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.

2 files changed, 30 insertions, 24 deletions

diff --git a/src/Language/Fiddle/Compiler/Stage1.hs b/src/Language/Fiddle/Compiler/Stage1.hs
index 25ee66b..2e3acbc 100644
--- a/src/Language/Fiddle/Compiler/Stage1.hs
+++ b/src/Language/Fiddle/Compiler/Stage1.hs
@@ -68,7 +68,7 @@ toStage2 (FiddleUnit decls annot) = do
       FiddleUnit <$> reconfigureFiddleDecls (Path []) decls <*> pure annot
   return a
 
-reconfigureFiddleDecls :: Path -> [FiddleDecl Stage1 I Annot] -> M Annot [FiddleDecl Stage2 I Annot]
+reconfigureFiddleDecls :: Path -> [Directed (FiddleDecl Stage1) I Annot] -> M Annot [Directed (FiddleDecl Stage2) I Annot]
 reconfigureFiddleDecls p decls = do
   -- (Stage2CompilerState anonymousObjTypes anonymousBitsTypes, decls) <- pushState $ do
   --   put (Stage2CompilerState [] [])
@@ -76,13 +76,13 @@ reconfigureFiddleDecls p decls = do
 
   lastState <- get
   put (Stage2CompilerState [] [])
-  decls <- mapM (fiddleDeclToStage2 p) decls
+  decls <- mapM (mapDirectedM $ fiddleDeclToStage2 p) decls
   (Stage2CompilerState anonymousObjTypes anonymousBitsTypes) <- get
   put lastState
 
   return $
-    map resolveAnonymousObjType anonymousObjTypes
-      ++ map resolveAnonymousBitsType anonymousBitsTypes
+    map (asDirected . resolveAnonymousObjType) anonymousObjTypes
+      ++ map (asDirected . resolveAnonymousBitsType) anonymousBitsTypes
       ++ decls
   where
     resolveAnonymousObjType (Linkage linkage, objTypeBody) =
@@ -104,6 +104,7 @@ fiddleDeclToStage2 path decl = do
     (LocationDecl i expr a) -> LocationDecl i <$> toStage2Expr expr <*> pure a
     (BitsDecl i typ a) -> BitsDecl i <$> bitsTypeToStage2 (pushId i path) typ <*> pure a
     (ObjTypeDecl i body a) -> ObjTypeDecl i <$> mapM (objTypeBodyToStage2 (pushId i path)) body <*> pure a
+    (ImportDecl importStatement a) -> return $ ImportDecl importStatement a
     (ObjectDecl i expr typ a) ->
       ObjectDecl i <$> toStage2Expr expr <*> objectTypeToStage2 (pushId i path) typ <*> pure a
 
@@ -115,7 +116,7 @@ bitsTypeToStage2 path = \case
 
 enumBodyToStage2 :: Path -> EnumBody Stage1 I Annot -> M Annot (EnumBody Stage2 I Annot)
 enumBodyToStage2 path = \case
-  EnumBody constants a -> EnumBody <$> mapM (enumConstantToStage2 path) constants <*> pure a
+  EnumBody constants a -> EnumBody <$> mapM (mapDirectedM (enumConstantToStage2 path)) constants <*> pure a
 
 enumConstantToStage2 :: Path -> EnumConstantDecl Stage1 I Annot -> M Annot (EnumConstantDecl Stage2 I Annot)
 enumConstantToStage2 path = \case
@@ -124,7 +125,7 @@ enumConstantToStage2 path = \case
 
 objTypeBodyToStage2 :: Path -> ObjTypeBody Stage1 I Annot -> M Annot (ObjTypeBody Stage2 I Annot)
 objTypeBodyToStage2 path (ObjTypeBody bodyType decls annot) =
-  ObjTypeBody bodyType <$> mapM (objTypeDeclToStage2 path) decls <*> pure annot
+  ObjTypeBody bodyType <$> mapM (mapDirectedM $ objTypeDeclToStage2 path) decls <*> pure annot
 
 objTypeDeclToStage2 :: Path -> ObjTypeDecl Stage1 I Annot -> M Annot (ObjTypeDecl Stage2 I Annot)
 objTypeDeclToStage2 path = \case
