summaryrefslogtreecommitdiff
path: root/src/Language/Fiddle/Ast.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/Fiddle/Ast.hs')
-rw-r--r--src/Language/Fiddle/Ast.hs566
1 files changed, 10 insertions, 556 deletions
diff --git a/src/Language/Fiddle/Ast.hs b/src/Language/Fiddle/Ast.hs
index 8680790..7ef12da 100644
--- a/src/Language/Fiddle/Ast.hs
+++ b/src/Language/Fiddle/Ast.hs
@@ -1,570 +1,24 @@
{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE IncoherentInstances #-}
-{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-module Language.Fiddle.Ast where
+module Language.Fiddle.Ast (module X) 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 qualified GHC.TypeError as TypeError
import GHC.TypeLits
-
--- 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
-
--- 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 (StageNumber stage) n ~ LT)
-
--- A Name is multiple identifiers separated by dots. It's the way of namespaces
--- to different packages.
-data Name f a where
- Name :: NonEmpty (Identifier f a) -> a -> Name f a
- deriving (Generic, Annotated, Alter, Typeable)
-
--- [[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
- deriving (Typeable)
-
--- 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 stage f a 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
-
--- 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
- {-
- - 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 :: f (ObjTypeBody 'Stage1 f a) -> a -> ObjType 'Stage1 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)
-
-data ObjTypeDecl stage f a where
- {- assert_pos(<expr>) -}
- AssertPosStatement ::
- (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 (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 ::
- AnonymousBitsType Stage1 f a ->
- a ->
- RegisterBitsTypeRef 'Stage1 f a
- {- (<expr>)
- -
- - The expression is just bits ... i.e. an integer.
- -}
- RegisterBitsJustBits ::
- Expression stage f a ->
- a ->
- RegisterBitsTypeRef stage f a
-
-instance Alter (Expression stage) where
- alter ffn fn = \case
- LitNum t a -> LitNum t <$> fn a
- Var i a -> Var <$> alter ffn fn i <*> fn a
-
-instance Annotated (Expression stage) where
- annot = \case
- LitNum _ a -> a
- Var _ a -> a
-
-instance Alter (ObjTypeDecl stage) where
- alter ffn fn = \case
- (AssertPosStatement expr a) ->
- AssertPosStatement <$> alter ffn fn expr <*> fn a
- (RegisterDecl mMod mIdent expr mBody a) ->
- RegisterDecl
- <$> mapM (alter ffn fn) mMod
- <*> mapM (alter ffn fn) mIdent
- <*> alter ffn fn expr
- <*> mapM (alter ffn fn) mBody
- <*> fn a
- (TypeSubStructure mBody mIdent a) ->
- TypeSubStructure
- <$> (ffn =<< mapM (alter ffn fn) mBody)
- <*> mapM (alter ffn fn) mIdent
- <*> fn a
- (ReservedDecl expr a) ->
- ReservedDecl
- <$> alter ffn fn expr
- <*> fn a
-
-instance Annotated (ObjTypeDecl stage) where
- annot = \case
- (AssertPosStatement _ a) -> a
- (RegisterDecl _ _ _ _ a) -> a
-
-instance Alter (ObjType stage) where
- alter ffn fn = \case
- (AnonymousObjType b a) ->
- AnonymousObjType <$> (ffn =<< mapM (alter ffn fn) b) <*> fn a
- (ArrayObjType t e a) ->
- ArrayObjType <$> alter ffn fn t <*> alter ffn fn e <*> fn a
- (ReferencedObjType i a) ->
- ReferencedObjType <$> alter ffn fn i <*> fn a
-
-instance Annotated (ObjType stage) where
- annot = \case
- (AnonymousObjType _ a) -> a
- (ArrayObjType _ _ a) -> a
- (ReferencedObjType _ a) -> a
-
-instance Alter (RegisterBitsTypeRef stage) where
- alter ffn fn = \case
- (RegisterBitsArray ref exp a) ->
- RegisterBitsArray <$> alter ffn fn ref <*> alter ffn fn exp <*> fn a
- (RegisterBitsReference i a) ->
- RegisterBitsReference <$> alter ffn fn i <*> fn a
- (RegisterBitsAnonymousType t a) ->
- RegisterBitsAnonymousType <$> alter ffn fn t <*> fn a
- (RegisterBitsJustBits e a) ->
- RegisterBitsJustBits <$> alter ffn fn e <*> fn a
-
-instance Annotated (RegisterBitsTypeRef stage) where
- annot = \case
- (RegisterBitsArray _ _ a) -> a
- (RegisterBitsReference _ a) -> a
- (RegisterBitsAnonymousType _ a) -> a
- (RegisterBitsJustBits _ a) -> a
-
-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)
-
--- instance Alter (Modifier stage) where
--- alter _ fn (ModifierKeyword m a) = ModifierKeyword m (fn a)
---
--- instance Alter (Identifier) where
--- alter _ fn (Identifier i a) = Identifier i $ fn a
---
--- instance Alter (Expression stage) where
--- alter ffn fn = \case
--- (LitNum t a) -> LitNum t $ fn a
--- (RealNum t a) -> RealNum t $ fn a
--- (Var i a) -> Var (alter ffn fn i) $ fn a
-
-proxyOf :: t f a -> Proxy t
-proxyOf _ = Proxy
-
-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)
-
-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
-
-class Alter (t :: SynTreeKind) 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)
-
-instance (Alter t, Traversable f) => Functor (t f) where
- fmap f t = runIdentity (alter return (return . f) t)
-
-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
-
-type family StageNumber (s :: Stage) :: Natural where
- StageNumber Stage1 = 1
- StageNumber Stage2 = 2
- StageNumber Stage3 = 3
-
-{--}
-squeeze :: (Alter t, Traversable f, Monad f) => t f a -> f (t Identity a)
-squeeze = alter (fmap Identity) return
+import Language.Fiddle.Ast.Internal.Instances as X
+import Language.Fiddle.Ast.Internal.Kinds as X
+import Language.Fiddle.Ast.Internal.Stage as X
+import Language.Fiddle.Ast.Internal.SyntaxTree as X