" $ do
SModuleTop -> optional_ (kw kwEnd >> semicolon)
-- | An ExpressionAtom which is a valid expression on its own.
-atomicExpression :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (ExpressionAtoms 'Parsed)
+atomicExpression :: (Members '[ParserResultBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (ExpressionAtoms 'Parsed)
atomicExpression = do
(atom, loc) <- interval expressionAtom
case atom of
@@ -1688,7 +1663,7 @@ atomicExpression = do
_ -> return ()
return $ ExpressionAtoms (NonEmpty.singleton atom) (Irrelevant loc)
-openModule :: forall r. (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (OpenModule 'Parsed)
+openModule :: forall r. (Members '[ParserResultBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (OpenModule 'Parsed)
openModule = do
_openModuleKw <- kw kwOpen
_openModuleName <- name
@@ -1699,7 +1674,7 @@ openModule = do
return OpenModule {..}
-- TODO is there way to merge this with `openModule`?
-popenModuleParams :: forall r. (Members '[Error ParserError, PathResolver, Files, InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (OpenModuleParams 'Parsed)
+popenModuleParams :: forall r. (Members '[Error ParserError, PathResolver, Files, ParserResultBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (OpenModuleParams 'Parsed)
popenModuleParams = do
_openModuleKw <- kw kwOpen
_openUsingHiding <- optional usingOrHiding
@@ -1708,7 +1683,7 @@ popenModuleParams = do
_openModuleParams = OpenModuleParams {..}
return OpenModuleParams {..}
-usingOrHiding :: (Members '[InfoTableBuilder, JudocStash, NameIdGen, PragmasStash] r) => ParsecS r (UsingHiding 'Parsed)
+usingOrHiding :: (Members '[ParserResultBuilder, JudocStash, NameIdGen, PragmasStash] r) => ParsecS r (UsingHiding 'Parsed)
usingOrHiding =
Using <$> pusingList
<|> Hiding <$> phidingList
diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource/Data/Context.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource/Data/Context.hs
index 6a79e0d842..a394f7a637 100644
--- a/src/Juvix/Compiler/Concrete/Translation/FromSource/Data/Context.hs
+++ b/src/Juvix/Compiler/Concrete/Translation/FromSource/Data/Context.hs
@@ -1,21 +1,12 @@
-module Juvix.Compiler.Concrete.Translation.FromSource.Data.Context
- ( module Juvix.Compiler.Concrete.Translation.FromSource.Data.Context,
- module Juvix.Compiler.Concrete.Data.ParsedInfoTable,
- )
-where
+module Juvix.Compiler.Concrete.Translation.FromSource.Data.Context where
-import Juvix.Compiler.Concrete.Data.ParsedInfoTable
-import Juvix.Compiler.Concrete.Data.ParsedInfoTableBuilder.BuilderState
import Juvix.Compiler.Concrete.Language
-import Juvix.Compiler.Pipeline.EntryPoint
+import Juvix.Compiler.Concrete.Translation.FromSource.Data.ParserState
import Juvix.Prelude
data ParserResult = ParserResult
- { _resultEntry :: EntryPoint,
- _resultTable :: InfoTable,
- _resultModules :: NonEmpty (Module 'Parsed 'ModuleTop),
- _resultBuilderState :: BuilderState
+ { _resultModule :: Module 'Parsed 'ModuleTop,
+ _resultParserState :: ParserState
}
- deriving stock (Show)
makeLenses ''ParserResult
diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource/Data/ParserState.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource/Data/ParserState.hs
new file mode 100644
index 0000000000..8dbda22bcf
--- /dev/null
+++ b/src/Juvix/Compiler/Concrete/Translation/FromSource/Data/ParserState.hs
@@ -0,0 +1,29 @@
+module Juvix.Compiler.Concrete.Translation.FromSource.Data.ParserState where
+
+import Juvix.Compiler.Concrete.Data.ParsedItem
+import Juvix.Compiler.Concrete.Language
+import Juvix.Prelude
+
+data ParserState = ParserState
+ { _parserStateImports :: [Import 'Parsed],
+ _parserStateComments :: [SpaceSpan],
+ _parserStateParsedItems :: [ParsedItem]
+ }
+
+makeLenses ''ParserState
+
+instance Semigroup ParserState where
+ s1 <> s2 =
+ ParserState
+ { _parserStateImports = s1 ^. parserStateImports <> s2 ^. parserStateImports,
+ _parserStateComments = s1 ^. parserStateComments <> s2 ^. parserStateComments,
+ _parserStateParsedItems = s1 ^. parserStateParsedItems <> s2 ^. parserStateParsedItems
+ }
+
+instance Monoid ParserState where
+ mempty =
+ ParserState
+ { _parserStateImports = mempty,
+ _parserStateComments = mempty,
+ _parserStateParsedItems = mempty
+ }
diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource/Lexer.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource/Lexer.hs
index be3f0995c1..8bcc310a73 100644
--- a/src/Juvix/Compiler/Concrete/Translation/FromSource/Lexer.hs
+++ b/src/Juvix/Compiler/Concrete/Translation/FromSource/Lexer.hs
@@ -8,10 +8,10 @@ where
import Data.Text qualified as Text
import GHC.Unicode
-import Juvix.Compiler.Concrete.Data.ParsedInfoTableBuilder
import Juvix.Compiler.Concrete.Extra hiding (Pos, hspace, space, string')
import Juvix.Compiler.Concrete.Extra qualified as P
import Juvix.Compiler.Concrete.Keywords
+import Juvix.Compiler.Concrete.Translation.FromSource.ParserResultBuilder
import Juvix.Data.Keyword
import Juvix.Extra.Strings qualified as Str
import Juvix.Parser.Lexer
@@ -20,37 +20,37 @@ import Text.Megaparsec.Char.Lexer qualified as L
type OperatorSym = Text
-judocText :: (Members '[InfoTableBuilder] r) => ParsecS r a -> ParsecS r a
+judocText :: (Members '[ParserResultBuilder] r) => ParsecS r a -> ParsecS r a
judocText c = do
(a, i) <- interval c
P.lift (registerJudocText i)
return a
-judocText_ :: (Members '[InfoTableBuilder] r) => ParsecS r a -> ParsecS r ()
+judocText_ :: (Members '[ParserResultBuilder] r) => ParsecS r a -> ParsecS r ()
judocText_ = void . judocText
-space :: forall r. (Members '[InfoTableBuilder] r) => ParsecS r ()
+space :: forall r. (Members '[ParserResultBuilder] r) => ParsecS r ()
space = space' True >>= mapM_ (P.lift . registerSpaceSpan)
-lexeme :: (Members '[InfoTableBuilder] r) => ParsecS r a -> ParsecS r a
+lexeme :: (Members '[ParserResultBuilder] r) => ParsecS r a -> ParsecS r a
lexeme = L.lexeme space
-symbol :: (Members '[InfoTableBuilder] r) => Text -> ParsecS r ()
+symbol :: (Members '[ParserResultBuilder] r) => Text -> ParsecS r ()
symbol = void . L.symbol space
-lexemeInterval :: (Members '[InfoTableBuilder] r) => ParsecS r a -> ParsecS r (a, Interval)
+lexemeInterval :: (Members '[ParserResultBuilder] r) => ParsecS r a -> ParsecS r (a, Interval)
lexemeInterval = lexeme . interval
-decimal :: (Members '[InfoTableBuilder] r, Num n) => ParsecS r (n, Interval)
+decimal :: (Members '[ParserResultBuilder] r, Num n) => ParsecS r (n, Interval)
decimal = lexemeInterval L.decimal
-identifier :: (Members '[InfoTableBuilder] r) => ParsecS r Text
+identifier :: (Members '[ParserResultBuilder] r) => ParsecS r Text
identifier = fmap fst identifierL
-identifierL :: (Members '[InfoTableBuilder] r) => ParsecS r (Text, Interval)
+identifierL :: (Members '[ParserResultBuilder] r) => ParsecS r (Text, Interval)
identifierL = lexeme bareIdentifier
-integer :: (Members '[InfoTableBuilder] r) => ParsecS r (WithLoc Integer)
+integer :: (Members '[ParserResultBuilder] r) => ParsecS r (WithLoc Integer)
integer = do
(num, i) <- integer' decimal
return (WithLoc i num)
@@ -70,26 +70,26 @@ bracedString =
void (char '\\')
char '}'
-string :: (Members '[InfoTableBuilder] r) => ParsecS r (Text, Interval)
+string :: (Members '[ParserResultBuilder] r) => ParsecS r (Text, Interval)
string = lexemeInterval string'
judocExampleStart :: ParsecS r ()
judocExampleStart = P.chunk Str.judocExample >> hspace_
-judocBlockEnd :: (Members '[InfoTableBuilder] r) => ParsecS r KeywordRef
+judocBlockEnd :: (Members '[ParserResultBuilder] r) => ParsecS r KeywordRef
judocBlockEnd = kw delimJudocBlockEnd
-judocBlockStart :: (Members '[InfoTableBuilder] r) => ParsecS r KeywordRef
+judocBlockStart :: (Members '[ParserResultBuilder] r) => ParsecS r KeywordRef
judocBlockStart = kwBare delimJudocBlockStart
-judocStart :: (Members '[InfoTableBuilder] r) => ParsecS r KeywordRef
+judocStart :: (Members '[ParserResultBuilder] r) => ParsecS r KeywordRef
judocStart = kwBare delimJudocStart <* hspace_
-- | Does not consume space after it
-kwBare :: (Member InfoTableBuilder r) => Keyword -> ParsecS r KeywordRef
+kwBare :: (Member ParserResultBuilder r) => Keyword -> ParsecS r KeywordRef
kwBare k = kw' k >>= P.lift . registerKeyword
-kw :: (Member InfoTableBuilder r) => Keyword -> ParsecS r KeywordRef
+kw :: (Member ParserResultBuilder r) => Keyword -> ParsecS r KeywordRef
kw = lexeme . kwBare
-- | Same as @identifier@ but does not consume space after it.
@@ -99,41 +99,41 @@ bareIdentifier = interval (rawIdentifier allKeywordStrings)
dot :: forall e m. (MonadParsec e Text m) => m Char
dot = P.char '.'
-dottedIdentifier :: (Members '[InfoTableBuilder] r) => ParsecS r (NonEmpty (Text, Interval))
+dottedIdentifier :: (Members '[ParserResultBuilder] r) => ParsecS r (NonEmpty (Text, Interval))
dottedIdentifier = lexeme $ P.sepBy1 bareIdentifier dot
-delim :: (Members '[InfoTableBuilder] r) => Text -> ParsecS r ()
+delim :: (Members '[ParserResultBuilder] r) => Text -> ParsecS r ()
delim sym = lexeme $ delim' sym >>= P.lift . registerDelimiter
-lbrace :: (Members '[InfoTableBuilder] r) => ParsecS r ()
+lbrace :: (Members '[ParserResultBuilder] r) => ParsecS r ()
lbrace = delim "{"
-rbrace :: (Members '[InfoTableBuilder] r) => ParsecS r ()
+rbrace :: (Members '[ParserResultBuilder] r) => ParsecS r ()
rbrace = delim "}"
-ldoubleBrace :: (Members '[InfoTableBuilder] r) => ParsecS r ()
+ldoubleBrace :: (Members '[ParserResultBuilder] r) => ParsecS r ()
ldoubleBrace = delim "{{"
-rdoubleBrace :: (Members '[InfoTableBuilder] r) => ParsecS r ()
+rdoubleBrace :: (Members '[ParserResultBuilder] r) => ParsecS r ()
rdoubleBrace = delim "}}"
-lparen :: (Members '[InfoTableBuilder] r) => ParsecS r ()
+lparen :: (Members '[ParserResultBuilder] r) => ParsecS r ()
lparen = delim "("
-rparen :: (Members '[InfoTableBuilder] r) => ParsecS r ()
+rparen :: (Members '[ParserResultBuilder] r) => ParsecS r ()
rparen = delim ")"
-pipe :: (Members '[InfoTableBuilder] r) => ParsecS r ()
+pipe :: (Members '[ParserResultBuilder] r) => ParsecS r ()
pipe = delim "|"
-semicolon :: (Members '[InfoTableBuilder] r) => ParsecS r ()
+semicolon :: (Members '[ParserResultBuilder] r) => ParsecS r ()
semicolon = delim ";"
-parens :: (Members '[InfoTableBuilder] r) => ParsecS r a -> ParsecS r a
+parens :: (Members '[ParserResultBuilder] r) => ParsecS r a -> ParsecS r a
parens = between lparen rparen
-braces :: (Members '[InfoTableBuilder] r) => ParsecS r a -> ParsecS r a
+braces :: (Members '[ParserResultBuilder] r) => ParsecS r a -> ParsecS r a
braces = between lbrace rbrace
-doubleBraces :: (Members '[InfoTableBuilder] r) => ParsecS r a -> ParsecS r a
+doubleBraces :: (Members '[ParserResultBuilder] r) => ParsecS r a -> ParsecS r a
doubleBraces = between ldoubleBrace rdoubleBrace
diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource/ParserResultBuilder.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource/ParserResultBuilder.hs
new file mode 100644
index 0000000000..ee474a6ba9
--- /dev/null
+++ b/src/Juvix/Compiler/Concrete/Translation/FromSource/ParserResultBuilder.hs
@@ -0,0 +1,88 @@
+module Juvix.Compiler.Concrete.Translation.FromSource.ParserResultBuilder where
+
+import Juvix.Compiler.Concrete.Data.Highlight.Input
+import Juvix.Compiler.Concrete.Data.Literal
+import Juvix.Compiler.Concrete.Language
+import Juvix.Compiler.Concrete.Translation.FromSource.Data.ParserState
+import Juvix.Prelude
+
+data ParserResultBuilder m a where
+ RegisterItem :: ParsedItem -> ParserResultBuilder m ()
+ RegisterSpaceSpan :: SpaceSpan -> ParserResultBuilder m ()
+ RegisterImport :: Import 'Parsed -> ParserResultBuilder m ()
+
+makeSem ''ParserResultBuilder
+
+registerKeyword :: (Member ParserResultBuilder r) => KeywordRef -> Sem r KeywordRef
+registerKeyword r =
+ r
+ <$ registerItem
+ ParsedItem
+ { _parsedLoc = getLoc r,
+ _parsedTag = ann
+ }
+ where
+ ann = case r ^. keywordRefKeyword . keywordType of
+ KeywordTypeKeyword -> ParsedTagKeyword
+ KeywordTypeJudoc -> ParsedTagJudoc
+ KeywordTypeDelimiter -> ParsedTagDelimiter
+
+registerDelimiter :: (Member ParserResultBuilder r) => Interval -> Sem r ()
+registerDelimiter i =
+ registerItem
+ ParsedItem
+ { _parsedLoc = i,
+ _parsedTag = ParsedTagDelimiter
+ }
+
+registerJudocText :: (Member ParserResultBuilder r) => Interval -> Sem r ()
+registerJudocText i =
+ registerItem
+ ParsedItem
+ { _parsedLoc = i,
+ _parsedTag = ParsedTagJudoc
+ }
+
+registerPragmas :: (Member ParserResultBuilder r) => Interval -> Sem r ()
+registerPragmas i =
+ registerItem
+ ParsedItem
+ { _parsedLoc = i,
+ _parsedTag = ParsedTagPragma
+ }
+
+registerLiteral :: (Member ParserResultBuilder r) => LiteralLoc -> Sem r LiteralLoc
+registerLiteral l =
+ l
+ <$ registerItem
+ ParsedItem
+ { _parsedLoc = loc,
+ _parsedTag = tag
+ }
+ where
+ tag = case l ^. withLocParam of
+ LitString {} -> ParsedTagLiteralString
+ LitInteger {} -> ParsedTagLiteralInt
+ loc = getLoc l
+
+registerItem' :: (Member (State ParserState) r) => ParsedItem -> Sem r ()
+registerItem' i = modify' (over parserStateParsedItems (i :))
+
+runParserResultBuilder :: (Member HighlightBuilder r) => ParserState -> Sem (ParserResultBuilder ': r) a -> Sem r (ParserState, a)
+runParserResultBuilder s =
+ runState s
+ . reinterpret
+ ( \case
+ RegisterImport i -> modify' (over parserStateImports (i :))
+ RegisterItem i -> do
+ modify' (over highlightParsed (i :))
+ registerItem' i
+ RegisterSpaceSpan g -> do
+ modify' (over parserStateComments (g :))
+ forM_ (g ^.. spaceSpan . each . _SpaceComment) $ \c ->
+ registerItem'
+ ParsedItem
+ { _parsedLoc = getLoc c,
+ _parsedTag = ParsedTagComment
+ }
+ )
diff --git a/src/Juvix/Compiler/Core/Data.hs b/src/Juvix/Compiler/Core/Data.hs
index f431b55b91..42ff0f294b 100644
--- a/src/Juvix/Compiler/Core/Data.hs
+++ b/src/Juvix/Compiler/Core/Data.hs
@@ -1,8 +1,10 @@
module Juvix.Compiler.Core.Data
( module Juvix.Compiler.Core.Data.InfoTable,
module Juvix.Compiler.Core.Data.InfoTableBuilder,
+ module Juvix.Compiler.Core.Data.Module,
)
where
import Juvix.Compiler.Core.Data.InfoTable
import Juvix.Compiler.Core.Data.InfoTableBuilder
+import Juvix.Compiler.Core.Data.Module
diff --git a/src/Juvix/Compiler/Core/Data/IdentDependencyInfo.hs b/src/Juvix/Compiler/Core/Data/IdentDependencyInfo.hs
index 6567ba9fb4..e26f1847d4 100644
--- a/src/Juvix/Compiler/Core/Data/IdentDependencyInfo.hs
+++ b/src/Juvix/Compiler/Core/Data/IdentDependencyInfo.hs
@@ -3,6 +3,7 @@ module Juvix.Compiler.Core.Data.IdentDependencyInfo where
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet
import Juvix.Compiler.Core.Data.InfoTable
+import Juvix.Compiler.Core.Data.Module
import Juvix.Compiler.Core.Extra.Utils
import Juvix.Compiler.Core.Language
@@ -14,7 +15,7 @@ createCallGraphMap tab =
fmap
( \IdentifierInfo {..} ->
HashSet.map (\Ident {..} -> _identSymbol) $
- getIdents (lookupIdentifierNode tab _identifierSymbol)
+ getIdents (lookupTabIdentifierNode tab _identifierSymbol)
)
(tab ^. infoIdentifiers)
@@ -38,12 +39,12 @@ createSymbolDependencyInfo tab = createDependencyInfo graph startVertices
graph =
fmap
( \IdentifierInfo {..} ->
- getSymbols tab (lookupIdentifierNode tab _identifierSymbol)
+ getSymbols' tab (lookupTabIdentifierNode tab _identifierSymbol)
)
(tab ^. infoIdentifiers)
<> foldr
( \ConstructorInfo {..} ->
- HashMap.insert _constructorInductive (getSymbols tab _constructorType)
+ HashMap.insert _constructorInductive (getSymbols' tab _constructorType)
)
mempty
(tab ^. infoConstructors)
@@ -54,8 +55,11 @@ createSymbolDependencyInfo tab = createDependencyInfo graph startVertices
syms :: [Symbol]
syms = maybe [] singleton (tab ^. infoMain)
-recursiveIdents :: InfoTable -> HashSet Symbol
-recursiveIdents = nodesOnCycles . createCallGraph
+recursiveIdents' :: InfoTable -> HashSet Symbol
+recursiveIdents' = nodesOnCycles . createCallGraph
+
+recursiveIdents :: Module -> HashSet Symbol
+recursiveIdents = recursiveIdents' . computeCombinedInfoTable
-- | identifiers from which some recursive identifier can be reached
recursiveIdentsClosure :: InfoTable -> HashSet Symbol
@@ -93,8 +97,8 @@ recursiveIdentsClosure tab =
chlds = fromJust $ HashMap.lookup sym graph
-- | Complement of recursiveIdentsClosure
-nonRecursiveIdents :: InfoTable -> HashSet Symbol
-nonRecursiveIdents tab =
+nonRecursiveIdents' :: InfoTable -> HashSet Symbol
+nonRecursiveIdents' tab =
HashSet.difference
(HashSet.fromList (HashMap.keys (tab ^. infoIdentifiers)))
(recursiveIdentsClosure tab)
diff --git a/src/Juvix/Compiler/Core/Data/InfoTable.hs b/src/Juvix/Compiler/Core/Data/InfoTable.hs
index 1ce16579da..09e06ed11b 100644
--- a/src/Juvix/Compiler/Core/Data/InfoTable.hs
+++ b/src/Juvix/Compiler/Core/Data/InfoTable.hs
@@ -1,156 +1,73 @@
module Juvix.Compiler.Core.Data.InfoTable
( module Juvix.Compiler.Core.Data.InfoTable,
module Juvix.Compiler.Concrete.Data.Builtins,
+ module Juvix.Compiler.Core.Data.InfoTable.Base,
)
where
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet
import Juvix.Compiler.Concrete.Data.Builtins
+import Juvix.Compiler.Core.Data.InfoTable.Base
import Juvix.Compiler.Core.Language
type IdentContext = HashMap Symbol Node
-data InfoTable = InfoTable
- { _identContext :: IdentContext,
- _identMap :: HashMap Text IdentKind,
- _infoMain :: Maybe Symbol,
- _infoIdentifiers :: HashMap Symbol IdentifierInfo,
- _infoInductives :: HashMap Symbol InductiveInfo,
- _infoConstructors :: HashMap Tag ConstructorInfo,
- _infoAxioms :: HashMap Text AxiomInfo,
- _infoSpecialisations :: HashMap Symbol [SpecialisationInfo],
- _infoLiteralIntToNat :: Maybe Symbol,
- _infoLiteralIntToInt :: Maybe Symbol,
- _infoNextSymbol :: Word,
- _infoNextTag :: Word,
- _infoBuiltins :: HashMap BuiltinPrim IdentKind
- }
-
-emptyInfoTable :: InfoTable
-emptyInfoTable =
- InfoTable
- { _identContext = mempty,
- _identMap = mempty,
- _infoMain = Nothing,
- _infoIdentifiers = mempty,
- _infoInductives = mempty,
- _infoConstructors = mempty,
- _infoAxioms = mempty,
- _infoSpecialisations = mempty,
- _infoLiteralIntToNat = Nothing,
- _infoLiteralIntToInt = Nothing,
- _infoNextSymbol = 1,
- _infoNextTag = 0,
- _infoBuiltins = mempty
- }
-
-emptyInfoTable' :: Node -> InfoTable
-emptyInfoTable' mainNode =
- emptyInfoTable
- { _identContext = HashMap.singleton 0 mainNode,
- _infoMain = Just 0
- }
-
-data IdentKind
- = IdentFun Symbol
- | IdentInd Symbol
- | IdentConstr Tag
-
-data IdentifierInfo = IdentifierInfo
- { _identifierName :: Text,
- _identifierLocation :: Maybe Location,
- _identifierSymbol :: Symbol,
- _identifierType :: Type,
- -- | The number of lambdas in the identifier body
- _identifierArgsNum :: Int,
- _identifierIsExported :: Bool,
- _identifierBuiltin :: Maybe BuiltinFunction,
- _identifierPragmas :: Pragmas,
- _identifierArgNames :: [Maybe Text]
- }
-
-data InductiveInfo = InductiveInfo
- { _inductiveName :: Text,
- _inductiveLocation :: Maybe Location,
- _inductiveSymbol :: Symbol,
- _inductiveKind :: Type,
- _inductiveConstructors :: [Tag],
- _inductiveParams :: [ParameterInfo],
- _inductivePositive :: Bool,
- _inductiveBuiltin :: Maybe BuiltinType,
- _inductivePragmas :: Pragmas
- }
-
-data ConstructorInfo = ConstructorInfo
- { _constructorName :: Text,
- _constructorLocation :: Maybe Location,
- _constructorTag :: Tag,
- _constructorType :: Type,
- _constructorArgsNum :: Int,
- _constructorArgNames :: [Maybe Text],
- _constructorInductive :: Symbol,
- _constructorFixity :: Maybe Fixity,
- _constructorBuiltin :: Maybe BuiltinConstructor,
- _constructorPragmas :: Pragmas
- }
-
-data ParameterInfo = ParameterInfo
- { _paramName :: Text,
- _paramLocation :: Maybe Location,
- _paramKind :: Type,
- _paramIsImplicit :: Bool
- }
-
-data AxiomInfo = AxiomInfo
- { _axiomName :: Text,
- _axiomLocation :: Maybe Location,
- _axiomType :: Type,
- _axiomPragmas :: Pragmas
- }
-
-data SpecialisationInfo = SpecialisationInfo
- { _specSignature :: ([Node], [Int]),
- _specSymbol :: Symbol
- }
-
-makeLenses ''InfoTable
-makeLenses ''IdentifierInfo
-makeLenses ''InductiveInfo
-makeLenses ''ConstructorInfo
-makeLenses ''ParameterInfo
-makeLenses ''AxiomInfo
-makeLenses ''SpecialisationInfo
-
-lookupInductiveInfo' :: InfoTable -> Symbol -> Maybe InductiveInfo
-lookupInductiveInfo' tab sym = HashMap.lookup sym (tab ^. infoInductives)
-
-lookupConstructorInfo' :: InfoTable -> Tag -> Maybe ConstructorInfo
-lookupConstructorInfo' tab tag = HashMap.lookup tag (tab ^. infoConstructors)
-
-lookupIdentifierInfo' :: InfoTable -> Symbol -> Maybe IdentifierInfo
-lookupIdentifierInfo' tab sym = HashMap.lookup sym (tab ^. infoIdentifiers)
-
-lookupIdentifierNode' :: InfoTable -> Symbol -> Maybe Node
-lookupIdentifierNode' tab sym = HashMap.lookup sym (tab ^. identContext)
-
-lookupSpecialisationInfo :: InfoTable -> Symbol -> [SpecialisationInfo]
-lookupSpecialisationInfo tab sym = fromMaybe [] $ HashMap.lookup sym (tab ^. infoSpecialisations)
-
-lookupInductiveInfo :: InfoTable -> Symbol -> InductiveInfo
-lookupInductiveInfo tab sym = fromJust $ lookupInductiveInfo' tab sym
-
-lookupConstructorInfo :: InfoTable -> Tag -> ConstructorInfo
-lookupConstructorInfo tab tag = fromMaybe (error ("tag: " <> show tag)) $ lookupConstructorInfo' tab tag
-
-lookupIdentifierInfo :: InfoTable -> Symbol -> IdentifierInfo
-lookupIdentifierInfo tab sym = fromJust $ lookupIdentifierInfo' tab sym
-
-lookupIdentifierNode :: InfoTable -> Symbol -> Node
-lookupIdentifierNode tab sym = fromJust $ lookupIdentifierNode' tab sym
-
-lookupBuiltinInductive :: InfoTable -> BuiltinInductive -> Maybe InductiveInfo
-lookupBuiltinInductive tab b = (HashMap.!) (tab ^. infoInductives) . indSym <$> idenKind
+type InfoTable = InfoTable' Node
+
+type IdentifierInfo = IdentifierInfo' Node
+
+type InductiveInfo = InductiveInfo' Node
+
+type ConstructorInfo = ConstructorInfo' Node
+
+type AxiomInfo = AxiomInfo' Node
+
+type ParameterInfo = ParameterInfo' Node
+
+type SpecialisationInfo = SpecialisationInfo' Node
+
+nextSymbolId :: InfoTable -> Word
+nextSymbolId tab =
+ maximum (0 : map (^. symbolId) (HashMap.keys (tab ^. infoIdentifiers)) ++ map (^. symbolId) (HashMap.keys (tab ^. infoInductives)))
+ + 1
+
+nextTagId :: InfoTable -> Word
+nextTagId tab =
+ maximum (0 : mapMaybe getUserTagId (HashMap.keys (tab ^. infoConstructors))) + 1
+
+lookupTabInductiveInfo' :: InfoTable -> Symbol -> Maybe InductiveInfo
+lookupTabInductiveInfo' tab sym = HashMap.lookup sym (tab ^. infoInductives)
+
+lookupTabConstructorInfo' :: InfoTable -> Tag -> Maybe ConstructorInfo
+lookupTabConstructorInfo' tab tag = HashMap.lookup tag (tab ^. infoConstructors)
+
+lookupTabIdentifierInfo' :: InfoTable -> Symbol -> Maybe IdentifierInfo
+lookupTabIdentifierInfo' tab sym = HashMap.lookup sym (tab ^. infoIdentifiers)
+
+lookupTabIdentifierNode' :: InfoTable -> Symbol -> Maybe Node
+lookupTabIdentifierNode' tab sym = HashMap.lookup sym (tab ^. identContext)
+
+lookupTabSpecialisationInfo' :: InfoTable -> Symbol -> Maybe [SpecialisationInfo]
+lookupTabSpecialisationInfo' tab sym = HashMap.lookup sym (tab ^. infoSpecialisations)
+
+lookupTabSpecialisationInfo :: InfoTable -> Symbol -> [SpecialisationInfo]
+lookupTabSpecialisationInfo tab sym = fromMaybe [] $ lookupTabSpecialisationInfo' tab sym
+
+lookupTabInductiveInfo :: InfoTable -> Symbol -> InductiveInfo
+lookupTabInductiveInfo tab sym = fromJust $ lookupTabInductiveInfo' tab sym
+
+lookupTabConstructorInfo :: InfoTable -> Tag -> ConstructorInfo
+lookupTabConstructorInfo tab tag = fromMaybe (error ("tag: " <> show tag)) $ lookupTabConstructorInfo' tab tag
+
+lookupTabIdentifierInfo :: InfoTable -> Symbol -> IdentifierInfo
+lookupTabIdentifierInfo tab sym = fromJust $ lookupTabIdentifierInfo' tab sym
+
+lookupTabIdentifierNode :: InfoTable -> Symbol -> Node
+lookupTabIdentifierNode tab sym = fromJust $ lookupTabIdentifierNode' tab sym
+
+lookupTabBuiltinInductive :: InfoTable -> BuiltinInductive -> Maybe InductiveInfo
+lookupTabBuiltinInductive tab b = (HashMap.!) (tab ^. infoInductives) . indSym <$> idenKind
where
idenKind :: Maybe IdentKind
idenKind = HashMap.lookup (BuiltinsInductive b) (tab ^. infoBuiltins)
@@ -160,8 +77,8 @@ lookupBuiltinInductive tab b = (HashMap.!) (tab ^. infoInductives) . indSym <$>
IdentInd s -> s
_ -> error "core infotable: expected inductive identifier"
-lookupBuiltinConstructor :: InfoTable -> BuiltinConstructor -> Maybe ConstructorInfo
-lookupBuiltinConstructor tab b = (HashMap.!) (tab ^. infoConstructors) . ctorTag <$> idenKind
+lookupTabBuiltinConstructor :: InfoTable -> BuiltinConstructor -> Maybe ConstructorInfo
+lookupTabBuiltinConstructor tab b = (HashMap.!) (tab ^. infoConstructors) . ctorTag <$> idenKind
where
idenKind :: Maybe IdentKind
idenKind = HashMap.lookup (BuiltinsConstructor b) (tab ^. infoBuiltins)
@@ -171,8 +88,8 @@ lookupBuiltinConstructor tab b = (HashMap.!) (tab ^. infoConstructors) . ctorTag
IdentConstr t -> t
_ -> error "core infotable: expected constructor identifier"
-lookupBuiltinFunction :: InfoTable -> BuiltinFunction -> Maybe IdentifierInfo
-lookupBuiltinFunction tab b = (HashMap.!) (tab ^. infoIdentifiers) . funSym <$> idenKind
+lookupTabBuiltinFunction :: InfoTable -> BuiltinFunction -> Maybe IdentifierInfo
+lookupTabBuiltinFunction tab b = (HashMap.!) (tab ^. infoIdentifiers) . funSym <$> idenKind
where
idenKind :: Maybe IdentKind
idenKind = HashMap.lookup (BuiltinsFunction b) (tab ^. infoBuiltins)
@@ -182,45 +99,34 @@ lookupBuiltinFunction tab b = (HashMap.!) (tab ^. infoIdentifiers) . funSym <$>
IdentFun s -> s
_ -> error "core infotable: expected function identifier"
-identName :: InfoTable -> Symbol -> Text
-identName tab sym = lookupIdentifierInfo tab sym ^. identifierName
+identName' :: InfoTable -> Symbol -> Text
+identName' tab sym = lookupTabIdentifierInfo tab sym ^. identifierName
-typeName :: InfoTable -> Symbol -> Text
-typeName tab sym = lookupInductiveInfo tab sym ^. inductiveName
+typeName' :: InfoTable -> Symbol -> Text
+typeName' tab sym = lookupTabInductiveInfo tab sym ^. inductiveName
-identNames :: InfoTable -> HashSet Text
-identNames tab =
+identNames' :: InfoTable -> HashSet Text
+identNames' tab =
HashSet.fromList $
map (^. identifierName) (HashMap.elems (tab ^. infoIdentifiers))
++ map (^. constructorName) (HashMap.elems (tab ^. infoConstructors))
++ map (^. inductiveName) (HashMap.elems (tab ^. infoInductives))
-freshIdentName :: InfoTable -> Text -> Text
-freshIdentName tab = freshName (identNames tab)
-
-filterByFile :: Path Abs File -> InfoTable -> InfoTable
-filterByFile f t =
- t
- { _infoIdentifiers = HashMap.filter (^. identifierLocation . to matchesLocation) (t ^. infoIdentifiers),
- _infoAxioms = HashMap.filter (^. axiomLocation . to matchesLocation) (t ^. infoAxioms),
- _infoConstructors = HashMap.filter (^. constructorLocation . to matchesLocation) (t ^. infoConstructors),
- _infoInductives = HashMap.filter (^. inductiveLocation . to matchesLocation) (t ^. infoInductives)
- }
- where
- matchesLocation :: Maybe Location -> Bool
- matchesLocation l = l ^? _Just . intervalFile == Just f
+freshIdentName' :: InfoTable -> Text -> Text
+freshIdentName' tab = freshName (identNames' tab)
-- | Prunes the orphaned entries of identMap, indentContext and
-- infoConstructors, i.e., ones that have no corresponding entries in
-- infoIdentifiers or infoInductives
-pruneInfoTable :: InfoTable -> InfoTable
-pruneInfoTable tab =
+pruneInfoTable' :: InfoTable -> InfoTable
+pruneInfoTable' tab =
pruneIdentMap
$ over
infoConstructors
( HashMap.filter
( \ConstructorInfo {..} ->
- HashMap.member _constructorInductive (tab ^. infoInductives)
+ isBuiltinTag _constructorTag
+ || HashMap.member _constructorInductive (tab ^. infoInductives)
)
)
$ over
@@ -240,3 +146,13 @@ pruneInfoTable tab =
)
)
tab'
+
+tableIsFragile :: InfoTable -> Bool
+tableIsFragile tab = any isFragile (HashMap.elems $ tab ^. infoIdentifiers)
+ where
+ isFragile :: IdentifierInfo -> Bool
+ isFragile IdentifierInfo {..} =
+ case _identifierPragmas ^. pragmasInline of
+ Just InlineAlways -> True
+ Just InlineCase -> True
+ _ -> False
diff --git a/src/Juvix/Compiler/Core/Data/InfoTable/Base.hs b/src/Juvix/Compiler/Core/Data/InfoTable/Base.hs
new file mode 100644
index 0000000000..c524fcc853
--- /dev/null
+++ b/src/Juvix/Compiler/Core/Data/InfoTable/Base.hs
@@ -0,0 +1,145 @@
+module Juvix.Compiler.Core.Data.InfoTable.Base where
+
+import Juvix.Compiler.Concrete.Data.Builtins
+import Juvix.Compiler.Core.Language.Base
+import Juvix.Extra.Serialize
+
+data InfoTable' n = InfoTable
+ { _identContext :: HashMap Symbol n,
+ _identMap :: HashMap Text IdentKind,
+ _infoMain :: Maybe Symbol,
+ _infoIdentifiers :: HashMap Symbol (IdentifierInfo' n),
+ _infoInductives :: HashMap Symbol (InductiveInfo' n),
+ _infoConstructors :: HashMap Tag (ConstructorInfo' n),
+ _infoAxioms :: HashMap Text (AxiomInfo' n),
+ _infoSpecialisations :: HashMap Symbol [SpecialisationInfo' n],
+ _infoLiteralIntToNat :: Maybe Symbol,
+ _infoLiteralIntToInt :: Maybe Symbol,
+ _infoBuiltins :: HashMap BuiltinPrim IdentKind
+ }
+ deriving stock (Generic)
+
+data IdentKind
+ = IdentFun Symbol
+ | IdentInd Symbol
+ | IdentConstr Tag
+ deriving stock (Generic)
+
+data IdentifierInfo' n = IdentifierInfo
+ { _identifierName :: Text,
+ _identifierLocation :: Maybe Location,
+ _identifierSymbol :: Symbol,
+ _identifierType :: n,
+ -- | The number of lambdas in the identifier body
+ _identifierArgsNum :: Int,
+ _identifierIsExported :: Bool,
+ _identifierBuiltin :: Maybe BuiltinFunction,
+ _identifierPragmas :: Pragmas,
+ _identifierArgNames :: [Maybe Text]
+ }
+ deriving stock (Generic)
+
+data InductiveInfo' n = InductiveInfo
+ { _inductiveName :: Text,
+ _inductiveLocation :: Maybe Location,
+ _inductiveSymbol :: Symbol,
+ _inductiveKind :: n,
+ _inductiveConstructors :: [Tag],
+ _inductiveParams :: [ParameterInfo' n],
+ _inductivePositive :: Bool,
+ _inductiveBuiltin :: Maybe BuiltinType,
+ _inductivePragmas :: Pragmas
+ }
+ deriving stock (Generic)
+
+data ConstructorInfo' n = ConstructorInfo
+ { _constructorName :: Text,
+ _constructorLocation :: Maybe Location,
+ _constructorTag :: Tag,
+ _constructorType :: n,
+ _constructorArgsNum :: Int,
+ _constructorArgNames :: [Maybe Text],
+ _constructorInductive :: Symbol,
+ _constructorFixity :: Maybe Fixity,
+ _constructorBuiltin :: Maybe BuiltinConstructor,
+ _constructorPragmas :: Pragmas
+ }
+ deriving stock (Generic)
+
+data ParameterInfo' n = ParameterInfo
+ { _paramName :: Text,
+ _paramLocation :: Maybe Location,
+ _paramKind :: n,
+ _paramIsImplicit :: Bool
+ }
+ deriving stock (Generic)
+
+data AxiomInfo' n = AxiomInfo
+ { _axiomName :: Text,
+ _axiomLocation :: Maybe Location,
+ _axiomType :: n,
+ _axiomPragmas :: Pragmas
+ }
+ deriving stock (Generic)
+
+data SpecialisationInfo' n = SpecialisationInfo
+ { _specSignature :: ([n], [Int]),
+ _specSymbol :: Symbol
+ }
+ deriving stock (Generic)
+
+instance (Serialize n) => Serialize (InfoTable' n)
+
+instance Serialize IdentKind
+
+instance (Serialize n) => Serialize (IdentifierInfo' n)
+
+instance (Serialize n) => Serialize (InductiveInfo' n)
+
+instance (Serialize n) => Serialize (ConstructorInfo' n)
+
+instance (Serialize n) => Serialize (ParameterInfo' n)
+
+instance (Serialize n) => Serialize (AxiomInfo' n)
+
+instance (Serialize n) => Serialize (SpecialisationInfo' n)
+
+makeLenses ''InfoTable'
+makeLenses ''IdentifierInfo'
+makeLenses ''InductiveInfo'
+makeLenses ''ConstructorInfo'
+makeLenses ''ParameterInfo'
+makeLenses ''AxiomInfo'
+makeLenses ''SpecialisationInfo'
+
+instance Semigroup (InfoTable' n) where
+ t1 <> t2 =
+ InfoTable
+ { _identContext = t1 ^. identContext <> t2 ^. identContext,
+ _identMap = t1 ^. identMap <> t2 ^. identMap,
+ _infoMain = (t1 ^. infoMain) <|> (t2 ^. infoMain),
+ _infoIdentifiers = t1 ^. infoIdentifiers <> t2 ^. infoIdentifiers,
+ _infoInductives = t1 ^. infoInductives <> t2 ^. infoInductives,
+ _infoConstructors = t1 ^. infoConstructors <> t2 ^. infoConstructors,
+ _infoAxioms = t1 ^. infoAxioms <> t2 ^. infoAxioms,
+ _infoSpecialisations = t1 ^. infoSpecialisations <> t2 ^. infoSpecialisations,
+ _infoLiteralIntToNat = (t1 ^. infoLiteralIntToNat) <|> (t2 ^. infoLiteralIntToNat),
+ _infoLiteralIntToInt = (t1 ^. infoLiteralIntToInt) <|> (t2 ^. infoLiteralIntToInt),
+ _infoBuiltins = t1 ^. infoBuiltins <> t2 ^. infoBuiltins
+ }
+
+instance Monoid (InfoTable' n) where
+ mempty =
+ InfoTable
+ { _identContext = mempty,
+ _identMap = mempty,
+ _infoMain = Nothing,
+ _infoIdentifiers = mempty,
+ _infoInductives = mempty,
+ _infoConstructors = mempty,
+ _infoAxioms = mempty,
+ _infoSpecialisations = mempty,
+ _infoLiteralIntToNat = Nothing,
+ _infoLiteralIntToInt = Nothing,
+ _infoBuiltins = mempty
+ }
diff --git a/src/Juvix/Compiler/Core/Data/InfoTableBuilder.hs b/src/Juvix/Compiler/Core/Data/InfoTableBuilder.hs
index fb8bee0361..44443ca887 100644
--- a/src/Juvix/Compiler/Core/Data/InfoTableBuilder.hs
+++ b/src/Juvix/Compiler/Core/Data/InfoTableBuilder.hs
@@ -6,6 +6,7 @@ where
import Data.HashMap.Strict qualified as HashMap
import Juvix.Compiler.Core.Data.InfoTable
+import Juvix.Compiler.Core.Data.Module
import Juvix.Compiler.Core.Extra.Base
import Juvix.Compiler.Core.Info.NameInfo
import Juvix.Compiler.Core.Language
@@ -24,24 +25,24 @@ data InfoTableBuilder m a where
RemoveSymbol :: Symbol -> InfoTableBuilder m ()
OverIdentArgs :: Symbol -> ([Binder] -> [Binder]) -> InfoTableBuilder m ()
GetIdent :: Text -> InfoTableBuilder m (Maybe IdentKind)
- GetInfoTable :: InfoTableBuilder m InfoTable
- SetInfoTable :: InfoTable -> InfoTableBuilder m ()
+ GetModule :: InfoTableBuilder m Module
+ SetModule :: Module -> InfoTableBuilder m ()
makeSem ''InfoTableBuilder
getConstructorInfo :: (Member InfoTableBuilder r) => Tag -> Sem r ConstructorInfo
-getConstructorInfo tag = flip lookupConstructorInfo tag <$> getInfoTable
+getConstructorInfo tag = flip lookupConstructorInfo tag <$> getModule
getInductiveInfo :: (Member InfoTableBuilder r) => Symbol -> Sem r InductiveInfo
-getInductiveInfo sym = flip lookupInductiveInfo sym <$> getInfoTable
+getInductiveInfo sym = flip lookupInductiveInfo sym <$> getModule
getBuiltinInductiveInfo :: (Member InfoTableBuilder r) => BuiltinInductive -> Sem r InductiveInfo
getBuiltinInductiveInfo b = do
- tab <- getInfoTable
+ tab <- getModule
return $ fromJust (lookupBuiltinInductive tab b)
getIdentifierInfo :: (Member InfoTableBuilder r) => Symbol -> Sem r IdentifierInfo
-getIdentifierInfo sym = flip lookupIdentifierInfo sym <$> getInfoTable
+getIdentifierInfo sym = flip lookupIdentifierInfo sym <$> getModule
getBoolSymbol :: (Member InfoTableBuilder r) => Sem r Symbol
getBoolSymbol = do
@@ -61,86 +62,120 @@ getIntSymbol = (^. inductiveSymbol) <$> getBuiltinInductiveInfo BuiltinInt
checkSymbolDefined :: (Member InfoTableBuilder r) => Symbol -> Sem r Bool
checkSymbolDefined sym = do
- tab <- getInfoTable
- return $ HashMap.member sym (tab ^. identContext)
+ m <- getModule
+ return $
+ HashMap.member sym (m ^. moduleInfoTable . identContext)
+ || HashMap.member sym (m ^. moduleImportsTable . identContext)
setIdentArgs :: (Member InfoTableBuilder r) => Symbol -> [Binder] -> Sem r ()
setIdentArgs sym = overIdentArgs sym . const
-runInfoTableBuilder :: forall r a. InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r (InfoTable, a)
-runInfoTableBuilder tab =
- runState tab
+data BuilderState = BuilderState
+ { _builderStateModule :: Module,
+ _builderStateNextSymbolId :: Word,
+ _builderStateNextTagId :: Word
+ }
+
+makeLenses ''BuilderState
+
+mkBuilderState :: Module -> BuilderState
+mkBuilderState m =
+ BuilderState
+ { _builderStateModule = m,
+ _builderStateNextSymbolId = nextSymbolId tab,
+ _builderStateNextTagId = nextTagId tab
+ }
+ where
+ tab = computeCombinedInfoTable m
+
+runInfoTableBuilder' :: BuilderState -> forall r a. Sem (InfoTableBuilder ': r) a -> Sem r (BuilderState, a)
+runInfoTableBuilder' st =
+ runState st
. reinterpret interp
where
- interp :: InfoTableBuilder m b -> Sem (State InfoTable ': r) b
+ interp :: InfoTableBuilder m b -> Sem (State BuilderState ': r) b
interp = \case
FreshSymbol -> do
s <- get
- modify' (over infoNextSymbol (+ 1))
- return (s ^. infoNextSymbol)
+ modify' (over builderStateNextSymbolId (+ 1))
+ return (Symbol (s ^. builderStateModule . moduleId) (s ^. builderStateNextSymbolId))
FreshTag -> do
s <- get
- modify' (over infoNextTag (+ 1))
- return (UserTag (s ^. infoNextTag))
+ modify' (over builderStateNextTagId (+ 1))
+ return (UserTag (s ^. builderStateModule . moduleId) (s ^. builderStateNextTagId))
RegisterIdent idt ii -> do
let sym = ii ^. identifierSymbol
identKind = IdentFun (ii ^. identifierSymbol)
whenJust
(ii ^. identifierBuiltin)
- (\b -> modify' (over infoBuiltins (HashMap.insert (BuiltinsFunction b) identKind)))
- modify' (over infoIdentifiers (HashMap.insert sym ii))
- modify' (over identMap (HashMap.insert idt identKind))
+ (\b -> modify' (over (builderStateModule . moduleInfoTable . infoBuiltins) (HashMap.insert (BuiltinsFunction b) identKind)))
+ modify' (over (builderStateModule . moduleInfoTable . infoIdentifiers) (HashMap.insert sym ii))
+ modify' (over (builderStateModule . moduleInfoTable . identMap) (HashMap.insert idt identKind))
RegisterConstructor idt ci -> do
let tag = ci ^. constructorTag
identKind = IdentConstr tag
whenJust
(ci ^. constructorBuiltin)
- (\b -> modify' (over infoBuiltins (HashMap.insert (BuiltinsConstructor b) identKind)))
- modify' (over infoConstructors (HashMap.insert tag ci))
- modify' (over identMap (HashMap.insert idt identKind))
+ (\b -> modify' (over (builderStateModule . moduleInfoTable . infoBuiltins) (HashMap.insert (BuiltinsConstructor b) identKind)))
+ modify' (over (builderStateModule . moduleInfoTable . infoConstructors) (HashMap.insert tag ci))
+ modify' (over (builderStateModule . moduleInfoTable . identMap) (HashMap.insert idt identKind))
RegisterInductive idt ii -> do
let sym = ii ^. inductiveSymbol
identKind = IdentInd sym
whenJust
(ii ^. inductiveBuiltin)
- (\b -> modify' (over infoBuiltins (HashMap.insert (builtinTypeToPrim b) identKind)))
- modify' (over infoInductives (HashMap.insert sym ii))
- modify' (over identMap (HashMap.insert idt identKind))
+ (\b -> modify' (over (builderStateModule . moduleInfoTable . infoBuiltins) (HashMap.insert (builtinTypeToPrim b) identKind)))
+ modify' (over (builderStateModule . moduleInfoTable . infoInductives) (HashMap.insert sym ii))
+ modify' (over (builderStateModule . moduleInfoTable . identMap) (HashMap.insert idt identKind))
RegisterSpecialisation sym spec -> do
modify'
( over
- infoSpecialisations
+ (builderStateModule . moduleInfoTable . infoSpecialisations)
(HashMap.alter (Just . maybe [spec] (spec :)) sym)
)
RegisterIdentNode sym node ->
- modify' (over identContext (HashMap.insert sym node))
+ modify' (over (builderStateModule . moduleInfoTable . identContext) (HashMap.insert sym node))
RegisterMain sym -> do
- modify' (set infoMain (Just sym))
+ modify' (set (builderStateModule . moduleInfoTable . infoMain) (Just sym))
RegisterLiteralIntToInt sym -> do
- modify' (set infoLiteralIntToInt (Just sym))
+ modify' (set (builderStateModule . moduleInfoTable . infoLiteralIntToInt) (Just sym))
RegisterLiteralIntToNat sym -> do
- modify' (set infoLiteralIntToNat (Just sym))
+ modify' (set (builderStateModule . moduleInfoTable . infoLiteralIntToNat) (Just sym))
RemoveSymbol sym -> do
- modify' (over infoMain (maybe Nothing (\sym' -> if sym' == sym then Nothing else Just sym')))
- modify' (over infoIdentifiers (HashMap.delete sym))
- modify' (over identContext (HashMap.delete sym))
- modify' (over infoInductives (HashMap.delete sym))
+ modify' (over (builderStateModule . moduleInfoTable . infoMain) (maybe Nothing (\sym' -> if sym' == sym then Nothing else Just sym')))
+ modify' (over (builderStateModule . moduleInfoTable . infoIdentifiers) (HashMap.delete sym))
+ modify' (over (builderStateModule . moduleInfoTable . identContext) (HashMap.delete sym))
+ modify' (over (builderStateModule . moduleInfoTable . infoInductives) (HashMap.delete sym))
OverIdentArgs sym f -> do
- args <- f <$> gets (^. identContext . at sym . _Just . to (map (^. lambdaLhsBinder) . fst . unfoldLambdas))
- modify' (set (infoIdentifiers . at sym . _Just . identifierArgsNum) (length args))
- modify' (over infoIdentifiers (HashMap.adjust (over identifierType (expandType args)) sym))
+ args <- f <$> gets (^. builderStateModule . moduleInfoTable . identContext . at sym . _Just . to (map (^. lambdaLhsBinder) . fst . unfoldLambdas))
+ modify' (set (builderStateModule . moduleInfoTable . infoIdentifiers . at sym . _Just . identifierArgsNum) (length args))
+ modify' (over (builderStateModule . moduleInfoTable . infoIdentifiers) (HashMap.adjust (over identifierType (expandType args)) sym))
GetIdent txt -> do
s <- get
- return $ HashMap.lookup txt (s ^. identMap)
- GetInfoTable ->
- get
- SetInfoTable t -> put t
+ let r1 = HashMap.lookup txt (s ^. builderStateModule . moduleInfoTable . identMap)
+ r2 = HashMap.lookup txt (s ^. builderStateModule . moduleImportsTable . identMap)
+ return (r1 <|> r2)
+ GetModule ->
+ (^. builderStateModule) <$> get
+ SetModule md ->
+ modify' (set builderStateModule md)
+
+execInfoTableBuilder' :: BuilderState -> Sem (InfoTableBuilder ': r) a -> Sem r BuilderState
+execInfoTableBuilder' st = fmap fst . runInfoTableBuilder' st
+
+evalInfoTableBuilder' :: BuilderState -> Sem (InfoTableBuilder ': r) a -> Sem r a
+evalInfoTableBuilder' st = fmap snd . runInfoTableBuilder' st
+
+runInfoTableBuilder :: Module -> Sem (InfoTableBuilder ': r) a -> Sem r (Module, a)
+runInfoTableBuilder m ma = do
+ (st, a) <- runInfoTableBuilder' (mkBuilderState m) ma
+ return (st ^. builderStateModule, a)
-execInfoTableBuilder :: InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r InfoTable
-execInfoTableBuilder tab = fmap fst . runInfoTableBuilder tab
+execInfoTableBuilder :: Module -> Sem (InfoTableBuilder ': r) a -> Sem r Module
+execInfoTableBuilder m = fmap fst . runInfoTableBuilder m
-evalInfoTableBuilder :: InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r a
-evalInfoTableBuilder tab = fmap snd . runInfoTableBuilder tab
+evalInfoTableBuilder :: Module -> Sem (InfoTableBuilder ': r) a -> Sem r a
+evalInfoTableBuilder m = fmap snd . runInfoTableBuilder m
--------------------------------------------
-- Builtin declarations
@@ -251,8 +286,8 @@ reserveLiteralIntToIntSymbol = do
-- | Register a function Int -> Nat used to transform literal integers to builtin Nat
setupLiteralIntToNat :: forall r. (Member InfoTableBuilder r) => (Symbol -> Sem r Node) -> Sem r ()
setupLiteralIntToNat mkNode = do
- tab <- getInfoTable
- whenJust (tab ^. infoLiteralIntToNat) go
+ m <- getModule
+ whenJust (getInfoLiteralIntToNat m) go
where
go :: Symbol -> Sem r ()
go sym = do
@@ -263,12 +298,12 @@ setupLiteralIntToNat mkNode = do
where
info :: Symbol -> Sem r IdentifierInfo
info s = do
- tab <- getInfoTable
+ m <- getModule
ty <- targetType
return $
IdentifierInfo
{ _identifierSymbol = s,
- _identifierName = freshIdentName tab "intToNat",
+ _identifierName = freshIdentName m "intToNat",
_identifierLocation = Nothing,
_identifierArgsNum = 1,
_identifierType = mkPi mempty (Binder "x" Nothing mkTypeInteger') ty,
@@ -280,15 +315,15 @@ setupLiteralIntToNat mkNode = do
targetType :: Sem r Node
targetType = do
- tab <- getInfoTable
- let natSymM = (^. inductiveSymbol) <$> lookupBuiltinInductive tab BuiltinNat
+ m <- getModule
+ let natSymM = (^. inductiveSymbol) <$> lookupBuiltinInductive m BuiltinNat
return (maybe mkTypeInteger' (\s -> mkTypeConstr (setInfoName "Nat" mempty) s []) natSymM)
-- | Register a function Int -> Int used to transform literal integers to builtin Int
setupLiteralIntToInt :: forall r. (Member InfoTableBuilder r) => Sem r Node -> Sem r ()
setupLiteralIntToInt node = do
- tab <- getInfoTable
- whenJust (tab ^. infoLiteralIntToInt) go
+ m <- getModule
+ whenJust (getInfoLiteralIntToInt m) go
where
go :: Symbol -> Sem r ()
go sym = do
@@ -299,12 +334,12 @@ setupLiteralIntToInt node = do
where
info :: Symbol -> Sem r IdentifierInfo
info s = do
- tab <- getInfoTable
+ m <- getModule
ty <- targetType
return $
IdentifierInfo
{ _identifierSymbol = s,
- _identifierName = freshIdentName tab "literalIntToInt",
+ _identifierName = freshIdentName m "literalIntToInt",
_identifierLocation = Nothing,
_identifierArgsNum = 1,
_identifierType = mkPi mempty (Binder "x" Nothing mkTypeInteger') ty,
@@ -316,6 +351,6 @@ setupLiteralIntToInt node = do
targetType :: Sem r Node
targetType = do
- tab <- getInfoTable
- let intSymM = (^. inductiveSymbol) <$> lookupBuiltinInductive tab BuiltinInt
+ m <- getModule
+ let intSymM = (^. inductiveSymbol) <$> lookupBuiltinInductive m BuiltinInt
return (maybe mkTypeInteger' (\s -> mkTypeConstr (setInfoName "Int" mempty) s []) intSymM)
diff --git a/src/Juvix/Compiler/Core/Data/Module.hs b/src/Juvix/Compiler/Core/Data/Module.hs
new file mode 100644
index 0000000000..53f1e57f9c
--- /dev/null
+++ b/src/Juvix/Compiler/Core/Data/Module.hs
@@ -0,0 +1,117 @@
+module Juvix.Compiler.Core.Data.Module
+ ( module Juvix.Compiler.Core.Data.Module,
+ module Juvix.Compiler.Core.Data.InfoTable,
+ )
+where
+
+import Juvix.Compiler.Core.Data.InfoTable
+import Juvix.Compiler.Core.Language
+
+data Module = Module
+ { _moduleId :: ModuleId,
+ _moduleInfoTable :: InfoTable,
+ -- | The imports table contains all dependencies, transitively. E.g., if the
+ -- module M imports A but not B, but A imports B, then all identifiers from
+ -- B will be in the imports table of M nonetheless.
+ _moduleImportsTable :: InfoTable
+ }
+
+makeLenses ''Module
+
+withInfoTable :: (Module -> Module) -> InfoTable -> InfoTable
+withInfoTable f tab =
+ f (moduleFromInfoTable tab) ^. moduleInfoTable
+
+emptyModule :: Module
+emptyModule = Module defaultModuleId mempty mempty
+
+moduleFromInfoTable :: InfoTable -> Module
+moduleFromInfoTable tab = Module defaultModuleId tab mempty
+
+computeCombinedIdentContext :: Module -> IdentContext
+computeCombinedIdentContext Module {..} =
+ _moduleInfoTable ^. identContext <> _moduleImportsTable ^. identContext
+
+computeCombinedInfoTable :: Module -> InfoTable
+computeCombinedInfoTable Module {..} = _moduleInfoTable <> _moduleImportsTable
+
+lookupInductiveInfo' :: Module -> Symbol -> Maybe InductiveInfo
+lookupInductiveInfo' Module {..} sym =
+ lookupTabInductiveInfo' _moduleInfoTable sym
+ <|> lookupTabInductiveInfo' _moduleImportsTable sym
+
+lookupConstructorInfo' :: Module -> Tag -> Maybe ConstructorInfo
+lookupConstructorInfo' Module {..} tag =
+ lookupTabConstructorInfo' _moduleInfoTable tag
+ <|> lookupTabConstructorInfo' _moduleImportsTable tag
+
+lookupIdentifierInfo' :: Module -> Symbol -> Maybe IdentifierInfo
+lookupIdentifierInfo' Module {..} sym =
+ lookupTabIdentifierInfo' _moduleInfoTable sym
+ <|> lookupTabIdentifierInfo' _moduleImportsTable sym
+
+lookupIdentifierNode' :: Module -> Symbol -> Maybe Node
+lookupIdentifierNode' Module {..} sym =
+ lookupTabIdentifierNode' _moduleInfoTable sym
+ <|> lookupTabIdentifierNode' _moduleImportsTable sym
+
+lookupSpecialisationInfo :: Module -> Symbol -> [SpecialisationInfo]
+lookupSpecialisationInfo Module {..} sym =
+ fromMaybe [] $
+ lookupTabSpecialisationInfo' _moduleInfoTable sym
+ <|> lookupTabSpecialisationInfo' _moduleImportsTable sym
+
+lookupInductiveInfo :: Module -> Symbol -> InductiveInfo
+lookupInductiveInfo m sym = fromJust $ lookupInductiveInfo' m sym
+
+lookupConstructorInfo :: Module -> Tag -> ConstructorInfo
+lookupConstructorInfo m tag = fromJust $ lookupConstructorInfo' m tag
+
+lookupIdentifierInfo :: Module -> Symbol -> IdentifierInfo
+lookupIdentifierInfo m sym = fromJust $ lookupIdentifierInfo' m sym
+
+lookupIdentifierNode :: Module -> Symbol -> Node
+lookupIdentifierNode m sym = fromJust $ lookupIdentifierNode' m sym
+
+lookupBuiltinInductive :: Module -> BuiltinInductive -> Maybe InductiveInfo
+lookupBuiltinInductive Module {..} b =
+ lookupTabBuiltinInductive _moduleInfoTable b
+ <|> lookupTabBuiltinInductive _moduleImportsTable b
+
+lookupBuiltinConstructor :: Module -> BuiltinConstructor -> Maybe ConstructorInfo
+lookupBuiltinConstructor Module {..} b =
+ lookupTabBuiltinConstructor _moduleInfoTable b
+ <|> lookupTabBuiltinConstructor _moduleImportsTable b
+
+getInfoLiteralIntToNat :: Module -> Maybe Symbol
+getInfoLiteralIntToNat Module {..} =
+ _moduleInfoTable ^. infoLiteralIntToNat
+ <|> _moduleImportsTable ^. infoLiteralIntToNat
+
+getInfoLiteralIntToInt :: Module -> Maybe Symbol
+getInfoLiteralIntToInt Module {..} =
+ _moduleInfoTable ^. infoLiteralIntToInt
+ <|> _moduleImportsTable ^. infoLiteralIntToInt
+
+getInfoMain :: Module -> Maybe Symbol
+getInfoMain Module {..} =
+ _moduleInfoTable ^. infoMain
+ <|> _moduleImportsTable ^. infoMain
+
+identName :: Module -> Symbol -> Text
+identName m = identName' (computeCombinedInfoTable m)
+
+typeName :: Module -> Symbol -> Text
+typeName m = typeName' (computeCombinedInfoTable m)
+
+identNames :: Module -> HashSet Text
+identNames m = identNames' (computeCombinedInfoTable m)
+
+freshIdentName :: Module -> Text -> Text
+freshIdentName m = freshName (identNames m)
+
+pruneInfoTable :: Module -> Module
+pruneInfoTable = over moduleInfoTable pruneInfoTable'
+
+moduleIsFragile :: Module -> Bool
+moduleIsFragile Module {..} = tableIsFragile _moduleInfoTable
diff --git a/src/Juvix/Compiler/Core/Data/TransformationId.hs b/src/Juvix/Compiler/Core/Data/TransformationId.hs
index e09f057c1a..99febd05e7 100644
--- a/src/Juvix/Compiler/Core/Data/TransformationId.hs
+++ b/src/Juvix/Compiler/Core/Data/TransformationId.hs
@@ -18,6 +18,7 @@ data TransformationId
| NaiveMatchToCase
| EtaExpandApps
| DisambiguateNames
+ | CombineInfoTables
| CheckGeb
| CheckExec
| CheckVampIR
@@ -43,7 +44,7 @@ data TransformationId
deriving stock (Data, Bounded, Enum, Show)
data PipelineId
- = PipelineEval
+ = PipelineStored
| PipelineNormalize
| PipelineGeb
| PipelineVampIR
@@ -71,25 +72,25 @@ fromTransformationLikes = concatMap fromTransformationLike
toTypecheckTransformations :: [TransformationId]
toTypecheckTransformations = [MatchToCase]
-toEvalTransformations :: [TransformationId]
-toEvalTransformations = [EtaExpandApps, MatchToCase, NatToPrimInt, IntToPrimInt, ConvertBuiltinTypes, OptPhaseEval, DisambiguateNames]
+toStoredTransformations :: [TransformationId]
+toStoredTransformations = [EtaExpandApps, MatchToCase, NatToPrimInt, IntToPrimInt, ConvertBuiltinTypes, OptPhaseEval, DisambiguateNames]
toNormalizeTransformations :: [TransformationId]
-toNormalizeTransformations = toEvalTransformations ++ [LetRecLifting, LetFolding, UnrollRecursion]
+toNormalizeTransformations = [CombineInfoTables, LetRecLifting, LetFolding, UnrollRecursion]
toVampIRTransformations :: [TransformationId]
-toVampIRTransformations = toEvalTransformations ++ [FilterUnreachable, CheckVampIR, LetRecLifting, OptPhaseVampIR, UnrollRecursion, Normalize, LetHoisting]
+toVampIRTransformations = [CombineInfoTables, FilterUnreachable, CheckVampIR, LetRecLifting, OptPhaseVampIR, UnrollRecursion, Normalize, LetHoisting]
toStrippedTransformations :: [TransformationId]
toStrippedTransformations =
- toEvalTransformations ++ [CheckExec, LambdaLetRecLifting, TopEtaExpand, OptPhaseExec, MoveApps, RemoveTypeArgs]
+ [CombineInfoTables, FilterUnreachable, CheckExec, LambdaLetRecLifting, TopEtaExpand, OptPhaseExec, MoveApps, RemoveTypeArgs]
toGebTransformations :: [TransformationId]
-toGebTransformations = toEvalTransformations ++ [FilterUnreachable, CheckGeb, LetRecLifting, OptPhaseGeb, UnrollRecursion, FoldTypeSynonyms, ComputeTypeInfo]
+toGebTransformations = [CombineInfoTables, FilterUnreachable, CheckGeb, LetRecLifting, OptPhaseGeb, UnrollRecursion, FoldTypeSynonyms, ComputeTypeInfo]
pipeline :: PipelineId -> [TransformationId]
pipeline = \case
- PipelineEval -> toEvalTransformations
+ PipelineStored -> toStoredTransformations
PipelineNormalize -> toNormalizeTransformations
PipelineGeb -> toGebTransformations
PipelineVampIR -> toVampIRTransformations
diff --git a/src/Juvix/Compiler/Core/Data/TransformationId/Parser.hs b/src/Juvix/Compiler/Core/Data/TransformationId/Parser.hs
index 754312375e..6bcfd8505d 100644
--- a/src/Juvix/Compiler/Core/Data/TransformationId/Parser.hs
+++ b/src/Juvix/Compiler/Core/Data/TransformationId/Parser.hs
@@ -50,7 +50,7 @@ transformationLike =
pipelineText :: PipelineId -> Text
pipelineText = \case
- PipelineEval -> strEvalPipeline
+ PipelineStored -> strStoredPipeline
PipelineNormalize -> strNormalizePipeline
PipelineGeb -> strGebPipeline
PipelineVampIR -> strVampIRPipeline
@@ -78,6 +78,7 @@ transformationText = \case
ComputeTypeInfo -> strComputeTypeInfo
UnrollRecursion -> strUnrollRecursion
DisambiguateNames -> strDisambiguateNames
+ CombineInfoTables -> strCombineInfoTables
CheckGeb -> strCheckGeb
CheckExec -> strCheckExec
CheckVampIR -> strCheckVampIR
@@ -113,8 +114,8 @@ allStrings = map transformationLikeText allTransformationLikeIds
strLetHoisting :: Text
strLetHoisting = "let-hoisting"
-strEvalPipeline :: Text
-strEvalPipeline = "pipeline-eval"
+strStoredPipeline :: Text
+strStoredPipeline = "pipeline-stored"
strNormalizePipeline :: Text
strNormalizePipeline = "pipeline-normalize"
@@ -173,6 +174,9 @@ strUnrollRecursion = "unroll-recursion"
strDisambiguateNames :: Text
strDisambiguateNames = "disambiguate-names"
+strCombineInfoTables :: Text
+strCombineInfoTables = "combine-info-tables"
+
strCheckGeb :: Text
strCheckGeb = "check-geb"
diff --git a/src/Juvix/Compiler/Core/Data/TypeDependencyInfo.hs b/src/Juvix/Compiler/Core/Data/TypeDependencyInfo.hs
index 7e74ecbb7d..849792f14b 100644
--- a/src/Juvix/Compiler/Core/Data/TypeDependencyInfo.hs
+++ b/src/Juvix/Compiler/Core/Data/TypeDependencyInfo.hs
@@ -17,7 +17,7 @@ createTypeDependencyInfo tab = createDependencyInfo graph startVertices
<$> HashMap.filter (isNothing . (^. inductiveBuiltin)) (tab ^. infoInductives)
constructorTypes :: SimpleFold Tag Type
- constructorTypes = to (lookupConstructorInfo tab) . constructorType . to typeArgs . each
+ constructorTypes = to (lookupTabConstructorInfo tab) . constructorType . to typeArgs . each
inductiveSymbols :: SimpleFold InductiveInfo Symbol
inductiveSymbols = inductiveConstructors . each . constructorTypes . nodeInductives
diff --git a/src/Juvix/Compiler/Core/Extra/Utils.hs b/src/Juvix/Compiler/Core/Extra/Utils.hs
index e1ab6123e6..907d721511 100644
--- a/src/Juvix/Compiler/Core/Extra/Utils.hs
+++ b/src/Juvix/Compiler/Core/Extra/Utils.hs
@@ -17,6 +17,7 @@ import Data.HashSet qualified as HashSet
import Data.Set qualified as Set
import Juvix.Compiler.Core.Data.BinderList qualified as BL
import Juvix.Compiler.Core.Data.InfoTable
+import Juvix.Compiler.Core.Data.Module
import Juvix.Compiler.Core.Extra.Base
import Juvix.Compiler.Core.Extra.Equality
import Juvix.Compiler.Core.Extra.Info
@@ -42,25 +43,25 @@ isClosed = not . has freeVars
mkAxiom :: Interval -> Type -> Node
mkAxiom loc = mkBottom (Info.setInfoLocation loc mempty)
-isTypeConstr :: InfoTable -> Type -> Bool
-isTypeConstr tab ty = case typeTarget ty of
+isTypeConstr :: Module -> Type -> Bool
+isTypeConstr md ty = case typeTarget ty of
NUniv {} ->
True
NIdt Ident {..} ->
- isTypeConstr tab (lookupIdentifierNode tab _identSymbol)
+ isTypeConstr md (lookupIdentifierNode md _identSymbol)
_ -> False
-getTypeParams :: InfoTable -> Type -> [Type]
-getTypeParams tab ty = filter (isTypeConstr tab) (typeArgs ty)
+getTypeParams :: Module -> Type -> [Type]
+getTypeParams md ty = filter (isTypeConstr md) (typeArgs ty)
-getTypeParamsNum :: InfoTable -> Type -> Int
-getTypeParamsNum tab ty = length $ getTypeParams tab ty
+getTypeParamsNum :: Module -> Type -> Int
+getTypeParamsNum md ty = length $ getTypeParams md ty
-filterOutTypeSynonyms :: InfoTable -> InfoTable
-filterOutTypeSynonyms tab = pruneInfoTable tab'
+filterOutTypeSynonyms :: Module -> Module
+filterOutTypeSynonyms md = pruneInfoTable md'
where
- tab' = tab {_infoIdentifiers = idents'}
- idents' = HashMap.filter (\ii -> not (isTypeConstr tab (ii ^. identifierType))) (tab ^. infoIdentifiers)
+ md' = set (moduleInfoTable . infoIdentifiers) idents' md
+ idents' = HashMap.filter (\ii -> not (isTypeConstr md (ii ^. identifierType))) (md ^. moduleInfoTable . infoIdentifiers)
isType' :: Node -> Bool
isType' = \case
@@ -83,77 +84,77 @@ isType' = \case
NMatch {} -> False
Closure {} -> False
-isType :: InfoTable -> BinderList Binder -> Node -> Bool
-isType tab bl node = case node of
+isType :: Module -> BinderList Binder -> Node -> Bool
+isType md bl node = case node of
NVar Var {..}
| Just Binder {..} <- BL.lookupMay _varIndex bl ->
- isTypeConstr tab _binderType
+ isTypeConstr md _binderType
NIdt Ident {..}
- | Just ii <- lookupIdentifierInfo' tab _identSymbol ->
- isTypeConstr tab (ii ^. identifierType)
+ | Just ii <- lookupIdentifierInfo' md _identSymbol ->
+ isTypeConstr md (ii ^. identifierType)
_ -> isType' node
-isZeroOrderType' :: HashSet Symbol -> InfoTable -> Type -> Bool
-isZeroOrderType' foinds tab = \case
+isZeroOrderType' :: HashSet Symbol -> Module -> Type -> Bool
+isZeroOrderType' foinds md = \case
NPi {} -> False
NDyn {} -> False
NTyp TypeConstr {..} ->
- isFirstOrderInductive' foinds tab _typeConstrSymbol
- && all (isZeroOrderType' foinds tab) _typeConstrArgs
+ isFirstOrderInductive' foinds md _typeConstrSymbol
+ && all (isZeroOrderType' foinds md) _typeConstrArgs
ty -> isType' ty
-isFirstOrderType' :: HashSet Symbol -> InfoTable -> Type -> Bool
-isFirstOrderType' foinds tab ty = case ty of
+isFirstOrderType' :: HashSet Symbol -> Module -> Type -> Bool
+isFirstOrderType' foinds md ty = case ty of
NVar {} -> True
NPi Pi {..} ->
- isZeroOrderType' foinds tab (_piBinder ^. binderType)
- && isFirstOrderType' foinds tab _piBody
+ isZeroOrderType' foinds md (_piBinder ^. binderType)
+ && isFirstOrderType' foinds md _piBody
NUniv {} -> True
NPrim {} -> True
- NTyp {} -> isZeroOrderType' foinds tab ty
+ NTyp {} -> isZeroOrderType' foinds md ty
NDyn {} -> False
_ -> assert (not (isType' ty)) False
-isFirstOrderInductive' :: HashSet Symbol -> InfoTable -> Symbol -> Bool
-isFirstOrderInductive' foinds tab sym
+isFirstOrderInductive' :: HashSet Symbol -> Module -> Symbol -> Bool
+isFirstOrderInductive' foinds md sym
| HashSet.member sym foinds = True
- | otherwise = case lookupInductiveInfo' tab sym of
+ | otherwise = case lookupInductiveInfo' md sym of
Nothing -> False
Just ii ->
all
- (isFirstOrderType' (HashSet.insert sym foinds) tab . (^. constructorType) . lookupConstructorInfo tab)
+ (isFirstOrderType' (HashSet.insert sym foinds) md . (^. constructorType) . lookupConstructorInfo md)
(ii ^. inductiveConstructors)
-isFirstOrderType :: InfoTable -> Type -> Bool
+isFirstOrderType :: Module -> Type -> Bool
isFirstOrderType = isFirstOrderType' mempty
-isZeroOrderType :: InfoTable -> Type -> Bool
+isZeroOrderType :: Module -> Type -> Bool
isZeroOrderType = isZeroOrderType' mempty
-- | True for nodes whose evaluation immediately returns a value, i.e.,
-- no reduction or memory allocation in the runtime is required.
-isImmediate :: InfoTable -> Node -> Bool
-isImmediate tab = \case
+isImmediate :: Module -> Node -> Bool
+isImmediate md = \case
NVar {} -> True
NIdt {} -> True
NCst {} -> True
NCtr Constr {..}
- | Just ci <- lookupConstructorInfo' tab _constrTag ->
- let paramsNum = length (takeWhile (isTypeConstr tab) (typeArgs (ci ^. constructorType)))
+ | Just ci <- lookupConstructorInfo' md _constrTag ->
+ let paramsNum = length (takeWhile (isTypeConstr md) (typeArgs (ci ^. constructorType)))
in length _constrArgs <= paramsNum
- | otherwise -> all (isType tab mempty) _constrArgs
+ | otherwise -> all (isType md mempty) _constrArgs
node@(NApp {}) ->
let (h, args) = unfoldApps' node
in case h of
NIdt Ident {..}
- | Just ii <- lookupIdentifierInfo' tab _identSymbol ->
- let paramsNum = length (takeWhile (isTypeConstr tab) (typeArgs (ii ^. identifierType)))
+ | Just ii <- lookupIdentifierInfo' md _identSymbol ->
+ let paramsNum = length (takeWhile (isTypeConstr md) (typeArgs (ii ^. identifierType)))
in length args <= paramsNum
- _ -> all (isType tab mempty) args
- node -> isType tab mempty node
+ _ -> all (isType md mempty) args
+ node -> isType md mempty node
isImmediate' :: Node -> Bool
-isImmediate' = isImmediate emptyInfoTable
+isImmediate' = isImmediate emptyModule
-- | True if the argument is fully evaluated first-order data
isDataValue :: Node -> Bool
@@ -206,8 +207,8 @@ nodeInductives f = ufoldA reassemble go
NTyp ty -> NTyp <$> traverseOf typeConstrSymbol f ty
n -> pure n
-getSymbols :: InfoTable -> Node -> HashSet Symbol
-getSymbols tab = gather go mempty
+getSymbols :: Module -> Node -> HashSet Symbol
+getSymbols md = gather go mempty
where
go :: HashSet Symbol -> Node -> HashSet Symbol
go acc = \case
@@ -215,10 +216,13 @@ getSymbols tab = gather go mempty
NIdt Ident {..} -> HashSet.insert _identSymbol acc
NCase Case {..} -> HashSet.insert _caseInductive acc
NCtr Constr {..}
- | Just ci <- lookupConstructorInfo' tab _constrTag ->
+ | Just ci <- lookupConstructorInfo' md _constrTag ->
HashSet.insert (ci ^. constructorInductive) acc
_ -> acc
+getSymbols' :: InfoTable -> Node -> HashSet Symbol
+getSymbols' tab = getSymbols emptyModule {_moduleInfoTable = tab}
+
-- | Prism for NRec
_NRec :: SimpleFold Node LetRec
_NRec f = \case
@@ -439,17 +443,17 @@ translateCase translateIfFun dflt Case {..} = case _caseBranches of
translateCaseIf :: (Node -> Node -> Node -> a) -> Case -> a
translateCaseIf f = translateCase f impossible
-checkDepth :: InfoTable -> BinderList Binder -> Int -> Node -> Bool
-checkDepth tab bl 0 node = isType tab bl node
-checkDepth tab bl d node = case node of
+checkDepth :: Module -> BinderList Binder -> Int -> Node -> Bool
+checkDepth md bl 0 node = isType md bl node
+checkDepth md bl d node = case node of
NApp App {..} ->
- checkDepth tab bl d _appLeft && checkDepth tab bl (d - 1) _appRight
+ checkDepth md bl d _appLeft && checkDepth md bl (d - 1) _appRight
_ ->
all go (children node)
where
go :: NodeChild -> Bool
go NodeChild {..} =
- checkDepth tab (BL.prependRev _childBinders bl) (d - 1) _childNode
+ checkDepth md (BL.prependRev _childBinders bl) (d - 1) _childNode
isCaseBoolean :: [CaseBranch] -> Bool
isCaseBoolean = \case
diff --git a/src/Juvix/Compiler/Core/Extra/Value.hs b/src/Juvix/Compiler/Core/Extra/Value.hs
index 487660ad80..96c22d6fad 100644
--- a/src/Juvix/Compiler/Core/Extra/Value.hs
+++ b/src/Juvix/Compiler/Core/Extra/Value.hs
@@ -38,8 +38,8 @@ toValue tab = \case
_constrAppArgs = map (toValue tab) (drop paramsNum _constrArgs)
}
where
- ci = lookupConstructorInfo tab _constrTag
- ii = lookupInductiveInfo tab (ci ^. constructorInductive)
+ ci = lookupTabConstructorInfo tab _constrTag
+ ii = lookupTabInductiveInfo tab (ci ^. constructorInductive)
paramsNum = length (ii ^. inductiveParams)
goType :: Value
diff --git a/src/Juvix/Compiler/Core/Language/Base.hs b/src/Juvix/Compiler/Core/Language/Base.hs
index f382bb2ada..2ab80eb4c5 100644
--- a/src/Juvix/Compiler/Core/Language/Base.hs
+++ b/src/Juvix/Compiler/Core/Language/Base.hs
@@ -8,14 +8,31 @@ module Juvix.Compiler.Core.Language.Base
)
where
+import GHC.Show qualified as Show
import Juvix.Compiler.Core.Info (Info, IsInfo, Key)
import Juvix.Compiler.Core.Language.Builtins
+import Juvix.Extra.Serialize
import Juvix.Prelude
+import Prettyprinter
type Location = Interval
-- | Consecutive symbol IDs for reachable user functions.
-type Symbol = Word
+data Symbol = Symbol
+ { _symbolModuleId :: ModuleId,
+ _symbolId :: Word
+ }
+ deriving stock (Ord, Eq, Generic)
+
+instance Serialize Symbol
+
+instance Hashable Symbol
+
+instance Pretty Symbol where
+ pretty Symbol {..} = pretty _symbolId <> "@" <> pretty _symbolModuleId
+
+instance Show Symbol where
+ show = show . pretty
uniqueName :: Text -> Symbol -> Text
uniqueName txt sym = txt <> "_" <> show sym
@@ -26,11 +43,13 @@ uniqueName txt sym = txt <> "_" <> show sym
-- can treat them specially.
data Tag
= BuiltinTag BuiltinDataTag
- | UserTag Word
+ | UserTag ModuleId Word
deriving stock (Eq, Generic, Ord, Show)
instance Hashable Tag
+instance Serialize Tag
+
isBuiltinTag :: Tag -> Bool
isBuiltinTag = \case
BuiltinTag {} -> True
@@ -42,6 +61,11 @@ type Index = Int
-- | de Bruijn level (reverse de Bruijn index)
type Level = Int
+getUserTagId :: Tag -> Maybe Word
+getUserTagId = \case
+ UserTag _ u -> Just u
+ BuiltinTag {} -> Nothing
+
-- | The first argument `bl` is the current binder level (the number of binders
-- upward).
getBinderLevel :: Level -> Index -> Level
@@ -51,3 +75,5 @@ getBinderLevel bl idx = bl - idx - 1
-- upward).
getBinderIndex :: Level -> Level -> Index
getBinderIndex bl lvl = bl - lvl - 1
+
+makeLenses ''Symbol
diff --git a/src/Juvix/Compiler/Core/Language/Builtins.hs b/src/Juvix/Compiler/Core/Language/Builtins.hs
index 2aa9187c2f..c8672130db 100644
--- a/src/Juvix/Compiler/Core/Language/Builtins.hs
+++ b/src/Juvix/Compiler/Core/Language/Builtins.hs
@@ -1,5 +1,6 @@
module Juvix.Compiler.Core.Language.Builtins where
+import Juvix.Extra.Serialize
import Juvix.Prelude
-- Builtin operations which the evaluator and the code generator treat
@@ -19,7 +20,9 @@ data BuiltinOp
| OpSeq
| OpTrace
| OpFail
- deriving stock (Eq)
+ deriving stock (Eq, Generic)
+
+instance Serialize BuiltinOp
-- Builtin data tags
data BuiltinDataTag
@@ -33,6 +36,8 @@ data BuiltinDataTag
instance Hashable BuiltinDataTag
+instance Serialize BuiltinDataTag
+
builtinOpArgsNum :: BuiltinOp -> Int
builtinOpArgsNum = \case
OpIntAdd -> 2
diff --git a/src/Juvix/Compiler/Core/Language/Nodes.hs b/src/Juvix/Compiler/Core/Language/Nodes.hs
index e79c1f8b36..e3ed665cf7 100644
--- a/src/Juvix/Compiler/Core/Language/Nodes.hs
+++ b/src/Juvix/Compiler/Core/Language/Nodes.hs
@@ -6,6 +6,7 @@ module Juvix.Compiler.Core.Language.Nodes
)
where
+import Data.Serialize
import Juvix.Compiler.Core.Language.Base
import Juvix.Compiler.Core.Language.Primitives
@@ -14,6 +15,7 @@ data Var' i = Var
{ _varInfo :: i,
_varIndex :: !Index
}
+ deriving stock (Generic)
-- | Global identifier of a function (with corresponding `Node` in the global
-- context).
@@ -21,16 +23,18 @@ data Ident' i = Ident
{ _identInfo :: i,
_identSymbol :: !Symbol
}
+ deriving stock (Generic)
data Constant' i = Constant
{ _constantInfo :: i,
_constantValue :: !ConstantValue
}
+ deriving stock (Generic)
data ConstantValue
= ConstInteger !Integer
| ConstString !Text
- deriving stock (Eq)
+ deriving stock (Eq, Generic)
-- | Info about a single binder. Associated with Lambda, Pi, Let, Case or Match.
data Binder' ty = Binder
@@ -38,6 +42,7 @@ data Binder' ty = Binder
_binderLocation :: Maybe Location,
_binderType :: ty
}
+ deriving stock (Generic)
-- Other things we might need in the future:
-- - ConstFloat or ConstFixedPoint
@@ -47,12 +52,14 @@ data App' i a = App
_appLeft :: !a,
_appRight :: !a
}
+ deriving stock (Generic)
data Apps' i f a = Apps
{ _appsInfo :: i,
_appsFun :: !f,
_appsArgs :: ![a]
}
+ deriving stock (Generic)
-- | A builtin application. A builtin has no corresponding Node. It is treated
-- specially by the evaluator and the code generator. For example, basic
@@ -66,6 +73,7 @@ data BuiltinApp' i a = BuiltinApp
_builtinAppOp :: !BuiltinOp,
_builtinAppArgs :: ![a]
}
+ deriving stock (Generic)
-- | A data constructor application. The number of arguments supplied must be
-- equal to the number of arguments expected by the constructor.
@@ -74,6 +82,7 @@ data Constr' i a = Constr
_constrTag :: !Tag,
_constrArgs :: ![a]
}
+ deriving stock (Generic)
-- | Useful for unfolding lambdas
data LambdaLhs' i ty = LambdaLhs
@@ -86,6 +95,7 @@ data Lambda' i a ty = Lambda
_lambdaBinder :: Binder' ty,
_lambdaBody :: !a
}
+ deriving stock (Generic)
-- | `let x := value in body` is not reducible to lambda + application for the
-- purposes of ML-polymorphic / dependent type checking or code generation!
@@ -94,11 +104,13 @@ data Let' i a ty = Let
_letItem :: {-# UNPACK #-} !(LetItem' a ty),
_letBody :: !a
}
+ deriving stock (Generic)
data LetItem' a ty = LetItem
{ _letItemBinder :: Binder' ty,
_letItemValue :: a
}
+ deriving stock (Generic)
-- | Represents a block of mutually recursive local definitions. Both in the
-- body and in the values `length _letRecValues` implicit binders are introduced
@@ -111,6 +123,7 @@ data LetRec' i a ty = LetRec
_letRecValues :: !(NonEmpty (LetItem' a ty)),
_letRecBody :: !a
}
+ deriving stock (Generic)
-- | One-level case matching on the tag of a data constructor: `Case value
-- branches default`. `Case` is lazy: only the selected branch is evaluated.
@@ -121,6 +134,7 @@ data Case' i bi a ty = Case
_caseBranches :: ![CaseBranch' bi a ty],
_caseDefault :: !(Maybe a)
}
+ deriving stock (Generic)
-- | `CaseBranch tag binders bindersNum branch`
-- - `binders` are the arguments of the constructor tagged with `tag`,
@@ -132,6 +146,7 @@ data CaseBranch' i a ty = CaseBranch
_caseBranchBindersNum :: !Int,
_caseBranchBody :: !a
}
+ deriving stock (Generic)
-- | A special form of `Case` for the booleans. Used only in Core.Stripped.
data If' i a = If
@@ -140,6 +155,7 @@ data If' i a = If
_ifTrue :: !a,
_ifFalse :: !a
}
+ deriving stock (Generic)
-- | Complex pattern match. `Match` is lazy: only the selected branch is evaluated.
data Match' i a = Match
@@ -196,12 +212,14 @@ data Pi' i a = Pi
_piBinder :: Binder' a,
_piBody :: !a
}
+ deriving stock (Generic)
-- | Universe. Compilation-time only.
data Univ' i = Univ
{ _univInfo :: i,
_univLevel :: !Int
}
+ deriving stock (Generic)
-- | Type constructor application. Compilation-time only.
data TypeConstr' i a = TypeConstr
@@ -209,12 +227,14 @@ data TypeConstr' i a = TypeConstr
_typeConstrSymbol :: !Symbol,
_typeConstrArgs :: ![a]
}
+ deriving stock (Generic)
-- | A primitive type.
data TypePrim' i = TypePrim
{ _typePrimInfo :: i,
_typePrimPrimitive :: Primitive
}
+ deriving stock (Generic)
-- | Dynamic type. A Node with a dynamic type has an unknown type. Useful
-- for transformations that introduce partial type information, e.g., one can
@@ -222,16 +242,58 @@ data TypePrim' i = TypePrim
newtype Dynamic' i = Dynamic
{ _dynamicInfo :: i
}
+ deriving stock (Generic)
-- | A fail node.
data Bottom' i a = Bottom
{ _bottomInfo :: i,
_bottomType :: !a
}
+ deriving stock (Generic)
{-------------------------------------------------------------------}
{- Typeclass instances -}
+instance (Serialize i) => Serialize (Var' i)
+
+instance (Serialize i) => Serialize (Ident' i)
+
+instance Serialize ConstantValue
+
+instance (Serialize i) => Serialize (Constant' i)
+
+instance (Serialize i, Serialize a) => Serialize (App' i a)
+
+instance (Serialize i, Serialize a) => Serialize (BuiltinApp' i a)
+
+instance (Serialize i, Serialize a) => Serialize (Constr' i a)
+
+instance (Serialize ty) => Serialize (Binder' ty)
+
+instance (Serialize i, Serialize a, Serialize ty) => Serialize (Lambda' i a ty)
+
+instance (Serialize a, Serialize ty) => Serialize (LetItem' a ty)
+
+instance (Serialize i, Serialize a, Serialize ty) => Serialize (Let' i a ty)
+
+instance (Serialize i, Serialize a, Serialize ty) => Serialize (LetRec' i a ty)
+
+instance (Serialize bi, Serialize a, Serialize ty) => Serialize (CaseBranch' bi a ty)
+
+instance (Serialize i, Serialize bi, Serialize a, Serialize ty) => Serialize (Case' i bi a ty)
+
+instance (Serialize i, Serialize a) => Serialize (Pi' i a)
+
+instance (Serialize i) => Serialize (Univ' i)
+
+instance (Serialize i) => Serialize (TypePrim' i)
+
+instance (Serialize i, Serialize a) => Serialize (TypeConstr' i a)
+
+instance (Serialize i) => Serialize (Dynamic' i)
+
+instance (Serialize i, Serialize a) => Serialize (Bottom' i a)
+
instance HasAtomicity (Var' i) where
atomicity _ = Atom
diff --git a/src/Juvix/Compiler/Core/Language/Primitives.hs b/src/Juvix/Compiler/Core/Language/Primitives.hs
index 35ec48865c..17f4e4cdd2 100644
--- a/src/Juvix/Compiler/Core/Language/Primitives.hs
+++ b/src/Juvix/Compiler/Core/Language/Primitives.hs
@@ -7,24 +7,31 @@ represented by booleans, any type isomorphic to unary natural numbers may be
represented by integers with minimum value 0. -}
import Juvix.Compiler.Core.Language.Base
+import Juvix.Extra.Serialize
-- | Primitive type representation.
data Primitive
= PrimInteger PrimIntegerInfo
| PrimBool PrimBoolInfo
| PrimString
- deriving stock (Eq)
+ deriving stock (Eq, Generic)
-- | Info about a type represented as an integer.
data PrimIntegerInfo = PrimIntegerInfo
{ _infoMinValue :: Maybe Integer,
_infoMaxValue :: Maybe Integer
}
- deriving stock (Eq)
+ deriving stock (Eq, Generic)
-- | Info about a type represented as a boolean.
data PrimBoolInfo = PrimBoolInfo
{ _infoTrueTag :: Tag,
_infoFalseTag :: Tag
}
- deriving stock (Eq)
+ deriving stock (Eq, Generic)
+
+instance Serialize Primitive
+
+instance Serialize PrimIntegerInfo
+
+instance Serialize PrimBoolInfo
diff --git a/src/Juvix/Compiler/Core/Normalizer.hs b/src/Juvix/Compiler/Core/Normalizer.hs
index bc15d6f9a2..289b80a2ff 100644
--- a/src/Juvix/Compiler/Core/Normalizer.hs
+++ b/src/Juvix/Compiler/Core/Normalizer.hs
@@ -1,8 +1,8 @@
module Juvix.Compiler.Core.Normalizer where
import Data.HashMap.Strict qualified as HashMap
-import Juvix.Compiler.Core.Data.InfoTable
import Juvix.Compiler.Core.Data.InfoTableBuilder
+import Juvix.Compiler.Core.Data.Module
import Juvix.Compiler.Core.Evaluator
import Juvix.Compiler.Core.Extra.Base
import Juvix.Compiler.Core.Language
@@ -20,8 +20,8 @@ makeLenses ''NormEnv
type Norm = Sem '[Reader NormEnv, InfoTableBuilder]
-normalize :: InfoTable -> Node -> Node
-normalize tab0 = run . evalInfoTableBuilder tab0 . runReader normEnv . normalize'
+normalize :: Module -> Node -> Node
+normalize md = run . evalInfoTableBuilder md . runReader normEnv . normalize'
where
normEnv =
NormEnv
@@ -29,6 +29,7 @@ normalize tab0 = run . evalInfoTableBuilder tab0 . runReader normEnv . normalize
_normEnvLevel = 0,
_normEnvEvalEnv = []
}
+ identCtx = computeCombinedIdentContext md
normalize' :: Node -> Norm Node
normalize' node0 = do
@@ -38,8 +39,7 @@ normalize tab0 = run . evalInfoTableBuilder tab0 . runReader normEnv . normalize
neval :: Node -> Norm Node
neval node = do
env <- asks (^. normEnvEvalEnv)
- tab <- getInfoTable
- return $ geval opts stdout (tab ^. identContext) env node
+ return $ geval opts stdout identCtx env node
where
opts =
defaultEvalOptions
diff --git a/src/Juvix/Compiler/Core/Pipeline.hs b/src/Juvix/Compiler/Core/Pipeline.hs
index 103ee0101c..f7b1c947af 100644
--- a/src/Juvix/Compiler/Core/Pipeline.hs
+++ b/src/Juvix/Compiler/Core/Pipeline.hs
@@ -9,34 +9,34 @@ import Juvix.Compiler.Core.Options
import Juvix.Compiler.Core.Transformation
import Juvix.Compiler.Pipeline.EntryPoint (EntryPoint)
--- | Perform transformations on Core necessary for efficient evaluation
-toEval' :: (Members '[Error JuvixError, Reader CoreOptions] r) => InfoTable -> Sem r InfoTable
-toEval' = applyTransformations toEvalTransformations
+-- | Perform transformations on Core necessary for storage
+toStored' :: (Members '[Error JuvixError, Reader CoreOptions] r) => Module -> Sem r Module
+toStored' = applyTransformations toStoredTransformations
-toTypechecked :: (Members '[Error JuvixError, Reader EntryPoint] r) => InfoTable -> Sem r InfoTable
+toTypechecked :: (Members '[Error JuvixError, Reader EntryPoint] r) => Module -> Sem r Module
toTypechecked = mapReader fromEntryPoint . applyTransformations toTypecheckTransformations
-toEval :: (Members '[Error JuvixError, Reader EntryPoint] r) => InfoTable -> Sem r InfoTable
-toEval = mapReader fromEntryPoint . applyTransformations toEvalTransformations
+toStored :: (Members '[Error JuvixError, Reader EntryPoint] r) => Module -> Sem r Module
+toStored = mapReader fromEntryPoint . applyTransformations toStoredTransformations
--- | Perform transformations on Core necessary before the translation to
+-- | Perform transformations on stored Core necessary before the translation to
-- Core.Stripped
-toStripped' :: (Members '[Error JuvixError, Reader CoreOptions] r) => InfoTable -> Sem r InfoTable
+toStripped' :: (Members '[Error JuvixError, Reader CoreOptions] r) => Module -> Sem r Module
toStripped' = applyTransformations toStrippedTransformations
-toStripped :: (Members '[Error JuvixError, Reader EntryPoint] r) => InfoTable -> Sem r InfoTable
+toStripped :: (Members '[Error JuvixError, Reader EntryPoint] r) => Module -> Sem r Module
toStripped = mapReader fromEntryPoint . applyTransformations toStrippedTransformations
--- | Perform transformations on Core necessary before the translation to GEB
-toGeb' :: (Members '[Error JuvixError, Reader CoreOptions] r) => InfoTable -> Sem r InfoTable
+-- | Perform transformations on stored Core necessary before the translation to GEB
+toGeb' :: (Members '[Error JuvixError, Reader CoreOptions] r) => Module -> Sem r Module
toGeb' = applyTransformations toGebTransformations
-toGeb :: (Members '[Error JuvixError, Reader EntryPoint] r) => InfoTable -> Sem r InfoTable
+toGeb :: (Members '[Error JuvixError, Reader EntryPoint] r) => Module -> Sem r Module
toGeb = mapReader fromEntryPoint . applyTransformations toGebTransformations
--- | Perform transformations on Core necessary before the translation to VampIR
-toVampIR' :: (Members '[Error JuvixError, Reader CoreOptions] r) => InfoTable -> Sem r InfoTable
+-- | Perform transformations on stored Core necessary before the translation to VampIR
+toVampIR' :: (Members '[Error JuvixError, Reader CoreOptions] r) => Module -> Sem r Module
toVampIR' = applyTransformations toVampIRTransformations
-toVampIR :: (Members '[Error JuvixError, Reader EntryPoint] r) => InfoTable -> Sem r InfoTable
+toVampIR :: (Members '[Error JuvixError, Reader EntryPoint] r) => Module -> Sem r Module
toVampIR = mapReader fromEntryPoint . applyTransformations toVampIRTransformations
diff --git a/src/Juvix/Compiler/Core/Pretty/Base.hs b/src/Juvix/Compiler/Core/Pretty/Base.hs
index d9303f23ab..c13e56414a 100644
--- a/src/Juvix/Compiler/Core/Pretty/Base.hs
+++ b/src/Juvix/Compiler/Core/Pretty/Base.hs
@@ -59,7 +59,7 @@ instance PrettyCode BuiltinDataTag where
instance PrettyCode Tag where
ppCode = \case
BuiltinTag tag -> ppCode tag
- UserTag tag -> return $ kwUnnamedConstr <> pretty tag
+ UserTag mid tag -> return $ kwUnnamedConstr <> pretty tag <> "@" <> pretty mid
instance PrettyCode Primitive where
ppCode = \case
@@ -73,7 +73,7 @@ ppName kind name = return $ annotate (AnnKind kind) (pretty name)
ppIdentName :: (Member (Reader Options) r) => Text -> Symbol -> Sem r (Doc Ann)
ppIdentName name sym = do
showIds <- asks (^. optShowIdentIds)
- let name' = if showIds then name <> "!" <> prettyText sym else name
+ let name' = if showIds then name <> "!" <> show sym else name
ppName KNameFunction name'
ppCodeVar' :: (Member (Reader Options) r) => Text -> Var' i -> Sem r (Doc Ann)
@@ -445,7 +445,7 @@ instance PrettyCode InfoTable where
sigs <- ppSigs (sortOn (^. identifierSymbol) $ toList (tbl ^. infoIdentifiers))
ctx' <- ppContext (tbl ^. identContext)
axioms <- vsep <$> mapM ppCode (tbl ^. infoAxioms)
- main <- maybe (return "") (\s -> (<> line) . (line <>) <$> ppName KNameFunction (identName tbl s)) (tbl ^. infoMain)
+ main <- maybe (return "") (\s -> (<> line) . (line <>) <$> ppName KNameFunction (identName' tbl s)) (tbl ^. infoMain)
return
( header "Inductives:"
<> tys
@@ -468,11 +468,11 @@ instance PrettyCode InfoTable where
showIds <- asks (^. optShowIdentIds)
let mname :: Text
mname = tbl ^. infoIdentifiers . at s . _Just . identifierName
- mname' = if showIds then (\nm -> nm <> "!" <> prettyText s) mname else mname
+ mname' = if showIds then (\nm -> nm <> "!" <> show s) mname else mname
sym' <- ppName KNameFunction mname'
let -- the identifier may be missing if we have filtered out some
-- identifiers for printing purposes
- mii = lookupIdentifierInfo' tbl s
+ mii = lookupTabIdentifierInfo' tbl s
case mii of
Nothing -> return Nothing
Just ii -> do
@@ -514,7 +514,7 @@ instance PrettyCode InfoTable where
ppInductive :: InductiveInfo -> Sem r (Doc Ann)
ppInductive ii = do
name <- ppName KNameInductive (ii ^. inductiveName)
- ctrs <- mapM (fmap (<> semi) . ppCode . lookupConstructorInfo tbl) (ii ^. inductiveConstructors)
+ ctrs <- mapM (fmap (<> semi) . ppCode . lookupTabConstructorInfo tbl) (ii ^. inductiveConstructors)
return (kwInductive <+> name <+> braces (line <> indent' (vsep ctrs) <> line) <> kwSemicolon)
instance PrettyCode AxiomInfo where
diff --git a/src/Juvix/Compiler/Core/Transformation.hs b/src/Juvix/Compiler/Core/Transformation.hs
index 9a3c3aabe7..8ed69f529a 100644
--- a/src/Juvix/Compiler/Core/Transformation.hs
+++ b/src/Juvix/Compiler/Core/Transformation.hs
@@ -8,6 +8,7 @@ module Juvix.Compiler.Core.Transformation
)
where
+import Juvix.Compiler.Core.Data.Module
import Juvix.Compiler.Core.Data.TransformationId
import Juvix.Compiler.Core.Error
import Juvix.Compiler.Core.Options
@@ -15,6 +16,7 @@ import Juvix.Compiler.Core.Transformation.Base
import Juvix.Compiler.Core.Transformation.Check.Exec
import Juvix.Compiler.Core.Transformation.Check.Geb
import Juvix.Compiler.Core.Transformation.Check.VampIR
+import Juvix.Compiler.Core.Transformation.CombineInfoTables (combineInfoTables)
import Juvix.Compiler.Core.Transformation.ComputeTypeInfo
import Juvix.Compiler.Core.Transformation.ConvertBuiltinTypes
import Juvix.Compiler.Core.Transformation.DisambiguateNames
@@ -49,10 +51,10 @@ import Juvix.Compiler.Core.Transformation.RemoveTypeArgs
import Juvix.Compiler.Core.Transformation.TopEtaExpand
import Juvix.Compiler.Core.Transformation.UnrollRecursion
-applyTransformations :: forall r. (Members '[Error JuvixError, Reader CoreOptions] r) => [TransformationId] -> InfoTable -> Sem r InfoTable
+applyTransformations :: forall r. (Members '[Error JuvixError, Reader CoreOptions] r) => [TransformationId] -> Module -> Sem r Module
applyTransformations ts tbl = foldM (flip appTrans) tbl ts
where
- appTrans :: TransformationId -> InfoTable -> Sem r InfoTable
+ appTrans :: TransformationId -> Module -> Sem r Module
appTrans = \case
LambdaLetRecLifting -> return . lambdaLetRecLifting
LetRecLifting -> return . letRecLifting
@@ -69,6 +71,7 @@ applyTransformations ts tbl = foldM (flip appTrans) tbl ts
NaiveMatchToCase -> return . Naive.matchToCase
EtaExpandApps -> return . etaExpansionApps
DisambiguateNames -> return . disambiguateNames
+ CombineInfoTables -> return . combineInfoTables
CheckGeb -> mapError (JuvixError @CoreError) . checkGeb
CheckExec -> mapError (JuvixError @CoreError) . checkExec
CheckVampIR -> mapError (JuvixError @CoreError) . checkVampIR
diff --git a/src/Juvix/Compiler/Core/Transformation/Base.hs b/src/Juvix/Compiler/Core/Transformation/Base.hs
index e2cf866b02..1074702dcc 100644
--- a/src/Juvix/Compiler/Core/Transformation/Base.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Base.hs
@@ -1,6 +1,9 @@
+-- | Transformations operate on a module. They transform the info table of the
+-- module. The imports table is used for symbol/tag lookup but never modified.
module Juvix.Compiler.Core.Transformation.Base
( module Juvix.Compiler.Core.Transformation.Base,
module Juvix.Compiler.Core.Data.InfoTable,
+ module Juvix.Compiler.Core.Data.Module,
module Juvix.Compiler.Core.Language,
)
where
@@ -8,25 +11,26 @@ where
import Data.HashMap.Strict qualified as HashMap
import Juvix.Compiler.Core.Data.InfoTable
import Juvix.Compiler.Core.Data.InfoTableBuilder
+import Juvix.Compiler.Core.Data.Module
import Juvix.Compiler.Core.Language
import Juvix.Compiler.Core.Options
-mapIdentsM :: (Monad m) => (IdentifierInfo -> m IdentifierInfo) -> InfoTable -> m InfoTable
-mapIdentsM = overM infoIdentifiers . mapM
+mapIdentsM :: (Monad m) => (IdentifierInfo -> m IdentifierInfo) -> Module -> m Module
+mapIdentsM = overM (moduleInfoTable . infoIdentifiers) . mapM
-mapInductivesM :: (Monad m) => (InductiveInfo -> m InductiveInfo) -> InfoTable -> m InfoTable
-mapInductivesM = overM infoInductives . mapM
+mapInductivesM :: (Monad m) => (InductiveInfo -> m InductiveInfo) -> Module -> m Module
+mapInductivesM = overM (moduleInfoTable . infoInductives) . mapM
-mapConstructorsM :: (Monad m) => (ConstructorInfo -> m ConstructorInfo) -> InfoTable -> m InfoTable
-mapConstructorsM = overM infoConstructors . mapM
+mapConstructorsM :: (Monad m) => (ConstructorInfo -> m ConstructorInfo) -> Module -> m Module
+mapConstructorsM = overM (moduleInfoTable . infoConstructors) . mapM
-mapAxiomsM :: (Monad m) => (AxiomInfo -> m AxiomInfo) -> InfoTable -> m InfoTable
-mapAxiomsM = overM infoAxioms . mapM
+mapAxiomsM :: (Monad m) => (AxiomInfo -> m AxiomInfo) -> Module -> m Module
+mapAxiomsM = overM (moduleInfoTable . infoAxioms) . mapM
-mapNodesM :: (Monad m) => (Node -> m Node) -> InfoTable -> m InfoTable
-mapNodesM = overM identContext . mapM
+mapNodesM :: (Monad m) => (Node -> m Node) -> Module -> m Module
+mapNodesM = overM (moduleInfoTable . identContext) . mapM
-mapAllNodesM :: (Monad m) => (Node -> m Node) -> InfoTable -> m InfoTable
+mapAllNodesM :: (Monad m) => (Node -> m Node) -> Module -> m Module
mapAllNodesM f tab =
mapNodesM f tab
>>= mapAxiomsM (overM axiomType f)
@@ -34,39 +38,39 @@ mapAllNodesM f tab =
>>= mapInductivesM (overM inductiveKind f)
>>= mapIdentsM (overM identifierType f)
-mapIdents :: (IdentifierInfo -> IdentifierInfo) -> InfoTable -> InfoTable
-mapIdents = over infoIdentifiers . fmap
+mapIdents :: (IdentifierInfo -> IdentifierInfo) -> Module -> Module
+mapIdents = over (moduleInfoTable . infoIdentifiers) . fmap
-mapInductives :: (InductiveInfo -> InductiveInfo) -> InfoTable -> InfoTable
-mapInductives = over infoInductives . fmap
+mapInductives :: (InductiveInfo -> InductiveInfo) -> Module -> Module
+mapInductives = over (moduleInfoTable . infoInductives) . fmap
-mapConstructors :: (ConstructorInfo -> ConstructorInfo) -> InfoTable -> InfoTable
-mapConstructors = over infoConstructors . fmap
+mapConstructors :: (ConstructorInfo -> ConstructorInfo) -> Module -> Module
+mapConstructors = over (moduleInfoTable . infoConstructors) . fmap
-mapAxioms :: (AxiomInfo -> AxiomInfo) -> InfoTable -> InfoTable
-mapAxioms = over infoAxioms . fmap
+mapAxioms :: (AxiomInfo -> AxiomInfo) -> Module -> Module
+mapAxioms = over (moduleInfoTable . infoAxioms) . fmap
-mapT :: (Symbol -> Node -> Node) -> InfoTable -> InfoTable
-mapT f tab = tab {_identContext = HashMap.mapWithKey f (tab ^. identContext)}
+mapT :: (Symbol -> Node -> Node) -> Module -> Module
+mapT f = over (moduleInfoTable . identContext) (HashMap.mapWithKey f)
-mapT' :: (Symbol -> Node -> Sem (InfoTableBuilder ': r) Node) -> InfoTable -> Sem r InfoTable
-mapT' f tab =
+mapT' :: (Symbol -> Node -> Sem (InfoTableBuilder ': r) Node) -> Module -> Sem r Module
+mapT' f m =
fmap fst $
- runInfoTableBuilder tab $
+ runInfoTableBuilder m $
mapM_
(\(k, v) -> f k v >>= registerIdentNode k)
- (HashMap.toList (tab ^. identContext))
+ (HashMap.toList (m ^. moduleInfoTable . identContext))
walkT :: (Applicative f) => (Symbol -> Node -> f ()) -> InfoTable -> f ()
walkT f tab = for_ (HashMap.toList (tab ^. identContext)) (uncurry f)
-mapAllNodes :: (Node -> Node) -> InfoTable -> InfoTable
-mapAllNodes f tab =
+mapAllNodes :: (Node -> Node) -> Module -> Module
+mapAllNodes f md =
mapAxioms convertAxiom $
mapInductives convertInductive $
mapConstructors convertConstructor $
mapIdents convertIdent $
- mapT (const f) tab
+ mapT (const f) md
where
convertIdent :: IdentifierInfo -> IdentifierInfo
convertIdent ii =
@@ -87,12 +91,12 @@ mapAllNodes f tab =
convertAxiom :: AxiomInfo -> AxiomInfo
convertAxiom = over axiomType f
-withOptimizationLevel :: (Member (Reader CoreOptions) r) => Int -> (InfoTable -> Sem r InfoTable) -> InfoTable -> Sem r InfoTable
+withOptimizationLevel :: (Member (Reader CoreOptions) r) => Int -> (Module -> Sem r Module) -> Module -> Sem r Module
withOptimizationLevel n f tab = do
l <- asks (^. optOptimizationLevel)
if
| l >= n -> f tab
| otherwise -> return tab
-withOptimizationLevel' :: (Member (Reader CoreOptions) r) => InfoTable -> Int -> (InfoTable -> Sem r InfoTable) -> Sem r InfoTable
+withOptimizationLevel' :: (Member (Reader CoreOptions) r) => Module -> Int -> (Module -> Sem r Module) -> Sem r Module
withOptimizationLevel' tab n f = withOptimizationLevel n f tab
diff --git a/src/Juvix/Compiler/Core/Transformation/Check/Base.hs b/src/Juvix/Compiler/Core/Transformation/Check/Base.hs
index 36a8286eee..421be2cb67 100644
--- a/src/Juvix/Compiler/Core/Transformation/Check/Base.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Check/Base.hs
@@ -2,6 +2,7 @@ module Juvix.Compiler.Core.Transformation.Check.Base where
import Juvix.Compiler.Core.Data.InfoTable
import Juvix.Compiler.Core.Data.InfoTableBuilder
+import Juvix.Compiler.Core.Data.Module
import Juvix.Compiler.Core.Data.TypeDependencyInfo (createTypeDependencyInfo)
import Juvix.Compiler.Core.Error
import Juvix.Compiler.Core.Extra
@@ -22,8 +23,8 @@ dynamicTypeError node loc =
axiomError :: (Members '[Error CoreError, InfoTableBuilder] r) => Symbol -> Maybe Location -> Sem r a
axiomError sym loc = do
- tbl <- getInfoTable
- let nameTxt = identName tbl sym
+ md <- getModule
+ let nameTxt = identName md sym
throw
CoreError
{ _coreErrorMsg = ppOutput ("The symbol" <+> annotate (AnnKind KNameAxiom) (pretty nameTxt) <> " is defined as an axiom and thus it cannot be compiled"),
@@ -73,7 +74,7 @@ checkBuiltins allowUntypedFail = dmapRM go
-- | Checks that the root of the node is not `Bottom`. Currently the only way we
-- create `Bottom` is when translating axioms that are not builtin. Hence it is
-- enough to check the root only.
-checkNoAxioms :: forall r. (Member (Error CoreError) r) => InfoTable -> Sem r ()
+checkNoAxioms :: forall r. (Member (Error CoreError) r) => Module -> Sem r ()
checkNoAxioms = void . mapT' checkNodeNoAxiom
where
checkNodeNoAxiom :: Symbol -> Node -> Sem (InfoTableBuilder ': r) Node
@@ -95,13 +96,13 @@ checkNoIO = dmapM go
_ -> return node
_ -> return node
-checkTypes :: forall r. (Member (Error CoreError) r) => Bool -> InfoTable -> Node -> Sem r Node
-checkTypes allowPolymorphism tab = dmapM go
+checkTypes :: forall r. (Member (Error CoreError) r) => Bool -> Module -> Node -> Sem r Node
+checkTypes allowPolymorphism md = dmapM go
where
go :: Node -> Sem r Node
go node = case node of
NIdt Ident {..}
- | isDynamic (lookupIdentifierInfo tab _identSymbol ^. identifierType) ->
+ | isDynamic (lookupIdentifierInfo md _identSymbol ^. identifierType) ->
throw (dynamicTypeError node (getInfoLocation _identInfo))
NLam Lambda {..}
| isDynamic (_lambdaBinder ^. binderType) ->
@@ -113,7 +114,7 @@ checkTypes allowPolymorphism tab = dmapM go
| any (isDynamic . (^. letItemBinder . binderType)) _letRecValues ->
throw (dynamicTypeError node (head _letRecValues ^. letItemBinder . binderLocation))
NPi Pi {..}
- | not allowPolymorphism && isTypeConstr tab (_piBinder ^. binderType) ->
+ | not allowPolymorphism && isTypeConstr md (_piBinder ^. binderType) ->
throw
CoreError
{ _coreErrorMsg = ppOutput "polymorphism not supported for this target",
@@ -122,9 +123,9 @@ checkTypes allowPolymorphism tab = dmapM go
}
_ -> return node
-checkNoRecursiveTypes :: forall r. (Member (Error CoreError) r) => InfoTable -> Sem r ()
-checkNoRecursiveTypes tab =
- when (isCyclic (createTypeDependencyInfo tab)) $
+checkNoRecursiveTypes :: forall r. (Member (Error CoreError) r) => Module -> Sem r ()
+checkNoRecursiveTypes md =
+ when (isCyclic (createTypeDependencyInfo (md ^. moduleInfoTable))) $
throw
CoreError
{ _coreErrorMsg = ppOutput "recursive types not supported for this target",
@@ -132,9 +133,9 @@ checkNoRecursiveTypes tab =
_coreErrorLoc = defaultLoc
}
-checkMainExists :: forall r. (Member (Error CoreError) r) => InfoTable -> Sem r ()
-checkMainExists tab =
- when (isNothing (tab ^. infoMain)) $
+checkMainExists :: forall r. (Member (Error CoreError) r) => Module -> Sem r ()
+checkMainExists md =
+ when (isNothing (md ^. moduleInfoTable . infoMain)) $
throw
CoreError
{ _coreErrorMsg = ppOutput "no `main` function",
diff --git a/src/Juvix/Compiler/Core/Transformation/Check/Exec.hs b/src/Juvix/Compiler/Core/Transformation/Check/Exec.hs
index f05e40483c..1ac2859742 100644
--- a/src/Juvix/Compiler/Core/Transformation/Check/Exec.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Check/Exec.hs
@@ -6,10 +6,10 @@ import Juvix.Compiler.Core.Transformation.Base
import Juvix.Compiler.Core.Transformation.Check.Base
import Juvix.Data.PPOutput
-checkExec :: forall r. (Member (Error CoreError) r) => InfoTable -> Sem r InfoTable
-checkExec tab = do
- checkNoAxioms tab
- case tab ^. infoMain of
+checkExec :: forall r. (Member (Error CoreError) r) => Module -> Sem r Module
+checkExec md = do
+ checkNoAxioms md
+ case md ^. moduleInfoTable . infoMain of
Nothing ->
throw
CoreError
@@ -27,7 +27,7 @@ checkExec tab = do
_coreErrorLoc = loc
}
ty
- | isTypeConstr tab ty ->
+ | isTypeConstr md ty ->
throw
CoreError
{ _coreErrorMsg = ppOutput "`main` cannot be a type for this target",
@@ -35,7 +35,7 @@ checkExec tab = do
_coreErrorLoc = loc
}
_ ->
- return tab
+ return md
where
- ii = lookupIdentifierInfo tab sym
+ ii = lookupIdentifierInfo md sym
loc = fromMaybe defaultLoc (ii ^. identifierLocation)
diff --git a/src/Juvix/Compiler/Core/Transformation/Check/Geb.hs b/src/Juvix/Compiler/Core/Transformation/Check/Geb.hs
index 4e391dce1c..9bb423b1cb 100644
--- a/src/Juvix/Compiler/Core/Transformation/Check/Geb.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Check/Geb.hs
@@ -4,11 +4,11 @@ import Juvix.Compiler.Core.Error
import Juvix.Compiler.Core.Transformation.Base
import Juvix.Compiler.Core.Transformation.Check.Base
-checkGeb :: forall r. (Member (Error CoreError) r) => InfoTable -> Sem r InfoTable
-checkGeb tab =
- checkMainExists tab
- >> checkNoRecursiveTypes tab
- >> checkNoAxioms tab
- >> mapAllNodesM checkNoIO tab
- >> mapAllNodesM (checkBuiltins False) tab
- >> mapAllNodesM (checkTypes False tab) tab
+checkGeb :: forall r. (Member (Error CoreError) r) => Module -> Sem r Module
+checkGeb md =
+ checkMainExists md
+ >> checkNoRecursiveTypes md
+ >> checkNoAxioms md
+ >> mapAllNodesM checkNoIO md
+ >> mapAllNodesM (checkBuiltins False) md
+ >> mapAllNodesM (checkTypes False md) md
diff --git a/src/Juvix/Compiler/Core/Transformation/Check/VampIR.hs b/src/Juvix/Compiler/Core/Transformation/Check/VampIR.hs
index 2006845bc6..8261c789cf 100644
--- a/src/Juvix/Compiler/Core/Transformation/Check/VampIR.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Check/VampIR.hs
@@ -6,14 +6,14 @@ import Juvix.Compiler.Core.Transformation.Base
import Juvix.Compiler.Core.Transformation.Check.Base
import Juvix.Data.PPOutput
-checkVampIR :: forall r. (Member (Error CoreError) r) => InfoTable -> Sem r InfoTable
-checkVampIR tab =
- checkMainExists tab
+checkVampIR :: forall r. (Member (Error CoreError) r) => Module -> Sem r Module
+checkVampIR md =
+ checkMainExists md
>> checkMainType
>> checkPublicInputs
- >> checkNoAxioms tab
- >> mapAllNodesM checkNoIO tab
- >> mapAllNodesM (checkBuiltins True) tab
+ >> checkNoAxioms md
+ >> mapAllNodesM checkNoIO md
+ >> mapAllNodesM (checkBuiltins True) md
where
checkMainType :: Sem r ()
checkMainType =
@@ -25,7 +25,7 @@ checkVampIR tab =
_coreErrorNode = Nothing
}
where
- ii = lookupIdentifierInfo tab (fromJust (tab ^. infoMain))
+ ii = lookupIdentifierInfo md (fromJust (getInfoMain md))
checkType :: Node -> Bool
checkType ty =
@@ -45,5 +45,5 @@ checkVampIR tab =
_coreErrorNode = Nothing
}
where
- ii = lookupIdentifierInfo tab (fromJust (tab ^. infoMain))
+ ii = lookupIdentifierInfo md (fromJust (getInfoMain md))
argnames = map (fromMaybe "") (ii ^. identifierArgNames)
diff --git a/src/Juvix/Compiler/Core/Transformation/CombineInfoTables.hs b/src/Juvix/Compiler/Core/Transformation/CombineInfoTables.hs
new file mode 100644
index 0000000000..7736df2b4a
--- /dev/null
+++ b/src/Juvix/Compiler/Core/Transformation/CombineInfoTables.hs
@@ -0,0 +1,10 @@
+module Juvix.Compiler.Core.Transformation.CombineInfoTables where
+
+import Juvix.Compiler.Core.Transformation.Base
+
+combineInfoTables :: Module -> Module
+combineInfoTables md =
+ md
+ { _moduleInfoTable = computeCombinedInfoTable md,
+ _moduleImportsTable = mempty
+ }
diff --git a/src/Juvix/Compiler/Core/Transformation/ComputeTypeInfo.hs b/src/Juvix/Compiler/Core/Transformation/ComputeTypeInfo.hs
index 768903e77a..1726d280ea 100644
--- a/src/Juvix/Compiler/Core/Transformation/ComputeTypeInfo.hs
+++ b/src/Juvix/Compiler/Core/Transformation/ComputeTypeInfo.hs
@@ -5,8 +5,8 @@ import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Info.TypeInfo qualified as Info
import Juvix.Compiler.Core.Transformation.Base
-computeNodeType :: InfoTable -> Node -> Type
-computeNodeType tab = Info.getNodeType . computeNodeTypeInfo tab
+computeNodeType :: Module -> Node -> Type
+computeNodeType md = Info.getNodeType . computeNodeTypeInfo md
-- | Computes the TypeInfo for each subnode of a well-typed node.
--
@@ -17,8 +17,8 @@ computeNodeType tab = Info.getNodeType . computeNodeTypeInfo tab
-- 3. All cases have at least one branch.
-- 4. No `Match` nodes.
-- 5. All inductives and function types are in universe 0.
-computeNodeTypeInfo :: InfoTable -> Node -> Node
-computeNodeTypeInfo tab = umapL go
+computeNodeTypeInfo :: Module -> Node -> Node
+computeNodeTypeInfo md = umapL go
where
go :: BinderList Binder -> Node -> Node
go bl node = Info.setNodeType (nodeType bl node) node
@@ -28,7 +28,7 @@ computeNodeTypeInfo tab = umapL go
NVar Var {..} ->
shift (_varIndex + 1) (BL.lookup _varIndex bl ^. binderType)
NIdt Ident {..} ->
- lookupIdentifierInfo tab _identSymbol ^. identifierType
+ lookupIdentifierInfo md _identSymbol ^. identifierType
NCst Constant {..} ->
case _constantValue of
ConstInteger {} -> mkTypeInteger'
@@ -60,8 +60,8 @@ computeNodeTypeInfo tab = umapL go
_ -> error "incorrect trace builtin application"
OpFail -> Info.getNodeType node
NCtr Constr {..} ->
- let ci = lookupConstructorInfo tab _constrTag
- ii = lookupInductiveInfo tab (ci ^. constructorInductive)
+ let ci = lookupConstructorInfo md _constrTag
+ ii = lookupInductiveInfo md (ci ^. constructorInductive)
in case ii ^. inductiveBuiltin of
Just (BuiltinTypeInductive BuiltinBool) ->
mkTypeBool'
@@ -96,5 +96,5 @@ computeNodeTypeInfo tab = umapL go
Closure {} ->
impossible
-computeTypeInfo :: InfoTable -> InfoTable
-computeTypeInfo tab = mapT (const (computeNodeTypeInfo tab)) tab
+computeTypeInfo :: Module -> Module
+computeTypeInfo md = mapT (const (computeNodeTypeInfo md)) md
diff --git a/src/Juvix/Compiler/Core/Transformation/ConvertBuiltinTypes.hs b/src/Juvix/Compiler/Core/Transformation/ConvertBuiltinTypes.hs
index 58b947f5b2..67847765e9 100644
--- a/src/Juvix/Compiler/Core/Transformation/ConvertBuiltinTypes.hs
+++ b/src/Juvix/Compiler/Core/Transformation/ConvertBuiltinTypes.hs
@@ -7,8 +7,8 @@ where
import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Transformation.Base
-convertNode :: InfoTable -> Node -> Node
-convertNode tab = umap go
+convertNode :: Module -> Node -> Node
+convertNode md = umap go
where
go :: Node -> Node
go node = case node of
@@ -20,9 +20,9 @@ convertNode tab = umap go
Just (BuiltinTypeAxiom BuiltinString) -> mkTypeString'
_ -> node
where
- ii = fromJust $ tab ^. infoInductives . at _typeConstrSymbol
+ ii = lookupInductiveInfo md _typeConstrSymbol
_ -> node
-convertBuiltinTypes :: InfoTable -> InfoTable
-convertBuiltinTypes tab =
- mapAllNodes (convertNode tab) tab
+convertBuiltinTypes :: Module -> Module
+convertBuiltinTypes md =
+ mapAllNodes (convertNode md) md
diff --git a/src/Juvix/Compiler/Core/Transformation/DisambiguateNames.hs b/src/Juvix/Compiler/Core/Transformation/DisambiguateNames.hs
index 4ddbfba077..98feeb1dfa 100644
--- a/src/Juvix/Compiler/Core/Transformation/DisambiguateNames.hs
+++ b/src/Juvix/Compiler/Core/Transformation/DisambiguateNames.hs
@@ -7,15 +7,15 @@ import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Info.NameInfo (setInfoName)
import Juvix.Compiler.Core.Transformation.Base
-disambiguateNodeNames' :: (BinderList Binder -> Text -> Text) -> InfoTable -> Node -> Node
-disambiguateNodeNames' disambiguate tab = dmapL go
+disambiguateNodeNames' :: (BinderList Binder -> Text -> Text) -> Module -> Node -> Node
+disambiguateNodeNames' disambiguate md = dmapL go
where
go :: BinderList Binder -> Node -> Node
go bl node = case node of
NVar Var {..} ->
mkVar (setInfoName (BL.lookup _varIndex bl ^. binderName) _varInfo) _varIndex
NIdt Ident {..} ->
- mkIdent (setInfoName (identName tab _identSymbol) _identInfo) _identSymbol
+ mkIdent (setInfoName (identName md _identSymbol) _identInfo) _identSymbol
NLam lam ->
NLam (over lambdaBinder (over binderName (disambiguate bl)) lam)
NLet lt ->
@@ -39,7 +39,7 @@ disambiguateNodeNames' disambiguate tab = dmapL go
NMatch m ->
NMatch (over matchBranches (map (over matchBranchPatterns (NonEmpty.fromList . snd . disambiguatePatterns bl . toList))) m)
NTyp TypeConstr {..} ->
- mkTypeConstr (setInfoName (typeName tab _typeConstrSymbol) _typeConstrInfo) _typeConstrSymbol _typeConstrArgs
+ mkTypeConstr (setInfoName (typeName md _typeConstrSymbol) _typeConstrInfo) _typeConstrSymbol _typeConstrArgs
NPi pi
| varOccurs 0 (pi ^. piBody) ->
NPi (over piBinder (over binderName (disambiguate bl)) pi)
@@ -66,8 +66,8 @@ disambiguateNodeNames' disambiguate tab = dmapL go
(bl', args') = disambiguatePatterns (BL.cons b' bl) (c ^. patternConstrArgs)
pat' = PatConstr $ set patternConstrBinder b' $ set patternConstrArgs args' c
-disambiguateNodeNames :: InfoTable -> Node -> Node
-disambiguateNodeNames tab = disambiguateNodeNames' disambiguate tab
+disambiguateNodeNames :: Module -> Node -> Node
+disambiguateNodeNames md = disambiguateNodeNames' disambiguate md
where
disambiguate :: BinderList Binder -> Text -> Text
disambiguate bl name =
@@ -81,20 +81,23 @@ disambiguateNodeNames tab = disambiguateNodeNames' disambiguate tab
name
names :: HashSet Text
- names = identNames tab
+ names = identNames md
-setArgNames :: InfoTable -> Symbol -> Node -> Node
-setArgNames tab sym node = reLambdas lhs' body
+setArgNames :: Module -> Symbol -> Node -> Node
+setArgNames md sym node = reLambdas lhs' body
where
(lhs, body) = unfoldLambdas node
- ii = lookupIdentifierInfo tab sym
+ ii = lookupIdentifierInfo md sym
lhs' =
zipWith
(\l mn -> over lambdaLhsBinder (over binderName (`fromMaybe` mn)) l)
lhs
(ii ^. identifierArgNames ++ repeat Nothing)
-disambiguateNames :: InfoTable -> InfoTable
-disambiguateNames tab =
- let tab' = mapT (setArgNames tab) tab
- in mapAllNodes (disambiguateNodeNames tab') tab'
+disambiguateNames :: Module -> Module
+disambiguateNames md =
+ let md' = mapT (setArgNames md) md
+ in mapAllNodes (disambiguateNodeNames md') md'
+
+disambiguateNames' :: InfoTable -> InfoTable
+disambiguateNames' = withInfoTable disambiguateNames
diff --git a/src/Juvix/Compiler/Core/Transformation/Eta.hs b/src/Juvix/Compiler/Core/Transformation/Eta.hs
index 3cbfc25d7c..e767d3c019 100644
--- a/src/Juvix/Compiler/Core/Transformation/Eta.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Eta.hs
@@ -47,8 +47,8 @@ etaExpandTypeConstrs getArgtys = umap go
argtys = getArgtys _typeConstrSymbol
_ -> n
-etaExpandApps :: InfoTable -> Node -> Node
-etaExpandApps tab =
+etaExpandApps :: Module -> Node -> Node
+etaExpandApps md =
squashApps
. etaExpandTypeConstrs typeConstrArgtys
. etaExpandConstrs constrArgtys
@@ -57,15 +57,15 @@ etaExpandApps tab =
where
constrArgtys :: Tag -> [Type]
constrArgtys tag =
- case lookupConstructorInfo' tab tag of
+ case lookupConstructorInfo' md tag of
Just ci -> typeArgs (ci ^. constructorType)
Nothing -> []
typeConstrArgtys :: Symbol -> [Type]
typeConstrArgtys sym =
- case lookupInductiveInfo' tab sym of
+ case lookupInductiveInfo' md sym of
Just ci -> map (^. paramKind) (ci ^. inductiveParams)
Nothing -> []
-etaExpansionApps :: InfoTable -> InfoTable
-etaExpansionApps tab = mapAllNodes (etaExpandApps tab) tab
+etaExpansionApps :: Module -> Module
+etaExpansionApps md = mapAllNodes (etaExpandApps md) md
diff --git a/src/Juvix/Compiler/Core/Transformation/FoldTypeSynonyms.hs b/src/Juvix/Compiler/Core/Transformation/FoldTypeSynonyms.hs
index b8c5369f72..91cef064ca 100644
--- a/src/Juvix/Compiler/Core/Transformation/FoldTypeSynonyms.hs
+++ b/src/Juvix/Compiler/Core/Transformation/FoldTypeSynonyms.hs
@@ -1,28 +1,27 @@
module Juvix.Compiler.Core.Transformation.FoldTypeSynonyms where
-import Data.HashMap.Strict qualified as HashMap
import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Transformation.Base
-convertNode :: InfoTable -> Node -> Node
-convertNode tab = rmap go
+convertNode :: Module -> Node -> Node
+convertNode md = rmap go
where
go :: ([BinderChange] -> Node -> Node) -> Node -> Node
go recur = \case
NIdt Ident {..}
- | isTypeConstr tab (ii ^. identifierType) ->
- go recur $ fromJust $ HashMap.lookup _identSymbol (tab ^. identContext)
+ | isTypeConstr md (ii ^. identifierType) ->
+ go recur $ lookupIdentifierNode md _identSymbol
where
- ii = fromJust $ HashMap.lookup _identSymbol (tab ^. infoIdentifiers)
+ ii = lookupIdentifierInfo md _identSymbol
NLet Let {..}
- | isTypeConstr tab (_letItem ^. letItemBinder . binderType) ->
+ | isTypeConstr md (_letItem ^. letItemBinder . binderType) ->
go (recur . (mkBCRemove (_letItem ^. letItemBinder) val' :)) _letBody
where
val' = go recur (_letItem ^. letItemValue)
node ->
recur [] node
-foldTypeSynonyms :: InfoTable -> InfoTable
-foldTypeSynonyms tab =
+foldTypeSynonyms :: Module -> Module
+foldTypeSynonyms md =
filterOutTypeSynonyms $
- mapAllNodes (convertNode tab) tab
+ mapAllNodes (convertNode md) md
diff --git a/src/Juvix/Compiler/Core/Transformation/Identity.hs b/src/Juvix/Compiler/Core/Transformation/Identity.hs
index cad242848c..40d6f1c426 100644
--- a/src/Juvix/Compiler/Core/Transformation/Identity.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Identity.hs
@@ -7,5 +7,5 @@ where
import Juvix.Compiler.Core.Pretty
import Juvix.Compiler.Core.Transformation.Base
-identity :: InfoTable -> InfoTable
+identity :: Module -> Module
identity = run . mapT' (const return)
diff --git a/src/Juvix/Compiler/Core/Transformation/IntToPrimInt.hs b/src/Juvix/Compiler/Core/Transformation/IntToPrimInt.hs
index 7f99bf58c4..cf519281d1 100644
--- a/src/Juvix/Compiler/Core/Transformation/IntToPrimInt.hs
+++ b/src/Juvix/Compiler/Core/Transformation/IntToPrimInt.hs
@@ -9,30 +9,32 @@ data BuiltinIntCtor
= BuiltinIntCtorOfNat
| BuiltinIntCtorNegSuc
-convertNode :: InfoTable -> Node -> Node
-convertNode tab = rmap go
+convertNode :: Module -> Node -> Node
+convertNode md = rmap go
where
+ intToInt = getInfoLiteralIntToInt md
+
go :: ([BinderChange] -> Node -> Node) -> Node -> Node
go recur node = case node of
NApp (App _ (NIdt (Ident {..})) l)
- | Just _identSymbol == tab ^. infoLiteralIntToInt -> go recur l
+ | Just _identSymbol == intToInt -> go recur l
NApp (App _ (NApp (App _ (NIdt (Ident {..})) l)) r) ->
recur [] $ convertIdentApp node (\g -> g _identInfo l r) _identSymbol
NApp (App _ (NIdt (Ident {..})) l) ->
recur [] $ convertSingleArgIdentApp node l _identInfo _identSymbol
NIdt (Ident {..})
- | Just _identSymbol == tab ^. infoLiteralIntToInt ->
+ | Just _identSymbol == intToInt ->
mkLambda' mkTypeInteger' (mkVar' 0)
NIdt (Ident {..}) ->
recur [] $ convertSingleArgIdent node _identInfo _identSymbol
NCtr (Constr {..}) ->
- let ci = lookupConstructorInfo tab _constrTag
+ let ci = lookupConstructorInfo md _constrTag
in case ci ^. constructorBuiltin of
Just BuiltinIntOfNat -> recur [] (fromJust (headMay _constrArgs))
Just BuiltinIntNegSuc -> recur [] (negSucConv (fromJust (headMay _constrArgs)))
_ -> recur [] node
NCase (Case {..}) ->
- let ii = lookupInductiveInfo tab _caseInductive
+ let ii = lookupInductiveInfo md _caseInductive
in case ii ^. inductiveBuiltin of
Just (BuiltinTypeInductive BuiltinInt) ->
case _caseBranches of
@@ -47,7 +49,7 @@ convertNode tab = rmap go
where
makeIf' :: CaseBranch -> Node -> Node
makeIf' caseBranch defaultNode =
- let boolSym = lookupConstructorInfo tab (BuiltinTag TagTrue) ^. constructorInductive
+ let boolSym = lookupConstructorInfo md (BuiltinTag TagTrue) ^. constructorInductive
cv = go recur _caseValue
binder = fromJust (headMay (caseBranch ^. caseBranchBinders))
binder' = over binderType (go recur) binder
@@ -70,7 +72,7 @@ convertNode tab = rmap go
makeIf :: CaseBranch -> CaseBranch -> Node
makeIf ofNatBranch negSucBranch =
- let boolSym = lookupConstructorInfo tab (BuiltinTag TagTrue) ^. constructorInductive
+ let boolSym = lookupConstructorInfo md (BuiltinTag TagTrue) ^. constructorInductive
cv = go recur _caseValue
binder :: CaseBranch -> Binder
binder br = fromJust (headMay (br ^. caseBranchBinders))
@@ -85,7 +87,7 @@ convertNode tab = rmap go
builtinCtor :: CaseBranch -> BuiltinIntCtor
builtinCtor CaseBranch {..} =
- let ci = lookupConstructorInfo tab _caseBranchTag
+ let ci = lookupConstructorInfo md _caseBranchTag
in case ci ^. constructorBuiltin of
Just BuiltinIntOfNat -> BuiltinIntCtorOfNat
Just BuiltinIntNegSuc -> BuiltinIntCtorNegSuc
@@ -98,7 +100,7 @@ convertNode tab = rmap go
Just (BuiltinTypeInductive BuiltinInt) -> mkTypeInteger'
_ -> recur [] node
where
- ii = fromJust $ tab ^. infoInductives . at _typeConstrSymbol
+ ii = lookupInductiveInfo md _typeConstrSymbol
_ -> recur [] node
-- Transforms n to -(n+1)
@@ -112,7 +114,7 @@ convertNode tab = rmap go
convertIdentApp :: Node -> ((Info -> Node -> Node -> Node) -> Node) -> Symbol -> Node
convertIdentApp node f sym =
- let ii = lookupIdentifierInfo tab sym
+ let ii = lookupIdentifierInfo md sym
in case ii ^. identifierBuiltin of
Just BuiltinIntEq -> f (\info x y -> mkBuiltinApp info OpEq [x, y])
Just BuiltinIntPlus -> f (\info x y -> mkBuiltinApp info OpIntAdd [x, y])
@@ -127,7 +129,7 @@ convertNode tab = rmap go
convertSingleArgIdentApp :: Node -> Node -> Info -> Symbol -> Node
convertSingleArgIdentApp node l info sym =
- let ii = lookupIdentifierInfo tab sym
+ let ii = lookupIdentifierInfo md sym
negNode = negNatBody info l
in case ii ^. identifierBuiltin of
Just BuiltinIntNegNat -> negNode
@@ -145,7 +147,7 @@ convertNode tab = rmap go
convertSingleArgIdent :: Node -> Info -> Symbol -> Node
convertSingleArgIdent node info sym =
- let ii = lookupIdentifierInfo tab sym
+ let ii = lookupIdentifierInfo md sym
negNode = mkLambda' mkTypeInteger' $ negNatBody info (mkVar' 0)
in case ii ^. identifierBuiltin of
Just BuiltinIntNegNat -> negNode
@@ -163,26 +165,12 @@ convertNode tab = rmap go
negNatBody :: Info -> Node -> Node
negNatBody info n = mkBuiltinApp info OpIntSub [mkConstant' (ConstInteger 0), n]
-filterIntBuiltins :: InfoTable -> InfoTable
-filterIntBuiltins tab =
- let tab' =
- over
- infoIdentifiers
- (HashMap.filter (isNotIntBuiltin . (^. identifierBuiltin)))
- tab
- in pruneInfoTable tab'
- where
- isNotIntBuiltin :: Maybe BuiltinFunction -> Bool
- isNotIntBuiltin = \case
- Just b -> not (isIntBuiltin b)
- Nothing -> True
-
-intToPrimInt :: InfoTable -> InfoTable
-intToPrimInt tab = filterIntBuiltins $ mapAllNodes (convertNode tab') tab'
+intToPrimInt :: Module -> Module
+intToPrimInt md = mapAllNodes (convertNode md') md'
where
- tab' =
- case tab ^. infoLiteralIntToInt of
+ md' =
+ case md ^. moduleInfoTable . infoLiteralIntToInt of
Just sym ->
- tab {_identContext = HashMap.insert sym (mkLambda' mkTypeInteger' (mkVar' 0)) (tab ^. identContext)}
+ over (moduleInfoTable . identContext) (HashMap.insert sym (mkLambda' mkTypeInteger' (mkVar' 0))) md
Nothing ->
- tab
+ md
diff --git a/src/Juvix/Compiler/Core/Transformation/LambdaLetRecLifting.hs b/src/Juvix/Compiler/Core/Transformation/LambdaLetRecLifting.hs
index 635e4717a1..ab783ff03a 100644
--- a/src/Juvix/Compiler/Core/Transformation/LambdaLetRecLifting.hs
+++ b/src/Juvix/Compiler/Core/Transformation/LambdaLetRecLifting.hs
@@ -28,7 +28,7 @@ lambdaLiftNode aboveBl top =
in goTop aboveBl body topArgs
where
nodeType :: Node -> Sem r Type
- nodeType n = flip computeNodeType n <$> getInfoTable
+ nodeType n = flip computeNodeType n <$> getModule
goTop :: BinderList Binder -> Node -> [LambdaLhs] -> Sem r Node
goTop bl body = \case
@@ -182,13 +182,13 @@ lambdaLiftNode aboveBl top =
res = shiftHelper body' (nonEmpty' (zipExact letItems letRecBinders'))
return (Recur res)
-lifting :: Bool -> InfoTable -> InfoTable
+lifting :: Bool -> Module -> Module
lifting onlyLetRec = run . runReader onlyLetRec . mapT' (const (lambdaLiftNode mempty))
-lambdaLetRecLifting :: InfoTable -> InfoTable
+lambdaLetRecLifting :: Module -> Module
lambdaLetRecLifting = lifting False
-letRecLifting :: InfoTable -> InfoTable
+letRecLifting :: Module -> Module
letRecLifting = lifting True
nodeIsLifted :: Node -> Bool
diff --git a/src/Juvix/Compiler/Core/Transformation/LetHoisting.hs b/src/Juvix/Compiler/Core/Transformation/LetHoisting.hs
index 711384e63f..2e301ef493 100644
--- a/src/Juvix/Compiler/Core/Transformation/LetHoisting.hs
+++ b/src/Juvix/Compiler/Core/Transformation/LetHoisting.hs
@@ -34,7 +34,7 @@ type LetsTable = HashMap Symbol (Indexed LItem)
mkLetsTable :: [Indexed LItem] -> LetsTable
mkLetsTable l = HashMap.fromList [(i ^. indexedThing . itemSymbol, i) | i <- l]
-letHoisting :: InfoTable -> InfoTable
+letHoisting :: Module -> Module
letHoisting = run . mapT' (const letHoist)
letHoist :: forall r. (Members '[InfoTableBuilder] r) => Node -> Sem r Node
diff --git a/src/Juvix/Compiler/Core/Transformation/MatchToCase.hs b/src/Juvix/Compiler/Core/Transformation/MatchToCase.hs
index 914d8b4ecb..3915d3d38d 100644
--- a/src/Juvix/Compiler/Core/Transformation/MatchToCase.hs
+++ b/src/Juvix/Compiler/Core/Transformation/MatchToCase.hs
@@ -28,12 +28,12 @@ type PatternMatrix = [PatternRow]
-- | Compiles pattern matches (`Match` nodes) to decision trees built up from
-- `Case` nodes. The algorithm is based on the paper: Luc Maranget, "Compiling
-- Pattern Matching to Good Decision Trees", ML'08.
-matchToCase :: (Members '[Error CoreError, Reader CoreOptions] r) => InfoTable -> Sem r InfoTable
-matchToCase tab = runReader tab $ mapAllNodesM (rmapM goMatchToCase) tab
+matchToCase :: (Members '[Error CoreError, Reader CoreOptions] r) => Module -> Sem r Module
+matchToCase md = runReader md $ mapAllNodesM (rmapM goMatchToCase) md
goMatchToCase ::
forall r.
- (Members '[Error CoreError, Reader CoreOptions, Reader InfoTable] r) =>
+ (Members '[Error CoreError, Reader CoreOptions, Reader Module] r) =>
([BinderChange] -> Node -> Sem r Node) ->
Node ->
Sem r Node
@@ -177,10 +177,10 @@ goMatchToCase recur node = case node of
_ : pats ->
getPatTags pats
- missingTag :: InfoTable -> Symbol -> HashSet Tag -> Tag
- missingTag tab ind tags = fromJust $ find (not . flip HashSet.member tags) (ii ^. inductiveConstructors)
+ missingTag :: Module -> Symbol -> HashSet Tag -> Tag
+ missingTag md ind tags = fromJust $ find (not . flip HashSet.member tags) (ii ^. inductiveConstructors)
where
- ii = lookupInductiveInfo tab ind
+ ii = lookupInductiveInfo md ind
compileMatchingRow :: Level -> [Level] -> PatternRow -> Sem r Node
compileMatchingRow bindersNum vs PatternRow {..} =
diff --git a/src/Juvix/Compiler/Core/Transformation/MoveApps.hs b/src/Juvix/Compiler/Core/Transformation/MoveApps.hs
index aa4ce30365..cee8e5b305 100644
--- a/src/Juvix/Compiler/Core/Transformation/MoveApps.hs
+++ b/src/Juvix/Compiler/Core/Transformation/MoveApps.hs
@@ -52,5 +52,5 @@ convertNode = dmap go
_ -> node
_ -> node
-moveApps :: InfoTable -> InfoTable
-moveApps tab = mapT (const convertNode) tab
+moveApps :: Module -> Module
+moveApps = mapT (const convertNode)
diff --git a/src/Juvix/Compiler/Core/Transformation/NaiveMatchToCase.hs b/src/Juvix/Compiler/Core/Transformation/NaiveMatchToCase.hs
index c434caafb3..dba1c0fcec 100644
--- a/src/Juvix/Compiler/Core/Transformation/NaiveMatchToCase.hs
+++ b/src/Juvix/Compiler/Core/Transformation/NaiveMatchToCase.hs
@@ -7,7 +7,7 @@ import Juvix.Compiler.Core.Language
import Juvix.Compiler.Core.Transformation.Base
import Juvix.Compiler.Core.Transformation.NaiveMatchToCase.Data
-matchToCase :: InfoTable -> InfoTable
+matchToCase :: Module -> Module
matchToCase = run . mapT' (const (umapM matchToCaseNode))
mkShiftedPis' :: [Type] -> Type -> Type
diff --git a/src/Juvix/Compiler/Core/Transformation/NatToPrimInt.hs b/src/Juvix/Compiler/Core/Transformation/NatToPrimInt.hs
index 9d46ef429b..083a0722f8 100644
--- a/src/Juvix/Compiler/Core/Transformation/NatToPrimInt.hs
+++ b/src/Juvix/Compiler/Core/Transformation/NatToPrimInt.hs
@@ -7,13 +7,15 @@ import Juvix.Compiler.Core.Info qualified as Info
import Juvix.Compiler.Core.Info.NameInfo
import Juvix.Compiler.Core.Transformation.Base
-convertNode :: InfoTable -> Node -> Node
-convertNode tab = rmap go
+convertNode :: Module -> Node -> Node
+convertNode md = rmap go
where
+ intToNat = getInfoLiteralIntToNat md
+
go :: ([BinderChange] -> Node -> Node) -> Node -> Node
go recur node = case node of
NApp (App _ (NIdt (Ident {..})) l)
- | Just _identSymbol == tab ^. infoLiteralIntToNat ->
+ | Just _identSymbol == intToNat ->
go recur l
NApp (App _ (NApp (App _ (NIdt (Ident {..})) l)) r) ->
recur [] $ convertIdentApp node (\g -> g _identInfo l r) _identSymbol
@@ -28,7 +30,7 @@ convertNode tab = rmap go
)
_identSymbol
NIdt (Ident {..})
- | Just _identSymbol == tab ^. infoLiteralIntToNat ->
+ | Just _identSymbol == intToNat ->
mkLambda' mkTypeInteger' (mkVar' 0)
NIdt (Ident {..}) ->
recur [] $
@@ -41,7 +43,7 @@ convertNode tab = rmap go
)
_identSymbol
NCtr (Constr {..}) ->
- let ci = lookupConstructorInfo tab _constrTag
+ let ci = lookupConstructorInfo md _constrTag
in case ci ^. constructorBuiltin of
Just BuiltinNatZero ->
mkConstant _constrInfo (ConstInteger 0)
@@ -49,7 +51,7 @@ convertNode tab = rmap go
recur [] $ mkBuiltinApp _constrInfo OpIntAdd (_constrArgs ++ [mkConstant' (ConstInteger 1)])
_ -> recur [] node
NCase (Case {..}) ->
- let ii = lookupInductiveInfo tab _caseInductive
+ let ii = lookupInductiveInfo md _caseInductive
in case ii ^. inductiveBuiltin of
Just (BuiltinTypeInductive BuiltinNat) ->
case _caseBranches of
@@ -68,7 +70,7 @@ convertNode tab = rmap go
where
makeIf :: CaseBranch -> Node -> Node
makeIf CaseBranch {..} br =
- let ci = lookupConstructorInfo tab (BuiltinTag TagTrue)
+ let ci = lookupConstructorInfo md (BuiltinTag TagTrue)
sym = ci ^. constructorInductive
in case _caseBranchBindersNum of
0 ->
@@ -94,12 +96,12 @@ convertNode tab = rmap go
Just (BuiltinTypeInductive BuiltinNat) -> mkTypeInteger'
_ -> recur [] node
where
- ii = fromJust $ tab ^. infoInductives . at _typeConstrSymbol
+ ii = lookupInductiveInfo md _typeConstrSymbol
_ -> recur [] node
convertIdentApp :: Node -> ((Info -> Node -> Node -> Node) -> Node) -> Symbol -> Node
convertIdentApp node f sym =
- let ii = lookupIdentifierInfo tab sym
+ let ii = lookupIdentifierInfo md sym
in case ii ^. identifierBuiltin of
Just BuiltinNatPlus -> f (\info x y -> mkBuiltinApp info OpIntAdd [x, y])
Just BuiltinNatSub ->
@@ -114,7 +116,7 @@ convertNode tab = rmap go
)
where
boolSymbol =
- lookupConstructorInfo tab (BuiltinTag TagTrue) ^. constructorInductive
+ lookupConstructorInfo md (BuiltinTag TagTrue) ^. constructorInductive
Just BuiltinNatMul -> f (\info x y -> mkBuiltinApp info OpIntMul [x, y])
Just BuiltinNatUDiv ->
f
@@ -128,26 +130,12 @@ convertNode tab = rmap go
Just BuiltinNatEq -> f (\info x y -> mkBuiltinApp info OpEq [x, y])
_ -> node
-filterNatBuiltins :: InfoTable -> InfoTable
-filterNatBuiltins tab =
- let tab' =
- over
- infoIdentifiers
- (HashMap.filter (isNotNatBuiltin . (^. identifierBuiltin)))
- tab
- in pruneInfoTable tab'
- where
- isNotNatBuiltin :: Maybe BuiltinFunction -> Bool
- isNotNatBuiltin = \case
- Just b -> not (isNatBuiltin b)
- Nothing -> True
-
-natToPrimInt :: InfoTable -> InfoTable
-natToPrimInt tab = filterNatBuiltins $ mapAllNodes (convertNode tab') tab'
+natToPrimInt :: Module -> Module
+natToPrimInt md = mapAllNodes (convertNode md') md'
where
- tab' =
- case tab ^. infoLiteralIntToNat of
+ md' =
+ case md ^. moduleInfoTable . infoLiteralIntToNat of
Just sym ->
- tab {_identContext = HashMap.insert sym (mkLambda' mkTypeInteger' (mkVar' 0)) (tab ^. identContext)}
+ over (moduleInfoTable . identContext) (HashMap.insert sym (mkLambda' mkTypeInteger' (mkVar' 0))) md
Nothing ->
- tab
+ md
diff --git a/src/Juvix/Compiler/Core/Transformation/Normalize.hs b/src/Juvix/Compiler/Core/Transformation/Normalize.hs
index 1c855a4381..a33586966b 100644
--- a/src/Juvix/Compiler/Core/Transformation/Normalize.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Normalize.hs
@@ -4,12 +4,12 @@ import Data.HashMap.Strict qualified as HashMap
import Juvix.Compiler.Core.Normalizer qualified as Normalizer
import Juvix.Compiler.Core.Transformation.Base
-normalize :: InfoTable -> InfoTable
-normalize tab =
+normalize :: Module -> Module
+normalize md =
pruneInfoTable $
- set identContext (HashMap.singleton sym node) $
- set infoIdentifiers (HashMap.singleton sym ii) tab
+ set (moduleInfoTable . identContext) (HashMap.singleton sym node) $
+ set (moduleInfoTable . infoIdentifiers) (HashMap.singleton sym ii) md
where
- sym = fromJust $ tab ^. infoMain
- node = Normalizer.normalize tab (lookupIdentifierNode tab sym)
- ii = lookupIdentifierInfo tab sym
+ sym = fromJust $ getInfoMain md
+ node = Normalizer.normalize md (lookupIdentifierNode md sym)
+ ii = lookupIdentifierInfo md sym
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/CaseCallLifting.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/CaseCallLifting.hs
index 7166607cc8..abf2944b5a 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/CaseCallLifting.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/CaseCallLifting.hs
@@ -5,15 +5,15 @@ import Data.List qualified as List
import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Transformation.Base
-convertNode :: InfoTable -> Node -> Node
-convertNode tab = umap go
+convertNode :: Module -> Node -> Node
+convertNode md = umap go
where
go :: Node -> Node
go = \case
NCase Case {..}
| not (null idents) ->
if
- | isCaseBoolean _caseBranches && not (isImmediate tab _caseValue) ->
+ | isCaseBoolean _caseBranches && not (isImmediate md _caseValue) ->
mkLet'
mkTypeBool'
_caseValue
@@ -47,7 +47,7 @@ convertNode tab = umap go
dargs0 = fmap (fromJust . gatherAppArgs sym) def
appArgs = computeArgs args0 dargs0
app = mkApps' (mkIdent' sym) appArgs
- (tyargs, tgt) = unfoldPi' (lookupIdentifierInfo tab sym ^. identifierType)
+ (tyargs, tgt) = unfoldPi' (lookupIdentifierInfo md sym ^. identifierType)
tyargs' = drop (length appArgs) tyargs
ty = substs appArgs (mkPis' tyargs' tgt)
brs' = map (\br -> over caseBranchBody (substApps sym (mkVar' (br ^. caseBranchBindersNum + idx))) br) brs
@@ -76,7 +76,7 @@ convertNode tab = umap go
let (h, args) = unfoldApps' node
in case h of
NIdt Ident {..}
- | length args == lookupIdentifierInfo tab _identSymbol ^. identifierArgsNum ->
+ | length args == lookupIdentifierInfo md _identSymbol ^. identifierArgsNum ->
HashSet.insert _identSymbol acc
_ -> acc
_ -> acc
@@ -84,7 +84,7 @@ convertNode tab = umap go
countApps :: Symbol -> Node -> Int
countApps sym = sgather go' 0
where
- argsNum = lookupIdentifierInfo tab sym ^. identifierArgsNum
+ argsNum = lookupIdentifierInfo md sym ^. identifierArgsNum
go' :: Int -> Node -> Int
go' acc node = case node of
@@ -101,7 +101,7 @@ convertNode tab = umap go
gatherAppArgs :: Symbol -> Node -> Maybe [Node]
gatherAppArgs sym = sgather go' Nothing
where
- argsNum = lookupIdentifierInfo tab sym ^. identifierArgsNum
+ argsNum = lookupIdentifierInfo md sym ^. identifierArgsNum
go' :: Maybe [Node] -> Node -> Maybe [Node]
go' acc node = case node of
@@ -118,7 +118,7 @@ convertNode tab = umap go
substApps :: Symbol -> Node -> Node -> Node
substApps sym snode = sumap go'
where
- argsNum = lookupIdentifierInfo tab sym ^. identifierArgsNum
+ argsNum = lookupIdentifierInfo md sym ^. identifierArgsNum
go' :: Node -> Node
go' node = case node of
@@ -132,5 +132,5 @@ convertNode tab = umap go
_ -> node
_ -> node
-caseCallLifting :: InfoTable -> InfoTable
-caseCallLifting tab = mapAllNodes (convertNode tab) tab
+caseCallLifting :: Module -> Module
+caseCallLifting md = mapAllNodes (convertNode md) md
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/CaseFolding.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/CaseFolding.hs
index bc3e0813e9..d3987f46e3 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/CaseFolding.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/CaseFolding.hs
@@ -28,5 +28,5 @@ convertNode = dmap go
_ ->
impossible
-caseFolding :: InfoTable -> InfoTable
+caseFolding :: Module -> Module
caseFolding = mapAllNodes convertNode
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/CasePermutation.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/CasePermutation.hs
index e961ff7b43..b93d6d5756 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/CasePermutation.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/CasePermutation.hs
@@ -5,8 +5,8 @@ import Data.HashSet qualified as HashSet
import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Transformation.Base
-isConstructorTree :: InfoTable -> Case -> Node -> Bool
-isConstructorTree tab c node = case run $ runFail $ go mempty node of
+isConstructorTree :: Module -> Case -> Node -> Bool
+isConstructorTree md c node = case run $ runFail $ go mempty node of
Just ctrsMap ->
all (checkOne ctrsMap) tags && checkDefault ctrsMap (c ^. caseDefault)
Nothing -> False
@@ -18,13 +18,13 @@ isConstructorTree tab c node = case run $ runFail $ go mempty node of
checkOne ctrsMap tag = case HashMap.lookup tag ctrsMap of
Just 1 -> True
Nothing -> True
- _ -> isImmediate tab (fromJust $ HashMap.lookup tag tagMap)
+ _ -> isImmediate md (fromJust $ HashMap.lookup tag tagMap)
checkDefault :: HashMap Tag Int -> Maybe Node -> Bool
checkDefault ctrsMap = \case
Just d ->
sum (HashMap.filterWithKey (\k _ -> not (HashSet.member k tags')) ctrsMap) <= 1
- || isImmediate tab d
+ || isImmediate md d
where
tags' = HashSet.fromList tags
Nothing -> True
@@ -39,14 +39,14 @@ isConstructorTree tab c node = case run $ runFail $ go mempty node of
_ ->
fail
-convertNode :: InfoTable -> Node -> Node
-convertNode tab = dmap go
+convertNode :: Module -> Node -> Node
+convertNode md = dmap go
where
go :: Node -> Node
go node = case node of
NCase c@Case {..} -> case _caseValue of
NCase c'
- | isConstructorTree tab c _caseValue ->
+ | isConstructorTree md c _caseValue ->
NCase
c'
{ _caseBranches = map permuteBranch (c' ^. caseBranches),
@@ -66,5 +66,5 @@ convertNode tab = dmap go
node
_ -> node
-casePermutation :: InfoTable -> InfoTable
-casePermutation tab = mapAllNodes (convertNode tab) tab
+casePermutation :: Module -> Module
+casePermutation md = mapAllNodes (convertNode md) md
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/CaseValueInlining.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/CaseValueInlining.hs
index 00aa04c14a..89dd926d30 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/CaseValueInlining.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/CaseValueInlining.hs
@@ -3,19 +3,19 @@ module Juvix.Compiler.Core.Transformation.Optimize.CaseValueInlining where
import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Transformation.Base
-convertNode :: InfoTable -> Node -> Node
-convertNode tab = dmap go
+convertNode :: Module -> Node -> Node
+convertNode md = dmap go
where
go :: Node -> Node
go node = case node of
NCase cs@Case {..} -> case _caseValue of
NIdt Ident {..}
- | Just InlineCase <- lookupIdentifierInfo tab _identSymbol ^. identifierPragmas . pragmasInline ->
- NCase cs {_caseValue = lookupIdentifierNode tab _identSymbol}
+ | Just InlineCase <- lookupIdentifierInfo md _identSymbol ^. identifierPragmas . pragmasInline ->
+ NCase cs {_caseValue = lookupIdentifierNode md _identSymbol}
_ ->
node
_ ->
node
-caseValueInlining :: InfoTable -> InfoTable
-caseValueInlining tab = mapAllNodes (convertNode tab) tab
+caseValueInlining :: Module -> Module
+caseValueInlining md = mapAllNodes (convertNode md) md
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/ConstantFolding.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/ConstantFolding.hs
index 4700318e00..f05751127d 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/ConstantFolding.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/ConstantFolding.hs
@@ -7,8 +7,8 @@ import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Info.FreeVarsInfo as Info
import Juvix.Compiler.Core.Transformation.Base
-convertNode :: HashSet Symbol -> InfoTable -> Node -> Node
-convertNode nonRecSyms tab = umap go
+convertNode :: HashSet Symbol -> InfoTable -> Module -> Node -> Node
+convertNode nonRecSyms tab md = umap go
where
go :: Node -> Node
go node = case node of
@@ -27,14 +27,14 @@ convertNode nonRecSyms tab = umap go
&& evalAllowed
&& length args == ii ^. identifierArgsNum
&& length tyargs == ii ^. identifierArgsNum
- && isZeroOrderType tab tgt'
+ && isZeroOrderType md tgt'
&& all isNonRecValue args ->
doEval' node
where
- ii = lookupIdentifierInfo tab _identSymbol
+ ii = lookupIdentifierInfo md _identSymbol
evalAllowed = maybe True (^. pragmaEval) (ii ^. identifierPragmas . pragmasEval)
(tyargs, tgt) = unfoldPi' (ii ^. identifierType)
- n = length (takeWhile (isTypeConstr tab) tyargs)
+ n = length (takeWhile (isTypeConstr md) tyargs)
tys = reverse (take n args)
tgt' = substs tys (shift (-(length tyargs - n)) tgt)
_ -> node
@@ -62,14 +62,16 @@ convertNode nonRecSyms tab = umap go
_evalOptionsSilent = True
}
-constantFolding' :: HashSet Symbol -> InfoTable -> InfoTable
-constantFolding' nonRecSyms tab =
+constantFolding' :: HashSet Symbol -> InfoTable -> Module -> Module
+constantFolding' nonRecSyms tab md =
mapAllNodes
( removeInfo kFreeVarsInfo
- . convertNode nonRecSyms tab
+ . convertNode nonRecSyms tab md
. computeFreeVarsInfo
)
- tab
+ md
-constantFolding :: InfoTable -> InfoTable
-constantFolding tab = constantFolding' (nonRecursiveIdents tab) tab
+constantFolding :: Module -> Module
+constantFolding md = constantFolding' (nonRecursiveIdents' tab) tab md
+ where
+ tab = computeCombinedInfoTable md
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/FilterUnreachable.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/FilterUnreachable.hs
index c9a2d1e4f9..6eac6c0764 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/FilterUnreachable.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/FilterUnreachable.hs
@@ -4,13 +4,13 @@ import Data.HashMap.Strict qualified as HashMap
import Juvix.Compiler.Core.Data.IdentDependencyInfo
import Juvix.Compiler.Core.Transformation.Base
-filterUnreachable :: InfoTable -> InfoTable
-filterUnreachable tab =
+filterUnreachable :: Module -> Module
+filterUnreachable md =
pruneInfoTable $
- over infoInductives goFilter $
- over infoIdentifiers goFilter tab
+ over (moduleInfoTable . infoInductives) goFilter $
+ over (moduleInfoTable . infoIdentifiers) goFilter md
where
- depInfo = createSymbolDependencyInfo tab
+ depInfo = createSymbolDependencyInfo (md ^. moduleInfoTable)
goFilter :: HashMap Symbol a -> HashMap Symbol a
goFilter =
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/Inlining.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/Inlining.hs
index b6f5329673..266a025bfb 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/Inlining.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/Inlining.hs
@@ -7,17 +7,17 @@ import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Options
import Juvix.Compiler.Core.Transformation.Base
-isInlineableLambda :: Int -> InfoTable -> BinderList Binder -> Node -> Bool
-isInlineableLambda inlineDepth tab bl node = case node of
+isInlineableLambda :: Int -> Module -> BinderList Binder -> Node -> Bool
+isInlineableLambda inlineDepth md bl node = case node of
NLam {} ->
let (lams, body) = unfoldLambdas node
binders = map (^. lambdaLhsBinder) lams
- in checkDepth tab (BL.prependRev binders bl) inlineDepth body
+ in checkDepth md (BL.prependRev binders bl) inlineDepth body
_ ->
False
-convertNode :: Int -> HashSet Symbol -> InfoTable -> Node -> Node
-convertNode inlineDepth recSyms tab = dmapL go
+convertNode :: Int -> HashSet Symbol -> Module -> Node -> Node
+convertNode inlineDepth recSyms md = dmapL go
where
go :: BinderList Binder -> Node -> Node
go bl node = case node of
@@ -38,16 +38,16 @@ convertNode inlineDepth recSyms tab = dmapL go
node
_
| not (HashSet.member _identSymbol recSyms)
- && isInlineableLambda inlineDepth tab bl def
+ && isInlineableLambda inlineDepth md bl def
&& length args >= argsNum ->
mkApps def args
_ ->
node
where
- ii = lookupIdentifierInfo tab _identSymbol
+ ii = lookupIdentifierInfo md _identSymbol
pi = ii ^. identifierPragmas . pragmasInline
argsNum = ii ^. identifierArgsNum
- def = lookupIdentifierNode tab _identSymbol
+ def = lookupIdentifierNode md _identSymbol
_ ->
node
NIdt Ident {..} ->
@@ -57,10 +57,10 @@ convertNode inlineDepth recSyms tab = dmapL go
Just InlineAlways -> def
_ -> node
where
- ii = lookupIdentifierInfo tab _identSymbol
+ ii = lookupIdentifierInfo md _identSymbol
pi = ii ^. identifierPragmas . pragmasInline
argsNum = ii ^. identifierArgsNum
- def = lookupIdentifierNode tab _identSymbol
+ def = lookupIdentifierNode md _identSymbol
-- inline zero-argument definitions (automatically) if inlining would result
-- in case reduction
NCase cs@Case {..} ->
@@ -72,23 +72,23 @@ convertNode inlineDepth recSyms tab = dmapL go
Nothing
| not (HashSet.member _identSymbol recSyms)
&& isConstructorApp def
- && checkDepth tab bl inlineDepth def ->
+ && checkDepth md bl inlineDepth def ->
NCase cs {_caseValue = mkApps def args}
_ ->
node
where
- ii = lookupIdentifierInfo tab _identSymbol
+ ii = lookupIdentifierInfo md _identSymbol
pi = ii ^. identifierPragmas . pragmasInline
- def = lookupIdentifierNode tab _identSymbol
+ def = lookupIdentifierNode md _identSymbol
_ ->
node
_ ->
node
-inlining' :: Int -> HashSet Symbol -> InfoTable -> InfoTable
-inlining' inliningDepth recSyms tab = mapT (const (convertNode inliningDepth recSyms tab)) tab
+inlining' :: Int -> HashSet Symbol -> Module -> Module
+inlining' inliningDepth recSyms md = mapT (const (convertNode inliningDepth recSyms md)) md
-inlining :: (Member (Reader CoreOptions) r) => InfoTable -> Sem r InfoTable
-inlining tab = do
+inlining :: (Member (Reader CoreOptions) r) => Module -> Sem r Module
+inlining md = do
d <- asks (^. optInliningDepth)
- return $ inlining' d (recursiveIdents tab) tab
+ return $ inlining' d (recursiveIdents md) md
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/LambdaFolding.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/LambdaFolding.hs
index 2878ac1a03..5f6c973181 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/LambdaFolding.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/LambdaFolding.hs
@@ -41,5 +41,5 @@ convertNode = rmap go
_ ->
recur [] node
-lambdaFolding :: InfoTable -> InfoTable
+lambdaFolding :: Module -> Module
lambdaFolding = mapAllNodes convertNode
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/LetFolding.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/LetFolding.hs
index d75155f788..ac3171b93f 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/LetFolding.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/LetFolding.hs
@@ -17,15 +17,15 @@ import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Info.FreeVarsInfo as Info
import Juvix.Compiler.Core.Transformation.Base
-convertNode :: (InfoTable -> BinderList Binder -> Node -> Bool) -> InfoTable -> Node -> Node
-convertNode isFoldable tab = rmapL go
+convertNode :: (Module -> BinderList Binder -> Node -> Bool) -> Module -> Node -> Node
+convertNode isFoldable md = rmapL go
where
go :: ([BinderChange] -> Node -> Node) -> BinderList Binder -> Node -> Node
go recur bl = \case
NLet Let {..}
- | isImmediate tab (_letItem ^. letItemValue)
+ | isImmediate md (_letItem ^. letItemValue)
|| Info.freeVarOccurrences 0 _letBody <= 1
- || isFoldable tab bl (_letItem ^. letItemValue) ->
+ || isFoldable md bl (_letItem ^. letItemValue) ->
go (recur . (mkBCRemove b val' :)) (BL.cons b bl) _letBody
where
val' = go recur bl (_letItem ^. letItemValue)
@@ -33,7 +33,7 @@ convertNode isFoldable tab = rmapL go
node ->
recur [] node
-letFolding' :: (InfoTable -> BinderList Binder -> Node -> Bool) -> InfoTable -> InfoTable
+letFolding' :: (Module -> BinderList Binder -> Node -> Bool) -> Module -> Module
letFolding' isFoldable tab =
mapAllNodes
( removeInfo kFreeVarsInfo
@@ -42,5 +42,5 @@ letFolding' isFoldable tab =
)
tab
-letFolding :: InfoTable -> InfoTable
+letFolding :: Module -> Module
letFolding = letFolding' (\_ _ _ -> False)
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/MandatoryInlining.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/MandatoryInlining.hs
index cd15fb73a2..61868c31a5 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/MandatoryInlining.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/MandatoryInlining.hs
@@ -3,22 +3,22 @@ module Juvix.Compiler.Core.Transformation.Optimize.MandatoryInlining where
import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Transformation.Base
-convertNode :: InfoTable -> Node -> Node
-convertNode tab = dmap go
+convertNode :: Module -> Node -> Node
+convertNode md = dmap go
where
go :: Node -> Node
go node = case node of
NIdt Ident {..}
- | Just InlineAlways <- lookupIdentifierInfo tab _identSymbol ^. identifierPragmas . pragmasInline ->
- lookupIdentifierNode tab _identSymbol
+ | Just InlineAlways <- lookupIdentifierInfo md _identSymbol ^. identifierPragmas . pragmasInline ->
+ lookupIdentifierNode md _identSymbol
NCase cs@Case {..} -> case _caseValue of
NIdt Ident {..}
- | Just InlineCase <- lookupIdentifierInfo tab _identSymbol ^. identifierPragmas . pragmasInline ->
- NCase cs {_caseValue = lookupIdentifierNode tab _identSymbol}
+ | Just InlineCase <- lookupIdentifierInfo md _identSymbol ^. identifierPragmas . pragmasInline ->
+ NCase cs {_caseValue = lookupIdentifierNode md _identSymbol}
_ ->
node
_ ->
node
-mandatoryInlining :: InfoTable -> InfoTable
-mandatoryInlining tab = mapAllNodes (convertNode tab) tab
+mandatoryInlining :: Module -> Module
+mandatoryInlining md = mapAllNodes (convertNode md) md
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/Eval.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/Eval.hs
index e793ff91ed..7859581515 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/Eval.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/Eval.hs
@@ -7,7 +7,7 @@ import Juvix.Compiler.Core.Transformation.Optimize.LambdaFolding
import Juvix.Compiler.Core.Transformation.Optimize.LetFolding
import Juvix.Compiler.Core.Transformation.Optimize.MandatoryInlining
-optimize :: InfoTable -> Sem r InfoTable
+optimize :: Module -> Sem r Module
optimize =
return
. letFolding
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/Exec.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/Exec.hs
index 20bd8ecd5a..2d6bcdc22b 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/Exec.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/Exec.hs
@@ -7,7 +7,7 @@ import Juvix.Compiler.Core.Transformation.Optimize.LetFolding
import Juvix.Compiler.Core.Transformation.Optimize.Phase.Main qualified as Main
import Juvix.Compiler.Core.Transformation.TopEtaExpand
-optimize :: (Member (Reader CoreOptions) r) => InfoTable -> Sem r InfoTable
+optimize :: (Member (Reader CoreOptions) r) => Module -> Sem r Module
optimize tab = do
opts <- ask
withOptimizationLevel' tab 1 $
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/Geb.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/Geb.hs
index 946c11a102..9846dd3586 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/Geb.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/Geb.hs
@@ -4,5 +4,5 @@ import Juvix.Compiler.Core.Options
import Juvix.Compiler.Core.Transformation.Base
import Juvix.Compiler.Core.Transformation.Optimize.Phase.Main qualified as Main
-optimize :: (Member (Reader CoreOptions) r) => InfoTable -> Sem r InfoTable
+optimize :: (Member (Reader CoreOptions) r) => Module -> Sem r Module
optimize = withOptimizationLevel 1 Main.optimize
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/Main.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/Main.hs
index 6df1a612bd..172babf0af 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/Main.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/Main.hs
@@ -15,8 +15,8 @@ import Juvix.Compiler.Core.Transformation.Optimize.SimplifyComparisons
import Juvix.Compiler.Core.Transformation.Optimize.SimplifyIfs
import Juvix.Compiler.Core.Transformation.Optimize.SpecializeArgs
-optimize' :: CoreOptions -> InfoTable -> InfoTable
-optimize' CoreOptions {..} tab =
+optimize' :: CoreOptions -> Module -> Module
+optimize' CoreOptions {..} md =
filterUnreachable
. compose
(4 * _optOptimizationLevel)
@@ -28,31 +28,34 @@ optimize' CoreOptions {..} tab =
)
. doConstantFolding
. letFolding
- $ tab
+ $ md
where
+ tab :: InfoTable
+ tab = computeCombinedInfoTable md
+
recs :: HashSet Symbol
- recs = recursiveIdents tab
+ recs = recursiveIdents' tab
nonRecs :: HashSet Symbol
- nonRecs = nonRecursiveIdents tab
+ nonRecs = nonRecursiveIdents' tab
- doConstantFolding :: InfoTable -> InfoTable
- doConstantFolding tab' = constantFolding' nonRecs' tab'
+ doConstantFolding :: Module -> Module
+ doConstantFolding md' = constantFolding' nonRecs' tab' md'
where
- nonRecs' =
- if
- | _optOptimizationLevel > 1 -> nonRecursiveIdents tab'
- | otherwise -> nonRecs
+ tab' = computeCombinedInfoTable md'
+ nonRecs'
+ | _optOptimizationLevel > 1 = nonRecursiveIdents' tab'
+ | otherwise = nonRecs
- doInlining :: InfoTable -> InfoTable
- doInlining tab' = inlining' _optInliningDepth recs' tab'
+ doInlining :: Module -> Module
+ doInlining md' = inlining' _optInliningDepth recs' md'
where
recs' =
if
- | _optOptimizationLevel > 1 -> recursiveIdents tab'
+ | _optOptimizationLevel > 1 -> recursiveIdents md'
| otherwise -> recs
- doSimplification :: Int -> InfoTable -> InfoTable
+ doSimplification :: Int -> Module -> Module
doSimplification n =
simplifyArithmetic
. simplifyIfs' (_optOptimizationLevel <= 1)
@@ -62,7 +65,7 @@ optimize' CoreOptions {..} tab =
. compose n (letFolding' (isInlineableLambda _optInliningDepth))
. lambdaFolding
-optimize :: (Member (Reader CoreOptions) r) => InfoTable -> Sem r InfoTable
+optimize :: (Member (Reader CoreOptions) r) => Module -> Sem r Module
optimize tab = do
opts <- ask
return $ optimize' opts tab
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/VampIR.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/VampIR.hs
index c706142a76..e86dff0fae 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/VampIR.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/Phase/VampIR.hs
@@ -7,7 +7,7 @@ import Juvix.Compiler.Core.Transformation.Optimize.LambdaFolding
import Juvix.Compiler.Core.Transformation.Optimize.LetFolding
import Juvix.Compiler.Core.Transformation.Optimize.SimplifyIfs
-optimize :: (Member (Reader CoreOptions) r) => InfoTable -> Sem r InfoTable
+optimize :: (Member (Reader CoreOptions) r) => Module -> Sem r Module
optimize =
withOptimizationLevel 1 $
return . letFolding . simplifyIfs . caseCallLifting . letFolding . lambdaFolding
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/SimplifyArithmetic.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/SimplifyArithmetic.hs
index 30c923eee5..c1d4d79f46 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/SimplifyArithmetic.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/SimplifyArithmetic.hs
@@ -60,5 +60,5 @@ convertNode = dmap go
x
_ -> node
-simplifyArithmetic :: InfoTable -> InfoTable
+simplifyArithmetic :: Module -> Module
simplifyArithmetic = mapAllNodes convertNode
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/SimplifyComparisons.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/SimplifyComparisons.hs
index 78ca2d25e8..9b11ad6bbb 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/SimplifyComparisons.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/SimplifyComparisons.hs
@@ -3,10 +3,10 @@ module Juvix.Compiler.Core.Transformation.Optimize.SimplifyComparisons (simplify
import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Transformation.Base
-convertNode :: InfoTable -> Node -> Node
-convertNode tab = dmap go
+convertNode :: Module -> Node -> Node
+convertNode md = dmap go
where
- boolSym = lookupConstructorInfo tab (BuiltinTag TagTrue) ^. constructorInductive
+ boolSym = lookupConstructorInfo md (BuiltinTag TagTrue) ^. constructorInductive
go :: Node -> Node
go node = case node of
@@ -91,5 +91,5 @@ convertNode tab = dmap go
where
theIfs = mkIf' boolSym v b1 (mkIf' boolSym v' b1' b2')
-simplifyComparisons :: InfoTable -> InfoTable
-simplifyComparisons tab = mapAllNodes (convertNode tab) tab
+simplifyComparisons :: Module -> Module
+simplifyComparisons md = mapAllNodes (convertNode md) md
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/SimplifyIfs.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/SimplifyIfs.hs
index bb01f8c333..c5a531ef54 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/SimplifyIfs.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/SimplifyIfs.hs
@@ -3,10 +3,10 @@ module Juvix.Compiler.Core.Transformation.Optimize.SimplifyIfs (simplifyIfs, sim
import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Transformation.Base
-convertNode :: Bool -> InfoTable -> Node -> Node
-convertNode bFast tab = umap go
+convertNode :: Bool -> Module -> Node -> Node
+convertNode bFast md = umap go
where
- boolSym = lookupConstructorInfo tab (BuiltinTag TagTrue) ^. constructorInductive
+ boolSym = lookupConstructorInfo md (BuiltinTag TagTrue) ^. constructorInductive
go :: Node -> Node
go node = case node of
@@ -23,8 +23,8 @@ convertNode bFast tab = umap go
| not bFast && b1 == b2 = b1
| otherwise = mkIf' boolSym v b1 b2
-simplifyIfs' :: Bool -> InfoTable -> InfoTable
-simplifyIfs' bFast tab = mapAllNodes (convertNode bFast tab) tab
+simplifyIfs' :: Bool -> Module -> Module
+simplifyIfs' bFast md = mapAllNodes (convertNode bFast md) md
-simplifyIfs :: InfoTable -> InfoTable
+simplifyIfs :: Module -> Module
simplifyIfs = simplifyIfs' False
diff --git a/src/Juvix/Compiler/Core/Transformation/Optimize/SpecializeArgs.hs b/src/Juvix/Compiler/Core/Transformation/Optimize/SpecializeArgs.hs
index f5ce4c00a5..c3b5f9d795 100644
--- a/src/Juvix/Compiler/Core/Transformation/Optimize/SpecializeArgs.hs
+++ b/src/Juvix/Compiler/Core/Transformation/Optimize/SpecializeArgs.hs
@@ -9,29 +9,29 @@ import Juvix.Compiler.Core.Transformation.LambdaLetRecLifting (lambdaLiftNode')
-- | Check if an argument value is suitable for specialisation (e.g. not a
-- variable)
-isSpecializable :: InfoTable -> Node -> Bool
-isSpecializable tab node =
- isType tab mempty node
+isSpecializable :: Module -> Node -> Bool
+isSpecializable md node =
+ isType md mempty node
|| case node of
NIdt Ident {..} ->
- case lookupIdentifierInfo tab _identSymbol ^. identifierPragmas . pragmasSpecialise of
+ case lookupIdentifierInfo md _identSymbol ^. identifierPragmas . pragmasSpecialise of
Just (PragmaSpecialise False) -> False
_ -> True
NLam {} -> True
NCst {} -> True
- NCtr Constr {..} -> all (isSpecializable tab) _constrArgs
+ NCtr Constr {..} -> all (isSpecializable md) _constrArgs
NApp {} ->
let (h, _) = unfoldApps' node
- in isSpecializable tab h
+ in isSpecializable md h
_ -> False
-- | Check for `h a1 .. an` where `h` is an identifier explicitly marked for
-- specialisation with `specialize: true`.
-isMarkedSpecializable :: InfoTable -> Node -> Bool
-isMarkedSpecializable tab = \case
+isMarkedSpecializable :: Module -> Node -> Bool
+isMarkedSpecializable md = \case
NTyp TypeConstr {..}
| Just (PragmaSpecialise True) <-
- lookupInductiveInfo tab _typeConstrSymbol
+ lookupInductiveInfo md _typeConstrSymbol
^. inductivePragmas . pragmasSpecialise ->
True
node ->
@@ -39,14 +39,14 @@ isMarkedSpecializable tab = \case
in case h of
NIdt Ident {..}
| Just (PragmaSpecialise True) <-
- lookupIdentifierInfo tab _identSymbol
+ lookupIdentifierInfo md _identSymbol
^. identifierPragmas . pragmasSpecialise ->
True
_ ->
False
-- | Checks if an argument is passed without modification to recursive calls.
-isArgSpecializable :: InfoTable -> Symbol -> Int -> Bool
+isArgSpecializable :: Module -> Symbol -> Int -> Bool
isArgSpecializable tab sym argNum = run $ execState True $ dmapNRM go body
where
nodeSym = lookupIdentifierNode tab sym
@@ -94,20 +94,20 @@ convertNode = dmapLRM go
goIdentApp :: BinderList Binder -> Ident -> [Node] -> Sem r Recur
goIdentApp bl idt@Ident {..} args = do
args' <- mapM (dmapLRM' (bl, go)) args
- tab <- getInfoTable
- let ii = lookupIdentifierInfo tab _identSymbol
+ md <- getModule
+ let ii = lookupIdentifierInfo md _identSymbol
pspec = ii ^. identifierPragmas . pragmasSpecialiseArgs
pspecby = ii ^. identifierPragmas . pragmasSpecialiseBy
argsNum = ii ^. identifierArgsNum
(tyargs, tgt) = unfoldPi' (ii ^. identifierType)
- def = lookupIdentifierNode tab _identSymbol
+ def = lookupIdentifierNode md _identSymbol
(lams, body) = unfoldLambdas def
argnames = map (^. lambdaLhsBinder . binderName) lams
-- arguments marked for specialisation with `specialize: true`
psargs0 =
map fst3 $
- filter (\(_, arg, ty) -> isMarkedSpecializable tab arg || isMarkedSpecializable tab ty) $
+ filter (\(_, arg, ty) -> isMarkedSpecializable md arg || isMarkedSpecializable md ty) $
zip3 [1 .. argsNum] args' tyargs
getArgIndex :: PragmaSpecialiseArg -> Maybe Int
@@ -124,11 +124,11 @@ convertNode = dmapLRM go
filter
( \argNum ->
argNum <= argsNum
- && isSpecializable tab (args' !! (argNum - 1))
- && isArgSpecializable tab _identSymbol argNum
+ && isSpecializable md (args' !! (argNum - 1))
+ && isArgSpecializable md _identSymbol argNum
)
psargs
- tyargsNum = length (takeWhile (isTypeConstr tab) tyargs)
+ tyargsNum = length (takeWhile (isTypeConstr md) tyargs)
-- in addition to the arguments explicitly marked for
-- specialisation, also specialise all type arguments
specargs =
@@ -170,13 +170,13 @@ convertNode = dmapLRM go
eassert (length args' == argsNum)
eassert (argsNum <= length tyargs)
-- assumption: all type variables are at the front
- eassert (not $ any (isTypeConstr tab) (drop tyargsNum tyargs))
+ eassert (not $ any (isTypeConstr md) (drop tyargsNum tyargs))
-- the specialisation signature: the values we specialise the arguments by
let specSigArgs = selectSpecargs specargs args'
specSig = (specSigArgs, specargs)
if
| all isClosed specSigArgs ->
- case find ((== specSig) . (^. specSignature)) (lookupSpecialisationInfo tab _identSymbol) of
+ case find ((== specSig) . (^. specSignature)) (lookupSpecialisationInfo md _identSymbol) of
Just SpecialisationInfo {..} ->
return $
End $
@@ -336,5 +336,5 @@ convertNode = dmapLRM go
argNum = argsNum - argIdx
_ -> node
-specializeArgs :: InfoTable -> InfoTable
-specializeArgs tab = run $ mapT' (const convertNode) tab
+specializeArgs :: Module -> Module
+specializeArgs = run . mapT' (const convertNode)
diff --git a/src/Juvix/Compiler/Core/Transformation/RemoveTypeArgs.hs b/src/Juvix/Compiler/Core/Transformation/RemoveTypeArgs.hs
index 7dc220f3fe..ba8a39496f 100644
--- a/src/Juvix/Compiler/Core/Transformation/RemoveTypeArgs.hs
+++ b/src/Juvix/Compiler/Core/Transformation/RemoveTypeArgs.hs
@@ -9,8 +9,8 @@ import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Pretty
import Juvix.Compiler.Core.Transformation.Base
-convertNode :: InfoTable -> Node -> Node
-convertNode tab = convert mempty
+convertNode :: Module -> Node -> Node
+convertNode md = convert mempty
where
unsupported :: forall a. Node -> a
unsupported node = error ("remove type arguments: unsupported node\n\t" <> ppTrace node)
@@ -23,15 +23,15 @@ convertNode tab = convert mempty
NVar v@(Var {..}) ->
let ty = BL.lookup _varIndex vars ^. binderType
in if
- | isTypeConstr tab ty -> End (mkDynamic _varInfo)
+ | isTypeConstr md ty -> End (mkDynamic _varInfo)
| otherwise -> End (NVar (shiftVar (-k) v))
where
- k = length (filter (isTypeConstr tab . (^. binderType)) (take _varIndex (toList vars)))
+ k = length (filter (isTypeConstr md . (^. binderType)) (take _varIndex (toList vars)))
NIdt Ident {..} ->
- let fi = lookupIdentifierInfo tab _identSymbol
+ let fi = lookupIdentifierInfo md _identSymbol
in if
- | isTypeConstr tab (fi ^. identifierType) ->
- Recur (lookupIdentifierNode tab _identSymbol)
+ | isTypeConstr md (fi ^. identifierType) ->
+ Recur (lookupIdentifierNode md _identSymbol)
| otherwise ->
Recur node
NApp App {..} ->
@@ -41,19 +41,19 @@ convertNode tab = convert mempty
NVar (Var {..}) ->
BL.lookup _varIndex vars ^. binderType
NIdt (Ident {..}) ->
- let fi = lookupIdentifierInfo tab _identSymbol
+ let fi = lookupIdentifierInfo md _identSymbol
in fi ^. identifierType
_ -> unsupported node
args' = filterArgs snd ty args
in if
- | isTypeConstr tab ty ->
+ | isTypeConstr md ty ->
End (mkDynamic _appInfo)
| null args' ->
End (convert vars h)
| otherwise ->
End (mkApps (convert vars h) (map (second (convert vars)) args'))
NCtr (Constr {..}) ->
- let ci = lookupConstructorInfo tab _constrTag
+ let ci = lookupConstructorInfo md _constrTag
ty = ci ^. constructorType
args' = filterArgs id ty _constrArgs
in End (mkConstr _constrInfo _constrTag (map (convert vars) args'))
@@ -61,13 +61,13 @@ convertNode tab = convert mempty
End (mkCase _caseInfo _caseInductive (convert vars _caseValue) (map convertBranch _caseBranches) (fmap (convert vars) _caseDefault))
where
nParams :: Int
- nParams = maybe 0 (length . (^. inductiveParams)) (tab ^. infoInductives . at _caseInductive)
+ nParams = maybe 0 (length . (^. inductiveParams)) (lookupInductiveInfo' md _caseInductive)
convertBranch :: CaseBranch -> CaseBranch
convertBranch br@CaseBranch {..} =
let paramBinders = map (set binderType mkSmallUniv) (take nParams _caseBranchBinders)
argBinders = drop nParams _caseBranchBinders
- tyargs = drop nParams (typeArgs (fromJust (tab ^. infoConstructors . at _caseBranchTag) ^. constructorType))
- argBinders' = zipWith (\b ty -> if isDynamic (b ^. binderType) && isTypeConstr tab ty then set binderType ty b else b) argBinders (tyargs ++ repeat mkDynamic')
+ tyargs = drop nParams (typeArgs (lookupConstructorInfo md _caseBranchTag ^. constructorType))
+ argBinders' = zipWith (\b ty -> if isDynamic (b ^. binderType) && isTypeConstr md ty then set binderType ty b else b) argBinders (tyargs ++ repeat mkDynamic')
binders' =
filterBinders
(BL.prependRev paramBinders vars)
@@ -84,18 +84,18 @@ convertNode tab = convert mempty
filterBinders :: BinderList Binder -> [Binder] -> [Binder]
filterBinders _ [] = []
filterBinders vars' (b : bs)
- | isTypeConstr tab (b ^. binderType) =
+ | isTypeConstr md (b ^. binderType) =
filterBinders (BL.cons b vars') bs
filterBinders vars' (b : bs) =
over binderType (convert vars') b : filterBinders (BL.cons b vars') bs
NLam (Lambda {..})
- | isTypeConstr tab (_lambdaBinder ^. binderType) ->
+ | isTypeConstr md (_lambdaBinder ^. binderType) ->
End (convert (BL.cons _lambdaBinder vars) _lambdaBody)
NLet (Let {..})
- | isTypeConstr tab (_letItem ^. letItemBinder . binderType) ->
+ | isTypeConstr md (_letItem ^. letItemBinder . binderType) ->
End (convert (BL.cons (_letItem ^. letItemBinder) vars) _letBody)
NPi (Pi {..})
- | isTypeConstr tab (_piBinder ^. binderType) && not (isTypeConstr tab _piBody) ->
+ | isTypeConstr md (_piBinder ^. binderType) && not (isTypeConstr md _piBody) ->
End (convert (BL.cons _piBinder vars) _piBody)
_ -> Recur node
where
@@ -105,61 +105,61 @@ convertNode tab = convert mempty
let ty' = subst (getNode arg) _piBody
args'' = filterArgs getNode ty' args'
in if
- | isTypeConstr tab (_piBinder ^. binderType) ->
+ | isTypeConstr md (_piBinder ^. binderType) ->
args''
| otherwise ->
arg : args''
_ ->
args
-convertIdent :: InfoTable -> IdentifierInfo -> IdentifierInfo
-convertIdent tab ii =
+convertIdent :: Module -> IdentifierInfo -> IdentifierInfo
+convertIdent md ii =
ii
{ _identifierType = ty',
_identifierArgsNum = length tyargs',
_identifierArgNames = filterArgNames (ii ^. identifierType) (ii ^. identifierArgNames)
}
where
- ty' = convertNode tab (ii ^. identifierType)
+ ty' = convertNode md (ii ^. identifierType)
tyargs' = typeArgs ty'
filterArgNames :: Type -> [Maybe Text] -> [Maybe Text]
filterArgNames ty argnames = case (ty, argnames) of
(NPi Pi {..}, name : argnames')
- | isTypeConstr tab (_piBinder ^. binderType) ->
+ | isTypeConstr md (_piBinder ^. binderType) ->
filterArgNames _piBody argnames'
| otherwise ->
name : filterArgNames _piBody argnames'
_ ->
argnames
-convertConstructor :: InfoTable -> ConstructorInfo -> ConstructorInfo
-convertConstructor tab ci =
+convertConstructor :: Module -> ConstructorInfo -> ConstructorInfo
+convertConstructor md ci =
ci
{ _constructorType = ty',
_constructorArgsNum = length (typeArgs ty')
}
where
- ty' = convertNode tab (ci ^. constructorType)
+ ty' = convertNode md (ci ^. constructorType)
-convertInductive :: InfoTable -> InductiveInfo -> InductiveInfo
-convertInductive tab ii =
+convertInductive :: Module -> InductiveInfo -> InductiveInfo
+convertInductive md ii =
ii
{ _inductiveKind = ty',
- _inductiveParams = map (over paramKind (convertNode tab) . fst) $ filter (not . isTypeConstr tab . snd) (zipExact (ii ^. inductiveParams) tyargs)
+ _inductiveParams = map (over paramKind (convertNode md) . fst) $ filter (not . isTypeConstr md . snd) (zipExact (ii ^. inductiveParams) tyargs)
}
where
tyargs = typeArgs (ii ^. inductiveKind)
- ty' = convertNode tab (ii ^. inductiveKind)
+ ty' = convertNode md (ii ^. inductiveKind)
-convertAxiom :: InfoTable -> AxiomInfo -> AxiomInfo
-convertAxiom tab = over axiomType (convertNode tab)
+convertAxiom :: Module -> AxiomInfo -> AxiomInfo
+convertAxiom md = over axiomType (convertNode md)
-removeTypeArgs :: InfoTable -> InfoTable
-removeTypeArgs tab =
+removeTypeArgs :: Module -> Module
+removeTypeArgs md =
filterOutTypeSynonyms $
- mapAxioms (convertAxiom tab) $
- mapInductives (convertInductive tab) $
- mapConstructors (convertConstructor tab) $
- mapIdents (convertIdent tab) $
- mapT (const (convertNode tab)) tab
+ mapAxioms (convertAxiom md) $
+ mapInductives (convertInductive md) $
+ mapConstructors (convertConstructor md) $
+ mapIdents (convertIdent md) $
+ mapT (const (convertNode md)) md
diff --git a/src/Juvix/Compiler/Core/Transformation/TopEtaExpand.hs b/src/Juvix/Compiler/Core/Transformation/TopEtaExpand.hs
index e8c83fdf74..54ea9e2076 100644
--- a/src/Juvix/Compiler/Core/Transformation/TopEtaExpand.hs
+++ b/src/Juvix/Compiler/Core/Transformation/TopEtaExpand.hs
@@ -4,11 +4,11 @@ import Juvix.Compiler.Core.Data.InfoTableBuilder
import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Transformation.Base
-topEtaExpand :: InfoTable -> InfoTable
-topEtaExpand info = run (mapT' go info)
+topEtaExpand :: Module -> Module
+topEtaExpand md = run (mapT' go md)
where
go :: Symbol -> Node -> Sem '[InfoTableBuilder] Node
- go sym body = case info ^. infoIdentifiers . at sym of
+ go sym body = case lookupIdentifierInfo' md sym of
Nothing -> return body
Just idenInfo ->
let args :: [PiLhs]
diff --git a/src/Juvix/Compiler/Core/Transformation/UnrollRecursion.hs b/src/Juvix/Compiler/Core/Transformation/UnrollRecursion.hs
index 26a89b0d5b..075e5cb3ff 100644
--- a/src/Juvix/Compiler/Core/Transformation/UnrollRecursion.hs
+++ b/src/Juvix/Compiler/Core/Transformation/UnrollRecursion.hs
@@ -8,16 +8,16 @@ import Juvix.Compiler.Core.Info.TypeInfo (setNodeType)
import Juvix.Compiler.Core.Options
import Juvix.Compiler.Core.Transformation.Base
-unrollRecursion :: (Member (Reader CoreOptions) r) => InfoTable -> Sem r InfoTable
-unrollRecursion tab = do
- (mp, tab') <-
+unrollRecursion :: (Member (Reader CoreOptions) r) => Module -> Sem r Module
+unrollRecursion md = do
+ (mp, md') <-
runState @(HashMap Symbol Symbol) mempty $
- execInfoTableBuilder tab $
- forM_ (buildSCCs (createCallGraph tab)) goSCC
- return $ mapIdentSymbols mp $ pruneInfoTable tab'
+ execInfoTableBuilder md $
+ forM_ (buildSCCs (createCallGraph (md ^. moduleInfoTable))) goSCC
+ return $ mapIdentSymbols mp $ pruneInfoTable md'
where
- mapIdentSymbols :: HashMap Symbol Symbol -> InfoTable -> InfoTable
- mapIdentSymbols mp = over infoMain adjustMain . mapAllNodes (umap go)
+ mapIdentSymbols :: HashMap Symbol Symbol -> Module -> Module
+ mapIdentSymbols mp = over (moduleInfoTable . infoMain) adjustMain . mapAllNodes (umap go)
where
go :: Node -> Node
go = \case
@@ -51,7 +51,7 @@ unrollRecursion tab = do
go :: Symbol -> Maybe Int
go sym = fmap (^. pragmaUnrollDepth) (ii ^. identifierPragmas . pragmasUnroll)
where
- ii = lookupIdentifierInfo tab sym
+ ii = lookupIdentifierInfo md sym
mapSymbol :: Int -> HashMap (Indexed Symbol) Symbol -> Symbol -> HashMap Symbol Symbol -> HashMap Symbol Symbol
mapSymbol unrollLimit freshSyms sym = HashMap.insert sym (fromJust $ HashMap.lookup (Indexed unrollLimit sym) freshSyms)
@@ -73,7 +73,7 @@ unrollRecursion tab = do
forM_ [0 .. unrollLimit] goUnroll
removeSymbol sym
where
- ii = lookupIdentifierInfo tab sym
+ ii = lookupIdentifierInfo md sym
goUnroll :: Int -> Sem r ()
goUnroll limit = do
@@ -88,7 +88,7 @@ unrollRecursion tab = do
| limit == 0 =
etaExpand (typeArgs (ii ^. identifierType)) failNode
| otherwise =
- umap (go limit) (lookupIdentifierNode tab sym)
+ umap (go limit) (lookupIdentifierNode md sym)
registerIdentNode sym' node
go :: Int -> Node -> Node
diff --git a/src/Juvix/Compiler/Core/Translation/FromInternal.hs b/src/Juvix/Compiler/Core/Translation/FromInternal.hs
index 4afb79f3b8..85054051f0 100644
--- a/src/Juvix/Compiler/Core/Translation/FromInternal.hs
+++ b/src/Juvix/Compiler/Core/Translation/FromInternal.hs
@@ -19,12 +19,12 @@ import Juvix.Compiler.Internal.Pretty (ppTrace)
import Juvix.Compiler.Internal.Pretty qualified as Internal
import Juvix.Compiler.Internal.Translation.Extra qualified as Internal
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking qualified as InternalTyped
+import Juvix.Compiler.Store.Extra qualified as Store
+import Juvix.Compiler.Store.Language qualified as Store
import Juvix.Data.Loc qualified as Loc
import Juvix.Data.PPOutput
import Juvix.Extra.Strings qualified as Str
-type MVisit = Visit Internal.ModuleIndex
-
data PreInductiveDef = PreInductiveDef
{ _preInductiveInternal :: Internal.InductiveDef,
_preInductiveInfo :: InductiveInfo
@@ -43,69 +43,70 @@ data PreMutual = PreMutual
makeLenses ''PreMutual
-unsupported :: Text -> a
-unsupported thing = error ("Internal to Core: Not yet supported: " <> thing)
-
-- | Translation of a Name into the identifier index used in the Core InfoTable
mkIdentIndex :: Name -> Text
-mkIdentIndex = show . (^. Internal.nameId . Internal.unNameId)
+mkIdentIndex = show . (^. Internal.nameId)
-fromInternal :: (Member NameIdGen k) => Internal.InternalTypedResult -> Sem k CoreResult
+fromInternal :: (Members '[NameIdGen, Reader Store.ModuleTable] k) => Internal.InternalTypedResult -> Sem k CoreResult
fromInternal i = do
+ importTab <- asks Store.getInternalModuleTable
+ coreImportsTab <- asks Store.computeCombinedCoreInfoTable
+ let md =
+ Module
+ { _moduleId = i ^. InternalTyped.resultInternalModule . Internal.internalModuleId,
+ _moduleInfoTable = mempty,
+ _moduleImportsTable = coreImportsTab
+ }
res <-
- execInfoTableBuilder emptyInfoTable
+ execInfoTableBuilder md
. evalState (i ^. InternalTyped.resultFunctions)
. runReader (i ^. InternalTyped.resultIdenTypes)
- $ f
+ $ do
+ when
+ (isNothing (coreImportsTab ^. infoLiteralIntToNat))
+ reserveLiteralIntToNatSymbol
+ when
+ (isNothing (coreImportsTab ^. infoLiteralIntToInt))
+ reserveLiteralIntToIntSymbol
+ let resultModule = i ^. InternalTyped.resultModule
+ resultTable =
+ Internal.computeCombinedInfoTable importTab
+ <> i ^. InternalTyped.resultInternalModule . Internal.internalModuleInfoTable
+ runReader resultTable $
+ goModule resultModule
+ tab <- getModule
+ when
+ (isNothing (lookupBuiltinInductive tab BuiltinBool))
+ declareBoolBuiltins
+ when (isNothing (coreImportsTab ^. infoLiteralIntToNat)) $
+ setupLiteralIntToNat literalIntToNatNode
+ when (isNothing (coreImportsTab ^. infoLiteralIntToInt)) $
+ setupLiteralIntToInt literalIntToIntNode
return $
CoreResult
- { _coreResultTable = res,
+ { _coreResultModule = res,
_coreResultInternalTypedResult = i
}
- where
- f :: (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, State InternalTyped.FunctionsTable, NameIdGen] r) => Sem r ()
- f = do
- reserveLiteralIntToNatSymbol
- reserveLiteralIntToIntSymbol
- let resultModules = toList (i ^. InternalTyped.resultModules)
- runReader (Internal.buildTable resultModules)
- . evalVisitEmpty goModuleNoVisit
- $ mapM_ goModule resultModules
- tab <- getInfoTable
- when
- (isNothing (lookupBuiltinInductive tab BuiltinBool))
- declareBoolBuiltins
- setupLiteralIntToNat literalIntToNatNode
- setupLiteralIntToInt literalIntToIntNode
-
-fromInternalExpression :: (Member NameIdGen r) => CoreResult -> Internal.Expression -> Sem r Node
-fromInternalExpression res exp = do
- let modules = res ^. coreResultInternalTypedResult . InternalTyped.resultModules
+
+fromInternalExpression :: (Member NameIdGen r) => Internal.InternalModuleTable -> CoreResult -> Internal.Expression -> Sem r Node
+fromInternalExpression importTab res exp = do
+ let mtab =
+ res ^. coreResultInternalTypedResult . InternalTyped.resultInternalModule . Internal.internalModuleInfoTable
+ <> Internal.computeCombinedInfoTable importTab
fmap snd
- . runReader (Internal.buildTable modules)
- . runInfoTableBuilder (res ^. coreResultTable)
+ . runReader mtab
+ . runInfoTableBuilder (res ^. coreResultModule)
. evalState (res ^. coreResultInternalTypedResult . InternalTyped.resultFunctions)
. runReader (res ^. coreResultInternalTypedResult . InternalTyped.resultIdenTypes)
$ fromTopIndex (goExpression exp)
goModule ::
forall r.
- (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, MVisit] r) =>
+ (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, NameIdGen] r) =>
Internal.Module ->
Sem r ()
-goModule = visit . Internal.ModuleIndex
-
-goModuleNoVisit ::
- forall r.
- (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, NameIdGen, MVisit] r) =>
- Internal.ModuleIndex ->
- Sem r ()
-goModuleNoVisit (Internal.ModuleIndex m) = do
- mapM_ goImport (m ^. Internal.moduleBody . Internal.moduleImports)
+goModule m = do
mapM_ goMutualBlock (m ^. Internal.moduleBody . Internal.moduleStatements)
- where
- goImport :: Internal.Import -> Sem r ()
- goImport (Internal.Import i) = visit i
-- | predefine an inductive definition
preInductiveDef ::
@@ -715,7 +716,7 @@ fromPatternArg pa = case pa ^. Internal.patternArgName of
getPatternType :: Name -> Sem r Type
getPatternType n = do
- ty <- asks (fromJust . HashMap.lookup (n ^. nameId))
+ ty <- asks (fromJust . HashMap.lookup (n ^. nameId) . (^. InternalTyped.typesTable))
idt :: IndexTable <- get
runReader idt (goType ty)
@@ -846,15 +847,18 @@ goIden ::
Internal.Iden ->
Sem r Node
goIden i = do
- infoTableDebug <- Core.ppTrace <$> getInfoTable
+ importsTableDebug <- Core.ppTrace . (^. moduleImportsTable) <$> getModule
+ infoTableDebug <- Core.ppTrace . (^. moduleInfoTable) <$> getModule
let undeclared =
error
( "internal to core: undeclared identifier: "
<> txt
<> "\nat "
<> Internal.ppTrace (getLoc i)
- <> "\n"
+ <> "\nModule:\n-------\n\n"
<> infoTableDebug
+ <> "\nImports:\n--------\n\n"
+ <> importsTableDebug
)
case i of
Internal.IdenVar n -> do
@@ -924,8 +928,8 @@ goExpression ::
goExpression = \case
Internal.ExpressionLet l -> goLet l
Internal.ExpressionLiteral l -> do
- tab <- getInfoTable
- return (goLiteral (fromJust $ tab ^. infoLiteralIntToNat) (fromJust $ tab ^. infoLiteralIntToInt) l)
+ md <- getModule
+ return (goLiteral (fromJust $ getInfoLiteralIntToNat md) (fromJust $ getInfoLiteralIntToInt md) l)
Internal.ExpressionIden i -> goIden i
Internal.ExpressionApplication a -> goApplication a
Internal.ExpressionSimpleLambda l -> goSimpleLambda l
diff --git a/src/Juvix/Compiler/Core/Translation/FromInternal/Builtins/Int.hs b/src/Juvix/Compiler/Core/Translation/FromInternal/Builtins/Int.hs
index 01c974c798..073885d860 100644
--- a/src/Juvix/Compiler/Core/Translation/FromInternal/Builtins/Int.hs
+++ b/src/Juvix/Compiler/Core/Translation/FromInternal/Builtins/Int.hs
@@ -9,11 +9,11 @@ import Juvix.Compiler.Core.Language
-- integers to builtin Int.
literalIntToIntNode :: (Member InfoTableBuilder r) => Sem r Node
literalIntToIntNode = do
- tab <- getInfoTable
- let intToNatSymM = tab ^. infoLiteralIntToNat
- tagOfNatM = (^. constructorTag) <$> lookupBuiltinConstructor tab BuiltinIntOfNat
- tagNegSucM = (^. constructorTag) <$> lookupBuiltinConstructor tab BuiltinIntNegSuc
- boolSymM = (^. inductiveSymbol) <$> lookupBuiltinInductive tab BuiltinBool
+ md <- getModule
+ let intToNatSymM = getInfoLiteralIntToNat md
+ tagOfNatM = (^. constructorTag) <$> lookupBuiltinConstructor md BuiltinIntOfNat
+ tagNegSucM = (^. constructorTag) <$> lookupBuiltinConstructor md BuiltinIntNegSuc
+ boolSymM = (^. inductiveSymbol) <$> lookupBuiltinInductive md BuiltinBool
return $
case (tagOfNatM, tagNegSucM, boolSymM, intToNatSymM) of
(Just tagOfNat, Just tagNegSuc, Just boolSym, Just intToNatSym) ->
diff --git a/src/Juvix/Compiler/Core/Translation/FromInternal/Builtins/Nat.hs b/src/Juvix/Compiler/Core/Translation/FromInternal/Builtins/Nat.hs
index e82af0c5ce..1188bca214 100644
--- a/src/Juvix/Compiler/Core/Translation/FromInternal/Builtins/Nat.hs
+++ b/src/Juvix/Compiler/Core/Translation/FromInternal/Builtins/Nat.hs
@@ -10,10 +10,10 @@ import Juvix.Compiler.Core.Language
-- so that it can be called recusively.
literalIntToNatNode :: (Member InfoTableBuilder r) => Symbol -> Sem r Node
literalIntToNatNode sym = do
- tab <- getInfoTable
- let tagZeroM = (^. constructorTag) <$> lookupBuiltinConstructor tab BuiltinNatZero
- tagSucM = (^. constructorTag) <$> lookupBuiltinConstructor tab BuiltinNatSuc
- boolSymM = (^. inductiveSymbol) <$> lookupBuiltinInductive tab BuiltinBool
+ md <- getModule
+ let tagZeroM = (^. constructorTag) <$> lookupBuiltinConstructor md BuiltinNatZero
+ tagSucM = (^. constructorTag) <$> lookupBuiltinConstructor md BuiltinNatSuc
+ boolSymM = (^. inductiveSymbol) <$> lookupBuiltinInductive md BuiltinBool
return $ case (tagZeroM, tagSucM, boolSymM) of
(Just tagZero, Just tagSuc, Just boolSym) ->
mkLambda' mkTypeInteger' $
diff --git a/src/Juvix/Compiler/Core/Translation/FromInternal/Data/Context.hs b/src/Juvix/Compiler/Core/Translation/FromInternal/Data/Context.hs
index d7600e4f56..74c9d009a7 100644
--- a/src/Juvix/Compiler/Core/Translation/FromInternal/Data/Context.hs
+++ b/src/Juvix/Compiler/Core/Translation/FromInternal/Data/Context.hs
@@ -1,11 +1,11 @@
module Juvix.Compiler.Core.Translation.FromInternal.Data.Context where
-import Juvix.Compiler.Core.Data.InfoTable qualified as Core
+import Juvix.Compiler.Core.Data.Module qualified as Core
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context qualified as Internal
import Juvix.Prelude
data CoreResult = CoreResult
- { _coreResultTable :: Core.InfoTable,
+ { _coreResultModule :: Core.Module,
_coreResultInternalTypedResult :: Internal.InternalTypedResult
}
diff --git a/src/Juvix/Compiler/Core/Translation/FromSource.hs b/src/Juvix/Compiler/Core/Translation/FromSource.hs
index 3a3ed40fab..d28cbc3bcf 100644
--- a/src/Juvix/Compiler/Core/Translation/FromSource.hs
+++ b/src/Juvix/Compiler/Core/Translation/FromSource.hs
@@ -24,34 +24,34 @@ import Text.Megaparsec qualified as P
-- | Note: only new symbols and tags that are not in the InfoTable already will be
-- generated during parsing
-runParser :: Path Abs File -> InfoTable -> Text -> Either MegaparsecError (InfoTable, Maybe Node)
-runParser fileName tab input =
+runParser :: Path Abs File -> ModuleId -> InfoTable -> Text -> Either MegaparsecError (InfoTable, Maybe Node)
+runParser fileName mid tab input =
case run $
- runInfoTableBuilder tab $
+ runInfoTableBuilder (Module mid tab mempty) $
P.runParserT parseToplevel (fromAbsFile fileName) input of
(_, Left err) -> Left (MegaparsecError err)
- (tbl, Right r) -> Right (tbl, r)
+ (md, Right r) -> Right (md ^. moduleInfoTable, r)
-runParserMain :: Path Abs File -> InfoTable -> Text -> Either MegaparsecError InfoTable
-runParserMain fileName tab input =
- case runParser fileName tab input of
+runParserMain :: Path Abs File -> ModuleId -> InfoTable -> Text -> Either MegaparsecError InfoTable
+runParserMain fileName mid tab input =
+ case runParser fileName mid tab input of
Left err -> Left err
Right (tab', Nothing) -> Right tab'
- Right (tab', Just node) -> Right $ setupMainFunction tab' node
+ Right (tab', Just node) -> Right $ setupMainFunction mid tab' node
-setupMainFunction :: InfoTable -> Node -> InfoTable
-setupMainFunction tab node =
+setupMainFunction :: ModuleId -> InfoTable -> Node -> InfoTable
+setupMainFunction mid tab node =
tab
{ _infoMain = Just sym,
_identContext = HashMap.insert sym node (tab ^. identContext),
- _infoIdentifiers = HashMap.insert sym info (tab ^. infoIdentifiers),
- _infoNextSymbol = tab ^. infoNextSymbol + 1
+ _infoIdentifiers = HashMap.insert sym info (tab ^. infoIdentifiers)
}
where
- sym = tab ^. infoNextSymbol
+ symId = nextSymbolId tab
+ sym = Symbol mid symId
info =
IdentifierInfo
- { _identifierName = freshIdentName tab "main",
+ { _identifierName = freshIdentName' tab "main",
_identifierLocation = Nothing,
_identifierSymbol = sym,
_identifierArgsNum = 0,
@@ -131,7 +131,7 @@ statementDef = do
guardSymbolNotDefined
sym
(parseFailure off ("duplicate definition of: " ++ fromText txt))
- tab <- lift getInfoTable
+ tab <- (^. moduleInfoTable) <$> lift getModule
mty <- optional typeAnnotation
let fi = fromMaybe impossible $ HashMap.lookup sym (tab ^. infoIdentifiers)
ty = fromMaybe (fi ^. identifierType) mty
@@ -250,8 +250,8 @@ expression ::
ParsecS r Node
expression = do
node <- expr 0 mempty
- tab <- lift getInfoTable
- return $ etaExpandApps tab node
+ md <- lift getModule
+ return $ etaExpandApps md node
expr ::
(Member InfoTableBuilder r) =>
diff --git a/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs b/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs
index c971fb56c1..39a1685e6e 100644
--- a/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs
+++ b/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs
@@ -1,7 +1,7 @@
module Juvix.Compiler.Core.Translation.Stripped.FromCore (fromCore) where
import Data.HashMap.Strict qualified as HashMap
-import Juvix.Compiler.Core hiding (unsupported)
+import Juvix.Compiler.Core
import Juvix.Compiler.Core.Data.Stripped.InfoTable qualified as Stripped
import Juvix.Compiler.Core.Extra.Stripped.Base qualified as Stripped
import Juvix.Compiler.Core.Info.LocationInfo
diff --git a/src/Juvix/Compiler/Internal/Data/CoercionInfo.hs b/src/Juvix/Compiler/Internal/Data/CoercionInfo.hs
index b768485577..79fb5744c8 100644
--- a/src/Juvix/Compiler/Internal/Data/CoercionInfo.hs
+++ b/src/Juvix/Compiler/Internal/Data/CoercionInfo.hs
@@ -6,6 +6,7 @@ import Data.List qualified as List
import Juvix.Compiler.Internal.Data.InstanceInfo
import Juvix.Compiler.Internal.Extra.Base
import Juvix.Compiler.Internal.Language
+import Juvix.Extra.Serialize
import Juvix.Prelude
data CoercionInfo = CoercionInfo
@@ -15,15 +16,20 @@ data CoercionInfo = CoercionInfo
_coercionInfoResult :: Expression,
_coercionInfoArgs :: [FunctionParameter]
}
- deriving stock (Eq)
+ deriving stock (Eq, Generic)
instance Hashable CoercionInfo where
hashWithSalt salt CoercionInfo {..} = hashWithSalt salt _coercionInfoResult
+instance Serialize CoercionInfo
+
-- | Maps trait names to available coercions
newtype CoercionTable = CoercionTable
{ _coercionTableMap :: HashMap InductiveName [CoercionInfo]
}
+ deriving stock (Eq, Generic)
+
+instance Serialize CoercionTable
makeLenses ''CoercionInfo
makeLenses ''CoercionTable
diff --git a/src/Juvix/Compiler/Internal/Data/InfoTable.hs b/src/Juvix/Compiler/Internal/Data/InfoTable.hs
index fc6d04ec6e..cf817de6b1 100644
--- a/src/Juvix/Compiler/Internal/Data/InfoTable.hs
+++ b/src/Juvix/Compiler/Internal/Data/InfoTable.hs
@@ -1,6 +1,6 @@
module Juvix.Compiler.Internal.Data.InfoTable
- ( module Juvix.Compiler.Internal.Data.InfoTable.Base,
- buildTable,
+ ( module Juvix.Compiler.Store.Internal.Language,
+ computeInternalModule,
extendWithReplExpression,
lookupConstructor,
lookupConstructorArgTypes,
@@ -13,33 +13,48 @@ module Juvix.Compiler.Internal.Data.InfoTable
lookupConstructorType,
getAxiomBuiltinInfo,
getFunctionBuiltinInfo,
- buildTableShallow,
mkConstructorEntries,
+ functionInfoFromFunctionDef,
+ inductiveInfoFromInductiveDef,
)
where
import Data.Generics.Uniplate.Data
import Data.HashMap.Strict qualified as HashMap
import Juvix.Compiler.Internal.Data.CoercionInfo
-import Juvix.Compiler.Internal.Data.InfoTable.Base
import Juvix.Compiler.Internal.Data.InstanceInfo
import Juvix.Compiler.Internal.Extra
import Juvix.Compiler.Internal.Pretty (ppTrace)
+import Juvix.Compiler.Store.Internal.Data.FunctionsTable
+import Juvix.Compiler.Store.Internal.Data.TypesTable
+import Juvix.Compiler.Store.Internal.Language
import Juvix.Prelude
-type MCache = Cache ModuleIndex InfoTable
+functionInfoFromFunctionDef :: FunctionDef -> FunctionInfo
+functionInfoFromFunctionDef FunctionDef {..} =
+ FunctionInfo
+ { _functionInfoName = _funDefName,
+ _functionInfoType = _funDefType,
+ _functionInfoArgsInfo = _funDefArgsInfo,
+ _functionInfoBuiltin = _funDefBuiltin,
+ _functionInfoCoercion = _funDefCoercion,
+ _functionInfoInstance = _funDefInstance,
+ _functionInfoTerminating = _funDefTerminating,
+ _functionInfoPragmas = _funDefPragmas
+ }
-buildTable :: (Foldable f) => f Module -> InfoTable
-buildTable = run . evalCache (computeTable True) mempty . getMany
-
-buildTable' :: (Foldable f) => Bool -> f Module -> InfoTable
-buildTable' recurIntoImports = run . evalCache (computeTable recurIntoImports) mempty . getMany
-
-buildTableShallow :: Module -> InfoTable
-buildTableShallow = buildTable' False . pure @[]
-
-getMany :: (Members '[MCache] r, Foldable f) => f Module -> Sem r InfoTable
-getMany = mconcatMap (cacheGet . ModuleIndex)
+inductiveInfoFromInductiveDef :: InductiveDef -> InductiveInfo
+inductiveInfoFromInductiveDef InductiveDef {..} =
+ InductiveInfo
+ { _inductiveInfoName = _inductiveName,
+ _inductiveInfoType = _inductiveType,
+ _inductiveInfoBuiltin = _inductiveBuiltin,
+ _inductiveInfoParameters = _inductiveParameters,
+ _inductiveInfoConstructors = map (^. inductiveConstructorName) _inductiveConstructors,
+ _inductiveInfoPositive = _inductivePositive,
+ _inductiveInfoTrait = _inductiveTrait,
+ _inductiveInfoPragmas = _inductivePragmas
+ }
extendWithReplExpression :: Expression -> InfoTable -> InfoTable
extendWithReplExpression e =
@@ -47,7 +62,7 @@ extendWithReplExpression e =
infoFunctions
( HashMap.union
( HashMap.fromList
- [ (f ^. funDefName, FunctionInfo f)
+ [ (f ^. funDefName, functionInfoFromFunctionDef f)
| f <- letFunctionDefs e
]
)
@@ -65,19 +80,20 @@ letFunctionDefs e =
LetFunDef f -> pure f
LetMutualBlock (MutualBlockLet fs) -> fs
-computeTable :: forall r. (Members '[MCache] r) => Bool -> ModuleIndex -> Sem r InfoTable
-computeTable recurIntoImports (ModuleIndex m) = compute
- where
- compute :: Sem r InfoTable
- compute = do
- infoInc <- mconcatMapM (cacheGet . (^. importModule)) imports
- return (InfoTable {..} <> infoInc)
-
- imports :: [Import]
- imports
- | recurIntoImports = m ^. moduleBody . moduleImports
- | otherwise = []
+computeInternalModule :: TypesTable -> FunctionsTable -> Module -> InternalModule
+computeInternalModule tysTab funsTab m@Module {..} =
+ InternalModule
+ { _internalModuleId = _moduleId,
+ _internalModuleName = _moduleName,
+ _internalModuleImports = _moduleBody ^. moduleImports,
+ _internalModuleInfoTable = computeInfoTable m,
+ _internalModuleTypesTable = tysTab,
+ _internalModuleFunctionsTable = funsTab
+ }
+computeInfoTable :: Module -> InfoTable
+computeInfoTable m = InfoTable {..}
+ where
mutuals :: [MutualStatement]
mutuals =
[ d
@@ -94,7 +110,7 @@ computeTable recurIntoImports (ModuleIndex m) = compute
_infoInductives :: HashMap Name InductiveInfo
_infoInductives =
HashMap.fromList
- [ (d ^. inductiveName, InductiveInfo d)
+ [ (d ^. inductiveName, inductiveInfoFromInductiveDef d)
| d <- inductives
]
@@ -109,10 +125,10 @@ computeTable recurIntoImports (ModuleIndex m) = compute
_infoFunctions :: HashMap Name FunctionInfo
_infoFunctions =
HashMap.fromList $
- [ (f ^. funDefName, FunctionInfo f)
+ [ (f ^. funDefName, functionInfoFromFunctionDef f)
| StatementFunction f <- mutuals
]
- <> [ (f ^. funDefName, FunctionInfo f)
+ <> [ (f ^. funDefName, functionInfoFromFunctionDef f)
| s <- ss,
f <- letFunctionDefs s
]
@@ -124,16 +140,44 @@ computeTable recurIntoImports (ModuleIndex m) = compute
| StatementAxiom d <- mutuals
]
+ _infoBuiltins :: HashMap BuiltinPrim Name
+ _infoBuiltins =
+ HashMap.fromList $
+ mapMaybe goInd (HashMap.elems _infoInductives)
+ <> mapMaybe goConstr (HashMap.elems _infoConstructors)
+ <> mapMaybe goFun (HashMap.elems _infoFunctions)
+ <> mapMaybe goAxiom (HashMap.elems _infoAxioms)
+ where
+ goInd :: InductiveInfo -> Maybe (BuiltinPrim, Name)
+ goInd InductiveInfo {..} =
+ _inductiveInfoBuiltin
+ >>= (\b -> Just (BuiltinsInductive b, _inductiveInfoName))
+
+ goConstr :: ConstructorInfo -> Maybe (BuiltinPrim, Name)
+ goConstr ConstructorInfo {..} =
+ _constructorInfoBuiltin
+ >>= (\b -> Just (BuiltinsConstructor b, _constructorInfoName))
+
+ goFun :: FunctionInfo -> Maybe (BuiltinPrim, Name)
+ goFun FunctionInfo {..} =
+ _functionInfoBuiltin
+ >>= (\b -> Just (BuiltinsFunction b, _functionInfoName))
+
+ goAxiom :: AxiomInfo -> Maybe (BuiltinPrim, Name)
+ goAxiom AxiomInfo {..} =
+ _axiomInfoDef ^. axiomBuiltin
+ >>= (\b -> Just (BuiltinsAxiom b, _axiomInfoDef ^. axiomName))
+
_infoInstances :: InstanceTable
_infoInstances = foldr (flip updateInstanceTable) mempty $ mapMaybe mkInstance (HashMap.elems _infoFunctions)
where
mkInstance :: FunctionInfo -> Maybe InstanceInfo
- mkInstance (FunctionInfo FunctionDef {..})
- | _funDefInstance =
+ mkInstance (FunctionInfo {..})
+ | _functionInfoInstance =
instanceFromTypedExpression
( TypedExpression
- { _typedType = _funDefType,
- _typedExpression = ExpressionIden (IdenFunction _funDefName)
+ { _typedType = _functionInfoType,
+ _typedExpression = ExpressionIden (IdenFunction _functionInfoName)
}
)
| otherwise =
@@ -143,12 +187,12 @@ computeTable recurIntoImports (ModuleIndex m) = compute
_infoCoercions = foldr (flip updateCoercionTable) mempty $ mapMaybe mkCoercion (HashMap.elems _infoFunctions)
where
mkCoercion :: FunctionInfo -> Maybe CoercionInfo
- mkCoercion (FunctionInfo FunctionDef {..})
- | _funDefCoercion =
+ mkCoercion (FunctionInfo {..})
+ | _functionInfoCoercion =
coercionFromTypedExpression
( TypedExpression
- { _typedType = _funDefType,
- _typedExpression = ExpressionIden (IdenFunction _funDefName)
+ { _typedType = _functionInfoType,
+ _typedExpression = ExpressionIden (IdenFunction _functionInfoName)
}
)
| otherwise =
@@ -235,7 +279,7 @@ getFunctionBuiltinInfo :: (Member (Reader InfoTable) r) => Name -> Sem r (Maybe
getFunctionBuiltinInfo n = do
maybeFunInfo <- HashMap.lookup n <$> asks (^. infoFunctions)
return $ case maybeFunInfo of
- Just funInfo -> funInfo ^. functionInfoDef . funDefBuiltin
+ Just funInfo -> funInfo ^. functionInfoBuiltin
Nothing -> Nothing
mkConstructorEntries :: InductiveDef -> [(ConstructorName, ConstructorInfo)]
diff --git a/src/Juvix/Compiler/Internal/Data/InstanceInfo.hs b/src/Juvix/Compiler/Internal/Data/InstanceInfo.hs
index 34a150e4f4..83d92589c6 100644
--- a/src/Juvix/Compiler/Internal/Data/InstanceInfo.hs
+++ b/src/Juvix/Compiler/Internal/Data/InstanceInfo.hs
@@ -4,6 +4,7 @@ import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet
import Juvix.Compiler.Internal.Extra.Base
import Juvix.Compiler.Internal.Language
+import Juvix.Extra.Serialize
import Juvix.Prelude
data InstanceParam
@@ -12,7 +13,9 @@ data InstanceParam
| InstanceParamFun InstanceFun
| InstanceParamHole Hole
| InstanceParamMeta VarName
- deriving stock (Eq)
+ deriving stock (Eq, Generic)
+
+instance Serialize InstanceParam
data InstanceApp = InstanceApp
{ _instanceAppHead :: Name,
@@ -20,7 +23,9 @@ data InstanceApp = InstanceApp
-- | The original expression from which this InstanceApp was created
_instanceAppExpression :: Expression
}
- deriving stock (Eq)
+ deriving stock (Eq, Generic)
+
+instance Serialize InstanceApp
data InstanceFun = InstanceFun
{ _instanceFunLeft :: InstanceParam,
@@ -28,7 +33,9 @@ data InstanceFun = InstanceFun
-- | The original expression from which this InstanceFun was created
_instanceFunExpression :: Expression
}
- deriving stock (Eq)
+ deriving stock (Eq, Generic)
+
+instance Serialize InstanceFun
data InstanceInfo = InstanceInfo
{ _instanceInfoInductive :: InductiveName,
@@ -36,15 +43,20 @@ data InstanceInfo = InstanceInfo
_instanceInfoResult :: Expression,
_instanceInfoArgs :: [FunctionParameter]
}
- deriving stock (Eq)
+ deriving stock (Eq, Generic)
instance Hashable InstanceInfo where
hashWithSalt salt InstanceInfo {..} = hashWithSalt salt _instanceInfoResult
+instance Serialize InstanceInfo
+
-- | Maps trait names to available instances
newtype InstanceTable = InstanceTable
{ _instanceTableMap :: HashMap InductiveName [InstanceInfo]
}
+ deriving stock (Eq, Generic)
+
+instance Serialize InstanceTable
makeLenses ''InstanceApp
makeLenses ''InstanceFun
diff --git a/src/Juvix/Compiler/Internal/Data/Name.hs b/src/Juvix/Compiler/Internal/Data/Name.hs
index 86cde7c8e1..f6b79f006a 100644
--- a/src/Juvix/Compiler/Internal/Data/Name.hs
+++ b/src/Juvix/Compiler/Internal/Data/Name.hs
@@ -9,6 +9,7 @@ where
import Juvix.Data.Fixity
import Juvix.Data.NameId
import Juvix.Data.NameKind
+import Juvix.Extra.Serialize
import Juvix.Prelude
import Juvix.Prelude.Pretty
@@ -21,10 +22,12 @@ data Name = Name
_nameLoc :: Interval,
_nameFixity :: Maybe Fixity
}
- deriving stock (Show, Data)
+ deriving stock (Show, Data, Generic)
makeLenses ''Name
+instance Serialize Name
+
varFromHole :: Hole -> VarName
varFromHole h =
Name
diff --git a/src/Juvix/Compiler/Internal/Extra.hs b/src/Juvix/Compiler/Internal/Extra.hs
index 086ae64300..69d9171a8e 100644
--- a/src/Juvix/Compiler/Internal/Extra.hs
+++ b/src/Juvix/Compiler/Internal/Extra.hs
@@ -8,11 +8,11 @@ where
import Data.HashMap.Strict qualified as HashMap
import Data.Stream qualified as Stream
-import Juvix.Compiler.Internal.Data.InfoTable.Base
import Juvix.Compiler.Internal.Extra.Base
import Juvix.Compiler.Internal.Extra.Clonable
import Juvix.Compiler.Internal.Extra.DependencyBuilder
import Juvix.Compiler.Internal.Language
+import Juvix.Compiler.Store.Internal.Data.InfoTable
import Juvix.Prelude
constructorArgTypes :: ConstructorInfo -> ([InductiveParameter], [Expression])
@@ -31,10 +31,10 @@ constructorReturnType info =
fullInductiveType :: InductiveInfo -> Expression
fullInductiveType info =
- let ps = info ^. inductiveInfoDef . inductiveParameters
+ let ps = info ^. inductiveInfoParameters
in foldr
(\p k -> p ^. inductiveParamType --> k)
- (info ^. inductiveInfoDef . inductiveType)
+ (info ^. inductiveInfoType)
ps
constructorType :: ConstructorInfo -> Expression
diff --git a/src/Juvix/Compiler/Internal/Extra/DependencyBuilder.hs b/src/Juvix/Compiler/Internal/Extra/DependencyBuilder.hs
index 0c4dc277e8..c1b2b5c350 100644
--- a/src/Juvix/Compiler/Internal/Extra/DependencyBuilder.hs
+++ b/src/Juvix/Compiler/Internal/Extra/DependencyBuilder.hs
@@ -1,7 +1,5 @@
module Juvix.Compiler.Internal.Extra.DependencyBuilder
- ( buildDependencyInfo,
- buildDependencyInfoPreModule,
- buildDependencyInfoExpr,
+ ( buildDependencyInfoPreModule,
buildDependencyInfoLet,
ExportsTable,
)
@@ -10,7 +8,6 @@ where
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet
import Juvix.Compiler.Internal.Data.NameDependencyInfo
-import Juvix.Compiler.Internal.Extra.Base
import Juvix.Compiler.Internal.Language
import Juvix.Prelude
@@ -43,21 +40,13 @@ buildDependencyInfoPreModule :: PreModule -> ExportsTable -> NameDependencyInfo
buildDependencyInfoPreModule ms tab =
buildDependencyInfoHelper tab (goPreModule ms >> addCastEdges)
-buildDependencyInfo :: NonEmpty Module -> ExportsTable -> NameDependencyInfo
-buildDependencyInfo ms tab =
- buildDependencyInfoHelper tab (mapM_ (visit . ModuleIndex) ms >> addCastEdges)
-
-buildDependencyInfoExpr :: Expression -> NameDependencyInfo
-buildDependencyInfoExpr e =
- buildDependencyInfoHelper mempty (goExpression Nothing e >> addCastEdges)
-
buildDependencyInfoLet :: NonEmpty PreLetStatement -> NameDependencyInfo
buildDependencyInfoLet ls =
- buildDependencyInfoHelper mempty (mapM_ goPreLetStatement ls >> addCastEdges)
+ buildDependencyInfoHelper mempty (goPreLetStatements Nothing (toList ls) >> addCastEdges)
buildDependencyInfoHelper ::
ExportsTable ->
- Sem '[Visit ModuleIndex, Reader ExportsTable, State DependencyGraph, State StartNodes, State BuilderState] () ->
+ Sem '[Reader ExportsTable, State DependencyGraph, State StartNodes, State BuilderState] () ->
NameDependencyInfo
buildDependencyInfoHelper tbl m = createDependencyInfo graph startNodes
where
@@ -69,7 +58,6 @@ buildDependencyInfoHelper tbl m = createDependencyInfo graph startNodes
. runState HashSet.empty
. execState HashMap.empty
. runReader tbl
- . evalVisitEmpty goModuleNoVisited
$ m
addCastEdges :: (Members '[State DependencyGraph, State BuilderState] r) => Sem r ()
@@ -120,62 +108,73 @@ checkStartNode n = do
(HashSet.member (n ^. nameId) tab)
(addStartNode n)
-goModuleNoVisited :: forall r. (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes, State BuilderState, Visit ModuleIndex] r) => ModuleIndex -> Sem r ()
-goModuleNoVisited (ModuleIndex m) = do
- checkStartNode (m ^. moduleName)
- let b = m ^. moduleBody
- mapM_ (goMutual (m ^. moduleName)) (b ^. moduleStatements)
- mapM_ goImport (b ^. moduleImports)
-
-goImport :: (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes, State BuilderState, Visit ModuleIndex] r) => Import -> Sem r ()
-goImport (Import m) = visit m
-
-goPreModule :: (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes, State BuilderState, Visit ModuleIndex] r) => PreModule -> Sem r ()
+goPreModule :: (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes, State BuilderState] r) => PreModule -> Sem r ()
goPreModule m = do
checkStartNode (m ^. moduleName)
let b = m ^. moduleBody
- mapM_ (goPreStatement (m ^. moduleName)) (b ^. moduleStatements)
- -- We cannot ignore imports with instances, because a trait in a module M may
- -- depend on an instance in a module N which imports M (i.e. new edges may be
- -- added from definitions in M to definitions in N)
- mapM_ goImport (b ^. moduleImports)
-
-goMutual :: forall r. (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes, State BuilderState] r) => Name -> MutualBlock -> Sem r ()
-goMutual parentModule (MutualBlock s) = mapM_ go s
+ -- Declarations in a module depend on the module, not the other way round (a
+ -- module is reachable if at least one of the declarations in it is reachable)
+ goPreStatements (m ^. moduleName) (b ^. moduleStatements)
+
+goPreLetStatements :: forall r. (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes, State BuilderState] r) => Maybe Name -> [PreLetStatement] -> Sem r ()
+goPreLetStatements mp = \case
+ stmt : stmts -> do
+ goPreLetStatement mp stmt
+ goPreLetStatements (Just $ getPreLetStatementName stmt) stmts
+ [] -> return ()
where
- go :: MutualStatement -> Sem r ()
- go = \case
- StatementInductive i -> goInductive parentModule i
- StatementFunction i -> goTopFunctionDef parentModule i
- StatementAxiom ax -> goAxiom parentModule ax
+ getPreLetStatementName :: PreLetStatement -> Name
+ getPreLetStatementName = \case
+ PreLetFunctionDef f -> f ^. funDefName
goPreLetStatement ::
forall r.
(Members '[Reader ExportsTable, State DependencyGraph, State StartNodes, State BuilderState] r) =>
+ Maybe Name ->
PreLetStatement ->
Sem r ()
-goPreLetStatement = \case
- PreLetFunctionDef f -> goFunctionDefHelper f
+goPreLetStatement mp = \case
+ PreLetFunctionDef f -> do
+ whenJust mp $ \n ->
+ addEdge (f ^. funDefName) n
+ goFunctionDefHelper f
+
+-- | `p` is the parent -- the previous declaration or the enclosing module. A
+-- declaraction depends on its parent (on the previous declaration in the module
+-- if it exists) in order to guarantee that instance declarations are always
+-- processed before their uses. For an instance to be taken into account in
+-- instance resolution, it needs to be declared textually earlier.
+goPreStatements :: forall r. (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes, State BuilderState] r) => Name -> [PreStatement] -> Sem r ()
+goPreStatements p = \case
+ stmt : stmts -> do
+ goPreStatement p stmt
+ goPreStatements (getPreStatementName stmt) stmts
+ [] -> return ()
+ where
+ getPreStatementName :: PreStatement -> Name
+ getPreStatementName = \case
+ PreAxiomDef ax -> ax ^. axiomName
+ PreFunctionDef f -> f ^. funDefName
+ PreInductiveDef i -> i ^. inductiveName
--- | Declarations in a module depend on the module, not the other way round (a
--- module is reachable if at least one of the declarations in it is reachable)
+-- | `p` is the parent -- the previous declaration or the enclosing module
goPreStatement :: forall r. (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes, State BuilderState] r) => Name -> PreStatement -> Sem r ()
-goPreStatement parentModule = \case
- PreAxiomDef ax -> goAxiom parentModule ax
- PreFunctionDef f -> goTopFunctionDef parentModule f
- PreInductiveDef i -> goInductive parentModule i
+goPreStatement p = \case
+ PreAxiomDef ax -> goAxiom p ax
+ PreFunctionDef f -> goTopFunctionDef p f
+ PreInductiveDef i -> goInductive p i
goAxiom :: forall r. (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes, State BuilderState] r) => Name -> AxiomDef -> Sem r ()
-goAxiom parentModule ax = do
+goAxiom p ax = do
checkStartNode (ax ^. axiomName)
- addEdge (ax ^. axiomName) parentModule
+ addEdge (ax ^. axiomName) p
goExpression (Just (ax ^. axiomName)) (ax ^. axiomType)
goInductive :: forall r. (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes, State BuilderState] r) => Name -> InductiveDef -> Sem r ()
-goInductive parentModule i = do
+goInductive p i = do
checkStartNode (i ^. inductiveName)
checkBuiltinInductiveStartNode i
- addEdge (i ^. inductiveName) parentModule
+ addEdge (i ^. inductiveName) p
mapM_ (goInductiveParameter (Just (i ^. inductiveName))) (i ^. inductiveParameters)
goExpression (Just (i ^. inductiveName)) (i ^. inductiveType)
mapM_ (goConstructorDef (i ^. inductiveName)) (i ^. inductiveConstructors)
@@ -200,26 +199,10 @@ checkBuiltinInductiveStartNode i = whenJust (i ^. inductiveBuiltin) go
addInductiveStartNode = addStartNode (i ^. inductiveName)
goTopFunctionDef :: (Members '[State DependencyGraph, State StartNodes, State BuilderState, Reader ExportsTable] r) => Name -> FunctionDef -> Sem r ()
-goTopFunctionDef modName f = do
- addEdge (f ^. funDefName) modName
+goTopFunctionDef p f = do
+ addEdge (f ^. funDefName) p
goFunctionDefHelper f
--- | An instance must be in the same component as the trait, because before type
--- checking the instance holes are not filled which may result in missing
--- dependencies. In other words, the trait needs to depend on all its instances.
-goInstance ::
- (Members '[State DependencyGraph, State StartNodes, State BuilderState, Reader ExportsTable] r) =>
- FunctionDef ->
- Sem r ()
-goInstance f = do
- let app = snd (unfoldFunType (f ^. funDefType))
- h = fst (unfoldExpressionApp app)
- case h of
- ExpressionIden (IdenInductive i) ->
- addEdge i (f ^. funDefName)
- _ ->
- return ()
-
checkCast ::
(Member (State BuilderState) r) =>
FunctionDef ->
@@ -237,8 +220,6 @@ goFunctionDefHelper f = do
addNode (f ^. funDefName)
checkStartNode (f ^. funDefName)
checkCast f
- when (f ^. funDefInstance || f ^. funDefCoercion) $
- goInstance f
goExpression (Just (f ^. funDefName)) (f ^. funDefType)
goExpression (Just (f ^. funDefName)) (f ^. funDefBody)
mapM_ (goExpression (Just (f ^. funDefName))) (f ^.. funDefArgsInfo . each . argInfoDefault . _Just)
diff --git a/src/Juvix/Compiler/Internal/Language.hs b/src/Juvix/Compiler/Internal/Language.hs
index 415c49716b..75028b05f7 100644
--- a/src/Juvix/Compiler/Internal/Language.hs
+++ b/src/Juvix/Compiler/Internal/Language.hs
@@ -15,6 +15,7 @@ import Juvix.Data.Hole
import Juvix.Data.IsImplicit
import Juvix.Data.Universe hiding (smallUniverse)
import Juvix.Data.WithLoc
+import Juvix.Extra.Serialize
import Juvix.Prelude
type Module = Module' MutualBlock
@@ -34,23 +35,26 @@ data PreStatement
| PreAxiomDef AxiomDef
data Module' stmt = Module
- { _moduleName :: Name,
+ { _moduleId :: ModuleId,
+ _moduleName :: Name,
_moduleExamples :: [Example],
_moduleBody :: ModuleBody' stmt,
_modulePragmas :: Pragmas
}
- deriving stock (Data)
+ deriving stock (Data, Generic)
newtype Import = Import
- { _importModule :: ModuleIndex
+ { _importModuleName :: Name
}
- deriving stock (Data)
+ deriving stock (Data, Generic)
+
+instance Serialize Import
data ModuleBody' stmt = ModuleBody
{ _moduleImports :: [Import],
_moduleStatements :: [stmt]
}
- deriving stock (Data)
+ deriving stock (Data, Generic)
data MutualStatement
= StatementInductive InductiveDef
@@ -70,13 +74,17 @@ newtype MutualBlockLet = MutualBlockLet
instance Hashable MutualBlockLet
+instance Serialize MutualBlockLet
+
data AxiomDef = AxiomDef
{ _axiomName :: AxiomName,
_axiomBuiltin :: Maybe BuiltinAxiom,
_axiomType :: Expression,
_axiomPragmas :: Pragmas
}
- deriving stock (Data)
+ deriving stock (Data, Generic)
+
+instance Serialize AxiomDef
data FunctionDef = FunctionDef
{ _funDefName :: FunctionName,
@@ -94,6 +102,8 @@ data FunctionDef = FunctionDef
instance Hashable FunctionDef
+instance Serialize FunctionDef
+
data Iden
= IdenFunction Name
| IdenConstructor Name
@@ -112,6 +122,8 @@ getName = \case
instance Hashable Iden
+instance Serialize Iden
+
data TypedExpression = TypedExpression
{ _typedType :: Expression,
_typedExpression :: Expression
@@ -125,6 +137,8 @@ data LetClause
instance Hashable LetClause
+instance Serialize LetClause
+
data Let = Let
{ _letClauses :: NonEmpty LetClause,
_letExpression :: Expression
@@ -133,6 +147,8 @@ data Let = Let
instance Hashable Let
+instance Serialize Let
+
type LiteralLoc = WithLoc Literal
data Literal
@@ -147,6 +163,8 @@ data Literal
instance Hashable Literal
+instance Serialize Literal
+
data Expression
= ExpressionIden Iden
| ExpressionApplication Application
@@ -163,6 +181,8 @@ data Expression
instance Hashable Expression
+instance Serialize Expression
+
data Example = Example
{ _exampleId :: NameId,
_exampleExpression :: Expression
@@ -171,18 +191,24 @@ data Example = Example
instance Hashable Example
+instance Serialize Example
+
data SimpleBinder = SimpleBinder
{ _sbinderVar :: VarName,
_sbinderType :: Expression
}
deriving stock (Eq, Generic, Data)
+instance Serialize SimpleBinder
+
data SimpleLambda = SimpleLambda
{ _slambdaBinder :: SimpleBinder,
_slambdaBody :: Expression
}
deriving stock (Eq, Generic, Data)
+instance Serialize SimpleLambda
+
data CaseBranch = CaseBranch
{ _caseBranchPattern :: PatternArg,
_caseBranchExpression :: Expression
@@ -191,6 +217,8 @@ data CaseBranch = CaseBranch
instance Hashable CaseBranch
+instance Serialize CaseBranch
+
data Case = Case
{ _caseExpression :: Expression,
-- | The type of the cased expression. The typechecker fills this field
@@ -204,6 +232,8 @@ data Case = Case
instance Hashable Case
+instance Serialize Case
+
data Lambda = Lambda
{ _lambdaClauses :: NonEmpty LambdaClause,
-- | The typechecker fills this field
@@ -225,16 +255,20 @@ instance Hashable SimpleBinder
instance Hashable SimpleLambda
+instance Serialize Lambda
+
+instance Serialize LambdaClause
+
data Application = Application
{ _appLeft :: Expression,
_appRight :: Expression,
_appImplicit :: IsImplicit
}
- deriving stock (Data)
+ deriving stock (Data, Generic)
+
+instance Serialize Application
-- TODO: Eq and Hashable instances ignore the _appImplicit field
--- to workaround a crash in Micro->Mono translation when looking up
--- a concrete type.
instance Eq Application where
(Application l r _) == (Application l' r' _) = (l == l') && (r == r')
@@ -252,6 +286,8 @@ data ConstructorApp = ConstructorApp
instance Hashable ConstructorApp
+instance Serialize ConstructorApp
+
data PatternArg = PatternArg
{ _patternArgIsImplicit :: IsImplicit,
_patternArgName :: Maybe VarName,
@@ -261,6 +297,8 @@ data PatternArg = PatternArg
instance Hashable PatternArg
+instance Serialize PatternArg
+
newtype WildcardConstructor = WildcardConstructor
{ _wildcardConstructor :: ConstrName
}
@@ -268,6 +306,8 @@ newtype WildcardConstructor = WildcardConstructor
instance Hashable WildcardConstructor
+instance Serialize WildcardConstructor
+
data Pattern
= PatternVariable VarName
| -- | PatternWildcardConstructor gets removed by the arity checker
@@ -277,11 +317,15 @@ data Pattern
instance Hashable Pattern
+instance Serialize Pattern
+
data InductiveParameter = InductiveParameter
{ _inductiveParamName :: VarName,
_inductiveParamType :: Expression
}
- deriving stock (Eq, Data)
+ deriving stock (Eq, Data, Generic)
+
+instance Serialize InductiveParameter
data InductiveDef = InductiveDef
{ _inductiveName :: InductiveName,
@@ -305,7 +349,7 @@ data ConstructorDef = ConstructorDef
deriving stock (Data)
-- | At the moment we only use the name when we have a default value, so
--- isNull _argInfoDefault implies isNull _argInfoName
+-- isNothing _argInfoDefault implies isNothing _argInfoName
data ArgInfo = ArgInfo
{ _argInfoDefault :: Maybe Expression,
_argInfoName :: Maybe Name
@@ -321,6 +365,8 @@ emptyArgInfo =
instance Hashable ArgInfo
+instance Serialize ArgInfo
+
data FunctionParameter = FunctionParameter
{ _paramName :: Maybe VarName,
_paramImplicit :: IsImplicit,
@@ -330,6 +376,8 @@ data FunctionParameter = FunctionParameter
instance Hashable FunctionParameter
+instance Serialize FunctionParameter
+
data Function = Function
{ _functionLeft :: FunctionParameter,
_functionRight :: Expression
@@ -338,6 +386,8 @@ data Function = Function
instance Hashable Function
+instance Serialize Function
+
newtype ModuleIndex = ModuleIndex
{ _moduleIxModule :: Module
}
diff --git a/src/Juvix/Compiler/Internal/Pretty/Base.hs b/src/Juvix/Compiler/Internal/Pretty/Base.hs
index 46b3851e12..4410c3cc31 100644
--- a/src/Juvix/Compiler/Internal/Pretty/Base.hs
+++ b/src/Juvix/Compiler/Internal/Pretty/Base.hs
@@ -6,7 +6,6 @@ module Juvix.Compiler.Internal.Pretty.Base
where
import Data.HashMap.Strict qualified as HashMap
-import Juvix.Compiler.Internal.Data.InfoTable.Base
import Juvix.Compiler.Internal.Data.InstanceInfo (instanceInfoResult, instanceTableMap)
import Juvix.Compiler.Internal.Data.LocalVars
import Juvix.Compiler.Internal.Data.NameDependencyInfo
@@ -14,6 +13,7 @@ import Juvix.Compiler.Internal.Data.TypedHole
import Juvix.Compiler.Internal.Language
import Juvix.Compiler.Internal.Pretty.Options
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.CheckerNew.Arity qualified as New
+import Juvix.Compiler.Store.Internal.Data.InfoTable
import Juvix.Data.CodeAnn
import Juvix.Prelude
@@ -30,7 +30,7 @@ runPrettyCode :: (PrettyCode c) => Options -> c -> Doc Ann
runPrettyCode opts = run . runReader opts . ppCode
instance PrettyCode NameId where
- ppCode (NameId k) = return (pretty k)
+ ppCode = return . pretty
instance PrettyCode Name where
ppCode n = do
@@ -274,7 +274,7 @@ instance PrettyCode PreLetStatement where
instance PrettyCode Import where
ppCode i = do
- name' <- ppCode (i ^. importModule . moduleIxModule . moduleName)
+ name' <- ppCode (i ^. importModuleName)
return $ kwImport <+> name'
instance PrettyCode BuiltinAxiom where
diff --git a/src/Juvix/Compiler/Internal/Translation.hs b/src/Juvix/Compiler/Internal/Translation.hs
index 30406b0981..b01f27d70b 100644
--- a/src/Juvix/Compiler/Internal/Translation.hs
+++ b/src/Juvix/Compiler/Internal/Translation.hs
@@ -8,7 +8,7 @@ module Juvix.Compiler.Internal.Translation
where
import Juvix.Compiler.Internal.Language
-import Juvix.Compiler.Internal.Translation.FromConcrete hiding (MCache, goModuleNoCache)
+import Juvix.Compiler.Internal.Translation.FromConcrete
import Juvix.Compiler.Internal.Translation.FromConcrete.Data.Context
import Juvix.Compiler.Internal.Translation.FromInternal
import Juvix.Compiler.Internal.Translation.FromInternal.Data
diff --git a/src/Juvix/Compiler/Internal/Translation/Extra.hs b/src/Juvix/Compiler/Internal/Translation/Extra.hs
index 05885fb873..982756db85 100644
--- a/src/Juvix/Compiler/Internal/Translation/Extra.hs
+++ b/src/Juvix/Compiler/Internal/Translation/Extra.hs
@@ -24,7 +24,7 @@ unfoldPolyApplication a =
filterCompileTimeArgsOrPatterns :: (Member (Reader TypesTable) r) => Name -> [a] -> Sem r [a]
filterCompileTimeArgsOrPatterns idenname lst = do
- tab <- ask
+ tab <- asks (^. typesTable)
let funParams = fst (unfoldFunType (ty tab))
typedArgs =
map fst $
diff --git a/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs b/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs
index 49dd5d2c4c..51cc70ae09 100644
--- a/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs
+++ b/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs
@@ -1,10 +1,9 @@
module Juvix.Compiler.Internal.Translation.FromConcrete
( module Juvix.Compiler.Internal.Translation.FromConcrete.Data.Context,
fromConcrete,
- MCache,
ConstructorInfos,
DefaultArgsStack,
- goModuleNoCache,
+ goTopModule,
fromConcreteExpression,
fromConcreteImport,
)
@@ -15,13 +14,13 @@ import Data.HashSet qualified as HashSet
import Data.IntMap.Strict qualified as IntMap
import Data.List.NonEmpty qualified as NonEmpty
import Juvix.Compiler.Builtins
-import Juvix.Compiler.Concrete.Data.Scope.Base (ScoperState, scoperScopedConstructorFields, scoperScopedSignatures)
import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
import Juvix.Compiler.Concrete.Extra qualified as Concrete
import Juvix.Compiler.Concrete.Gen qualified as Gen
import Juvix.Compiler.Concrete.Language qualified as Concrete
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error
+import Juvix.Compiler.Internal.Data.InfoTable qualified as Internal
import Juvix.Compiler.Internal.Data.NameDependencyInfo qualified as Internal
import Juvix.Compiler.Internal.Extra (mkLetClauses)
import Juvix.Compiler.Internal.Extra qualified as Internal
@@ -31,15 +30,23 @@ import Juvix.Compiler.Internal.Translation.FromConcrete.Data.Context
import Juvix.Compiler.Internal.Translation.FromConcrete.NamedArguments
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker
import Juvix.Compiler.Pipeline.EntryPoint
+import Juvix.Compiler.Store.Language qualified as Store
+import Juvix.Compiler.Store.Scoped.Data.InfoTable qualified as S
+import Juvix.Compiler.Store.Scoped.Language (createExportsTable)
+import Juvix.Compiler.Store.Scoped.Language qualified as S
import Juvix.Data.NameKind
import Juvix.Prelude
import Safe (lastMay)
-type MCache = Cache Concrete.ModuleIndex Internal.Module
+-- | Needed only to generate field projections.
+newtype ConstructorInfos = ConstructorInfos
+ { _constructorInfos :: HashMap Internal.ConstructorName ConstructorInfo
+ }
+ deriving newtype (Semigroup, Monoid)
--- | Needed to generate field projections.
-type ConstructorInfos = HashMap Internal.ConstructorName ConstructorInfo
+makeLenses ''ConstructorInfos
+-- | Needed to detect looping while inserting default arguments
newtype DefaultArgsStack = DefaultArgsStack
{ _defaultArgsStack :: [S.Symbol]
}
@@ -48,31 +55,57 @@ newtype DefaultArgsStack = DefaultArgsStack
makeLenses ''DefaultArgsStack
fromConcrete ::
- (Members '[Reader EntryPoint, Error JuvixError, Builtins, NameIdGen, Termination] r) =>
+ (Members '[Reader EntryPoint, Error JuvixError, Reader Store.ModuleTable, NameIdGen, Termination] r) =>
Scoper.ScoperResult ->
Sem r InternalResult
-fromConcrete _resultScoper =
+fromConcrete _resultScoper = do
+ mtab <- ask
+ let ms = HashMap.elems (mtab ^. Store.moduleTable)
+ blts =
+ mconcatMap
+ (^. Store.moduleInfoInternalModule . internalModuleInfoTable . infoBuiltins)
+ ms
+ exportTbl =
+ _resultScoper ^. Scoper.resultExports
+ <> mconcatMap (createExportsTable . (^. Store.moduleInfoScopedModule . S.scopedModuleExportInfo)) ms
+ tab =
+ S.getCombinedInfoTable (_resultScoper ^. Scoper.resultScopedModule)
+ <> mconcatMap (S.getCombinedInfoTable . (^. Store.moduleInfoScopedModule)) ms
mapError (JuvixError @ScoperError) $ do
- (modulesCache, _resultModules) <-
+ _resultModule <-
runReader @Pragmas mempty
. runReader @ExportsTable exportTbl
+ . runReader tab
. evalState @ConstructorInfos mempty
- . runReader namesSigs
- . runReader constrSigs
. runReader @DefaultArgsStack mempty
- . runCacheEmpty goModuleNoCache
- $ mapM goTopModule ms
- let _resultTable = buildTable _resultModules
- _resultDepInfo = buildDependencyInfo _resultModules exportTbl
- _resultModulesCache = ModulesCache modulesCache
+ . evalBuiltins (BuiltinsState blts)
+ $ goTopModule m
+ let _resultInternalModule = Internal.computeInternalModule mempty mempty _resultModule
return InternalResult {..}
where
- ms = _resultScoper ^. Scoper.resultModules
- exportTbl = _resultScoper ^. Scoper.resultExports
- constrSigs = _resultScoper ^. Scoper.resultScoperState . scoperScopedConstructorFields
- namesSigs = _resultScoper ^. Scoper.resultScoperState . scoperScopedSignatures
+ m = _resultScoper ^. Scoper.resultModule
+
+fromConcreteExpression :: (Members '[Builtins, Error JuvixError, NameIdGen, Termination, Reader S.InfoTable] r) => Scoper.Expression -> Sem r Internal.Expression
+fromConcreteExpression e = do
+ e' <-
+ mapError (JuvixError @ScoperError)
+ . runReader @Pragmas mempty
+ . runReader @DefaultArgsStack mempty
+ . goExpression
+ $ e
+ checkTerminationShallow e'
+ return e'
+
+fromConcreteImport ::
+ (Members '[Reader ExportsTable, Error JuvixError, NameIdGen, Builtins, Termination] r) =>
+ Scoper.Import 'Scoped ->
+ Sem r Internal.Import
+fromConcreteImport i = do
+ mapError (JuvixError @ScoperError)
+ . runReader @Pragmas mempty
+ . goImport
+ $ i
--- | `StatementInclude`s are not included in the result
buildMutualBlocks ::
(Members '[Reader Internal.NameDependencyInfo] r) =>
[Internal.PreStatement] ->
@@ -119,51 +152,17 @@ buildMutualBlocks ss = do
AcyclicSCC a -> AcyclicSCC <$> a
CyclicSCC p -> CyclicSCC . toList <$> nonEmpty (catMaybes p)
-fromConcreteExpression :: (Members '[Builtins, Error JuvixError, NameIdGen, Termination, State ScoperState] r) => Scoper.Expression -> Sem r Internal.Expression
-fromConcreteExpression e = do
- nameSigs <- gets (^. scoperScopedSignatures)
- constrSigs <- gets (^. scoperScopedConstructorFields)
- e' <-
- mapError (JuvixError @ScoperError)
- . runReader @Pragmas mempty
- . runReader nameSigs
- . runReader constrSigs
- . runReader @DefaultArgsStack mempty
- . goExpression
- $ e
- checkTerminationShallow e'
- return e'
-
-fromConcreteImport ::
- (Members '[Reader ExportsTable, Error JuvixError, NameIdGen, Builtins, MCache, Termination] r) =>
- Scoper.Import 'Scoped ->
- Sem r Internal.Import
-fromConcreteImport i = do
- i' <-
- mapError (JuvixError @ScoperError)
- . runReader @Pragmas mempty
- . goImport
- $ i
- checkTerminationShallow i'
- return i'
-
goLocalModule ::
- (Members '[Reader DefaultArgsStack, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, State ConstructorInfos, Reader NameSignatures, Reader ConstructorNameSignatures, Reader EntryPoint] r) =>
+ (Members '[Reader EntryPoint, Reader DefaultArgsStack, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, State ConstructorInfos, Reader S.InfoTable] r) =>
Module 'Scoped 'ModuleLocal ->
Sem r [Internal.PreStatement]
goLocalModule = concatMapM goAxiomInductive . (^. moduleBody)
goTopModule ::
- (Members '[Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, MCache] r) =>
+ (Members '[Reader DefaultArgsStack, Reader EntryPoint, Reader ExportsTable, Error JuvixError, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, State ConstructorInfos, Termination, Reader S.InfoTable] r) =>
Module 'Scoped 'ModuleTop ->
Sem r Internal.Module
-goTopModule = cacheGet . ModuleIndex
-
-goModuleNoCache ::
- (Members '[Reader DefaultArgsStack, Reader EntryPoint, Reader ExportsTable, Error JuvixError, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, MCache, State ConstructorInfos, Termination, Reader NameSignatures, Reader ConstructorNameSignatures] r) =>
- ModuleIndex ->
- Sem r Internal.Module
-goModuleNoCache (ModuleIndex m) = do
+goTopModule m = do
p <- toPreModule m
tbl <- ask
let depInfo = buildDependencyInfoPreModule p tbl
@@ -178,11 +177,12 @@ goPragmas p = do
return $ p' <> p ^. _Just . withLocParam . withSourceValue
goScopedIden :: ScopedIden -> Internal.Name
-goScopedIden iden =
+goScopedIden iden = goName (iden ^. scopedIdenFinal)
+
+goName :: S.Name -> Internal.Name
+goName name =
set Internal.namePretty prettyStr (goSymbol (S.nameUnqualify name))
where
- name :: S.Name
- name = iden ^. scopedIdenFinal
prettyStr :: Text
prettyStr = prettyText name
@@ -211,7 +211,7 @@ traverseM' f x = sequence <$> traverse f x
toPreModule ::
forall r t.
- (SingI t, Members '[Reader DefaultArgsStack, Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, MCache, State ConstructorInfos, Reader NameSignatures, Reader ConstructorNameSignatures, Reader EntryPoint] r) =>
+ (SingI t, Members '[Reader EntryPoint, Reader DefaultArgsStack, Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, State ConstructorInfos, Reader S.InfoTable] r) =>
Module 'Scoped t ->
Sem r Internal.PreModule
toPreModule Module {..} = do
@@ -223,7 +223,8 @@ toPreModule Module {..} = do
{ _moduleName = name',
_moduleBody = body',
_moduleExamples = examples',
- _modulePragmas = pragmas'
+ _modulePragmas = pragmas',
+ _moduleId
}
where
name' :: Internal.Name
@@ -276,7 +277,7 @@ fromPreModuleBody b = do
goModuleBody ::
forall r.
- (Members '[Reader DefaultArgsStack, Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, MCache, State ConstructorInfos, Reader NameSignatures, Reader ConstructorNameSignatures, Reader EntryPoint] r) =>
+ (Members '[Reader EntryPoint, Reader DefaultArgsStack, Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, State ConstructorInfos, Reader S.InfoTable] r) =>
[Statement 'Scoped] ->
Sem r Internal.PreModuleBody
goModuleBody stmts = do
@@ -326,22 +327,19 @@ scanImports = mconcatMap go
goImport ::
forall r.
- (Members '[Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, MCache] r) =>
Import 'Scoped ->
Sem r Internal.Import
-goImport Import {..} = do
- let m = _importModule ^. moduleRefModule
- m' <- goTopModule m
+goImport Import {..} =
return
( Internal.Import
- { _importModule = Internal.ModuleIndex m'
+ { _importModuleName = goName (S.topModulePathName _importModulePath)
}
)
-- | Ignores functions
goAxiomInductive ::
forall r.
- (Members '[Reader DefaultArgsStack, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, State ConstructorInfos, Reader NameSignatures, Reader ConstructorNameSignatures, Reader EntryPoint] r) =>
+ (Members '[Reader EntryPoint, Reader DefaultArgsStack, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, State ConstructorInfos, Reader S.InfoTable] r) =>
Statement 'Scoped ->
Sem r [Internal.PreStatement]
goAxiomInductive = \case
@@ -361,14 +359,14 @@ goProjectionDef ::
Sem r Internal.FunctionDef
goProjectionDef ProjectionDef {..} = do
let c = goSymbol _projectionConstructor
- info <- gets @ConstructorInfos (^?! at c . _Just)
+ info <- gets (^?! constructorInfos . at c . _Just)
fun <- Internal.genFieldProjection (goSymbol _projectionField) ((^. withLocParam) <$> _projectionFieldBuiltin) info _projectionFieldIx
whenJust (fun ^. Internal.funDefBuiltin) (registerBuiltinFunction fun)
return fun
goFunctionDef ::
forall r.
- (Members '[Reader DefaultArgsStack, Reader Pragmas, Error ScoperError, Builtins, NameIdGen, Reader NameSignatures, Reader ConstructorNameSignatures] r) =>
+ (Members '[Reader DefaultArgsStack, Reader Pragmas, Error ScoperError, Builtins, NameIdGen, Reader S.InfoTable] r) =>
FunctionDef 'Scoped ->
Sem r Internal.FunctionDef
goFunctionDef FunctionDef {..} = do
@@ -381,7 +379,7 @@ goFunctionDef FunctionDef {..} = do
_funDefExamples <- goExamples _signDoc
_funDefPragmas <- goPragmas _signPragmas
_funDefBody <- goBody
- msig <- asks @NameSignatures (^. at (_funDefName ^. Internal.nameId))
+ msig <- asks (^. S.infoNameSigs . at (_funDefName ^. Internal.nameId))
_funDefArgsInfo <- maybe (return mempty) goNameSignature msig
let fun = Internal.FunctionDef {..}
whenJust _signBuiltin (registerBuiltinFunction fun . (^. withLocParam))
@@ -482,7 +480,7 @@ goFunctionDef FunctionDef {..} = do
goExamples ::
forall r.
- (Members '[Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader NameSignatures, Reader ConstructorNameSignatures] r) =>
+ (Members '[Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader S.InfoTable] r) =>
Maybe (Judoc 'Scoped) ->
Sem r [Internal.Example]
goExamples = mapM goExample . maybe [] judocExamples
@@ -498,7 +496,7 @@ goExamples = mapM goExample . maybe [] judocExamples
goInductiveParameters ::
forall r.
- (Members '[Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader NameSignatures, Reader ConstructorNameSignatures, Reader EntryPoint] r) =>
+ (Members '[Reader EntryPoint, Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader S.InfoTable] r) =>
InductiveParameters 'Scoped ->
Sem r [Internal.InductiveParameter]
goInductiveParameters params@InductiveParameters {..} = do
@@ -584,7 +582,7 @@ registerBuiltinAxiom d = \case
BuiltinIntPrint -> registerIntPrint d
goInductive ::
- (Members '[Reader DefaultArgsStack, NameIdGen, Reader Pragmas, Builtins, Error ScoperError, State ConstructorInfos, Reader NameSignatures, Reader ConstructorNameSignatures, Reader EntryPoint] r) =>
+ (Members '[Reader EntryPoint, Reader DefaultArgsStack, NameIdGen, Reader Pragmas, Builtins, Error ScoperError, State ConstructorInfos, Reader S.InfoTable] r) =>
InductiveDef 'Scoped ->
Sem r Internal.InductiveDef
goInductive ty@InductiveDef {..} = do
@@ -617,12 +615,12 @@ goInductive ty@InductiveDef {..} = do
-- | Registers constructors so we can access them for generating field projections
registerInductiveConstructors :: (Members '[State ConstructorInfos] r) => Internal.InductiveDef -> Sem r ()
registerInductiveConstructors indDef = do
- m <- get
- put (foldr (uncurry HashMap.insert) m (mkConstructorEntries indDef))
+ m <- gets (^. constructorInfos)
+ put (ConstructorInfos $ foldr (uncurry HashMap.insert) m (mkConstructorEntries indDef))
goConstructorDef ::
forall r.
- (Members '[Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader NameSignatures, Reader ConstructorNameSignatures] r) =>
+ (Members '[Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader S.InfoTable] r) =>
Internal.Expression ->
ConstructorDef 'Scoped ->
Sem r Internal.ConstructorDef
@@ -688,7 +686,7 @@ goLiteral = fmap go
LitString s -> Internal.LitString s
LitInteger i -> Internal.LitNumeric i
-goListPattern :: (Members '[Builtins, Error ScoperError, NameIdGen] r) => Concrete.ListPattern 'Scoped -> Sem r Internal.Pattern
+goListPattern :: (Members '[Builtins, Error ScoperError, NameIdGen, Reader S.InfoTable] r) => Concrete.ListPattern 'Scoped -> Sem r Internal.Pattern
goListPattern l = do
nil_ <- getBuiltinName loc BuiltinListNil
cons_ <- getBuiltinName loc BuiltinListCons
@@ -724,7 +722,7 @@ goListPattern l = do
goExpression ::
forall r.
- (Members '[Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader NameSignatures, Reader ConstructorNameSignatures] r) =>
+ (Members '[Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader S.InfoTable] r) =>
Expression ->
Sem r Internal.Expression
goExpression = \case
@@ -753,7 +751,7 @@ goExpression = \case
where
goNamedApplication :: Concrete.NamedApplication 'Scoped -> [Internal.ApplicationArg] -> Sem r Internal.Expression
goNamedApplication w extraArgs = do
- s <- ask @NameSignatures
+ s <- asks (^. S.infoNameSigs)
runReader s (runNamedArguments w extraArgs) >>= goDesugaredNamedApplication
goNamedApplicationNew :: Concrete.NamedApplicationNew 'Scoped -> [Internal.ApplicationArg] -> Sem r Internal.Expression
@@ -761,7 +759,7 @@ goExpression = \case
Nothing -> return (goIden (napp ^. namedApplicationNewName))
Just appargs -> do
let name = napp ^. namedApplicationNewName . scopedIdenName
- sig <- fromJust <$> asks @NameSignatures (^. at (name ^. S.nameId))
+ sig <- fromJust <$> asks (^. S.infoNameSigs . at (name ^. S.nameId))
cls <- goArgs appargs
let args :: [Internal.Name] = appargs ^.. each . namedArgumentNewFunDef . signName . to goSymbol
-- changes the kind from Variable to Function
@@ -1046,7 +1044,7 @@ goExpression = \case
mkApp :: Internal.Expression -> Internal.Expression -> Internal.Expression
mkApp a1 a2 = Internal.ExpressionApplication $ Internal.Application a1 a2 Explicit
-goCase :: forall r. (Members '[Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader NameSignatures, Reader ConstructorNameSignatures] r) => Case 'Scoped -> Sem r Internal.Case
+goCase :: forall r. (Members '[Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader S.InfoTable] r) => Case 'Scoped -> Sem r Internal.Case
goCase c = do
_caseExpression <- goExpression (c ^. caseExpression)
_caseBranches <- mapM goBranch (c ^. caseBranches)
@@ -1061,7 +1059,7 @@ goCase c = do
_caseBranchExpression <- goExpression (b ^. caseBranchExpression)
return Internal.CaseBranch {..}
-goNewCase :: forall r. (Members '[Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader NameSignatures, Reader ConstructorNameSignatures] r) => NewCase 'Scoped -> Sem r Internal.Case
+goNewCase :: forall r. (Members '[Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader S.InfoTable] r) => NewCase 'Scoped -> Sem r Internal.Case
goNewCase c = do
_caseExpression <- goExpression (c ^. newCaseExpression)
_caseBranches <- mapM goBranch (c ^. newCaseBranches)
@@ -1076,7 +1074,7 @@ goNewCase c = do
_caseBranchExpression <- goExpression (b ^. newCaseBranchExpression)
return Internal.CaseBranch {..}
-goLambda :: forall r. (Members '[Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader NameSignatures, Reader ConstructorNameSignatures] r) => Lambda 'Scoped -> Sem r Internal.Lambda
+goLambda :: forall r. (Members '[Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader S.InfoTable] r) => Lambda 'Scoped -> Sem r Internal.Lambda
goLambda l = do
clauses' <- mapM goClause (l ^. lambdaClauses)
return
@@ -1096,7 +1094,7 @@ goUniverse u
| isSmallUniverse u = SmallUniverse (getLoc u)
| otherwise = error "only small universe is supported"
-goFunction :: (Members '[Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader NameSignatures, Reader ConstructorNameSignatures] r) => Function 'Scoped -> Sem r Internal.Function
+goFunction :: (Members '[Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader S.InfoTable] r) => Function 'Scoped -> Sem r Internal.Function
goFunction f = do
headParam :| tailParams <- goFunctionParameters (f ^. funParameters)
ret <- goExpression (f ^. funReturn)
@@ -1107,7 +1105,7 @@ goFunction f = do
}
goFunctionParameters ::
- (Members '[Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader NameSignatures, Reader ConstructorNameSignatures] r) =>
+ (Members '[Reader DefaultArgsStack, Builtins, NameIdGen, Error ScoperError, Reader Pragmas, Reader S.InfoTable] r) =>
FunctionParameters 'Scoped ->
Sem r (NonEmpty Internal.FunctionParameter)
goFunctionParameters FunctionParameters {..} = do
@@ -1134,7 +1132,7 @@ mkConstructorApp :: Internal.ConstrName -> [Internal.PatternArg] -> Internal.Con
mkConstructorApp a b = Internal.ConstructorApp a b Nothing
goPatternApplication ::
- (Members '[Builtins, NameIdGen, Error ScoperError] r) =>
+ (Members '[Builtins, NameIdGen, Error ScoperError, Reader S.InfoTable] r) =>
PatternApp ->
Sem r Internal.ConstructorApp
goPatternApplication a = uncurry mkConstructorApp <$> viewApp (PatternApplication a)
@@ -1145,24 +1143,24 @@ goWildcardConstructor ::
goWildcardConstructor a = Internal.WildcardConstructor (goScopedIden (a ^. wildcardConstructor))
goPatternConstructor ::
- (Members '[Builtins, NameIdGen, Error ScoperError] r) =>
+ (Members '[Builtins, NameIdGen, Error ScoperError, Reader S.InfoTable] r) =>
ScopedIden ->
Sem r Internal.ConstructorApp
goPatternConstructor a = uncurry mkConstructorApp <$> viewApp (PatternConstructor a)
goInfixPatternApplication ::
- (Members '[Builtins, NameIdGen, Error ScoperError] r) =>
+ (Members '[Builtins, NameIdGen, Error ScoperError, Reader S.InfoTable] r) =>
PatternInfixApp ->
Sem r Internal.ConstructorApp
goInfixPatternApplication a = uncurry mkConstructorApp <$> viewApp (PatternInfixApplication a)
goPostfixPatternApplication ::
- (Members '[Builtins, NameIdGen, Error ScoperError] r) =>
+ (Members '[Builtins, NameIdGen, Error ScoperError, Reader S.InfoTable] r) =>
PatternPostfixApp ->
Sem r Internal.ConstructorApp
goPostfixPatternApplication a = uncurry mkConstructorApp <$> viewApp (PatternPostfixApplication a)
-viewApp :: forall r. (Members '[Builtins, NameIdGen, Error ScoperError] r) => Pattern -> Sem r (Internal.ConstrName, [Internal.PatternArg])
+viewApp :: forall r. (Members '[Builtins, NameIdGen, Error ScoperError, Reader S.InfoTable] r) => Pattern -> Sem r (Internal.ConstrName, [Internal.PatternArg])
viewApp p = case p of
PatternConstructor c -> return (goScopedIden c, [])
PatternWildcardConstructor c -> return (goScopedIden (c ^. wildcardConstructor), [])
@@ -1188,7 +1186,7 @@ viewApp p = case p of
| otherwise = viewApp (l ^. patternArgPattern)
err = throw (ErrConstructorExpectedLeftApplication (ConstructorExpectedLeftApplication p))
-goPatternArg :: (Members '[Builtins, NameIdGen, Error ScoperError] r) => PatternArg -> Sem r Internal.PatternArg
+goPatternArg :: (Members '[Builtins, NameIdGen, Error ScoperError, Reader S.InfoTable] r) => PatternArg -> Sem r Internal.PatternArg
goPatternArg p = do
pat' <- goPattern (p ^. patternArgPattern)
return
@@ -1198,7 +1196,7 @@ goPatternArg p = do
_patternArgPattern = pat'
}
-goPattern :: (Members '[Builtins, NameIdGen, Error ScoperError] r) => Pattern -> Sem r Internal.Pattern
+goPattern :: (Members '[Builtins, NameIdGen, Error ScoperError, Reader S.InfoTable] r) => Pattern -> Sem r Internal.Pattern
goPattern p = case p of
PatternVariable a -> return $ Internal.PatternVariable (goSymbol a)
PatternList a -> goListPattern a
@@ -1211,9 +1209,8 @@ goPattern p = case p of
PatternRecord i -> goRecordPattern i
PatternEmpty {} -> error "unsupported empty pattern"
-goRecordPattern :: forall r. (Members '[NameIdGen, Error ScoperError, Builtins] r) => RecordPattern 'Scoped -> Sem r Internal.Pattern
+goRecordPattern :: forall r. (Members '[NameIdGen, Error ScoperError, Builtins, Reader S.InfoTable] r) => RecordPattern 'Scoped -> Sem r Internal.Pattern
goRecordPattern r = do
- let constr = goScopedIden (r ^. recordPatternConstructor)
params' <- mkPatterns
return
( Internal.PatternConstructorApp
@@ -1224,6 +1221,9 @@ goRecordPattern r = do
}
)
where
+ constr :: Internal.Name
+ constr = goScopedIden (r ^. recordPatternConstructor)
+
itemField :: RecordPatternItem 'Scoped -> Symbol
itemField = \case
RecordPatternItemAssign a -> a ^. recordPatternAssignField
@@ -1257,24 +1257,24 @@ goRecordPattern r = do
mkPatterns :: Sem r [Internal.PatternArg]
mkPatterns = do
+ sig <- asks (fromJust . HashMap.lookup (constr ^. Internal.nameId) . (^. S.infoConstructorSigs))
+ let maxIdx = length (sig ^. recordNames) - 1
args <- IntMap.toAscList <$> byIndex
- execOutputList (go 0 args)
+ execOutputList (go maxIdx 0 args)
where
loc = getLoc r
- maxIdx :: Int
- maxIdx = length (r ^. recordPatternSignature . unIrrelevant . recordNames) - 1
- go :: Int -> [(Int, Internal.PatternArg)] -> Sem (Output Internal.PatternArg ': r) ()
- go idx args
+ go :: Int -> Int -> [(Int, Internal.PatternArg)] -> Sem (Output Internal.PatternArg ': r) ()
+ go maxIdx idx args
| idx > maxIdx = return ()
| (ix', arg') : args' <- args,
ix' == idx = do
output arg'
- go (idx + 1) args'
+ go maxIdx (idx + 1) args'
| otherwise = do
v <- Internal.freshVar loc ("x" <> show idx)
output (Internal.patternArgFromVar Internal.Explicit v)
-goAxiom :: (Members '[Reader DefaultArgsStack, Reader Pragmas, Error ScoperError, Builtins, NameIdGen, Reader NameSignatures, Reader ConstructorNameSignatures] r) => AxiomDef 'Scoped -> Sem r Internal.AxiomDef
+goAxiom :: (Members '[Reader DefaultArgsStack, Reader Pragmas, Error ScoperError, Builtins, NameIdGen, Reader S.InfoTable] r) => AxiomDef 'Scoped -> Sem r Internal.AxiomDef
goAxiom a = do
_axiomType' <- goExpression (a ^. axiomType)
_axiomPragmas' <- goPragmas (a ^. axiomPragmas)
diff --git a/src/Juvix/Compiler/Internal/Translation/FromConcrete/Data/Context.hs b/src/Juvix/Compiler/Internal/Translation/FromConcrete/Data/Context.hs
index 6f1c53d957..1a4e09876f 100644
--- a/src/Juvix/Compiler/Internal/Translation/FromConcrete/Data/Context.hs
+++ b/src/Juvix/Compiler/Internal/Translation/FromConcrete/Data/Context.hs
@@ -4,30 +4,15 @@ module Juvix.Compiler.Internal.Translation.FromConcrete.Data.Context
)
where
-import Juvix.Compiler.Concrete.Language qualified as Concrete
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context qualified as Concrete
-import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context qualified as Concrete
import Juvix.Compiler.Internal.Data.InfoTable
-import Juvix.Compiler.Internal.Data.NameDependencyInfo
import Juvix.Compiler.Internal.Language
-import Juvix.Compiler.Internal.Language qualified as Internal
-import Juvix.Compiler.Pipeline.EntryPoint qualified as E
import Juvix.Prelude
--- | Top modules cache
-newtype ModulesCache = ModulesCache
- {_cachedModules :: HashMap Concrete.ModuleIndex Internal.Module}
-
data InternalResult = InternalResult
{ _resultScoper :: Concrete.ScoperResult,
- _resultTable :: InfoTable,
- _resultModules :: NonEmpty Module,
- _resultDepInfo :: NameDependencyInfo,
- _resultModulesCache :: ModulesCache
+ _resultInternalModule :: InternalModule,
+ _resultModule :: Module
}
makeLenses ''InternalResult
-makeLenses ''ModulesCache
-
-internalResultEntryPoint :: Lens' InternalResult E.EntryPoint
-internalResultEntryPoint = resultScoper . Concrete.resultParserResult . Concrete.resultEntry
diff --git a/src/Juvix/Compiler/Internal/Translation/FromConcrete/NamedArguments.hs b/src/Juvix/Compiler/Internal/Translation/FromConcrete/NamedArguments.hs
index 59e8855bc2..61ac4aa606 100644
--- a/src/Juvix/Compiler/Internal/Translation/FromConcrete/NamedArguments.hs
+++ b/src/Juvix/Compiler/Internal/Translation/FromConcrete/NamedArguments.hs
@@ -1,7 +1,5 @@
module Juvix.Compiler.Internal.Translation.FromConcrete.NamedArguments
( runNamedArguments,
- NameSignatures,
- ConstructorNameSignatures,
DesugaredNamedApplication,
dnamedAppIdentifier,
dnamedAppArgs,
@@ -23,9 +21,7 @@ import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error
import Juvix.Compiler.Internal.Extra.Base qualified as Internal
import Juvix.Prelude
-type NameSignatures = HashMap NameId (NameSignature 'Scoped)
-
-type ConstructorNameSignatures = HashMap NameId (RecordNameSignature 'Scoped)
+type NameSignatures = HashMap S.NameId (NameSignature 'Scoped)
data BuilderState = BuilderState
{ _stateRemainingArgs :: [ArgumentBlock 'Scoped],
diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal.hs
index 6e92708b8c..10685fa80e 100644
--- a/src/Juvix/Compiler/Internal/Translation/FromInternal.hs
+++ b/src/Juvix/Compiler/Internal/Translation/FromInternal.hs
@@ -1,7 +1,5 @@
module Juvix.Compiler.Internal.Translation.FromInternal
- ( module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Reachability,
- typeChecking,
- typeCheckingNew,
+ ( typeCheckingNew,
typeCheckExpression,
typeCheckExpressionType,
typeCheckImport,
@@ -9,16 +7,16 @@ module Juvix.Compiler.Internal.Translation.FromInternal
where
import Data.HashMap.Strict qualified as HashMap
-import Juvix.Compiler.Builtins.Effect
import Juvix.Compiler.Concrete.Data.Highlight.Input
+import Juvix.Compiler.Internal.Data.LocalVars
import Juvix.Compiler.Internal.Language
-import Juvix.Compiler.Internal.Pretty
import Juvix.Compiler.Internal.Translation.FromConcrete.Data.Context as Internal
-import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Reachability
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking
import Juvix.Compiler.Pipeline.Artifacts
import Juvix.Compiler.Pipeline.EntryPoint
+import Juvix.Compiler.Store.Extra
+import Juvix.Compiler.Store.Language
import Juvix.Data.Effect.NameIdGen
import Juvix.Prelude hiding (fromEither)
@@ -28,12 +26,13 @@ typeCheckExpressionType ::
Expression ->
Sem r TypedExpression
typeCheckExpressionType exp = do
+ -- TODO: refactor: modules outside of REPL should not refer to Artifacts
table <- extendedTableReplArtifacts exp
runTypesTableArtifacts
- . ignoreHighlightBuilder
. runFunctionsTableArtifacts
. runBuiltinsArtifacts
. runNameIdGenArtifacts
+ . ignoreHighlightBuilder
. runReader table
. ignoreOutput @Example
. withEmptyLocalVars
@@ -49,89 +48,39 @@ typeCheckExpression ::
Sem r Expression
typeCheckExpression exp = (^. typedExpression) <$> typeCheckExpressionType exp
-typeCheckImport ::
- (Members '[Reader EntryPoint, Error JuvixError, State Artifacts, Termination] r) =>
- Import ->
- Sem r Import
-typeCheckImport i = do
- artiTable <- gets (^. artifactInternalTypedTable)
- let table = buildTable [i ^. importModule . moduleIxModule] <> artiTable
- modify (set artifactInternalTypedTable table)
- mapError (JuvixError @TypeCheckerError)
- . runTypesTableArtifacts
- . runFunctionsTableArtifacts
- . ignoreHighlightBuilder
- . runBuiltinsArtifacts
- . runNameIdGenArtifacts
- . ignoreOutput @Example
- . runReader table
- . withEmptyLocalVars
- -- TODO Store cache in Artifacts and use it here
- . evalCacheEmpty checkModuleNoCache
- $ checkTable >> checkImport i
-
-typeChecking ::
- forall r.
- (Members '[HighlightBuilder, Error JuvixError, Builtins, NameIdGen] r) =>
- Sem (Termination ': r) Internal.InternalResult ->
- Sem r InternalTypedResult
-typeChecking a = do
- (termin, (res, table, (normalized, (idens, (funs, r))))) <- runTermination iniTerminationState $ do
- res <- a
- let table :: InfoTable
- table = buildTable (res ^. Internal.resultModules)
-
- entryPoint :: EntryPoint
- entryPoint = res ^. Internal.internalResultEntryPoint
- fmap (res,table,)
- . runOutputList
- . runReader entryPoint
- . runState (mempty :: TypesTable)
- . runState (mempty :: FunctionsTable)
- . runReader table
- . mapError (JuvixError @TypeCheckerError)
- . evalCacheEmpty checkModuleNoCache
- $ checkTable >> mapM checkModule (res ^. Internal.resultModules)
- return
- InternalTypedResult
- { _resultInternalResult = res,
- _resultModules = r,
- _resultTermination = termin,
- _resultNormalized = HashMap.fromList [(e ^. exampleId, e ^. exampleExpression) | e <- normalized],
- _resultIdenTypes = idens,
- _resultFunctions = funs,
- _resultInfoTable = table
- }
+typeCheckImport :: Import -> Sem r Import
+typeCheckImport = return
typeCheckingNew ::
forall r.
- (Members '[HighlightBuilder, Error JuvixError, Builtins, NameIdGen] r) =>
+ (Members '[HighlightBuilder, Reader EntryPoint, Error JuvixError, NameIdGen, Reader ModuleTable] r) =>
Sem (Termination ': r) InternalResult ->
Sem r InternalTypedResult
typeCheckingNew a = do
- (termin, (res, table, (normalized, (idens, (funs, r))))) <- runTermination iniTerminationState $ do
- res :: InternalResult <- a
- let table :: InfoTable
- table = buildTable (res ^. Internal.resultModules)
-
- entryPoint :: EntryPoint
- entryPoint = res ^. Internal.internalResultEntryPoint
- fmap (res,table,)
+ (termin, (res, (normalized, (idens, (funs, r))))) <- runTermination iniTerminationState $ do
+ res <- a
+ itab <- getInternalModuleTable <$> ask
+ let md :: InternalModule
+ md = res ^. Internal.resultInternalModule
+ itab' :: InternalModuleTable
+ itab' = insertInternalModule itab md
+ table :: InfoTable
+ table = computeCombinedInfoTable itab'
+ fmap (res,)
. runOutputList
- . runReader entryPoint
- . runState (mempty :: TypesTable)
- . runState (mempty :: FunctionsTable)
+ . runState (computeTypesTable itab')
+ . runState (computeFunctionsTable itab')
. runReader table
. mapError (JuvixError @TypeCheckerError)
- . evalCacheEmpty checkModuleNoCache
- $ checkTable >> mapM checkModule (res ^. Internal.resultModules)
+ $ checkTable >> checkModule (res ^. Internal.resultModule)
+ let md = computeInternalModule idens funs r
return
InternalTypedResult
- { _resultInternalResult = res,
- _resultModules = r,
+ { _resultInternal = res,
+ _resultModule = r,
+ _resultInternalModule = md,
_resultTermination = termin,
_resultNormalized = HashMap.fromList [(e ^. exampleId, e ^. exampleExpression) | e <- normalized],
_resultIdenTypes = idens,
- _resultFunctions = funs,
- _resultInfoTable = table
+ _resultFunctions = funs
}
diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/ArityChecking/Data/Context.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/ArityChecking/Data/Context.hs
new file mode 100644
index 0000000000..ca1e8f5d6f
--- /dev/null
+++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/ArityChecking/Data/Context.hs
@@ -0,0 +1,13 @@
+module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.ArityChecking.Data.Context where
+
+import Juvix.Compiler.Internal.Language
+import Juvix.Compiler.Internal.Translation.FromConcrete.Data.Context
+import Juvix.Prelude
+
+data InternalArityResult = InternalArityResult
+ { _resultInternal :: InternalResult,
+ _resultModule :: Module,
+ _resultInternalModule :: InternalModule
+ }
+
+makeLenses ''InternalArityResult
diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/Positivity/Checker.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/Positivity/Checker.hs
index a7a9171deb..d6494866d3 100644
--- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/Positivity/Checker.hs
+++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/Positivity/Checker.hs
@@ -23,7 +23,7 @@ type CheckPositivityEffects r =
r
data CheckPositivityArgs = CheckPositivityArgs
- { _checkPositivityArgsInductive :: InductiveDef,
+ { _checkPositivityArgsInductive :: InductiveInfo,
_checkPositivityArgsConstructorName :: Name,
_checkPositivityArgsInductiveName :: Name,
_checkPositivityArgsRecursionLimit :: Int,
@@ -36,22 +36,22 @@ makeLenses ''CheckPositivityArgs
checkPositivity ::
forall r.
(CheckPositivityEffects r) =>
- InductiveDef ->
+ InductiveInfo ->
Sem r ()
-checkPositivity ty = do
+checkPositivity indInfo = do
unlessM (asks (^. E.entryPointNoPositivity)) $
- forM_ (ty ^. inductiveConstructors) $ \ctor -> do
- unless (ty ^. inductivePositive) $ do
+ forM_ (indInfo ^. inductiveInfoConstructors) $ \ctorName -> do
+ ctor <- asks (fromJust . HashMap.lookup ctorName . (^. infoConstructors))
+ unless (indInfo ^. inductiveInfoPositive) $ do
numInductives <- HashMap.size <$> asks (^. infoInductives)
forM_
- (constructorArgs (ctor ^. inductiveConstructorType))
+ (constructorArgs (ctor ^. constructorInfoType))
$ \typeOfConstr ->
checkStrictlyPositiveOccurrences
( CheckPositivityArgs
- { _checkPositivityArgsInductive = ty,
- _checkPositivityArgsConstructorName =
- ctor ^. inductiveConstructorName,
- _checkPositivityArgsInductiveName = ty ^. inductiveName,
+ { _checkPositivityArgsInductive = indInfo,
+ _checkPositivityArgsConstructorName = ctorName,
+ _checkPositivityArgsInductiveName = indInfo ^. inductiveInfoName,
_checkPositivityArgsRecursionLimit = numInductives,
_checkPositivityArgsErrorReference = Nothing,
_checkPositivityArgsTypeOfConstructor = typeOfConstr
@@ -67,14 +67,14 @@ checkStrictlyPositiveOccurrences p = do
typeOfConstr <- strongNormalize (p ^. checkPositivityArgsTypeOfConstructor)
go False typeOfConstr
where
- ty = p ^. checkPositivityArgsInductive
+ indInfo = p ^. checkPositivityArgsInductive
ctorName = p ^. checkPositivityArgsConstructorName
name = p ^. checkPositivityArgsInductiveName
recLimit = p ^. checkPositivityArgsRecursionLimit
ref = p ^. checkPositivityArgsErrorReference
indName :: Name
- indName = ty ^. inductiveName
+ indName = indInfo ^. inductiveInfoName
{- The following `go` function determines if there is any negative
occurence of the symbol `name` in the given expression. The `inside` flag
@@ -139,7 +139,8 @@ checkStrictlyPositiveOccurrences p = do
IdenVar name'
| not inside -> return ()
| name == name' -> throwNegativePositonError expr
- | name' `elem` ty ^.. inductiveParameters . each . inductiveParamName -> modify (HashSet.insert name')
+ | name' `elem` indInfo ^.. inductiveInfoParameters . each . inductiveParamName -> modify (HashSet.insert name')
+ | otherwise -> return ()
_ -> return ()
goApp :: Application -> Sem r ()
@@ -154,19 +155,19 @@ checkStrictlyPositiveOccurrences p = do
throwTypeAsArgumentOfBoundVarError var
ExpressionIden (IdenInductive ty') -> do
when (inside && name == ty') (throwNegativePositonError expr)
- InductiveInfo indType' <- lookupInductive ty'
+ indInfo' <- lookupInductive ty'
{- We now need to know whether `name` negatively occurs at
`indTy'` or not. The way to know is by checking that the type ty'
preserves the positivity condition, i.e., its type parameters are
no negative.
-}
- let paramsTy' = indType' ^. inductiveParameters
- goInductiveApp indType' (zip paramsTy' (toList args))
+ let paramsTy' = indInfo' ^. inductiveInfoParameters
+ goInductiveApp indInfo' (zip paramsTy' (toList args))
_ -> return ()
- goInductiveApp :: InductiveDef -> [(InductiveParameter, Expression)] -> Sem r ()
- goInductiveApp indType' = \case
+ goInductiveApp :: InductiveInfo -> [(InductiveParameter, Expression)] -> Sem r ()
+ goInductiveApp indInfo' = \case
[] -> return ()
(InductiveParameter pName' _ty', tyArg) : ps -> do
negParms :: NegativeTypeParameters <- get
@@ -175,15 +176,15 @@ checkStrictlyPositiveOccurrences p = do
(HashSet.member pName' negParms)
(throwNegativePositonError tyArg)
when (recLimit > 0) $
- forM_ (indType' ^. inductiveConstructors) $ \ctor' -> do
- let ctorName' = ctor' ^. inductiveConstructorName
- errorRef = fromMaybe tyArg ref
- args = constructorArgs (ctor' ^. inductiveConstructorType)
+ forM_ (indInfo' ^. inductiveInfoConstructors) $ \ctorName' -> do
+ ctorType' <- lookupConstructorType ctorName'
+ let errorRef = fromMaybe tyArg ref
+ args = constructorArgs ctorType'
mapM_
( \tyConstr' ->
checkStrictlyPositiveOccurrences
CheckPositivityArgs
- { _checkPositivityArgsInductive = indType',
+ { _checkPositivityArgsInductive = indInfo',
_checkPositivityArgsConstructorName = ctorName',
_checkPositivityArgsInductiveName = pName',
_checkPositivityArgsRecursionLimit = recLimit - 1,
@@ -192,7 +193,7 @@ checkStrictlyPositiveOccurrences p = do
}
)
args
- goInductiveApp indType' ps
+ goInductiveApp indInfo' ps
throwNegativePositonError :: Expression -> Sem r ()
throwNegativePositonError expr = do
diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/Reachability.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/Reachability.hs
deleted file mode 100644
index 7bfe9db0b6..0000000000
--- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/Reachability.hs
+++ /dev/null
@@ -1,63 +0,0 @@
-module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Reachability (filterUnreachable) where
-
-import Juvix.Compiler.Internal.Data.NameDependencyInfo
-import Juvix.Compiler.Internal.Language
-import Juvix.Compiler.Internal.Translation.FromConcrete.Data.Context
-import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context qualified as Typed
-import Juvix.Compiler.Pipeline.EntryPoint
-import Juvix.Prelude
-
-type MCache = Cache ModuleIndex Module
-
-filterUnreachable :: (Members '[Reader EntryPoint] r) => Typed.InternalTypedResult -> Sem r Typed.InternalTypedResult
-filterUnreachable r = do
- asks (^. entryPointSymbolPruningMode) >>= \case
- KeepAll -> return r
- FilterUnreachable -> return (set Typed.resultModules modules' r)
- where
- depInfo = r ^. Typed.resultInternalResult . resultDepInfo
- modules = r ^. Typed.resultModules
- modules' =
- run
- . runReader depInfo
- . evalCacheEmpty goModuleNoCache
- $ mapM goModule modules
-
-askIsReachable :: (Member (Reader NameDependencyInfo) r) => Name -> Sem r Bool
-askIsReachable n = do
- depInfo <- ask
- return (isReachable depInfo n)
-
-returnIfReachable :: (Member (Reader NameDependencyInfo) r) => Name -> a -> Sem r (Maybe a)
-returnIfReachable n a = do
- r <- askIsReachable n
- return (guard r $> a)
-
-goModuleNoCache :: forall r. (Members '[Reader NameDependencyInfo, MCache] r) => ModuleIndex -> Sem r Module
-goModuleNoCache (ModuleIndex m) = do
- body' <- goBody (m ^. moduleBody)
- return (set moduleBody body' m)
- where
- goBody :: ModuleBody -> Sem r ModuleBody
- goBody body = do
- _moduleStatements <- mapMaybeM goMutual (body ^. moduleStatements)
- _moduleImports <- mapM goImport (body ^. moduleImports)
- return ModuleBody {..}
-
-goModule :: (Members '[Reader NameDependencyInfo, MCache] r) => Module -> Sem r Module
-goModule = cacheGet . ModuleIndex
-
-goModuleIndex :: (Members '[Reader NameDependencyInfo, MCache] r) => ModuleIndex -> Sem r ModuleIndex
-goModuleIndex = fmap ModuleIndex . cacheGet
-
--- note that the first mutual statement is reachable iff all are reachable
-goMutual :: forall r. (Member (Reader NameDependencyInfo) r) => MutualBlock -> Sem r (Maybe MutualBlock)
-goMutual b@(MutualBlock (m :| _)) = case m of
- StatementFunction f -> returnIfReachable (f ^. funDefName) b
- StatementInductive f -> returnIfReachable (f ^. inductiveName) b
- StatementAxiom ax -> returnIfReachable (ax ^. axiomName) b
-
-goImport :: forall r. (Members '[Reader NameDependencyInfo, MCache] r) => Import -> Sem r Import
-goImport i = do
- _importModule <- goModuleIndex (i ^. importModule)
- return Import {..}
diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/Termination/Checker.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/Termination/Checker.hs
index d119150618..aa6a389f70 100644
--- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/Termination/Checker.hs
+++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/Termination/Checker.hs
@@ -48,9 +48,6 @@ evalTermination s = fmap snd . runTermination s
execTermination :: (Members '[Error JuvixError] r) => TerminationState -> Sem (Termination ': r) a -> Sem r TerminationState
execTermination s = fmap fst . runTermination s
-instance Scannable Import where
- buildCallMap = buildCallMap . (^. importModule . moduleIxModule)
-
instance Scannable Module where
buildCallMap =
run
diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking.hs
index 7b3aeb7a47..493778aa57 100644
--- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking.hs
+++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking.hs
@@ -1,12 +1,14 @@
module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking
( module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.CheckerNew,
module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Inference,
- module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.FunctionsTable,
module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context,
+ module Juvix.Compiler.Store.Internal.Data.FunctionsTable,
+ module Juvix.Compiler.Store.Internal.Data.TypesTable,
)
where
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.CheckerNew
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context
-import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.FunctionsTable
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Inference
+import Juvix.Compiler.Store.Internal.Data.FunctionsTable
+import Juvix.Compiler.Store.Internal.Data.TypesTable
diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Checker.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Checker.hs
deleted file mode 100644
index a839b7ca42..0000000000
--- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Checker.hs
+++ /dev/null
@@ -1,962 +0,0 @@
-module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Checker
- ( module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Checker,
- module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Error,
- )
-where
-
-import Data.HashMap.Strict qualified as HashMap
-import Data.HashSet qualified as HashSet
-import Juvix.Compiler.Builtins.Effect
-import Juvix.Compiler.Concrete.Data.Highlight.Input
-import Juvix.Compiler.Internal.Data.Cast
-import Juvix.Compiler.Internal.Data.CoercionInfo
-import Juvix.Compiler.Internal.Data.InstanceInfo
-import Juvix.Compiler.Internal.Data.LocalVars
-import Juvix.Compiler.Internal.Data.TypedHole
-import Juvix.Compiler.Internal.Extra
-import Juvix.Compiler.Internal.Pretty
-import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Positivity.Checker
-import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker (Termination)
-import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context
-import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Inference
-import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Error
-import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Traits.Resolver
-import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Traits.Termination
-import Juvix.Compiler.Pipeline.EntryPoint
-import Juvix.Data.Effect.NameIdGen
-import Juvix.Prelude hiding (fromEither)
-
-type MCache = Cache ModuleIndex Module
-
-registerConstructor :: (Members '[HighlightBuilder, State TypesTable, Reader InfoTable] r) => ConstructorDef -> Sem r ()
-registerConstructor ctr = do
- ty <- lookupConstructorType (ctr ^. inductiveConstructorName)
- registerNameIdType (ctr ^. inductiveConstructorName . nameId) ty
-
-registerNameIdType :: (Members '[HighlightBuilder, State TypesTable, Reader InfoTable] r) => NameId -> Expression -> Sem r ()
-registerNameIdType uid ty = do
- modify (HashMap.insert uid ty)
- modify (set (highlightTypes . at uid) (Just ty))
-
-checkTable ::
- (Members '[Reader InfoTable, Error TypeCheckerError] r) =>
- Sem r ()
-checkTable = do
- tab <- ask
- let s = toList $ cyclicCoercions (tab ^. infoCoercions)
- whenJust (nonEmpty s) $
- throw
- . ErrCoercionCycles
- . CoercionCycles
-
-checkModule ::
- (Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache] r) =>
- Module ->
- Sem r Module
-checkModule = cacheGet . ModuleIndex
-
-checkModuleIndex ::
- (Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache] r) =>
- ModuleIndex ->
- Sem r ModuleIndex
-checkModuleIndex = fmap ModuleIndex . cacheGet
-
-checkModuleNoCache ::
- (Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache, Termination] r) =>
- ModuleIndex ->
- Sem r Module
-checkModuleNoCache (ModuleIndex Module {..}) = do
- _moduleBody' <-
- evalState (mempty :: NegativeTypeParameters)
- . checkModuleBody
- $ _moduleBody
- _moduleExamples <- mapM checkExample _moduleExamples
- return
- Module
- { _moduleBody = _moduleBody',
- _moduleName,
- _moduleExamples,
- _modulePragmas
- }
-
-checkModuleBody ::
- (Members '[HighlightBuilder, Reader EntryPoint, State NegativeTypeParameters, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache, Termination] r) =>
- ModuleBody ->
- Sem r ModuleBody
-checkModuleBody ModuleBody {..} = do
- _moduleImports' <- mapM checkImport _moduleImports
- _moduleStatements' <- mapM checkMutualBlock _moduleStatements
- return
- ModuleBody
- { _moduleStatements = _moduleStatements',
- _moduleImports = _moduleImports'
- }
-
-checkImport ::
- (Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache, Termination] r) =>
- Import ->
- Sem r Import
-checkImport = traverseOf importModule checkModuleIndex
-
-checkMutualBlock ::
- (Members '[HighlightBuilder, Reader EntryPoint, State NegativeTypeParameters, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, Termination] r) =>
- MutualBlock ->
- Sem r MutualBlock
-checkMutualBlock s = runReader emptyLocalVars (checkTopMutualBlock s)
-
-checkInductiveDef ::
- forall r.
- (Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, State TypesTable, State NegativeTypeParameters, Output Example, Builtins, Termination, Output TypedHole, Output CastHole] r) =>
- InductiveDef ->
- Sem r InductiveDef
-checkInductiveDef InductiveDef {..} = runInferenceDef $ do
- constrs' <- mapM goConstructor _inductiveConstructors
- ty <- lookupInductiveType _inductiveName
- registerNameIdType (_inductiveName ^. nameId) ty
- examples' <- mapM checkExample _inductiveExamples
- inductiveType' <- runReader paramLocals (checkDefType _inductiveType)
- let d =
- InductiveDef
- { _inductiveConstructors = constrs',
- _inductiveExamples = examples',
- _inductiveType = inductiveType',
- _inductiveName,
- _inductiveBuiltin,
- _inductivePositive,
- _inductiveParameters,
- _inductiveTrait,
- _inductivePragmas
- }
- checkPositivity d
- return d
- where
- paramLocals :: LocalVars
- paramLocals =
- LocalVars
- { _localTypes = HashMap.fromList [(p ^. inductiveParamName, p ^. inductiveParamType) | p <- _inductiveParameters],
- _localTyMap = mempty
- }
- goConstructor :: ConstructorDef -> Sem (Inference ': r) ConstructorDef
- goConstructor ConstructorDef {..} = do
- expectedRetTy <- lookupConstructorReturnType _inductiveConstructorName
- cty' <-
- runReader paramLocals $
- checkIsType (getLoc _inductiveConstructorType) _inductiveConstructorType
- examples' <- mapM checkExample _inductiveConstructorExamples
- whenJustM (matchTypes expectedRetTy ret) (const (errRet expectedRetTy))
- let c' =
- ConstructorDef
- { _inductiveConstructorType = cty',
- _inductiveConstructorExamples = examples',
- _inductiveConstructorName,
- _inductiveConstructorPragmas
- }
- registerConstructor c'
- return c'
- where
- ret = snd (viewConstructorType _inductiveConstructorType)
- errRet :: Expression -> Sem (Inference ': r) a
- errRet expected =
- throw
- ( ErrWrongReturnType
- WrongReturnType
- { _wrongReturnTypeConstructorName = _inductiveConstructorName,
- _wrongReturnTypeExpected = expected,
- _wrongReturnTypeActual = ret
- }
- )
-
--- TODO should we register functions (type synonyms) first?
-checkTopMutualBlock ::
- (Members '[HighlightBuilder, State NegativeTypeParameters, Reader EntryPoint, Reader LocalVars, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, Termination] r) =>
- MutualBlock ->
- Sem r MutualBlock
-checkTopMutualBlock (MutualBlock ds) =
- MutualBlock <$> runInferenceDefs (mapM checkMutualStatement ds)
-
-checkMutualStatement ::
- (Members '[HighlightBuilder, State NegativeTypeParameters, Reader EntryPoint, Inference, Reader LocalVars, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, Termination] r) =>
- MutualStatement ->
- Sem r MutualStatement
-checkMutualStatement = \case
- StatementFunction f -> StatementFunction <$> resolveInstanceHoles (resolveCastHoles (checkFunctionDef f))
- StatementInductive f -> StatementInductive <$> resolveInstanceHoles (resolveCastHoles (checkInductiveDef f))
- StatementAxiom ax -> do
- registerNameIdType (ax ^. axiomName . nameId) (ax ^. axiomType)
- return $ StatementAxiom ax
-
-checkFunctionDef ::
- forall r.
- (Members '[HighlightBuilder, Reader LocalVars, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, Inference, Termination, Output TypedHole, Output CastHole] r) =>
- FunctionDef ->
- Sem r FunctionDef
-checkFunctionDef FunctionDef {..} = do
- funDef <- do
- _funDefType' <- checkDefType _funDefType
- _funDefExamples' <- mapM checkExample _funDefExamples
- registerIdenType _funDefName _funDefType'
- _funDefBody' <- checkExpression _funDefType' _funDefBody
- let params = fst (unfoldFunType _funDefType')
- _funDefArgsInfo' <- checkArgsInfo params
- return
- FunctionDef
- { _funDefBody = _funDefBody',
- _funDefType = _funDefType',
- _funDefExamples = _funDefExamples',
- _funDefArgsInfo = _funDefArgsInfo',
- _funDefName,
- _funDefTerminating,
- _funDefInstance,
- _funDefCoercion,
- _funDefBuiltin,
- _funDefPragmas
- }
- when _funDefInstance $
- checkInstanceType funDef
- when _funDefCoercion $
- checkCoercionType funDef
- registerFunctionDef funDef
- rememberFunctionDef funDef
- return funDef
- where
- -- Since default arguments come from the left of the : then it must be that
- -- there are at least n FunctionParameter
- checkArgsInfo :: [FunctionParameter] -> Sem r [ArgInfo]
- checkArgsInfo allparams = execOutputList $ do
- go (zipExact infos params)
- where
- params = take n allparams
- infos = _funDefArgsInfo
- n = length infos
- go :: [(ArgInfo, FunctionParameter)] -> Sem (Output ArgInfo ': r) ()
- go = \case
- [] -> return ()
- (me, p) : rest -> do
- me' <- traverseOf (argInfoDefault . _Just) (checkExpression (p ^. paramType)) me
- output me'
- withLocalTypeMaybe (p ^. paramName) (p ^. paramType) (go rest)
-
-checkIsType ::
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Builtins, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole] r) =>
- Interval ->
- Expression ->
- Sem r Expression
-checkIsType = checkExpression . smallUniverseE
-
-checkDefType ::
- forall r.
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Builtins, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole] r) =>
- Expression ->
- Sem r Expression
-checkDefType ty = checkIsType loc ty
- where
- loc = getLoc ty
-
-checkInstanceType ::
- forall r.
- (Members '[Error TypeCheckerError, Reader InfoTable, Inference, NameIdGen] r) =>
- FunctionDef ->
- Sem r ()
-checkInstanceType FunctionDef {..} = case mi of
- Just ii@InstanceInfo {..} -> do
- tab <- ask
- unless (isTrait tab _instanceInfoInductive) $
- throw (ErrTargetNotATrait (TargetNotATrait _funDefType))
- is <- subsumingInstances (tab ^. infoInstances) ii
- unless (null is) $
- throw (ErrSubsumedInstance (SubsumedInstance ii is (getLoc _funDefName)))
- let metaVars = HashSet.fromList $ mapMaybe (^. paramName) _instanceInfoArgs
- mapM_ (checkArg tab metaVars ii) _instanceInfoArgs
- Nothing ->
- throw (ErrInvalidInstanceType (InvalidInstanceType _funDefType))
- where
- mi =
- instanceFromTypedExpression
- ( TypedExpression
- { _typedType = _funDefType,
- _typedExpression = ExpressionIden (IdenFunction _funDefName)
- }
- )
-
- checkArg :: InfoTable -> HashSet VarName -> InstanceInfo -> FunctionParameter -> Sem r ()
- checkArg tab metaVars ii fp@FunctionParameter {..} = case _paramImplicit of
- Implicit -> return ()
- Explicit -> throw (ErrExplicitInstanceArgument (ExplicitInstanceArgument fp))
- ImplicitInstance -> case traitFromExpression metaVars _paramType of
- Just app@InstanceApp {..}
- | isTrait tab _instanceAppHead ->
- checkTraitTermination app ii
- _ ->
- throw (ErrNotATrait (NotATrait _paramType))
-
-checkInstanceParam :: (Member (Error TypeCheckerError) r) => InfoTable -> Expression -> Sem r ()
-checkInstanceParam tab ty = case traitFromExpression mempty ty of
- Just InstanceApp {..} | isTrait tab _instanceAppHead -> return ()
- _ -> throw (ErrNotATrait (NotATrait ty))
-
-checkCoercionType ::
- forall r.
- (Members '[Error TypeCheckerError, Reader InfoTable, Inference] r) =>
- FunctionDef ->
- Sem r ()
-checkCoercionType FunctionDef {..} = case mi of
- Just CoercionInfo {..} -> do
- tab <- ask
- unless (isTrait tab _coercionInfoInductive) $
- throw (ErrTargetNotATrait (TargetNotATrait _funDefType))
- unless (isTrait tab (_coercionInfoTarget ^. instanceAppHead)) $
- throw (ErrInvalidCoercionType (InvalidCoercionType _funDefType))
- mapM_ checkArg _coercionInfoArgs
- Nothing ->
- throw (ErrInvalidCoercionType (InvalidCoercionType _funDefType))
- where
- mi =
- coercionFromTypedExpression
- ( TypedExpression
- { _typedType = _funDefType,
- _typedExpression = ExpressionIden (IdenFunction _funDefName)
- }
- )
-
- checkArg :: FunctionParameter -> Sem r ()
- checkArg fp@FunctionParameter {..} = case _paramImplicit of
- Implicit -> return ()
- Explicit -> throw (ErrWrongCoercionArgument (WrongCoercionArgument fp))
- ImplicitInstance -> throw (ErrWrongCoercionArgument (WrongCoercionArgument fp))
-
-checkExample ::
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, Builtins, NameIdGen, Output Example, State TypesTable, Termination] r) =>
- Example ->
- Sem r Example
-checkExample e = do
- e' <- withEmptyLocalVars (runInferenceDef (traverseOf exampleExpression (fmap (^. typedExpression) . inferExpression Nothing >=> strongNormalize) e))
- output e'
- return e'
-
-checkExpression ::
- forall r.
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, Builtins, NameIdGen, Reader LocalVars, Inference, Output Example, Output TypedHole, Output CastHole, State TypesTable, Termination] r) =>
- Expression ->
- Expression ->
- Sem r Expression
-checkExpression expectedTy e = do
- e' <- inferExpression' (Just expectedTy) e
- let inferredType = e' ^. typedType
- whenJustM (matchTypes expectedTy inferredType) (const (err inferredType))
- return (e' ^. typedExpression)
- where
- err :: Expression -> Sem r a
- err inferred = do
- inferred' <- strongNormalize inferred
- expected' <- strongNormalize expectedTy
- throw $
- ErrWrongType
- ( WrongType
- { _wrongTypeThing = Left e,
- _wrongTypeThingWithHoles = Nothing,
- _wrongTypeActual = inferred',
- _wrongTypeExpected = expected'
- }
- )
-
-resolveCastHoles ::
- forall a r.
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, Builtins, NameIdGen, Inference, Output Example, Output TypedHole, State TypesTable, Termination] r) =>
- Sem (Output CastHole ': r) a ->
- Sem r a
-resolveCastHoles s = do
- (hs, e) <- runOutputList s
- let (hs1, hs2) = partition (isCastInt . (^. castHoleType)) hs
- mapM_ (go getIntTy) hs1
- mapM_ (go getNatTy) hs2
- return e
- where
- go :: (Interval -> Sem r Expression) -> CastHole -> Sem r ()
- go mkTy CastHole {..} = do
- m <- queryMetavarFinal _castHoleHole
- case m of
- Just {} -> return ()
- Nothing -> do
- ty <- mkTy (getLoc _castHoleHole)
- void (matchTypes (ExpressionHole _castHoleHole) ty)
-
- mkBuiltinInductive :: BuiltinInductive -> Interval -> Sem r Expression
- mkBuiltinInductive b i = fmap (ExpressionIden . IdenInductive) (getBuiltinName i b)
-
- getIntTy :: Interval -> Sem r Expression
- getIntTy = mkBuiltinInductive BuiltinInt
-
- getNatTy :: Interval -> Sem r Expression
- getNatTy = mkBuiltinInductive BuiltinNat
-
-resolveInstanceHoles ::
- forall a r.
- (HasExpressions a) =>
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, Builtins, NameIdGen, Inference, Output Example, State TypesTable, Termination] r) =>
- Sem (Output TypedHole ': r) a ->
- Sem r a
-resolveInstanceHoles s = do
- (hs, e) <- runOutputList s
- ts <- mapM goResolve hs
- let subs = HashMap.fromList (zipExact (map (^. typedHoleHole) hs) ts)
- subsInstanceHoles subs e
- where
- goResolve :: TypedHole -> Sem r Expression
- goResolve h@TypedHole {..} = do
- t <- resolveTraitInstance h
- resolveInstanceHoles $ resolveCastHoles $ runReader _typedHoleLocalVars $ checkExpression _typedHoleType t
-
-checkFunctionParameter ::
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Builtins, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole] r) =>
- FunctionParameter ->
- Sem r FunctionParameter
-checkFunctionParameter (FunctionParameter mv i e) = do
- e' <- checkIsType (getLoc e) e
- when (i == ImplicitInstance) $ do
- tab <- ask
- checkInstanceParam tab e'
- return (FunctionParameter mv i e')
-
-checkConstructorDef ::
- ( Members
- '[ Reader EntryPoint,
- Reader InfoTable,
- Error TypeCheckerError,
- State NegativeTypeParameters
- ]
- r
- ) =>
- InductiveDef ->
- ConstructorDef ->
- Sem r ()
-checkConstructorDef ty ctor = checkConstructorReturnType ty ctor
-
-checkConstructorReturnType ::
- (Members '[Reader InfoTable, Error TypeCheckerError] r) =>
- InductiveDef ->
- ConstructorDef ->
- Sem r ()
-checkConstructorReturnType indType ctor = do
- let ctorName = ctor ^. inductiveConstructorName
- tyName = indType ^. inductiveName
- indParams = map (^. inductiveParamName) (indType ^. inductiveParameters)
- ctorReturnType = snd (viewConstructorType (ctor ^. inductiveConstructorType))
- expectedReturnType =
- foldExplicitApplication
- (ExpressionIden (IdenInductive tyName))
- (map (ExpressionIden . IdenVar) indParams)
- when
- (ctorReturnType /= expectedReturnType)
- ( throw
- ( ErrWrongReturnType
- ( WrongReturnType
- { _wrongReturnTypeConstructorName = ctorName,
- _wrongReturnTypeExpected = expectedReturnType,
- _wrongReturnTypeActual = ctorReturnType
- }
- )
- )
- )
-
-inferExpression ::
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Builtins, Output Example, State TypesTable, Termination] r) =>
- Maybe Expression -> -- type hint
- Expression ->
- Sem r TypedExpression
-inferExpression hint e = resolveInstanceHoles $ resolveCastHoles $ inferExpression' hint e
-
-lookupVar :: (Members '[Reader LocalVars, Reader InfoTable] r) => Name -> Sem r Expression
-lookupVar v = do
- locals <- asks (^. localTypes)
- return
- ( fromMaybe
- err
- ( locals ^. at v
- )
- )
- where
- err = error $ "internal error: could not find var " <> ppTrace v <> " at " <> ppTrace (getLoc v)
-
--- | helper function for function clauses and lambda functions
-checkClause ::
- forall r.
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Builtins, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole] r) =>
- -- | Type
- Expression ->
- -- | Arguments
- [PatternArg] ->
- -- | Body
- Expression ->
- Sem r ([PatternArg], Expression) -- (Checked patterns, Checked body)
-checkClause clauseType clausePats body = do
- locals0 <- ask
- (localsPats, (checkedPatterns, bodyType)) <- helper clausePats clauseType
- let locals' = locals0 <> localsPats
- bodyTy' <- substitutionE (localsToSubsE locals') bodyType
- checkedBody <- local (const locals') (checkExpression bodyTy' body)
- return (checkedPatterns, checkedBody)
- where
- helper :: [PatternArg] -> Expression -> Sem r (LocalVars, ([PatternArg], Expression))
- helper pats ty = runState emptyLocalVars (go pats ty)
-
- go :: [PatternArg] -> Expression -> Sem (State LocalVars ': r) ([PatternArg], Expression)
- go pats bodyTy = case pats of
- [] -> return ([], bodyTy)
- (p : ps) -> do
- bodyTy' <- weakNormalize bodyTy
- case bodyTy' of
- ExpressionHole h -> do
- fun <- holeRefineToFunction h
- go pats (ExpressionFunction fun)
- _ -> case unfoldFunType bodyTy' of
- ([], _) -> error "too many patterns"
- (par : pars, ret) -> do
- par' <- checkPattern par p
- first (par' :) <$> go ps (foldFunType pars ret)
-
--- | Refines a hole into a function type. I.e. '_@1' is matched with '_@fresh → _@fresh'
-holeRefineToFunction :: (Members '[Inference, NameIdGen] r) => Hole -> Sem r Function
-holeRefineToFunction h = do
- s <- queryMetavar h
- case s of
- Just h' -> case h' of
- ExpressionFunction f -> return f
- ExpressionHole h'' -> holeRefineToFunction h''
- _ -> error "cannot refine hole to function"
- Nothing -> do
- l <- ExpressionHole <$> freshHole (getLoc h)
- r <- ExpressionHole <$> freshHole (getLoc h)
- let fun = Function (unnamedParameter l) r
- whenJustM (matchTypes (ExpressionHole h) (ExpressionFunction fun)) impossible
- return fun
-
-matchIsImplicit :: (Member (Error TypeCheckerError) r) => IsImplicit -> PatternArg -> Sem r ()
-matchIsImplicit expected actual =
- unless
- (expected == actual ^. patternArgIsImplicit)
- ( throw
- ( ErrArityCheckerError
- ( ErrWrongPatternIsImplicit
- WrongPatternIsImplicit
- { _wrongPatternIsImplicitExpected = expected,
- _wrongPatternIsImplicitActual = actual
- }
- )
- )
- )
-
-checkPattern ::
- forall r.
- (Members '[Reader InfoTable, Error TypeCheckerError, State LocalVars, Inference, NameIdGen, State FunctionsTable] r) =>
- FunctionParameter ->
- PatternArg ->
- Sem r PatternArg
-checkPattern = go
- where
- go :: FunctionParameter -> PatternArg -> Sem r PatternArg
- go argTy patArg = do
- matchIsImplicit (argTy ^. paramImplicit) patArg
- tyVarMap <- localsToSubsE <$> get
- ty <- substitutionE tyVarMap (argTy ^. paramType)
- let pat = patArg ^. patternArgPattern
- name = patArg ^. patternArgName
- whenJust name (\n -> addVar n ty argTy)
- pat' <- case pat of
- PatternVariable v -> addVar v ty argTy $> pat
- PatternWildcardConstructor {} -> impossible
- PatternConstructorApp a -> do
- s <- checkSaturatedInductive ty
- info <- lookupConstructor (a ^. constrAppConstructor)
- let constrIndName = info ^. constructorInfoInductive
- constrName = a ^. constrAppConstructor
- err :: MatchError -> Sem r ()
- err m =
- throw
- ( ErrWrongType
- WrongType
- { _wrongTypeThing = Right pat,
- _wrongTypeThingWithHoles = Nothing,
- _wrongTypeExpected = m ^. matchErrorRight,
- _wrongTypeActual = m ^. matchErrorLeft
- }
- )
- case s of
- Left hole -> do
- let indParams = info ^. constructorInfoInductiveParameters
- numIndParams = length indParams
- indName :: Iden
- indName = IdenInductive (info ^. constructorInfoInductive)
- loc = getLoc a
- paramHoles <- map ExpressionHole <$> replicateM numIndParams (freshHole loc)
- let patternTy = foldApplication (ExpressionIden indName) (map (ApplicationArg Explicit) paramHoles)
- whenJustM
- (matchTypes patternTy (ExpressionHole hole))
- err
- let tyArgs = zipExact indParams paramHoles
- PatternConstructorApp <$> goConstr indName a tyArgs
- Right (ind, tyArgs) -> do
- when
- (ind /= constrIndName)
- ( throw
- ( ErrWrongConstructorType
- WrongConstructorType
- { _wrongCtorTypeName = constrName,
- _wrongCtorTypeExpected = ind,
- _wrongCtorTypeActual = constrIndName
- }
- )
- )
- PatternConstructorApp <$> goConstr (IdenInductive ind) a tyArgs
- return (set patternArgPattern pat' patArg)
- where
- addVar :: VarName -> Expression -> FunctionParameter -> Sem r ()
- addVar v ty argType = do
- modify (addType v ty)
- registerIdenType v ty
- whenJust (argType ^. paramName) (\v' -> modify (addTypeMapping v' v))
- goConstr :: Iden -> ConstructorApp -> [(InductiveParameter, Expression)] -> Sem r ConstructorApp
- goConstr inductivename app@(ConstructorApp c ps _) ctx = do
- (_, psTys) <- constructorArgTypes <$> lookupConstructor c
- psTys' <- mapM (substituteIndParams ctx) psTys
- let expectedNum = length psTys
- w = map unnamedParameter psTys'
- when (expectedNum /= length ps) (throw (appErr app expectedNum))
- pis <- zipWithM go w ps
- let appTy = foldExplicitApplication (ExpressionIden inductivename) (map snd ctx)
- return app {_constrAppType = Just appTy, _constrAppParameters = pis}
- appErr :: ConstructorApp -> Int -> TypeCheckerError
- appErr app expected =
- ErrArityCheckerError
- ( ErrWrongConstructorAppLength
- ( WrongConstructorAppLength
- { _wrongConstructorAppLength = app,
- _wrongConstructorAppLengthExpected = expected
- }
- )
- )
-
- checkSaturatedInductive :: Expression -> Sem r (Either Hole (InductiveName, [(InductiveParameter, Expression)]))
- checkSaturatedInductive ty = do
- i <- viewInductiveApp ty
- case i of
- Left hole -> return (Left hole)
- Right (ind, args) -> do
- params :: [InductiveParameter] <-
- (^. inductiveInfoDef . inductiveParameters)
- <$> lookupInductive ind
- let numArgs = length args
- numParams = length params
- when
- (numArgs < numParams)
- ( throw
- ( ErrTooFewArgumentsIndType
- ( WrongNumberArgumentsIndType
- { _wrongNumberArgumentsIndTypeActualType = ty,
- _wrongNumberArgumentsIndTypeActualNumArgs = numArgs,
- _wrongNumberArgumentsIndTypeExpectedNumArgs = numParams
- }
- )
- )
- )
- when
- (numArgs > numParams)
- ( throw
- ( ErrTooManyArgumentsIndType
- ( WrongNumberArgumentsIndType
- { _wrongNumberArgumentsIndTypeActualType = ty,
- _wrongNumberArgumentsIndTypeActualNumArgs = numArgs,
- _wrongNumberArgumentsIndTypeExpectedNumArgs = numParams
- }
- )
- )
- )
- return (Right (ind, zipExact params args))
-
-inferExpression' ::
- forall r.
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, State TypesTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Output Example, Output TypedHole, Output CastHole, Builtins, Termination] r) =>
- Maybe Expression ->
- Expression ->
- Sem r TypedExpression
-inferExpression' hint e = case e of
- ExpressionIden i -> goIden i
- ExpressionApplication a -> goApplication a
- ExpressionLiteral l -> goLiteral l
- ExpressionFunction f -> goFunction f
- ExpressionHole h -> goHole h
- ExpressionInstanceHole h -> goInstanceHole h
- ExpressionUniverse u -> goUniverse u
- ExpressionSimpleLambda l -> goSimpleLambda l
- ExpressionLambda l -> goLambda l
- ExpressionLet l -> goLet l
- ExpressionCase l -> goCase l
- where
- goLet :: Let -> Sem r TypedExpression
- goLet l = do
- _letClauses <- mapM goLetClause (l ^. letClauses)
- typedBody <- inferExpression' hint (l ^. letExpression)
- return
- TypedExpression
- { _typedType = typedBody ^. typedType,
- _typedExpression =
- ExpressionLet
- Let
- { _letExpression = typedBody ^. typedExpression,
- _letClauses
- }
- }
-
- goLetClause :: LetClause -> Sem r LetClause
- goLetClause = \case
- LetFunDef f -> LetFunDef <$> checkFunctionDef f
- LetMutualBlock b -> LetMutualBlock <$> goMutualLet b
- where
- goMutualLet :: MutualBlockLet -> Sem r MutualBlockLet
- goMutualLet (MutualBlockLet fs) = MutualBlockLet <$> mapM checkFunctionDef fs
-
- goHole :: Hole -> Sem r TypedExpression
- goHole h = do
- void (queryMetavar h)
- return
- TypedExpression
- { _typedExpression = ExpressionHole h,
- _typedType = ExpressionUniverse (SmallUniverse (getLoc h))
- }
-
- goInstanceHole :: InstanceHole -> Sem r TypedExpression
- goInstanceHole h = do
- let ty = fromMaybe impossible hint
- locals <- ask
- output (TypedHole h ty locals)
- return
- TypedExpression
- { _typedType = ty,
- _typedExpression = ExpressionInstanceHole h
- }
-
- goSimpleLambda :: SimpleLambda -> Sem r TypedExpression
- goSimpleLambda (SimpleLambda (SimpleBinder v ty) b) = do
- b' <- inferExpression' Nothing b
- let smallUni = smallUniverseE (getLoc ty)
- ty' <- checkExpression smallUni ty
- let fun = Function (unnamedParameter smallUni) (b' ^. typedType)
- return
- TypedExpression
- { _typedType = ExpressionFunction fun,
- _typedExpression = ExpressionSimpleLambda (SimpleLambda (SimpleBinder v ty') (b' ^. typedExpression))
- }
-
- goCase :: Case -> Sem r TypedExpression
- goCase c = do
- ty <- case hint of
- Nothing -> ExpressionHole <$> freshHole (getLoc c)
- Just hi -> return hi
- typedCaseExpression <- inferExpression' Nothing (c ^. caseExpression)
- let _caseExpression = typedCaseExpression ^. typedExpression
- _caseExpressionType = Just (typedCaseExpression ^. typedType)
- _caseExpressionWholeType = Just ty
- goBranch :: CaseBranch -> Sem r CaseBranch
- goBranch b = do
- (onePat, _caseBranchExpression) <- checkClause funty [b ^. caseBranchPattern] (b ^. caseBranchExpression)
- let _caseBranchPattern = case onePat of
- [x] -> x
- _ -> impossible
- return CaseBranch {..}
- where
- funty :: Expression
- funty = ExpressionFunction (mkFunction (typedCaseExpression ^. typedType) ty)
- _caseBranches <- mapM goBranch (c ^. caseBranches)
- let _caseParens = c ^. caseParens
- return
- TypedExpression
- { _typedType = ty,
- _typedExpression = ExpressionCase Case {..}
- }
-
- goLambda :: Lambda -> Sem r TypedExpression
- goLambda l = do
- ty <- case hint of
- Just hi -> return hi
- Nothing -> ExpressionHole <$> freshHole (getLoc l)
- _lambdaClauses <- mapM (goClause ty) (l ^. lambdaClauses)
- let _lambdaType = Just ty
- l' = Lambda {..}
- return
- TypedExpression
- { _typedType = ty,
- _typedExpression = ExpressionLambda l'
- }
- where
- goClause :: Expression -> LambdaClause -> Sem r LambdaClause
- goClause ty (LambdaClause pats body) = do
- (pats', body') <- checkClause ty (toList pats) body
- return (LambdaClause (nonEmpty' pats') body')
-
- goUniverse :: SmallUniverse -> Sem r TypedExpression
- goUniverse u =
- return
- TypedExpression
- { _typedType = ExpressionUniverse u,
- _typedExpression = ExpressionUniverse u
- }
-
- goFunction :: Function -> Sem r TypedExpression
- goFunction (Function l r) = do
- let uni = smallUniverseE (getLoc l)
- l' <- checkFunctionParameter l
- let bodyEnv :: Sem r a -> Sem r a
- bodyEnv = withLocalTypeMaybe (l ^. paramName) (l ^. paramType)
- r' <- bodyEnv (checkExpression uni r)
- return (TypedExpression uni (ExpressionFunction (Function l' r')))
-
- goLiteral :: LiteralLoc -> Sem r TypedExpression
- goLiteral lit@(WithLoc i l) = do
- case l of
- LitNumeric v -> outHole v >> typedLitNumeric v
- LitInteger {} -> do
- ty <- getIntTy
- return $
- TypedExpression
- { _typedType = ty,
- _typedExpression = ExpressionLiteral lit
- }
- LitNatural {} -> do
- ty <- getNatTy
- return $
- TypedExpression
- { _typedType = ty,
- _typedExpression = ExpressionLiteral lit
- }
- LitString {} -> do
- str <- getBuiltinName i BuiltinString
- return
- TypedExpression
- { _typedExpression = ExpressionLiteral lit,
- _typedType = ExpressionIden (IdenAxiom str)
- }
- where
- typedLitNumeric :: Integer -> Sem r TypedExpression
- typedLitNumeric v
- | v < 0 = getIntTy >>= typedLit LitInteger BuiltinFromInt
- | otherwise = getNatTy >>= typedLit LitNatural BuiltinFromNat
- where
- typedLit :: (Integer -> Literal) -> BuiltinFunction -> Expression -> Sem r TypedExpression
- typedLit litt blt ty = do
- from <- getBuiltinName i blt
- ihole <- freshInstanceHole i
- let ty' = fromMaybe ty hint
- inferExpression' (Just ty') $
- foldApplication
- (ExpressionIden (IdenFunction from))
- [ ApplicationArg Implicit ty',
- ApplicationArg ImplicitInstance (ExpressionInstanceHole ihole),
- ApplicationArg Explicit (ExpressionLiteral (WithLoc i (litt v)))
- ]
-
- mkBuiltinInductive :: BuiltinInductive -> Sem r Expression
- mkBuiltinInductive = fmap (ExpressionIden . IdenInductive) . getBuiltinName i
-
- getIntTy :: Sem r Expression
- getIntTy = mkBuiltinInductive BuiltinInt
-
- getNatTy :: Sem r Expression
- getNatTy = mkBuiltinInductive BuiltinNat
-
- outHole :: Integer -> Sem r ()
- outHole v
- | v < 0 = case hint of
- Just (ExpressionHole h) ->
- output CastHole {_castHoleHole = h, _castHoleType = CastInt}
- _ ->
- return ()
- | otherwise = case hint of
- Just (ExpressionHole h) ->
- output CastHole {_castHoleHole = h, _castHoleType = CastNat}
- _ ->
- return ()
-
- goIden :: Iden -> Sem r TypedExpression
- goIden i = case i of
- IdenFunction fun -> do
- info <- lookupFunction fun
- return (TypedExpression (info ^. functionInfoDef . funDefType) (ExpressionIden i))
- IdenConstructor c -> do
- ty <- lookupConstructorType c
- return (TypedExpression ty (ExpressionIden i))
- IdenVar v -> do
- ty <- lookupVar v
- return (TypedExpression ty (ExpressionIden i))
- IdenAxiom v -> do
- info <- lookupAxiom v
- return (TypedExpression (info ^. axiomInfoDef . axiomType) (ExpressionIden i))
- IdenInductive v -> do
- kind <- lookupInductiveType v
- return (TypedExpression kind (ExpressionIden i))
-
- goApplication :: Application -> Sem r TypedExpression
- goApplication (Application l r iapp) = inferExpression' Nothing l >>= helper
- where
- helper :: TypedExpression -> Sem r TypedExpression
- helper l' = do
- l'ty <- weakNormalize (l' ^. typedType)
- case l'ty of
- ExpressionFunction (Function (FunctionParameter paraName ifun funL) funR) -> do
- r' <- checkExpression funL r
- unless
- (iapp == ifun)
- ( error
- ( "Impossible: implicitness mismatch"
- <> show ifun
- <> show iapp
- <> "\n"
- <> ppTrace (Application l r iapp)
- )
- )
- ty <- substitutionE (substitutionApp (paraName, r')) funR
- return
- TypedExpression
- { _typedExpression =
- ExpressionApplication
- Application
- { _appLeft = l' ^. typedExpression,
- _appRight = r',
- _appImplicit = iapp
- },
- _typedType = ty
- }
- ExpressionHole h -> do
- fun <- ExpressionFunction <$> holeRefineToFunction h
- helper (set typedType fun l')
- _ -> throw tyErr
- where
- tyErr :: TypeCheckerError
- tyErr =
- ErrExpectedFunctionType
- ( ExpectedFunctionType
- { _expectedFunctionTypeExpression = e,
- _expectedFunctionTypeLeft = l,
- _expectedFunctionTypeType = l' ^. typedType
- }
- )
-
-viewInductiveApp ::
- (Members '[Error TypeCheckerError, Inference, State FunctionsTable] r) =>
- Expression ->
- Sem r (Either Hole (InductiveName, [Expression]))
-viewInductiveApp ty = do
- ty' <- weakNormalize ty
- let (t, as) = viewTypeApp ty'
- case t of
- ExpressionIden (IdenInductive n) -> return (Right (n, as))
- ExpressionHole h -> do
- r <- queryMetavar h
- case r of
- Just h' -> viewInductiveApp h'
- Nothing -> return (Left h)
- _ -> throw (ErrInvalidPatternMatching (InvalidPatternMatching ty))
- where
- viewTypeApp :: Expression -> (Expression, [Expression])
- viewTypeApp tyapp = case tyapp of
- ExpressionApplication (Application l r _) ->
- second (`snoc` r) (viewTypeApp l)
- _ -> (tyapp, [])
diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/CheckerNew.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/CheckerNew.hs
index 29b6551470..5e0a5a2007 100644
--- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/CheckerNew.hs
+++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/CheckerNew.hs
@@ -2,11 +2,8 @@ module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Ch
( module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Error,
checkModule,
checkTable,
- checkModuleIndex,
- checkModuleNoCache,
checkImport,
withEmptyInsertedArgsStack,
- withEmptyLocalVars,
inferExpression,
)
where
@@ -14,8 +11,8 @@ where
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet
import Data.List.NonEmpty qualified as NonEmpty
-import Juvix.Compiler.Builtins.Effect
-import Juvix.Compiler.Concrete.Data.Highlight.Input
+import Juvix.Compiler.Builtins.Error (NotDefined (..))
+import Juvix.Compiler.Concrete.Data.Highlight
import Juvix.Compiler.Internal.Data.Cast
import Juvix.Compiler.Internal.Data.CoercionInfo
import Juvix.Compiler.Internal.Data.InstanceInfo
@@ -36,8 +33,6 @@ import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Data.Effect.NameIdGen
import Juvix.Prelude hiding (fromEither)
-type MCache = Cache ModuleIndex Module
-
data FunctionDefaultInfo = FunctionDefaultInfo
{ _functionDefaultArgId :: ArgId,
_functionDefaultValue :: Expression
@@ -116,8 +111,8 @@ registerConstructor ctr = do
registerNameIdType :: (Members '[HighlightBuilder, State TypesTable, Reader InfoTable] r) => NameId -> Expression -> Sem r ()
registerNameIdType uid ty = do
- modify (HashMap.insert uid ty)
- modify (set (highlightTypes . at uid) (Just ty))
+ modify (over typesTable (HashMap.insert uid ty))
+ modify (over (highlightTypes . typesTable) (HashMap.insert uid ty))
checkTable ::
(Members '[Reader InfoTable, Error TypeCheckerError] r) =>
@@ -131,25 +126,10 @@ checkTable = do
. CoercionCycles
checkModule ::
- (Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache] r) =>
+ (Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Termination] r) =>
Module ->
Sem r Module
-checkModule = cacheGet . ModuleIndex
-
-checkModuleIndex ::
- (Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache] r) =>
- ModuleIndex ->
- Sem r ModuleIndex
-checkModuleIndex = fmap ModuleIndex . cacheGet
-
-withEmptyInsertedArgsStack :: Sem (Reader InsertedArgsStack ': r) a -> Sem r a
-withEmptyInsertedArgsStack = runReader (mempty @InsertedArgsStack)
-
-checkModuleNoCache ::
- (Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache, Termination] r) =>
- ModuleIndex ->
- Sem r Module
-checkModuleNoCache (ModuleIndex Module {..}) = withEmptyInsertedArgsStack $ do
+checkModule Module {..} = runReader (mempty @InsertedArgsStack) $ do
_moduleBody' <-
evalState (mempty :: NegativeTypeParameters)
. checkModuleBody
@@ -160,11 +140,12 @@ checkModuleNoCache (ModuleIndex Module {..}) = withEmptyInsertedArgsStack $ do
{ _moduleBody = _moduleBody',
_moduleName,
_moduleExamples,
- _modulePragmas
+ _modulePragmas,
+ _moduleId
}
checkModuleBody ::
- (Members '[HighlightBuilder, Reader EntryPoint, State NegativeTypeParameters, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache, Termination, Reader InsertedArgsStack] r) =>
+ (Members '[HighlightBuilder, Reader EntryPoint, State NegativeTypeParameters, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Termination, Reader InsertedArgsStack] r) =>
ModuleBody ->
Sem r ModuleBody
checkModuleBody ModuleBody {..} = do
@@ -176,21 +157,18 @@ checkModuleBody ModuleBody {..} = do
_moduleImports = _moduleImports'
}
-checkImport ::
- (Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache, Termination] r) =>
- Import ->
- Sem r Import
-checkImport = traverseOf importModule checkModuleIndex
+checkImport :: Import -> Sem r Import
+checkImport = return
checkMutualBlock ::
- (Members '[HighlightBuilder, Reader EntryPoint, State NegativeTypeParameters, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, Termination, Reader InsertedArgsStack] r) =>
+ (Members '[HighlightBuilder, Reader EntryPoint, State NegativeTypeParameters, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Termination, Reader InsertedArgsStack] r) =>
MutualBlock ->
Sem r MutualBlock
checkMutualBlock s = runReader emptyLocalVars (checkTopMutualBlock s)
checkInductiveDef ::
forall r.
- (Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, State TypesTable, State NegativeTypeParameters, Output Example, Builtins, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack, Reader LocalVars] r) =>
+ (Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, State TypesTable, State NegativeTypeParameters, Output Example, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack, Reader LocalVars] r) =>
InductiveDef ->
Sem r InductiveDef
checkInductiveDef InductiveDef {..} = runInferenceDef $ do
@@ -213,7 +191,7 @@ checkInductiveDef InductiveDef {..} = runInferenceDef $ do
_inductiveTrait,
_inductivePragmas
}
- checkPositivity d
+ checkPositivity (inductiveInfoFromInductiveDef d)
return d
where
checkParams :: Sem (Inference ': r) [(Name, Expression)]
@@ -256,7 +234,7 @@ withEmptyVars :: Sem (Reader LocalVars ': r) a -> Sem r a
withEmptyVars = runReader emptyLocalVars
checkTopMutualBlock ::
- (Members '[HighlightBuilder, State NegativeTypeParameters, Reader EntryPoint, Reader LocalVars, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, Termination, Reader InsertedArgsStack] r) =>
+ (Members '[HighlightBuilder, State NegativeTypeParameters, Reader EntryPoint, Reader LocalVars, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Termination, Reader InsertedArgsStack] r) =>
MutualBlock ->
Sem r MutualBlock
checkTopMutualBlock (MutualBlock ds) =
@@ -264,7 +242,7 @@ checkTopMutualBlock (MutualBlock ds) =
resolveCastHoles ::
forall a r.
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, Builtins, NameIdGen, Inference, Output Example, Output TypedHole, State TypesTable, Termination, Reader InsertedArgsStack] r) =>
+ (Members '[Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Inference, Output Example, Output TypedHole, State TypesTable, Termination, Reader InsertedArgsStack] r) =>
Sem (Output CastHole ': r) a ->
Sem r a
resolveCastHoles s = do
@@ -293,7 +271,7 @@ resolveCastHoles s = do
getNatTy = mkBuiltinInductive BuiltinNat
checkMutualStatement ::
- (Members '[HighlightBuilder, State NegativeTypeParameters, Reader EntryPoint, Inference, Reader LocalVars, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, Termination, Reader InsertedArgsStack] r) =>
+ (Members '[HighlightBuilder, State NegativeTypeParameters, Reader EntryPoint, Inference, Reader LocalVars, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Termination, Reader InsertedArgsStack] r) =>
MutualStatement ->
Sem r MutualStatement
checkMutualStatement = \case
@@ -321,7 +299,7 @@ unfoldFunType' e = do
checkFunctionDef ::
forall r.
- (Members '[HighlightBuilder, Reader LocalVars, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, Inference, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack] r) =>
+ (Members '[Reader LocalVars, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Inference, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack] r) =>
FunctionDef ->
Sem r FunctionDef
checkFunctionDef FunctionDef {..} = do
@@ -371,7 +349,7 @@ checkFunctionDef FunctionDef {..} = do
withLocalTypeMaybe (p ^. paramName) (p ^. paramType) (go rest)
checkIsType ::
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Builtins, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack] r) =>
+ (Members '[Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack] r) =>
Interval ->
Expression ->
Sem r Expression
@@ -379,7 +357,7 @@ checkIsType = checkExpression . smallUniverseE
checkDefType ::
forall r.
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Builtins, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack] r) =>
+ (Members '[Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack] r) =>
Expression ->
Sem r Expression
checkDefType ty = checkIsType loc ty
@@ -459,7 +437,7 @@ checkCoercionType FunctionDef {..} = case mi of
ImplicitInstance -> throw (ErrWrongCoercionArgument (WrongCoercionArgument fp))
checkExample ::
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, Builtins, NameIdGen, Output Example, State TypesTable, Termination, Reader InsertedArgsStack] r) =>
+ (Members '[Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Output Example, State TypesTable, Termination, Reader InsertedArgsStack] r) =>
Example ->
Sem r Example
checkExample e = do
@@ -469,7 +447,7 @@ checkExample e = do
checkExpression ::
forall r.
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, Builtins, NameIdGen, Reader LocalVars, Inference, Output Example, Output TypedHole, State TypesTable, Termination, Output CastHole, Reader InsertedArgsStack] r) =>
+ (Members '[Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Output Example, Output TypedHole, State TypesTable, Termination, Output CastHole, Reader InsertedArgsStack] r) =>
Expression ->
Expression ->
Sem r Expression
@@ -496,7 +474,7 @@ checkExpression expectedTy e = do
resolveInstanceHoles ::
forall a r.
(HasExpressions a) =>
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, Builtins, NameIdGen, Inference, Output Example, State TypesTable, Termination, Reader InsertedArgsStack] r) =>
+ (Members '[Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Inference, Output Example, State TypesTable, Termination, Reader InsertedArgsStack] r) =>
Sem (Output TypedHole ': r) a ->
Sem r a
resolveInstanceHoles s = do
@@ -514,7 +492,7 @@ resolveInstanceHoles s = do
$ checkExpression _typedHoleType t
checkFunctionParameter ::
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Builtins, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack] r) =>
+ (Members '[Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack] r) =>
FunctionParameter ->
Sem r FunctionParameter
checkFunctionParameter FunctionParameter {..} = do
@@ -531,7 +509,7 @@ checkFunctionParameter FunctionParameter {..} = do
}
inferExpression ::
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Builtins, Output Example, State TypesTable, Termination, Reader InsertedArgsStack] r) =>
+ (Members '[Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Output Example, State TypesTable, Termination, Reader InsertedArgsStack] r) =>
-- | type hint
Maybe Expression ->
Expression ->
@@ -546,7 +524,7 @@ lookupVar v = do
err = error $ "internal error: could not find var " <> ppTrace v <> " at " <> ppTrace (getLoc v)
checkFunctionBody ::
- (Members '[Reader LocalVars, Reader InfoTable, NameIdGen, Error TypeCheckerError, Output Example, Output TypedHole, State TypesTable, State HighlightInput, State FunctionsTable, Builtins, Inference, Termination, Output CastHole, Reader InsertedArgsStack] r) =>
+ (Members '[Reader LocalVars, Reader InfoTable, NameIdGen, Error TypeCheckerError, Output Example, Output TypedHole, State TypesTable, State FunctionsTable, Inference, Termination, Output CastHole, Reader InsertedArgsStack] r) =>
Expression ->
Expression ->
Sem r Expression
@@ -572,7 +550,7 @@ checkFunctionBody expectedTy body =
-- | helper function for lambda functions and case branches
checkClause ::
forall r.
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Builtins, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack] r) =>
+ (Members '[Reader InfoTable, State FunctionsTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack] r) =>
Interval ->
-- | Type
Expression ->
@@ -822,7 +800,7 @@ checkPattern = go
Left hole -> return (Left hole)
Right (ind, args) -> do
params :: [InductiveParameter] <-
- (^. inductiveInfoDef . inductiveParameters)
+ (^. inductiveInfoParameters)
<$> lookupInductive ind
let numArgs = length args
numParams = length params
@@ -850,7 +828,7 @@ checkPattern = go
inferExpression' ::
forall r.
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, State TypesTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Output Example, Output TypedHole, Builtins, Termination, Output CastHole, Reader InsertedArgsStack, Reader InsertedArgsStack] r) =>
+ (Members '[Reader InfoTable, State FunctionsTable, State TypesTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Output Example, Output TypedHole, Termination, Output CastHole, Reader InsertedArgsStack, Reader InsertedArgsStack] r) =>
Maybe Expression ->
Expression ->
Sem r TypedExpression
@@ -859,7 +837,7 @@ inferExpression' = holesHelper
-- | Checks anything but an Application. Does not insert holes
inferLeftAppExpression ::
forall r.
- (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, State TypesTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Output Example, Output TypedHole, Builtins, Termination, Output CastHole, Reader InsertedArgsStack] r) =>
+ (Members '[Reader InfoTable, State FunctionsTable, State TypesTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Output Example, Output TypedHole, Termination, Output CastHole, Reader InsertedArgsStack] r) =>
Maybe Expression ->
Expression ->
Sem r TypedExpression
@@ -1072,7 +1050,7 @@ inferLeftAppExpression mhint e = case e of
goIden i = case i of
IdenFunction fun -> do
info <- lookupFunction fun
- return (TypedExpression (info ^. functionInfoDef . funDefType) (ExpressionIden i))
+ return (TypedExpression (info ^. functionInfoType) (ExpressionIden i))
IdenConstructor c -> do
ty <- lookupConstructorType c
return (TypedExpression ty (ExpressionIden i))
@@ -1087,7 +1065,7 @@ inferLeftAppExpression mhint e = case e of
return (TypedExpression kind (ExpressionIden i))
-- | The hint is used for trailing holes only
-holesHelper :: forall r. (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, State TypesTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Output Example, Output TypedHole, Builtins, Termination, Output CastHole, Reader InsertedArgsStack] r) => Maybe Expression -> Expression -> Sem r TypedExpression
+holesHelper :: forall r. (Members '[Reader InfoTable, State FunctionsTable, State TypesTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Output Example, Output TypedHole, Termination, Output CastHole, Reader InsertedArgsStack] r) => Maybe Expression -> Expression -> Sem r TypedExpression
holesHelper mhint expr = do
let (f, args) = unfoldExpressionApp expr
hint
@@ -1157,7 +1135,7 @@ holesHelper mhint expr = do
let ty = fTy ^. typedType
in runFailDefault (BuilderTypeNoDefaults ty) $ do
fun <- failMaybe (getFunctionName (fTy ^. typedExpression))
- infos <- (^. functionInfoDef . funDefArgsInfo) <$> lookupFunction fun
+ infos <- (^. functionInfoArgsInfo) <$> lookupFunction fun
return $ toFunctionDefaultMay fun ty infos
where
toFunctionDefaultMay :: Name -> Expression -> [ArgInfo] -> BuilderType
@@ -1626,9 +1604,9 @@ idenArity = \case
IdenVar v -> getLocalArity v
IdenInductive i -> lookupInductiveType i >>= typeArity
IdenFunction f -> do
- fun <- (^. functionInfoDef) <$> lookupFunction f
- ari <- typeArity (fun ^. funDefType)
- let defaults = fun ^. funDefArgsInfo
+ fun <- lookupFunction f
+ ari <- typeArity (fun ^. functionInfoType)
+ let defaults = fun ^. functionInfoArgsInfo
return (addArgsInfo defaults ari)
IdenConstructor c -> lookupConstructorType c >>= typeArity
IdenAxiom a -> lookupAxiom a >>= typeArity . (^. axiomInfoDef . axiomType)
@@ -1657,3 +1635,22 @@ newHoleImplicit loc = ExpressionHole . mkHole loc <$> freshNameId
newHoleInstance :: (Member NameIdGen r) => Interval -> Sem r Expression
newHoleInstance loc = ExpressionInstanceHole . mkInstanceHole loc <$> freshNameId
+
+getBuiltinName ::
+ (Members '[Reader InfoTable, Error TypeCheckerError] r, IsBuiltin a) =>
+ Interval ->
+ a ->
+ Sem r Name
+getBuiltinName i b = fromMaybeM notDefined (asks (^. infoBuiltins . at b'))
+ where
+ b' = toBuiltinPrim b
+ notDefined =
+ throw $
+ ErrBuiltinNotDefined
+ NotDefined
+ { _notDefinedBuiltin = b',
+ _notDefinedLoc = i
+ }
+
+withEmptyInsertedArgsStack :: Sem (Reader InsertedArgsStack ': r) a -> Sem r a
+withEmptyInsertedArgsStack = runReader (mempty @InsertedArgsStack)
diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data.hs
index 155c6be048..2cb2a98a69 100644
--- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data.hs
+++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data.hs
@@ -1,10 +1,8 @@
module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data
( module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context,
- module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.FunctionsTable,
module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Inference,
)
where
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context
-import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.FunctionsTable
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Inference
diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Context.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Context.hs
index c5654b0c26..9aa9c7f22f 100644
--- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Context.hs
+++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Context.hs
@@ -1,40 +1,30 @@
module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context
( module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context,
- module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.FunctionsTable,
+ module Juvix.Compiler.Store.Internal.Data.FunctionsTable,
+ module Juvix.Compiler.Store.Internal.Data.TypesTable,
module Juvix.Compiler.Internal.Data.InfoTable,
)
where
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context qualified as Scoped
import Juvix.Compiler.Internal.Data.InfoTable
import Juvix.Compiler.Internal.Language
import Juvix.Compiler.Internal.Translation.FromConcrete.Data.Context qualified as Internal
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker (TerminationState)
-import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.FunctionsTable
-import Juvix.Compiler.Pipeline.EntryPoint qualified as E
+import Juvix.Compiler.Store.Internal.Data.FunctionsTable
+import Juvix.Compiler.Store.Internal.Data.TypesTable
import Juvix.Prelude
-type TypesTable = HashMap NameId Expression
-
type NormalizedTable = HashMap NameId Expression
data InternalTypedResult = InternalTypedResult
- { _resultInternalResult :: Internal.InternalResult,
- _resultModules :: NonEmpty Module,
+ { _resultInternal :: Internal.InternalResult,
+ _resultModule :: Module,
+ _resultInternalModule :: InternalModule,
_resultTermination :: TerminationState,
_resultNormalized :: NormalizedTable,
_resultIdenTypes :: TypesTable,
- _resultFunctions :: FunctionsTable,
- _resultInfoTable :: InfoTable
+ _resultFunctions :: FunctionsTable
}
+makeLenses ''TypesTable
makeLenses ''InternalTypedResult
-
-mainModule :: Lens' InternalTypedResult Module
-mainModule = resultModules . _head1
-
-internalTypedResultEntryPoint :: Lens' InternalTypedResult E.EntryPoint
-internalTypedResultEntryPoint = resultInternalResult . Internal.internalResultEntryPoint
-
-internalTypedResultScoped :: Lens' InternalTypedResult Scoped.ScoperResult
-internalTypedResultScoped = resultInternalResult . Internal.resultScoper
diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Inference.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Inference.hs
index 7c4b0b0533..63c725302c 100644
--- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Inference.hs
+++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Inference.hs
@@ -1,5 +1,5 @@
module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Inference
- ( module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.FunctionsTable,
+ ( module Juvix.Compiler.Store.Internal.Data.FunctionsTable,
Inference,
MatchError,
registerFunctionDef,
@@ -20,13 +20,12 @@ module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Da
where
import Data.HashMap.Strict qualified as HashMap
-import Juvix.Compiler.Concrete.Data.Highlight.Input
import Juvix.Compiler.Internal.Extra
import Juvix.Compiler.Internal.Pretty
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context
-import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.FunctionsTable
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Error
+import Juvix.Compiler.Store.Internal.Data.FunctionsTable
import Juvix.Prelude hiding (fromEither)
data MetavarState
@@ -308,7 +307,7 @@ re = reinterpret $ \case
WeakNormalize ty -> weakNormalize' ty
where
registerIdenType' :: (Members '[State InferenceState] r) => Name -> Expression -> Sem r ()
- registerIdenType' i ty = modify (over inferenceIdens (HashMap.insert (i ^. nameId) ty))
+ registerIdenType' i ty = modify (over (inferenceIdens . typesTable) (HashMap.insert (i ^. nameId) ty))
-- Supports alpha equivalence.
matchTypes' :: (Members '[State InferenceState, State FunctionsTable, Error TypeCheckerError, NameIdGen] r) => Expression -> Expression -> Sem r (Maybe MatchError)
@@ -484,28 +483,27 @@ matchPatterns (PatternArg impl1 name1 pat1) (PatternArg impl2 name2 pat2) =
err = return False
runInferenceDefs ::
- (Members '[Termination, HighlightBuilder, Error TypeCheckerError, State FunctionsTable, State TypesTable, NameIdGen] r, HasExpressions funDef) =>
+ (Members '[Termination, Error TypeCheckerError, State FunctionsTable, State TypesTable, NameIdGen] r, HasExpressions funDef) =>
Sem (Inference ': r) (NonEmpty funDef) ->
Sem r (NonEmpty funDef)
runInferenceDefs a = do
(finalState, expr) <- runState iniState (re a)
(subs, idens) <- closeState finalState
- idens' <- mapM (subsHoles subs) idens
+ idens' <- mapM (subsHoles subs) (idens ^. typesTable)
stash' <- mapM (subsHoles subs) (finalState ^. inferenceFunctionsStash)
forM_ stash' registerFunctionDef
- addIdens idens'
+ addIdens (TypesTable idens')
mapM (subsHoles subs) expr
runInferenceDef ::
- (Members '[Termination, HighlightBuilder, Error TypeCheckerError, State FunctionsTable, State TypesTable, NameIdGen] r, HasExpressions funDef) =>
+ (Members '[Termination, Error TypeCheckerError, State FunctionsTable, State TypesTable, NameIdGen] r, HasExpressions funDef) =>
Sem (Inference ': r) funDef ->
Sem r funDef
runInferenceDef = fmap head . runInferenceDefs . fmap pure
-addIdens :: (Members '[HighlightBuilder, State TypesTable] r) => TypesTable -> Sem r ()
+addIdens :: (Members '[State TypesTable] r) => TypesTable -> Sem r ()
addIdens idens = do
- modify (HashMap.union idens)
- modify (over highlightTypes (HashMap.union idens))
+ modify (over typesTable (HashMap.union (idens ^. typesTable)))
-- | Assumes the given function has been type checked. Does *not* register the
-- function.
diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Error.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Error.hs
index c81801c871..5532e3cbba 100644
--- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Error.hs
+++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Error.hs
@@ -6,6 +6,7 @@ module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Er
)
where
+import Juvix.Compiler.Builtins.Error (NotDefined)
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.ArityChecking.Error
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Positivity.Error
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Error.Pretty
@@ -35,6 +36,7 @@ data TypeCheckerError
| ErrSubsumedInstance SubsumedInstance
| ErrExplicitInstanceArgument ExplicitInstanceArgument
| ErrTraitNotTerminating TraitNotTerminating
+ | ErrBuiltinNotDefined NotDefined
| ErrArityCheckerError ArityCheckerError
| ErrDefaultArgLoop DefaultArgLoop
@@ -62,6 +64,7 @@ instance ToGenericError TypeCheckerError where
ErrSubsumedInstance e -> genericError e
ErrExplicitInstanceArgument e -> genericError e
ErrTraitNotTerminating e -> genericError e
+ ErrBuiltinNotDefined e -> genericError e
ErrArityCheckerError e -> genericError e
ErrDefaultArgLoop e -> genericError e
@@ -90,3 +93,4 @@ instance Show TypeCheckerError where
ErrTraitNotTerminating {} -> "ErrTraitNotTerminating"
ErrArityCheckerError {} -> "ErrArityCheckerError"
ErrDefaultArgLoop {} -> "ErrDefaultArgLoop"
+ ErrBuiltinNotDefined {} -> "ErrBuiltinNotDefined"
diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Traits/Resolver.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Traits/Resolver.hs
index 6178add7a4..f54a5c10c4 100644
--- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Traits/Resolver.hs
+++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Traits/Resolver.hs
@@ -24,7 +24,7 @@ subsIToE = fmap paramToExpression
type CoercionChain = [(CoercionInfo, SubsI)]
isTrait :: InfoTable -> Name -> Bool
-isTrait tab name = maybe False (^. inductiveInfoDef . inductiveTrait) (HashMap.lookup name (tab ^. infoInductives))
+isTrait tab name = maybe False (^. inductiveInfoTrait) (HashMap.lookup name (tab ^. infoInductives))
resolveTraitInstance ::
(Members '[Error TypeCheckerError, NameIdGen, Inference, Reader InfoTable] r) =>
diff --git a/src/Juvix/Compiler/Pipeline.hs b/src/Juvix/Compiler/Pipeline.hs
index 4f84336d74..6e1102875d 100644
--- a/src/Juvix/Compiler/Pipeline.hs
+++ b/src/Juvix/Compiler/Pipeline.hs
@@ -3,7 +3,7 @@ module Juvix.Compiler.Pipeline
module Juvix.Compiler.Pipeline.EntryPoint,
module Juvix.Compiler.Pipeline.Artifacts,
module Juvix.Compiler.Pipeline.Root.Base,
- module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.DependenciesConfig,
+ module Juvix.Compiler.Pipeline.Result,
)
where
@@ -16,13 +16,9 @@ import Juvix.Compiler.Backend qualified as Backend
import Juvix.Compiler.Backend.C qualified as C
import Juvix.Compiler.Backend.Geb qualified as Geb
import Juvix.Compiler.Backend.VampIR.Translation qualified as VampIR
-import Juvix.Compiler.Builtins
import Juvix.Compiler.Concrete.Data.Highlight.Input
import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Concrete.Translation.FromParsed qualified as Scoper
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Base
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.DependenciesConfig
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error
import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser
import Juvix.Compiler.Core qualified as Core
import Juvix.Compiler.Core.Translation.Stripped.FromCore qualified as Stripped
@@ -30,12 +26,15 @@ import Juvix.Compiler.Internal qualified as Internal
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker
import Juvix.Compiler.Pipeline.Artifacts
import Juvix.Compiler.Pipeline.EntryPoint
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Base
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Error
import Juvix.Compiler.Pipeline.Package.Loader.Error
import Juvix.Compiler.Pipeline.Package.Loader.EvalEff
+import Juvix.Compiler.Pipeline.Result
import Juvix.Compiler.Pipeline.Root.Base
-import Juvix.Compiler.Pipeline.Setup
import Juvix.Compiler.Reg.Data.InfoTable qualified as Reg
import Juvix.Compiler.Reg.Translation.FromAsm qualified as Reg
+import Juvix.Compiler.Store.Language qualified as Store
import Juvix.Data.Effect.Git
import Juvix.Data.Effect.Process
import Juvix.Data.Effect.TaggedLock
@@ -43,97 +42,128 @@ import Juvix.Prelude
type PipelineAppEffects = '[TaggedLock, Embed IO, Resource, Final IO]
-type PipelineLocalEff = '[PathResolver, EvalFileEff, Error PackageLoaderError, Error DependencyError, GitClone, Error GitProcessError, Process, Log, Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError, HighlightBuilder, Internet]
+type PipelineLocalEff = '[PathResolver, EvalFileEff, Error PackageLoaderError, Error DependencyError, GitClone, Error GitProcessError, Process, Log, Reader EntryPoint, Files, Error JuvixError, HighlightBuilder, Internet]
-type PipelineEff r = PipelineLocalEff ++ r
+type PipelineEff' r = PipelineLocalEff ++ r
+
+type PipelineEff r = Reader Parser.ParserResult ': Reader Store.ModuleTable ': NameIdGen ': PipelineEff' r
--------------------------------------------------------------------------------
--- Workflows
+-- Workflows from source
--------------------------------------------------------------------------------
-upToSetup ::
- (Members '[Reader EntryPoint, Files, GitClone, PathResolver] r) =>
- DependenciesConfig ->
- Sem r ()
-upToSetup = entrySetup
-
upToParsing ::
- (Members '[HighlightBuilder, Reader EntryPoint, Files, Error JuvixError, NameIdGen, GitClone, PathResolver] r) =>
+ (Members '[HighlightBuilder, Reader EntryPoint, Error JuvixError, Files, PathResolver] r) =>
+ Sem r Parser.ParserResult
+upToParsing = ask >>= Parser.fromSource
+
+--------------------------------------------------------------------------------
+-- Workflows from parsed source
+--------------------------------------------------------------------------------
+
+upToParsedSource ::
+ (Members '[Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Error JuvixError, NameIdGen] r) =>
Sem r Parser.ParserResult
-upToParsing = upToSetup defaultDependenciesConfig >> ask >>= Parser.fromSource
+upToParsedSource = ask
upToScoping ::
- (Members '[HighlightBuilder, Reader EntryPoint, Files, NameIdGen, Error JuvixError, GitClone, PathResolver] r) =>
+ (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Error JuvixError, NameIdGen] r) =>
Sem r Scoper.ScoperResult
-upToScoping = upToParsing >>= Scoper.fromParsed
+upToScoping = Scoper.fromParsed
upToInternal ::
- (Members '[HighlightBuilder, Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError, GitClone, PathResolver, Termination] r) =>
+ (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Error JuvixError, NameIdGen, Termination] r) =>
Sem r Internal.InternalResult
upToInternal = upToScoping >>= Internal.fromConcrete
upToInternalTyped ::
- (Members '[HighlightBuilder, Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, GitClone, PathResolver] r) =>
+ (Members '[HighlightBuilder, Reader Parser.ParserResult, Error JuvixError, Reader EntryPoint, Reader Store.ModuleTable, NameIdGen] r) =>
Sem r Internal.InternalTypedResult
upToInternalTyped = Internal.typeCheckingNew upToInternal
-upToInternalReachability ::
- (Members '[HighlightBuilder, Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, GitClone, PathResolver] r) =>
- Sem r Internal.InternalTypedResult
-upToInternalReachability =
- upToInternalTyped >>= Internal.filterUnreachable
-
upToCore ::
- (Members '[HighlightBuilder, Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, GitClone, PathResolver] r) =>
+ (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError, GitClone, PathResolver] r) =>
+ Sem r Core.CoreResult
+upToCore = upToInternalTyped >>= Core.fromInternal
+
+upToStoredCore ::
+ (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError, GitClone, PathResolver] r) =>
Sem r Core.CoreResult
-upToCore = upToInternalReachability >>= Core.fromInternal
+upToStoredCore =
+ upToCore >>= \r -> Core.toStored (r ^. Core.coreResultModule) >>= \md -> return r {Core._coreResultModule = md}
upToAsm ::
- (Members '[HighlightBuilder, Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, GitClone, PathResolver] r) =>
+ (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError, GitClone, PathResolver] r) =>
Sem r Asm.InfoTable
upToAsm =
- upToCore >>= \Core.CoreResult {..} -> coreToAsm _coreResultTable
+ upToStoredCore >>= \Core.CoreResult {..} -> storedCoreToAsm _coreResultModule
upToMiniC ::
- (Members '[HighlightBuilder, Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, GitClone, PathResolver] r) =>
+ (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError, GitClone, PathResolver] r) =>
Sem r C.MiniCResult
upToMiniC = upToAsm >>= asmToMiniC
upToVampIR ::
- (Members '[HighlightBuilder, Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, GitClone, PathResolver] r) =>
+ (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError, GitClone, PathResolver] r) =>
Sem r VampIR.Result
upToVampIR =
- upToCore >>= \Core.CoreResult {..} -> coreToVampIR _coreResultTable
+ upToStoredCore >>= \Core.CoreResult {..} -> storedCoreToVampIR _coreResultModule
upToGeb ::
- (Members '[HighlightBuilder, Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, GitClone, PathResolver] r) =>
+ (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError, GitClone, PathResolver] r) =>
Geb.ResultSpec ->
Sem r Geb.Result
upToGeb spec =
- upToCore >>= \Core.CoreResult {..} -> coreToGeb spec _coreResultTable
+ upToStoredCore >>= \Core.CoreResult {..} -> storedCoreToGeb spec _coreResultModule
upToCoreTypecheck ::
- (Members '[HighlightBuilder, Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, GitClone, PathResolver] r) =>
+ (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError, GitClone, PathResolver] r) =>
Sem r Core.CoreResult
upToCoreTypecheck =
- upToCore >>= \r -> Core.toTypechecked (r ^. Core.coreResultTable) >>= \tab -> return r {Core._coreResultTable = tab}
+ upToCore >>= \r -> Core.toTypechecked (r ^. Core.coreResultModule) >>= \md -> return r {Core._coreResultModule = md}
-upToEval ::
- (Members '[HighlightBuilder, Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, GitClone, PathResolver] r) =>
- Sem r Core.CoreResult
-upToEval =
- upToCore >>= \r -> Core.toEval (r ^. Core.coreResultTable) >>= \tab -> return r {Core._coreResultTable = tab}
+--------------------------------------------------------------------------------
+-- Workflows from stored Core
+--------------------------------------------------------------------------------
+
+storedCoreToAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Asm.InfoTable
+storedCoreToAsm = Core.toStripped >=> return . Asm.fromCore . Stripped.fromCore . Core.computeCombinedInfoTable
+
+storedCoreToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r C.MiniCResult
+storedCoreToMiniC = storedCoreToAsm >=> asmToMiniC
+
+storedCoreToGeb :: (Members '[Error JuvixError, Reader EntryPoint] r) => Geb.ResultSpec -> Core.Module -> Sem r Geb.Result
+storedCoreToGeb spec = Core.toGeb >=> return . uncurry (Geb.toResult spec) . Geb.fromCore . Core.computeCombinedInfoTable
+
+storedCoreToVampIR :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r VampIR.Result
+storedCoreToVampIR = Core.toVampIR >=> VampIR.fromCore . Core.computeCombinedInfoTable
+
+storedCoreToVampIR' :: (Members '[Error JuvixError, Reader Core.CoreOptions] r) => Core.Module -> Sem r VampIR.Result
+storedCoreToVampIR' = Core.toVampIR' >=> return . VampIR.fromCore' False . Core.computeCombinedInfoTable
--------------------------------------------------------------------------------
--- Internal workflows
+-- Workflows from Core
--------------------------------------------------------------------------------
-coreToAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.InfoTable -> Sem r Asm.InfoTable
-coreToAsm = Core.toStripped >=> return . Asm.fromCore . Stripped.fromCore
+coreToAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Asm.InfoTable
+coreToAsm = Core.toStored >=> storedCoreToAsm
-coreToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.InfoTable -> Sem r C.MiniCResult
+coreToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r C.MiniCResult
coreToMiniC = coreToAsm >=> asmToMiniC
+coreToGeb :: (Members '[Error JuvixError, Reader EntryPoint] r) => Geb.ResultSpec -> Core.Module -> Sem r Geb.Result
+coreToGeb spec = Core.toStored >=> storedCoreToGeb spec
+
+coreToVampIR :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r VampIR.Result
+coreToVampIR = Core.toStored >=> storedCoreToVampIR
+
+coreToVampIR' :: (Members '[Error JuvixError, Reader Core.CoreOptions] r) => Core.Module -> Sem r VampIR.Result
+coreToVampIR' = Core.toStored' >=> storedCoreToVampIR'
+
+--------------------------------------------------------------------------------
+-- Other workflows
+--------------------------------------------------------------------------------
+
asmToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Asm.InfoTable -> Sem r C.MiniCResult
asmToMiniC = Asm.toReg >=> regToMiniC . Reg.fromAsm
@@ -142,12 +172,6 @@ regToMiniC tab = do
e <- ask
return $ C.fromReg (Backend.getLimits (e ^. entryPointTarget) (e ^. entryPointDebug)) tab
-coreToGeb :: (Members '[Error JuvixError, Reader EntryPoint] r) => Geb.ResultSpec -> Core.InfoTable -> Sem r Geb.Result
-coreToGeb spec = Core.toGeb >=> return . uncurry (Geb.toResult spec) . Geb.fromCore
-
-coreToVampIR :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.InfoTable -> Sem r VampIR.Result
-coreToVampIR = Core.toVampIR >=> VampIR.fromCore
-
asmToMiniC' :: (Members '[Error JuvixError, Reader Asm.Options] r) => Asm.InfoTable -> Sem r C.MiniCResult
asmToMiniC' = mapError (JuvixError @Asm.AsmError) . Asm.toReg' >=> regToMiniC' . Reg.fromAsm
@@ -155,6 +179,3 @@ regToMiniC' :: (Member (Reader Asm.Options) r) => Reg.InfoTable -> Sem r C.MiniC
regToMiniC' tab = do
e <- ask
return $ C.fromReg (e ^. Asm.optLimits) tab
-
-coreToVampIR' :: (Members '[Error JuvixError, Reader Core.CoreOptions] r) => Core.InfoTable -> Sem r VampIR.Result
-coreToVampIR' = Core.toVampIR' >=> return . VampIR.fromCore' False
diff --git a/src/Juvix/Compiler/Pipeline/Artifacts.hs b/src/Juvix/Compiler/Pipeline/Artifacts.hs
index f820c5ccc4..9dece89fa5 100644
--- a/src/Juvix/Compiler/Pipeline/Artifacts.hs
+++ b/src/Juvix/Compiler/Pipeline/Artifacts.hs
@@ -11,40 +11,44 @@ where
import Juvix.Compiler.Builtins
import Juvix.Compiler.Concrete.Data.InfoTableBuilder qualified as Scoped
-import Juvix.Compiler.Concrete.Data.ParsedInfoTableBuilder qualified as Concrete
-import Juvix.Compiler.Concrete.Data.Scope
import Juvix.Compiler.Concrete.Data.Scope qualified as S
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping (ScoperError)
import Juvix.Compiler.Core.Data.InfoTableBuilder qualified as Core
-import Juvix.Compiler.Internal.Extra.DependencyBuilder (ExportsTable)
+import Juvix.Compiler.Core.Data.Module qualified as Core
import Juvix.Compiler.Internal.Language qualified as Internal
import Juvix.Compiler.Internal.Translation.FromConcrete qualified as Internal
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context
import Juvix.Compiler.Pipeline.Artifacts.Base
-import Juvix.Compiler.Pipeline.EntryPoint
+import Juvix.Compiler.Store.Extra
+import Juvix.Compiler.Store.Language
import Juvix.Prelude
+appendArtifactsModuleTable :: ModuleTable -> Artifacts -> Artifacts
+appendArtifactsModuleTable mtab =
+ over artifactInternalTypedTable (computeCombinedInfoTable importTab <>)
+ . over (artifactCoreModule . Core.moduleImportsTable) (computeCombinedCoreInfoTable mtab <>)
+ . over artifactModuleTable (mtab <>)
+ where
+ importTab :: Internal.InternalModuleTable
+ importTab = getInternalModuleTable mtab
+
-- | It only reads the Artifacts. It does not modify the table in it.
extendedTableReplArtifacts :: forall r. (Members '[State Artifacts] r) => Internal.Expression -> Sem r Internal.InfoTable
extendedTableReplArtifacts e = Internal.extendWithReplExpression e <$> gets (^. artifactInternalTypedTable)
runCoreInfoTableBuilderArtifacts :: (Members '[State Artifacts] r) => Sem (Core.InfoTableBuilder ': r) a -> Sem r a
-runCoreInfoTableBuilderArtifacts = runStateLikeArtifacts Core.runInfoTableBuilder artifactCoreTable
+runCoreInfoTableBuilderArtifacts = runStateLikeArtifacts Core.runInfoTableBuilder artifactCoreModule
tmpCoreInfoTableBuilderArtifacts :: (Members '[State Artifacts] r) => Sem (Core.InfoTableBuilder ': r) a -> Sem r a
tmpCoreInfoTableBuilderArtifacts m = do
- tbl <- gets (^. artifactCoreTable)
- a <- runStateLikeArtifacts Core.runInfoTableBuilder artifactCoreTable m
- modify' (set artifactCoreTable tbl)
+ md <- gets (^. artifactCoreModule)
+ a <- runStateLikeArtifacts Core.runInfoTableBuilder artifactCoreModule m
+ modify' (set artifactCoreModule md)
return a
runBuiltinsArtifacts :: (Members '[Error JuvixError, State Artifacts] r) => Sem (Builtins ': r) a -> Sem r a
runBuiltinsArtifacts = runStateLikeArtifacts runBuiltins artifactBuiltins
-runParserInfoTableBuilderArtifacts :: (Members '[State Artifacts] r) => Sem (Concrete.InfoTableBuilder ': r) a -> Sem r a
-runParserInfoTableBuilderArtifacts = runStateLikeArtifacts Concrete.runParserInfoTableBuilderRepl artifactParsing
-
runScoperInfoTableBuilderArtifacts :: (Members '[State Artifacts] r) => Sem (Scoped.InfoTableBuilder ': r) a -> Sem r a
runScoperInfoTableBuilderArtifacts = runStateLikeArtifacts Scoped.runInfoTableBuilderRepl artifactScopeTable
@@ -92,27 +96,3 @@ runStateLikeArtifacts runEff l m = do
(s', a) <- runEff s m
modify' (set l s')
return a
-
-runCacheArtifacts ::
- (Hashable k, Members '[State Artifacts] r) =>
- Lens' Artifacts (HashMap k v) ->
- (k -> Sem (Cache k v ': r) v) ->
- (Sem (Cache k v ': r) a) ->
- Sem r a
-runCacheArtifacts l f = runStateLikeArtifacts (runCache f) l
-
-runFromConcreteCache ::
- (Members '[Reader EntryPoint, State Artifacts, Builtins, NameIdGen, Reader ExportsTable, Error JuvixError] r) =>
- Sem (Internal.MCache ': r) a ->
- Sem r a
-runFromConcreteCache =
- runCacheArtifacts
- (artifactInternalModuleCache . Internal.cachedModules)
- $ mapError (JuvixError @ScoperError)
- . runReader (mempty :: Pragmas)
- . runReader (mempty :: Internal.DefaultArgsStack)
- . evalState (mempty :: Internal.ConstructorInfos)
- . runTerminationArtifacts
- . runReaderArtifacts (artifactScoperState . scoperScopedSignatures)
- . runReaderArtifacts (artifactScoperState . scoperScopedConstructorFields)
- . Internal.goModuleNoCache
diff --git a/src/Juvix/Compiler/Pipeline/Artifacts/Base.hs b/src/Juvix/Compiler/Pipeline/Artifacts/Base.hs
index 9d89f7c879..b500bb35bd 100644
--- a/src/Juvix/Compiler/Pipeline/Artifacts/Base.hs
+++ b/src/Juvix/Compiler/Pipeline/Artifacts/Base.hs
@@ -1,31 +1,30 @@
module Juvix.Compiler.Pipeline.Artifacts.Base where
import Juvix.Compiler.Builtins
-import Juvix.Compiler.Concrete.Data.InfoTable qualified as Scoped
-import Juvix.Compiler.Concrete.Data.ParsedInfoTableBuilder (BuilderState)
import Juvix.Compiler.Concrete.Data.Scope
import Juvix.Compiler.Concrete.Data.Scope qualified as Scoped
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Data
-import Juvix.Compiler.Core.Data.InfoTableBuilder qualified as Core
+import Juvix.Compiler.Concrete.Translation.FromSource.Data.ParserState
+import Juvix.Compiler.Core.Data.Module qualified as Core
import Juvix.Compiler.Internal.Translation.FromConcrete qualified as Internal
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Data
+import Juvix.Compiler.Store.Language qualified as Store
import Juvix.Prelude
-- | `Artifacts` contains enough information so that the pipeline can be
-- restarted while preserving existing state.
data Artifacts = Artifacts
- { _artifactParsing :: BuilderState,
+ { _artifactParsing :: ParserState,
-- Scoping
_artifactResolver :: ResolverState,
_artifactBuiltins :: BuiltinsState,
- _artifactNameIdState :: Stream NameId,
+ _artifactNameIdState :: NameIdGenState,
_artifactScopeTable :: Scoped.InfoTable,
_artifactScopeExports :: HashSet NameId,
_artifactMainModuleScope :: Maybe Scope,
_artifactScoperState :: Scoped.ScoperState,
-- Concrete -> Internal
- _artifactInternalModuleCache :: Internal.ModulesCache,
_artifactTerminationState :: TerminationState,
-- Typechecking
_artifactTypes :: TypesTable,
@@ -33,7 +32,9 @@ data Artifacts = Artifacts
-- | This includes the InfoTable from all type checked modules
_artifactInternalTypedTable :: Internal.InfoTable,
-- Core
- _artifactCoreTable :: Core.InfoTable
+ _artifactCoreModule :: Core.Module,
+ -- Store
+ _artifactModuleTable :: Store.ModuleTable
}
makeLenses ''Artifacts
diff --git a/src/Juvix/Compiler/Pipeline/Artifacts/PathResolver.hs b/src/Juvix/Compiler/Pipeline/Artifacts/PathResolver.hs
index 3e32ab02c9..8d2804f839 100644
--- a/src/Juvix/Compiler/Pipeline/Artifacts/PathResolver.hs
+++ b/src/Juvix/Compiler/Pipeline/Artifacts/PathResolver.hs
@@ -1,8 +1,8 @@
module Juvix.Compiler.Pipeline.Artifacts.PathResolver where
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver
import Juvix.Compiler.Pipeline.Artifacts
import Juvix.Compiler.Pipeline.EntryPoint
+import Juvix.Compiler.Pipeline.Loader.PathResolver
import Juvix.Compiler.Pipeline.Package.Loader.EvalEff
import Juvix.Compiler.Pipeline.Package.Loader.PathResolver
import Juvix.Data.Effect.Git
diff --git a/src/Juvix/Compiler/Pipeline/Driver.hs b/src/Juvix/Compiler/Pipeline/Driver.hs
new file mode 100644
index 0000000000..68c16c4be6
--- /dev/null
+++ b/src/Juvix/Compiler/Pipeline/Driver.hs
@@ -0,0 +1,292 @@
+module Juvix.Compiler.Pipeline.Driver
+ ( processFile,
+ processFileUpTo,
+ processFileToStoredCore,
+ processModule,
+ processImport,
+ processRecursiveUpToTyped,
+ )
+where
+
+import Data.HashMap.Strict qualified as HashMap
+import Data.List.NonEmpty qualified as NonEmpty
+import Juvix.Compiler.Concrete (ImportCycle (ImportCycle), ScoperError (ErrImportCycle))
+import Juvix.Compiler.Concrete.Data.Highlight
+import Juvix.Compiler.Concrete.Language
+import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context qualified as Scoper
+import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser
+import Juvix.Compiler.Concrete.Translation.FromSource.Data.ParserState (parserStateImports)
+import Juvix.Compiler.Concrete.Translation.FromSource.Data.ParserState qualified as Parser
+import Juvix.Compiler.Core.Data.Module qualified as Core
+import Juvix.Compiler.Core.Translation.FromInternal.Data.Context qualified as Core
+import Juvix.Compiler.Internal.Translation.FromConcrete.Data.Context qualified as Internal
+import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context qualified as InternalTyped
+import Juvix.Compiler.Internal.Translation.FromInternal.Data (InternalTypedResult)
+import Juvix.Compiler.Pipeline
+import Juvix.Compiler.Pipeline.Loader.PathResolver
+import Juvix.Compiler.Store.Core.Extra
+import Juvix.Compiler.Store.Extra qualified as Store
+import Juvix.Compiler.Store.Language qualified as Store
+import Juvix.Compiler.Store.Options qualified as StoredModule
+import Juvix.Compiler.Store.Options qualified as StoredOptions
+import Juvix.Data.CodeAnn
+import Juvix.Data.Effect.Git
+import Juvix.Data.Effect.TaggedLock
+import Juvix.Data.SHA256 qualified as SHA256
+import Juvix.Extra.Serialize
+import Juvix.Prelude
+import Path.Posix qualified as Path
+
+newtype ImportParents = ImportParents
+ { _importParents :: [TopModulePath]
+ }
+ deriving newtype (Semigroup, Monoid)
+
+makeLenses ''ImportParents
+
+newtype EntryIndex = EntryIndex
+ { _entryIxEntry :: EntryPoint
+ }
+
+makeLenses ''EntryIndex
+
+instance Eq EntryIndex where
+ (==) = (==) `on` (^. entryIxEntry . entryPointModulePath)
+
+instance Hashable EntryIndex where
+ hashWithSalt s = hashWithSalt s . (^. entryIxEntry . entryPointModulePath)
+
+type MCache' a = Cache EntryIndex a
+
+type MCache = MCache' (PipelineResult Store.ModuleInfo)
+
+processFile ::
+ forall r.
+ (Members '[TaggedLock, HighlightBuilder, Error JuvixError, Files, GitClone, PathResolver] r) =>
+ EntryPoint ->
+ Sem r (PipelineResult Parser.ParserResult)
+processFile entry =
+ runReader @ImportParents mempty $
+ evalCacheEmpty processModule' $
+ processFile' entry
+
+processImport ::
+ forall r.
+ (Members '[TaggedLock, Error JuvixError, Files, GitClone, PathResolver] r) =>
+ EntryPoint ->
+ Import 'Parsed ->
+ Sem r (PipelineResult Store.ModuleInfo)
+processImport entry i =
+ runReader @ImportParents mempty $
+ evalCacheEmpty processModule' $
+ processImport' entry (i ^. importModulePath)
+
+processModule ::
+ forall r.
+ (Members '[TaggedLock, Error JuvixError, Files, GitClone, PathResolver] r) =>
+ EntryPoint ->
+ Sem r (PipelineResult Store.ModuleInfo)
+processModule entry =
+ runReader @ImportParents mempty $
+ evalCacheEmpty processModule' $
+ processModule' (EntryIndex entry)
+
+processFileToStoredCore ::
+ forall r.
+ (Members '[TaggedLock, Error JuvixError, Files, GitClone, PathResolver] r) =>
+ EntryPoint ->
+ Sem r (PipelineResult Core.CoreResult)
+processFileToStoredCore entry =
+ runReader @ImportParents mempty $
+ evalCacheEmpty processModule' $
+ processFileToStoredCore' entry
+
+processFileUpTo ::
+ forall r a.
+ (Members '[TaggedLock, HighlightBuilder, Reader EntryPoint, Error JuvixError, Files, GitClone, PathResolver] r) =>
+ Sem (Reader Parser.ParserResult ': Reader Store.ModuleTable ': NameIdGen ': r) a ->
+ Sem r (PipelineResult a)
+processFileUpTo a = do
+ entry <- ask
+ res <- processFile entry
+ a' <-
+ evalTopNameIdGen
+ (res ^. pipelineResult . Parser.resultModule . moduleId)
+ $ runReader (res ^. pipelineResultImports)
+ $ runReader (res ^. pipelineResult) a
+ return $ set pipelineResult a' res
+
+processFile' ::
+ forall r.
+ (Members '[HighlightBuilder, Reader ImportParents, Error JuvixError, Files, GitClone, PathResolver, MCache] r) =>
+ EntryPoint ->
+ Sem r (PipelineResult Parser.ParserResult)
+processFile' entry = do
+ res <- runReader entry upToParsing
+ let imports = res ^. Parser.resultParserState . Parser.parserStateImports
+ mtab <- processImports' entry (map (^. importModulePath) imports)
+ return (PipelineResult res mtab True)
+
+processImports' ::
+ forall r.
+ (Members '[Reader ImportParents, Error JuvixError, Files, GitClone, PathResolver, MCache] r) =>
+ EntryPoint ->
+ [TopModulePath] ->
+ Sem r Store.ModuleTable
+processImports' entry imports = snd <$> processImports'' entry imports
+
+processImports'' ::
+ forall r.
+ (Members '[Reader ImportParents, Error JuvixError, Files, GitClone, PathResolver, MCache] r) =>
+ EntryPoint ->
+ [TopModulePath] ->
+ Sem r (Bool, Store.ModuleTable)
+processImports'' entry imports = do
+ ms <- forM imports (processImport' entry)
+ let mtab = Store.mkModuleTable (map (^. pipelineResult) ms) <> mconcatMap (^. pipelineResultImports) ms
+ changed = any (^. pipelineResultChanged) ms
+ return (changed, mtab)
+
+processImport' ::
+ forall r a.
+ (Members '[Reader ImportParents, Error JuvixError, Files, GitClone, PathResolver, MCache' a] r) =>
+ EntryPoint ->
+ TopModulePath ->
+ Sem r a
+processImport' entry p = do
+ checkCycle
+ local (over importParents (p :)) $
+ withPath' p getCachedImport
+ where
+ checkCycle :: Sem r ()
+ checkCycle = do
+ topp <- asks (^. importParents)
+ case span (/= p) topp of
+ (_, []) -> return ()
+ (c, _) ->
+ let cyc = NonEmpty.reverse (p :| c)
+ in mapError (JuvixError @ScoperError) $
+ throw (ErrImportCycle (ImportCycle cyc))
+
+ getCachedImport :: Path Abs File -> Sem r a
+ getCachedImport path = cacheGet (EntryIndex entry')
+ where
+ entry' =
+ entry
+ { _entryPointStdin = Nothing,
+ _entryPointModulePath = Just path
+ }
+
+processFileToStoredCore' ::
+ forall r.
+ (Members '[Reader ImportParents, Error JuvixError, Files, GitClone, PathResolver, MCache] r) =>
+ EntryPoint ->
+ Sem r (PipelineResult Core.CoreResult)
+processFileToStoredCore' entry = ignoreHighlightBuilder $ do
+ res <- processFile' entry
+ r <-
+ evalTopNameIdGen
+ (res ^. pipelineResult . Parser.resultModule . moduleId)
+ $ runReader (res ^. pipelineResultImports)
+ $ runReader entry
+ $ runReader (res ^. pipelineResult) upToStoredCore
+ return $ set pipelineResult r res
+
+processModule' ::
+ forall r.
+ (Members '[TaggedLock, Reader ImportParents, Error JuvixError, Files, GitClone, PathResolver, MCache] r) =>
+ EntryIndex ->
+ Sem r (PipelineResult Store.ModuleInfo)
+processModule' (EntryIndex entry) = do
+ let buildDir = resolveAbsBuildDir root (entry ^. entryPointBuildDir)
+ relPath = fromJust $ replaceExtension ".jvo" $ fromJust $ stripProperPrefix $(mkAbsDir "/") sourcePath
+ absPath = buildDir Path.> relPath
+ sha256 <- SHA256.digestFile sourcePath
+ m :: Maybe Store.ModuleInfo <- loadFromFile absPath
+ case m of
+ Just info
+ | info ^. Store.moduleInfoSHA256 == sha256
+ && info ^. Store.moduleInfoOptions == opts -> do
+ (changed, mtab) <- processImports'' entry (info ^. Store.moduleInfoImports)
+ -- We need to check whether any of the recursive imports is fragile,
+ -- not only the direct ones, because identifiers may be re-exported
+ -- (with `open public`).
+ let fragile = any (^. Store.moduleInfoFragile) (HashMap.elems $ mtab ^. Store.moduleTable)
+ if
+ | changed && fragile ->
+ recompile sha256 absPath
+ | otherwise ->
+ return (PipelineResult info mtab False)
+ _ ->
+ recompile sha256 absPath
+ where
+ root = entry ^. entryPointRoot
+ sourcePath = fromJust $ entry ^. entryPointModulePath
+ opts = StoredModule.fromEntryPoint entry
+
+ recompile :: Text -> Path Abs File -> Sem r (PipelineResult Store.ModuleInfo)
+ recompile sha256 absPath = do
+ res <- processModule'' sha256 entry
+ saveToFile absPath (res ^. pipelineResult)
+ return res
+
+processModule'' ::
+ forall r.
+ (Members '[Reader ImportParents, Error JuvixError, Files, GitClone, PathResolver, MCache] r) =>
+ Text ->
+ EntryPoint ->
+ Sem r (PipelineResult Store.ModuleInfo)
+processModule'' sha256 entry = over pipelineResult mkModuleInfo <$> processFileToStoredCore' entry
+ where
+ mkModuleInfo :: Core.CoreResult -> Store.ModuleInfo
+ mkModuleInfo Core.CoreResult {..} =
+ Store.ModuleInfo
+ { _moduleInfoScopedModule = scoperResult ^. Scoper.resultScopedModule,
+ _moduleInfoInternalModule = _coreResultInternalTypedResult ^. InternalTyped.resultInternalModule,
+ _moduleInfoCoreTable = fromCore (_coreResultModule ^. Core.moduleInfoTable),
+ _moduleInfoImports = map (^. importModulePath) $ scoperResult ^. Scoper.resultParserResult . Parser.resultParserState . parserStateImports,
+ _moduleInfoOptions = StoredOptions.fromEntryPoint entry,
+ _moduleInfoFragile = Core.moduleIsFragile _coreResultModule,
+ _moduleInfoSHA256 = sha256
+ }
+ where
+ scoperResult = _coreResultInternalTypedResult ^. InternalTyped.resultInternal . Internal.resultScoper
+
+processRecursiveUpToTyped ::
+ forall r.
+ (Members '[Reader EntryPoint, TaggedLock, HighlightBuilder, Error JuvixError, Files, GitClone, PathResolver] r) =>
+ Sem r (InternalTypedResult, [InternalTypedResult])
+processRecursiveUpToTyped = do
+ entry <- ask
+ PipelineResult res mtab _ <- processFile entry
+ let imports = HashMap.keys (mtab ^. Store.moduleTable)
+ ms <- forM imports (`withPath'` goImport)
+ a <-
+ evalTopNameIdGen
+ (res ^. Parser.resultModule . moduleId)
+ . runReader mtab
+ . runReader res
+ $ upToInternalTyped
+ return (a, ms)
+ where
+ goImport :: Path Abs File -> Sem r InternalTypedResult
+ goImport path = do
+ entry <- ask
+ let entry' =
+ entry
+ { _entryPointStdin = Nothing,
+ _entryPointModulePath = Just path
+ }
+ (^. pipelineResult) <$> runReader entry' (processFileUpTo upToInternalTyped)
+
+withPath' ::
+ forall r a.
+ (Members '[PathResolver, Error JuvixError] r) =>
+ TopModulePath ->
+ (Path Abs File -> Sem r a) ->
+ Sem r a
+withPath' path a = withPathFile path (either throwError a)
+ where
+ throwError :: PathResolverError -> Sem r a
+ throwError e =
+ mapError (JuvixError @PathResolverError) $ throw e
diff --git a/src/Juvix/Compiler/Pipeline/EntryPoint.hs b/src/Juvix/Compiler/Pipeline/EntryPoint.hs
index d36a21f0f6..b5fe4edf22 100644
--- a/src/Juvix/Compiler/Pipeline/EntryPoint.hs
+++ b/src/Juvix/Compiler/Pipeline/EntryPoint.hs
@@ -15,7 +15,7 @@ data SymbolPruningMode
| KeepAll
deriving stock (Eq, Show)
--- | The head of _entryModulePaths is assumed to be the Main module
+-- | A module in _entryModulePath is the unit of compilation
data EntryPoint = EntryPoint
{ _entryPointRoot :: Path Abs Dir,
-- | initial root for the path resolver. Usually it should be equal to
@@ -36,7 +36,7 @@ data EntryPoint = EntryPoint
_entryPointOptimizationLevel :: Int,
_entryPointInliningDepth :: Int,
_entryPointGenericOptions :: GenericOptions,
- _entryPointModulePaths :: [Path Abs File],
+ _entryPointModulePath :: Maybe (Path Abs File),
_entryPointSymbolPruningMode :: SymbolPruningMode,
_entryPointOffline :: Bool
}
@@ -47,7 +47,7 @@ makeLenses ''EntryPoint
defaultEntryPoint :: Package -> Root -> Path Abs File -> EntryPoint
defaultEntryPoint pkg root mainFile =
(defaultEntryPointNoFile pkg root)
- { _entryPointModulePaths = pure mainFile
+ { _entryPointModulePath = pure mainFile
}
defaultEntryPointNoFile :: Package -> Root -> EntryPoint
@@ -70,7 +70,7 @@ defaultEntryPointNoFile pkg root =
_entryPointUnrollLimit = defaultUnrollLimit,
_entryPointOptimizationLevel = defaultOptimizationLevel,
_entryPointInliningDepth = defaultInliningDepth,
- _entryPointModulePaths = [],
+ _entryPointModulePath = Nothing,
_entryPointSymbolPruningMode = FilterUnreachable,
_entryPointOffline = False
}
@@ -83,6 +83,3 @@ defaultOptimizationLevel = 1
defaultInliningDepth :: Int
defaultInliningDepth = 3
-
-mainModulePath :: Traversal' EntryPoint (Path Abs File)
-mainModulePath = entryPointModulePaths . _head
diff --git a/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs b/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs
index 4e8f65cdb0..f793b05c01 100644
--- a/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs
+++ b/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs
@@ -1,7 +1,6 @@
module Juvix.Compiler.Pipeline.EntryPoint.IO where
import Juvix.Compiler.Pipeline.EntryPoint
-import Juvix.Compiler.Pipeline.Package
import Juvix.Compiler.Pipeline.Root
import Juvix.Data.Effect.TaggedLock
import Juvix.Prelude
diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs b/src/Juvix/Compiler/Pipeline/Loader/PathResolver.hs
similarity index 94%
rename from src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs
rename to src/Juvix/Compiler/Pipeline/Loader/PathResolver.hs
index 2953922ff3..583883ff98 100644
--- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs
+++ b/src/Juvix/Compiler/Pipeline/Loader/PathResolver.hs
@@ -1,9 +1,9 @@
-module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver
- ( module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Paths,
- module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Base,
- module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error,
- module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Data,
- module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.PackageInfo,
+module Juvix.Compiler.Pipeline.Loader.PathResolver
+ ( module Juvix.Compiler.Pipeline.Loader.PathResolver.Paths,
+ module Juvix.Compiler.Pipeline.Loader.PathResolver.Base,
+ module Juvix.Compiler.Pipeline.Loader.PathResolver.Error,
+ module Juvix.Compiler.Pipeline.Loader.PathResolver.Data,
+ module Juvix.Compiler.Pipeline.Loader.PathResolver.PackageInfo,
runPathResolver,
runPathResolverPipe,
runPathResolverPipe',
@@ -15,12 +15,12 @@ import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet
import Data.Text qualified as T
import Juvix.Compiler.Concrete.Data.Name
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Base
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Data
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.PackageInfo
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Paths
import Juvix.Compiler.Pipeline.EntryPoint
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Base
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Data
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Error
+import Juvix.Compiler.Pipeline.Loader.PathResolver.PackageInfo
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Paths
import Juvix.Compiler.Pipeline.Lockfile
import Juvix.Compiler.Pipeline.Package
import Juvix.Compiler.Pipeline.Package.Loader.EvalEff
@@ -437,7 +437,7 @@ runPathResolver' st root x = do
e <- ask
let _envSingleFile :: Maybe (Path Abs File)
_envSingleFile
- | e ^. entryPointPackageType == GlobalStdlib = e ^? entryPointModulePaths . _head
+ | e ^. entryPointPackageType == GlobalStdlib = e ^. entryPointModulePath
| otherwise = Nothing
env :: ResolverEnv
env =
diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Base.hs b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Base.hs
similarity index 69%
rename from src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Base.hs
rename to src/Juvix/Compiler/Pipeline/Loader/PathResolver/Base.hs
index 64b254dee9..03c787287c 100644
--- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Base.hs
+++ b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Base.hs
@@ -1,12 +1,12 @@
-module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Base
- ( module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Base,
- module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.DependenciesConfig,
+module Juvix.Compiler.Pipeline.Loader.PathResolver.Base
+ ( module Juvix.Compiler.Pipeline.Loader.PathResolver.Base,
+ module Juvix.Compiler.Pipeline.Loader.PathResolver.DependenciesConfig,
)
where
import Juvix.Compiler.Concrete.Data.Name
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.DependenciesConfig
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error
+import Juvix.Compiler.Pipeline.Loader.PathResolver.DependenciesConfig
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Error
import Juvix.Prelude
data RootKind
diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Data.hs b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Data.hs
similarity index 93%
rename from src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Data.hs
rename to src/Juvix/Compiler/Pipeline/Loader/PathResolver/Data.hs
index 3de76e7e98..9a72754290 100644
--- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Data.hs
+++ b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Data.hs
@@ -1,6 +1,6 @@
-module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Data where
+module Juvix.Compiler.Pipeline.Loader.PathResolver.Data where
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.PackageInfo
+import Juvix.Compiler.Pipeline.Loader.PathResolver.PackageInfo
import Juvix.Compiler.Pipeline.Lockfile
import Juvix.Compiler.Pipeline.Package.Base
import Juvix.Prelude
diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/DependenciesConfig.hs b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/DependenciesConfig.hs
similarity index 75%
rename from src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/DependenciesConfig.hs
rename to src/Juvix/Compiler/Pipeline/Loader/PathResolver/DependenciesConfig.hs
index 0280b2f9ca..07bb45a2f0 100644
--- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/DependenciesConfig.hs
+++ b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/DependenciesConfig.hs
@@ -1,4 +1,4 @@
-module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.DependenciesConfig where
+module Juvix.Compiler.Pipeline.Loader.PathResolver.DependenciesConfig where
import Juvix.Prelude.Base
diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Error.hs b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Error.hs
similarity index 87%
rename from src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Error.hs
rename to src/Juvix/Compiler/Pipeline/Loader/PathResolver/Error.hs
index 292c23277f..7e16cdb451 100644
--- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Error.hs
+++ b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Error.hs
@@ -1,8 +1,8 @@
-module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error where
+module Juvix.Compiler.Pipeline.Loader.PathResolver.Error where
import Juvix.Compiler.Concrete.Language
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.PackageInfo
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Paths
+import Juvix.Compiler.Pipeline.Loader.PathResolver.PackageInfo
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Paths
import Juvix.Compiler.Pipeline.Package.Base
import Juvix.Data.CodeAnn
import Juvix.Data.Effect.Git
@@ -96,6 +96,26 @@ data PathResolverError
| ErrPackageInvalidImport PackageInvalidImport
deriving stock (Show)
+instance ToGenericError PathResolverError where
+ genericError e =
+ return $
+ GenericError
+ { _genericErrorLoc = i,
+ _genericErrorMessage = mkAnsiText $ ppCodeAnn e,
+ _genericErrorIntervals = [i]
+ }
+ where
+ i = getLoc e
+
+instance HasLoc PathResolverError where
+ getLoc = \case
+ ErrDependencyConflict DependencyConflict {..} ->
+ getLoc _conflictPath
+ ErrMissingModule MissingModule {..} ->
+ getLoc _missingModule
+ ErrPackageInvalidImport PackageInvalidImport {..} ->
+ getLoc _packageInvalidImport
+
instance PrettyCodeAnn PathResolverError where
ppCodeAnn = \case
ErrDependencyConflict e -> ppCodeAnn e
diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/PackageInfo.hs b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/PackageInfo.hs
similarity index 84%
rename from src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/PackageInfo.hs
rename to src/Juvix/Compiler/Pipeline/Loader/PathResolver/PackageInfo.hs
index c17058dded..d361331f8a 100644
--- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/PackageInfo.hs
+++ b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/PackageInfo.hs
@@ -1,4 +1,4 @@
-module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.PackageInfo where
+module Juvix.Compiler.Pipeline.Loader.PathResolver.PackageInfo where
import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Prelude
diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Paths.hs b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Paths.hs
similarity index 94%
rename from src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Paths.hs
rename to src/Juvix/Compiler/Pipeline/Loader/PathResolver/Paths.hs
index 7d3e7f1592..0371e5340a 100644
--- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Paths.hs
+++ b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Paths.hs
@@ -1,4 +1,4 @@
-module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Paths where
+module Juvix.Compiler.Pipeline.Loader.PathResolver.Paths where
import Data.Text qualified as Text
import Juvix.Compiler.Concrete.Data.Name
diff --git a/src/Juvix/Compiler/Pipeline/Package.hs b/src/Juvix/Compiler/Pipeline/Package.hs
index 2fef5e53d1..d6e6d5e69a 100644
--- a/src/Juvix/Compiler/Pipeline/Package.hs
+++ b/src/Juvix/Compiler/Pipeline/Package.hs
@@ -1,11 +1,7 @@
module Juvix.Compiler.Pipeline.Package
( module Juvix.Compiler.Pipeline.Package.Base,
readPackage,
- readPackageIO,
- readPackageRootIO,
- readGlobalPackageIO,
readGlobalPackage,
- loadPackageFileIO,
packageBasePackage,
ensureGlobalPackage,
)
@@ -20,9 +16,6 @@ import Juvix.Compiler.Pipeline.Package.Base
import Juvix.Compiler.Pipeline.Package.Loader
import Juvix.Compiler.Pipeline.Package.Loader.Error
import Juvix.Compiler.Pipeline.Package.Loader.EvalEff
-import Juvix.Compiler.Pipeline.Package.Loader.EvalEff.IO
-import Juvix.Compiler.Pipeline.Root.Base
-import Juvix.Compiler.Pipeline.Root.Base qualified as Root
import Juvix.Data.Effect.TaggedLock
import Juvix.Extra.Paths
import Juvix.Prelude
@@ -130,32 +123,6 @@ readPackageFile root buildDir f = mapError (JuvixError @PackageLoaderError) $ do
checkNoDuplicateDepNames f (pkg ^. packageDependencies)
return (pkg {_packageLockfile = mLockfile})
-loadPackageFileIO :: (Members '[TaggedLock, Error JuvixError, Embed IO] r) => Path Abs Dir -> BuildDir -> Sem r Package
-loadPackageFileIO root buildDir =
- runFilesIO
- . mapError (JuvixError @PackageLoaderError)
- . runEvalFileEffIO
- $ loadPackage buildDir (mkPackagePath root)
-
-readPackageRootIO :: (Members '[TaggedLock, Embed IO] r) => Root -> Sem r Package
-readPackageRootIO root = readPackageIO (root ^. rootRootDir) (root ^. Root.rootBuildDir)
-
-readPackageIO :: (Members '[TaggedLock, Embed IO] r) => Path Abs Dir -> BuildDir -> Sem r Package
-readPackageIO root buildDir =
- runFilesIO
- . runErrorIO' @JuvixError
- . mapError (JuvixError @PackageLoaderError)
- . runEvalFileEffIO
- $ readPackage root buildDir
-
-readGlobalPackageIO :: (Members '[Embed IO, TaggedLock] r) => Sem r Package
-readGlobalPackageIO =
- runFilesIO
- . runErrorIO' @JuvixError
- . mapError (JuvixError @PackageLoaderError)
- . runEvalFileEffIO
- $ readGlobalPackage
-
ensureGlobalPackage :: (Members '[TaggedLock, Files] r) => Sem r (Path Abs File)
ensureGlobalPackage = do
packagePath <- globalPackageJuvix
diff --git a/src/Juvix/Compiler/Pipeline/Package/IO.hs b/src/Juvix/Compiler/Pipeline/Package/IO.hs
new file mode 100644
index 0000000000..0601e680cc
--- /dev/null
+++ b/src/Juvix/Compiler/Pipeline/Package/IO.hs
@@ -0,0 +1,35 @@
+module Juvix.Compiler.Pipeline.Package.IO
+ ( module Juvix.Compiler.Pipeline.Package.IO,
+ module Juvix.Compiler.Pipeline.Package,
+ )
+where
+
+import Juvix.Compiler.Pipeline.Package
+import Juvix.Compiler.Pipeline.Package.Loader
+import Juvix.Compiler.Pipeline.Package.Loader.Error
+import Juvix.Compiler.Pipeline.Package.Loader.EvalEff.IO
+import Juvix.Data.Effect.TaggedLock
+import Juvix.Prelude
+
+loadPackageFileIO :: (Members '[TaggedLock, Error JuvixError, Embed IO] r) => Path Abs Dir -> BuildDir -> Sem r Package
+loadPackageFileIO root buildDir =
+ runFilesIO
+ . mapError (JuvixError @PackageLoaderError)
+ . runEvalFileEffIO
+ $ loadPackage buildDir (mkPackagePath root)
+
+readPackageIO :: (Members '[TaggedLock, Embed IO] r) => Path Abs Dir -> BuildDir -> Sem r Package
+readPackageIO root buildDir =
+ runFilesIO
+ . runErrorIO' @JuvixError
+ . mapError (JuvixError @PackageLoaderError)
+ . runEvalFileEffIO
+ $ readPackage root buildDir
+
+readGlobalPackageIO :: (Members '[Embed IO, TaggedLock] r) => Sem r Package
+readGlobalPackageIO =
+ runFilesIO
+ . runErrorIO' @JuvixError
+ . mapError (JuvixError @PackageLoaderError)
+ . runEvalFileEffIO
+ $ readGlobalPackage
diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader.hs b/src/Juvix/Compiler/Pipeline/Package/Loader.hs
index 9c9e3fdb89..5c4f01fc98 100644
--- a/src/Juvix/Compiler/Pipeline/Package/Loader.hs
+++ b/src/Juvix/Compiler/Pipeline/Package/Loader.hs
@@ -67,6 +67,12 @@ toConcrete t p = run . runReader l $ do
return (stdlib <> body)
_moduleKw <- kw kwModule
let _modulePath = mkTopModulePath (packageSymbol :| [])
+ _moduleId =
+ ModuleId
+ { _moduleIdPath = show $ pretty (p ^. packageFile),
+ _moduleIdPackage = p ^. packageName,
+ _moduleIdPackageVersion = show (p ^. packageVersion)
+ }
return
Module
{ _moduleKwEnd = (),
@@ -104,7 +110,7 @@ toConcrete t p = run . runReader l $ do
| otherwise = return Nothing
mkImport :: (Member (Reader Interval) r) => TopModulePath -> Sem r (Statement 'Parsed)
- mkImport _importModule = do
+ mkImport _importModulePath = do
_openModuleKw <- kw kwOpen
_importKw <- kw kwImport
return
diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs b/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs
index 0719f5b111..3ec8bd40c2 100644
--- a/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs
+++ b/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs
@@ -5,14 +5,14 @@ module Juvix.Compiler.Pipeline.Package.Loader.EvalEff.IO
where
import Data.HashMap.Strict qualified as HashMap
-import Juvix.Compiler.Builtins
import Juvix.Compiler.Concrete hiding (Symbol)
-import Juvix.Compiler.Core (CoreResult, coreResultTable)
+import Juvix.Compiler.Core (CoreResult, coreResultModule)
import Juvix.Compiler.Core qualified as Core
import Juvix.Compiler.Core.Evaluator
import Juvix.Compiler.Core.Extra.Value
import Juvix.Compiler.Core.Language
import Juvix.Compiler.Pipeline
+import Juvix.Compiler.Pipeline.Driver (processFileToStoredCore)
import Juvix.Compiler.Pipeline.Package.Loader.Error
import Juvix.Compiler.Pipeline.Package.Loader.EvalEff
import Juvix.Compiler.Pipeline.Package.Loader.PathResolver
@@ -58,7 +58,7 @@ runEvalFileEffIO = interpretScopedAs allocator handler
AssertNodeType n ty -> assertNodeType' n ty
where
tab :: Core.InfoTable
- tab = res ^. loaderResourceResult . coreResultTable
+ tab = Core.computeCombinedInfoTable (res ^. loaderResourceResult . coreResultModule)
packagePath :: Path Abs File
packagePath = res ^. loaderResourcePackagePath
@@ -93,8 +93,8 @@ runEvalFileEffIO = interpretScopedAs allocator handler
evalN <- evalNode n
case evalN of
NCtr Constr {..} -> do
- let ci = Core.lookupConstructorInfo tab _constrTag
- ii = Core.lookupInductiveInfo tab (ci ^. Core.constructorInductive)
+ let ci = Core.lookupTabConstructorInfo tab _constrTag
+ ii = Core.lookupTabInductiveInfo tab (ci ^. Core.constructorInductive)
ty = find (checkInductiveType ii) tys
fromMaybeM err (return ty)
_ -> err
@@ -127,16 +127,14 @@ loadPackage' packagePath = do
. evalInternetOffline
. ignoreHighlightBuilder
. runProcessIO
- . evalTopBuiltins
- . evalTopNameIdGen
- . evalTopBuiltins
- . evalTopNameIdGen
+ . runFilesIO
+ . evalTopNameIdGen defaultModuleId
. runReader packageEntryPoint
. ignoreLog
. mapError (JuvixError @GitProcessError)
. runGitProcess
. runPackagePathResolver rootPath
- $ upToEval
+ $ (^. pipelineResult) <$> processFileToStoredCore packageEntryPoint
)
where
rootPath :: Path Abs Dir
diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs b/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs
index 949952026c..7f5a584282 100644
--- a/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs
+++ b/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs
@@ -2,11 +2,11 @@ module Juvix.Compiler.Pipeline.Package.Loader.PathResolver where
import Data.HashSet qualified as HashSet
import Juvix.Compiler.Concrete hiding (Symbol)
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Base
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Data
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Paths
import Juvix.Compiler.Core.Language
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Base
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Data
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Error
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Paths
import Juvix.Data.Effect.TaggedLock
import Juvix.Extra.PackageFiles
import Juvix.Extra.Paths
diff --git a/src/Juvix/Compiler/Pipeline/Repl.hs b/src/Juvix/Compiler/Pipeline/Repl.hs
index 2f13b2d7fd..8bf7efc333 100644
--- a/src/Juvix/Compiler/Pipeline/Repl.hs
+++ b/src/Juvix/Compiler/Pipeline/Repl.hs
@@ -1,39 +1,40 @@
module Juvix.Compiler.Pipeline.Repl where
-import Juvix.Compiler.Builtins (Builtins)
-import Juvix.Compiler.Concrete.Data.InfoTableBuilder qualified as Concrete
-import Juvix.Compiler.Concrete.Data.ParsedInfoTableBuilder.BuilderState qualified as C
-import Juvix.Compiler.Concrete.Data.Scope qualified as Scoper
+import Juvix.Compiler.Concrete (ignoreHighlightBuilder)
import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Concrete.Translation.FromParsed qualified as Scoper
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver
import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser
+import Juvix.Compiler.Concrete.Translation.FromSource.ParserResultBuilder (runParserResultBuilder)
import Juvix.Compiler.Core qualified as Core
import Juvix.Compiler.Internal qualified as Internal
-import Juvix.Compiler.Internal.Translation.FromConcrete qualified as FromConcrete
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker
import Juvix.Compiler.Pipeline.Artifacts
import Juvix.Compiler.Pipeline.Artifacts.PathResolver
+import Juvix.Compiler.Pipeline.Driver qualified as Driver
import Juvix.Compiler.Pipeline.EntryPoint
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Base
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Error
import Juvix.Compiler.Pipeline.Package.Loader.Error
import Juvix.Compiler.Pipeline.Package.Loader.EvalEff.IO
-import Juvix.Data.Effect.Git.Process
-import Juvix.Data.Effect.Git.Process.Error
+import Juvix.Compiler.Pipeline.Result
+import Juvix.Compiler.Store.Extra qualified as Store
+import Juvix.Data.Effect.Git
import Juvix.Data.Effect.Process (runProcessIO)
import Juvix.Data.Effect.TaggedLock
import Juvix.Prelude
upToInternalExpression ::
- (Members '[Error JuvixError, State Artifacts, Termination] r) =>
+ (Members '[Reader EntryPoint, Error JuvixError, State Artifacts, Termination] r) =>
ExpressionAtoms 'Parsed ->
Sem r Internal.Expression
upToInternalExpression p = do
scopeTable <- gets (^. artifactScopeTable)
+ mtab <- gets (^. artifactModuleTable)
runBuiltinsArtifacts
. runScoperScopeArtifacts
. runStateArtifacts artifactScoperState
- $ runNameIdGenArtifacts (Scoper.scopeCheckExpression scopeTable p)
- >>= runNameIdGenArtifacts . Internal.fromConcreteExpression
+ $ runNameIdGenArtifacts (Scoper.scopeCheckExpression (Store.getScopedModuleTable mtab) scopeTable p)
+ >>= runNameIdGenArtifacts . runReader scopeTable . Internal.fromConcreteExpression
expressionUpToAtomsParsed ::
(Members '[State Artifacts, Error JuvixError] r) =>
@@ -46,71 +47,32 @@ expressionUpToAtomsParsed fp txt =
$ Parser.expressionFromTextSource fp txt
expressionUpToAtomsScoped ::
- (Members '[State Artifacts, Error JuvixError] r) =>
+ (Members '[Reader EntryPoint, State Artifacts, Error JuvixError] r) =>
Path Abs File ->
Text ->
Sem r (ExpressionAtoms 'Scoped)
expressionUpToAtomsScoped fp txt = do
scopeTable <- gets (^. artifactScopeTable)
- runNameIdGenArtifacts
- . runBuiltinsArtifacts
+ mtab <- gets (^. artifactModuleTable)
+ runBuiltinsArtifacts
. runScoperScopeArtifacts
+ . runStateArtifacts artifactScoperState
+ . runNameIdGenArtifacts
$ Parser.expressionFromTextSource fp txt
- >>= Scoper.scopeCheckExpressionAtoms scopeTable
+ >>= Scoper.scopeCheckExpressionAtoms (Store.getScopedModuleTable mtab) scopeTable
scopeCheckExpression ::
- (Members '[Error JuvixError, State Artifacts] r) =>
+ (Members '[Reader EntryPoint, Error JuvixError, State Artifacts] r) =>
ExpressionAtoms 'Parsed ->
Sem r Expression
scopeCheckExpression p = do
scopeTable <- gets (^. artifactScopeTable)
+ mtab <- gets (^. artifactModuleTable)
runNameIdGenArtifacts
. runBuiltinsArtifacts
. runScoperScopeArtifacts
. runStateArtifacts artifactScoperState
- . Scoper.scopeCheckExpression scopeTable
- $ p
-
-runToInternal ::
- (Members '[Reader EntryPoint, State Artifacts, Error JuvixError] r) =>
- Sem
- ( State Scoper.ScoperState
- ': FromConcrete.MCache
- ': Reader Scoper.ScopeParameters
- ': Reader (HashSet NameId)
- ': State Scoper.Scope
- ': Concrete.InfoTableBuilder
- ': Builtins
- ': NameIdGen
- ': r
- )
- b ->
- Sem r b
-runToInternal m = do
- parsedModules <- gets (^. artifactParsing . C.stateModules)
- runNameIdGenArtifacts
- . runBuiltinsArtifacts
- . runScoperInfoTableBuilderArtifacts
- . runScoperScopeArtifacts
- . runReaderArtifacts artifactScopeExports
- . runReader (Scoper.ScopeParameters mempty parsedModules)
- . runFromConcreteCache
- . runStateArtifacts artifactScoperState
- $ m
-
-importToInternal ::
- (Members '[Reader EntryPoint, Error JuvixError, State Artifacts, Termination] r) =>
- Import 'Parsed ->
- Sem r Internal.Import
-importToInternal i = runToInternal $ do
- Scoper.scopeCheckImport i
- >>= Internal.fromConcreteImport
-
-importToInternalTyped ::
- (Members '[Reader EntryPoint, Error JuvixError, State Artifacts, Termination] r) =>
- Internal.Import ->
- Sem r Internal.Import
-importToInternalTyped = Internal.typeCheckImport
+ $ Scoper.scopeCheckExpression (Store.getScopedModuleTable mtab) scopeTable p
parseReplInput ::
(Members '[PathResolver, Files, State Artifacts, Error JuvixError] r) =>
@@ -118,13 +80,13 @@ parseReplInput ::
Text ->
Sem r Parser.ReplInput
parseReplInput fp txt =
- runNameIdGenArtifacts
- . runBuiltinsArtifacts
- . runParserInfoTableBuilderArtifacts
- $ Parser.replInputFromTextSource fp txt
+ ignoreHighlightBuilder $
+ runNameIdGenArtifacts $
+ runStateLikeArtifacts runParserResultBuilder artifactParsing $
+ Parser.replInputFromTextSource fp txt
expressionUpToTyped ::
- (Members '[Error JuvixError, State Artifacts] r) =>
+ (Members '[Reader EntryPoint, Error JuvixError, State Artifacts] r) =>
Path Abs File ->
Text ->
Sem r Internal.TypedExpression
@@ -136,7 +98,7 @@ expressionUpToTyped fp txt = do
)
compileExpression ::
- (Members '[Error JuvixError, State Artifacts] r) =>
+ (Members '[Reader EntryPoint, Error JuvixError, State Artifacts] r) =>
ExpressionAtoms 'Parsed ->
Sem r Core.Node
compileExpression p =
@@ -147,29 +109,22 @@ compileExpression p =
>>= fromInternalExpression
registerImport ::
- (Members '[Error JuvixError, State Artifacts, Reader EntryPoint] r) =>
+ (Members '[TaggedLock, Error JuvixError, State Artifacts, Reader EntryPoint, Files, GitClone, PathResolver] r) =>
Import 'Parsed ->
Sem r ()
-registerImport p =
- runTerminationArtifacts
- ( importToInternal p
- >>= importToInternalTyped
- )
- >>= fromInternalImport
-
-fromInternalImport :: (Members '[State Artifacts] r) => Internal.Import -> Sem r ()
-fromInternalImport i = do
- artiTable <- gets (^. artifactInternalTypedTable)
- let table = Internal.buildTable [i ^. Internal.importModule . Internal.moduleIxModule] <> artiTable
- runNameIdGenArtifacts
- . runReader table
- . runCoreInfoTableBuilderArtifacts
- . runFunctionsTableArtifacts
- . readerTypesTableArtifacts
- . runReader Core.initIndexTable
- -- TODO add cache in Artifacts
- . evalVisitEmpty Core.goModuleNoVisit
- $ Core.goModule (i ^. Internal.importModule . Internal.moduleIxModule)
+registerImport i = do
+ e <- ask
+ PipelineResult {..} <- Driver.processImport e i
+ let mtab' = Store.insertModule (i ^. importModulePath) _pipelineResult _pipelineResultImports
+ modify' (appendArtifactsModuleTable mtab')
+ scopeTable <- gets (^. artifactScopeTable)
+ mtab'' <- gets (^. artifactModuleTable)
+ void
+ . runNameIdGenArtifacts
+ . runBuiltinsArtifacts
+ . runScoperScopeArtifacts
+ . runStateArtifacts artifactScoperState
+ $ Scoper.scopeCheckImport (Store.getScopedModuleTable mtab'') scopeTable i
fromInternalExpression :: (Members '[State Artifacts] r) => Internal.Expression -> Sem r Core.Node
fromInternalExpression exp = do
@@ -210,12 +165,5 @@ compileReplInputIO fp txt = do
p <- parseReplInput fp txt
case p of
Parser.ReplExpression e -> ReplPipelineResultNode <$> compileExpression e
- Parser.ReplImport i -> registerImport i $> ReplPipelineResultImport (i ^. importModule)
+ Parser.ReplImport i -> registerImport i $> ReplPipelineResultImport (i ^. importModulePath)
Parser.ReplOpenImport i -> return (ReplPipelineResultOpen (i ^. openModuleName))
-
-expressionUpToTypedIO ::
- (Members '[State Artifacts, Embed IO] r) =>
- Path Abs File ->
- Text ->
- Sem r (Either JuvixError Internal.TypedExpression)
-expressionUpToTypedIO fp txt = runError (expressionUpToTyped fp txt)
diff --git a/src/Juvix/Compiler/Pipeline/Result.hs b/src/Juvix/Compiler/Pipeline/Result.hs
new file mode 100644
index 0000000000..b98800053e
--- /dev/null
+++ b/src/Juvix/Compiler/Pipeline/Result.hs
@@ -0,0 +1,18 @@
+module Juvix.Compiler.Pipeline.Result where
+
+import Juvix.Compiler.Store.Language qualified as Store
+import Juvix.Prelude
+
+data PipelineResult a = PipelineResult
+ { _pipelineResult :: a,
+ -- | Transitive imports. The imports table contains all dependencies,
+ -- transitively. E.g., if module M imports A but not B, but A imports B,
+ -- then still both A and B will be in the imports table in the pipeline
+ -- result for processing M.
+ _pipelineResultImports :: Store.ModuleTable,
+ -- | True if the module had to be recompiled. False if the module was loaded
+ -- from disk.
+ _pipelineResultChanged :: Bool
+ }
+
+makeLenses ''PipelineResult
diff --git a/src/Juvix/Compiler/Pipeline/Root.hs b/src/Juvix/Compiler/Pipeline/Root.hs
index b6f4d60d83..9efdf5c786 100644
--- a/src/Juvix/Compiler/Pipeline/Root.hs
+++ b/src/Juvix/Compiler/Pipeline/Root.hs
@@ -6,12 +6,15 @@ where
import Control.Exception (SomeException)
import Control.Exception qualified as IO
-import Juvix.Compiler.Pipeline.Package
+import Juvix.Compiler.Pipeline.Package.IO
import Juvix.Compiler.Pipeline.Root.Base
import Juvix.Data.Effect.TaggedLock
import Juvix.Extra.Paths qualified as Paths
import Juvix.Prelude
+readPackageRootIO :: (Members '[TaggedLock, Embed IO] r) => Root -> Sem r Package
+readPackageRootIO root = readPackageIO (root ^. rootRootDir) (root ^. rootBuildDir)
+
findRootAndChangeDir ::
forall r.
(Members '[TaggedLock, Embed IO, Final IO] r) =>
diff --git a/src/Juvix/Compiler/Pipeline/Run.hs b/src/Juvix/Compiler/Pipeline/Run.hs
index 6ec148418f..729b1177ce 100644
--- a/src/Juvix/Compiler/Pipeline/Run.hs
+++ b/src/Juvix/Compiler/Pipeline/Run.hs
@@ -6,34 +6,65 @@ where
import Juvix.Compiler.Builtins
import Juvix.Compiler.Concrete.Data.Highlight
-import Juvix.Compiler.Concrete.Data.ParsedInfoTableBuilder.BuilderState qualified as Concrete
import Juvix.Compiler.Concrete.Data.Scope
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoped
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper
import Juvix.Compiler.Concrete.Translation.FromSource qualified as P
-import Juvix.Compiler.Core.Data.InfoTable qualified as Core
+import Juvix.Compiler.Core.Data.Module qualified as Core
import Juvix.Compiler.Core.Translation.FromInternal.Data qualified as Core
import Juvix.Compiler.Internal.Translation qualified as Internal
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking qualified as Typed
import Juvix.Compiler.Pipeline
import Juvix.Compiler.Pipeline.Artifacts.PathResolver
+import Juvix.Compiler.Pipeline.Driver
+import Juvix.Compiler.Pipeline.Loader.PathResolver
import Juvix.Compiler.Pipeline.Package.Loader.Error
import Juvix.Compiler.Pipeline.Package.Loader.EvalEff.IO
import Juvix.Compiler.Pipeline.Package.Loader.PathResolver
+import Juvix.Compiler.Pipeline.Setup
+import Juvix.Compiler.Store.Scoped.Language qualified as Scoped
import Juvix.Data.Effect.Git
import Juvix.Data.Effect.Process
import Juvix.Data.Effect.TaggedLock
import Juvix.Prelude
-runPipelineHighlight :: forall r a. (Members '[TaggedLock, Embed IO] r) => EntryPoint -> Sem (PipelineEff r) a -> Sem r HighlightInput
-runPipelineHighlight entry = fmap fst . runIOEither entry
-
-- | It returns `ResolverState` so that we can retrieve the `juvix.yaml` files,
-- which we require for `Scope` tests.
-runIOEither :: forall a r. (Members '[TaggedLock, Embed IO] r) => EntryPoint -> Sem (PipelineEff r) a -> Sem r (HighlightInput, (Either JuvixError (ResolverState, a)))
-runIOEither entry = do
+runIOEither :: forall a r. (Members '[TaggedLock, Embed IO] r) => EntryPoint -> Sem (PipelineEff r) a -> Sem r (Either JuvixError (ResolverState, PipelineResult a))
+runIOEither entry = fmap snd . runIOEitherHelper entry
+
+runIOEither' :: forall a r. (Members '[TaggedLock, Embed IO] r) => EntryPoint -> Sem (PipelineEff r) a -> Sem r (Either JuvixError (ResolverState, PipelineResult a))
+runIOEither' entry = fmap snd . runIOEitherHelper entry
+
+runPipelineHighlight :: forall a r. (Members '[TaggedLock, Embed IO] r) => EntryPoint -> Sem (PipelineEff r) a -> Sem r HighlightInput
+runPipelineHighlight entry = fmap fst . runIOEitherHelper entry
+
+runPipelineHtmlEither :: forall r. (Members '[TaggedLock, Embed IO] r) => EntryPoint -> Sem r (Either JuvixError (Typed.InternalTypedResult, [Typed.InternalTypedResult]))
+runPipelineHtmlEither entry = do
+ x <- runIOEitherPipeline' entry $ entrySetup defaultDependenciesConfig >> processRecursiveUpToTyped
+ return $ mapRight snd $ snd x
+
+runIOEitherHelper :: forall a r. (Members '[TaggedLock, Embed IO] r) => EntryPoint -> Sem (PipelineEff r) a -> Sem r (HighlightInput, (Either JuvixError (ResolverState, PipelineResult a)))
+runIOEitherHelper entry a = do
+ runIOEitherPipeline' entry $
+ entrySetup defaultDependenciesConfig >> processFileUpTo a
+
+runIOEitherPipeline ::
+ forall a r.
+ (Members '[TaggedLock, Embed IO] r) =>
+ EntryPoint ->
+ Sem (PipelineEff' r) a ->
+ Sem r (Either JuvixError (ResolverState, a))
+runIOEitherPipeline entry = fmap snd . runIOEitherPipeline' entry
+
+runIOEitherPipeline' ::
+ forall a r.
+ (Members '[TaggedLock, Embed IO] r) =>
+ EntryPoint ->
+ Sem (PipelineEff' r) a ->
+ Sem r (HighlightInput, (Either JuvixError (ResolverState, a)))
+runIOEitherPipeline' entry a = do
let hasInternet = not (entry ^. entryPointOffline)
runPathResolver'
| mainIsPackageFile entry = runPackagePathResolver' (entry ^. entryPointResolverRoot)
@@ -41,8 +72,6 @@ runIOEither entry = do
evalInternet hasInternet
. runHighlightBuilder
. runJuvixError
- . evalTopBuiltins
- . evalTopNameIdGen
. runFilesIO
. runReader entry
. runLogIO
@@ -53,41 +82,48 @@ runIOEither entry = do
. mapError (JuvixError @PackageLoaderError)
. runEvalFileEffIO
. runPathResolver'
+ $ a
mainIsPackageFile :: EntryPoint -> Bool
-mainIsPackageFile entry = case entry ^? entryPointModulePaths . _head of
+mainIsPackageFile entry = case entry ^. entryPointModulePath of
Just p -> p == mkPackagePath (entry ^. entryPointResolverRoot)
Nothing -> False
-runIO :: forall a r. (Members '[TaggedLock, Embed IO] r) => GenericOptions -> EntryPoint -> Sem (PipelineEff r) a -> Sem r (ResolverState, a)
-runIO opts entry = runIOEither entry >=> mayThrow . snd
+runIO ::
+ forall a r.
+ (Members '[TaggedLock, Embed IO] r) =>
+ GenericOptions ->
+ EntryPoint ->
+ Sem (PipelineEff r) a ->
+ Sem r (ResolverState, PipelineResult a)
+runIO opts entry = runIOEither entry >=> mayThrow
where
mayThrow :: (Members '[Embed IO] r') => Either JuvixError x -> Sem r' x
mayThrow = \case
Left err -> runReader opts $ printErrorAnsiSafe err >> embed exitFailure
Right r -> return r
-corePipelineIO' :: EntryPoint -> IO Artifacts
-corePipelineIO' = corePipelineIO defaultGenericOptions
+runReplPipelineIO :: EntryPoint -> IO Artifacts
+runReplPipelineIO = runReplPipelineIO' defaultGenericOptions
-corePipelineIO :: GenericOptions -> EntryPoint -> IO Artifacts
-corePipelineIO opts entry = corePipelineIOEither entry >>= mayThrow
+runReplPipelineIO' :: GenericOptions -> EntryPoint -> IO Artifacts
+runReplPipelineIO' opts entry = runReplPipelineIOEither entry >>= mayThrow
where
mayThrow :: Either JuvixError r -> IO r
mayThrow = \case
Left err -> runM . runReader opts $ printErrorAnsiSafe err >> embed exitFailure
Right r -> return r
-corePipelineIOEither ::
+runReplPipelineIOEither ::
EntryPoint ->
IO (Either JuvixError Artifacts)
-corePipelineIOEither = corePipelineIOEither' LockModePermissive
+runReplPipelineIOEither = runReplPipelineIOEither' LockModePermissive
-corePipelineIOEither' ::
+runReplPipelineIOEither' ::
LockMode ->
EntryPoint ->
IO (Either JuvixError Artifacts)
-corePipelineIOEither' lockMode entry = do
+runReplPipelineIOEither' lockMode entry = do
let hasInternet = not (entry ^. entryPointOffline)
runPathResolver'
| mainIsPackageFile entry = runPackagePathResolverArtifacts (entry ^. entryPointResolverRoot)
@@ -113,13 +149,13 @@ corePipelineIOEither' lockMode entry = do
. mapError (JuvixError @PackageLoaderError)
. runEvalFileEffIO
. runPathResolver'
- $ upToCore
+ $ entrySetup defaultDependenciesConfig >> processFileToStoredCore entry
return $ case eith of
Left err -> Left err
- Right (art, coreRes) ->
+ Right (art, PipelineResult {..}) ->
let typedResult :: Internal.InternalTypedResult
typedResult =
- coreRes
+ _pipelineResult
^. Core.coreResultInternalTypedResult
typesTable :: Typed.TypesTable
@@ -129,15 +165,15 @@ corePipelineIOEither' lockMode entry = do
functionsTable = typedResult ^. Typed.resultFunctions
typedTable :: Internal.InfoTable
- typedTable = typedResult ^. Typed.resultInfoTable
+ typedTable = typedResult ^. Typed.resultInternalModule . Typed.internalModuleInfoTable
internalResult :: Internal.InternalResult
internalResult =
typedResult
- ^. Typed.resultInternalResult
+ ^. Typed.resultInternal
- coreTable :: Core.InfoTable
- coreTable = coreRes ^. Core.coreResultTable
+ coreModule :: Core.Module
+ coreModule = _pipelineResult ^. Core.coreResultModule
scopedResult :: Scoped.ScoperResult
scopedResult =
@@ -147,44 +183,42 @@ corePipelineIOEither' lockMode entry = do
parserResult :: P.ParserResult
parserResult = scopedResult ^. Scoped.resultParserResult
- resultScoperTable :: Scoped.InfoTable
- resultScoperTable = scopedResult ^. Scoped.resultScoperTable
-
- mainModuleScope_ :: Scope
- mainModuleScope_ = Scoped.mainModuleSope scopedResult
+ resultScoperTable :: InfoTable
+ resultScoperTable = Scoped.getCombinedInfoTable (scopedResult ^. Scoped.resultScopedModule)
in Right $
- Artifacts
- { _artifactMainModuleScope = Just mainModuleScope_,
- _artifactParsing = parserResult ^. P.resultBuilderState,
- _artifactInternalModuleCache = internalResult ^. Internal.resultModulesCache,
- _artifactInternalTypedTable = typedTable,
- _artifactTerminationState = typedResult ^. Typed.resultTermination,
- _artifactCoreTable = coreTable,
- _artifactScopeTable = resultScoperTable,
- _artifactScopeExports = scopedResult ^. Scoped.resultExports,
- _artifactTypes = typesTable,
- _artifactFunctions = functionsTable,
- _artifactScoperState = scopedResult ^. Scoped.resultScoperState,
- _artifactResolver = art ^. artifactResolver,
- _artifactBuiltins = art ^. artifactBuiltins,
- _artifactNameIdState = art ^. artifactNameIdState
- }
+ appendArtifactsModuleTable _pipelineResultImports $
+ Artifacts
+ { _artifactMainModuleScope = Just $ scopedResult ^. Scoped.resultScope,
+ _artifactParsing = parserResult ^. P.resultParserState,
+ _artifactInternalTypedTable = typedTable,
+ _artifactTerminationState = typedResult ^. Typed.resultTermination,
+ _artifactCoreModule = coreModule,
+ _artifactScopeTable = resultScoperTable,
+ _artifactScopeExports = scopedResult ^. Scoped.resultExports,
+ _artifactTypes = typesTable,
+ _artifactFunctions = functionsTable,
+ _artifactScoperState = scopedResult ^. Scoped.resultScoperState,
+ _artifactResolver = art ^. artifactResolver,
+ _artifactBuiltins = art ^. artifactBuiltins,
+ _artifactNameIdState = art ^. artifactNameIdState,
+ _artifactModuleTable = mempty
+ }
where
initialArtifacts :: Artifacts
initialArtifacts =
Artifacts
- { _artifactParsing = Concrete.iniState,
+ { _artifactParsing = mempty,
_artifactMainModuleScope = Nothing,
_artifactInternalTypedTable = mempty,
- _artifactTypes = mempty,
_artifactTerminationState = iniTerminationState,
_artifactResolver = iniResolverState,
- _artifactNameIdState = allNameIds,
+ _artifactNameIdState = genNameIdState defaultModuleId,
+ _artifactTypes = mempty,
_artifactFunctions = mempty,
- _artifactCoreTable = Core.emptyInfoTable,
- _artifactScopeTable = Scoped.emptyInfoTable,
+ _artifactCoreModule = Core.emptyModule,
+ _artifactScopeTable = mempty,
_artifactBuiltins = iniBuiltins,
_artifactScopeExports = mempty,
- _artifactInternalModuleCache = Internal.ModulesCache mempty,
- _artifactScoperState = Scoper.iniScoperState
+ _artifactScoperState = Scoper.iniScoperState mempty,
+ _artifactModuleTable = mempty
}
diff --git a/src/Juvix/Compiler/Pipeline/Setup.hs b/src/Juvix/Compiler/Pipeline/Setup.hs
index c0fc56a867..7afe16c2a0 100644
--- a/src/Juvix/Compiler/Pipeline/Setup.hs
+++ b/src/Juvix/Compiler/Pipeline/Setup.hs
@@ -1,12 +1,10 @@
module Juvix.Compiler.Pipeline.Setup where
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Base
-import Juvix.Compiler.Pipeline.EntryPoint
-import Juvix.Data.Effect.Git
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Base
import Juvix.Prelude
entrySetup ::
- (Members '[Reader EntryPoint, Files, GitClone, PathResolver] r) =>
+ (Member PathResolver r) =>
DependenciesConfig ->
Sem r ()
entrySetup = registerDependencies
diff --git a/src/Juvix/Compiler/Store/Core/Data/InfoTable.hs b/src/Juvix/Compiler/Store/Core/Data/InfoTable.hs
new file mode 100644
index 0000000000..5ccebefa16
--- /dev/null
+++ b/src/Juvix/Compiler/Store/Core/Data/InfoTable.hs
@@ -0,0 +1,22 @@
+module Juvix.Compiler.Store.Core.Data.InfoTable
+ ( module Juvix.Compiler.Store.Core.Data.InfoTable,
+ module Juvix.Compiler.Core.Data.InfoTable.Base,
+ )
+where
+
+import Juvix.Compiler.Core.Data.InfoTable.Base
+import Juvix.Compiler.Store.Core.Language
+
+type InfoTable = InfoTable' Node
+
+type IdentifierInfo = IdentifierInfo' Node
+
+type InductiveInfo = InductiveInfo' Node
+
+type ConstructorInfo = ConstructorInfo' Node
+
+type AxiomInfo = AxiomInfo' Node
+
+type ParameterInfo = ParameterInfo' Node
+
+type SpecialisationInfo = SpecialisationInfo' Node
diff --git a/src/Juvix/Compiler/Store/Core/Extra.hs b/src/Juvix/Compiler/Store/Core/Extra.hs
new file mode 100644
index 0000000000..9cc71bcaff
--- /dev/null
+++ b/src/Juvix/Compiler/Store/Core/Extra.hs
@@ -0,0 +1,183 @@
+module Juvix.Compiler.Store.Core.Extra where
+
+import Juvix.Compiler.Core.Data.InfoTable qualified as Core
+import Juvix.Compiler.Core.Extra qualified as Core
+import Juvix.Compiler.Core.Language qualified as Core
+import Juvix.Compiler.Store.Core.Data.InfoTable
+import Juvix.Compiler.Store.Core.Language
+
+toCore :: InfoTable -> Core.InfoTable
+toCore InfoTable {..} =
+ Core.InfoTable
+ { _identContext = fmap goNode _identContext,
+ _identMap,
+ _infoMain,
+ _infoIdentifiers = fmap goIdentifierInfo _infoIdentifiers,
+ _infoInductives = fmap goInductiveInfo _infoInductives,
+ _infoConstructors = fmap goConstructorInfo _infoConstructors,
+ _infoAxioms = fmap goAxiomInfo _infoAxioms,
+ _infoSpecialisations = fmap (map goSpecialisationInfo) _infoSpecialisations,
+ _infoLiteralIntToNat,
+ _infoLiteralIntToInt,
+ _infoBuiltins
+ }
+ where
+ goIdentifierInfo :: IdentifierInfo -> Core.IdentifierInfo
+ goIdentifierInfo IdentifierInfo {..} =
+ Core.IdentifierInfo
+ { _identifierType = goNode _identifierType,
+ ..
+ }
+
+ goInductiveInfo :: InductiveInfo -> Core.InductiveInfo
+ goInductiveInfo InductiveInfo {..} =
+ Core.InductiveInfo
+ { _inductiveKind = goNode _inductiveKind,
+ _inductiveParams = map goParameterInfo _inductiveParams,
+ ..
+ }
+
+ goParameterInfo :: ParameterInfo -> Core.ParameterInfo
+ goParameterInfo ParameterInfo {..} =
+ Core.ParameterInfo
+ { _paramKind = goNode _paramKind,
+ ..
+ }
+
+ goConstructorInfo :: ConstructorInfo -> Core.ConstructorInfo
+ goConstructorInfo ConstructorInfo {..} =
+ Core.ConstructorInfo
+ { _constructorType = goNode _constructorType,
+ ..
+ }
+
+ goAxiomInfo :: AxiomInfo -> Core.AxiomInfo
+ goAxiomInfo AxiomInfo {..} =
+ Core.AxiomInfo
+ { _axiomType = goNode _axiomType,
+ ..
+ }
+
+ goSpecialisationInfo :: SpecialisationInfo -> Core.SpecialisationInfo
+ goSpecialisationInfo SpecialisationInfo {..} =
+ Core.SpecialisationInfo
+ { _specSignature = first (map goNode) _specSignature,
+ ..
+ }
+
+ goNode :: Node -> Core.Node
+ goNode = \case
+ NVar Var {..} -> Core.mkVar' _varIndex
+ NIdt Ident {..} -> Core.mkIdent' _identSymbol
+ NCst Constant {..} -> Core.mkConstant' _constantValue
+ NApp App {..} -> Core.mkApp' (goNode _appLeft) (goNode _appRight)
+ NBlt BuiltinApp {..} -> Core.mkBuiltinApp' _builtinAppOp (map goNode _builtinAppArgs)
+ NCtr Constr {..} -> Core.mkConstr' _constrTag (map goNode _constrArgs)
+ NLam Lambda {..} -> Core.mkLambda mempty (goBinder _lambdaBinder) (goNode _lambdaBody)
+ NLet Let {..} -> Core.NLet $ Core.Let mempty (goLetItem _letItem) (goNode _letBody)
+ NRec LetRec {..} -> Core.NRec $ Core.LetRec mempty (fmap goLetItem _letRecValues) (goNode _letRecBody)
+ NCase Case {..} -> Core.mkCase' _caseInductive (goNode _caseValue) (map goCaseBranch _caseBranches) (fmap goNode _caseDefault)
+ NPi Pi {..} -> Core.mkPi mempty (goBinder _piBinder) (goNode _piBody)
+ NUniv Univ {..} -> Core.mkUniv' _univLevel
+ NTyp TypeConstr {..} -> Core.mkTypeConstr' _typeConstrSymbol (map goNode _typeConstrArgs)
+ NPrim TypePrim {..} -> Core.mkTypePrim' _typePrimPrimitive
+ NDyn Dynamic {} -> Core.mkDynamic'
+ NBot Bottom {..} -> Core.mkBottom mempty (goNode _bottomType)
+
+ goBinder :: Binder -> Core.Binder
+ goBinder Binder {..} = Core.Binder _binderName _binderLocation (goNode _binderType)
+
+ goLetItem :: LetItem -> Core.LetItem
+ goLetItem LetItem {..} = Core.LetItem (goBinder _letItemBinder) (goNode _letItemValue)
+
+ goCaseBranch :: CaseBranch -> Core.CaseBranch
+ goCaseBranch CaseBranch {..} = Core.CaseBranch mempty _caseBranchTag (map goBinder _caseBranchBinders) _caseBranchBindersNum (goNode _caseBranchBody)
+
+fromCore :: Core.InfoTable -> InfoTable
+fromCore Core.InfoTable {..} =
+ InfoTable
+ { _identContext = fmap goNode _identContext,
+ _identMap,
+ _infoMain,
+ _infoIdentifiers = fmap goIdentifierInfo _infoIdentifiers,
+ _infoInductives = fmap goInductiveInfo _infoInductives,
+ _infoConstructors = fmap goConstructorInfo _infoConstructors,
+ _infoAxioms = fmap goAxiomInfo _infoAxioms,
+ _infoSpecialisations = fmap (map goSpecialisationInfo) _infoSpecialisations,
+ _infoLiteralIntToNat,
+ _infoLiteralIntToInt,
+ _infoBuiltins
+ }
+ where
+ goIdentifierInfo :: Core.IdentifierInfo -> IdentifierInfo
+ goIdentifierInfo Core.IdentifierInfo {..} =
+ IdentifierInfo
+ { _identifierType = goNode _identifierType,
+ ..
+ }
+
+ goInductiveInfo :: Core.InductiveInfo -> InductiveInfo
+ goInductiveInfo Core.InductiveInfo {..} =
+ InductiveInfo
+ { _inductiveKind = goNode _inductiveKind,
+ _inductiveParams = map goParameterInfo _inductiveParams,
+ ..
+ }
+
+ goParameterInfo :: Core.ParameterInfo -> ParameterInfo
+ goParameterInfo Core.ParameterInfo {..} =
+ ParameterInfo
+ { _paramKind = goNode _paramKind,
+ ..
+ }
+
+ goConstructorInfo :: Core.ConstructorInfo -> ConstructorInfo
+ goConstructorInfo Core.ConstructorInfo {..} =
+ ConstructorInfo
+ { _constructorType = goNode _constructorType,
+ ..
+ }
+
+ goAxiomInfo :: Core.AxiomInfo -> AxiomInfo
+ goAxiomInfo Core.AxiomInfo {..} =
+ AxiomInfo
+ { _axiomType = goNode _axiomType,
+ ..
+ }
+
+ goSpecialisationInfo :: Core.SpecialisationInfo -> SpecialisationInfo
+ goSpecialisationInfo Core.SpecialisationInfo {..} =
+ SpecialisationInfo
+ { _specSignature = first (map goNode) _specSignature,
+ ..
+ }
+
+ goNode :: Core.Node -> Node
+ goNode = \case
+ Core.NVar Core.Var {..} -> NVar $ Var () _varIndex
+ Core.NIdt Core.Ident {..} -> NIdt $ Ident () _identSymbol
+ Core.NCst Core.Constant {..} -> NCst $ Constant () _constantValue
+ Core.NApp Core.App {..} -> NApp $ App () (goNode _appLeft) (goNode _appRight)
+ Core.NBlt Core.BuiltinApp {..} -> NBlt $ BuiltinApp () _builtinAppOp (map goNode _builtinAppArgs)
+ Core.NCtr Core.Constr {..} -> NCtr $ Constr () _constrTag (map goNode _constrArgs)
+ Core.NLam Core.Lambda {..} -> NLam $ Lambda () (goBinder _lambdaBinder) (goNode _lambdaBody)
+ Core.NLet Core.Let {..} -> NLet $ Let () (goLetItem _letItem) (goNode _letBody)
+ Core.NRec Core.LetRec {..} -> NRec $ LetRec () (fmap goLetItem _letRecValues) (goNode _letRecBody)
+ Core.NCase Core.Case {..} -> NCase $ Case () _caseInductive (goNode _caseValue) (map goCaseBranch _caseBranches) (fmap goNode _caseDefault)
+ Core.NPi Core.Pi {..} -> NPi $ Pi () (goBinder _piBinder) (goNode _piBody)
+ Core.NUniv Core.Univ {..} -> NUniv $ Univ () _univLevel
+ Core.NTyp Core.TypeConstr {..} -> NTyp $ TypeConstr () _typeConstrSymbol (map goNode _typeConstrArgs)
+ Core.NPrim Core.TypePrim {..} -> NPrim $ TypePrim () _typePrimPrimitive
+ Core.NDyn Core.Dynamic {} -> NDyn $ Dynamic ()
+ Core.NBot Core.Bottom {..} -> NBot $ Bottom () (goNode _bottomType)
+ Core.NMatch {} -> impossible
+ Core.Closure {} -> impossible
+
+ goBinder :: Core.Binder -> Binder
+ goBinder Core.Binder {..} = Binder _binderName _binderLocation (goNode _binderType)
+
+ goLetItem :: Core.LetItem -> LetItem
+ goLetItem Core.LetItem {..} = LetItem (goBinder _letItemBinder) (goNode _letItemValue)
+
+ goCaseBranch :: Core.CaseBranch -> CaseBranch
+ goCaseBranch Core.CaseBranch {..} = CaseBranch mempty _caseBranchTag (map goBinder _caseBranchBinders) _caseBranchBindersNum (goNode _caseBranchBody)
diff --git a/src/Juvix/Compiler/Store/Core/Language.hs b/src/Juvix/Compiler/Store/Core/Language.hs
new file mode 100644
index 0000000000..33065a076d
--- /dev/null
+++ b/src/Juvix/Compiler/Store/Core/Language.hs
@@ -0,0 +1,75 @@
+module Juvix.Compiler.Store.Core.Language
+ ( module Juvix.Compiler.Store.Core.Language,
+ module Juvix.Compiler.Core.Language.Nodes,
+ )
+where
+
+import Juvix.Compiler.Core.Language.Nodes
+import Juvix.Extra.Serialize
+
+{---------------------------------------------------------------------------------}
+
+type Type = Node
+
+type Var = Var' ()
+
+type Ident = Ident' ()
+
+type Constant = Constant' ()
+
+type App = App' () Node
+
+type BuiltinApp = BuiltinApp' () Node
+
+type Constr = Constr' () Node
+
+type Lambda = Lambda' () Node Type
+
+type LetItem = LetItem' Node Type
+
+type Let = Let' () Node Type
+
+type LetRec = LetRec' () Node Type
+
+type Case = Case' () () Node Type
+
+type CaseBranch = CaseBranch' () Node Type
+
+type PiLhs = PiLhs' () Node
+
+type Pi = Pi' () Node
+
+type Univ = Univ' ()
+
+type TypeConstr = TypeConstr' () Node
+
+type TypePrim = TypePrim' ()
+
+type Dynamic = Dynamic' ()
+
+type Bottom = Bottom' () Node
+
+type Binder = Binder' Node
+
+{---------------------------------------------------------------------------------}
+
+data Node
+ = NVar Var
+ | NIdt Ident
+ | NCst Constant
+ | NApp App
+ | NBlt BuiltinApp
+ | NCtr Constr
+ | NLam Lambda
+ | NLet Let
+ | NRec LetRec
+ | NCase Case
+ | NPi Pi
+ | NUniv Univ
+ | NTyp TypeConstr
+ | NPrim TypePrim
+ | NDyn Dynamic
+ | NBot Bottom
+ deriving stock (Generic)
+
+instance Serialize Node
diff --git a/src/Juvix/Compiler/Store/Extra.hs b/src/Juvix/Compiler/Store/Extra.hs
new file mode 100644
index 0000000000..4128c9ba1a
--- /dev/null
+++ b/src/Juvix/Compiler/Store/Extra.hs
@@ -0,0 +1,44 @@
+module Juvix.Compiler.Store.Extra where
+
+import Data.HashMap.Strict qualified as HashMap
+import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
+import Juvix.Compiler.Concrete.Language (TopModulePath)
+import Juvix.Compiler.Core.Data.InfoTable qualified as Core
+import Juvix.Compiler.Store.Core.Extra
+import Juvix.Compiler.Store.Internal.Language
+import Juvix.Compiler.Store.Language
+import Juvix.Compiler.Store.Scoped.Data.InfoTable qualified as Scoped
+import Juvix.Compiler.Store.Scoped.Language
+import Juvix.Prelude
+
+getModulePath :: ModuleInfo -> TopModulePath
+getModulePath mi = mi ^. moduleInfoScopedModule . scopedModulePath . S.nameConcrete
+
+getModuleId :: ModuleInfo -> ModuleId
+getModuleId mi = mi ^. moduleInfoScopedModule . scopedModuleId
+
+getScopedModuleTable :: ModuleTable -> ScopedModuleTable
+getScopedModuleTable mtab =
+ ScopedModuleTable $ fmap (^. moduleInfoScopedModule) (mtab ^. moduleTable)
+
+getInternalModuleTable :: ModuleTable -> InternalModuleTable
+getInternalModuleTable mtab =
+ InternalModuleTable $
+ HashMap.fromList (map (\mi -> (mi ^. moduleInfoInternalModule . internalModuleName, mi ^. moduleInfoInternalModule)) (HashMap.elems (mtab ^. moduleTable)))
+
+mkModuleTable :: [ModuleInfo] -> ModuleTable
+mkModuleTable = ModuleTable . HashMap.fromList . map (\mi -> (getModulePath mi, mi))
+
+lookupModule :: ModuleTable -> TopModulePath -> ModuleInfo
+lookupModule mtab n = fromJust $ HashMap.lookup n (mtab ^. moduleTable)
+
+insertModule :: TopModulePath -> ModuleInfo -> ModuleTable -> ModuleTable
+insertModule p mi = over moduleTable (HashMap.insert p mi)
+
+computeCombinedScopedInfoTable :: ModuleTable -> Scoped.InfoTable
+computeCombinedScopedInfoTable mtab =
+ mconcatMap (^. moduleInfoScopedModule . scopedModuleInfoTable) (HashMap.elems (mtab ^. moduleTable))
+
+computeCombinedCoreInfoTable :: ModuleTable -> Core.InfoTable
+computeCombinedCoreInfoTable mtab =
+ mconcatMap (toCore . (^. moduleInfoCoreTable)) (HashMap.elems (mtab ^. moduleTable))
diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/FunctionsTable.hs b/src/Juvix/Compiler/Store/Internal/Data/FunctionsTable.hs
similarity index 71%
rename from src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/FunctionsTable.hs
rename to src/Juvix/Compiler/Store/Internal/Data/FunctionsTable.hs
index 8c004970ce..8cd0a54602 100644
--- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/FunctionsTable.hs
+++ b/src/Juvix/Compiler/Store/Internal/Data/FunctionsTable.hs
@@ -1,12 +1,16 @@
-module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.FunctionsTable where
+module Juvix.Compiler.Store.Internal.Data.FunctionsTable where
import Juvix.Compiler.Internal.Language
+import Juvix.Extra.Serialize
import Juvix.Prelude
newtype FunctionsTable = FunctionsTable
{ _functionsTable :: HashMap FunctionName Expression
}
deriving newtype (Semigroup, Monoid)
+ deriving stock (Generic)
+
+instance Serialize FunctionsTable
makeLenses ''FunctionsTable
diff --git a/src/Juvix/Compiler/Internal/Data/InfoTable/Base.hs b/src/Juvix/Compiler/Store/Internal/Data/InfoTable.hs
similarity index 58%
rename from src/Juvix/Compiler/Internal/Data/InfoTable/Base.hs
rename to src/Juvix/Compiler/Store/Internal/Data/InfoTable.hs
index bb2a169dfc..5452d47344 100644
--- a/src/Juvix/Compiler/Internal/Data/InfoTable/Base.hs
+++ b/src/Juvix/Compiler/Store/Internal/Data/InfoTable.hs
@@ -1,8 +1,9 @@
-module Juvix.Compiler.Internal.Data.InfoTable.Base where
+module Juvix.Compiler.Store.Internal.Data.InfoTable where
import Juvix.Compiler.Internal.Data.CoercionInfo
import Juvix.Compiler.Internal.Data.InstanceInfo
import Juvix.Compiler.Internal.Language
+import Juvix.Extra.Serialize
import Juvix.Prelude
data ConstructorInfo = ConstructorInfo
@@ -13,27 +14,57 @@ data ConstructorInfo = ConstructorInfo
_constructorInfoBuiltin :: Maybe BuiltinConstructor,
_constructorInfoTrait :: Bool
}
+ deriving stock (Generic)
-newtype FunctionInfo = FunctionInfo
- { _functionInfoDef :: FunctionDef
+instance Serialize ConstructorInfo
+
+data FunctionInfo = FunctionInfo
+ { _functionInfoName :: FunctionName,
+ _functionInfoType :: Expression,
+ _functionInfoTerminating :: Bool,
+ _functionInfoInstance :: Bool,
+ _functionInfoCoercion :: Bool,
+ _functionInfoBuiltin :: Maybe BuiltinFunction,
+ _functionInfoArgsInfo :: [ArgInfo],
+ _functionInfoPragmas :: Pragmas
}
+ deriving stock (Generic)
+
+instance Serialize FunctionInfo
newtype AxiomInfo = AxiomInfo
{ _axiomInfoDef :: AxiomDef
}
+ deriving stock (Generic)
+
+instance Serialize AxiomInfo
-newtype InductiveInfo = InductiveInfo
- { _inductiveInfoDef :: InductiveDef
+data InductiveInfo = InductiveInfo
+ { _inductiveInfoName :: InductiveName,
+ _inductiveInfoBuiltin :: Maybe BuiltinInductive,
+ _inductiveInfoType :: Expression,
+ _inductiveInfoParameters :: [InductiveParameter],
+ _inductiveInfoConstructors :: [ConstrName],
+ _inductiveInfoPositive :: Bool,
+ _inductiveInfoTrait :: Bool,
+ _inductiveInfoPragmas :: Pragmas
}
+ deriving stock (Generic)
+
+instance Serialize InductiveInfo
data InfoTable = InfoTable
{ _infoConstructors :: HashMap Name ConstructorInfo,
_infoAxioms :: HashMap Name AxiomInfo,
_infoFunctions :: HashMap Name FunctionInfo,
_infoInductives :: HashMap Name InductiveInfo,
+ _infoBuiltins :: HashMap BuiltinPrim Name,
_infoInstances :: InstanceTable,
_infoCoercions :: CoercionTable
}
+ deriving stock (Generic)
+
+instance Serialize InfoTable
makeLenses ''InfoTable
makeLenses ''FunctionInfo
@@ -48,6 +79,7 @@ instance Semigroup InfoTable where
_infoAxioms = a ^. infoAxioms <> b ^. infoAxioms,
_infoFunctions = a ^. infoFunctions <> b ^. infoFunctions,
_infoInductives = a ^. infoInductives <> b ^. infoInductives,
+ _infoBuiltins = a ^. infoBuiltins <> b ^. infoBuiltins,
_infoInstances = a ^. infoInstances <> b ^. infoInstances,
_infoCoercions = a ^. infoCoercions <> b ^. infoCoercions
}
@@ -59,6 +91,7 @@ instance Monoid InfoTable where
_infoAxioms = mempty,
_infoFunctions = mempty,
_infoInductives = mempty,
+ _infoBuiltins = mempty,
_infoInstances = mempty,
_infoCoercions = mempty
}
diff --git a/src/Juvix/Compiler/Store/Internal/Data/TypesTable.hs b/src/Juvix/Compiler/Store/Internal/Data/TypesTable.hs
new file mode 100644
index 0000000000..d5f3b41236
--- /dev/null
+++ b/src/Juvix/Compiler/Store/Internal/Data/TypesTable.hs
@@ -0,0 +1,13 @@
+module Juvix.Compiler.Store.Internal.Data.TypesTable where
+
+import Juvix.Compiler.Internal.Language
+import Juvix.Extra.Serialize
+import Juvix.Prelude
+
+newtype TypesTable = TypesTable
+ { _typesTable :: HashMap NameId Expression
+ }
+ deriving newtype (Semigroup, Monoid)
+ deriving stock (Generic)
+
+instance Serialize TypesTable
diff --git a/src/Juvix/Compiler/Store/Internal/Language.hs b/src/Juvix/Compiler/Store/Internal/Language.hs
new file mode 100644
index 0000000000..a5cb3cdf73
--- /dev/null
+++ b/src/Juvix/Compiler/Store/Internal/Language.hs
@@ -0,0 +1,51 @@
+module Juvix.Compiler.Store.Internal.Language
+ ( module Juvix.Compiler.Store.Internal.Data.InfoTable,
+ module Juvix.Compiler.Store.Internal.Language,
+ )
+where
+
+import Data.HashMap.Strict qualified as HashMap
+import Juvix.Compiler.Internal.Language
+import Juvix.Compiler.Store.Internal.Data.FunctionsTable
+import Juvix.Compiler.Store.Internal.Data.InfoTable
+import Juvix.Compiler.Store.Internal.Data.TypesTable
+import Juvix.Extra.Serialize
+import Juvix.Prelude
+
+data InternalModule = InternalModule
+ { _internalModuleId :: ModuleId,
+ _internalModuleName :: Name,
+ _internalModuleImports :: [Import],
+ _internalModuleInfoTable :: InfoTable,
+ _internalModuleTypesTable :: TypesTable,
+ _internalModuleFunctionsTable :: FunctionsTable
+ }
+ deriving stock (Generic)
+
+instance Serialize InternalModule
+
+newtype InternalModuleTable = InternalModuleTable
+ { _internalModuleTable :: HashMap Name InternalModule
+ }
+ deriving stock (Generic)
+ deriving newtype (Semigroup, Monoid)
+
+instance Serialize InternalModuleTable
+
+makeLenses ''InternalModule
+makeLenses ''InternalModuleTable
+
+lookupInternalModule :: InternalModuleTable -> Name -> InternalModule
+lookupInternalModule mtab n = fromJust $ HashMap.lookup n (mtab ^. internalModuleTable)
+
+insertInternalModule :: InternalModuleTable -> InternalModule -> InternalModuleTable
+insertInternalModule tab sm = over internalModuleTable (HashMap.insert (sm ^. internalModuleName) sm) tab
+
+computeCombinedInfoTable :: InternalModuleTable -> InfoTable
+computeCombinedInfoTable = mconcatMap (^. internalModuleInfoTable) . HashMap.elems . (^. internalModuleTable)
+
+computeTypesTable :: InternalModuleTable -> TypesTable
+computeTypesTable = mconcatMap (^. internalModuleTypesTable) . (^. internalModuleTable)
+
+computeFunctionsTable :: InternalModuleTable -> FunctionsTable
+computeFunctionsTable = mconcatMap (^. internalModuleFunctionsTable) . (^. internalModuleTable)
diff --git a/src/Juvix/Compiler/Store/Language.hs b/src/Juvix/Compiler/Store/Language.hs
new file mode 100644
index 0000000000..b3668302b8
--- /dev/null
+++ b/src/Juvix/Compiler/Store/Language.hs
@@ -0,0 +1,32 @@
+module Juvix.Compiler.Store.Language where
+
+import Juvix.Compiler.Concrete.Language (TopModulePath)
+import Juvix.Compiler.Store.Core.Data.InfoTable qualified as Core
+import Juvix.Compiler.Store.Internal.Language
+import Juvix.Compiler.Store.Options
+import Juvix.Compiler.Store.Scoped.Language
+import Juvix.Extra.Serialize
+import Juvix.Prelude
+
+data ModuleInfo = ModuleInfo
+ { _moduleInfoScopedModule :: ScopedModule,
+ _moduleInfoInternalModule :: InternalModule,
+ _moduleInfoCoreTable :: Core.InfoTable,
+ _moduleInfoImports :: [TopModulePath],
+ _moduleInfoOptions :: Options,
+ -- | True if any module depending on this module requires recompilation
+ -- whenever this module is changed
+ _moduleInfoFragile :: Bool,
+ _moduleInfoSHA256 :: Text
+ }
+ deriving stock (Generic)
+
+instance Serialize ModuleInfo
+
+newtype ModuleTable = ModuleTable
+ { _moduleTable :: HashMap TopModulePath ModuleInfo
+ }
+ deriving newtype (Semigroup, Monoid)
+
+makeLenses ''ModuleInfo
+makeLenses ''ModuleTable
diff --git a/src/Juvix/Compiler/Store/Options.hs b/src/Juvix/Compiler/Store/Options.hs
new file mode 100644
index 0000000000..7dbb00ba9e
--- /dev/null
+++ b/src/Juvix/Compiler/Store/Options.hs
@@ -0,0 +1,36 @@
+module Juvix.Compiler.Store.Options where
+
+import Juvix.Compiler.Pipeline.EntryPoint
+import Juvix.Extra.Serialize
+import Juvix.Prelude
+
+data Options = Options
+ { _optionsNoTermination :: Bool,
+ _optionsNoPositivity :: Bool,
+ _optionsNoCoverage :: Bool,
+ _optionsNoStdlib :: Bool,
+ _optionsDebug :: Bool,
+ _optionsUnsafe :: Bool,
+ _optionsUnrollLimit :: Int,
+ _optionsOptimizationLevel :: Int,
+ _optionsInliningDepth :: Int
+ }
+ deriving stock (Show, Eq, Generic)
+
+instance Serialize Options
+
+makeLenses ''Options
+
+fromEntryPoint :: EntryPoint -> Options
+fromEntryPoint EntryPoint {..} =
+ Options
+ { _optionsNoTermination = _entryPointNoTermination,
+ _optionsNoPositivity = _entryPointNoPositivity,
+ _optionsNoCoverage = _entryPointNoCoverage,
+ _optionsNoStdlib = _entryPointNoStdlib,
+ _optionsDebug = _entryPointDebug,
+ _optionsUnsafe = _entryPointUnsafe,
+ _optionsUnrollLimit = _entryPointUnrollLimit,
+ _optionsOptimizationLevel = _entryPointOptimizationLevel,
+ _optionsInliningDepth = _entryPointInliningDepth
+ }
diff --git a/src/Juvix/Compiler/Store/Scoped/Data/InfoTable.hs b/src/Juvix/Compiler/Store/Scoped/Data/InfoTable.hs
new file mode 100644
index 0000000000..391bb3b6ca
--- /dev/null
+++ b/src/Juvix/Compiler/Store/Scoped/Data/InfoTable.hs
@@ -0,0 +1,73 @@
+module Juvix.Compiler.Store.Scoped.Data.InfoTable where
+
+import Data.HashMap.Strict qualified as HashMap
+import Data.HashSet qualified as HashSet
+import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
+import Juvix.Compiler.Concrete.Language
+import Juvix.Extra.Serialize
+import Juvix.Prelude
+
+type DocTable = HashMap NameId (Judoc 'Scoped)
+
+type PrecedenceGraph = HashMap S.NameId (HashSet S.NameId)
+
+data InfoTable = InfoTable
+ { _infoFixities :: HashMap S.NameId FixityDef,
+ _infoPrecedenceGraph :: PrecedenceGraph,
+ _infoHighlightDoc :: DocTable,
+ _infoHighlightNames :: [S.AName],
+ _infoConstructorSigs :: HashMap NameId (RecordNameSignature 'Scoped),
+ _infoNameSigs :: HashMap NameId (NameSignature 'Scoped),
+ _infoParsedConstructorSigs :: HashMap NameId (RecordNameSignature 'Parsed),
+ _infoParsedNameSigs :: HashMap NameId (NameSignature 'Parsed),
+ _infoRecords :: HashMap NameId RecordInfo,
+ _infoFunctions :: HashMap NameId (FunctionDef 'Scoped),
+ _infoInductives :: HashMap NameId (InductiveDef 'Scoped),
+ _infoConstructors :: HashMap NameId (ConstructorDef 'Scoped),
+ _infoAxioms :: HashMap NameId (AxiomDef 'Scoped)
+ }
+ deriving stock (Generic)
+
+instance Serialize InfoTable
+
+makeLenses ''InfoTable
+
+instance Semigroup InfoTable where
+ tab1 <> tab2 =
+ InfoTable
+ { _infoFixities = tab1 ^. infoFixities <> tab2 ^. infoFixities,
+ _infoPrecedenceGraph = combinePrecedenceGraphs (tab1 ^. infoPrecedenceGraph) (tab2 ^. infoPrecedenceGraph),
+ _infoHighlightDoc = tab1 ^. infoHighlightDoc <> tab2 ^. infoHighlightDoc,
+ _infoHighlightNames = tab1 ^. infoHighlightNames <> tab2 ^. infoHighlightNames,
+ _infoConstructorSigs = tab1 ^. infoConstructorSigs <> tab2 ^. infoConstructorSigs,
+ _infoNameSigs = tab1 ^. infoNameSigs <> tab2 ^. infoNameSigs,
+ _infoParsedConstructorSigs = tab1 ^. infoParsedConstructorSigs <> tab2 ^. infoParsedConstructorSigs,
+ _infoParsedNameSigs = tab1 ^. infoParsedNameSigs <> tab2 ^. infoParsedNameSigs,
+ _infoRecords = tab1 ^. infoRecords <> tab2 ^. infoRecords,
+ _infoFunctions = tab1 ^. infoFunctions <> tab2 ^. infoFunctions,
+ _infoInductives = tab1 ^. infoInductives <> tab2 ^. infoInductives,
+ _infoConstructors = tab1 ^. infoConstructors <> tab2 ^. infoConstructors,
+ _infoAxioms = tab1 ^. infoAxioms <> tab2 ^. infoAxioms
+ }
+
+instance Monoid InfoTable where
+ mempty =
+ InfoTable
+ { _infoFixities = mempty,
+ _infoPrecedenceGraph = mempty,
+ _infoHighlightDoc = mempty,
+ _infoHighlightNames = mempty,
+ _infoConstructorSigs = mempty,
+ _infoNameSigs = mempty,
+ _infoParsedConstructorSigs = mempty,
+ _infoParsedNameSigs = mempty,
+ _infoRecords = mempty,
+ _infoFunctions = mempty,
+ _infoInductives = mempty,
+ _infoConstructors = mempty,
+ _infoAxioms = mempty
+ }
+
+combinePrecedenceGraphs :: PrecedenceGraph -> PrecedenceGraph -> PrecedenceGraph
+combinePrecedenceGraphs g1 g2 =
+ HashMap.unionWith HashSet.union g1 g2
diff --git a/src/Juvix/Compiler/Store/Scoped/Language.hs b/src/Juvix/Compiler/Store/Scoped/Language.hs
new file mode 100644
index 0000000000..58a270ccdc
--- /dev/null
+++ b/src/Juvix/Compiler/Store/Scoped/Language.hs
@@ -0,0 +1,135 @@
+module Juvix.Compiler.Store.Scoped.Language where
+
+import Data.HashSet qualified as HashSet
+import Juvix.Compiler.Concrete.Data.Name qualified as C
+import Juvix.Compiler.Concrete.Data.ScopedName (HasNameKind)
+import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
+import Juvix.Compiler.Store.Scoped.Data.InfoTable
+import Juvix.Extra.Serialize
+import Juvix.Prelude
+
+newtype Alias = Alias
+ { _aliasName :: S.Name
+ }
+ deriving stock (Show, Eq, Ord, Generic)
+
+instance Serialize Alias
+
+-- | Either an alias or a symbol entry.
+data PreSymbolEntry
+ = PreSymbolAlias Alias
+ | PreSymbolFinal SymbolEntry
+ deriving stock (Show, Eq, Ord, Generic)
+
+instance Serialize PreSymbolEntry
+
+-- | A symbol which is not an alias.
+newtype SymbolEntry = SymbolEntry
+ { _symbolEntry :: S.Name
+ }
+ deriving stock (Show, Eq, Ord, Generic)
+
+instance Hashable SymbolEntry
+
+instance Serialize SymbolEntry
+
+newtype ModuleSymbolEntry = ModuleSymbolEntry
+ { _moduleEntry :: S.Name
+ }
+ deriving stock (Show, Eq, Ord, Generic)
+
+instance Serialize ModuleSymbolEntry
+
+newtype FixitySymbolEntry = FixitySymbolEntry
+ { _fixityEntry :: S.Name
+ }
+ deriving stock (Show, Eq, Ord, Generic)
+
+instance Serialize FixitySymbolEntry
+
+-- | Symbols that a module exports
+data ExportInfo = ExportInfo
+ { _exportSymbols :: HashMap C.Symbol PreSymbolEntry,
+ _exportModuleSymbols :: HashMap C.Symbol ModuleSymbolEntry,
+ _exportFixitySymbols :: HashMap C.Symbol FixitySymbolEntry
+ }
+ deriving stock (Show, Eq, Ord, Generic)
+
+instance Serialize ExportInfo
+
+data ScopedModule = ScopedModule
+ { _scopedModuleId :: ModuleId,
+ _scopedModulePath :: S.TopModulePath,
+ _scopedModuleName :: S.Name,
+ _scopedModuleFilePath :: Path Abs File,
+ _scopedModuleExportInfo :: ExportInfo,
+ _scopedModuleLocalModules :: HashMap S.NameId ScopedModule,
+ _scopedModuleInfoTable :: InfoTable
+ }
+ deriving stock (Generic)
+
+instance Serialize ScopedModule
+
+newtype ScopedModuleTable = ScopedModuleTable
+ { _scopedModuleTable :: HashMap C.TopModulePath ScopedModule
+ }
+
+makeLenses ''Alias
+makeLenses ''SymbolEntry
+makeLenses ''ModuleSymbolEntry
+makeLenses ''FixitySymbolEntry
+makeLenses ''ExportInfo
+makeLenses ''ScopedModule
+makeLenses ''ScopedModuleTable
+
+instance HasLoc Alias where
+ getLoc = (^. aliasName . S.nameDefined)
+
+instance HasLoc PreSymbolEntry where
+ getLoc = \case
+ PreSymbolAlias a -> getLoc a
+ PreSymbolFinal a -> getLoc a
+
+instance HasLoc SymbolEntry where
+ getLoc = (^. symbolEntry . S.nameDefined)
+
+instance HasNameKind ModuleSymbolEntry where
+ getNameKind (ModuleSymbolEntry s) = S.getNameKind s
+
+instance HasLoc ModuleSymbolEntry where
+ getLoc (ModuleSymbolEntry s) = s ^. S.nameDefined
+
+symbolEntryNameId :: SymbolEntry -> NameId
+symbolEntryNameId = (^. symbolEntry . S.nameId)
+
+instance HasNameKind SymbolEntry where
+ getNameKind = S.getNameKind . (^. symbolEntry)
+
+preSymbolName :: Lens' PreSymbolEntry S.Name
+preSymbolName f = \case
+ PreSymbolAlias a -> PreSymbolAlias <$> traverseOf aliasName f a
+ PreSymbolFinal a -> PreSymbolFinal <$> traverseOf symbolEntry f a
+
+exportAllNames :: SimpleFold ExportInfo S.Name
+exportAllNames =
+ exportSymbols
+ . each
+ . preSymbolName
+ <> exportModuleSymbols
+ . each
+ . moduleEntry
+ <> exportFixitySymbols
+ . each
+ . fixityEntry
+
+createExportsTable :: ExportInfo -> HashSet NameId
+createExportsTable = HashSet.fromList . (^.. exportAllNames . S.nameId)
+
+getScopedModuleNameId :: ScopedModule -> S.NameId
+getScopedModuleNameId m = m ^. scopedModuleName . S.nameId
+
+getCombinedInfoTable :: ScopedModule -> InfoTable
+getCombinedInfoTable sm = sm ^. scopedModuleInfoTable <> mconcatMap getCombinedInfoTable (sm ^. scopedModuleLocalModules)
+
+computeCombinedInfoTable :: ScopedModuleTable -> InfoTable
+computeCombinedInfoTable stab = mconcatMap getCombinedInfoTable (stab ^. scopedModuleTable)
diff --git a/src/Juvix/Data/Comment.hs b/src/Juvix/Data/Comment.hs
index b8ec84dc1b..adf59e60ba 100644
--- a/src/Juvix/Data/Comment.hs
+++ b/src/Juvix/Data/Comment.hs
@@ -9,6 +9,7 @@ import Prettyprinter
newtype Comments = Comments
{ _commentsByFile :: HashMap (Path Abs File) FileComments
}
+ deriving newtype (Semigroup, Monoid)
deriving stock (Eq, Show, Generic, Data)
data FileComments = FileComments
diff --git a/src/Juvix/Data/Effect/FileLock/Base.hs b/src/Juvix/Data/Effect/FileLock/Base.hs
index ec6b976aa5..c8f669e662 100644
--- a/src/Juvix/Data/Effect/FileLock/Base.hs
+++ b/src/Juvix/Data/Effect/FileLock/Base.hs
@@ -1,6 +1,7 @@
module Juvix.Data.Effect.FileLock.Base where
-import Juvix.Prelude
+import Juvix.Prelude.Base
+import Juvix.Prelude.Path
-- | An effect for wrapping an action in file lock
data FileLock m a where
diff --git a/src/Juvix/Data/Effect/FileLock/IO.hs b/src/Juvix/Data/Effect/FileLock/IO.hs
index 039bf6ed16..a83b617e80 100644
--- a/src/Juvix/Data/Effect/FileLock/IO.hs
+++ b/src/Juvix/Data/Effect/FileLock/IO.hs
@@ -1,7 +1,8 @@
module Juvix.Data.Effect.FileLock.IO where
import Juvix.Data.Effect.FileLock.Base
-import Juvix.Prelude
+import Juvix.Prelude.Base
+import Juvix.Prelude.Path
import System.FileLock hiding (FileLock)
-- | Interpret `FileLock` using `System.FileLock`
diff --git a/src/Juvix/Data/Effect/FileLock/Permissive.hs b/src/Juvix/Data/Effect/FileLock/Permissive.hs
index a5712e4dcb..fdad56123f 100644
--- a/src/Juvix/Data/Effect/FileLock/Permissive.hs
+++ b/src/Juvix/Data/Effect/FileLock/Permissive.hs
@@ -1,7 +1,7 @@
module Juvix.Data.Effect.FileLock.Permissive where
import Juvix.Data.Effect.FileLock.Base
-import Juvix.Prelude
+import Juvix.Prelude.Base
-- | Interpret `FileLock` by executing all actions unconditionally
runFileLockPermissive :: Sem (FileLock ': r) a -> Sem r a
diff --git a/src/Juvix/Data/Effect/NameIdGen.hs b/src/Juvix/Data/Effect/NameIdGen.hs
index 926499c9ed..8d0c05ae57 100644
--- a/src/Juvix/Data/Effect/NameIdGen.hs
+++ b/src/Juvix/Data/Effect/NameIdGen.hs
@@ -8,8 +8,13 @@ import Data.Stream (Stream (Cons))
import Juvix.Data.NameId
import Juvix.Prelude.Base
-allNameIds :: Stream NameId
-allNameIds = NameId <$> ids
+data NameIdGenState = NameIdGenState
+ { _nameIdGenStateModuleId :: ModuleId,
+ _nameIdGenStateStream :: Stream Word64
+ }
+
+genNameIdState :: ModuleId -> NameIdGenState
+genNameIdState mid = NameIdGenState mid ids
where
ids :: Stream Word64
ids = aux minBound
@@ -21,18 +26,18 @@ data NameIdGen m a where
makeSem ''NameIdGen
-toState :: Sem (NameIdGen ': r) a -> Sem (State (Stream NameId) ': r) a
+toState :: Sem (NameIdGen ': r) a -> Sem (State NameIdGenState ': r) a
toState = reinterpret $ \case
FreshNameId -> do
- (Cons fresh rest) <- get
- put rest
- return fresh
+ NameIdGenState mid (Cons fresh rest) <- get
+ put (NameIdGenState mid rest)
+ return (NameId fresh mid)
-runNameIdGen :: Stream NameId -> Sem (NameIdGen ': r) a -> Sem r (Stream NameId, a)
+runNameIdGen :: NameIdGenState -> Sem (NameIdGen ': r) a -> Sem r (NameIdGenState, a)
runNameIdGen s = runState s . toState
-runTopNameIdGen :: Sem (NameIdGen ': r) a -> Sem r (Stream NameId, a)
-runTopNameIdGen = runNameIdGen allNameIds
+runTopNameIdGen :: ModuleId -> Sem (NameIdGen ': r) a -> Sem r (NameIdGenState, a)
+runTopNameIdGen mid = runNameIdGen (genNameIdState mid)
-evalTopNameIdGen :: Sem (NameIdGen ': r) a -> Sem r a
-evalTopNameIdGen = fmap snd . runTopNameIdGen
+evalTopNameIdGen :: ModuleId -> Sem (NameIdGen ': r) a -> Sem r a
+evalTopNameIdGen mid = fmap snd . runTopNameIdGen mid
diff --git a/src/Juvix/Data/Effect/TaggedLock.hs b/src/Juvix/Data/Effect/TaggedLock.hs
index 8a0973e8cf..af55498fd0 100644
--- a/src/Juvix/Data/Effect/TaggedLock.hs
+++ b/src/Juvix/Data/Effect/TaggedLock.hs
@@ -9,7 +9,8 @@ where
import Juvix.Data.Effect.TaggedLock.Base
import Juvix.Data.Effect.TaggedLock.IO
import Juvix.Data.Effect.TaggedLock.Permissive
-import Juvix.Prelude
+import Juvix.Prelude.Base
+import Juvix.Prelude.Path
-- | A variant of `withTaggedLock` that accepts an absolute directory as a tag.
--
diff --git a/src/Juvix/Data/Effect/TaggedLock/Base.hs b/src/Juvix/Data/Effect/TaggedLock/Base.hs
index ad73b62a22..74180407cb 100644
--- a/src/Juvix/Data/Effect/TaggedLock/Base.hs
+++ b/src/Juvix/Data/Effect/TaggedLock/Base.hs
@@ -1,6 +1,7 @@
module Juvix.Data.Effect.TaggedLock.Base where
-import Juvix.Prelude
+import Juvix.Prelude.Base
+import Juvix.Prelude.Path
-- | An effect that wraps an action with a lock that is tagged with a relative
-- path.
diff --git a/src/Juvix/Data/Effect/TaggedLock/IO.hs b/src/Juvix/Data/Effect/TaggedLock/IO.hs
index f1891cb55a..b88895adf3 100644
--- a/src/Juvix/Data/Effect/TaggedLock/IO.hs
+++ b/src/Juvix/Data/Effect/TaggedLock/IO.hs
@@ -1,8 +1,10 @@
module Juvix.Data.Effect.TaggedLock.IO where
import Juvix.Data.Effect.FileLock
+import Juvix.Data.Effect.Files
import Juvix.Data.Effect.TaggedLock.Base
-import Juvix.Prelude
+import Juvix.Prelude.Base
+import Juvix.Prelude.Path
-- | Interpret `TaggedLock` using `FileLock`.
--
diff --git a/src/Juvix/Data/Effect/TaggedLock/Permissive.hs b/src/Juvix/Data/Effect/TaggedLock/Permissive.hs
index 1360596b19..108eab67a1 100644
--- a/src/Juvix/Data/Effect/TaggedLock/Permissive.hs
+++ b/src/Juvix/Data/Effect/TaggedLock/Permissive.hs
@@ -1,7 +1,7 @@
module Juvix.Data.Effect.TaggedLock.Permissive where
import Juvix.Data.Effect.TaggedLock.Base
-import Juvix.Prelude
+import Juvix.Prelude.Base
runTaggedLockPermissive :: Sem (TaggedLock ': r) a -> Sem r a
runTaggedLockPermissive = interpretH $ \case
diff --git a/src/Juvix/Data/Fixity.hs b/src/Juvix/Data/Fixity.hs
index 9f391e759c..2b857acada 100644
--- a/src/Juvix/Data/Fixity.hs
+++ b/src/Juvix/Data/Fixity.hs
@@ -1,6 +1,7 @@
module Juvix.Data.Fixity where
import Juvix.Data.NameId
+import Juvix.Extra.Serialize
import Juvix.Prelude.Base
-- | Note that the order of the constructors is important due to the `Ord`
@@ -10,32 +11,42 @@ data Precedence
| PrecNat Int
| PrecApp
| PrecUpdate
- deriving stock (Show, Eq, Data, Ord)
+ deriving stock (Show, Eq, Data, Ord, Generic)
data UnaryAssoc = AssocPostfix
- deriving stock (Show, Eq, Ord, Data)
+ deriving stock (Show, Eq, Ord, Data, Generic)
data BinaryAssoc
= AssocNone
| AssocLeft
| AssocRight
- deriving stock (Show, Eq, Ord, Data)
+ deriving stock (Show, Eq, Ord, Data, Generic)
data OperatorArity
= OpUnary UnaryAssoc
| OpBinary BinaryAssoc
| OpNone
- deriving stock (Show, Eq, Ord, Data)
+ deriving stock (Show, Eq, Ord, Data, Generic)
data Fixity = Fixity
{ _fixityPrecedence :: Precedence,
_fixityArity :: OperatorArity,
_fixityId :: Maybe NameId
}
- deriving stock (Show, Eq, Ord, Data)
+ deriving stock (Show, Eq, Ord, Data, Generic)
makeLenses ''Fixity
+instance Serialize Precedence
+
+instance Serialize UnaryAssoc
+
+instance Serialize BinaryAssoc
+
+instance Serialize OperatorArity
+
+instance Serialize Fixity
+
data Atomicity
= Atom
| Aggregate Fixity
diff --git a/src/Juvix/Data/Hole.hs b/src/Juvix/Data/Hole.hs
index 1311f38749..27e277f418 100644
--- a/src/Juvix/Data/Hole.hs
+++ b/src/Juvix/Data/Hole.hs
@@ -4,6 +4,7 @@ import Juvix.Data.Keyword
import Juvix.Data.Keyword.All (kwWildcard)
import Juvix.Data.Loc
import Juvix.Data.NameId
+import Juvix.Extra.Serialize as S
import Juvix.Prelude.Base
import Prettyprinter
@@ -11,7 +12,7 @@ data Hole = Hole
{ _holeId :: NameId,
_holeKw :: KeywordRef
}
- deriving stock (Show, Data)
+ deriving stock (Show, Data, Generic)
mkHole :: Interval -> NameId -> Hole
mkHole loc uid =
@@ -29,6 +30,16 @@ mkHole loc uid =
makeLenses ''Hole
+instance Serialize Hole where
+ put Hole {..} = do
+ S.put _holeId
+ S.put (_holeKw ^. keywordRefInterval)
+
+ get = do
+ i <- S.get
+ loc <- S.get
+ return $ mkHole loc i
+
instance Eq Hole where
(==) = (==) `on` (^. holeId)
diff --git a/src/Juvix/Data/InstanceHole.hs b/src/Juvix/Data/InstanceHole.hs
index 97db01e3eb..5ad67d6bf1 100644
--- a/src/Juvix/Data/InstanceHole.hs
+++ b/src/Juvix/Data/InstanceHole.hs
@@ -5,6 +5,7 @@ import Juvix.Data.Keyword
import Juvix.Data.Keyword.All (kwWildcard)
import Juvix.Data.Loc
import Juvix.Data.NameId
+import Juvix.Extra.Serialize
import Juvix.Prelude.Base
import Prettyprinter
@@ -15,7 +16,9 @@ data InstanceHole = InstanceHole
{ _iholeId :: NameId,
_iholeKw :: KeywordRef
}
- deriving stock (Show, Data)
+ deriving stock (Show, Data, Generic)
+
+instance Serialize InstanceHole
mkInstanceHole :: Interval -> NameId -> InstanceHole
mkInstanceHole loc uid =
diff --git a/src/Juvix/Data/Irrelevant.hs b/src/Juvix/Data/Irrelevant.hs
index b79f73a078..94a01d829c 100644
--- a/src/Juvix/Data/Irrelevant.hs
+++ b/src/Juvix/Data/Irrelevant.hs
@@ -1,6 +1,7 @@
module Juvix.Data.Irrelevant where
import Juvix.Data.Loc
+import Juvix.Extra.Serialize as S
import Juvix.Prelude.Base
import Juvix.Prelude.Pretty
import Prelude (show)
@@ -10,6 +11,11 @@ import Prelude (show)
newtype Irrelevant a = Irrelevant
{ _unIrrelevant :: a
}
+ deriving newtype (Generic)
+
+instance (Serialize a) => Serialize (Irrelevant a) where
+ put (Irrelevant x) = S.put x
+ get = Irrelevant <$> S.get
instance Show (Irrelevant a) where
show = const "Irrelevant {}"
diff --git a/src/Juvix/Data/IsImplicit.hs b/src/Juvix/Data/IsImplicit.hs
index e5796925cc..87ce9f0a17 100644
--- a/src/Juvix/Data/IsImplicit.hs
+++ b/src/Juvix/Data/IsImplicit.hs
@@ -1,5 +1,6 @@
module Juvix.Data.IsImplicit where
+import Juvix.Extra.Serialize
import Juvix.Prelude.Base
import Juvix.Prelude.Pretty
@@ -17,6 +18,8 @@ isImplicitOrInstance = \case
instance Hashable IsImplicit
+instance Serialize IsImplicit
+
instance Pretty IsImplicit where
pretty = \case
Implicit -> "implicit"
diff --git a/src/Juvix/Data/IteratorInfo.hs b/src/Juvix/Data/IteratorInfo.hs
index 6074cb3c28..f17965d38d 100644
--- a/src/Juvix/Data/IteratorInfo.hs
+++ b/src/Juvix/Data/IteratorInfo.hs
@@ -1,5 +1,6 @@
module Juvix.Data.IteratorInfo where
+import Juvix.Extra.Serialize
import Juvix.Prelude.Base
data IteratorInfo = IteratorInfo
@@ -8,6 +9,8 @@ data IteratorInfo = IteratorInfo
}
deriving stock (Show, Eq, Ord, Generic)
+instance Serialize IteratorInfo
+
makeLenses ''IteratorInfo
emptyIteratorInfo :: IteratorInfo
diff --git a/src/Juvix/Data/Keyword.hs b/src/Juvix/Data/Keyword.hs
index fbf15b8dd4..1a1d7dbbf9 100644
--- a/src/Juvix/Data/Keyword.hs
+++ b/src/Juvix/Data/Keyword.hs
@@ -2,19 +2,24 @@ module Juvix.Data.Keyword where
import Data.HashSet qualified as HashSet
import Juvix.Data.Loc
+import Juvix.Extra.Serialize
import Juvix.Prelude.Base
import Juvix.Prelude.Pretty
data IsUnicode
= Unicode
| Ascii
- deriving stock (Eq, Show, Ord, Data)
+ deriving stock (Eq, Show, Ord, Data, Generic)
+
+instance Serialize IsUnicode
data KeywordType
= KeywordTypeKeyword
| KeywordTypeDelimiter
| KeywordTypeJudoc
- deriving stock (Eq, Show, Ord, Data)
+ deriving stock (Eq, Show, Ord, Data, Generic)
+
+instance Serialize KeywordType
data Keyword = Keyword
{ _keywordAscii :: Text,
@@ -23,14 +28,18 @@ data Keyword = Keyword
_keywordHasReserved :: Bool,
_keywordType :: KeywordType
}
- deriving stock (Eq, Show, Ord, Data)
+ deriving stock (Eq, Show, Ord, Data, Generic)
+
+instance Serialize Keyword
data KeywordRef = KeywordRef
{ _keywordRefKeyword :: Keyword,
_keywordRefInterval :: Interval,
_keywordRefUnicode :: IsUnicode
}
- deriving stock (Show, Data)
+ deriving stock (Show, Data, Generic)
+
+instance Serialize KeywordRef
makeLenses ''Keyword
makeLenses ''KeywordRef
diff --git a/src/Juvix/Data/Loc.hs b/src/Juvix/Data/Loc.hs
index 1aa0ee50f7..d6673dcc73 100644
--- a/src/Juvix/Data/Loc.hs
+++ b/src/Juvix/Data/Loc.hs
@@ -1,14 +1,17 @@
module Juvix.Data.Loc where
+import Juvix.Extra.Serialize
import Juvix.Prelude.Base
import Juvix.Prelude.Path
import Prettyprinter
import Text.Megaparsec qualified as M
newtype Pos = Pos {_unPos :: Word64}
- deriving stock (Show, Eq, Ord, Data)
+ deriving stock (Show, Eq, Ord, Data, Generic)
deriving newtype (Hashable, Num, Enum, Real, Integral)
+instance Serialize Pos
+
instance Semigroup Pos where
Pos x <> Pos y = Pos (x + y)
@@ -27,6 +30,8 @@ data FileLoc = FileLoc
instance Hashable FileLoc
+instance Serialize FileLoc
+
instance Ord FileLoc where
compare (FileLoc l c o) (FileLoc l' c' o') = compare (l, c, o) (l', c', o')
@@ -71,6 +76,8 @@ data Interval = Interval
instance Hashable Interval
+instance Serialize Interval
+
class HasLoc t where
getLoc :: t -> Interval
diff --git a/src/Juvix/Data/ModuleId.hs b/src/Juvix/Data/ModuleId.hs
new file mode 100644
index 0000000000..c3ed9e536c
--- /dev/null
+++ b/src/Juvix/Data/ModuleId.hs
@@ -0,0 +1,29 @@
+module Juvix.Data.ModuleId where
+
+import Juvix.Extra.Serialize
+import Juvix.Prelude.Base
+import Prettyprinter
+
+data ModuleId = ModuleId
+ { _moduleIdPath :: Text,
+ _moduleIdPackage :: Text,
+ _moduleIdPackageVersion :: Text
+ }
+ deriving stock (Show, Eq, Ord, Generic, Data)
+
+makeLenses ''ModuleId
+
+instance Pretty ModuleId where
+ pretty ModuleId {..} = pretty _moduleIdPath
+
+instance Hashable ModuleId
+
+instance Serialize ModuleId
+
+defaultModuleId :: ModuleId
+defaultModuleId =
+ ModuleId
+ { _moduleIdPath = "$DefaultModule$",
+ _moduleIdPackage = "$",
+ _moduleIdPackageVersion = "1.0"
+ }
diff --git a/src/Juvix/Data/NameId.hs b/src/Juvix/Data/NameId.hs
index 04c0efcc74..7b1adf6c35 100644
--- a/src/Juvix/Data/NameId.hs
+++ b/src/Juvix/Data/NameId.hs
@@ -1,17 +1,25 @@
-module Juvix.Data.NameId where
+module Juvix.Data.NameId
+ ( module Juvix.Data.NameId,
+ module Juvix.Data.ModuleId,
+ )
+where
+import Juvix.Data.ModuleId
+import Juvix.Extra.Serialize
import Juvix.Prelude.Base
import Prettyprinter
-newtype NameId = NameId
- { _unNameId :: Word64
+data NameId = NameId
+ { _nameIdUid :: Word64,
+ _nameIdModuleId :: ModuleId
}
deriving stock (Show, Eq, Ord, Generic, Data)
- deriving newtype (Enum)
makeLenses ''NameId
instance Pretty NameId where
- pretty (NameId w) = pretty w
+ pretty (NameId w m) = pretty m <> ":" <> pretty w
instance Hashable NameId
+
+instance Serialize NameId
diff --git a/src/Juvix/Data/NameKind.hs b/src/Juvix/Data/NameKind.hs
index 999ef50df1..1c9ed1a45f 100644
--- a/src/Juvix/Data/NameKind.hs
+++ b/src/Juvix/Data/NameKind.hs
@@ -1,5 +1,6 @@
module Juvix.Data.NameKind where
+import Juvix.Extra.Serialize
import Juvix.Prelude
import Juvix.Prelude.Pretty
import Prettyprinter.Render.Terminal
@@ -23,10 +24,12 @@ data NameKind
KNameFixity
| -- | An alias name. Only used in the declaration site.
KNameAlias
- deriving stock (Show, Eq, Data)
+ deriving stock (Show, Eq, Data, Generic)
$(genSingletons [''NameKind])
+instance Serialize NameKind
+
class HasNameKind a where
getNameKind :: a -> NameKind
diff --git a/src/Juvix/Data/Pragmas.hs b/src/Juvix/Data/Pragmas.hs
index 687fe838f0..2c0246c427 100644
--- a/src/Juvix/Data/Pragmas.hs
+++ b/src/Juvix/Data/Pragmas.hs
@@ -2,6 +2,7 @@ module Juvix.Data.Pragmas where
import Data.Aeson.BetterErrors qualified as Aeson
import Juvix.Data.Yaml
+import Juvix.Extra.Serialize
import Juvix.Prelude.Base
data PragmaInline
@@ -101,6 +102,28 @@ instance Hashable PragmaEval
instance Hashable Pragmas
+instance Serialize PragmaInline
+
+instance Serialize PragmaUnroll
+
+instance Serialize PragmaArgNames
+
+instance Serialize PragmaPublic
+
+instance Serialize PragmaFormat
+
+instance Serialize PragmaSpecialiseArg
+
+instance Serialize PragmaSpecialiseArgs
+
+instance Serialize PragmaSpecialise
+
+instance Serialize PragmaSpecialiseBy
+
+instance Serialize PragmaEval
+
+instance Serialize Pragmas
+
instance FromJSON Pragmas where
parseJSON = toAesonParser id parsePragmas
where
diff --git a/src/Juvix/Data/Universe.hs b/src/Juvix/Data/Universe.hs
index fc0294c1dd..aa51170e39 100644
--- a/src/Juvix/Data/Universe.hs
+++ b/src/Juvix/Data/Universe.hs
@@ -4,6 +4,7 @@ import Juvix.Data.Fixity
import Juvix.Data.Keyword
import Juvix.Data.Keyword.All (kwType)
import Juvix.Data.Loc
+import Juvix.Extra.Serialize
import Juvix.Prelude.Base
data Universe = Universe
@@ -11,7 +12,9 @@ data Universe = Universe
_universeKw :: KeywordRef,
_universeLevelLoc :: Maybe Interval
}
- deriving stock (Show, Ord, Data)
+ deriving stock (Show, Ord, Data, Generic)
+
+instance Serialize Universe
newtype SmallUniverse = SmallUniverse
{ _smallUniverseLoc :: Interval
@@ -23,6 +26,8 @@ instance Eq SmallUniverse where
instance Hashable SmallUniverse
+instance Serialize SmallUniverse
+
getUniverseLevel :: Universe -> Natural
getUniverseLevel Universe {..} = fromMaybe defaultLevel _universeLevel
diff --git a/src/Juvix/Data/Wildcard.hs b/src/Juvix/Data/Wildcard.hs
index cdad9c04a0..e5af876c2f 100644
--- a/src/Juvix/Data/Wildcard.hs
+++ b/src/Juvix/Data/Wildcard.hs
@@ -1,13 +1,16 @@
module Juvix.Data.Wildcard where
import Juvix.Data.Loc
+import Juvix.Extra.Serialize
import Juvix.Prelude.Base
import Prettyprinter
newtype Wildcard = Wildcard
{ _wildcardLoc :: Interval
}
- deriving stock (Show, Data)
+ deriving stock (Show, Data, Generic)
+
+instance Serialize Wildcard
makeLenses ''Wildcard
diff --git a/src/Juvix/Data/WithLoc.hs b/src/Juvix/Data/WithLoc.hs
index 97a47e54be..67d3fad04e 100644
--- a/src/Juvix/Data/WithLoc.hs
+++ b/src/Juvix/Data/WithLoc.hs
@@ -2,6 +2,7 @@ module Juvix.Data.WithLoc where
import Juvix.Data.Fixity
import Juvix.Data.Loc
+import Juvix.Extra.Serialize
import Juvix.Prelude.Base
import Juvix.Prelude.Pretty
@@ -9,10 +10,12 @@ data WithLoc a = WithLoc
{ _withLocInt :: Interval,
_withLocParam :: a
}
- deriving stock (Show, Data)
+ deriving stock (Show, Data, Generic)
makeLenses ''WithLoc
+instance (Serialize a) => Serialize (WithLoc a)
+
instance HasLoc (WithLoc a) where
getLoc = (^. withLocInt)
diff --git a/src/Juvix/Data/WithSource.hs b/src/Juvix/Data/WithSource.hs
index 360df8d253..8aaabceede 100644
--- a/src/Juvix/Data/WithSource.hs
+++ b/src/Juvix/Data/WithSource.hs
@@ -1,13 +1,16 @@
module Juvix.Data.WithSource where
import Juvix.Data.Fixity
+import Juvix.Extra.Serialize
import Juvix.Prelude.Base
data WithSource a = WithSource
{ _withSourceText :: Text,
_withSourceValue :: a
}
- deriving stock (Show, Data)
+ deriving stock (Show, Data, Generic)
+
+instance (Serialize a) => Serialize (WithSource a)
makeLenses ''WithSource
diff --git a/src/Juvix/Extra/Serialize.hs b/src/Juvix/Extra/Serialize.hs
new file mode 100644
index 0000000000..15373cc5e4
--- /dev/null
+++ b/src/Juvix/Extra/Serialize.hs
@@ -0,0 +1,57 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Avoid restricted flags" #-}
+module Juvix.Extra.Serialize
+ ( module S,
+ saveToFile,
+ loadFromFile,
+ )
+where
+
+import Data.HashMap.Strict qualified as HashMap
+import Data.HashSet qualified as HashSet
+import Data.Serialize as S
+import Juvix.Data.Effect.Files
+import Juvix.Data.Effect.TaggedLock
+import Juvix.Prelude.Base
+import Juvix.Prelude.Path
+
+instance Serialize (Path Abs File)
+
+instance Serialize (Path Abs Dir)
+
+instance Serialize Text where
+ put txt = S.put (unpack txt)
+
+ get = pack <$> S.get
+
+instance (Serialize a) => Serialize (NonEmpty a)
+
+instance (Hashable k, Serialize k, Serialize a) => Serialize (HashMap k a) where
+ put m = S.put (HashMap.toList m)
+
+ get = HashMap.fromList <$> S.get
+
+instance (Hashable a, Serialize a) => Serialize (HashSet a) where
+ put s = S.put (HashSet.toList s)
+
+ get = HashSet.fromList <$> S.get
+
+saveToFile :: (Members '[Files, TaggedLock] r, Serialize a) => Path Abs File -> a -> Sem r ()
+saveToFile file a = withTaggedLockDir (parent file) $ do
+ ensureDir' (parent file)
+ let bs = runPut (S.put a)
+ writeFileBS file bs
+
+loadFromFile :: forall a r. (Members '[Files, TaggedLock] r, Serialize a) => Path Abs File -> Sem r (Maybe a)
+loadFromFile file = withTaggedLockDir (parent file) $ do
+ ex <- fileExists' file
+ if
+ | ex -> do
+ bs <- readFileBS' file
+ case runGet (S.get @a) bs of
+ Left {} -> return Nothing
+ Right a -> return (Just a)
+ | otherwise ->
+ return Nothing
diff --git a/src/Juvix/Formatter.hs b/src/Juvix/Formatter.hs
index fab0967462..721a5f80f6 100644
--- a/src/Juvix/Formatter.hs
+++ b/src/Juvix/Formatter.hs
@@ -1,10 +1,8 @@
module Juvix.Formatter where
-import Data.List.NonEmpty qualified as NonEmpty
import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Concrete.Print (docDefault)
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper
-import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context
import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Data.CodeAnn
import Juvix.Extra.Paths
@@ -18,7 +16,7 @@ data FormattedFileInfo = FormattedFileInfo
data ScopeEff m a where
ScopeFile :: Path Abs File -> ScopeEff m Scoper.ScoperResult
- ScopeStdin :: ScopeEff m Scoper.ScoperResult
+ ScopeStdin :: EntryPoint -> ScopeEff m Scoper.ScoperResult
makeLenses ''FormattedFileInfo
makeSem ''ScopeEff
@@ -102,11 +100,12 @@ formatPath p = do
formatStdin ::
forall r.
- (Members '[ScopeEff, Files, Output FormattedFileInfo] r) =>
+ (Members '[Reader EntryPoint, ScopeEff, Files, Output FormattedFileInfo] r) =>
Sem r FormatResult
formatStdin = do
- res <- scopeStdin
- let originalContents = fromMaybe "" (res ^. Scoper.resultParserResult . resultEntry . entryPointStdin)
+ entry <- ask
+ res <- scopeStdin entry
+ let originalContents = fromMaybe "" (entry ^. entryPointStdin)
runReader originalContents $ do
formattedContents :: Text <- formatScoperResult False res
formatResultFromContents formattedContents formatStdinPath
@@ -145,14 +144,13 @@ formatScoperResult ::
Scoper.ScoperResult ->
Sem r Text
formatScoperResult force res = do
- let cs = res ^. Scoper.comments
- formattedModules <-
+ let cs = Scoper.getScoperResultComments res
+ formattedModule <-
runReader cs
- . mapM formatTopModule
+ . formatTopModule
$ res
- ^. Scoper.resultModules
- let txt :: Text = toPlainTextTrim . mconcat . NonEmpty.toList $ formattedModules
-
+ ^. Scoper.resultModule
+ let txt :: Text = toPlainTextTrim formattedModule
case res ^. Scoper.mainModule . modulePragmas of
Just pragmas ->
case pragmas ^. withLocParam . withSourceValue . pragmasFormat of
diff --git a/src/Juvix/Parser/Error.hs b/src/Juvix/Parser/Error.hs
index 4e29d3f7f7..63498ead43 100644
--- a/src/Juvix/Parser/Error.hs
+++ b/src/Juvix/Parser/Error.hs
@@ -4,8 +4,8 @@ import Commonmark qualified as MK
import Juvix.Compiler.Backend.Markdown.Error
import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Concrete.Pretty.Options (fromGenericOptions)
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error.Pretty
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Error
import Juvix.Extra.Paths
import Juvix.Prelude
import Text.Megaparsec qualified as M
@@ -16,7 +16,6 @@ import Text.Parsec.Pos qualified as P
data ParserError
= ErrMegaparsec MegaparsecError
| ErrCommonmark CommonmarkError
- | ErrTopModulePath TopModulePathError
| ErrWrongTopModuleName WrongTopModuleName
| ErrWrongTopModuleNameOrphan WrongTopModuleNameOrphan
| ErrStdinOrFile StdinOrFileError
@@ -28,7 +27,6 @@ instance ToGenericError ParserError where
genericError = \case
ErrMegaparsec e -> genericError e
ErrCommonmark e -> genericError e
- ErrTopModulePath e -> genericError e
ErrWrongTopModuleName e -> genericError e
ErrWrongTopModuleNameOrphan e -> genericError e
ErrStdinOrFile e -> genericError e
diff --git a/test/BackendGeb/Compilation/Base.hs b/test/BackendGeb/Compilation/Base.hs
index 8c98ee1d48..49377bc36c 100644
--- a/test/BackendGeb/Compilation/Base.hs
+++ b/test/BackendGeb/Compilation/Base.hs
@@ -14,5 +14,5 @@ gebCompilationAssertion ::
gebCompilationAssertion root mainFile expectedFile step = do
step "Translate to JuvixCore"
entryPoint <- set entryPointTarget TargetGeb <$> testDefaultEntryPointIO root mainFile
- tab <- (^. Core.coreResultTable) . snd <$> testRunIO entryPoint upToCore
- coreToGebTranslationAssertion' tab entryPoint expectedFile step
+ m <- (^. pipelineResult . Core.coreResultModule) . snd <$> testRunIO entryPoint upToStoredCore
+ coreToGebTranslationAssertion' (Core.computeCombinedInfoTable m) entryPoint expectedFile step
diff --git a/test/BackendGeb/FromCore/Base.hs b/test/BackendGeb/FromCore/Base.hs
index 0c926b9a24..1e5e86f36e 100644
--- a/test/BackendGeb/FromCore/Base.hs
+++ b/test/BackendGeb/FromCore/Base.hs
@@ -19,7 +19,7 @@ coreToGebTranslationAssertion root mainFile expectedFile step = do
step "Parse Juvix Core file"
input <- readFile . toFilePath $ mainFile
entryPoint <- set entryPointTarget TargetGeb <$> testDefaultEntryPointIO root mainFile
- case Core.runParserMain mainFile Core.emptyInfoTable input of
+ case Core.runParserMain mainFile defaultModuleId mempty input of
Left err -> assertFailure . show . pretty $ err
Right coreInfoTable -> coreToGebTranslationAssertion' coreInfoTable entryPoint expectedFile step
@@ -31,60 +31,61 @@ coreToGebTranslationAssertion' ::
Assertion
coreToGebTranslationAssertion' coreInfoTable entryPoint expectedFile step = do
step "Prepare the Juvix Core node for translation to Geb"
- case run . runReader entryPoint . runError @Geb.JuvixError $ Core.toGeb coreInfoTable of
+ case run . runReader entryPoint . runError @Geb.JuvixError $ Core.toGeb (Core.moduleFromInfoTable coreInfoTable) of
Left err ->
assertFailure . show . pretty $
fromJuvixError @GenericError err
- Right readyCoreInfoTable ->
- length (fromText (Core.ppTrace readyCoreInfoTable) :: String) `seq` do
- step "Translate the Juvix Core node to Geb"
- let (translatedMorphism, translatedObj) = Geb.fromCore readyCoreInfoTable
- step "Typecheck the translated Geb node"
- let typeMorph =
- Geb.TypedMorphism
- { _typedMorphism = translatedMorphism,
- _typedMorphismObject = translatedObj
- }
- case run . runError @Geb.CheckingError $ Geb.check' typeMorph of
- Left err ->
- assertFailure . show . pretty $
- fromJuvixError @GenericError (JuvixError err)
- Right _ -> do
- step "Try evaluating the JuvixCore node"
- let resultCoreEval :: Core.Node = Core.evalInfoTable stderr readyCoreInfoTable
- step "Translate the result of the evaluated JuvixCore node to Geb"
- let (gebCoreEvalResult, _) = Geb.fromCore $ Core.setupMainFunction readyCoreInfoTable resultCoreEval
- case ( Geb.eval' Geb.defaultEvalEnv translatedMorphism,
- Geb.eval' Geb.defaultEvalEnv gebCoreEvalResult
- ) of
- (Left err, _) -> do
- step "The evaluation of the translated Geb node failed"
+ Right readyCoreModule ->
+ let readyCoreInfoTable = Core.computeCombinedInfoTable readyCoreModule
+ in length (fromText (Core.ppTrace readyCoreInfoTable) :: String) `seq` do
+ step "Translate the Juvix Core node to Geb"
+ let (translatedMorphism, translatedObj) = Geb.fromCore readyCoreInfoTable
+ step "Typecheck the translated Geb node"
+ let typeMorph =
+ Geb.TypedMorphism
+ { _typedMorphism = translatedMorphism,
+ _typedMorphismObject = translatedObj
+ }
+ case run . runError @Geb.CheckingError $ Geb.check' typeMorph of
+ Left err ->
assertFailure . show . pretty $
fromJuvixError @GenericError (JuvixError err)
- (_, Left err) -> do
- step "The evaluation of gebCoreEvalResult failed"
- assertFailure . show . pretty $ fromJuvixError @GenericError (JuvixError err)
- ( Right resEvalTranslatedMorph,
- Right resEvalGebCoreEvalResult
- ) -> do
- step "Compare the geb value of the Core eval output and the Geb eval output"
- if
- | resEvalTranslatedMorph /= resEvalGebCoreEvalResult ->
- assertFailure "The evaluation for the Core node and the Geb node are not equal"
- | otherwise -> do
- let fpath = toFilePath expectedFile
- expectedInput <- TIO.readFile fpath
- step "Compare expected and actual program output"
- let compareEvalOutput morph =
- if
- | Geb.quote resEvalTranslatedMorph /= morph ->
- assertFailure $
- "The result of evaluating the translated Geb"
- <> "node is not equal to the expected output"
- | otherwise -> assertBool "" True
- case Geb.runParser expectedFile expectedInput of
- Left parseErr -> assertFailure . show . pretty $ parseErr
- Right (Geb.ExpressionMorphism m) -> compareEvalOutput m
- Right (Geb.ExpressionTypedMorphism m) -> compareEvalOutput (m ^. Geb.typedMorphism)
- Right (Geb.ExpressionObject _) ->
- assertFailure "Expected a morphism, but got an object for the expected output"
+ Right _ -> do
+ step "Try evaluating the JuvixCore node"
+ let resultCoreEval :: Core.Node = Core.evalInfoTable stderr readyCoreInfoTable
+ step "Translate the result of the evaluated JuvixCore node to Geb"
+ let (gebCoreEvalResult, _) = Geb.fromCore $ Core.setupMainFunction defaultModuleId readyCoreInfoTable resultCoreEval
+ case ( Geb.eval' Geb.defaultEvalEnv translatedMorphism,
+ Geb.eval' Geb.defaultEvalEnv gebCoreEvalResult
+ ) of
+ (Left err, _) -> do
+ step "The evaluation of the translated Geb node failed"
+ assertFailure . show . pretty $
+ fromJuvixError @GenericError (JuvixError err)
+ (_, Left err) -> do
+ step "The evaluation of gebCoreEvalResult failed"
+ assertFailure . show . pretty $ fromJuvixError @GenericError (JuvixError err)
+ ( Right resEvalTranslatedMorph,
+ Right resEvalGebCoreEvalResult
+ ) -> do
+ step "Compare the geb value of the Core eval output and the Geb eval output"
+ if
+ | resEvalTranslatedMorph /= resEvalGebCoreEvalResult ->
+ assertFailure "The evaluation for the Core node and the Geb node are not equal"
+ | otherwise -> do
+ let fpath = toFilePath expectedFile
+ expectedInput <- TIO.readFile fpath
+ step "Compare expected and actual program output"
+ let compareEvalOutput morph =
+ if
+ | Geb.quote resEvalTranslatedMorph /= morph ->
+ assertFailure $
+ "The result of evaluating the translated Geb"
+ <> "node is not equal to the expected output"
+ | otherwise -> assertBool "" True
+ case Geb.runParser expectedFile expectedInput of
+ Left parseErr -> assertFailure . show . pretty $ parseErr
+ Right (Geb.ExpressionMorphism m) -> compareEvalOutput m
+ Right (Geb.ExpressionTypedMorphism m) -> compareEvalOutput (m ^. Geb.typedMorphism)
+ Right (Geb.ExpressionObject _) ->
+ assertFailure "Expected a morphism, but got an object for the expected output"
diff --git a/test/BackendMarkdown/Negative.hs b/test/BackendMarkdown/Negative.hs
index 69124a1464..2617fb9d43 100644
--- a/test/BackendMarkdown/Negative.hs
+++ b/test/BackendMarkdown/Negative.hs
@@ -22,7 +22,7 @@ testDescr NegTest {..} =
_testRoot = tRoot,
_testAssertion = Single $ do
entryPoint <- testDefaultEntryPointIO tRoot file'
- result <- testTaggedLockedToIO (snd <$> runIOEither entryPoint upToParsing)
+ result <- testTaggedLockedToIO (runIOEither entryPoint upToParsing)
case mapLeft fromJuvixError result of
Left (Just err) -> whenJust (_checkErr err) assertFailure
Right _ -> assertFailure "Unexpected success."
diff --git a/test/BackendMarkdown/Positive.hs b/test/BackendMarkdown/Positive.hs
index 38de660e23..24af613775 100644
--- a/test/BackendMarkdown/Positive.hs
+++ b/test/BackendMarkdown/Positive.hs
@@ -4,8 +4,6 @@ import Base
import Juvix.Compiler.Backend.Markdown.Translation.FromTyped.Source
import Juvix.Compiler.Concrete qualified as Concrete
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper
-import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser
-import Juvix.Compiler.Pipeline.Setup
data PosTest = PosTest
{ _name :: String,
@@ -36,18 +34,9 @@ testDescr PosTest {..} =
_testRoot = _dir,
_testAssertion = Steps $ \step -> do
entryPoint <- testDefaultEntryPointIO _dir _file
- step "Parsing"
- p :: Parser.ParserResult <- snd <$> testRunIO entryPoint upToParsing
- step "Scoping"
- s :: Scoper.ScoperResult <-
- snd
- <$> testRunIO
- entryPoint
- ( do
- void (entrySetup defaultDependenciesConfig)
- Concrete.fromParsed p
- )
- let m = head (s ^. Scoper.resultModules)
+ step "Parsing & Scoping"
+ PipelineResult {..} <- snd <$> testRunIO entryPoint upToScoping
+ let m = _pipelineResult ^. Scoper.resultModule
let opts =
ProcessJuvixBlocksArgs
{ _processJuvixBlocksArgsConcreteOpts = Concrete.defaultOptions,
@@ -55,7 +44,7 @@ testDescr PosTest {..} =
_processJuvixBlocksArgsIdPrefix = _IdPrefix,
_processJuvixBlocksArgsNoPath = _NoPath,
_processJuvixBlocksArgsComments =
- s ^. Scoper.comments,
+ Scoper.getScoperResultComments _pipelineResult,
_processJuvixBlocksArgsModule = m,
_processJuvixBlocksArgsOutputDir =
root /> $(mkRelDir "markdown")
diff --git a/test/Base.hs b/test/Base.hs
index 576a7fe859..781b65973f 100644
--- a/test/Base.hs
+++ b/test/Base.hs
@@ -13,10 +13,9 @@ where
import Control.Monad.Extra as Monad
import Data.Algorithm.Diff
import Data.Algorithm.DiffOutput
-import Juvix.Compiler.Concrete (HighlightInput)
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination
import Juvix.Compiler.Pipeline.EntryPoint.IO
+import Juvix.Compiler.Pipeline.Loader.PathResolver
import Juvix.Compiler.Pipeline.Run
import Juvix.Data.Effect.TaggedLock
import Juvix.Extra.Paths hiding (rootBuildDir)
@@ -90,7 +89,7 @@ testRunIO ::
forall a.
EntryPoint ->
Sem (PipelineEff PipelineAppEffects) a ->
- IO (ResolverState, a)
+ IO (ResolverState, PipelineResult a)
testRunIO e = testTaggedLockedToIO . runIO defaultGenericOptions e
testDefaultEntryPointIO :: Path Abs Dir -> Path Abs File -> IO EntryPoint
@@ -102,14 +101,13 @@ testDefaultEntryPointNoFileIO cwd = testTaggedLockedToIO (defaultEntryPointNoFil
testRunIOEither ::
EntryPoint ->
Sem (PipelineEff PipelineAppEffects) a ->
- IO (HighlightInput, (Either JuvixError (ResolverState, a)))
+ IO (Either JuvixError (ResolverState, PipelineResult a))
testRunIOEither entry = testTaggedLockedToIO . runIOEither entry
testRunIOEitherTermination ::
EntryPoint ->
Sem (Termination ': PipelineEff PipelineAppEffects) a ->
- IO (Either JuvixError (ResolverState, a))
+ IO (Either JuvixError (ResolverState, PipelineResult a))
testRunIOEitherTermination entry =
- fmap snd
- . testRunIOEither entry
+ testRunIOEither entry
. evalTermination iniTerminationState
diff --git a/test/Compilation/Base.hs b/test/Compilation/Base.hs
index 1a02f1129a..be45ae3158 100644
--- a/test/Compilation/Base.hs
+++ b/test/Compilation/Base.hs
@@ -4,7 +4,6 @@ import Base
import Core.Compile.Base
import Core.Eval.Base
import Juvix.Compiler.Core qualified as Core
-import Juvix.Data.PPOutput
data CompileAssertionMode
= EvalOnly
@@ -34,16 +33,14 @@ compileAssertionEntry ::
compileAssertionEntry adjustEntry root' optLevel mode mainFile expectedFile step = do
step "Translate to JuvixCore"
entryPoint <- adjustEntry <$> testDefaultEntryPointIO root' mainFile
- tab <- (^. Core.coreResultTable) . snd <$> testRunIO entryPoint upToCore
- case run $ runReader Core.defaultCoreOptions $ runError $ Core.toEval' tab of
- Left err -> assertFailure (show (pretty (fromJuvixError @GenericError err)))
- Right tab' -> do
- let evalAssertion = coreEvalAssertion' EvalModePlain tab' mainFile expectedFile step
- compileAssertion' stdinText = coreCompileAssertion' optLevel tab' mainFile expectedFile stdinText step
- case mode of
- EvalOnly -> evalAssertion
- CompileOnly stdinText -> compileAssertion' stdinText
- EvalAndCompile -> evalAssertion >> compileAssertion' ""
+ PipelineResult {..} <- snd <$> testRunIO entryPoint upToStoredCore
+ let tab' = Core.computeCombinedInfoTable (_pipelineResult ^. Core.coreResultModule)
+ evalAssertion = coreEvalAssertion' EvalModePlain tab' mainFile expectedFile step
+ compileAssertion' stdinText = coreCompileAssertion' optLevel tab' mainFile expectedFile stdinText step
+ case mode of
+ EvalOnly -> evalAssertion
+ CompileOnly stdinText -> compileAssertion' stdinText
+ EvalAndCompile -> evalAssertion >> compileAssertion' ""
compileErrorAssertion ::
Path Abs Dir ->
@@ -53,7 +50,7 @@ compileErrorAssertion ::
compileErrorAssertion root' mainFile step = do
step "Translate to JuvixCore"
entryPoint <- testDefaultEntryPointIO root' mainFile
- tab <- (^. Core.coreResultTable) . snd <$> testRunIO entryPoint upToCore
- case run $ runReader Core.defaultCoreOptions $ runError @JuvixError $ Core.toStripped' tab of
+ PipelineResult {..} <- snd <$> testRunIO entryPoint upToCore
+ case run $ runReader Core.defaultCoreOptions $ runError @JuvixError $ Core.toStored' (_pipelineResult ^. Core.coreResultModule) >>= Core.toStripped' of
Left _ -> assertBool "" True
Right _ -> assertFailure "no error"
diff --git a/test/Core/Asm/Base.hs b/test/Core/Asm/Base.hs
index d83903601e..960d58a316 100644
--- a/test/Core/Asm/Base.hs
+++ b/test/Core/Asm/Base.hs
@@ -6,6 +6,7 @@ import Core.Eval.Base
import Core.Eval.Positive qualified as Eval
import Data.Text.IO qualified as TIO
import Juvix.Compiler.Asm.Translation.FromCore qualified as Asm
+import Juvix.Compiler.Core.Data.Module (computeCombinedInfoTable, moduleFromInfoTable)
import Juvix.Compiler.Core.Options
import Juvix.Compiler.Core.Pipeline
import Juvix.Compiler.Core.Translation.FromSource
@@ -50,8 +51,8 @@ coreAsmAssertion mainFile expectedFile step = do
assertEqDiffText ("Check: EVAL output = " <> toFilePath expectedFile) "" expected
Right (tabIni, Just node) -> do
step "Translate"
- case run $ runReader defaultCoreOptions $ runError $ toStripped' $ setupMainFunction tabIni node of
+ case run $ runReader defaultCoreOptions $ runError $ toStored' >=> toStripped' $ moduleFromInfoTable $ setupMainFunction defaultModuleId tabIni node of
Left err -> assertFailure (show (pretty (fromJuvixError @GenericError err)))
- Right tab' -> do
- let tab = Asm.fromCore $ Stripped.fromCore $ tab'
+ Right m -> do
+ let tab = Asm.fromCore $ Stripped.fromCore $ computeCombinedInfoTable m
Asm.asmRunAssertion' tab expectedFile step
diff --git a/test/Core/Compile/Base.hs b/test/Core/Compile/Base.hs
index 012207f950..6cd7d4399f 100644
--- a/test/Core/Compile/Base.hs
+++ b/test/Core/Compile/Base.hs
@@ -8,6 +8,7 @@ import Data.Text.IO qualified as TIO
import GHC.Base (seq)
import Juvix.Compiler.Asm.Pretty qualified as Asm
import Juvix.Compiler.Asm.Translation.FromCore qualified as Asm
+import Juvix.Compiler.Core.Data.Module
import Juvix.Compiler.Core.Extra.Utils
import Juvix.Compiler.Core.Options
import Juvix.Compiler.Core.Pipeline
@@ -47,11 +48,12 @@ coreCompileAssertion' ::
Assertion
coreCompileAssertion' optLevel tab mainFile expectedFile stdinText step = do
step "Translate to JuvixAsm"
- case run $ runReader opts $ runError $ toStripped' tab of
+ case run $ runReader opts $ runError $ toStored' (moduleFromInfoTable tab) >>= toStripped' of
Left err -> assertFailure (show (pretty (fromJuvixError @GenericError err)))
- Right tab0 -> do
+ Right m -> do
+ let tab0 = computeCombinedInfoTable m
assertBool "Check info table" (checkInfoTable tab0)
- let tab' = Asm.fromCore $ Stripped.fromCore $ tab0
+ let tab' = Asm.fromCore $ Stripped.fromCore tab0
length (fromText (Asm.ppPrint tab' tab') :: String) `seq`
Asm.asmCompileAssertion' optLevel tab' mainFile expectedFile stdinText step
where
@@ -73,4 +75,4 @@ coreCompileAssertion mainFile expectedFile stdinText step = do
expected <- TIO.readFile (toFilePath expectedFile)
assertEqDiffText ("Check: EVAL output = " <> toFilePath expectedFile) "" expected
Right (tabIni, Just node) ->
- coreCompileAssertion' 3 (setupMainFunction tabIni node) mainFile expectedFile stdinText step
+ coreCompileAssertion' 3 (setupMainFunction defaultModuleId tabIni node) mainFile expectedFile stdinText step
diff --git a/test/Core/Eval/Base.hs b/test/Core/Eval/Base.hs
index fca206041d..0a2eaa3bd4 100644
--- a/test/Core/Eval/Base.hs
+++ b/test/Core/Eval/Base.hs
@@ -65,7 +65,7 @@ coreEvalAssertion' mode tab mainFile expectedFile step =
let outputFile = dirPath /> $(mkRelFile "out.out")
hout <- openFile (toFilePath outputFile) WriteMode
step "Evaluate"
- let tyargs = typeArgs (lookupIdentifierInfo tab sym ^. identifierType)
+ let tyargs = typeArgs (lookupIdentifierInfo m sym ^. identifierType)
args = zipWith mkArg (tyargs ++ repeat mkDynamic') (map snd _evalDataInput)
node' = mkApps' node args
r' <- doEval' opts mainFile hout tab node'
@@ -85,7 +85,8 @@ coreEvalAssertion' mode tab mainFile expectedFile step =
Nothing -> assertFailure ("No main function registered in: " <> toFilePath mainFile)
where
sym = fromJust (tab ^. infoMain)
- ii = lookupIdentifierInfo tab sym
+ ii = lookupIdentifierInfo m sym
+ m = moduleFromInfoTable tab
opts = case mode of
EvalModePlain -> defaultEvalOptions
@@ -150,9 +151,10 @@ coreEvalAssertion mainFile expectedFile trans testTrans step = do
expected <- TIO.readFile (toFilePath expectedFile)
assertEqDiffText ("Check: EVAL output = " <> toFilePath expectedFile) "" expected
Right (tabIni, Just node) ->
- case run $ runReader defaultCoreOptions $ runError $ applyTransformations trans (setupMainFunction tabIni node) of
+ case run $ runReader defaultCoreOptions $ runError $ applyTransformations trans $ moduleFromInfoTable $ setupMainFunction defaultModuleId tabIni node of
Left err -> assertFailure (show (pretty (fromJuvixError @GenericError err)))
- Right tab -> do
+ Right m -> do
+ let tab = computeCombinedInfoTable m
assertBool "Check info table" (checkInfoTable tab)
testTrans tab
coreEvalAssertion' EvalModePlain tab mainFile expectedFile step
@@ -181,7 +183,7 @@ parseFile :: Path Abs File -> IO (Either MegaparsecError (InfoTable, Maybe Node)
parseFile f = do
let f' = toFilePath f
s <- readFile f'
- return $ runParser f emptyInfoTable s
+ return $ runParser f defaultModuleId mempty s
doEval' ::
EvalOptions ->
diff --git a/test/Core/Normalize/Base.hs b/test/Core/Normalize/Base.hs
index bf516c982f..e230a11a8c 100644
--- a/test/Core/Normalize/Base.hs
+++ b/test/Core/Normalize/Base.hs
@@ -22,12 +22,13 @@ coreNormalizeAssertion mainFile expectedFile step = do
Right (_, Nothing) -> assertFailure "Empty program"
Right (tabIni, Just node) -> do
step "Transform"
- let tab = setupMainFunction tabIni node
- transforms = toNormalizeTransformations
- case run $ runReader defaultCoreOptions $ runError @JuvixError $ applyTransformations transforms tab of
+ let tab = setupMainFunction defaultModuleId tabIni node
+ transforms = toStoredTransformations ++ toNormalizeTransformations
+ case run $ runReader defaultCoreOptions $ runError @JuvixError $ applyTransformations transforms (moduleFromInfoTable tab) of
Left err -> assertFailure (show (pretty (fromJuvixError @GenericError err)))
- Right tab' -> do
+ Right m -> do
step "Normalize"
- let node' = normalize tab' (lookupIdentifierNode tab' (fromJust $ tab' ^. infoMain))
- tab'' = setupMainFunction tab' node'
+ let tab' = computeCombinedInfoTable m
+ node' = normalize m (lookupIdentifierNode m (fromJust $ tab' ^. infoMain))
+ tab'' = setupMainFunction defaultModuleId tab' node'
coreEvalAssertion' EvalModeJSON tab'' mainFile expectedFile step
diff --git a/test/Core/Print/Base.hs b/test/Core/Print/Base.hs
index 55470f5e55..d8b320e270 100644
--- a/test/Core/Print/Base.hs
+++ b/test/Core/Print/Base.hs
@@ -4,7 +4,7 @@ import Base
import Core.Eval.Base
import Core.Eval.Positive qualified as Eval
import Data.Text.IO qualified as TIO
-import Juvix.Compiler.Core.Pipeline
+import Juvix.Compiler.Core.Data.Module (computeCombinedInfoTable, moduleFromInfoTable)
import Juvix.Compiler.Core.Pretty
import Juvix.Compiler.Core.Transformation.DisambiguateNames (disambiguateNames)
import Juvix.Compiler.Core.Translation.FromSource
@@ -46,9 +46,10 @@ corePrintAssertion mainFile expectedFile step = do
expected <- TIO.readFile (toFilePath expectedFile)
assertEqDiffText ("Check: EVAL output = " <> toFilePath expectedFile) "" expected
Right (tabIni, Just node) -> do
- let tab = disambiguateNames (setupMainFunction tabIni node)
+ let m = disambiguateNames (moduleFromInfoTable $ setupMainFunction defaultModuleId tabIni node)
+ tab = computeCombinedInfoTable m
step "Print and parse back"
- let r' = runParserMain mainFile emptyInfoTable (ppPrint tab)
+ let r' = runParserMain mainFile defaultModuleId mempty (ppPrint tab)
case r' of
Left err -> assertFailure (show (pretty err))
Right tab' -> coreEvalAssertion' EvalModePlain tab' mainFile expectedFile step
diff --git a/test/Core/Transformation/Pipeline.hs b/test/Core/Transformation/Pipeline.hs
index b9696d084e..12845f6b5c 100644
--- a/test/Core/Transformation/Pipeline.hs
+++ b/test/Core/Transformation/Pipeline.hs
@@ -9,7 +9,7 @@ allTests :: TestTree
allTests = testGroup "Transformation pipeline (to Stripped)" (map liftTest Eval.compilableTests)
pipe :: [TransformationId]
-pipe = toStrippedTransformations
+pipe = toStoredTransformations ++ toStrippedTransformations
liftTest :: Eval.PosTest -> TestTree
liftTest _testEval =
diff --git a/test/Core/VampIR/Base.hs b/test/Core/VampIR/Base.hs
index da11765e6a..01698167be 100644
--- a/test/Core/VampIR/Base.hs
+++ b/test/Core/VampIR/Base.hs
@@ -21,7 +21,7 @@ coreVampIRAssertion transforms mainFile expectedFile step = do
Left err -> assertFailure (show (pretty err))
Right (_, Nothing) -> assertFailure "Empty program"
Right (tabIni, Just node) -> do
- coreVampIRAssertion' (setupMainFunction tabIni node) transforms mainFile expectedFile step
+ coreVampIRAssertion' (setupMainFunction defaultModuleId tabIni node) transforms mainFile expectedFile step
coreVampIRAssertion' ::
InfoTable ->
@@ -33,9 +33,10 @@ coreVampIRAssertion' ::
coreVampIRAssertion' tab transforms mainFile expectedFile step = do
step "Transform and normalize"
case run . runReader defaultCoreOptions . runError @JuvixError $
- applyTransformations transforms tab of
+ applyTransformations transforms (moduleFromInfoTable tab) of
Left err -> assertFailure (show (pretty (fromJuvixError @GenericError err)))
- Right tab' -> do
+ Right m -> do
+ let tab' = computeCombinedInfoTable m
step "Check let-hoisted"
walkT checkHoisted tab'
coreEvalAssertion' EvalModeJSON tab' mainFile expectedFile step
diff --git a/test/Core/VampIR/Positive.hs b/test/Core/VampIR/Positive.hs
index f91e0ee81e..10fe0d4c54 100644
--- a/test/Core/VampIR/Positive.hs
+++ b/test/Core/VampIR/Positive.hs
@@ -10,7 +10,7 @@ fromTest :: PosTest -> TestTree
fromTest = mkTest . toTestDescr
toTestDescr :: PosTest -> TestDescr
-toTestDescr = Normalize.toTestDescr' (coreVampIRAssertion toVampIRTransformations)
+toTestDescr = Normalize.toTestDescr' (coreVampIRAssertion (toStoredTransformations ++ toVampIRTransformations))
allTests :: TestTree
allTests =
diff --git a/test/Format.hs b/test/Format.hs
index 0c5c011384..c599c80472 100644
--- a/test/Format.hs
+++ b/test/Format.hs
@@ -1,10 +1,6 @@
module Format where
import Base
-import Juvix.Compiler.Concrete qualified as Concrete
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper
-import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser
-import Juvix.Compiler.Pipeline.Setup
import Juvix.Formatter
data PosTest = PosTest
@@ -34,25 +30,15 @@ testDescr PosTest {..} =
_testRoot = _dir,
_testAssertion = Steps $ \step -> do
entryPoint <- testDefaultEntryPointIO _dir _file
- let maybeFile = entryPoint ^? entryPointModulePaths . _head
+ let maybeFile = entryPoint ^. entryPointModulePath
f <- fromMaybeM (assertFailure "Not a module") (return maybeFile)
original :: Text <- readFile (toFilePath f)
- step "Parsing"
- p :: Parser.ParserResult <- snd <$> testRunIO entryPoint upToParsing
+ step "Parsing & scoping"
+ PipelineResult {..} <- snd <$> testRunIO entryPoint upToScoping
- step "Scoping"
- s :: Scoper.ScoperResult <-
- snd
- <$> testRunIO
- entryPoint
- ( do
- void (entrySetup defaultDependenciesConfig)
- Concrete.fromParsed p
- )
-
- let formatted = formatScoperResult' _force original s
+ let formatted = formatScoperResult' _force original _pipelineResult
case _expectedFile of
Nothing -> do
step "Format"
diff --git a/test/Formatter/Positive.hs b/test/Formatter/Positive.hs
index 533036b39d..629bedfacc 100644
--- a/test/Formatter/Positive.hs
+++ b/test/Formatter/Positive.hs
@@ -9,10 +9,9 @@ runScopeEffIO :: (Member (Embed IO) r) => Path Abs Dir -> Sem (ScopeEff ': r) a
runScopeEffIO root = interpret $ \case
ScopeFile p -> do
entry <- embed (testDefaultEntryPointIO root p)
- embed (snd <$> testRunIO entry upToScoping)
- ScopeStdin -> do
- entry <- embed (testDefaultEntryPointNoFileIO root)
- embed (snd <$> testRunIO entry upToScoping)
+ embed ((^. pipelineResult) . snd <$> testRunIO entry upToScoping)
+ ScopeStdin entry -> do
+ embed ((^. pipelineResult) . snd <$> testRunIO entry upToScoping)
makeFormatTest' :: Scope.PosTest -> TestDescr
makeFormatTest' Scope.PosTest {..} =
diff --git a/test/Internal/Eval/Base.hs b/test/Internal/Eval/Base.hs
index af0253b567..8fa007f079 100644
--- a/test/Internal/Eval/Base.hs
+++ b/test/Internal/Eval/Base.hs
@@ -9,15 +9,16 @@ import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Info qualified as Info
import Juvix.Compiler.Core.Info.NoDisplayInfo
import Juvix.Compiler.Core.Pretty
-import Juvix.Compiler.Core.Transformation (etaExpansionApps)
-import Juvix.Compiler.Core.Translation.FromInternal.Data as Core
+import Juvix.Compiler.Core.Transformation (computeCombinedInfoTable, etaExpansionApps)
+import Juvix.Compiler.Core.Translation.FromInternal.Data.Context qualified as Core
internalCoreAssertion :: Path Abs Dir -> Path Abs File -> Path Abs File -> (String -> IO ()) -> Assertion
internalCoreAssertion root' mainFile expectedFile step = do
step "Translate to Core"
entryPoint <- testDefaultEntryPointIO root' mainFile
- tab0 <- (^. Core.coreResultTable) . snd <$> testRunIO entryPoint upToCore
- let tab = etaExpansionApps tab0
+ PipelineResult {..} <- snd <$> testRunIO entryPoint upToStoredCore
+ let m = etaExpansionApps (_pipelineResult ^. Core.coreResultModule)
+ tab = computeCombinedInfoTable m
case (tab ^. infoMain) >>= ((tab ^. identContext) HashMap.!?) of
Just node -> do
withTempDir'
diff --git a/test/Main.hs b/test/Main.hs
index 79acfdca10..a6ff0b951c 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -12,7 +12,7 @@ import Formatter qualified
import Internal qualified
import Package qualified
import Parsing qualified
-import Reachability qualified
+import Resolver qualified
import Runtime qualified
import Scope qualified
import Termination qualified
@@ -38,10 +38,10 @@ fastTests =
testGroup
"Juvix fast tests"
[ Parsing.allTests,
+ Resolver.allTests,
Scope.allTests,
Termination.allTests,
Typecheck.allTests,
- Reachability.allTests,
Format.allTests,
Formatter.allTests,
Package.allTests,
diff --git a/test/Parsing/Negative.hs b/test/Parsing/Negative.hs
index 59fa45c285..0bd583399b 100644
--- a/test/Parsing/Negative.hs
+++ b/test/Parsing/Negative.hs
@@ -1,7 +1,6 @@
module Parsing.Negative where
import Base
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error
import Juvix.Parser.Error
root :: Path Abs Dir
@@ -24,7 +23,7 @@ testDescr NegTest {..} =
_testRoot = tRoot,
_testAssertion = Single $ do
entryPoint <- testDefaultEntryPointIO tRoot _file
- res <- snd <$> testRunIOEither entryPoint upToParsing
+ res <- testRunIOEither entryPoint upToParsedSource
case mapLeft fromJuvixError res of
Left (Just parErr) -> whenJust (_checkErr parErr) assertFailure
Left Nothing -> assertFailure "An error ocurred but it was not in the parser."
@@ -95,14 +94,6 @@ parserErrorTests =
filesErrorTests :: [NegTest]
filesErrorTests =
[ negTest
- "Importing a module that conflicts with a module in the stdlib"
- $(mkRelDir "StdlibConflict")
- $(mkRelFile "Input.juvix")
- $ \case
- ErrTopModulePath
- TopModulePathError {_topModulePathError = ErrDependencyConflict {}} -> Nothing
- _ -> wrongError,
- negTest
"Incorrect top module path"
$(mkRelDir ".")
$(mkRelFile "WrongModuleName.juvix")
@@ -116,14 +107,6 @@ filesErrorTests =
$ \case
ErrWrongTopModuleNameOrphan {} -> Nothing
_ -> wrongError,
- negTest
- "Import a module that doesn't exist"
- $(mkRelDir "NoDependencies")
- $(mkRelFile "InvalidImport.juvix")
- $ \case
- ErrTopModulePath
- TopModulePathError {_topModulePathError = ErrMissingModule {}} -> Nothing
- _ -> wrongError,
negTest
"Dangling Judoc comment"
$(mkRelDir ".")
diff --git a/test/Reachability.hs b/test/Reachability.hs
deleted file mode 100644
index ae10020195..0000000000
--- a/test/Reachability.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Reachability
- ( allTests,
- )
-where
-
-import Base
-import Reachability.Positive qualified as P
-
-allTests :: TestTree
-allTests = testGroup "Reachability tests" [P.allTests]
diff --git a/test/Reachability/Positive.hs b/test/Reachability/Positive.hs
deleted file mode 100644
index 4f8be9568a..0000000000
--- a/test/Reachability/Positive.hs
+++ /dev/null
@@ -1,112 +0,0 @@
-module Reachability.Positive where
-
-import Base
-import Data.HashSet qualified as HashSet
-import Juvix.Compiler.Internal.Language qualified as Internal
-import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context qualified as Internal
-
-data PosTest = PosTest
- { _name :: String,
- _relDir :: Path Rel Dir,
- _stdlibMode :: StdlibMode,
- _file :: Path Rel File,
- _reachable :: HashSet String
- }
-
-makeLenses ''PosTest
-
-root :: Path Abs Dir
-root = relToProject $(mkRelDir "tests/positive")
-
-testDescr :: PosTest -> TestDescr
-testDescr PosTest {..} =
- let tRoot = root /> _relDir
- file' = tRoot /> _file
- in TestDescr
- { _testName = _name,
- _testRoot = tRoot,
- _testAssertion = Steps $ \step -> do
- let noStdlib = _stdlibMode == StdlibExclude
- entryPoint <-
- set entryPointNoStdlib noStdlib
- <$> testDefaultEntryPointIO tRoot file'
-
- step "Pipeline up to reachability"
- p :: Internal.InternalTypedResult <- snd <$> testRunIO entryPoint upToInternalReachability
-
- step "Check reachability results"
- let names = concatMap getNames (p ^. Internal.resultModules)
- mapM_ check names
- }
- where
- check n = assertBool ("unreachable not filtered: " ++ unpack n) (HashSet.member (unpack n) _reachable)
-
-getNames :: Internal.Module -> [Text]
-getNames m =
- concatMap getDeclName (m ^. Internal.moduleBody . Internal.moduleStatements)
- <> concatMap (getNames . (^. Internal.importModule . Internal.moduleIxModule)) (m ^. Internal.moduleBody . Internal.moduleImports)
- where
- getDeclName :: Internal.MutualBlock -> [Text]
- getDeclName = \case
- (Internal.MutualBlock f) -> map getMutualName (toList f)
- getMutualName :: Internal.MutualStatement -> Text
- getMutualName = \case
- Internal.StatementFunction f -> f ^. Internal.funDefName . Internal.nameText
- Internal.StatementInductive f -> f ^. Internal.inductiveName . Internal.nameText
- Internal.StatementAxiom ax -> ax ^. (Internal.axiomName . Internal.nameText)
-
-allTests :: TestTree
-allTests =
- testGroup
- "Reachability positive tests"
- (map (mkTest . testDescr) tests)
-
-tests :: [PosTest]
-tests =
- [ PosTest
- "Reachability with modules"
- $(mkRelDir "Reachability")
- StdlibInclude
- $(mkRelFile "M.juvix")
- ( HashSet.fromList
- ["f", "g", "h", "Bool", "Maybe"]
- ),
- PosTest
- "Reachability with modules and standard library"
- $(mkRelDir "Reachability")
- StdlibInclude
- $(mkRelFile "N.juvix")
- ( HashSet.fromList
- [ "test",
- "Unit",
- "Bool",
- "Nat",
- "Int",
- "fromNat",
- "Natural",
- "fromInt",
- "Integral",
- "naturalNatI",
- "naturalIntI",
- "integralIntI",
- "+",
- "*",
- "sub",
- "udiv",
- "div",
- "mod",
- "intSubNat",
- "negNat",
- "neg",
- "-"
- ]
- ),
- PosTest
- "Reachability with public imports"
- $(mkRelDir "Reachability")
- StdlibInclude
- $(mkRelFile "O.juvix")
- ( HashSet.fromList
- ["f", "g", "h", "k", "Bool", "Maybe", "Nat"]
- )
- ]
diff --git a/test/Resolver.hs b/test/Resolver.hs
new file mode 100644
index 0000000000..fb556d6bdf
--- /dev/null
+++ b/test/Resolver.hs
@@ -0,0 +1,10 @@
+module Resolver
+ ( allTests,
+ )
+where
+
+import Base
+import Resolver.Negative qualified as N
+
+allTests :: TestTree
+allTests = testGroup "Path resolver tests" [N.allTests]
diff --git a/test/Resolver/Negative.hs b/test/Resolver/Negative.hs
new file mode 100644
index 0000000000..a15c929717
--- /dev/null
+++ b/test/Resolver/Negative.hs
@@ -0,0 +1,73 @@
+module Resolver.Negative where
+
+import Base
+import Juvix.Compiler.Pipeline.Loader.PathResolver.Error
+
+root :: Path Abs Dir
+root = relToProject $(mkRelDir "tests/negative")
+
+type FailMsg = String
+
+data NegTest = NegTest
+ { _name :: String,
+ _dir :: Path Abs Dir,
+ _file :: Path Abs File,
+ _checkErr :: PathResolverError -> Maybe FailMsg
+ }
+
+testDescr :: NegTest -> TestDescr
+testDescr NegTest {..} =
+ let tRoot = _dir
+ in TestDescr
+ { _testName = _name,
+ _testRoot = tRoot,
+ _testAssertion = Single $ do
+ entryPoint <- testDefaultEntryPointIO tRoot _file
+ res <- testRunIOEither entryPoint upToParsedSource
+ case mapLeft fromJuvixError res of
+ Left (Just parErr) -> whenJust (_checkErr parErr) assertFailure
+ Left Nothing -> assertFailure "An error ocurred but it was not in the path resolver."
+ Right _ -> assertFailure "The path resolver did not find an error."
+ }
+
+allTests :: TestTree
+allTests =
+ testGroup
+ "Path resolver negative tests"
+ ( map (mkTest . testDescr) resolverErrorTests
+ )
+
+wrongError :: Maybe FailMsg
+wrongError = Just "Incorrect error"
+
+negTest :: String -> Path Rel Dir -> Path Rel File -> (PathResolverError -> Maybe FailMsg) -> NegTest
+negTest _name d f _checkErr = negTestAbsDir _name (root /> d) f _checkErr
+
+negTestAbsDir :: String -> Path Abs Dir -> Path Rel File -> (PathResolverError -> Maybe FailMsg) -> NegTest
+negTestAbsDir _name _dir f _checkErr =
+ NegTest
+ { _file = _dir /> f,
+ _dir,
+ _name,
+ _checkErr
+ }
+
+resolverErrorTests :: [NegTest]
+resolverErrorTests =
+ [ negTest
+ "Importing a module that conflicts with a module in the stdlib"
+ $(mkRelDir "StdlibConflict")
+ $(mkRelFile "Input.juvix")
+ $ \case
+ ErrDependencyConflict
+ DependencyConflict {} -> Nothing
+ _ -> wrongError,
+ negTest
+ "Import a module that doesn't exist"
+ $(mkRelDir "NoDependencies")
+ $(mkRelFile "InvalidImport.juvix")
+ $ \case
+ ErrMissingModule
+ MissingModule {} -> Nothing
+ _ -> wrongError
+ ]
diff --git a/test/Scope/Positive.hs b/test/Scope/Positive.hs
index fb13e16cdd..983abd4676 100644
--- a/test/Scope/Positive.hs
+++ b/test/Scope/Positive.hs
@@ -1,23 +1,11 @@
module Scope.Positive where
import Base
-import Data.HashMap.Strict qualified as HashMap
-import Juvix.Compiler.Builtins (evalTopBuiltins)
-import Juvix.Compiler.Concrete qualified as Concrete
-import Juvix.Compiler.Concrete.Data.Highlight (ignoreHighlightBuilder)
import Juvix.Compiler.Concrete.Extra
import Juvix.Compiler.Concrete.Print qualified as P
-import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper
import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser
-import Juvix.Compiler.Pipeline.Package.Loader
-import Juvix.Compiler.Pipeline.Package.Loader.Error
-import Juvix.Compiler.Pipeline.Package.Loader.EvalEff.IO
-import Juvix.Compiler.Pipeline.Package.Loader.PathResolver
-import Juvix.Compiler.Pipeline.Setup
-import Juvix.Data.Effect.Git
-import Juvix.Data.Effect.Process
-import Juvix.Data.Effect.TaggedLock
+import Juvix.Compiler.Store.Scoped.Language
import Juvix.Prelude.Pretty
data PathResolverMode
@@ -43,6 +31,11 @@ root = relToProject $(mkRelDir "tests/positive")
renderCodeNew :: (P.PrettyPrint c) => c -> Text
renderCodeNew = toPlainText . P.ppOutNoComments P.defaultOptions
+getModuleFilePath' :: Either ScopedModule (Scoper.Module s 'Scoper.ModuleTop) -> Path Abs File
+getModuleFilePath' = \case
+ Left m -> m ^. scopedModuleFilePath
+ Right m -> getModuleFilePath m
+
testDescr :: PosTest -> TestDescr
testDescr PosTest {..} = helper renderCodeNew
where
@@ -55,85 +48,37 @@ testDescr PosTest {..} = helper renderCodeNew
_testRoot = tRoot,
_testAssertion = Steps $ \step -> do
entryPoint <- testDefaultEntryPointIO tRoot file'
- let runHelper :: HashMap (Path Abs File) Text -> Sem (PipelineEff PipelineAppEffects) a -> IO (ResolverState, a)
- runHelper files = do
- let runPathResolver' = case _pathResolverMode of
- FullPathResolver -> runPathResolverPipe
- PackagePathResolver -> runPackagePathResolver' (entryPoint ^. entryPointResolverRoot)
- runFinal
- . resourceToIOFinal
- . embedToFinal @IO
- . runTaggedLock LockModeExclusive
- . evalInternetOffline
- . ignoreHighlightBuilder
- . runErrorIO' @JuvixError
- . evalTopBuiltins
- . evalTopNameIdGen
- . runFilesPure files tRoot
- . runReader entryPoint
- . ignoreLog
- . runProcessIO
- . mapError (JuvixError @GitProcessError)
- . runGitProcess
- . mapError (JuvixError @DependencyError)
- . mapError (JuvixError @PackageLoaderError)
- . runEvalFileEffIO
- . runPathResolver'
- evalHelper :: HashMap (Path Abs File) Text -> Sem (PipelineEff PipelineAppEffects) a -> IO a
- evalHelper files = fmap snd . runHelper files
- step "Parsing"
- p :: Parser.ParserResult <- snd <$> testRunIO entryPoint upToParsing
+ let evalHelper :: Text -> Sem (PipelineEff PipelineAppEffects) a -> IO (PipelineResult a)
+ evalHelper input m = snd <$> testRunIO entryPoint {_entryPointStdin = Just input} m
- step "Scoping"
- (resolverState :: ResolverState, s :: Scoper.ScoperResult) <-
- testRunIO
- entryPoint
- ( do
- void (entrySetup defaultDependenciesConfig)
- Concrete.fromParsed p
- )
+ step "Parsing & Scoping"
+ PipelineResult s _ _ <- snd <$> testRunIO entryPoint upToScoping
- let packageFiles' :: [(Path Abs File, Text)]
- packageFiles' =
- [ (pkgi ^. packagePackage . packageFile, renderPackageVersion PackageVersion1 (pkgi ^. packagePackage))
- | pkgi <- (^. resolverCacheItemPackage) <$> toList (resolverState ^. resolverCache)
- ]
- fsScoped :: HashMap (Path Abs File) Text
- fsScoped =
- HashMap.fromList $
- [ (getModuleFilePath m, renderer m)
- | m <- toList (s ^. Scoper.resultScoperTable . Scoper.infoModules)
- ]
- <> packageFiles'
- fsParsed :: HashMap (Path Abs File) Text
- fsParsed =
- HashMap.fromList $
- [ (getModuleFilePath m, renderCodeNew m)
- | m <- toList (p ^. Parser.resultTable . Parser.infoParsedModules)
- ]
- <> packageFiles'
+ let p = s ^. Scoper.resultParserResult
+ fScoped :: Text
+ fScoped = renderer $ s ^. Scoper.resultModule
+ fParsed :: Text
+ fParsed = renderer $ p ^. Parser.resultModule
- step "Parsing pretty scoped"
- p' :: Parser.ParserResult <- evalHelper fsScoped upToParsing
+ step "Parsing & scoping pretty scoped"
+ PipelineResult s' _ _ <- evalHelper fScoped upToScoping
+ let p' = s' ^. Scoper.resultParserResult
step "Parsing pretty parsed"
- parsedPretty' :: Parser.ParserResult <- evalHelper fsParsed upToParsing
-
- step "Scoping the scoped"
- s' :: Scoper.ScoperResult <- evalHelper fsScoped upToScoping
+ PipelineResult parsedPretty' _ _ <- evalHelper fParsed upToParsedSource
step "Checks"
- let smodules = s ^. Scoper.resultModules
- smodules' = s' ^. Scoper.resultModules
+ let smodule = s ^. Scoper.resultModule
+ smodule' = s' ^. Scoper.resultModule
- let pmodules = p ^. Parser.resultModules
- pmodules' = p' ^. Parser.resultModules
- parsedPrettyModules = parsedPretty' ^. Parser.resultModules
+ let pmodule = p ^. Parser.resultModule
+ pmodule' = p' ^. Parser.resultModule
+ parsedPrettyModule = parsedPretty' ^. Parser.resultModule
- assertEqDiffShow "check: scope . parse . pretty . scope . parse = scope . parse" smodules smodules'
- assertEqDiffShow "check: parse . pretty . scope . parse = parse" pmodules pmodules'
- assertEqDiffShow "check: parse . pretty . parse = parse" pmodules parsedPrettyModules
+ assertEqDiffShow "check: scope . parse . pretty . scope . parse = scope . parse" smodule smodule'
+ assertEqDiffShow "check: parse . pretty . scope . parse = parse" pmodule pmodule'
+ assertEqDiffShow "check: parse . pretty . parse = parse" pmodule parsedPrettyModule
}
allTests :: TestTree
diff --git a/test/Termination/Negative.hs b/test/Termination/Negative.hs
index ca429abfae..e366c710e5 100644
--- a/test/Termination/Negative.hs
+++ b/test/Termination/Negative.hs
@@ -21,7 +21,7 @@ testDescr NegTest {..} =
_testRoot = tRoot,
_testAssertion = Single $ do
entryPoint <- set entryPointNoStdlib True <$> testDefaultEntryPointIO tRoot file'
- result <- snd <$> testRunIOEither entryPoint upToInternalTyped
+ result <- testRunIOEither entryPoint upToInternalTyped
case mapLeft fromJuvixError result of
Left (Just lexError) -> whenJust (_checkErr lexError) assertFailure
Left Nothing -> assertFailure "The termination checker did not find an error."
diff --git a/test/Typecheck/Negative.hs b/test/Typecheck/Negative.hs
index a793e561b3..4b54326d6e 100644
--- a/test/Typecheck/Negative.hs
+++ b/test/Typecheck/Negative.hs
@@ -24,7 +24,7 @@ testDescr NegTest {..} =
_testRoot = tRoot,
_testAssertion = Single $ do
entryPoint <- testDefaultEntryPointIO tRoot file'
- result <- snd <$> testRunIOEither entryPoint upToInternalTyped
+ result <- testRunIOEither entryPoint upToInternalTyped
case mapLeft fromJuvixError result of
Left (Just tyError) -> whenJust (_checkErr tyError) assertFailure
Left Nothing -> assertFailure "An error ocurred but it was not in the type checker."
diff --git a/test/Typecheck/NegativeNew.hs b/test/Typecheck/NegativeNew.hs
index be92bd7a4d..5cf65280e3 100644
--- a/test/Typecheck/NegativeNew.hs
+++ b/test/Typecheck/NegativeNew.hs
@@ -30,7 +30,7 @@ testDescr Old.NegTest {..} =
_testRoot = tRoot,
_testAssertion = Single $ do
entryPoint <- testDefaultEntryPointIO tRoot file'
- result <- snd <$> testRunIOEither entryPoint upToCore
+ result <- testRunIOEither entryPoint upToCore
case mapLeft fromJuvixError result of
Left (Just tyError) -> whenJust (_checkErr tyError) assertFailure
Left Nothing -> assertFailure "An error ocurred but it was not in the type checker."
diff --git a/test/VampIR/Compilation/Base.hs b/test/VampIR/Compilation/Base.hs
index f45d6aa5fa..70e676dc42 100644
--- a/test/VampIR/Compilation/Base.hs
+++ b/test/VampIR/Compilation/Base.hs
@@ -10,7 +10,8 @@ vampirCompileAssertion :: Path Abs Dir -> Path Abs File -> Path Abs File -> (Str
vampirCompileAssertion root' mainFile dataFile step = do
step "Translate to JuvixCore"
entryPoint <- testDefaultEntryPointIO root' mainFile
- tab <- (^. coreResultTable) . snd <$> testRunIO entryPoint upToCore
+ PipelineResult {..} <- snd <$> testRunIO entryPoint upToStoredCore
+ let tab = computeCombinedInfoTable (_pipelineResult ^. coreResultModule)
coreVampIRAssertion' tab toVampIRTransformations mainFile dataFile step
vampirAssertion' VampirHalo2 tab dataFile step
@@ -22,11 +23,11 @@ vampirCompileErrorAssertion ::
vampirCompileErrorAssertion root' mainFile step = do
step "Translate to JuvixCore"
entryPoint <- testDefaultEntryPointIO root' mainFile
- r <- snd <$> testRunIOEither entryPoint upToCore
+ r <- testRunIOEither entryPoint upToStoredCore
case r of
Left _ -> return ()
Right res ->
- let tab = snd res ^. coreResultTable
- in case run $ runReader defaultCoreOptions $ runError @JuvixError $ toVampIR' tab of
+ let m = snd res ^. pipelineResult . coreResultModule
+ in case run $ runReader defaultCoreOptions $ runError @JuvixError $ toVampIR' m of
Left _ -> return ()
Right _ -> assertFailure "no error"
diff --git a/test/VampIR/Core/Base.hs b/test/VampIR/Core/Base.hs
index 2778bb6015..60440d61d3 100644
--- a/test/VampIR/Core/Base.hs
+++ b/test/VampIR/Core/Base.hs
@@ -13,7 +13,7 @@ vampirAssertion :: VampirBackend -> Path Abs File -> Path Abs File -> (String ->
vampirAssertion backend mainFile dataFile step = do
step "Parse"
s <- readFile (toFilePath mainFile)
- case runParserMain mainFile emptyInfoTable s of
+ case runParserMain mainFile defaultModuleId mempty s of
Left err -> assertFailure (show err)
Right tab -> vampirAssertion' backend tab dataFile step
@@ -23,7 +23,7 @@ vampirAssertion' backend tab dataFile step = do
( \dirPath -> do
step "Translate to VampIR"
let vampirFile = dirPath /> $(mkRelFile "program.pir")
- case run (runReader defaultCoreOptions (runError @JuvixError (coreToVampIR' tab))) of
+ case run (runReader defaultCoreOptions (runError @JuvixError (coreToVampIR' (moduleFromInfoTable tab)))) of
Left err -> assertFailure (show (pretty (fromJuvixError @GenericError err)))
Right VampIR.Result {..} -> do
TIO.writeFile (toFilePath vampirFile) _resultCode
diff --git a/tests/Internal/Core/positive/out/test006.out b/tests/Internal/Core/positive/out/test006.out
index e8c4b9de08..0cfbf08886 100644
--- a/tests/Internal/Core/positive/out/test006.out
+++ b/tests/Internal/Core/positive/out/test006.out
@@ -1 +1 @@
-suc (suc zero)
+2
diff --git a/tests/Internal/Core/positive/out/test011.out b/tests/Internal/Core/positive/out/test011.out
index bfcc1ac581..a787364590 100644
--- a/tests/Internal/Core/positive/out/test011.out
+++ b/tests/Internal/Core/positive/out/test011.out
@@ -1 +1 @@
-suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc zero)))))))))))))))))))))))))))))))))
+34
diff --git a/tests/Internal/positive/AsPatterns.juvix b/tests/Internal/positive/AsPatterns.juvix
index c441e2a452..793fd9d735 100644
--- a/tests/Internal/positive/AsPatterns.juvix
+++ b/tests/Internal/positive/AsPatterns.juvix
@@ -16,13 +16,16 @@ f2 : List Nat -> List Nat
| _ := nil;
f3 : Nat -> List Nat -> List Nat
- | _ a@(x :: x' :: xs) := a;
+ | _ a@(x :: x' :: xs) := a
+ | _ _ := nil;
f4 : Nat -> List Nat -> Nat
- | y (x :: a@(x' :: xs)) := y;
+ | y (x :: a@(x' :: xs)) := y
+ | _ _ := zero;
f5 : List Nat -> List Nat -> List Nat
- | (x :: a@(x' :: xs)) (y :: b@(y' :: ys)) := b;
+ | (x :: a@(x' :: xs)) (y :: b@(y' :: ys)) := b
+ | a b := a;
l1 : List Nat := zero :: suc zero :: nil;
diff --git a/tests/Internal/positive/BuiltinInductive.juvix b/tests/Internal/positive/BuiltinInductive.juvix
index 706cb37c0e..ac18cfa89f 100644
--- a/tests/Internal/positive/BuiltinInductive.juvix
+++ b/tests/Internal/positive/BuiltinInductive.juvix
@@ -1,7 +1,5 @@
module BuiltinInductive;
-builtin string
-axiom MyString : Type;
+type MyString := str;
main : Type := MyString;
-
diff --git a/tests/Internal/positive/FunctionType.juvix b/tests/Internal/positive/FunctionType.juvix
index e2e84bc48c..ebca598e82 100644
--- a/tests/Internal/positive/FunctionType.juvix
+++ b/tests/Internal/positive/FunctionType.juvix
@@ -1,7 +1,7 @@
module FunctionType;
-type A :=
- | a : A;
+type A' :=
+ | a : A';
main : Type := (A : Type) -> (B : Type) -> A -> B;
diff --git a/tests/Internal/positive/IdenFunctionArgs.juvix b/tests/Internal/positive/IdenFunctionArgs.juvix
index f40015657c..477216b518 100644
--- a/tests/Internal/positive/IdenFunctionArgs.juvix
+++ b/tests/Internal/positive/IdenFunctionArgs.juvix
@@ -6,4 +6,3 @@ f : Nat → Nat → Nat
| x y := x;
main : Nat := f 100 200;
-
diff --git a/tests/Internal/positive/IdenFunctionArgsImplicit.juvix b/tests/Internal/positive/IdenFunctionArgsImplicit.juvix
index e148104da6..e9fd2c2e68 100644
--- a/tests/Internal/positive/IdenFunctionArgsImplicit.juvix
+++ b/tests/Internal/positive/IdenFunctionArgsImplicit.juvix
@@ -6,4 +6,3 @@ f : {A : Type} → Nat → A → Nat
| x y := x;
main : Nat := f 100 200;
-
diff --git a/tests/Internal/positive/Import/out/Importer.out b/tests/Internal/positive/Import/out/Importer.out
index 55312977f8..d00491fd7e 100644
--- a/tests/Internal/positive/Import/out/Importer.out
+++ b/tests/Internal/positive/Import/out/Importer.out
@@ -1 +1 @@
-suc zero
+1
diff --git a/tests/Internal/positive/NatMatch1.juvix b/tests/Internal/positive/NatMatch1.juvix
index ff94973eaf..fd4ef76f29 100644
--- a/tests/Internal/positive/NatMatch1.juvix
+++ b/tests/Internal/positive/NatMatch1.juvix
@@ -4,7 +4,8 @@ import Stdlib.Prelude open;
f : Nat → Nat → Nat
| zero k := 100
- | (suc n) (suc (suc m)) := m;
+ | (suc n) (suc (suc m)) := m
+ | _ _ := 0;
n : Nat := suc (suc (suc (suc (suc zero))));
diff --git a/tests/Internal/positive/NatMatch2.juvix b/tests/Internal/positive/NatMatch2.juvix
index 5e1f599e25..299e257af6 100644
--- a/tests/Internal/positive/NatMatch2.juvix
+++ b/tests/Internal/positive/NatMatch2.juvix
@@ -4,7 +4,8 @@ import Stdlib.Prelude open;
f : Nat → Nat → Nat
| zero k := zero
- | n (suc (suc m)) := n;
+ | n (suc (suc m)) := n
+ | _ _ := zero;
n : Nat := suc (suc (suc (suc (suc zero))));
diff --git a/tests/Internal/positive/PatternArgs.juvix b/tests/Internal/positive/PatternArgs.juvix
index 0f3dd694ac..de264ff792 100644
--- a/tests/Internal/positive/PatternArgs.juvix
+++ b/tests/Internal/positive/PatternArgs.juvix
@@ -5,8 +5,8 @@ import Stdlib.Prelude open;
f : Nat -> Nat -> Nat
| zero zero := zero
| n1@(suc m1) n2@(suc m2) :=
- n1 + m1 + suc (suc zero) * (n2 + m2);
+ n1 + m1 + suc (suc zero) * (n2 + m2)
+ | _ _ := zero;
main : IO :=
printNatLn (f (suc (suc zero)) (suc (suc (suc zero))));
-
diff --git a/tests/Internal/positive/out/AsPatterns.out b/tests/Internal/positive/out/AsPatterns.out
index 963c1b9039..96d19926ee 100644
--- a/tests/Internal/positive/out/AsPatterns.out
+++ b/tests/Internal/positive/out/AsPatterns.out
@@ -1,5 +1,5 @@
-zero :: suc zero :: nil
-suc zero :: nil
-zero :: suc zero :: nil
-zero
-suc zero :: suc (suc zero) :: suc (suc (suc zero)) :: nil
+0 :: 1 :: nil
+1 :: nil
+0 :: 1 :: nil
+0
+1 :: 2 :: 3 :: nil
diff --git a/tests/Internal/positive/out/BuiltinAdd.out b/tests/Internal/positive/out/BuiltinAdd.out
index 7574e3e74c..00750edc07 100644
--- a/tests/Internal/positive/out/BuiltinAdd.out
+++ b/tests/Internal/positive/out/BuiltinAdd.out
@@ -1 +1 @@
-suc (suc (suc zero))
+3
diff --git a/tests/Internal/positive/out/Church.out b/tests/Internal/positive/out/Church.out
index 55312977f8..d00491fd7e 100644
--- a/tests/Internal/positive/out/Church.out
+++ b/tests/Internal/positive/out/Church.out
@@ -1 +1 @@
-suc zero
+1
diff --git a/tests/Internal/positive/out/HigherOrderLambda.out b/tests/Internal/positive/out/HigherOrderLambda.out
index 7574e3e74c..00750edc07 100644
--- a/tests/Internal/positive/out/HigherOrderLambda.out
+++ b/tests/Internal/positive/out/HigherOrderLambda.out
@@ -1 +1 @@
-suc (suc (suc zero))
+3
diff --git a/tests/Internal/positive/out/IdenFunctionArgs.out b/tests/Internal/positive/out/IdenFunctionArgs.out
index 8bd7fa2e55..29d6383b52 100644
--- a/tests/Internal/positive/out/IdenFunctionArgs.out
+++ b/tests/Internal/positive/out/IdenFunctionArgs.out
@@ -1 +1 @@
-suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc zero)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
+100
diff --git a/tests/Internal/positive/out/IdenFunctionArgsImplicit.out b/tests/Internal/positive/out/IdenFunctionArgsImplicit.out
index 8bd7fa2e55..29d6383b52 100644
--- a/tests/Internal/positive/out/IdenFunctionArgsImplicit.out
+++ b/tests/Internal/positive/out/IdenFunctionArgsImplicit.out
@@ -1 +1 @@
-suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc zero)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
+100
diff --git a/tests/Internal/positive/out/IdenFunctionIntegerLiteral.out b/tests/Internal/positive/out/IdenFunctionIntegerLiteral.out
index 55312977f8..d00491fd7e 100644
--- a/tests/Internal/positive/out/IdenFunctionIntegerLiteral.out
+++ b/tests/Internal/positive/out/IdenFunctionIntegerLiteral.out
@@ -1 +1 @@
-suc zero
+1
diff --git a/tests/Internal/positive/out/IntegerLiteral.out b/tests/Internal/positive/out/IntegerLiteral.out
index 55312977f8..d00491fd7e 100644
--- a/tests/Internal/positive/out/IntegerLiteral.out
+++ b/tests/Internal/positive/out/IntegerLiteral.out
@@ -1 +1 @@
-suc zero
+1
diff --git a/tests/Internal/positive/out/Lambda.out b/tests/Internal/positive/out/Lambda.out
index f0b5868758..b471e1165b 100644
--- a/tests/Internal/positive/out/Lambda.out
+++ b/tests/Internal/positive/out/Lambda.out
@@ -1,5 +1,5 @@
-zero
-suc (suc zero)
-zero
-suc (suc zero)
-suc (suc (suc (suc (suc (suc zero)))))
+0
+2
+0
+2
+6
diff --git a/tests/Internal/positive/out/LitInteger.out b/tests/Internal/positive/out/LitInteger.out
index 7574e3e74c..00750edc07 100644
--- a/tests/Internal/positive/out/LitInteger.out
+++ b/tests/Internal/positive/out/LitInteger.out
@@ -1 +1 @@
-suc (suc (suc zero))
+3
diff --git a/tests/Internal/positive/out/LitIntegerToNat.out b/tests/Internal/positive/out/LitIntegerToNat.out
index c3cf1b1b0a..389e262145 100644
--- a/tests/Internal/positive/out/LitIntegerToNat.out
+++ b/tests/Internal/positive/out/LitIntegerToNat.out
@@ -1,2 +1,2 @@
-suc (suc zero)
-zero
+2
+0
diff --git a/tests/Internal/positive/out/MatchConstructor.out b/tests/Internal/positive/out/MatchConstructor.out
index e73acf3e17..08839f6bb2 100644
--- a/tests/Internal/positive/out/MatchConstructor.out
+++ b/tests/Internal/positive/out/MatchConstructor.out
@@ -1 +1 @@
-suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc zero)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
+200
diff --git a/tests/Internal/positive/out/NatMatch1.out b/tests/Internal/positive/out/NatMatch1.out
index 7574e3e74c..00750edc07 100644
--- a/tests/Internal/positive/out/NatMatch1.out
+++ b/tests/Internal/positive/out/NatMatch1.out
@@ -1 +1 @@
-suc (suc (suc zero))
+3
diff --git a/tests/Internal/positive/out/NatMatch2.out b/tests/Internal/positive/out/NatMatch2.out
index f3a3ba66ef..7ed6ff82de 100644
--- a/tests/Internal/positive/out/NatMatch2.out
+++ b/tests/Internal/positive/out/NatMatch2.out
@@ -1 +1 @@
-suc (suc (suc (suc (suc zero))))
+5
diff --git a/tests/Internal/positive/out/PatternArgs.out b/tests/Internal/positive/out/PatternArgs.out
index a188bb98f1..b1bd38b62a 100644
--- a/tests/Internal/positive/out/PatternArgs.out
+++ b/tests/Internal/positive/out/PatternArgs.out
@@ -1 +1 @@
-suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc (suc zero))))))))))))
+13
diff --git a/tests/Internal/positive/out/QuickSort.out b/tests/Internal/positive/out/QuickSort.out
index 6d04fd0060..3ad19d955a 100644
--- a/tests/Internal/positive/out/QuickSort.out
+++ b/tests/Internal/positive/out/QuickSort.out
@@ -1 +1 @@
-:: (Nat) (suc (suc zero)) (:: (Nat) (suc (suc (suc zero))) (:: (Nat) (suc (suc (suc (suc zero)))) (:: (Nat) (suc (suc (suc (suc (suc zero))))) (:: (Nat) (suc (suc (suc (suc (suc (suc zero)))))) (:: (Nat) (suc (suc (suc (suc (suc (suc (suc zero))))))) (nil (Nat)))))))
+:: Int 2 (:: Int 3 (:: Int 4 (:: Int 5 (:: Int 6 (:: Int 7 (nil Int))))))
diff --git a/tests/positive/Format.juvix b/tests/positive/Format.juvix
index ae634e38a1..0aee60b3bf 100644
--- a/tests/positive/Format.juvix
+++ b/tests/positive/Format.juvix
@@ -4,8 +4,8 @@ Format;
------------ many --- in comment
-import -- Import a module of name:
-Stdlib.Prelude open -- Bring all names into scope but..
+import Stdlib.Prelude -- Import a module of name:
+open -- Bring all names into scope but..
hiding -- Hide some names
{-- like this
,; -- don't want , here
diff --git a/tests/positive/Internal/Synonyms.juvix b/tests/positive/Internal/Synonyms.juvix
index f614ad11ad..3d579ad342 100644
--- a/tests/positive/Internal/Synonyms.juvix
+++ b/tests/positive/Internal/Synonyms.juvix
@@ -6,11 +6,11 @@ Ty1 : Type := Bool → Bool;
idTy (A : Type) : Type := A;
+typeToType : Type := Type -> Type;
+
idTy2 : typeToType
| A := A;
-typeToType : Type := Type -> Type;
-
Ty2 : idTy Type := Ty1;
k : Ty2
diff --git a/tests/positive/Iterators.juvix b/tests/positive/Iterators.juvix
index d0ec842d9d..565a9ed8a4 100644
--- a/tests/positive/Iterators.juvix
+++ b/tests/positive/Iterators.juvix
@@ -1,12 +1,10 @@
module Iterators;
syntax iterator for {init := 1; range := 1};
-
for {A B : Type} (f : A → B → A) (x : A) (y : B) : A :=
f x y;
syntax iterator itconst {init := 2; range := 2};
-
itconst
: {A B C : Type} → (A → A → B → C → A) → A → A → B → C → A
| f := f;
diff --git a/tests/positive/Markdown/markdown/Test.md b/tests/positive/Markdown/markdown/Test.md
index a2d23af825..0a45d0a794 100644
--- a/tests/positive/Markdown/markdown/Test.md
+++ b/tests/positive/Markdown/markdown/Test.md
@@ -3,17 +3,17 @@
A Juvix Markdown file name ends with `.juvix.md`. This kind of file must contain
a module declaration at the top, as shown below ---in the first code block.
-module Test;
+module Test;
Certain blocks can be hidden from the output by adding the `hide` attribute, as shown below.
-fib : Nat → Nat → Nat → Nat
| zero x1 _ := x1
| (suc n) x1 x2 := fib n x2 (x1 + x2);
fibonacci (n : Nat) : Nat := fib n 0 1;
+fib : Nat → Nat → Nat → Nat
| zero x1 _ := x1
| (suc n) x1 x2 := fib n x2 (x1 + x2);
fibonacci (n : Nat) : Nat := fib n 0 1;
Commands like `typecheck` and `compile` can be used with Juvix Markdown files.
-main : IO := readLn (printNatLn ∘ fibonacci ∘ stringToNat);
+main : IO := readLn (printNatLn ∘ fibonacci ∘ stringToNat);
Other code blocks are not touched, e.g:
@@ -57,8 +57,8 @@ We also use other markup for documentation such as:
Initial function arguments that match variables or wildcards in all clauses can
be moved to the left of the colon in the function definition. For example,
- module move-to-left;
import Stdlib.Data.Nat open;
add (n : Nat) : Nat -> Nat
| zero := n
| (suc m) := suc (add n m);
end;
+ module move-to-left;
import Stdlib.Data.Nat open;
add (n : Nat) : Nat -> Nat
| zero := n
| (suc m) := suc (add n m);
end;
is equivalent to
- module example-add;
import Stdlib.Data.Nat open;
add : Nat -> Nat -> Nat
| n zero := n
| n (suc m) := suc (add n m);
end;
+ module example-add;
import Stdlib.Data.Nat open;
add : Nat -> Nat -> Nat
| n zero := n
| n (suc m) := suc (add n m);
end;
diff --git a/tests/positive/StdlibList/Data/Product.juvix b/tests/positive/StdlibList/Data/Product.juvix
index d0f5f9d4de..41d5be3be6 100644
--- a/tests/positive/StdlibList/Data/Product.juvix
+++ b/tests/positive/StdlibList/Data/Product.juvix
@@ -1,6 +1,5 @@
module Data.Product;
syntax fixity prod := binary;
-
syntax operator × prod;
type × (a : Type) (b : Type) := , : a → b → a × b;
diff --git a/tests/positive/Syntax.juvix b/tests/positive/Syntax.juvix
index 5c6a868d93..6aa76c2f8c 100644
--- a/tests/positive/Syntax.juvix
+++ b/tests/positive/Syntax.juvix
@@ -28,24 +28,19 @@ odd : Nat -> Bool
| (suc n) := even n;
syntax fixity cmp := binary {};
-
syntax operator ==1 cmp;
-
==1 : Nat -> Nat -> Bool
| zero zero := true
| (suc a) (suc b) := a ==2 b
| _ _ := false;
--- note that ==2 is used before its infix definition
syntax operator ==2 cmp;
-
==2 : Nat -> Nat -> Bool
| zero zero := true
| (suc a) (suc b) := a ==1 b
| _ _ := false;
module MutualTypes;
- -- we use Tree and isEmpty before their definition
isNotEmpty {a : Type} (t : Tree a) : Bool :=
not (isEmpty t);
diff --git a/tests/smoke/Commands/compile.smoke.yaml b/tests/smoke/Commands/compile.smoke.yaml
index 10625f63e6..78c147bd3f 100644
--- a/tests/smoke/Commands/compile.smoke.yaml
+++ b/tests/smoke/Commands/compile.smoke.yaml
@@ -33,7 +33,7 @@ tests:
cd ./examples/milestone/
cp -r HelloWorld "$temp"
cd "$temp/HelloWorld"
- sed -i 's/just \"HelloWorld.juvix\"/nothing/' Package.juvix
+ sed -i'.bak' 's/just \"HelloWorld.juvix\"/nothing/' Package.juvix
juvix compile
exit-status: 1
stdout: |
diff --git a/tests/smoke/Commands/dev/core.smoke.yaml b/tests/smoke/Commands/dev/core.smoke.yaml
index 3ee6e6f9d6..007abfa011 100644
--- a/tests/smoke/Commands/dev/core.smoke.yaml
+++ b/tests/smoke/Commands/dev/core.smoke.yaml
@@ -9,22 +9,7 @@ tests:
- from-concrete
- --eval
- --transforms
- - eta-expand-apps
- args:
- - positive/Internal/LiteralInt.juvix
- stdout: |
- suc (suc zero)
- exit-status: 0
-
- - name: core-from-concrete-eval
- command:
- - juvix
- - dev
- - core
- - from-concrete
- - --eval
- - --transforms
- - eta-expand-apps,nat-to-primint
+ - pipeline-stored
args:
- positive/Internal/LiteralInt.juvix
stdout: |
@@ -39,13 +24,13 @@ tests:
- from-concrete
- --eval
- --transforms
- - eta-expand-apps
+ - pipeline-stored
- --symbol-name
- f
args:
- positive/Internal/LiteralInt.juvix
stdout: |
- suc zero
+ 1
exit-status: 0
- name: core-repl-normalize
@@ -66,12 +51,12 @@ tests:
- dev
- core
- from-concrete
- - -t eta-expand-apps
+ - -t pipeline-stored
- --normalize
args:
- positive/Internal/Norm.juvix
stdout: |
- suc (suc (suc zero))
+ 3
exit-status: 0
- name: core-read-normalize
diff --git a/tests/smoke/Commands/dev/repl.smoke.yaml b/tests/smoke/Commands/dev/repl.smoke.yaml
index 4d834aa8a4..a72369ec4e 100644
--- a/tests/smoke/Commands/dev/repl.smoke.yaml
+++ b/tests/smoke/Commands/dev/repl.smoke.yaml
@@ -295,5 +295,5 @@ tests:
stdin: "0"
stdout:
contains: |
- zero
+ 0
exit-status: 0
diff --git a/tests/smoke/Commands/html.smoke.yaml b/tests/smoke/Commands/html.smoke.yaml
index 72147a036e..938ffdb969 100644
--- a/tests/smoke/Commands/html.smoke.yaml
+++ b/tests/smoke/Commands/html.smoke.yaml
@@ -67,7 +67,7 @@ tests:
cat html/HelloWorld.html
stdout:
matches: |
- .*href="HelloWorld.html#XYZ[0-9]+".*
+ .*href="HelloWorld.html#XYZHelloWorld:[0-9]+".*
exit-status: 0
- name: html-no-path
@@ -81,5 +81,5 @@ tests:
cat html/HelloWorld.html
stdout:
matches: |
- .*href="#[0-9]+".*
- exit-status: 0
\ No newline at end of file
+ .*href="#HelloWorld:[0-9]+".*
+ exit-status: 0
diff --git a/tests/smoke/Commands/markdown.smoke.yaml b/tests/smoke/Commands/markdown.smoke.yaml
index ec707ec5ee..8f0a535a0b 100644
--- a/tests/smoke/Commands/markdown.smoke.yaml
+++ b/tests/smoke/Commands/markdown.smoke.yaml
@@ -56,7 +56,7 @@ tests:
cat markdown/Test.md
stdout:
matches: |
- .*href="Test.html#XYZ[0-9]+".*
+ .*href="Test.html#XYZTest:[0-9]+".*
exit-status: 0
- name: markdown-no-path
@@ -72,7 +72,7 @@ tests:
juvix markdown Test.juvix.md --no-path --stdout
stdout:
matches: |
- .*href="#[0-9]+".*
+ .*href="#Test:[0-9]+".*
exit-status: 0
- name: markdown-options-for-mkdocs
@@ -88,5 +88,5 @@ tests:
juvix markdown Test.juvix.md --no-path --prefix-url Y --prefix-id X --stdout
stdout:
matches: |
- .*href="Y#X[0-9]+".*
- exit-status: 0
\ No newline at end of file
+ .*href="Y#XTest:[0-9]+".*
+ exit-status: 0