diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler/Qualification.hs')
| -rw-r--r-- | src/Language/Fiddle/Compiler/Qualification.hs | 170 |
1 files changed, 108 insertions, 62 deletions
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs index 56f1122..1307c2a 100644 --- a/src/Language/Fiddle/Compiler/Qualification.hs +++ b/src/Language/Fiddle/Compiler/Qualification.hs @@ -37,6 +37,8 @@ data GlobalState = GlobalState data LocalState = LocalState { currentScopePath :: ScopePath String, + -- | Current qualified path, used for building metadata. + currentQualifiedPath :: QualifiedPath (), ephemeralScope :: Scope String (Metadata, ExportedDecl) } @@ -62,29 +64,62 @@ instance CompilationStage Expanded where type StageFunctor Expanded = F type StageAnnotation Expanded = A +pushPackage :: NonEmpty String -> LocalState -> (QualifiedPath String, LocalState) +pushPackage pk ls = + let q = currentQualifiedPath ls + in ( qualifyPackage pk, + ls + { currentScopePath = pushScope pk (currentScopePath ls), + currentQualifiedPath = + q + { packagePart = packagePart q ++ NonEmpty.toList pk + } + } + ) + where + qualifyPackage :: NonEmpty String -> QualifiedPath String + qualifyPackage (NonEmpty.reverse -> (l :| (reverse -> h))) = + let q = currentQualifiedPath ls + in q {packagePart = packagePart q ++ h, basenamePart = l} + +pushObject :: String -> LocalState -> (QualifiedPath String, LocalState) +pushObject objName ls = + let q = currentQualifiedPath ls + in ( fmap (const objName) q, + ls + { currentScopePath = pushScope (NonEmpty.singleton objName) (currentScopePath ls), + currentQualifiedPath = + q + { objectPart = Just objName + } + } + ) + +pushRegister :: String -> LocalState -> (QualifiedPath String, LocalState) +pushRegister regName ls = + let q = currentQualifiedPath ls + in ( fmap (const regName) q, + ls + { currentScopePath = pushScope (NonEmpty.singleton regName) (currentScopePath ls), + currentQualifiedPath = + q + { registerPart = registerPart q ++ [regName] + } + } + ) + qualificationPhase :: CompilationPhase Expanded Qualified qualificationPhase = - pureCompilationPhase $ \t -> do - raw <- - fmap snd $ - subCompile (GlobalState mempty 0) $ - advanceStage - (LocalState mempty mempty) - (soakA t) - - squeezeDiagnostics raw - -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 + let initialQualifiedPath = QualifiedPath [] Nothing [] () + in pureCompilationPhase $ \t -> do + raw <- + fmap snd $ + subCompile (GlobalState mempty 0) $ + advanceStage + (LocalState mempty initialQualifiedPath mempty) + (soakA t) + + squeezeDiagnostics raw instance StageConvertible @@ -98,7 +133,7 @@ instance AdvanceStage S (ConstExpression u) where advanceStage ls (ConstExpression (RightV exp) a) = case exp of Var var _ -> do - (_, ExportedLocationDecl _ v) <- resolveOrFail =<< resolveName var ls + (ExportedLocationDecl _ v) <- resolveOrFail =<< resolveName var ls return $ ConstExpression (LeftV $ fromIntegral v) a LitNum (RightV v) _ -> return $ ConstExpression (LeftV v) a @@ -127,15 +162,13 @@ instance AdvanceStage S RegisterBitsDecl where <*> pure name <*> pure an DefinedBits _ mod ident typ an -> do - let qMeta = + let (path, _) = pushObject (identToString ident) localState + qMeta = QBitsMetadata { bitsSpan = Vacant, - bitsFullPath = - qualifyPath - (currentScopePath localState) - (NonEmpty.singleton (identToString ident)) + bitsFullPath = path } - DefinedBits (Present qMeta) mod ident + DefinedBits (Present qMeta) (guarantee (ModifierKeyword Rw an) mod) ident <$> advanceStage localState typ <*> pure an @@ -145,38 +178,39 @@ instance AdvanceStage S ObjTypeDecl where 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 (qualified, localState') = + pushRegister (identToString $ unwrap ident') localState + -- Avoid pushing the anonymized name onto the stack. + localState'' = + if isNothing (toMaybe ident) then localState else localState' let qRegMeta = QRegMetadata { regSpan = Vacant, regIsPadding = False, regIsUnnamed = isNothing (toMaybe ident), - regFullPath = - qualifyPath - (currentScopePath localState) - (NonEmpty.singleton (identToString (unwrap ident'))) + regFullPath = qualified } RegisterDecl (Present qRegMeta) (guarantee (ModifierKeyword Rw ann) mod) ident' - <$> advanceStage localState' size - <*> mapM (advanceStage localState') bod + <$> advanceStage localState'' size + <*> mapM (advanceStage localState'') bod <*> pure ann ReservedDecl _ expr ann -> do ident <- uniqueIdentifier "reserved" ann + let (q, _) = pushRegister (identToString ident) localState + let qRegMeta = QRegMetadata { regSpan = Vacant, regIsPadding = True, regIsUnnamed = True, - regFullPath = - qualifyPath - (currentScopePath localState) - (NonEmpty.singleton (identToString ident)) + regFullPath = q } RegisterDecl @@ -187,7 +221,11 @@ instance AdvanceStage S ObjTypeDecl where <*> pure Nothing <*> pure ann TypeSubStructure bod name an -> do - let localState' = pushIdents name localState + let localState' = + maybe + localState + (\n -> snd $ pushRegister (identToString n) localState) + name TypeSubStructure <$> mapM (advanceStage localState') bod <*> pure name @@ -207,7 +245,7 @@ instance AdvanceStage S RegisterBitsTypeRef where <$> advanceStage localState a <*> pure b RegisterBitsReference _ name a -> do - v <- fmap (Present . snd) <$> resolveName name localState + v <- fmap Present <$> resolveName name localState return $ RegisterBitsReference v name a instance AdvanceStage S ObjType where @@ -218,7 +256,7 @@ instance AdvanceStage S ObjType where <*> advanceStage localState b <*> pure c ReferencedObjType _ name a -> do - v <- fmap (Present . snd) <$> resolveName name localState + v <- fmap Present <$> resolveName name localState return $ ReferencedObjType v name a deriving instance (AdvanceStage S t) => AdvanceStage S (Directed t) @@ -246,13 +284,13 @@ modifyCurrentScopePath :: modifyCurrentScopePath fn ls@LocalState {currentScopePath = cs} = ls {currentScopePath = fn cs} -resolveIdent :: (ExportableDecl d, Functor f) => Identifier f A -> LocalState -> M (F ([String], d)) +resolveIdent :: (ExportableDecl d, Functor f) => Identifier f A -> LocalState -> M (F d) resolveIdent i = resolveSymbol (annot i) [identToString i] -resolveName :: (ExportableDecl d, Functor f) => Name f A -> LocalState -> M (F ([String], d)) +resolveName :: (ExportableDecl d, Functor f) => Name f A -> LocalState -> M (F d) resolveName n = resolveSymbol (annot n) (toList $ nameToList n) -resolveSymbol :: (ExportableDecl d) => A -> [String] -> LocalState -> M (F ([String], d)) +resolveSymbol :: (ExportableDecl d) => A -> [String] -> LocalState -> M (F d) resolveSymbol a (p : ps) (LocalState {ephemeralScope = ephemeralScope, currentScopePath = currentPath}) = do GlobalState {unitInterface = UnitInterface {rootScope = rootScope}} <- get @@ -265,7 +303,7 @@ resolveSymbol a (p : ps) (LocalState {ephemeralScope = ephemeralScope, currentSc return $ case matches of - [(p, (_, e))] -> Right (toList p, e) + [(_, (_, e))] -> Right e [] -> Left [ Diagnostic @@ -307,7 +345,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do 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} -> @@ -320,8 +358,10 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do <$> advanceStage localState'' st <*> pure a PackageDecl _ name body ann -> - let qualifiedName = qualify (nameToList name) - localState'' = modifyCurrentScopePath (pushScope (nameToList name)) localState' + let (qualifiedName, localState'') = + pushPackage + (nameToList name) + localState' decl = ExportedPackageDecl (metadata qualifiedName) in do insertDecl decl @@ -332,7 +372,10 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do <$> mapM (advanceStage localState'') body <*> pure ann LocationDecl _ ident expr ann -> - let qualifiedName = qualify (NonEmpty.singleton (identToString ident)) + let qualifiedName = + fmap + (const $ identToString ident) + (currentQualifiedPath localState') in do expr' <- advanceStage localState' expr let decl = @@ -347,7 +390,10 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do <$> advanceStage localState' expr <*> pure ann BitsDecl _ ident typ ann -> - let qualifiedName = qualify (NonEmpty.singleton (identToString ident)) + let qualifiedName = + fmap + (const $ identToString ident) + (currentQualifiedPath localState) in do sizeBits <- getBitTypeDeclaredSize typ let decl = @@ -362,11 +408,10 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do <$> advanceStage localState' typ <*> pure ann ObjTypeDecl _ ident body ann -> - let qualifiedName = qualify (NonEmpty.singleton (identToString ident)) - localState'' = - modifyCurrentScopePath - (pushScope (NonEmpty.singleton $ identToString ident)) - localState' + let (qualifiedName, localState'') = + pushObject + (identToString ident) + localState in do typeSize <- calculateTypeSize =<< resolveOrFail body let decl = @@ -381,7 +426,10 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do <$> mapM (advanceStage localState'') body <*> pure ann ObjectDecl _ ident loc typ ann -> - let qualifiedName = qualify (NonEmpty.singleton (identToString ident)) + let qualifiedName = + fmap + (const $ identToString ident) + (currentQualifiedPath localState) in do location <- resolveLocationExpression localState' loc typ' <- advanceStage localState' typ @@ -414,10 +462,8 @@ objTypeToExport ls = \case <$> objTypeToExport ls objType <*> pure (trueValue size) ReferencedObjType {refName = n} -> do - (full, _ :: ExportedTypeDecl) <- resolveOrFail =<< resolveName n ls - case full of - (f : fs) -> return $ ReferencedObjectType (f :| fs) - _ -> compilationFailure + (td :: ExportedTypeDecl) <- resolveOrFail =<< resolveName n ls + return $ ReferencedObjectType (metadataFullyQualifiedPath $ getMetadata td) calculateTypeSize :: ObjTypeBody Expanded F A -> M (N Bytes) calculateTypeSize (ObjTypeBody bodyType decls _) = @@ -446,7 +492,7 @@ resolveLocationExpression :: Expression u stage F A -> M (N u) resolveLocationExpression ls (Var var _) = do - (_, ExportedLocationDecl _ v) <- resolveOrFail =<< resolveName var ls + (ExportedLocationDecl _ v) <- resolveOrFail =<< resolveName var ls return (fromIntegral v) resolveLocationExpression _ e = expressionToIntM e |