diff --git a/app/App.hs b/app/App.hs index e0e0f6d5a..8ecb788a3 100644 --- a/app/App.hs +++ b/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 diff --git a/app/Commands/Dev/Core/Strip.hs b/app/Commands/Dev/Core/Strip.hs index a06a20ec3..33dacd275 100644 --- a/app/Commands/Dev/Core/Strip.hs +++ b/app/Commands/Dev/Core/Strip.hs @@ -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 diff --git a/app/Commands/Dev/Geb/Repl.hs b/app/Commands/Dev/Geb/Repl.hs index 338cd60a2..cdf0cb019 100644 --- a/app/Commands/Dev/Geb/Repl.hs +++ b/app/Commands/Dev/Geb/Repl.hs @@ -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) diff --git a/app/Commands/Dev/Scope.hs b/app/Commands/Dev/Scope.hs index 6a7f7753c..5dfe07bc2 100644 --- a/app/Commands/Dev/Scope.hs +++ b/app/Commands/Dev/Scope.hs @@ -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 -> diff --git a/app/Commands/Eval.hs b/app/Commands/Eval.hs index 83144feec..e5758b3aa 100644 --- a/app/Commands/Eval.hs +++ b/app/Commands/Eval.hs @@ -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 diff --git a/app/Commands/Format.hs b/app/Commands/Format.hs index 37395388a..d40fef91e 100644 --- a/app/Commands/Format.hs +++ b/app/Commands/Format.hs @@ -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) diff --git a/app/Commands/Format/Options.hs b/app/Commands/Format/Options.hs index eb0f57ee4..65729e4c3 100644 --- a/app/Commands/Format/Options.hs +++ b/app/Commands/Format/Options.hs @@ -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" diff --git a/app/Commands/Html.hs b/app/Commands/Html.hs index 94fb25326..5491b0e26 100644 --- a/app/Commands/Html.hs +++ b/app/Commands/Html.hs @@ -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 $ diff --git a/app/Commands/Markdown.hs b/app/Commands/Markdown.hs index 4b6d8665f..417222663 100644 --- a/app/Commands/Markdown.hs +++ b/app/Commands/Markdown.hs @@ -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 = diff --git a/app/Commands/Repl.hs b/app/Commands/Repl.hs index 79aecc7b6..412ae0035 100644 --- a/app/Commands/Repl.hs +++ b/app/Commands/Repl.hs @@ -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) diff --git a/app/CommonOptions.hs b/app/CommonOptions.hs index c2fba8373..e1f1c3300 100644 --- a/app/CommonOptions.hs +++ b/app/CommonOptions.hs @@ -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 diff --git a/app/GlobalOptions.hs b/app/GlobalOptions.hs index 0c76ad558..a797cba5d 100644 --- a/app/GlobalOptions.hs +++ b/app/GlobalOptions.hs @@ -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 diff --git a/app/TopCommand/Options.hs b/app/TopCommand/Options.hs index 4aef6749e..7603e9697 100644 --- a/app/TopCommand/Options.hs +++ b/app/TopCommand/Options.hs @@ -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 diff --git a/src/Juvix/Compiler/Backend/Isabelle/Translation/FromTyped.hs b/src/Juvix/Compiler/Backend/Isabelle/Translation/FromTyped.hs index 4c5b7180a..5766c207d 100644 --- a/src/Juvix/Compiler/Backend/Isabelle/Translation/FromTyped.hs +++ b/src/Juvix/Compiler/Backend/Isabelle/Translation/FromTyped.hs @@ -114,7 +114,7 @@ goModule onlyTypes infoTable Internal.Module {..} = defaultId = NameId { _nameIdUid = 0, - _nameIdModuleId = ModuleId "" "" "" + _nameIdModuleId = defaultModuleId } goConstructorDef :: Internal.ConstructorDef -> Constructor diff --git a/src/Juvix/Compiler/Concrete/Data/Name.hs b/src/Juvix/Compiler/Concrete/Data/Name.hs index a76bc9fd1..9729563d9 100644 --- a/src/Juvix/Compiler/Concrete/Data/Name.hs +++ b/src/Juvix/Compiler/Concrete/Data/Name.hs @@ -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) diff --git a/src/Juvix/Compiler/Concrete/Data/Scope/Base.hs b/src/Juvix/Compiler/Concrete/Data/Scope/Base.hs index 3114c214f..3287d7872 100644 --- a/src/Juvix/Compiler/Concrete/Data/Scope/Base.hs +++ b/src/Juvix/Compiler/Concrete/Data/Scope/Base.hs @@ -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 diff --git a/src/Juvix/Compiler/Concrete/Language.hs b/src/Juvix/Compiler/Concrete/Language.hs index 70b270b38..b4c5832f3 100644 --- a/src/Juvix/Compiler/Concrete/Language.hs +++ b/src/Juvix/Compiler/Concrete/Language.hs @@ -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 } diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs index dfc2419de..d9eaa1604 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs @@ -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 diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs index e51c91029..bbf3360f4 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs @@ -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 diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Data/Context.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Data/Context.hs index cc0df0e12..ca7ee2943 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Data/Context.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Data/Context.hs @@ -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) diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs index 85705aa2c..6e13d36b9 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs @@ -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 diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource/Data/Context.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource/Data/Context.hs index a394f7a63..80518d82f 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromSource/Data/Context.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromSource/Data/Context.hs @@ -10,3 +10,6 @@ data ParserResult = ParserResult } makeLenses ''ParserResult + +getParserResultComments :: ParserResult -> Comments +getParserResultComments sr = mkComments $ sr ^. resultParserState . parserStateComments diff --git a/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs b/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs index 8ac97c154..62bb69a6e 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs @@ -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) diff --git a/src/Juvix/Compiler/Pipeline.hs b/src/Juvix/Compiler/Pipeline.hs index 088ee7a2d..65c7bafb3 100644 --- a/src/Juvix/Compiler/Pipeline.hs +++ b/src/Juvix/Compiler/Pipeline.hs @@ -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) => diff --git a/src/Juvix/Compiler/Pipeline/Driver.hs b/src/Juvix/Compiler/Pipeline/Driver.hs index b07a0d88c..9be9c3811 100644 --- a/src/Juvix/Compiler/Pipeline/Driver.hs +++ b/src/Juvix/Compiler/Pipeline/Driver.hs @@ -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) diff --git a/src/Juvix/Compiler/Pipeline/DriverParallel.hs b/src/Juvix/Compiler/Pipeline/DriverParallel.hs index e93ff6ace..c84435e46 100644 --- a/src/Juvix/Compiler/Pipeline/DriverParallel.hs +++ b/src/Juvix/Compiler/Pipeline/DriverParallel.hs @@ -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_)) diff --git a/src/Juvix/Compiler/Pipeline/EntryPoint.hs b/src/Juvix/Compiler/Pipeline/EntryPoint.hs index f437febb5..cd0cf26bc 100644 --- a/src/Juvix/Compiler/Pipeline/EntryPoint.hs +++ b/src/Juvix/Compiler/Pipeline/EntryPoint.hs @@ -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 diff --git a/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs b/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs index a202c0534..5852c0562 100644 --- a/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs +++ b/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs @@ -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 diff --git a/src/Juvix/Compiler/Pipeline/JvoCache.hs b/src/Juvix/Compiler/Pipeline/JvoCache.hs index 86e8d3179..e8e468423 100644 --- a/src/Juvix/Compiler/Pipeline/JvoCache.hs +++ b/src/Juvix/Compiler/Pipeline/JvoCache.hs @@ -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 diff --git a/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Base.hs b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Base.hs index 48e642c92..283681d1e 100644 --- a/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Base.hs +++ b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Base.hs @@ -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 diff --git a/src/Juvix/Compiler/Pipeline/Loader/PathResolver/ImportTree/Base.hs b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/ImportTree/Base.hs index 0bb8c5279..7ae311e0f 100644 --- a/src/Juvix/Compiler/Pipeline/Loader/PathResolver/ImportTree/Base.hs +++ b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/ImportTree/Base.hs @@ -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 diff --git a/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Paths.hs b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Paths.hs index 7a139e51b..ddbb0a35b 100644 --- a/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Paths.hs +++ b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Paths.hs @@ -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 diff --git a/src/Juvix/Compiler/Pipeline/ModuleInfoCache.hs b/src/Juvix/Compiler/Pipeline/ModuleInfoCache.hs index 03fd2b12c..3e5e1f251 100644 --- a/src/Juvix/Compiler/Pipeline/ModuleInfoCache.hs +++ b/src/Juvix/Compiler/Pipeline/ModuleInfoCache.hs @@ -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 } diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs b/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs index 478de2fe1..02ce23b6f 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs @@ -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 = diff --git a/src/Juvix/Compiler/Pipeline/Repl.hs b/src/Juvix/Compiler/Pipeline/Repl.hs index 7101de9a1..9569b9e07 100644 --- a/src/Juvix/Compiler/Pipeline/Repl.hs +++ b/src/Juvix/Compiler/Pipeline/Repl.hs @@ -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 diff --git a/src/Juvix/Compiler/Pipeline/Run.hs b/src/Juvix/Compiler/Pipeline/Run.hs index becf31178..3967b3655 100644 --- a/src/Juvix/Compiler/Pipeline/Run.hs +++ b/src/Juvix/Compiler/Pipeline/Run.hs @@ -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 diff --git a/src/Juvix/Compiler/Store/Extra.hs b/src/Juvix/Compiler/Store/Extra.hs index b45de01af..b4ede7700 100644 --- a/src/Juvix/Compiler/Store/Extra.hs +++ b/src/Juvix/Compiler/Store/Extra.hs @@ -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 diff --git a/src/Juvix/Compiler/Store/Language.hs b/src/Juvix/Compiler/Store/Language.hs index c8bac0b6a..ae5bd9d9f 100644 --- a/src/Juvix/Compiler/Store/Language.hs +++ b/src/Juvix/Compiler/Store/Language.hs @@ -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 diff --git a/src/Juvix/Compiler/Store/Scoped/Language.hs b/src/Juvix/Compiler/Store/Scoped/Language.hs index 877e95a3b..9f3971922 100644 --- a/src/Juvix/Compiler/Store/Scoped/Language.hs +++ b/src/Juvix/Compiler/Store/Scoped/Language.hs @@ -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 diff --git a/src/Juvix/Data.hs b/src/Juvix/Data.hs index 194fad259..322280be7 100644 --- a/src/Juvix/Data.hs +++ b/src/Juvix/Data.hs @@ -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 diff --git a/src/Juvix/Data/Effect.hs b/src/Juvix/Data/Effect.hs index 71aca734b..4ed60f740 100644 --- a/src/Juvix/Data/Effect.hs +++ b/src/Juvix/Data/Effect.hs @@ -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 diff --git a/src/Juvix/Data/Effect/Forcing.hs b/src/Juvix/Data/Effect/Forcing.hs new file mode 100644 index 000000000..256f4efb6 --- /dev/null +++ b/src/Juvix/Data/Effect/Forcing.hs @@ -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)) diff --git a/src/Juvix/Data/ModuleId.hs b/src/Juvix/Data/ModuleId.hs index e7c708701..29818e43f 100644 --- a/src/Juvix/Data/ModuleId.hs +++ b/src/Juvix/Data/ModuleId.hs @@ -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" } diff --git a/src/Juvix/Data/TopModulePathKey.hs b/src/Juvix/Data/TopModulePathKey.hs new file mode 100644 index 000000000..305b58e72 --- /dev/null +++ b/src/Juvix/Data/TopModulePathKey.hs @@ -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 diff --git a/src/Juvix/Formatter.hs b/src/Juvix/Formatter.hs index ad53539e6..08b973b54 100644 --- a/src/Juvix/Formatter.hs +++ b/src/Juvix/Formatter.hs @@ -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 diff --git a/src/Juvix/Prelude/Base/Foundation.hs b/src/Juvix/Prelude/Base/Foundation.hs index 66b9a53a6..56399dfa3 100644 --- a/src/Juvix/Prelude/Base/Foundation.hs +++ b/src/Juvix/Prelude/Base/Foundation.hs @@ -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, diff --git a/src/Parallel/ParallelTemplate.hs b/src/Parallel/ParallelTemplate.hs index 0f11985ae..fe61f55fd 100644 --- a/src/Parallel/ParallelTemplate.hs +++ b/src/Parallel/ParallelTemplate.hs @@ -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, diff --git a/test/BackendMarkdown/Negative.hs b/test/BackendMarkdown/Negative.hs index 0cb4b9a47..70bd6ff8c 100644 --- a/test/BackendMarkdown/Negative.hs +++ b/test/BackendMarkdown/Negative.hs @@ -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 diff --git a/test/BackendMarkdown/Positive.hs b/test/BackendMarkdown/Positive.hs index 37e09f2b2..177c12f00 100644 --- a/test/BackendMarkdown/Positive.hs +++ b/test/BackendMarkdown/Positive.hs @@ -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 diff --git a/test/Format.hs b/test/Format.hs index 47b6d22c2..2e3528fea 100644 --- a/test/Format.hs +++ b/test/Format.hs @@ -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 diff --git a/test/Formatter/Positive.hs b/test/Formatter/Positive.hs index bffaa1ba8..b5f5a7722 100644 --- a/test/Formatter/Positive.hs +++ b/test/Formatter/Positive.hs @@ -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 {..} = diff --git a/test/Repl/Positive.hs b/test/Repl/Positive.hs index 027c061b0..e703c6b66 100644 --- a/test/Repl/Positive.hs +++ b/test/Repl/Positive.hs @@ -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 diff --git a/test/Scope/Positive.hs b/test/Scope/Positive.hs index 0705c4c8c..a635689a0 100644 --- a/test/Scope/Positive.hs +++ b/test/Scope/Positive.hs @@ -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"