anoma/juvix
1
1
Fork 0
mirror of https://github.com/anoma/juvix.git synced 2024-08-16 19:50:26 +03:00
Code Issues Projects Releases Wiki Activity

Improve performance of formatting a project (#2863)

Browse Source 
Currently formatting a project is equivalent to running `juvix format`
on each individual file. Hence, the performance is quadratic wrt the
number of modules in the project. This pr fixes that and we now we only
process each module once.

# Benchmark (1236% faster 🚀)
Checking the standard library
```
hyperfine --warmup 1 'juvix format --check' 'juvix-main format --check'
Benchmark 1: juvix format --check
  Time (mean ± σ):     450.6 ms ±  33.7 ms    [User: 707.2 ms, System: 178.7 ms]
  Range (min … max):   396.0 ms … 497.0 ms    10 runs

Benchmark 2: juvix-main format --check
  Time (mean ± σ):      6.019 s ±  0.267 s    [User: 9.333 s, System: 1.512 s]
  Range (min … max):    5.598 s …  6.524 s    10 runs

Summary
  juvix format --check ran
   13.36 ± 1.16 times faster than juvix-main format --check
```

# Other changes:
1. The `EntryPoint` field `entryPointModulePath` is now optional.
2. I've introduced a new type `TopModulePathKey` which is analogous to
`TopModulePath` but wihout location information. It is used in hashmap
keys where the location in the key is never used. This is useful as we
can now get a `TopModulePathKey` from a `Path Rel File`.
3. I've refactored the `_formatInput` field in `FormatOptions` so that
it doesn't need to be a special case anymore.
4. I've introduced a new effect `Forcing` that allows to individually
force fields of a record type with a convenient syntax.
5. I've refactored some of the constraints in scoping so that they only
require `Reader Package` instead of `Reader EntryPoint`.
6. I've introduced a new type family so that local modules are no longer
required to have `ModuleId` from their type. Before, they were assigned
one, but it was never used.


# Future work:
1. For project-wise formatting, the compilation is done in parallel, but
the formatting is still done sequentially. That should be improved.
This commit is contained in:
Jan Mas Rovira 2024-07-01 18:05:24 +02:00 committed by GitHub
parent fef37a86ee
commit 6fcc9f21d2
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
53 changed files with 559 additions and 321 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
app/App.hs
View File

@ -32,7 +32,9 @@ data App :: Effect where
AskGlobalOptions :: App m GlobalOptions AskGlobalOptions :: App m GlobalOptions
FromAppPathFile :: AppPath File -> App m (Path Abs File) FromAppPathFile :: AppPath File -> App m (Path Abs File)
GetMainAppFile :: Maybe (AppPath File) -> App m (AppPath File) GetMainAppFile :: Maybe (AppPath File) -> App m (AppPath File)
GetMainAppFileMaybe :: Maybe (AppPath File) -> App m (Maybe (AppPath File))
GetMainFile :: Maybe (AppPath File) -> App m (Path Abs File) GetMainFile :: Maybe (AppPath File) -> App m (Path Abs File)
GetMainFileMaybe :: Maybe (AppPath File) -> App m (Maybe (Path Abs File))
FromAppPathDir :: AppPath Dir -> App m (Path Abs Dir) FromAppPathDir :: AppPath Dir -> App m (Path Abs Dir)
RenderStdOut :: (HasAnsiBackend a, HasTextBackend a) => a -> App m () RenderStdOut :: (HasAnsiBackend a, HasTextBackend a) => a -> App m ()
Say :: Text -> App m () Say :: Text -> App m ()
@ -68,7 +70,9 @@ reAppIO args@RunAppIOArgs {..} =
FromAppPathFile p -> prepathToAbsFile invDir (p ^. pathPath) FromAppPathFile p -> prepathToAbsFile invDir (p ^. pathPath)
FromAppFile m -> fromAppFile' m FromAppFile m -> fromAppFile' m
GetMainAppFile m -> getMainAppFile' m GetMainAppFile m -> getMainAppFile' m
GetMainAppFileMaybe m -> getMainAppFileMaybe' m
GetMainFile m -> getMainFile' m GetMainFile m -> getMainFile' m
GetMainFileMaybe m -> getMainFileMaybe' m
FromAppPathDir p -> liftIO (prepathToAbsDir invDir (p ^. pathPath)) FromAppPathDir p -> liftIO (prepathToAbsDir invDir (p ^. pathPath))
RenderStdOut t RenderStdOut t
| _runAppIOArgsGlobalOptions ^. globalOnlyErrors -> return () | _runAppIOArgsGlobalOptions ^. globalOnlyErrors -> return ()
@ -105,19 +109,25 @@ reAppIO args@RunAppIOArgs {..} =
getMainFile' :: (Members '[SCache Package, EmbedIO] r') => Maybe (AppPath File) -> Sem r' (Path Abs File) getMainFile' :: (Members '[SCache Package, EmbedIO] r') => Maybe (AppPath File) -> Sem r' (Path Abs File)
getMainFile' = getMainAppFile' >=> fromAppFile' getMainFile' = getMainAppFile' >=> fromAppFile'
getMainAppFile' :: (Members '[SCache Package, EmbedIO] r') => Maybe (AppPath File) -> Sem r' (AppPath File) getMainFileMaybe' :: (Members '[SCache Package, EmbedIO] r') => Maybe (AppPath File) -> Sem r' (Maybe (Path Abs File))
getMainAppFile' = \case getMainFileMaybe' = getMainAppFileMaybe' >=> mapM fromAppFile'
Just p -> return p
getMainAppFileMaybe' :: (Members '[SCache Package, EmbedIO] r') => Maybe (AppPath File) -> Sem r' (Maybe (AppPath File))
getMainAppFileMaybe' = \case
Just p -> return (Just p)
Nothing -> do Nothing -> do
pkg <- getPkg pkg <- getPkg
case pkg ^. packageMain of return $ case pkg ^. packageMain of
Just p -> Just p ->
return return
AppPath AppPath
{ _pathPath = p, { _pathPath = p,
_pathIsInput = True _pathIsInput = True
} }
Nothing -> missingMainErr Nothing -> Nothing
getMainAppFile' :: (Members '[SCache Package, EmbedIO] r') => Maybe (AppPath File) -> Sem r' (AppPath File)
getMainAppFile' = fromMaybeM missingMainErr . getMainAppFileMaybe'
missingMainErr :: (Members '[EmbedIO] r') => Sem r' x missingMainErr :: (Members '[EmbedIO] r') => Sem r' x
missingMainErr = missingMainErr =
@ -148,8 +158,8 @@ getEntryPoint' RunAppIOArgs {..} inputFile = do
if if
| opts ^. globalStdin -> Just <$> liftIO getContents | opts ^. globalStdin -> Just <$> liftIO getContents
| otherwise -> return Nothing | otherwise -> return Nothing
mainFile <- getMainAppFile inputFile mainFile <- getMainAppFileMaybe inputFile
set entryPointStdin estdin <$> entryPointFromGlobalOptionsPre root (mainFile ^. pathPath) opts set entryPointStdin estdin <$> entryPointFromGlobalOptionsPre root ((^. pathPath) <$> mainFile) opts
runPipelineEither :: runPipelineEither ::
(Members '[EmbedIO, TaggedLock, ProgressLog, App] r, EntryPointOptions opts) => (Members '[EmbedIO, TaggedLock, ProgressLog, App] r, EntryPointOptions opts) =>
@ -183,6 +193,12 @@ someBaseToAbs' f = do
r <- askInvokeDir r <- askInvokeDir
return (someBaseToAbs r f) return (someBaseToAbs r f)
fromAppPathFileOrDir ::
(Members '[EmbedIO, App] r) =>
AppPath FileOrDir ->
Sem r (Either (Path Abs File) (Path Abs Dir))
fromAppPathFileOrDir = filePathToAbs . (^. pathPath)
filePathToAbs :: (Members '[EmbedIO, App] r) => Prepath FileOrDir -> Sem r (Either (Path Abs File) (Path Abs Dir)) filePathToAbs :: (Members '[EmbedIO, App] r) => Prepath FileOrDir -> Sem r (Either (Path Abs File) (Path Abs Dir))
filePathToAbs fp = do filePathToAbs fp = do
invokeDir <- askInvokeDir invokeDir <- askInvokeDir
@ -282,9 +298,11 @@ runPipelineEntry entry p = runPipelineOptions $ do
r <- runIOEither entry (inject p) >>= fromRightJuvixError r <- runIOEither entry (inject p) >>= fromRightJuvixError
return (snd r ^. pipelineResult) return (snd r ^. pipelineResult)
runPipelineSetup :: (Members '[App, EmbedIO, Reader PipelineOptions, TaggedLock] r) => Sem (PipelineEff' r) a -> Sem r a runPipelineSetup ::
-- runPipelineSetup p = ignoreProgressLog $ do -- TODO restore (Members '[App, EmbedIO, Reader PipelineOptions, TaggedLock] r) =>
runPipelineSetup p = appRunProgressLog $ do Sem (PipelineEff' r) a ->
Sem r a
runPipelineSetup p = ignoreProgressLog $ do
args <- askArgs args <- askArgs
entry <- getEntryPointStdin' args entry <- getEntryPointStdin' args
r <- runIOEitherPipeline entry (inject p) >>= fromRightJuvixError r <- runIOEitherPipeline entry (inject p) >>= fromRightJuvixError

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

@ -11,7 +11,7 @@ runCommand opts = do
root <- askRoot root <- askRoot
gopts <- askGlobalOptions gopts <- askGlobalOptions
inputFile :: Path Abs File <- fromAppPathFile sinputFile inputFile :: Path Abs File <- fromAppPathFile sinputFile
ep <- entryPointFromGlobalOptions root inputFile gopts ep <- entryPointFromGlobalOptions root (Just inputFile) gopts
s' <- readFile inputFile s' <- readFile inputFile
(tab, _) <- getRight (Core.runParser inputFile defaultModuleId mempty s') (tab, _) <- getRight (Core.runParser inputFile defaultModuleId mempty s')
let r = let r =
@ -19,7 +19,9 @@ runCommand opts = do
. runReader ep . runReader ep
. runError @JuvixError . runError @JuvixError
$ Core.toStripped Core.IdentityTrans (Core.moduleFromInfoTable tab) $ Core.toStripped Core.IdentityTrans (Core.moduleFromInfoTable tab)
tab' <- getRight $ mapRight (Stripped.fromCore (project gopts ^. Core.optFieldSize) . Core.computeCombinedInfoTable) r tab' <-
getRight $
mapRight (Stripped.fromCore (project gopts ^. Core.optFieldSize) . Core.computeCombinedInfoTable) r
unless (project opts ^. coreStripNoPrint) $ do unless (project opts ^. coreStripNoPrint) $ do
renderStdOut (Core.ppOut opts tab') renderStdOut (Core.ppOut opts tab')
where where

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

@ -41,7 +41,7 @@ runCommand replOpts = do
gopts <- State.gets (^. replStateGlobalOptions) gopts <- State.gets (^. replStateGlobalOptions)
absInputFile :: Path Abs File <- replMakeAbsolute inputFile absInputFile :: Path Abs File <- replMakeAbsolute inputFile
set entryPointTarget (Just Backend.TargetGeb) set entryPointTarget (Just Backend.TargetGeb)
<$> runM (runTaggedLockPermissive (entryPointFromGlobalOptions root absInputFile gopts)) <$> runM (runTaggedLockPermissive (entryPointFromGlobalOptions root (Just absInputFile) gopts))
liftIO liftIO
. State.evalStateT . State.evalStateT
(replAction replOpts getReplEntryPoint) (replAction replOpts getReplEntryPoint)

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

@ -10,7 +10,7 @@ import Juvix.Prelude.Pretty
runCommand :: (Members '[EmbedIO, TaggedLock, App] r) => ScopeOptions -> Sem r () runCommand :: (Members '[EmbedIO, TaggedLock, App] r) => ScopeOptions -> Sem r ()
runCommand opts = do runCommand opts = do
globalOpts <- askGlobalOptions globalOpts <- askGlobalOptions
res :: Scoper.ScoperResult <- runPipelineNoOptions (opts ^. scopeInputFile) upToScoping res :: Scoper.ScoperResult <- runPipelineNoOptions (opts ^. scopeInputFile) upToScopingEntry
let m :: Module 'Scoped 'ModuleTop = res ^. Scoper.resultModule let m :: Module 'Scoped 'ModuleTop = res ^. Scoper.resultModule
if if
| opts ^. scopeWithComments -> | opts ^. scopeWithComments ->

2
app/Commands/Eval.hs
View File

@ -10,7 +10,7 @@ runCommand :: (Members '[EmbedIO, TaggedLock, App] r) => EvalOptions -> Sem r ()
runCommand opts@EvalOptions {..} = do runCommand opts@EvalOptions {..} = do
gopts <- askGlobalOptions gopts <- askGlobalOptions
root <- askRoot root <- askRoot
entryPoint <- maybe (entryPointFromGlobalOptionsNoFile root gopts) (fromAppPathFile >=> \f -> entryPointFromGlobalOptions root f gopts) _evalInputFile entryPoint <- maybe (entryPointFromGlobalOptionsNoFile root gopts) (fromAppPathFile >=> \f -> entryPointFromGlobalOptions root (Just f) gopts) _evalInputFile
Core.CoreResult {..} <- ignoreProgressLog (runPipelineProgress () _evalInputFile upToCore) Core.CoreResult {..} <- ignoreProgressLog (runPipelineProgress () _evalInputFile upToCore)
let r = let r =
run run

38
app/Commands/Format.hs
View File

@ -3,6 +3,10 @@ module Commands.Format where
import Commands.Base import Commands.Base
import Commands.Format.Options import Commands.Format.Options
import Data.Text qualified as Text import Data.Text qualified as Text
import Juvix.Compiler.Pipeline.Driver (processModule)
import Juvix.Compiler.Pipeline.Loader.PathResolver.ImportTree.Base
import Juvix.Compiler.Pipeline.ModuleInfoCache
import Juvix.Compiler.Store.Language (ModuleInfo)
import Juvix.Formatter import Juvix.Formatter
data FormatNoEditRenderMode data FormatNoEditRenderMode
@ -16,7 +20,7 @@ data FormatRenderMode
data FormatTarget data FormatTarget
= TargetFile (Path Abs File) = TargetFile (Path Abs File)
| TargetProject (Path Abs Dir) | TargetProject
| TargetStdin | TargetStdin
isTargetProject :: FormatTarget -> Bool isTargetProject :: FormatTarget -> Bool
@ -28,16 +32,15 @@ targetFromOptions :: (Members '[EmbedIO, App] r) => FormatOptions -> Sem r Forma
targetFromOptions opts = do targetFromOptions opts = do
globalOpts <- askGlobalOptions globalOpts <- askGlobalOptions
let isStdin = globalOpts ^. globalStdin let isStdin = globalOpts ^. globalStdin
f <- mapM filePathToAbs (opts ^. formatInput) f <- mapM fromAppPathFileOrDir (opts ^. formatInput)
pkgDir <- askPkgDir
case f of case f of
Just (Left p) -> return (TargetFile p) Just (Left p) -> return (TargetFile p)
Just Right {} -> return (TargetProject pkgDir) Just Right {} -> return TargetProject
Nothing -> do Nothing -> do
isPackageGlobal <- askPackageGlobal isPackageGlobal <- askPackageGlobal
if if
| isStdin -> return TargetStdin | isStdin -> return TargetStdin
| not (isPackageGlobal) -> return (TargetProject pkgDir) | not isPackageGlobal -> return TargetProject
| otherwise -> do | otherwise -> do
exitFailMsg $ exitFailMsg $
Text.unlines Text.unlines
@ -45,13 +48,30 @@ targetFromOptions opts = do
"Use the --help option to display more usage information." "Use the --help option to display more usage information."
] ]
-- | Formats the project on the root
formatProject ::
forall r.
(Members '[App, EmbedIO, TaggedLock, Files, Output FormattedFileInfo] r) =>
Sem r FormatResult
formatProject = runPipelineOptions . runPipelineSetup $ do
pkg <- askPackage
root <- (^. rootRootDir) <$> askRoot
nodes <- toList <$> asks (importTreeProjectNodes root)
res :: [(ImportNode, PipelineResult ModuleInfo)] <- forM nodes $ \node -> do
res <- mkEntryIndex node >>= processModule
return (node, res)
res' :: [(ImportNode, SourceCode)] <- runReader pkg . forM res $ \(node, nfo) -> do
src <- formatModuleInfo node nfo
return (node, src)
formatProjectSourceCode res'
runCommand :: forall r. (Members '[EmbedIO, App, TaggedLock, Files] r) => FormatOptions -> Sem r () runCommand :: forall r. (Members '[EmbedIO, App, TaggedLock, Files] r) => FormatOptions -> Sem r ()
runCommand opts = do runCommand opts = do
target <- targetFromOptions opts target <- targetFromOptions opts
runOutputSem (renderFormattedOutput target opts) $ runScopeFileApp $ do runOutputSem (renderFormattedOutput target opts) . runScopeFileApp $ do
res <- case target of res <- case target of
TargetFile p -> format p TargetFile p -> format p
TargetProject p -> formatProject p TargetProject -> formatProject
TargetStdin -> do TargetStdin -> do
entry <- getEntryPointStdin entry <- getEntryPointStdin
runReader entry formatStdin runReader entry formatStdin
@ -103,5 +123,5 @@ runScopeFileApp = interpret $ \case
{ _pathPath = mkPrepath (toFilePath p), { _pathPath = mkPrepath (toFilePath p),
_pathIsInput = False _pathIsInput = False
} }
ignoreProgressLog (runPipelineProgress () (Just appFile) upToScoping) ignoreProgressLog (runPipelineProgress () (Just appFile) upToScopingEntry)
ScopeStdin e -> ignoreProgressLog (runPipelineEntry e upToScoping) ScopeStdin e -> ignoreProgressLog (runPipelineEntry e upToScopingEntry)

13
app/Commands/Format/Options.hs
View File

@ -3,7 +3,7 @@ module Commands.Format.Options where
import CommonOptions import CommonOptions
data FormatOptions = FormatOptions data FormatOptions = FormatOptions
{ _formatInput :: Maybe (Prepath FileOrDir), { _formatInput :: Maybe (AppPath FileOrDir),
_formatCheck :: Bool, _formatCheck :: Bool,
_formatInPlace :: Bool _formatInPlace :: Bool
} }
@ -11,18 +11,21 @@ data FormatOptions = FormatOptions
makeLenses ''FormatOptions makeLenses ''FormatOptions
parseInputJuvixFileOrDir :: Parser (Prepath FileOrDir) parseInputFileOrDir :: Parser (AppPath FileOrDir)
parseInputJuvixFileOrDir = parseInputFileOrDir = do
strArgument _pathPath <-
argument
somePreFileOrDirOpt
( metavar "JUVIX_FILE_OR_PROJECT" ( metavar "JUVIX_FILE_OR_PROJECT"
<> help ("Path to a " <> show FileExtJuvix <> " file or to a directory containing a Juvix project.") <> help ("Path to a " <> show FileExtJuvix <> " file or to a directory containing a Juvix project.")
<> completer (extCompleter FileExtJuvix) <> completer (extCompleter FileExtJuvix)
<> action "directory" <> action "directory"
) )
pure AppPath {_pathIsInput = True, ..}
parseFormat :: Parser FormatOptions parseFormat :: Parser FormatOptions
parseFormat = do parseFormat = do
_formatInput <- optional parseInputJuvixFileOrDir _formatInput <- optional parseInputFileOrDir
_formatCheck <- _formatCheck <-
switch switch
( long "check" ( long "check"

2
app/Commands/Html.hs
View File

@ -16,7 +16,7 @@ import System.Process qualified as Process
runGenOnlySourceHtml :: (Members '[EmbedIO, TaggedLock, App] r) => HtmlOptions -> Sem r () runGenOnlySourceHtml :: (Members '[EmbedIO, TaggedLock, App] r) => HtmlOptions -> Sem r ()
runGenOnlySourceHtml HtmlOptions {..} = do runGenOnlySourceHtml HtmlOptions {..} = do
res <- runPipelineNoOptions _htmlInputFile upToScoping res <- runPipelineNoOptions _htmlInputFile upToScopingEntry
let m = res ^. Scoper.resultModule let m = res ^. Scoper.resultModule
outputDir <- fromAppPathDir _htmlOutputDir outputDir <- fromAppPathDir _htmlOutputDir
liftIO $ liftIO $

2
app/Commands/Markdown.hs
View File

@ -17,7 +17,7 @@ runCommand ::
Sem r () Sem r ()
runCommand opts = do runCommand opts = do
let inputFile = opts ^. markdownInputFile let inputFile = opts ^. markdownInputFile
scopedM <- runPipelineNoOptions inputFile upToScoping scopedM <- runPipelineNoOptions inputFile upToScopingEntry
let m = scopedM ^. Scoper.resultModule let m = scopedM ^. Scoper.resultModule
outputDir <- fromAppPathDir (opts ^. markdownOutputDir) outputDir <- fromAppPathDir (opts ^. markdownOutputDir)
let res = let res =

4
app/Commands/Repl.hs
View File

@ -143,10 +143,10 @@ getReplEntryPoint f inputFile = do
liftIO (set entryPointSymbolPruningMode KeepAll <$> f root inputFile gopts) liftIO (set entryPointSymbolPruningMode KeepAll <$> f root inputFile gopts)
getReplEntryPointFromPrepath :: Prepath File -> Repl EntryPoint getReplEntryPointFromPrepath :: Prepath File -> Repl EntryPoint
getReplEntryPointFromPrepath = getReplEntryPoint (\r x -> runM . runTaggedLockPermissive . entryPointFromGlobalOptionsPre r x) getReplEntryPointFromPrepath = getReplEntryPoint (\r x -> runM . runTaggedLockPermissive . entryPointFromGlobalOptionsPre r (Just x))
getReplEntryPointFromPath :: Path Abs File -> Repl EntryPoint getReplEntryPointFromPath :: Path Abs File -> Repl EntryPoint
getReplEntryPointFromPath = getReplEntryPoint (\r a -> runM . runTaggedLockPermissive . entryPointFromGlobalOptions r a) getReplEntryPointFromPath = getReplEntryPoint (\r a -> runM . runTaggedLockPermissive . entryPointFromGlobalOptions r (Just a))
displayVersion :: String -> Repl () displayVersion :: String -> Repl ()
displayVersion _ = liftIO (putStrLn versionTag) displayVersion _ = liftIO (putStrLn versionTag)

11
app/CommonOptions.hs
View File

@ -37,8 +37,8 @@ makeLenses ''AppPath
instance Show (AppPath f) where instance Show (AppPath f) where
show = Prelude.show . (^. pathPath) show = Prelude.show . (^. pathPath)
parseInputFiles :: NonEmpty FileExt -> Parser (AppPath File) parseInputFilesMod :: NonEmpty FileExt -> Mod ArgumentFields (Prepath File) -> Parser (AppPath File)
parseInputFiles exts' = do parseInputFilesMod exts' mods = do
let exts = NonEmpty.toList exts' let exts = NonEmpty.toList exts'
mvars = intercalate "|" (map toMetavar exts) mvars = intercalate "|" (map toMetavar exts)
dotExts = intercalate ", " (map Prelude.show exts) dotExts = intercalate ", " (map Prelude.show exts)
@ -51,9 +51,13 @@ parseInputFiles exts' = do
<> help helpMsg <> help helpMsg
<> completers <> completers
<> action "file" <> action "file"
<> mods
) )
pure AppPath {_pathIsInput = True, ..} pure AppPath {_pathIsInput = True, ..}
parseInputFiles :: NonEmpty FileExt -> Parser (AppPath File)
parseInputFiles exts' = parseInputFilesMod exts' mempty
parseInputFile :: FileExt -> Parser (AppPath File) parseInputFile :: FileExt -> Parser (AppPath File)
parseInputFile = parseInputFiles . NonEmpty.singleton parseInputFile = parseInputFiles . NonEmpty.singleton
@ -126,6 +130,9 @@ parseGenericOutputDir m = do
somePreDirOpt :: ReadM (Prepath Dir) somePreDirOpt :: ReadM (Prepath Dir)
somePreDirOpt = mkPrepath <$> str somePreDirOpt = mkPrepath <$> str
somePreFileOrDirOpt :: ReadM (Prepath FileOrDir)
somePreFileOrDirOpt = mkPrepath <$> str
somePreFileOpt :: ReadM (Prepath File) somePreFileOpt :: ReadM (Prepath File)
somePreFileOpt = mkPrepath <$> str somePreFileOpt = mkPrepath <$> str

6
app/GlobalOptions.hs
View File

@ -166,17 +166,17 @@ parseBuildDir m = do
entryPointFromGlobalOptionsPre :: entryPointFromGlobalOptionsPre ::
(Members '[TaggedLock, EmbedIO] r) => (Members '[TaggedLock, EmbedIO] r) =>
Root -> Root ->
Prepath File -> Maybe (Prepath File) ->
GlobalOptions -> GlobalOptions ->
Sem r EntryPoint Sem r EntryPoint
entryPointFromGlobalOptionsPre root premainFile opts = do entryPointFromGlobalOptionsPre root premainFile opts = do
mainFile <- liftIO (prepathToAbsFile (root ^. rootInvokeDir) premainFile) mainFile <- mapM (prepathToAbsFile (root ^. rootInvokeDir)) premainFile
entryPointFromGlobalOptions root mainFile opts entryPointFromGlobalOptions root mainFile opts
entryPointFromGlobalOptions :: entryPointFromGlobalOptions ::
(Members '[TaggedLock, EmbedIO] r) => (Members '[TaggedLock, EmbedIO] r) =>
Root -> Root ->
Path Abs File -> Maybe (Path Abs File) ->
GlobalOptions -> GlobalOptions ->
Sem r EntryPoint Sem r EntryPoint
entryPointFromGlobalOptions root mainFile opts = do entryPointFromGlobalOptions root mainFile opts = do

6
app/TopCommand/Options.hs
View File

@ -38,11 +38,7 @@ data TopCommand
deriving stock (Data) deriving stock (Data)
topCommandInputPath :: TopCommand -> IO (Maybe (SomePath Abs)) topCommandInputPath :: TopCommand -> IO (Maybe (SomePath Abs))
topCommandInputPath = \case topCommandInputPath t = do
JuvixFormat fopts -> case fopts ^. formatInput of
Just f -> getInputPathFromPrepathFileOrDir f
Nothing -> return Nothing
t -> do
d <- firstJustM getInputFileOrDir (universeBi t) d <- firstJustM getInputFileOrDir (universeBi t)
f <- firstJustM getInputFile (universeBi t) f <- firstJustM getInputFile (universeBi t)
return (f <|> d) return (f <|> d)

2
src/Juvix/Compiler/Backend/Isabelle/Translation/FromTyped.hs
View File

@ -114,7 +114,7 @@ goModule onlyTypes infoTable Internal.Module {..} =
defaultId = defaultId =
NameId NameId
{ _nameIdUid = 0, { _nameIdUid = 0,
_nameIdModuleId = ModuleId "" "" "" _nameIdModuleId = defaultModuleId
} }
goConstructorDef :: Internal.ConstructorDef -> Constructor goConstructorDef :: Internal.ConstructorDef -> Constructor

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

@ -87,11 +87,19 @@ instance Serialize TopModulePath
instance NFData TopModulePath instance NFData TopModulePath
instance Hashable TopModulePath
makeLenses ''TopModulePath makeLenses ''TopModulePath
topModulePathKey :: TopModulePath -> TopModulePathKey
topModulePathKey TopModulePath {..} =
TopModulePathKey
{ _modulePathKeyDir = (^. symbolText) <$> _modulePathDir,
_modulePathKeyName = _modulePathName ^. symbolText
}
instance Pretty TopModulePath where instance Pretty TopModulePath where
pretty (TopModulePath path name) = pretty = pretty . topModulePathKey
mconcat (punctuate Pretty.dot (map pretty (snoc path name)))
instance HasLoc TopModulePath where instance HasLoc TopModulePath where
getLoc TopModulePath {..} = getLoc TopModulePath {..} =
@ -115,8 +123,6 @@ moduleNameToTopModulePath = \case
NameUnqualified s -> TopModulePath [] s NameUnqualified s -> TopModulePath [] s
NameQualified (QualifiedName (SymbolPath p) s) -> TopModulePath (toList p) s NameQualified (QualifiedName (SymbolPath p) s) -> TopModulePath (toList p) s
instance Hashable TopModulePath
splitName :: Name -> ([Symbol], Symbol) splitName :: Name -> ([Symbol], Symbol)
splitName = \case splitName = \case
NameQualified (QualifiedName (SymbolPath p) s) -> (toList p, s) NameQualified (QualifiedName (SymbolPath p) s) -> (toList p, s)

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

@ -37,7 +37,7 @@ data Scope = Scope
-- several imports under the same name. E.g. -- several imports under the same name. E.g.
-- import A as X; -- import A as X;
-- import B as X; -- import B as X;
_scopeTopModules :: HashMap TopModulePath (HashMap S.NameId ScopedModule), _scopeTopModules :: HashMap TopModulePathKey (HashMap S.NameId ScopedModule),
-- | Symbols that have been defined in the current scope level. Every symbol -- | 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 -- 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 -- symbol with a different location but we may want the location of the
@ -48,11 +48,11 @@ data Scope = Scope
} }
newtype ModulesCache = ModulesCache newtype ModulesCache = ModulesCache
{ _cachedModules :: HashMap TopModulePath ScopedModule { _cachedModules :: HashMap TopModulePathKey ScopedModule
} }
newtype ScopeParameters = ScopeParameters newtype ScopeParameters = ScopeParameters
{ _scopeImportedModules :: HashMap TopModulePath ScopedModule { _scopeImportedModules :: HashMap TopModulePathKey ScopedModule
} }
data ScoperState = ScoperState data ScoperState = ScoperState

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

@ -57,10 +57,11 @@ type family FieldArgIxType s = res | res -> s where
FieldArgIxType 'Parsed = () FieldArgIxType 'Parsed = ()
FieldArgIxType 'Scoped = Int FieldArgIxType 'Scoped = Int
type ModuleIdType :: Stage -> GHC.Type type ModuleIdType :: Stage -> ModuleIsTop -> GHC.Type
type family ModuleIdType s = res | res -> s where type family ModuleIdType s t = res where
ModuleIdType 'Parsed = () ModuleIdType 'Parsed _ = ()
ModuleIdType 'Scoped = ModuleId ModuleIdType 'Scoped 'ModuleLocal = ()
ModuleIdType 'Scoped 'ModuleTop = ModuleId
type SymbolType :: Stage -> GHC.Type type SymbolType :: Stage -> GHC.Type
type family SymbolType s = res | res -> s where type family SymbolType s = res | res -> s where
@ -1197,7 +1198,7 @@ data Module (s :: Stage) (t :: ModuleIsTop) = Module
_moduleBody :: [Statement s], _moduleBody :: [Statement s],
_moduleKwEnd :: ModuleEndType t, _moduleKwEnd :: ModuleEndType t,
_moduleOrigin :: ModuleInductiveType t, _moduleOrigin :: ModuleInductiveType t,
_moduleId :: ModuleIdType s, _moduleId :: ModuleIdType s t,
_moduleMarkdownInfo :: Maybe MarkdownInfo _moduleMarkdownInfo :: Maybe MarkdownInfo
} }

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

@ -16,7 +16,16 @@ import Juvix.Compiler.Store.Language
import Juvix.Prelude import Juvix.Prelude
fromParsed :: fromParsed ::
(Members '[HighlightBuilder, Reader EntryPoint, Reader ModuleTable, Reader Parsed.ParserResult, Error JuvixError, NameIdGen] r) => ( Members
'[ HighlightBuilder,
Reader Package,
Reader ModuleTable,
Reader Parsed.ParserResult,
Error JuvixError,
NameIdGen
]
r
) =>
Sem r ScoperResult Sem r ScoperResult
fromParsed = do fromParsed = do
e <- ask e <- ask

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

