mirror of
https://github.com/anoma/juvix.git
synced 2024-08-16 19:50:26 +03:00
Improve performance of formatting a project (#2863)
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:
parent
fef37a86ee
commit
6fcc9f21d2
38
app/App.hs
38
app/App.hs
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
@ -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 ->
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
@ -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"
|
||||||
|
@ -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 $
|
||||||
|
@ -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 =
|
||||||
|
@ -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)
|
||||||
|
@ -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
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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,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)
|
||||||
|
@ -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
|
||||||
|
|
||||||
|
@ -10,3 +10,6 @@ data ParserResult = ParserResult
|
|||||||
}
|
}
|
||||||
|
|
||||||
makeLenses ''ParserResult
|
makeLenses ''ParserResult
|
||||||
|
|
||||||
|
getParserResultComments :: ParserResult -> Comments
|
||||||
|
getParserResultComments sr = mkComments $ sr ^. resultParserState . parserStateComments
|
||||||
|
@ -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)
|
||||||
|
@ -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) =>
|
||||||
|
@ -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)
|
||||||
|
@ -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_))
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
}
|
}
|
||||||
|
@ -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 =
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
24
src/Juvix/Data/Effect/Forcing.hs
Normal 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))
|
@ -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
41
src/Juvix/Data/TopModulePathKey.hs
Normal 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
|
@ -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
|
|
||||||
|
@ -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,
|
||||||
|
@ -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,
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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 {..} =
|
||||||
|
@ -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
|
||||||
|
@ -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"
|
||||||
|
Loading…
Reference in New Issue
Block a user