From 272ad281c13df5ee5c71c6c7897747a29d6542fe Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Tue, 5 Dec 2023 14:32:41 +0100 Subject: [PATCH 1/7] refactor to run TaggedLock globally --- app/App.hs | 37 ++++++++++--------- app/Commands/Compile.hs | 4 +- app/Commands/Dev.hs | 2 +- app/Commands/Dev/Asm.hs | 2 +- app/Commands/Dev/Asm/Compile.hs | 2 +- app/Commands/Dev/Core.hs | 2 +- app/Commands/Dev/Core/Compile.hs | 2 +- app/Commands/Dev/Core/Compile/Base.hs | 10 ++--- app/Commands/Dev/Geb/Repl.hs | 2 +- app/Commands/Dev/Highlight.hs | 2 +- app/Commands/Repl.hs | 13 ++++--- app/Commands/Repl/Base.hs | 1 + app/GlobalOptions.hs | 19 ++++++---- app/Main.hs | 8 ++-- app/TopCommand.hs | 2 +- src/Juvix/Compiler/Core/Evaluator.hs | 15 ++++---- src/Juvix/Compiler/Pipeline/EntryPoint.hs | 12 +++--- src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs | 25 ++++++------- src/Juvix/Compiler/Pipeline/Package.hs | 26 ++++++------- .../Pipeline/Package/Loader/EvalEff/IO.hs | 3 +- src/Juvix/Compiler/Pipeline/Root.hs | 26 +++++++------ src/Juvix/Compiler/Pipeline/Root/Base.hs | 2 - src/Juvix/Data/Effect/TaggedLock.hs | 4 +- src/Juvix/Prelude/Prepath.hs | 16 ++++---- 24 files changed, 122 insertions(+), 115 deletions(-) diff --git a/app/App.hs b/app/App.hs index 60dfd882ef..31a6a714ad 100644 --- a/app/App.hs +++ b/app/App.hs @@ -43,7 +43,7 @@ data RunAppIOArgs = RunAppIOArgs runAppIO :: forall r a. - (Member (Embed IO) r) => + (Members '[Embed IO, TaggedLock] r) => RunAppIOArgs -> Sem (App ': r) a -> Sem r a @@ -52,26 +52,26 @@ runAppIO args@RunAppIOArgs {..} = AskPackageGlobal -> return (_runAppIOArgsRoot ^. rootPackageType `elem` [GlobalStdlib, GlobalPackageDescription, GlobalPackageBase]) FromAppPathFile p -> embed (prepathToAbsFile invDir (p ^. pathPath)) GetMainFile m -> getMainFile' m - FromAppPathDir p -> embed (prepathToAbsDir invDir (p ^. pathPath)) + FromAppPathDir p -> liftIO (prepathToAbsDir invDir (p ^. pathPath)) RenderStdOut t | _runAppIOArgsGlobalOptions ^. globalOnlyErrors -> return () | otherwise -> embed $ do sup <- Ansi.hSupportsANSIColor stdout renderIO (not (_runAppIOArgsGlobalOptions ^. globalNoColors) && sup) t AskGlobalOptions -> return _runAppIOArgsGlobalOptions - AskPackage -> return (_runAppIOArgsRoot ^. rootPackage) + AskPackage -> getPkg AskRoot -> return _runAppIOArgsRoot AskInvokeDir -> return invDir AskPkgDir -> return (_runAppIOArgsRoot ^. rootRootDir) AskBuildDir -> return (resolveAbsBuildDir (_runAppIOArgsRoot ^. rootRootDir) (_runAppIOArgsRoot ^. rootBuildDir)) RunCorePipelineEither input -> do - entry <- embed (getEntryPoint' args input) + entry <- getEntryPoint' args input embed (corePipelineIOEither entry) RunPipelineEither input p -> do - entry <- embed (getEntryPoint' args input) + entry <- getEntryPoint' args input embed (runIOEither entry p) RunPipelineNoFileEither p -> do - entry <- embed (getEntryPointStdin' args) + entry <- getEntryPointStdin' args embed (runIOEither entry p) Say t | g ^. globalOnlyErrors -> return () @@ -84,14 +84,19 @@ runAppIO args@RunAppIOArgs {..} = ExitMsg exitCode t -> exitMsg' exitCode t SayRaw b -> embed (ByteString.putStr b) where + getPkg :: Sem r Package + getPkg = undefined exitMsg' :: ExitCode -> Text -> Sem r x exitMsg' exitCode t = embed (putStrLn t >> hFlush stdout >> exitWith exitCode) getMainFile' :: Maybe (AppPath File) -> Sem r (Path Abs File) getMainFile' = \case Just p -> embed (prepathToAbsFile invDir (p ^. pathPath)) - Nothing -> case pkg ^. packageMain of - Just p -> embed (prepathToAbsFile invDir p) - Nothing -> missingMainErr + -- Nothing -> case pkg ^. packageMain of + Nothing -> do + pkg <- getPkg + case pkg ^. packageMain of + Just p -> embed (prepathToAbsFile invDir p) + Nothing -> missingMainErr missingMainErr :: Sem r x missingMainErr = exitMsg' @@ -101,30 +106,28 @@ runAppIO args@RunAppIOArgs {..} = <> " file" ) invDir = _runAppIOArgsRoot ^. rootInvokeDir - pkg :: Package - pkg = _runAppIOArgsRoot ^. rootPackage g :: GlobalOptions g = _runAppIOArgsGlobalOptions printErr e = embed $ hPutStrLn stderr $ run $ runReader (project' @GenericOptions g) $ Error.render (not (_runAppIOArgsGlobalOptions ^. globalNoColors)) (g ^. globalOnlyErrors) e -getEntryPoint' :: RunAppIOArgs -> AppPath File -> IO EntryPoint +getEntryPoint' :: (Members '[Embed IO, TaggedLock] r) => RunAppIOArgs -> AppPath File -> Sem r EntryPoint getEntryPoint' RunAppIOArgs {..} inputFile = do let opts = _runAppIOArgsGlobalOptions root = _runAppIOArgsRoot estdin <- if - | opts ^. globalStdin -> Just <$> getContents + | opts ^. globalStdin -> Just <$> liftIO getContents | otherwise -> return Nothing set entryPointStdin estdin <$> entryPointFromGlobalOptionsPre root (inputFile ^. pathPath) opts -getEntryPointStdin' :: RunAppIOArgs -> IO EntryPoint +getEntryPointStdin' :: (Members '[Embed IO, TaggedLock] r) => RunAppIOArgs -> Sem r EntryPoint getEntryPointStdin' RunAppIOArgs {..} = do let opts = _runAppIOArgsGlobalOptions root = _runAppIOArgsRoot estdin <- if - | opts ^. globalStdin -> Just <$> getContents + | opts ^. globalStdin -> Just <$> liftIO getContents | otherwise -> return Nothing set entryPointStdin estdin <$> entryPointFromGlobalOptionsNoFile root opts @@ -141,11 +144,11 @@ filePathToAbs fp = do askGenericOptions :: (Members '[App] r) => Sem r GenericOptions askGenericOptions = project <$> askGlobalOptions -getEntryPoint :: (Members '[Embed IO, App] r) => AppPath File -> Sem r EntryPoint +getEntryPoint :: (Members '[Embed IO, App, TaggedLock] r) => AppPath File -> Sem r EntryPoint getEntryPoint inputFile = do _runAppIOArgsGlobalOptions <- askGlobalOptions _runAppIOArgsRoot <- askRoot - embed (getEntryPoint' (RunAppIOArgs {..}) inputFile) + getEntryPoint' (RunAppIOArgs {..}) inputFile runPipelineTermination :: (Member App r) => AppPath File -> Sem (Termination ': PipelineEff) a -> Sem r a runPipelineTermination input p = do diff --git a/app/Commands/Compile.hs b/app/Commands/Compile.hs index 20006617a0..479453a0b0 100644 --- a/app/Commands/Compile.hs +++ b/app/Commands/Compile.hs @@ -9,7 +9,7 @@ import Juvix.Compiler.Core qualified as Core import Juvix.Compiler.Core.Pretty qualified as Core import Juvix.Compiler.Core.Transformation.DisambiguateNames qualified as Core -runCommand :: (Members '[Embed IO, App] r) => CompileOptions -> Sem r () +runCommand :: (Members '[Embed IO, App, TaggedLock] r) => CompileOptions -> Sem r () runCommand opts@CompileOptions {..} = do inputFile <- getMainFile _compileInputFile Core.CoreResult {..} <- runPipeline (AppPath (preFileFromAbs inputFile) True) upToCore @@ -27,7 +27,7 @@ runCommand opts@CompileOptions {..} = do TargetCore -> writeCoreFile arg TargetAsm -> Compile.runAsmPipeline arg -writeCoreFile :: (Members '[Embed IO, App] r) => Compile.PipelineArg -> Sem r () +writeCoreFile :: (Members '[Embed IO, App, TaggedLock] r) => Compile.PipelineArg -> Sem r () writeCoreFile pa@Compile.PipelineArg {..} = do entryPoint <- Compile.getEntry pa coreFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile diff --git a/app/Commands/Dev.hs b/app/Commands/Dev.hs index 62aad7c9b6..1b6e725429 100644 --- a/app/Commands/Dev.hs +++ b/app/Commands/Dev.hs @@ -19,7 +19,7 @@ import Commands.Dev.Scope qualified as Scope import Commands.Dev.Termination qualified as Termination import Commands.Repl qualified as Repl -runCommand :: (Members '[Embed IO, App] r) => DevCommand -> Sem r () +runCommand :: (Members '[Embed IO, App, TaggedLock] r) => DevCommand -> Sem r () runCommand = \case Highlight opts -> Highlight.runCommand opts Parse opts -> Parse.runCommand opts diff --git a/app/Commands/Dev/Asm.hs b/app/Commands/Dev/Asm.hs index 1efa8f3d79..1945ec5bc7 100644 --- a/app/Commands/Dev/Asm.hs +++ b/app/Commands/Dev/Asm.hs @@ -6,7 +6,7 @@ import Commands.Dev.Asm.Options import Commands.Dev.Asm.Run as Run import Commands.Dev.Asm.Validate as Validate -runCommand :: forall r. (Members '[Embed IO, App] r) => AsmCommand -> Sem r () +runCommand :: forall r. (Members '[Embed IO, App, TaggedLock] r) => AsmCommand -> Sem r () runCommand = \case Run opts -> Run.runCommand opts Validate opts -> Validate.runCommand opts diff --git a/app/Commands/Dev/Asm/Compile.hs b/app/Commands/Dev/Asm/Compile.hs index 9d1a3add24..3def53f3b2 100644 --- a/app/Commands/Dev/Asm/Compile.hs +++ b/app/Commands/Dev/Asm/Compile.hs @@ -8,7 +8,7 @@ import Juvix.Compiler.Asm.Translation.FromSource qualified as Asm import Juvix.Compiler.Backend qualified as Backend import Juvix.Compiler.Backend.C qualified as C -runCommand :: forall r. (Members '[Embed IO, App] r) => AsmCompileOptions -> Sem r () +runCommand :: forall r. (Members '[Embed IO, App, TaggedLock] r) => AsmCompileOptions -> Sem r () runCommand opts = do file <- getFile ep <- getEntryPoint (AppPath (preFileFromAbs file) True) diff --git a/app/Commands/Dev/Core.hs b/app/Commands/Dev/Core.hs index 24d8f74374..a3b8197f39 100644 --- a/app/Commands/Dev/Core.hs +++ b/app/Commands/Dev/Core.hs @@ -11,7 +11,7 @@ import Commands.Dev.Core.Read as Read import Commands.Dev.Core.Repl as Repl import Commands.Dev.Core.Strip as Strip -runCommand :: forall r. (Members '[Embed IO, App] r) => CoreCommand -> Sem r () +runCommand :: forall r. (Members '[Embed IO, App, TaggedLock] r) => CoreCommand -> Sem r () runCommand = \case Repl opts -> Repl.runCommand opts Eval opts -> Eval.runCommand opts diff --git a/app/Commands/Dev/Core/Compile.hs b/app/Commands/Dev/Core/Compile.hs index 0672d7af78..4b7d300484 100644 --- a/app/Commands/Dev/Core/Compile.hs +++ b/app/Commands/Dev/Core/Compile.hs @@ -6,7 +6,7 @@ import Commands.Dev.Core.Compile.Options import Juvix.Compiler.Core.Data.InfoTable qualified as Core import Juvix.Compiler.Core.Translation.FromSource qualified as Core -runCommand :: forall r. (Members '[Embed IO, App] r) => CompileOptions -> Sem r () +runCommand :: forall r. (Members '[Embed IO, App, TaggedLock] r) => CompileOptions -> Sem r () runCommand opts = do file <- getFile s <- readFile (toFilePath file) diff --git a/app/Commands/Dev/Core/Compile/Base.hs b/app/Commands/Dev/Core/Compile/Base.hs index af3e5f4138..1ee7b392f5 100644 --- a/app/Commands/Dev/Core/Compile/Base.hs +++ b/app/Commands/Dev/Core/Compile/Base.hs @@ -18,7 +18,7 @@ data PipelineArg = PipelineArg _pipelineArgInfoTable :: Core.InfoTable } -getEntry :: (Members '[Embed IO, App] r) => PipelineArg -> Sem r EntryPoint +getEntry :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r EntryPoint getEntry PipelineArg {..} = do ep <- getEntryPoint (AppPath (preFileFromAbs _pipelineArgFile) True) return $ @@ -46,7 +46,7 @@ getEntry PipelineArg {..} = do runCPipeline :: forall r. - (Members '[Embed IO, App] r) => + (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r () runCPipeline pa@PipelineArg {..} = do @@ -69,7 +69,7 @@ runCPipeline pa@PipelineArg {..} = do runGebPipeline :: forall r. - (Members '[Embed IO, App] r) => + (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r () runGebPipeline pa@PipelineArg {..} = do @@ -89,7 +89,7 @@ runGebPipeline pa@PipelineArg {..} = do runVampIRPipeline :: forall r. - (Members '[Embed IO, App] r) => + (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r () runVampIRPipeline pa@PipelineArg {..} = do @@ -98,7 +98,7 @@ runVampIRPipeline pa@PipelineArg {..} = do VampIR.Result {..} <- getRight (run (runReader entryPoint (runError (coreToVampIR _pipelineArgInfoTable :: Sem '[Error JuvixError, Reader EntryPoint] VampIR.Result)))) embed $ TIO.writeFile (toFilePath vampirFile) _resultCode -runAsmPipeline :: (Members '[Embed IO, App] r) => PipelineArg -> Sem r () +runAsmPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r () runAsmPipeline pa@PipelineArg {..} = do entryPoint <- getEntry pa asmFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile diff --git a/app/Commands/Dev/Geb/Repl.hs b/app/Commands/Dev/Geb/Repl.hs index a5f0f5d6dc..68e552dd14 100644 --- a/app/Commands/Dev/Geb/Repl.hs +++ b/app/Commands/Dev/Geb/Repl.hs @@ -43,7 +43,7 @@ runCommand replOpts = do gopts <- State.gets (^. replStateGlobalOptions) absInputFile :: Path Abs File <- replMakeAbsolute inputFile set entryPointTarget Backend.TargetGeb - <$> liftIO (entryPointFromGlobalOptions root absInputFile gopts) + <$> liftIO (runM (runTaggedLockPermissive (entryPointFromGlobalOptions root absInputFile gopts))) embed ( State.evalStateT (replAction replOpts getReplEntryPoint) diff --git a/app/Commands/Dev/Highlight.hs b/app/Commands/Dev/Highlight.hs index 3db3100cc5..9cdea0f216 100644 --- a/app/Commands/Dev/Highlight.hs +++ b/app/Commands/Dev/Highlight.hs @@ -5,7 +5,7 @@ import Commands.Dev.Highlight.Options import Juvix.Compiler.Concrete.Data.Highlight qualified as Highlight import Juvix.Compiler.Pipeline.Run -runCommand :: (Members '[Embed IO, App] r) => HighlightOptions -> Sem r () +runCommand :: (Members '[Embed IO, App, TaggedLock] r) => HighlightOptions -> Sem r () runCommand HighlightOptions {..} = do entry <- getEntryPoint _highlightInputFile inputFile <- fromAppPathFile _highlightInputFile diff --git a/app/Commands/Repl.hs b/app/Commands/Repl.hs index 828e1868e7..97b18947b5 100644 --- a/app/Commands/Repl.hs +++ b/app/Commands/Repl.hs @@ -39,7 +39,6 @@ import Juvix.Compiler.Pipeline.Setup (entrySetup) import Juvix.Data.CodeAnn (Ann) import Juvix.Data.Effect.Git import Juvix.Data.Effect.Process -import Juvix.Data.Effect.TaggedLock import Juvix.Data.Error.GenericError qualified as Error import Juvix.Data.NameKind import Juvix.Extra.Paths qualified as P @@ -172,10 +171,10 @@ getReplEntryPoint f inputFile = do liftIO (set entryPointSymbolPruningMode KeepAll <$> f root inputFile gopts) getReplEntryPointFromPrepath :: Prepath File -> Repl EntryPoint -getReplEntryPointFromPrepath = getReplEntryPoint entryPointFromGlobalOptionsPre +getReplEntryPointFromPrepath = getReplEntryPoint (\r x -> runM . runTaggedLockPermissive . entryPointFromGlobalOptionsPre r x) getReplEntryPointFromPath :: Path Abs File -> Repl EntryPoint -getReplEntryPointFromPath = getReplEntryPoint entryPointFromGlobalOptions +getReplEntryPointFromPath = getReplEntryPoint (\r a -> runM . runTaggedLockPermissive . entryPointFromGlobalOptions r a) displayVersion :: String -> Repl () displayVersion _ = liftIO (putStrLn versionTag) @@ -495,9 +494,10 @@ printRoot _ = do r <- State.gets (^. replStateRoot . rootRootDir) liftIO $ putStrLn (pack (toFilePath r)) -runCommand :: (Members '[Embed IO, App] r) => ReplOptions -> Sem r () +runCommand :: (Members '[Embed IO, App, TaggedLock] r) => ReplOptions -> Sem r () runCommand opts = do root <- askRoot + pkg <- askPackage let replAction :: ReplS () replAction = do evalReplOpts @@ -515,7 +515,8 @@ runCommand opts = do let env = ReplEnv { _replRoot = root, - _replOptions = opts + _replOptions = opts, + _replPackage = pkg } iniState = ReplState @@ -539,7 +540,7 @@ defaultPreludeEntryPoint = do root <- State.gets (^. replStateRoot) let buildRoot = root ^. rootRootDir buildDir = resolveAbsBuildDir buildRoot (root ^. rootBuildDir) - pkg = root ^. rootPackage + pkg <- Reader.asks (^. replPackage) mstdlibPath <- liftIO (runM (runFilesIO (packageStdlib buildRoot buildDir (pkg ^. packageDependencies)))) case mstdlibPath of Just stdlibPath -> diff --git a/app/Commands/Repl/Base.hs b/app/Commands/Repl/Base.hs index 2d9be7300e..97908e2fbf 100644 --- a/app/Commands/Repl/Base.hs +++ b/app/Commands/Repl/Base.hs @@ -20,6 +20,7 @@ data ReplContext = ReplContext data ReplEnv = ReplEnv { _replRoot :: Root, + _replPackage :: Package, _replOptions :: ReplOptions } diff --git a/app/GlobalOptions.hs b/app/GlobalOptions.hs index 7591ae60da..39c5aa6686 100644 --- a/app/GlobalOptions.hs +++ b/app/GlobalOptions.hs @@ -1,5 +1,6 @@ module GlobalOptions ( module GlobalOptions, + module Juvix.Data.Effect.TaggedLock, ) where @@ -7,6 +8,8 @@ import CommonOptions import Juvix.Compiler.Core.Options qualified as Core import Juvix.Compiler.Internal.Pretty.Options qualified as Internal import Juvix.Compiler.Pipeline +import Juvix.Compiler.Pipeline.Package (readPackageRootIO) +import Juvix.Data.Effect.TaggedLock import Juvix.Data.Error.GenericError qualified as E data GlobalOptions = GlobalOptions @@ -139,16 +142,17 @@ parseBuildDir m = do ) pure AppPath {_pathIsInput = False, ..} -entryPointFromGlobalOptionsPre :: Root -> Prepath File -> GlobalOptions -> IO EntryPoint +entryPointFromGlobalOptionsPre :: (Members '[TaggedLock, Embed IO] r) => Root -> Prepath File -> GlobalOptions -> Sem r EntryPoint entryPointFromGlobalOptionsPre root premainFile opts = do - mainFile <- prepathToAbsFile (root ^. rootInvokeDir) premainFile + mainFile <- liftIO (prepathToAbsFile (root ^. rootInvokeDir) premainFile) entryPointFromGlobalOptions root mainFile opts -entryPointFromGlobalOptions :: Root -> Path Abs File -> GlobalOptions -> IO EntryPoint +entryPointFromGlobalOptions :: (Members '[TaggedLock, Embed IO] r) => Root -> Path Abs File -> GlobalOptions -> Sem r EntryPoint entryPointFromGlobalOptions root mainFile opts = do - mabsBuildDir :: Maybe (Path Abs Dir) <- mapM (prepathToAbsDir cwd) optBuildDir + mabsBuildDir :: Maybe (Path Abs Dir) <- liftIO (mapM (prepathToAbsDir cwd) optBuildDir) + pkg <- readPackageRootIO root let def :: EntryPoint - def = defaultEntryPoint root mainFile + def = defaultEntryPoint pkg root mainFile return def { _entryPointNoTermination = opts ^. globalNoTermination, @@ -165,11 +169,12 @@ entryPointFromGlobalOptions root mainFile opts = do optBuildDir = fmap (^. pathPath) (opts ^. globalBuildDir) cwd = root ^. rootInvokeDir -entryPointFromGlobalOptionsNoFile :: Root -> GlobalOptions -> IO EntryPoint +entryPointFromGlobalOptionsNoFile :: (Members '[Embed IO, TaggedLock] r, MonadIO (Sem r)) => Root -> GlobalOptions -> Sem r EntryPoint entryPointFromGlobalOptionsNoFile root opts = do mabsBuildDir :: Maybe (Path Abs Dir) <- mapM (prepathToAbsDir cwd) optBuildDir + pkg <- readPackageRootIO root let def :: EntryPoint - def = defaultEntryPointNoFile root + def = defaultEntryPointNoFile pkg root return def { _entryPointNoTermination = opts ^. globalNoTermination, diff --git a/app/Main.hs b/app/Main.hs index 82e4590545..a5b54dc688 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -7,7 +7,6 @@ import CommonOptions import Data.String.Interpolate (i) import GlobalOptions import Juvix.Compiler.Pipeline.Root -import Juvix.Data.Effect.TaggedLock import TopCommand import TopCommand.Options @@ -19,12 +18,13 @@ main = do mbuildDir <- mapM (prepathToAbsDir invokeDir) (_runAppIOArgsGlobalOptions ^? globalBuildDir . _Just . pathPath) mainFile <- topCommandInputPath cli mapM_ checkMainFile mainFile - _runAppIOArgsRoot <- findRootAndChangeDir LockModePermissive (containingDir <$> mainFile) mbuildDir invokeDir runFinal . resourceToIOFinal . embedToFinal @IO - . runAppIO RunAppIOArgs {..} - $ runTopCommand cli + . runTaggedLockPermissive + $ do + _runAppIOArgsRoot <- findRootAndChangeDir (containingDir <$> mainFile) mbuildDir invokeDir + runAppIO RunAppIOArgs {..} (runTopCommand cli) where checkMainFile :: SomePath b -> IO () checkMainFile p = unlessM (doesSomePathExist p) err diff --git a/app/TopCommand.hs b/app/TopCommand.hs index 485b5638c1..4abae2ab5b 100644 --- a/app/TopCommand.hs +++ b/app/TopCommand.hs @@ -25,7 +25,7 @@ showHelpText = do (msg, _) = renderFailure helpText progn putStrLn (pack msg) -runTopCommand :: forall r. (Members '[Embed IO, App, Resource] r) => TopCommand -> Sem r () +runTopCommand :: forall r. (Members '[Embed IO, App, Resource, TaggedLock] r) => TopCommand -> Sem r () runTopCommand = \case DisplayVersion -> embed runDisplayVersion DisplayNumericVersion -> embed runDisplayNumericVersion diff --git a/src/Juvix/Compiler/Core/Evaluator.hs b/src/Juvix/Compiler/Core/Evaluator.hs index ad6f7b4fd7..8bfda475f3 100644 --- a/src/Juvix/Compiler/Core/Evaluator.hs +++ b/src/Juvix/Compiler/Core/Evaluator.hs @@ -401,23 +401,24 @@ evalIO = hEvalIO stderr stdin stdout doEval :: forall r. - (Members '[Embed IO] r) => + (MonadIO (Sem r)) => Bool -> Interval -> InfoTable -> Node -> Sem r (Either CoreError Node) doEval noIO loc tab node - | noIO = embed $ catchEvalError loc (eval stderr (tab ^. identContext) [] node) - | otherwise = embed $ catchEvalErrorIO loc (evalIO (tab ^. identContext) [] node) + | noIO = catchEvalError loc (eval stderr (tab ^. identContext) [] node) + | otherwise = liftIO (catchEvalErrorIO loc (evalIO (tab ^. identContext) [] node)) -- | Catch EvalError and convert it to CoreError. Needs a default location in case -- no location is available in EvalError. -catchEvalError :: Location -> a -> IO (Either CoreError a) +catchEvalError :: (MonadIO m) => Location -> a -> m (Either CoreError a) catchEvalError loc a = - Exception.catch - (Exception.evaluate a <&> Right) - (\(ex :: EvalError) -> return (Left (toCoreError loc ex))) + liftIO $ + Exception.catch + (Exception.evaluate a <&> Right) + (\(ex :: EvalError) -> return (Left (toCoreError loc ex))) catchEvalErrorIO :: Location -> IO a -> IO (Either CoreError a) catchEvalErrorIO loc ma = diff --git a/src/Juvix/Compiler/Pipeline/EntryPoint.hs b/src/Juvix/Compiler/Pipeline/EntryPoint.hs index 3ecd9f4801..d36a21f0f6 100644 --- a/src/Juvix/Compiler/Pipeline/EntryPoint.hs +++ b/src/Juvix/Compiler/Pipeline/EntryPoint.hs @@ -44,14 +44,14 @@ data EntryPoint = EntryPoint makeLenses ''EntryPoint -defaultEntryPoint :: Root -> Path Abs File -> EntryPoint -defaultEntryPoint root mainFile = - (defaultEntryPointNoFile root) +defaultEntryPoint :: Package -> Root -> Path Abs File -> EntryPoint +defaultEntryPoint pkg root mainFile = + (defaultEntryPointNoFile pkg root) { _entryPointModulePaths = pure mainFile } -defaultEntryPointNoFile :: Root -> EntryPoint -defaultEntryPointNoFile root = +defaultEntryPointNoFile :: Package -> Root -> EntryPoint +defaultEntryPointNoFile pkg root = EntryPoint { _entryPointRoot = root ^. rootRootDir, _entryPointResolverRoot = root ^. rootRootDir, @@ -61,7 +61,7 @@ defaultEntryPointNoFile root = _entryPointNoCoverage = False, _entryPointNoStdlib = False, _entryPointStdin = Nothing, - _entryPointPackage = root ^. rootPackage, + _entryPointPackage = pkg, _entryPointPackageType = root ^. rootPackageType, _entryPointGenericOptions = defaultGenericOptions, _entryPointTarget = TargetCore, diff --git a/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs b/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs index 9babe49707..4e8f65cdb0 100644 --- a/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs +++ b/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs @@ -1,22 +1,19 @@ module Juvix.Compiler.Pipeline.EntryPoint.IO where import Juvix.Compiler.Pipeline.EntryPoint +import Juvix.Compiler.Pipeline.Package import Juvix.Compiler.Pipeline.Root import Juvix.Data.Effect.TaggedLock import Juvix.Prelude -defaultEntryPointIO :: Path Abs Dir -> Path Abs File -> IO EntryPoint -defaultEntryPointIO = defaultEntryPointIO' LockModePermissive +defaultEntryPointIO :: (Members '[Embed IO, TaggedLock, Final IO] r) => Path Abs Dir -> Path Abs File -> Sem r EntryPoint +defaultEntryPointIO cwd mainFile = do + root <- findRootAndChangeDir (Just (parent mainFile)) Nothing cwd + pkg <- readPackageRootIO root + return (defaultEntryPoint pkg root mainFile) -defaultEntryPointIO' :: LockMode -> Path Abs Dir -> Path Abs File -> IO EntryPoint -defaultEntryPointIO' lockMode cwd mainFile = do - root <- findRootAndChangeDir lockMode (Just (parent mainFile)) Nothing cwd - return (defaultEntryPoint root mainFile) - -defaultEntryPointNoFileIO :: Path Abs Dir -> IO EntryPoint -defaultEntryPointNoFileIO = defaultEntryPointNoFileIO' LockModePermissive - -defaultEntryPointNoFileIO' :: LockMode -> Path Abs Dir -> IO EntryPoint -defaultEntryPointNoFileIO' lockMode cwd = do - root <- findRootAndChangeDir lockMode Nothing Nothing cwd - return (defaultEntryPointNoFile root) +defaultEntryPointNoFileIO :: (Members '[Embed IO, TaggedLock, Final IO] r) => Path Abs Dir -> Sem r EntryPoint +defaultEntryPointNoFileIO cwd = do + root <- findRootAndChangeDir Nothing Nothing cwd + pkg <- readPackageRootIO root + return (defaultEntryPointNoFile pkg root) diff --git a/src/Juvix/Compiler/Pipeline/Package.hs b/src/Juvix/Compiler/Pipeline/Package.hs index b1f8b8def8..0af265269f 100644 --- a/src/Juvix/Compiler/Pipeline/Package.hs +++ b/src/Juvix/Compiler/Pipeline/Package.hs @@ -2,6 +2,7 @@ module Juvix.Compiler.Pipeline.Package ( module Juvix.Compiler.Pipeline.Package.Base, readPackage, readPackageIO, + readPackageRootIO, readGlobalPackageIO, readGlobalPackage, loadPackageFileIO, @@ -19,6 +20,8 @@ import Juvix.Compiler.Pipeline.Package.Loader import Juvix.Compiler.Pipeline.Package.Loader.Error import Juvix.Compiler.Pipeline.Package.Loader.EvalEff import Juvix.Compiler.Pipeline.Package.Loader.EvalEff.IO +import Juvix.Compiler.Pipeline.Root.Base +import Juvix.Compiler.Pipeline.Root.Base qualified as Root import Juvix.Data.Effect.TaggedLock import Juvix.Extra.Paths import Juvix.Prelude @@ -133,27 +136,22 @@ loadPackageFileIO root buildDir = . runEvalFileEffIO $ loadPackage buildDir (mkPackagePath root) -readPackageIO :: LockMode -> Path Abs Dir -> BuildDir -> IO Package -readPackageIO lockMode root buildDir = - runFinal - . resourceToIOFinal - . embedToFinal @IO - . runFilesIO +readPackageRootIO :: (Members '[TaggedLock, Embed IO] r) => Root -> Sem r Package +readPackageRootIO root = readPackageIO (root ^. rootRootDir) (root ^. Root.rootBuildDir) + +readPackageIO :: (Members '[TaggedLock, Embed IO] r) => Path Abs Dir -> BuildDir -> Sem r Package +readPackageIO root buildDir = + runFilesIO . runErrorIO' @JuvixError . mapError (JuvixError @PackageLoaderError) - . runTaggedLock lockMode . runEvalFileEffIO $ readPackage root buildDir -readGlobalPackageIO :: LockMode -> IO Package -readGlobalPackageIO lockMode = - runFinal - . resourceToIOFinal - . embedToFinal @IO - . runFilesIO +readGlobalPackageIO :: (Members '[Embed IO, TaggedLock] r) => Sem r Package +readGlobalPackageIO = + runFilesIO . runErrorIO' @JuvixError . mapError (JuvixError @PackageLoaderError) - . runTaggedLock lockMode . runEvalFileEffIO $ readGlobalPackage diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs b/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs index 28d3a602aa..0719f5b111 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs @@ -143,14 +143,13 @@ loadPackage' packagePath = do rootPath = parent packagePath packageEntryPoint :: EntryPoint - packageEntryPoint = defaultEntryPoint root packagePath + packageEntryPoint = defaultEntryPoint rootPkg root packagePath where root :: Root root = Root { _rootRootDir = rootPath, _rootPackageType = GlobalPackageDescription, - _rootPackage = rootPkg, _rootInvokeDir = rootPath, _rootBuildDir = DefaultBuildDir } diff --git a/src/Juvix/Compiler/Pipeline/Root.hs b/src/Juvix/Compiler/Pipeline/Root.hs index 822519d6c2..17a44673d3 100644 --- a/src/Juvix/Compiler/Pipeline/Root.hs +++ b/src/Juvix/Compiler/Pipeline/Root.hs @@ -4,6 +4,7 @@ module Juvix.Compiler.Pipeline.Root ) where +import Control.Exception (SomeException) import Control.Exception qualified as IO import Juvix.Compiler.Pipeline.Package import Juvix.Compiler.Pipeline.Root.Base @@ -12,15 +13,16 @@ import Juvix.Extra.Paths qualified as Paths import Juvix.Prelude findRootAndChangeDir :: - LockMode -> + forall r. + (Members '[Embed IO, TaggedLock, Final IO] r) => Maybe (Path Abs Dir) -> Maybe (Path Abs Dir) -> Path Abs Dir -> - IO Root -findRootAndChangeDir lockMode minputFileDir mbuildDir _rootInvokeDir = do - r <- IO.try go + Sem r Root +findRootAndChangeDir minputFileDir mbuildDir _rootInvokeDir = do + r <- runError (fromExceptionSem @SomeException go) case r of - Left (err :: IO.SomeException) -> do + Left (err :: IO.SomeException) -> liftIO $ do putStrLn "Something went wrong when looking for the root of the project" putStrLn (pack (IO.displayException err)) exitFailure @@ -29,7 +31,7 @@ findRootAndChangeDir lockMode minputFileDir mbuildDir _rootInvokeDir = do possiblePaths :: Path Abs Dir -> [Path Abs Dir] possiblePaths p = p : toList (parents p) - findPackageFile :: IO (Maybe (Path Abs File)) + findPackageFile :: (Members '[Embed IO] r') => Sem r' (Maybe (Path Abs File)) findPackageFile = do let cwd = fromMaybe _rootInvokeDir minputFileDir findPackageFile' = findFile (possiblePaths cwd) @@ -37,31 +39,31 @@ findRootAndChangeDir lockMode minputFileDir mbuildDir _rootInvokeDir = do pFile <- findPackageFile' Paths.packageFilePath return (pFile <|> yamlFile) - go :: IO Root + go :: Sem (Error SomeException ': r) Root go = do l <- findPackageFile case l of Nothing -> do let cwd = fromMaybe _rootInvokeDir minputFileDir - packageBaseRootDir <- runM (runFilesIO globalPackageBaseRoot) + packageBaseRootDir <- runFilesIO globalPackageBaseRoot (_rootPackage, _rootRootDir, _rootPackageType) <- if | isPathPrefix packageBaseRootDir cwd -> return (packageBasePackage, packageBaseRootDir, GlobalPackageBase) | otherwise -> do - globalPkg <- readGlobalPackageIO lockMode - r <- runM (runFilesIO globalRoot) + globalPkg <- readGlobalPackageIO + r <- runFilesIO globalRoot return (globalPkg, r, GlobalStdlib) let _rootBuildDir = getBuildDir mbuildDir return Root {..} Just pkgPath -> do - packageDescriptionRootDir <- runM (runFilesIO globalPackageDescriptionRoot) + packageDescriptionRootDir <- runFilesIO globalPackageDescriptionRoot let _rootRootDir = parent pkgPath _rootPackageType | isPathPrefix packageDescriptionRootDir _rootRootDir = GlobalPackageDescription | otherwise = LocalPackage _rootBuildDir = getBuildDir mbuildDir - _rootPackage <- readPackageIO lockMode _rootRootDir _rootBuildDir + _rootPackage <- readPackageIO _rootRootDir _rootBuildDir return Root {..} getBuildDir :: Maybe (Path Abs Dir) -> BuildDir diff --git a/src/Juvix/Compiler/Pipeline/Root/Base.hs b/src/Juvix/Compiler/Pipeline/Root/Base.hs index c553fb0549..8946107dd7 100644 --- a/src/Juvix/Compiler/Pipeline/Root/Base.hs +++ b/src/Juvix/Compiler/Pipeline/Root/Base.hs @@ -12,11 +12,9 @@ data PackageType data Root = Root { _rootRootDir :: Path Abs Dir, - _rootPackage :: Package, _rootPackageType :: PackageType, _rootBuildDir :: BuildDir, _rootInvokeDir :: Path Abs Dir } - deriving stock (Show) makeLenses ''Root diff --git a/src/Juvix/Data/Effect/TaggedLock.hs b/src/Juvix/Data/Effect/TaggedLock.hs index 81a8204e34..8a0973e8cf 100644 --- a/src/Juvix/Data/Effect/TaggedLock.hs +++ b/src/Juvix/Data/Effect/TaggedLock.hs @@ -31,7 +31,9 @@ withTaggedLockDir d = do p = maybe lockFile ( lockFile) (dropDrive d) withTaggedLock p -data LockMode = LockModePermissive | LockModeExclusive +data LockMode + = LockModePermissive + | LockModeExclusive runTaggedLock :: (Members '[Resource, Embed IO] r) => LockMode -> Sem (TaggedLock ': r) a -> Sem r a runTaggedLock = \case diff --git a/src/Juvix/Prelude/Prepath.hs b/src/Juvix/Prelude/Prepath.hs index 24dafb3d9d..774d14e3cc 100644 --- a/src/Juvix/Prelude/Prepath.hs +++ b/src/Juvix/Prelude/Prepath.hs @@ -42,7 +42,7 @@ data PrepathPart -- 3. ~ is reserved for $(HOME). I.e. the prepath ~~ will expand to $HOME$HOME. -- 4. Nested environment variables are not allowed. -- 5. Paths cannot start with space. -expandPrepath :: Prepath a -> IO FilePath +expandPrepath :: (MonadIO m) => Prepath a -> m FilePath expandPrepath (Prepath p) = let e = parseHelper prepathParts p in case e of @@ -77,14 +77,14 @@ expandPrepath (Prepath p) = str :: m String str = P.takeWhile1P (Just "") notReserved -expandParts :: PrepathParts -> IO FilePath +expandParts :: forall m. (MonadIO m) => PrepathParts -> m FilePath expandParts = mconcatMapM fromPart where - fromPart :: PrepathPart -> IO String + fromPart :: PrepathPart -> m String fromPart = \case PrepathString s -> return s - PrepathHome -> getHomeDirectory - PrepathVar s -> fromMaybe err <$> lookupEnv s + PrepathHome -> liftIO getHomeDirectory + PrepathVar s -> fromMaybe err <$> liftIO (lookupEnv s) where err = error ("The environment variable " <> pack s <> " is not defined") @@ -107,13 +107,13 @@ instance Pretty (Prepath d) where prepathToAbsFile :: Path Abs Dir -> Prepath File -> IO (Path Abs File) prepathToAbsFile root = fmap absFile . prepathToFilePath root -prepathToAbsDir :: Path Abs Dir -> Prepath Dir -> IO (Path Abs Dir) +prepathToAbsDir :: (MonadIO m) => Path Abs Dir -> Prepath Dir -> m (Path Abs Dir) prepathToAbsDir root = fmap absDir . prepathToFilePath root -prepathToFilePath :: Path Abs Dir -> Prepath d -> IO FilePath +prepathToFilePath :: (MonadIO m) => Path Abs Dir -> Prepath d -> m FilePath prepathToFilePath root pre = do expandedPre <- expandPrepath pre - System.canonicalizePath (toFilePath root expandedPre) + liftIO (System.canonicalizePath (toFilePath root expandedPre)) fromPreFileOrDir :: Path Abs Dir -> Prepath FileOrDir -> IO (Either (Path Abs File) (Path Abs Dir)) fromPreFileOrDir cwd fp = do From ee6943cfd6a01e6a530525e2e5afec28240b02bc Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Tue, 5 Dec 2023 16:57:08 +0100 Subject: [PATCH 2/7] add Package cache --- app/App.hs | 32 +++++++++++++++++++++-------- src/Juvix/Compiler/Pipeline/Root.hs | 11 ++++------ src/Juvix/Data/Effect/Cache.hs | 16 +++++++++++++++ 3 files changed, 44 insertions(+), 15 deletions(-) diff --git a/app/App.hs b/app/App.hs index 31a6a714ad..3fd0295027 100644 --- a/app/App.hs +++ b/app/App.hs @@ -5,6 +5,7 @@ import Data.ByteString qualified as ByteString import GlobalOptions import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker +import Juvix.Compiler.Pipeline.Package import Juvix.Compiler.Pipeline.Run import Juvix.Data.Error qualified as Error import Juvix.Extra.Paths.Base hiding (rootBuildDir) @@ -41,14 +42,26 @@ data RunAppIOArgs = RunAppIOArgs _runAppIOArgsRoot :: Root } +makeLenses ''RunAppIOArgs + runAppIO :: forall r a. (Members '[Embed IO, TaggedLock] r) => RunAppIOArgs -> Sem (App ': r) a -> Sem r a -runAppIO args@RunAppIOArgs {..} = - interpret $ \case +runAppIO args = evalSingletonCache (readPackageRootIO root) . reAppIO args + where + root = args ^. runAppIOArgsRoot + +reAppIO :: + forall r a. + (Members '[Embed IO, TaggedLock] r) => + RunAppIOArgs -> + Sem (App ': r) a -> + Sem (SCache Package ': r) a +reAppIO args@RunAppIOArgs {..} = + reinterpret $ \case AskPackageGlobal -> return (_runAppIOArgsRoot ^. rootPackageType `elem` [GlobalStdlib, GlobalPackageDescription, GlobalPackageBase]) FromAppPathFile p -> embed (prepathToAbsFile invDir (p ^. pathPath)) GetMainFile m -> getMainFile' m @@ -84,11 +97,13 @@ runAppIO args@RunAppIOArgs {..} = ExitMsg exitCode t -> exitMsg' exitCode t SayRaw b -> embed (ByteString.putStr b) where - getPkg :: Sem r Package - getPkg = undefined - exitMsg' :: ExitCode -> Text -> Sem r x - exitMsg' exitCode t = embed (putStrLn t >> hFlush stdout >> exitWith exitCode) - getMainFile' :: Maybe (AppPath File) -> Sem r (Path Abs File) + getPkg :: (Members '[SCache Package] r') => Sem r' Package + getPkg = cacheSingletonGet + + exitMsg' :: (Members '[Embed IO] r') => ExitCode -> Text -> Sem r' x + exitMsg' exitCode t = liftIO (putStrLn t >> hFlush stdout >> exitWith exitCode) + + getMainFile' :: (Members '[SCache Package, Embed IO] r') => Maybe (AppPath File) -> Sem r' (Path Abs File) getMainFile' = \case Just p -> embed (prepathToAbsFile invDir (p ^. pathPath)) -- Nothing -> case pkg ^. packageMain of @@ -97,7 +112,8 @@ runAppIO args@RunAppIOArgs {..} = case pkg ^. packageMain of Just p -> embed (prepathToAbsFile invDir p) Nothing -> missingMainErr - missingMainErr :: Sem r x + + missingMainErr :: (Members '[Embed IO] r') => Sem r' x missingMainErr = exitMsg' (ExitFailure 1) diff --git a/src/Juvix/Compiler/Pipeline/Root.hs b/src/Juvix/Compiler/Pipeline/Root.hs index 17a44673d3..28a618ddcb 100644 --- a/src/Juvix/Compiler/Pipeline/Root.hs +++ b/src/Juvix/Compiler/Pipeline/Root.hs @@ -8,13 +8,12 @@ import Control.Exception (SomeException) import Control.Exception qualified as IO import Juvix.Compiler.Pipeline.Package import Juvix.Compiler.Pipeline.Root.Base -import Juvix.Data.Effect.TaggedLock import Juvix.Extra.Paths qualified as Paths import Juvix.Prelude findRootAndChangeDir :: forall r. - (Members '[Embed IO, TaggedLock, Final IO] r) => + (Members '[Embed IO, Final IO] r) => Maybe (Path Abs Dir) -> Maybe (Path Abs Dir) -> Path Abs Dir -> @@ -46,14 +45,13 @@ findRootAndChangeDir minputFileDir mbuildDir _rootInvokeDir = do Nothing -> do let cwd = fromMaybe _rootInvokeDir minputFileDir packageBaseRootDir <- runFilesIO globalPackageBaseRoot - (_rootPackage, _rootRootDir, _rootPackageType) <- + (_rootRootDir, _rootPackageType) <- if | isPathPrefix packageBaseRootDir cwd -> - return (packageBasePackage, packageBaseRootDir, GlobalPackageBase) + return (packageBaseRootDir, GlobalPackageBase) | otherwise -> do - globalPkg <- readGlobalPackageIO r <- runFilesIO globalRoot - return (globalPkg, r, GlobalStdlib) + return (r, GlobalStdlib) let _rootBuildDir = getBuildDir mbuildDir return Root {..} Just pkgPath -> do @@ -63,7 +61,6 @@ findRootAndChangeDir minputFileDir mbuildDir _rootInvokeDir = do | isPathPrefix packageDescriptionRootDir _rootRootDir = GlobalPackageDescription | otherwise = LocalPackage _rootBuildDir = getBuildDir mbuildDir - _rootPackage <- readPackageIO _rootRootDir _rootBuildDir return Root {..} getBuildDir :: Maybe (Path Abs Dir) -> BuildDir diff --git a/src/Juvix/Data/Effect/Cache.hs b/src/Juvix/Data/Effect/Cache.hs index 2c3393e7f9..efb3b7c4ea 100644 --- a/src/Juvix/Data/Effect/Cache.hs +++ b/src/Juvix/Data/Effect/Cache.hs @@ -5,7 +5,10 @@ module Juvix.Data.Effect.Cache runCacheEmpty, cacheGet, cacheLookup, + evalSingletonCache, + cacheSingletonGet, Cache, + SCache, ) where @@ -15,6 +18,9 @@ data Cache k v m a where CacheGet :: k -> Cache k v m v CacheLookup :: k -> Cache k v m (Maybe v) +-- | Singleton cache +type SCache = Cache () + makeSem ''Cache -- | Run a 'Cache' effect purely. @@ -52,6 +58,16 @@ runCacheEmpty :: runCacheEmpty f = runCache f mempty {-# INLINE runCacheEmpty #-} +cacheSingletonGet :: (Members '[SCache v] r) => Sem r v +cacheSingletonGet = cacheGet () + +evalSingletonCache :: + Sem (SCache v ': r) v -> + Sem (SCache v ': r) a -> + Sem r a +evalSingletonCache f c = evalCacheEmpty @() (const f) c +{-# INLINE evalSingletonCache #-} + re :: forall k v r a. (Hashable k) => From 68448ec2cbd9ae5216cd412a4f1ad16c863b6f0a Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Tue, 5 Dec 2023 20:28:34 +0100 Subject: [PATCH 3/7] refactor tests --- app/App.hs | 31 ++++++++------ app/Commands/Dependencies.hs | 2 +- app/Commands/Dependencies/Update.hs | 2 +- app/Commands/Dev/Core/FromConcrete.hs | 2 +- app/Commands/Dev/Highlight.hs | 2 +- app/Commands/Dev/Internal.hs | 2 +- app/Commands/Dev/Internal/Pretty.hs | 2 +- app/Commands/Dev/Internal/Reachability.hs | 2 +- app/Commands/Dev/Internal/Typecheck.hs | 2 +- app/Commands/Dev/Parse.hs | 2 +- app/Commands/Dev/Scope.hs | 2 +- app/Commands/Dev/Termination.hs | 2 +- app/Commands/Dev/Termination/CallGraph.hs | 2 +- app/Commands/Dev/Termination/Calls.hs | 2 +- app/Commands/Eval.hs | 2 +- app/Commands/Format.hs | 4 +- app/Commands/Html.hs | 4 +- app/Commands/Markdown.hs | 2 +- app/Commands/Typecheck.hs | 2 +- package.yaml | 1 + src/Juvix/Compiler/Pipeline.hs | 8 +++- src/Juvix/Compiler/Pipeline/Run.hs | 50 +++++------------------ test/BackendGeb/Compilation/Base.hs | 5 +-- test/BackendGeb/FromCore/Base.hs | 3 +- test/BackendMarkdown/Negative.hs | 5 +-- test/BackendMarkdown/Positive.hs | 7 ++-- test/Base.hs | 39 ++++++++++++++++++ test/Compilation/Base.hs | 9 ++-- test/Format.hs | 7 ++-- test/Formatter/Positive.hs | 9 ++-- test/Internal/Eval/Base.hs | 5 +-- test/Parsing/Negative.hs | 5 +-- test/Reachability/Positive.hs | 5 +-- test/Scope/Negative.hs | 5 +-- test/Scope/Positive.hs | 12 +++--- test/Termination/Negative.hs | 5 +-- test/Termination/Positive.hs | 9 ++-- test/Typecheck/Negative.hs | 5 +-- test/Typecheck/NegativeNew.hs | 5 +-- test/Typecheck/Positive.hs | 9 ++-- test/VampIR/Compilation/Base.hs | 9 ++-- 41 files changed, 145 insertions(+), 143 deletions(-) diff --git a/app/App.hs b/app/App.hs index 3fd0295027..fbc4cb385c 100644 --- a/app/App.hs +++ b/app/App.hs @@ -19,6 +19,7 @@ data App m a where ExitJuvixError :: JuvixError -> App m a PrintJuvixError :: JuvixError -> App m () AskRoot :: App m Root + AskArgs :: App m RunAppIOArgs AskInvokeDir :: App m (Path Abs Dir) AskPkgDir :: App m (Path Abs Dir) AskBuildDir :: App m (Path Abs Dir) @@ -29,19 +30,16 @@ data App m a where GetMainFile :: Maybe (AppPath File) -> App m (Path Abs File) FromAppPathDir :: AppPath Dir -> App m (Path Abs Dir) RenderStdOut :: (HasAnsiBackend a, HasTextBackend a) => a -> App m () - RunPipelineEither :: AppPath File -> Sem PipelineEff a -> App m (Either JuvixError (ResolverState, a)) - RunPipelineNoFileEither :: Sem PipelineEff a -> App m (Either JuvixError (ResolverState, a)) RunCorePipelineEither :: AppPath File -> App m (Either JuvixError Artifacts) Say :: Text -> App m () SayRaw :: ByteString -> App m () -makeSem ''App - data RunAppIOArgs = RunAppIOArgs { _runAppIOArgsGlobalOptions :: GlobalOptions, _runAppIOArgsRoot :: Root } +makeSem ''App makeLenses ''RunAppIOArgs runAppIO :: @@ -73,6 +71,7 @@ reAppIO args@RunAppIOArgs {..} = renderIO (not (_runAppIOArgsGlobalOptions ^. globalNoColors) && sup) t AskGlobalOptions -> return _runAppIOArgsGlobalOptions AskPackage -> getPkg + AskArgs -> return args AskRoot -> return _runAppIOArgsRoot AskInvokeDir -> return invDir AskPkgDir -> return (_runAppIOArgsRoot ^. rootRootDir) @@ -80,12 +79,6 @@ reAppIO args@RunAppIOArgs {..} = RunCorePipelineEither input -> do entry <- getEntryPoint' args input embed (corePipelineIOEither entry) - RunPipelineEither input p -> do - entry <- getEntryPoint' args input - embed (runIOEither entry p) - RunPipelineNoFileEither p -> do - entry <- getEntryPointStdin' args - embed (runIOEither entry p) Say t | g ^. globalOnlyErrors -> return () | otherwise -> embed (putStrLn t) @@ -137,6 +130,18 @@ getEntryPoint' RunAppIOArgs {..} inputFile = do | otherwise -> return Nothing set entryPointStdin estdin <$> entryPointFromGlobalOptionsPre root (inputFile ^. pathPath) opts +runPipelineNoFileEither :: (Members '[Embed IO, TaggedLock, App] r) => Sem (PipelineEff r) a -> Sem r (Either JuvixError (ResolverState, a)) +runPipelineNoFileEither p = do + args <- askArgs + entry <- getEntryPointStdin' args + snd <$> runIOEither entry p + +runPipelineEither :: (Members '[Embed IO, TaggedLock, App] r) => AppPath File -> Sem (PipelineEff r) a -> Sem r (Either JuvixError (ResolverState, a)) +runPipelineEither input p = do + args <- askArgs + entry <- getEntryPoint' args input + snd <$> runIOEither entry p + getEntryPointStdin' :: (Members '[Embed IO, TaggedLock] r) => RunAppIOArgs -> Sem r EntryPoint getEntryPointStdin' RunAppIOArgs {..} = do let opts = _runAppIOArgsGlobalOptions @@ -166,21 +171,21 @@ getEntryPoint inputFile = do _runAppIOArgsRoot <- askRoot getEntryPoint' (RunAppIOArgs {..}) inputFile -runPipelineTermination :: (Member App r) => AppPath File -> Sem (Termination ': PipelineEff) a -> Sem r a +runPipelineTermination :: (Members '[App, Embed IO, TaggedLock] r) => AppPath File -> Sem (Termination ': PipelineEff r) a -> Sem r a runPipelineTermination input p = do r <- runPipelineEither input (evalTermination iniTerminationState p) case r of Left err -> exitJuvixError err Right res -> return (snd res) -runPipeline :: (Member App r) => AppPath File -> Sem PipelineEff a -> Sem r a +runPipeline :: (Members '[App, Embed IO, TaggedLock] r) => AppPath File -> Sem (PipelineEff r) a -> Sem r a runPipeline input p = do r <- runPipelineEither input p case r of Left err -> exitJuvixError err Right res -> return (snd res) -runPipelineNoFile :: (Member App r) => Sem PipelineEff a -> Sem r a +runPipelineNoFile :: (Members '[App, Embed IO, TaggedLock] r) => Sem (PipelineEff r) a -> Sem r a runPipelineNoFile p = do r <- runPipelineNoFileEither p case r of diff --git a/app/Commands/Dependencies.hs b/app/Commands/Dependencies.hs index 876cd981e2..7df99cc17e 100644 --- a/app/Commands/Dependencies.hs +++ b/app/Commands/Dependencies.hs @@ -8,6 +8,6 @@ import Commands.Base import Commands.Dependencies.Options import Commands.Dependencies.Update qualified as Update -runCommand :: (Members '[Embed IO, App] r) => DependenciesCommand -> Sem r () +runCommand :: (Members '[Embed IO, TaggedLock, App] r) => DependenciesCommand -> Sem r () runCommand = \case Update -> Update.runCommand diff --git a/app/Commands/Dependencies/Update.hs b/app/Commands/Dependencies/Update.hs index 79e0e5ae41..e915057677 100644 --- a/app/Commands/Dependencies/Update.hs +++ b/app/Commands/Dependencies/Update.hs @@ -2,5 +2,5 @@ module Commands.Dependencies.Update where import Commands.Base -runCommand :: (Members '[Embed IO, App] r) => Sem r () +runCommand :: (Members '[Embed IO, TaggedLock, App] r) => Sem r () runCommand = runPipelineNoFile (upToSetup (set dependenciesConfigForceUpdateLockfile True defaultDependenciesConfig)) diff --git a/app/Commands/Dev/Core/FromConcrete.hs b/app/Commands/Dev/Core/FromConcrete.hs index 86b9f5e9f0..a30dbf5187 100644 --- a/app/Commands/Dev/Core/FromConcrete.hs +++ b/app/Commands/Dev/Core/FromConcrete.hs @@ -10,7 +10,7 @@ import Juvix.Compiler.Core.Transformation qualified as Core import Juvix.Compiler.Core.Transformation.DisambiguateNames (disambiguateNames) import Juvix.Compiler.Core.Translation -runCommand :: forall r. (Members '[Embed IO, App] r) => CoreFromConcreteOptions -> Sem r () +runCommand :: forall r. (Members '[Embed IO, TaggedLock, App] r) => CoreFromConcreteOptions -> Sem r () runCommand localOpts = do gopts <- askGlobalOptions tab <- (^. coreResultTable) <$> runPipeline (localOpts ^. coreFromConcreteInputFile) upToCore diff --git a/app/Commands/Dev/Highlight.hs b/app/Commands/Dev/Highlight.hs index 9cdea0f216..bc3f386f0d 100644 --- a/app/Commands/Dev/Highlight.hs +++ b/app/Commands/Dev/Highlight.hs @@ -12,5 +12,5 @@ runCommand HighlightOptions {..} = do hinput <- Highlight.filterInput inputFile - <$> liftIO (runPipelineHighlight entry upToInternalTyped) + <$> runPipelineHighlight entry upToInternalTyped sayRaw (Highlight.highlight _highlightBackend hinput) diff --git a/app/Commands/Dev/Internal.hs b/app/Commands/Dev/Internal.hs index 2e89ac3d13..729d2f4d39 100644 --- a/app/Commands/Dev/Internal.hs +++ b/app/Commands/Dev/Internal.hs @@ -6,7 +6,7 @@ import Commands.Dev.Internal.Pretty qualified as Pretty import Commands.Dev.Internal.Reachability qualified as Reachability import Commands.Dev.Internal.Typecheck qualified as Typecheck -runCommand :: (Members '[Embed IO, App] r) => InternalCommand -> Sem r () +runCommand :: (Members '[Embed IO, App, TaggedLock] r) => InternalCommand -> Sem r () runCommand = \case Pretty opts -> Pretty.runCommand opts TypeCheck opts -> Typecheck.runCommand opts diff --git a/app/Commands/Dev/Internal/Pretty.hs b/app/Commands/Dev/Internal/Pretty.hs index 71999cc8c3..dac0a6a88a 100644 --- a/app/Commands/Dev/Internal/Pretty.hs +++ b/app/Commands/Dev/Internal/Pretty.hs @@ -5,7 +5,7 @@ import Commands.Dev.Internal.Pretty.Options import Juvix.Compiler.Internal.Pretty qualified as Internal import Juvix.Compiler.Internal.Translation.FromConcrete qualified as Internal -runCommand :: (Members '[Embed IO, App] r) => InternalPrettyOptions -> Sem r () +runCommand :: (Members '[Embed IO, App, TaggedLock] r) => InternalPrettyOptions -> Sem r () runCommand opts = do globalOpts <- askGlobalOptions intern <- head . (^. Internal.resultModules) <$> runPipelineTermination (opts ^. internalPrettyInputFile) upToInternal diff --git a/app/Commands/Dev/Internal/Reachability.hs b/app/Commands/Dev/Internal/Reachability.hs index b4dca80368..0aaab80c1f 100644 --- a/app/Commands/Dev/Internal/Reachability.hs +++ b/app/Commands/Dev/Internal/Reachability.hs @@ -5,7 +5,7 @@ import Commands.Dev.Internal.Reachability.Options import Juvix.Compiler.Internal.Pretty qualified as Internal import Juvix.Compiler.Internal.Translation.FromConcrete qualified as Internal -runCommand :: (Members '[Embed IO, App] r) => InternalReachabilityOptions -> Sem r () +runCommand :: (Members '[Embed IO, App, TaggedLock] r) => InternalReachabilityOptions -> Sem r () runCommand opts = do globalOpts <- askGlobalOptions depInfo <- (^. Internal.resultDepInfo) <$> runPipelineTermination (opts ^. internalReachabilityInputFile) upToInternal diff --git a/app/Commands/Dev/Internal/Typecheck.hs b/app/Commands/Dev/Internal/Typecheck.hs index 17c0387573..ce184528e9 100644 --- a/app/Commands/Dev/Internal/Typecheck.hs +++ b/app/Commands/Dev/Internal/Typecheck.hs @@ -5,7 +5,7 @@ import Commands.Dev.Internal.Typecheck.Options import Juvix.Compiler.Internal.Pretty qualified as Internal import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking qualified as InternalTyped -runCommand :: (Members '[Embed IO, App] r) => InternalTypeOptions -> Sem r () +runCommand :: (Members '[Embed IO, TaggedLock, App] r) => InternalTypeOptions -> Sem r () runCommand localOpts = do globalOpts <- askGlobalOptions res <- runPipeline (localOpts ^. internalTypeInputFile) upToInternalTyped diff --git a/app/Commands/Dev/Parse.hs b/app/Commands/Dev/Parse.hs index d48cbbaeab..e365dfe039 100644 --- a/app/Commands/Dev/Parse.hs +++ b/app/Commands/Dev/Parse.hs @@ -5,7 +5,7 @@ import Commands.Dev.Parse.Options import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser import Text.Show.Pretty (ppShow) -runCommand :: (Members '[Embed IO, App] r) => ParseOptions -> Sem r () +runCommand :: (Members '[Embed IO, App, TaggedLock] r) => ParseOptions -> Sem r () runCommand opts = do m <- head . (^. Parser.resultModules) diff --git a/app/Commands/Dev/Scope.hs b/app/Commands/Dev/Scope.hs index fda65fa8d5..b44b693af7 100644 --- a/app/Commands/Dev/Scope.hs +++ b/app/Commands/Dev/Scope.hs @@ -7,7 +7,7 @@ import Juvix.Compiler.Concrete.Print qualified as Print import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper import Juvix.Prelude.Pretty -runCommand :: (Members '[Embed IO, App] r) => ScopeOptions -> Sem r () +runCommand :: (Members '[Embed IO, TaggedLock, App] r) => ScopeOptions -> Sem r () runCommand opts = do globalOpts <- askGlobalOptions res :: Scoper.ScoperResult <- runPipeline (opts ^. scopeInputFile) upToScoping diff --git a/app/Commands/Dev/Termination.hs b/app/Commands/Dev/Termination.hs index 5409dbb271..3c072f2326 100644 --- a/app/Commands/Dev/Termination.hs +++ b/app/Commands/Dev/Termination.hs @@ -5,7 +5,7 @@ import Commands.Dev.Termination.CallGraph qualified as CallGraph import Commands.Dev.Termination.Calls qualified as Calls import Commands.Dev.Termination.Options -runCommand :: (Members '[Embed IO, App] r) => TerminationCommand -> Sem r () +runCommand :: (Members '[Embed IO, TaggedLock, App] r) => TerminationCommand -> Sem r () runCommand = \case Calls opts -> Calls.runCommand opts CallGraph opts -> CallGraph.runCommand opts diff --git a/app/Commands/Dev/Termination/CallGraph.hs b/app/Commands/Dev/Termination/CallGraph.hs index 5a05cb0ae4..6da03795f7 100644 --- a/app/Commands/Dev/Termination/CallGraph.hs +++ b/app/Commands/Dev/Termination/CallGraph.hs @@ -9,7 +9,7 @@ import Juvix.Compiler.Internal.Translation.FromConcrete.Data.Context qualified a import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination qualified as Termination import Juvix.Prelude.Pretty -runCommand :: (Members '[Embed IO, App] r) => CallGraphOptions -> Sem r () +runCommand :: (Members '[Embed IO, TaggedLock, App] r) => CallGraphOptions -> Sem r () runCommand CallGraphOptions {..} = do globalOpts <- askGlobalOptions results <- runPipelineTermination _graphInputFile upToInternal diff --git a/app/Commands/Dev/Termination/Calls.hs b/app/Commands/Dev/Termination/Calls.hs index e2d4205ef3..e91bbe4657 100644 --- a/app/Commands/Dev/Termination/Calls.hs +++ b/app/Commands/Dev/Termination/Calls.hs @@ -6,7 +6,7 @@ import Juvix.Compiler.Internal.Pretty qualified as Internal import Juvix.Compiler.Internal.Translation.FromConcrete qualified as Internal import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination qualified as Termination -runCommand :: (Members '[Embed IO, App] r) => CallsOptions -> Sem r () +runCommand :: (Members '[Embed IO, TaggedLock, App] r) => CallsOptions -> Sem r () runCommand localOpts@CallsOptions {..} = do globalOpts <- askGlobalOptions results <- runPipelineTermination _callsInputFile upToInternal diff --git a/app/Commands/Eval.hs b/app/Commands/Eval.hs index 1f6190a7b5..18cb4709c7 100644 --- a/app/Commands/Eval.hs +++ b/app/Commands/Eval.hs @@ -6,7 +6,7 @@ import Evaluator qualified as Eval import Juvix.Compiler.Core qualified as Core import Juvix.Extra.Strings qualified as Str -runCommand :: (Members '[Embed IO, App] r) => EvalOptions -> Sem r () +runCommand :: (Members '[Embed IO, TaggedLock, App] r) => EvalOptions -> Sem r () runCommand opts@EvalOptions {..} = do gopts <- askGlobalOptions Core.CoreResult {..} <- runPipeline _evalInputFile upToCore diff --git a/app/Commands/Format.hs b/app/Commands/Format.hs index 984a585a1f..10f0f13216 100644 --- a/app/Commands/Format.hs +++ b/app/Commands/Format.hs @@ -45,7 +45,7 @@ targetFromOptions opts = do "Use the --help option to display more usage information." ] -runCommand :: forall r. (Members '[Embed IO, App, Resource, Files] r) => FormatOptions -> Sem r () +runCommand :: forall r. (Members '[Embed IO, App, TaggedLock, Resource, Files] r) => FormatOptions -> Sem r () runCommand opts = do target <- targetFromOptions opts runOutputSem (renderFormattedOutput target opts) $ runScopeFileApp $ do @@ -96,7 +96,7 @@ renderFormattedOutput target opts fInfo = do InputPath p -> say (pack (toFilePath p)) Silent -> return () -runScopeFileApp :: (Member App r) => Sem (ScopeEff ': r) a -> Sem r a +runScopeFileApp :: (Members '[App, Embed IO, TaggedLock] r) => Sem (ScopeEff ': r) a -> Sem r a runScopeFileApp = interpret $ \case ScopeFile p -> do let appFile = diff --git a/app/Commands/Html.hs b/app/Commands/Html.hs index f61d17ac64..3d44df4d94 100644 --- a/app/Commands/Html.hs +++ b/app/Commands/Html.hs @@ -13,7 +13,7 @@ import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Cont import Juvix.Extra.Process import System.Process qualified as Process -runGenOnlySourceHtml :: (Members '[Embed IO, App] r) => HtmlOptions -> Sem r () +runGenOnlySourceHtml :: (Members '[Embed IO, TaggedLock, App] r) => HtmlOptions -> Sem r () runGenOnlySourceHtml HtmlOptions {..} = do res <- runPipeline _htmlInputFile upToScoping let m = head (res ^. Scoper.resultModules) @@ -37,7 +37,7 @@ runGenOnlySourceHtml HtmlOptions {..} = do _genSourceHtmlArgsTheme = _htmlTheme } -runCommand :: (Members '[Embed IO, App] r) => HtmlOptions -> Sem r () +runCommand :: (Members '[Embed IO, TaggedLock, App] r) => HtmlOptions -> Sem r () runCommand HtmlOptions {..} | _htmlOnlySource = runGenOnlySourceHtml HtmlOptions {..} | otherwise = do diff --git a/app/Commands/Markdown.hs b/app/Commands/Markdown.hs index b52d29a95d..7f845fe273 100644 --- a/app/Commands/Markdown.hs +++ b/app/Commands/Markdown.hs @@ -12,7 +12,7 @@ import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified import Juvix.Extra.Assets (writeAssets) runCommand :: - (Members '[Embed IO, App] r) => + (Members '[Embed IO, TaggedLock, App] r) => MarkdownOptions -> Sem r () runCommand opts = do diff --git a/app/Commands/Typecheck.hs b/app/Commands/Typecheck.hs index c754aaf76d..39387b56ec 100644 --- a/app/Commands/Typecheck.hs +++ b/app/Commands/Typecheck.hs @@ -3,7 +3,7 @@ module Commands.Typecheck where import Commands.Base import Commands.Typecheck.Options -runCommand :: (Members '[Embed IO, App] r) => TypecheckOptions -> Sem r () +runCommand :: (Members '[Embed IO, TaggedLock, App] r) => TypecheckOptions -> Sem r () runCommand localOpts = do void (runPipeline (localOpts ^. typecheckInputFile) upToCoreTypecheck) say "Well done! It type checks" diff --git a/package.yaml b/package.yaml index 4bc8691ca6..c18d5a223c 100644 --- a/package.yaml +++ b/package.yaml @@ -77,6 +77,7 @@ dependencies: - process == 1.6.* - safe == 0.3.* - singletons == 3.0.* + - singletons-base == 3.1.* - singletons-th == 3.1.* - Stream == 0.4.* - string-interpolate == 0.3.* diff --git a/src/Juvix/Compiler/Pipeline.hs b/src/Juvix/Compiler/Pipeline.hs index 2a97394354..3f959a424f 100644 --- a/src/Juvix/Compiler/Pipeline.hs +++ b/src/Juvix/Compiler/Pipeline.hs @@ -7,6 +7,7 @@ module Juvix.Compiler.Pipeline ) where +import Data.List.Singletons import Juvix.Compiler.Asm.Error qualified as Asm import Juvix.Compiler.Asm.Options qualified as Asm import Juvix.Compiler.Asm.Pipeline qualified as Asm @@ -40,9 +41,12 @@ import Juvix.Data.Effect.Process import Juvix.Data.Effect.TaggedLock import Juvix.Prelude -type PipelineEff = '[PathResolver, EvalFileEff, Error PackageLoaderError, Error DependencyError, GitClone, Error GitProcessError, Process, Log, TaggedLock, Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError, HighlightBuilder, Internet, Embed IO, Resource, Final IO] +type PipelineAppEffects = '[TaggedLock, Embed IO, Resource, Final IO] -type TopPipelineEff = '[PathResolver, EvalFileEff, Error PackageLoaderError, Error DependencyError, GitClone, Error GitProcessError, Process, Log, TaggedLock, Reader EntryPoint, Files, NameIdGen, Builtins, State Artifacts, Error JuvixError, HighlightBuilder, Embed IO, Resource, Final IO] +type PipelineLocalEff = '[PathResolver, EvalFileEff, Error PackageLoaderError, Error DependencyError, GitClone, Error GitProcessError, Process, Log, Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError, HighlightBuilder, Internet] + +-- type PipelineEff r = PipelineLocalEff ++ r +type PipelineEff r = PathResolver ': EvalFileEff ': Error PackageLoaderError ': Error DependencyError ': GitClone ': Error GitProcessError ': Process ': Log ': Reader EntryPoint ': Files ': NameIdGen ': Builtins ': Error JuvixError ': HighlightBuilder ': Internet ': r -------------------------------------------------------------------------------- -- Workflows diff --git a/src/Juvix/Compiler/Pipeline/Run.hs b/src/Juvix/Compiler/Pipeline/Run.hs index 6e020f7167..6ec148418f 100644 --- a/src/Juvix/Compiler/Pipeline/Run.hs +++ b/src/Juvix/Compiler/Pipeline/Run.hs @@ -27,43 +27,24 @@ import Juvix.Data.Effect.Process import Juvix.Data.Effect.TaggedLock import Juvix.Prelude +runPipelineHighlight :: forall r a. (Members '[TaggedLock, Embed IO] r) => EntryPoint -> Sem (PipelineEff r) a -> Sem r HighlightInput +runPipelineHighlight entry = fmap fst . runIOEither entry + -- | It returns `ResolverState` so that we can retrieve the `juvix.yaml` files, -- which we require for `Scope` tests. -runIOEither :: forall a. EntryPoint -> Sem PipelineEff a -> IO (Either JuvixError (ResolverState, a)) -runIOEither = runIOEither' LockModePermissive - -runIOEither' :: forall a. LockMode -> EntryPoint -> Sem PipelineEff a -> IO (Either JuvixError (ResolverState, a)) -runIOEither' lockMode entry = fmap snd . runIOEitherHelper' lockMode entry - -runIOEitherTermination :: forall a. EntryPoint -> Sem (Termination ': PipelineEff) a -> IO (Either JuvixError (ResolverState, a)) -runIOEitherTermination = runIOEitherTermination' LockModePermissive - -runIOEitherTermination' :: forall a. LockMode -> EntryPoint -> Sem (Termination ': PipelineEff) a -> IO (Either JuvixError (ResolverState, a)) -runIOEitherTermination' lockMode entry = fmap snd . runIOEitherHelper' lockMode entry . evalTermination iniTerminationState - -runPipelineHighlight :: forall a. EntryPoint -> Sem PipelineEff a -> IO HighlightInput -runPipelineHighlight entry = fmap fst . runIOEitherHelper entry - -runIOEitherHelper :: forall a. EntryPoint -> Sem PipelineEff a -> IO (HighlightInput, (Either JuvixError (ResolverState, a))) -runIOEitherHelper = runIOEitherHelper' LockModePermissive - -runIOEitherHelper' :: forall a. LockMode -> EntryPoint -> Sem PipelineEff a -> IO (HighlightInput, (Either JuvixError (ResolverState, a))) -runIOEitherHelper' lockMode entry = do +runIOEither :: forall a r. (Members '[TaggedLock, Embed IO] r) => EntryPoint -> Sem (PipelineEff r) a -> Sem r (HighlightInput, (Either JuvixError (ResolverState, a))) +runIOEither entry = do let hasInternet = not (entry ^. entryPointOffline) runPathResolver' | mainIsPackageFile entry = runPackagePathResolver' (entry ^. entryPointResolverRoot) | otherwise = runPathResolverPipe - runFinal - . resourceToIOFinal - . embedToFinal @IO - . evalInternet hasInternet + evalInternet hasInternet . runHighlightBuilder . runJuvixError . evalTopBuiltins . evalTopNameIdGen . runFilesIO . runReader entry - . runTaggedLock lockMode . runLogIO . runProcessIO . mapError (JuvixError @GitProcessError) @@ -78,25 +59,14 @@ mainIsPackageFile entry = case entry ^? entryPointModulePaths . _head of Just p -> p == mkPackagePath (entry ^. entryPointResolverRoot) Nothing -> False -runIOLockMode :: LockMode -> GenericOptions -> EntryPoint -> Sem PipelineEff a -> IO (ResolverState, a) -runIOLockMode lockMode opts entry = runIOEither' lockMode entry >=> mayThrow - where - mayThrow :: Either JuvixError r -> IO r - mayThrow = \case - Left err -> runM . runReader opts $ printErrorAnsiSafe err >> embed exitFailure - Right r -> return r - -runIO :: GenericOptions -> EntryPoint -> Sem PipelineEff a -> IO (ResolverState, a) -runIO opts entry = runIOEither entry >=> mayThrow +runIO :: forall a r. (Members '[TaggedLock, Embed IO] r) => GenericOptions -> EntryPoint -> Sem (PipelineEff r) a -> Sem r (ResolverState, a) +runIO opts entry = runIOEither entry >=> mayThrow . snd where - mayThrow :: Either JuvixError r -> IO r + mayThrow :: (Members '[Embed IO] r') => Either JuvixError x -> Sem r' x mayThrow = \case - Left err -> runM . runReader opts $ printErrorAnsiSafe err >> embed exitFailure + Left err -> runReader opts $ printErrorAnsiSafe err >> embed exitFailure Right r -> return r -runIOExclusive :: EntryPoint -> Sem PipelineEff a -> IO (ResolverState, a) -runIOExclusive = runIOLockMode LockModeExclusive defaultGenericOptions - corePipelineIO' :: EntryPoint -> IO Artifacts corePipelineIO' = corePipelineIO defaultGenericOptions diff --git a/test/BackendGeb/Compilation/Base.hs b/test/BackendGeb/Compilation/Base.hs index fe8116965c..8c98ee1d48 100644 --- a/test/BackendGeb/Compilation/Base.hs +++ b/test/BackendGeb/Compilation/Base.hs @@ -4,7 +4,6 @@ import BackendGeb.FromCore.Base import Base import Juvix.Compiler.Backend (Target (TargetGeb)) import Juvix.Compiler.Core qualified as Core -import Juvix.Data.Effect.TaggedLock gebCompilationAssertion :: Path Abs Dir -> @@ -14,6 +13,6 @@ gebCompilationAssertion :: Assertion gebCompilationAssertion root mainFile expectedFile step = do step "Translate to JuvixCore" - entryPoint <- set entryPointTarget TargetGeb <$> defaultEntryPointIO' LockModeExclusive root mainFile - tab <- (^. Core.coreResultTable) . snd <$> runIOExclusive entryPoint upToCore + entryPoint <- set entryPointTarget TargetGeb <$> testDefaultEntryPointIO root mainFile + tab <- (^. Core.coreResultTable) . snd <$> testRunIO entryPoint upToCore coreToGebTranslationAssertion' tab entryPoint expectedFile step diff --git a/test/BackendGeb/FromCore/Base.hs b/test/BackendGeb/FromCore/Base.hs index d20a9f4433..0c926b9a24 100644 --- a/test/BackendGeb/FromCore/Base.hs +++ b/test/BackendGeb/FromCore/Base.hs @@ -7,7 +7,6 @@ import Juvix.Compiler.Backend (Target (TargetGeb)) import Juvix.Compiler.Backend.Geb qualified as Geb import Juvix.Compiler.Core qualified as Core import Juvix.Compiler.Core.Pretty qualified as Core -import Juvix.Data.Effect.TaggedLock import Juvix.Prelude.Pretty coreToGebTranslationAssertion :: @@ -19,7 +18,7 @@ coreToGebTranslationAssertion :: coreToGebTranslationAssertion root mainFile expectedFile step = do step "Parse Juvix Core file" input <- readFile . toFilePath $ mainFile - entryPoint <- set entryPointTarget TargetGeb <$> defaultEntryPointIO' LockModeExclusive root mainFile + entryPoint <- set entryPointTarget TargetGeb <$> testDefaultEntryPointIO root mainFile case Core.runParserMain mainFile Core.emptyInfoTable input of Left err -> assertFailure . show . pretty $ err Right coreInfoTable -> coreToGebTranslationAssertion' coreInfoTable entryPoint expectedFile step diff --git a/test/BackendMarkdown/Negative.hs b/test/BackendMarkdown/Negative.hs index dc6e3341a0..69124a1464 100644 --- a/test/BackendMarkdown/Negative.hs +++ b/test/BackendMarkdown/Negative.hs @@ -2,7 +2,6 @@ module BackendMarkdown.Negative where import Base import Juvix.Compiler.Backend.Markdown.Error -import Juvix.Data.Effect.TaggedLock import Juvix.Parser.Error type FailMsg = String @@ -22,8 +21,8 @@ testDescr NegTest {..} = { _testName = _name, _testRoot = tRoot, _testAssertion = Single $ do - entryPoint <- defaultEntryPointIO' LockModeExclusive tRoot file' - result <- runIOEither' LockModeExclusive entryPoint upToParsing + entryPoint <- testDefaultEntryPointIO tRoot file' + result <- testTaggedLockedToIO (snd <$> runIOEither entryPoint upToParsing) case mapLeft fromJuvixError result of Left (Just err) -> whenJust (_checkErr err) assertFailure Right _ -> assertFailure "Unexpected success." diff --git a/test/BackendMarkdown/Positive.hs b/test/BackendMarkdown/Positive.hs index f2e07c694d..38de660e23 100644 --- a/test/BackendMarkdown/Positive.hs +++ b/test/BackendMarkdown/Positive.hs @@ -6,7 +6,6 @@ import Juvix.Compiler.Concrete qualified as Concrete import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser import Juvix.Compiler.Pipeline.Setup -import Juvix.Data.Effect.TaggedLock data PosTest = PosTest { _name :: String, @@ -36,13 +35,13 @@ testDescr PosTest {..} = { _testName = _name, _testRoot = _dir, _testAssertion = Steps $ \step -> do - entryPoint <- defaultEntryPointIO' LockModeExclusive _dir _file + entryPoint <- testDefaultEntryPointIO _dir _file step "Parsing" - p :: Parser.ParserResult <- snd <$> runIOExclusive entryPoint upToParsing + p :: Parser.ParserResult <- snd <$> testRunIO entryPoint upToParsing step "Scoping" s :: Scoper.ScoperResult <- snd - <$> runIOExclusive + <$> testRunIO entryPoint ( do void (entrySetup defaultDependenciesConfig) diff --git a/test/Base.hs b/test/Base.hs index 71c788e5cf..576a7fe859 100644 --- a/test/Base.hs +++ b/test/Base.hs @@ -13,8 +13,12 @@ where import Control.Monad.Extra as Monad import Data.Algorithm.Diff import Data.Algorithm.DiffOutput +import Juvix.Compiler.Concrete (HighlightInput) +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver +import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination import Juvix.Compiler.Pipeline.EntryPoint.IO import Juvix.Compiler.Pipeline.Run +import Juvix.Data.Effect.TaggedLock import Juvix.Extra.Paths hiding (rootBuildDir) import Juvix.Prelude hiding (assert) import Juvix.Prelude.Env @@ -74,3 +78,38 @@ assertCmdExists cmd = assertBool ("Command: " <> toFilePath cmd <> " is not present on $PATH") . isJust =<< findExecutable cmd + +testTaggedLockedToIO :: Sem PipelineAppEffects a -> IO a +testTaggedLockedToIO = + runFinal + . resourceToIOFinal + . embedToFinal @IO + . runTaggedLock LockModeExclusive + +testRunIO :: + forall a. + EntryPoint -> + Sem (PipelineEff PipelineAppEffects) a -> + IO (ResolverState, a) +testRunIO e = testTaggedLockedToIO . runIO defaultGenericOptions e + +testDefaultEntryPointIO :: Path Abs Dir -> Path Abs File -> IO EntryPoint +testDefaultEntryPointIO cwd mainFile = testTaggedLockedToIO (defaultEntryPointIO cwd mainFile) + +testDefaultEntryPointNoFileIO :: Path Abs Dir -> IO EntryPoint +testDefaultEntryPointNoFileIO cwd = testTaggedLockedToIO (defaultEntryPointNoFileIO cwd) + +testRunIOEither :: + EntryPoint -> + Sem (PipelineEff PipelineAppEffects) a -> + IO (HighlightInput, (Either JuvixError (ResolverState, a))) +testRunIOEither entry = testTaggedLockedToIO . runIOEither entry + +testRunIOEitherTermination :: + EntryPoint -> + Sem (Termination ': PipelineEff PipelineAppEffects) a -> + IO (Either JuvixError (ResolverState, a)) +testRunIOEitherTermination entry = + fmap snd + . testRunIOEither entry + . evalTermination iniTerminationState diff --git a/test/Compilation/Base.hs b/test/Compilation/Base.hs index 3e1ebdf133..1a02f1129a 100644 --- a/test/Compilation/Base.hs +++ b/test/Compilation/Base.hs @@ -4,7 +4,6 @@ import Base import Core.Compile.Base import Core.Eval.Base import Juvix.Compiler.Core qualified as Core -import Juvix.Data.Effect.TaggedLock import Juvix.Data.PPOutput data CompileAssertionMode @@ -34,8 +33,8 @@ compileAssertionEntry :: Assertion compileAssertionEntry adjustEntry root' optLevel mode mainFile expectedFile step = do step "Translate to JuvixCore" - entryPoint <- adjustEntry <$> defaultEntryPointIO' LockModeExclusive root' mainFile - tab <- (^. Core.coreResultTable) . snd <$> runIOExclusive entryPoint upToCore + entryPoint <- adjustEntry <$> testDefaultEntryPointIO root' mainFile + tab <- (^. Core.coreResultTable) . snd <$> testRunIO entryPoint upToCore case run $ runReader Core.defaultCoreOptions $ runError $ Core.toEval' tab of Left err -> assertFailure (show (pretty (fromJuvixError @GenericError err))) Right tab' -> do @@ -53,8 +52,8 @@ compileErrorAssertion :: Assertion compileErrorAssertion root' mainFile step = do step "Translate to JuvixCore" - entryPoint <- defaultEntryPointIO' LockModeExclusive root' mainFile - tab <- (^. Core.coreResultTable) . snd <$> runIOExclusive entryPoint upToCore + entryPoint <- testDefaultEntryPointIO root' mainFile + tab <- (^. Core.coreResultTable) . snd <$> testRunIO entryPoint upToCore case run $ runReader Core.defaultCoreOptions $ runError @JuvixError $ Core.toStripped' tab of Left _ -> assertBool "" True Right _ -> assertFailure "no error" diff --git a/test/Format.hs b/test/Format.hs index b4821bd482..0c5c011384 100644 --- a/test/Format.hs +++ b/test/Format.hs @@ -5,7 +5,6 @@ import Juvix.Compiler.Concrete qualified as Concrete import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser import Juvix.Compiler.Pipeline.Setup -import Juvix.Data.Effect.TaggedLock import Juvix.Formatter data PosTest = PosTest @@ -34,19 +33,19 @@ testDescr PosTest {..} = { _testName = _name, _testRoot = _dir, _testAssertion = Steps $ \step -> do - entryPoint <- defaultEntryPointIO' LockModeExclusive _dir _file + entryPoint <- testDefaultEntryPointIO _dir _file let maybeFile = entryPoint ^? entryPointModulePaths . _head f <- fromMaybeM (assertFailure "Not a module") (return maybeFile) original :: Text <- readFile (toFilePath f) step "Parsing" - p :: Parser.ParserResult <- snd <$> runIOExclusive entryPoint upToParsing + p :: Parser.ParserResult <- snd <$> testRunIO entryPoint upToParsing step "Scoping" s :: Scoper.ScoperResult <- snd - <$> runIOExclusive + <$> testRunIO entryPoint ( do void (entrySetup defaultDependenciesConfig) diff --git a/test/Formatter/Positive.hs b/test/Formatter/Positive.hs index be6ac18648..533036b39d 100644 --- a/test/Formatter/Positive.hs +++ b/test/Formatter/Positive.hs @@ -1,7 +1,6 @@ module Formatter.Positive where import Base -import Juvix.Data.Effect.TaggedLock import Juvix.Formatter import Scope.Positive qualified import Scope.Positive qualified as Scope @@ -9,11 +8,11 @@ import Scope.Positive qualified as Scope runScopeEffIO :: (Member (Embed IO) r) => Path Abs Dir -> Sem (ScopeEff ': r) a -> Sem r a runScopeEffIO root = interpret $ \case ScopeFile p -> do - entry <- embed (defaultEntryPointIO' LockModeExclusive root p) - embed (snd <$> runIOExclusive entry upToScoping) + entry <- embed (testDefaultEntryPointIO root p) + embed (snd <$> testRunIO entry upToScoping) ScopeStdin -> do - entry <- embed (defaultEntryPointNoFileIO' LockModeExclusive root) - embed (snd <$> runIOExclusive entry upToScoping) + entry <- embed (testDefaultEntryPointNoFileIO root) + embed (snd <$> testRunIO entry upToScoping) makeFormatTest' :: Scope.PosTest -> TestDescr makeFormatTest' Scope.PosTest {..} = diff --git a/test/Internal/Eval/Base.hs b/test/Internal/Eval/Base.hs index 92baf8c2be..af0253b567 100644 --- a/test/Internal/Eval/Base.hs +++ b/test/Internal/Eval/Base.hs @@ -11,13 +11,12 @@ import Juvix.Compiler.Core.Info.NoDisplayInfo import Juvix.Compiler.Core.Pretty import Juvix.Compiler.Core.Transformation (etaExpansionApps) import Juvix.Compiler.Core.Translation.FromInternal.Data as Core -import Juvix.Data.Effect.TaggedLock internalCoreAssertion :: Path Abs Dir -> Path Abs File -> Path Abs File -> (String -> IO ()) -> Assertion internalCoreAssertion root' mainFile expectedFile step = do step "Translate to Core" - entryPoint <- defaultEntryPointIO' LockModeExclusive root' mainFile - tab0 <- (^. Core.coreResultTable) . snd <$> runIOExclusive entryPoint upToCore + entryPoint <- testDefaultEntryPointIO root' mainFile + tab0 <- (^. Core.coreResultTable) . snd <$> testRunIO entryPoint upToCore let tab = etaExpansionApps tab0 case (tab ^. infoMain) >>= ((tab ^. identContext) HashMap.!?) of Just node -> do diff --git a/test/Parsing/Negative.hs b/test/Parsing/Negative.hs index cc4b4905eb..59fa45c285 100644 --- a/test/Parsing/Negative.hs +++ b/test/Parsing/Negative.hs @@ -2,7 +2,6 @@ module Parsing.Negative where import Base import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error -import Juvix.Data.Effect.TaggedLock import Juvix.Parser.Error root :: Path Abs Dir @@ -24,8 +23,8 @@ testDescr NegTest {..} = { _testName = _name, _testRoot = tRoot, _testAssertion = Single $ do - entryPoint <- defaultEntryPointIO' LockModeExclusive tRoot _file - res <- runIOEither' LockModeExclusive entryPoint upToParsing + entryPoint <- testDefaultEntryPointIO tRoot _file + res <- snd <$> testRunIOEither entryPoint upToParsing case mapLeft fromJuvixError res of Left (Just parErr) -> whenJust (_checkErr parErr) assertFailure Left Nothing -> assertFailure "An error ocurred but it was not in the parser." diff --git a/test/Reachability/Positive.hs b/test/Reachability/Positive.hs index 5eba6a3478..4f8be9568a 100644 --- a/test/Reachability/Positive.hs +++ b/test/Reachability/Positive.hs @@ -4,7 +4,6 @@ import Base import Data.HashSet qualified as HashSet import Juvix.Compiler.Internal.Language qualified as Internal import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context qualified as Internal -import Juvix.Data.Effect.TaggedLock data PosTest = PosTest { _name :: String, @@ -30,10 +29,10 @@ testDescr PosTest {..} = let noStdlib = _stdlibMode == StdlibExclude entryPoint <- set entryPointNoStdlib noStdlib - <$> defaultEntryPointIO' LockModeExclusive tRoot file' + <$> testDefaultEntryPointIO tRoot file' step "Pipeline up to reachability" - p :: Internal.InternalTypedResult <- snd <$> runIOExclusive entryPoint upToInternalReachability + p :: Internal.InternalTypedResult <- snd <$> testRunIO entryPoint upToInternalReachability step "Check reachability results" let names = concatMap getNames (p ^. Internal.resultModules) diff --git a/test/Scope/Negative.hs b/test/Scope/Negative.hs index b18a9f1e62..82b17f3e2b 100644 --- a/test/Scope/Negative.hs +++ b/test/Scope/Negative.hs @@ -2,7 +2,6 @@ module Scope.Negative (allTests) where import Base import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error -import Juvix.Data.Effect.TaggedLock type FailMsg = String @@ -24,8 +23,8 @@ testDescr NegTest {..} = { _testName = _name, _testRoot = tRoot, _testAssertion = Single $ do - entryPoint <- defaultEntryPointIO' LockModeExclusive tRoot file' - res <- runIOEitherTermination' LockModeExclusive entryPoint upToInternal + entryPoint <- testDefaultEntryPointIO tRoot file' + res <- testRunIOEitherTermination entryPoint upToInternal case mapLeft fromJuvixError res of Left (Just err) -> whenJust (_checkErr err) assertFailure Left Nothing -> assertFailure "An error ocurred but it was not in the scoper." diff --git a/test/Scope/Positive.hs b/test/Scope/Positive.hs index e237c70b13..fb13e16cdd 100644 --- a/test/Scope/Positive.hs +++ b/test/Scope/Positive.hs @@ -54,8 +54,8 @@ testDescr PosTest {..} = helper renderCodeNew { _testName = _name, _testRoot = tRoot, _testAssertion = Steps $ \step -> do - entryPoint <- defaultEntryPointIO' LockModeExclusive tRoot file' - let runHelper :: HashMap (Path Abs File) Text -> Sem PipelineEff a -> IO (ResolverState, a) + entryPoint <- testDefaultEntryPointIO tRoot file' + let runHelper :: HashMap (Path Abs File) Text -> Sem (PipelineEff PipelineAppEffects) a -> IO (ResolverState, a) runHelper files = do let runPathResolver' = case _pathResolverMode of FullPathResolver -> runPathResolverPipe @@ -63,6 +63,7 @@ testDescr PosTest {..} = helper renderCodeNew runFinal . resourceToIOFinal . embedToFinal @IO + . runTaggedLock LockModeExclusive . evalInternetOffline . ignoreHighlightBuilder . runErrorIO' @JuvixError @@ -70,7 +71,6 @@ testDescr PosTest {..} = helper renderCodeNew . evalTopNameIdGen . runFilesPure files tRoot . runReader entryPoint - . runTaggedLock LockModeExclusive . ignoreLog . runProcessIO . mapError (JuvixError @GitProcessError) @@ -79,15 +79,15 @@ testDescr PosTest {..} = helper renderCodeNew . mapError (JuvixError @PackageLoaderError) . runEvalFileEffIO . runPathResolver' - evalHelper :: HashMap (Path Abs File) Text -> Sem PipelineEff a -> IO a + evalHelper :: HashMap (Path Abs File) Text -> Sem (PipelineEff PipelineAppEffects) a -> IO a evalHelper files = fmap snd . runHelper files step "Parsing" - p :: Parser.ParserResult <- snd <$> runIOExclusive entryPoint upToParsing + p :: Parser.ParserResult <- snd <$> testRunIO entryPoint upToParsing step "Scoping" (resolverState :: ResolverState, s :: Scoper.ScoperResult) <- - runIOExclusive + testRunIO entryPoint ( do void (entrySetup defaultDependenciesConfig) diff --git a/test/Termination/Negative.hs b/test/Termination/Negative.hs index dce990ff0b..ca429abfae 100644 --- a/test/Termination/Negative.hs +++ b/test/Termination/Negative.hs @@ -2,7 +2,6 @@ module Termination.Negative (module Termination.Negative) where import Base import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination -import Juvix.Data.Effect.TaggedLock type FailMsg = String @@ -21,8 +20,8 @@ testDescr NegTest {..} = { _testName = _name, _testRoot = tRoot, _testAssertion = Single $ do - entryPoint <- set entryPointNoStdlib True <$> defaultEntryPointIO' LockModeExclusive tRoot file' - result <- runIOEither' LockModeExclusive entryPoint upToInternalTyped + entryPoint <- set entryPointNoStdlib True <$> testDefaultEntryPointIO tRoot file' + result <- snd <$> testRunIOEither entryPoint upToInternalTyped case mapLeft fromJuvixError result of Left (Just lexError) -> whenJust (_checkErr lexError) assertFailure Left Nothing -> assertFailure "The termination checker did not find an error." diff --git a/test/Termination/Positive.hs b/test/Termination/Positive.hs index c9cc023f2a..f1fc4ca5ce 100644 --- a/test/Termination/Positive.hs +++ b/test/Termination/Positive.hs @@ -1,7 +1,6 @@ module Termination.Positive where import Base -import Juvix.Data.Effect.TaggedLock (LockMode (LockModeExclusive)) import Termination.Negative qualified as N data PosTest = PosTest @@ -21,8 +20,8 @@ testDescr PosTest {..} = { _testName = _name, _testRoot = tRoot, _testAssertion = Single $ do - entryPoint <- set entryPointNoStdlib True <$> defaultEntryPointIO' LockModeExclusive tRoot file' - (void . runIOExclusive entryPoint) upToInternalTyped + entryPoint <- set entryPointNoStdlib True <$> testDefaultEntryPointIO tRoot file' + (void . testRunIO entryPoint) upToInternalTyped } -------------------------------------------------------------------------------- @@ -43,8 +42,8 @@ testDescrFlag N.NegTest {..} = entryPoint <- set entryPointNoTermination True . set entryPointNoStdlib True - <$> defaultEntryPointIO' LockModeExclusive tRoot file' - (void . runIOExclusive entryPoint) upToInternalTyped + <$> testDefaultEntryPointIO tRoot file' + (void . testRunIO entryPoint) upToInternalTyped } tests :: [PosTest] diff --git a/test/Typecheck/Negative.hs b/test/Typecheck/Negative.hs index d8758b2aa9..a793e561b3 100644 --- a/test/Typecheck/Negative.hs +++ b/test/Typecheck/Negative.hs @@ -3,7 +3,6 @@ module Typecheck.Negative where import Base import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Positivity.Error import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Error -import Juvix.Data.Effect.TaggedLock type FailMsg = String @@ -24,8 +23,8 @@ testDescr NegTest {..} = { _testName = _name, _testRoot = tRoot, _testAssertion = Single $ do - entryPoint <- defaultEntryPointIO' LockModeExclusive tRoot file' - result <- runIOEither' LockModeExclusive entryPoint upToInternalTyped + entryPoint <- testDefaultEntryPointIO tRoot file' + result <- snd <$> testRunIOEither entryPoint upToInternalTyped case mapLeft fromJuvixError result of Left (Just tyError) -> whenJust (_checkErr tyError) assertFailure Left Nothing -> assertFailure "An error ocurred but it was not in the type checker." diff --git a/test/Typecheck/NegativeNew.hs b/test/Typecheck/NegativeNew.hs index f2be769999..be92bd7a4d 100644 --- a/test/Typecheck/NegativeNew.hs +++ b/test/Typecheck/NegativeNew.hs @@ -4,7 +4,6 @@ import Base import Data.HashSet qualified as HashSet import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Positivity.Error import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Error -import Juvix.Data.Effect.TaggedLock import Typecheck.Negative qualified as Old type FailMsg = String @@ -30,8 +29,8 @@ testDescr Old.NegTest {..} = { _testName = _name, _testRoot = tRoot, _testAssertion = Single $ do - entryPoint <- defaultEntryPointIO' LockModeExclusive tRoot file' - result <- runIOEither' LockModeExclusive entryPoint upToCore + entryPoint <- testDefaultEntryPointIO tRoot file' + result <- snd <$> testRunIOEither entryPoint upToCore case mapLeft fromJuvixError result of Left (Just tyError) -> whenJust (_checkErr tyError) assertFailure Left Nothing -> assertFailure "An error ocurred but it was not in the type checker." diff --git a/test/Typecheck/Positive.hs b/test/Typecheck/Positive.hs index ad1879b39a..e030efbf3c 100644 --- a/test/Typecheck/Positive.hs +++ b/test/Typecheck/Positive.hs @@ -2,7 +2,6 @@ module Typecheck.Positive where import Base import Compilation.Positive qualified as Compilation -import Juvix.Data.Effect.TaggedLock import Typecheck.Negative qualified as N data PosTest = PosTest @@ -33,8 +32,8 @@ testDescr PosTest {..} = { _testName = _name, _testRoot = _dir, _testAssertion = Single $ do - entryPoint <- defaultEntryPointIO' LockModeExclusive _dir _file - (void . runIOExclusive entryPoint) upToInternalTyped + entryPoint <- testDefaultEntryPointIO _dir _file + (void . testRunIO entryPoint) upToInternalTyped } rootNegTests :: Path Abs Dir @@ -51,8 +50,8 @@ testNoPositivityFlag N.NegTest {..} = _testAssertion = Single $ do entryPoint <- set entryPointNoPositivity True - <$> defaultEntryPointIO' LockModeExclusive tRoot file' - (void . runIOExclusive entryPoint) upToInternalTyped + <$> testDefaultEntryPointIO tRoot file' + (void . testRunIO entryPoint) upToInternalTyped } negPositivityTests :: [N.NegTest] diff --git a/test/VampIR/Compilation/Base.hs b/test/VampIR/Compilation/Base.hs index 17688a007f..f45d6aa5fa 100644 --- a/test/VampIR/Compilation/Base.hs +++ b/test/VampIR/Compilation/Base.hs @@ -4,14 +4,13 @@ import Base import Core.VampIR.Base (coreVampIRAssertion') import Juvix.Compiler.Core import Juvix.Compiler.Core.Data.TransformationId -import Juvix.Data.Effect.TaggedLock import VampIR.Core.Base (VampirBackend (..), vampirAssertion') vampirCompileAssertion :: Path Abs Dir -> Path Abs File -> Path Abs File -> (String -> IO ()) -> Assertion vampirCompileAssertion root' mainFile dataFile step = do step "Translate to JuvixCore" - entryPoint <- defaultEntryPointIO' LockModeExclusive root' mainFile - tab <- (^. coreResultTable) . snd <$> runIOExclusive entryPoint upToCore + entryPoint <- testDefaultEntryPointIO root' mainFile + tab <- (^. coreResultTable) . snd <$> testRunIO entryPoint upToCore coreVampIRAssertion' tab toVampIRTransformations mainFile dataFile step vampirAssertion' VampirHalo2 tab dataFile step @@ -22,8 +21,8 @@ vampirCompileErrorAssertion :: Assertion vampirCompileErrorAssertion root' mainFile step = do step "Translate to JuvixCore" - entryPoint <- defaultEntryPointIO' LockModeExclusive root' mainFile - r <- runIOEither entryPoint upToCore + entryPoint <- testDefaultEntryPointIO root' mainFile + r <- snd <$> testRunIOEither entryPoint upToCore case r of Left _ -> return () Right res -> From ffcc8798f7898ff9a5f279169af44b132a97fa35 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Tue, 5 Dec 2023 20:29:57 +0100 Subject: [PATCH 4/7] use ++ --- src/Juvix/Compiler/Pipeline.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Juvix/Compiler/Pipeline.hs b/src/Juvix/Compiler/Pipeline.hs index 3f959a424f..4f84336d74 100644 --- a/src/Juvix/Compiler/Pipeline.hs +++ b/src/Juvix/Compiler/Pipeline.hs @@ -45,8 +45,7 @@ type PipelineAppEffects = '[TaggedLock, Embed IO, Resource, Final IO] type PipelineLocalEff = '[PathResolver, EvalFileEff, Error PackageLoaderError, Error DependencyError, GitClone, Error GitProcessError, Process, Log, Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError, HighlightBuilder, Internet] --- type PipelineEff r = PipelineLocalEff ++ r -type PipelineEff r = PathResolver ': EvalFileEff ': Error PackageLoaderError ': Error DependencyError ': GitClone ': Error GitProcessError ': Process ': Log ': Reader EntryPoint ': Files ': NameIdGen ': Builtins ': Error JuvixError ': HighlightBuilder ': Internet ': r +type PipelineEff r = PipelineLocalEff ++ r -------------------------------------------------------------------------------- -- Workflows From 1386286147232e4d1f687c5e6dd7d36e90dfd9d1 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Wed, 6 Dec 2023 10:04:59 +0100 Subject: [PATCH 5/7] add Package.juvix to Geb tests --- tests/Geb/positive/Package.juvix | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 tests/Geb/positive/Package.juvix diff --git a/tests/Geb/positive/Package.juvix b/tests/Geb/positive/Package.juvix new file mode 100644 index 0000000000..0a97a86198 --- /dev/null +++ b/tests/Geb/positive/Package.juvix @@ -0,0 +1,5 @@ +module Package; + +import PackageDescription.V2 open; + +package : Package := defaultPackage {name := "positive"}; From 5b9f5141cb5e89733f6453aaa4f61bd174ab83c7 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Wed, 6 Dec 2023 10:27:37 +0100 Subject: [PATCH 6/7] ensure global package when finding the root --- app/Commands/Extra/Package.hs | 3 --- src/Juvix/Compiler/Pipeline/Package.hs | 12 +++++++++--- .../Compiler/Pipeline/Package/Loader/Versions.hs | 3 +++ src/Juvix/Compiler/Pipeline/Root.hs | 4 +++- 4 files changed, 15 insertions(+), 7 deletions(-) diff --git a/app/Commands/Extra/Package.hs b/app/Commands/Extra/Package.hs index b74a756a80..a6d5ca4556 100644 --- a/app/Commands/Extra/Package.hs +++ b/app/Commands/Extra/Package.hs @@ -6,9 +6,6 @@ import Juvix.Compiler.Pipeline.Package.Loader import Juvix.Extra.Paths import Juvix.Prelude -currentPackageVersion :: PackageVersion -currentPackageVersion = PackageVersion2 - renderPackage :: Package -> Text renderPackage = renderPackageVersion currentPackageVersion diff --git a/src/Juvix/Compiler/Pipeline/Package.hs b/src/Juvix/Compiler/Pipeline/Package.hs index 0af265269f..2fef5e53d1 100644 --- a/src/Juvix/Compiler/Pipeline/Package.hs +++ b/src/Juvix/Compiler/Pipeline/Package.hs @@ -7,6 +7,7 @@ module Juvix.Compiler.Pipeline.Package readGlobalPackage, loadPackageFileIO, packageBasePackage, + ensureGlobalPackage, ) where @@ -155,17 +156,22 @@ readGlobalPackageIO = . runEvalFileEffIO $ readGlobalPackage -readGlobalPackage :: (Members '[TaggedLock, Error JuvixError, EvalFileEff, Files] r) => Sem r Package -readGlobalPackage = do +ensureGlobalPackage :: (Members '[TaggedLock, Files] r) => Sem r (Path Abs File) +ensureGlobalPackage = do packagePath <- globalPackageJuvix withTaggedLockDir (parent packagePath) (unlessM (fileExists' packagePath) writeGlobalPackage) + return packagePath + +readGlobalPackage :: (Members '[TaggedLock, Error JuvixError, EvalFileEff, Files] r) => Sem r Package +readGlobalPackage = do + packagePath <- ensureGlobalPackage readPackage (parent packagePath) DefaultBuildDir writeGlobalPackage :: (Members '[Files] r) => Sem r () writeGlobalPackage = do packagePath <- globalPackageJuvix ensureDir' (parent packagePath) - writeFile' packagePath (renderPackageVersion PackageVersion1 (globalPackage packagePath)) + writeFile' packagePath (renderPackageVersion currentPackageVersion (globalPackage packagePath)) packageBasePackage :: Package packageBasePackage = diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader/Versions.hs b/src/Juvix/Compiler/Pipeline/Package/Loader/Versions.hs index f574d7e203..594f6b16b2 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Loader/Versions.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Loader/Versions.hs @@ -12,6 +12,9 @@ import Juvix.Compiler.Pipeline.Package.Loader.Error import Juvix.Extra.Paths import Juvix.Prelude +currentPackageVersion :: PackageVersion +currentPackageVersion = PackageVersion2 + data PackageVersion = PackageVersion1 | PackageVersion2 diff --git a/src/Juvix/Compiler/Pipeline/Root.hs b/src/Juvix/Compiler/Pipeline/Root.hs index 28a618ddcb..b6f4d60d83 100644 --- a/src/Juvix/Compiler/Pipeline/Root.hs +++ b/src/Juvix/Compiler/Pipeline/Root.hs @@ -8,18 +8,20 @@ import Control.Exception (SomeException) import Control.Exception qualified as IO import Juvix.Compiler.Pipeline.Package import Juvix.Compiler.Pipeline.Root.Base +import Juvix.Data.Effect.TaggedLock import Juvix.Extra.Paths qualified as Paths import Juvix.Prelude findRootAndChangeDir :: forall r. - (Members '[Embed IO, Final IO] r) => + (Members '[TaggedLock, Embed IO, Final IO] r) => Maybe (Path Abs Dir) -> Maybe (Path Abs Dir) -> Path Abs Dir -> Sem r Root findRootAndChangeDir minputFileDir mbuildDir _rootInvokeDir = do r <- runError (fromExceptionSem @SomeException go) + runFilesIO ensureGlobalPackage case r of Left (err :: IO.SomeException) -> liftIO $ do putStrLn "Something went wrong when looking for the root of the project" From 497e024f60e80c2075cc110bc42ca9ead0dc290a Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Wed, 6 Dec 2023 13:57:51 +0100 Subject: [PATCH 7/7] fix smoke --- app/App.hs | 1 - tests/smoke/Commands/typecheck.smoke.yaml | 22 ++++++++++++++++++++++ 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/app/App.hs b/app/App.hs index fbc4cb385c..d28b7a14af 100644 --- a/app/App.hs +++ b/app/App.hs @@ -99,7 +99,6 @@ reAppIO args@RunAppIOArgs {..} = getMainFile' :: (Members '[SCache Package, Embed IO] r') => Maybe (AppPath File) -> Sem r' (Path Abs File) getMainFile' = \case Just p -> embed (prepathToAbsFile invDir (p ^. pathPath)) - -- Nothing -> case pkg ^. packageMain of Nothing -> do pkg <- getPkg case pkg ^. packageMain of diff --git a/tests/smoke/Commands/typecheck.smoke.yaml b/tests/smoke/Commands/typecheck.smoke.yaml index ce7e5b565d..6ebc9321a8 100644 --- a/tests/smoke/Commands/typecheck.smoke.yaml +++ b/tests/smoke/Commands/typecheck.smoke.yaml @@ -55,6 +55,26 @@ tests: equals: "Well done! It type checks\n" exit-status: 0 + - name: typecheck-global-package + command: + shell: + - bash + script: | + base=$PWD + temp=$(mktemp -d) + trap 'rm -rf -- "$temp"' EXIT + configDir=$temp/config + projDir=$temp/projDir + mkdir $configDir + export XDG_CONFIG_HOME="$configDir" + mkdir $projDir + cd $projDir + echo 'module foo;' > foo.juvix + juvix typecheck foo.juvix + stdout: + equals: "Well done! It type checks\n" + exit-status: 0 + - name: typecheck-package-description command: shell: @@ -69,7 +89,9 @@ tests: export XDG_CONFIG_HOME="$configDir" mkdir $projDir cd $projDir + echo 'module foo;' > foo.juvix # side-effect: initializes the global project / the package package + juvix typecheck foo.juvix > /dev/null globalPackageDir=$(juvix dev root) packagePackageDir="$(dirname $globalPackageDir)"/package juvix typecheck "$packagePackageDir/PackageDescription/V2.juvix"