diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler/Qualification.hs')
| -rw-r--r-- | src/Language/Fiddle/Compiler/Qualification.hs | 54 |
1 files changed, 36 insertions, 18 deletions
diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs index 1307c2a..81e6ac4 100644 --- a/src/Language/Fiddle/Compiler/Qualification.hs +++ b/src/Language/Fiddle/Compiler/Qualification.hs @@ -1,4 +1,4 @@ --- | Qualification compilation phase. +-- | Qualification compilation pha se. -- -- The qualification phase is responsible for resolving all type references in -- the AST to their fully-qualified counterparts. This process involves @@ -82,18 +82,36 @@ pushPackage pk ls = let q = currentQualifiedPath ls in q {packagePart = packagePart q ++ h, basenamePart = l} -pushObject :: String -> LocalState -> (QualifiedPath String, LocalState) -pushObject objName ls = +pushObject :: NonEmpty String -> LocalState -> (QualifiedPath String, LocalState) +pushObject obj ls = let q = currentQualifiedPath ls - in ( fmap (const objName) q, + in ( qualifyObject obj, ls - { currentScopePath = pushScope (NonEmpty.singleton objName) (currentScopePath ls), + { currentScopePath = pushScope obj (currentScopePath ls), currentQualifiedPath = q - { objectPart = Just objName + { objectPart = objectPart q ++ NonEmpty.toList obj } } ) + where + qualifyObject :: NonEmpty String -> QualifiedPath String + qualifyObject (NonEmpty.reverse -> (l :| (reverse -> h))) = + let q = currentQualifiedPath ls + in q {objectPart = objectPart 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 = objName +-- } +-- } +-- ) pushRegister :: String -> LocalState -> (QualifiedPath String, LocalState) pushRegister regName ls = @@ -103,14 +121,14 @@ pushRegister regName ls = { currentScopePath = pushScope (NonEmpty.singleton regName) (currentScopePath ls), currentQualifiedPath = q - { registerPart = registerPart q ++ [regName] + { registerPart = registerPart q ++ [regName] } } ) qualificationPhase :: CompilationPhase Expanded Qualified qualificationPhase = - let initialQualifiedPath = QualifiedPath [] Nothing [] () + let initialQualifiedPath = QualifiedPath [] [] [] () in pureCompilationPhase $ \t -> do raw <- fmap snd $ @@ -162,7 +180,7 @@ instance AdvanceStage S RegisterBitsDecl where <*> pure name <*> pure an DefinedBits _ mod ident typ an -> do - let (path, _) = pushObject (identToString ident) localState + let (path, _) = pushRegister (identToString ident) localState qMeta = QBitsMetadata { bitsSpan = Vacant, @@ -389,11 +407,11 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do ident <$> advanceStage localState' expr <*> pure ann - BitsDecl _ ident typ ann -> - let qualifiedName = - fmap - (const $ identToString ident) - (currentQualifiedPath localState) + BitsDecl _ name@(Name ids _) typ ann -> + let (qualifiedName, _) = + pushObject + (fmap identToString ids) + localState in do sizeBits <- getBitTypeDeclaredSize typ let decl = @@ -404,13 +422,13 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do doReturn =<< BitsDecl (qMd decl) - ident + name <$> advanceStage localState' typ <*> pure ann - ObjTypeDecl _ ident body ann -> + ObjTypeDecl _ name@(Name ids _) body ann -> let (qualifiedName, localState'') = pushObject - (identToString ident) + (fmap identToString ids) localState in do typeSize <- calculateTypeSize =<< resolveOrFail body @@ -422,7 +440,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do doReturn =<< ObjTypeDecl (qMd decl) - ident + name <$> mapM (advanceStage localState'') body <*> pure ann ObjectDecl _ ident loc typ ann -> |