@ -32,14 +32,14 @@ import Juvix.Prelude
scopeCheck :: scopeCheck ::
(Members '[HighlightBuilder, Error JuvixError, NameIdGen] r) => (Members '[HighlightBuilder, Error JuvixError, NameIdGen] r) =>
EntryPoint -> Package ->
ScopedModuleTable -> ScopedModuleTable ->
Parser.ParserResult -> Parser.ParserResult ->
Sem r ScoperResult Sem r ScoperResult
scopeCheck entry importMap pr = scopeCheck pkg importMap pr =
mapError (JuvixError @ScoperError) $ mapError (JuvixError @ScoperError)
runReader entry $ . runReader pkg
scopeCheck' importMap pr m $ scopeCheck' importMap pr m
where where
m :: Module 'Parsed 'ModuleTop m :: Module 'Parsed 'ModuleTop
m = pr ^. Parser.resultModule m = pr ^. Parser.resultModule
@ -57,7 +57,7 @@ iniScoperState tab =
} }
scopeCheck' :: scopeCheck' ::
(Members '[HighlightBuilder, Error ScoperError, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Error ScoperError, NameIdGen, Reader Package] r) =>
ScopedModuleTable -> ScopedModuleTable ->
Parser.ParserResult -> Parser.ParserResult ->
Module 'Parsed 'ModuleTop -> Module 'Parsed 'ModuleTop ->
@ -69,6 +69,7 @@ scopeCheck' importTab pr m = do
. runState (iniScoperState tab) . runState (iniScoperState tab)
$ checkTopModule m $ checkTopModule m
where where
tab :: InfoTable
tab = computeCombinedInfoTable importTab tab = computeCombinedInfoTable importTab
iniScopeParameters :: ScopeParameters iniScopeParameters :: ScopeParameters
@ -90,9 +91,9 @@ scopeCheck' importTab pr m = do
scopeCheckRepl :: scopeCheckRepl ::
forall r a b. forall r a b.
(Members '[Error JuvixError, NameIdGen, Reader EntryPoint, State Scope, State ScoperState] r) => (Members '[Error JuvixError, NameIdGen, Reader Package, State Scope, State ScoperState] r) =>
( forall r'. ( forall r'.
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader BindingStrategy, Reader EntryPoint] r') => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader BindingStrategy, Reader Package] r') =>
a -> a ->
Sem r' b Sem r' b
) -> ) ->
@ -120,7 +121,7 @@ scopeCheckRepl check importTab tab a = mapError (JuvixError @ScoperError) $ do
-- TODO refactor to have less code duplication -- TODO refactor to have less code duplication
scopeCheckExpressionAtoms :: scopeCheckExpressionAtoms ::
forall r. forall r.
(Members '[Error JuvixError, NameIdGen, Reader EntryPoint, State Scope, State ScoperState] r) => (Members '[Error JuvixError, NameIdGen, Reader Package, State Scope, State ScoperState] r) =>
ScopedModuleTable -> ScopedModuleTable ->
InfoTable -> InfoTable ->
ExpressionAtoms 'Parsed -> ExpressionAtoms 'Parsed ->
@ -129,7 +130,7 @@ scopeCheckExpressionAtoms = scopeCheckRepl checkExpressionAtoms
scopeCheckExpression :: scopeCheckExpression ::
forall r. forall r.
(Members '[Error JuvixError, NameIdGen, Reader EntryPoint, State Scope, State ScoperState] r) => (Members '[Error JuvixError, NameIdGen, Reader Package, State Scope, State ScoperState] r) =>
ScopedModuleTable -> ScopedModuleTable ->
InfoTable -> InfoTable ->
ExpressionAtoms 'Parsed -> ExpressionAtoms 'Parsed ->
@ -138,7 +139,7 @@ scopeCheckExpression = scopeCheckRepl checkParseExpressionAtoms
scopeCheckImport :: scopeCheckImport ::
forall r. forall r.
(Members '[Error JuvixError, NameIdGen, Reader EntryPoint, State Scope, State ScoperState] r) => (Members '[Error JuvixError, NameIdGen, Reader Package, State Scope, State ScoperState] r) =>
ScopedModuleTable -> ScopedModuleTable ->
InfoTable -> InfoTable ->
Import 'Parsed -> Import 'Parsed ->
@ -457,7 +458,7 @@ checkImport ::
Reader InfoTable, Reader InfoTable,
NameIdGen, NameIdGen,
Reader BindingStrategy, Reader BindingStrategy,
Reader EntryPoint Reader Package
] ]
r r
) => ) =>
@ -479,7 +480,7 @@ checkImportPublic ::
NameIdGen, NameIdGen,
HighlightBuilder, HighlightBuilder,
Reader BindingStrategy, Reader BindingStrategy,
Reader EntryPoint Reader Package
] ]
r r
) => ) =>
@ -616,7 +617,7 @@ checkImportNoPublic import_@Import {..} = do
where where
addModuleToScope :: ScopedModule -> Sem r () addModuleToScope :: ScopedModule -> Sem r ()
addModuleToScope smod = do addModuleToScope smod = do
let mpath :: TopModulePath = fromMaybe _importModulePath _importAsName let mpath :: TopModulePathKey = topModulePathKey (fromMaybe _importModulePath _importAsName)
uid :: S.NameId = smod ^. scopedModuleName . S.nameId uid :: S.NameId = smod ^. scopedModuleName . S.nameId
singTbl = HashMap.singleton uid smod singTbl = HashMap.singleton uid smod
modify (over (scopeTopModules . at mpath) (Just . maybe singTbl (HashMap.insert uid smod))) modify (over (scopeTopModules . at mpath) (Just . maybe singTbl (HashMap.insert uid smod)))
@ -678,7 +679,7 @@ lookupSymbolAux modules final = do
tbl <- gets (^. scopeTopModules) tbl <- gets (^. scopeTopModules)
mapM_ output (tbl ^.. at path . _Just . each . to mkModuleEntry) mapM_ output (tbl ^.. at path . _Just . each . to mkModuleEntry)
where where
path = TopModulePath modules final path = topModulePathKey (TopModulePath modules final)
mkModuleEntry :: ScopedModule -> ModuleSymbolEntry mkModuleEntry :: ScopedModule -> ModuleSymbolEntry
mkModuleEntry m = ModuleSymbolEntry (m ^. scopedModuleName) mkModuleEntry m = ModuleSymbolEntry (m ^. scopedModuleName)
@ -728,7 +729,7 @@ lookupQualifiedSymbol sms = do
there :: Sem r' () there :: Sem r' ()
there = mapM_ (uncurry lookInTopModule) allTopPaths there = mapM_ (uncurry lookInTopModule) allTopPaths
where where
allTopPaths :: [(TopModulePath, [Symbol])] allTopPaths :: [(TopModulePathKey, [Symbol])]
allTopPaths = map (first nonEmptyToTopPath) raw allTopPaths = map (first nonEmptyToTopPath) raw
where where
lpath = toList path lpath = toList path
@ -736,9 +737,12 @@ lookupQualifiedSymbol sms = do
raw = raw =
[ (l, r) | i <- [1 .. length path], (Just l, r) <- [first nonEmpty (splitAt i lpath)] [ (l, r) | i <- [1 .. length path], (Just l, r) <- [first nonEmpty (splitAt i lpath)]
] ]
nonEmptyToTopPath :: NonEmpty Symbol -> TopModulePath nonEmptyToTopPath :: NonEmpty Symbol -> TopModulePathKey
nonEmptyToTopPath l = TopModulePath (NonEmpty.init l) (NonEmpty.last l) nonEmptyToTopPath lsym = TopModulePathKey (NonEmpty.init l) (NonEmpty.last l)
lookInTopModule :: TopModulePath -> [Symbol] -> Sem r' () where
l = (^. symbolText) <$> lsym
lookInTopModule :: TopModulePathKey -> [Symbol] -> Sem r' ()
lookInTopModule topPath remaining = do lookInTopModule topPath remaining = do
tbl <- gets (^. scopeTopModules) tbl <- gets (^. scopeTopModules)
sequence_ sequence_
@ -866,7 +870,8 @@ readScopeModule import_ = do
<> "\nAvailable modules:\n " <> "\nAvailable modules:\n "
<> show (HashMap.keys (mods ^. scopeImportedModules)) <> show (HashMap.keys (mods ^. scopeImportedModules))
) )
return (fromMaybe err (mods ^. scopeImportedModules . at (import_ ^. importModulePath))) let path = topModulePathKey (import_ ^. importModulePath)
return (fromMaybe err (mods ^. scopeImportedModules . at path))
checkFixityInfo :: checkFixityInfo ::
forall r. forall r.
@ -895,22 +900,19 @@ checkFixityInfo ParsedFixityInfo {..} = do
_fixityFieldsBraces _fixityFieldsBraces
} }
getModuleId :: forall t r. (SingI t, Member (Reader EntryPoint) r) => ModulePathType 'Parsed t -> Sem r ModuleId getModuleId :: forall r. (Member (Reader Package) r) => TopModulePathKey -> Sem r ModuleId
getModuleId path = do getModuleId path = do
p <- asks (^. entryPointPackage) p <- ask
return return
ModuleId ModuleId
{ _moduleIdPath = { _moduleIdPath = path,
case sing :: SModuleIsTop t of
SModuleLocal -> prettyText path
SModuleTop -> prettyText path,
_moduleIdPackage = p ^. packageName, _moduleIdPackage = p ^. packageName,
_moduleIdPackageVersion = show (p ^. packageVersion) _moduleIdPackageVersion = show (p ^. packageVersion)
} }
checkFixitySyntaxDef :: checkFixitySyntaxDef ::
forall r. forall r.
(Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, State ScoperSyntax, NameIdGen, InfoTableBuilder, Reader InfoTable, Reader EntryPoint] r) => (Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, State ScoperSyntax, NameIdGen, InfoTableBuilder, Reader InfoTable, Reader Package] r) =>
FixitySyntaxDef 'Parsed -> FixitySyntaxDef 'Parsed ->
Sem r (FixitySyntaxDef 'Scoped) Sem r (FixitySyntaxDef 'Scoped)
checkFixitySyntaxDef FixitySyntaxDef {..} = topBindings $ do checkFixitySyntaxDef FixitySyntaxDef {..} = topBindings $ do
@ -1044,7 +1046,7 @@ resolveIteratorSyntaxDef s@IteratorSyntaxDef {..} = do
checkFunctionDef :: checkFunctionDef ::
forall r. forall r.
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint, State ScoperSyntax, Reader BindingStrategy] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package, State ScoperSyntax, Reader BindingStrategy] r) =>
FunctionDef 'Parsed -> FunctionDef 'Parsed ->
Sem r (FunctionDef 'Scoped) Sem r (FunctionDef 'Scoped)
checkFunctionDef FunctionDef {..} = do checkFunctionDef FunctionDef {..} = do
@ -1110,7 +1112,7 @@ checkFunctionDef FunctionDef {..} = do
checkInductiveParameters :: checkInductiveParameters ::
forall r. forall r.
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
InductiveParameters 'Parsed -> InductiveParameters 'Parsed ->
Sem r (InductiveParameters 'Scoped) Sem r (InductiveParameters 'Scoped)
checkInductiveParameters params = do checkInductiveParameters params = do
@ -1126,7 +1128,7 @@ checkInductiveParameters params = do
checkInductiveDef :: checkInductiveDef ::
forall r. forall r.
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint, State ScoperSyntax, Reader BindingStrategy] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package, State ScoperSyntax, Reader BindingStrategy] r) =>
InductiveDef 'Parsed -> InductiveDef 'Parsed ->
Sem r (InductiveDef 'Scoped) Sem r (InductiveDef 'Scoped)
checkInductiveDef InductiveDef {..} = do checkInductiveDef InductiveDef {..} = do
@ -1245,7 +1247,7 @@ localBindings = runReader BindingLocal
checkTopModule :: checkTopModule ::
forall r. forall r.
(Members '[HighlightBuilder, Error ScoperError, Reader ScopeParameters, State ScoperState, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Error ScoperError, Reader ScopeParameters, State ScoperState, Reader InfoTable, NameIdGen, Reader Package] r) =>
Module 'Parsed 'ModuleTop -> Module 'Parsed 'ModuleTop ->
Sem r (Module 'Scoped 'ModuleTop, ScopedModule, Scope) Sem r (Module 'Scoped 'ModuleTop, ScopedModule, Scope)
checkTopModule m@Module {..} = checkedModule checkTopModule m@Module {..} = checkedModule
@ -1286,7 +1288,7 @@ checkTopModule m@Module {..} = checkedModule
registerModuleDoc (path' ^. S.nameId) doc' registerModuleDoc (path' ^. S.nameId) doc'
return (e, body', path', doc') return (e, body', path', doc')
localModules <- getLocalModules e localModules <- getLocalModules e
_moduleId <- getModuleId (path' ^. S.nameConcrete) _moduleId <- getModuleId (topModulePathKey (path' ^. S.nameConcrete))
let md = let md =
Module Module
{ _modulePath = path', { _modulePath = path',
@ -1301,8 +1303,7 @@ checkTopModule m@Module {..} = checkedModule
} }
smd = smd =
ScopedModule ScopedModule
{ _scopedModuleId = _moduleId, { _scopedModulePath = path',
_scopedModulePath = path',
_scopedModuleName = S.topModulePathName path', _scopedModuleName = S.topModulePathName path',
_scopedModuleFilePath = P.getModuleFilePath m, _scopedModuleFilePath = P.getModuleFilePath m,
_scopedModuleExportInfo = e, _scopedModuleExportInfo = e,
@ -1353,7 +1354,7 @@ syntaxBlock m =
checkModuleBody :: checkModuleBody ::
forall r. forall r.
(Members '[HighlightBuilder, InfoTableBuilder, Reader InfoTable, Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, NameIdGen, Reader EntryPoint, Reader BindingStrategy] r) => (Members '[HighlightBuilder, InfoTableBuilder, Reader InfoTable, Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, NameIdGen, Reader Package, Reader BindingStrategy] r) =>
[Statement 'Parsed] -> [Statement 'Parsed] ->
Sem r (ExportInfo, [Statement 'Scoped]) Sem r (ExportInfo, [Statement 'Scoped])
checkModuleBody body = do checkModuleBody body = do
@ -1396,7 +1397,7 @@ checkModuleBody body = do
checkSections :: checkSections ::
forall r. forall r.
(Members '[HighlightBuilder, Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, State ScoperSyntax, Reader EntryPoint] r) => (Members '[HighlightBuilder, Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, State ScoperSyntax, Reader Package] r) =>
StatementSections 'Parsed -> StatementSections 'Parsed ->
Sem r (StatementSections 'Scoped) Sem r (StatementSections 'Scoped)
checkSections sec = topBindings helper checkSections sec = topBindings helper
@ -1578,7 +1579,7 @@ checkSections sec = topBindings helper
defineInductiveModule headConstr i = do defineInductiveModule headConstr i = do
runReader (getLoc (i ^. inductiveName)) genModule runReader (getLoc (i ^. inductiveName)) genModule
where where
genModule :: forall s'. (Members '[Reader Interval, Reader EntryPoint, State Scope] s') => Sem s' (Module 'Parsed 'ModuleLocal) genModule :: forall s'. (Members '[Reader Interval, Reader Package, State Scope] s') => Sem s' (Module 'Parsed 'ModuleLocal)
genModule = do genModule = do
_moduleKw <- G.kw G.kwModule _moduleKw <- G.kw G.kwModule
_moduleKwEnd <- G.kw G.kwEnd _moduleKwEnd <- G.kw G.kwEnd
@ -1694,7 +1695,7 @@ mkSections = \case
StatementOpenModule o -> Right (NonDefinitionOpenModule o) StatementOpenModule o -> Right (NonDefinitionOpenModule o)
reserveLocalModuleSymbol :: reserveLocalModuleSymbol ::
(Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint, Reader BindingStrategy] r) => (Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package, Reader BindingStrategy] r) =>
Symbol -> Symbol ->
Sem r S.Symbol Sem r S.Symbol
reserveLocalModuleSymbol = reserveLocalModuleSymbol =
@ -1712,7 +1713,7 @@ checkLocalModule ::
Reader InfoTable, Reader InfoTable,
NameIdGen, NameIdGen,
Reader BindingStrategy, Reader BindingStrategy,
Reader EntryPoint Reader Package
] ]
r r
) => ) =>
@ -1728,7 +1729,6 @@ checkLocalModule md@Module {..} = do
doc' <- mapM checkJudoc _moduleDoc doc' <- mapM checkJudoc _moduleDoc
return (e, b, doc') return (e, b, doc')
_modulePath' <- reserveLocalModuleSymbol _modulePath _modulePath' <- reserveLocalModuleSymbol _modulePath
_moduleId' <- getModuleId _modulePath
localModules <- getLocalModules moduleExportInfo localModules <- getLocalModules moduleExportInfo
let mid = _modulePath' ^. S.nameId let mid = _modulePath' ^. S.nameId
moduleName = S.unqualifiedSymbol _modulePath' moduleName = S.unqualifiedSymbol _modulePath'
@ -1739,15 +1739,14 @@ checkLocalModule md@Module {..} = do
_moduleDoc = moduleDoc', _moduleDoc = moduleDoc',
_modulePragmas = _modulePragmas, _modulePragmas = _modulePragmas,
_moduleMarkdownInfo = Nothing, _moduleMarkdownInfo = Nothing,
_moduleId = _moduleId', _moduleId = (),
_moduleKw, _moduleKw,
_moduleOrigin, _moduleOrigin,
_moduleKwEnd _moduleKwEnd
} }
smod = smod =
ScopedModule ScopedModule
{ _scopedModuleId = _moduleId', { _scopedModulePath = set nameConcrete (moduleNameToTopModulePath (NameUnqualified _modulePath)) moduleName,
_scopedModulePath = set nameConcrete (moduleNameToTopModulePath (NameUnqualified _modulePath)) moduleName,
_scopedModuleName = moduleName, _scopedModuleName = moduleName,
_scopedModuleFilePath = P.getModuleFilePath md, _scopedModuleFilePath = P.getModuleFilePath md,
_scopedModuleExportInfo = moduleExportInfo, _scopedModuleExportInfo = moduleExportInfo,
@ -1758,7 +1757,7 @@ checkLocalModule md@Module {..} = do
registerName _modulePath' registerName _modulePath'
return m return m
where where
inheritScope :: (Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint, Reader BindingStrategy] r') => Sem r' () inheritScope :: (Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package, Reader BindingStrategy] r') => Sem r' ()
inheritScope = do inheritScope = do
absPath <- (S.<.> _modulePath) <$> gets (^. scopePath) absPath <- (S.<.> _modulePath) <$> gets (^. scopePath)
modify (set scopePath absPath) modify (set scopePath absPath)
@ -2004,7 +2003,7 @@ filterExportInfo pub openModif = alterEntries . filterScope
Nothing -> id Nothing -> id
checkAxiomDef :: checkAxiomDef ::
(Members '[HighlightBuilder, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, Error ScoperError, State Scope, State ScoperState, NameIdGen, State ScoperSyntax, Reader BindingStrategy, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, Error ScoperError, State Scope, State ScoperState, NameIdGen, State ScoperSyntax, Reader BindingStrategy, Reader Package] r) =>
AxiomDef 'Parsed -> AxiomDef 'Parsed ->
Sem r (AxiomDef 'Scoped) Sem r (AxiomDef 'Scoped)
checkAxiomDef AxiomDef {..} = do checkAxiomDef AxiomDef {..} = do
@ -2020,7 +2019,7 @@ entryToSymbol sentry csym = set S.nameConcrete csym (sentry ^. nsEntry)
checkFunction :: checkFunction ::
forall r. forall r.
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
Function 'Parsed -> Function 'Parsed ->
Sem r (Function 'Scoped) Sem r (Function 'Scoped)
checkFunction f = do checkFunction f = do
@ -2039,7 +2038,7 @@ checkFunction f = do
-- | for now functions defined in let clauses cannot be infix operators -- | for now functions defined in let clauses cannot be infix operators
checkLetStatements :: checkLetStatements ::
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
NonEmpty (LetStatement 'Parsed) -> NonEmpty (LetStatement 'Parsed) ->
Sem r (NonEmpty (LetStatement 'Scoped)) Sem r (NonEmpty (LetStatement 'Scoped))
checkLetStatements = checkLetStatements =
@ -2157,7 +2156,7 @@ checkListPattern l = do
checkList :: checkList ::
forall r. forall r.
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
List 'Parsed -> List 'Parsed ->
Sem r (List 'Scoped) Sem r (List 'Scoped)
checkList l = do checkList l = do
@ -2168,7 +2167,7 @@ checkList l = do
checkLet :: checkLet ::
forall r. forall r.
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
Let 'Parsed -> Let 'Parsed ->
Sem r (Let 'Scoped) Sem r (Let 'Scoped)
checkLet Let {..} = checkLet Let {..} =
@ -2185,7 +2184,7 @@ checkLet Let {..} =
checkCaseBranch :: checkCaseBranch ::
forall r. forall r.
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
CaseBranch 'Parsed -> CaseBranch 'Parsed ->
Sem r (CaseBranch 'Scoped) Sem r (CaseBranch 'Scoped)
checkCaseBranch CaseBranch {..} = withLocalScope $ do checkCaseBranch CaseBranch {..} = withLocalScope $ do
@ -2199,7 +2198,7 @@ checkCaseBranch CaseBranch {..} = withLocalScope $ do
} }
checkCase :: checkCase ::
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
Case 'Parsed -> Case 'Parsed ->
Sem r (Case 'Scoped) Sem r (Case 'Scoped)
checkCase Case {..} = do checkCase Case {..} = do
@ -2215,7 +2214,7 @@ checkCase Case {..} = do
checkIfBranch :: checkIfBranch ::
forall r. forall r.
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
IfBranch 'Parsed -> IfBranch 'Parsed ->
Sem r (IfBranch 'Scoped) Sem r (IfBranch 'Scoped)
checkIfBranch IfBranch {..} = withLocalScope $ do checkIfBranch IfBranch {..} = withLocalScope $ do
@ -2230,7 +2229,7 @@ checkIfBranch IfBranch {..} = withLocalScope $ do
checkIfBranchElse :: checkIfBranchElse ::
forall r. forall r.
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
IfBranchElse 'Parsed -> IfBranchElse 'Parsed ->
Sem r (IfBranchElse 'Scoped) Sem r (IfBranchElse 'Scoped)
checkIfBranchElse IfBranchElse {..} = withLocalScope $ do checkIfBranchElse IfBranchElse {..} = withLocalScope $ do
@ -2242,7 +2241,7 @@ checkIfBranchElse IfBranchElse {..} = withLocalScope $ do
} }
checkIf :: checkIf ::
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
If 'Parsed -> If 'Parsed ->
Sem r (If 'Scoped) Sem r (If 'Scoped)
checkIf If {..} = do checkIf If {..} = do
@ -2256,7 +2255,7 @@ checkIf If {..} = do
} }
checkLambda :: checkLambda ::
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
Lambda 'Parsed -> Lambda 'Parsed ->
Sem r (Lambda 'Scoped) Sem r (Lambda 'Scoped)
checkLambda Lambda {..} = do checkLambda Lambda {..} = do
@ -2269,7 +2268,7 @@ checkLambda Lambda {..} = do
} }
checkLambdaClause :: checkLambdaClause ::
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
LambdaClause 'Parsed -> LambdaClause 'Parsed ->
Sem r (LambdaClause 'Scoped) Sem r (LambdaClause 'Scoped)
checkLambdaClause LambdaClause {..} = withLocalScope $ do checkLambdaClause LambdaClause {..} = withLocalScope $ do
@ -2458,7 +2457,7 @@ checkScopedIden ::
checkScopedIden n = checkName n >>= entryToScopedIden n checkScopedIden n = checkName n >>= entryToScopedIden n
checkExpressionAtom :: checkExpressionAtom ::
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
ExpressionAtom 'Parsed -> ExpressionAtom 'Parsed ->
Sem r (NonEmpty (ExpressionAtom 'Scoped)) Sem r (NonEmpty (ExpressionAtom 'Scoped))
checkExpressionAtom e = case e of checkExpressionAtom e = case e of
@ -2482,7 +2481,7 @@ checkExpressionAtom e = case e of
AtomNamedApplicationNew i -> pure . AtomNamedApplicationNew <$> checkNamedApplicationNew i AtomNamedApplicationNew i -> pure . AtomNamedApplicationNew <$> checkNamedApplicationNew i
AtomRecordUpdate i -> pure . AtomRecordUpdate <$> checkRecordUpdate i AtomRecordUpdate i -> pure . AtomRecordUpdate <$> checkRecordUpdate i
checkNamedApplicationNew :: forall r. (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => NamedApplicationNew 'Parsed -> Sem r (NamedApplicationNew 'Scoped) checkNamedApplicationNew :: forall r. (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => NamedApplicationNew 'Parsed -> Sem r (NamedApplicationNew 'Scoped)
checkNamedApplicationNew napp = do checkNamedApplicationNew napp = do
let nargs = napp ^. namedApplicationNewArguments let nargs = napp ^. namedApplicationNewArguments
aname <- checkScopedIden (napp ^. namedApplicationNewName) aname <- checkScopedIden (napp ^. namedApplicationNewName)
@ -2505,7 +2504,7 @@ checkNamedApplicationNew napp = do
} }
checkNamedArgumentNew :: checkNamedArgumentNew ::
(Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
HashSet Symbol -> HashSet Symbol ->
NamedArgumentNew 'Parsed -> NamedArgumentNew 'Parsed ->
Sem r (NamedArgumentNew 'Scoped) Sem r (NamedArgumentNew 'Scoped)
@ -2519,7 +2518,7 @@ checkNamedArgumentNew snames NamedArgumentNew {..} = do
{ _namedArgumentNewFunDef = def { _namedArgumentNewFunDef = def
} }
checkRecordUpdate :: forall r. (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => RecordUpdate 'Parsed -> Sem r (RecordUpdate 'Scoped) checkRecordUpdate :: forall r. (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => RecordUpdate 'Parsed -> Sem r (RecordUpdate 'Scoped)
checkRecordUpdate RecordUpdate {..} = do checkRecordUpdate RecordUpdate {..} = do
tyName' <- getNameOfKind KNameInductive _recordUpdateTypeName tyName' <- getNameOfKind KNameInductive _recordUpdateTypeName
info <- getRecordInfo tyName' info <- getRecordInfo tyName'
@ -2543,7 +2542,7 @@ checkRecordUpdate RecordUpdate {..} = do
} }
checkUpdateField :: checkUpdateField ::
(Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
RecordNameSignature 'Parsed -> RecordNameSignature 'Parsed ->
RecordUpdateField 'Parsed -> RecordUpdateField 'Parsed ->
Sem r (RecordUpdateField 'Scoped) Sem r (RecordUpdateField 'Scoped)
@ -2563,7 +2562,7 @@ checkUpdateField sig f = do
checkNamedApplication :: checkNamedApplication ::
forall r. forall r.
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
NamedApplication 'Parsed -> NamedApplication 'Parsed ->
Sem r (NamedApplication 'Scoped) Sem r (NamedApplication 'Scoped)
checkNamedApplication napp = do checkNamedApplication napp = do
@ -2617,7 +2616,7 @@ getNameSignature s = do
lookupNameSignature s' = gets (^. scoperScopedSignatures . at s') lookupNameSignature s' = gets (^. scoperScopedSignatures . at s')
checkIterator :: checkIterator ::
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
Iterator 'Parsed -> Iterator 'Parsed ->
Sem r (Iterator 'Scoped) Sem r (Iterator 'Scoped)
checkIterator iter = do checkIterator iter = do
@ -2660,7 +2659,7 @@ checkIterator iter = do
return Iterator {..} return Iterator {..}
checkInitializer :: checkInitializer ::
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
Initializer 'Parsed -> Initializer 'Parsed ->
Sem r (Initializer 'Scoped) Sem r (Initializer 'Scoped)
checkInitializer ini = do checkInitializer ini = do
@ -2673,7 +2672,7 @@ checkInitializer ini = do
} }
checkRange :: checkRange ::
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
Range 'Parsed -> Range 'Parsed ->
Sem r (Range 'Scoped) Sem r (Range 'Scoped)
checkRange rng = do checkRange rng = do
@ -2698,7 +2697,7 @@ checkHole h = do
} }
checkParens :: checkParens ::
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
ExpressionAtoms 'Parsed -> ExpressionAtoms 'Parsed ->
Sem r Expression Sem r Expression
checkParens e@(ExpressionAtoms as _) = case as of checkParens e@(ExpressionAtoms as _) = case as of
@ -2714,13 +2713,13 @@ checkParens e@(ExpressionAtoms as _) = case as of
checkExpressionAtoms :: checkExpressionAtoms ::
forall r. forall r.
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
ExpressionAtoms 'Parsed -> ExpressionAtoms 'Parsed ->
Sem r (ExpressionAtoms 'Scoped) Sem r (ExpressionAtoms 'Scoped)
checkExpressionAtoms (ExpressionAtoms l i) = (`ExpressionAtoms` i) <$> sconcatMap checkExpressionAtom l checkExpressionAtoms (ExpressionAtoms l i) = (`ExpressionAtoms` i) <$> sconcatMap checkExpressionAtom l
checkJudoc :: checkJudoc ::
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
Judoc 'Parsed -> Judoc 'Parsed ->
Sem r (Judoc 'Scoped) Sem r (Judoc 'Scoped)
checkJudoc (Judoc groups) = checkJudoc (Judoc groups) =
@ -2729,7 +2728,7 @@ checkJudoc (Judoc groups) =
$ Judoc <$> mapM checkJudocGroup groups $ Judoc <$> mapM checkJudocGroup groups
checkJudocGroup :: checkJudocGroup ::
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
JudocGroup 'Parsed -> JudocGroup 'Parsed ->
Sem r (JudocGroup 'Scoped) Sem r (JudocGroup 'Scoped)
checkJudocGroup = \case checkJudocGroup = \case
@ -2737,26 +2736,26 @@ checkJudocGroup = \case
JudocGroupLines l -> JudocGroupLines <$> mapM checkJudocBlock l JudocGroupLines l -> JudocGroupLines <$> mapM checkJudocBlock l
checkJudocBlock :: checkJudocBlock ::
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
JudocBlock 'Parsed -> JudocBlock 'Parsed ->
Sem r (JudocBlock 'Scoped) Sem r (JudocBlock 'Scoped)
checkJudocBlock = \case checkJudocBlock = \case
JudocLines l -> JudocLines <$> mapM checkJudocLine l JudocLines l -> JudocLines <$> mapM checkJudocLine l
checkJudocBlockParagraph :: checkJudocBlockParagraph ::
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
JudocBlockParagraph 'Parsed -> JudocBlockParagraph 'Parsed ->
Sem r (JudocBlockParagraph 'Scoped) Sem r (JudocBlockParagraph 'Scoped)
checkJudocBlockParagraph = traverseOf judocBlockParagraphBlocks (mapM checkJudocBlock) checkJudocBlockParagraph = traverseOf judocBlockParagraphBlocks (mapM checkJudocBlock)
checkJudocLine :: checkJudocLine ::
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
JudocLine 'Parsed -> JudocLine 'Parsed ->
Sem r (JudocLine 'Scoped) Sem r (JudocLine 'Scoped)
checkJudocLine (JudocLine delim atoms) = JudocLine delim <$> mapM (mapM checkJudocAtom) atoms checkJudocLine (JudocLine delim atoms) = JudocLine delim <$> mapM (mapM checkJudocAtom) atoms
checkJudocAtom :: checkJudocAtom ::
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
JudocAtom 'Parsed -> JudocAtom 'Parsed ->
Sem r (JudocAtom 'Scoped) Sem r (JudocAtom 'Scoped)
checkJudocAtom = \case checkJudocAtom = \case
@ -2765,7 +2764,7 @@ checkJudocAtom = \case
checkParseExpressionAtoms :: checkParseExpressionAtoms ::
forall r. forall r.
(Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint] r) => (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) =>
ExpressionAtoms 'Parsed -> ExpressionAtoms 'Parsed ->
Sem r Expression Sem r Expression
checkParseExpressionAtoms = checkExpressionAtoms >=> parseExpressionAtoms checkParseExpressionAtoms = checkExpressionAtoms >=> parseExpressionAtoms
@ -2777,7 +2776,7 @@ checkParsePatternAtom ::
checkParsePatternAtom = checkPatternAtom >=> parsePatternAtom checkParsePatternAtom = checkPatternAtom >=> parsePatternAtom
checkSyntaxDef :: checkSyntaxDef ::
(Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader EntryPoint, State ScoperSyntax] r) => (Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package, State ScoperSyntax] r) =>
SyntaxDef 'Parsed -> SyntaxDef 'Parsed ->
Sem r (SyntaxDef 'Scoped) Sem r (SyntaxDef 'Scoped)
checkSyntaxDef = \case checkSyntaxDef = \case

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

