diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler')
| -rw-r--r-- | src/Language/Fiddle/Compiler/Backend/C.hs | 2 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/ConsistencyCheck.hs | 16 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Expansion.hs | 8 | ||||
| -rw-r--r-- | src/Language/Fiddle/Compiler/Qualification.hs | 17 |
4 files changed, 25 insertions, 18 deletions
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs index 5379099..2e6421e 100644 --- a/src/Language/Fiddle/Compiler/Backend/C.hs +++ b/src/Language/Fiddle/Compiler/Backend/C.hs @@ -265,7 +265,7 @@ transpileWalk sourceFile headerFile t _ = case () of withFileAt headerFile middlePos $ do pad $ do emitDocComments a - struct (identifierFor metadata) $ do + struct (identifierFor (unwrap metadata)) $ do structBody objTypeBody return Stop _ -> return (Continue ()) diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs index a4f252e..552ea40 100644 --- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs +++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs @@ -35,6 +35,9 @@ type A = Commented SourceSpan type M = Compile () +pattern QMdP :: t -> Identity (When True t) +pattern QMdP t = Identity (Present t) + instance CompilationStage Checked where type StageAfter Checked = TypeError (TypeError.Text "No stage after Checked") type StageMonad Checked = M @@ -85,19 +88,19 @@ instance AdvanceStage S FiddleUnit where doWalk t = case () of () - | (Just (PackageDecl {packageQualificationMetadata = (Identity d)})) <- + | (Just (PackageDecl {packageQualificationMetadata = (QMdP d)})) <- castTS t -> tell (UnitInterface.singleton d) - | (Just (LocationDecl {locationQualificationMetadata = (Identity d)})) <- + | (Just (LocationDecl {locationQualificationMetadata = (QMdP d)})) <- castTS t -> tell (UnitInterface.singleton d) - | (Just (BitsDecl {bitsQualificationMetadata = (Identity d)})) <- + | (Just (BitsDecl {bitsQualificationMetadata = (QMdP d)})) <- castTS t -> tell (UnitInterface.singleton d) - | (Just (ObjTypeDecl {objTypeQualificationMetadata = (Identity d)})) <- + | (Just (ObjTypeDecl {objTypeQualificationMetadata = (QMdP d)})) <- castTS t -> tell (UnitInterface.singleton d) - | (Just (ObjectDecl {objectQualificationMetadata = (Identity d)})) <- + | (Just (ObjectDecl {objectQualificationMetadata = (QMdP d)})) <- castTS t -> tell (UnitInterface.singleton d) | (Just (ImportStatement {importInterface = ii})) <- @@ -242,8 +245,9 @@ bitsTypeSize (RegisterBitsArray tr nExpr _) = do bitsTypeSize RegisterBitsReference { bitsRefQualificationMetadata = - Identity (ExportedBitsDecl {exportedBitsDeclSizeBits = sz}) + QMdP (ExportedBitsDecl {exportedBitsDeclSizeBits = sz}) } = return sz +bitsTypeSize (RegisterBitsReference {}) = error "should be exhaustive" bitsTypeSize (RegisterBitsJustBits expr _) = expressionToIntM expr diff --git a/src/Language/Fiddle/Compiler/Expansion.hs b/src/Language/Fiddle/Compiler/Expansion.hs index 935d8ee..ca97fc4 100644 --- a/src/Language/Fiddle/Compiler/Expansion.hs +++ b/src/Language/Fiddle/Compiler/Expansion.hs @@ -130,14 +130,14 @@ instance AdvanceStage CurrentStage RegisterBitsTypeRef where ident <- internAnonymousBitsType path =<< advanceStage path anonType - return $ RegisterBitsReference (pure ()) (identToName ident) annot + return $ RegisterBitsReference (Identity Vacant) (identToName ident) annot instance AdvanceStage CurrentStage ObjType where advanceStage path = \case (AnonymousObjType _ (Identity body) annot) -> do body' <- advanceStage path body identifier <- internObjType path body' - return (ReferencedObjType (pure ()) (identToName identifier) annot) + return (ReferencedObjType (Identity Vacant) (identToName identifier) annot) (ReferencedObjType q name annot) -> return $ ReferencedObjType q name annot (ArrayObjType objType expr a) -> @@ -197,13 +197,13 @@ reconfigureFiddleDecls p decls = do where resolveAnonymousObjType (Linkage linkage, objTypeBody) = ObjTypeDecl - (pure ()) + (Identity Vacant) (Identifier linkage (annot objTypeBody)) (pure objTypeBody) (annot objTypeBody) resolveAnonymousBitsType (Linkage linkage, AnonymousEnumBody expr body a) = - BitsDecl (pure ()) (Identifier linkage a) (EnumBitType expr body a) a + BitsDecl (Identity Vacant) (Identifier linkage a) (EnumBitType expr body a) a identToName :: Identifier I a -> Name I a identToName ident = Name (NonEmpty.singleton ident) (annot ident) diff --git a/src/Language/Fiddle/Compiler/Qualification.hs b/src/Language/Fiddle/Compiler/Qualification.hs index a39e5dc..0f7158d 100644 --- a/src/Language/Fiddle/Compiler/Qualification.hs +++ b/src/Language/Fiddle/Compiler/Qualification.hs @@ -96,7 +96,7 @@ instance AdvanceStage S RegisterBitsTypeRef where <$> advanceStage localState a <*> pure b RegisterBitsReference _ name a -> do - v <- fmap snd <$> resolveName name localState + v <- fmap (Present . snd) <$> resolveName name localState return $ RegisterBitsReference v name a instance AdvanceStage S ObjType where @@ -107,7 +107,7 @@ instance AdvanceStage S ObjType where <*> advanceStage localState b <*> pure c ReferencedObjType _ name a -> do - v <- fmap snd <$> resolveName name localState + v <- fmap (Present . snd) <$> resolveName name localState return $ ReferencedObjType v name a deriving instance (AdvanceStage S t) => AdvanceStage S (Directed t) @@ -176,6 +176,9 @@ resolveSymbol a (p : ps) (LocalState {ephemeralScope = ephemeralScope, currentSc resolveSymbol a _ _ = return $ Left [Diagnostic Error "Empty path provided (this is a bug)" (unCommented a)] +qMd :: (Applicative f) => t -> f (QMd Qualified t) +qMd = pure . Present + advanceFiddleDecls :: LocalState -> [Directed FiddleDecl S F A] -> @@ -213,7 +216,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do insertDecl decl doReturn =<< PackageDecl - (pure decl) + (qMd decl) name <$> mapM (advanceStage localState'') body <*> pure ann @@ -228,7 +231,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do insertDecl decl doReturn =<< LocationDecl - (pure decl) + (qMd decl) ident <$> advanceStage localState' expr <*> pure ann @@ -243,7 +246,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do insertDecl decl doReturn =<< BitsDecl - (pure decl) + (qMd decl) ident <$> advanceStage localState' typ <*> pure ann @@ -258,7 +261,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do insertDecl decl doReturn =<< ObjTypeDecl - (pure decl) + (qMd decl) ident <$> mapM (advanceStage localState') body <*> pure ann @@ -275,7 +278,7 @@ advanceFiddleDecls localState decls = fmap (reverse . fst) $ do insertDecl decl doReturn =<< ObjectDecl - (pure decl) + (qMd decl) ident <$> advanceStage localState' loc <*> advanceStage localState' typ |