diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler/Qualification.hs')
| -rw-r--r-- | src/Language/Fiddle/Compiler/Qualification.hs | 330 |
1 files changed, 283 insertions, 47 deletions
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs index eddb3cb..7eea141 100644 --- a/src/Language/Fiddle/Compiler/Qualification.hs +++ b/src/Language/Fiddle/Compiler/Qualification.hs @@ -10,97 +10,333 @@ -- removed, as they become unnecessary once references are fully qualified. module Language.Fiddle.Compiler.Qualification (qualificationPhase) where -import Control.Monad.Identity +import Control.Monad.RWS (MonadWriter (tell)) +import Control.Monad.State import Data.Foldable (foldlM) +import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty (..), toList) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (mapMaybe) import Data.Word import Language.Fiddle.Ast import Language.Fiddle.Compiler import Language.Fiddle.Compiler.ConsistencyCheck () import Language.Fiddle.Internal.Scopes -import Language.Fiddle.Internal.UnitInterface +import Language.Fiddle.Internal.UnitInterface as UnitInterface import Language.Fiddle.Types +import Text.Printf (printf) -type CurrentStage = Expanded +type S = Expanded -data GlobalState = GlobalState - { _globalScope :: Scope String (Either SizeBits SizeBytes), - _fileDependencies :: [FilePath], - _unitInterface :: UnitInterface +newtype GlobalState = GlobalState + { unitInterface :: UnitInterface } -newtype LocalState = LocalState (ScopePath String) - -type I = Identity +data LocalState = LocalState + { currentScopePath :: ScopePath String, + ephemeralScope :: Scope String (Metadata, ExportedDecl) + } -type Annot = Commented SourceSpan +type F = Either [Diagnostic] -type SizeBits = Word32 +type A = Commented SourceSpan -type SizeBytes = Word32 +type M = Compile GlobalState instance CompilationStage Expanded where type StageAfter Expanded = Qualified - type StageMonad Expanded = Compile GlobalState + type StageMonad Expanded = M type StageState Expanded = LocalState - type StageFunctor Expanded = I - type StageAnnotation Expanded = Annot + type StageFunctor Expanded = F + type StageAnnotation Expanded = A qualificationPhase :: CompilationPhase Expanded Qualified qualificationPhase = - pureCompilationPhase $ - fmap snd - . subCompile (GlobalState mempty mempty mempty) - . advanceStage (LocalState mempty) + pureCompilationPhase $ \t -> do + raw <- + fmap snd $ + subCompile (GlobalState mempty) $ + advanceStage + (LocalState mempty mempty) + (soakA t) + + squeezeDiagnostics raw -deriving instance AdvanceStage CurrentStage ObjTypeBody +deriving instance AdvanceStage S ObjTypeBody -deriving instance AdvanceStage CurrentStage DeferredRegisterBody +deriving instance AdvanceStage S DeferredRegisterBody -deriving instance AdvanceStage CurrentStage RegisterBody +deriving instance AdvanceStage S RegisterBody -deriving instance AdvanceStage CurrentStage AnonymousBitsType +deriving instance AdvanceStage S AnonymousBitsType -deriving instance AdvanceStage CurrentStage ImportStatement +deriving instance AdvanceStage S ImportStatement -deriving instance AdvanceStage CurrentStage BitType +deriving instance AdvanceStage S BitType -deriving instance AdvanceStage CurrentStage EnumBody +deriving instance AdvanceStage S EnumBody -deriving instance AdvanceStage CurrentStage EnumConstantDecl +deriving instance AdvanceStage S EnumConstantDecl -deriving instance AdvanceStage CurrentStage RegisterBitsDecl +deriving instance AdvanceStage S RegisterBitsDecl -deriving instance AdvanceStage CurrentStage ObjTypeDecl +deriving instance AdvanceStage S ObjTypeDecl -deriving instance AdvanceStage CurrentStage Expression +deriving instance AdvanceStage S Expression -instance AdvanceStage CurrentStage RegisterBitsTypeRef where - advanceStage = undefined +instance AdvanceStage S RegisterBitsTypeRef where + advanceStage localState = \case + RegisterBitsArray a b c -> + RegisterBitsArray + <$> advanceStage localState a + <*> advanceStage localState b + <*> pure c + RegisterBitsJustBits a b -> + RegisterBitsJustBits + <$> advanceStage localState a + <*> pure b + RegisterBitsReference _ name a -> do + v <- fmap snd <$> resolveName name localState + return $ RegisterBitsReference v name a -instance AdvanceStage CurrentStage ObjType where - advanceStage = undefined +instance AdvanceStage S ObjType where + advanceStage localState = \case + ArrayObjType a b c -> + ArrayObjType + <$> advanceStage localState a + <*> advanceStage localState b + <*> pure c + ReferencedObjType _ name a -> do + v <- fmap snd <$> resolveName name localState + return $ ReferencedObjType v name a -deriving instance (AdvanceStage CurrentStage t) => AdvanceStage CurrentStage (Directed t) +deriving instance (AdvanceStage S t) => AdvanceStage S (Directed t) -instance AdvanceStage CurrentStage PackageBody where +instance AdvanceStage S PackageBody where advanceStage localState (PackageBody decls a) = PackageBody <$> advanceFiddleDecls localState decls <*> pure a -instance AdvanceStage CurrentStage FiddleUnit where +instance AdvanceStage S FiddleUnit where advanceStage localState (FiddleUnit () decls a) = FiddleUnit () <$> advanceFiddleDecls localState decls <*> pure a +modifyEphemeralScope :: + ( Scope String (Metadata, ExportedDecl) -> Scope String (Metadata, ExportedDecl) + ) -> + LocalState -> + LocalState +modifyEphemeralScope fn ls@LocalState {ephemeralScope = es} = + ls {ephemeralScope = fn es} + +modifyCurrentScopePath :: + (ScopePath String -> ScopePath String) -> + LocalState -> + LocalState +modifyCurrentScopePath fn ls@LocalState {currentScopePath = cs} = + ls {currentScopePath = fn cs} + +resolveIdent :: (ExportableDecl d, Functor f) => Identifier f A -> LocalState -> M (F ([String], d)) +resolveIdent i = resolveSymbol (annot i) [identToString i] + +resolveName :: (ExportableDecl d, Functor f) => Name f A -> LocalState -> M (F ([String], d)) +resolveName n = resolveSymbol (annot n) (toList $ nameToList n) + +resolveSymbol :: (ExportableDecl d) => A -> [String] -> LocalState -> M (F ([String], d)) +resolveSymbol a (p : ps) (LocalState {ephemeralScope = ephemeralScope, currentScopePath = currentPath}) = do + GlobalState {unitInterface = UnitInterface {rootScope = rootScope}} <- get + + let matches = + concatMap + ( mapMaybe (\(p, (m, e)) -> (p,) . (m,) <$> fromExportedDecl e) + . lookupScopeWithPath currentPath (p :| ps) + ) + [rootScope, ephemeralScope] + + return $ + case matches of + [(p, (_, e))] -> Right (toList p, e) + [] -> + Left + [ Diagnostic + Error + ( printf "Could not resolve symbol %s" (intercalate "." (p : ps)) + ) + (unCommented a) + ] + (_ : _ : _) -> do + Left + [ Diagnostic + Error + ( printf + "Ambiguous occurance of %s" + (intercalate "." (p : ps)) + ) + (unCommented a) + ] +resolveSymbol a _ _ = + return $ Left [Diagnostic Error "Empty path provided (this is a bug)" (unCommented a)] + advanceFiddleDecls :: LocalState -> - [TreeType (Directed FiddleDecl) CurrentStage] -> - (StageMonad CurrentStage) - [TreeType (Directed FiddleDecl) Qualified] -advanceFiddleDecls (LocalState scopePath) decls = fmap (reverse . fst) $ do + [Directed FiddleDecl S F A] -> + M [Directed FiddleDecl Qualified F A] +advanceFiddleDecls localState decls = fmap (reverse . fst) $ do foldlM - ( \(declsRet, scopePath') -> \case - Directed {directedSubtree = UsingDecl {usingName = name}} -> - return (declsRet, addUsingPath (nameToList name) scopePath') - _ -> undefined + ( \(declsRet, localState' :: LocalState) unsqeezedd -> do + d <- case squeeze unsqeezedd of + Left diags -> tell diags >> compilationFailure + Right x -> return x + case unsqeezedd of + (Directed directives t dann) -> + let doReturn :: + FiddleDecl Qualified F A -> + M ([Directed FiddleDecl Qualified F A], LocalState) + doReturn v = return (Directed directives v dann : declsRet, localState') + doReturnWith s v = return (Directed directives v dann : declsRet, s) + qualify = qualifyPath (currentScopePath localState') + metadata = directiveToMetadata d + in case t of + UsingDecl {usingName = name} -> + return (declsRet, modifyCurrentScopePath (addUsingPath (nameToList name)) localState') + OptionDecl key value ann -> doReturn $ OptionDecl key value ann + ImportDecl st@(ImportStatement {importInterface = interface}) a -> + let localState'' = modifyEphemeralScope (<> rootScope interface) localState' + in doReturnWith localState'' + =<< ImportDecl + <$> advanceStage localState'' st + <*> pure a + PackageDecl _ name body ann -> + let qualifiedName = qualify (nameToList name) + localState'' = modifyCurrentScopePath (pushScope (nameToList name)) localState' + decl = ExportedPackageDecl (metadata qualifiedName) + in do + insertDecl decl + doReturn + =<< PackageDecl + (pure decl) + name + <$> mapM (advanceStage localState'') body + <*> pure ann + LocationDecl _ ident expr ann -> + let qualifiedName = qualify (NonEmpty.singleton (identToString ident)) + in do + exprValue <- expressionToIntM expr + let decl = + ExportedLocationDecl + (metadata qualifiedName) + exprValue + insertDecl decl + doReturn + =<< LocationDecl + (pure decl) + ident + <$> advanceStage localState' expr + <*> pure ann + BitsDecl _ ident typ ann -> + let qualifiedName = qualify (NonEmpty.singleton (identToString ident)) + in do + sizeBits <- getBitTypeDeclaredSize typ + let decl = + ExportedBitsDecl + (metadata qualifiedName) + sizeBits + insertDecl decl + doReturn + =<< BitsDecl + (pure decl) + ident + <$> advanceStage localState' typ + <*> pure ann + ObjTypeDecl _ ident body ann -> + let qualifiedName = qualify (NonEmpty.singleton (identToString ident)) + in do + typeSize <- calculateTypeSize =<< resolveOrFail body + let decl = + ExportedTypeDecl + (metadata qualifiedName) + typeSize + insertDecl decl + doReturn + =<< ObjTypeDecl + (pure decl) + ident + <$> mapM (advanceStage localState') body + <*> pure ann + ObjectDecl _ ident loc typ ann -> + let qualifiedName = qualify (NonEmpty.singleton (identToString ident)) + in do + location <- resolveLocationExpression localState' loc + exportedType <- objTypeToExport localState' typ + let decl = + ExportedObjectDecl + (metadata qualifiedName) + location + exportedType + insertDecl decl + doReturn + =<< ObjectDecl + (pure decl) + ident + <$> advanceStage localState' loc + <*> advanceStage localState' typ + <*> pure ann ) - ([], scopePath) + ([], localState) decls + +insertDecl :: (ExportableDecl d) => d -> M () +insertDecl decl = + modify $ \(GlobalState ui) -> GlobalState (UnitInterface.insert decl ui) + +objTypeToExport :: LocalState -> ObjType Expanded F A -> M ReferencedObjectType +objTypeToExport ls = \case + ArrayObjType {arraySize = size, arrayObjType = objType} -> + ArrayObjectType + <$> objTypeToExport ls objType + <*> expressionToIntM size + ReferencedObjType {refName = n} -> do + (full, _ :: ExportedTypeDecl) <- resolveOrFail =<< resolveName n ls + return $ ReferencedObjectType (intercalate "." full) + +calculateTypeSize :: ObjTypeBody Expanded F A -> M Word32 +calculateTypeSize (ObjTypeBody bodyType decls _) = + ( case bodyType of + Union {} -> maximum + Struct {} -> sum + ) + <$> mapM calculateDeclSize decls + where + calculateDeclSize :: Directed ObjTypeDecl Expanded F A -> M Word32 + calculateDeclSize (undirected -> decl) = + case decl of + AssertPosStatement {} -> return 0 + RegisterDecl {regSize = size} -> expressionToIntM size + ReservedDecl {reservedExpr = size} -> expressionToIntM size + TypeSubStructure {subStructureBody = b} -> calculateTypeSize =<< resolveOrFail b + +getBitTypeDeclaredSize :: BitType Expanded F A -> M Word32 +getBitTypeDeclaredSize = \case + (EnumBitType declaredSize _ _) -> expressionToIntM declaredSize + (RawBits declaredSize _) -> expressionToIntM declaredSize + +resolveLocationExpression :: + (Integral i, Integral (NumberType stage)) => + LocalState -> + Expression stage F A -> + M i +resolveLocationExpression ls (Var var _) = do + (_, ExportedLocationDecl _ v) <- resolveOrFail =<< resolveName var ls + return (fromIntegral v) +resolveLocationExpression _ e = expressionToIntM e + +expressionToIntM :: + (Integral i, Integral (NumberType stage)) => + Expression stage f A -> + M i +expressionToIntM expr = + resolveOrFail $ + either + ( \reason -> Left [Diagnostic Error reason (unCommented $ annot expr)] + ) + return + (expressionToInt expr) |