diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler/ConsistencyCheck.hs')
| -rw-r--r-- | src/Language/Fiddle/Compiler/ConsistencyCheck.hs | 64 |
1 files changed, 32 insertions, 32 deletions
diff --git a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs index 3286e86..2f570a4 100644 --- a/src/Language/Fiddle/Compiler/ConsistencyCheck.hs +++ b/src/Language/Fiddle/Compiler/ConsistencyCheck.hs @@ -46,6 +46,8 @@ data GlobalState = GlobalState newtype LocalState = LocalState (ScopePath String) +type CurrentStage = Qualified + type I = Identity type Annot = Commented SourceSpan @@ -54,13 +56,11 @@ type SizeBits = Word32 type SizeBytes = Word32 -consistencyCheckPhase :: - CompilationPhase Expanded Checked -consistencyCheckPhase = - CompilationPhase (pure ()) (\_ _ -> return ([], Just ())) (\_ _ -> checkConsistency) +consistencyCheckPhase :: CompilationPhase CurrentStage Checked +consistencyCheckPhase = pureCompilationPhase checkConsistency checkConsistency :: - FiddleUnit Expanded I Annot -> + FiddleUnit CurrentStage I Annot -> Compile () (FiddleUnit Checked I Annot) checkConsistency = fmap snd @@ -74,14 +74,14 @@ instance CompilationStage Checked where type StageFunctor Checked = Identity type StageAnnotation Checked = Commented SourceSpan -instance CompilationStage Expanded where - type StageAfter Expanded = Checked - type StageMonad Expanded = Compile GlobalState - type StageState Expanded = LocalState - type StageFunctor Expanded = Identity - type StageAnnotation Expanded = Commented SourceSpan +instance CompilationStage CurrentStage where + type StageAfter CurrentStage = Checked + type StageMonad CurrentStage = Compile GlobalState + type StageState CurrentStage = LocalState + type StageFunctor CurrentStage = Identity + type StageAnnotation CurrentStage = Commented SourceSpan -instance AdvanceStage Expanded FiddleUnit where +instance AdvanceStage CurrentStage FiddleUnit where advanceStage localState (FiddleUnit _ decls a) = do decls' <- mapM (advanceStage localState) decls intf <- gets unitInterface @@ -91,27 +91,27 @@ instance AdvanceStage Expanded FiddleUnit where -- decls' <- mapM (advanceStage localState) decls -deriving instance AdvanceStage Expanded Expression +deriving instance AdvanceStage CurrentStage Expression -deriving instance AdvanceStage Expanded ObjType +deriving instance AdvanceStage CurrentStage ObjType -deriving instance AdvanceStage Expanded DeferredRegisterBody +deriving instance AdvanceStage CurrentStage DeferredRegisterBody -deriving instance AdvanceStage Expanded RegisterBitsDecl +deriving instance AdvanceStage CurrentStage RegisterBitsDecl -deriving instance AdvanceStage Expanded RegisterBitsTypeRef +deriving instance AdvanceStage CurrentStage RegisterBitsTypeRef -deriving instance AdvanceStage Expanded AnonymousBitsType +deriving instance AdvanceStage CurrentStage AnonymousBitsType -deriving instance AdvanceStage Expanded BitType +deriving instance AdvanceStage CurrentStage BitType -deriving instance AdvanceStage Expanded EnumBody +deriving instance AdvanceStage CurrentStage EnumBody -deriving instance AdvanceStage Expanded EnumConstantDecl +deriving instance AdvanceStage CurrentStage EnumConstantDecl -deriving instance AdvanceStage Expanded PackageBody +deriving instance AdvanceStage CurrentStage PackageBody -instance AdvanceStage Expanded ImportStatement where +instance AdvanceStage CurrentStage ImportStatement where modifyState ( ImportStatement { importInterface = @@ -147,17 +147,17 @@ instance AdvanceStage Expanded ImportStatement where ExportedObjType sz -> Right sz ) -deriving instance (AdvanceStage Expanded t) => AdvanceStage Expanded (Directed t) +deriving instance (AdvanceStage CurrentStage t) => AdvanceStage CurrentStage (Directed t) -instance AdvanceStage Expanded RegisterBody where +instance AdvanceStage CurrentStage RegisterBody where advanceStage s body = fst <$> registerBodyToStage3 s body -instance AdvanceStage Expanded ObjTypeBody where +instance AdvanceStage CurrentStage ObjTypeBody where advanceStage s body = fst <$> objTypeBodyToStage3 s body 0 -deriving instance AdvanceStage Expanded FiddleDecl +deriving instance AdvanceStage CurrentStage FiddleDecl -instance AdvanceStage Expanded (Directed FiddleDecl) where +instance AdvanceStage CurrentStage (Directed FiddleDecl) where modifyState (Directed directives t _) s = case t of (BitsDecl id typ annotation) -> do typeSize <- getTypeSize typ @@ -200,7 +200,7 @@ nameToList (Name idents _) = map (\(Identifier (Text.unpack -> s) _) -> s) (toLi objTypeBodyToStage3 :: LocalState -> - ObjTypeBody Expanded I Annot -> + ObjTypeBody CurrentStage I Annot -> Word32 -> Compile GlobalState (ObjTypeBody Checked I Annot, Word32) objTypeBodyToStage3 st (ObjTypeBody bodyType decls a) startOff = do @@ -354,7 +354,7 @@ objTypeBodyToStage3 st (ObjTypeBody bodyType decls a) startOff = do registerBodyToStage3 :: LocalState -> - RegisterBody Expanded I Annot -> + RegisterBody CurrentStage I Annot -> Compile GlobalState (RegisterBody Checked I Annot, Word32) registerBodyToStage3 st @@ -445,7 +445,7 @@ registerBodyToStage3 registerBitsTypeRefToStage3 :: LocalState -> - RegisterBitsTypeRef Expanded I Annot -> + RegisterBitsTypeRef CurrentStage I Annot -> Compile GlobalState (RegisterBitsTypeRef Checked I Annot, Word32) registerBitsTypeRefToStage3 localState = \case RegisterBitsArray ref expr a -> do @@ -535,7 +535,7 @@ lookupTypeSize (LocalState scopePath) (Name idents a) = do ] compilationFailure -getTypeSize :: BitType Expanded I Annot -> Compile s SizeBits +getTypeSize :: BitType CurrentStage I Annot -> Compile s SizeBits getTypeSize (RawBits expr _) = fromIntegral <$> exprToSize expr getTypeSize (EnumBitType expr (Identity (EnumBody constants _)) ann) = do declaredSize <- fromIntegral <$> exprToSize expr |