diff options
| -rw-r--r-- | package.yaml | 2 | ||||
| -rw-r--r-- | src/Language/Fiddle/Ast/Internal/Instances.hs | 1 | ||||
| -rw-r--r-- | src/Language/Fiddle/Ast/Internal/SyntaxTree.hs | 20 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/ConsistencyCheck.hs | 15 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Qualification.hs | 37 | ||||
| -rw-r--r-- | src/Language/Fiddle/Internal/Scopes.hs | 14 |
6 files changed, 66 insertions, 23 deletions
diff --git a/package.yaml b/package.yaml index 217a741..62bbdf8 100644 --- a/package.yaml +++ b/package.yaml @@ -31,6 +31,8 @@ ghc-options: - -XTypeOperators - -XUndecidableInstances - -XViewPatterns + - -Wall + - -fno-warn-orphans dependencies: - base >= 4.0.0 diff --git a/src/Language/Fiddle/Ast/Internal/Instances.hs b/src/Language/Fiddle/Ast/Internal/Instances.hs index 379c788..3380ccd 100644 --- a/src/Language/Fiddle/Ast/Internal/Instances.hs +++ b/src/Language/Fiddle/Ast/Internal/Instances.hs @@ -7,6 +7,7 @@ module Language.Fiddle.Ast.Internal.Instances CompilationStage (..), Annotated (..), GAnnot (..), + TreeType (..), ) where diff --git a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs index 9c6718c..6aa0793 100644 --- a/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs +++ b/src/Language/Fiddle/Ast/Internal/SyntaxTree.hs @@ -43,7 +43,6 @@ module Language.Fiddle.Ast.Internal.SyntaxTree EnumBody (..), EnumConstantDecl (..), PackageBody (..), - TreeType (..), -- Helper Functions mapDirected, mapDirectedM, @@ -51,6 +50,7 @@ module Language.Fiddle.Ast.Internal.SyntaxTree undirected, -- Utility Functions squeeze, + nameToList, ) where @@ -58,7 +58,7 @@ import Control.Monad (forM_) import Data.Coerce import Data.Functor.Identity import Data.Kind (Type) -import Data.List.NonEmpty +import Data.List.NonEmpty hiding (map) import Data.Proxy import Data.Text (Text) import Data.Traversable @@ -73,14 +73,19 @@ import Language.Fiddle.Ast.Internal.Instances import Language.Fiddle.Ast.Internal.Kinds import Language.Fiddle.Ast.Internal.Stage import Language.Fiddle.Internal.UnitInterface (UnitInterface) +import qualified Data.Text as Text -type TreeType t stage = t stage (StageFunctor stage) (StageAnnotation stage) - -type FullyQualifiedName = String +-- | Common data for each qualified element. +newtype CommonQualifcationData + = CommonQualifcationData + { -- The fully qualified path to this qualified element. + fullyQualifiedPath :: [String] + } + deriving (Eq, Ord, Show) type family QualificationMetadata stage t where QualificationMetadata stage t = - If (stage < Qualified) () t + If (stage < Qualified) () (CommonQualifcationData, t) -- | The type attached to import statements which describe the imported file's -- unit interface @@ -718,3 +723,6 @@ data PackageBody (stage :: Stage) (f :: Type -> Type) a where squeeze :: (Alter t, Traversable f, Monad f) => t f a -> f (t Identity a) squeeze = alter (fmap Identity) return + +nameToList :: Name f a -> [String] +nameToList (Name ids _) = map (Text.unpack . identifierName) (toList ids) diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs index 7ca618b..79ac9e7 100644 --- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs +++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs @@ -159,11 +159,11 @@ deriving instance AdvanceStage CurrentStage FiddleDecl instance AdvanceStage CurrentStage (Directed FiddleDecl) where modifyState (Directed directives t _) s = case t of - (BitsDecl () id typ annotation) -> do + (BitsDecl _ id typ annotation) -> do typeSize <- getTypeSize typ insertTypeSize annotation s id typeSize return s - (PackageDecl () n _ _) -> do + (PackageDecl _ n _ _) -> do let strs = nameToList n let (LocalState scopePath) = s @@ -180,7 +180,7 @@ instance AdvanceStage CurrentStage (Directed FiddleDecl) where _ -> return s customAdvanceStage (Directed directives t a) (LocalState scopePath) = case t of - (ObjTypeDecl () ident (Identity body) annot) -> do + (ObjTypeDecl q ident (Identity body) annot) -> do (body', size) <- objTypeBodyToStage3 (LocalState scopePath) body 0 let fullName = @@ -192,12 +192,9 @@ instance AdvanceStage CurrentStage (Directed FiddleDecl) where let ui' = insertIntoUnitInterface fullName ui annot (ExportedObjType size) modify' $ \gs -> gs {unitInterface = ui'} - return $ Just $ Directed directives (ObjTypeDecl () ident (Identity body') annot) a + return $ Just $ Directed directives (ObjTypeDecl q ident (Identity body') annot) a _ -> return Nothing -nameToList :: Name f a -> [String] -nameToList (Name idents _) = map (\(Identifier (Text.unpack -> s) _) -> s) (toList idents) - objTypeBodyToStage3 :: LocalState -> ObjTypeBody CurrentStage I Annot -> @@ -456,8 +453,8 @@ registerBitsTypeRefToStage3 localState = \case ( RegisterBitsArray ref' expr' a, size * fromIntegral multiplier ) - RegisterBitsReference () name a -> - (RegisterBitsReference () name a,) <$> lookupTypeSize localState name + RegisterBitsReference q name a -> + (RegisterBitsReference q name a,) <$> lookupTypeSize localState name RegisterBitsJustBits expr a -> do expr' <- advanceStage localState expr (RegisterBitsJustBits expr' a,) diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs index f8fbc0a..27c0911 100644 --- a/src/Language/Fiddle/Compiler/Qualification.hs +++ b/src/Language/Fiddle/Compiler/Qualification.hs @@ -10,7 +10,10 @@ -- removed, as they become unnecessary once references are fully qualified. module Language.Fiddle.Compiler.Qualification (qualificationPhase) where +import Control.Monad (forM) import Control.Monad.Identity +import Data.Foldable (foldlM) +import Data.Maybe (catMaybes) import Data.Word import Language.Fiddle.Ast import Language.Fiddle.Compiler @@ -69,18 +72,36 @@ deriving instance AdvanceStage CurrentStage EnumConstantDecl deriving instance AdvanceStage CurrentStage RegisterBitsDecl -deriving instance AdvanceStage CurrentStage PackageBody - deriving instance AdvanceStage CurrentStage ObjTypeDecl -deriving instance AdvanceStage CurrentStage FiddleDecl - -deriving instance AdvanceStage CurrentStage FiddleUnit - deriving instance AdvanceStage CurrentStage Expression -deriving instance AdvanceStage CurrentStage RegisterBitsTypeRef +instance AdvanceStage CurrentStage RegisterBitsTypeRef where + advanceStage = undefined -deriving instance AdvanceStage CurrentStage ObjType +instance AdvanceStage CurrentStage ObjType where + advanceStage = undefined deriving instance (AdvanceStage CurrentStage t) => AdvanceStage CurrentStage (Directed t) + +instance AdvanceStage CurrentStage PackageBody where + advanceStage localState (PackageBody decls annot) = + PackageBody <$> advanceFiddleDecls localState decls <*> pure annot + +instance AdvanceStage CurrentStage FiddleUnit where + advanceStage localState (FiddleUnit () decls annot) = + FiddleUnit () <$> advanceFiddleDecls localState decls <*> pure annot + +advanceFiddleDecls :: + LocalState -> + [TreeType (Directed FiddleDecl) CurrentStage] -> + (StageMonad CurrentStage) + [TreeType (Directed FiddleDecl) Qualified] +advanceFiddleDecls (LocalState scopePath) decls = fmap (reverse . fst) $ do + foldlM + ( \(declsRet, scopePath') -> \case + Directed {directedSubtree = UsingDecl {usingName = name}} -> + return (declsRet, addUsingPath (nameToList name) scopePath') + ) + ([], scopePath) + decls diff --git a/src/Language/Fiddle/Internal/Scopes.hs b/src/Language/Fiddle/Internal/Scopes.hs index ac6f7d1..02c9a5a 100644 --- a/src/Language/Fiddle/Internal/Scopes.hs +++ b/src/Language/Fiddle/Internal/Scopes.hs @@ -29,6 +29,20 @@ data ScopePath k = ScopePath } deriving (Eq, Ord, Show, Read) +-- | Qualify a name with the current scope. +qualifyPath :: ScopePath k -> k -> [k] +qualifyPath ScopePath {currentScope = scope} k = scope ++ [k] + +-- | Push a new scope onto the current scope. +pushScope :: k -> ScopePath k -> ScopePath k +pushScope v s@ScopePath {currentScope = scope} = + s {currentScope = scope ++ [v]} + +-- | Adds a path to the "using" paths. +addUsingPath :: [k] -> ScopePath k -> ScopePath k +addUsingPath path s@ScopePath {usingPaths = paths} = + s {usingPaths = path : paths} + -- | The 'Semigroup' instance for 'Scope' allows combining two scopes, -- where sub-scopes and values are merged together. instance (Ord k) => Semigroup (Scope k t) where |