mirror of
https://github.com/anoma/juvix.git
synced 2024-10-05 20:47:36 +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
|
||||
FromAppPathFile :: AppPath File -> App m (Path Abs 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)
|
||||
GetMainFileMaybe :: Maybe (AppPath File) -> App m (Maybe (Path Abs File))
|
||||
FromAppPathDir :: AppPath Dir -> App m (Path Abs Dir)
|
||||
RenderStdOut :: (HasAnsiBackend a, HasTextBackend a) => a -> App m ()
|
||||
Say :: Text -> App m ()
|
||||
@ -68,7 +70,9 @@ reAppIO args@RunAppIOArgs {..} =
|
||||
FromAppPathFile p -> prepathToAbsFile invDir (p ^. pathPath)
|
||||
FromAppFile m -> fromAppFile' m
|
||||
GetMainAppFile m -> getMainAppFile' m
|
||||
GetMainAppFileMaybe m -> getMainAppFileMaybe' m
|
||||
GetMainFile m -> getMainFile' m
|
||||
GetMainFileMaybe m -> getMainFileMaybe' m
|
||||
FromAppPathDir p -> liftIO (prepathToAbsDir invDir (p ^. pathPath))
|
||||
RenderStdOut t
|
||||
| _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' = getMainAppFile' >=> fromAppFile'
|
||||
|
||||
getMainAppFile' :: (Members '[SCache Package, EmbedIO] r') => Maybe (AppPath File) -> Sem r' (AppPath File)
|
||||
getMainAppFile' = \case
|
||||
Just p -> return p
|
||||
getMainFileMaybe' :: (Members '[SCache Package, EmbedIO] r') => Maybe (AppPath File) -> Sem r' (Maybe (Path Abs File))
|
||||
getMainFileMaybe' = getMainAppFileMaybe' >=> mapM fromAppFile'
|
||||
|
||||
getMainAppFileMaybe' :: (Members '[SCache Package, EmbedIO] r') => Maybe (AppPath File) -> Sem r' (Maybe (AppPath File))
|
||||
getMainAppFileMaybe' = \case
|
||||
Just p -> return (Just p)
|
||||
Nothing -> do
|
||||
pkg <- getPkg
|
||||
case pkg ^. packageMain of
|
||||
return $ case pkg ^. packageMain of
|
||||
Just p ->
|
||||
return
|
||||
AppPath
|
||||
{ _pathPath = p,
|
||||
_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 =
|
||||
@ -148,8 +158,8 @@ getEntryPoint' RunAppIOArgs {..} inputFile = do
|
||||
if
|
||||
| opts ^. globalStdin -> Just <$> liftIO getContents
|
||||
| otherwise -> return Nothing
|
||||
mainFile <- getMainAppFile inputFile
|
||||
set entryPointStdin estdin <$> entryPointFromGlobalOptionsPre root (mainFile ^. pathPath) opts
|
||||
mainFile <- getMainAppFileMaybe inputFile
|
||||
set entryPointStdin estdin <$> entryPointFromGlobalOptionsPre root ((^. pathPath) <$> mainFile) opts
|
||||
|
||||
runPipelineEither ::
|
||||
(Members '[EmbedIO, TaggedLock, ProgressLog, App] r, EntryPointOptions opts) =>
|
||||
@ -183,6 +193,12 @@ someBaseToAbs' f = do
|
||||
r <- askInvokeDir
|
||||
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 fp = do
|
||||
invokeDir <- askInvokeDir
|
||||
@ -282,9 +298,11 @@ runPipelineEntry entry p = runPipelineOptions $ do
|
||||
r <- runIOEither entry (inject p) >>= fromRightJuvixError
|
||||
return (snd r ^. pipelineResult)
|
||||
|
||||
runPipelineSetup :: (Members '[App, EmbedIO, Reader PipelineOptions, TaggedLock] r) => Sem (PipelineEff' r) a -> Sem r a
|
||||
-- runPipelineSetup p = ignoreProgressLog $ do -- TODO restore
|
||||
runPipelineSetup p = appRunProgressLog $ do
|
||||
runPipelineSetup ::
|
||||
(Members '[App, EmbedIO, Reader PipelineOptions, TaggedLock] r) =>
|
||||
Sem (PipelineEff' r) a ->
|
||||
Sem r a
|
||||
runPipelineSetup p = ignoreProgressLog $ do
|
||||
args <- askArgs
|
||||
entry <- getEntryPointStdin' args
|
||||
r <- runIOEitherPipeline entry (inject p) >>= fromRightJuvixError
|
||||
|
@ -11,7 +11,7 @@ runCommand opts = do
|
||||
root <- askRoot
|
||||
gopts <- askGlobalOptions
|
||||
inputFile :: Path Abs File <- fromAppPathFile sinputFile
|
||||
ep <- entryPointFromGlobalOptions root inputFile gopts
|
||||
ep <- entryPointFromGlobalOptions root (Just inputFile) gopts
|
||||
s' <- readFile inputFile
|
||||
(tab, _) <- getRight (Core.runParser inputFile defaultModuleId mempty s')
|
||||
let r =
|
||||
@ -19,7 +19,9 @@ runCommand opts = do
|
||||
. runReader ep
|
||||
. runError @JuvixError
|
||||
$ 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
|
||||
renderStdOut (Core.ppOut opts tab')
|
||||
where
|
||||
|
@ -41,7 +41,7 @@ runCommand replOpts = do
|
||||
gopts <- State.gets (^. replStateGlobalOptions)
|
||||
absInputFile :: Path Abs File <- replMakeAbsolute inputFile
|
||||
set entryPointTarget (Just Backend.TargetGeb)
|
||||
<$> runM (runTaggedLockPermissive (entryPointFromGlobalOptions root absInputFile gopts))
|
||||
<$> runM (runTaggedLockPermissive (entryPointFromGlobalOptions root (Just absInputFile) gopts))
|
||||
liftIO
|
||||
. State.evalStateT
|
||||
(replAction replOpts getReplEntryPoint)
|
||||
|
@ -10,7 +10,7 @@ import Juvix.Prelude.Pretty
|
||||
runCommand :: (Members '[EmbedIO, TaggedLock, App] r) => ScopeOptions -> Sem r ()
|
||||
runCommand opts = do
|
||||
globalOpts <- askGlobalOptions
|
||||
res :: Scoper.ScoperResult <- runPipelineNoOptions (opts ^. scopeInputFile) upToScoping
|
||||
res :: Scoper.ScoperResult <- runPipelineNoOptions (opts ^. scopeInputFile) upToScopingEntry
|
||||
let m :: Module 'Scoped 'ModuleTop = res ^. Scoper.resultModule
|
||||
if
|
||||
| opts ^. scopeWithComments ->
|
||||
|
@ -10,7 +10,7 @@ runCommand :: (Members '[EmbedIO, TaggedLock, App] r) => EvalOptions -> Sem r ()
|
||||
runCommand opts@EvalOptions {..} = do
|
||||
gopts <- askGlobalOptions
|
||||
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)
|
||||
let r =
|
||||
run
|
||||
|
@ -3,6 +3,10 @@ module Commands.Format where
|
||||
import Commands.Base
|
||||
import Commands.Format.Options
|
||||
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
|
||||
|
||||
data FormatNoEditRenderMode
|
||||
@ -16,7 +20,7 @@ data FormatRenderMode
|
||||
|
||||
data FormatTarget
|
||||
= TargetFile (Path Abs File)
|
||||
| TargetProject (Path Abs Dir)
|
||||
| TargetProject
|
||||
| TargetStdin
|
||||
|
||||
isTargetProject :: FormatTarget -> Bool
|
||||
@ -28,16 +32,15 @@ targetFromOptions :: (Members '[EmbedIO, App] r) => FormatOptions -> Sem r Forma
|
||||
targetFromOptions opts = do
|
||||
globalOpts <- askGlobalOptions
|
||||
let isStdin = globalOpts ^. globalStdin
|
||||
f <- mapM filePathToAbs (opts ^. formatInput)
|
||||
pkgDir <- askPkgDir
|
||||
f <- mapM fromAppPathFileOrDir (opts ^. formatInput)
|
||||
case f of
|
||||
Just (Left p) -> return (TargetFile p)
|
||||
Just Right {} -> return (TargetProject pkgDir)
|
||||
Just Right {} -> return TargetProject
|
||||
Nothing -> do
|
||||
isPackageGlobal <- askPackageGlobal
|
||||
if
|
||||
| isStdin -> return TargetStdin
|
||||
| not (isPackageGlobal) -> return (TargetProject pkgDir)
|
||||
| not isPackageGlobal -> return TargetProject
|
||||
| otherwise -> do
|
||||
exitFailMsg $
|
||||
Text.unlines
|
||||
@ -45,13 +48,30 @@ targetFromOptions opts = do
|
||||
"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 opts = do
|
||||
target <- targetFromOptions opts
|
||||
runOutputSem (renderFormattedOutput target opts) $ runScopeFileApp $ do
|
||||
runOutputSem (renderFormattedOutput target opts) . runScopeFileApp $ do
|
||||
res <- case target of
|
||||
TargetFile p -> format p
|
||||
TargetProject p -> formatProject p
|
||||
TargetProject -> formatProject
|
||||
TargetStdin -> do
|
||||
entry <- getEntryPointStdin
|
||||
runReader entry formatStdin
|
||||
@ -103,5 +123,5 @@ runScopeFileApp = interpret $ \case
|
||||
{ _pathPath = mkPrepath (toFilePath p),
|
||||
_pathIsInput = False
|
||||
}
|
||||
ignoreProgressLog (runPipelineProgress () (Just appFile) upToScoping)
|
||||
ScopeStdin e -> ignoreProgressLog (runPipelineEntry e upToScoping)
|
||||
ignoreProgressLog (runPipelineProgress () (Just appFile) upToScopingEntry)
|
||||
ScopeStdin e -> ignoreProgressLog (runPipelineEntry e upToScopingEntry)
|
||||
|
@ -3,7 +3,7 @@ module Commands.Format.Options where
|
||||
import CommonOptions
|
||||
|
||||
data FormatOptions = FormatOptions
|
||||
{ _formatInput :: Maybe (Prepath FileOrDir),
|
||||
{ _formatInput :: Maybe (AppPath FileOrDir),
|
||||
_formatCheck :: Bool,
|
||||
_formatInPlace :: Bool
|
||||
}
|
||||
@ -11,18 +11,21 @@ data FormatOptions = FormatOptions
|
||||
|
||||
makeLenses ''FormatOptions
|
||||
|
||||
parseInputJuvixFileOrDir :: Parser (Prepath FileOrDir)
|
||||
parseInputJuvixFileOrDir =
|
||||
strArgument
|
||||
( metavar "JUVIX_FILE_OR_PROJECT"
|
||||
<> help ("Path to a " <> show FileExtJuvix <> " file or to a directory containing a Juvix project.")
|
||||
<> completer (extCompleter FileExtJuvix)
|
||||
<> action "directory"
|
||||
)
|
||||
parseInputFileOrDir :: Parser (AppPath FileOrDir)
|
||||
parseInputFileOrDir = do
|
||||
_pathPath <-
|
||||
argument
|
||||
somePreFileOrDirOpt
|
||||
( metavar "JUVIX_FILE_OR_PROJECT"
|
||||
<> help ("Path to a " <> show FileExtJuvix <> " file or to a directory containing a Juvix project.")
|
||||
<> completer (extCompleter FileExtJuvix)
|
||||
<> action "directory"
|
||||
)
|
||||
pure AppPath {_pathIsInput = True, ..}
|
||||
|
||||
parseFormat :: Parser FormatOptions
|
||||
parseFormat = do
|
||||
_formatInput <- optional parseInputJuvixFileOrDir
|
||||
_formatInput <- optional parseInputFileOrDir
|
||||
_formatCheck <-
|
||||
switch
|
||||
( long "check"
|
||||
|
@ -16,7 +16,7 @@ import System.Process qualified as Process
|
||||
|
||||
runGenOnlySourceHtml :: (Members '[EmbedIO, TaggedLock, App] r) => HtmlOptions -> Sem r ()
|
||||
runGenOnlySourceHtml HtmlOptions {..} = do
|
||||
res <- runPipelineNoOptions _htmlInputFile upToScoping
|
||||
res <- runPipelineNoOptions _htmlInputFile upToScopingEntry
|
||||
let m = res ^. Scoper.resultModule
|
||||
outputDir <- fromAppPathDir _htmlOutputDir
|
||||
liftIO $
|
||||
|
@ -17,7 +17,7 @@ runCommand ::
|
||||
Sem r ()
|
||||
runCommand opts = do
|
||||
let inputFile = opts ^. markdownInputFile
|
||||
scopedM <- runPipelineNoOptions inputFile upToScoping
|
||||
scopedM <- runPipelineNoOptions inputFile upToScopingEntry
|
||||
let m = scopedM ^. Scoper.resultModule
|
||||
outputDir <- fromAppPathDir (opts ^. markdownOutputDir)
|
||||
let res =
|
||||
|
@ -143,10 +143,10 @@ getReplEntryPoint f inputFile = do
|
||||
liftIO (set entryPointSymbolPruningMode KeepAll <$> f root inputFile gopts)
|
||||
|
||||
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 = getReplEntryPoint (\r a -> runM . runTaggedLockPermissive . entryPointFromGlobalOptions r a)
|
||||
getReplEntryPointFromPath = getReplEntryPoint (\r a -> runM . runTaggedLockPermissive . entryPointFromGlobalOptions r (Just a))
|
||||
|
||||
displayVersion :: String -> Repl ()
|
||||
displayVersion _ = liftIO (putStrLn versionTag)
|
||||
|
@ -37,8 +37,8 @@ makeLenses ''AppPath
|
||||
instance Show (AppPath f) where
|
||||
show = Prelude.show . (^. pathPath)
|
||||
|
||||
parseInputFiles :: NonEmpty FileExt -> Parser (AppPath File)
|
||||
parseInputFiles exts' = do
|
||||
parseInputFilesMod :: NonEmpty FileExt -> Mod ArgumentFields (Prepath File) -> Parser (AppPath File)
|
||||
parseInputFilesMod exts' mods = do
|
||||
let exts = NonEmpty.toList exts'
|
||||
mvars = intercalate "|" (map toMetavar exts)
|
||||
dotExts = intercalate ", " (map Prelude.show exts)
|
||||
@ -51,9 +51,13 @@ parseInputFiles exts' = do
|
||||
<> help helpMsg
|
||||
<> completers
|
||||
<> action "file"
|
||||
<> mods
|
||||
)
|
||||
pure AppPath {_pathIsInput = True, ..}
|
||||
|
||||
parseInputFiles :: NonEmpty FileExt -> Parser (AppPath File)
|
||||
parseInputFiles exts' = parseInputFilesMod exts' mempty
|
||||
|
||||
parseInputFile :: FileExt -> Parser (AppPath File)
|
||||
parseInputFile = parseInputFiles . NonEmpty.singleton
|
||||
|
||||
@ -126,6 +130,9 @@ parseGenericOutputDir m = do
|
||||
somePreDirOpt :: ReadM (Prepath Dir)
|
||||
somePreDirOpt = mkPrepath <$> str
|
||||
|
||||
somePreFileOrDirOpt :: ReadM (Prepath FileOrDir)
|
||||
somePreFileOrDirOpt = mkPrepath <$> str
|
||||
|
||||
somePreFileOpt :: ReadM (Prepath File)
|
||||
somePreFileOpt = mkPrepath <$> str
|
||||
|
||||
|
@ -166,17 +166,17 @@ parseBuildDir m = do
|
||||
entryPointFromGlobalOptionsPre ::
|
||||
(Members '[TaggedLock, EmbedIO] r) =>
|
||||
Root ->
|
||||
Prepath File ->
|
||||
Maybe (Prepath File) ->
|
||||
GlobalOptions ->
|
||||
Sem r EntryPoint
|
||||
entryPointFromGlobalOptionsPre root premainFile opts = do
|
||||
mainFile <- liftIO (prepathToAbsFile (root ^. rootInvokeDir) premainFile)
|
||||
mainFile <- mapM (prepathToAbsFile (root ^. rootInvokeDir)) premainFile
|
||||
entryPointFromGlobalOptions root mainFile opts
|
||||
|
||||
entryPointFromGlobalOptions ::
|
||||
(Members '[TaggedLock, EmbedIO] r) =>
|
||||
Root ->
|
||||
Path Abs File ->
|
||||
Maybe (Path Abs File) ->
|
||||
GlobalOptions ->
|
||||
Sem r EntryPoint
|
||||
entryPointFromGlobalOptions root mainFile opts = do
|
||||
|
@ -38,14 +38,10 @@ data TopCommand
|
||||
deriving stock (Data)
|
||||
|
||||
topCommandInputPath :: TopCommand -> IO (Maybe (SomePath Abs))
|
||||
topCommandInputPath = \case
|
||||
JuvixFormat fopts -> case fopts ^. formatInput of
|
||||
Just f -> getInputPathFromPrepathFileOrDir f
|
||||
Nothing -> return Nothing
|
||||
t -> do
|
||||
d <- firstJustM getInputFileOrDir (universeBi t)
|
||||
f <- firstJustM getInputFile (universeBi t)
|
||||
return (f <|> d)
|
||||
topCommandInputPath t = do
|
||||
d <- firstJustM getInputFileOrDir (universeBi t)
|
||||
f <- firstJustM getInputFile (universeBi t)
|
||||
return (f <|> d)
|
||||
where
|
||||
getInputFile :: AppPath File -> IO (Maybe (SomePath Abs))
|
||||
getInputFile p
|
||||
|
@ -114,7 +114,7 @@ goModule onlyTypes infoTable Internal.Module {..} =
|
||||
defaultId =
|
||||
NameId
|
||||
{ _nameIdUid = 0,
|
||||
_nameIdModuleId = ModuleId "" "" ""
|
||||
_nameIdModuleId = defaultModuleId
|
||||
}
|
||||
|
||||
goConstructorDef :: Internal.ConstructorDef -> Constructor
|
||||
|
@ -87,11 +87,19 @@ instance Serialize TopModulePath
|
||||
|
||||
instance NFData TopModulePath
|
||||
|
||||
instance Hashable TopModulePath
|
||||
|
||||
makeLenses ''TopModulePath
|
||||
|
||||
topModulePathKey :: TopModulePath -> TopModulePathKey
|
||||
topModulePathKey TopModulePath {..} =
|
||||
TopModulePathKey
|
||||
{ _modulePathKeyDir = (^. symbolText) <$> _modulePathDir,
|
||||
_modulePathKeyName = _modulePathName ^. symbolText
|
||||
}
|
||||
|
||||
instance Pretty TopModulePath where
|
||||
pretty (TopModulePath path name) =
|
||||
mconcat (punctuate Pretty.dot (map pretty (snoc path name)))
|
||||
pretty = pretty . topModulePathKey
|
||||
|
||||
instance HasLoc TopModulePath where
|
||||
getLoc TopModulePath {..} =
|
||||
@ -115,8 +123,6 @@ moduleNameToTopModulePath = \case
|
||||
NameUnqualified s -> TopModulePath [] s
|
||||
NameQualified (QualifiedName (SymbolPath p) s) -> TopModulePath (toList p) s
|
||||
|
||||
instance Hashable TopModulePath
|
||||
|
||||
splitName :: Name -> ([Symbol], Symbol)
|
||||
splitName = \case
|
||||
NameQualified (QualifiedName (SymbolPath p) s) -> (toList p, s)
|
||||
|
@ -37,7 +37,7 @@ data Scope = Scope
|
||||
-- several imports under the same name. E.g.
|
||||
-- import A 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
|
||||
-- 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
|
||||
@ -48,11 +48,11 @@ data Scope = Scope
|
||||
}
|
||||
|
||||
newtype ModulesCache = ModulesCache
|
||||
{ _cachedModules :: HashMap TopModulePath ScopedModule
|
||||
{ _cachedModules :: HashMap TopModulePathKey ScopedModule
|
||||
}
|
||||
|
||||
newtype ScopeParameters = ScopeParameters
|
||||
{ _scopeImportedModules :: HashMap TopModulePath ScopedModule
|
||||
{ _scopeImportedModules :: HashMap TopModulePathKey ScopedModule
|
||||
}
|
||||
|
||||
data ScoperState = ScoperState
|
||||
|
@ -57,10 +57,11 @@ type family FieldArgIxType s = res | res -> s where
|
||||
FieldArgIxType 'Parsed = ()
|
||||
FieldArgIxType 'Scoped = Int
|
||||
|
||||
type ModuleIdType :: Stage -> GHC.Type
|
||||
type family ModuleIdType s = res | res -> s where
|
||||
ModuleIdType 'Parsed = ()
|
||||
ModuleIdType 'Scoped = ModuleId
|
||||
type ModuleIdType :: Stage -> ModuleIsTop -> GHC.Type
|
||||
type family ModuleIdType s t = res where
|
||||
ModuleIdType 'Parsed _ = ()
|
||||
ModuleIdType 'Scoped 'ModuleLocal = ()
|
||||
ModuleIdType 'Scoped 'ModuleTop = ModuleId
|
||||
|
||||
type SymbolType :: Stage -> GHC.Type
|
||||
type family SymbolType s = res | res -> s where
|
||||
@ -1197,7 +1198,7 @@ data Module (s :: Stage) (t :: ModuleIsTop) = Module
|
||||
_moduleBody :: [Statement s],
|
||||
_moduleKwEnd :: ModuleEndType t,
|
||||
_moduleOrigin :: ModuleInductiveType t,
|
||||
_moduleId :: ModuleIdType s,
|
||||
_moduleId :: ModuleIdType s t,
|
||||
_moduleMarkdownInfo :: Maybe MarkdownInfo
|
||||
}
|
||||
|
||||
|
@ -16,7 +16,16 @@ import Juvix.Compiler.Store.Language
|
||||
import Juvix.Prelude
|
||||
|
||||
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
|
||||
fromParsed = do
|
||||
e <- ask
|
||||
|
@ -32,14 +32,14 @@ import Juvix.Prelude
|
||||
|
||||
scopeCheck ::
|
||||
(Members '[HighlightBuilder, Error JuvixError, NameIdGen] r) =>
|
||||
EntryPoint ->
|
||||
Package ->
|
||||
ScopedModuleTable ->
|
||||
Parser.ParserResult ->
|
||||
Sem r ScoperResult
|
||||
scopeCheck entry importMap pr =
|
||||
mapError (JuvixError @ScoperError) $
|
||||
runReader entry $
|
||||
scopeCheck' importMap pr m
|
||||
scopeCheck pkg importMap pr =
|
||||
mapError (JuvixError @ScoperError)
|
||||
. runReader pkg
|
||||
$ scopeCheck' importMap pr m
|
||||
where
|
||||
m :: Module 'Parsed 'ModuleTop
|
||||
m = pr ^. Parser.resultModule
|
||||
@ -57,7 +57,7 @@ iniScoperState tab =
|
||||
}
|
||||
|
||||
scopeCheck' ::
|
||||
(Members '[HighlightBuilder, Error ScoperError, NameIdGen, Reader EntryPoint] r) =>
|
||||
(Members '[HighlightBuilder, Error ScoperError, NameIdGen, Reader Package] r) =>
|
||||
ScopedModuleTable ->
|
||||
Parser.ParserResult ->
|
||||
Module 'Parsed 'ModuleTop ->
|
||||
@ -69,6 +69,7 @@ scopeCheck' importTab pr m = do
|
||||
. runState (iniScoperState tab)
|
||||
$ checkTopModule m
|
||||
where
|
||||
tab :: InfoTable
|
||||
tab = computeCombinedInfoTable importTab
|
||||
|
||||
iniScopeParameters :: ScopeParameters
|
||||
@ -90,9 +91,9 @@ scopeCheck' importTab pr m = do
|
||||
|
||||
scopeCheckRepl ::
|
||||
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'.
|
||||
(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 ->
|
||||
Sem r' b
|
||||
) ->
|
||||
@ -120,7 +121,7 @@ scopeCheckRepl check importTab tab a = mapError (JuvixError @ScoperError) $ do
|
||||
-- TODO refactor to have less code duplication
|
||||
scopeCheckExpressionAtoms ::
|
||||
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 ->
|
||||
InfoTable ->
|
||||
ExpressionAtoms 'Parsed ->
|
||||
@ -129,7 +130,7 @@ scopeCheckExpressionAtoms = scopeCheckRepl checkExpressionAtoms
|
||||
|
||||
scopeCheckExpression ::
|
||||
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 ->
|
||||
InfoTable ->
|
||||
ExpressionAtoms 'Parsed ->
|
||||
@ -138,7 +139,7 @@ scopeCheckExpression = scopeCheckRepl checkParseExpressionAtoms
|
||||
|
||||
scopeCheckImport ::
|
||||
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 ->
|
||||
InfoTable ->
|
||||
Import 'Parsed ->
|
||||
@ -457,7 +458,7 @@ checkImport ::
|
||||
Reader InfoTable,
|
||||
NameIdGen,
|
||||
Reader BindingStrategy,
|
||||
Reader EntryPoint
|
||||
Reader Package
|
||||
]
|
||||
r
|
||||
) =>
|
||||
@ -479,7 +480,7 @@ checkImportPublic ::
|
||||
NameIdGen,
|
||||
HighlightBuilder,
|
||||
Reader BindingStrategy,
|
||||
Reader EntryPoint
|
||||
Reader Package
|
||||
]
|
||||
r
|
||||
) =>
|
||||
@ -616,7 +617,7 @@ checkImportNoPublic import_@Import {..} = do
|
||||
where
|
||||
addModuleToScope :: ScopedModule -> Sem r ()
|
||||
addModuleToScope smod = do
|
||||
let mpath :: TopModulePath = fromMaybe _importModulePath _importAsName
|
||||
let mpath :: TopModulePathKey = topModulePathKey (fromMaybe _importModulePath _importAsName)
|
||||
uid :: S.NameId = smod ^. scopedModuleName . S.nameId
|
||||
singTbl = HashMap.singleton 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)
|
||||
mapM_ output (tbl ^.. at path . _Just . each . to mkModuleEntry)
|
||||
where
|
||||
path = TopModulePath modules final
|
||||
path = topModulePathKey (TopModulePath modules final)
|
||||
|
||||
mkModuleEntry :: ScopedModule -> ModuleSymbolEntry
|
||||
mkModuleEntry m = ModuleSymbolEntry (m ^. scopedModuleName)
|
||||
@ -728,7 +729,7 @@ lookupQualifiedSymbol sms = do
|
||||
there :: Sem r' ()
|
||||
there = mapM_ (uncurry lookInTopModule) allTopPaths
|
||||
where
|
||||
allTopPaths :: [(TopModulePath, [Symbol])]
|
||||
allTopPaths :: [(TopModulePathKey, [Symbol])]
|
||||
allTopPaths = map (first nonEmptyToTopPath) raw
|
||||
where
|
||||
lpath = toList path
|
||||
@ -736,9 +737,12 @@ lookupQualifiedSymbol sms = do
|
||||
raw =
|
||||
[ (l, r) | i <- [1 .. length path], (Just l, r) <- [first nonEmpty (splitAt i lpath)]
|
||||
]
|
||||
nonEmptyToTopPath :: NonEmpty Symbol -> TopModulePath
|
||||
nonEmptyToTopPath l = TopModulePath (NonEmpty.init l) (NonEmpty.last l)
|
||||
lookInTopModule :: TopModulePath -> [Symbol] -> Sem r' ()
|
||||
nonEmptyToTopPath :: NonEmpty Symbol -> TopModulePathKey
|
||||
nonEmptyToTopPath lsym = TopModulePathKey (NonEmpty.init l) (NonEmpty.last l)
|
||||
where
|
||||
l = (^. symbolText) <$> lsym
|
||||
|
||||
lookInTopModule :: TopModulePathKey -> [Symbol] -> Sem r' ()
|
||||
lookInTopModule topPath remaining = do
|
||||
tbl <- gets (^. scopeTopModules)
|
||||
sequence_
|
||||
@ -866,7 +870,8 @@ readScopeModule import_ = do
|
||||
<> "\nAvailable modules:\n "
|
||||
<> 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 ::
|
||||
forall r.
|
||||
@ -895,22 +900,19 @@ checkFixityInfo ParsedFixityInfo {..} = do
|
||||
_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
|
||||
p <- asks (^. entryPointPackage)
|
||||
p <- ask
|
||||
return
|
||||
ModuleId
|
||||
{ _moduleIdPath =
|
||||
case sing :: SModuleIsTop t of
|
||||
SModuleLocal -> prettyText path
|
||||
SModuleTop -> prettyText path,
|
||||
{ _moduleIdPath = path,
|
||||
_moduleIdPackage = p ^. packageName,
|
||||
_moduleIdPackageVersion = show (p ^. packageVersion)
|
||||
}
|
||||
|
||||
checkFixitySyntaxDef ::
|
||||
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 ->
|
||||
Sem r (FixitySyntaxDef 'Scoped)
|
||||
checkFixitySyntaxDef FixitySyntaxDef {..} = topBindings $ do
|
||||
@ -1044,7 +1046,7 @@ resolveIteratorSyntaxDef s@IteratorSyntaxDef {..} = do
|
||||
|
||||
checkFunctionDef ::
|
||||
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 ->
|
||||
Sem r (FunctionDef 'Scoped)
|
||||
checkFunctionDef FunctionDef {..} = do
|
||||
@ -1110,7 +1112,7 @@ checkFunctionDef FunctionDef {..} = do
|
||||
|
||||
checkInductiveParameters ::
|
||||
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 ->
|
||||
Sem r (InductiveParameters 'Scoped)
|
||||
checkInductiveParameters params = do
|
||||
@ -1126,7 +1128,7 @@ checkInductiveParameters params = do
|
||||
|
||||
checkInductiveDef ::
|
||||
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 ->
|
||||
Sem r (InductiveDef 'Scoped)
|
||||
checkInductiveDef InductiveDef {..} = do
|
||||
@ -1245,7 +1247,7 @@ localBindings = runReader BindingLocal
|
||||
|
||||
checkTopModule ::
|
||||
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 ->
|
||||
Sem r (Module 'Scoped 'ModuleTop, ScopedModule, Scope)
|
||||
checkTopModule m@Module {..} = checkedModule
|
||||
@ -1286,7 +1288,7 @@ checkTopModule m@Module {..} = checkedModule
|
||||
registerModuleDoc (path' ^. S.nameId) doc'
|
||||
return (e, body', path', doc')
|
||||
localModules <- getLocalModules e
|
||||
_moduleId <- getModuleId (path' ^. S.nameConcrete)
|
||||
_moduleId <- getModuleId (topModulePathKey (path' ^. S.nameConcrete))
|
||||
let md =
|
||||
Module
|
||||
{ _modulePath = path',
|
||||
@ -1301,8 +1303,7 @@ checkTopModule m@Module {..} = checkedModule
|
||||
}
|
||||
smd =
|
||||
ScopedModule
|
||||
{ _scopedModuleId = _moduleId,
|
||||
_scopedModulePath = path',
|
||||
{ _scopedModulePath = path',
|
||||
_scopedModuleName = S.topModulePathName path',
|
||||
_scopedModuleFilePath = P.getModuleFilePath m,
|
||||
_scopedModuleExportInfo = e,
|
||||
@ -1353,7 +1354,7 @@ syntaxBlock m =
|
||||
|
||||
checkModuleBody ::
|
||||
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] ->
|
||||
Sem r (ExportInfo, [Statement 'Scoped])
|
||||
checkModuleBody body = do
|
||||
@ -1396,7 +1397,7 @@ checkModuleBody body = do
|
||||
|
||||
checkSections ::
|
||||
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 ->
|
||||
Sem r (StatementSections 'Scoped)
|
||||
checkSections sec = topBindings helper
|
||||
@ -1578,7 +1579,7 @@ checkSections sec = topBindings helper
|
||||
defineInductiveModule headConstr i = do
|
||||
runReader (getLoc (i ^. inductiveName)) genModule
|
||||
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
|
||||
_moduleKw <- G.kw G.kwModule
|
||||
_moduleKwEnd <- G.kw G.kwEnd
|
||||
@ -1694,7 +1695,7 @@ mkSections = \case
|
||||
StatementOpenModule o -> Right (NonDefinitionOpenModule o)
|
||||
|
||||
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 ->
|
||||
Sem r S.Symbol
|
||||
reserveLocalModuleSymbol =
|
||||
@ -1712,7 +1713,7 @@ checkLocalModule ::
|
||||
Reader InfoTable,
|
||||
NameIdGen,
|
||||
Reader BindingStrategy,
|
||||
Reader EntryPoint
|
||||
Reader Package
|
||||
]
|
||||
r
|
||||
) =>
|
||||
@ -1728,7 +1729,6 @@ checkLocalModule md@Module {..} = do
|
||||
doc' <- mapM checkJudoc _moduleDoc
|
||||
return (e, b, doc')
|
||||
_modulePath' <- reserveLocalModuleSymbol _modulePath
|
||||
_moduleId' <- getModuleId _modulePath
|
||||
localModules <- getLocalModules moduleExportInfo
|
||||
let mid = _modulePath' ^. S.nameId
|
||||
moduleName = S.unqualifiedSymbol _modulePath'
|
||||
@ -1739,15 +1739,14 @@ checkLocalModule md@Module {..} = do
|
||||
_moduleDoc = moduleDoc',
|
||||
_modulePragmas = _modulePragmas,
|
||||
_moduleMarkdownInfo = Nothing,
|
||||
_moduleId = _moduleId',
|
||||
_moduleId = (),
|
||||
_moduleKw,
|
||||
_moduleOrigin,
|
||||
_moduleKwEnd
|
||||
}
|
||||
smod =
|
||||
ScopedModule
|
||||
{ _scopedModuleId = _moduleId',
|
||||
_scopedModulePath = set nameConcrete (moduleNameToTopModulePath (NameUnqualified _modulePath)) moduleName,
|
||||
{ _scopedModulePath = set nameConcrete (moduleNameToTopModulePath (NameUnqualified _modulePath)) moduleName,
|
||||
_scopedModuleName = moduleName,
|
||||
_scopedModuleFilePath = P.getModuleFilePath md,
|
||||
_scopedModuleExportInfo = moduleExportInfo,
|
||||
@ -1758,7 +1757,7 @@ checkLocalModule md@Module {..} = do
|
||||
registerName _modulePath'
|
||||
return m
|
||||
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
|
||||
absPath <- (S.<.> _modulePath) <$> gets (^. scopePath)
|
||||
modify (set scopePath absPath)
|
||||
@ -2004,7 +2003,7 @@ filterExportInfo pub openModif = alterEntries . filterScope
|
||||
Nothing -> id
|
||||
|
||||
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 ->
|
||||
Sem r (AxiomDef 'Scoped)
|
||||
checkAxiomDef AxiomDef {..} = do
|
||||
@ -2020,7 +2019,7 @@ entryToSymbol sentry csym = set S.nameConcrete csym (sentry ^. nsEntry)
|
||||
|
||||
checkFunction ::
|
||||
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 ->
|
||||
Sem r (Function 'Scoped)
|
||||
checkFunction f = do
|
||||
@ -2039,7 +2038,7 @@ checkFunction f = do
|
||||
|
||||
-- | for now functions defined in let clauses cannot be infix operators
|
||||
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) ->
|
||||
Sem r (NonEmpty (LetStatement 'Scoped))
|
||||
checkLetStatements =
|
||||
@ -2157,7 +2156,7 @@ checkListPattern l = do
|
||||
|
||||
checkList ::
|
||||
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 ->
|
||||
Sem r (List 'Scoped)
|
||||
checkList l = do
|
||||
@ -2168,7 +2167,7 @@ checkList l = do
|
||||
|
||||
checkLet ::
|
||||
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 ->
|
||||
Sem r (Let 'Scoped)
|
||||
checkLet Let {..} =
|
||||
@ -2185,7 +2184,7 @@ checkLet Let {..} =
|
||||
|
||||
checkCaseBranch ::
|
||||
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 ->
|
||||
Sem r (CaseBranch 'Scoped)
|
||||
checkCaseBranch CaseBranch {..} = withLocalScope $ do
|
||||
@ -2199,7 +2198,7 @@ checkCaseBranch CaseBranch {..} = withLocalScope $ do
|
||||
}
|
||||
|
||||
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 ->
|
||||
Sem r (Case 'Scoped)
|
||||
checkCase Case {..} = do
|
||||
@ -2215,7 +2214,7 @@ checkCase Case {..} = do
|
||||
|
||||
checkIfBranch ::
|
||||
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 ->
|
||||
Sem r (IfBranch 'Scoped)
|
||||
checkIfBranch IfBranch {..} = withLocalScope $ do
|
||||
@ -2230,7 +2229,7 @@ checkIfBranch IfBranch {..} = withLocalScope $ do
|
||||
|
||||
checkIfBranchElse ::
|
||||
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 ->
|
||||
Sem r (IfBranchElse 'Scoped)
|
||||
checkIfBranchElse IfBranchElse {..} = withLocalScope $ do
|
||||
@ -2242,7 +2241,7 @@ checkIfBranchElse IfBranchElse {..} = withLocalScope $ do
|
||||
}
|
||||
|
||||
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 ->
|
||||
Sem r (If 'Scoped)
|
||||
checkIf If {..} = do
|
||||
@ -2256,7 +2255,7 @@ checkIf If {..} = do
|
||||
}
|
||||
|
||||
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 ->
|
||||
Sem r (Lambda 'Scoped)
|
||||
checkLambda Lambda {..} = do
|
||||
@ -2269,7 +2268,7 @@ checkLambda Lambda {..} = do
|
||||
}
|
||||
|
||||
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 ->
|
||||
Sem r (LambdaClause 'Scoped)
|
||||
checkLambdaClause LambdaClause {..} = withLocalScope $ do
|
||||
@ -2458,7 +2457,7 @@ checkScopedIden ::
|
||||
checkScopedIden n = checkName n >>= entryToScopedIden n
|
||||
|
||||
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 ->
|
||||
Sem r (NonEmpty (ExpressionAtom 'Scoped))
|
||||
checkExpressionAtom e = case e of
|
||||
@ -2482,7 +2481,7 @@ checkExpressionAtom e = case e of
|
||||
AtomNamedApplicationNew i -> pure . AtomNamedApplicationNew <$> checkNamedApplicationNew 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
|
||||
let nargs = napp ^. namedApplicationNewArguments
|
||||
aname <- checkScopedIden (napp ^. namedApplicationNewName)
|
||||
@ -2505,7 +2504,7 @@ checkNamedApplicationNew napp = do
|
||||
}
|
||||
|
||||
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 ->
|
||||
NamedArgumentNew 'Parsed ->
|
||||
Sem r (NamedArgumentNew 'Scoped)
|
||||
@ -2519,7 +2518,7 @@ checkNamedArgumentNew snames NamedArgumentNew {..} = do
|
||||
{ _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
|
||||
tyName' <- getNameOfKind KNameInductive _recordUpdateTypeName
|
||||
info <- getRecordInfo tyName'
|
||||
@ -2543,7 +2542,7 @@ checkRecordUpdate RecordUpdate {..} = do
|
||||
}
|
||||
|
||||
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 ->
|
||||
RecordUpdateField 'Parsed ->
|
||||
Sem r (RecordUpdateField 'Scoped)
|
||||
@ -2563,7 +2562,7 @@ checkUpdateField sig f = do
|
||||
|
||||
checkNamedApplication ::
|
||||
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 ->
|
||||
Sem r (NamedApplication 'Scoped)
|
||||
checkNamedApplication napp = do
|
||||
@ -2617,7 +2616,7 @@ getNameSignature s = do
|
||||
lookupNameSignature s' = gets (^. scoperScopedSignatures . at s')
|
||||
|
||||
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 ->
|
||||
Sem r (Iterator 'Scoped)
|
||||
checkIterator iter = do
|
||||
@ -2660,7 +2659,7 @@ checkIterator iter = do
|
||||
return Iterator {..}
|
||||
|
||||
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 ->
|
||||
Sem r (Initializer 'Scoped)
|
||||
checkInitializer ini = do
|
||||
@ -2673,7 +2672,7 @@ checkInitializer ini = do
|
||||
}
|
||||
|
||||
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 ->
|
||||
Sem r (Range 'Scoped)
|
||||
checkRange rng = do
|
||||
@ -2698,7 +2697,7 @@ checkHole h = do
|
||||
}
|
||||
|
||||
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 ->
|
||||
Sem r Expression
|
||||
checkParens e@(ExpressionAtoms as _) = case as of
|
||||
@ -2714,13 +2713,13 @@ checkParens e@(ExpressionAtoms as _) = case as of
|
||||
|
||||
checkExpressionAtoms ::
|
||||
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 ->
|
||||
Sem r (ExpressionAtoms 'Scoped)
|
||||
checkExpressionAtoms (ExpressionAtoms l i) = (`ExpressionAtoms` i) <$> sconcatMap checkExpressionAtom l
|
||||
|
||||
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 ->
|
||||
Sem r (Judoc 'Scoped)
|
||||
checkJudoc (Judoc groups) =
|
||||
@ -2729,7 +2728,7 @@ checkJudoc (Judoc groups) =
|
||||
$ Judoc <$> mapM checkJudocGroup groups
|
||||
|
||||
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 ->
|
||||
Sem r (JudocGroup 'Scoped)
|
||||
checkJudocGroup = \case
|
||||
@ -2737,26 +2736,26 @@ checkJudocGroup = \case
|
||||
JudocGroupLines l -> JudocGroupLines <$> mapM checkJudocBlock l
|
||||
|
||||
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 ->
|
||||
Sem r (JudocBlock 'Scoped)
|
||||
checkJudocBlock = \case
|
||||
JudocLines l -> JudocLines <$> mapM checkJudocLine l
|
||||
|
||||
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 ->
|
||||
Sem r (JudocBlockParagraph 'Scoped)
|
||||
checkJudocBlockParagraph = traverseOf judocBlockParagraphBlocks (mapM checkJudocBlock)
|
||||
|
||||
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 ->
|
||||
Sem r (JudocLine 'Scoped)
|
||||
checkJudocLine (JudocLine delim atoms) = JudocLine delim <$> mapM (mapM checkJudocAtom) atoms
|
||||
|
||||
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 ->
|
||||
Sem r (JudocAtom 'Scoped)
|
||||
checkJudocAtom = \case
|
||||
@ -2765,7 +2764,7 @@ checkJudocAtom = \case
|
||||
|
||||
checkParseExpressionAtoms ::
|
||||
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 ->
|
||||
Sem r Expression
|
||||
checkParseExpressionAtoms = checkExpressionAtoms >=> parseExpressionAtoms
|
||||
@ -2777,7 +2776,7 @@ checkParsePatternAtom ::
|
||||
checkParsePatternAtom = checkPatternAtom >=> parsePatternAtom
|
||||
|
||||
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 ->
|
||||
Sem r (SyntaxDef 'Scoped)
|
||||
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.Language
|
||||
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.Prelude
|
||||
|
||||
@ -22,4 +21,4 @@ mainModule :: Lens' ScoperResult (Module 'Scoped 'ModuleTop)
|
||||
mainModule = resultModule
|
||||
|
||||
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.TopModuleNameChecker
|
||||
import Juvix.Compiler.Pipeline.EntryPoint
|
||||
import Juvix.Data.Yaml
|
||||
import Juvix.Extra.Paths
|
||||
import Juvix.Extra.Strings qualified as Str
|
||||
@ -48,20 +47,18 @@ type PragmasStash = State (Maybe ParsedPragmas)
|
||||
|
||||
fromSource ::
|
||||
(Members '[HighlightBuilder, TopModuleNameChecker, Files, Error JuvixError] r) =>
|
||||
EntryPoint ->
|
||||
Maybe Text ->
|
||||
Maybe (Path Abs File) ->
|
||||
Sem r ParserResult
|
||||
fromSource e = mapError (JuvixError @ParserError) $ do
|
||||
(_resultParserState, _resultModule) <-
|
||||
runParserResultBuilder mempty
|
||||
. evalTopNameIdGen defaultModuleId
|
||||
$ getParsedModuleTop
|
||||
fromSource mstdin minputfile = mapError (JuvixError @ParserError) $ do
|
||||
(_resultParserState, _resultModule) <- runParserResultBuilder mempty getParsedModuleTop
|
||||
return ParserResult {..}
|
||||
where
|
||||
getParsedModuleTop ::
|
||||
forall r.
|
||||
(Members '[Files, TopModuleNameChecker, Error ParserError, ParserResultBuilder] r) =>
|
||||
Sem r (Module 'Parsed 'ModuleTop)
|
||||
getParsedModuleTop = case (e ^. entryPointStdin, e ^. entryPointModulePath) of
|
||||
getParsedModuleTop = case (mstdin, minputfile) of
|
||||
(Nothing, Nothing) -> throw $ ErrStdinOrFile StdinOrFileError
|
||||
(Just txt, Just x) ->
|
||||
runModuleParser x txt >>= \case
|
||||
@ -87,8 +84,8 @@ fromSource e = mapError (JuvixError @ParserError) $ do
|
||||
where
|
||||
getFileContents :: Path Abs File -> Sem r Text
|
||||
getFileContents fp
|
||||
| Just fp == e ^. entryPointModulePath,
|
||||
Just txt <- e ^. entryPointStdin =
|
||||
| Just fp == minputfile,
|
||||
Just txt <- mstdin =
|
||||
return txt
|
||||
| otherwise = readFile' fp
|
||||
|
||||
|
@ -10,3 +10,6 @@ data ParserResult = ParserResult
|
||||
}
|
||||
|
||||
makeLenses ''ParserResult
|
||||
|
||||
getParserResultComments :: ParserResult -> Comments
|
||||
getParserResultComments sr = mkComments $ sr ^. resultParserState . parserStateComments
|
||||
|
@ -208,13 +208,14 @@ traverseM' ::
|
||||
traverseM' f x = sequence <$> traverse f x
|
||||
|
||||
toPreModule ::
|
||||
forall r t.
|
||||
(SingI t, Members '[Reader EntryPoint, Reader DefaultArgsStack, Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, State ConstructorInfos, Reader S.InfoTable] r) =>
|
||||
Module 'Scoped t ->
|
||||
forall r.
|
||||
(Members '[Reader EntryPoint, Reader DefaultArgsStack, Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, State ConstructorInfos, Reader S.InfoTable] r) =>
|
||||
Module 'Scoped 'ModuleTop ->
|
||||
Sem r Internal.PreModule
|
||||
toPreModule Module {..} = do
|
||||
pragmas' <- goPragmas _modulePragmas
|
||||
body' <- local (const pragmas') (goModuleBody _moduleBody)
|
||||
let name' = goTopModulePath _modulePath
|
||||
return
|
||||
Internal.Module
|
||||
{ _moduleName = name',
|
||||
@ -222,11 +223,6 @@ toPreModule Module {..} = do
|
||||
_modulePragmas = pragmas',
|
||||
_moduleId
|
||||
}
|
||||
where
|
||||
name' :: Internal.Name
|
||||
name' = case sing :: SModuleIsTop t of
|
||||
SModuleTop -> goTopModulePath _modulePath
|
||||
SModuleLocal -> goSymbol _modulePath
|
||||
|
||||
goTopModulePath :: S.TopModulePath -> Internal.Name
|
||||
goTopModulePath p = goSymbolPretty (prettyText p) (S.topModulePathSymbol p)
|
||||
|
@ -80,6 +80,7 @@ type PipelineLocalEff =
|
||||
Error JuvixError,
|
||||
HighlightBuilder,
|
||||
Internet,
|
||||
Reader NumThreads,
|
||||
Concurrent
|
||||
]
|
||||
|
||||
@ -101,7 +102,9 @@ makeLenses ''PipelineOptions
|
||||
upToParsing ::
|
||||
(Members '[HighlightBuilder, TopModuleNameChecker, Reader EntryPoint, Error JuvixError, Files] r) =>
|
||||
Sem r Parser.ParserResult
|
||||
upToParsing = ask >>= Parser.fromSource
|
||||
upToParsing = do
|
||||
e <- ask
|
||||
Parser.fromSource (e ^. entryPointStdin) (e ^. entryPointModulePath)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Workflows from parsed source
|
||||
@ -112,15 +115,24 @@ upToParsedSource ::
|
||||
Sem r Parser.ParserResult
|
||||
upToParsedSource = ask
|
||||
|
||||
upToScoping ::
|
||||
upToScopingEntry ::
|
||||
(Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Error JuvixError, NameIdGen] r) =>
|
||||
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
|
||||
|
||||
upToInternal ::
|
||||
(Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Error JuvixError, NameIdGen, Termination] r) =>
|
||||
Sem r Internal.InternalResult
|
||||
upToInternal = upToScoping >>= Internal.fromConcrete
|
||||
upToInternal = do
|
||||
pkg <- asks (^. entryPointPackage)
|
||||
runReader pkg upToScoping >>= Internal.fromConcrete
|
||||
|
||||
upToInternalTyped ::
|
||||
(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.moduleInfoOptions == opts
|
||||
&& info ^. Store.moduleInfoFieldSize == entry ^. entryPointFieldSize -> do
|
||||
CompileResult {..} <- runReader entry ((processImports (info ^. Store.moduleInfoImports)))
|
||||
CompileResult {..} <- runReader entry (processImports (info ^. Store.moduleInfoImports))
|
||||
if
|
||||
| _compileResultChanged ->
|
||||
recompile sha256 absPath
|
||||
@ -140,24 +140,26 @@ processRecursiveUpToTyped ::
|
||||
Sem r (InternalTypedResult, [InternalTypedResult])
|
||||
processRecursiveUpToTyped = do
|
||||
entry <- ask
|
||||
PipelineResult res mtab _ <- processFileUpToParsing entry
|
||||
let imports = HashMap.keys (mtab ^. Store.moduleTable)
|
||||
ms <- forM imports (`withPathFile` goImport)
|
||||
mid <- getModuleId (res ^. Parser.resultModule . modulePath)
|
||||
PipelineResult {..} <- processFileUpToParsing entry
|
||||
let imports = HashMap.keys (_pipelineResultImports ^. Store.moduleTable)
|
||||
ms <- forM imports $ \imp ->
|
||||
withPathFile imp goImport
|
||||
let pkg = entry ^. entryPointPackage
|
||||
mid <- runReader pkg (getModuleId (_pipelineResult ^. Parser.resultModule . modulePath . to topModulePathKey))
|
||||
a <-
|
||||
evalTopNameIdGen mid
|
||||
. runReader mtab
|
||||
. runReader res
|
||||
. runReader _pipelineResultImports
|
||||
. runReader _pipelineResult
|
||||
$ upToInternalTyped
|
||||
return (a, ms)
|
||||
where
|
||||
goImport :: Path Abs File -> Sem r InternalTypedResult
|
||||
goImport path = do
|
||||
goImport :: ImportNode -> Sem r InternalTypedResult
|
||||
goImport node = do
|
||||
entry <- ask
|
||||
let entry' =
|
||||
entry
|
||||
{ _entryPointStdin = Nothing,
|
||||
_entryPointModulePath = Just path
|
||||
_entryPointModulePath = Just (node ^. importNodeAbsFile)
|
||||
}
|
||||
(^. pipelineResult) <$> runReader entry' (processFileUpTo upToInternalTyped)
|
||||
|
||||
@ -166,18 +168,17 @@ processImport ::
|
||||
(Members '[ModuleInfoCache, Reader EntryPoint, Error JuvixError, Files, PathResolver] r) =>
|
||||
TopModulePath ->
|
||||
Sem r (PipelineResult Store.ModuleInfo)
|
||||
processImport p = do
|
||||
withPathFile p getCachedImport
|
||||
processImport p = withPathFile p getCachedImport
|
||||
where
|
||||
getCachedImport :: Path Abs File -> Sem r (PipelineResult Store.ModuleInfo)
|
||||
getCachedImport file = do
|
||||
getCachedImport :: ImportNode -> Sem r (PipelineResult Store.ModuleInfo)
|
||||
getCachedImport node = do
|
||||
b <- supportsParallel
|
||||
root <- resolverRoot
|
||||
eix <- mkEntryIndex node
|
||||
if
|
||||
| b -> do
|
||||
res <- mkEntryIndex root file >>= cacheGetResult
|
||||
res <- cacheGetResult eix
|
||||
return (res ^. cacheResult)
|
||||
| otherwise -> mkEntryIndex root file >>= processModule
|
||||
| otherwise -> processModule eix
|
||||
|
||||
processFileUpToParsing ::
|
||||
forall r.
|
||||
@ -203,7 +204,8 @@ processFileUpTo ::
|
||||
processFileUpTo a = do
|
||||
entry <- ask
|
||||
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' <-
|
||||
evalTopNameIdGen mid
|
||||
. runReader (res ^. pipelineResultImports)
|
||||
@ -257,7 +259,8 @@ processFileToStoredCore ::
|
||||
Sem r (PipelineResult Core.CoreResult)
|
||||
processFileToStoredCore entry = ignoreHighlightBuilder . runReader entry $ do
|
||||
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 <-
|
||||
evalTopNameIdGen mid
|
||||
. runReader (res ^. pipelineResultImports)
|
||||
|
@ -1,5 +1,6 @@
|
||||
module Juvix.Compiler.Pipeline.DriverParallel
|
||||
( compileInParallel,
|
||||
compileInParallel_,
|
||||
ModuleInfoCache,
|
||||
evalModuleInfoCache,
|
||||
module Parallel.ProgressLog,
|
||||
@ -29,13 +30,13 @@ data CompileResult = CompileResult
|
||||
|
||||
makeLenses ''CompileResult
|
||||
|
||||
type NodeId = Path Abs File
|
||||
|
||||
type Node = EntryIndex
|
||||
|
||||
type CompileProof = PipelineResult Store.ModuleInfo
|
||||
|
||||
mkNodesIndex :: forall r. (Members '[Reader EntryPoint] r) => ImportTree -> Sem r (NodesIndex NodeId Node)
|
||||
mkNodesIndex ::
|
||||
forall r.
|
||||
(Members '[Reader EntryPoint] r) =>
|
||||
ImportTree ->
|
||||
Sem r (NodesIndex ImportNode Node)
|
||||
mkNodesIndex tree =
|
||||
NodesIndex
|
||||
. hashMap
|
||||
@ -44,29 +45,47 @@ mkNodesIndex tree =
|
||||
| fromNode <- HashMap.keys (tree ^. importTree)
|
||||
]
|
||||
where
|
||||
mkAssoc :: ImportNode -> Sem r (Path Abs File, EntryIndex)
|
||||
mkAssoc :: ImportNode -> Sem r (ImportNode, EntryIndex)
|
||||
mkAssoc p = do
|
||||
let abspath = p ^. importNodeAbsFile
|
||||
i <- mkEntryIndex (p ^. importNodePackageRoot) abspath
|
||||
return (abspath, i)
|
||||
i <- mkEntryIndex p
|
||||
return (p, i)
|
||||
|
||||
mkDependencies :: ImportTree -> Dependencies NodeId
|
||||
mkDependencies :: ImportTree -> Dependencies ImportNode
|
||||
mkDependencies tree =
|
||||
Dependencies
|
||||
{ _dependenciesTable = helper (tree ^. importTree),
|
||||
_dependenciesTableReverse = helper (tree ^. importTreeReverse)
|
||||
{ _dependenciesTable = tree ^. importTree,
|
||||
_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
|
||||
toPath = (^. importNodeAbsFile)
|
||||
getNodePath :: Node -> ImportNode
|
||||
getNodePath = (^. entryIxImportNode)
|
||||
|
||||
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 ::
|
||||
forall r.
|
||||
( Members
|
||||
@ -81,20 +100,19 @@ compileInParallel ::
|
||||
Error JuvixError,
|
||||
Reader EntryPoint,
|
||||
PathResolver,
|
||||
Reader NumThreads,
|
||||
Reader ImportTree
|
||||
]
|
||||
r
|
||||
) =>
|
||||
NumThreads ->
|
||||
EntryIndex ->
|
||||
Sem r ()
|
||||
compileInParallel nj _entry = do
|
||||
Sem r (HashMap ImportNode (PipelineResult Store.ModuleInfo))
|
||||
compileInParallel = do
|
||||
-- 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
|
||||
t <- ask
|
||||
idx <- mkNodesIndex t
|
||||
numWorkers <- numThreads nj
|
||||
let args :: CompileArgs r NodeId Node CompileProof
|
||||
numWorkers <- ask >>= numThreads
|
||||
let args :: CompileArgs r ImportNode Node (PipelineResult Store.ModuleInfo)
|
||||
args =
|
||||
CompileArgs
|
||||
{ _compileArgsNodesIndex = idx,
|
||||
@ -104,11 +122,14 @@ compileInParallel nj _entry = do
|
||||
_compileArgsNumWorkers = numWorkers,
|
||||
_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 =
|
||||
withResolverRoot (e ^. entryIxResolverRoot)
|
||||
withResolverRoot (e ^. entryIxImportNode . importNodePackageRoot)
|
||||
. fmap force
|
||||
$ processModule e
|
||||
|
||||
@ -139,11 +160,11 @@ evalModuleInfoCache ::
|
||||
Error JuvixError,
|
||||
PathResolver,
|
||||
Reader ImportScanStrategy,
|
||||
Reader NumThreads,
|
||||
Files
|
||||
]
|
||||
r
|
||||
) =>
|
||||
NumThreads ->
|
||||
Sem (ModuleInfoCache ': JvoCache ': 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?
|
||||
defaultTarget = TargetCore
|
||||
|
||||
defaultEntryPoint :: Package -> Root -> Path Abs File -> EntryPoint
|
||||
defaultEntryPoint :: Package -> Root -> Maybe (Path Abs File) -> EntryPoint
|
||||
defaultEntryPoint pkg root mainFile =
|
||||
(defaultEntryPointNoFile pkg root)
|
||||
{ _entryPointModulePath = pure mainFile
|
||||
{ _entryPointModulePath = mainFile
|
||||
}
|
||||
|
||||
defaultEntryPointNoFile :: Package -> Root -> EntryPoint
|
||||
|
@ -9,7 +9,7 @@ defaultEntryPointIO :: (Members '[EmbedIO, TaggedLock, EmbedIO] r) => Path Abs D
|
||||
defaultEntryPointIO cwd mainFile = do
|
||||
root <- findRootAndChangeDir (Just (parent mainFile)) Nothing cwd
|
||||
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 cwd = do
|
||||
|
@ -1,5 +1,6 @@
|
||||
module Juvix.Compiler.Pipeline.JvoCache where
|
||||
|
||||
import Juvix.Compiler.Pipeline.Loader.PathResolver.ImportTree.ImportNode
|
||||
import Juvix.Compiler.Store.Language qualified as Store
|
||||
import Juvix.Extra.Serialize qualified as Serialize
|
||||
import Juvix.Prelude
|
||||
@ -10,8 +11,8 @@ evalJvoCache :: (Members '[TaggedLock, Files] r) => Sem (JvoCache ': r) a -> Sem
|
||||
evalJvoCache = evalCacheEmpty Serialize.loadFromFile
|
||||
|
||||
-- | Used to fill the cache in parallel
|
||||
preLoadFromFile :: (Members '[JvoCache] r) => Path Abs File -> Sem r ()
|
||||
preLoadFromFile = void . fmap force . cacheGetResult @(Path Abs File) @(Maybe Store.ModuleInfo)
|
||||
preLoadFromFile :: (Members '[JvoCache] r) => ImportNode -> Sem r ()
|
||||
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 = cacheGet
|
||||
|
@ -6,6 +6,7 @@ where
|
||||
|
||||
import Juvix.Compiler.Concrete.Data.Name
|
||||
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.Paths
|
||||
import Juvix.Prelude
|
||||
@ -37,7 +38,6 @@ data PathResolver :: Effect where
|
||||
ResolvePath :: ImportScan -> PathResolver m (PackageInfo, FileExt)
|
||||
-- | The root is assumed to be a package root.
|
||||
WithResolverRoot :: Path Abs Dir -> m a -> PathResolver m a
|
||||
-- TODO remove: ugly af
|
||||
SupportsParallel :: PathResolver m Bool
|
||||
ResolverRoot :: PathResolver m (Path Abs Dir)
|
||||
|
||||
@ -48,20 +48,26 @@ makeSem ''PathResolver
|
||||
withPathFile ::
|
||||
(Members '[PathResolver] r) =>
|
||||
TopModulePath ->
|
||||
(Path Abs File -> Sem r a) ->
|
||||
(ImportNode -> Sem r a) ->
|
||||
Sem r a
|
||||
withPathFile m f = do
|
||||
(root, file) <- resolveTopModulePath m
|
||||
withResolverRoot root (f (root <//> file))
|
||||
node <- resolveTopModulePath m
|
||||
let root = node ^. importNodePackageRoot
|
||||
withResolverRoot root (f node)
|
||||
|
||||
-- | Returns the root of the package where the module belongs and the path to
|
||||
-- the module relative to the root.
|
||||
resolveTopModulePath ::
|
||||
(Members '[PathResolver] r) =>
|
||||
TopModulePath ->
|
||||
Sem r (Path Abs Dir, Path Rel File)
|
||||
Sem r ImportNode
|
||||
resolveTopModulePath mp = do
|
||||
let scan = topModulePathToImportScan mp
|
||||
relpath = topModulePathToRelativePathNoExt mp
|
||||
(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,
|
||||
importTreeReverse,
|
||||
importTreeEdges,
|
||||
importTreeNodes,
|
||||
importTreeProjectNodes,
|
||||
ImportTreeBuilder,
|
||||
runImportTreeBuilder,
|
||||
ignoreImportTreeBuilder,
|
||||
@ -93,6 +95,17 @@ importTree = fimportTree
|
||||
importTreeReverse :: SimpleGetter ImportTree (HashMap ImportNode (HashSet ImportNode))
|
||||
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 = fimportTreeEdges
|
||||
|
||||
|
@ -11,15 +11,22 @@ topModulePathToRelativePath' m =
|
||||
ext = fileExtension' absPath
|
||||
in topModulePathToRelativePath ext "" (</>) m
|
||||
|
||||
topModulePathKeyToRelativePathNoExt :: TopModulePathKey -> Path Rel File
|
||||
topModulePathKeyToRelativePathNoExt TopModulePathKey {..} =
|
||||
relFile (joinFilePaths (map unpack (_modulePathKeyDir ++ [_modulePathKeyName])))
|
||||
|
||||
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 t@TopModulePath {..} =
|
||||
ImportScan
|
||||
{ _importNames = unpack . (^. withLocParam) <$> (NonEmpty.prependList _modulePathDir (pure _modulePathName)),
|
||||
_importLoc = getLoc t
|
||||
}
|
||||
topModulePathToImportScan t = topModulePathKeyToImportScan (getLoc t) (topModulePathKey t)
|
||||
|
||||
topModulePathToRelativePath :: String -> String -> (FilePath -> FilePath -> FilePath) -> TopModulePath -> Path Rel File
|
||||
topModulePathToRelativePath ext suffix joinpath mp = relFile relFilePath
|
||||
|
@ -1,6 +1,7 @@
|
||||
module Juvix.Compiler.Pipeline.ModuleInfoCache where
|
||||
|
||||
import Juvix.Compiler.Pipeline.EntryPoint
|
||||
import Juvix.Compiler.Pipeline.Loader.PathResolver.ImportTree.ImportNode
|
||||
import Juvix.Compiler.Pipeline.Result
|
||||
import Juvix.Compiler.Store.Language qualified as Store
|
||||
import Juvix.Data.Effect.Cache
|
||||
@ -8,7 +9,7 @@ import Juvix.Prelude
|
||||
|
||||
data EntryIndex = EntryIndex
|
||||
{ _entryIxEntry :: EntryPoint,
|
||||
_entryIxResolverRoot :: Path Abs Dir
|
||||
_entryIxImportNode :: ImportNode
|
||||
}
|
||||
|
||||
makeLenses ''EntryIndex
|
||||
@ -27,10 +28,11 @@ entryIndexPath = fromMaybe err . (^. entryIxEntry . entryPointModulePath)
|
||||
err :: a
|
||||
err = error "unexpected: EntryIndex should always have a path"
|
||||
|
||||
mkEntryIndex :: (Members '[Reader EntryPoint] r) => Path Abs Dir -> Path Abs File -> Sem r EntryIndex
|
||||
mkEntryIndex _entryIxResolverRoot path = do
|
||||
mkEntryIndex :: (Members '[Reader EntryPoint] r) => ImportNode -> Sem r EntryIndex
|
||||
mkEntryIndex node = do
|
||||
entry <- ask
|
||||
let stdin'
|
||||
let path = node ^. importNodeAbsFile
|
||||
stdin'
|
||||
| Just path == entry ^. entryPointModulePath = entry ^. entryPointStdin
|
||||
| otherwise = Nothing
|
||||
entry' =
|
||||
@ -41,5 +43,5 @@ mkEntryIndex _entryIxResolverRoot path = do
|
||||
return
|
||||
EntryIndex
|
||||
{ _entryIxEntry = entry',
|
||||
_entryIxResolverRoot
|
||||
_entryIxImportNode = node
|
||||
}
|
||||
|
@ -149,7 +149,7 @@ loadPackage' packagePath = do
|
||||
rootPath = parent packagePath
|
||||
|
||||
packageEntryPoint :: EntryPoint
|
||||
packageEntryPoint = defaultEntryPoint rootPkg root packagePath
|
||||
packageEntryPoint = defaultEntryPoint rootPkg root (Just packagePath)
|
||||
where
|
||||
root :: Root
|
||||
root =
|
||||
|
@ -38,9 +38,11 @@ upToInternalExpression ::
|
||||
upToInternalExpression p = do
|
||||
scopeTable <- gets (^. artifactScopeTable)
|
||||
mtab <- gets (^. artifactModuleTable)
|
||||
pkg <- asks (^. entryPointPackage)
|
||||
runBuiltinsArtifacts
|
||||
. runScoperScopeArtifacts
|
||||
. runStateArtifacts artifactScoperState
|
||||
. runReader pkg
|
||||
$ runNameIdGenArtifacts (Scoper.scopeCheckExpression (Store.getScopedModuleTable mtab) scopeTable p)
|
||||
>>= runNameIdGenArtifacts . runReader scopeTable . Internal.fromConcreteExpression
|
||||
|
||||
@ -62,10 +64,12 @@ expressionUpToAtomsScoped ::
|
||||
expressionUpToAtomsScoped fp txt = do
|
||||
scopeTable <- gets (^. artifactScopeTable)
|
||||
mtab <- gets (^. artifactModuleTable)
|
||||
pkg <- asks (^. entryPointPackage)
|
||||
runBuiltinsArtifacts
|
||||
. runScoperScopeArtifacts
|
||||
. runStateArtifacts artifactScoperState
|
||||
. runNameIdGenArtifacts
|
||||
. runReader pkg
|
||||
$ Parser.expressionFromTextSource fp txt
|
||||
>>= Scoper.scopeCheckExpressionAtoms (Store.getScopedModuleTable mtab) scopeTable
|
||||
|
||||
@ -76,10 +80,12 @@ scopeCheckExpression ::
|
||||
scopeCheckExpression p = do
|
||||
scopeTable <- gets (^. artifactScopeTable)
|
||||
mtab <- gets (^. artifactModuleTable)
|
||||
pkg <- asks (^. entryPointPackage)
|
||||
runNameIdGenArtifacts
|
||||
. runBuiltinsArtifacts
|
||||
. runScoperScopeArtifacts
|
||||
. runStateArtifacts artifactScoperState
|
||||
. runReader pkg
|
||||
$ Scoper.scopeCheckExpression (Store.getScopedModuleTable mtab) scopeTable p
|
||||
|
||||
parseReplInput ::
|
||||
@ -126,11 +132,13 @@ registerImport i = do
|
||||
modify' (appendArtifactsModuleTable mtab')
|
||||
scopeTable <- gets (^. artifactScopeTable)
|
||||
mtab'' <- gets (^. artifactModuleTable)
|
||||
pkg <- asks (^. entryPointPackage)
|
||||
void
|
||||
. runNameIdGenArtifacts
|
||||
. runBuiltinsArtifacts
|
||||
. runScoperScopeArtifacts
|
||||
. runStateArtifacts artifactScoperState
|
||||
. runReader pkg
|
||||
$ Scoper.scopeCheckImport (Store.getScopedModuleTable mtab'') scopeTable i
|
||||
|
||||
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)
|
||||
runError
|
||||
. runConcurrent
|
||||
. runReader defaultNumThreads
|
||||
. evalInternet hasInternet
|
||||
. runTaggedLockPermissive
|
||||
. runLogIO
|
||||
@ -176,7 +185,7 @@ compileReplInputIO fp txt = do
|
||||
. runReader defaultImportScanStrategy
|
||||
. withImportTree (Just fp)
|
||||
. ignoreProgressLog
|
||||
. evalModuleInfoCacheHelper defaultNumThreads
|
||||
. evalModuleInfoCacheHelper
|
||||
$ do
|
||||
p <- parseReplInput fp txt
|
||||
case p of
|
||||
|
@ -114,6 +114,7 @@ runIOEitherPipeline' entry a = do
|
||||
let hasInternet = not (entry ^. entryPointOffline)
|
||||
opts :: PipelineOptions <- ask
|
||||
runConcurrent
|
||||
. runReader (opts ^. pipelineNumThreads)
|
||||
. evalInternet hasInternet
|
||||
. runHighlightBuilder
|
||||
. runJuvixError
|
||||
@ -132,7 +133,7 @@ runIOEitherPipeline' entry a = do
|
||||
. runTopModuleNameChecker
|
||||
. runReader (opts ^. pipelineImportStrategy)
|
||||
. withImportTree (entry ^. entryPointModulePath)
|
||||
. evalModuleInfoCacheHelper (opts ^. pipelineNumThreads)
|
||||
. evalModuleInfoCacheHelper
|
||||
$ a
|
||||
|
||||
evalModuleInfoCacheHelper ::
|
||||
@ -148,18 +149,18 @@ evalModuleInfoCacheHelper ::
|
||||
Error JuvixError,
|
||||
PathResolver,
|
||||
Reader ImportScanStrategy,
|
||||
Reader NumThreads,
|
||||
Files
|
||||
]
|
||||
r
|
||||
) =>
|
||||
NumThreads ->
|
||||
Sem (ModuleInfoCache ': JvoCache ': r) a ->
|
||||
Sem r a
|
||||
evalModuleInfoCacheHelper nj m = do
|
||||
evalModuleInfoCacheHelper m = do
|
||||
b <- supportsParallel
|
||||
threads <- numThreads nj
|
||||
threads <- ask >>= numThreads
|
||||
if
|
||||
| b && threads > 1 -> DriverPar.evalModuleInfoCache nj m
|
||||
| b && threads > 1 -> DriverPar.evalModuleInfoCache m
|
||||
| otherwise -> evalModuleInfoCache m
|
||||
|
||||
mainIsPackageFile :: EntryPoint -> Bool
|
||||
@ -212,6 +213,7 @@ runReplPipelineIOEither' lockMode entry = do
|
||||
eith <-
|
||||
runM
|
||||
. runConcurrent
|
||||
. runReader defaultNumThreads
|
||||
. evalInternet hasInternet
|
||||
. ignoreHighlightBuilder
|
||||
. runError
|
||||
@ -235,7 +237,7 @@ runReplPipelineIOEither' lockMode entry = do
|
||||
. runReader defaultImportScanStrategy
|
||||
. withImportTree (entry ^. entryPointModulePath)
|
||||
. ignoreProgressLog
|
||||
. evalModuleInfoCacheHelper defaultNumThreads
|
||||
. evalModuleInfoCacheHelper
|
||||
$ processFileToStoredCore entry
|
||||
return $ case eith of
|
||||
Left err -> Left err
|
||||
|
@ -2,8 +2,8 @@ module Juvix.Compiler.Store.Extra where
|
||||
|
||||
import Data.HashMap.Strict qualified as HashMap
|
||||
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.Language (TopModulePath)
|
||||
import Juvix.Compiler.Core.Data.InfoTable qualified as Core
|
||||
import Juvix.Compiler.Internal.Data.Name
|
||||
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.Prelude
|
||||
|
||||
getModulePath :: ModuleInfo -> TopModulePath
|
||||
getModulePath :: ModuleInfo -> C.TopModulePath
|
||||
getModulePath mi = mi ^. moduleInfoScopedModule . scopedModulePath . S.nameConcrete
|
||||
|
||||
getModuleId :: ModuleInfo -> ModuleId
|
||||
getModuleId mi = mi ^. moduleInfoScopedModule . scopedModuleId
|
||||
getModulePathKey :: ModuleInfo -> TopModulePathKey
|
||||
getModulePathKey = C.topModulePathKey . getModulePath
|
||||
|
||||
getScopedModuleTable :: ModuleTable -> ScopedModuleTable
|
||||
getScopedModuleTable mtab =
|
||||
ScopedModuleTable $ fmap (^. moduleInfoScopedModule) (mtab ^. moduleTable)
|
||||
ScopedModuleTable $ HashMap.mapKeys C.topModulePathKey (fmap (^. moduleInfoScopedModule) (mtab ^. moduleTable))
|
||||
|
||||
getInternalModuleTable :: ModuleTable -> InternalModuleTable
|
||||
getInternalModuleTable mtab =
|
||||
@ -31,10 +31,10 @@ getInternalModuleTable mtab =
|
||||
mkModuleTable :: [ModuleInfo] -> ModuleTable
|
||||
mkModuleTable = ModuleTable . hashMap . map (\mi -> (getModulePath mi, mi))
|
||||
|
||||
lookupModule :: ModuleTable -> TopModulePath -> ModuleInfo
|
||||
lookupModule mtab n = fromJust $ HashMap.lookup n (mtab ^. moduleTable)
|
||||
lookupModule :: ModuleTable -> C.TopModulePath -> ModuleInfo
|
||||
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)
|
||||
|
||||
computeCombinedScopedInfoTable :: ModuleTable -> Scoped.InfoTable
|
||||
|
@ -1,6 +1,6 @@
|
||||
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.Internal.Language
|
||||
import Juvix.Compiler.Store.Options
|
||||
|
@ -25,8 +25,7 @@ instance Serialize ExportInfo
|
||||
instance NFData ExportInfo
|
||||
|
||||
data ScopedModule = ScopedModule
|
||||
{ _scopedModuleId :: ModuleId,
|
||||
_scopedModulePath :: S.TopModulePath,
|
||||
{ _scopedModulePath :: S.TopModulePath,
|
||||
_scopedModuleName :: S.Name,
|
||||
_scopedModuleFilePath :: Path Abs File,
|
||||
_scopedModuleExportInfo :: ExportInfo,
|
||||
@ -40,7 +39,7 @@ instance Serialize ScopedModule
|
||||
instance NFData ScopedModule
|
||||
|
||||
newtype ScopedModuleTable = ScopedModuleTable
|
||||
{ _scopedModuleTable :: HashMap C.TopModulePath ScopedModule
|
||||
{ _scopedModuleTable :: HashMap TopModulePathKey ScopedModule
|
||||
}
|
||||
|
||||
makeLenses ''ExportInfo
|
||||
|
@ -19,6 +19,7 @@ module Juvix.Data
|
||||
module Juvix.Data.WithLoc,
|
||||
module Juvix.Data.WithSource,
|
||||
module Juvix.Data.DependencyInfo,
|
||||
module Juvix.Data.TopModulePathKey,
|
||||
module Juvix.Data.Keyword,
|
||||
)
|
||||
where
|
||||
@ -39,6 +40,7 @@ import Juvix.Data.NameId qualified
|
||||
import Juvix.Data.NumThreads
|
||||
import Juvix.Data.Pragmas
|
||||
import Juvix.Data.Processed
|
||||
import Juvix.Data.TopModulePathKey
|
||||
import Juvix.Data.Uid
|
||||
import Juvix.Data.Universe
|
||||
import Juvix.Data.Wildcard
|
||||
|
@ -6,6 +6,7 @@ module Juvix.Data.Effect
|
||||
module Juvix.Data.Effect.Visit,
|
||||
module Juvix.Data.Effect.Log,
|
||||
module Juvix.Data.Effect.Internet,
|
||||
module Juvix.Data.Effect.Forcing,
|
||||
module Juvix.Data.Effect.TaggedLock,
|
||||
)
|
||||
where
|
||||
@ -13,6 +14,7 @@ where
|
||||
import Juvix.Data.Effect.Cache
|
||||
import Juvix.Data.Effect.Fail
|
||||
import Juvix.Data.Effect.Files
|
||||
import Juvix.Data.Effect.Forcing
|
||||
import Juvix.Data.Effect.Internet
|
||||
import Juvix.Data.Effect.Log
|
||||
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
|
||||
|
||||
import Juvix.Data.TopModulePathKey
|
||||
import Juvix.Extra.Serialize
|
||||
import Juvix.Prelude.Base
|
||||
import Prettyprinter
|
||||
|
||||
data ModuleId = ModuleId
|
||||
{ _moduleIdPath :: Text,
|
||||
{ _moduleIdPath :: TopModulePathKey,
|
||||
_moduleIdPackage :: Text,
|
||||
_moduleIdPackageVersion :: Text
|
||||
}
|
||||
@ -25,7 +26,7 @@ instance NFData ModuleId
|
||||
defaultModuleId :: ModuleId
|
||||
defaultModuleId =
|
||||
ModuleId
|
||||
{ _moduleIdPath = "$DefaultModule$",
|
||||
{ _moduleIdPath = nonEmptyToTopModulePathKey (pure "$DefaultModule$"),
|
||||
_moduleIdPackage = "$",
|
||||
_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
|
||||
|
||||
import Juvix.Compiler.Concrete.Data.Highlight.Input (ignoreHighlightBuilder)
|
||||
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.FromSource (ParserResult, fromSource)
|
||||
import Juvix.Compiler.Concrete.Translation.FromSource.TopModuleNameChecker (runTopModuleNameChecker)
|
||||
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.Extra.Paths
|
||||
import Juvix.Prelude
|
||||
@ -16,6 +25,8 @@ data FormattedFileInfo = FormattedFileInfo
|
||||
_formattedFileInfoContentsModified :: Bool
|
||||
}
|
||||
|
||||
type OriginalSource = Text
|
||||
|
||||
data ScopeEff :: Effect where
|
||||
ScopeFile :: Path Abs File -> ScopeEff m Scoper.ScoperResult
|
||||
ScopeStdin :: EntryPoint -> ScopeEff m Scoper.ScoperResult
|
||||
@ -29,6 +40,13 @@ data FormatResult
|
||||
| FormatResultFail
|
||||
deriving stock (Eq)
|
||||
|
||||
data SourceCode = SourceCode
|
||||
{ _sourceCodeFormatted :: Text,
|
||||
_sourceCodeOriginal :: Text
|
||||
}
|
||||
|
||||
makeLenses ''SourceCode
|
||||
|
||||
instance Semigroup FormatResult where
|
||||
FormatResultFail <> _ = FormatResultFail
|
||||
_ <> FormatResultFail = FormatResultFail
|
||||
@ -54,9 +72,13 @@ format ::
|
||||
Sem r FormatResult
|
||||
format p = do
|
||||
originalContents <- readFile' p
|
||||
runReader originalContents $ do
|
||||
formattedContents :: Text <- formatPath p
|
||||
formatResultFromContents formattedContents p
|
||||
formattedContents :: Text <- runReader originalContents (formatPath p)
|
||||
let src =
|
||||
SourceCode
|
||||
{ _sourceCodeFormatted = formattedContents,
|
||||
_sourceCodeOriginal = originalContents
|
||||
}
|
||||
formatResultSourceCode p src
|
||||
|
||||
-- | Format a Juvix project.
|
||||
--
|
||||
@ -73,27 +95,57 @@ format p = do
|
||||
--
|
||||
-- NB: This function does not traverse into Juvix sub-projects, i.e into
|
||||
-- subdirectories that contain a juvix.yaml file.
|
||||
formatProject ::
|
||||
formatProjectSourceCode ::
|
||||
forall r.
|
||||
(Members '[ScopeEff, Files, Output FormattedFileInfo] r) =>
|
||||
Path Abs Dir ->
|
||||
(Members '[Output FormattedFileInfo] r) =>
|
||||
[(ImportNode, SourceCode)] ->
|
||||
Sem r FormatResult
|
||||
formatProject p = do
|
||||
walkDirRelAccum handler p FormatResultOK
|
||||
where
|
||||
handler ::
|
||||
Path Abs Dir ->
|
||||
[Path Rel Dir] ->
|
||||
[Path Rel File] ->
|
||||
FormatResult ->
|
||||
Sem r (FormatResult, Recurse Rel)
|
||||
handler cd _ files res = do
|
||||
let juvixFiles = [cd <//> f | f <- files, isJuvixFile f]
|
||||
subRes <- mconcat <$> mapM format juvixFiles
|
||||
return (res <> subRes, RecurseFilter (\hasJuvixPackage d -> not hasJuvixPackage && not (isHiddenDirectory d)))
|
||||
formatProjectSourceCode =
|
||||
mconcatMapM (uncurry formatResultSourceCode)
|
||||
. map (first (^. importNodeAbsFile))
|
||||
|
||||
formatModuleInfo ::
|
||||
( Members
|
||||
'[ PathResolver,
|
||||
Error JuvixError,
|
||||
Files,
|
||||
Reader Package
|
||||
]
|
||||
r
|
||||
) =>
|
||||
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 ::
|
||||
(Members '[Reader Text, ScopeEff] r) =>
|
||||
(Members '[Reader OriginalSource, ScopeEff] r) =>
|
||||
Path Abs File ->
|
||||
Sem r Text
|
||||
formatPath p = do
|
||||
@ -107,21 +159,20 @@ formatStdin ::
|
||||
formatStdin = do
|
||||
entry <- ask
|
||||
res <- scopeStdin entry
|
||||
let originalContents = fromMaybe "" (entry ^. entryPointStdin)
|
||||
runReader originalContents $ do
|
||||
formattedContents :: Text <- formatScoperResult False res
|
||||
formatResultFromContents formattedContents formatStdinPath
|
||||
let _sourceCodeOriginal = fromMaybe "" (entry ^. entryPointStdin)
|
||||
_sourceCodeFormatted :: Text <- runReader _sourceCodeOriginal (formatScoperResult False res)
|
||||
let src = SourceCode {..}
|
||||
formatResultSourceCode formatStdinPath src
|
||||
|
||||
formatResultFromContents ::
|
||||
formatResultSourceCode ::
|
||||
forall r.
|
||||
(Members '[Reader Text, Output FormattedFileInfo] r) =>
|
||||
Text ->
|
||||
(Members '[Output FormattedFileInfo] r) =>
|
||||
Path Abs File ->
|
||||
SourceCode ->
|
||||
Sem r FormatResult
|
||||
formatResultFromContents formattedContents filepath = do
|
||||
originalContents <- ask
|
||||
formatResultSourceCode filepath src = do
|
||||
if
|
||||
| originalContents /= formattedContents -> mkResult FormatResultNotFormatted
|
||||
| src ^. sourceCodeOriginal /= src ^. sourceCodeFormatted -> mkResult FormatResultNotFormatted
|
||||
| otherwise -> mkResult FormatResultOK
|
||||
where
|
||||
mkResult :: FormatResult -> Sem r FormatResult
|
||||
@ -129,7 +180,7 @@ formatResultFromContents formattedContents filepath = do
|
||||
output
|
||||
( FormattedFileInfo
|
||||
{ _formattedFileInfoPath = filepath,
|
||||
_formattedFileInfoContents = formattedContents,
|
||||
_formattedFileInfoContents = src ^. sourceCodeFormatted,
|
||||
_formattedFileInfoContentsModified = res == FormatResultNotFormatted
|
||||
}
|
||||
)
|
||||
@ -141,29 +192,15 @@ formatScoperResult' forceFormat original sres =
|
||||
run . runReader original $ formatScoperResult forceFormat sres
|
||||
|
||||
formatScoperResult ::
|
||||
(Members '[Reader Text] r) =>
|
||||
(Members '[Reader OriginalSource] r) =>
|
||||
Bool ->
|
||||
Scoper.ScoperResult ->
|
||||
Sem r Text
|
||||
formatScoperResult forceFormat res = do
|
||||
let cs = Scoper.getScoperResultComments res
|
||||
formattedModule <-
|
||||
runReader cs
|
||||
. formatTopModule
|
||||
$ res
|
||||
^. Scoper.resultModule
|
||||
let txt :: Text = toPlainTextTrim formattedModule
|
||||
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
|
||||
let comments = Scoper.getScoperResultComments res
|
||||
formattedTxt = toPlainTextTrim (ppOutDefault comments (res ^. Scoper.resultModule))
|
||||
runFailDefault formattedTxt $ do
|
||||
pragmas <- failMaybe (res ^. Scoper.mainModule . modulePragmas)
|
||||
PragmaFormat {..} <- failMaybe (pragmas ^. withLocParam . withSourceValue . pragmasFormat)
|
||||
failUnless (not _pragmaFormat && not forceFormat)
|
||||
ask @OriginalSource
|
||||
|
@ -171,7 +171,7 @@ import Safe.Exact
|
||||
import Safe.Foldable
|
||||
import System.Exit hiding (exitFailure, exitSuccess)
|
||||
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.IO hiding
|
||||
( appendFile,
|
||||
|
@ -152,14 +152,14 @@ compile args@CompileArgs {..} = do
|
||||
allNodesIds :: [nodeId] = HashMap.keys (nodesIx ^. nodesIndex)
|
||||
deps = _compileArgsDependencies
|
||||
numMods :: Natural = fromIntegral (length allNodesIds)
|
||||
starterModules :: [nodeId] =
|
||||
startingModules :: [nodeId] =
|
||||
[m | m <- allNodesIds, null (nodeDependencies deps m)]
|
||||
logs <- Logs <$> newTQueueIO
|
||||
qq <- newTBQueueIO (max 1 numMods)
|
||||
let compileQ = CompileQueue qq
|
||||
whenJust _compileArgsPreProcess $ \preProcess ->
|
||||
mapConcurrently_ preProcess allNodesIds
|
||||
atomically (forM_ starterModules (writeTBQueue qq))
|
||||
atomically (forM_ startingModules (writeTBQueue qq))
|
||||
let iniCompilationState :: CompilationState nodeId compileProof =
|
||||
CompilationState
|
||||
{ _compilationStartedNum = 0,
|
||||
|
@ -25,7 +25,7 @@ testDescr NegTest {..} =
|
||||
_testRoot = tRoot,
|
||||
_testAssertion = Single $ do
|
||||
entryPoint <- testDefaultEntryPointIO tRoot file'
|
||||
result <- testTaggedLockedToIO (runIOEither entryPoint upToScoping)
|
||||
result <- testTaggedLockedToIO (runIOEither entryPoint upToScopingEntry)
|
||||
case result of
|
||||
Left err -> whenJust (_checkErr err) assertFailure
|
||||
Right (_, pipelineRes) -> checkResult pipelineRes
|
||||
|
@ -35,7 +35,7 @@ testDescr PosTest {..} =
|
||||
_testAssertion = Steps $ \step -> do
|
||||
entryPoint <- testDefaultEntryPointIO _dir _file
|
||||
step "Parsing & Scoping"
|
||||
PipelineResult {..} <- snd <$> testRunIO entryPoint upToScoping
|
||||
PipelineResult {..} <- snd <$> testRunIO entryPoint upToScopingEntry
|
||||
let m = _pipelineResult ^. Scoper.resultModule
|
||||
let opts =
|
||||
ProcessJuvixBlocksArgs
|
||||
|
@ -36,7 +36,7 @@ testDescr PosTest {..} =
|
||||
original :: Text <- readFile f
|
||||
|
||||
step "Parsing & scoping"
|
||||
PipelineResult {..} <- snd <$> testRunIO entryPoint upToScoping
|
||||
PipelineResult {..} <- snd <$> testRunIO entryPoint upToScopingEntry
|
||||
|
||||
let formatted = formatScoperResult' _force original _pipelineResult
|
||||
case _expectedFile of
|
||||
|
@ -9,9 +9,9 @@ runScopeEffIO :: (Member EmbedIO r) => Path Abs Dir -> Sem (ScopeEff ': r) a ->
|
||||
runScopeEffIO root = interpret $ \case
|
||||
ScopeFile p -> do
|
||||
entry <- testDefaultEntryPointIO root p
|
||||
((^. pipelineResult) . snd <$> testRunIO entry upToScoping)
|
||||
((^. pipelineResult) . snd <$> testRunIO entry upToScopingEntry)
|
||||
ScopeStdin entry -> do
|
||||
((^. pipelineResult) . snd <$> testRunIO entry upToScoping)
|
||||
((^. pipelineResult) . snd <$> testRunIO entry upToScopingEntry)
|
||||
|
||||
makeFormatTest' :: Scope.PosTest -> TestDescr
|
||||
makeFormatTest' Scope.PosTest {..} =
|
||||
|
@ -22,7 +22,7 @@ loadPrelude :: Path Abs Dir -> IO (Artifacts, EntryPoint)
|
||||
loadPrelude rootDir = runTaggedLockIO' $ do
|
||||
runReader rootDir writeStdlib
|
||||
pkg <- readPackageRootIO root
|
||||
let ep = defaultEntryPoint pkg root (rootDir <//> preludePath)
|
||||
let ep = defaultEntryPoint pkg root (Just (rootDir <//> preludePath))
|
||||
artif <- runReplPipelineIO ep
|
||||
return (artif, ep)
|
||||
where
|
||||
|
@ -53,7 +53,7 @@ testDescr PosTest {..} = helper renderCodeNew
|
||||
evalHelper input_ m = snd <$> testRunIO entryPoint {_entryPointStdin = Just input_} m
|
||||
|
||||
step "Parsing & Scoping"
|
||||
PipelineResult s _ _ <- snd <$> testRunIO entryPoint upToScoping
|
||||
PipelineResult s _ _ <- snd <$> testRunIO entryPoint upToScopingEntry
|
||||
|
||||
let p = s ^. Scoper.resultParserResult
|
||||
fScoped :: Text
|
||||
@ -62,7 +62,7 @@ testDescr PosTest {..} = helper renderCodeNew
|
||||
fParsed = renderer $ p ^. Parser.resultModule
|
||||
|
||||
step "Parsing & scoping pretty scoped"
|
||||
PipelineResult s' _ _ <- evalHelper fScoped upToScoping
|
||||
PipelineResult s' _ _ <- evalHelper fScoped upToScopingEntry
|
||||
let p' = s' ^. Scoper.resultParserResult
|
||||
|
||||
step "Parsing pretty parsed"
|
||||
|
Loading…
Reference in New Issue
Block a user