diff --git a/src/Juvix/Compiler/Core/Data/InfoTable.hs b/src/Juvix/Compiler/Core/Data/InfoTable.hs index f603cd0515..e643c6f0d6 100644 --- a/src/Juvix/Compiler/Core/Data/InfoTable.hs +++ b/src/Juvix/Compiler/Core/Data/InfoTable.hs @@ -12,7 +12,9 @@ data InfoTable = InfoTable _infoIdentifiers :: HashMap Symbol IdentifierInfo, _infoInductives :: HashMap Symbol InductiveInfo, _infoConstructors :: HashMap Tag ConstructorInfo, - _infoAxioms :: HashMap Name AxiomInfo + _infoAxioms :: HashMap Name AxiomInfo, + _infoNextSymbol :: Word, + _infoNextTag :: Word } emptyInfoTable :: InfoTable @@ -24,7 +26,9 @@ emptyInfoTable = _infoIdentifiers = mempty, _infoInductives = mempty, _infoConstructors = mempty, - _infoAxioms = mempty + _infoAxioms = mempty, + _infoNextSymbol = 0, + _infoNextTag = 0 } data IdentKind = IdentSym Symbol | IdentTag Tag diff --git a/src/Juvix/Compiler/Core/Data/InfoTableBuilder.hs b/src/Juvix/Compiler/Core/Data/InfoTableBuilder.hs index acaa3c7972..5315b16e0d 100644 --- a/src/Juvix/Compiler/Core/Data/InfoTableBuilder.hs +++ b/src/Juvix/Compiler/Core/Data/InfoTableBuilder.hs @@ -26,52 +26,35 @@ checkSymbolDefined sym = do tab <- getInfoTable return $ HashMap.member sym (tab ^. identContext) -data BuilderState = BuilderState - { _stateNextSymbol :: Word, - _stateNextUserTag :: Word, - _stateInfoTable :: InfoTable - } - -makeLenses ''BuilderState - -initBuilderState :: InfoTable -> BuilderState -initBuilderState tab = - BuilderState - { _stateNextSymbol = fromIntegral $ HashMap.size (tab ^. infoIdentifiers), - _stateNextUserTag = fromIntegral $ HashMap.size (tab ^. infoConstructors), - _stateInfoTable = tab - } - runInfoTableBuilder :: InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r (InfoTable, a) runInfoTableBuilder tab = - fmap (first (^. stateInfoTable)) - . runState (initBuilderState tab) + runState tab . reinterpret interp where - interp :: InfoTableBuilder m a -> Sem (State BuilderState : r) a + interp :: InfoTableBuilder m a -> Sem (State InfoTable : r) a interp = \case FreshSymbol -> do - modify' (over stateNextSymbol (+ 1)) s <- get - return (s ^. stateNextSymbol - 1) + modify' (over infoNextSymbol (+ 1)) + return (s ^. infoNextSymbol) FreshTag -> do - modify' (over stateNextUserTag (+ 1)) s <- get - return (UserTag (s ^. stateNextUserTag - 1)) + modify' (over infoNextTag (+ 1)) + return (UserTag (s ^. infoNextTag)) RegisterIdent ii -> do - modify' (over stateInfoTable (over infoIdentifiers (HashMap.insert (ii ^. identifierSymbol) ii))) + modify' (over infoIdentifiers (HashMap.insert (ii ^. identifierSymbol) ii)) whenJust (ii ^? identifierName . _Just . nameText) $ \name -> - modify' (over stateInfoTable (over identMap (HashMap.insert name (IdentSym (ii ^. identifierSymbol))))) + modify' (over identMap (HashMap.insert name (IdentSym (ii ^. identifierSymbol)))) RegisterConstructor ci -> do - modify' (over stateInfoTable (over infoConstructors (HashMap.insert (ci ^. constructorTag) ci))) - modify' (over stateInfoTable (over identMap (HashMap.insert (ci ^. (constructorName . nameText)) (IdentTag (ci ^. constructorTag))))) + modify' (over infoConstructors (HashMap.insert (ci ^. constructorTag) ci)) + modify' (over identMap (HashMap.insert (ci ^. (constructorName . nameText)) (IdentTag (ci ^. constructorTag)))) RegisterIdentNode sym node -> - modify' (over stateInfoTable (over identContext (HashMap.insert sym node))) + modify' (over identContext (HashMap.insert sym node)) SetIdentArgsInfo sym argsInfo -> do - modify' (over stateInfoTable (over infoIdentifiers (HashMap.adjust (set identifierArgsInfo argsInfo) sym))) - modify' (over stateInfoTable (over infoIdentifiers (HashMap.adjust (set identifierArgsNum (length argsInfo)) sym))) + modify' (set (infoIdentifiers . at sym . _Just . identifierArgsInfo) argsInfo) + modify' (set (infoIdentifiers . at sym . _Just . identifierArgsNum) (length argsInfo)) GetIdent txt -> do s <- get - return $ HashMap.lookup txt (s ^. (stateInfoTable . identMap)) + return $ HashMap.lookup txt (s ^. identMap) GetInfoTable -> - get <&> (^. stateInfoTable) + get diff --git a/tests/Core/positive/lambda-lifting/test1.out b/tests/Core/positive/lambda-lifting/test1.out index 12b80c3cc9..fbc55a87b8 100644 --- a/tests/Core/positive/lambda-lifting/test1.out +++ b/tests/Core/positive/lambda-lifting/test1.out @@ -1,3 +1,3 @@ -- IdentContext -def 1 := λg λx λy λz g$3 x$2 -def t1 := λg λf f$0 (!1 g$1) +def t1 := λg λf f$0 (!7 g$1) +def 7 := λg λx λy λz g$3 x$2 diff --git a/tests/Core/positive/lambda-lifting/test2.out b/tests/Core/positive/lambda-lifting/test2.out index 11bd69ce52..023092bd51 100644 --- a/tests/Core/positive/lambda-lifting/test2.out +++ b/tests/Core/positive/lambda-lifting/test2.out @@ -1,6 +1,6 @@ -- IdentContext -def 1 := λx λw w$0 x$1 -def 2 := λy λx λe y$2 e$0 x$1 y$2 -def 3 := λy λx λz z$0 y$2 x$1 (!1 x$1) (!2 x$1 y$2) -def 4 := λs λx λy s$2 y$0 (!3 x$1 y$0) -def t2 := λr λs r$1 (!4 s$0) +def t2 := λr λs r$1 (!10 s$0) +def 7 := λx λw w$0 x$1 +def 8 := λy λx λe y$2 e$0 x$1 y$2 +def 9 := λy λx λz z$0 y$2 x$1 (!7 x$1) (!8 x$1 y$2) +def 10 := λs λx λy s$2 y$0 (!9 x$1 y$0) diff --git a/tests/Core/positive/lambda-lifting/test3.out b/tests/Core/positive/lambda-lifting/test3.out index 2cd9e3f7c6..3055cfffe4 100644 --- a/tests/Core/positive/lambda-lifting/test3.out +++ b/tests/Core/positive/lambda-lifting/test3.out @@ -1,6 +1,6 @@ -- IdentContext -def 3 := λx x$0 -def 4 := λr λx r$1 def const := λx λy x$1 def id := λx x$0 -def t3 := λr λs const !3 (id (!4 r$1)) +def t3 := λr λs const !9 (id (!10 r$1)) +def 9 := λx x$0 +def 10 := λr λx r$1