diff options
author | Josh Rahm <joshuarahm@gmail.com> | 2024-09-27 16:20:32 -0600 |
---|---|---|
committer | Josh Rahm <joshuarahm@gmail.com> | 2024-09-27 16:24:10 -0600 |
commit | 21e6e5940ecb462436b8dc94428c5cee5cdc9072 (patch) | |
tree | 01405c637f904f24feadc177a84ab9bae7c8c99c | |
parent | a4cffc1eeb547f780068875a703251db6aa41d6c (diff) | |
download | fiddle-21e6e5940ecb462436b8dc94428c5cee5cdc9072.tar.gz fiddle-21e6e5940ecb462436b8dc94428c5cee5cdc9072.tar.bz2 fiddle-21e6e5940ecb462436b8dc94428c5cee5cdc9072.zip |
Add import resolution phase and also add a more abstractions around
compliation phases.
-rw-r--r-- | package.yaml | 14 | ||||
-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 | ||||
-rw-r--r-- | src/Language/Fiddle/Compiler.hs | 109 | ||||
-rw-r--r-- | src/Language/Fiddle/Compiler/ConsistencyCheck.hs | 23 | ||||
-rw-r--r-- | src/Language/Fiddle/Compiler/Expansion.hs | 62 | ||||
-rw-r--r-- | src/Language/Fiddle/Compiler/ImportResolution.hs | 123 | ||||
-rw-r--r-- | src/Language/Fiddle/GenericTree.hs | 9 | ||||
-rw-r--r-- | src/Language/Fiddle/Internal/Scopes.hs | 2 | ||||
-rw-r--r-- | src/Language/Fiddle/Internal/UnitInterface.hs | 34 | ||||
-rw-r--r-- | src/Language/Fiddle/Parser.hs | 6 | ||||
-rw-r--r-- | src/Main.hs | 56 |
13 files changed, 450 insertions, 188 deletions
diff --git a/package.yaml b/package.yaml index 56f6ffd..34c255e 100644 --- a/package.yaml +++ b/package.yaml @@ -8,21 +8,29 @@ executables: ghc-options: - -XBangPatterns + - -XConstraintKinds - -XDataKinds + - -XDefaultSignatures + - -XDeriveAnyClass + - -XDeriveFunctor + - -XDeriveGeneric - -XFlexibleContexts - -XFlexibleInstances - -XGADTs + - -XIncoherentInstances - -XKindSignatures + - -XLambdaCase - -XMultiParamTypeClasses - -XPolyKinds - -XRankNTypes - - -XGeneralizedNewtypeDeriving + - -XScopedTypeVariables - -XStandaloneDeriving + - -XStrictData - -XTupleSections - -XTypeFamilies + - -XTypeOperators + - -XUndecidableInstances - -XViewPatterns - - -XLambdaCase - - -XStrictData dependencies: - base >= 4.0.0 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 diff --git a/src/Language/Fiddle/Compiler.hs b/src/Language/Fiddle/Compiler.hs index 768c569..0fe277f 100644 --- a/src/Language/Fiddle/Compiler.hs +++ b/src/Language/Fiddle/Compiler.hs @@ -1,6 +1,24 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- Compilation monad. Has diagnostics. Optionally produces a value. +-- newtype Compile s a = Compile (s -> (s, [Diagnostic], Maybe a)) +-- Runs a sub-compilation routine with the given state, but discards the +-- resulting state in favor of the original state. +-- mapMaybeT (mapRWS (\(a, _, w) -> (a, s', w))) mtrws +-- Saves the state, runs the routine, then restores the state. +-- Runs a compilation routine. It produces diagnostics and maybe a result. +-- Generally if the diagnostics contain an error, the result will be Nothing, +-- but if only Warnings are generated, then Just something will be returned. +-- +-- Note that there is no actual type-level mechanism restricting this function +-- from returning something even if the diagnostics contain errors, but it +-- generally wouldn't make much sense for this to be the case. +{-# LANGUAGE RankNTypes #-} + module Language.Fiddle.Compiler where import Control.Monad (when) +import Control.Monad.Identity (Identity) import Control.Monad.RWS (RWS, RWST, evalRWS, mapRWS, runRWS) import Control.Monad.State import Control.Monad.Trans.Maybe @@ -8,18 +26,15 @@ import Control.Monad.Writer import Data.Default import Language.Fiddle.Ast import Language.Fiddle.Types -import Text.Parsec (SourcePos, sourceColumn, sourceLine, sourceName) import System.IO (hPutStrLn, stderr) +import Text.Parsec (SourcePos, sourceColumn, sourceLine, sourceName) data Level = Error | Warning | Info data Diagnostic = Diagnostic Level String SourceSpan --- Compilation monad. Has diagnostics. Optionally produces a value. --- newtype Compile s a = Compile (s -> (s, [Diagnostic], Maybe a)) - newtype Compile s a = Compile (MaybeT (RWS () [Diagnostic] s) a) - deriving (Functor, Applicative, Monad) + deriving newtype (Functor, Applicative, Monad) compilationFailure :: Compile s a compilationFailure = Compile $ MaybeT (return Nothing) @@ -34,29 +49,17 @@ instance MonadState s (Compile s) where put s = Compile $ put s state fn = Compile $ state fn --- Runs a sub-compilation routine with the given state, but discards the --- resulting state in favor of the original state. subCompile :: s' -> Compile s' a -> Compile s (s', a) subCompile s' (Compile mtrws) = Compile $ do let (a, s, w) = runRWS (runMaybeT mtrws) () s' tell w MaybeT $ return $ fmap (s,) a --- mapMaybeT (mapRWS (\(a, _, w) -> (a, s', w))) mtrws - --- Saves the state, runs the routine, then restores the state. pushState :: Compile s a -> Compile s a pushState cp = do s <- get snd <$> subCompile s cp --- Runs a compilation routine. It produces diagnostics and maybe a result. --- Generally if the diagnostics contain an error, the result will be Nothing, --- but if only Warnings are generated, then Just something will be returned. --- --- Note that there is no actual type-level mechanism restricting this function --- from returning something even if the diagnostics contain errors, but it --- generally wouldn't make much sense for this to be the case. compile :: Compile s a -> s -> ([Diagnostic], Maybe a) compile (Compile fn) initState = do let (a, _, w) = runRWS (runMaybeT fn) () initState in (w, a) @@ -104,3 +107,75 @@ fromMayberOrFail sourceSpan err Nothing = do tell [Diagnostic Error err sourceSpan] compilationFailure fromMayberOrFail _ _ (Just a) = return a + +-- | 'CompilationPhase' represents a phase in the compilation process. +-- It consists of an IO action that performs necessary side effects or state +-- preparations before the next stage, and a function that transforms the +-- 'FiddleUnit' from the current stage to the next. +data CompilationPhase stageFrom stageTo where + CompilationPhase :: + forall privateState stageFrom stageTo. + (CompilationStage stageFrom) => + { -- | 'ioAction' is an IO operation that runs after the ast is parsed. It + -- takes the parsed 'FiddleUnit' and performs some side effect + -- returning a private state that is passed to 'nextStage'. This is the + -- only time a side effect may be performed. + ioAction :: + FiddleUnit Parsed (StageFunctor Parsed) (StageAnnotation Parsed) -> + IO privateState, + -- | 'nextStage' is the function that transforms a 'FiddleUnit' from + -- the current stage ('stageFrom') to the next stage ('stageTo'). It + -- uses the private state obtained from 'ioAction' and outputs a + -- potentially updated 'FiddleUnit' in the compilation pipeline. + nextStage :: + privateState -> + FiddleUnit + stageFrom + (StageFunctor stageFrom) + (StageAnnotation stageFrom) -> + Compile + () + ( FiddleUnit + stageTo + (StageFunctor stageTo) + (StageAnnotation stageTo) + ) + } -> + CompilationPhase stageFrom stageTo + +-- | 'thenPhase' composes two 'CompilationPhase' stages into a single pipeline +-- phase. It combines their IO actions and applies each stage in sequence. +thenPhase :: + CompilationPhase stage1 stage2 -> + CompilationPhase stage2 stage3 -> + CompilationPhase stage1 stage3 +thenPhase + (CompilationPhase ioAction1 compile1) + (CompilationPhase ioAction2 compile2) = + CompilationPhase + (\unit -> (,) <$> ioAction1 unit <*> ioAction2 unit) + ( \(s1, s2) firstStage -> do + secondStage <- compile1 s1 firstStage + compile2 s2 secondStage + ) + +-- | Infix operator for 'thenPhase' to chain compilation phases. +(>>>) :: CompilationPhase stage1 stage2 -> CompilationPhase stage2 stage3 -> CompilationPhase stage1 stage3 +(>>>) = thenPhase + +-- | 'execCompilationPipeline' executes a full compilation pipeline starting +-- from the 'Parsed' phase. It performs the IO action of the first phase and +-- then invokes the compilation function for the remaining stages. It returns +-- a tuple containing diagnostics and an optional final 'FiddleUnit'. +execCompilationPipeline :: + CompilationPhase Parsed s' -> + FiddleUnit Parsed (StageFunctor Parsed) (StageAnnotation Parsed) -> + IO + ( [Diagnostic], + Maybe + ( FiddleUnit s' (StageFunctor s') (StageAnnotation s') + ) + ) +execCompilationPipeline (CompilationPhase ioAction rest) ast = do + s <- ioAction ast + return $ compile_ $ rest s ast diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs index 90f4aa4..4c708f7 100644 --- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs +++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs @@ -5,7 +5,11 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Language.Fiddle.Compiler.ConsistencyCheck (checkConsistency) where +module Language.Fiddle.Compiler.ConsistencyCheck + ( checkConsistency, + consistencyCheckPhase, + ) +where import Control.Monad (forM, forM_, unless, when) import Control.Monad.Identity (Identity (Identity)) @@ -22,7 +26,10 @@ import qualified Data.Map as Map import Data.Maybe (fromMaybe) import qualified Data.Set as Set import qualified Data.Text as Text +import Data.Void import Data.Word (Word32) +import GHC.TypeError as TypeError +import GHC.TypeLits import Language.Fiddle.Ast import Language.Fiddle.Compiler import Language.Fiddle.Internal.Scopes @@ -44,6 +51,11 @@ type SizeBits = Word32 type SizeBytes = Word32 +consistencyCheckPhase :: + CompilationPhase Expanded Checked +consistencyCheckPhase = + CompilationPhase (const $ return ()) (\() -> checkConsistency) + checkConsistency :: FiddleUnit Expanded I Annot -> Compile () (FiddleUnit Checked I Annot) @@ -52,6 +64,13 @@ checkConsistency = . subCompile (GlobalState mempty) . advanceStage (LocalState mempty) +instance CompilationStage Checked where + type StageAfter Checked = TypeError (TypeError.Text "No stage after Checked") + type StageMonad Checked = Compile GlobalState + type StageState Checked = LocalState + type StageFunctor Checked = Identity + type StageAnnotation Checked = Commented SourceSpan + instance CompilationStage Expanded where type StageAfter Expanded = Checked type StageMonad Expanded = Compile GlobalState @@ -81,6 +100,8 @@ deriving instance AdvanceStage Expanded EnumConstantDecl deriving instance AdvanceStage Expanded PackageBody +deriving instance AdvanceStage Expanded ImportStatement + deriving instance (AdvanceStage Expanded t) => AdvanceStage Expanded (Directed t) instance AdvanceStage Expanded RegisterBody where diff --git a/src/Language/Fiddle/Compiler/Expansion.hs b/src/Language/Fiddle/Compiler/Expansion.hs index 8cfd0f0..77ccf6c 100644 --- a/src/Language/Fiddle/Compiler/Expansion.hs +++ b/src/Language/Fiddle/Compiler/Expansion.hs @@ -4,7 +4,7 @@ {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE UndecidableInstances #-} -module Language.Fiddle.Compiler.Expansion (expandAst) where +module Language.Fiddle.Compiler.Expansion (expandAst, expansionPhase) where import Control.Monad.Identity (Identity (..)) import Control.Monad.State (get, gets, modify, put) @@ -18,23 +18,29 @@ import Debug.Trace import GHC.TypeLits import Language.Fiddle.Ast import Language.Fiddle.Compiler +import Language.Fiddle.Compiler.ConsistencyCheck import Language.Fiddle.Types import Text.Printf (printf) +type M = Compile State + type Annot = Commented SourceSpan +type CurrentStage = ImportsResolved + newtype Path = Path [PathExpression] newtype PathExpression = PathExpression String -type M = Compile State - joinPath :: Path -> String joinPath (Path l) = intercalate "#" $ reverse (map (\(PathExpression s) -> s) l) -expandAst :: FiddleUnit Parsed I Annot -> Compile () (FiddleUnit Expanded I Annot) +expandAst :: FiddleUnit CurrentStage I Annot -> Compile () (FiddleUnit Expanded I Annot) expandAst = fmap snd . subCompile (State [] []) . advanceStage (Path mempty) +expansionPhase :: CompilationPhase CurrentStage Expanded +expansionPhase = CompilationPhase (const $ return ()) (\() -> expandAst) + -- Shorthand for Identity type I = Identity @@ -47,41 +53,43 @@ data State -- Anonymous enum bodies that need to be re-linked ![(Linkage, AnonymousBitsType Expanded I Annot)] -instance CompilationStage Parsed where - type StageAfter Parsed = Expanded - type StageMonad Parsed = M - type StageState Parsed = Path - type StageFunctor Parsed = Identity - type StageAnnotation Parsed = Annot +instance CompilationStage CurrentStage where + type StageAfter CurrentStage = Expanded + type StageMonad CurrentStage = M + type StageState CurrentStage = Path + type StageFunctor CurrentStage = Identity + type StageAnnotation CurrentStage = Annot + +deriving instance AdvanceStage CurrentStage ObjTypeBody -deriving instance AdvanceStage Parsed ObjTypeBody +deriving instance AdvanceStage CurrentStage DeferredRegisterBody -deriving instance AdvanceStage Parsed DeferredRegisterBody +deriving instance AdvanceStage CurrentStage RegisterBody -deriving instance AdvanceStage Parsed RegisterBody +deriving instance AdvanceStage CurrentStage AnonymousBitsType -deriving instance AdvanceStage Parsed AnonymousBitsType +deriving instance AdvanceStage CurrentStage ImportStatement -deriving instance AdvanceStage Parsed BitType +deriving instance AdvanceStage CurrentStage BitType -deriving instance AdvanceStage Parsed EnumBody +deriving instance AdvanceStage CurrentStage EnumBody -deriving instance AdvanceStage Parsed EnumConstantDecl +deriving instance AdvanceStage CurrentStage EnumConstantDecl -deriving instance (AdvanceStage Parsed t) => AdvanceStage Parsed (Directed t) +deriving instance (AdvanceStage CurrentStage t) => AdvanceStage CurrentStage (Directed t) -instance AdvanceStage Parsed RegisterBitsDecl where +instance AdvanceStage CurrentStage RegisterBitsDecl where modifyState t = return . case t of DefinedBits {definedBitsIdent = i} -> pushId i _ -> id -instance AdvanceStage Parsed PackageBody where +instance AdvanceStage CurrentStage PackageBody where advanceStage p (PackageBody decls a) = PackageBody <$> reconfigureFiddleDecls p decls <*> pure a -instance AdvanceStage Parsed ObjTypeDecl where +instance AdvanceStage CurrentStage ObjTypeDecl where modifyState t = return . case t of @@ -89,7 +97,7 @@ instance AdvanceStage Parsed ObjTypeDecl where RegisterDecl {regIdent = (Just n)} -> pushId n _ -> id -instance AdvanceStage Parsed FiddleDecl where +instance AdvanceStage CurrentStage FiddleDecl where modifyState t = return . case t of @@ -99,16 +107,16 @@ instance AdvanceStage Parsed FiddleDecl where ObjectDecl {objectIdent = i} -> pushId i _ -> id -instance AdvanceStage Parsed FiddleUnit where +instance AdvanceStage CurrentStage FiddleUnit where advanceStage path (FiddleUnit decls a) = FiddleUnit <$> reconfigureFiddleDecls path decls <*> pure a -instance AdvanceStage Parsed Expression where +instance AdvanceStage CurrentStage Expression where advanceStage _ = \case (Var i a) -> return $ Var i a (LitNum t a) -> LitNum <$> parseNum (unCommented a) t <*> pure a -instance AdvanceStage Parsed RegisterBitsTypeRef where +instance AdvanceStage CurrentStage RegisterBitsTypeRef where advanceStage path = \case RegisterBitsArray typeref expr annot -> RegisterBitsArray @@ -127,7 +135,7 @@ instance AdvanceStage Parsed RegisterBitsTypeRef where =<< advanceStage path anonType return $ RegisterBitsReference (identToName ident) annot -instance AdvanceStage Parsed ObjType where +instance AdvanceStage CurrentStage ObjType where advanceStage path = \case (AnonymousObjType _ (Identity body) annot) -> do body' <- advanceStage path body @@ -176,7 +184,7 @@ parseNum span txt = fromMayberOrFail span "Unable to parse number" $ reconfigureFiddleDecls :: Path -> - [Directed FiddleDecl Parsed I Annot] -> + [Directed FiddleDecl CurrentStage I Annot] -> M [Directed FiddleDecl Expanded I Annot] reconfigureFiddleDecls p decls = do lastState <- get diff --git a/src/Language/Fiddle/Compiler/ImportResolution.hs b/src/Language/Fiddle/Compiler/ImportResolution.hs new file mode 100644 index 0000000..b4c5293 --- /dev/null +++ b/src/Language/Fiddle/Compiler/ImportResolution.hs @@ -0,0 +1,123 @@ +module Language.Fiddle.Compiler.ImportResolution + ( resolveImports, + getImportResolutionState, + ImportResolutionOptions (..), + importResolutionPhase, + ) +where + +import Control.Monad.Identity (Identity) +import Control.Monad.Writer.Lazy (MonadWriter (tell)) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Language.Fiddle.Ast +import Language.Fiddle.Ast.FileInterface (ResolvedImport) +import Language.Fiddle.Compiler +import Language.Fiddle.Compiler.Expansion +import Language.Fiddle.Internal.UnitInterface +import Language.Fiddle.Types +import Text.Printf (printf) + +type GlobalState = () + +type LocalState = ResolvedImports + +type M = Compile GlobalState + +type Annot = Commented SourceSpan + +data ImportError = ImportError Text (Maybe SourceSpan) + deriving (Show) + +newtype ResolvedImports = ResolvedImports + { importMap :: Map Text (Either ImportError UnitInterface) + } + +type CurrentStage = Parsed + +type I = Identity + +instance CompilationStage CurrentStage where + type StageAfter CurrentStage = ImportsResolved + type StageMonad CurrentStage = M + type StageState CurrentStage = LocalState + type StageFunctor CurrentStage = Identity + type StageAnnotation CurrentStage = Annot + +importResolutionPhase :: + ImportResolutionOptions -> + CompilationPhase CurrentStage ImportsResolved +importResolutionPhase opts = + CompilationPhase + (getImportResolutionState opts) + resolveImports + +resolveImports :: + ResolvedImports -> + FiddleUnit CurrentStage I Annot -> + Compile () (FiddleUnit ImportsResolved I Annot) +resolveImports = advanceStage + +deriving instance AdvanceStage CurrentStage ObjTypeBody + +deriving instance AdvanceStage CurrentStage DeferredRegisterBody + +deriving instance AdvanceStage CurrentStage RegisterBody + +deriving instance AdvanceStage CurrentStage AnonymousBitsType + +deriving instance AdvanceStage CurrentStage BitType + +deriving instance AdvanceStage CurrentStage EnumBody + +deriving instance AdvanceStage CurrentStage EnumConstantDecl + +deriving instance AdvanceStage CurrentStage RegisterBitsDecl + +deriving instance AdvanceStage CurrentStage PackageBody + +deriving instance AdvanceStage CurrentStage ObjTypeDecl + +deriving instance AdvanceStage CurrentStage FiddleUnit + +deriving instance AdvanceStage CurrentStage Expression + +deriving instance AdvanceStage CurrentStage RegisterBitsTypeRef + +deriving instance AdvanceStage CurrentStage ObjType + +deriving instance (AdvanceStage CurrentStage t) => AdvanceStage CurrentStage (Directed t) + +deriving instance AdvanceStage CurrentStage FiddleDecl + +diagnosticError :: String -> Annot -> Compile a () +diagnosticError str a = tell [Diagnostic Error str (unCommented a)] + +instance AdvanceStage CurrentStage ImportStatement where + advanceStage s (ImportStatement path list _ a) = do + let what = Map.lookup path (importMap s) + empty = UnitInterface mempty mempty + + v <- case what of + Nothing -> do + diagnosticError "Failed to lookup imports (This is a bug)" a + return empty + Just (Left err) -> do + diagnosticError (printf "Error in import %s: %s" path (show err)) a + return empty + Just (Right val) -> return val + + return $ ImportStatement path list v a + +newtype ImportResolutionOptions + = ImportResolutionOptions + { searchPath :: [FilePath] + } + +getImportResolutionState :: + ImportResolutionOptions -> + FiddleUnit CurrentStage Identity Annot -> + IO ResolvedImports +getImportResolutionState _ _ = return (ResolvedImports mempty) diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs index 031f6ab..ef53e31 100644 --- a/src/Language/Fiddle/GenericTree.hs +++ b/src/Language/Fiddle/GenericTree.hs @@ -32,9 +32,8 @@ import Text.Printf (printf) type Context stage = ( Show (NumberType stage), Typeable stage, - ToGenericSyntaxTree (ImportType stage), - Typeable (ImportType stage), - ToGenericSyntaxTreeValue (NumberType stage) + ToGenericSyntaxTreeValue (NumberType stage), + Show (ImportInterface stage) ) data GenericSyntaxTree f a where @@ -124,7 +123,7 @@ class ToGenericSyntaxTreeValue v where instance ToGenericSyntaxTreeValue Data.Text.Text where toGenericSyntaxTreeValue = Just . SyntaxTreeValue . Data.Text.unpack -instance (Show s, Num s) => ToGenericSyntaxTreeValue s where +instance (Show s) => ToGenericSyntaxTreeValue s where toGenericSyntaxTreeValue = Just . SyntaxTreeValue . show -- Witnesses exist just for type level meta programming, don't return anything @@ -228,7 +227,7 @@ deriving instance (ToGenericSyntaxTree DirectiveExpression) deriving instance (ToGenericSyntaxTree ImportList) -deriving instance (ToGenericSyntaxTree ImportStatement) +deriving instance (Context stage) => (ToGenericSyntaxTree (ImportStatement stage)) deriving instance (Context stage, ToGenericSyntaxTree (t stage), Typeable t) => diff --git a/src/Language/Fiddle/Internal/Scopes.hs b/src/Language/Fiddle/Internal/Scopes.hs index 302eab2..83ea144 100644 --- a/src/Language/Fiddle/Internal/Scopes.hs +++ b/src/Language/Fiddle/Internal/Scopes.hs @@ -14,6 +14,7 @@ data Scope k v = Scope { subScopes :: Map k (Scope k v), -- Nested sub-scopes scopeValues :: Map k v -- Values stored in the current scope } + deriving (Eq, Ord, Show, Read) -- | 'ScopePath' keeps track of the current scope path as a list of keys, -- and also includes any additional paths (like imported modules or @@ -22,6 +23,7 @@ data ScopePath k = ScopePath { currentScope :: [k], -- Current path within the scope hierarchy usingPaths :: [[k]] -- Additional paths for resolving symbols } + deriving (Eq, Ord, Show, Read) -- | The 'Semigroup' instance for 'Scope' allows combining two scopes, -- where sub-scopes and values are merged together. diff --git a/src/Language/Fiddle/Internal/UnitInterface.hs b/src/Language/Fiddle/Internal/UnitInterface.hs new file mode 100644 index 0000000..1f12c4c --- /dev/null +++ b/src/Language/Fiddle/Internal/UnitInterface.hs @@ -0,0 +1,34 @@ +module Language.Fiddle.Internal.UnitInterface where + +import Data.Text +import Data.Word +import Language.Fiddle.Internal.Scopes (Scope) +import Language.Fiddle.Types (SourceSpan) + +data Annotated a = Annotated + { sourceSpan :: SourceSpan, + docComment :: Text, + internal :: a + } + deriving (Eq, Ord, Show) + +-- | Contains a datastructure which represents a FiddleUnit. +-- +-- These datastructures contain the exported symobls of a fiddle unit and it's +-- direct dependencies. +data UnitInterface where + UnitInterface :: + { rootScope :: Scope String (Annotated ExportedValue), + dependencies :: [FilePath] + } -> + UnitInterface + deriving (Eq, Ord, Show) + +data ExportedValue where + ExportedBitsType :: + {exportBitsTypeSize :: Word32} -> + ExportedValue + ExportedObjType :: + {exportObjTypeSize :: Word32} -> + ExportedValue + deriving (Show, Eq, Ord) diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs index b3ed09a..d41cc64 100644 --- a/src/Language/Fiddle/Parser.hs +++ b/src/Language/Fiddle/Parser.hs @@ -59,7 +59,7 @@ directedP subparser = withMeta $ do directiveP :: PaS Directive directiveP = withMeta $ - Directive <$> defer directiveBodyTokens directiveBodyP + Directive <$> defer directiveBodyTokens directiveBodyP directiveBodyP :: PaS DirectiveBody directiveBodyP = withMeta $ do @@ -122,10 +122,10 @@ importListP = withMeta $ do <$> many (ident <* (tok TokComma <|> lookAhead (tok TokRParen))) <* tok TokRParen -importStatementP :: PaS ImportStatement +importStatementP :: Pa ImportStatement importStatementP = withMeta $ - ImportStatement <$> stringTokenP <*> optionMaybe importListP + ImportStatement <$> stringTokenP <*> optionMaybe importListP <*> pure () fiddleDeclP :: Pa FiddleDecl fiddleDeclP = do diff --git a/src/Main.hs b/src/Main.hs index cf33e62..f643320 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -11,42 +11,56 @@ import qualified Data.Text.IO import Data.Typeable import GHC.IO.Exception (ExitCode (ExitFailure, ExitSuccess)) import Language.Fiddle.Ast -import Language.Fiddle.Compiler (coloredFormat, compile_, printDiagnostic) -import Language.Fiddle.Compiler.Stage0 -import Language.Fiddle.Compiler.Expansion +import Language.Fiddle.Compiler import Language.Fiddle.Compiler.ConsistencyCheck +import Language.Fiddle.Compiler.Expansion +import Language.Fiddle.Compiler.ImportResolution +import Language.Fiddle.Compiler.Stage0 import Language.Fiddle.GenericTree (GenericSyntaxTree (..), ToGenericSyntaxTree (toGenericSyntaxTree), alterGenericSyntaxTree) import qualified Language.Fiddle.Parser import qualified Language.Fiddle.Tokenizer import qualified System.Environment as System import System.Exit (exitWith) +phases res = + importResolutionPhase res >>> expansionPhase >>> consistencyCheckPhase + main :: IO () main = do argv <- System.getArgs + let opts = ImportResolutionOptions ["."] case argv of [filePath] -> do text <- Data.Text.IO.readFile filePath - let (diags, ma) = compile_ $ checkConsistency =<< expandAst =<< toStage1 =<< toStage0 filePath text - ec <- - case ma of - Just ast -> do - putStrLn $ - BL.unpack $ - encode $ - alterGenericSyntaxTree cleanupIdentifiers $ - toGenericSyntaxTree $ - fmap - (const (Nothing :: Maybe Value)) - ast - return ExitSuccess - Nothing -> do - putStrLn "\x1b[1;31mCompilation Failed\x1b[0m" - return (ExitFailure 1) + let maybeParsedAst = compile_ $ toStage0 filePath text >>= toStage1 + + case maybeParsedAst of + (priorDiags, Just ast) -> do + ((priorDiags ++) -> diags, ma) <- + execCompilationPipeline (phases opts) ast + ec <- + case ma of + Just ast -> do + putStrLn $ + BL.unpack $ + encode $ + alterGenericSyntaxTree cleanupIdentifiers $ + toGenericSyntaxTree $ + fmap + (const (Nothing :: Maybe Value)) + ast + return ExitSuccess + Nothing -> do + putStrLn "\x1b[1;31mCompilation Failed\x1b[0m" + return (ExitFailure 1) - forM_ diags printDiagnostic - exitWith ec + forM_ diags printDiagnostic + exitWith ec + (diags, _) -> do + putStrLn "\x1b[1;31mParsing Failed\x1b[0m" + forM_ diags printDiagnostic + exitWith (ExitFailure 1) _ -> do putStrLn "Wrong Args" exitWith (ExitFailure 2) |