diff options
Diffstat (limited to 'src/Language/Fiddle/Ast/Internal/Instances.hs')
| -rw-r--r-- | src/Language/Fiddle/Ast/Internal/Instances.hs | 336 |
1 files changed, 279 insertions, 57 deletions
diff --git a/src/Language/Fiddle/Ast/Internal/Instances.hs b/src/Language/Fiddle/Ast/Internal/Instances.hs index c8c606c..2f3707e 100644 --- a/src/Language/Fiddle/Ast/Internal/Instances.hs +++ b/src/Language/Fiddle/Ast/Internal/Instances.hs @@ -15,27 +15,6 @@ import GHC.TypeError as TypeError import Language.Fiddle.Ast.Internal.Kinds import Language.Fiddle.Ast.Internal.Stage --- Type class to easily switch between stages if there is no difference in the --- syntax tree structure between these stages. Can make things much cleaner and --- avoids the boilerplate and bugprone-ness of needing to rote copy everything. -class - (Functor f) => - EasySwitchStage - (t :: Stage -> SynTree) - (f :: Type -> Type) - (fromStage :: Stage) - (toStage :: Stage) - where - switchStage :: t fromStage f a -> t toStage f a - default switchStage :: - ( Generic (t fromStage f a), - Generic (t toStage f a), - GEasySwitchStage (Rep (t fromStage f a)) (Rep (t toStage f a)) - ) => - t fromStage f a -> - t toStage f a - switchStage t = to $ gSwitchStage (from t) - -- Class for walking a syntax tree under the context of a monad and modifying -- the different parts of the SynTree type.. class Alter (t :: SynTree) where @@ -63,6 +42,154 @@ class Alter (t :: SynTree) where m (t f2 a2) alter ffn fn t = to <$> galter (proxyOf t) ffn fn (from t) +-- | '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. +-- +-- This class requires: +-- * A 'StageMonad' for handling monadic actions during the compilation process. +-- * A 'StageFunctor' for traversing the syntax tree. +-- * A 'StageState' to represent local state information during traversal. +class + (Monad (StageMonad stage), Traversable (StageFunctor stage)) => + CompilationStage stage + where + -- | The next stage in the compilation pipeline. + type StageAfter stage :: Stage + + -- | The monadic context for this stage (e.g., 'Compile' or 'Either'). + type StageMonad stage :: Type -> Type + + -- | The state type associated with this stage. This state is designed to be + -- used as a 'local state', meaning any modifications to this state are + -- only visible to child nodes during the traversal. To share state across + -- sibling nodes, use the 'StageMonad'. + type StageState stage :: Type + + -- | The functor used for traversing the syntax tree during this stage. + type StageFunctor stage :: Type -> Type + + -- | The type of annotations associated with nodes in the syntax tree. + type StageAnnotation stage :: Type + +-- | Utility type that captures the structure of a syntax tree node for a given +-- stage. This type alias simplifies references to the full tree structure in +-- other parts of the code. +type TreeType (t :: StagedSynTree) (s :: Stage) = + t s (StageFunctor s) (StageAnnotation s) + +-- | '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 +-- used. +class + (CompilationStage stage) => + AdvanceStage (stage :: Stage) (t :: StagedSynTree) + where + -- | 'advanceStage' transitions a syntax tree node from the current stage to + -- the next stage ('StageAfter stage'). It takes the current local state + -- ('StageState') and the syntax tree node ('TreeType') as input and returns + -- a monadic action that produces the transformed node for the next stage. + -- + -- This function typically performs tree transformations, checks, or other + -- modifications necessary for the compilation process. + -- + -- Parameters: + -- * 'StageState stage' - The local state for this stage of the compiler. + -- This state is only visible to child nodes. Any changes do not affect + -- sibling nodes. + -- * 'TreeType t stage' - The syntax tree node at the current stage. + -- + -- Returns: A monadic action that produces the transformed syntax tree node + -- at the next stage. + advanceStage :: + StageState stage -> -- Local state for the current stage + TreeType t stage -> -- Syntax tree node at the current stage + StageMonad + stage + ( t + (StageAfter stage) -- The next stage in the pipeline + (StageFunctor stage) -- The functor associated with the next stage + (StageAnnotation stage) -- Annotation type for the next stage + ) + + -- | Default implementation of 'advanceStage' using generics. This leverages + -- 'GAdvanceStage' to automatically traverse and transform the syntax tree. + -- If an AST type derives 'Generic', this default can be used to reduce + -- boilerplate code. + -- + -- Before performing the generic transformation with 'gAdvanceStage', the + -- 'modifyState' function is called to potentially alter the local state + -- based on the current node. + -- + -- This implementation is useful for cases where the tree structure remains + -- mostly unchanged between stages, and only the state or annotations need + -- to be adjusted. + default advanceStage :: + ( GAdvanceStage + (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 + (Rep (t (StageAfter stage) (StageFunctor stage) (StageAnnotation stage))), -- Generic representation of the next stage's tree type + Generic (TreeType t stage), -- The current tree type must be an instance of 'Generic' + Generic + ( t + (StageAfter stage) -- The tree type at the next stage + (StageFunctor stage) -- The functor for the next stage + (StageAnnotation stage) -- The annotation type for the next stage + ) + ) => + StageState stage -> -- Local state for the current stage + TreeType t stage -> -- Syntax tree node at the current stage + StageMonad + stage + ( t + (StageAfter stage) -- The tree type for the next stage + (StageFunctor stage) -- The functor for the next stage + (StageAnnotation stage) -- The annotation type for the next stage + ) + advanceStage s t = do + -- 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) + + -- | 'modifyState' allows for changes to the local state ('StageState') before + -- transforming the syntax tree node. This is called on each node during the + -- traversal, allowing the state to be adjusted based on the current node's + -- information. + -- + -- The default implementation simply returns the unchanged state, but it can + -- be overridden to implement custom state modifications. + -- + -- Note: This state modification is local to the current node and its + -- children. Changes to this state are not visible to sibling nodes. If + -- information needs to be shared across siblings, consider using the + -- 'StageMonad' for that purpose. + -- + -- 'modifyState' is only called by the default implementation of + -- advanceStage. If 'advaceStage' is overridden, then overriding this + -- function is superfluous. + -- + -- Parameters: + -- * 'TreeType t stage' - The syntax tree node at the current stage. + -- * 'StageState stage' - The local state for this stage. + -- + -- Returns: A monadic action that produces the (potentially modified) state. + modifyState :: + TreeType t stage -> -- Syntax tree node at the current stage + StageState stage -> -- Local state for the current stage + StageMonad stage (StageState stage) -- The modified local state + modifyState _ = return + +-- | 'GAdvanceStage' is a helper type class that performs the transformation +-- 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) + + -- A syntax tree object is annotated if it has an annotation 'a' as the last -- element. class Annotated (t :: SynTree) where @@ -170,59 +297,154 @@ 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 + +instance (Alter t, Traversable f) => Functor (t f) where + fmap f t = runIdentity (alter return (return . f) t) + +-- | 'GAdvanceStage' instance for metadata wrappers ('M1'). +-- This instance allows advancing the stage of a metadata node in a generic +-- representation. The metadata node ('M1') wraps another node ('s1'), which +-- is recursively advanced to the next stage using 'gAdvanceStage'. instance - (GEasySwitchStage s1 s2) => - GEasySwitchStage (M1 i c s1) (M1 i c s2) + (Monad m, GAdvanceStage s m s1 s2) => + GAdvanceStage s m (M1 i c s1) (M1 i c s2) where - gSwitchStage (M1 a) = M1 (gSwitchStage a) + gAdvanceStage s (M1 a) = M1 <$> gAdvanceStage 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 +-- choice between two alternatives). The sum type can be either 'L1' (left) +-- or 'R1' (right), and 'gAdvanceStage' is called recursively on the selected +-- branch. instance - (GEasySwitchStage l1 l2, GEasySwitchStage r1 r2) => - GEasySwitchStage (l1 :+: r1) (l2 :+: r2) + (Monad m, GAdvanceStage s m l1 l2, GAdvanceStage s m r1 r2) => + GAdvanceStage s m (l1 :+: r1) (l2 :+: r2) where - gSwitchStage (R1 r) = R1 $ gSwitchStage r - gSwitchStage (L1 l) = L1 $ gSwitchStage l + gAdvanceStage s (R1 r) = R1 <$> gAdvanceStage s r + gAdvanceStage s (L1 l) = L1 <$> gAdvanceStage 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 - (GEasySwitchStage l1 l2, GEasySwitchStage r1 r2) => - (GEasySwitchStage (l1 :*: r1) (l2 :*: r2)) + (Monad m, GAdvanceStage s m l1 l2, GAdvanceStage s m r1 r2) => + GAdvanceStage s m (l1 :*: r1) (l2 :*: r2) where - gSwitchStage (l :*: r) = gSwitchStage l :*: gSwitchStage r + gAdvanceStage s (l :*: r) = + (:*:) <$> gAdvanceStage s l <*> gAdvanceStage s r +-- | 'GAdvanceStage' instance for record fields ('Rec0') containing a single +-- AST element ('t') to be advanced. This instance covers the case where the +-- field is an individual AST node that implements 'AdvanceStage'. +-- It advances this node using 'advanceStage'. instance - (EasySwitchStage t f fs ts) => - (GEasySwitchStage (Rec0 (t fs f a)) (Rec0 (t ts f a))) + ( Monad m, + AdvanceStage stage t', + Traversable f, + StageAfter stage ~ stage', + StageMonad stage ~ m, + StageState stage ~ s, + StageFunctor stage ~ f, + StageAnnotation stage ~ a + ) => + GAdvanceStage s m (Rec0 (t' stage f a)) (Rec0 (t' stage' f a)) where - gSwitchStage (K1 val) = K1 (switchStage val) + gAdvanceStage 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 +-- container (e.g., list, 'Maybe') of AST nodes that need to be advanced. +-- Each node in the container is transformed using 'advanceStage'. instance - ( EasySwitchStage t f fs ts, - Functor func + ( Monad m, + AdvanceStage stage t', + Traversable f, + StageAfter stage ~ stage', + StageMonad stage ~ m, + StageState stage ~ s, + StageFunctor stage ~ f, + StageAnnotation stage ~ a, + Traversable func ) => - (GEasySwitchStage (Rec0 (func (t fs f a))) (Rec0 (func (t ts f a)))) + GAdvanceStage s m (Rec0 (func (t' stage f a))) (Rec0 (func (t' stage' f a))) where - gSwitchStage (K1 val) = K1 (switchStage <$> val) - -instance (GEasySwitchStage (Rec0 a) (Rec0 a)) where - gSwitchStage = id + gAdvanceStage 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 +-- is a container ('f') of AST nodes that need to be advanced. Each node in +-- the container is transformed using 'advanceStage'. instance - ( TypeError - ( TypeError.Text "Unable to match type " - :<>: TypeError.ShowType a - :<>: TypeError.Text " with " - :<>: TypeError.ShowType b - ) + ( Monad m, + AdvanceStage stage t', + Traversable f, + StageAfter stage ~ stage', + StageMonad stage ~ m, + StageState stage ~ s, + StageFunctor stage ~ f, + StageAnnotation stage ~ a ) => - (GEasySwitchStage (Rec0 a) (Rec0 b)) + GAdvanceStage s m (Rec0 (f (t' stage f a))) (Rec0 (f (t' stage' f a))) where - gSwitchStage = error "Cannot be called" - -class GEasySwitchStage r1 r2 where - gSwitchStage :: r1 x -> r2 x + gAdvanceStage st (K1 val) = K1 <$> mapM (advanceStage st) val -proxyOf :: t f a -> Proxy t -proxyOf _ = Proxy - -instance (Alter t, Traversable f) => Functor (t f) where - fmap f t = runIdentity (alter return (return . f) t) +-- | '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) |