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, 135 insertions, 19 deletions

diff --git a/src/Language/Fiddle/Ast.hs b/src/Language/Fiddle/Ast.hs
index 8352975..bb6605e 100644
--- a/src/Language/Fiddle/Ast.hs
+++ b/src/Language/Fiddle/Ast.hs
@@ -18,13 +18,79 @@ import Data.Typeable
 import GHC.Generics
 import GHC.TypeLits
 
--- The type of a number at each stage in compilation. Numbers should be parsed
--- in Stage2.
-type family NumberType (a :: Stage) where
+-- The Kind types should have for SyntaxTrees.
+--
+-- A synatx tree kind should take as parameters, an applicative functor for the
+-- first argument. This applicative functor allows errors and warnings to be
+-- contained to their deferred regions during compilation, so more errors may be
+-- reported an once.
+--
+-- The second argument is the annotation type. Every syntax tree element has an
+-- annotation. When initially parsing, this annotation is a list of comments
+-- that came before the element and the source position of the element.
+type SynTreeKind = (Type -> Type) -> Type -> Type
+
+-- The Type of number during each stage of compilation. When in the first stage,
+-- numbers are just strings like anything else. In later stages, numbers get
+-- parsed into actual integers. This makes it easier to process later.
+type family NumberType (a :: Stage) :: Type where
   NumberType Stage1 = Text
   NumberType Stage2 = Integer
   NumberType Stage3 = Integer
 