@ -3,7 +3,6 @@ module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Cont
import Juvix.Compiler.Concrete.Data.Scope import Juvix.Compiler.Concrete.Data.Scope
import Juvix.Compiler.Concrete.Language import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context qualified as Parsed import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context qualified as Parsed
import Juvix.Compiler.Concrete.Translation.FromSource.Data.ParserState qualified as Parsed
import Juvix.Compiler.Store.Scoped.Language import Juvix.Compiler.Store.Scoped.Language
import Juvix.Prelude import Juvix.Prelude
@ -22,4 +21,4 @@ mainModule :: Lens' ScoperResult (Module 'Scoped 'ModuleTop)
mainModule = resultModule mainModule = resultModule
getScoperResultComments :: ScoperResult -> Comments getScoperResultComments :: ScoperResult -> Comments
getScoperResultComments sr = mkComments $ sr ^. resultParserResult . Parsed.resultParserState . Parsed.parserStateComments getScoperResultComments = Parsed.getParserResultComments . (^. resultParserResult)

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

@ -24,7 +24,6 @@ import Juvix.Compiler.Concrete.Translation.FromSource.Lexer hiding
) )
import Juvix.Compiler.Concrete.Translation.FromSource.ParserResultBuilder import Juvix.Compiler.Concrete.Translation.FromSource.ParserResultBuilder
import Juvix.Compiler.Concrete.Translation.FromSource.TopModuleNameChecker import Juvix.Compiler.Concrete.Translation.FromSource.TopModuleNameChecker
import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Data.Yaml import Juvix.Data.Yaml
import Juvix.Extra.Paths import Juvix.Extra.Paths
import Juvix.Extra.Strings qualified as Str import Juvix.Extra.Strings qualified as Str
@ -48,20 +47,18 @@ type PragmasStash = State (Maybe ParsedPragmas)
fromSource :: fromSource ::
(Members '[HighlightBuilder, TopModuleNameChecker, Files, Error JuvixError] r) => (Members '[HighlightBuilder, TopModuleNameChecker, Files, Error JuvixError] r) =>
EntryPoint -> Maybe Text ->
Maybe (Path Abs File) ->
Sem r ParserResult Sem r ParserResult
fromSource e = mapError (JuvixError @ParserError) $ do fromSource mstdin minputfile = mapError (JuvixError @ParserError) $ do
(_resultParserState, _resultModule) <- (_resultParserState, _resultModule) <- runParserResultBuilder mempty getParsedModuleTop
runParserResultBuilder mempty
. evalTopNameIdGen defaultModuleId
$ getParsedModuleTop
return ParserResult {..} return ParserResult {..}
where where
getParsedModuleTop :: getParsedModuleTop ::
forall r. forall r.
(Members '[Files, TopModuleNameChecker, Error ParserError, ParserResultBuilder] r) => (Members '[Files, TopModuleNameChecker, Error ParserError, ParserResultBuilder] r) =>
Sem r (Module 'Parsed 'ModuleTop) Sem r (Module 'Parsed 'ModuleTop)
getParsedModuleTop = case (e ^. entryPointStdin, e ^. entryPointModulePath) of getParsedModuleTop = case (mstdin, minputfile) of
(Nothing, Nothing) -> throw $ ErrStdinOrFile StdinOrFileError (Nothing, Nothing) -> throw $ ErrStdinOrFile StdinOrFileError
(Just txt, Just x) -> (Just txt, Just x) ->
runModuleParser x txt >>= \case runModuleParser x txt >>= \case
@ -87,8 +84,8 @@ fromSource e = mapError (JuvixError @ParserError) $ do
where where
getFileContents :: Path Abs File -> Sem r Text getFileContents :: Path Abs File -> Sem r Text
getFileContents fp getFileContents fp
| Just fp == e ^. entryPointModulePath, | Just fp == minputfile,
Just txt <- e ^. entryPointStdin = Just txt <- mstdin =
return txt return txt
| otherwise = readFile' fp | otherwise = readFile' fp

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

