diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler/Qualification.hs')
| -rw-r--r-- | src/Language/Fiddle/Compiler/Qualification.hs | 116 |
1 files changed, 95 insertions, 21 deletions
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs index ce6250a..67d3f29 100644 --- a/src/Language/Fiddle/Compiler/Qualification.hs +++ b/src/Language/Fiddle/Compiler/Qualification.hs @@ -12,11 +12,11 @@ module Language.Fiddle.Compiler.Qualification (qualificationPhase) where import Control.Monad.RWS (MonadWriter (tell)) import Control.Monad.State -import Data.Foldable (foldlM) +import Data.Foldable (foldlM, toList) import Data.List (intercalate) -import Data.List.NonEmpty (NonEmpty (..), toList) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe (mapMaybe) +import Data.Maybe (isNothing, mapMaybe) import qualified Data.Text import Data.Word import Language.Fiddle.Ast @@ -52,11 +52,8 @@ uniqueString prefix = do modify $ \g -> g {uniqueCounter = cnt + 1} return $ "_" ++ prefix ++ show cnt -uniqueIdentifier :: a -> M (Identifier F a) -uniqueIdentifier a = (\s -> Identifier (Data.Text.pack s) a) <$> uniqueString "ident" - -uniqueReservedIdentifier :: a -> M (Identifier F a) -uniqueReservedIdentifier a = (\s -> Identifier (Data.Text.pack s) a) <$> uniqueString "reserved" +uniqueIdentifier :: String -> a -> M (Identifier F a) +uniqueIdentifier prefix a = (\s -> Identifier (Data.Text.pack s) a) <$> uniqueString prefix instance CompilationStage Expanded where type StageAfter Expanded = Qualified @@ -77,14 +74,17 @@ qualificationPhase = squeezeDiagnostics raw --- Any non-guaranteed identifiers are given generated identifiers here. -instance - StageConvertible - Expanded - (Guaranteed False (Identifier F A)) - (Guaranteed True (Identifier F A)) - where - convertInStage _ ann _ = guaranteeM (uniqueIdentifier ann) +pushIdent :: Identifier f a -> LocalState -> LocalState +pushIdent i = pushIdents [i] + +pushIdents :: (Foldable t) => t (Identifier f a) -> LocalState -> LocalState +pushIdents = + ( \case + [] -> id + (i : is) -> + modifyCurrentScopePath (pushScope $ fmap identToString (i :| is)) + ) + . toList instance StageConvertible @@ -110,9 +110,80 @@ deriving instance AdvanceStage S EnumBody deriving instance AdvanceStage S EnumConstantDecl -deriving instance AdvanceStage S RegisterBitsDecl - -deriving instance AdvanceStage S ObjTypeDecl +instance AdvanceStage S RegisterBitsDecl where + advanceStage localState = \case + ReservedBits expr an -> ReservedBits <$> advanceStage localState expr <*> pure an + BitsSubStructure bod name an -> + BitsSubStructure + <$> advanceStage localState bod + <*> pure name + <*> pure an + DefinedBits _ mod ident typ an -> do + let qMeta = + QBitsMetadata + { bitsSpan = Vacant, + bitsFullPath = + qualifyPath + (currentScopePath localState) + (NonEmpty.singleton (identToString ident)) + } + DefinedBits (Present qMeta) mod ident + <$> advanceStage localState typ + <*> pure an + +instance AdvanceStage S ObjTypeDecl where + advanceStage localState = \case + AssertPosStatement d e a -> + AssertPosStatement d <$> advanceStage localState e <*> pure a + RegisterDecl _ mod ident size bod ann -> do + ident' <- guaranteeM (uniqueIdentifier "reg" ann) ident + let localState' = pushIdents ident localState + + let qRegMeta = + QRegMetadata + { regSpan = Vacant, + regIsPadding = False, + regIsUnnamed = isNothing (toMaybe ident), + regFullPath = + qualifyPath + (currentScopePath localState) + (NonEmpty.singleton (identToString (unwrap ident'))) + } + + RegisterDecl + (Present qRegMeta) + (guarantee (ModifierKeyword Rw ann) mod) + ident' + <$> advanceStage localState' size + <*> mapM (advanceStage localState') bod + <*> pure ann + ReservedDecl _ expr ann -> do + ident <- uniqueIdentifier "reserved" ann + + let qRegMeta = + QRegMetadata + { regSpan = Vacant, + regIsPadding = True, + regIsUnnamed = True, + regFullPath = + qualifyPath + (currentScopePath localState) + (NonEmpty.singleton (identToString ident)) + } + + RegisterDecl + (Present qRegMeta) + (Guaranteed $ ModifierKeyword Pr ann) + (Guaranteed ident) + <$> advanceStage localState expr + <*> pure Nothing + <*> pure ann + TypeSubStructure bod name an -> do + let localState' = pushIdents name localState + TypeSubStructure + <$> mapM (advanceStage localState') bod + <*> pure name + <*> pure an deriving instance AdvanceStage S (Expression u) @@ -284,6 +355,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do <*> pure ann ObjTypeDecl _ ident body ann -> let qualifiedName = qualify (NonEmpty.singleton (identToString ident)) + localState'' = modifyCurrentScopePath (pushScope (NonEmpty.singleton $ identToString ident)) localState' in do typeSize <- calculateTypeSize =<< resolveOrFail body let decl = @@ -295,7 +367,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do =<< ObjTypeDecl (qMd decl) ident - <$> mapM (advanceStage localState') body + <$> mapM (advanceStage localState'') body <*> pure ann ObjectDecl _ ident loc typ ann -> let qualifiedName = qualify (NonEmpty.singleton (identToString ident)) @@ -331,7 +403,9 @@ objTypeToExport ls = \case <*> expressionToIntM size ReferencedObjType {refName = n} -> do (full, _ :: ExportedTypeDecl) <- resolveOrFail =<< resolveName n ls - return $ ReferencedObjectType (intercalate "." full) + case full of + (f:fs) -> return $ ReferencedObjectType (f :| fs) + _ -> compilationFailure calculateTypeSize :: ObjTypeBody Expanded F A -> M (N Bytes) calculateTypeSize (ObjTypeBody bodyType decls _) = |