diff options
Diffstat (limited to 'src/Language/Fiddle/Ast.hs')
-rw-r--r-- | src/Language/Fiddle/Ast.hs | 42 |
1 files changed, 32 insertions, 10 deletions
diff --git a/src/Language/Fiddle/Ast.hs b/src/Language/Fiddle/Ast.hs index 03cf527..7600006 100644 --- a/src/Language/Fiddle/Ast.hs +++ b/src/Language/Fiddle/Ast.hs @@ -88,7 +88,6 @@ data FiddleDecl (stage :: Stage) (f :: * -> *) a where ObjType stage f a -> a -> FiddleDecl stage f a - deriving (Generic, Annotated, Alter) data ObjType stage f a where @@ -116,7 +115,6 @@ instance Annotated (ObjType stage) where (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) @@ -132,14 +130,13 @@ data ObjTypeDecl stage f a where Maybe (RegisterBody stage f a) -> a -> ObjTypeDecl stage f a - deriving (Generic, Annotated, Alter) data Modifier stage f a where ModifierKeyword :: ModifierKeyword -> a -> Modifier stage f a deriving (Generic, Annotated, Alter) -data ModifierKeyword = Rw | Ro | Wo +data ModifierKeyword = Rw | Ro | Wo deriving (Eq, Ord, Show, Read) data DeferredRegisterBody stage f a where DeferredRegisterBody :: @@ -162,9 +159,20 @@ 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) + data RegisterBitsTypeRef stage f a where -- <type>[<expr>] RegisterBitsArray :: @@ -182,6 +190,13 @@ data RegisterBitsTypeRef stage f a where 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 (RegisterBitsTypeRef stage) where alter ffn fn = \case (RegisterBitsArray ref exp a) -> @@ -190,12 +205,15 @@ instance Alter (RegisterBitsTypeRef stage) where 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> } @@ -204,8 +222,11 @@ data AnonymousBitsType stage f a where data BitType (stage :: Stage) (f :: * -> *) a where -- enum(<expr>) { <body> } - EnumBitType :: - Expression stage f a -> f (EnumBody stage f a) -> a -> BitType stage f a + 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) @@ -244,7 +265,6 @@ proxyOf _ = Proxy class Annotated (t :: (* -> *) -> * -> *) 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) @@ -289,6 +309,9 @@ class Alter (t :: (* -> *) -> * -> *) where 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. @@ -358,7 +381,6 @@ instance where galter proxy ffn fn (M1 a) = M1 <$> galter proxy ffn fn a - {--} -squeeze :: (Alter t, Traversable f, Monad f) => t f a -> f (t Identity a) +squeeze :: (Alter t, Traversable f, Monad f) => t f a -> f (t Identity a) squeeze = alter (fmap Identity) return |