@ -10,3 +10,6 @@ data ParserResult = ParserResult
} }
makeLenses ''ParserResult makeLenses ''ParserResult
getParserResultComments :: ParserResult -> Comments
getParserResultComments sr = mkComments $ sr ^. resultParserState . parserStateComments

12
src/Juvix/Compiler/Internal/Translation/FromConcrete.hs
View File

@ -208,13 +208,14 @@ traverseM' ::
traverseM' f x = sequence <$> traverse f x traverseM' f x = sequence <$> traverse f x
toPreModule :: toPreModule ::
forall r t. forall r.
(SingI t, Members '[Reader EntryPoint, Reader DefaultArgsStack, Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, State ConstructorInfos, Reader S.InfoTable] r) => (Members '[Reader EntryPoint, Reader DefaultArgsStack, Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, State ConstructorInfos, Reader S.InfoTable] r) =>
Module 'Scoped t -> Module 'Scoped 'ModuleTop ->
Sem r Internal.PreModule Sem r Internal.PreModule
toPreModule Module {..} = do toPreModule Module {..} = do
pragmas' <- goPragmas _modulePragmas pragmas' <- goPragmas _modulePragmas
body' <- local (const pragmas') (goModuleBody _moduleBody) body' <- local (const pragmas') (goModuleBody _moduleBody)
let name' = goTopModulePath _modulePath
return return
Internal.Module Internal.Module
{ _moduleName = name', { _moduleName = name',
@ -222,11 +223,6 @@ toPreModule Module {..} = do
_modulePragmas = pragmas', _modulePragmas = pragmas',
_moduleId _moduleId
} }
where
name' :: Internal.Name
name' = case sing :: SModuleIsTop t of
SModuleTop -> goTopModulePath _modulePath
SModuleLocal -> goSymbol _modulePath
goTopModulePath :: S.TopModulePath -> Internal.Name goTopModulePath :: S.TopModulePath -> Internal.Name
goTopModulePath p = goSymbolPretty (prettyText p) (S.topModulePathSymbol p) goTopModulePath p = goSymbolPretty (prettyText p) (S.topModulePathSymbol p)

