diff options
Diffstat (limited to 'src/Language/Fiddle/Ast')
| -rw-r--r-- | src/Language/Fiddle/Ast/Internal/Instances.hs | 56 | ||||
| -rw-r--r-- | src/Language/Fiddle/Ast/Internal/SyntaxTree.hs | 10 |
2 files changed, 60 insertions, 6 deletions
diff --git a/src/Language/Fiddle/Ast/Internal/Instances.hs b/src/Language/Fiddle/Ast/Internal/Instances.hs index c9c3455..379c788 100644 --- a/src/Language/Fiddle/Ast/Internal/Instances.hs +++ b/src/Language/Fiddle/Ast/Internal/Instances.hs @@ -6,7 +6,7 @@ module Language.Fiddle.Ast.Internal.Instances AdvanceStage (..), CompilationStage (..), Annotated (..), - GAnnot (..) + GAnnot (..), ) where @@ -168,8 +168,13 @@ class 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 (Proxy :: Proxy stage) s' (from t) + specific <- customAdvanceStage t s + + case specific of + Nothing -> + -- Perform the generic transformation using 'gAdvanceStage' + to <$> gAdvanceStage (Proxy :: Proxy stage) s' (from t) + Just ast -> return ast -- | 'modifyState' allows for changes to the local state ('StageState') before -- transforming the syntax tree node. This is called on each node during the @@ -199,6 +204,40 @@ class StageMonad stage (StageState stage) -- The modified local state modifyState _ = return + -- \| An optional method that allows for partial customization of the + -- 'advanceStage' process. This method can be used to handle specific cases + -- in the input without requiring the implementer to redefine 'advanceStage' + -- for the entire structure. If this method returns 'Nothing', the default + -- generic implementation of 'advanceStage' is used. + -- + -- This method is useful when only certain conditions or patterns in the + -- syntax tree need special handling during the stage transition. Implementers + -- can focus on those specific conditions and leave the remaining cases to the + -- generic traversal. + -- + -- Parameters: + -- - 'StageState stage': The local state for the current stage. + -- - 'TreeType t stage': The syntax tree node at the current stage. + -- + -- Returns: + -- - 'StageMonad stage (Maybe (t (StageAfter stage) (StageFunctor stage) + -- (StageAnnotation stage)))': A monadic computation that either returns + -- 'Just' the transformed tree node for the next stage, or 'Nothing' to + -- continue with the default generic implementation. + customAdvanceStage :: + TreeType t stage -> -- Syntax tree node at the current stage + StageState stage -> -- Local state for the current stage + StageMonad + stage + ( Maybe + ( t + (StageAfter stage) -- The next stage in the pipeline + (StageFunctor stage) -- Functor associated with the next stage + (StageAnnotation stage) -- Annotation type for the next stage + ) + ) + customAdvanceStage _ _ = return Nothing + -- | '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 @@ -210,9 +249,14 @@ class GAdvanceStage (stage :: Stage) s m from to where -- element. class Annotated (t :: SynTree) where annot :: t f a -> a + setAnnot :: (a -> a) -> t f a -> t f a + default annot :: (Generic (t f a), GAnnot a (Rep (t f a))) => t f a -> a annot t = gannot (from t) + default setAnnot :: (Generic (t f a), GAnnot a (Rep (t f a))) => (a -> a) -> t f a -> t f a + setAnnot f t = to $ gsetAnnot f (from t) + -- Generic implementations of common typeclass for SyntaxTrees. -- -- This is where we try to hide the pig behind the curtain. @@ -299,19 +343,25 @@ instance class GAnnot a r where gannot :: r x -> a + gsetAnnot :: (a -> a) -> r x -> r x instance GAnnot a (Rec0 a) where gannot = unK1 + gsetAnnot fn (K1 t) = K1 (fn t) instance (GAnnot a r) => GAnnot a (l :*: r) where gannot (_ :*: r) = gannot r + gsetAnnot fn (l :*: r) = l :*: gsetAnnot fn r instance (GAnnot a r, GAnnot a l) => GAnnot a (l :+: r) where gannot (R1 r) = gannot r gannot (L1 l) = gannot l + gsetAnnot fn (R1 r) = R1 (gsetAnnot fn r) + gsetAnnot fn (L1 l) = L1 (gsetAnnot fn l) instance (GAnnot a r) => GAnnot a (M1 i c r) where gannot (M1 a) = gannot a + gsetAnnot fn (M1 a) = M1 (gsetAnnot fn a) proxyOf :: t f a -> Proxy t proxyOf _ = Proxy diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs index 706a178..8eb8c8e 100644 --- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs +++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs @@ -10,6 +10,7 @@ module Language.Fiddle.Ast.Internal.SyntaxTree ( -- Type Families NumberType, ImportInterface, + FiddleUnitInterface, -- Witness Types Witness (..), WitnessType, @@ -41,6 +42,7 @@ module Language.Fiddle.Ast.Internal.SyntaxTree EnumBody (..), EnumConstantDecl (..), PackageBody (..), + TreeType (..), -- Helper Functions mapDirected, mapDirectedM, @@ -71,6 +73,8 @@ import Language.Fiddle.Ast.Internal.Kinds import Language.Fiddle.Ast.Internal.Stage import Language.Fiddle.Internal.UnitInterface (UnitInterface) +type TreeType t stage = t stage (StageFunctor stage) (StageAnnotation stage) + type family FiddleUnitInterface (s :: Stage) :: Type where FiddleUnitInterface s = If (s < Checked) () UnitInterface @@ -233,11 +237,11 @@ undirected (Directed _ tfa _) = tfa -- | The root of the parse tree, containing a list of top-level declarations. data FiddleUnit (stage :: Stage) (f :: Type -> Type) a where FiddleUnit :: - { -- | List of declarations. - fiddleDecls :: [Directed FiddleDecl stage f a], - -- | The interface for this FiddleUnit. Early on, this is just () because + { -- | The interface for this FiddleUnit. Early on, this is just () because -- not enough information is provided to determine the interface.. fiddleUnitInterface :: FiddleUnitInterface stage, + -- | List of declarations. + fiddleDecls :: [Directed FiddleDecl stage f a], -- | Annotation for the 'FiddleUnit'. fiddleUnitAnnot :: a } -> |