diff options
Diffstat (limited to 'src/Language/Fiddle/Ast')
| -rw-r--r-- | src/Language/Fiddle/Ast/Internal/Instances.hs | 137 | ||||
| -rw-r--r-- | src/Language/Fiddle/Ast/Internal/Stage.hs | 13 | ||||
| -rw-r--r-- | src/Language/Fiddle/Ast/Internal/SyntaxTree.hs | 50 |
3 files changed, 89 insertions, 111 deletions
diff --git a/src/Language/Fiddle/Ast/Internal/Instances.hs b/src/Language/Fiddle/Ast/Internal/Instances.hs index 2f3707e..b8f6072 100644 --- a/src/Language/Fiddle/Ast/Internal/Instances.hs +++ b/src/Language/Fiddle/Ast/Internal/Instances.hs @@ -1,17 +1,15 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE IncoherentInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies #-} module Language.Fiddle.Ast.Internal.Instances where import Data.Functor.Identity -import Data.Kind (Type) +import Data.Kind +import Data.Type.Bool +import Data.Type.Equality import Data.Typeable import GHC.Generics import GHC.TypeError as TypeError +import GHC.TypeLits import Language.Fiddle.Ast.Internal.Kinds import Language.Fiddle.Ast.Internal.Stage @@ -42,6 +40,13 @@ class Alter (t :: SynTree) where m (t f2 a2) alter ffn fn t = to <$> galter (proxyOf t) ffn fn (from t) +class (Typeable t) => Visit (t :: SynTree) where + visit :: + (Typeable f, Typeable a, Monad m) => + (forall t'. (Typeable t') => t' f a -> m ()) -> + t f a -> + m () + -- | 'CompilationStage' is a type class representing a stage in the compiler -- pipeline. Each 'stage' has associated types that define how it transforms -- syntax trees, manages state, and handles annotations. @@ -78,6 +83,15 @@ class type TreeType (t :: StagedSynTree) (s :: Stage) = t s (StageFunctor s) (StageAnnotation s) +class + (CompilationStage stage) => + StageConvertible stage from to + where + convertInStage :: proxy stage -> StageState stage -> from -> StageMonad stage to + +instance (CompilationStage s, Applicative (StageMonad s)) => StageConvertible s a a where + convertInStage _ _ = pure + -- | 'AdvanceStage' defines how to transform an Abstract Syntax Tree (AST) node -- from one stage to the next in the compiler pipeline. This transformation -- can be customized per node type, or a default generic implementation can be @@ -127,6 +141,7 @@ class -- to be adjusted. default advanceStage :: ( GAdvanceStage + stage (StageState stage) -- The local state for this stage (StageMonad stage) -- The monadic context of this stage (Rep (TreeType t stage)) -- Generic representation of the current tree type @@ -152,7 +167,7 @@ class -- Modify the local state for this node before performing the transformation s' <- modifyState t s -- Perform the generic transformation using 'gAdvanceStage' - to <$> gAdvanceStage s' (from t) + to <$> gAdvanceStage (Proxy :: Proxy stage) s' (from t) -- | 'modifyState' allows for changes to the local state ('StageState') before -- transforming the syntax tree node. This is called on each node during the @@ -186,9 +201,8 @@ class -- of the generic representation of a syntax tree node. It is used by the -- default implementation of 'advanceStage' to traverse and modify nodes -- automatically. -class GAdvanceStage s m from to where - gAdvanceStage :: s -> from x -> m (to x) - +class GAdvanceStage (stage :: Stage) s m from to where + gAdvanceStage :: Proxy stage -> s -> from x -> m (to x) -- A syntax tree object is annotated if it has an annotation 'a' as the last -- element. @@ -297,57 +311,6 @@ 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 --- instance --- (GEasySwitchStage s1 s2) => --- GEasySwitchStage (M1 i c s1) (M1 i c s2) --- where --- gSwitchStage (M1 a) = M1 (gSwitchStage a) --- --- instance --- (GEasySwitchStage l1 l2, GEasySwitchStage r1 r2) => --- GEasySwitchStage (l1 :+: r1) (l2 :+: r2) --- where --- gSwitchStage (R1 r) = R1 $ gSwitchStage r --- gSwitchStage (L1 l) = L1 $ gSwitchStage l --- --- instance --- (GEasySwitchStage l1 l2, GEasySwitchStage r1 r2) => --- (GEasySwitchStage (l1 :*: r1) (l2 :*: r2)) --- where --- gSwitchStage (l :*: r) = gSwitchStage l :*: gSwitchStage r --- --- instance --- (EasySwitchStage t f fs ts) => --- (GEasySwitchStage (Rec0 (t fs f a)) (Rec0 (t ts f a))) --- where --- gSwitchStage (K1 val) = K1 (switchStage val) --- --- instance --- ( EasySwitchStage t f fs ts, --- Functor func --- ) => --- (GEasySwitchStage (Rec0 (func (t fs f a))) (Rec0 (func (t ts f a)))) --- where --- gSwitchStage (K1 val) = K1 (switchStage <$> val) --- --- instance (GEasySwitchStage (Rec0 a) (Rec0 a)) where --- gSwitchStage = id --- --- instance --- ( TypeError --- ( TypeError.Text "Unable to match type " --- :<>: TypeError.ShowType a --- :<>: TypeError.Text " with " --- :<>: TypeError.ShowType b --- ) --- ) => --- (GEasySwitchStage (Rec0 a) (Rec0 b)) --- where --- gSwitchStage = error "Cannot be called" - --- class GEasySwitchStage r1 r2 where --- gSwitchStage :: r1 x -> r2 x - proxyOf :: t f a -> Proxy t proxyOf _ = Proxy @@ -359,10 +322,10 @@ instance (Alter t, Traversable f) => Functor (t f) where -- representation. The metadata node ('M1') wraps another node ('s1'), which -- is recursively advanced to the next stage using 'gAdvanceStage'. instance - (Monad m, GAdvanceStage s m s1 s2) => - GAdvanceStage s m (M1 i c s1) (M1 i c s2) + (Monad m, GAdvanceStage stage s m s1 s2) => + GAdvanceStage stage s m (M1 i c s1) (M1 i c s2) where - gAdvanceStage s (M1 a) = M1 <$> gAdvanceStage s a + gAdvanceStage pxy s (M1 a) = M1 <$> gAdvanceStage pxy s a -- | 'GAdvanceStage' instance for sum types (':+:'). This handles the case -- where the generic representation of a type is a sum (i.e., an 'Either'-like @@ -370,22 +333,22 @@ instance -- or 'R1' (right), and 'gAdvanceStage' is called recursively on the selected -- branch. instance - (Monad m, GAdvanceStage s m l1 l2, GAdvanceStage s m r1 r2) => - GAdvanceStage s m (l1 :+: r1) (l2 :+: r2) + (Monad m, GAdvanceStage stage s m l1 l2, GAdvanceStage stage s m r1 r2) => + GAdvanceStage stage s m (l1 :+: r1) (l2 :+: r2) where - gAdvanceStage s (R1 r) = R1 <$> gAdvanceStage s r - gAdvanceStage s (L1 l) = L1 <$> gAdvanceStage s l + gAdvanceStage pxy s (R1 r) = R1 <$> gAdvanceStage pxy s r + gAdvanceStage pxy s (L1 l) = L1 <$> gAdvanceStage pxy s l -- | 'GAdvanceStage' instance for product types (':*:'). This handles cases -- where the generic representation of a type is a product (i.e., a tuple of -- multiple components). It recursively advances each component ('l' and 'r') -- to the next stage. instance - (Monad m, GAdvanceStage s m l1 l2, GAdvanceStage s m r1 r2) => - GAdvanceStage s m (l1 :*: r1) (l2 :*: r2) + (Monad m, GAdvanceStage stage s m l1 l2, GAdvanceStage stage s m r1 r2) => + GAdvanceStage stage s m (l1 :*: r1) (l2 :*: r2) where - gAdvanceStage s (l :*: r) = - (:*:) <$> gAdvanceStage s l <*> gAdvanceStage s r + gAdvanceStage pxy s (l :*: r) = + (:*:) <$> gAdvanceStage pxy s l <*> gAdvanceStage pxy s r -- | 'GAdvanceStage' instance for record fields ('Rec0') containing a single -- AST element ('t') to be advanced. This instance covers the case where the @@ -401,9 +364,9 @@ instance StageFunctor stage ~ f, StageAnnotation stage ~ a ) => - GAdvanceStage s m (Rec0 (t' stage f a)) (Rec0 (t' stage' f a)) + GAdvanceStage stage s m (Rec0 (t' stage f a)) (Rec0 (t' stage' f a)) where - gAdvanceStage st (K1 val) = K1 <$> advanceStage st val + gAdvanceStage pxy st (K1 val) = K1 <$> advanceStage st val -- | 'GAdvanceStage' instance for record fields ('Rec0') containing a functor -- ('func') of AST elements ('t'). This handles cases where the field is a @@ -420,9 +383,9 @@ instance StageAnnotation stage ~ a, Traversable func ) => - GAdvanceStage s m (Rec0 (func (t' stage f a))) (Rec0 (func (t' stage' f a))) + GAdvanceStage stage s m (Rec0 (func (t' stage f a))) (Rec0 (func (t' stage' f a))) where - gAdvanceStage st (K1 val) = K1 <$> mapM (advanceStage st) val + gAdvanceStage pxy st (K1 val) = K1 <$> mapM (advanceStage st) val -- | 'GAdvanceStage' instance for record fields ('Rec0') containing a -- functor ('f') wrapping an AST element. This handles cases where the field @@ -438,13 +401,25 @@ instance StageFunctor stage ~ f, StageAnnotation stage ~ a ) => - GAdvanceStage s m (Rec0 (f (t' stage f a))) (Rec0 (f (t' stage' f a))) + GAdvanceStage stage s m (Rec0 (f (t' stage f a))) (Rec0 (f (t' stage' f a))) where - gAdvanceStage st (K1 val) = K1 <$> mapM (advanceStage st) val + gAdvanceStage pxy st (K1 val) = K1 <$> mapM (advanceStage st) val -- | 'GAdvanceStage' instance for simple record fields ('Rec0') that do not -- need to change between stages. This is used for fields that are not AST -- nodes and remain the same when advancing the stage (e.g., primitive -- types like 'Int', 'Bool', etc.). -instance (Monad m) => GAdvanceStage s m (Rec0 a) (Rec0 a) where - gAdvanceStage _ (K1 val) = return (K1 val) +instance (Monad m) => GAdvanceStage stage s m (Rec0 a) (Rec0 a) where + gAdvanceStage pxy _ (K1 val) = return (K1 val) + +-- | 'GAdvanceStage' instance for records which can be converted to eathother +-- for the current stage.. +instance + ( Monad m, + StageConvertible stage a b, + StageState stage ~ s, + StageMonad stage ~ m + ) => + GAdvanceStage stage s m (Rec0 a) (Rec0 b) + where + gAdvanceStage pxy s (K1 val) = K1 <$> convertInStage pxy s val diff --git a/src/Language/Fiddle/Ast/Internal/Stage.hs b/src/Language/Fiddle/Ast/Internal/Stage.hs index 20460b6..17ec9f2 100644 --- a/src/Language/Fiddle/Ast/Internal/Stage.hs +++ b/src/Language/Fiddle/Ast/Internal/Stage.hs @@ -17,8 +17,10 @@ import GHC.TypeLits -- as the compilation process simplifies or transforms the tree. data Stage = Parsed + | ImportsResolved | Expanded | Checked + | End deriving (Typeable) -- | Converts a 'Stage' into a type-level natural number. This mapping allows @@ -26,8 +28,9 @@ data Stage -- For example, 'Parsed' maps to 1, 'Expanded' to 2, and so on. type family StageToNumber (s :: Stage) :: Natural where StageToNumber Parsed = 1 - StageToNumber Expanded = 2 - StageToNumber Checked = 3 + StageToNumber ImportsResolved = 2 + StageToNumber Expanded = 3 + StageToNumber Checked = 4 -- | A type-level constraint that checks if one compilation stage precedes another. -- It compares the numeric values associated with each stage using 'CmpNat'. @@ -35,7 +38,7 @@ type family StageToNumber (s :: Stage) :: Natural where -- This is useful to conditionally include or exclude parts of the AST -- depending on the compilation stage. type StagePreceeds stage1 stage2 = - (CmpNat (StageToNumber stage1) (StageToNumber stage2) == LT) + (CmpStage stage1 stage2 == LT) type (<) a b = StagePreceeds a b @@ -43,9 +46,9 @@ type (<) a b = StagePreceeds a b -- Similar to 'StagePreceeds', it compares the numeric values of stages. -- Returns 'True' if 'stage1' comes after 'stage2'. type StageSucceeds stage1 stage2 = - (CmpNat (StageToNumber stage1) (StageToNumber stage2) == LT) + (CmpStage stage1 stage2 == LT) -type (>) a b = StagePreceeds a b +type (>) a b = StageSucceeds a b -- | A type-level function that compares two stages and returns a comparison -- result ('LT', 'EQ', or 'GT'). This function is a generalized way to compare diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs index d03a855..c37be87 100644 --- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs +++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs @@ -9,7 +9,7 @@ module Language.Fiddle.Ast.Internal.SyntaxTree ( -- Type Families NumberType, - ImportType, + ImportInterface, -- Witness Types Witness (..), WitnessType, @@ -68,23 +68,21 @@ import Language.Fiddle.Ast.Internal.Generic import Language.Fiddle.Ast.Internal.Instances import Language.Fiddle.Ast.Internal.Kinds import Language.Fiddle.Ast.Internal.Stage +import Language.Fiddle.Internal.UnitInterface (UnitInterface) --- The Type of number during each stage of compilation. When in the first 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 s = If (s < Expanded) Text 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) :: SynTree where - ImportType Parsed = ImportStatement - ImportType Expanded = ImportStatement - ImportType Checked = ImportStatement +-- | The type used for ImportInterfaces attached to ImportStatements. Before import +-- resolution, this type is just '()', but when imports are resolved, it turns +-- into a 'UnitInterface'. +type family ImportInterface (stage :: Stage) :: Type where + ImportInterface s = If (s < ImportsResolved) () UnitInterface --- A way to disable or enable a subtree type based on a type-level boolean. +-- | 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. @@ -225,9 +223,7 @@ data FiddleUnit (stage :: Stage) (f :: Type -> Type) a where fiddleUnitAnnot :: a } -> FiddleUnit stage f a - deriving (Generic, Annotated, Typeable) - -deriving instance (Alter (ImportType stage)) => Alter (FiddleUnit stage) + deriving (Generic, Annotated, Typeable, Alter) -- | Represents an identifier with an associated annotation. data Identifier f a = Identifier @@ -259,16 +255,19 @@ data Expression (s :: Stage) :: SynTree where deriving (Generic, Annotated, Alter, Typeable) -- | Represents an import statement in the Fiddle language. -data ImportStatement f a where +data ImportStatement stage f a where ImportStatement :: { -- | The path to import. importPath :: Text, -- | Optional list of imported items. importList :: Maybe (ImportList f a), + + importInterface :: ImportInterface stage, + -- | Annotation for the import statement. importStatementAnnot :: a } -> - ImportStatement f a + ImportStatement stage f a deriving (Generic, Annotated, Alter, Typeable) -- | A list of imported identifiers. @@ -297,7 +296,12 @@ data FiddleDecl :: StagedSynTree where -- | An import declaration. ImportDecl :: { -- | The imported type. - importType :: ImportType stage f a, + importStatement :: ImportStatement stage f a, + + -- | The interface for this imported file. This type depends on the stage + -- of compilation. Initially it's just '()', but will eventually be resolved + -- into a 'UnitInterface'. + -- | Annotation for the import declaration. importDeclAnnot :: a } -> @@ -362,9 +366,7 @@ data FiddleDecl :: StagedSynTree where objectAnnot :: a } -> FiddleDecl stage f a - deriving (Generic, Annotated, Typeable) - -deriving instance (Alter (ImportType stage)) => Alter (FiddleDecl stage) + deriving (Generic, Annotated, Alter, Typeable) -- | Represents the body of an object type, containing a body type (struct or -- union), a list of object declarations, and an annotation. @@ -386,7 +388,7 @@ data ObjType stage f a where -- | An anonymous object type, allowed only in Parsed. AnonymousObjType :: { -- | Witness for stage constraint. - anonWitness :: Witness (stage == Parsed), + anonWitness :: Witness (stage < Expanded), -- | The body of the anonymous type. anonBody :: f (ObjTypeBody stage f a), -- | Annotation for the anonymous type. @@ -573,7 +575,7 @@ data RegisterBitsTypeRef stage f a where -- | An anonymous type for register bits, used in Parsed. RegisterBitsAnonymousType :: { -- | Witness for stage constraint. - anonBitsWitness :: Witness (stage == Parsed), + anonBitsWitness :: Witness (stage < Expanded), -- | The anonymous type. anonBitsType :: AnonymousBitsType stage f a, -- | Annotation for the anonymous type. @@ -667,9 +669,7 @@ data PackageBody (stage :: Stage) (f :: Type -> Type) a where packageBodyAnnot :: a } -> PackageBody stage f a - deriving (Generic, Annotated, Typeable) - -deriving instance (Alter (ImportType stage)) => Alter (PackageBody stage) + deriving (Generic, Annotated, Typeable, Alter) squeeze :: (Alter t, Traversable f, Monad f) => t f a -> f (t Identity a) squeeze = alter (fmap Identity) return |