18
src/Juvix/Compiler/Pipeline.hs
View File

@ -80,6 +80,7 @@ type PipelineLocalEff =
Error JuvixError, Error JuvixError,
HighlightBuilder, HighlightBuilder,
Internet, Internet,
Reader NumThreads,
Concurrent Concurrent
] ]
@ -101,7 +102,9 @@ makeLenses ''PipelineOptions
upToParsing :: upToParsing ::
(Members '[HighlightBuilder, TopModuleNameChecker, Reader EntryPoint, Error JuvixError, Files] r) => (Members '[HighlightBuilder, TopModuleNameChecker, Reader EntryPoint, Error JuvixError, Files] r) =>
Sem r Parser.ParserResult Sem r Parser.ParserResult
upToParsing = ask >>= Parser.fromSource upToParsing = do
e <- ask
Parser.fromSource (e ^. entryPointStdin) (e ^. entryPointModulePath)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Workflows from parsed source -- Workflows from parsed source
@ -112,15 +115,24 @@ upToParsedSource ::
Sem r Parser.ParserResult Sem r Parser.ParserResult
upToParsedSource = ask upToParsedSource = ask
upToScoping :: upToScopingEntry ::
(Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Error JuvixError, NameIdGen] r) => (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Error JuvixError, NameIdGen] r) =>
Sem r Scoper.ScoperResult Sem r Scoper.ScoperResult
upToScopingEntry = do
pkg <- asks (^. entryPointPackage)
runReader pkg (upToScoping)
upToScoping ::
(Members '[HighlightBuilder, Reader Parser.ParserResult, Reader Package, Reader Store.ModuleTable, Error JuvixError, NameIdGen] r) =>
Sem r Scoper.ScoperResult
upToScoping = Scoper.fromParsed upToScoping = Scoper.fromParsed
upToInternal :: upToInternal ::
(Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Error JuvixError, NameIdGen, Termination] r) => (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Error JuvixError, NameIdGen, Termination] r) =>
Sem r Internal.InternalResult Sem r Internal.InternalResult
upToInternal = upToScoping >>= Internal.fromConcrete upToInternal = do
pkg <- asks (^. entryPointPackage)
runReader pkg upToScoping >>= Internal.fromConcrete
upToInternalTyped :: upToInternalTyped ::
(Members '[HighlightBuilder, Reader Parser.ParserResult, Error JuvixError, Reader EntryPoint, Reader Store.ModuleTable, NameIdGen] r) => (Members '[HighlightBuilder, Reader Parser.ParserResult, Error JuvixError, Reader EntryPoint, Reader Store.ModuleTable, NameIdGen] r) =>

41
src/Juvix/Compiler/Pipeline/Driver.hs
View File

@ -99,7 +99,7 @@ processModuleCacheMiss entryIx = do
| info ^. Store.moduleInfoSHA256 == sha256 | info ^. Store.moduleInfoSHA256 == sha256
&& info ^. Store.moduleInfoOptions == opts && info ^. Store.moduleInfoOptions == opts
&& info ^. Store.moduleInfoFieldSize == entry ^. entryPointFieldSize -> do && info ^. Store.moduleInfoFieldSize == entry ^. entryPointFieldSize -> do
CompileResult {..} <- runReader entry ((processImports (info ^. Store.moduleInfoImports))) CompileResult {..} <- runReader entry (processImports (info ^. Store.moduleInfoImports))
if if
| _compileResultChanged -> | _compileResultChanged ->
recompile sha256 absPath recompile sha256 absPath
@ -140,24 +140,26 @@ processRecursiveUpToTyped ::
Sem r (InternalTypedResult, [InternalTypedResult]) Sem r (InternalTypedResult, [InternalTypedResult])
processRecursiveUpToTyped = do processRecursiveUpToTyped = do
entry <- ask entry <- ask
PipelineResult res mtab _ <- processFileUpToParsing entry PipelineResult {..} <- processFileUpToParsing entry
let imports = HashMap.keys (mtab ^. Store.moduleTable) let imports = HashMap.keys (_pipelineResultImports ^. Store.moduleTable)
ms <- forM imports (`withPathFile` goImport) ms <- forM imports $ \imp ->
mid <- getModuleId (res ^. Parser.resultModule . modulePath) withPathFile imp goImport
let pkg = entry ^. entryPointPackage
mid <- runReader pkg (getModuleId (_pipelineResult ^. Parser.resultModule . modulePath . to topModulePathKey))
a <- a <-
evalTopNameIdGen mid evalTopNameIdGen mid
. runReader mtab . runReader _pipelineResultImports
. runReader res . runReader _pipelineResult
$ upToInternalTyped $ upToInternalTyped
return (a, ms) return (a, ms)
where where
goImport :: Path Abs File -> Sem r InternalTypedResult goImport :: ImportNode -> Sem r InternalTypedResult
goImport path = do goImport node = do
entry <- ask entry <- ask
let entry' = let entry' =
entry entry
{ _entryPointStdin = Nothing, { _entryPointStdin = Nothing,
_entryPointModulePath = Just path _entryPointModulePath = Just (node ^. importNodeAbsFile)
} }
(^. pipelineResult) <$> runReader entry' (processFileUpTo upToInternalTyped) (^. pipelineResult) <$> runReader entry' (processFileUpTo upToInternalTyped)
@ -166,18 +168,17 @@ processImport ::
(Members '[ModuleInfoCache, Reader EntryPoint, Error JuvixError, Files, PathResolver] r) => (Members '[ModuleInfoCache, Reader EntryPoint, Error JuvixError, Files, PathResolver] r) =>
TopModulePath -> TopModulePath ->
Sem r (PipelineResult Store.ModuleInfo) Sem r (PipelineResult Store.ModuleInfo)
processImport p = do processImport p = withPathFile p getCachedImport
withPathFile p getCachedImport
where where
getCachedImport :: Path Abs File -> Sem r (PipelineResult Store.ModuleInfo) getCachedImport :: ImportNode -> Sem r (PipelineResult Store.ModuleInfo)
getCachedImport file = do getCachedImport node = do
b <- supportsParallel b <- supportsParallel
root <- resolverRoot eix <- mkEntryIndex node
if if
| b -> do | b -> do
res <- mkEntryIndex root file >>= cacheGetResult res <- cacheGetResult eix
return (res ^. cacheResult) return (res ^. cacheResult)
| otherwise -> mkEntryIndex root file >>= processModule | otherwise -> processModule eix
processFileUpToParsing :: processFileUpToParsing ::
forall r. forall r.
@ -203,7 +204,8 @@ processFileUpTo ::
processFileUpTo a = do processFileUpTo a = do
entry <- ask entry <- ask
res <- processFileUpToParsing entry res <- processFileUpToParsing entry
mid <- getModuleId (res ^. pipelineResult . Parser.resultModule . modulePath) let pkg = entry ^. entryPointPackage
mid <- runReader pkg (getModuleId (res ^. pipelineResult . Parser.resultModule . modulePath . to topModulePathKey))
a' <- a' <-
evalTopNameIdGen mid evalTopNameIdGen mid
. runReader (res ^. pipelineResultImports) . runReader (res ^. pipelineResultImports)
@ -257,7 +259,8 @@ processFileToStoredCore ::
Sem r (PipelineResult Core.CoreResult) Sem r (PipelineResult Core.CoreResult)
processFileToStoredCore entry = ignoreHighlightBuilder . runReader entry $ do processFileToStoredCore entry = ignoreHighlightBuilder . runReader entry $ do
res <- processFileUpToParsing entry res <- processFileUpToParsing entry
mid <- getModuleId (res ^. pipelineResult . Parser.resultModule . modulePath) let pkg = entry ^. entryPointPackage
mid <- runReader pkg (getModuleId (res ^. pipelineResult . Parser.resultModule . modulePath . to topModulePathKey))
r <- r <-
evalTopNameIdGen mid evalTopNameIdGen mid
. runReader (res ^. pipelineResultImports) . runReader (res ^. pipelineResultImports)

81
src/Juvix/Compiler/Pipeline/DriverParallel.hs
View File

@ -1,5 +1,6 @@
module Juvix.Compiler.Pipeline.DriverParallel module Juvix.Compiler.Pipeline.DriverParallel
( compileInParallel, ( compileInParallel,
compileInParallel_,
ModuleInfoCache, ModuleInfoCache,
evalModuleInfoCache, evalModuleInfoCache,
module Parallel.ProgressLog, module Parallel.ProgressLog,
@ -29,13 +30,13 @@ data CompileResult = CompileResult
makeLenses ''CompileResult makeLenses ''CompileResult
type NodeId = Path Abs File
type Node = EntryIndex type Node = EntryIndex
type CompileProof = PipelineResult Store.ModuleInfo mkNodesIndex ::
forall r.
mkNodesIndex :: forall r. (Members '[Reader EntryPoint] r) => ImportTree -> Sem r (NodesIndex NodeId Node) (Members '[Reader EntryPoint] r) =>
ImportTree ->
Sem r (NodesIndex ImportNode Node)
mkNodesIndex tree = mkNodesIndex tree =
NodesIndex NodesIndex
. hashMap . hashMap
@ -44,29 +45,47 @@ mkNodesIndex tree =
| fromNode <- HashMap.keys (tree ^. importTree) | fromNode <- HashMap.keys (tree ^. importTree)
] ]
where where
mkAssoc :: ImportNode -> Sem r (Path Abs File, EntryIndex) mkAssoc :: ImportNode -> Sem r (ImportNode, EntryIndex)
mkAssoc p = do mkAssoc p = do
let abspath = p ^. importNodeAbsFile i <- mkEntryIndex p
i <- mkEntryIndex (p ^. importNodePackageRoot) abspath return (p, i)
return (abspath, i)
mkDependencies :: ImportTree -> Dependencies NodeId mkDependencies :: ImportTree -> Dependencies ImportNode
mkDependencies tree = mkDependencies tree =
Dependencies Dependencies
{ _dependenciesTable = helper (tree ^. importTree), { _dependenciesTable = tree ^. importTree,
_dependenciesTableReverse = helper (tree ^. importTreeReverse) _dependenciesTableReverse = tree ^. importTreeReverse
} }
where
helper :: HashMap ImportNode (HashSet ImportNode) -> HashMap NodeId (HashSet NodeId)
helper m = hashMap [(toPath k, hashSet (toPath <$> toList v)) | (k, v) <- HashMap.toList m]
toPath :: ImportNode -> Path Abs File getNodePath :: Node -> ImportNode
toPath = (^. importNodeAbsFile) getNodePath = (^. entryIxImportNode)
getNodeName :: Node -> Text getNodeName :: Node -> Text
getNodeName = toFilePath . fromJust . (^. entryIxEntry . entryPointModulePath) getNodeName = toFilePath . (^. importNodeAbsFile) . getNodePath
-- | Fills the cache in parallel compileInParallel_ ::
forall r.
( Members
'[ Concurrent,
ProgressLog,
IOE,
ModuleInfoCache,
JvoCache,
TaggedLock,
Files,
TopModuleNameChecker,
Error JuvixError,
Reader EntryPoint,
PathResolver,
Reader NumThreads,
Reader ImportTree
]
r
) =>
Sem r ()
compileInParallel_ = void compileInParallel
-- | Compiles the whole project in parallel (i.e. all modules in the ImportTree).
compileInParallel :: compileInParallel ::
forall r. forall r.
( Members ( Members
@ -81,20 +100,19 @@ compileInParallel ::
Error JuvixError, Error JuvixError,
Reader EntryPoint, Reader EntryPoint,
PathResolver, PathResolver,
Reader NumThreads,
Reader ImportTree Reader ImportTree
] ]
r r
) => ) =>
NumThreads -> Sem r (HashMap ImportNode (PipelineResult Store.ModuleInfo))
EntryIndex -> compileInParallel = do
Sem r ()
compileInParallel nj _entry = do
-- At the moment we compile everything, so the EntryIndex is ignored, but in -- At the moment we compile everything, so the EntryIndex is ignored, but in
-- principle we could only compile what is reachable from the given EntryIndex -- principle we could only compile what is reachable from the given EntryIndex
t <- ask t <- ask
idx <- mkNodesIndex t idx <- mkNodesIndex t
numWorkers <- numThreads nj numWorkers <- ask >>= numThreads
let args :: CompileArgs r NodeId Node CompileProof let args :: CompileArgs r ImportNode Node (PipelineResult Store.ModuleInfo)
args = args =
CompileArgs CompileArgs
{ _compileArgsNodesIndex = idx, { _compileArgsNodesIndex = idx,
@ -104,11 +122,14 @@ compileInParallel nj _entry = do
_compileArgsNumWorkers = numWorkers, _compileArgsNumWorkers = numWorkers,
_compileArgsCompileNode = compileNode _compileArgsCompileNode = compileNode
} }
void (compile args) compile args
compileNode :: (Members '[ModuleInfoCache, PathResolver] r) => EntryIndex -> Sem r CompileProof compileNode ::
(Members '[ModuleInfoCache, PathResolver] r) =>
EntryIndex ->
Sem r (PipelineResult Store.ModuleInfo)
compileNode e = compileNode e =
withResolverRoot (e ^. entryIxResolverRoot) withResolverRoot (e ^. entryIxImportNode . importNodePackageRoot)
. fmap force . fmap force
$ processModule e $ processModule e
@ -139,11 +160,11 @@ evalModuleInfoCache ::
Error JuvixError, Error JuvixError,
PathResolver, PathResolver,
Reader ImportScanStrategy, Reader ImportScanStrategy,
Reader NumThreads,
Files Files
] ]
r r
) => ) =>
NumThreads ->
Sem (ModuleInfoCache ': JvoCache ': r) a -> Sem (ModuleInfoCache ': JvoCache ': r) a ->
Sem r a Sem r a
evalModuleInfoCache nj = Driver.evalModuleInfoCacheSetup (compileInParallel nj) evalModuleInfoCache = Driver.evalModuleInfoCacheSetup (const (compileInParallel_))

