anoma/juvix
1
1
Fork 0
mirror of https://github.com/anoma/juvix.git synced 2024-11-24 00:35:43 +03:00
Code Issues Projects Releases Wiki Activity

Per-module compilation (#2468)

Browse Source 
* Closes #2392 

Changes checklist
-----------------
* [X] Abstract out data types for stored module representation
(`ModuleInfo` in `Juvix.Compiler.Store.Language`)
* [X] Adapt the parser to operate per-module
* [X] Adapt the scoper to operate per-module
* [X] Adapt the arity checker to operate per-module
* [X] Adapt the type checker to operate per-module
* [x] Adapt Core transformations to operate per-module
* [X] Adapt the pipeline functions in `Juvix.Compiler.Pipeline`
* [X] Add `Juvix.Compiler.Pipeline.Driver` which drives the per-module
compilation process
* [x] Implement module saving / loading in `Pipeline.Driver`
* [x] Detect cyclic module dependencies in `Pipeline.Driver`
* [x] Cache visited modules in memory in `Pipeline.Driver` to avoid
excessive disk operations and repeated hash re-computations
* [x] Recompile a module if one of its dependencies needs recompilation
and contains functions that are always inlined.
* [x] Fix identifier dependencies for mutual block creation in
`Internal.fromConcrete`
- Fixed by making textually later definitions depend on earlier ones.
- Now instances are used for resolution only after the textual point of
their definition.
- Similarly, type synonyms will be unfolded only after the textual point
of their definition.
* [x] Fix CLI
* [x] Fix REPL
* [x] Fix highlighting
* [x] Fix HTML generation
* [x] Adapt test suite
This commit is contained in:
Łukasz Czajka 2023-12-30 20:15:35 +01:00 committed by GitHub
parent 758d1cd949
commit 75bce8f665
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
300 changed files with 4978 additions and 4562 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
app/App.hs
View File

@ -3,9 +3,10 @@ module App where
import CommonOptions
import Data.ByteString qualified as ByteString
import GlobalOptions
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver
import Juvix.Compiler.Internal.Translation (InternalTypedResult)
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker
import Juvix.Compiler.Pipeline.Package
import Juvix.Compiler.Pipeline.Loader.PathResolver
import Juvix.Compiler.Pipeline.Root
import Juvix.Compiler.Pipeline.Run
import Juvix.Data.Error qualified as Error
import Juvix.Extra.Paths.Base hiding (rootBuildDir)
@ -30,7 +31,6 @@ data App m a where
GetMainFile :: Maybe (AppPath File) -> App m (Path Abs File)
FromAppPathDir :: AppPath Dir -> App m (Path Abs Dir)
RenderStdOut :: (HasAnsiBackend a, HasTextBackend a) => a -> App m ()
RunCorePipelineEither :: AppPath File -> App m (Either JuvixError Artifacts)
Say :: Text -> App m ()
SayRaw :: ByteString -> App m ()
@ -76,9 +76,6 @@ reAppIO args@RunAppIOArgs {..} =
AskInvokeDir -> return invDir
AskPkgDir -> return (_runAppIOArgsRoot ^. rootRootDir)
AskBuildDir -> return (resolveAbsBuildDir (_runAppIOArgsRoot ^. rootRootDir) (_runAppIOArgsRoot ^. rootBuildDir))
RunCorePipelineEither input -> do
entry <- getEntryPoint' args input
embed (corePipelineIOEither entry)
Say t
| g ^. globalOnlyErrors -> return ()
| otherwise -> embed (putStrLn t)
@ -129,17 +126,17 @@ getEntryPoint' RunAppIOArgs {..} inputFile = do
| otherwise -> return Nothing
set entryPointStdin estdin <$> entryPointFromGlobalOptionsPre root (inputFile ^. pathPath) opts
runPipelineNoFileEither :: (Members '[Embed IO, TaggedLock, App] r) => Sem (PipelineEff r) a -> Sem r (Either JuvixError (ResolverState, a))
runPipelineNoFileEither p = do
args <- askArgs
entry <- getEntryPointStdin' args
snd <$> runIOEither entry p
runPipelineEither :: (Members '[Embed IO, TaggedLock, App] r) => AppPath File -> Sem (PipelineEff r) a -> Sem r (Either JuvixError (ResolverState, a))
runPipelineEither :: (Members '[Embed IO, TaggedLock, App] r) => AppPath File -> Sem (PipelineEff r) a -> Sem r (Either JuvixError (ResolverState, PipelineResult a))
runPipelineEither input p = do
args <- askArgs
entry <- getEntryPoint' args input
snd <$> runIOEither entry p
runIOEither entry p
runPipelineSetupEither :: (Members '[Embed IO, TaggedLock, App] r) => Sem (PipelineEff' r) a -> Sem r (Either JuvixError (ResolverState, a))
runPipelineSetupEither p = do
args <- askArgs
entry <- getEntryPointStdin' args
runIOEitherPipeline entry p
getEntryPointStdin' :: (Members '[Embed IO, TaggedLock] r) => RunAppIOArgs -> Sem r EntryPoint
getEntryPointStdin' RunAppIOArgs {..} = do
@ -170,7 +167,13 @@ getEntryPoint inputFile = do
_runAppIOArgsRoot <- askRoot
getEntryPoint' (RunAppIOArgs {..}) inputFile
runPipelineTermination :: (Members '[App, Embed IO, TaggedLock] r) => AppPath File -> Sem (Termination ': PipelineEff r) a -> Sem r a
getEntryPointStdin :: (Members '[Embed IO, App, TaggedLock] r) => Sem r EntryPoint
getEntryPointStdin = do
_runAppIOArgsGlobalOptions <- askGlobalOptions
_runAppIOArgsRoot <- askRoot
getEntryPointStdin' (RunAppIOArgs {..})
runPipelineTermination :: (Members '[Embed IO, App, TaggedLock] r) => AppPath File -> Sem (Termination ': PipelineEff r) a -> Sem r (PipelineResult a)
runPipelineTermination input p = do
r <- runPipelineEither input (evalTermination iniTerminationState p)
case r of
@ -182,11 +185,32 @@ runPipeline input p = do
r <- runPipelineEither input p
case r of
Left err -> exitJuvixError err
Right res -> return (snd res)
Right res -> return (snd res ^. pipelineResult)
runPipelineNoFile :: (Members '[App, Embed IO, TaggedLock] r) => Sem (PipelineEff r) a -> Sem r a
runPipelineNoFile p = do
r <- runPipelineNoFileEither p
runPipelineHtml :: (Members '[App, Embed IO, TaggedLock] r) => Bool -> AppPath File -> Sem r (InternalTypedResult, [InternalTypedResult])
runPipelineHtml bNonRecursive input =
if
| bNonRecursive -> do
r <- runPipeline input upToInternalTyped
return (r, [])
| otherwise -> do
args <- askArgs
entry <- getEntryPoint' args input
r <- runPipelineHtmlEither entry
case r of
Left err -> exitJuvixError err
Right res -> return res
runPipelineEntry :: (Members '[App, Embed IO, TaggedLock] r) => EntryPoint -> Sem (PipelineEff r) a -> Sem r a
runPipelineEntry entry p = do
r <- runIOEither entry p
case r of
Left err -> exitJuvixError err
Right res -> return (snd res ^. pipelineResult)
runPipelineSetup :: (Members '[App, Embed IO, TaggedLock] r) => Sem (PipelineEff' r) a -> Sem r a
runPipelineSetup p = do
r <- runPipelineSetupEither p
case r of
Left err -> exitJuvixError err
Right res -> return (snd res)

8
app/Commands/Compile.hs
View File

@ -17,7 +17,7 @@ runCommand opts@CompileOptions {..} = do
Compile.PipelineArg
{ _pipelineArgFile = inputFile,
_pipelineArgOptions = opts,
_pipelineArgInfoTable = _coreResultTable
_pipelineArgModule = _coreResultModule
}
case _compileTarget of
TargetNative64 -> Compile.runCPipeline arg
@ -31,8 +31,8 @@ writeCoreFile :: (Members '[Embed IO, App, TaggedLock] r) => Compile.PipelineArg
writeCoreFile pa@Compile.PipelineArg {..} = do
entryPoint <- Compile.getEntry pa
coreFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
r <- runReader entryPoint $ runError @JuvixError $ Core.toEval _pipelineArgInfoTable
r <- runReader entryPoint $ runError @JuvixError $ Core.toStored _pipelineArgModule
case r of
Left e -> exitJuvixError e
Right tab ->
embed $ TIO.writeFile (toFilePath coreFile) (show $ Core.ppOutDefault (Core.disambiguateNames tab))
Right md ->
embed $ TIO.writeFile (toFilePath coreFile) (show $ Core.ppOutDefault (Core.disambiguateNames md ^. Core.moduleInfoTable))

4
app/Commands/Dependencies/Update.hs
View File

@ -1,6 +1,8 @@
module Commands.Dependencies.Update where
import Commands.Base
import Juvix.Compiler.Pipeline.Loader.PathResolver
import Juvix.Compiler.Pipeline.Setup
runCommand :: (Members '[Embed IO, TaggedLock, App] r) => Sem r ()
runCommand = runPipelineNoFile (upToSetup (set dependenciesConfigForceUpdateLockfile True defaultDependenciesConfig))
runCommand = runPipelineSetup (entrySetup (set dependenciesConfigForceUpdateLockfile True defaultDependenciesConfig))

6
app/Commands/Dev/Core/Asm.hs
View File

@ -12,9 +12,9 @@ runCommand opts = do
gopts <- askGlobalOptions
inputFile :: Path Abs File <- fromAppPathFile sinputFile
s' <- readFile $ toFilePath inputFile
tab <- getRight (mapLeft JuvixError (Core.runParserMain inputFile Core.emptyInfoTable s'))
r <- runReader (project @GlobalOptions @Core.CoreOptions gopts) $ runError @JuvixError $ Core.toStripped' tab
tab' <- Asm.fromCore . Stripped.fromCore <$> getRight r
tab <- getRight (mapLeft JuvixError (Core.runParserMain inputFile defaultModuleId mempty s'))
r <- runReader (project @GlobalOptions @Core.CoreOptions gopts) $ runError @JuvixError $ Core.toStripped' (Core.moduleFromInfoTable tab)
tab' <- Asm.fromCore . Stripped.fromCore . Core.computeCombinedInfoTable <$> getRight r
if
| project opts ^. coreAsmPrint ->
renderStdOut (Asm.ppOutDefault tab' tab')

6
app/Commands/Dev/Core/Compile.hs
View File

@ -3,15 +3,15 @@ module Commands.Dev.Core.Compile where
import Commands.Base
import Commands.Dev.Core.Compile.Base
import Commands.Dev.Core.Compile.Options
import Juvix.Compiler.Core.Data.InfoTable qualified as Core
import Juvix.Compiler.Core.Data.Module qualified as Core
import Juvix.Compiler.Core.Translation.FromSource qualified as Core
runCommand :: forall r. (Members '[Embed IO, App, TaggedLock] r) => CompileOptions -> Sem r ()
runCommand opts = do
file <- getFile
s <- readFile (toFilePath file)
tab <- getRight (mapLeft JuvixError (Core.runParserMain file Core.emptyInfoTable s))
let arg = PipelineArg opts file tab
tab <- getRight (mapLeft JuvixError (Core.runParserMain file defaultModuleId mempty s))
let arg = PipelineArg opts file (Core.moduleFromInfoTable tab)
case opts ^. compileTarget of
TargetWasm32Wasi -> runCPipeline arg
TargetNative64 -> runCPipeline arg

12
app/Commands/Dev/Core/Compile/Base.hs
View File

@ -9,13 +9,13 @@ 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.Core.Data.InfoTable qualified as Core
import Juvix.Compiler.Core.Data.Module qualified as Core
import System.FilePath (takeBaseName)
data PipelineArg = PipelineArg
{ _pipelineArgOptions :: CompileOptions,
_pipelineArgFile :: Path Abs File,
_pipelineArgInfoTable :: Core.InfoTable
_pipelineArgModule :: Core.Module
}
getEntry :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r EntryPoint
@ -51,7 +51,7 @@ runCPipeline ::
Sem r ()
runCPipeline pa@PipelineArg {..} = do
entryPoint <- getEntry pa
C.MiniCResult {..} <- getRight (run (runReader entryPoint (runError (coreToMiniC _pipelineArgInfoTable :: Sem '[Error JuvixError, Reader EntryPoint] C.MiniCResult))))
C.MiniCResult {..} <- getRight (run (runReader entryPoint (runError (coreToMiniC _pipelineArgModule :: Sem '[Error JuvixError, Reader EntryPoint] C.MiniCResult))))
cFile <- inputCFile _pipelineArgFile
embed $ TIO.writeFile (toFilePath cFile) _resultCCode
outfile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
@ -84,7 +84,7 @@ runGebPipeline pa@PipelineArg {..} = do
{ _lispPackageName = fromString $ takeBaseName $ toFilePath gebFile,
_lispPackageEntry = "*entry*"
}
Geb.Result {..} <- getRight (run (runReader entryPoint (runError (coreToGeb spec _pipelineArgInfoTable :: Sem '[Error JuvixError, Reader EntryPoint] Geb.Result))))
Geb.Result {..} <- getRight (run (runReader entryPoint (runError (coreToGeb spec _pipelineArgModule :: Sem '[Error JuvixError, Reader EntryPoint] Geb.Result))))
embed $ TIO.writeFile (toFilePath gebFile) _resultCode
runVampIRPipeline ::
@ -95,14 +95,14 @@ runVampIRPipeline ::
runVampIRPipeline pa@PipelineArg {..} = do
entryPoint <- getEntry pa
vampirFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
VampIR.Result {..} <- getRight (run (runReader entryPoint (runError (coreToVampIR _pipelineArgInfoTable :: Sem '[Error JuvixError, Reader EntryPoint] VampIR.Result))))
VampIR.Result {..} <- getRight (run (runReader entryPoint (runError (coreToVampIR _pipelineArgModule :: Sem '[Error JuvixError, Reader EntryPoint] VampIR.Result))))
embed $ TIO.writeFile (toFilePath vampirFile) _resultCode
runAsmPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r ()
runAsmPipeline pa@PipelineArg {..} = do
entryPoint <- getEntry pa
asmFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
r <- runReader entryPoint $ runError @JuvixError (coreToAsm _pipelineArgInfoTable)
r <- runReader entryPoint $ runError @JuvixError (coreToAsm _pipelineArgModule)
tab' <- getRight r
let code = Asm.ppPrint tab' tab'
embed $ TIO.writeFile (toFilePath asmFile) code

3
app/Commands/Dev/Core/Eval.hs
View File

@ -3,14 +3,13 @@ module Commands.Dev.Core.Eval where
import Commands.Base
import Commands.Dev.Core.Eval.Options
import Evaluator
import Juvix.Compiler.Core.Data.InfoTable qualified as Core
import Juvix.Compiler.Core.Translation.FromSource qualified as Core
runCommand :: forall r. (Members '[Embed IO, App] r) => CoreEvalOptions -> Sem r ()
runCommand opts = do
f :: Path Abs File <- fromAppPathFile b
s <- readFile (toFilePath f)
case Core.runParser f Core.emptyInfoTable s of
case Core.runParser f defaultModuleId mempty s of
Left err -> exitJuvixError (JuvixError err)
Right (tab, Just node) -> do evalAndPrint opts tab node
Right (_, Nothing) -> return ()

17
app/Commands/Dev/Core/FromConcrete.hs
View File

@ -4,20 +4,21 @@ import Commands.Base
import Commands.Dev.Core.FromConcrete.Options
import Evaluator
import Juvix.Compiler.Core.Data.InfoTable
import Juvix.Compiler.Core.Data.Module qualified as Core
import Juvix.Compiler.Core.Options qualified as Core
import Juvix.Compiler.Core.Pretty qualified as Core
import Juvix.Compiler.Core.Transformation qualified as Core
import Juvix.Compiler.Core.Transformation.DisambiguateNames (disambiguateNames)
import Juvix.Compiler.Core.Transformation.DisambiguateNames (disambiguateNames')
import Juvix.Compiler.Core.Translation
runCommand :: forall r. (Members '[Embed IO, TaggedLock, App] r) => CoreFromConcreteOptions -> Sem r ()
runCommand localOpts = do
gopts <- askGlobalOptions
tab <- (^. coreResultTable) <$> runPipeline (localOpts ^. coreFromConcreteInputFile) upToCore
md <- (^. coreResultModule) <$> runPipeline (localOpts ^. coreFromConcreteInputFile) upToCore
path :: Path Abs File <- fromAppPathFile (localOpts ^. coreFromConcreteInputFile)
let r = run $ runReader (project @GlobalOptions @Core.CoreOptions gopts) $ runError @JuvixError $ Core.applyTransformations (project localOpts ^. coreFromConcreteTransformations) tab
tab0 :: InfoTable <- getRight r
let tab' :: InfoTable = if localOpts ^. coreFromConcreteNoDisambiguate then tab0 else disambiguateNames tab0
let r = run $ runReader (project @GlobalOptions @Core.CoreOptions gopts) $ runError @JuvixError $ Core.applyTransformations (project localOpts ^. coreFromConcreteTransformations) md
tab0 :: InfoTable <- Core.computeCombinedInfoTable <$> getRight r
let tab' :: InfoTable = if localOpts ^. coreFromConcreteNoDisambiguate then tab0 else disambiguateNames' tab0
inInputModule :: IdentifierInfo -> Bool
inInputModule _ | not (localOpts ^. coreFromConcreteFilter) = True
inInputModule x = (== Just path) . (^? identifierLocation . _Just . intervalFile) $ x
@ -40,12 +41,8 @@ runCommand localOpts = do
goPrint :: Sem r ()
goPrint = case localOpts ^. coreFromConcreteSymbolName of
Just {} -> printNode (fromMaybe err (getDef selInfo))
Nothing -> renderStdOut (Core.ppOut localOpts printTab)
Nothing -> renderStdOut (Core.ppOut localOpts tab')
where
printTab :: InfoTable
printTab
| localOpts ^. coreFromConcreteFilter = filterByFile path tab'
| otherwise = tab'
printNode :: (Text, Core.Node) -> Sem r ()
printNode (name, node) = do
renderStdOut (name <> " = ")

3
app/Commands/Dev/Core/Normalize.hs
View File

@ -3,14 +3,13 @@ module Commands.Dev.Core.Normalize where
import Commands.Base
import Commands.Dev.Core.Normalize.Options
import Evaluator
import Juvix.Compiler.Core.Data.InfoTable qualified as Core
import Juvix.Compiler.Core.Translation.FromSource qualified as Core
runCommand :: forall r. (Members '[Embed IO, App] r) => CoreNormalizeOptions -> Sem r ()
runCommand opts = do
f :: Path Abs File <- fromAppPathFile b
s <- readFile (toFilePath f)
case Core.runParser f Core.emptyInfoTable s of
case Core.runParser f defaultModuleId mempty s of
Left err -> exitJuvixError (JuvixError err)
Right (tab, Just node) -> do normalizeAndPrint opts tab node
Right (_, Nothing) -> return ()

6
app/Commands/Dev/Core/Read.hs
View File

@ -23,10 +23,10 @@ runCommand opts = do
gopts <- askGlobalOptions
inputFile :: Path Abs File <- fromAppPathFile sinputFile
s' <- readFile . toFilePath $ inputFile
tab <- getRight (mapLeft JuvixError (Core.runParserMain inputFile Core.emptyInfoTable s'))
let r = run $ runReader (project @GlobalOptions @Core.CoreOptions gopts) $ runError @JuvixError $ Core.applyTransformations (project opts ^. coreReadTransformations) tab
tab <- getRight (mapLeft JuvixError (Core.runParserMain inputFile defaultModuleId mempty s'))
let r = run $ runReader (project @GlobalOptions @Core.CoreOptions gopts) $ runError @JuvixError $ Core.applyTransformations (project opts ^. coreReadTransformations) (Core.moduleFromInfoTable tab)
tab0 <- getRight $ mapLeft JuvixError r
let tab' = if project opts ^. coreReadNoDisambiguate then tab0 else Core.disambiguateNames tab0
let tab' = Core.computeCombinedInfoTable $ if project opts ^. coreReadNoDisambiguate then tab0 else Core.disambiguateNames tab0
embed (Scoper.scopeTrace tab')
unless (project opts ^. coreReadNoPrint) $ do
renderStdOut (Pretty.ppOut opts tab')

19
app/Commands/Dev/Core/Repl.hs
View File

@ -3,6 +3,7 @@ module Commands.Dev.Core.Repl where
import Commands.Base
import Commands.Dev.Core.Repl.Options
import Juvix.Compiler.Core.Data.InfoTable qualified as Core
import Juvix.Compiler.Core.Data.Module qualified as Core
import Juvix.Compiler.Core.Evaluator qualified as Core
import Juvix.Compiler.Core.Extra.Base qualified as Core
import Juvix.Compiler.Core.Info qualified as Info
@ -18,10 +19,10 @@ import Juvix.Extra.Paths
runCommand :: forall r. (Members '[Embed IO, App] r) => CoreReplOptions -> Sem r ()
runCommand opts = do
showReplWelcome
runRepl opts Core.emptyInfoTable
runRepl opts mempty
parseText :: Core.InfoTable -> Text -> Either Core.MegaparsecError (Core.InfoTable, Maybe Core.Node)
parseText = Core.runParser replPath
parseText = Core.runParser replPath defaultModuleId
runRepl :: forall r. (Members '[Embed IO, App] r) => CoreReplOptions -> Core.InfoTable -> Sem r ()
runRepl opts tab = do
@ -76,7 +77,7 @@ runRepl opts tab = do
':' : 'l' : ' ' : f -> do
s' <- readFile f
sf <- someBaseToAbs' (someFile f)
case Core.runParser sf Core.emptyInfoTable s' of
case Core.runParser sf defaultModuleId mempty s' of
Left err -> do
printJuvixError (JuvixError err)
runRepl opts tab
@ -84,7 +85,7 @@ runRepl opts tab = do
Nothing -> runRepl opts tab'
Just node -> replEval False tab' node
":r" ->
runRepl opts Core.emptyInfoTable
runRepl opts mempty
_ ->
case parseText tab s of
Left err -> do
@ -105,7 +106,7 @@ runRepl opts tab = do
Right node'
| Info.member Info.kNoDisplayInfo (Core.getInfo node') -> runRepl opts tab'
| otherwise -> do
renderStdOut (Core.ppOut opts (Core.disambiguateNodeNames tab' node'))
renderStdOut (Core.ppOut opts (Core.disambiguateNodeNames (Core.moduleFromInfoTable tab') node'))
embed (putStrLn "")
runRepl opts tab'
where
@ -113,18 +114,20 @@ runRepl opts tab = do
replNormalize :: Core.InfoTable -> Core.Node -> Sem r ()
replNormalize tab' node =
let node' = normalize tab' node
let md' = Core.moduleFromInfoTable tab'
node' = normalize md' node
in if
| Info.member Info.kNoDisplayInfo (Core.getInfo node') ->
runRepl opts tab'
| otherwise -> do
renderStdOut (Core.ppOut opts (Core.disambiguateNodeNames tab' node'))
renderStdOut (Core.ppOut opts (Core.disambiguateNodeNames md' node'))
embed (putStrLn "")
runRepl opts tab'
replType :: Core.InfoTable -> Core.Node -> Sem r ()
replType tab' node = do
let ty = Core.disambiguateNodeNames tab' (Core.computeNodeType tab' node)
let md' = Core.moduleFromInfoTable tab'
ty = Core.disambiguateNodeNames md' (Core.computeNodeType md' node)
renderStdOut (Core.ppOut opts ty)
embed (putStrLn "")
runRepl opts tab'

10
app/Commands/Dev/Core/Strip.hs
View File

@ -2,10 +2,8 @@ module Commands.Dev.Core.Strip where
import Commands.Base
import Commands.Dev.Core.Strip.Options
import Juvix.Compiler.Core.Options qualified as Core
import Juvix.Compiler.Core.Pipeline qualified as Core
import Juvix.Compiler.Core qualified as Core
import Juvix.Compiler.Core.Pretty qualified as Core
import Juvix.Compiler.Core.Translation.FromSource qualified as Core
import Juvix.Compiler.Core.Translation.Stripped.FromCore qualified as Stripped
runCommand :: forall r a. (Members '[Embed IO, App] r, CanonicalProjection a Core.Options, CanonicalProjection a CoreStripOptions) => a -> Sem r ()
@ -13,12 +11,12 @@ runCommand opts = do
gopts <- askGlobalOptions
inputFile :: Path Abs File <- fromAppPathFile sinputFile
s' <- readFile $ toFilePath inputFile
(tab, _) <- getRight (mapLeft JuvixError (Core.runParser inputFile Core.emptyInfoTable s'))
(tab, _) <- getRight (mapLeft JuvixError (Core.runParser inputFile defaultModuleId mempty s'))
let r =
run $
runReader (project gopts) $
runError @JuvixError (Core.toStripped' tab :: Sem '[Error JuvixError, Reader Core.CoreOptions] Core.InfoTable)
tab' <- getRight $ mapLeft JuvixError $ mapRight Stripped.fromCore r
runError @JuvixError (Core.toStripped' (Core.moduleFromInfoTable tab) :: Sem '[Error JuvixError, Reader Core.CoreOptions] Core.Module)
tab' <- getRight $ mapLeft JuvixError $ mapRight (Stripped.fromCore . Core.computeCombinedInfoTable) r
unless (project opts ^. coreStripNoPrint) $ do
renderStdOut (Core.ppOut opts tab')
where

2
app/Commands/Dev/Geb/Repl.hs
View File

@ -62,7 +62,7 @@ loadEntryPoint ep = do
replContextEntryPoint
(Just ep)
)
let epPath :: Maybe (Path Abs File) = ep ^? entryPointModulePaths . _head
let epPath :: Maybe (Path Abs File) = ep ^. entryPointModulePath
whenJust epPath $ \path -> do
let filepath = toFilePath path
liftIO (putStrLn . pack $ "OK loaded " <> filepath)

2
app/Commands/Dev/Internal.hs
View File

@ -3,11 +3,9 @@ module Commands.Dev.Internal where
import Commands.Base
import Commands.Dev.Internal.Options
import Commands.Dev.Internal.Pretty qualified as Pretty
import Commands.Dev.Internal.Reachability qualified as Reachability
import Commands.Dev.Internal.Typecheck qualified as Typecheck
runCommand :: (Members '[Embed IO, App, TaggedLock] r) => InternalCommand -> Sem r ()
runCommand = \case
Pretty opts -> Pretty.runCommand opts
TypeCheck opts -> Typecheck.runCommand opts
Reachability opts -> Reachability.runCommand opts

14
app/Commands/Dev/Internal/Options.hs
View File

@ -1,14 +1,12 @@
module Commands.Dev.Internal.Options where
import Commands.Dev.Internal.Pretty.Options
import Commands.Dev.Internal.Reachability.Options
import Commands.Dev.Internal.Typecheck.Options
import CommonOptions
data InternalCommand
= Pretty InternalPrettyOptions
| TypeCheck InternalTypeOptions
| Reachability InternalReachabilityOptions
deriving stock (Data)
parseInternalCommand :: Parser InternalCommand
@ -16,8 +14,7 @@ parseInternalCommand =
hsubparser $
mconcat
[ commandPretty,
commandTypeCheck,
commandReachability
commandTypeCheck
]
where
commandPretty :: Mod CommandFields InternalCommand
@ -26,9 +23,6 @@ parseInternalCommand =
commandTypeCheck :: Mod CommandFields InternalCommand
commandTypeCheck = command "typecheck" typeCheckInfo
commandReachability :: Mod CommandFields InternalCommand
commandReachability = command "reachability" reachabilityInfo
prettyInfo :: ParserInfo InternalCommand
prettyInfo =
info
@ -40,9 +34,3 @@ parseInternalCommand =
info
(TypeCheck <$> parseInternalType)
(progDesc "Translate a Juvix file to Internal and typecheck the result")
reachabilityInfo :: ParserInfo InternalCommand
reachabilityInfo =
info
(Reachability <$> parseInternalReachability)
(progDesc "Print reachability information")

2
app/Commands/Dev/Internal/Pretty.hs
View File

@ -8,5 +8,5 @@ import Juvix.Compiler.Internal.Translation.FromConcrete qualified as Internal
runCommand :: (Members '[Embed IO, App, TaggedLock] r) => InternalPrettyOptions -> Sem r ()
runCommand opts = do
globalOpts <- askGlobalOptions
intern <- head . (^. Internal.resultModules) <$> runPipelineTermination (opts ^. internalPrettyInputFile) upToInternal
intern <- (^. pipelineResult . Internal.resultModule) <$> runPipelineTermination (opts ^. internalPrettyInputFile) upToInternal
renderStdOut (Internal.ppOut globalOpts intern)

12
app/Commands/Dev/Internal/Reachability.hs
View File

@ -1,12 +0,0 @@
module Commands.Dev.Internal.Reachability where
import Commands.Base
import Commands.Dev.Internal.Reachability.Options
import Juvix.Compiler.Internal.Pretty qualified as Internal
import Juvix.Compiler.Internal.Translation.FromConcrete qualified as Internal
runCommand :: (Members '[Embed IO, App, TaggedLock] r) => InternalReachabilityOptions -> Sem r ()
runCommand opts = do
globalOpts <- askGlobalOptions
depInfo <- (^. Internal.resultDepInfo) <$> runPipelineTermination (opts ^. internalReachabilityInputFile) upToInternal
renderStdOut (Internal.ppOut globalOpts depInfo)

15
app/Commands/Dev/Internal/Reachability/Options.hs
View File

@ -1,15 +0,0 @@
module Commands.Dev.Internal.Reachability.Options where
import CommonOptions
newtype InternalReachabilityOptions = InternalReachabilityOptions
{ _internalReachabilityInputFile :: AppPath File
}
deriving stock (Data)
makeLenses ''InternalReachabilityOptions
parseInternalReachability :: Parser InternalReachabilityOptions
parseInternalReachability = do
_internalReachabilityInputFile <- parseInputFile FileExtJuvix
pure InternalReachabilityOptions {..}

2
app/Commands/Dev/Internal/Typecheck.hs
View File

@ -11,5 +11,5 @@ runCommand localOpts = do
res <- runPipeline (localOpts ^. internalTypeInputFile) upToInternalTyped
say "Well done! It type checks"
when (localOpts ^. internalTypePrint) $ do
let checkedModule = head (res ^. InternalTyped.resultModules)
let checkedModule = res ^. InternalTyped.resultModule
renderStdOut (Internal.ppOut globalOpts checkedModule)

2
app/Commands/Dev/Parse.hs
View File

@ -8,6 +8,6 @@ import Text.Show.Pretty (ppShow)
runCommand :: (Members '[Embed IO, App, TaggedLock] r) => ParseOptions -> Sem r ()
runCommand opts = do
m <-
head . (^. Parser.resultModules)
(^. Parser.resultModule)
<$> runPipeline (opts ^. parseOptionsInputFile) upToParsing
if opts ^. parseOptionsNoPrettyShow then say (show m) else say (pack (ppShow m))

4
app/Commands/Dev/Repl/Options.hs
View File

@ -2,7 +2,7 @@ module Commands.Dev.Repl.Options where
import Commands.Repl.Options
import CommonOptions
import Juvix.Compiler.Core.Data.TransformationId (toEvalTransformations)
import Juvix.Compiler.Core.Data.TransformationId (toStoredTransformations)
parseDevRepl :: Parser ReplOptions
parseDevRepl = do
@ -13,7 +13,7 @@ parseDevRepl = do
ts <- optTransformationIds
pure $
if
| null ts -> toEvalTransformations
| null ts -> toStoredTransformations
| otherwise -> ts
_replNoDisambiguate <- optNoDisambiguate
_replShowDeBruijn <-

9
app/Commands/Dev/Scope.hs
View File

@ -11,15 +11,14 @@ runCommand :: (Members '[Embed IO, TaggedLock, App] r) => ScopeOptions -> Sem r
runCommand opts = do
globalOpts <- askGlobalOptions
res :: Scoper.ScoperResult <- runPipeline (opts ^. scopeInputFile) upToScoping
let modules :: NonEmpty (Module 'Scoped 'ModuleTop) = res ^. Scoper.resultModules
forM_ modules $ \s ->
let m :: Module 'Scoped 'ModuleTop = res ^. Scoper.resultModule
if
| opts ^. scopeWithComments ->
renderStdOut (Print.ppOut (globalOpts, opts) (res ^. Scoper.comments) s)
renderStdOut (Print.ppOut (globalOpts, opts) (Scoper.getScoperResultComments res) m)
| otherwise ->
renderStdOut (Print.ppOutNoComments (globalOpts, opts) s)
renderStdOut (Print.ppOutNoComments (globalOpts, opts) m)
when (opts ^. scopeListComments) $ do
newline
newline
say "Comments:"
say (prettyText (res ^. Scoper.comments))
say (prettyText (Scoper.getScoperResultComments res))

13
app/Commands/Dev/Termination/CallGraph.hs
View File

@ -3,21 +3,22 @@ module Commands.Dev.Termination.CallGraph where
import Commands.Base
import Commands.Dev.Termination.CallGraph.Options
import Data.HashMap.Strict qualified as HashMap
import Juvix.Compiler.Internal.Language qualified as Internal
import Juvix.Compiler.Internal.Pretty qualified as Internal
import Juvix.Compiler.Internal.Translation.FromConcrete.Data.Context qualified as Internal
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination qualified as Termination
import Juvix.Compiler.Store.Extra qualified as Stored
import Juvix.Prelude.Pretty
runCommand :: (Members '[Embed IO, TaggedLock, App] r) => CallGraphOptions -> Sem r ()
runCommand CallGraphOptions {..} = do
globalOpts <- askGlobalOptions
results <- runPipelineTermination _graphInputFile upToInternal
let topModules = results ^. Internal.resultModules
mainModule = head topModules
PipelineResult {..} <- runPipelineTermination _graphInputFile upToInternal
let mainModule = _pipelineResult ^. Internal.resultModule
toAnsiText' :: forall a. (HasAnsiBackend a, HasTextBackend a) => a -> Text
toAnsiText' = toAnsiText (not (globalOpts ^. globalNoColors))
infotable = Internal.buildTable topModules
infotable =
Internal.computeCombinedInfoTable (Stored.getInternalModuleTable _pipelineResultImports)
<> _pipelineResult ^. Internal.resultInternalModule . Internal.internalModuleInfoTable
callMap = Termination.buildCallMap mainModule
completeGraph = Termination.completeCallGraph callMap
filteredGraph =
@ -36,7 +37,7 @@ runCommand CallGraphOptions {..} = do
impossible
funName
(infotable ^. Internal.infoFunctions)
markedTerminating = funInfo ^. (Internal.functionInfoDef . Internal.funDefTerminating)
markedTerminating = funInfo ^. Internal.functionInfoTerminating
n = toAnsiText' (Internal.ppOut globalOpts funName)
renderStdOut (Internal.ppOut globalOpts r)
newline

5
app/Commands/Dev/Termination/Calls.hs
View File

@ -9,9 +9,8 @@ import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination qua
runCommand :: (Members '[Embed IO, TaggedLock, App] r) => CallsOptions -> Sem r ()
runCommand localOpts@CallsOptions {..} = do
globalOpts <- askGlobalOptions
results <- runPipelineTermination _callsInputFile upToInternal
let topModules = results ^. Internal.resultModules
callMap0 = Termination.buildCallMap (head topModules)
PipelineResult {..} <- runPipelineTermination _callsInputFile upToInternal
let callMap0 = Termination.buildCallMap (_pipelineResult ^. Internal.resultModule)
callMap = case _callsFunctionNameFilter of
Nothing -> callMap0
Just f -> Termination.filterCallMap f callMap0

4
app/Commands/Eval.hs
View File

@ -14,8 +14,8 @@ runCommand opts@EvalOptions {..} = do
run $
runReader (project gopts) $
runError @JuvixError $
(Core.toEval' _coreResultTable :: Sem '[Error JuvixError, Reader Core.CoreOptions] Core.InfoTable)
tab <- getRight r
(Core.toStored' _coreResultModule :: Sem '[Error JuvixError, Reader Core.CoreOptions] Core.Module)
tab <- Core.computeCombinedInfoTable <$> getRight r
let mevalNode =
if
| isJust _evalSymbolName -> getNode tab (selInfo tab)

6
app/Commands/Format.hs
View File

@ -52,7 +52,9 @@ runCommand opts = do
res <- case target of
TargetFile p -> format p
TargetProject p -> formatProject p
TargetStdin -> formatStdin
TargetStdin -> do
entry <- getEntryPointStdin
runReader entry formatStdin
let exitFail :: IO a
exitFail = exitWith (ExitFailure 1)
@ -105,4 +107,4 @@ runScopeFileApp = interpret $ \case
_pathIsInput = False
}
runPipeline appFile upToScoping
ScopeStdin -> runPipelineNoFile upToScoping
ScopeStdin e -> runPipelineEntry e upToScoping

25
app/Commands/Html.hs
View File

@ -9,14 +9,15 @@ import Juvix.Compiler.Backend.Html.Translation.FromTyped.Source
)
import Juvix.Compiler.Concrete.Pretty qualified as Concrete
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context
import Juvix.Compiler.Internal.Translation
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context (resultInternal, resultNormalized)
import Juvix.Extra.Process
import System.Process qualified as Process
runGenOnlySourceHtml :: (Members '[Embed IO, TaggedLock, App] r) => HtmlOptions -> Sem r ()
runGenOnlySourceHtml HtmlOptions {..} = do
res <- runPipeline _htmlInputFile upToScoping
let m = head (res ^. Scoper.resultModules)
let m = res ^. Scoper.resultModule
outputDir <- fromAppPathDir _htmlOutputDir
embed $
Html.genSourceHtml
@ -30,24 +31,38 @@ runGenOnlySourceHtml HtmlOptions {..} = do
_genSourceHtmlArgsNoPath = _htmlNoPath,
_genSourceHtmlArgsConcreteOpts = Concrete.defaultOptions,
_genSourceHtmlArgsModule = m,
_genSourceHtmlArgsComments = res ^. comments,
_genSourceHtmlArgsComments = Scoper.getScoperResultComments res,
_genSourceHtmlArgsOutputDir = outputDir,
_genSourceHtmlArgsNoFooter = _htmlNoFooter,
_genSourceHtmlArgsNonRecursive = _htmlNonRecursive,
_genSourceHtmlArgsTheme = _htmlTheme
}
runCommand :: (Members '[Embed IO, TaggedLock, App] r) => HtmlOptions -> Sem r ()
resultToJudocCtx :: InternalTypedResult -> Html.JudocCtx
resultToJudocCtx res =
Html.JudocCtx
{ _judocCtxComments = Scoper.getScoperResultComments sres,
_judocCtxNormalizedTable = res ^. resultNormalized,
_judocCtxTopModules = [sres ^. Scoper.resultModule]
}
where
sres = res ^. resultInternal . resultScoper
runCommand :: forall r. (Members '[Embed IO, TaggedLock, App] r) => HtmlOptions -> Sem r ()
runCommand HtmlOptions {..}
| _htmlOnlySource = runGenOnlySourceHtml HtmlOptions {..}
| otherwise = do
ctx <- runPipeline _htmlInputFile upToInternalTyped
entry <- getEntryPoint _htmlInputFile
(r, rs) <- runPipelineHtml _htmlNonRecursive _htmlInputFile
outputDir <- fromAppPathDir _htmlOutputDir
let ctx = resultToJudocCtx r <> mconcatMap resultToJudocCtx rs
Html.genJudocHtml
entry
JudocArgs
{ _judocArgsAssetsPrefix = _htmlAssetsPrefix,
_judocArgsBaseName = "proj",
_judocArgsCtx = ctx,
_judocArgsMainModule = r ^. resultInternal . resultScoper . Scoper.resultModule,
_judocArgsOutputDir = outputDir,
_judocArgsUrlPrefix = _htmlUrlPrefix,
_judocArgsIdPrefix = _htmlIdPrefix,

1
app/Commands/Init.hs
View File

@ -5,6 +5,7 @@ import Commands.Init.Options
import Data.Text qualified as Text
import Data.Versions
import Juvix.Compiler.Pipeline.Package
import Juvix.Compiler.Pipeline.Package.IO
import Juvix.Data.Effect.Fail.Extra qualified as Fail
import Juvix.Data.Effect.TaggedLock
import Juvix.Extra.Paths

4
app/Commands/Markdown.hs
View File

@ -18,7 +18,7 @@ runCommand ::
runCommand opts = do
let inputFile = opts ^. markdownInputFile
scopedM <- runPipeline inputFile upToScoping
let m = head (scopedM ^. Scoper.resultModules)
let m = scopedM ^. Scoper.resultModule
outputDir <- fromAppPathDir (opts ^. markdownOutputDir)
let res =
MK.fromJuvixMarkdown'
@ -29,7 +29,7 @@ runCommand opts = do
opts ^. markdownIdPrefix,
_processJuvixBlocksArgsNoPath =
opts ^. markdownNoPath,
_processJuvixBlocksArgsComments = scopedM ^. Scoper.comments,
_processJuvixBlocksArgsComments = Scoper.getScoperResultComments scopedM,
_processJuvixBlocksArgsModule = m,
_processJuvixBlocksArgsOutputDir = outputDir
}

109
app/Commands/Repl.hs
View File

@ -14,14 +14,12 @@ import Control.Monad.State.Strict qualified as State
import Control.Monad.Trans.Class (lift)
import Data.String.Interpolate (i, __i)
import Evaluator
import Juvix.Compiler.Concrete.Data.InfoTable qualified as Scoped
import Juvix.Compiler.Concrete.Data.Scope (scopePath)
import Juvix.Compiler.Concrete.Data.Scope qualified as Scoped
import Juvix.Compiler.Concrete.Data.ScopedName (absTopModulePath)
import Juvix.Compiler.Concrete.Data.ScopedName qualified as Scoped
import Juvix.Compiler.Concrete.Language qualified as Concrete
import Juvix.Compiler.Concrete.Pretty qualified as Concrete
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver (runPathResolver)
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error
import Juvix.Compiler.Core qualified as Core
import Juvix.Compiler.Core.Extra.Value
import Juvix.Compiler.Core.Info qualified as Info
@ -31,14 +29,10 @@ import Juvix.Compiler.Core.Transformation qualified as Core
import Juvix.Compiler.Core.Transformation.DisambiguateNames (disambiguateNames)
import Juvix.Compiler.Internal.Language qualified as Internal
import Juvix.Compiler.Internal.Pretty qualified as Internal
import Juvix.Compiler.Pipeline.Package.Loader.Error
import Juvix.Compiler.Pipeline.Package.Loader.EvalEff.IO
import Juvix.Compiler.Pipeline.Repl
import Juvix.Compiler.Pipeline.Run
import Juvix.Compiler.Pipeline.Setup (entrySetup)
import Juvix.Compiler.Store.Extra
import Juvix.Data.CodeAnn (Ann)
import Juvix.Data.Effect.Git
import Juvix.Data.Effect.Process
import Juvix.Data.Error.GenericError qualified as Error
import Juvix.Data.NameKind
import Juvix.Extra.Paths qualified as P
@ -118,14 +112,14 @@ quit _ = liftIO (throwIO Interrupt)
loadEntryPoint :: EntryPoint -> Repl ()
loadEntryPoint ep = do
artif <- liftIO (corePipelineIO' ep)
artif <- liftIO (runReplPipelineIO ep)
let newCtx =
ReplContext
{ _replContextArtifacts = artif,
_replContextEntryPoint = ep
}
State.modify (set replStateContext (Just newCtx))
let epPath :: Maybe (Path Abs File) = ep ^? entryPointModulePaths . _head
let epPath :: Maybe (Path Abs File) = ep ^. entryPointModulePath
whenJust epPath $ \path -> liftIO (putStrLn [i|OK loaded: #{toFilePath path}|])
reloadFile :: String -> Repl ()
@ -140,29 +134,10 @@ loadFile f = do
loadEntryPoint entryPoint
loadDefaultPrelude :: Repl ()
loadDefaultPrelude = whenJustM defaultPreludeEntryPoint $ \e -> do
root <- Reader.asks (^. replRoot . rootRootDir)
let hasInternet = not (e ^. entryPointOffline)
-- The following is needed to ensure that the default location of the
-- standard library exists
void
. liftIO
. runM
. evalInternet hasInternet
. runFilesIO
. runError @JuvixError
. runReader e
. runTaggedLockPermissive
. runLogIO
. runProcessIO
. runError @GitProcessError
. runGitProcess
. runError @DependencyError
. runError @PackageLoaderError
. runEvalFileEffIO
. runPathResolver root
$ entrySetup defaultDependenciesConfig
loadEntryPoint e
loadDefaultPrelude =
whenJustM
defaultPreludeEntryPoint
loadEntryPoint
getReplEntryPoint :: (Root -> a -> GlobalOptions -> IO EntryPoint) -> a -> Repl EntryPoint
getReplEntryPoint f inputFile = do
@ -182,7 +157,7 @@ displayVersion _ = liftIO (putStrLn versionTag)
replCommand :: ReplOptions -> String -> Repl ()
replCommand opts input = catchAll $ do
ctx <- replGetContext
let tab = ctx ^. replContextArtifacts . artifactCoreTable
let tab = Core.computeCombinedInfoTable $ ctx ^. replContextArtifacts . artifactCoreModule
evalRes <- compileThenEval ctx input
whenJust evalRes $ \n ->
if
@ -215,7 +190,7 @@ replCommand opts input = catchAll $ do
doEvalIO' :: Artifacts -> Core.Node -> IO (Either JuvixError Core.Node)
doEvalIO' artif' n =
mapLeft (JuvixError @Core.CoreError)
<$> doEvalIO False replDefaultLoc (artif' ^. artifactCoreTable) n
<$> doEvalIO False replDefaultLoc (Core.computeCombinedInfoTable $ artif' ^. artifactCoreModule) n
compileString :: Repl (Maybe Core.Node)
compileString = do
@ -281,6 +256,12 @@ replParseIdentifiers input =
err :: Repl a
err = replError (mkAnsiText @Text ":def expects one or more identifiers")
getScopedInfoTable :: Repl Scoped.InfoTable
getScopedInfoTable = do
artifs <- (^. replContextArtifacts) <$> replGetContext
let tab0 = artifs ^. artifactScopeTable
return $ tab0 <> computeCombinedScopedInfoTable (artifs ^. artifactModuleTable)
printDocumentation :: String -> Repl ()
printDocumentation = replParseIdentifiers >=> printIdentifiers
where
@ -289,9 +270,6 @@ printDocumentation = replParseIdentifiers >=> printIdentifiers
printIdentifier d
whenJust (nonEmpty ds) $ \ds' -> replNewline >> printIdentifiers ds'
where
getInfoTable :: Repl Scoped.InfoTable
getInfoTable = (^. replContextArtifacts . artifactScopeTable) <$> replGetContext
printIdentifier :: Concrete.ScopedIden -> Repl ()
printIdentifier s = do
let n = s ^. Concrete.scopedIdenFinal . Scoped.nameId
@ -317,27 +295,27 @@ printDocumentation = replParseIdentifiers >=> printIdentifiers
getDocFunction :: Scoped.NameId -> Repl (Maybe (Concrete.Judoc 'Concrete.Scoped))
getDocFunction fun = do
tbl :: Scoped.InfoTable <- getInfoTable
let def :: Scoped.FunctionInfo = tbl ^?! Scoped.infoFunctions . at fun . _Just
return (def ^. Scoped.functionInfoDoc)
tbl :: Scoped.InfoTable <- getScopedInfoTable
let def = tbl ^?! Scoped.infoFunctions . at fun . _Just
return (def ^. Concrete.signDoc)
getDocInductive :: Scoped.NameId -> Repl (Maybe (Concrete.Judoc 'Concrete.Scoped))
getDocInductive ind = do
tbl :: Scoped.InfoTable <- (^. replContextArtifacts . artifactScopeTable) <$> replGetContext
let def :: Concrete.InductiveDef 'Concrete.Scoped = tbl ^?! Scoped.infoInductives . at ind . _Just . Scoped.inductiveInfoDef
tbl :: Scoped.InfoTable <- getScopedInfoTable
let def :: Concrete.InductiveDef 'Concrete.Scoped = tbl ^?! Scoped.infoInductives . at ind . _Just
return (def ^. Concrete.inductiveDoc)
getDocAxiom :: Scoped.NameId -> Repl (Maybe (Concrete.Judoc 'Concrete.Scoped))
getDocAxiom ax = do
tbl :: Scoped.InfoTable <- (^. replContextArtifacts . artifactScopeTable) <$> replGetContext
let def :: Concrete.AxiomDef 'Concrete.Scoped = tbl ^?! Scoped.infoAxioms . at ax . _Just . Scoped.axiomInfoDef
tbl :: Scoped.InfoTable <- getScopedInfoTable
let def :: Concrete.AxiomDef 'Concrete.Scoped = tbl ^?! Scoped.infoAxioms . at ax . _Just
return (def ^. Concrete.axiomDoc)
getDocConstructor :: Scoped.NameId -> Repl (Maybe (Concrete.Judoc 'Concrete.Scoped))
getDocConstructor c = do
tbl :: Scoped.InfoTable <- (^. replContextArtifacts . artifactScopeTable) <$> replGetContext
let def :: Scoped.ConstructorInfo = tbl ^?! Scoped.infoConstructors . at c . _Just
return (def ^. Scoped.constructorInfoDef . Concrete.constructorDoc)
tbl :: Scoped.InfoTable <- getScopedInfoTable
let def = tbl ^?! Scoped.infoConstructors . at c . _Just
return (def ^. Concrete.constructorDoc)
printDefinition :: String -> Repl ()
printDefinition = replParseIdentifiers >=> printIdentifiers
@ -347,9 +325,6 @@ printDefinition = replParseIdentifiers >=> printIdentifiers
printIdentifier d
whenJust (nonEmpty ds) $ \ds' -> replNewline >> printIdentifiers ds'
where
getInfoTable :: Repl Scoped.InfoTable
getInfoTable = (^. replContextArtifacts . artifactScopeTable) <$> replGetContext
printIdentifier :: Concrete.ScopedIden -> Repl ()
printIdentifier s =
let n = s ^. Concrete.scopedIdenFinal . Scoped.nameId
@ -372,7 +347,7 @@ printDefinition = replParseIdentifiers >=> printIdentifiers
printFunction :: Scoped.NameId -> Repl ()
printFunction fun = do
tbl :: Scoped.InfoTable <- getInfoTable
tbl :: Scoped.InfoTable <- getScopedInfoTable
case tbl ^. Scoped.infoFunctions . at fun of
Just def -> do
printLocation def
@ -381,22 +356,22 @@ printDefinition = replParseIdentifiers >=> printIdentifiers
printInductive :: Scoped.NameId -> Repl ()
printInductive ind = do
tbl :: Scoped.InfoTable <- (^. replContextArtifacts . artifactScopeTable) <$> replGetContext
let def :: Concrete.InductiveDef 'Concrete.Scoped = tbl ^?! Scoped.infoInductives . at ind . _Just . Scoped.inductiveInfoDef
tbl :: Scoped.InfoTable <- getScopedInfoTable
let def :: Concrete.InductiveDef 'Concrete.Scoped = tbl ^?! Scoped.infoInductives . at ind . _Just
printLocation def
printConcreteLn def
printAxiom :: Scoped.NameId -> Repl ()
printAxiom ax = do
tbl :: Scoped.InfoTable <- (^. replContextArtifacts . artifactScopeTable) <$> replGetContext
let def :: Concrete.AxiomDef 'Concrete.Scoped = tbl ^?! Scoped.infoAxioms . at ax . _Just . Scoped.axiomInfoDef
tbl :: Scoped.InfoTable <- getScopedInfoTable
let def :: Concrete.AxiomDef 'Concrete.Scoped = tbl ^?! Scoped.infoAxioms . at ax . _Just
printLocation def
printConcreteLn def
printConstructor :: Scoped.NameId -> Repl ()
printConstructor c = do
tbl :: Scoped.InfoTable <- (^. replContextArtifacts . artifactScopeTable) <$> replGetContext
let ind :: Scoped.Symbol = tbl ^?! Scoped.infoConstructors . at c . _Just . Scoped.constructorInfoTypeName
tbl :: Scoped.InfoTable <- getScopedInfoTable
let ind = tbl ^?! Scoped.infoConstructors . at c . _Just . Concrete.constructorInductiveName
printInductive (ind ^. Scoped.nameId)
inferType :: String -> Repl ()
@ -634,8 +609,8 @@ runTransformations shouldDisambiguate ts n = runCoreInfoTableBuilderArtifacts $
Core.registerIdentNode sym node
-- `n` will get filtered out by the transformations unless it has a
-- corresponding entry in `infoIdentifiers`
tab <- Core.getInfoTable
let name = Core.freshIdentName tab "_repl"
md <- Core.getModule
let name = Core.freshIdentName md "_repl"
idenInfo =
Core.IdentifierInfo
{ _identifierName = name,
@ -653,13 +628,13 @@ runTransformations shouldDisambiguate ts n = runCoreInfoTableBuilderArtifacts $
applyTransforms :: Bool -> [Core.TransformationId] -> Sem (Core.InfoTableBuilder ': r) ()
applyTransforms shouldDisambiguate' ts' = do
tab <- Core.getInfoTable
tab' <- mapReader Core.fromEntryPoint $ Core.applyTransformations ts' tab
let tab'' =
md <- Core.getModule
md' <- mapReader Core.fromEntryPoint $ Core.applyTransformations ts' md
let md'' =
if
| shouldDisambiguate' -> disambiguateNames tab'
| otherwise -> tab'
Core.setInfoTable tab''
| shouldDisambiguate' -> disambiguateNames md'
| otherwise -> md'
Core.setModule md''
getNode :: Core.Symbol -> Sem (Core.InfoTableBuilder ': r) Core.Node
getNode sym = fromMaybe impossible . flip Core.lookupIdentifierNode' sym <$> Core.getInfoTable
getNode sym = fromMaybe impossible . flip Core.lookupIdentifierNode' sym <$> Core.getModule

2
app/Commands/Repl/Options.hs
View File

@ -25,7 +25,7 @@ instance CanonicalProjection ReplOptions Core.Options where
parseRepl :: Parser ReplOptions
parseRepl = do
let _replTransformations = toEvalTransformations
let _replTransformations = toStoredTransformations
_replShowDeBruijn = False
_replNoDisambiguate = False
_replPrintValues = True

12
app/Evaluator.hs
View File

@ -2,14 +2,10 @@ module Evaluator where
import App
import CommonOptions
import Juvix.Compiler.Core.Data.InfoTable qualified as Core
import Juvix.Compiler.Core.Error qualified as Core
import Juvix.Compiler.Core.Evaluator qualified as Core
import Juvix.Compiler.Core.Extra.Base qualified as Core
import Juvix.Compiler.Core qualified as Core
import Juvix.Compiler.Core.Extra.Value qualified as Core
import Juvix.Compiler.Core.Info qualified as Info
import Juvix.Compiler.Core.Info.NoDisplayInfo qualified as Info
import Juvix.Compiler.Core.Language qualified as Core
import Juvix.Compiler.Core.Normalizer
import Juvix.Compiler.Core.Pretty qualified as Core
import Juvix.Compiler.Core.Transformation.DisambiguateNames qualified as Core
@ -54,7 +50,7 @@ evalAndPrint opts tab node = do
renderStdOut (Core.ppOut opts node'')
newline
where
node'' = if project opts ^. evalNoDisambiguate then node' else Core.disambiguateNodeNames tab node'
node'' = if project opts ^. evalNoDisambiguate then node' else Core.disambiguateNodeNames (Core.moduleFromInfoTable tab) node'
where
defaultLoc :: Sem r Interval
defaultLoc = singletonInterval . mkInitialLoc <$> fromAppPathFile f
@ -69,11 +65,11 @@ normalizeAndPrint ::
Core.Node ->
Sem r ()
normalizeAndPrint opts tab node =
let node' = normalize tab node
let node' = normalize (Core.moduleFromInfoTable tab) node
in if
| Info.member Info.kNoDisplayInfo (Core.getInfo node') ->
return ()
| otherwise -> do
let node'' = if project opts ^. evalNoDisambiguate then node' else Core.disambiguateNodeNames tab node'
let node'' = if project opts ^. evalNoDisambiguate then node' else Core.disambiguateNodeNames (Core.moduleFromInfoTable tab) node'
renderStdOut (Core.ppOut opts node'')
embed (putStrLn "")

2
app/GlobalOptions.hs
View File

@ -8,7 +8,7 @@ import CommonOptions
import Juvix.Compiler.Core.Options qualified as Core
import Juvix.Compiler.Internal.Pretty.Options qualified as Internal
import Juvix.Compiler.Pipeline
import Juvix.Compiler.Pipeline.Package (readPackageRootIO)
import Juvix.Compiler.Pipeline.Root
import Juvix.Data.Effect.TaggedLock
import Juvix.Data.Error.GenericError qualified as E

4
cntlines.sh
View File

@ -31,10 +31,11 @@ HTML=$(count src/Juvix/Compiler/Backend/Html/)
EXTRA=$(count src/Juvix/Extra/)
DATA=$(count src/Juvix/Data/)
PRELUDE=$(count src/Juvix/Prelude/)
STORE=$(count src/Juvix/Compiler/Store/)
FRONT=$((CONCRETE + INTERNAL + BUILTINS + PIPELINE))
BACK=$((BACKENDC + GEB + VAMPIR + REG + ASM + CORE))
OTHER=$((APP + HTML + EXTRA + DATA + PRELUDE))
OTHER=$((APP + STORE + HTML + EXTRA + DATA + PRELUDE))
TESTS=$(count test/)
TOTAL=$((FRONT+BACK+OTHER+TESTS))
@ -57,6 +58,7 @@ echo " JuvixAsm runtime: $RUNTIME_JVA LOC"
echo " VampIR runtime: $RUNTIME_VAMPIR LOC"
echo "Other: $OTHER LOC"
echo " Application: $APP LOC"
echo " Store: $STORE LOC"
echo " Html: $HTML LOC"
echo " Extra: $EXTRA LOC"
echo " Data: $DATA LOC"

1
package.yaml
View File

@ -48,6 +48,7 @@ dependencies:
- base16-bytestring == 1.0.*
- blaze-html == 0.9.*
- bytestring == 0.11.*
- cereal == 0.5.*
- containers == 0.6.*
- cryptohash-sha256 == 0.11.*
- directory == 1.3.*

10
src/Juvix/Compiler/Asm/Data/InfoTableBuilder.hs
View File

@ -24,7 +24,7 @@ data InfoTableBuilder m a where
makeSem ''InfoTableBuilder
data BuilderState = BuilderState
{ _stateNextSymbol :: Word,
{ _stateNextSymbolId :: Word,
_stateNextUserTag :: Word,
_stateInfoTable :: InfoTable,
_stateIdents :: HashMap Text IdentKind
@ -35,7 +35,7 @@ makeLenses ''BuilderState
emptyBuilderState :: BuilderState
emptyBuilderState =
BuilderState
{ _stateNextSymbol = 0,
{ _stateNextSymbolId = 0,
_stateNextUserTag = 0,
_stateInfoTable = emptyInfoTable,
_stateIdents = mempty
@ -53,12 +53,12 @@ runInfoTableBuilder' bs =
interp = \case
FreshSymbol -> do
s <- get
modify' (over stateNextSymbol (+ 1))
return (s ^. stateNextSymbol)
modify' (over stateNextSymbolId (+ 1))
return (Symbol defaultModuleId (s ^. stateNextSymbolId))
FreshTag -> do
modify' (over stateNextUserTag (+ 1))
s <- get
return (UserTag (s ^. stateNextUserTag - 1))
return (UserTag defaultModuleId (s ^. stateNextUserTag - 1))
RegisterFunction fi -> do
modify' (over (stateInfoTable . infoFunctions) (HashMap.insert (fi ^. functionSymbol) fi))
modify' (over stateIdents (HashMap.insert (fi ^. functionName) (IdentFun (fi ^. functionSymbol))))

11
src/Juvix/Compiler/Asm/Extra/Apply.hs
View File

@ -20,13 +20,13 @@ makeLenses ''ApplyBuiltins
addApplyBuiltins :: InfoTable -> (ApplyBuiltins, InfoTable)
addApplyBuiltins tab = (blts, bs' ^. stateInfoTable)
where
nextSymbol = maximum (0 : HashMap.keys (tab ^. infoFunctions) ++ HashMap.keys (tab ^. infoInductives)) + 1
nextUserId = maximum (0 : mapMaybe getUserTag (HashMap.keys (tab ^. infoConstrs))) + 1
nextSymbolId = maximum (0 : map (^. symbolId) (HashMap.keys (tab ^. infoFunctions) ++ HashMap.keys (tab ^. infoInductives))) + 1
nextUserId = maximum (0 : mapMaybe getUserTagId (HashMap.keys (tab ^. infoConstrs))) + 1
bs :: BuilderState
bs =
BuilderState
{ _stateNextSymbol = nextSymbol,
{ _stateNextSymbolId = nextSymbolId,
_stateNextUserTag = nextUserId,
_stateInfoTable = tab,
_stateIdents = mempty
@ -53,8 +53,3 @@ addApplyBuiltins tab = (blts, bs' ^. stateInfoTable)
f = case fromJust $ HashMap.lookup idt (bs' ^. stateIdents) of
IdentFun s -> s
_ -> impossible
getUserTag :: Tag -> Maybe Word
getUserTag = \case
BuiltinTag {} -> Nothing
UserTag x -> Just x

2
src/Juvix/Compiler/Asm/Pretty/Base.hs
View File

@ -398,7 +398,7 @@ instance PrettyCode InfoTable where
HashMap.filter
( \ii -> case ii ^. inductiveConstructors of
BuiltinTag _ : _ -> False
UserTag _ : _ -> True
UserTag _ _ : _ -> True
[] -> True
)

2
src/Juvix/Compiler/Asm/Translation/FromSource.hs
View File

@ -42,7 +42,7 @@ runParser' bs fileName input =
evalState @Index 0 $
evalState @LocalNameMap mempty $
runInfoTableBuilder' bs $
evalTopNameIdGen $
evalTopNameIdGen defaultModuleId $
P.runParserT parseToplevel fileName input of
(_, Left err) -> Left (MegaparsecError err)
(bs', Right ()) -> Right bs'

18
src/Juvix/Compiler/Backend/Geb/Translation/FromCore.hs
View File

@ -57,9 +57,9 @@ withSymbol sym a = do
fromCore :: Core.InfoTable -> (Morphism, Object)
fromCore tab = case tab ^. Core.infoMain of
Just sym ->
let node = Core.lookupIdentifierNode tab sym
let node = Core.lookupTabIdentifierNode tab sym
syms = reverse $ filter (/= sym) $ Core.createCallGraph tab ^. Core.depInfoTopSort
idents = map (Core.lookupIdentifierInfo tab) syms
idents = map (Core.lookupTabIdentifierInfo tab) syms
morph = run . runReader emptyEnv $ goIdents node idents
obj = convertType $ Info.getNodeType node
in (morph, obj)
@ -104,7 +104,7 @@ fromCore tab = case tab ^. Core.infoMain of
}
where
sym = ii ^. Core.identifierSymbol
fundef = Core.lookupIdentifierNode tab sym
fundef = Core.lookupTabIdentifierNode tab sym
argty = convertType (Info.getNodeType fundef)
mkLambda = do
body <- withSymbol sym (goIdents node idents)
@ -268,9 +268,9 @@ fromCore tab = case tab ^. Core.infoMain of
error "constructor tag out of range"
return $ (constructors !! tagNum) args
where
ci = Core.lookupConstructorInfo tab _constrTag
ci = Core.lookupTabConstructorInfo tab _constrTag
sym = ci ^. Core.constructorInductive
ctrs = Core.lookupInductiveInfo tab sym ^. Core.inductiveConstructors
ctrs = Core.lookupTabInductiveInfo tab sym ^. Core.inductiveConstructors
tagNum =
fromJust
$ elemIndex
@ -391,7 +391,7 @@ fromCore tab = case tab ^. Core.infoMain of
go indty val branches
where
indty = convertInductive _caseInductive
ii = Core.lookupInductiveInfo tab _caseInductive
ii = Core.lookupTabInductiveInfo tab _caseInductive
missingCtrs =
filter
( \x ->
@ -401,7 +401,7 @@ fromCore tab = case tab ^. Core.infoMain of
_caseBranches
)
)
(map (Core.lookupConstructorInfo tab) (ii ^. Core.inductiveConstructors))
(map (Core.lookupTabConstructorInfo tab) (ii ^. Core.inductiveConstructors))
missingCtrsNum = length missingCtrs
ctrBrs = map mkCtrBranch missingCtrs
defaultNode = fromMaybe (error "not all cases covered") _caseDefault
@ -550,9 +550,9 @@ fromCore tab = case tab ^. Core.infoMain of
convertInductive :: Symbol -> Object
convertInductive sym = do
let ctrs =
map (Core.lookupConstructorInfo tab) $
map (Core.lookupTabConstructorInfo tab) $
sort $
Core.lookupInductiveInfo tab sym ^. Core.inductiveConstructors
Core.lookupTabInductiveInfo tab sym ^. Core.inductiveConstructors
case reverse ctrs of
ci : ctrs' -> do
foldr

54
src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs
View File

@ -13,11 +13,8 @@ import Juvix.Compiler.Backend.Html.Data
import Juvix.Compiler.Backend.Html.Extra
import Juvix.Compiler.Backend.Html.Translation.FromTyped.Source hiding (go)
import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
import Juvix.Compiler.Concrete.Extra
import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Concrete.Print
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoped
import Juvix.Compiler.Internal.Translation.FromConcrete qualified as Internal
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking qualified as InternalTyped
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context
import Juvix.Compiler.Pipeline.EntryPoint
@ -30,12 +27,19 @@ import Text.Blaze.Html.Renderer.Utf8 qualified as Html
import Text.Blaze.Html5 as Html hiding (map)
import Text.Blaze.Html5.Attributes qualified as Attr
data JudocCtx = JudocCtx
{ _judocCtxComments :: Comments,
_judocCtxTopModules :: [Module 'Scoped 'ModuleTop],
_judocCtxNormalizedTable :: InternalTyped.NormalizedTable
}
data JudocArgs = JudocArgs
{ _judocArgsOutputDir :: Path Abs Dir,
_judocArgsBaseName :: Text,
_judocArgsCtx :: JudocCtx,
_judocArgsMainModule :: Module 'Scoped 'ModuleTop,
_judocArgsAssetsPrefix :: Text,
_judocArgsUrlPrefix :: Text,
_judocArgsCtx :: InternalTypedResult,
_judocArgsTheme :: Theme,
_judocArgsNonRecursive :: Bool,
_judocArgsNoFooter :: Bool,
@ -43,8 +47,25 @@ data JudocArgs = JudocArgs
_judocArgsNoPath :: Bool
}
makeLenses ''JudocCtx
makeLenses ''JudocArgs
instance Semigroup JudocCtx where
ctx1 <> ctx2 =
JudocCtx
{ _judocCtxComments = ctx1 ^. judocCtxComments <> ctx2 ^. judocCtxComments,
_judocCtxTopModules = ctx1 ^. judocCtxTopModules <> ctx2 ^. judocCtxTopModules,
_judocCtxNormalizedTable = ctx1 ^. judocCtxNormalizedTable <> ctx2 ^. judocCtxNormalizedTable
}
instance Monoid JudocCtx where
mempty =
JudocCtx
{ _judocCtxComments = mempty,
_judocCtxTopModules = mempty,
_judocCtxNormalizedTable = mempty
}
data Tree k a = Tree
{ _treeLabel :: a,
_treeChildren :: HashMap k (Tree k a)
@ -155,32 +176,21 @@ writeHtml f h = Prelude.embed $ do
dir :: Path Abs Dir
dir = parent f
genJudocHtml :: (Members '[Embed IO] r) => JudocArgs -> Sem r ()
genJudocHtml JudocArgs {..} =
genJudocHtml :: (Members '[Embed IO] r) => EntryPoint -> JudocArgs -> Sem r ()
genJudocHtml entry JudocArgs {..} =
runReader htmlOpts . runReader normTable . runReader entry $ do
Prelude.embed (writeAssets _judocArgsOutputDir)
mapM_ (goTopModule cs) allModules
createIndexFile (map topModulePath (toList allModules))
where
cs :: Comments
cs =
_judocArgsCtx
^. resultInternalResult
. Internal.resultScoper
. Scoped.comments
entry :: EntryPoint
entry = _judocArgsCtx ^. InternalTyped.internalTypedResultEntryPoint
cs = _judocArgsCtx ^. judocCtxComments
normTable :: InternalTyped.NormalizedTable
normTable = _judocArgsCtx ^. InternalTyped.resultNormalized
normTable = _judocArgsCtx ^. judocCtxNormalizedTable
mainMod :: Module 'Scoped 'ModuleTop
mainMod =
_judocArgsCtx
^. InternalTyped.resultInternalResult
. Internal.resultScoper
. Scoped.mainModule
mainMod = _judocArgsMainModule
htmlOpts :: HtmlOptions
htmlOpts =
@ -201,8 +211,8 @@ genJudocHtml JudocArgs {..} =
| _judocArgsNonRecursive = pure mainMod
| otherwise = toList topModules
topModules :: HashMap NameId (Module 'Scoped 'ModuleTop)
topModules = getAllModules mainMod
topModules :: [Module 'Scoped 'ModuleTop]
topModules = _judocArgsCtx ^. judocCtxTopModules
moduleDocPath :: (Members '[Reader HtmlOptions] r) => Module 'Scoped 'ModuleTop -> Sem r (Path Abs File)
moduleDocPath m = do

11
src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs
View File

@ -1,5 +1,6 @@
module Juvix.Compiler.Backend.Html.Translation.FromTyped.Source where
import Data.HashMap.Strict qualified as HashMap
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import Data.Text.Lazy (toStrict)
@ -8,11 +9,10 @@ import Data.Time.Format
import Juvix.Compiler.Backend.Html.Data.Options
import Juvix.Compiler.Backend.Html.Extra
import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
import Juvix.Compiler.Concrete.Extra
import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Concrete.Print
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver
import Juvix.Compiler.Internal.Pretty qualified as Internal
import Juvix.Compiler.Pipeline.Loader.PathResolver
import Juvix.Extra.Assets (writeAssets)
import Juvix.Prelude
import Prettyprinter
@ -108,8 +108,9 @@ genSourceHtml o@GenSourceHtmlArgs {..} = do
| _genSourceHtmlArgsNonRecursive = pure entry
| otherwise = toList topModules
-- TODO: top modules
topModules :: HashMap NameId (Module 'Scoped 'ModuleTop)
topModules = getAllModules entry
topModules = HashMap.fromList [(entry ^. modulePath . S.nameId, entry)]
outputModule :: Module 'Scoped 'ModuleTop -> IO ()
outputModule m = do
@ -345,9 +346,9 @@ putTag ann x = case ann of
! juColor (juKindColor k)
nameIdAttr :: (Members '[Reader HtmlOptions] r) => S.NameId -> Sem r AttributeValue
nameIdAttr (S.NameId k) = do
nameIdAttr nid = do
pfx <- unpack <$> asks (^. htmlOptionsIdPrefix)
return $ fromString $ pfx <> show k
return $ fromString $ pfx <> show (pretty nid)
moduleDocRelativePath :: (Members '[Reader HtmlOptions] r) => TopModulePath -> Sem r (Path Rel File)
moduleDocRelativePath m = do

4
src/Juvix/Compiler/Backend/Markdown/Translation/FromTyped/Source.hs
View File

@ -153,9 +153,7 @@ go = do
else
MkTextBlock
TextBlock
{ _textBlock =
Text.replace "\n" "<br/>" $
resHtml,
{ _textBlock = Text.replace "\n" "<br/>" resHtml,
_textBlockInterval = j ^. juvixCodeBlockInterval
}
let newState =

7
src/Juvix/Compiler/Backend/VampIR/Translation/FromCore.hs
View File

@ -3,6 +3,7 @@ module Juvix.Compiler.Backend.VampIR.Translation.FromCore where
import Data.Text qualified as T
import Juvix.Compiler.Backend.VampIR.Extra (getVampIRInputs)
import Juvix.Compiler.Backend.VampIR.Language as VampIR
import Juvix.Compiler.Core.Data (emptyModule)
import Juvix.Compiler.Core.Data.InfoTable
import Juvix.Compiler.Core.Extra
import Juvix.Compiler.Core.Info.NameInfo (getInfoName)
@ -13,12 +14,12 @@ fromCore :: InfoTable -> Program
fromCore tab = fromCoreNode ii node
where
sym = fromJust (tab ^. infoMain)
node = lookupIdentifierNode tab sym
ii = lookupIdentifierInfo tab sym
node = lookupTabIdentifierNode tab sym
ii = lookupTabIdentifierInfo tab sym
fromCoreNode :: IdentifierInfo -> Node -> Program
fromCoreNode ii node =
let (lams, body) = unfoldLambdas (disambiguateNodeNames' disambiguate emptyInfoTable node)
let (lams, body) = unfoldLambdas (disambiguateNodeNames' disambiguate emptyModule node)
(defs, expr) = convertLets body
n = length lams
args = getVampIRInputs n (ii ^. identifierArgNames)

16
src/Juvix/Compiler/Builtins/Effect.hs
View File

@ -21,15 +21,14 @@ registerBuiltin = registerBuiltin' . toBuiltinPrim
getBuiltinName :: (IsBuiltin a, Member Builtins r) => Interval -> a -> Sem r Name
getBuiltinName i = getBuiltinName' i . toBuiltinPrim
data BuiltinsState = BuiltinsState
{ _builtinsTable :: HashMap BuiltinPrim Name,
_builtinsNameTable :: HashMap Name BuiltinPrim
newtype BuiltinsState = BuiltinsState
{ _builtinsTable :: HashMap BuiltinPrim Name
}
makeLenses ''BuiltinsState
iniBuiltins :: BuiltinsState
iniBuiltins = BuiltinsState mempty mempty
iniBuiltins = BuiltinsState mempty
re :: forall r a. (Member (Error JuvixError) r) => Sem (Builtins ': r) a -> Sem (State BuiltinsState ': r) a
re = reinterpret $ \case
@ -43,13 +42,11 @@ re = reinterpret $ \case
{ _notDefinedBuiltin = b,
_notDefinedLoc = i
}
-- GetBuiltin n -> gets (^. builtinsNameTable . at n)
RegisterBuiltin' b n -> do
s <- gets (^. builtinsTable . at b)
case s of
Nothing -> do
modify (over builtinsTable (set (at b) (Just n)))
modify (over builtinsNameTable (set (at n) (Just b)))
Just {} -> alreadyDefined
where
alreadyDefined :: Sem (State BuiltinsState ': r) x
@ -61,11 +58,8 @@ re = reinterpret $ \case
_alreadyDefinedLoc = getLoc n
}
evalTopBuiltins :: (Member (Error JuvixError) r) => Sem (Builtins ': r) a -> Sem r a
evalTopBuiltins = fmap snd . runTopBuiltins
runTopBuiltins :: (Member (Error JuvixError) r) => Sem (Builtins ': r) a -> Sem r (BuiltinsState, a)
runTopBuiltins = runBuiltins iniBuiltins
evalBuiltins :: (Member (Error JuvixError) r) => BuiltinsState -> Sem (Builtins ': r) a -> Sem r a
evalBuiltins s = fmap snd . runBuiltins s
runBuiltins :: (Member (Error JuvixError) r) => BuiltinsState -> Sem (Builtins ': r) a -> Sem r (BuiltinsState, a)
runBuiltins s = runState s . re

2
src/Juvix/Compiler/Concrete.hs
View File

@ -2,7 +2,6 @@ module Juvix.Compiler.Concrete
( module Juvix.Compiler.Concrete.Language,
module Juvix.Compiler.Concrete.Data,
module Juvix.Compiler.Concrete.Pretty,
module Juvix.Compiler.Concrete.Translation,
module FromParsed,
)
where
@ -10,5 +9,4 @@ where
import Juvix.Compiler.Concrete.Data
import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Concrete.Pretty
import Juvix.Compiler.Concrete.Translation
import Juvix.Compiler.Concrete.Translation.FromParsed as FromParsed

4
src/Juvix/Compiler/Concrete/Data.hs
View File

@ -5,7 +5,7 @@ module Juvix.Compiler.Concrete.Data
module Juvix.Compiler.Concrete.Data.Highlight,
module Juvix.Compiler.Concrete.Data.Name,
module Juvix.Compiler.Concrete.Data.ScopedName,
module Juvix.Compiler.Concrete.Data.InfoTable,
module Juvix.Compiler.Store.Scoped.Data.InfoTable,
module Juvix.Compiler.Concrete.Data.InfoTableBuilder,
module Juvix.Data.NameKind,
module Juvix.Compiler.Concrete.Data.ParsedItem,
@ -18,7 +18,6 @@ where
import Juvix.Compiler.Concrete.Data.Builtins
import Juvix.Compiler.Concrete.Data.Highlight
import Juvix.Compiler.Concrete.Data.InfoTable
import Juvix.Compiler.Concrete.Data.InfoTableBuilder
import Juvix.Compiler.Concrete.Data.Literal
import Juvix.Compiler.Concrete.Data.ModuleIsTop
@ -28,5 +27,6 @@ import Juvix.Compiler.Concrete.Data.ParsedItem
import Juvix.Compiler.Concrete.Data.PublicAnn
import Juvix.Compiler.Concrete.Data.ScopedName qualified
import Juvix.Compiler.Concrete.Data.VisibilityAnn
import Juvix.Compiler.Store.Scoped.Data.InfoTable
import Juvix.Data.NameId
import Juvix.Data.NameKind

13
src/Juvix/Compiler/Concrete/Data/Builtins.hs
View File

@ -1,5 +1,6 @@
module Juvix.Compiler.Concrete.Data.Builtins where
import Data.Serialize
import Juvix.Extra.Strings qualified as Str
import Juvix.Prelude
import Juvix.Prelude.Pretty
@ -28,6 +29,8 @@ data BuiltinPrim
instance Hashable BuiltinPrim
instance Serialize BuiltinPrim
instance Pretty BuiltinPrim where
pretty = \case
BuiltinsInductive i -> pretty i
@ -51,6 +54,8 @@ data BuiltinInductive
instance Hashable BuiltinInductive
instance Serialize BuiltinInductive
instance Pretty BuiltinInductive where
pretty = \case
BuiltinNat -> Str.nat
@ -82,6 +87,8 @@ data BuiltinConstructor
instance Hashable BuiltinConstructor
instance Serialize BuiltinConstructor
data BuiltinFunction
= BuiltinNatPlus
| BuiltinNatSub
@ -114,6 +121,8 @@ data BuiltinFunction
instance Hashable BuiltinFunction
instance Serialize BuiltinFunction
instance Pretty BuiltinFunction where
pretty = \case
BuiltinNatPlus -> Str.natPlus
@ -164,6 +173,8 @@ data BuiltinAxiom
instance Hashable BuiltinAxiom
instance Serialize BuiltinAxiom
instance Pretty BuiltinAxiom where
pretty = \case
BuiltinNatPrint -> Str.natPrint
@ -189,6 +200,8 @@ data BuiltinType
instance Hashable BuiltinType
instance Serialize BuiltinType
instance Pretty BuiltinType where
pretty = \case
BuiltinTypeInductive ty -> pretty ty

4
src/Juvix/Compiler/Concrete/Data/Highlight.hs
View File

@ -12,10 +12,10 @@ import Juvix.Compiler.Concrete.Data.Highlight.Input
import Juvix.Compiler.Concrete.Data.Highlight.PrettyJudoc
import Juvix.Compiler.Concrete.Data.Highlight.Properties
import Juvix.Compiler.Concrete.Data.Highlight.RenderEmacs
import Juvix.Compiler.Concrete.Data.InfoTable qualified as Scoped
import Juvix.Compiler.Concrete.Data.ScopedName
import Juvix.Compiler.Internal.Language qualified as Internal
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context qualified as Internal
import Juvix.Compiler.Store.Scoped.Data.InfoTable qualified as Scoped
import Juvix.Data.CodeAnn
import Juvix.Data.Emacs
import Juvix.Prelude as Prelude hiding (show)
@ -75,7 +75,7 @@ goGotoProperty n = WithLoc (getLoc n) PropertyGoto {..}
goDocProperty :: Scoped.DocTable -> Internal.TypesTable -> AName -> Maybe (WithLoc PropertyDoc)
goDocProperty doctbl tbl a = do
let ty :: Maybe Internal.Expression = tbl ^. at (a ^. anameDocId)
let ty :: Maybe Internal.Expression = tbl ^. Internal.typesTable . at (a ^. anameDocId)
d <- ppDocDefault a ty (doctbl ^. at (a ^. anameDocId))
let (_docText, _docSExp) = renderEmacs (layoutPretty defaultLayoutOptions d)
return (WithLoc (getLoc a) PropertyDoc {..})

2
src/Juvix/Compiler/Concrete/Data/Highlight/Input.hs
View File

@ -4,10 +4,10 @@ module Juvix.Compiler.Concrete.Data.Highlight.Input
)
where
import Juvix.Compiler.Concrete.Data.InfoTable qualified as Scoped
import Juvix.Compiler.Concrete.Data.ParsedItem
import Juvix.Compiler.Concrete.Data.ScopedName
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context qualified as Internal
import Juvix.Compiler.Store.Scoped.Data.InfoTable qualified as Scoped
import Juvix.Prelude
data HighlightInput = HighlightInput

65
src/Juvix/Compiler/Concrete/Data/InfoTable.hs
View File

@ -1,65 +0,0 @@
module Juvix.Compiler.Concrete.Data.InfoTable where
import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
import Juvix.Compiler.Concrete.Language
import Juvix.Prelude
newtype FunctionInfo = FunctionInfo (FunctionDef 'Scoped)
deriving stock (Eq, Show)
data ConstructorInfo = ConstructorInfo
{ _constructorInfoDef :: ConstructorDef 'Scoped,
_constructorInfoTypeName :: S.Symbol
}
deriving stock (Eq, Show)
newtype AxiomInfo = AxiomInfo
{ _axiomInfoDef :: AxiomDef 'Scoped
}
deriving stock (Eq, Show)
newtype InductiveInfo = InductiveInfo
{ _inductiveInfoDef :: InductiveDef 'Scoped
}
deriving stock (Eq, Show)
type DocTable = HashMap NameId (Judoc 'Scoped)
data InfoTable = InfoTable
{ _infoConstructors :: HashMap S.NameId ConstructorInfo,
_infoModules :: HashMap S.TopModulePath (Module 'Scoped 'ModuleTop),
_infoAxioms :: HashMap S.NameId AxiomInfo,
_infoInductives :: HashMap S.NameId InductiveInfo,
_infoFunctions :: HashMap S.NameId FunctionInfo,
_infoFixities :: HashMap S.NameId FixityDef,
_infoPriorities :: IntSet,
_infoPrecedenceGraph :: HashMap S.NameId (HashSet S.NameId)
}
emptyInfoTable :: InfoTable
emptyInfoTable =
InfoTable
{ _infoConstructors = mempty,
_infoAxioms = mempty,
_infoModules = mempty,
_infoInductives = mempty,
_infoFunctions = mempty,
_infoFixities = mempty,
_infoPriorities = mempty,
_infoPrecedenceGraph = mempty
}
makeLenses ''InfoTable
makeLenses ''InductiveInfo
makeLenses ''ConstructorInfo
makeLenses ''AxiomInfo
functionInfoDoc :: Lens' FunctionInfo (Maybe (Judoc 'Scoped))
functionInfoDoc f = \case
FunctionInfo i -> do
i' <- traverseOf signDoc f i
pure (FunctionInfo i')
instance HasLoc FunctionInfo where
getLoc = \case
FunctionInfo f -> getLoc f

89
src/Juvix/Compiler/Concrete/Data/InfoTableBuilder.hs
View File

@ -2,7 +2,6 @@ module Juvix.Compiler.Concrete.Data.InfoTableBuilder where
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet
import Data.IntSet qualified as IntSet
import Juvix.Compiler.Concrete.Data.Highlight.Input
import Juvix.Compiler.Concrete.Data.Scope
import Juvix.Compiler.Concrete.Data.ScopedName
@ -12,62 +11,62 @@ import Juvix.Prelude
data InfoTableBuilder m a where
RegisterAxiom :: AxiomDef 'Scoped -> InfoTableBuilder m ()
RegisterConstructor :: S.Symbol -> ConstructorDef 'Scoped -> InfoTableBuilder m ()
RegisterConstructor :: ConstructorDef 'Scoped -> InfoTableBuilder m ()
RegisterInductive :: InductiveDef 'Scoped -> InfoTableBuilder m ()
RegisterFunctionDef :: FunctionDef 'Scoped -> InfoTableBuilder m ()
RegisterName :: (HasLoc c) => S.Name' c -> InfoTableBuilder m ()
RegisterScopedIden :: ScopedIden -> InfoTableBuilder m ()
RegisterModule :: Module 'Scoped 'ModuleTop -> InfoTableBuilder m ()
RegisterModuleDoc :: S.NameId -> Maybe (Judoc 'Scoped) -> InfoTableBuilder m ()
RegisterFixity :: FixityDef -> InfoTableBuilder m ()
RegisterPrecedence :: S.NameId -> S.NameId -> InfoTableBuilder m ()
RegisterHighlightDoc :: S.NameId -> Maybe (Judoc 'Scoped) -> InfoTableBuilder m ()
RegisterNameSig :: S.NameId -> NameSignature 'Scoped -> InfoTableBuilder m ()
RegisterConstructorSig :: S.NameId -> RecordNameSignature 'Scoped -> InfoTableBuilder m ()
RegisterParsedNameSig :: S.NameId -> NameSignature 'Parsed -> InfoTableBuilder m ()
RegisterParsedConstructorSig :: S.NameId -> RecordNameSignature 'Parsed -> InfoTableBuilder m ()
RegisterRecordInfo :: S.NameId -> RecordInfo -> InfoTableBuilder m ()
GetInfoTable :: InfoTableBuilder m InfoTable
makeSem ''InfoTableBuilder
registerDoc :: (Members '[HighlightBuilder] r) => NameId -> Maybe (Judoc 'Scoped) -> Sem r ()
registerDoc k md = modify (set (highlightDoc . at k) md)
registerDoc :: forall r. (Members '[HighlightBuilder, State InfoTable] r) => NameId -> Maybe (Judoc 'Scoped) -> Sem r ()
registerDoc k md = do
modify (set (highlightDoc . at k) md)
modify (set (infoHighlightDoc . at k) md)
toState :: (Members '[HighlightBuilder] r) => Sem (InfoTableBuilder ': r) a -> Sem (State InfoTable ': r) a
toState :: (Member HighlightBuilder r) => Sem (InfoTableBuilder ': r) a -> Sem (State InfoTable ': r) a
toState = reinterpret $ \case
RegisterAxiom d ->
let ref = d ^. axiomName . S.nameId
info = AxiomInfo d
j = d ^. axiomDoc
let j = d ^. axiomDoc
in do
modify (over infoAxioms (HashMap.insert ref info))
modify' (over infoAxioms (HashMap.insert (d ^. axiomName . nameId) d))
registerDoc (d ^. axiomName . nameId) j
RegisterConstructor ind c ->
let ref = c ^. constructorName . S.nameId
info = ConstructorInfo c ind
j = c ^. constructorDoc
RegisterConstructor c ->
let j = c ^. constructorDoc
in do
modify (over infoConstructors (HashMap.insert ref info))
modify' (over infoConstructors (HashMap.insert (c ^. constructorName . nameId) c))
registerDoc (c ^. constructorName . nameId) j
RegisterInductive ity ->
let ref = ity ^. inductiveName . S.nameId
info = InductiveInfo {_inductiveInfoDef = ity}
j = ity ^. inductiveDoc
let j = ity ^. inductiveDoc
in do
modify (over infoInductives (HashMap.insert ref info))
modify' (over infoInductives (HashMap.insert (ity ^. inductiveName . nameId) ity))
registerDoc (ity ^. inductiveName . nameId) j
RegisterFunctionDef f ->
let ref = f ^. signName . S.nameId
info = FunctionInfo f
j = f ^. signDoc
let j = f ^. signDoc
in do
modify (set (infoFunctions . at ref) (Just info))
modify' (over infoFunctions (HashMap.insert (f ^. signName . nameId) f))
registerDoc (f ^. signName . nameId) j
RegisterName n -> modify (over highlightNames (cons (S.anameFromName n)))
RegisterScopedIden n -> modify (over highlightNames (cons (anameFromScopedIden n)))
RegisterModule m -> do
let j = m ^. moduleDoc
modify (over infoModules (HashMap.insert (m ^. modulePath) m))
registerDoc (m ^. modulePath . nameId) j
RegisterName n -> do
modify (over highlightNames (cons (S.anameFromName n)))
modify (over infoHighlightNames (cons (S.anameFromName n)))
RegisterScopedIden n -> do
modify (over highlightNames (cons (anameFromScopedIden n)))
modify (over infoHighlightNames (cons (anameFromScopedIden n)))
RegisterModuleDoc uid doc -> do
registerDoc uid doc
RegisterFixity f -> do
let sid = f ^. fixityDefSymbol . S.nameId
modify (over infoFixities (HashMap.insert sid f))
modify (over infoPriorities (IntSet.insert (f ^. fixityDefPrec)))
case f ^. fixityDefFixity . fixityId of
Just fid -> modify (over infoPrecedenceGraph (HashMap.alter (Just . fromMaybe mempty) fid))
Nothing -> return ()
@ -75,17 +74,27 @@ toState = reinterpret $ \case
modify (over infoPrecedenceGraph (HashMap.alter (Just . HashSet.insert h . fromMaybe mempty) l))
RegisterHighlightDoc fid doc ->
registerDoc fid doc
RegisterNameSig uid sig ->
modify (over infoNameSigs (HashMap.insert uid sig))
RegisterConstructorSig uid sig ->
modify (over infoConstructorSigs (HashMap.insert uid sig))
RegisterParsedNameSig uid sig ->
modify (over infoParsedNameSigs (HashMap.insert uid sig))
RegisterParsedConstructorSig uid sig ->
modify (over infoParsedConstructorSigs (HashMap.insert uid sig))
RegisterRecordInfo uid recInfo ->
modify (over infoRecords (HashMap.insert uid recInfo))
GetInfoTable ->
get
runInfoTableBuilderRepl :: InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r (InfoTable, a)
runInfoTableBuilderRepl tab = ignoreHighlightBuilder . runInfoTableBuilder tab . raiseUnder
runInfoTableBuilder :: (Members '[HighlightBuilder] r) => InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r (InfoTable, a)
runInfoTableBuilder :: (Member HighlightBuilder r) => InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r (InfoTable, a)
runInfoTableBuilder tab = runState tab . toState
ignoreInfoTableBuilder :: (Members '[HighlightBuilder] r) => Sem (InfoTableBuilder ': r) a -> Sem r a
ignoreInfoTableBuilder = evalState emptyInfoTable . toState
ignoreInfoTableBuilder :: (Member HighlightBuilder r) => Sem (InfoTableBuilder ': r) a -> Sem r a
ignoreInfoTableBuilder = evalState mempty . toState
anameFromScopedIden :: ScopedIden -> AName
anameFromScopedIden s =
@ -96,3 +105,17 @@ anameFromScopedIden s =
_anameDefinedLoc = s ^. scopedIdenName . nameDefined,
_anameVerbatim = s ^. scopedIdenName . nameVerbatim
}
lookupInfo :: (Members '[InfoTableBuilder, Reader InfoTable] r) => (InfoTable -> Maybe a) -> Sem r a
lookupInfo f = do
tab1 <- ask
fromMaybe (fromJust (f tab1)) . f <$> getInfoTable
lookupFixity :: (Members '[InfoTableBuilder, Reader InfoTable] r) => S.NameId -> Sem r FixityDef
lookupFixity uid = lookupInfo (HashMap.lookup uid . (^. infoFixities))
getPrecedenceGraph :: (Members '[InfoTableBuilder, Reader InfoTable] r) => Sem r PrecedenceGraph
getPrecedenceGraph = do
tab <- ask
tab' <- getInfoTable
return $ combinePrecedenceGraphs (tab ^. infoPrecedenceGraph) (tab' ^. infoPrecedenceGraph)

3
src/Juvix/Compiler/Concrete/Data/Literal.hs
View File

@ -1,6 +1,7 @@
module Juvix.Compiler.Concrete.Data.Literal where
import Juvix.Data.Fixity
import Juvix.Extra.Serialize
import Juvix.Prelude
import Prettyprinter
@ -13,6 +14,8 @@ data Literal
instance Hashable Literal
instance Serialize Literal
instance HasAtomicity Literal where
atomicity = \case
LitInteger {} -> Atom

13
src/Juvix/Compiler/Concrete/Data/Name.hs
View File

@ -1,6 +1,7 @@
module Juvix.Compiler.Concrete.Data.Name where
import Data.List.NonEmpty.Extra qualified as NonEmpty
import Juvix.Extra.Serialize
import Juvix.Prelude
import Juvix.Prelude.Pretty as Pretty
@ -15,7 +16,9 @@ symbolLoc = withLocInt
data Name
= NameQualified QualifiedName
| NameUnqualified Symbol
deriving stock (Show, Eq, Ord)
deriving stock (Show, Eq, Ord, Generic)
instance Serialize Name
instance HasLoc Name where
getLoc = \case
@ -41,7 +44,9 @@ instance Pretty Name where
newtype SymbolPath = SymbolPath
{ _pathParts :: NonEmpty Symbol
}
deriving stock (Show, Eq, Ord)
deriving stock (Show, Eq, Ord, Generic)
instance Serialize SymbolPath
data QualifiedName = QualifiedName
{ _qualifiedPath :: SymbolPath,
@ -49,6 +54,8 @@ data QualifiedName = QualifiedName
}
deriving stock (Show, Eq, Ord, Generic)
instance Serialize QualifiedName
instance HasLoc QualifiedName where
getLoc QualifiedName {..} =
getLoc _qualifiedPath <> getLoc _qualifiedSymbol
@ -70,6 +77,8 @@ data TopModulePath = TopModulePath
}
deriving stock (Show, Eq, Ord, Generic)
instance Serialize TopModulePath
makeLenses ''TopModulePath
instance Pretty TopModulePath where

17
src/Juvix/Compiler/Concrete/Data/NameSpace.hs
View File

@ -1,6 +1,8 @@
module Juvix.Compiler.Concrete.Data.NameSpace where
import Data.Kind qualified as GHC
import Juvix.Compiler.Concrete.Data.Name qualified as C
import Juvix.Compiler.Store.Scoped.Language
import Juvix.Data.NameKind
import Juvix.Prelude
@ -12,9 +14,6 @@ data NameSpace
instance Hashable NameSpace
type AnyNameSpace (k :: NameSpace -> GHC.Type) =
Σ NameSpace (TyCon1 k)
$(genSingletons [''NameSpace])
type NameKindNameSpace :: NameKind -> NameSpace
@ -28,3 +27,15 @@ type family NameKindNameSpace s = res where
NameKindNameSpace 'KNameLocalModule = 'NameSpaceModules
NameKindNameSpace 'KNameTopModule = 'NameSpaceModules
NameKindNameSpace 'KNameFixity = 'NameSpaceFixities
type NameSpaceEntryType :: NameSpace -> GHC.Type
type family NameSpaceEntryType s = res | res -> s where
NameSpaceEntryType 'NameSpaceSymbols = PreSymbolEntry
NameSpaceEntryType 'NameSpaceModules = ModuleSymbolEntry
NameSpaceEntryType 'NameSpaceFixities = FixitySymbolEntry
exportNameSpace :: forall ns. (SingI ns) => Lens' ExportInfo (HashMap C.Symbol (NameSpaceEntryType ns))
exportNameSpace = case sing :: SNameSpace ns of
SNameSpaceSymbols -> exportSymbols
SNameSpaceModules -> exportModuleSymbols
SNameSpaceFixities -> exportFixitySymbols

12
src/Juvix/Compiler/Concrete/Data/ParsedInfoTable.hs
View File

@ -1,12 +0,0 @@
module Juvix.Compiler.Concrete.Data.ParsedInfoTable where
import Juvix.Compiler.Concrete.Language
import Juvix.Prelude
data InfoTable = InfoTable
{ _infoParsedComments :: Comments,
_infoParsedModules :: HashMap TopModulePath (Module 'Parsed 'ModuleTop)
}
deriving stock (Eq, Show)
makeLenses ''InfoTable

113
src/Juvix/Compiler/Concrete/Data/ParsedInfoTableBuilder.hs
View File

@ -1,113 +0,0 @@
module Juvix.Compiler.Concrete.Data.ParsedInfoTableBuilder
( module Juvix.Compiler.Concrete.Data.ParsedInfoTableBuilder,
BuilderState,
)
where
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet
import Juvix.Compiler.Concrete.Data.Highlight.Input
import Juvix.Compiler.Concrete.Data.Literal
import Juvix.Compiler.Concrete.Data.ParsedInfoTable
import Juvix.Compiler.Concrete.Data.ParsedInfoTableBuilder.BuilderState
import Juvix.Compiler.Concrete.Language
import Juvix.Prelude
data InfoTableBuilder m a where
RegisterItem :: ParsedItem -> InfoTableBuilder m ()
RegisterSpaceSpan :: SpaceSpan -> InfoTableBuilder m ()
RegisterModule :: Module 'Parsed 'ModuleTop -> InfoTableBuilder m ()
VisitModule :: TopModulePath -> InfoTableBuilder m ()
ModuleVisited :: TopModulePath -> InfoTableBuilder m Bool
makeSem ''InfoTableBuilder
registerKeyword :: (Member InfoTableBuilder 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 InfoTableBuilder r) => Interval -> Sem r ()
registerDelimiter i =
registerItem
ParsedItem
{ _parsedLoc = i,
_parsedTag = ParsedTagDelimiter
}
registerJudocText :: (Member InfoTableBuilder r) => Interval -> Sem r ()
registerJudocText i =
registerItem
ParsedItem
{ _parsedLoc = i,
_parsedTag = ParsedTagJudoc
}
registerPragmas :: (Member InfoTableBuilder r) => Interval -> Sem r ()
registerPragmas i =
registerItem
ParsedItem
{ _parsedLoc = i,
_parsedTag = ParsedTagPragma
}
registerLiteral :: (Member InfoTableBuilder 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
build :: BuilderState -> InfoTable
build st =
InfoTable
{ _infoParsedComments = mkComments (st ^. stateComments),
_infoParsedModules = st ^. stateModules
}
registerItem' :: (Members '[HighlightBuilder] r) => ParsedItem -> Sem r ()
registerItem' i = modify' (over highlightParsed (i :))
runParserInfoTableBuilderRepl :: BuilderState -> Sem (InfoTableBuilder ': r) a -> Sem r (BuilderState, a)
runParserInfoTableBuilderRepl st = ignoreHighlightBuilder . runParserInfoTableBuilder' st . raiseUnder
runParserInfoTableBuilder' :: (Members '[HighlightBuilder] r) => BuilderState -> Sem (InfoTableBuilder ': r) a -> Sem r (BuilderState, a)
runParserInfoTableBuilder' s =
runState s
. reinterpret
( \case
ModuleVisited i -> HashSet.member i <$> gets (^. stateVisited)
VisitModule i -> modify' (over stateVisited (HashSet.insert i))
RegisterModule m ->
modify' (over stateModules (HashMap.insert (m ^. modulePath) m))
RegisterItem i -> registerItem' i
RegisterSpaceSpan g -> do
modify' (over stateComments (g :))
forM_ (g ^.. spaceSpan . each . _SpaceComment) $ \c ->
registerItem'
ParsedItem
{ _parsedLoc = getLoc c,
_parsedTag = ParsedTagComment
}
)
runParserInfoTableBuilder :: (Members '[HighlightBuilder] r) => Sem (InfoTableBuilder ': r) a -> Sem r (BuilderState, InfoTable, a)
runParserInfoTableBuilder m = do
(builderState, x) <- runParserInfoTableBuilder' iniState m
return (builderState, build builderState, x)

21
src/Juvix/Compiler/Concrete/Data/ParsedInfoTableBuilder/BuilderState.hs
View File

@ -1,21 +0,0 @@
module Juvix.Compiler.Concrete.Data.ParsedInfoTableBuilder.BuilderState where
import Juvix.Compiler.Concrete.Language
import Juvix.Prelude
data BuilderState = BuilderState
{ _stateComments :: [SpaceSpan],
_stateVisited :: HashSet TopModulePath,
_stateModules :: HashMap TopModulePath (Module 'Parsed 'ModuleTop)
}
deriving stock (Show)
makeLenses ''BuilderState
iniState :: BuilderState
iniState =
BuilderState
{ _stateComments = [],
_stateVisited = mempty,
_stateModules = mempty
}

5
src/Juvix/Compiler/Concrete/Data/PublicAnn.hs
View File

@ -1,5 +1,6 @@
module Juvix.Compiler.Concrete.Data.PublicAnn where
import Juvix.Extra.Serialize
import Juvix.Prelude
data PublicAnn
@ -7,4 +8,6 @@ data PublicAnn
Public
| -- | No annotation. Do not confuse this with 'not public' or 'private'.
NoPublic
deriving stock (Show, Eq, Ord)
deriving stock (Show, Eq, Ord, Generic)
instance Serialize PublicAnn

10
src/Juvix/Compiler/Concrete/Data/Scope.hs
View File

@ -1,27 +1,25 @@
module Juvix.Compiler.Concrete.Data.Scope
( module Juvix.Compiler.Concrete.Data.Scope,
module Juvix.Compiler.Concrete.Data.InfoTable,
module Juvix.Compiler.Store.Scoped.Data.InfoTable,
module Juvix.Compiler.Concrete.Data.NameSpace,
module Juvix.Compiler.Concrete.Data.Scope.Base,
)
where
import Juvix.Compiler.Concrete.Data.InfoTable
import Juvix.Compiler.Concrete.Data.NameSpace
import Juvix.Compiler.Concrete.Data.Scope.Base
import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Store.Scoped.Data.InfoTable
import Juvix.Compiler.Store.Scoped.Language
import Juvix.Prelude
nsEntry :: forall ns. (SingI ns) => Lens' (NameSpaceEntryType ns) (S.Name' ())
nsEntry :: forall ns. (SingI ns) => Lens' (NameSpaceEntryType ns) S.Name
nsEntry = case sing :: SNameSpace ns of
SNameSpaceModules -> moduleEntry
SNameSpaceSymbols -> preSymbolName
SNameSpaceFixities -> fixityEntry
mkModuleRef' :: (SingI t) => ModuleRef'' 'S.NotConcrete t -> ModuleRef' 'S.NotConcrete
mkModuleRef' m = ModuleRef' (sing :&: m)
scopeNameSpace :: forall (ns :: NameSpace). (SingI ns) => Lens' Scope (HashMap Symbol (SymbolInfo ns))
scopeNameSpace = case sing :: SNameSpace ns of
SNameSpaceSymbols -> scopeSymbols

24
src/Juvix/Compiler/Concrete/Data/Scope/Base.hs
View File

@ -3,6 +3,7 @@ module Juvix.Compiler.Concrete.Data.Scope.Base where
import Juvix.Compiler.Concrete.Data.NameSpace
import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Store.Scoped.Language
import Juvix.Prelude
newtype SymbolInfo (n :: NameSpace) = SymbolInfo
@ -22,13 +23,14 @@ data BindingStrategy
data Scope = Scope
{ _scopePath :: S.AbsModulePath,
_scopeSymbols :: HashMap Symbol (SymbolInfo 'NameSpaceSymbols),
-- | Local module symbols (excluding top modules associated with files)
_scopeModuleSymbols :: HashMap Symbol (SymbolInfo 'NameSpaceModules),
_scopeFixitySymbols :: HashMap Symbol (SymbolInfo 'NameSpaceFixities),
-- | The map from S.NameId to Modules is needed because we support merging
-- several imports under the same name. E.g.
-- import A as X;
-- import B as X;
_scopeTopModules :: HashMap TopModulePath (HashMap S.NameId (ModuleRef'' 'S.NotConcrete 'ModuleTop)),
_scopeTopModules :: HashMap TopModulePath (HashMap S.NameId ScopedModule),
-- | Symbols that have been defined in the current scope level. Every symbol
-- should map to itself. This is needed because we may query it with a
-- symbol with a different location but we may want the location of the
@ -39,25 +41,16 @@ data Scope = Scope
}
newtype ModulesCache = ModulesCache
{ _cachedModules :: HashMap TopModulePath (ModuleRef'' 'S.NotConcrete 'ModuleTop)
{ _cachedModules :: HashMap TopModulePath ScopedModule
}
data ScopeParameters = ScopeParameters
{ -- | Used for import cycle detection.
_scopeTopParents :: [Import 'Parsed],
_scopeParsedModules :: HashMap TopModulePath (Module 'Parsed 'ModuleTop)
}
data RecordInfo = RecordInfo
{ _recordInfoConstructor :: S.Symbol,
_recordInfoSignature :: RecordNameSignature 'Parsed
newtype ScopeParameters = ScopeParameters
{ _scopeImportedModules :: HashMap TopModulePath ScopedModule
}
data ScoperState = ScoperState
{ _scoperModulesCache :: ModulesCache,
-- | Local and top modules
_scoperModules :: HashMap S.ModuleNameId (ModuleRef' 'S.NotConcrete),
_scoperScope :: HashMap TopModulePath Scope,
{ -- | Local and top modules currently in scope - used to look up qualified symbols
_scoperModules :: HashMap S.NameId ScopedModule,
_scoperAlias :: HashMap S.NameId PreSymbolEntry,
_scoperSignatures :: HashMap S.NameId (NameSignature 'Parsed),
_scoperScopedSignatures :: HashMap S.NameId (NameSignature 'Scoped),
@ -108,4 +101,3 @@ makeLenses ''ScoperSyntax
makeLenses ''ScoperState
makeLenses ''ScopeParameters
makeLenses ''ModulesCache
makeLenses ''RecordInfo

23
src/Juvix/Compiler/Concrete/Data/ScopedName.hs
View File

@ -13,6 +13,7 @@ import Juvix.Data.Fixity qualified as C
import Juvix.Data.IteratorInfo
import Juvix.Data.NameId
import Juvix.Data.NameKind
import Juvix.Extra.Serialize
import Juvix.Prelude
import Juvix.Prelude.Pretty
@ -22,6 +23,8 @@ data AbsModulePath = AbsModulePath
}
deriving stock (Show, Eq, Generic)
instance Serialize AbsModulePath
makeLenses ''AbsModulePath
instance HasLoc AbsModulePath where
@ -54,7 +57,9 @@ data WhyInScope
BecauseImportedOpened
| -- | Defined in this module.
BecauseDefined
deriving stock (Eq, Show)
deriving stock (Eq, Show, Generic)
instance Serialize WhyInScope
type Name = Name' C.Name
@ -62,8 +67,6 @@ type Symbol = Name' C.Symbol
type TopModulePath = Name' C.TopModulePath
type ModuleNameId = NameId
data Name' n = Name'
{ _nameConcrete :: n,
_nameId :: NameId,
@ -77,7 +80,13 @@ data Name' n = Name'
-- | The textual representation of the name at the binding site
_nameVerbatim :: Text
}
deriving stock (Show)
deriving stock (Show, Generic)
instance Serialize Name
instance Serialize Symbol
instance Serialize TopModulePath
-- | For highlighting
data AName = AName
@ -87,6 +96,9 @@ data AName = AName
_anameDocId :: NameId,
_anameVerbatim :: Text
}
deriving stock (Generic)
instance Serialize AName
makeLenses ''Name'
makeLenses ''AName
@ -135,9 +147,6 @@ topModulePathSymbol = over nameConcrete (^. C.modulePathName)
topModulePathName :: TopModulePath -> Name
topModulePathName = over nameConcrete C.topModulePathToName
unConcrete :: Name' a -> Name' ()
unConcrete = set nameConcrete ()
symbolText :: Symbol -> Text
symbolText s = s ^. nameConcrete . C.symbolText

5
src/Juvix/Compiler/Concrete/Data/VisibilityAnn.hs
View File

@ -1,8 +1,11 @@
module Juvix.Compiler.Concrete.Data.VisibilityAnn where
import Juvix.Extra.Serialize
import Juvix.Prelude
data VisibilityAnn
= VisPublic
| VisPrivate
deriving stock (Show, Eq, Ord)
deriving stock (Show, Eq, Ord, Generic)
instance Serialize VisibilityAnn

48
src/Juvix/Compiler/Concrete/Extra.hs
View File

@ -1,7 +1,5 @@
module Juvix.Compiler.Concrete.Extra
( module Juvix.Prelude.Parsing,
mkScopedModule,
getAllModules,
getModuleFilePath,
unfoldApplication,
groupStatements,
@ -14,7 +12,6 @@ module Juvix.Compiler.Concrete.Extra
)
where
import Data.HashMap.Strict qualified as HashMap
import Data.IntMap.Strict qualified as IntMap
import Data.List.NonEmpty qualified as NonEmpty
import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
@ -22,42 +19,7 @@ import Juvix.Compiler.Concrete.Language
import Juvix.Prelude hiding (some)
import Juvix.Prelude.Parsing
data ScopedModule = forall t. MkScopedModule (SModuleIsTop t) (Module 'Scoped t)
mkScopedModule :: forall t. (SingI t) => Module 'Scoped t -> ScopedModule
mkScopedModule = MkScopedModule sing
getAllModules :: Module 'Scoped 'ModuleTop -> HashMap S.NameId (Module 'Scoped 'ModuleTop)
getAllModules m = HashMap.fromList (fst (run (runOutputList (getAllModules' m))))
getAllModules' ::
forall r.
(Member (Output (S.NameId, Module 'Scoped 'ModuleTop)) r) =>
Module 'Scoped 'ModuleTop ->
Sem r ()
getAllModules' m = recordModule m
where
recordModule :: Module 'Scoped 'ModuleTop -> Sem r ()
recordModule n = do
output (n ^. modulePath . S.nameId, n)
processModule (mkScopedModule n)
processModule :: ScopedModule -> Sem r ()
processModule (MkScopedModule _ w) = forM_ (w ^. moduleBody) processStatement
processStatement :: Statement 'Scoped -> Sem r ()
processStatement = \case
StatementImport i -> recordModule (i ^. importModule . moduleRefModule)
StatementModule n -> processModule (mkScopedModule n)
StatementOpenModule n -> forM_ (getModuleRefTopModule (n ^. openModuleName)) recordModule
_ -> return ()
getModuleRefTopModule :: ModuleRef' c -> Maybe (Module 'Scoped 'ModuleTop)
getModuleRefTopModule (ModuleRef' (isTop :&: ModuleRef'' {..})) = case isTop of
SModuleLocal -> Nothing
SModuleTop -> Just _moduleRefModule
getModuleFilePath :: Module s 'ModuleTop -> Path Abs File
getModuleFilePath :: Module s r -> Path Abs File
getModuleFilePath m = getLoc (m ^. moduleKw) ^. intervalFile
unfoldApplication :: Application -> (Expression, [Expression])
@ -92,13 +54,7 @@ groupStatements = \case
(StatementImport _, StatementImport _) -> True
(StatementImport i, StatementOpenModule o) -> case sing :: SStage s of
SParsed -> True
SScoped ->
i
^. importModule
. moduleRefModule
. modulePath
. S.nameId
== getModuleRefNameId (o ^. openModuleName)
SScoped -> i ^. importModulePath . S.nameId == o ^. openModuleName . S.nameId
(StatementImport _, _) -> False
(StatementOpenModule {}, StatementOpenModule {}) -> True
(StatementOpenModule {}, _) -> False

583
src/Juvix/Compiler/Concrete/Language.hs
View File

File diff suppressed because it is too large Load Diff

47
src/Juvix/Compiler/Concrete/Print/Base.hs
View File

@ -9,13 +9,13 @@ where
import Data.HashMap.Strict qualified as HashMap
import Data.List.NonEmpty.Extra qualified as NonEmpty
import Juvix.Compiler.Concrete.Data.InfoTable
import Juvix.Compiler.Concrete.Data.Scope.Base
import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
import Juvix.Compiler.Concrete.Extra qualified as Concrete
import Juvix.Compiler.Concrete.Keywords qualified as Kw
import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Concrete.Pretty.Options
import Juvix.Compiler.Store.Scoped.Language (Alias, ModuleSymbolEntry, PreSymbolEntry (..), ScopedModule, SymbolEntry, aliasName, moduleEntry, scopedModuleName, symbolEntry)
import Juvix.Data.Ape.Base
import Juvix.Data.Ape.Print
import Juvix.Data.CodeAnn (Ann, CodeAnn (..), ppStringLit)
@ -91,21 +91,16 @@ ppSymbolType = case sing :: SStage s of
SParsed -> ppCode
SScoped -> ppCode
ppModuleNameType :: forall s. (SingI s) => PrettyPrinting (ModuleNameType s)
ppModuleNameType = case sing :: SStage s of
SParsed -> ppCode
SScoped -> ppCode
ppIdentifierType :: forall s. (SingI s) => PrettyPrinting (IdentifierType s)
ppIdentifierType = case sing :: SStage s of
SParsed -> ppCode
SScoped -> ppCode
ppModuleRefType :: forall s. (SingI s) => PrettyPrinting (ModuleRefType s)
ppModuleRefType = case sing :: SStage s of
SParsed -> ppCode
SScoped -> ppCode
ppImportType :: forall s. (SingI s) => PrettyPrinting (ImportType s)
ppImportType = case sing :: SStage s of
SParsed -> ppCode
SScoped -> ppCode
ppHoleType :: forall s. (SingI s) => PrettyPrinting (HoleType s)
ppHoleType = case sing :: SStage s of
SParsed -> ppCode
@ -263,10 +258,6 @@ instance (SingI s) => PrettyPrint (Iterator s) where
instance PrettyPrint S.AName where
ppCode n = annotated (AnnKind (S.getNameKind n)) (noLoc (pretty (n ^. S.anameVerbatim)))
instance PrettyPrint FunctionInfo where
ppCode = \case
FunctionInfo f -> ppCode f
instance (SingI s) => PrettyPrint (List s) where
ppCode List {..} = do
let l = ppCode _listBracketL
@ -383,7 +374,7 @@ withNameIdSuffix nid a = do
when showNameId (noLoc "@" <> ppCode nid)
instance PrettyPrint S.NameId where
ppCode (S.NameId k) = noLoc (pretty k)
ppCode = noLoc . pretty
ppModuleHeader :: (SingI t, SingI s) => PrettyPrinting (Module s t)
ppModuleHeader Module {..} = do
@ -466,11 +457,8 @@ instance PrettyPrint QualifiedName where
let symbols = _qualifiedPath ^. pathParts NonEmpty.|> _qualifiedSymbol
dotted (ppSymbolType <$> symbols)
instance (SingI t) => PrettyPrint (ModuleRef'' 'S.NotConcrete t) where
ppCode = ppCode @(ModuleRef' 'S.NotConcrete) . project
instance PrettyPrint (ModuleRef'' 'S.Concrete t) where
ppCode m = ppCode (m ^. moduleRefName)
instance PrettyPrint ScopedModule where
ppCode m = ppCode (m ^. scopedModuleName)
instance PrettyPrint ScopedIden where
ppCode = ppCode . (^. scopedIdenName)
@ -1072,23 +1060,12 @@ instance (SingI s) => PrettyPrint (UsingItem s) where
kwmodule = ppCode <$> (ui ^. usingModuleKw)
kwmodule <?+> (sym' <+?> kwAs' <+?> alias')
instance PrettyPrint (ModuleRef' 'S.NotConcrete) where
ppCode (ModuleRef' (t :&: m)) =
let path = m ^. moduleRefModule . modulePath
txt = case t of
SModuleTop -> annotate (AnnKind KNameTopModule) (pretty path)
SModuleLocal -> annotate (AnnKind KNameLocalModule) (pretty path)
in noLoc txt
instance PrettyPrint ModuleRef where
ppCode (ModuleRef' (_ :&: ModuleRef'' {..})) = ppCode _moduleRefName
instance (SingI s) => PrettyPrint (Import s) where
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => Import s -> Sem r ()
ppCode i = do
let open' = ppOpenModuleHelper Nothing <$> (i ^. importOpen)
ppCode (i ^. importKw)
<+> ppImportType (i ^. importModule)
<+> ppModulePathType (i ^. importModulePath)
<+?> ppAlias
<+?> open'
where
@ -1097,9 +1074,9 @@ instance (SingI s) => PrettyPrint (Import s) where
Nothing -> Nothing
Just as -> Just (ppCode Kw.kwAs <+> ppModulePathType as)
ppOpenModuleHelper :: (SingI s) => Maybe (ModuleRefType s) -> PrettyPrinting (OpenModuleParams s)
ppOpenModuleHelper :: (SingI s) => Maybe (ModuleNameType s) -> PrettyPrinting (OpenModuleParams s)
ppOpenModuleHelper modName OpenModuleParams {..} = do
let name' = ppModuleRefType <$> modName
let name' = ppModuleNameType <$> modName
usingHiding' = ppCode <$> _openUsingHiding
openkw = ppCode _openModuleKw
public' = ppCode <$> _openPublicKw ^. unIrrelevant

17
src/Juvix/Compiler/Concrete/Translation.hs
View File

@ -1,17 +0,0 @@
module Juvix.Compiler.Concrete.Translation where
import Juvix.Compiler.Concrete.Data.Highlight.Input (HighlightBuilder)
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.FromSource qualified as Parser
import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Prelude
type JudocStash = State (Maybe (Judoc 'Parsed))
fromSource ::
(Members '[HighlightBuilder, Files, Error JuvixError, NameIdGen, Reader EntryPoint, PathResolver, Parser.PragmasStash] r) =>
EntryPoint ->
Sem r Scoper.ScoperResult
fromSource = Parser.fromSource >=> Scoper.fromParsed

17
src/Juvix/Compiler/Concrete/Translation/FromParsed.hs
View File

@ -5,20 +5,21 @@ module Juvix.Compiler.Concrete.Translation.FromParsed
)
where
import Juvix.Compiler.Concrete.Data.Highlight.Input
import Juvix.Compiler.Concrete.Data.Highlight
import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Base
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context
import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser
import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context qualified as Parsed
import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Compiler.Store.Extra
import Juvix.Compiler.Store.Language
import Juvix.Prelude
fromParsed ::
(Members '[HighlightBuilder, Error JuvixError, Files, NameIdGen, Reader EntryPoint, PathResolver] r) =>
Parsed.ParserResult ->
(Members '[HighlightBuilder, Reader EntryPoint, Reader ModuleTable, Reader Parsed.ParserResult, Error JuvixError, NameIdGen] r) =>
Sem r ScoperResult
fromParsed pr = mapError (JuvixError @ScoperError) $ do
let modules = pr ^. Parser.resultModules
scopeCheck pr modules
fromParsed = do
e <- ask
tab <- ask
r <- ask
scopeCheck e (getScopedModuleTable tab) r

633
src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs
View File

File diff suppressed because it is too large Load Diff

36
src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Data/Context.hs
View File

@ -1,41 +1,25 @@
module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context
( module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context,
module Juvix.Compiler.Concrete.Data.InfoTable,
)
where
module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context where
import Juvix.Compiler.Concrete.Data.InfoTable
import Juvix.Compiler.Concrete.Data.ParsedInfoTable qualified as Parsed
import Juvix.Compiler.Concrete.Data.Scope
import Juvix.Compiler.Concrete.Data.ScopedName qualified as Scoped
import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context qualified as Parsed
import Juvix.Compiler.Pipeline.EntryPoint (EntryPoint)
import Juvix.Compiler.Concrete.Translation.FromSource.Data.ParserState qualified as Parsed
import Juvix.Compiler.Store.Scoped.Language
import Juvix.Prelude
data ScoperResult = ScoperResult
{ _resultParserResult :: Parsed.ParserResult,
_resultScoperTable :: InfoTable,
_resultModules :: NonEmpty (Module 'Scoped 'ModuleTop),
_resultModule :: Module 'Scoped 'ModuleTop,
_resultScopedModule :: ScopedModule,
_resultExports :: HashSet NameId,
_resultScope :: HashMap TopModulePath Scope,
_resultScoperState :: ScoperState
_resultScoperState :: ScoperState,
_resultScope :: Scope
}
makeLenses ''ScoperResult
mainModule :: Lens' ScoperResult (Module 'Scoped 'ModuleTop)
mainModule = resultModules . _head1
mainModule = resultModule
entryPoint :: Lens' ScoperResult EntryPoint
entryPoint = resultParserResult . Parsed.resultEntry
mainModuleSope :: ScoperResult -> Scope
mainModuleSope r =
r
^?! resultScope
. at (r ^. mainModule . modulePath . Scoped.nameConcrete)
. _Just
comments :: Lens' ScoperResult Comments
comments = resultParserResult . Parsed.resultTable . Parsed.infoParsedComments
getScoperResultComments :: ScoperResult -> Comments
getScoperResultComments sr = mkComments $ sr ^. resultParserResult . Parsed.resultParserState . Parsed.parserStateComments

8
src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs
View File

@ -13,6 +13,7 @@ import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Concrete.Pretty.Options (Options, fromGenericOptions)
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error.Pretty
import Juvix.Compiler.Store.Scoped.Language (FixitySymbolEntry, ModuleSymbolEntry, PreSymbolEntry, ScopedModule)
import Juvix.Data.CodeAnn
import Juvix.Prelude
@ -97,7 +98,7 @@ instance ToGenericError InfixErrorP where
newtype ImportCycle = ImportCycle
{ -- | If we have [a, b, c] it means that a import b imports c imports a.
_importCycleImports :: NonEmpty (Import 'Parsed)
_importCycleImports :: NonEmpty TopModulePath
}
deriving stock (Show)
@ -120,7 +121,7 @@ instance ToGenericError ImportCycle where
<> line
<> indent' (vsep (intersperse "⇓" (map pp (toList (tie _importCycleImports)))))
pp :: Import 'Parsed -> Doc Ann
pp :: TopModulePath -> Doc Ann
pp t = ppCode opts' t <+> parens ("at" <+> pretty (getLoc t))
tie :: NonEmpty a -> NonEmpty a
@ -611,9 +612,8 @@ instance ToGenericError ConstructorExpectedLeftApplication where
data ModuleDoesNotExportSymbol = ModuleDoesNotExportSymbol
{ _moduleDoesNotExportSymbol :: Symbol,
_moduleDoesNotExportModule :: ModuleRef
_moduleDoesNotExportModule :: ScopedModule
}
deriving stock (Show)
instance ToGenericError ModuleDoesNotExportSymbol where
genericError :: (Member (Reader GenericOptions) r) => ModuleDoesNotExportSymbol -> Sem r GenericError

339
src/Juvix/Compiler/Concrete/Translation/FromSource.hs
View File

File diff suppressed because it is too large Load Diff

17
src/Juvix/Compiler/Concrete/Translation/FromSource/Data/Context.hs
View File

@ -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

29
src/Juvix/Compiler/Concrete/Translation/FromSource/Data/ParserState.hs Normal file
View File

@ -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
}

60
src/Juvix/Compiler/Concrete/Translation/FromSource/Lexer.hs
View File

@ -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

88
src/Juvix/Compiler/Concrete/Translation/FromSource/ParserResultBuilder.hs Normal file
View File

@ -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
}
)

2
src/Juvix/Compiler/Core/Data.hs
View File

@ -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

18
src/Juvix/Compiler/Core/Data/IdentDependencyInfo.hs
View File

@ -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)

212
src/Juvix/Compiler/Core/Data/InfoTable.hs
View File

@ -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
}
type InfoTable = InfoTable' Node
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
}
type IdentifierInfo = IdentifierInfo' Node
emptyInfoTable' :: Node -> InfoTable
emptyInfoTable' mainNode =
emptyInfoTable
{ _identContext = HashMap.singleton 0 mainNode,
_infoMain = Just 0
}
type InductiveInfo = InductiveInfo' Node
data IdentKind
= IdentFun Symbol
| IdentInd Symbol
| IdentConstr Tag
type ConstructorInfo = ConstructorInfo' Node
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]
}
type AxiomInfo = AxiomInfo' Node
data InductiveInfo = InductiveInfo
{ _inductiveName :: Text,
_inductiveLocation :: Maybe Location,
_inductiveSymbol :: Symbol,
_inductiveKind :: Type,
_inductiveConstructors :: [Tag],
_inductiveParams :: [ParameterInfo],
_inductivePositive :: Bool,
_inductiveBuiltin :: Maybe BuiltinType,
_inductivePragmas :: Pragmas
}
type ParameterInfo = ParameterInfo' Node
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
}
type SpecialisationInfo = SpecialisationInfo' Node
data ParameterInfo = ParameterInfo
{ _paramName :: Text,
_paramLocation :: Maybe Location,
_paramKind :: Type,
_paramIsImplicit :: Bool
}
nextSymbolId :: InfoTable -> Word
nextSymbolId tab =
maximum (0 : map (^. symbolId) (HashMap.keys (tab ^. infoIdentifiers)) ++ map (^. symbolId) (HashMap.keys (tab ^. infoInductives)))
+ 1
data AxiomInfo = AxiomInfo
{ _axiomName :: Text,
_axiomLocation :: Maybe Location,
_axiomType :: Type,
_axiomPragmas :: Pragmas
}
nextTagId :: InfoTable -> Word
nextTagId tab =
maximum (0 : mapMaybe getUserTagId (HashMap.keys (tab ^. infoConstructors))) + 1
data SpecialisationInfo = SpecialisationInfo
{ _specSignature :: ([Node], [Int]),
_specSymbol :: Symbol
}
lookupTabInductiveInfo' :: InfoTable -> Symbol -> Maybe InductiveInfo
lookupTabInductiveInfo' tab sym = HashMap.lookup sym (tab ^. infoInductives)
makeLenses ''InfoTable
makeLenses ''IdentifierInfo
makeLenses ''InductiveInfo
makeLenses ''ConstructorInfo
makeLenses ''ParameterInfo
makeLenses ''AxiomInfo
makeLenses ''SpecialisationInfo
lookupTabConstructorInfo' :: InfoTable -> Tag -> Maybe ConstructorInfo
lookupTabConstructorInfo' tab tag = HashMap.lookup tag (tab ^. infoConstructors)
lookupInductiveInfo' :: InfoTable -> Symbol -> Maybe InductiveInfo
lookupInductiveInfo' tab sym = HashMap.lookup sym (tab ^. infoInductives)
lookupTabIdentifierInfo' :: InfoTable -> Symbol -> Maybe IdentifierInfo
lookupTabIdentifierInfo' tab sym = HashMap.lookup sym (tab ^. infoIdentifiers)
lookupConstructorInfo' :: InfoTable -> Tag -> Maybe ConstructorInfo
lookupConstructorInfo' tab tag = HashMap.lookup tag (tab ^. infoConstructors)
lookupTabIdentifierNode' :: InfoTable -> Symbol -> Maybe Node
lookupTabIdentifierNode' tab sym = HashMap.lookup sym (tab ^. identContext)
lookupIdentifierInfo' :: InfoTable -> Symbol -> Maybe IdentifierInfo
lookupIdentifierInfo' tab sym = HashMap.lookup sym (tab ^. infoIdentifiers)
lookupTabSpecialisationInfo' :: InfoTable -> Symbol -> Maybe [SpecialisationInfo]
lookupTabSpecialisationInfo' tab sym = HashMap.lookup sym (tab ^. infoSpecialisations)
lookupIdentifierNode' :: InfoTable -> Symbol -> Maybe Node
lookupIdentifierNode' tab sym = HashMap.lookup sym (tab ^. identContext)
lookupTabSpecialisationInfo :: InfoTable -> Symbol -> [SpecialisationInfo]
lookupTabSpecialisationInfo tab sym = fromMaybe [] $ lookupTabSpecialisationInfo' tab sym
lookupSpecialisationInfo :: InfoTable -> Symbol -> [SpecialisationInfo]
lookupSpecialisationInfo tab sym = fromMaybe [] $ HashMap.lookup sym (tab ^. infoSpecialisations)
lookupTabInductiveInfo :: InfoTable -> Symbol -> InductiveInfo
lookupTabInductiveInfo tab sym = fromJust $ lookupTabInductiveInfo' tab sym
lookupInductiveInfo :: InfoTable -> Symbol -> InductiveInfo
lookupInductiveInfo tab sym = fromJust $ lookupInductiveInfo' tab sym
lookupTabConstructorInfo :: InfoTable -> Tag -> ConstructorInfo
lookupTabConstructorInfo tab tag = fromMaybe (error ("tag: " <> show tag)) $ lookupTabConstructorInfo' tab tag
lookupConstructorInfo :: InfoTable -> Tag -> ConstructorInfo
lookupConstructorInfo tab tag = fromMaybe (error ("tag: " <> show tag)) $ lookupConstructorInfo' tab tag
lookupTabIdentifierInfo :: InfoTable -> Symbol -> IdentifierInfo
lookupTabIdentifierInfo tab sym = fromJust $ lookupTabIdentifierInfo' tab sym
lookupIdentifierInfo :: InfoTable -> Symbol -> IdentifierInfo
lookupIdentifierInfo tab sym = fromJust $ lookupIdentifierInfo' tab sym
lookupTabIdentifierNode :: InfoTable -> Symbol -> Node
lookupTabIdentifierNode tab sym = fromJust $ lookupTabIdentifierNode' 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
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

145
src/Juvix/Compiler/Core/Data/InfoTable/Base.hs Normal file
View File

@ -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
}

149
src/Juvix/Compiler/Core/Data/InfoTableBuilder.hs
View File

@ -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 :: InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r InfoTable
execInfoTableBuilder tab = fmap fst . runInfoTableBuilder tab
execInfoTableBuilder' :: BuilderState -> Sem (InfoTableBuilder ': r) a -> Sem r BuilderState
execInfoTableBuilder' st = fmap fst . runInfoTableBuilder' st
evalInfoTableBuilder :: InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r a
evalInfoTableBuilder tab = fmap snd . runInfoTableBuilder tab
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 :: Module -> Sem (InfoTableBuilder ': r) a -> Sem r Module
execInfoTableBuilder m = fmap fst . runInfoTableBuilder m
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)

117
src/Juvix/Compiler/Core/Data/Module.hs Normal file
View File

@ -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

17
src/Juvix/Compiler/Core/Data/TransformationId.hs
View File

@ -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

10
src/Juvix/Compiler/Core/Data/TransformationId/Parser.hs
View File

@ -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"

2
src/Juvix/Compiler/Core/Data/TypeDependencyInfo.hs
View File

@ -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

102
src/Juvix/Compiler/Core/Extra/Utils.hs
View File

@ -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

4
src/Juvix/Compiler/Core/Extra/Value.hs
View File

@ -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

30
src/Juvix/Compiler/Core/Language/Base.hs
View File

@ -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

7
src/Juvix/Compiler/Core/Language/Builtins.hs
View File

@ -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

64
src/Juvix/Compiler/Core/Language/Nodes.hs
View File

@ -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

13
src/Juvix/Compiler/Core/Language/Primitives.hs
View File

@ -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

10
src/Juvix/Compiler/Core/Normalizer.hs
View File

@ -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

30
src/Juvix/Compiler/Core/Pipeline.hs
View File

@ -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

12
src/Juvix/Compiler/Core/Pretty/Base.hs
View File

@ -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

7
src/Juvix/Compiler/Core/Transformation.hs
View File

@ -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

64
src/Juvix/Compiler/Core/Transformation/Base.hs
View File

@ -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

27
src/Juvix/Compiler/Core/Transformation/Check/Base.hs
View File

@ -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",

14
src/Juvix/Compiler/Core/Transformation/Check/Exec.hs
View File

@ -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)

16
src/Juvix/Compiler/Core/Transformation/Check/Geb.hs
View File

@ -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

16
src/Juvix/Compiler/Core/Transformation/Check/VampIR.hs
View File

@ -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)

Some files were not shown because too many files have changed in this diff Show More