{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ConstraintKinds #-} 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 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 -- Top-level declarations. data FiddleDecl (stage :: Stage) (f :: Type -> Type) a where {- - An option is a key/value pair. - option ; -} OptionDecl :: Identifier f a -> Identifier f a -> a -> FiddleDecl stage f a {- Package Statement. Package Name, Package body -} PackageDecl :: Identifier f a -> f (PackageBody stage f a) -> a -> FiddleDecl stage f a {- location = . -} LocationDecl :: Identifier f a -> Expression stage f a -> a -> FiddleDecl stage f a {- bits : -} BitsDecl :: Identifier f a -> BitType stage f a -> a -> FiddleDecl stage f a {- objtype : -} ObjTypeDecl :: Identifier f a -> f (ObjTypeBody stage f a) -> a -> FiddleDecl stage f a {- object at : -} ObjectDecl :: Identifier f a -> Expression stage f a -> ObjType stage f a -> a -> FiddleDecl stage f a 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 -- { } -- 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 -- [] ArrayObjType :: ObjType stage f a -> Expression stage f a -> a -> ObjType stage f a -- ReferencedObjType :: Identifier f a -> a -> ObjType stage f a deriving (Typeable) type StageLessThan stage (n :: Natural) = (CmpNat (StageNumber stage) n ~ LT) data ObjTypeDecl stage f a where {- assert_pos() -} AssertPosStatement :: (StageLessThan stage 3) => Expression stage f a -> a -> ObjTypeDecl stage f a {- reg () : -} RegisterDecl :: Maybe (Modifier f a) -> Maybe (Identifier f a) -> Expression stage f a -> Maybe (RegisterBody stage 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 :: [RegisterBitsDecl stage f a] -> a -> DeferredRegisterBody stage f a 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, Typeable) data RegisterBitsDecl stage f a where -- reserved() ReservedBits :: Expression stage f a -> a -> RegisterBitsDecl stage f a -- : DefinedBits :: Maybe (Modifier f a) -> Identifier f a -> RegisterBitsTypeRef stage f a -> a -> RegisterBitsDecl stage f a deriving (Generic, Annotated, Alter, Typeable) data RegisterBitsTypeRef stage f a where -- [] RegisterBitsArray :: RegisterBitsTypeRef stage f a -> Expression stage f a -> a -> RegisterBitsTypeRef stage f a {- Reference to a type. -} RegisterBitsReference :: Identifier f a -> a -> RegisterBitsTypeRef stage f a {- enum() { } Anonymous types are only allowed in stage1. Stage2 should de-anonymize these type. -} RegisterBitsAnonymousType :: AnonymousBitsType Stage1 f a -> a -> RegisterBitsTypeRef 'Stage1 f a {- () - - 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 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() { } 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() { } EnumBitType :: Expression stage f a -> f (EnumBody stage f a) -> a -> BitType stage f a -- () RawBits :: Expression stage f a -> a -> BitType stage f a deriving (Generic, Annotated, Alter, Typeable) data EnumBody (stage :: Stage) (f :: Type -> Type) a where -- , EnumBody :: [EnumConstantDecl stage f a] -> a -> EnumBody stage f a deriving (Generic, Annotated, Alter, Typeable) data EnumConstantDecl stage f a where -- = EnumConstantDecl :: Identifier f a -> Expression stage f a -> a -> EnumConstantDecl stage f a -- reserved = 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 :: [FiddleDecl stage f a] -> a -> PackageBody stage f a deriving (Generic, Annotated, Alter, Typeable) -- 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 :: (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) 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 :: (Type -> Type) -> Type -> Type) 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