4
src/Juvix/Compiler/Pipeline/EntryPoint.hs
View File

@ -53,10 +53,10 @@ getEntryPointTarget e = fromMaybe defaultTarget (e ^. entryPointTarget)
-- TODO is having a default target a good idea? -- TODO is having a default target a good idea?
defaultTarget = TargetCore defaultTarget = TargetCore
defaultEntryPoint :: Package -> Root -> Path Abs File -> EntryPoint defaultEntryPoint :: Package -> Root -> Maybe (Path Abs File) -> EntryPoint
defaultEntryPoint pkg root mainFile = defaultEntryPoint pkg root mainFile =
(defaultEntryPointNoFile pkg root) (defaultEntryPointNoFile pkg root)
{ _entryPointModulePath = pure mainFile { _entryPointModulePath = mainFile
} }
defaultEntryPointNoFile :: Package -> Root -> EntryPoint defaultEntryPointNoFile :: Package -> Root -> EntryPoint

2
src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs
View File

@ -9,7 +9,7 @@ defaultEntryPointIO :: (Members '[EmbedIO, TaggedLock, EmbedIO] r) => Path Abs D
defaultEntryPointIO cwd mainFile = do defaultEntryPointIO cwd mainFile = do
root <- findRootAndChangeDir (Just (parent mainFile)) Nothing cwd root <- findRootAndChangeDir (Just (parent mainFile)) Nothing cwd
pkg <- readPackageRootIO root pkg <- readPackageRootIO root
return (defaultEntryPoint pkg root mainFile) return (defaultEntryPoint pkg root (Just mainFile))
defaultEntryPointNoFileIO :: (Members '[EmbedIO, TaggedLock, EmbedIO] r) => Path Abs Dir -> Sem r EntryPoint defaultEntryPointNoFileIO :: (Members '[EmbedIO, TaggedLock, EmbedIO] r) => Path Abs Dir -> Sem r EntryPoint
defaultEntryPointNoFileIO cwd = do defaultEntryPointNoFileIO cwd = do

5
src/Juvix/Compiler/Pipeline/JvoCache.hs
View File

@ -1,5 +1,6 @@
module Juvix.Compiler.Pipeline.JvoCache where module Juvix.Compiler.Pipeline.JvoCache where
import Juvix.Compiler.Pipeline.Loader.PathResolver.ImportTree.ImportNode
import Juvix.Compiler.Store.Language qualified as Store import Juvix.Compiler.Store.Language qualified as Store
import Juvix.Extra.Serialize qualified as Serialize import Juvix.Extra.Serialize qualified as Serialize
import Juvix.Prelude import Juvix.Prelude
@ -10,8 +11,8 @@ evalJvoCache :: (Members '[TaggedLock, Files] r) => Sem (JvoCache ': r) a -> Sem
evalJvoCache = evalCacheEmpty Serialize.loadFromFile evalJvoCache = evalCacheEmpty Serialize.loadFromFile
-- | Used to fill the cache in parallel -- | Used to fill the cache in parallel
preLoadFromFile :: (Members '[JvoCache] r) => Path Abs File -> Sem r () preLoadFromFile :: (Members '[JvoCache] r) => ImportNode -> Sem r ()
preLoadFromFile = void . fmap force . cacheGetResult @(Path Abs File) @(Maybe Store.ModuleInfo) preLoadFromFile = void . fmap force . cacheGetResult @(Path Abs File) @(Maybe Store.ModuleInfo) . (^. importNodeAbsFile)
loadFromFile :: (Members '[JvoCache] r) => Path Abs File -> Sem r (Maybe Store.ModuleInfo) loadFromFile :: (Members '[JvoCache] r) => Path Abs File -> Sem r (Maybe Store.ModuleInfo)
loadFromFile = cacheGet loadFromFile = cacheGet

18
src/Juvix/Compiler/Pipeline/Loader/PathResolver/Base.hs
View File

@ -6,6 +6,7 @@ where
import Juvix.Compiler.Concrete.Data.Name import Juvix.Compiler.Concrete.Data.Name
import Juvix.Compiler.Pipeline.Loader.PathResolver.DependenciesConfig import Juvix.Compiler.Pipeline.Loader.PathResolver.DependenciesConfig
import Juvix.Compiler.Pipeline.Loader.PathResolver.ImportTree.ImportNode
import Juvix.Compiler.Pipeline.Loader.PathResolver.PackageInfo import Juvix.Compiler.Pipeline.Loader.PathResolver.PackageInfo
import Juvix.Compiler.Pipeline.Loader.PathResolver.Paths import Juvix.Compiler.Pipeline.Loader.PathResolver.Paths
import Juvix.Prelude import Juvix.Prelude
@ -37,7 +38,6 @@ data PathResolver :: Effect where
ResolvePath :: ImportScan -> PathResolver m (PackageInfo, FileExt) ResolvePath :: ImportScan -> PathResolver m (PackageInfo, FileExt)
-- | The root is assumed to be a package root. -- | The root is assumed to be a package root.
WithResolverRoot :: Path Abs Dir -> m a -> PathResolver m a WithResolverRoot :: Path Abs Dir -> m a -> PathResolver m a
-- TODO remove: ugly af
SupportsParallel :: PathResolver m Bool SupportsParallel :: PathResolver m Bool
ResolverRoot :: PathResolver m (Path Abs Dir) ResolverRoot :: PathResolver m (Path Abs Dir)
@ -48,20 +48,26 @@ makeSem ''PathResolver
withPathFile :: withPathFile ::
(Members '[PathResolver] r) => (Members '[PathResolver] r) =>
TopModulePath -> TopModulePath ->
(Path Abs File -> Sem r a) -> (ImportNode -> Sem r a) ->
Sem r a Sem r a
withPathFile m f = do withPathFile m f = do
(root, file) <- resolveTopModulePath m node <- resolveTopModulePath m
withResolverRoot root (f (root <//> file)) let root = node ^. importNodePackageRoot
withResolverRoot root (f node)
-- | Returns the root of the package where the module belongs and the path to -- | Returns the root of the package where the module belongs and the path to
-- the module relative to the root. -- the module relative to the root.
resolveTopModulePath :: resolveTopModulePath ::
(Members '[PathResolver] r) => (Members '[PathResolver] r) =>
TopModulePath -> TopModulePath ->
Sem r (Path Abs Dir, Path Rel File) Sem r ImportNode
resolveTopModulePath mp = do resolveTopModulePath mp = do
let scan = topModulePathToImportScan mp let scan = topModulePathToImportScan mp
relpath = topModulePathToRelativePathNoExt mp relpath = topModulePathToRelativePathNoExt mp
(pkg, ext) <- resolvePath scan (pkg, ext) <- resolvePath scan
return (pkg ^. packageRoot, addFileExt ext relpath) let node =
ImportNode
{ _importNodeFile = addFileExt ext relpath,
_importNodePackageRoot = pkg ^. packageRoot
}
return node

13
src/Juvix/Compiler/Pipeline/Loader/PathResolver/ImportTree/Base.hs
View File

@ -4,6 +4,8 @@ module Juvix.Compiler.Pipeline.Loader.PathResolver.ImportTree.Base
importTree, importTree,
importTreeReverse, importTreeReverse,
importTreeEdges, importTreeEdges,
importTreeNodes,
importTreeProjectNodes,
ImportTreeBuilder, ImportTreeBuilder,
runImportTreeBuilder, runImportTreeBuilder,
ignoreImportTreeBuilder, ignoreImportTreeBuilder,
@ -93,6 +95,17 @@ importTree = fimportTree
importTreeReverse :: SimpleGetter ImportTree (HashMap ImportNode (HashSet ImportNode)) importTreeReverse :: SimpleGetter ImportTree (HashMap ImportNode (HashSet ImportNode))
importTreeReverse = fimportTreeReverse importTreeReverse = fimportTreeReverse
importTreeNodes :: SimpleGetter ImportTree (HashSet ImportNode)
importTreeNodes = importTree . to HashMap.keysSet
importTreeProjectNodes :: Path Abs Dir -> ImportTree -> [ImportNode]
importTreeProjectNodes pkgRoot tree = mapMaybe projectFile (toList (tree ^. importTreeNodes))
where
projectFile :: ImportNode -> Maybe ImportNode
projectFile i = do
guard (i ^. importNodePackageRoot == pkgRoot)
return i
importTreeEdges :: SimpleGetter ImportTree (HashMap ImportNode (HashSet ImportScan)) importTreeEdges :: SimpleGetter ImportTree (HashMap ImportNode (HashSet ImportScan))
importTreeEdges = fimportTreeEdges importTreeEdges = fimportTreeEdges

19
src/Juvix/Compiler/Pipeline/Loader/PathResolver/Paths.hs
View File

@ -11,15 +11,22 @@ topModulePathToRelativePath' m =
ext = fileExtension' absPath ext = fileExtension' absPath
in topModulePathToRelativePath ext "" (</>) m in topModulePathToRelativePath ext "" (</>) m
topModulePathKeyToRelativePathNoExt :: TopModulePathKey -> Path Rel File
topModulePathKeyToRelativePathNoExt TopModulePathKey {..} =
relFile (joinFilePaths (map unpack (_modulePathKeyDir ++ [_modulePathKeyName])))
topModulePathToRelativePathNoExt :: TopModulePath -> Path Rel File topModulePathToRelativePathNoExt :: TopModulePath -> Path Rel File
topModulePathToRelativePathNoExt TopModulePath {..} = relFile (joinFilePaths (map (unpack . (^. withLocParam)) (_modulePathDir ++ [_modulePathName]))) topModulePathToRelativePathNoExt = topModulePathKeyToRelativePathNoExt . topModulePathKey
topModulePathKeyToImportScan :: Interval -> TopModulePathKey -> ImportScan
topModulePathKeyToImportScan loc TopModulePathKey {..} =
ImportScan
{ _importNames = unpack <$> NonEmpty.prependList _modulePathKeyDir (pure _modulePathKeyName),
_importLoc = loc
}
topModulePathToImportScan :: TopModulePath -> ImportScan topModulePathToImportScan :: TopModulePath -> ImportScan
topModulePathToImportScan t@TopModulePath {..} = topModulePathToImportScan t = topModulePathKeyToImportScan (getLoc t) (topModulePathKey t)
ImportScan
{ _importNames = unpack . (^. withLocParam) <$> (NonEmpty.prependList _modulePathDir (pure _modulePathName)),
_importLoc = getLoc t
}
topModulePathToRelativePath :: String -> String -> (FilePath -> FilePath -> FilePath) -> TopModulePath -> Path Rel File topModulePathToRelativePath :: String -> String -> (FilePath -> FilePath -> FilePath) -> TopModulePath -> Path Rel File
topModulePathToRelativePath ext suffix joinpath mp = relFile relFilePath topModulePathToRelativePath ext suffix joinpath mp = relFile relFilePath

12
src/Juvix/Compiler/Pipeline/ModuleInfoCache.hs
View File

@ -1,6 +1,7 @@
module Juvix.Compiler.Pipeline.ModuleInfoCache where module Juvix.Compiler.Pipeline.ModuleInfoCache where
import Juvix.Compiler.Pipeline.EntryPoint import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Compiler.Pipeline.Loader.PathResolver.ImportTree.ImportNode
import Juvix.Compiler.Pipeline.Result import Juvix.Compiler.Pipeline.Result
import Juvix.Compiler.Store.Language qualified as Store import Juvix.Compiler.Store.Language qualified as Store
import Juvix.Data.Effect.Cache import Juvix.Data.Effect.Cache
@ -8,7 +9,7 @@ import Juvix.Prelude
data EntryIndex = EntryIndex data EntryIndex = EntryIndex
{ _entryIxEntry :: EntryPoint, { _entryIxEntry :: EntryPoint,
_entryIxResolverRoot :: Path Abs Dir _entryIxImportNode :: ImportNode
} }
makeLenses ''EntryIndex makeLenses ''EntryIndex
@ -27,10 +28,11 @@ entryIndexPath = fromMaybe err . (^. entryIxEntry . entryPointModulePath)
err :: a err :: a
err = error "unexpected: EntryIndex should always have a path" err = error "unexpected: EntryIndex should always have a path"
mkEntryIndex :: (Members '[Reader EntryPoint] r) => Path Abs Dir -> Path Abs File -> Sem r EntryIndex mkEntryIndex :: (Members '[Reader EntryPoint] r) => ImportNode -> Sem r EntryIndex
mkEntryIndex _entryIxResolverRoot path = do mkEntryIndex node = do
entry <- ask entry <- ask
let stdin' let path = node ^. importNodeAbsFile
stdin'
| Just path == entry ^. entryPointModulePath = entry ^. entryPointStdin | Just path == entry ^. entryPointModulePath = entry ^. entryPointStdin
| otherwise = Nothing | otherwise = Nothing
entry' = entry' =
@ -41,5 +43,5 @@ mkEntryIndex _entryIxResolverRoot path = do
return return
EntryIndex EntryIndex
{ _entryIxEntry = entry', { _entryIxEntry = entry',
_entryIxResolverRoot _entryIxImportNode = node
} }

2
src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs
View File

@ -149,7 +149,7 @@ loadPackage' packagePath = do
rootPath = parent packagePath rootPath = parent packagePath
packageEntryPoint :: EntryPoint packageEntryPoint :: EntryPoint
packageEntryPoint = defaultEntryPoint rootPkg root packagePath packageEntryPoint = defaultEntryPoint rootPkg root (Just packagePath)
where where
root :: Root root :: Root
root = root =

11
src/Juvix/Compiler/Pipeline/Repl.hs
View File

@ -38,9 +38,11 @@ upToInternalExpression ::
upToInternalExpression p = do upToInternalExpression p = do
scopeTable <- gets (^. artifactScopeTable) scopeTable <- gets (^. artifactScopeTable)
mtab <- gets (^. artifactModuleTable) mtab <- gets (^. artifactModuleTable)
pkg <- asks (^. entryPointPackage)
runBuiltinsArtifacts runBuiltinsArtifacts
. runScoperScopeArtifacts . runScoperScopeArtifacts
. runStateArtifacts artifactScoperState . runStateArtifacts artifactScoperState
. runReader pkg
$ runNameIdGenArtifacts (Scoper.scopeCheckExpression (Store.getScopedModuleTable mtab) scopeTable p) $ runNameIdGenArtifacts (Scoper.scopeCheckExpression (Store.getScopedModuleTable mtab) scopeTable p)
>>= runNameIdGenArtifacts . runReader scopeTable . Internal.fromConcreteExpression >>= runNameIdGenArtifacts . runReader scopeTable . Internal.fromConcreteExpression
@ -62,10 +64,12 @@ expressionUpToAtomsScoped ::
expressionUpToAtomsScoped fp txt = do expressionUpToAtomsScoped fp txt = do
scopeTable <- gets (^. artifactScopeTable) scopeTable <- gets (^. artifactScopeTable)
mtab <- gets (^. artifactModuleTable) mtab <- gets (^. artifactModuleTable)
pkg <- asks (^. entryPointPackage)
runBuiltinsArtifacts runBuiltinsArtifacts
. runScoperScopeArtifacts . runScoperScopeArtifacts
. runStateArtifacts artifactScoperState . runStateArtifacts artifactScoperState
. runNameIdGenArtifacts . runNameIdGenArtifacts
. runReader pkg
$ Parser.expressionFromTextSource fp txt $ Parser.expressionFromTextSource fp txt
>>= Scoper.scopeCheckExpressionAtoms (Store.getScopedModuleTable mtab) scopeTable >>= Scoper.scopeCheckExpressionAtoms (Store.getScopedModuleTable mtab) scopeTable
@ -76,10 +80,12 @@ scopeCheckExpression ::
scopeCheckExpression p = do scopeCheckExpression p = do
scopeTable <- gets (^. artifactScopeTable) scopeTable <- gets (^. artifactScopeTable)
mtab <- gets (^. artifactModuleTable) mtab <- gets (^. artifactModuleTable)
pkg <- asks (^. entryPointPackage)
runNameIdGenArtifacts runNameIdGenArtifacts
. runBuiltinsArtifacts . runBuiltinsArtifacts
. runScoperScopeArtifacts . runScoperScopeArtifacts
. runStateArtifacts artifactScoperState . runStateArtifacts artifactScoperState
. runReader pkg
$ Scoper.scopeCheckExpression (Store.getScopedModuleTable mtab) scopeTable p $ Scoper.scopeCheckExpression (Store.getScopedModuleTable mtab) scopeTable p
parseReplInput :: parseReplInput ::
@ -126,11 +132,13 @@ registerImport i = do
modify' (appendArtifactsModuleTable mtab') modify' (appendArtifactsModuleTable mtab')
scopeTable <- gets (^. artifactScopeTable) scopeTable <- gets (^. artifactScopeTable)
mtab'' <- gets (^. artifactModuleTable) mtab'' <- gets (^. artifactModuleTable)
pkg <- asks (^. entryPointPackage)
void void
. runNameIdGenArtifacts . runNameIdGenArtifacts
. runBuiltinsArtifacts . runBuiltinsArtifacts
. runScoperScopeArtifacts . runScoperScopeArtifacts
. runStateArtifacts artifactScoperState . runStateArtifacts artifactScoperState
. runReader pkg
$ Scoper.scopeCheckImport (Store.getScopedModuleTable mtab'') scopeTable i $ Scoper.scopeCheckImport (Store.getScopedModuleTable mtab'') scopeTable i
fromInternalExpression :: (Members '[State Artifacts, Error JuvixError] r) => Internal.Expression -> Sem r Core.Node fromInternalExpression :: (Members '[State Artifacts, Error JuvixError] r) => Internal.Expression -> Sem r Core.Node
@ -159,6 +167,7 @@ compileReplInputIO fp txt = do
hasInternet <- not <$> asks (^. entryPointOffline) hasInternet <- not <$> asks (^. entryPointOffline)
runError runError
. runConcurrent . runConcurrent
. runReader defaultNumThreads
. evalInternet hasInternet . evalInternet hasInternet
. runTaggedLockPermissive . runTaggedLockPermissive
. runLogIO . runLogIO
@ -176,7 +185,7 @@ compileReplInputIO fp txt = do
. runReader defaultImportScanStrategy . runReader defaultImportScanStrategy
. withImportTree (Just fp) . withImportTree (Just fp)
. ignoreProgressLog . ignoreProgressLog
. evalModuleInfoCacheHelper defaultNumThreads . evalModuleInfoCacheHelper
$ do $ do
p <- parseReplInput fp txt p <- parseReplInput fp txt
case p of case p of

