1 files changed, 537 insertions, 0 deletions

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'