diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler/ConsistencyCheck.hs')
| -rw-r--r-- | src/Language/Fiddle/Compiler/ConsistencyCheck.hs | 134 |
1 files changed, 111 insertions, 23 deletions
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs index 908db52..abfbb9b 100644 --- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs +++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs @@ -23,7 +23,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set import qualified Data.Text as Text import Data.Void @@ -33,8 +33,8 @@ import GHC.TypeLits import Language.Fiddle.Ast import Language.Fiddle.Compiler import Language.Fiddle.Internal.Scopes -import Language.Fiddle.Internal.UnitInterface -import Language.Fiddle.Types (Commented (unCommented), SourceSpan) +import Language.Fiddle.Internal.UnitInterface as UnitInterface +import Language.Fiddle.Types (Comment (DocComment), Commented (Commented, unCommented), SourceSpan) import Text.Printf (printf) import Prelude hiding (unzip) @@ -57,14 +57,14 @@ type SizeBytes = Word32 consistencyCheckPhase :: CompilationPhase Expanded Checked consistencyCheckPhase = - CompilationPhase (pure ()) (\_ _ -> return ()) (\_ _ -> checkConsistency) + CompilationPhase (pure ()) (\_ _ -> return ([], Just ())) (\_ _ -> checkConsistency) checkConsistency :: FiddleUnit Expanded I Annot -> Compile () (FiddleUnit Checked I Annot) checkConsistency = fmap snd - . subCompile (GlobalState mempty mempty) + . subCompile (GlobalState mempty mempty mempty) . advanceStage (LocalState mempty) instance CompilationStage Checked where @@ -81,7 +81,11 @@ instance CompilationStage Expanded where type StageFunctor Expanded = Identity type StageAnnotation Expanded = Commented SourceSpan -instance AdvanceStage Expanded FiddleUnit +instance AdvanceStage Expanded FiddleUnit where + advanceStage localState (FiddleUnit _ decls a) = do + decls' <- mapM (advanceStage localState) decls + intf <- gets unitInterface + return $ FiddleUnit intf decls' a -- advanceStage localState (FiddleUnit decls _ annot) = do @@ -107,7 +111,41 @@ deriving instance AdvanceStage Expanded EnumConstantDecl deriving instance AdvanceStage Expanded PackageBody -deriving instance AdvanceStage Expanded ImportStatement +instance AdvanceStage Expanded ImportStatement where + modifyState + ( ImportStatement + { importInterface = + ( UnitInterface + { rootScope = unitScope, + dependencies = importDependencies + } + ) + } + ) + ls = do + modify' + ( \s@GlobalState + { globalScope = globalScope, + unitInterface = unitInterface + } -> + s + { globalScope = + unitInterfaceScopeToGlobalScope unitScope <> globalScope, + unitInterface = + unitInterface + { dependencies = + importDependencies ++ dependencies unitInterface + } + } + ) + return ls + where + unitInterfaceScopeToGlobalScope = + fmap + ( \(Annotated _ _ exportedValue) -> case exportedValue of + ExportedBitsType sz -> Left sz + ExportedObjType sz -> Right sz + ) deriving instance (AdvanceStage Expanded t) => AdvanceStage Expanded (Directed t) @@ -119,9 +157,9 @@ instance AdvanceStage Expanded ObjTypeBody where instance AdvanceStage Expanded FiddleDecl where modifyState t s = case t of - (BitsDecl id typ a) -> do + (BitsDecl id typ annotation) -> do typeSize <- getTypeSize typ - insertTypeSize s id typeSize + insertTypeSize annotation s id typeSize return s (PackageDecl n _ _) -> do let strs = nameToList n @@ -139,6 +177,22 @@ instance AdvanceStage Expanded FiddleDecl where } _ -> return s + customAdvanceStage t (LocalState scopePath) = case t of + (ObjTypeDecl ident (Identity body) annot) -> do + (body', size) <- objTypeBodyToStage3 (LocalState scopePath) body 0 + + let fullName = + NonEmpty.prependList + (currentScope scopePath) + (NonEmpty.singleton (Text.unpack (identifierName ident))) + + ui <- gets unitInterface + let ui' = insertIntoUnitInterface fullName ui annot (ExportedObjType size) + modify' $ \gs -> gs {unitInterface = ui'} + + return $ Just $ ObjTypeDecl ident (Identity body') annot + _ -> return Nothing + nameToList :: Name f a -> [String] nameToList (Name idents _) = map (\(Identifier (Text.unpack -> s) _) -> s) (toList idents) @@ -444,9 +498,9 @@ lookupTypeSize (LocalState scopePath) (Name idents a) = do case results of -- Successfully resolved to a unique size - [(_, Right sz)] -> return sz + [(_, Left sz)] -> return sz -- Multiple ambiguous results found - matches@(_ : _) -> do + matches@(_ : _ : _) -> do -- Generate a list of ambiguous paths for error reporting let ambiguousPaths = map @@ -467,7 +521,7 @@ lookupTypeSize (LocalState scopePath) (Name idents a) = do compilationFailure -- No matches found - _ -> do + [] -> do tell [ Diagnostic Error @@ -528,23 +582,57 @@ getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do diagnosticError :: String -> Annot -> Compile a () diagnosticError str a = tell [Diagnostic Error str (unCommented a)] +diagnosticInfo :: String -> Annot -> Compile a () +diagnosticInfo str a = tell [Diagnostic Info str (unCommented a)] + +insertIntoUnitInterface path ui (Commented comments srcspan) val = + let docComments = + mconcat + ( mapMaybe + ( \com -> do + (DocComment txt) <- Just com + return txt + ) + comments + ) + in ui + { rootScope = + insertScope path (Annotated srcspan docComments val) (rootScope ui) + } + insertTypeSize :: + Annot -> LocalState -> Identifier f Annot -> SizeBits -> Compile GlobalState () -insertTypeSize (LocalState scopePath) (Identifier s annot) size = do +insertTypeSize annot (LocalState scopePath) (Identifier s idannot) size = do modifyM $ - \state@GlobalState {globalScope = globalScope} -> - let fullName = - NonEmpty.prependList - (currentScope scopePath) - (NonEmpty.singleton (Text.unpack s)) - in case upsertScope fullName (Right size) globalScope of - (Just _, _) -> do - diagnosticError (printf "Duplicate type %s" s) annot - compilationFailure - (Nothing, n) -> return $ state {globalScope = n} + \state@GlobalState + { globalScope = globalScope, + unitInterface = unitInterface + } -> + let fullName = + NonEmpty.prependList + (currentScope scopePath) + (NonEmpty.singleton (Text.unpack s)) + in case upsertScope fullName (Left size) globalScope of + (Just _, _) -> do + diagnosticError (printf "Duplicate type %s" s) idannot + + compilationFailure + (Nothing, n) -> + let unitInterface' = + insertIntoUnitInterface + fullName + unitInterface + annot + (ExportedBitsType size) + in return $ + state + { globalScope = n, + unitInterface = unitInterface' + } where modifyM fn = do s <- get |