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.hs170
1 files changed, 97 insertions, 73 deletions
diff --git a/src/Language/Fiddle/Ast.hs b/src/Language/Fiddle/Ast.hs
index 61a637e..277ab24 100644
--- a/src/Language/Fiddle/Ast.hs
+++ b/src/Language/Fiddle/Ast.hs
@@ -9,45 +9,41 @@
module Language.Fiddle.Ast where
import Data.Functor.Identity
+import Data.Kind (Type)
import Data.Proxy
import Data.Text (Text)
import Data.Traversable
+import Data.Typeable
import GHC.Generics
+import GHC.TypeLits
+
+type family NumberType (a :: Stage) where
+ NumberType Stage1 = Text
+ NumberType Stage2 = Integer
+ NumberType Stage3 = Integer
-- 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 :: [FiddleDecl stage f a] -> a -> FiddleUnit stage f a
+ deriving (Generic, Annotated, Alter, Typeable)
-- Just an identifier.
data Identifier stage f a = Identifier !Text a
- deriving (Generic, Annotated, Alter)
+ deriving (Generic, Annotated, Alter, Typeable)
-- Expression.
data Expression stage f a where
-- Just a string. Parsing the number comes in stage2.
- LitNum :: Text -> a -> Expression 'Stage1 f a
- RealNum :: Integer -> a -> Expression 'Stage2 f a
+ LitNum :: NumberType stage -> a -> Expression stage f a
Var :: Identifier stage f a -> a -> Expression stage f a
-instance Alter (Expression stage) where
- alter ffn fn = \case
- LitNum t a -> LitNum t <$> fn a
- RealNum i a -> RealNum i <$> fn a
- Var i a -> Var <$> alter ffn fn i <*> fn a
-
-instance Annotated (Expression stage) where
- annot = \case
- LitNum _ a -> a
- RealNum _ a -> a
- Var _ a -> a
-
--- Root of the parse tree. Just contains a list of declarations.
-data FiddleUnit (stage :: Stage) (f :: * -> *) a where
- FiddleUnit :: [FiddleDecl stage f a] -> a -> FiddleUnit stage f a
- deriving (Generic, Annotated, Alter)
-
-- Top-level declarations.
-data FiddleDecl (stage :: Stage) (f :: * -> *) a where
+data FiddleDecl (stage :: Stage) (f :: Type -> Type) a where
{-
- An option is a key/value pair.
- option <ident> <ident>;
@@ -88,7 +84,11 @@ data FiddleDecl (stage :: Stage) (f :: * -> *) a where
ObjType stage f a ->
a ->
FiddleDecl stage f a
- deriving (Generic, Annotated, Alter)
+ deriving (Generic, Annotated, Alter, Typeable)
+
+data ObjTypeBody (stage :: Stage) (f :: Type -> Type) a where
+ ObjTypeBody :: [ObjTypeDecl stage f a] -> a -> ObjTypeBody stage f a
+ deriving (Generic, Annotated, Alter, Typeable)
data ObjType stage f a where
-- { <body> }
@@ -99,29 +99,15 @@ data ObjType stage f a where
ArrayObjType :: ObjType stage f a -> Expression stage f a -> a -> ObjType stage f a
-- <identifier>
ReferencedObjType :: Identifier stage f a -> a -> ObjType stage f 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
-
-data ObjTypeBody (stage :: Stage) (f :: * -> *) a where
- ObjTypeBody :: [ObjTypeDecl stage f a] -> a -> ObjTypeBody stage f a
- deriving (Generic, Annotated, Alter)
+ deriving (Typeable)
data ObjTypeDecl stage f a where
{- assert_pos(<expr>) -}
- AssertPosStatement :: Expression stage f a -> a -> ObjTypeDecl stage f a
+ AssertPosStatement ::
+ (CmpNat (StageNumber stage) 3 ~ LT) =>
+ Expression stage f a ->
+ a ->
+ ObjTypeDecl stage f a
{- reg <ident>(<expr>) : <regtype> -}
RegisterDecl ::
Maybe (Modifier stage f a) ->
@@ -130,24 +116,24 @@ data ObjTypeDecl stage f a where
Maybe (RegisterBody stage f a) ->
a ->
ObjTypeDecl stage f a
- deriving (Generic, Annotated, Alter)
+ deriving (Typeable)
data Modifier stage f a where
ModifierKeyword :: ModifierKeyword -> a -> Modifier stage f a
- deriving (Generic, Annotated, Alter)
+ deriving (Generic, Annotated, Alter, Typeable)
-data ModifierKeyword = Rw | Ro | Wo deriving (Eq, Ord, Show, Read)
+data ModifierKeyword = Rw | Ro | Wo deriving (Eq, Ord, Show, Read, Typeable)
data DeferredRegisterBody stage f a where
DeferredRegisterBody ::
[RegisterBitsDecl stage f a] ->
a ->
DeferredRegisterBody stage f a
- deriving (Generic, Annotated, Alter)
+ deriving (Generic, Annotated, Alter, Typeable)
data RegisterBody stage f a where
RegisterBody :: f (DeferredRegisterBody stage f a) -> a -> RegisterBody stage f a
- deriving (Generic, Annotated, Alter)
+ deriving (Generic, Annotated, Alter, Typeable)
data RegisterBitsDecl stage f a where
-- reserved(<expr>)
@@ -159,19 +145,7 @@ data RegisterBitsDecl stage f a where
RegisterBitsTypeRef stage f a ->
a ->
RegisterBitsDecl stage f a
- deriving (Generic, Annotated, Alter)
-
-data Test stage f a where
- Test ::
- Identifier stage f a ->
- Identifier stage f a ->
- Identifier stage f a ->
- Identifier stage f a ->
- Identifier stage f a ->
- Identifier stage f a ->
- a ->
- Test stage f a
- deriving (Generic)
+ deriving (Generic, Annotated, Alter, Typeable)
data RegisterBitsTypeRef stage f a where
-- <type>[<expr>]
@@ -186,7 +160,7 @@ data RegisterBitsTypeRef stage f a where
Anonymous types are only allowed in stage1.
Stage2 should de-anonymize these type. -}
RegisterBitsAnonymousType ::
- AnonymousBitsType stage f a ->
+ AnonymousBitsType Stage1 f a ->
a ->
RegisterBitsTypeRef 'Stage1 f a
{- (<expr>)
@@ -198,6 +172,47 @@ data RegisterBitsTypeRef stage f a where
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
+
+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) ->
@@ -218,10 +233,14 @@ instance Annotated (RegisterBitsTypeRef stage) where
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)
+ 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 :: * -> *) a where
+data BitType (stage :: Stage) (f :: Type -> Type) a where
-- enum(<expr>) { <body> }
EnumBitType ::
Expression stage f a ->
@@ -230,24 +249,24 @@ data BitType (stage :: Stage) (f :: * -> *) a where
BitType stage f a
-- (<expr>)
RawBits :: Expression stage f a -> a -> BitType stage f a
- deriving (Generic, Annotated, Alter)
+ deriving (Generic, Annotated, Alter, Typeable)
-data EnumBody (stage :: Stage) (f :: * -> *) a where
+data EnumBody (stage :: Stage) (f :: Type -> Type) a where
-- <decl>,
EnumBody :: [EnumConstantDecl stage f a] -> a -> EnumBody stage f a
- deriving (Generic, Annotated, Alter)
+ deriving (Generic, Annotated, Alter, Typeable)
data EnumConstantDecl stage f a where
-- <ident> = <expr>
EnumConstantDecl :: Identifier stage 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)
+ deriving (Generic, Annotated, Alter, Typeable)
-data PackageBody (stage :: Stage) (f :: * -> *) a where
+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)
+ deriving (Generic, Annotated, Alter, Typeable)
-- instance Alter (Modifier stage) where
-- alter _ fn (ModifierKeyword m a) = ModifierKeyword m (fn a)
@@ -264,7 +283,7 @@ data PackageBody (stage :: Stage) (f :: * -> *) a where
proxyOf :: t f a -> Proxy t
proxyOf _ = Proxy
-class Annotated (t :: (* -> *) -> * -> *) where
+class Annotated (t :: (Type -> Type) -> Type -> Type) 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)
@@ -273,7 +292,7 @@ class GAnnot a r where
gannot :: r x -> a
instance GAnnot a (Rec0 a) where
- gannot k1 = unK1 k1
+ gannot = unK1
instance (GAnnot a r) => GAnnot a (l :*: r) where
gannot (_ :*: r) = gannot r
@@ -285,7 +304,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 :: (* -> *) -> * -> *) where
+class Alter (t :: (Type -> Type) -> Type -> Type) where
alter ::
forall f1 f2 a1 a2 m.
(Monad m, Traversable f1) =>
@@ -382,6 +401,11 @@ instance
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
generated by cgit (git 2.34.1) at 2025-07-03 04:59:57 +0000