@@ -150,7 +151,7 @@ registerBodyToStage2 :: Path -> RegisterBody Stage1 I Annot -> M Annot (Register
 registerBodyToStage2 path (RegisterBody bodyType (Identity (DeferredRegisterBody registerBitsDecl a1)) a2) =
   RegisterBody bodyType . Identity
     <$> ( DeferredRegisterBody
-            <$> mapM (registerBitsDeclToStage2 path) registerBitsDecl
+            <$> mapM (mapDirectedM $ registerBitsDeclToStage2 path) registerBitsDecl
             <*> pure a1
         )
     <*> pure a2
diff --git a/src/Language/Fiddle/Compiler/Stage2.hs b/src/Language/Fiddle/Compiler/Stage2.hs
index 727f153..431fc76 100644
--- a/src/Language/Fiddle/Compiler/Stage2.hs
+++ b/src/Language/Fiddle/Compiler/Stage2.hs
@@ -72,7 +72,7 @@ toStage3 (FiddleUnit decls a) =
   snd
     <$> subCompile
       emptyState
-      ( FiddleUnit <$> mapM fiddleDeclToStage3 decls <*> pure a
+      ( FiddleUnit <$> mapM (mapDirectedM fiddleDeclToStage3) decls <*> pure a
       )
 
 exprToSize ::
@@ -94,7 +94,7 @@ getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do
   when (declaredSize <= 4) $ do
     imap <-
       foldlM
-        ( \imap enumConst -> do
+        ( \imap (undirected -> enumConst) -> do
             number <- case enumConst of
               EnumConstantDecl _ expr _ -> exprToSize expr
               EnumConstantReserved expr _ -> exprToSize expr
@@ -137,6 +137,7 @@ fiddleDeclToStage3 = \case
     BitsDecl id <$> bitTypeToStage3 typ <*> pure a
   ObjTypeDecl ident body a ->
     ObjTypeDecl ident <$> mapM (\bt -> fst <$> objTypeBodyToStage3 bt 0) body <*> pure a
+  ImportDecl importStatement a -> return $ ImportDecl importStatement a
   ObjectDecl ident expr typ a ->
     ObjectDecl ident (expressionToStage3 expr) <$> objTypeToStage3 typ <*> pure a
 
@@ -162,10 +163,10 @@ registerBodyToStage3 (RegisterBody bodyType (Identity deferredRegisterBody) a')
       (cur, returned) <-
         foldlM
           ( \(cursor, returned) decl ->
-              case decl of
+              case undirected decl of
                 ReservedBits expr a -> do
                   size <- fromIntegral <$> exprToSize expr
-                  let s3 = ReservedBits (expressionToStage3 expr) a
+                  let s3 = mapDirected (const $ ReservedBits (expressionToStage3 expr) a) decl
                   if isUnion
                     then checkUnion cursor size (s3 : returned) a
                     else
@@ -174,7 +175,7 @@ registerBodyToStage3 (RegisterBody bodyType (Identity deferredRegisterBody) a')
                   checkBitsSubStructure registerBody maybeIdent annot
 
                   (newBody, subsize) <- registerBodyToStage3 registerBody
-                  let s3 = BitsSubStructure newBody maybeIdent annot
+                  let s3 = mapDirected (const $ BitsSubStructure newBody maybeIdent annot) decl
 
                   if isUnion
                     then checkUnion cursor subsize (s3 : returned) a
@@ -182,7 +183,7 @@ registerBodyToStage3 (RegisterBody bodyType (Identity deferredRegisterBody) a')
                       return (cursor + subsize, s3 : returned)
                 DefinedBits modifier identifier typeref a -> do
                   (s3TypeRef, size) <- registerBitsTypeRefToStage3 typeref
-                  let s3 = DefinedBits modifier identifier s3TypeRef a
+                  let s3 = mapDirected (const $ DefinedBits modifier identifier s3TypeRef a) decl
 
                   if isUnion
                     then checkUnion cursor size (s3 : returned) a
@@ -265,18 +266,22 @@ objTypeBodyToStage3 (ObjTypeBody bodyType decls a) startOff = do
   (cur, returned) <-
     foldlM
       ( \(cursor, returned) decl ->
-          case decl of
+          case undirected decl of
             RegisterDecl mMod mIdent expr mBody a -> do
               (s3RegisterBody, mCalculatedSize) <-
                 fUnzip <$> mapM registerBodyToStage3 mBody
 
               let s3 =
-                    RegisterDecl
-                      mMod
-                      mIdent
-                      (expressionToStage3 expr)
-                      s3RegisterBody
-                      a
+                    mapDirected
+                      ( const $
+                          RegisterDecl
+                            mMod
+                            mIdent
+                            (expressionToStage3 expr)
+                            s3RegisterBody
+                            a
+                      )
+                      decl
 
               declaredSizeBits <- fromIntegral <$> exprToSize expr
 
@@ -320,7 +325,7 @@ objTypeBodyToStage3 (ObjTypeBody bodyType decls a) startOff = do
                   subBody
                   ( if isUnion then startOff else cursor
                   )
-              let s3 = TypeSubStructure (Identity newBody) maybeIdent annot
+              let s3 = mapDirected (const $ TypeSubStructure (Identity newBody) maybeIdent annot) decl
 
               checkTypesSubStructure subBody maybeIdent annot
               if isUnion
@@ -338,7 +343,7 @@ objTypeBodyToStage3 (ObjTypeBody bodyType decls a) startOff = do
                       (unCommented a)
                   ]
               let size = size' `div` 8
-              let s3 = ReservedDecl (expressionToStage3 expr) annot
+              let s3 = mapDirected (const $ ReservedDecl (expressionToStage3 expr) annot) decl
               if isUnion
                 then
                   checkUnion cursor size (s3 : returned) a
@@ -406,7 +411,7 @@ bitTypeToStage3 (EnumBitType expr body a) =
 
 enumBodyToStage3 :: EnumBody Stage2 I Annot -> Compile Stage3State (EnumBody Stage3 I Annot)
 enumBodyToStage3 (EnumBody constants a) =
-  EnumBody <$> mapM enumConstantDeclToStage3 constants <*> pure a
+  EnumBody <$> mapM (mapDirectedM enumConstantDeclToStage3) constants <*> pure a
 
 enumConstantDeclToStage3 :: EnumConstantDecl Stage2 I Annot -> Compile Stage3State (EnumConstantDecl Stage3 I Annot)
 enumConstantDeclToStage3 = \case
@@ -415,4 +420,4 @@ enumConstantDeclToStage3 = \case
 
 packageBodyToStage3 :: PackageBody Stage2 I Annot -> Compile Stage3State (PackageBody Stage3 I Annot)
 packageBodyToStage3 (PackageBody decls a) =
-  PackageBody <$> mapM fiddleDeclToStage3 decls <*> pure a
+  PackageBody <$> mapM (mapDirectedM fiddleDeclToStage3) decls <*> pure a