14
src/Juvix/Compiler/Pipeline/Run.hs
View File

@ -114,6 +114,7 @@ runIOEitherPipeline' entry a = do
let hasInternet = not (entry ^. entryPointOffline) let hasInternet = not (entry ^. entryPointOffline)
opts :: PipelineOptions <- ask opts :: PipelineOptions <- ask
runConcurrent runConcurrent
. runReader (opts ^. pipelineNumThreads)
. evalInternet hasInternet . evalInternet hasInternet
. runHighlightBuilder . runHighlightBuilder
. runJuvixError . runJuvixError
@ -132,7 +133,7 @@ runIOEitherPipeline' entry a = do
. runTopModuleNameChecker . runTopModuleNameChecker
. runReader (opts ^. pipelineImportStrategy) . runReader (opts ^. pipelineImportStrategy)
. withImportTree (entry ^. entryPointModulePath) . withImportTree (entry ^. entryPointModulePath)
. evalModuleInfoCacheHelper (opts ^. pipelineNumThreads) . evalModuleInfoCacheHelper
$ a $ a
evalModuleInfoCacheHelper :: evalModuleInfoCacheHelper ::
@ -148,18 +149,18 @@ evalModuleInfoCacheHelper ::
Error JuvixError, Error JuvixError,
PathResolver, PathResolver,
Reader ImportScanStrategy, Reader ImportScanStrategy,
Reader NumThreads,
Files Files
] ]
r r
) => ) =>
NumThreads ->
Sem (ModuleInfoCache ': JvoCache ': r) a -> Sem (ModuleInfoCache ': JvoCache ': r) a ->
Sem r a Sem r a
evalModuleInfoCacheHelper nj m = do evalModuleInfoCacheHelper m = do
b <- supportsParallel b <- supportsParallel
threads <- numThreads nj threads <- ask >>= numThreads
if if
| b && threads > 1 -> DriverPar.evalModuleInfoCache nj m | b && threads > 1 -> DriverPar.evalModuleInfoCache m
| otherwise -> evalModuleInfoCache m | otherwise -> evalModuleInfoCache m
mainIsPackageFile :: EntryPoint -> Bool mainIsPackageFile :: EntryPoint -> Bool
@ -212,6 +213,7 @@ runReplPipelineIOEither' lockMode entry = do
eith <- eith <-
runM runM
. runConcurrent . runConcurrent
. runReader defaultNumThreads
. evalInternet hasInternet . evalInternet hasInternet
. ignoreHighlightBuilder . ignoreHighlightBuilder
. runError . runError
@ -235,7 +237,7 @@ runReplPipelineIOEither' lockMode entry = do
. runReader defaultImportScanStrategy . runReader defaultImportScanStrategy
. withImportTree (entry ^. entryPointModulePath) . withImportTree (entry ^. entryPointModulePath)
. ignoreProgressLog . ignoreProgressLog
. evalModuleInfoCacheHelper defaultNumThreads . evalModuleInfoCacheHelper
$ processFileToStoredCore entry $ processFileToStoredCore entry
return $ case eith of return $ case eith of
Left err -> Left err Left err -> Left err

16
src/Juvix/Compiler/Store/Extra.hs
View File

@ -2,8 +2,8 @@ module Juvix.Compiler.Store.Extra where
import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict qualified as HashMap
import Juvix.Compiler.Concrete.Data.Builtins import Juvix.Compiler.Concrete.Data.Builtins
import Juvix.Compiler.Concrete.Data.Name qualified as C
import Juvix.Compiler.Concrete.Data.ScopedName qualified as S import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
import Juvix.Compiler.Concrete.Language (TopModulePath)
import Juvix.Compiler.Core.Data.InfoTable qualified as Core import Juvix.Compiler.Core.Data.InfoTable qualified as Core
import Juvix.Compiler.Internal.Data.Name import Juvix.Compiler.Internal.Data.Name
import Juvix.Compiler.Store.Core.Extra import Juvix.Compiler.Store.Core.Extra
@ -13,15 +13,15 @@ import Juvix.Compiler.Store.Scoped.Data.InfoTable qualified as Scoped
import Juvix.Compiler.Store.Scoped.Language import Juvix.Compiler.Store.Scoped.Language
import Juvix.Prelude import Juvix.Prelude
getModulePath :: ModuleInfo -> TopModulePath getModulePath :: ModuleInfo -> C.TopModulePath
getModulePath mi = mi ^. moduleInfoScopedModule . scopedModulePath . S.nameConcrete getModulePath mi = mi ^. moduleInfoScopedModule . scopedModulePath . S.nameConcrete
getModuleId :: ModuleInfo -> ModuleId getModulePathKey :: ModuleInfo -> TopModulePathKey
getModuleId mi = mi ^. moduleInfoScopedModule . scopedModuleId getModulePathKey = C.topModulePathKey . getModulePath
getScopedModuleTable :: ModuleTable -> ScopedModuleTable getScopedModuleTable :: ModuleTable -> ScopedModuleTable
getScopedModuleTable mtab = getScopedModuleTable mtab =
ScopedModuleTable $ fmap (^. moduleInfoScopedModule) (mtab ^. moduleTable) ScopedModuleTable $ HashMap.mapKeys C.topModulePathKey (fmap (^. moduleInfoScopedModule) (mtab ^. moduleTable))
getInternalModuleTable :: ModuleTable -> InternalModuleTable getInternalModuleTable :: ModuleTable -> InternalModuleTable
getInternalModuleTable mtab = getInternalModuleTable mtab =
@ -31,10 +31,10 @@ getInternalModuleTable mtab =
mkModuleTable :: [ModuleInfo] -> ModuleTable mkModuleTable :: [ModuleInfo] -> ModuleTable
mkModuleTable = ModuleTable . hashMap . map (\mi -> (getModulePath mi, mi)) mkModuleTable = ModuleTable . hashMap . map (\mi -> (getModulePath mi, mi))
lookupModule :: ModuleTable -> TopModulePath -> ModuleInfo lookupModule :: ModuleTable -> C.TopModulePath -> ModuleInfo
lookupModule mtab n = fromJust $ HashMap.lookup n (mtab ^. moduleTable) lookupModule mtab n = fromJust (mtab ^. moduleTable . at n)
insertModule :: TopModulePath -> ModuleInfo -> ModuleTable -> ModuleTable insertModule :: C.TopModulePath -> ModuleInfo -> ModuleTable -> ModuleTable
insertModule p mi = over moduleTable (HashMap.insert p mi) insertModule p mi = over moduleTable (HashMap.insert p mi)
computeCombinedScopedInfoTable :: ModuleTable -> Scoped.InfoTable computeCombinedScopedInfoTable :: ModuleTable -> Scoped.InfoTable

2
src/Juvix/Compiler/Store/Language.hs
View File

@ -1,6 +1,6 @@
module Juvix.Compiler.Store.Language where module Juvix.Compiler.Store.Language where
import Juvix.Compiler.Concrete.Language (TopModulePath) import Juvix.Compiler.Concrete.Data.Name
import Juvix.Compiler.Store.Core.Data.InfoTable qualified as Core import Juvix.Compiler.Store.Core.Data.InfoTable qualified as Core
import Juvix.Compiler.Store.Internal.Language import Juvix.Compiler.Store.Internal.Language
import Juvix.Compiler.Store.Options import Juvix.Compiler.Store.Options

5
src/Juvix/Compiler/Store/Scoped/Language.hs
View File

@ -25,8 +25,7 @@ instance Serialize ExportInfo
instance NFData ExportInfo instance NFData ExportInfo
data ScopedModule = ScopedModule data ScopedModule = ScopedModule
{ _scopedModuleId :: ModuleId, { _scopedModulePath :: S.TopModulePath,
_scopedModulePath :: S.TopModulePath,
_scopedModuleName :: S.Name, _scopedModuleName :: S.Name,
_scopedModuleFilePath :: Path Abs File, _scopedModuleFilePath :: Path Abs File,
_scopedModuleExportInfo :: ExportInfo, _scopedModuleExportInfo :: ExportInfo,
@ -40,7 +39,7 @@ instance Serialize ScopedModule
instance NFData ScopedModule instance NFData ScopedModule
newtype ScopedModuleTable = ScopedModuleTable newtype ScopedModuleTable = ScopedModuleTable
{ _scopedModuleTable :: HashMap C.TopModulePath ScopedModule { _scopedModuleTable :: HashMap TopModulePathKey ScopedModule
} }
makeLenses ''ExportInfo makeLenses ''ExportInfo

2
src/Juvix/Data.hs
View File

@ -19,6 +19,7 @@ module Juvix.Data
module Juvix.Data.WithLoc, module Juvix.Data.WithLoc,
module Juvix.Data.WithSource, module Juvix.Data.WithSource,
module Juvix.Data.DependencyInfo, module Juvix.Data.DependencyInfo,
module Juvix.Data.TopModulePathKey,
module Juvix.Data.Keyword, module Juvix.Data.Keyword,
) )
where where
@ -39,6 +40,7 @@ import Juvix.Data.NameId qualified
import Juvix.Data.NumThreads import Juvix.Data.NumThreads
import Juvix.Data.Pragmas import Juvix.Data.Pragmas
import Juvix.Data.Processed import Juvix.Data.Processed
import Juvix.Data.TopModulePathKey
import Juvix.Data.Uid import Juvix.Data.Uid
import Juvix.Data.Universe import Juvix.Data.Universe
import Juvix.Data.Wildcard import Juvix.Data.Wildcard

2
src/Juvix/Data/Effect.hs
View File

@ -6,6 +6,7 @@ module Juvix.Data.Effect
module Juvix.Data.Effect.Visit, module Juvix.Data.Effect.Visit,
module Juvix.Data.Effect.Log, module Juvix.Data.Effect.Log,
module Juvix.Data.Effect.Internet, module Juvix.Data.Effect.Internet,
module Juvix.Data.Effect.Forcing,
module Juvix.Data.Effect.TaggedLock, module Juvix.Data.Effect.TaggedLock,
) )
where where
@ -13,6 +14,7 @@ where
import Juvix.Data.Effect.Cache import Juvix.Data.Effect.Cache
import Juvix.Data.Effect.Fail import Juvix.Data.Effect.Fail
import Juvix.Data.Effect.Files import Juvix.Data.Effect.Files
import Juvix.Data.Effect.Forcing
import Juvix.Data.Effect.Internet import Juvix.Data.Effect.Internet
import Juvix.Data.Effect.Log import Juvix.Data.Effect.Log
import Juvix.Data.Effect.NameIdGen import Juvix.Data.Effect.NameIdGen

24
src/Juvix/Data/Effect/Forcing.hs Normal file
View File

