More major changes to the grammer.

Added annotation sublanguage for defining compiler directives. Also
added the syntax for import statements. Imports are not implemented, but
I'm currently working on that.

1 files changed, 81 insertions, 8 deletions

diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs
index 7eed0f2..f3ad744 100644
--- a/src/Language/Fiddle/Parser.hs
+++ b/src/Language/Fiddle/Parser.hs
@@ -7,6 +7,7 @@ module Language.Fiddle.Parser
   )
 where
 
+import Control.Monad (void)
 import Data.Functor.Identity
 import Data.Kind (Type)
 import Data.Text (Text)
@@ -50,25 +51,89 @@ isComment (Token t _) =
 stripTrailingComments :: [Token s] -> [Token s]
 stripTrailingComments = reverse . dropWhile isComment . reverse
 
+directed :: Pa t -> PaS (Directed (t 'Stage1))
+directed subparser = withMeta $ do
+  Directed <$> many directive <*> subparser
+
+directive :: PaS Directive
+directive =
+  withMeta $
+    Directive <$> defer directiveBodyTokens directiveBody
+
+directiveBody :: PaS DirectiveBody
+directiveBody = withMeta $ do
+  DirectiveBody <$> many (directiveElement <* (void (tok TokComma) <|> eof))
+
+directiveElement :: PaS DirectiveElement
+directiveElement = withMeta $ do
+  identifier1 <- nextText
+  choice
+    [ do
+        tok TokColon
+        let backend = identifier1
+        key <- nextText
+        choice
+          [ do
+              tok TokEq
+              DirectiveElementKeyValue (Just backend) key <$> directiveExpression,
+            do
+              return (DirectiveElementKey (Just backend) key)
+          ],
+      do
+        tok TokEq
+        let key = identifier1
+        DirectiveElementKeyValue Nothing key <$> directiveExpression,
+      return $ DirectiveElementKey Nothing identifier1
+    ]
+
+nextText :: PaS Identifier
+nextText = withMeta $ Identifier <$> token textOf
+
+directiveExpression :: PaS DirectiveExpression
+directiveExpression = withMeta $ do
+  choice
+    [ do
+        token $ \case
+          (TokString str) -> Just $ DirectiveString str
+          (TokLitNum num) -> Just $ DirectiveNumber num
+          _ -> Nothing
+    ]
+
 fiddleUnit :: Pa FiddleUnit
 fiddleUnit = do
   withMeta
-    ( FiddleUnit <$> many1 (fiddleDecl <* tok TokSemi)
+    ( FiddleUnit <$> many1 (directed fiddleDecl <* tok TokSemi)
     )
     <* many comment
 
+stringToken :: P Text
+stringToken = token (\case
+  (TokString str) -> Just str
+  _ -> Nothing)
+
+importList :: PaS ImportList
+importList = withMeta $ do
+  tok TokLParen
+  ImportList <$> many (ident <* (tok TokComma <|> lookAhead (tok TokRParen)))
+   <* tok TokRParen
+
+importStatement :: PaS ImportStatement
+importStatement = withMeta $
+  ImportStatement <$> stringToken <*> optionMaybe importList
+
 fiddleDecl :: Pa FiddleDecl
 fiddleDecl = do
   withMeta $ do
     t <- tokenType <$> anyToken
     case t of
-      KWOption -> OptionDecl <$> ident <*> ident
+      KWOption -> OptionDecl <$> nextText <*> nextText
       KWPackage ->
         PackageDecl
           <$> ident
           <*> defer body packageBody
       KWLocation -> LocationDecl <$> ident <*> (tok TokEq >> expression)
       KWBits -> BitsDecl <$> ident <*> (tok TokColon >> bitType)
+      KWImport -> ImportDecl <$> importStatement
       KWType ->
         ObjTypeDecl
           <$> ident
@@ -132,7 +197,7 @@ exprInParen = tok TokLParen *> expression <* tok TokRParen
 objTypeBody :: BodyType F (Commented SourceSpan) -> Pa ObjTypeBody
 objTypeBody bt =
   withMeta $
-    ObjTypeBody bt <$> many (objTypeDecl <* tok TokSemi)
+    ObjTypeBody bt <$> many (directed objTypeDecl <* tok TokSemi)
 
 objTypeDecl :: Pa ObjTypeDecl
 objTypeDecl =
@@ -185,7 +250,7 @@ registerBody = withMeta $ RegisterBody <$> bitBodyType <*> defer body deferredRe
 deferredRegisterBody :: Pa DeferredRegisterBody
 deferredRegisterBody =
   withMeta $
-    DeferredRegisterBody <$> many (registerBitsDecl <* tok TokSemi)
+    DeferredRegisterBody <$> many (directed registerBitsDecl <* tok TokSemi)
 
 registerBitsDecl :: Pa RegisterBitsDecl
 registerBitsDecl =
@@ -239,7 +304,7 @@ bitType = withMeta $ rawBits <|> enumType
 enumBody :: Pa EnumBody
 enumBody =
   withMeta $
-    EnumBody <$> many (enumConstantDecl <* tok TokComma)
+    EnumBody <$> many (directed enumConstantDecl <* tok TokComma)
 
 enumConstantDecl :: Pa EnumConstantDecl
 enumConstantDecl =
@@ -260,6 +325,13 @@ body = do
   (_, b, _) <- body'
   return b
 
+directiveBodyTokens :: P [Token SourceSpan]
+directiveBodyTokens = do
+  tokKeepComment TokDirectiveStart
+  ret <- concat <$> manyTill ((: []) <$> anyToken) (lookAhead $ tokKeepComment TokDirectiveEnd)
+  tokKeepComment TokDirectiveEnd
+  return ret
+
 body' :: P (Token SourceSpan, [Token SourceSpan], Token SourceSpan)
 body' = do
   l <- tokKeepComment TokLBrace
@@ -299,9 +371,10 @@ packageBody =
   withMeta $
     PackageBody
       <$> many
-        ( fiddleDecl
-            <* ( tok TokSemi <|> fail "Expected ';'"
-               )
+        ( directed $
+            fiddleDecl
+              <* ( tok TokSemi <|> fail "Expected ';'"
+                 )
         )
 
 printNext :: P ()