summaryrefslogtreecommitdiff
path: root/src/Language/Fiddle/Ast
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/Fiddle/Ast')
-rw-r--r--src/Language/Fiddle/Ast/FileInterface.hs33
-rw-r--r--src/Language/Fiddle/Ast/Internal/Generic.hs5
-rw-r--r--src/Language/Fiddle/Ast/Internal/Instances.hs228
-rw-r--r--src/Language/Fiddle/Ast/Internal/Kinds.hs25
-rw-r--r--src/Language/Fiddle/Ast/Internal/Stage.hs43
-rw-r--r--src/Language/Fiddle/Ast/Internal/SyntaxTree.hs537
-rw-r--r--src/Language/Fiddle/Ast/Internal/SyntaxTreeKinds.hs1
7 files changed, 872 insertions, 0 deletions
diff --git a/src/Language/Fiddle/Ast/FileInterface.hs b/src/Language/Fiddle/Ast/FileInterface.hs
new file mode 100644
index 0000000..d29fc9d
--- /dev/null
+++ b/src/Language/Fiddle/Ast/FileInterface.hs
@@ -0,0 +1,33 @@
+module Language.Fiddle.Ast.FileInterface where
+
+-- Definitions for file interfaces. These interfaces contain an abstract
+-- representation of the symbols and information exported by a fiddle file.
+-- These interfaces are also serializable, and when compiling a fiddle file, all
+-- the import statements should supply an fdi (fiddle interface) file to speed
+-- up subsequent compilations.
+
+-- import Data.Text
+--
+-- data ObjectType = ObjectType
+-- { objectTypeSize :: Word32
+-- }
+--
+-- data Metatype
+-- = Object
+-- { objectLocation :: Word64,
+-- objectType :: Text
+-- }
+-- | Type
+-- { typeSizeBytes :: Word32
+-- }
+--
+-- data Element a = Element
+-- { elementFullyQualifiedSymbol :: Text,
+-- elementDocumentation :: Maybe Text,
+-- elementMetatype :: Metatype,
+-- elementAnnotation :: a
+-- }
+--
+-- data FileInterface a = FiddleInterface
+-- { exportedElements :: [Element a]
+-- }
diff --git a/src/Language/Fiddle/Ast/Internal/Generic.hs b/src/Language/Fiddle/Ast/Internal/Generic.hs
new file mode 100644
index 0000000..cb075cc
--- /dev/null
+++ b/src/Language/Fiddle/Ast/Internal/Generic.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeOperators #-}
+module Language.Fiddle.Ast.Internal.Generic where
+
+import GHC.Generics
+import GHC.TypeError as TypeError
diff --git a/src/Language/Fiddle/Ast/Internal/Instances.hs b/src/Language/Fiddle/Ast/Internal/Instances.hs
new file mode 100644
index 0000000..c8c606c
--- /dev/null
+++ b/src/Language/Fiddle/Ast/Internal/Instances.hs
@@ -0,0 +1,228 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE IncoherentInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Language.Fiddle.Ast.Internal.Instances where
+
+import Data.Functor.Identity
+import Data.Kind (Type)
+import Data.Typeable
+import GHC.Generics
+import GHC.TypeError as TypeError
+import Language.Fiddle.Ast.Internal.Kinds
+import Language.Fiddle.Ast.Internal.Stage
+
+-- Type class to easily switch between stages if there is no difference in the
+-- syntax tree structure between these stages. Can make things much cleaner and
+-- avoids the boilerplate and bugprone-ness of needing to rote copy everything.
+class
+ (Functor f) =>
+ EasySwitchStage
+ (t :: Stage -> SynTree)
+ (f :: Type -> Type)
+ (fromStage :: Stage)
+ (toStage :: Stage)
+ where
+ switchStage :: t fromStage f a -> t toStage f a
+ default switchStage ::
+ ( Generic (t fromStage f a),
+ Generic (t toStage f a),
+ GEasySwitchStage (Rep (t fromStage f a)) (Rep (t toStage f a))
+ ) =>
+ t fromStage f a ->
+ t toStage f a
+ switchStage t = to $ gSwitchStage (from t)
+
+-- Class for walking a syntax tree under the context of a monad and modifying
+-- the different parts of the SynTree type..
+class Alter (t :: SynTree) where
+ alter ::
+ forall f1 f2 a1 a2 m.
+ (Monad m, Traversable f1) =>
+ (forall z. f1 z -> m (f2 z)) ->
+ (a1 -> m a2) ->
+ t f1 a1 ->
+ m (t f2 a2)
+ default alter ::
+ forall f1 f2 a1 a2 m.
+ ( Generic (t f1 a1),
+ Generic (t f2 a2),
+ Traversable f1,
+ GAlter t f1 f2 a1 a2 (Rep (t f1 a1)) (Rep (t f2 a2)),
+ Monad m
+ ) =>
+ ( forall z.
+ f1 z ->
+ m (f2 z)
+ ) ->
+ (a1 -> m a2) ->
+ t f1 a1 ->
+ m (t f2 a2)
+ alter ffn fn t = to <$> galter (proxyOf t) ffn fn (from t)
+
+-- A syntax tree object is annotated if it has an annotation 'a' as the last
+-- element.
+class Annotated (t :: SynTree) 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)
+
+-- Generic implementations of common typeclass for SyntaxTrees.
+--
+-- This is where we try to hide the pig behind the curtain.
+--
+--
+-- ---------------------------------------------------------------
+--
+--
+--
+class GAlter t f1 f2 a1 a2 r1 r2 where
+ galter ::
+ forall proxy x m.
+ (Monad m, Traversable f1) =>
+ proxy t ->
+ (forall z. f1 z -> m (f2 z)) ->
+ (a1 -> m a2) ->
+ r1 x ->
+ m (r2 x)
+
+{- Altering a record with type a1 will apply the mapping function and produce a
+ record with type a2 -}
+instance GAlter t f1 f2 a1 a2 (Rec0 a1) (Rec0 a2) where
+ galter _ _ fn k1 = K1 <$> fn (unK1 k1)
+
+{- Base-Case. Altering unrelated leaf types will do nothing. -}
+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
+ 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
+ galter _ ffn fn k1 =
+ K1 <$> mapM (alter ffn fn) (unK1 k1)
+
+-- instance GAlter t f1 f2 a1 a2 (Rec0 (f1 z)) (Rec0 (f2 z)) where
+-- galter _ ffn _ k1 = K1 <$> ffn (unK1 k1)
+
+{- Generic altering. Descends into the function and alters whatever is inside
+ the functor and then transforms the functor using the ffn function. -}
+instance
+ (Traversable f1, Alter u) =>
+ GAlter t f1 f2 a1 a2 (Rec0 (f1 (u f1 a1))) (Rec0 (f2 (u f2 a2)))
+ where
+ galter proxy ffn fn k1 = do
+ newK <- mapM (alter ffn fn) (unK1 k1)
+ K1 <$> ffn newK
+
+instance
+ ( GAlter t f1 f2 a1 a2 l1 l2,
+ GAlter t f1 f2 a1 a2 r1 r2
+ ) =>
+ GAlter t f1 f2 a1 a2 (l1 :*: r1) (l2 :*: r2)
+ where
+ galter proxy ffn fn (a :*: b) = do
+ a' <- galter proxy ffn fn a
+ b' <- galter proxy ffn fn b
+ return (a' :*: b')
+
+instance
+ ( GAlter t f1 f2 a1 a2 l1 l2,
+ GAlter t f1 f2 a1 a2 r1 r2
+ ) =>
+ GAlter t f1 f2 a1 a2 (l1 :+: r1) (l2 :+: r2)
+ where
+ galter proxy ffn fn (R1 r) = R1 <$> galter proxy ffn fn r
+ galter proxy ffn fn (L1 l) = L1 <$> galter proxy ffn fn l
+
+instance
+ (GAlter t f1 f2 a1 a2 r1 r2) =>
+ GAlter t f1 f2 a1 a2 (M1 i c r1) (M1 i c r2)
+ where
+ galter proxy ffn fn (M1 a) = M1 <$> galter proxy ffn fn a
+
+class GAnnot a r where
+ gannot :: r x -> a
+
+instance GAnnot a (Rec0 a) where
+ gannot = unK1
+
+instance (GAnnot a r) => GAnnot a (l :*: r) where
+ gannot (_ :*: r) = gannot r
+
+instance (GAnnot a r, GAnnot a l) => GAnnot a (l :+: r) where
+ gannot (R1 r) = gannot r
+ gannot (L1 l) = gannot l
+
+instance (GAnnot a r) => GAnnot a (M1 i c r) where
+ gannot (M1 a) = gannot a
+
+instance
+ (GEasySwitchStage s1 s2) =>
+ GEasySwitchStage (M1 i c s1) (M1 i c s2)
+ where
+ gSwitchStage (M1 a) = M1 (gSwitchStage a)
+
+instance
+ (GEasySwitchStage l1 l2, GEasySwitchStage r1 r2) =>
+ GEasySwitchStage (l1 :+: r1) (l2 :+: r2)
+ where
+ gSwitchStage (R1 r) = R1 $ gSwitchStage r
+ gSwitchStage (L1 l) = L1 $ gSwitchStage l
+
+instance
+ (GEasySwitchStage l1 l2, GEasySwitchStage r1 r2) =>
+ (GEasySwitchStage (l1 :*: r1) (l2 :*: r2))
+ where
+ gSwitchStage (l :*: r) = gSwitchStage l :*: gSwitchStage r
+
+instance
+ (EasySwitchStage t f fs ts) =>
+ (GEasySwitchStage (Rec0 (t fs f a)) (Rec0 (t ts f a)))
+ where
+ gSwitchStage (K1 val) = K1 (switchStage val)
+
+instance
+ ( EasySwitchStage t f fs ts,
+ Functor func
+ ) =>
+ (GEasySwitchStage (Rec0 (func (t fs f a))) (Rec0 (func (t ts f a))))
+ where
+ gSwitchStage (K1 val) = K1 (switchStage <$> val)
+
+instance (GEasySwitchStage (Rec0 a) (Rec0 a)) where
+ gSwitchStage = id
+
+instance
+ ( TypeError
+ ( TypeError.Text "Unable to match type "
+ :<>: TypeError.ShowType a
+ :<>: TypeError.Text " with "
+ :<>: TypeError.ShowType b
+ )
+ ) =>
+ (GEasySwitchStage (Rec0 a) (Rec0 b))
+ where
+ gSwitchStage = error "Cannot be called"
+
+class GEasySwitchStage r1 r2 where
+ gSwitchStage :: r1 x -> r2 x
+
+proxyOf :: t f a -> Proxy t
+proxyOf _ = Proxy
+
+instance (Alter t, Traversable f) => Functor (t f) where
+ fmap f t = runIdentity (alter return (return . f) t)
diff --git a/src/Language/Fiddle/Ast/Internal/Kinds.hs b/src/Language/Fiddle/Ast/Internal/Kinds.hs
new file mode 100644
index 0000000..1368c84
--- /dev/null
+++ b/src/Language/Fiddle/Ast/Internal/Kinds.hs
@@ -0,0 +1,25 @@
+
+module Language.Fiddle.Ast.Internal.Kinds where
+
+import Data.Kind (Type)
+import Language.Fiddle.Ast.Internal.Stage
+
+-- 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.
+--
+-- SynTree types are not dependent on the compilation stage. They're the same
+-- regardless of the compilation stage.
+type SynTree = (Type -> Type) -> Type -> Type
+
+-- A syntax tree which is dependent on the stage in compilation. As compilations
+-- progress through stages, types in the syntax tree may change as things become
+-- more and more machine readable.
+type StagedSynTree = Stage -> SynTree
diff --git a/src/Language/Fiddle/Ast/Internal/Stage.hs b/src/Language/Fiddle/Ast/Internal/Stage.hs
new file mode 100644
index 0000000..cfcd0e6
--- /dev/null
+++ b/src/Language/Fiddle/Ast/Internal/Stage.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE IncoherentInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Language.Fiddle.Ast.Internal.Stage where
+
+import Data.Type.Bool
+import Data.Type.Equality
+import Data.Typeable
+import qualified GHC.TypeError as TypeError
+import GHC.TypeLits
+
+-- Stage of compilation. Parts of the AST maybe un unavailable with other stages
+-- as compilation simplifies the AST.
+data Stage = Stage1 | Stage2 | Stage3
+ deriving (Typeable)
+
+-- Returns the stage before the given stage.
+type family PreviousStage (s :: Stage) :: Stage where
+ PreviousStage Stage1 = TypeError (TypeError.Text "No Prior stage to Stage1")
+ PreviousStage s = NumberToStage (StageToNumber s - 1)
+
+-- Returns the stage after the give stage.
+type family NextStage (s :: Stage) :: Stage where
+ NextStage s = NumberToStage (StageToNumber s + 1)
+
+-- Converts a stage to a number.
+type family StageToNumber (s :: Stage) :: Natural where
+ StageToNumber Stage1 = 1
+ StageToNumber Stage2 = 2
+ StageToNumber Stage3 = 3
+
+-- Converts a number to a stage.
+type family NumberToStage (n :: Natural) :: Stage where
+ NumberToStage 1 = Stage1
+ NumberToStage 2 = Stage2
+ NumberToStage 3 = Stage3
+ NumberToStage n = TypeError (TypeError.Text "Number in NumberToStage.")
+
+-- Type-level constraint to determine if a stage is less than some natural
+-- ordinal. Used to bound parts of the AST in multiple stages.
+type StageLessThan stage (n :: Natural) = (CmpNat (StageToNumber stage) n == LT)
diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
new file mode 100644
index 0000000..48852ee
--- /dev/null
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs
@@ -0,0 +1,537 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE IncoherentInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Language.Fiddle.Ast.Internal.SyntaxTree
+ ( -- Type Families
+ NumberType,
+ ImportType,
+ -- Witness Types
+ Witness (..),
+ WitnessType,
+ -- AST Types
+ Name (..),
+ Directive (..),
+ DirectiveBody (..),
+ DirectiveElement (..),
+ DirectiveExpression (..),
+ Directed (..),
+ FiddleUnit (..),
+ Identifier (..),
+ Expression (..),
+ ImportStatement (..),
+ ImportList (..),
+ FiddleDecl (..),
+ ObjTypeBody (..),
+ ObjType (..),
+ ObjTypeDecl (..),
+ Modifier (..),
+ ModifierKeyword (..),
+ DeferredRegisterBody (..),
+ BodyType (..),
+ RegisterBody (..),
+ RegisterBitsDecl (..),
+ RegisterBitsTypeRef (..),
+ AnonymousBitsType (..),
+ BitType (..),
+ EnumBody (..),
+ EnumConstantDecl (..),
+ PackageBody (..),
+ -- Helper Functions
+ mapDirected,
+ mapDirectedM,
+ asDirected,
+ undirected,
+ -- Utility Functions
+ squeeze,
+ )
+where
+
+import Data.Coerce
+import Data.Functor.Identity
+import Data.Kind (Type)
+import Data.List.NonEmpty
+import Data.Proxy
+import Data.Text (Text)
+import Data.Traversable
+import Data.Type.Bool
+import Data.Type.Equality
+import Data.Typeable
+import Data.Void (Void, absurd)
+import GHC.Generics
+import GHC.TypeLits
+import Language.Fiddle.Ast.Internal.Generic
+import Language.Fiddle.Ast.Internal.Instances
+import Language.Fiddle.Ast.Internal.Kinds
+import Language.Fiddle.Ast.Internal.Stage
+
+-- 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 s = NumberType (PreviousStage s)
+
+-- 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) :: SynTree where
+ ImportType Stage1 = ImportStatement
+ ImportType Stage2 = ImportStatement
+ ImportType Stage3 = ImportStatement
+
+-- A way to disable or enable a subtree type based on a type-level boolean.
+--
+-- This is used over GADT's specific parameterization to allow for deriving
+-- generics and reduce boilerplate.
+--
+-- This is a wrapper type to allow defining instances.
+data Witness (s :: Bool) where
+ Witness :: (WitnessType s) -> Witness s
+
+-- | If the type level expression is true, the witness type is the Unit type, if
+-- it is false, the witness type is Void, thus making whatever it touches
+-- uninhabitable. This is how parts of the AST is enabled or disabled during
+-- compilation.
+type family WitnessType (s :: Bool) where
+ WitnessType True = ()
+ WitnessType False = Void
+
+-- A Name is multiple identifiers separated by dots. It's the way of namespaces
+-- to different packages.
+data Name :: SynTree where
+ Name :: NonEmpty (Identifier f a) -> a -> Name f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+-- Syntax tree fo the directive sublanguage. Directives can be on many elements
+-- and provide the compiler with additional information about the emitted code.
+--
+-- The directive subtree by design does not depend on the compilation stage.
+-- This is because the directive sublanguage should pass directly to the backend
+-- compilation stage.
+data Directive :: SynTree where
+ Directive :: f (DirectiveBody f a) -> a -> Directive f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+-- A directive body has multiple directive elements.
+data DirectiveBody :: SynTree where
+ DirectiveBody :: [DirectiveElement f a] -> a -> DirectiveBody f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+-- Element in the directive.
+data DirectiveElement :: SynTree where
+ -- A directive can just be a key. Where the mere presence of the key has
+ -- semantic value.
+ DirectiveElementKey ::
+ -- Which backend is this directive intended for?
+ Maybe (Identifier f a) ->
+ Identifier f a ->
+ a ->
+ DirectiveElement f a
+ -- A directive can be more complex too. It can have an optional backend
+ -- specificer, a key and a value.
+ DirectiveElementKeyValue ::
+ -- Which backend is this directive intendend for?
+ Maybe (Identifier f a) ->
+ -- The key for this directive.
+ Identifier f a ->
+ -- The value for this directive.
+ DirectiveExpression f a ->
+ a ->
+ DirectiveElement f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+-- Expressions which can be found in the directive.
+data DirectiveExpression f a where
+ DirectiveString :: Text -> a -> DirectiveExpression f a
+ DirectiveNumber :: Text -> a -> DirectiveExpression f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+-- A type, which wraps another syntax tree, but tacks on an array of directives.
+-- that apply to the subtree.
+data Directed t stage f a where
+ Directed :: [Directive f a] -> t stage f a -> a -> Directed t stage f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+-- Apply a function to the underlying subtree in a Directed type.
+mapDirected :: (t s f a -> t' s' f a) -> Directed t s f a -> Directed t' s' f a
+mapDirected fn (Directed dr tfa a) = Directed dr (fn tfa) a
+
+-- Apply a monadic function to the underlying subtree in a Directed type.
+mapDirectedM ::
+ (Monad m) => (t s f a -> m (t' s' f a)) -> Directed t s f a -> m (Directed t' s' f a)
+mapDirectedM fn (Directed dr tfa a) = Directed dr <$> fn tfa <*> pure a
+
+asDirected :: (Annotated (t s)) => t s f a -> Directed t s f a
+asDirected tfa = Directed [] tfa (annot tfa)
+
+undirected :: Directed t s f a -> t s f a
+undirected (Directed _ tfa _) = tfa
+
+-- Root of the parse tree. Just contains a list of declarations.
+data FiddleUnit (stage :: Stage) (f :: Type -> Type) a where
+ 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
+ deriving (Generic, Annotated, Alter, Typeable)
+
+-- Expression.
+data Expression (s :: Stage) :: SynTree where
+ -- Just a string. Parsing the number comes in stage2.
+ LitNum :: NumberType stage -> a -> Expression stage f a
+ Var :: Identifier f a -> a -> Expression stage f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+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 :: StagedSynTree where
+ {-
+ - An option is a key/value pair.
+ - option <ident> <ident>;
+ -}
+ OptionDecl ::
+ Identifier f a ->
+ Identifier f a ->
+ a ->
+ FiddleDecl stage f a
+ ImportDecl ::
+ ImportType stage f a ->
+ a ->
+ FiddleDecl stage f a
+ UsingDecl ::
+ Name f a -> a -> FiddleDecl stage f a
+ {- Package Statement. Package Name, Package body -}
+ PackageDecl ::
+ Name f a ->
+ f (PackageBody stage f a) ->
+ a ->
+ FiddleDecl stage f a
+ {- location <identifier> = <expr>. -}
+ LocationDecl ::
+ Identifier f a ->
+ Expression stage f a ->
+ a ->
+ FiddleDecl stage f a
+ {- bits <identifier> : <type> -}
+ BitsDecl ::
+ Identifier f a ->
+ BitType stage f a ->
+ a ->
+ FiddleDecl stage f a
+ {- objtype <identifier> : <type> -}
+ ObjTypeDecl ::
+ Identifier f a ->
+ f (ObjTypeBody stage f a) ->
+ a ->
+ FiddleDecl stage f a
+ {- object <ident> at <expr> : <type> -}
+ ObjectDecl ::
+ Identifier f a ->
+ Expression stage f a ->
+ ObjType stage f a ->
+ a ->
+ FiddleDecl stage f a
+ 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 ->
+ [Directed ObjTypeDecl stage f a] ->
+ a ->
+ ObjTypeBody stage f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+data ObjType stage f a where
+ -- { <body> }
+ -- Anonymous types are only allowed in stage1. Stage2 should have them be
+ -- de-anonymized.
+ AnonymousObjType ::
+ (Witness (stage == Stage1)) ->
+ f (ObjTypeBody stage f a) ->
+ a ->
+ ObjType stage f a
+ -- <type>[<expr>]
+ ArrayObjType :: ObjType stage f a -> Expression stage f a -> a -> ObjType stage f a
+ -- <identifier>
+ ReferencedObjType :: Name f a -> a -> ObjType stage f a
+ deriving (Typeable, Generic, Alter, Annotated, Typeable)
+
+data ObjTypeDecl stage f a where
+ {- assert_pos(<expr>) -}
+ AssertPosStatement ::
+ Witness (StageLessThan stage 3) ->
+ Expression stage f a ->
+ a ->
+ ObjTypeDecl stage f a
+ {- reg <ident>(<expr>) : <regtype> -}
+ RegisterDecl ::
+ Maybe (Modifier f a) ->
+ Maybe (Identifier f a) ->
+ Expression stage f a ->
+ Maybe (RegisterBody stage f a) ->
+ a ->
+ ObjTypeDecl stage f a
+ {- reserved(n); -}
+ ReservedDecl :: Expression stage f a -> a -> ObjTypeDecl stage f a
+ {- <struct|union> { subfields } <name>; -}
+ TypeSubStructure ::
+ f (ObjTypeBody stage f a) ->
+ Maybe (Identifier f a) ->
+ a ->
+ ObjTypeDecl stage f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+data Modifier f a where
+ ModifierKeyword :: ModifierKeyword -> a -> Modifier f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+data ModifierKeyword = Rw | Ro | Wo deriving (Eq, Ord, Show, Read, Typeable)
+
+data DeferredRegisterBody stage f a where
+ DeferredRegisterBody ::
+ [Directed RegisterBitsDecl stage f a] ->
+ a ->
+ DeferredRegisterBody stage f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+data BodyType (f :: Type -> Type) a where
+ Union :: a -> BodyType f a
+ Struct :: a -> BodyType f a
+ 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
+ deriving (Generic, Annotated, Alter, Typeable)
+
+data RegisterBitsDecl stage f a where
+ -- reserved(<expr>)
+ ReservedBits :: Expression stage f a -> a -> RegisterBitsDecl stage f a
+ -- <modifer> <ident> : <type>
+ DefinedBits ::
+ Maybe (Modifier f a) ->
+ Identifier f a ->
+ RegisterBitsTypeRef stage f a ->
+ a ->
+ RegisterBitsDecl stage f a
+ BitsSubStructure ::
+ RegisterBody stage f a ->
+ Maybe (Identifier f a) ->
+ a ->
+ RegisterBitsDecl stage f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+data RegisterBitsTypeRef stage f a where
+ -- <type>[<expr>]
+ RegisterBitsArray ::
+ RegisterBitsTypeRef stage f a ->
+ Expression stage f a ->
+ a ->
+ RegisterBitsTypeRef stage f a
+ {- Reference to a type. -}
+ RegisterBitsReference :: Name f a -> a -> RegisterBitsTypeRef stage f a
+ {- enum(<expr>) { <body> }
+ Anonymous types are only allowed in stage1.
+ Stage2 should de-anonymize these type. -}
+ RegisterBitsAnonymousType ::
+ Witness (stage == Stage1) ->
+ AnonymousBitsType stage f a ->
+ a ->
+ RegisterBitsTypeRef stage f a
+ {- (<expr>)
+ -
+ - The expression is just bits ... i.e. an integer.
+ -}
+ RegisterBitsJustBits ::
+ Expression stage f a ->
+ a ->
+ RegisterBitsTypeRef stage f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+data AnonymousBitsType stage f a where
+ -- enum(<expr>) { <body> }
+ AnonymousEnumBody ::
+ Expression stage f a ->
+ f (EnumBody stage f a) ->
+ a ->
+ AnonymousBitsType stage f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+data BitType (stage :: Stage) (f :: Type -> Type) a where
+ -- enum(<expr>) { <body> }
+ EnumBitType ::
+ Expression stage f a ->
+ f (EnumBody stage f a) ->
+ a ->
+ BitType stage f a
+ -- (<expr>)
+ RawBits :: Expression stage f a -> a -> BitType stage f a
+ deriving (Generic, Annotated, Alter, Typeable)
+
+data EnumBody (stage :: Stage) (f :: Type -> Type) a where
+ -- <decl>,
+ 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
+ -- reserved = <expr>
+ 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 :: [Directed FiddleDecl stage f a] -> a -> PackageBody stage f a
+ deriving (Generic, Annotated, Typeable)
+
+deriving instance (Alter (ImportType stage)) => Alter (PackageBody stage)
+
+squeeze :: (Alter t, Traversable f, Monad f) => t f a -> f (t Identity a)
+squeeze = alter (fmap Identity) return
+
+-- Expression involves NumberType, so we add the constraint:
+deriving instance (Functor f, NumberType s ~ NumberType s') => EasySwitchStage Expression f s s'
+
+-- FiddleDecl includes both NumberType and ImportType, so we need both constraints:
+deriving instance
+ ( Functor f,
+ StageLessThan s 3 ~ StageLessThan s' 3,
+ (s == Stage1) ~ (s' == Stage1),
+ NumberType s ~ NumberType s',
+ ImportType s ~ ImportType s'
+ ) =>
+ EasySwitchStage FiddleDecl f s s'
+
+-- ObjType includes NumberType, so we add the constraint:
+deriving instance
+ ( Functor f,
+ StageLessThan s 3 ~ StageLessThan s' 3,
+ (s == Stage1) ~ (s' == Stage1),
+ NumberType s ~ NumberType s'
+ ) =>
+ EasySwitchStage ObjType f s s'
+
+-- ObjTypeBody doesn't have any special type families, so no additional constraints:
+deriving instance
+ ( Functor f,
+ StageLessThan s 3 ~ StageLessThan s' 3,
+ (s == Stage1) ~ (s' == Stage1),
+ NumberType s ~ NumberType s'
+ ) =>
+ EasySwitchStage ObjTypeBody f s s'
+
+-- ObjTypeDecl doesn't have special type families, so no additional constraints:
+deriving instance
+ ( Functor f,
+ StageLessThan s 3 ~ StageLessThan s' 3,
+ (s == Stage1) ~ (s' == Stage1),
+ NumberType s ~ NumberType s'
+ ) =>
+ EasySwitchStage ObjTypeDecl f s s'
+
+-- DeferredRegisterBody doesn't have special type families:
+deriving instance
+ ( Functor f,
+ (s == Stage1) ~ (s' == Stage1),
+ NumberType s ~ NumberType s'
+ ) =>
+ EasySwitchStage DeferredRegisterBody f s s'
+
+-- RegisterBody depends on NumberType, so we add that constraint:
+deriving instance
+ ( Functor f,
+ (s == Stage1) ~ (s' == Stage1),
+ NumberType s ~ NumberType s'
+ ) =>
+ EasySwitchStage RegisterBody f s s'
+
+-- RegisterBitsDecl depends on NumberType:
+deriving instance
+ ( Functor f,
+ (s == Stage1) ~ (s' == Stage1),
+ NumberType s ~ NumberType s'
+ ) =>
+ EasySwitchStage RegisterBitsDecl f s s'
+
+-- RegisterBitsTypeRef depends on NumberType:
+deriving instance
+ ( Functor f,
+ (s == Stage1) ~ (s' == Stage1),
+ NumberType s ~ NumberType s'
+ ) =>
+ EasySwitchStage RegisterBitsTypeRef f s s'
+
+-- AnonymousBitsType depends on NumberType:
+deriving instance
+ (Functor f, NumberType s ~ NumberType s') =>
+ EasySwitchStage AnonymousBitsType f s s'
+
+-- BitType depends on NumberType:
+deriving instance
+ (Functor f, NumberType s ~ NumberType s') =>
+ EasySwitchStage BitType f s s'
+
+-- EnumBody doesn't depend on any type families:
+deriving instance
+ (Functor f, NumberType s ~ NumberType s') =>
+ EasySwitchStage EnumBody f s s'
+
+-- EnumConstantDecl depends on NumberType:
+deriving instance
+ (Functor f, NumberType s ~ NumberType s') =>
+ EasySwitchStage EnumConstantDecl f s s'
+
+-- PackageBody includes both NumberType and ImportType:
+deriving instance
+ ( Functor f,
+ StageLessThan s 3 ~ StageLessThan s' 3,
+ (s == Stage1) ~ (s' == Stage1),
+ NumberType s ~ NumberType s',
+ ImportType s ~ ImportType s'
+ ) =>
+ EasySwitchStage PackageBody f s s'
+
+-- FiddleUnit includes NumberType and ImportType, so we need both constraints:
+deriving instance
+ ( Functor f,
+ StageLessThan s 3 ~ StageLessThan s' 3,
+ (s == Stage1) ~ (s' == Stage1),
+ NumberType s ~ NumberType s',
+ ImportType s ~ ImportType s'
+ ) =>
+ EasySwitchStage FiddleUnit f s s'
+
+-- Directed depends on its underlying AST type:
+deriving instance
+ (EasySwitchStage t f s s') =>
+ EasySwitchStage (Directed t) f s s'
diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTreeKinds.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTreeKinds.hs
new file mode 100644
index 0000000..bfdfb13
--- /dev/null
+++ b/src/Language/Fiddle/Ast/Internal/SyntaxTreeKinds.hs
@@ -0,0 +1 @@
+module Language.Fiddle.Ast.Internal.SyntaxTreeKinds where
generated by cgit (git 2.34.1) at 2025-07-17 14:43:11 +0000