+-- The type that represents an import statement. In the early stages of
+-- compilation, this is just a string representing the import path, but in later
+-- stages of compilation, this actually gets replaced by an abstract
+-- representation of the imported material.
+type family ImportType (stage :: Stage) :: SynTreeKind where
+  ImportType Stage1 = ImportStatement
+  ImportType Stage2 = ImportStatement
+  ImportType Stage3 = ImportStatement
+
+-- [[packed, rust: name="field_name"]]
+data Directive f a where
+  Directive :: f (DirectiveBody f a) -> a -> Directive f a
+  deriving (Generic, Annotated, Alter, Typeable)
+
+data DirectiveBody f a where
+  DirectiveBody :: [DirectiveElement f a] -> a -> DirectiveBody f a
+  deriving (Generic, Annotated, Alter, Typeable)
+
+data DirectiveElement f a where
+  -- <key>
+  DirectiveElementKey ::
+    Maybe (Identifier f a) -> Identifier f a -> a -> DirectiveElement f a
+  -- (<backend>:)? <key>=<value>
+  DirectiveElementKeyValue ::
+    Maybe (Identifier f a) ->
+    Identifier f a ->
+    DirectiveExpression f a ->
+    a ->
+    DirectiveElement f a
+  deriving (Generic, Annotated, Alter, Typeable)
+
+data DirectiveExpression f a where
+  DirectiveString :: Text -> a -> DirectiveExpression f a
+  DirectiveNumber :: Text -> a -> DirectiveExpression f a
+  deriving (Generic, Annotated, Alter, Typeable)
+
+data Directed t f a where
+  Directed :: [Directive f a] -> t f a -> a -> Directed t f a
+  deriving (Generic, Annotated, Alter, Typeable)
+
+mapDirected :: (t f a -> t' f a) -> Directed t f a -> Directed t' f a
+mapDirected fn (Directed dr tfa a) = Directed dr (fn tfa) a
+
+mapDirectedM ::
+  (Monad m) => (t f a -> m (t' f a)) -> Directed t f a -> m (Directed t' f a)
+mapDirectedM fn (Directed dr tfa a) = Directed dr <$> fn tfa <*> pure a
+
+asDirected :: (Annotated t) => t f a -> Directed t f a
+asDirected tfa = Directed [] tfa (annot tfa)
+
+undirected :: Directed t f a -> t f a
+undirected (Directed _ tfa _) = tfa
+
 -- Stage of compilation. Parts of the AST maybe un unavailable with other stages
 -- as compilation simplifies the AST.
 data Stage = Stage1 | Stage2 | Stage3
@@ -32,8 +98,10 @@ data Stage = Stage1 | Stage2 | Stage3
 
 -- Root of the parse tree. Just contains a list of declarations.
 data FiddleUnit (stage :: Stage) (f :: Type -> Type) a where
-  FiddleUnit :: [FiddleDecl stage f a] -> a -> FiddleUnit stage f a
-  deriving (Generic, Annotated, Alter, Typeable)
+  FiddleUnit :: [Directed (FiddleDecl stage) f a] -> a -> FiddleUnit stage f a
+  deriving (Generic, Annotated, Typeable)
+
+deriving instance (Alter (ImportType stage)) => Alter (FiddleUnit stage)
 
 -- Just an identifier.
 data Identifier f a = Identifier !Text a
@@ -45,6 +113,24 @@ data Expression stage f a where
   LitNum :: NumberType stage -> a -> Expression stage f a
   Var :: Identifier f a -> a -> Expression stage f a
 
+-- Wrapper class because using a type family like "ImportType" means I cannot
+-- derive classes. I'd rather only derive for this class than have to derive for
+-- the whole PackageBody class.
+data ImportTypeWrapper stage f a where
+  ImportTypeWrapper :: ImportType stage f a -> ImportTypeWrapper stage f a
+
+instance (Alter (ImportType stage)) => Alter (ImportTypeWrapper stage) where
+  alter ffn fn (ImportTypeWrapper st) =
+    ImportTypeWrapper <$> alter ffn fn st
+
+data ImportStatement f a where
+  ImportStatement :: Text -> Maybe (ImportList f a) -> a -> ImportStatement f a
+  deriving (Generic, Annotated, Alter, Typeable)
+
+data ImportList f a where
+  ImportList :: [Identifier f a] -> a -> ImportList f a
+  deriving (Generic, Annotated, Alter, Typeable)
+
 -- Top-level declarations.
 data FiddleDecl (stage :: Stage) (f :: Type -> Type) a where
   {-
@@ -56,6 +142,10 @@ data FiddleDecl (stage :: Stage) (f :: Type -> Type) a where
     Identifier f a ->
     a ->
     FiddleDecl stage f a
+  ImportDecl ::
+    ImportType stage f a ->
+    a ->
+    FiddleDecl stage f a
   {- Package Statement. Package Name, Package body -}
   PackageDecl ::
     Identifier f a ->
@@ -87,10 +177,16 @@ data FiddleDecl (stage :: Stage) (f :: Type -> Type) a where
     ObjType stage f a ->
     a ->
     FiddleDecl stage f a
-  deriving (Generic, Annotated, Alter, Typeable)
+  deriving (Generic, Annotated, Typeable)
+
+deriving instance (Alter (ImportType stage)) => Alter (FiddleDecl stage)
 
 data ObjTypeBody (stage :: Stage) (f :: Type -> Type) a where
-  ObjTypeBody :: BodyType f a -> [ObjTypeDecl stage f a] -> a -> ObjTypeBody stage f a
+  ObjTypeBody ::
+    BodyType f a ->
+    [Directed (ObjTypeDecl stage) f a] ->
+    a ->
+    ObjTypeBody stage f a
   deriving (Generic, Annotated, Alter, Typeable)
 
 data ObjType stage f a where
@@ -139,7 +235,7 @@ data ModifierKeyword = Rw | Ro | Wo deriving (Eq, Ord, Show, Read, Typeable)
 
 data DeferredRegisterBody stage f a where
   DeferredRegisterBody ::
-    [RegisterBitsDecl stage f a] ->
+    [Directed (RegisterBitsDecl stage) f a] ->
     a ->
     DeferredRegisterBody stage f a
   deriving (Generic, Annotated, Alter, Typeable)
@@ -150,7 +246,11 @@ data BodyType (f :: Type -> Type) a where
   deriving (Generic, Annotated, Alter, Typeable)
 
 data RegisterBody stage f a where
-  RegisterBody :: BodyType f a -> f (DeferredRegisterBody stage f a) -> a -> RegisterBody stage f a
+  RegisterBody ::
+    BodyType f a ->
+    f (DeferredRegisterBody stage f a) ->
+    a ->
+    RegisterBody stage f a
   deriving (Generic, Annotated, Alter, Typeable)
 
 data RegisterBitsDecl stage f a where
@@ -207,7 +307,8 @@ instance Annotated (Expression stage) where
 
 instance Alter (ObjTypeDecl stage) where
   alter ffn fn = \case
-    (AssertPosStatement expr a) -> AssertPosStatement <$> alter ffn fn expr <*> fn a
+    (AssertPosStatement expr a) ->
+      AssertPosStatement <$> alter ffn fn expr <*> fn a
     (RegisterDecl mMod mIdent expr mBody a) ->
       RegisterDecl
         <$> mapM (alter ffn fn) mMod
@@ -285,20 +386,29 @@ data BitType (stage :: Stage) (f :: Type -> Type) a where
 
 data EnumBody (stage :: Stage) (f :: Type -> Type) a where
   -- <decl>,
-  EnumBody :: [EnumConstantDecl stage f a] -> a -> EnumBody stage f a
+  EnumBody :: [Directed (EnumConstantDecl stage) f a] -> a -> EnumBody stage f a
   deriving (Generic, Annotated, Alter, Typeable)
 
 data EnumConstantDecl stage f a where
   -- <ident> = <expr>
-  EnumConstantDecl :: Identifier f a -> Expression stage f a -> a -> EnumConstantDecl stage f a
+  EnumConstantDecl ::
+    Identifier f a ->
+    Expression stage f a ->
+    a ->
+    EnumConstantDecl stage f a
   -- reserved = <expr>
-  EnumConstantReserved :: Expression stage f a -> a -> EnumConstantDecl stage f a
+  EnumConstantReserved ::
+    Expression stage f a ->
+    a ->
+    EnumConstantDecl stage f a
   deriving (Generic, Annotated, Alter, Typeable)
 
 data PackageBody (stage :: Stage) (f :: Type -> Type) a where
   {- The body of a package -}
-  PackageBody :: [FiddleDecl stage f a] -> a -> PackageBody stage f a
-  deriving (Generic, Annotated, Alter, Typeable)
+  PackageBody :: [Directed (FiddleDecl stage) f a] -> a -> PackageBody stage f a
+  deriving (Generic, Annotated, Typeable)
+
+deriving instance (Alter (ImportType stage)) => Alter (PackageBody stage)
 
 -- instance Alter (Modifier stage) where
 --   alter _ fn (ModifierKeyword m a) = ModifierKeyword m (fn a)
@@ -315,7 +425,7 @@ data PackageBody (stage :: Stage) (f :: Type -> Type) a where
 proxyOf :: t f a -> Proxy t
 proxyOf _ = Proxy
 
-class Annotated (t :: (Type -> Type) -> Type -> Type) where
+class Annotated (t :: SynTreeKind) where
   annot :: t f a -> a
   default annot :: (Generic (t f a), GAnnot a (Rep (t f a))) => t f a -> a
   annot t = gannot (from t)
@@ -336,7 +446,7 @@ instance (GAnnot a r, GAnnot a l) => GAnnot a (l :+: r) where
 instance (GAnnot a r) => GAnnot a (M1 i c r) where
   gannot (M1 a) = gannot a
 
-class Alter (t :: (Type -> Type) -> Type -> Type) where
+class Alter (t :: SynTreeKind) where
   alter ::
     forall f1 f2 a1 a2 m.
     (Monad m, Traversable f1) =>
@@ -384,13 +494,19 @@ instance GAlter t f1 f2 a1 a2 (Rec0 u1) (Rec0 u1) where
   galter _ _ _ = return
 
 {- Recursive case. Call alter on sub-structures. -}
-instance (Alter u) => GAlter t f1 f2 a1 a2 (Rec0 (u f1 a1)) (Rec0 (u f2 a2)) where
+instance
+  (Alter u) =>
+  GAlter t f1 f2 a1 a2 (Rec0 (u f1 a1)) (Rec0 (u f2 a2))
+  where
   galter _ ffn fn k1 =
     K1 <$> alter ffn fn (unK1 k1)
 
 {- Recursive case. Called when there are list of substructures that need to be
     recused. -}
-instance (Alter u, Traversable l) => GAlter t f1 f2 a1 a2 (Rec0 (l (u f1 a1))) (Rec0 (l (u f2 a2))) where
+instance
+  (Alter u, Traversable l) =>
+  GAlter t f1 f2 a1 a2 (Rec0 (l (u f1 a1))) (Rec0 (l (u f2 a2)))
+  where
   galter _ ffn fn k1 =
     K1 <$> mapM (alter ffn fn) (unK1 k1)