From 9af1d30c8cd6aef509736e1ecb6e77b47338b98d Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Fri, 11 Oct 2024 13:17:39 -0600 Subject: Prefer GADT's over typ families for some SyntaxTree elements. --- src/Language/Fiddle/Ast/Internal/Instances.hs | 34 +++--- src/Language/Fiddle/Ast/Internal/MetaTypes.hs | 152 +++++++++++++++++++++++++ src/Language/Fiddle/Ast/Internal/Stage.hs | 13 ++- src/Language/Fiddle/Ast/Internal/SyntaxTree.hs | 36 +++--- 4 files changed, 195 insertions(+), 40 deletions(-) create mode 100644 src/Language/Fiddle/Ast/Internal/MetaTypes.hs (limited to 'src/Language/Fiddle/Ast') diff --git a/src/Language/Fiddle/Ast/Internal/Instances.hs b/src/Language/Fiddle/Ast/Internal/Instances.hs index aaa20b8..8222174 100644 --- a/src/Language/Fiddle/Ast/Internal/Instances.hs +++ b/src/Language/Fiddle/Ast/Internal/Instances.hs @@ -84,10 +84,15 @@ class (CompilationStage stage) => StageConvertible stage from to where - convertInStage :: proxy stage -> StageState stage -> from -> StageMonad stage to + convertInStage :: + proxy stage -> + StageAnnotation stage -> + StageState stage -> + from -> + StageMonad stage to instance (CompilationStage s, Applicative (StageMonad s)) => StageConvertible s a a where - convertInStage _ _ = pure + 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 @@ -143,6 +148,7 @@ class (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 + Annotated (t stage), Generic (TreeType t stage), -- The current tree type must be an instance of 'Generic' Generic ( t @@ -168,7 +174,7 @@ class case specific of Nothing -> -- Perform the generic transformation using 'gAdvanceStage' - to <$> gAdvanceStage (Proxy :: Proxy stage) s' (from t) + to <$> gAdvanceStage (Proxy :: Proxy stage) (annot t) s' (from t) Just ast -> return ast -- | 'modifyState' allows for changes to the local state ('StageState') before @@ -238,7 +244,7 @@ class -- default implementation of 'advanceStage' to traverse and modify nodes -- automatically. class GAdvanceStage (stage :: Stage) s m from to where - gAdvanceStage :: Proxy stage -> s -> from x -> m (to x) + gAdvanceStage :: Proxy stage -> StageAnnotation stage -> s -> from x -> m (to x) -- A syntax tree object is annotated if it has an annotation 'a' as the last -- element. @@ -378,7 +384,7 @@ instance (Monad m, GAdvanceStage stage s m s1 s2) => GAdvanceStage stage s m (M1 i c s1) (M1 i c s2) where - gAdvanceStage pxy s (M1 a) = M1 <$> gAdvanceStage pxy s a + gAdvanceStage pxy ant s (M1 a) = M1 <$> gAdvanceStage pxy ant 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 @@ -389,8 +395,8 @@ instance (Monad m, GAdvanceStage stage s m l1 l2, GAdvanceStage stage s m r1 r2) => GAdvanceStage stage s m (l1 :+: r1) (l2 :+: r2) where - gAdvanceStage pxy s (R1 r) = R1 <$> gAdvanceStage pxy s r - gAdvanceStage pxy s (L1 l) = L1 <$> gAdvanceStage pxy s l + gAdvanceStage pxy ant s (R1 r) = R1 <$> gAdvanceStage pxy ant s r + gAdvanceStage pxy ant s (L1 l) = L1 <$> gAdvanceStage pxy ant 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 @@ -400,8 +406,8 @@ instance (Monad m, GAdvanceStage stage s m l1 l2, GAdvanceStage stage s m r1 r2) => GAdvanceStage stage s m (l1 :*: r1) (l2 :*: r2) where - gAdvanceStage pxy s (l :*: r) = - (:*:) <$> gAdvanceStage pxy s l <*> gAdvanceStage pxy s r + gAdvanceStage pxy ant s (l :*: r) = + (:*:) <$> gAdvanceStage pxy ant s l <*> gAdvanceStage pxy ant s r -- | 'GAdvanceStage' instance for record fields ('Rec0') containing a single -- AST element ('t') to be advanced. This instance covers the case where the @@ -419,7 +425,7 @@ instance ) => GAdvanceStage stage s m (Rec0 (t' stage f a)) (Rec0 (t' stage' f a)) where - gAdvanceStage _ st (K1 val) = K1 <$> advanceStage st 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 @@ -438,7 +444,7 @@ instance ) => 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 _ _ 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 @@ -456,14 +462,14 @@ instance ) => 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 _ _ 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 stage s m (Rec0 a) (Rec0 a) where - gAdvanceStage _ _ (K1 val) = return (K1 val) + gAdvanceStage _ _ _ (K1 val) = return (K1 val) -- | 'GAdvanceStage' instance for records which can be converted to eathother -- for the current stage.. @@ -475,4 +481,4 @@ instance ) => GAdvanceStage stage s m (Rec0 a) (Rec0 b) where - gAdvanceStage pxy s (K1 val) = K1 <$> convertInStage pxy s val + gAdvanceStage pxy ant s (K1 val) = K1 <$> convertInStage pxy ant s val diff --git a/src/Language/Fiddle/Ast/Internal/MetaTypes.hs b/src/Language/Fiddle/Ast/Internal/MetaTypes.hs new file mode 100644 index 0000000..7e5e9da --- /dev/null +++ b/src/Language/Fiddle/Ast/Internal/MetaTypes.hs @@ -0,0 +1,152 @@ +-- | This module provides various types and typeclasses useful for +-- type-level meta-programming on the AST (Abstract Syntax Tree). +-- These types enable conditional compilation and transformations +-- based on type-level booleans, typically reflecting different stages +-- of the compilation pipeline. +module Language.Fiddle.Ast.Internal.MetaTypes + ( When (..), -- Conditional type based on a type-level boolean + Witness (..), -- Type constructible if a condition holds + IsIdentity (..), -- Typeclass for unwrapping values from certain functors + toMaybe, -- Function for converting a 'When' to a 'Maybe' + module X, -- Re-exporting some commonly used modules + Guaranteed(..), + guarantee, + ) +where + +import Data.Functor.Identity as X +import Data.List.NonEmpty as X (NonEmpty (..)) +import Data.Maybe (fromMaybe) + +-- | 'IsMaybe' is a typeclass for converting a general functor into a Maybe. +class IsMaybe f where + toMaybe :: f a -> Maybe a + +-- | 'IsIdentity' is a typeclass for extracting a value from +-- a functor that guarantees to contain something. +-- +-- This is used to abstract over different functors where +-- the wrapped value can always be accessed directly. +class (Functor f) => IsIdentity f where + unwrap :: f a -> a + wrap :: a -> f a + +-- | An instance of 'IsIdentity' for 'Identity', which simply +-- unwraps the contained value using 'runIdentity'. +instance IsIdentity Identity where + unwrap = runIdentity + wrap = Identity + +-- | An instance of 'IsIdentity' for 'NonEmpty', which unwraps +-- the first element of the non-empty list. +instance IsIdentity NonEmpty where + unwrap (a :| _) = a + wrap = (:|[]) + +-- | 'Witness' is a type that can only be constructed if the +-- type-level condition 's' is 'True'. It serves as a proof +-- that the condition holds. +-- +-- This is typically used for enabling or disabling parts of +-- the syntax tree based on type-level booleans (e.g., a compilation stage). +data Witness (s :: Bool) where + Witness :: Witness True + +-- | 'When' is a type that either holds nothing (if the type-level +-- condition 's' is 'False') or contains a value of type 't' (if 's' is 'True'). +-- +-- This type is useful for representing optional values at the type level, +-- where the presence of a value is determined by a type-level boolean. +data When (s :: Bool) t where + Vacant :: When False t -- No value present + Present :: t -> When True t -- Value is present + +-- | Instance for converting a 'When' type to a 'Maybe', erasing type-level +-- information about the presence of the value. +instance IsMaybe (When s) where + toMaybe (Present t) = Just t + toMaybe _ = Nothing + +-- | 'Functor' instance for 'When'. If 'When' is 'Present', the function +-- is applied to the value; otherwise, the result is 'Vacant'. +instance Functor (When s) where + fmap _ Vacant = Vacant + fmap fn (Present t) = Present (fn t) + +-- | 'Semigroup' instance for 'When'. If both operands are 'Present', +-- their values are combined using the 'Semigroup' instance of 't'. +-- If both are 'Vacant', the result is 'Vacant'. +instance (Semigroup t) => Semigroup (When s t) where + (<>) (Present t) (Present u) = Present (t <> u) + (<>) Vacant Vacant = Vacant + +-- | 'Foldable' instance for 'When'. If 'When' is 'Present', the +-- contained value is folded using the provided function; otherwise, +-- the result is 'mempty'. +instance Foldable (When s) where + foldMap _ Vacant = mempty + foldMap fn (Present t) = fn t + +-- | 'Traversable' instance for 'When'. If 'When' is 'Present', the +-- function is applied to the contained value, wrapped in an applicative; +-- otherwise, the result is 'pure Vacant'. +instance Traversable (When s) where + traverse _ Vacant = pure Vacant + traverse fn (Present t) = Present <$> fn t + +-- | 'IsIdentity' instance for 'When True', which allows unwrapping the +-- contained value when the type-level condition is 'True'. +instance IsIdentity (When True) where + unwrap (Present t) = t + wrap = Present + +-- | 'Guaranteed' is a type that represents a value of type 't' that may or may +-- not be present, depending on the type-level boolean 's'. When 's' is 'False', +-- the value is optional and represented by a 'Maybe'. When 's' is 'True', the +-- value is guaranteed to be present. +-- +-- This type is useful for expressing conditions where a value is required to +-- exist only when certain compile-time conditions are met. It allows encoding +-- optionality at the type level and transitioning from a potentially missing +-- value to a guaranteed value based on type-level information. +data Guaranteed (s :: Bool) t where + -- | Represents a potentially absent value when the condition 's' is 'False'. + -- The value is wrapped in a 'Maybe', indicating that it may be 'Nothing'. + Perhaps :: Maybe t -> Guaranteed False t + -- | Represents a guaranteed value of type 't' when the condition 's' is 'True'. + -- In this case, the value is always present, and thus 't' is not wrapped + -- in a 'Maybe'. + Guaranteed :: t -> Guaranteed True t + +guarantee :: t -> Guaranteed s t -> Guaranteed True t +guarantee v = Guaranteed . fromMaybe v . toMaybe + +instance Functor (Guaranteed s) where + fmap _ (Perhaps Nothing) = Perhaps Nothing + fmap f (Perhaps (Just t)) = Perhaps (Just (f t)) + fmap f (Guaranteed t) = Guaranteed (f t) + +instance Foldable (Guaranteed s) where + foldMap f (Perhaps m) = foldMap f m + foldMap f (Guaranteed t) = f t + + foldr f acc (Perhaps m) = foldr f acc m + foldr f acc (Guaranteed t) = f t acc + +instance Traversable (Guaranteed s) where + traverse f (Perhaps m) = Perhaps <$> traverse f m + traverse f (Guaranteed t) = Guaranteed <$> f t + +instance (Semigroup t) => Semigroup (Guaranteed s t) where + (Perhaps a) <> (Perhaps b) = Perhaps (a <> b) + (Guaranteed t) <> (Guaranteed u) = Guaranteed (t <> u) + +instance IsMaybe (Guaranteed s) where + toMaybe (Perhaps m) = m + toMaybe (Guaranteed t) = Just t + +-- | 'IsIdentity' instance for 'Guaranteed True' to allow unwrapping the value +-- when it is guaranteed to be present. +instance IsIdentity (Guaranteed True) where + unwrap (Guaranteed t) = t + wrap = Guaranteed diff --git a/src/Language/Fiddle/Ast/Internal/Stage.hs b/src/Language/Fiddle/Ast/Internal/Stage.hs index 985dfae..65459a0 100644 --- a/src/Language/Fiddle/Ast/Internal/Stage.hs +++ b/src/Language/Fiddle/Ast/Internal/Stage.hs @@ -3,11 +3,13 @@ {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneKindSignatures #-} module Language.Fiddle.Ast.Internal.Stage where import Data.Type.Equality import Data.Typeable +import Data.Type.Bool import GHC.TypeLits -- | Represents the different stages of the compilation process. @@ -40,15 +42,20 @@ type family StageToNumber (s :: Stage) :: Natural where type StagePreceeds stage1 stage2 = (CmpStage stage1 stage2 == LT) -type (<) a b = StagePreceeds a b +type (.<) a b = StagePreceeds a b +type (.<=) a b = StagePreceeds a b || (a == b) + -- | A type-level constraint that checks if one compilation stage succeeds another. -- Similar to 'StagePreceeds', it compares the numeric values of stages. -- Returns 'True' if 'stage1' comes after 'stage2'. type StageSucceeds stage1 stage2 = - (CmpStage stage1 stage2 == LT) + (CmpStage stage1 stage2 == GT) + +type (.>) a b = StageSucceeds a b -type (>) a b = StageSucceeds a b +type (.>=) :: Stage -> Stage -> Bool +type (.>=) a b = StageSucceeds a b || (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 9566ab5..66b8e42 100644 --- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs +++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs @@ -9,7 +9,6 @@ module Language.Fiddle.Ast.Internal.SyntaxTree ( -- Type Families NumberType, - ImportInterface, FiddleUnitInterface, QualificationMetadata, CommonQualificationData (..), @@ -64,7 +63,11 @@ import GHC.Generics import Language.Fiddle.Ast.Internal.Instances import Language.Fiddle.Ast.Internal.Kinds import Language.Fiddle.Ast.Internal.Stage +import Language.Fiddle.Ast.Internal.MetaTypes import Language.Fiddle.Internal.UnitInterface +import Data.Type.Equality +import GHC.TypeError as TypeError +import GHC.TypeLits -- | Common data for each qualified element. newtype CommonQualificationData @@ -80,37 +83,24 @@ type BitsOffset stage = RegisterOffset stage -- stage, which will attach the appropriate offset to the register. This helps -- backends so they don't have to recalculate this offset. type family RegisterOffset stage where - RegisterOffset stage = If (stage < Checked) () Word32 + RegisterOffset stage = If (stage .< Checked) () Word32 -- | Type which stores metadata after qualification. Before qualification, this -- metadata has not been calculated and so is unset. type family QualificationMetadata stage t where QualificationMetadata stage t = - If (stage < Qualified) () t + If (stage .< Qualified) () t -- | The type attached to import statements which describe the imported file's -- unit interface type family FiddleUnitInterface (s :: Stage) :: Type where - FiddleUnitInterface s = If (s < Checked) () UnitInterface + FiddleUnitInterface s = If (s .< Checked) () UnitInterface -- | 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 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 type which is only constructible if the type-level condition 's' holds. --- --- This type is used as a way to enable/disable parts of the syntax tree based --- on type level booleans (typically incorporating the compilation 'stage') -data Witness (s :: Bool) where - Witness :: Witness True + NumberType s = If (s .< Expanded) Text Integer -- A Name is multiple identifiers separated by dots. It's the way of namespaces -- to different packages. @@ -249,7 +239,7 @@ data FiddleUnit (stage :: Stage) (f :: Type -> Type) a where FiddleUnit :: { -- | The interface for this FiddleUnit. Early on, this is just () because -- not enough information is provided to determine the interface.. - fiddleUnitInterface :: FiddleUnitInterface stage, + fiddleUnitInterface :: When (stage == Checked) UnitInterface, -- | List of declarations. fiddleDecls :: [Directed FiddleDecl stage f a], -- | Annotation for the 'FiddleUnit'. @@ -294,7 +284,7 @@ data ImportStatement stage f a where importPath :: Text, -- | Optional list of imported items. importList :: Maybe (ImportList f a), - importInterface :: ImportInterface stage, + importInterface :: When (stage .>= ImportsResolved) UnitInterface, -- | Annotation for the import statement. importStatementAnnot :: a } -> @@ -433,7 +423,7 @@ data ObjType stage f a where -- | An anonymous object type, allowed only in Parsed. AnonymousObjType :: { -- | Witness for stage constraint. - disableAnonymousTypesAfterExpansion :: Witness (stage < Expanded), + disableAnonymousTypesAfterExpansion :: Witness (stage .< Expanded), -- | The body of the anonymous type. anonBody :: f (ObjTypeBody stage f a), -- | Annotation for the anonymous type. @@ -467,7 +457,7 @@ data ObjTypeDecl stage f a where -- | An assertion statement for a specific position. AssertPosStatement :: { -- | Witness for stage constraint. - disableAssertStatementsAfterConsistencyCheck :: Witness (stage < Checked), + disableAssertStatementsAfterConsistencyCheck :: Witness (stage .< Checked), -- | The expression for the assertion. assertExpr :: Expression stage f a, -- | Annotation for the assertion. @@ -629,7 +619,7 @@ data RegisterBitsTypeRef stage f a where -- | An anonymous type for register bits, used in Parsed. RegisterBitsAnonymousType :: { -- | Witness for stage constraint. - disableAnonymousBitsAfterExpansion :: Witness (stage < Expanded), + disableAnonymousBitsAfterExpansion :: Witness (stage .< Expanded), -- | The anonymous type. anonBitsType :: AnonymousBitsType stage f a, -- | Annotation for the anonymous type. -- cgit