@ -0,0 +1,24 @@
{-# OPTIONS_GHC -Wno-unused-type-patterns #-}
-- | This effect provides convenient syntax for individually forcing evaluation
-- on fields of a record type (or anything pointed by a lens)
module Juvix.Data.Effect.Forcing where
import Juvix.Prelude.Base
data Forcing (a :: GHCType) :: Effect where
-- | Forces full evaluation on the field pointed by the lens
ForcesField :: (NFData b) => Lens' a b -> Forcing a m ()
-- | Forcing effect scoped to the field pointed by the lens
Forces :: Lens' a b -> Sem '[Forcing b] () -> Forcing a m ()
makeSem ''Forcing
forcing :: a -> Sem '[Forcing a] () -> a
forcing a = run . evalForcing a
evalForcing :: a -> Sem (Forcing a ': r) () -> Sem r a
evalForcing a =
reinterpret (execState a) $ \case
ForcesField l -> modify (over l force)
Forces l r -> modify (over l (`forcing` r))

5
src/Juvix/Data/ModuleId.hs
View File

@ -1,11 +1,12 @@
module Juvix.Data.ModuleId where module Juvix.Data.ModuleId where
import Juvix.Data.TopModulePathKey
import Juvix.Extra.Serialize import Juvix.Extra.Serialize
import Juvix.Prelude.Base import Juvix.Prelude.Base
import Prettyprinter import Prettyprinter
data ModuleId = ModuleId data ModuleId = ModuleId
{ _moduleIdPath :: Text, { _moduleIdPath :: TopModulePathKey,
_moduleIdPackage :: Text, _moduleIdPackage :: Text,
_moduleIdPackageVersion :: Text _moduleIdPackageVersion :: Text
} }
@ -25,7 +26,7 @@ instance NFData ModuleId
defaultModuleId :: ModuleId defaultModuleId :: ModuleId
defaultModuleId = defaultModuleId =
ModuleId ModuleId
{ _moduleIdPath = "$DefaultModule$", { _moduleIdPath = nonEmptyToTopModulePathKey (pure "$DefaultModule$"),
_moduleIdPackage = "$", _moduleIdPackage = "$",
_moduleIdPackageVersion = "1.0" _moduleIdPackageVersion = "1.0"
} }

41
src/Juvix/Data/TopModulePathKey.hs Normal file
View File

@ -0,0 +1,41 @@
module Juvix.Data.TopModulePathKey where
import Data.List.NonEmpty qualified as NonEmpty
import Juvix.Extra.Serialize
import Juvix.Prelude.Base
import Juvix.Prelude.Path
import Juvix.Prelude.Pretty as Pretty
data TopModulePathKey = TopModulePathKey
{ _modulePathKeyDir :: [Text],
_modulePathKeyName :: Text
}
deriving stock (Show, Eq, Ord, Generic, Data)
instance Serialize TopModulePathKey
instance NFData TopModulePathKey
instance Hashable TopModulePathKey
makeLenses ''TopModulePathKey
instance Pretty TopModulePathKey where
pretty (TopModulePathKey path name) =
mconcat (punctuate Pretty.dot (map pretty (snoc path name)))
nonEmptyToTopModulePathKey :: NonEmpty Text -> TopModulePathKey
nonEmptyToTopModulePathKey l =
TopModulePathKey
{ _modulePathKeyDir = NonEmpty.init l,
_modulePathKeyName = NonEmpty.last l
}
relPathtoTopModulePathKey :: Path Rel File -> TopModulePathKey
relPathtoTopModulePathKey =
nonEmptyToTopModulePathKey
. fmap pack
. nonEmpty'
. splitDirectories
. toFilePath
. removeExtensions

145
src/Juvix/Formatter.hs
View File

@ -2,10 +2,19 @@
module Juvix.Formatter where module Juvix.Formatter where
import Juvix.Compiler.Concrete.Data.Highlight.Input (ignoreHighlightBuilder)
import Juvix.Compiler.Concrete.Language import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Concrete.Print (docDefault) import Juvix.Compiler.Concrete.Print (ppOutDefault)
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping (ScoperResult, getModuleId, scopeCheck)
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper
import Juvix.Compiler.Concrete.Translation.FromSource (ParserResult, fromSource)
import Juvix.Compiler.Concrete.Translation.FromSource.TopModuleNameChecker (runTopModuleNameChecker)
import Juvix.Compiler.Pipeline.EntryPoint import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Compiler.Pipeline.Loader.PathResolver
import Juvix.Compiler.Pipeline.Result
import Juvix.Compiler.Store.Extra (getScopedModuleTable)
import Juvix.Compiler.Store.Language qualified as Store
import Juvix.Compiler.Store.Scoped.Language (ScopedModuleTable)
import Juvix.Data.CodeAnn import Juvix.Data.CodeAnn
import Juvix.Extra.Paths import Juvix.Extra.Paths
import Juvix.Prelude import Juvix.Prelude
@ -16,6 +25,8 @@ data FormattedFileInfo = FormattedFileInfo
_formattedFileInfoContentsModified :: Bool _formattedFileInfoContentsModified :: Bool
} }
type OriginalSource = Text
data ScopeEff :: Effect where data ScopeEff :: Effect where
ScopeFile :: Path Abs File -> ScopeEff m Scoper.ScoperResult ScopeFile :: Path Abs File -> ScopeEff m Scoper.ScoperResult
ScopeStdin :: EntryPoint -> ScopeEff m Scoper.ScoperResult ScopeStdin :: EntryPoint -> ScopeEff m Scoper.ScoperResult
@ -29,6 +40,13 @@ data FormatResult
| FormatResultFail | FormatResultFail
deriving stock (Eq) deriving stock (Eq)
data SourceCode = SourceCode
{ _sourceCodeFormatted :: Text,
_sourceCodeOriginal :: Text
}
makeLenses ''SourceCode
instance Semigroup FormatResult where instance Semigroup FormatResult where
FormatResultFail <> _ = FormatResultFail FormatResultFail <> _ = FormatResultFail
_ <> FormatResultFail = FormatResultFail _ <> FormatResultFail = FormatResultFail
@ -54,9 +72,13 @@ format ::
Sem r FormatResult Sem r FormatResult
format p = do format p = do
originalContents <- readFile' p originalContents <- readFile' p
runReader originalContents $ do formattedContents :: Text <- runReader originalContents (formatPath p)
formattedContents :: Text <- formatPath p let src =
formatResultFromContents formattedContents p SourceCode
{ _sourceCodeFormatted = formattedContents,
_sourceCodeOriginal = originalContents
}
formatResultSourceCode p src
-- | Format a Juvix project. -- | Format a Juvix project.
-- --
@ -73,27 +95,57 @@ format p = do
-- --
-- NB: This function does not traverse into Juvix sub-projects, i.e into -- NB: This function does not traverse into Juvix sub-projects, i.e into
-- subdirectories that contain a juvix.yaml file. -- subdirectories that contain a juvix.yaml file.
formatProject :: formatProjectSourceCode ::
forall r. forall r.
(Members '[ScopeEff, Files, Output FormattedFileInfo] r) => (Members '[Output FormattedFileInfo] r) =>
Path Abs Dir -> [(ImportNode, SourceCode)] ->
Sem r FormatResult Sem r FormatResult
formatProject p = do formatProjectSourceCode =
walkDirRelAccum handler p FormatResultOK mconcatMapM (uncurry formatResultSourceCode)
where . map (first (^. importNodeAbsFile))
handler ::
Path Abs Dir -> formatModuleInfo ::
[Path Rel Dir] -> ( Members
[Path Rel File] -> '[ PathResolver,
FormatResult -> Error JuvixError,
Sem r (FormatResult, Recurse Rel) Files,
handler cd _ files res = do Reader Package
let juvixFiles = [cd <//> f | f <- files, isJuvixFile f] ]
subRes <- mconcat <$> mapM format juvixFiles r
return (res <> subRes, RecurseFilter (\hasJuvixPackage d -> not hasJuvixPackage && not (isHiddenDirectory d))) ) =>
ImportNode ->
PipelineResult Store.ModuleInfo ->
Sem r SourceCode
formatModuleInfo node moduleInfo =
withResolverRoot (node ^. importNodePackageRoot)
. ignoreHighlightBuilder
$ do
pkg :: Package <- ask
parseRes :: ParserResult <-
runTopModuleNameChecker $
fromSource Nothing (Just (node ^. importNodeAbsFile))
let modules = moduleInfo ^. pipelineResultImports
scopedModules :: ScopedModuleTable = getScopedModuleTable modules
tmp :: TopModulePathKey = relPathtoTopModulePathKey (node ^. importNodeFile)
moduleid :: ModuleId = run (runReader pkg (getModuleId tmp))
scopeRes :: ScoperResult <-
evalTopNameIdGen moduleid $
scopeCheck pkg scopedModules parseRes
originalSource :: Text <- readFile' (node ^. importNodeAbsFile)
formattedTxt <-
runReader originalSource $
formatScoperResult False scopeRes
let formatRes =
SourceCode
{ _sourceCodeFormatted = formattedTxt,
_sourceCodeOriginal = originalSource
}
return . forcing formatRes $ do
forcesField sourceCodeFormatted
forcesField sourceCodeOriginal
formatPath :: formatPath ::
(Members '[Reader Text, ScopeEff] r) => (Members '[Reader OriginalSource, ScopeEff] r) =>
Path Abs File -> Path Abs File ->
Sem r Text Sem r Text
formatPath p = do formatPath p = do
@ -107,21 +159,20 @@ formatStdin ::
formatStdin = do formatStdin = do
entry <- ask entry <- ask
res <- scopeStdin entry res <- scopeStdin entry
let originalContents = fromMaybe "" (entry ^. entryPointStdin) let _sourceCodeOriginal = fromMaybe "" (entry ^. entryPointStdin)
runReader originalContents $ do _sourceCodeFormatted :: Text <- runReader _sourceCodeOriginal (formatScoperResult False res)
formattedContents :: Text <- formatScoperResult False res let src = SourceCode {..}
formatResultFromContents formattedContents formatStdinPath formatResultSourceCode formatStdinPath src
formatResultFromContents :: formatResultSourceCode ::
forall r. forall r.
(Members '[Reader Text, Output FormattedFileInfo] r) => (Members '[Output FormattedFileInfo] r) =>
Text ->
Path Abs File -> Path Abs File ->
SourceCode ->
Sem r FormatResult Sem r FormatResult
formatResultFromContents formattedContents filepath = do formatResultSourceCode filepath src = do
originalContents <- ask
if if
| originalContents /= formattedContents -> mkResult FormatResultNotFormatted | src ^. sourceCodeOriginal /= src ^. sourceCodeFormatted -> mkResult FormatResultNotFormatted
| otherwise -> mkResult FormatResultOK | otherwise -> mkResult FormatResultOK
where where
mkResult :: FormatResult -> Sem r FormatResult mkResult :: FormatResult -> Sem r FormatResult
@ -129,7 +180,7 @@ formatResultFromContents formattedContents filepath = do
output output
( FormattedFileInfo ( FormattedFileInfo
{ _formattedFileInfoPath = filepath, { _formattedFileInfoPath = filepath,
_formattedFileInfoContents = formattedContents, _formattedFileInfoContents = src ^. sourceCodeFormatted,
_formattedFileInfoContentsModified = res == FormatResultNotFormatted _formattedFileInfoContentsModified = res == FormatResultNotFormatted
} }
) )
@ -141,29 +192,15 @@ formatScoperResult' forceFormat original sres =
run . runReader original $ formatScoperResult forceFormat sres run . runReader original $ formatScoperResult forceFormat sres
formatScoperResult :: formatScoperResult ::
(Members '[Reader Text] r) => (Members '[Reader OriginalSource] r) =>
Bool -> Bool ->
Scoper.ScoperResult -> Scoper.ScoperResult ->
Sem r Text Sem r Text
formatScoperResult forceFormat res = do formatScoperResult forceFormat res = do
let cs = Scoper.getScoperResultComments res let comments = Scoper.getScoperResultComments res
formattedModule <- formattedTxt = toPlainTextTrim (ppOutDefault comments (res ^. Scoper.resultModule))
runReader cs runFailDefault formattedTxt $ do
. formatTopModule pragmas <- failMaybe (res ^. Scoper.mainModule . modulePragmas)
$ res PragmaFormat {..} <- failMaybe (pragmas ^. withLocParam . withSourceValue . pragmasFormat)
^. Scoper.resultModule failUnless (not _pragmaFormat && not forceFormat)
let txt :: Text = toPlainTextTrim formattedModule ask @OriginalSource
case res ^. Scoper.mainModule . modulePragmas of
Just pragmas ->
case pragmas ^. withLocParam . withSourceValue . pragmasFormat of
Just PragmaFormat {..}
| not _pragmaFormat && not forceFormat -> ask @Text
_ ->
return txt
Nothing ->
return txt
where
formatTopModule :: (Members '[Reader Comments] r) => Module 'Scoped 'ModuleTop -> Sem r (Doc Ann)
formatTopModule m = do
cs :: Comments <- ask
return $ docDefault cs m

2
src/Juvix/Prelude/Base/Foundation.hs
View File

@ -171,7 +171,7 @@ import Safe.Exact
import Safe.Foldable import Safe.Foldable
import System.Exit hiding (exitFailure, exitSuccess) import System.Exit hiding (exitFailure, exitSuccess)
import System.Exit qualified as IO import System.Exit qualified as IO
import System.FilePath (FilePath, dropTrailingPathSeparator, normalise, (<.>), (</>)) import System.FilePath (FilePath, dropTrailingPathSeparator, normalise, splitDirectories, (<.>), (</>))
import System.FilePath qualified as FilePath import System.FilePath qualified as FilePath
import System.IO hiding import System.IO hiding
( appendFile, ( appendFile,

4
src/Parallel/ParallelTemplate.hs
View File

@ -152,14 +152,14 @@ compile args@CompileArgs {..} = do
allNodesIds :: [nodeId] = HashMap.keys (nodesIx ^. nodesIndex) allNodesIds :: [nodeId] = HashMap.keys (nodesIx ^. nodesIndex)
deps = _compileArgsDependencies deps = _compileArgsDependencies
numMods :: Natural = fromIntegral (length allNodesIds) numMods :: Natural = fromIntegral (length allNodesIds)
starterModules :: [nodeId] = startingModules :: [nodeId] =
[m | m <- allNodesIds, null (nodeDependencies deps m)] [m | m <- allNodesIds, null (nodeDependencies deps m)]
logs <- Logs <$> newTQueueIO logs <- Logs <$> newTQueueIO
qq <- newTBQueueIO (max 1 numMods) qq <- newTBQueueIO (max 1 numMods)
let compileQ = CompileQueue qq let compileQ = CompileQueue qq
whenJust _compileArgsPreProcess $ \preProcess -> whenJust _compileArgsPreProcess $ \preProcess ->
mapConcurrently_ preProcess allNodesIds mapConcurrently_ preProcess allNodesIds
atomically (forM_ starterModules (writeTBQueue qq)) atomically (forM_ startingModules (writeTBQueue qq))
let iniCompilationState :: CompilationState nodeId compileProof = let iniCompilationState :: CompilationState nodeId compileProof =
CompilationState CompilationState
{ _compilationStartedNum = 0, { _compilationStartedNum = 0,

2
test/BackendMarkdown/Negative.hs
View File

@ -25,7 +25,7 @@ testDescr NegTest {..} =
_testRoot = tRoot, _testRoot = tRoot,
_testAssertion = Single $ do _testAssertion = Single $ do
entryPoint <- testDefaultEntryPointIO tRoot file' entryPoint <- testDefaultEntryPointIO tRoot file'
result <- testTaggedLockedToIO (runIOEither entryPoint upToScoping) result <- testTaggedLockedToIO (runIOEither entryPoint upToScopingEntry)
case result of case result of
Left err -> whenJust (_checkErr err) assertFailure Left err -> whenJust (_checkErr err) assertFailure
Right (_, pipelineRes) -> checkResult pipelineRes Right (_, pipelineRes) -> checkResult pipelineRes

2
test/BackendMarkdown/Positive.hs
View File

@ -35,7 +35,7 @@ testDescr PosTest {..} =
_testAssertion = Steps $ \step -> do _testAssertion = Steps $ \step -> do
entryPoint <- testDefaultEntryPointIO _dir _file entryPoint <- testDefaultEntryPointIO _dir _file
step "Parsing & Scoping" step "Parsing & Scoping"
PipelineResult {..} <- snd <$> testRunIO entryPoint upToScoping PipelineResult {..} <- snd <$> testRunIO entryPoint upToScopingEntry
let m = _pipelineResult ^. Scoper.resultModule let m = _pipelineResult ^. Scoper.resultModule
let opts = let opts =
ProcessJuvixBlocksArgs ProcessJuvixBlocksArgs

2
test/Format.hs
View File

@ -36,7 +36,7 @@ testDescr PosTest {..} =
original :: Text <- readFile f original :: Text <- readFile f
step "Parsing & scoping" step "Parsing & scoping"
PipelineResult {..} <- snd <$> testRunIO entryPoint upToScoping PipelineResult {..} <- snd <$> testRunIO entryPoint upToScopingEntry
let formatted = formatScoperResult' _force original _pipelineResult let formatted = formatScoperResult' _force original _pipelineResult
case _expectedFile of case _expectedFile of

4
test/Formatter/Positive.hs
View File

@ -9,9 +9,9 @@ runScopeEffIO :: (Member EmbedIO r) => Path Abs Dir -> Sem (ScopeEff ': r) a ->
runScopeEffIO root = interpret $ \case runScopeEffIO root = interpret $ \case
ScopeFile p -> do ScopeFile p -> do
entry <- testDefaultEntryPointIO root p entry <- testDefaultEntryPointIO root p
((^. pipelineResult) . snd <$> testRunIO entry upToScoping) ((^. pipelineResult) . snd <$> testRunIO entry upToScopingEntry)
ScopeStdin entry -> do ScopeStdin entry -> do
((^. pipelineResult) . snd <$> testRunIO entry upToScoping) ((^. pipelineResult) . snd <$> testRunIO entry upToScopingEntry)
makeFormatTest' :: Scope.PosTest -> TestDescr makeFormatTest' :: Scope.PosTest -> TestDescr
makeFormatTest' Scope.PosTest {..} = makeFormatTest' Scope.PosTest {..} =

2
test/Repl/Positive.hs
View File

@ -22,7 +22,7 @@ loadPrelude :: Path Abs Dir -> IO (Artifacts, EntryPoint)
loadPrelude rootDir = runTaggedLockIO' $ do loadPrelude rootDir = runTaggedLockIO' $ do
runReader rootDir writeStdlib runReader rootDir writeStdlib
pkg <- readPackageRootIO root pkg <- readPackageRootIO root
let ep = defaultEntryPoint pkg root (rootDir <//> preludePath) let ep = defaultEntryPoint pkg root (Just (rootDir <//> preludePath))
artif <- runReplPipelineIO ep artif <- runReplPipelineIO ep
return (artif, ep) return (artif, ep)
where where

4
test/Scope/Positive.hs
View File

@ -53,7 +53,7 @@ testDescr PosTest {..} = helper renderCodeNew
evalHelper input_ m = snd <$> testRunIO entryPoint {_entryPointStdin = Just input_} m evalHelper input_ m = snd <$> testRunIO entryPoint {_entryPointStdin = Just input_} m
step "Parsing & Scoping" step "Parsing & Scoping"
PipelineResult s _ _ <- snd <$> testRunIO entryPoint upToScoping PipelineResult s _ _ <- snd <$> testRunIO entryPoint upToScopingEntry
let p = s ^. Scoper.resultParserResult let p = s ^. Scoper.resultParserResult
fScoped :: Text fScoped :: Text
@ -62,7 +62,7 @@ testDescr PosTest {..} = helper renderCodeNew
fParsed = renderer $ p ^. Parser.resultModule fParsed = renderer $ p ^. Parser.resultModule
step "Parsing & scoping pretty scoped" step "Parsing & scoping pretty scoped"
PipelineResult s' _ _ <- evalHelper fScoped upToScoping PipelineResult s' _ _ <- evalHelper fScoped upToScopingEntry
let p' = s' ^. Scoper.resultParserResult let p' = s' ^. Scoper.resultParserResult
step "Parsing pretty parsed" step "Parsing pretty parsed"