diff --git a/app/App.hs b/app/App.hs index 4d03b7cf1..7c64209b5 100644 --- a/app/App.hs +++ b/app/App.hs @@ -13,18 +13,19 @@ data App m a where ExitMsg :: ExitCode -> Text -> App m a ExitJuvixError :: JuvixError -> App m a PrintJuvixError :: JuvixError -> App m () - AskRoot :: App m FilePath + AskInvokeDir :: App m (Path Abs Dir) + AskPkgDir :: App m (Path Abs Dir) AskPackage :: App m Package AskGlobalOptions :: App m GlobalOptions RenderStdOut :: (HasAnsiBackend a, HasTextBackend a) => a -> App m () - RunPipelineEither :: Path -> Sem PipelineEff a -> App m (Either JuvixError (BuiltinsState, a)) + RunPipelineEither :: AppPath File -> Sem PipelineEff a -> App m (Either JuvixError (Artifacts, a)) Say :: Text -> App m () - Raw :: ByteString -> App m () + SayRaw :: ByteString -> App m () makeSem ''App -runAppIO :: forall r a. Member (Embed IO) r => GlobalOptions -> FilePath -> Package -> Sem (App ': r) a -> Sem r a -runAppIO g root pkg = interpret $ \case +runAppIO :: forall r a. Member (Embed IO) r => GlobalOptions -> Path Abs Dir -> Path Abs Dir -> Package -> Sem (App ': r) a -> Sem r a +runAppIO g invokeDir pkgDir pkg = interpret $ \case RenderStdOut t | g ^. globalOnlyErrors -> return () | otherwise -> embed $ do @@ -32,9 +33,10 @@ runAppIO g root pkg = interpret $ \case renderIO (not (g ^. globalNoColors) && sup) t AskGlobalOptions -> return g AskPackage -> return pkg - AskRoot -> return root + AskInvokeDir -> return invokeDir + AskPkgDir -> return pkgDir RunPipelineEither input p -> do - entry <- embed (getEntryPoint' g root pkg input) + entry <- embed (getEntryPoint' invokeDir g pkgDir pkg input) embed (runIOEither iniState entry p) Say t | g ^. globalOnlyErrors -> return () @@ -45,13 +47,13 @@ runAppIO g root pkg = interpret $ \case printErr e embed exitFailure ExitMsg exitCode t -> embed (putStrLn t >> exitWith exitCode) - Raw b -> embed (ByteString.putStr b) + SayRaw b -> embed (ByteString.putStr b) where printErr e = embed $ hPutStrLn stderr $ run $ runReader (project' @GenericOptions g) $ Error.render (not (g ^. globalNoColors)) (g ^. globalOnlyErrors) e -getEntryPoint' :: GlobalOptions -> FilePath -> Package -> Path -> IO EntryPoint -getEntryPoint' opts root pkg inputFile = do +getEntryPoint' :: Path Abs Dir -> GlobalOptions -> Path Abs Dir -> Package -> AppPath File -> IO EntryPoint +getEntryPoint' invokeDir opts root pkg inputFile = do estdin <- if | opts ^. globalStdin -> Just <$> getContents @@ -59,27 +61,33 @@ getEntryPoint' opts root pkg inputFile = do return EntryPoint { _entryPointRoot = root, + _entryPointResolverRoot = root, _entryPointNoTermination = opts ^. globalNoTermination, _entryPointNoPositivity = opts ^. globalNoPositivity, _entryPointNoStdlib = opts ^. globalNoStdlib, - _entryPointStdlibPath = opts ^. globalStdlibPath, _entryPointPackage = pkg, - _entryPointModulePaths = pure (inputFile ^. pathPath), + _entryPointModulePaths = pure (someBaseToAbs invokeDir (inputFile ^. pathPath)), _entryPointGenericOptions = project opts, _entryPointStdin = estdin } +someBaseToAbs' :: Members '[App] r => SomeBase a -> Sem r (Path Abs a) +someBaseToAbs' f = do + r <- askInvokeDir + return (someBaseToAbs r f) + askGenericOptions :: Members '[App] r => Sem r GenericOptions askGenericOptions = project <$> askGlobalOptions -getEntryPoint :: Members '[Embed IO, App] r => Path -> Sem r EntryPoint +getEntryPoint :: Members '[Embed IO, App] r => AppPath File -> Sem r EntryPoint getEntryPoint inputFile = do opts <- askGlobalOptions - root <- askRoot + root <- askPkgDir pkg <- askPackage - embed (getEntryPoint' opts root pkg inputFile) + invokeDir <- askInvokeDir + embed (getEntryPoint' invokeDir opts root pkg inputFile) -runPipeline :: Member App r => Path -> Sem PipelineEff a -> Sem r a +runPipeline :: Member App r => AppPath File -> Sem PipelineEff a -> Sem r a runPipeline input p = do r <- runPipelineEither input p case r of diff --git a/app/Commands/Compile.hs b/app/Commands/Compile.hs index 994a24b09..16e69db6c 100644 --- a/app/Commands/Compile.hs +++ b/app/Commands/Compile.hs @@ -12,54 +12,37 @@ import System.Process qualified as P runCommand :: Members '[Embed IO, App] r => CompileOptions -> Sem r () runCommand opts@CompileOptions {..} = do - root <- askRoot miniC <- (^. MiniC.resultCCode) <$> runPipeline _compileInputFile upToMiniC - let inputFile = _compileInputFile ^. pathPath - result <- embed (runCompile root inputFile opts miniC) + inputFile <- someBaseToAbs' (_compileInputFile ^. pathPath) + result <- runCompile inputFile opts miniC case result of Left err -> printFailureExit err _ -> return () -inputCFile :: FilePath -> FilePath -> FilePath -inputCFile projRoot inputFileCompile = - projRoot juvixBuildDir outputMiniCFile +inputCFile :: Members '[App] r => Path Abs File -> Sem r (Path Abs File) +inputCFile inputFileCompile = do + root <- askPkgDir + return (root juvixBuildDir outputMiniCFile) where - outputMiniCFile :: FilePath - outputMiniCFile = takeBaseName inputFileCompile <> ".c" + outputMiniCFile :: Path Rel File + outputMiniCFile = replaceExtension' ".c" (filename inputFileCompile) -runCompile :: FilePath -> FilePath -> CompileOptions -> Text -> IO (Either Text ()) -runCompile projRoot inputFileCompile o minic = do - createDirectoryIfMissing True (projRoot juvixBuildDir) - TIO.writeFile (inputCFile projRoot inputFileCompile) minic - prepareRuntime projRoot o +runCompile :: Members '[Embed IO, App] r => Path Abs File -> CompileOptions -> Text -> Sem r (Either Text ()) +runCompile inputFileCompile o minic = do + root <- askPkgDir + ensureDir (root juvixBuildDir) + f <- inputCFile inputFileCompile + embed (TIO.writeFile (toFilePath f) minic) + prepareRuntime o case o ^. compileTarget of - TargetWasm -> runM (runError (clangCompile projRoot inputFileCompile o)) + TargetWasm -> runError (clangCompile inputFileCompile o) TargetC -> return (Right ()) - TargetNative -> runM (runError (clangNativeCompile projRoot inputFileCompile o)) + TargetNative -> runError (clangNativeCompile inputFileCompile o) -prepareRuntime :: FilePath -> CompileOptions -> IO () -prepareRuntime projRoot o = do - mapM_ writeRuntime runtimeProjectDir +prepareRuntime :: forall r. Members '[Embed IO, App] r => CompileOptions -> Sem r () +prepareRuntime o = mapM_ writeRuntime runtimeProjectDir where - wasiStandaloneRuntimeDir :: [(FilePath, BS.ByteString)] - wasiStandaloneRuntimeDir = $(FE.makeRelativeToProject "c-runtime/wasi-standalone" >>= FE.embedDir) - - standaloneRuntimeDir :: [(FilePath, BS.ByteString)] - standaloneRuntimeDir = $(FE.makeRelativeToProject "c-runtime/standalone" >>= FE.embedDir) - - wasiLibCRuntimeDir :: [(FilePath, BS.ByteString)] - wasiLibCRuntimeDir = $(FE.makeRelativeToProject "c-runtime/wasi-libc" >>= FE.embedDir) - - builtinCRuntimeDir :: [(FilePath, BS.ByteString)] - builtinCRuntimeDir = $(FE.makeRelativeToProject "c-runtime/builtins" >>= FE.embedDir) - - wallocDir :: [(FilePath, BS.ByteString)] - wallocDir = $(FE.makeRelativeToProject "c-runtime/walloc" >>= FE.embedDir) - - libcRuntime :: [(FilePath, BS.ByteString)] - libcRuntime = wasiLibCRuntimeDir <> builtinCRuntimeDir - - runtimeProjectDir :: [(FilePath, BS.ByteString)] + runtimeProjectDir :: [(Path Rel File, BS.ByteString)] runtimeProjectDir = case o ^. compileTarget of TargetNative -> libcRuntime _ -> case o ^. compileRuntime of @@ -67,99 +50,135 @@ prepareRuntime projRoot o = do RuntimeWasiLibC -> libcRuntime RuntimeStandalone -> standaloneRuntimeDir <> builtinCRuntimeDir <> wallocDir - writeRuntime :: (FilePath, BS.ByteString) -> IO () - writeRuntime (filePath, contents) = - BS.writeFile (projRoot juvixBuildDir takeFileName filePath) contents + writeRuntime :: (Path Rel File, BS.ByteString) -> Sem r () + writeRuntime (filePath, contents) = do + root <- askPkgDir + embed (BS.writeFile (toFilePath (root juvixBuildDir filePath)) contents) + +wasiStandaloneRuntimeDir :: [(Path Rel File, BS.ByteString)] +wasiStandaloneRuntimeDir = map (first relFile) $(FE.makeRelativeToProject "c-runtime/wasi-standalone" >>= FE.embedDir) + +standaloneRuntimeDir :: [(Path Rel File, BS.ByteString)] +standaloneRuntimeDir = map (first relFile) $(FE.makeRelativeToProject "c-runtime/standalone" >>= FE.embedDir) + +wasiLibCRuntimeDir :: [(Path Rel File, BS.ByteString)] +wasiLibCRuntimeDir = map (first relFile) $(FE.makeRelativeToProject "c-runtime/wasi-libc" >>= FE.embedDir) + +builtinCRuntimeDir :: [(Path Rel File, BS.ByteString)] +builtinCRuntimeDir = map (first relFile) $(FE.makeRelativeToProject "c-runtime/builtins" >>= FE.embedDir) + +wallocDir :: [(Path Rel File, BS.ByteString)] +wallocDir = map (first relFile) $(FE.makeRelativeToProject "c-runtime/walloc" >>= FE.embedDir) + +libcRuntime :: [(Path Rel File, BS.ByteString)] +libcRuntime = wasiLibCRuntimeDir <> builtinCRuntimeDir clangNativeCompile :: forall r. - Members '[Embed IO, Error Text] r => - FilePath -> - FilePath -> + Members '[Embed IO, App, Error Text] r => + Path Abs File -> CompileOptions -> Sem r () -clangNativeCompile projRoot inputFileCompile o = runClang (nativeArgs outputFile inputFile) +clangNativeCompile inputFileCompile o = do + inputFile <- getInputFile + outputFile <- getOutputFile + runClang (nativeArgs outputFile inputFile) where - outputFile :: FilePath - outputFile = maybe (takeBaseName inputFileCompile) (^. pathPath) (o ^. compileOutputFile) + getOutputFile :: Sem r (Path Abs File) + getOutputFile = case o ^. compileOutputFile of + Nothing -> return (removeExtension' inputFileCompile) + Just f -> someBaseToAbs' (f ^. pathPath) - inputFile :: FilePath - inputFile = inputCFile projRoot inputFileCompile + getInputFile :: Sem r (Path Abs File) + getInputFile = inputCFile inputFileCompile clangCompile :: forall r. - Members '[Embed IO, Error Text] r => - FilePath -> - FilePath -> + Members '[Embed IO, App, Error Text] r => + Path Abs File -> CompileOptions -> Sem r () -clangCompile projRoot inputFileCompile o = clangArgs >>= runClang +clangCompile inputFileCompile o = do + outputFile <- getOutputFile + inputFile <- getInputFile + let clangArgs :: Sem r [String] + clangArgs = case o ^. compileRuntime of + RuntimeStandalone -> do + standaloneLibArgs outputFile inputFile + RuntimeWasiStandalone -> wasiStandaloneArgs outputFile inputFile + RuntimeWasiLibC -> wasiLibcArgs outputFile inputFile + + clangArgs >>= runClang where - clangArgs :: Sem r [String] - clangArgs = case o ^. compileRuntime of - RuntimeStandalone -> - return (standaloneLibArgs projRoot outputFile inputFile) - RuntimeWasiStandalone -> wasiStandaloneArgs projRoot outputFile inputFile <$> sysrootEnvVar - RuntimeWasiLibC -> wasiLibcArgs outputFile inputFile <$> sysrootEnvVar + getOutputFile :: Sem r (Path Abs File) + getOutputFile = maybe (return defaultOutputFile) someBaseToAbs' (o ^? compileOutputFile . _Just . pathPath) - outputFile :: FilePath - outputFile = maybe (takeBaseName inputFileCompile <> ".wasm") (^. pathPath) (o ^. compileOutputFile) + defaultOutputFile :: Path Abs File + defaultOutputFile = replaceExtension' ".wasm" inputFileCompile - inputFile :: FilePath - inputFile = inputCFile projRoot inputFileCompile + getInputFile :: Sem r (Path Abs File) + getInputFile = inputCFile inputFileCompile - sysrootEnvVar :: Sem r String - sysrootEnvVar = - fromMaybeM (throw msg) (embed (lookupEnv "WASI_SYSROOT_PATH")) - where - msg :: Text - msg = "Missing environment variable WASI_SYSROOT_PATH" +sysrootEnvVar :: Members '[Error Text, Embed IO] r => Sem r (Path Abs Dir) +sysrootEnvVar = + absDir + <$> fromMaybeM (throw msg) (embed (lookupEnv "WASI_SYSROOT_PATH")) + where + msg :: Text + msg = "Missing environment variable WASI_SYSROOT_PATH" -commonArgs :: FilePath -> [String] +commonArgs :: Path Abs File -> [String] commonArgs wasmOutputFile = [ "-std=c99", "-Oz", "-I", - juvixBuildDir, + toFilePath juvixBuildDir, "-o", - wasmOutputFile + toFilePath wasmOutputFile ] -standaloneLibArgs :: FilePath -> FilePath -> FilePath -> [String] -standaloneLibArgs projRoot wasmOutputFile inputFile = - commonArgs wasmOutputFile - <> [ "--target=wasm32", - "-nodefaultlibs", - "-nostartfiles", - "-Wl,--no-entry", - projRoot juvixBuildDir "walloc.c", - inputFile - ] +standaloneLibArgs :: Members '[App, Embed IO] r => Path Abs File -> Path Abs File -> Sem r [String] +standaloneLibArgs wasmOutputFile inputFile = do + root <- askPkgDir + return $ + commonArgs wasmOutputFile + <> [ "--target=wasm32", + "-nodefaultlibs", + "-nostartfiles", + "-Wl,--no-entry", + toFilePath (root juvixBuildDir $(mkRelFile "walloc.c")), + toFilePath inputFile + ] -wasiStandaloneArgs :: FilePath -> FilePath -> FilePath -> FilePath -> [String] -wasiStandaloneArgs projRoot wasmOutputFile inputFile sysrootPath = - wasiCommonArgs sysrootPath wasmOutputFile - <> [ projRoot juvixBuildDir "walloc.c", - inputFile - ] +wasiStandaloneArgs :: Members '[App, Error Text, Embed IO] r => Path Abs File -> Path Abs File -> Sem r [String] +wasiStandaloneArgs wasmOutputFile inputFile = do + root <- askPkgDir + com <- wasiCommonArgs wasmOutputFile + return $ + com + <> [ toFilePath (root juvixBuildDir $(mkRelFile "walloc.c")), + toFilePath inputFile + ] -wasiLibcArgs :: FilePath -> FilePath -> FilePath -> [String] -wasiLibcArgs wasmOutputFile inputFile sysrootPath = - wasiCommonArgs sysrootPath wasmOutputFile - <> ["-lc", inputFile] +wasiLibcArgs :: Members '[App, Error Text, Embed IO] r => Path Abs File -> Path Abs File -> Sem r [String] +wasiLibcArgs wasmOutputFile inputFile = do + com <- wasiCommonArgs wasmOutputFile + return $ com <> ["-lc", toFilePath inputFile] -nativeArgs :: FilePath -> FilePath -> [String] +nativeArgs :: Path Abs File -> Path Abs File -> [String] nativeArgs outputFile inputFile = - commonArgs outputFile <> [inputFile] + commonArgs outputFile <> [toFilePath inputFile] -wasiCommonArgs :: FilePath -> FilePath -> [String] -wasiCommonArgs sysrootPath wasmOutputFile = - commonArgs wasmOutputFile - <> [ "-nodefaultlibs", - "--target=wasm32-wasi", - "--sysroot", - sysrootPath - ] +wasiCommonArgs :: Members '[App, Error Text, Embed IO] r => Path Abs File -> Sem r [String] +wasiCommonArgs wasmOutputFile = do + sysrootPath <- sysrootEnvVar + return $ + commonArgs wasmOutputFile + <> [ "-nodefaultlibs", + "--target=wasm32-wasi", + "--sysroot", + toFilePath sysrootPath + ] runClang :: Members '[Embed IO, Error Text] r => diff --git a/app/Commands/Compile/Options.hs b/app/Commands/Compile/Options.hs index b447d678f..9ad960529 100644 --- a/app/Commands/Compile/Options.hs +++ b/app/Commands/Compile/Options.hs @@ -2,7 +2,10 @@ module Commands.Compile.Options where import CommonOptions -data CompileTarget = TargetC | TargetWasm | TargetNative +data CompileTarget + = TargetC + | TargetWasm + | TargetNative deriving stock (Show, Data) data CompileRuntime @@ -14,8 +17,8 @@ data CompileRuntime data CompileOptions = CompileOptions { _compileTarget :: CompileTarget, _compileRuntime :: CompileRuntime, - _compileOutputFile :: Maybe Path, - _compileInputFile :: Path + _compileOutputFile :: Maybe (AppPath File), + _compileInputFile :: AppPath File } deriving stock (Data) diff --git a/app/Commands/Dev.hs b/app/Commands/Dev.hs index 45df6048f..faa86549b 100644 --- a/app/Commands/Dev.hs +++ b/app/Commands/Dev.hs @@ -30,4 +30,4 @@ runCommand = \case Core opts -> Core.runCommand opts Asm opts -> Asm.runCommand opts Runtime opts -> Runtime.runCommand opts - DisplayRoot -> DisplayRoot.runCommand + DisplayRoot opts -> DisplayRoot.runCommand opts diff --git a/app/Commands/Dev/Asm/Compile.hs b/app/Commands/Dev/Asm/Compile.hs index 1840c7f17..c6851c3a2 100644 --- a/app/Commands/Dev/Asm/Compile.hs +++ b/app/Commands/Dev/Asm/Compile.hs @@ -12,20 +12,21 @@ import Juvix.Extra.Paths runCommand :: forall r. Members '[Embed IO, App] r => AsmCompileOptions -> Sem r () runCommand opts = do - s <- embed (readFile file) - case Asm.runParser file s of + file <- getFile + s <- embed (readFile (toFilePath file)) + case Asm.runParser (toFilePath file) s of Left err -> exitJuvixError (JuvixError err) Right tab -> case run $ runError $ asmToMiniC asmOpts tab of Left err -> exitJuvixError err Right C.MiniCResult {..} -> do - root <- askRoot - embed $ createDirectoryIfMissing True (root juvixBuildDir) - let cFile = inputCFile root file - embed $ TIO.writeFile cFile _resultCCode - Compile.runCommand opts {_compileInputFile = Path cFile False} + root <- askPkgDir + ensureDir (root juvixBuildDir) + cFile <- inputCFile file + embed $ TIO.writeFile (toFilePath cFile) _resultCCode + Compile.runCommand opts {_compileInputFile = AppPath (Abs cFile) False} where - file :: FilePath - file = opts ^. compileInputFile . pathPath + getFile :: Sem r (Path Abs File) + getFile = someBaseToAbs' (opts ^. compileInputFile . pathPath) asmOpts :: Asm.Options asmOpts = Asm.makeOptions (asmTarget (opts ^. compileTarget)) (opts ^. compileDebug) @@ -36,9 +37,10 @@ runCommand opts = do TargetNative64 -> Backend.TargetCNative64 TargetC -> Backend.TargetCWasm32Wasi -inputCFile :: FilePath -> FilePath -> FilePath -inputCFile projRoot inputFileCompile = - projRoot juvixBuildDir outputMiniCFile +inputCFile :: Members '[App] r => Path Abs File -> Sem r (Path Abs File) +inputCFile inputFileCompile = do + root <- askPkgDir + return (root juvixBuildDir outputMiniCFile) where - outputMiniCFile :: FilePath - outputMiniCFile = takeBaseName inputFileCompile <> ".c" + outputMiniCFile :: Path Rel File + outputMiniCFile = replaceExtension' ".c" (filename inputFileCompile) diff --git a/app/Commands/Dev/Asm/Run.hs b/app/Commands/Dev/Asm/Run.hs index d62b0ff11..89e232b73 100644 --- a/app/Commands/Dev/Asm/Run.hs +++ b/app/Commands/Dev/Asm/Run.hs @@ -12,8 +12,9 @@ import Juvix.Compiler.Asm.Translation.FromSource qualified as Asm runCommand :: forall r. Members '[Embed IO, App] r => AsmRunOptions -> Sem r () runCommand opts = do - s <- embed (readFile file) - case Asm.runParser file s of + afile :: Path Abs File <- someBaseToAbs' file + s <- embed (readFile (toFilePath afile)) + case Asm.runParser (toFilePath afile) s of Left err -> exitJuvixError (JuvixError err) Right tab -> let v = if opts ^. asmRunNoValidate then Nothing else Asm.validate' tab @@ -35,7 +36,7 @@ runCommand opts = do Nothing -> exitMsg (ExitFailure 1) "no 'main' function" where - file :: FilePath + file :: SomeBase File file = opts ^. asmRunInputFile . pathPath doRun :: diff --git a/app/Commands/Dev/Asm/Run/Options.hs b/app/Commands/Dev/Asm/Run/Options.hs index f91a08305..134d1dcc9 100644 --- a/app/Commands/Dev/Asm/Run/Options.hs +++ b/app/Commands/Dev/Asm/Run/Options.hs @@ -4,7 +4,7 @@ import CommonOptions data AsmRunOptions = AsmRunOptions { _asmRunNoValidate :: Bool, - _asmRunInputFile :: Path + _asmRunInputFile :: AppPath File } deriving stock (Data) diff --git a/app/Commands/Dev/Asm/Validate.hs b/app/Commands/Dev/Asm/Validate.hs index 1be0bfc2d..3701287d2 100644 --- a/app/Commands/Dev/Asm/Validate.hs +++ b/app/Commands/Dev/Asm/Validate.hs @@ -8,8 +8,9 @@ import Juvix.Compiler.Asm.Translation.FromSource qualified as Asm runCommand :: forall r. Members '[Embed IO, App] r => AsmValidateOptions -> Sem r () runCommand opts = do - s <- embed (readFile file) - case Asm.runParser file s of + afile :: Path Abs File <- someBaseToAbs' file + s <- embed (readFile (toFilePath afile)) + case Asm.runParser (toFilePath afile) s of Left err -> exitJuvixError (JuvixError err) Right tab -> do case Asm.validate' tab of @@ -23,5 +24,5 @@ runCommand opts = do renderStdOut (Asm.ppOutDefault tab tab) exitMsg ExitSuccess "" where - file :: FilePath + file :: SomeBase File file = opts ^. asmValidateInputFile . pathPath diff --git a/app/Commands/Dev/Asm/Validate/Options.hs b/app/Commands/Dev/Asm/Validate/Options.hs index df668d9ba..71735c0a0 100644 --- a/app/Commands/Dev/Asm/Validate/Options.hs +++ b/app/Commands/Dev/Asm/Validate/Options.hs @@ -3,7 +3,7 @@ module Commands.Dev.Asm.Validate.Options where import CommonOptions data AsmValidateOptions = AsmValidateOptions - { _asmValidateInputFile :: Path, + { _asmValidateInputFile :: AppPath File, _asmValidateNoPrint :: Bool } deriving stock (Data) diff --git a/app/Commands/Dev/Core/Eval.hs b/app/Commands/Dev/Core/Eval.hs index f5d26f67c..5bf57b128 100644 --- a/app/Commands/Dev/Core/Eval.hs +++ b/app/Commands/Dev/Core/Eval.hs @@ -8,11 +8,12 @@ import Juvix.Compiler.Core.Translation.FromSource qualified as Core runCommand :: forall r. Members '[Embed IO, App] r => CoreEvalOptions -> Sem r () runCommand opts = do - s <- embed (readFile f) - case Core.runParser f Core.emptyInfoTable s of + f :: Path Abs File <- someBaseToAbs' b + s <- embed (readFile (toFilePath f)) + case Core.runParser (toFilePath f) Core.emptyInfoTable s of Left err -> exitJuvixError (JuvixError err) Right (tab, Just node) -> do evalAndPrint opts tab node Right (_, Nothing) -> return () where - f :: FilePath - f = opts ^. coreEvalInputFile . pathPath + b :: SomeBase File + b = opts ^. coreEvalInputFile . pathPath diff --git a/app/Commands/Dev/Core/Eval/Options.hs b/app/Commands/Dev/Core/Eval/Options.hs index cb0f15fd8..7ea0c13e4 100644 --- a/app/Commands/Dev/Core/Eval/Options.hs +++ b/app/Commands/Dev/Core/Eval/Options.hs @@ -6,7 +6,7 @@ import Juvix.Compiler.Core.Pretty.Options qualified as Core data CoreEvalOptions = CoreEvalOptions { _coreEvalNoIO :: Bool, - _coreEvalInputFile :: Path, + _coreEvalInputFile :: AppPath File, _coreEvalShowDeBruijn :: Bool } deriving stock (Data) diff --git a/app/Commands/Dev/Core/Read.hs b/app/Commands/Dev/Core/Read.hs index 6ef9ae28d..609c71dd7 100644 --- a/app/Commands/Dev/Core/Read.hs +++ b/app/Commands/Dev/Core/Read.hs @@ -10,8 +10,9 @@ import Juvix.Compiler.Core.Translation.FromSource qualified as Core runCommand :: forall r a. (Members '[Embed IO, App] r, CanonicalProjection a Eval.EvalOptions, CanonicalProjection a Core.Options, CanonicalProjection a CoreReadOptions) => a -> Sem r () runCommand opts = do - s' <- embed (readFile f) - (tab, mnode) <- getRight (mapLeft JuvixError (Core.runParser f Core.emptyInfoTable s')) + inputFile :: Path Abs File <- someBaseToAbs' sinputFile + s' <- embed . readFile . toFilePath $ inputFile + (tab, mnode) <- getRight (mapLeft JuvixError (Core.runParser (toFilePath inputFile) Core.emptyInfoTable s')) let tab' = Core.applyTransformations (project opts ^. coreReadTransformations) tab embed (Scoper.scopeTrace tab') unless (project opts ^. coreReadNoPrint) $ do @@ -30,5 +31,5 @@ runCommand opts = do embed (putStrLn "-- Node") renderStdOut (Core.ppOut opts node) embed (putStrLn "") - f :: FilePath - f = project opts ^. coreReadInputFile . pathPath + sinputFile :: SomeBase File + sinputFile = project opts ^. coreReadInputFile . pathPath diff --git a/app/Commands/Dev/Core/Read/Options.hs b/app/Commands/Dev/Core/Read/Options.hs index c84cff710..22a36f57e 100644 --- a/app/Commands/Dev/Core/Read/Options.hs +++ b/app/Commands/Dev/Core/Read/Options.hs @@ -11,7 +11,7 @@ data CoreReadOptions = CoreReadOptions _coreReadShowDeBruijn :: Bool, _coreReadEval :: Bool, _coreReadNoPrint :: Bool, - _coreReadInputFile :: Path + _coreReadInputFile :: AppPath File } deriving stock (Data) diff --git a/app/Commands/Dev/DisplayRoot.hs b/app/Commands/Dev/DisplayRoot.hs index ce42746ad..c661c90a4 100644 --- a/app/Commands/Dev/DisplayRoot.hs +++ b/app/Commands/Dev/DisplayRoot.hs @@ -1,6 +1,15 @@ module Commands.Dev.DisplayRoot where import Commands.Base +import Commands.Dev.DisplayRoot.Options +import Data.Yaml -runCommand :: Members '[Embed IO, App] r => Sem r () -runCommand = askRoot >>= say . pack +runCommand :: forall r. Members '[Embed IO, App] r => RootOptions -> Sem r () +runCommand RootOptions {..} = do + askPkgDir >>= say . pack . toFilePath + when _rootPrintPackage printPackage + where + printPackage :: Sem r () + printPackage = do + say "+----------------------------+" + askPackage >>= say . decodeUtf8 . encode . rawPackage diff --git a/app/Commands/Dev/DisplayRoot/Options.hs b/app/Commands/Dev/DisplayRoot/Options.hs new file mode 100644 index 000000000..d9098eefe --- /dev/null +++ b/app/Commands/Dev/DisplayRoot/Options.hs @@ -0,0 +1,22 @@ +module Commands.Dev.DisplayRoot.Options where + +import CommonOptions + +data RootOptions = RootOptions + { _rootPrintPackage :: Bool, + _rootMainFile :: Maybe (AppPath File) + } + deriving stock (Data) + +makeLenses ''RootOptions + +parseRoot :: Parser RootOptions +parseRoot = do + _rootPrintPackage <- + switch + ( long "print-package" + <> help "print the juvix.yaml file as parsed" + ) + + _rootMainFile <- optional parseInputJuvixFile + pure RootOptions {..} diff --git a/app/Commands/Dev/Doc.hs b/app/Commands/Dev/Doc.hs index e2f8daac2..649aae43b 100644 --- a/app/Commands/Dev/Doc.hs +++ b/app/Commands/Dev/Doc.hs @@ -9,8 +9,8 @@ import System.Process qualified as Process runCommand :: Members '[Embed IO, App] r => DocOptions -> Sem r () runCommand DocOptions {..} = do ctx <- runPipeline _docInputFile upToInternalTyped - let docDir = _docOutputDir ^. pathPath + docDir <- someBaseToAbs' (_docOutputDir ^. pathPath) Doc.compile docDir "proj" ctx when _docOpen $ case openCmd of Nothing -> say "Could not recognize the 'open' command for your OS" - Just opencmd -> embed (void (Process.spawnProcess opencmd [docDir Doc.indexFileName])) + Just opencmd -> embed (void (Process.spawnProcess opencmd [toFilePath (docDir Doc.indexFileName)])) diff --git a/app/Commands/Dev/Doc/Options.hs b/app/Commands/Dev/Doc/Options.hs index b7ba24554..7a0f1251d 100644 --- a/app/Commands/Dev/Doc/Options.hs +++ b/app/Commands/Dev/Doc/Options.hs @@ -3,9 +3,9 @@ module Commands.Dev.Doc.Options where import CommonOptions data DocOptions = DocOptions - { _docOutputDir :: Path, + { _docOutputDir :: AppPath Dir, _docOpen :: Bool, - _docInputFile :: Path + _docInputFile :: AppPath File } deriving stock (Data) @@ -15,7 +15,7 @@ parseDoc :: Parser DocOptions parseDoc = do _docOutputDir <- parseGenericOutputDir - ( value "doc" + ( value (Rel (relDir "doc")) <> showDefault <> help "html output directory" ) diff --git a/app/Commands/Dev/Highlight.hs b/app/Commands/Dev/Highlight.hs index 16cc3f40a..4441bde92 100644 --- a/app/Commands/Dev/Highlight.hs +++ b/app/Commands/Dev/Highlight.hs @@ -15,10 +15,10 @@ runCommand HighlightOptions {..} = do genOpts <- askGenericOptions say (Highlight.goError (run $ runReader genOpts $ errorIntervals err)) Right r -> do + inputFile <- someBaseToAbs' (_highlightInputFile ^. pathPath) let tbl = r ^. _2 . Scoper.resultParserTable items = tbl ^. Parser.infoParsedItems names = r ^. _2 . (Scoper.resultScoperTable . Scoper.infoNames) - inputFile = _highlightInputFile ^. pathPath hinput = Highlight.filterInput inputFile @@ -26,4 +26,4 @@ runCommand HighlightOptions {..} = do { _highlightNames = names, _highlightParsed = items } - raw (Highlight.go _highlightBackend hinput) + sayRaw (Highlight.go _highlightBackend hinput) diff --git a/app/Commands/Dev/Highlight/Options.hs b/app/Commands/Dev/Highlight/Options.hs index 310284e1c..bc33cdeb3 100644 --- a/app/Commands/Dev/Highlight/Options.hs +++ b/app/Commands/Dev/Highlight/Options.hs @@ -9,7 +9,7 @@ import Juvix.Compiler.Concrete.Data.Highlight data HighlightOptions = HighlightOptions { _highlightBackend :: HighlightBackend, - _highlightInputFile :: Path + _highlightInputFile :: AppPath File } deriving stock (Data) diff --git a/app/Commands/Dev/Internal/Arity/Options.hs b/app/Commands/Dev/Internal/Arity/Options.hs index 393bc5723..b5ffc9545 100644 --- a/app/Commands/Dev/Internal/Arity/Options.hs +++ b/app/Commands/Dev/Internal/Arity/Options.hs @@ -3,7 +3,7 @@ module Commands.Dev.Internal.Arity.Options where import CommonOptions newtype InternalArityOptions = InternalArityOptions - { _internalArityInputFile :: Path + { _internalArityInputFile :: AppPath File } deriving stock (Data) diff --git a/app/Commands/Dev/Internal/CoreEval/Options.hs b/app/Commands/Dev/Internal/CoreEval/Options.hs index bc225b8dd..703dae91a 100644 --- a/app/Commands/Dev/Internal/CoreEval/Options.hs +++ b/app/Commands/Dev/Internal/CoreEval/Options.hs @@ -9,7 +9,7 @@ data InternalCoreEvalOptions = InternalCoreEvalOptions { _internalCoreEvalTransformations :: [TransformationId], _internalCoreEvalShowDeBruijn :: Bool, _internalCoreEvalNoIO :: Bool, - _internalCoreEvalInputFile :: Path + _internalCoreEvalInputFile :: AppPath File } deriving stock (Data) diff --git a/app/Commands/Dev/Internal/Pretty/Options.hs b/app/Commands/Dev/Internal/Pretty/Options.hs index 06c2c3681..7972af586 100644 --- a/app/Commands/Dev/Internal/Pretty/Options.hs +++ b/app/Commands/Dev/Internal/Pretty/Options.hs @@ -3,7 +3,7 @@ module Commands.Dev.Internal.Pretty.Options where import CommonOptions newtype InternalPrettyOptions = InternalPrettyOptions - { _internalPrettyInputFile :: Path + { _internalPrettyInputFile :: AppPath File } deriving stock (Data) diff --git a/app/Commands/Dev/Internal/Typecheck/Options.hs b/app/Commands/Dev/Internal/Typecheck/Options.hs index d73adf3bd..c2030c412 100644 --- a/app/Commands/Dev/Internal/Typecheck/Options.hs +++ b/app/Commands/Dev/Internal/Typecheck/Options.hs @@ -4,7 +4,7 @@ import CommonOptions data InternalTypeOptions = InternalTypeOptions { _internalTypePrint :: Bool, - _internalTypeInputFile :: Path + _internalTypeInputFile :: AppPath File } deriving stock (Data) diff --git a/app/Commands/Dev/MiniC/Options.hs b/app/Commands/Dev/MiniC/Options.hs index 141b77586..f2e4b92e6 100644 --- a/app/Commands/Dev/MiniC/Options.hs +++ b/app/Commands/Dev/MiniC/Options.hs @@ -3,7 +3,7 @@ module Commands.Dev.MiniC.Options where import CommonOptions newtype MiniCOptions = MiniCOptions - { _miniCInputFile :: Path + { _miniCInputFile :: AppPath File } deriving stock (Data) diff --git a/app/Commands/Dev/Options.hs b/app/Commands/Dev/Options.hs index 6b647ccf5..744651222 100644 --- a/app/Commands/Dev/Options.hs +++ b/app/Commands/Dev/Options.hs @@ -8,11 +8,13 @@ module Commands.Dev.Options module Commands.Dev.Scope.Options, module Commands.Dev.Doc.Options, module Commands.Dev.Termination.Options, + module Commands.Dev.DisplayRoot.Options, ) where import Commands.Dev.Asm.Options hiding (Compile) import Commands.Dev.Core.Options +import Commands.Dev.DisplayRoot.Options import Commands.Dev.Doc.Options import Commands.Dev.Highlight.Options import Commands.Dev.Internal.Options @@ -24,7 +26,7 @@ import Commands.Dev.Termination.Options import CommonOptions data DevCommand - = DisplayRoot + = DisplayRoot RootOptions | Highlight HighlightOptions | Internal InternalCommand | Core CoreCommand @@ -122,7 +124,7 @@ commandShowRoot :: Mod CommandFields DevCommand commandShowRoot = command "root" $ info - (pure DisplayRoot) + (DisplayRoot <$> parseRoot) (progDesc "Show the root path for a Juvix project") commandTermination :: Mod CommandFields DevCommand diff --git a/app/Commands/Dev/Parse/Options.hs b/app/Commands/Dev/Parse/Options.hs index 176d29380..807bf8b25 100644 --- a/app/Commands/Dev/Parse/Options.hs +++ b/app/Commands/Dev/Parse/Options.hs @@ -4,7 +4,7 @@ import CommonOptions data ParseOptions = ParseOptions { _parseNoPrettyShow :: Bool, - _parseInputFile :: Path + _parseInputFile :: AppPath File } deriving stock (Data) diff --git a/app/Commands/Dev/Scope/Options.hs b/app/Commands/Dev/Scope/Options.hs index 35448ae86..adbcac787 100644 --- a/app/Commands/Dev/Scope/Options.hs +++ b/app/Commands/Dev/Scope/Options.hs @@ -6,7 +6,7 @@ import Juvix.Compiler.Concrete.Pretty qualified as Scoper data ScopeOptions = ScopeOptions { _scopeInlineImports :: Bool, - _scopeInputFile :: Path + _scopeInputFile :: AppPath File } deriving stock (Data) diff --git a/app/Commands/Dev/Termination/CallGraph/Options.hs b/app/Commands/Dev/Termination/CallGraph/Options.hs index 61d8c9def..945bbac76 100644 --- a/app/Commands/Dev/Termination/CallGraph/Options.hs +++ b/app/Commands/Dev/Termination/CallGraph/Options.hs @@ -5,7 +5,7 @@ import Data.Text qualified as Text data CallGraphOptions = CallGraphOptions { _graphFunctionNameFilter :: Maybe (NonEmpty Text), - _graphInputFile :: Path + _graphInputFile :: AppPath File } deriving stock (Data) diff --git a/app/Commands/Dev/Termination/Calls/Options.hs b/app/Commands/Dev/Termination/Calls/Options.hs index b2e5805c5..acb549148 100644 --- a/app/Commands/Dev/Termination/Calls/Options.hs +++ b/app/Commands/Dev/Termination/Calls/Options.hs @@ -8,7 +8,7 @@ import Juvix.Compiler.Abstract.Pretty.Base qualified as Abstract data CallsOptions = CallsOptions { _callsFunctionNameFilter :: Maybe (NonEmpty Text), _callsShowDecreasingArgs :: Abstract.ShowDecrArgs, - _callsInputFile :: Path + _callsInputFile :: AppPath File } deriving stock (Data) diff --git a/app/Commands/Doctor.hs b/app/Commands/Doctor.hs index 62494cdde..7abad52e7 100644 --- a/app/Commands/Doctor.hs +++ b/app/Commands/Doctor.hs @@ -68,7 +68,7 @@ type DoctorEff = '[Log, Embed IO] checkCmdOnPath :: Members DoctorEff r => String -> [Text] -> Sem r () checkCmdOnPath cmd errMsg = - whenM (isNothing <$> embed (findExecutable cmd)) (mapM_ warning errMsg) + whenM (isNothing <$> findExecutable (relFile cmd)) (mapM_ warning errMsg) checkClangTargetSupported :: Members DoctorEff r => String -> [Text] -> Sem r () checkClangTargetSupported target errMsg = do diff --git a/app/Commands/Extra/Compile.hs b/app/Commands/Extra/Compile.hs index a400703d5..de29a01d9 100644 --- a/app/Commands/Extra/Compile.hs +++ b/app/Commands/Extra/Compile.hs @@ -10,27 +10,24 @@ import System.Process qualified as P runCommand :: forall r. Members '[Embed IO, App] r => CompileOptions -> Sem r () runCommand opts = do - root <- askRoot - let inputFile = opts ^. compileInputFile . pathPath - result <- embed (runCompile root inputFile opts) + root <- askPkgDir + inputFile <- someBaseToAbs' (opts ^. compileInputFile . pathPath) + result <- runCompile root inputFile opts case result of Left err -> printFailureExit err _ -> return () -juvixIncludeDir :: FilePath -juvixIncludeDir = juvixBuildDir "include" - -runCompile :: FilePath -> FilePath -> CompileOptions -> IO (Either Text ()) +runCompile :: Members '[App, Embed IO] r => Path Abs Dir -> Path Abs File -> CompileOptions -> Sem r (Either Text ()) runCompile projRoot inputFile o = do - createDirectoryIfMissing True (projRoot juvixBuildDir) - createDirectoryIfMissing True (projRoot juvixIncludeDir) + ensureDir (projRoot juvixBuildDir) + ensureDir (projRoot juvixIncludeDir) prepareRuntime projRoot o case o ^. compileTarget of - TargetWasm32Wasi -> runM (runError (clangWasmWasiCompile inputFile o)) - TargetNative64 -> runM (runError (clangNativeCompile inputFile o)) + TargetWasm32Wasi -> runError (clangWasmWasiCompile inputFile o) + TargetNative64 -> runError (clangNativeCompile inputFile o) TargetC -> return $ Right () -prepareRuntime :: FilePath -> CompileOptions -> IO () +prepareRuntime :: forall r. Members '[App, Embed IO] r => Path Abs Dir -> CompileOptions -> Sem r () prepareRuntime projRoot o = do mapM_ writeHeader headersDir case o ^. compileTarget of @@ -52,64 +49,74 @@ prepareRuntime projRoot o = do nativeDebugRuntime :: BS.ByteString nativeDebugRuntime = $(FE.makeRelativeToProject "runtime/_build.native64-debug/libjuvix.a" >>= FE.embedFile) - headersDir :: [(FilePath, BS.ByteString)] - headersDir = $(FE.makeRelativeToProject "runtime/include" >>= FE.embedDir) - - writeRuntime :: BS.ByteString -> IO () + writeRuntime :: BS.ByteString -> Sem r () writeRuntime = - BS.writeFile (projRoot juvixBuildDir "libjuvix.a") + embed + . BS.writeFile (toFilePath (projRoot juvixBuildDir $(mkRelFile "libjuvix.a"))) - writeHeader :: (FilePath, BS.ByteString) -> IO () - writeHeader (filePath, contents) = do - createDirectoryIfMissing True (projRoot juvixIncludeDir takeDirectory filePath) - BS.writeFile (projRoot juvixIncludeDir filePath) contents + headersDir :: [(Path Rel File, BS.ByteString)] + headersDir = map (first relFile) $(FE.makeRelativeToProject "runtime/include" >>= FE.embedDir) + + writeHeader :: (Path Rel File, BS.ByteString) -> Sem r () + writeHeader (filePath, contents) = embed $ do + ensureDir (projRoot juvixIncludeDir parent filePath) + BS.writeFile (toFilePath (projRoot juvixIncludeDir filePath)) contents clangNativeCompile :: forall r. - Members '[Embed IO, Error Text] r => - FilePath -> + Members '[App, Embed IO, Error Text] r => + Path Abs File -> CompileOptions -> Sem r () -clangNativeCompile inputFile o = - runClang (native64Args o outputFile inputFile) +clangNativeCompile inputFile o = do + outputFile' <- outputFile + runClang (native64Args o outputFile' inputFile) where - outputFile :: FilePath - outputFile = maybe defaultOutputFile (^. pathPath) (o ^. compileOutputFile) + outputFile :: Sem r (Path Abs File) + outputFile = maybe (return defaultOutputFile) someBaseToAbs' (o ^? compileOutputFile . _Just . pathPath) - defaultOutputFile :: FilePath + defaultOutputFile :: Path Abs File defaultOutputFile - | o ^. compilePreprocess = takeBaseName inputFile <> ".out.c" - | o ^. compileAssembly = takeBaseName inputFile <> ".s" - | otherwise = takeBaseName inputFile + | o ^. compilePreprocess = replaceExtension' ".out.c" inputFile + | o ^. compileAssembly = replaceExtension' ".s" inputFile + | otherwise = removeExtension' inputFile clangWasmWasiCompile :: forall r. - Members '[Embed IO, Error Text] r => - FilePath -> + Members '[App, Embed IO, Error Text] r => + Path Abs File -> CompileOptions -> Sem r () clangWasmWasiCompile inputFile o = clangArgs >>= runClang where clangArgs :: Sem r [String] - clangArgs = wasiArgs o outputFile inputFile <$> sysrootEnvVar + clangArgs = do + outputFile' <- outputFile + wasiArgs o outputFile' inputFile <$> sysrootEnvVar - outputFile :: FilePath - outputFile = maybe defaultOutputFile (^. pathPath) (o ^. compileOutputFile) + outputFile :: Sem r (Path Abs File) + outputFile = case o ^? compileOutputFile . _Just . pathPath of + Just f -> someBaseToAbs' f + Nothing -> return defaultOutputFile - defaultOutputFile :: FilePath - defaultOutputFile - | o ^. compilePreprocess = takeBaseName inputFile <> ".out.c" - | o ^. compileAssembly = takeBaseName inputFile <> ".wat" - | otherwise = takeBaseName inputFile <> ".wasm" + defaultOutputFile :: Path Abs File + defaultOutputFile = replaceExtension' extension inputFile + where + extension :: String + extension + | o ^. compilePreprocess = ".out.c" + | o ^. compileAssembly = ".wat" + | otherwise = ".wasm" - sysrootEnvVar :: Sem r String + sysrootEnvVar :: Sem r (Path Abs Dir) sysrootEnvVar = - fromMaybeM (throw msg) (embed (lookupEnv "WASI_SYSROOT_PATH")) + absDir + <$> fromMaybeM (throw msg) (embed (lookupEnv "WASI_SYSROOT_PATH")) where msg :: Text msg = "Missing environment variable WASI_SYSROOT_PATH" -commonArgs :: CompileOptions -> FilePath -> [String] +commonArgs :: CompileOptions -> Path Abs File -> [String] commonArgs o outputFile = ["-E" | o ^. compilePreprocess] <> ["-S" | o ^. compileAssembly] @@ -121,26 +128,26 @@ commonArgs o outputFile = "-Werror", "-std=c11", "-I", - juvixIncludeDir, + toFilePath juvixIncludeDir, "-o", - outputFile + toFilePath outputFile ] <> ( if | not (o ^. compilePreprocess || o ^. compileAssembly) -> [ "-L", - juvixBuildDir + toFilePath juvixBuildDir ] | otherwise -> [] ) -native64Args :: CompileOptions -> FilePath -> FilePath -> [String] +native64Args :: CompileOptions -> Path Abs File -> Path Abs File -> [String] native64Args o outputFile inputFile = commonArgs o outputFile <> [ "-DARCH_NATIVE64", "-DAPI_LIBC", "-m64", "-O3", - inputFile + toFilePath inputFile ] <> ( if | not (o ^. compilePreprocess || o ^. compileAssembly) -> @@ -148,7 +155,7 @@ native64Args o outputFile inputFile = | otherwise -> [] ) -wasiArgs :: CompileOptions -> FilePath -> FilePath -> FilePath -> [String] +wasiArgs :: CompileOptions -> Path Abs File -> Path Abs File -> Path Abs Dir -> [String] wasiArgs o outputFile inputFile sysrootPath = commonArgs o outputFile <> [ "-DARCH_WASM32", @@ -157,8 +164,8 @@ wasiArgs o outputFile inputFile sysrootPath = "-nodefaultlibs", "--target=wasm32-wasi", "--sysroot", - sysrootPath, - inputFile + toFilePath sysrootPath, + toFilePath inputFile ] <> ( if | not (o ^. compilePreprocess || o ^. compileAssembly) -> diff --git a/app/Commands/Extra/Compile/Options.hs b/app/Commands/Extra/Compile/Options.hs index 66258ed2b..e830753f9 100644 --- a/app/Commands/Extra/Compile/Options.hs +++ b/app/Commands/Extra/Compile/Options.hs @@ -2,16 +2,19 @@ module Commands.Extra.Compile.Options where import CommonOptions -data CompileTarget = TargetWasm32Wasi | TargetNative64 | TargetC +data CompileTarget + = TargetWasm32Wasi + | TargetNative64 + | TargetC deriving stock (Show, Data) data CompileOptions = CompileOptions { _compileDebug :: Bool, _compilePreprocess :: Bool, _compileAssembly :: Bool, - _compileOutputFile :: Maybe Path, + _compileOutputFile :: Maybe (AppPath File), _compileTarget :: CompileTarget, - _compileInputFile :: Path + _compileInputFile :: AppPath File } deriving stock (Data) diff --git a/app/Commands/Html.hs b/app/Commands/Html.hs index 72ba2e42e..4d355b4ed 100644 --- a/app/Commands/Html.hs +++ b/app/Commands/Html.hs @@ -10,4 +10,5 @@ runCommand :: Members '[Embed IO, App] r => HtmlOptions -> Sem r () runCommand HtmlOptions {..} = do res <- runPipeline _htmlInputFile upToScoping let m = head (res ^. Scoper.resultModules) - embed (Html.genHtml Concrete.defaultOptions _htmlRecursive _htmlTheme (_htmlOutputDir ^. pathPath) _htmlPrintMetadata m) + outDir <- someBaseToAbs' (_htmlOutputDir ^. pathPath) + embed (Html.genHtml Concrete.defaultOptions _htmlRecursive _htmlTheme outDir _htmlPrintMetadata m) diff --git a/app/Commands/Html/Options.hs b/app/Commands/Html/Options.hs index 3fe63608a..ab2de7a50 100644 --- a/app/Commands/Html/Options.hs +++ b/app/Commands/Html/Options.hs @@ -6,8 +6,8 @@ import Juvix.Compiler.Backend.Html.Data.Theme data HtmlOptions = HtmlOptions { _htmlRecursive :: Bool, _htmlTheme :: Theme, - _htmlOutputDir :: Path, - _htmlInputFile :: Path, + _htmlOutputDir :: AppPath Dir, + _htmlInputFile :: AppPath File, _htmlPrintMetadata :: Bool } deriving stock (Data) @@ -33,7 +33,7 @@ parseHtml = do ) _htmlOutputDir <- parseGenericOutputDir - ( value "html" + ( value (Rel $(mkRelDir "html")) <> showDefault <> help "html output directory" <> action "directory" diff --git a/app/Commands/Init.hs b/app/Commands/Init.hs index ac039016c..ca162c761 100644 --- a/app/Commands/Init.hs +++ b/app/Commands/Init.hs @@ -26,13 +26,13 @@ init = do say "✨ Your next Juvix adventure is about to begin! ✨" say "I will help you set it up" pkg <- getPackage - say ("creating " <> pack juvixYamlFile) - embed (encodeFile juvixYamlFile pkg) + say ("creating " <> pack (toFilePath juvixYamlFile)) + embed (encodeFile (toFilePath juvixYamlFile) (rawPackage pkg)) say "you are all set" checkNotInProject :: forall r. Members '[Embed IO] r => Sem r () checkNotInProject = - whenM (embed (doesFileExist juvixYamlFile)) err + whenM (doesFileExist juvixYamlFile) err where err :: Sem r () err = do @@ -43,11 +43,12 @@ getPackage :: forall r. Members '[Embed IO] r => Sem r Package getPackage = do tproj <- getProjName say "Tell me the version of your project [leave empty for 0.0.0]" - tversion <- getVersion + tversion :: SemVer <- getVersion return Package - { _packageName = Just tproj, - _packageVersion = Just (prettySemVer tversion) + { _packageName = tproj, + _packageVersion = Ideal tversion, + _packageDependencies = mempty } getProjName :: forall r. Members '[Embed IO] r => Sem r Text @@ -66,7 +67,7 @@ getProjName = do where getDefault :: Sem r (Maybe Text) getDefault = runFail $ do - dir <- map toLower <$> (embed getCurrentDirectory >>= Fail.last . splitDirectories) + dir <- map toLower . dropTrailingPathSeparator . toFilePath . dirname <$> getCurrentDir Fail.fromRight (parse projectNameParser (pack dir)) readName :: Maybe Text -> Sem r Text readName def = go diff --git a/app/Commands/Repl.hs b/app/Commands/Repl.hs index fc713de60..227216edf 100644 --- a/app/Commands/Repl.hs +++ b/app/Commands/Repl.hs @@ -5,7 +5,6 @@ module Commands.Repl where import Commands.Base hiding (command) import Commands.Repl.Options import Control.Exception (throwIO) -import Control.Monad.IO.Class import Control.Monad.State.Strict qualified as State import Data.String.Interpolate (i, __i) import Evaluator @@ -23,7 +22,6 @@ import Juvix.Data.Error.GenericError qualified as Error import Juvix.Extra.Paths import Juvix.Extra.Version import Juvix.Prelude.Pretty qualified as P -import Root import System.Console.ANSI qualified as Ansi import System.Console.Haskeline import System.Console.Repline @@ -41,10 +39,10 @@ data ReplContext = ReplContext } data ReplState = ReplState - { _replStateReplRoot :: FilePath, + { _replStatePkgDir :: Path Abs Dir, + _replStateInvokeDir :: Path Abs Dir, _replStateContext :: Maybe ReplContext, - _replStateGlobalOptions :: GlobalOptions, - _replStateMkEntryPoint :: FilePath -> Repl EntryPoint + _replStateGlobalOptions :: GlobalOptions } makeLenses ''ReplState @@ -77,7 +75,26 @@ welcomeMsg = liftIO (putStrLn [i|Juvix REPL version #{versionTag}: https://juvix runCommand :: Members '[Embed IO, App] r => ReplOptions -> Sem r () runCommand opts = do - let printHelpTxt :: String -> Repl () + root <- askPkgDir + package <- askPackage + let getReplEntryPoint :: SomeBase File -> Repl EntryPoint + getReplEntryPoint inputFile = do + gopts <- State.gets (^. replStateGlobalOptions) + absInputFile :: Path Abs File <- replMakeAbsolute inputFile + return $ + EntryPoint + { _entryPointRoot = root, + _entryPointResolverRoot = root, + _entryPointNoTermination = gopts ^. globalNoTermination, + _entryPointNoPositivity = gopts ^. globalNoPositivity, + _entryPointNoStdlib = gopts ^. globalNoStdlib, + _entryPointPackage = package, + _entryPointModulePaths = pure absInputFile, + _entryPointGenericOptions = project gopts, + _entryPointStdin = Nothing + } + + printHelpTxt :: String -> Repl () printHelpTxt _ = helpTxt multilineCmd :: String @@ -88,21 +105,21 @@ runCommand opts = do loadEntryPoint :: EntryPoint -> Repl () loadEntryPoint ep = do - (bs, res) <- liftIO (runIO' iniState ep upToCore) + (artif, res) <- liftIO (runIO' iniState ep upToCore) State.modify ( set replStateContext ( Just ( ReplContext - { _replContextBuiltins = bs, + { _replContextBuiltins = artif ^. artifactBuiltins, _replContextExpContext = expressionContext res, _replContextEntryPoint = ep } ) ) ) - let epPath :: FilePath = ep ^. entryPointModulePaths . _head1 - liftIO (putStrLn [i|OK loaded: #{epPath}|]) + let epPath :: Path Abs File = ep ^. entryPointModulePaths . _head1 + liftIO (putStrLn [i|OK loaded: #{toFilePath epPath}|]) reloadFile :: String -> Repl () reloadFile _ = do @@ -112,29 +129,24 @@ runCommand opts = do loadEntryPoint entryPoint Nothing -> noFileLoadedMsg - loadFile :: String -> Repl () - loadFile args = do - mkEntryPoint <- State.gets (^. replStateMkEntryPoint) - let f = unpack (strip (pack args)) - entryPoint <- mkEntryPoint f + pSomeFile :: String -> SomeBase File + pSomeFile = someFile . unpack . strip . pack + + loadFile :: SomeBase File -> Repl () + loadFile f = do + entryPoint <- getReplEntryPoint f loadEntryPoint entryPoint loadPrelude :: Repl () - loadPrelude = do - mStdlibPath <- State.gets (^. replStateGlobalOptions . globalStdlibPath) - case mStdlibPath of - Nothing -> loadDefaultPrelude - Just stdlibDir' -> do - absStdlibDir <- liftIO (makeAbsolute stdlibDir') - loadFile (absStdlibDir preludePath) + loadPrelude = loadDefaultPrelude loadDefaultPrelude :: Repl () loadDefaultPrelude = defaultPreludeEntryPoint >>= loadEntryPoint printRoot :: String -> Repl () printRoot _ = do - r <- State.gets (^. replStateReplRoot) - liftIO $ putStrLn (pack r) + r <- State.gets (^. replStatePkgDir) + liftIO $ putStrLn (pack (toFilePath r)) displayVersion :: String -> Repl () displayVersion _ = liftIO (putStrLn versionTag) @@ -202,7 +214,7 @@ runCommand opts = do -- `repline`'s `multilineCommand` logic overrides this no-op. (multilineCmd, Repline.dontCrash . \_ -> return ()), ("quit", quit), - ("load", Repline.dontCrash . loadFile), + ("load", Repline.dontCrash . loadFile . pSomeFile), ("reload", Repline.dontCrash . reloadFile), ("prelude", Repline.dontCrash . const loadPrelude), ("root", printRoot), @@ -249,18 +261,30 @@ runCommand opts = do tabComplete = Prefix (wordCompleter optsCompleter) defaultMatcher replAction :: ReplS () - replAction = evalReplOpts ReplOpts {..} + replAction = do + evalReplOpts + ReplOpts + { prefix, + multilineCommand, + initialiser, + finaliser, + tabComplete, + command, + options, + banner + } - root <- askRoot + pkgDir <- askPkgDir + invokeDir <- askInvokeDir globalOptions <- askGlobalOptions embed ( State.evalStateT replAction ( ReplState - { _replStateReplRoot = root, + { _replStatePkgDir = pkgDir, + _replStateInvokeDir = invokeDir, _replStateContext = Nothing, - _replStateGlobalOptions = globalOptions, - _replStateMkEntryPoint = getReplEntryPoint + _replStateGlobalOptions = globalOptions } ) ) @@ -268,38 +292,26 @@ runCommand opts = do defaultPreludeEntryPoint :: Repl EntryPoint defaultPreludeEntryPoint = do opts <- State.gets (^. replStateGlobalOptions) - root <- State.gets (^. replStateReplRoot) + root <- State.gets (^. replStatePkgDir) return $ EntryPoint { _entryPointRoot = root, + _entryPointResolverRoot = defaultStdlibPath root, _entryPointNoTermination = opts ^. globalNoTermination, _entryPointNoPositivity = opts ^. globalNoPositivity, _entryPointNoStdlib = opts ^. globalNoStdlib, - _entryPointStdlibPath = opts ^. globalStdlibPath, - _entryPointPackage = emptyPackage, - _entryPointModulePaths = pure (defaultStdlibPath root preludePath), + _entryPointPackage = defaultPackage root, + _entryPointModulePaths = pure (defaultStdlibPath root preludePath), _entryPointGenericOptions = project opts, _entryPointStdin = Nothing } -getReplEntryPoint :: FilePath -> Repl EntryPoint -getReplEntryPoint inputFile = do - opts <- State.gets (^. replStateGlobalOptions) - absInputFile <- liftIO (makeAbsolute inputFile) - absStdlibPath <- liftIO (mapM makeAbsolute (opts ^. globalStdlibPath)) - (root, package) <- liftIO (findRoot (Just absInputFile)) - return $ - EntryPoint - { _entryPointRoot = root, - _entryPointNoTermination = opts ^. globalNoTermination, - _entryPointNoPositivity = opts ^. globalNoPositivity, - _entryPointNoStdlib = opts ^. globalNoStdlib, - _entryPointStdlibPath = absStdlibPath, - _entryPointPackage = package, - _entryPointModulePaths = pure absInputFile, - _entryPointGenericOptions = project opts, - _entryPointStdin = Nothing - } +replMakeAbsolute :: SomeBase b -> Repl (Path Abs b) +replMakeAbsolute = \case + Abs p -> return p + Rel r -> do + invokeDir <- State.gets (^. replStateInvokeDir) + return (invokeDir r) inferExpressionIO' :: ReplContext -> Text -> IO (Either JuvixError Internal.Expression) inferExpressionIO' ctx = inferExpressionIO "" (ctx ^. replContextExpContext) (ctx ^. replContextBuiltins) diff --git a/app/Commands/Repl/Options.hs b/app/Commands/Repl/Options.hs index cf4f9e2ff..9c03ebed5 100644 --- a/app/Commands/Repl/Options.hs +++ b/app/Commands/Repl/Options.hs @@ -3,7 +3,7 @@ module Commands.Repl.Options where import CommonOptions data ReplOptions = ReplOptions - { _replInputFile :: Maybe Path, + { _replInputFile :: Maybe (AppPath File), _replNoPrelude :: Bool } deriving stock (Data) diff --git a/app/Commands/Typecheck/Options.hs b/app/Commands/Typecheck/Options.hs index 16715bc07..d9c7583db 100644 --- a/app/Commands/Typecheck/Options.hs +++ b/app/Commands/Typecheck/Options.hs @@ -4,7 +4,7 @@ import Commands.Dev.Internal.Typecheck.Options qualified as Internal import CommonOptions newtype TypecheckOptions = TypecheckOptions - { _typecheckInputFile :: Path + { _typecheckInputFile :: AppPath File } deriving stock (Data) diff --git a/app/CommonOptions.hs b/app/CommonOptions.hs index 117cebb50..e51949b79 100644 --- a/app/CommonOptions.hs +++ b/app/CommonOptions.hs @@ -14,86 +14,98 @@ import System.Process import Prelude (show) -- | Paths that are input are used to detect the root of the project. -data Path = Path - { _pathPath :: FilePath, +data AppPath f = AppPath + { _pathPath :: SomeBase f, _pathIsInput :: Bool } deriving stock (Data) -makeLenses ''Path +makeLenses ''AppPath -instance Show Path where - show = (^. pathPath) +instance Show (AppPath f) where + show = Prelude.show . (^. pathPath) -parseInputJuvixFile :: Parser Path +parseInputJuvixFile :: Parser (AppPath File) parseInputJuvixFile = do _pathPath <- argument - str + someFileOpt ( metavar "JUVIX_FILE" <> help "Path to a .juvix file" <> completer juvixCompleter ) - pure Path {_pathIsInput = True, ..} + pure AppPath {_pathIsInput = True, ..} -parseInputJuvixCoreFile :: Parser Path +parseInputJuvixCoreFile :: Parser (AppPath File) parseInputJuvixCoreFile = do _pathPath <- argument - str + someFileOpt ( metavar "JUVIX_CORE_FILE" <> help "Path to a .jvc file" <> completer juvixCoreCompleter ) - pure Path {_pathIsInput = True, ..} + pure AppPath {_pathIsInput = True, ..} -parseInputJuvixAsmFile :: Parser Path +parseInputJuvixAsmFile :: Parser (AppPath File) parseInputJuvixAsmFile = do _pathPath <- argument - str + someFileOpt ( metavar "JUVIX_ASM_FILE" <> help "Path to a .jva file" <> completer juvixAsmCompleter ) - pure Path {_pathIsInput = True, ..} + pure AppPath {_pathIsInput = True, ..} -parseInputCFile :: Parser Path +parseInputCFile :: Parser (AppPath File) parseInputCFile = do _pathPath <- argument - str + someFileOpt ( metavar "C_FILE" <> help "Path to a .c file" <> completer juvixCCompleter ) - pure Path {_pathIsInput = True, ..} + pure AppPath {_pathIsInput = True, ..} -parseGenericOutputFile :: Parser Path +parseGenericOutputFile :: Parser (AppPath File) parseGenericOutputFile = do _pathPath <- option - str + someFileOpt ( long "output" <> short 'o' <> metavar "OUTPUT_FILE" <> help "Path to output file" <> action "file" ) - pure Path {_pathIsInput = False, ..} + pure AppPath {_pathIsInput = False, ..} -parseGenericOutputDir :: Mod OptionFields FilePath -> Parser Path +parseGenericOutputDir :: Mod OptionFields (SomeBase Dir) -> Parser (AppPath Dir) parseGenericOutputDir m = do _pathPath <- option - str + someDirOpt ( long "output-dir" <> metavar "OUTPUT_DIR" <> help "Path to output directory" <> action "directory" <> m ) - pure Path {_pathIsInput = False, ..} + pure AppPath {_pathIsInput = False, ..} + +someFileOpt :: ReadM (SomeBase File) +someFileOpt = eitherReader aux + where + aux :: String -> Either String (SomeBase File) + aux s = maybe (Left $ s <> " is not a file path") Right (parseSomeFile s) + +someDirOpt :: ReadM (SomeBase Dir) +someDirOpt = eitherReader aux + where + aux :: String -> Either String (SomeBase Dir) + aux s = maybe (Left $ s <> " is not a directory path") Right (parseSomeDir s) extCompleter :: String -> Completer extCompleter ext = mkCompleter $ \word -> do @@ -186,7 +198,7 @@ requote s = goX [] = [] -class HasPaths a where +class HasAppPaths a where paths :: Traversal' a FilePath optDeBruijn :: Parser Bool diff --git a/app/Evaluator.hs b/app/Evaluator.hs index 92fcef304..9e20cad89 100644 --- a/app/Evaluator.hs +++ b/app/Evaluator.hs @@ -13,7 +13,7 @@ import Juvix.Compiler.Core.Pretty qualified as Core import Text.Megaparsec.Pos qualified as M data EvalOptions = EvalOptions - { _evalInputFile :: Path, + { _evalInputFile :: AppPath File, _evalNoIO :: Bool } @@ -58,6 +58,6 @@ evalAndPrint opts tab node = do embed (putStrLn "") where defaultLoc :: Interval - defaultLoc = singletonInterval (mkLoc 0 (M.initialPos f)) - f :: FilePath + defaultLoc = singletonInterval (mkLoc 0 (M.initialPos (fromSomeFile f))) + f :: SomeBase File f = project opts ^. evalInputFile . pathPath diff --git a/app/GlobalOptions.hs b/app/GlobalOptions.hs index 94696608e..1b8f9cb2d 100644 --- a/app/GlobalOptions.hs +++ b/app/GlobalOptions.hs @@ -3,11 +3,10 @@ module GlobalOptions ) where +import CommonOptions import Juvix.Compiler.Abstract.Pretty.Options qualified as Abstract import Juvix.Compiler.Internal.Pretty.Options qualified as Internal import Juvix.Data.Error.GenericError qualified as E -import Juvix.Prelude -import Options.Applicative hiding (hidden) data GlobalOptions = GlobalOptions { _globalNoColors :: Bool, @@ -17,10 +16,9 @@ data GlobalOptions = GlobalOptions _globalStdin :: Bool, _globalNoTermination :: Bool, _globalNoPositivity :: Bool, - _globalNoStdlib :: Bool, - _globalStdlibPath :: Maybe FilePath + _globalNoStdlib :: Bool } - deriving stock (Eq, Show, Data) + deriving stock (Eq, Show) makeLenses ''GlobalOptions @@ -53,8 +51,7 @@ defaultGlobalOptions = _globalNoTermination = False, _globalStdin = False, _globalNoPositivity = False, - _globalNoStdlib = False, - _globalStdlibPath = Nothing + _globalNoStdlib = False } -- | Get a parser for global flags which can be hidden or not depending on @@ -101,14 +98,4 @@ parseGlobalFlags = do ( long "no-stdlib" <> help "Do not use the standard library" ) - _globalStdlibPath <- - optional - ( strOption - ( long "stdlib-path" - <> metavar "PATH" - <> help "Specify path to the standard library" - <> action "directory" - ) - ) - return GlobalOptions {..} diff --git a/app/Main.hs b/app/Main.hs index 327d0358c..b0014fff8 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,7 +2,6 @@ module Main (main) where import App import CommonOptions -import Juvix.Compiler.Pipeline import Root import TopCommand import TopCommand.Options @@ -10,9 +9,7 @@ import TopCommand.Options main :: IO () main = do let p = prefs showHelpOnEmpty - (global, cli) <- customExecParser p descr >>= secondM makeAbsPaths - (root, pkg) <- findRoot' cli - runM (runAppIO global root pkg (runTopCommand cli)) - where - findRoot' :: TopCommand -> IO (FilePath, Package) - findRoot' cli = findRoot (topCommandInputFile cli) + cwd <- getCurrentDir + (global, cli) <- customExecParser p descr + (root, pkg) <- findRootAndChangeDir (topCommandInputFile cli) + runM (runAppIO global cwd root pkg (runTopCommand cli)) diff --git a/app/Root.hs b/app/Root.hs index a0bdfd4c6..bbfa82959 100644 --- a/app/Root.hs +++ b/app/Root.hs @@ -2,14 +2,15 @@ module Root where import Control.Exception qualified as IO import Data.ByteString qualified as ByteString -import Data.Yaml import Juvix.Compiler.Pipeline import Juvix.Extra.Paths qualified as Paths import Juvix.Prelude -findRoot :: Maybe FilePath -> IO (FilePath, Package) -findRoot minputFile = do - whenJust (takeDirectory <$> minputFile) setCurrentDirectory +findRootAndChangeDir :: Maybe (SomeBase File) -> IO (Path Abs Dir, Package) +findRootAndChangeDir minputFile = do + whenJust minputFile $ \case + Abs d -> setCurrentDir (parent d) + Rel d -> setCurrentDir (parent d) r <- IO.try go case r of Left (err :: IO.SomeException) -> do @@ -18,22 +19,21 @@ findRoot minputFile = do exitFailure Right root -> return root where - possiblePaths :: FilePath -> [FilePath] - possiblePaths start = takeWhile (/= "/") (aux start) - where - aux f = f : aux (takeDirectory f) + possiblePaths :: Path Abs Dir -> [Path Abs Dir] + possiblePaths p = p : toList (parents p) - go :: IO (FilePath, Package) + go :: IO (Path Abs Dir, Package) go = do - c <- getCurrentDirectory - l <- findFile (possiblePaths c) Paths.juvixYamlFile + cwd <- getCurrentDir + l <- findFile (possiblePaths cwd) Paths.juvixYamlFile case l of - Nothing -> return (c, emptyPackage) - Just yaml -> do - bs <- ByteString.readFile yaml + Nothing -> return (cwd, defaultPackage cwd) + Just yamlPath -> do + bs <- ByteString.readFile (toFilePath yamlPath) let isEmpty = ByteString.null bs + root = parent yamlPath pkg <- if - | isEmpty -> return emptyPackage - | otherwise -> decodeThrow bs - return (takeDirectory yaml, pkg) + | isEmpty -> return (defaultPackage root) + | otherwise -> readPackageIO root + return (root, pkg) diff --git a/app/TopCommand/Options.hs b/app/TopCommand/Options.hs index d82a518b7..1b9355a06 100644 --- a/app/TopCommand/Options.hs +++ b/app/TopCommand/Options.hs @@ -23,10 +23,10 @@ data TopCommand | JuvixRepl ReplOptions deriving stock (Data) -topCommandInputFile :: TopCommand -> Maybe FilePath +topCommandInputFile :: TopCommand -> Maybe (SomeBase File) topCommandInputFile = firstJust getInputFile . universeBi where - getInputFile :: Path -> Maybe FilePath + getInputFile :: AppPath File -> Maybe (SomeBase File) getInputFile p | p ^. pathIsInput = Just (p ^. pathPath) | otherwise = Nothing @@ -134,12 +134,6 @@ parseTopCommand = <|> parseCompilerCommand <|> parseUtility -makeAbsPaths :: TopCommand -> IO TopCommand -makeAbsPaths = transformBiM go - where - go :: Path -> IO Path - go = traverseOf pathPath canonicalizePath - descr :: ParserInfo (GlobalOptions, TopCommand) descr = info diff --git a/juvix-stdlib b/juvix-stdlib index c91ec2eb6..a2790ca49 160000 --- a/juvix-stdlib +++ b/juvix-stdlib @@ -1 +1 @@ -Subproject commit c91ec2eb6daf49c993a1f55673e75d97cb8dada3 +Subproject commit a2790ca49ceeb569559224abe1587305ea1861fa diff --git a/package.yaml b/package.yaml index 7d04dee4d..48e1a642f 100644 --- a/package.yaml +++ b/package.yaml @@ -15,6 +15,7 @@ github: anoma/juvix extra-source-files: - README.org - assets/* +- juvix-stdlib/juvix.yaml - juvix-stdlib/**/*.juvix - runtime/include/**/*.h - runtime/**/*.a @@ -23,6 +24,7 @@ extra-source-files: dependencies: - aeson == 2.0.* +- aeson-better-errors == 0.9.* - ansi-terminal == 0.11.* - base == 4.16.* - blaze-html == 0.9.* @@ -31,8 +33,8 @@ dependencies: - directory == 1.3.* - dlist == 1.0.* - edit-distance == 0.2.* +- exceptions == 0.10.* - extra == 1.7.* -- transformers == 0.5.* - file-embed == 0.0.* - filepath == 1.4.* - gitrev == 1.3.* @@ -45,19 +47,20 @@ dependencies: - path-io == 1.7.* - polysemy == 1.7.* - polysemy-plugin == 0.4.* +- pretty == 1.1.* - prettyprinter == 1.7.* - prettyprinter-ansi-terminal == 1.1.* -- pretty == 1.1.* - process == 1.6.* - safe == 0.3.* -- semirings == 0.6.* - singletons == 3.0.* - singletons-th == 3.1.* - Stream == 0.4.* -- time == 1.11.* - template-haskell == 2.18.* - text == 1.2.* - th-utilities == 0.2.* +- time == 1.11.* +- transformers == 0.5.* +- unix-compat == 0.5.* - unordered-containers == 0.2.* - versions == 5.0.* - yaml == 0.11.* diff --git a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs index 0c0a7354b..6bd13aacc 100644 --- a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs +++ b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs @@ -9,6 +9,7 @@ import Data.ByteString qualified as BS import Data.ByteString.Builder qualified as Builder import Data.HashMap.Strict qualified as HashMap import Data.Time.Clock +import Data.Versions (prettyV) import Juvix.Compiler.Abstract.Translation.FromConcrete qualified as Abstract import Juvix.Compiler.Backend.Html.Data import Juvix.Compiler.Backend.Html.Extra @@ -34,7 +35,7 @@ import Text.Blaze.Html5.Attributes qualified as Attr data DocParams = DocParams { _docParamBase :: Text, - _docOutputDir :: FilePath + _docOutputDir :: Path Abs Dir } makeLenses ''DocParams @@ -64,8 +65,8 @@ indexTree = foldr insertModule emptyTree emptyTree :: Tree Symbol (Maybe TopModulePath) emptyTree = Tree Nothing mempty -indexFileName :: FilePath -indexFileName = "index.html" +indexFileName :: Path Rel File +indexFileName = $(mkRelFile "index.html") createIndexFile :: forall r. @@ -74,7 +75,7 @@ createIndexFile :: Sem r () createIndexFile ps = do outDir <- asks (^. docOutputDir) - indexHtml >>= (template mempty >=> writeHtml (outDir indexFileName)) + indexHtml >>= (template mempty >=> writeHtml (outDir indexFileName)) where indexHtml :: Sem r Html indexHtml = do @@ -126,7 +127,7 @@ createIndexFile ps = do summary "Subtree" <> ul (mconcatMap li c') -compile :: Members '[Embed IO] r => FilePath -> Text -> InternalTypedResult -> Sem r () +compile :: Members '[Embed IO] r => Path Abs Dir -> Text -> InternalTypedResult -> Sem r () compile dir baseName ctx = runReader params . runReader normTable . runReader entry $ do copyAssets mapM_ goTopModule topModules @@ -147,15 +148,15 @@ compile dir baseName ctx = runReader params . runReader normTable . runReader en . Scoped.mainModule copyAssets :: forall s. Members '[Embed IO, Reader DocParams] s => Sem s () copyAssets = do - toAssetsDir <- ( "assets") <$> asks (^. docOutputDir) - let writeAsset :: (FilePath, BS.ByteString) -> Sem s () + toAssetsDir <- ( $(mkRelDir "assets")) <$> asks (^. docOutputDir) + let writeAsset :: (Path Rel File, BS.ByteString) -> Sem s () writeAsset (filePath, fileContents) = - Prelude.embed $ BS.writeFile (toAssetsDir takeFileName filePath) fileContents - Prelude.embed (createDirectoryIfMissing True toAssetsDir) + Prelude.embed $ BS.writeFile (toFilePath (toAssetsDir filePath)) fileContents + ensureDir toAssetsDir mapM_ writeAsset assetFiles where - assetFiles :: [(FilePath, BS.ByteString)] - assetFiles = $(assetsDir) + assetFiles :: [(Path Rel File, BS.ByteString)] + assetFiles = assetsDir params :: DocParams params = @@ -166,19 +167,19 @@ compile dir baseName ctx = runReader params . runReader normTable . runReader en topModules :: HashMap NameId (Module 'Scoped 'ModuleTop) topModules = getAllModules mainMod -writeHtml :: Members '[Embed IO] r => FilePath -> Html -> Sem r () +writeHtml :: Members '[Embed IO] r => Path Abs File -> Html -> Sem r () writeHtml f h = Prelude.embed $ do - createDirectoryIfMissing True dir - Builder.writeFile f (Html.renderHtmlBuilder h) + ensureDir dir + Builder.writeFile (toFilePath f) (Html.renderHtmlBuilder h) where - dir :: FilePath - dir = takeDirectory f + dir :: Path Abs Dir + dir = parent f -moduleDocPath :: Members '[Reader HtmlOptions, Reader DocParams] r => Module 'Scoped 'ModuleTop -> Sem r FilePath +moduleDocPath :: Members '[Reader HtmlOptions, Reader DocParams] r => Module 'Scoped 'ModuleTop -> Sem r (Path Abs File) moduleDocPath m = do relPath <- moduleDocRelativePath (m ^. modulePath . S.nameConcrete) outDir <- asks (^. docOutputDir) - return (outDir relPath) + return (outDir relPath) topModulePath :: Module 'Scoped 'ModuleTop -> TopModulePath @@ -215,8 +216,8 @@ template rightMenu' content' = do packageHeader :: Sem r Html packageHeader = do - pkgName' <- toHtml <$> asks (^. entryPointPackage . packageName') - version' <- toHtml <$> asks (^. entryPointPackage . packageVersion') + pkgName' <- toHtml <$> asks (^. entryPointPackage . packageName) + version' <- toHtml <$> asks (^. entryPointPackage . packageVersion . to prettyV) return $ Html.div ! Attr.id "package-header" $ ( Html.span ! Attr.class_ "caption" $ @@ -258,7 +259,7 @@ goTopModule :: goTopModule m = do runReader docHtmlOpts $ do fpath <- moduleDocPath m - Prelude.embed (putStrLn ("processing " <> pack fpath)) + Prelude.embed (putStrLn ("processing " <> pack (toFilePath fpath))) docHtml >>= writeHtml fpath runReader srcHtmlOpts $ do @@ -285,7 +286,7 @@ goTopModule m = do return $ ul ! Attr.id "page-menu" ! Attr.class_ "links" $ li (a ! Attr.href sourceRef' $ "Source") - <> li (a ! Attr.href (fromString indexFileName) $ "Index") + <> li (a ! Attr.href (fromString (toFilePath indexFileName)) $ "Index") content :: Sem s Html content = do diff --git a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs index 580d82fb4..e7959c99a 100644 --- a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs +++ b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs @@ -12,6 +12,7 @@ import Juvix.Compiler.Concrete.Data.ScopedName qualified as S import Juvix.Compiler.Concrete.Extra import Juvix.Compiler.Concrete.Language import Juvix.Compiler.Concrete.Pretty.Base +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver import Juvix.Compiler.Internal.Pretty qualified as Internal import Juvix.Extra.Paths import Juvix.Extra.Version @@ -34,11 +35,11 @@ kindSuffix = \case HtmlSrc -> "-src" HtmlOnly -> "" -genHtml :: Options -> Bool -> Theme -> FilePath -> Bool -> Module 'Scoped 'ModuleTop -> IO () +genHtml :: Options -> Bool -> Theme -> Path Abs Dir -> Bool -> Module 'Scoped 'ModuleTop -> IO () genHtml opts recursive theme outputDir printMetadata entry = do - createDirectoryIfMissing True outputDir + ensureDir outputDir copyAssetFiles - withCurrentDirectory outputDir $ do + withCurrentDir outputDir $ do mapM_ outputModule allModules where allModules @@ -47,25 +48,26 @@ genHtml opts recursive theme outputDir printMetadata entry = do copyAssetFiles :: IO () copyAssetFiles = do - createDirectoryIfMissing True toAssetsDir + ensureDir toAssetsDir mapM_ writeAsset assetFiles where - assetFiles :: [(FilePath, BS.ByteString)] - assetFiles = $(assetsDir) + assetFiles :: [(Path Rel File, BS.ByteString)] + assetFiles = assetsDir - writeAsset :: (FilePath, BS.ByteString) -> IO () + writeAsset :: (Path Rel File, BS.ByteString) -> IO () writeAsset (filePath, fileContents) = - BS.writeFile (toAssetsDir takeFileName filePath) fileContents - toAssetsDir = outputDir "assets" + BS.writeFile (toFilePath (toAssetsDir filePath)) fileContents + toAssetsDir = outputDir $(mkRelDir "assets") outputModule :: Module 'Scoped 'ModuleTop -> IO () outputModule m = do - createDirectoryIfMissing True (takeDirectory htmlFile) - putStrLn $ "Writing " <> pack htmlFile + ensureDir (parent htmlFile) + putStrLn $ "Writing " <> pack (toFilePath htmlFile) utc <- getCurrentTime - Text.writeFile htmlFile (genModule opts HtmlOnly printMetadata utc theme m) + Text.writeFile (toFilePath htmlFile) (genModule opts HtmlOnly printMetadata utc theme m) where - htmlFile = topModulePathToDottedPath (m ^. modulePath . S.nameConcrete) <.> ".html" + htmlFile :: Path Rel File + htmlFile = relFile (topModulePathToDottedPath (m ^. modulePath . S.nameConcrete) <.> ".html") genModuleHtml :: Options -> HtmlKind -> Bool -> UTCTime -> Theme -> Module 'Scoped 'ModuleTop -> Html genModuleHtml opts htmlKind printMetadata utc theme m = @@ -215,15 +217,12 @@ putTag ann x = case ann of nameIdAttr :: S.NameId -> AttributeValue nameIdAttr (S.NameId k) = fromString . show $ k -moduleDocRelativePath :: Members '[Reader HtmlOptions] r => TopModulePath -> Sem r FilePath +moduleDocRelativePath :: Members '[Reader HtmlOptions] r => TopModulePath -> Sem r (Path Rel File) moduleDocRelativePath m = do suff <- kindSuffix <$> asks (^. htmlOptionsKind) - return (topModulePathToRelativeFilePath (Just "html") suff joinDot m) - where - joinDot :: FilePath -> FilePath -> FilePath - joinDot l r = l <.> r + return (topModulePathToRelativePathDot ".html" suff m) nameIdAttrRef :: Members '[Reader HtmlOptions] r => TopModulePath -> Maybe S.NameId -> Sem r AttributeValue nameIdAttrRef tp s = do - pth <- moduleDocRelativePath tp + pth <- toFilePath <$> moduleDocRelativePath tp return (fromString pth <> preEscapedToValue '#' <>? (nameIdAttr <$> s)) diff --git a/src/Juvix/Compiler/Concrete/Data/Highlight/Input.hs b/src/Juvix/Compiler/Concrete/Data/Highlight/Input.hs index 3ba734ae0..781cbddf8 100644 --- a/src/Juvix/Compiler/Concrete/Data/Highlight/Input.hs +++ b/src/Juvix/Compiler/Concrete/Data/Highlight/Input.hs @@ -15,12 +15,12 @@ data HighlightInput = HighlightInput makeLenses ''HighlightInput -filterInput :: FilePath -> HighlightInput -> HighlightInput +filterInput :: Path Abs File -> HighlightInput -> HighlightInput filterInput absPth HighlightInput {..} = HighlightInput { _highlightNames = filterByLoc absPth _highlightNames, _highlightParsed = filterByLoc absPth _highlightParsed } -filterByLoc :: HasLoc p => FilePath -> [p] -> [p] -filterByLoc absPth = filter ((== absPth) . (^. intervalFile) . getLoc) +filterByLoc :: HasLoc p => Path Abs File -> [p] -> [p] +filterByLoc p = filter ((== toFilePath p) . (^. intervalFile) . getLoc) diff --git a/src/Juvix/Compiler/Concrete/Data/Name.hs b/src/Juvix/Compiler/Concrete/Data/Name.hs index 99fc346b9..3615d86f0 100644 --- a/src/Juvix/Compiler/Concrete/Data/Name.hs +++ b/src/Juvix/Compiler/Concrete/Data/Name.hs @@ -23,7 +23,7 @@ instance HasLoc Name where NameUnqualified s -> getLoc s instance Pretty QualifiedName where - pretty (QualifiedName (Path path) s) = + pretty (QualifiedName (SymbolPath path) s) = let symbols = snoc (toList path) s in dotted (map pretty symbols) where @@ -35,13 +35,13 @@ instance Pretty Name where NameQualified q -> pretty q NameUnqualified s -> pretty s -newtype Path = Path +newtype SymbolPath = SymbolPath { _pathParts :: NonEmpty Symbol } deriving stock (Show, Eq, Ord) data QualifiedName = QualifiedName - { _qualifiedPath :: Path, + { _qualifiedPath :: SymbolPath, _qualifiedSymbol :: Symbol } deriving stock (Show, Eq, Ord, Generic) @@ -52,13 +52,13 @@ instance HasLoc QualifiedName where instance Hashable QualifiedName -instance HasLoc Path where - getLoc (Path p) = getLoc (NonEmpty.head p) <> getLoc (NonEmpty.last p) +instance HasLoc SymbolPath where + getLoc (SymbolPath p) = getLoc (NonEmpty.head p) <> getLoc (NonEmpty.last p) -deriving newtype instance Hashable Path +deriving newtype instance Hashable SymbolPath makeLenses ''QualifiedName -makeLenses ''Path +makeLenses ''SymbolPath -- | A.B.C corresponds to TopModulePath [A,B] C data TopModulePath = TopModulePath @@ -79,31 +79,6 @@ instance HasLoc TopModulePath where [] -> getLoc _modulePathName (x : _) -> getLoc x <> getLoc _modulePathName -topModulePathToFilePath :: Member Files r => TopModulePath -> Sem r FilePath -topModulePathToFilePath = topModulePathToFilePath' (Just ".juvix") - -topModulePathToRelativeFilePath :: Maybe String -> String -> (FilePath -> FilePath -> FilePath) -> TopModulePath -> FilePath -topModulePathToRelativeFilePath ext suffix joinpath mp = relFilePath - where - relDirPath :: FilePath - relDirPath = foldr (joinpath . toPath) mempty (mp ^. modulePathDir) - relFilePath :: FilePath - relFilePath = addExt (relDirPath `joinpath'` toPath (mp ^. modulePathName) <> suffix) - joinpath' :: FilePath -> FilePath -> FilePath - joinpath' l r - | null l = r - | otherwise = joinpath l r - addExt = case ext of - Nothing -> id - Just e -> (<.> e) - toPath :: Symbol -> FilePath - toPath s = unpack (s ^. symbolText) - -topModulePathToFilePath' :: - Member Files r => Maybe String -> TopModulePath -> Sem r FilePath -topModulePathToFilePath' ext mp = - getAbsPath (topModulePathToRelativeFilePath ext "" () mp) - topModulePathToDottedPath :: IsString s => TopModulePath -> s topModulePathToDottedPath (TopModulePath l r) = fromText $ mconcat $ intersperse "." $ map (^. symbolText) $ l ++ [r] diff --git a/src/Juvix/Compiler/Concrete/Data/Scope.hs b/src/Juvix/Compiler/Concrete/Data/Scope.hs index 4991f0265..43a91ea55 100644 --- a/src/Juvix/Compiler/Concrete/Data/Scope.hs +++ b/src/Juvix/Compiler/Concrete/Data/Scope.hs @@ -52,10 +52,8 @@ newtype ModulesCache = ModulesCache makeLenses ''ModulesCache -data ScopeParameters = ScopeParameters - { -- | Usually set to ".juvix". - _scopeFileExtension :: String, - -- | Used for import cycle detection. +newtype ScopeParameters = ScopeParameters + { -- | Used for import cycle detection. _scopeTopParents :: [Import 'Parsed] } diff --git a/src/Juvix/Compiler/Concrete/Data/ScopedName.hs b/src/Juvix/Compiler/Concrete/Data/ScopedName.hs index a32f63a1b..9fa9a50df 100644 --- a/src/Juvix/Compiler/Concrete/Data/ScopedName.hs +++ b/src/Juvix/Compiler/Concrete/Data/ScopedName.hs @@ -40,11 +40,11 @@ instance Hashable AbsModulePath -- | Tells whether the first argument is an immediate child of the second argument. -- In other words, tells whether the first argument is a local module of the second. isChildOf :: AbsModulePath -> AbsModulePath -> Bool -isChildOf child parent +isChildOf child parentMod | null (child ^. absLocalPath) = False | otherwise = - init (child ^. absLocalPath) == parent ^. absLocalPath - && child ^. absTopModulePath == parent ^. absTopModulePath + init (child ^. absLocalPath) == parentMod ^. absLocalPath + && child ^. absTopModulePath == parentMod ^. absTopModulePath -- | Appends a local path to the absolute path -- e.g. TopMod.Local <.> Inner == TopMod.Local.Inner diff --git a/src/Juvix/Compiler/Concrete/Translation.hs b/src/Juvix/Compiler/Concrete/Translation.hs index 47cc570fe..3e8930cf5 100644 --- a/src/Juvix/Compiler/Concrete/Translation.hs +++ b/src/Juvix/Compiler/Concrete/Translation.hs @@ -3,6 +3,7 @@ module Juvix.Compiler.Concrete.Translation where -- import Juvix.Compiler.Concrete.Translation.FromParsed import Juvix.Compiler.Concrete.Language import Juvix.Compiler.Concrete.Translation.FromParsed qualified as Scoper +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser import Juvix.Compiler.Pipeline.EntryPoint import Juvix.Prelude @@ -10,7 +11,7 @@ import Juvix.Prelude type JudocStash = State (Maybe (Judoc 'Parsed)) fromSource :: - Members '[Files, Error JuvixError, NameIdGen] r => + Members '[Files, Error JuvixError, NameIdGen, Reader EntryPoint, PathResolver] r => EntryPoint -> Sem r Scoper.ScoperResult fromSource = Parser.fromSource >=> Scoper.fromParsed diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs index c4bb68679..348e43e4a 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs @@ -7,14 +7,16 @@ where import Juvix.Compiler.Concrete.Data.InfoTable import Juvix.Compiler.Concrete.Language +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context qualified as Parsed +import Juvix.Compiler.Pipeline.EntryPoint import Juvix.Prelude fromParsed :: - Members '[Error JuvixError, Files, NameIdGen] r => + Members '[Error JuvixError, Files, NameIdGen, Reader EntryPoint, PathResolver] r => Parsed.ParserResult -> Sem r ScoperResult fromParsed pr = mapError (JuvixError @ScoperError) $ do diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs new file mode 100644 index 000000000..a37b967a8 --- /dev/null +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs @@ -0,0 +1,185 @@ +module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver + ( module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Base, + module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error, + module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.PackageInfo, + PathResolver, + addDependency, + withPath, + withPathFile, + expectedModulePath, + runPathResolverPipe, + evalPathResolverPipe, + ResolverState, + resolverFiles, + resolverPackages, + ) +where + +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet qualified as HashSet +import Juvix.Compiler.Concrete.Data.Name +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Base +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.PackageInfo +import Juvix.Compiler.Pipeline.EntryPoint +import Juvix.Extra.Stdlib (ensureStdlib) +import Juvix.Prelude + +data PathResolver m a where + -- | Currently, we pass (Just entrypoint) only for the current package and Nothing for all dependencies + AddDependency :: Maybe EntryPoint -> Dependency -> PathResolver m () + ExpectedModulePath :: TopModulePath -> PathResolver m (Path Abs File) + WithPath :: + TopModulePath -> + (Either PathResolverError (Path Abs Dir, Path Rel File) -> m x) -> + PathResolver m x + +makeSem ''PathResolver + +newtype ResolverEnv = ResolverEnv + { _envRoot :: Path Abs Dir + } + +data ResolverState = ResolverState + { -- | juvix files indexed by relative path + _resolverFiles :: HashMap (Path Rel File) (NonEmpty PackageInfo), + -- | PackageInfos indexed by root + _resolverPackages :: HashMap (Path Abs Dir) PackageInfo + } + deriving stock (Show) + +makeLenses ''ResolverState +makeLenses ''ResolverEnv + +iniResolverState :: ResolverState +iniResolverState = + ResolverState + { _resolverPackages = mempty, + _resolverFiles = mempty + } + +mkPackageInfo :: + forall r. + Members '[Files, Error Text] r => + Maybe EntryPoint -> + Path Abs Dir -> + Sem r PackageInfo +mkPackageInfo mpackageEntry _packageRoot = do + _packagePackage <- maybe (readPackage _packageRoot) (return . (^. entryPointPackage)) mpackageEntry + let deps :: [Dependency] = _packagePackage ^. packageDependencies + ensureStdlib _packageRoot deps + files :: [Path Rel File] <- map (fromJust . stripProperPrefix _packageRoot) <$> walkDirRelAccum juvixAccum _packageRoot [] + let _packageRelativeFiles = HashSet.fromList files + _packageAvailableRoots = + HashSet.fromList (_packageRoot : map (^. dependencyPath) deps) + return PackageInfo {..} + where + juvixAccum :: Path Abs Dir -> [Path Rel Dir] -> [Path Rel File] -> [Path Abs File] -> Sem r ([Path Abs File], Recurse Rel) + juvixAccum cd _ files acc = return (newJuvixFiles <> acc, RecurseFilter (not . isHiddenDirectory)) + where + newJuvixFiles :: [Path Abs File] + newJuvixFiles = [cd f | f <- files, isJuvixFile f] + +dependencyCached :: Members '[State ResolverState] r => Dependency -> Sem r Bool +dependencyCached d = HashMap.member (d ^. dependencyPath) <$> gets (^. resolverPackages) + +withPathFile :: Members '[PathResolver] r => TopModulePath -> (Either PathResolverError (Path Abs File) -> Sem r a) -> Sem r a +withPathFile m f = withPath m (f . mapRight (uncurry ())) + +addDependency' :: + Members '[State ResolverState, Files, Error Text] r => + Maybe EntryPoint -> + Dependency -> + Sem r () +addDependency' me d = do + let p :: Path Abs Dir = d ^. dependencyPath + unlessM (dependencyCached d) $ do + pkgInfo <- mkPackageInfo me p + -- traceM ("adding dependency " <> pack (toFilePath p)) + -- traceM ("has " <> prettyText (pkgInfo ^. packageRelativeFiles . to HashSet.size) <> " files") + modify' (set (resolverPackages . at p) (Just pkgInfo)) + forM_ (pkgInfo ^. packageRelativeFiles) $ \f -> do + -- traceM ("adding file " <> pack (toFilePath f)) + modify' (over resolverFiles (HashMap.insertWith (<>) f (pure pkgInfo))) + forM_ (pkgInfo ^. packagePackage . packageDependencies) (addDependency' Nothing) + +currentPackage :: Members '[State ResolverState, Reader ResolverEnv] r => Sem r PackageInfo +currentPackage = do + curRoot <- asks (^. envRoot) + gets (^?! resolverPackages . at curRoot . _Just) + +-- | Returns the root of the package where the module belongs and the path to +-- the module relative to the root. +resolvePath' :: Members '[State ResolverState, Reader ResolverEnv] r => TopModulePath -> Sem r (Either PathResolverError (Path Abs Dir, Path Rel File)) +resolvePath' mp = do + z <- gets (^. resolverFiles) + curPkg <- currentPackage + let rel = topModulePathToRelativePath' mp + packagesWithModule = z ^. at rel + visible :: PackageInfo -> Bool + visible p = HashSet.member (p ^. packageRoot) (curPkg ^. packageAvailableRoots) + return $ case filter visible (maybe [] toList packagesWithModule) of + [r] -> Right (r ^. packageRoot, rel) + [] -> + Left + ( ErrMissingModule + MissingModule + { _missingInfo = curPkg, + _missingModule = mp + } + ) + (r : rs) -> + Left + ( ErrDependencyConflict + DependencyConflict + { _conflictPackages = r :| rs, + _conflictPath = mp + } + ) + +expectedPath' :: Members '[Reader ResolverEnv] r => TopModulePath -> Sem r (Path Abs File) +expectedPath' m = do + root <- asks (^. envRoot) + return (root topModulePathToRelativePath' m) + +re :: + forall r a. + Members '[Files, Error Text] r => + Sem (PathResolver ': r) a -> + Sem (Reader ResolverEnv ': State ResolverState ': r) a +re = reinterpret2H helper + where + helper :: + forall rInitial x. + PathResolver (Sem rInitial) x -> + Tactical PathResolver (Sem rInitial) (Reader ResolverEnv ': (State ResolverState ': r)) x + helper = \case + AddDependency me m -> addDependency' me m >>= pureT + ExpectedModulePath m -> expectedPath' m >>= pureT + WithPath m a -> do + x :: Either PathResolverError (Path Abs Dir, Path Rel File) <- resolvePath' m + oldroot <- asks (^. envRoot) + x' <- pureT x + a' <- bindT a + st' <- get + let root' = case x of + Left {} -> oldroot + Right (r, _) -> r + raise (evalPathResolver' st' root' (a' x')) + +evalPathResolver' :: Members '[Files, Error Text] r => ResolverState -> Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r a +evalPathResolver' st root = fmap snd . runPathResolver' st root + +runPathResolver' :: Members '[Files, Error Text] r => ResolverState -> Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a) +runPathResolver' st root = runState st . runReader (ResolverEnv root) . re + +runPathResolver :: Members '[Files, Error Text] r => Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a) +runPathResolver = runPathResolver' iniResolverState + +runPathResolverPipe :: Members '[Files, Reader EntryPoint] r => Sem (PathResolver ': r) a -> Sem r (ResolverState, a) +runPathResolverPipe a = do + r <- asks (^. entryPointResolverRoot) + runError (runPathResolver r (raiseUnder a)) >>= either error return + +evalPathResolverPipe :: Members '[Files, Reader EntryPoint] r => Sem (PathResolver ': r) a -> Sem r a +evalPathResolverPipe = fmap snd . runPathResolverPipe diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Base.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Base.hs new file mode 100644 index 000000000..28769d3f7 --- /dev/null +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Base.hs @@ -0,0 +1,28 @@ +module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Base where + +import Juvix.Compiler.Concrete.Data.Name +import Juvix.Prelude + +topModulePathToRelativePath' :: TopModulePath -> Path Rel File +topModulePathToRelativePath' = topModulePathToRelativePath ".juvix" "" () + +topModulePathToRelativePath :: String -> String -> (FilePath -> FilePath -> FilePath) -> TopModulePath -> Path Rel File +topModulePathToRelativePath ext suffix joinpath mp = relFile relFilePath + where + relDirPath :: FilePath + relDirPath = foldr (joinpath . toPath) mempty (mp ^. modulePathDir) + relFilePath :: FilePath + relFilePath = addExt (relDirPath `joinpath'` toPath (mp ^. modulePathName) <> suffix) + joinpath' :: FilePath -> FilePath -> FilePath + joinpath' l r + | null l = r + | otherwise = joinpath l r + addExt = (<.> ext) + toPath :: Symbol -> FilePath + toPath s = unpack (s ^. symbolText) + +topModulePathToRelativePathDot :: String -> String -> TopModulePath -> Path Rel File +topModulePathToRelativePathDot ext suff m = topModulePathToRelativePath ext suff joinDot m + where + joinDot :: FilePath -> FilePath -> FilePath + joinDot l r = l <.> r diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Error.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Error.hs new file mode 100644 index 000000000..41d4714ae --- /dev/null +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Error.hs @@ -0,0 +1,61 @@ +module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error where + +import Juvix.Compiler.Concrete.Language +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Base +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.PackageInfo +import Juvix.Compiler.Pipeline.Package +import Juvix.Data.CodeAnn +import Juvix.Prelude + +data PathResolverError + = ErrDependencyConflict DependencyConflict + | ErrMissingModule MissingModule + deriving stock (Show) + +instance PrettyCodeAnn PathResolverError where + ppCodeAnn = \case + ErrDependencyConflict e -> ppCodeAnn e + ErrMissingModule e -> ppCodeAnn e + +data DependencyConflict = DependencyConflict + { _conflictPackages :: NonEmpty PackageInfo, + _conflictPath :: TopModulePath + } + deriving stock (Show) + +instance PrettyCodeAnn DependencyConflict where + ppCodeAnn DependencyConflict {..} = + "The module name " + <> code (pretty _conflictPath) + <> " is ambiguous. It is defined in these packages:" + <> line + <> indent' (itemize (item <$> toList _conflictPackages)) + where + item :: PackageInfo -> Doc CodeAnn + item pkg = pcode (pkg ^. packagePackage . packageName) <+> "at" <+> pretty (pkg ^. packageRoot) + +pcode :: Pretty a => a -> Doc CodeAnn +pcode = code . pretty + +data MissingModule = MissingModule + { _missingModule :: TopModulePath, + _missingInfo :: PackageInfo + } + deriving stock (Show) + +instance PrettyCodeAnn MissingModule where + ppCodeAnn MissingModule {..} = + "The module" + <+> pcode _missingModule + <+> "does not exist." + <> line + <> suggestion + where + suggestion :: Doc Ann + suggestion = + "It should be in" + <+> pcode (_missingInfo ^. packageRoot topModulePathToRelativePath' _missingModule) + <> line + <> "or in one of the dependencies:" + <> line + <> itemize (map pcode (_missingInfo ^.. packagePackage . packageDependencies . each . dependencyPath)) diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/PackageInfo.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/PackageInfo.hs new file mode 100644 index 000000000..c17058dde --- /dev/null +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/PackageInfo.hs @@ -0,0 +1,18 @@ +module Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.PackageInfo where + +import Juvix.Compiler.Pipeline.EntryPoint +import Juvix.Prelude + +data PackageInfo = PackageInfo + { _packageRoot :: Path Abs Dir, + -- | files relative to the root of the package + _packageRelativeFiles :: HashSet (Path Rel File), + _packageAvailableRoots :: HashSet (Path Abs Dir), + _packagePackage :: Package + } + deriving stock (Show) + +makeLenses ''PackageInfo + +packageFiles :: PackageInfo -> [Path Abs File] +packageFiles k = [k ^. packageRoot f | f <- toList (k ^. packageRelativeFiles)] diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs index c793e569e..9c77a7f3d 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs @@ -20,11 +20,13 @@ import Juvix.Compiler.Concrete.Data.Scope qualified as S import Juvix.Compiler.Concrete.Data.ScopedName qualified as S import Juvix.Compiler.Concrete.Extra qualified as P import Juvix.Compiler.Concrete.Language +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error import Juvix.Compiler.Concrete.Translation.FromSource (runModuleParser) import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context (ParserResult) +import Juvix.Compiler.Pipeline.EntryPoint import Juvix.Prelude iniScoperState :: ScoperState @@ -38,12 +40,11 @@ iniScoperState = iniScopeParameters :: ScopeParameters iniScopeParameters = ScopeParameters - { _scopeFileExtension = ".juvix", - _scopeTopParents = mempty + { _scopeTopParents = mempty } scopeCheck :: - Members '[Files, Error ScoperError, NameIdGen] r => + Members '[Files, Error ScoperError, NameIdGen, Reader EntryPoint, PathResolver] r => ParserResult -> InfoTable -> NonEmpty (Module 'Parsed 'ModuleTop) -> @@ -216,13 +217,13 @@ bindLocalModuleSymbol _moduleExportInfo _moduleRefModule = checkImport :: forall r. - Members '[Error ScoperError, State Scope, Reader ScopeParameters, Files, State ScoperState, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen] r => + Members '[Error ScoperError, State Scope, Reader ScopeParameters, Files, State ScoperState, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen, PathResolver] r => Import 'Parsed -> Sem r (Import 'Scoped) checkImport import_@(Import path) = do checkCycle cache <- gets (^. scoperModulesCache . cachedModules) - moduleRef <- maybe (readParseModule path >>= local addImport . checkTopModule) return (cache ^. at path) + moduleRef <- maybe (readScopeModule import_) return (cache ^. at path) let checked = moduleRef ^. moduleRefModule sname = checked ^. modulePath moduleId = sname ^. S.nameId @@ -232,8 +233,6 @@ checkImport import_@(Import path) = do modify (over scoperModules (HashMap.insert moduleId moduleRef')) return (Import checked) where - addImport :: ScopeParameters -> ScopeParameters - addImport = over scopeTopParents (cons import_) checkCycle :: Sem r () checkCycle = do topp <- asks (^. scopeTopParents) @@ -334,7 +333,7 @@ checkQualifiedExpr :: Members '[Error ScoperError, State Scope, State ScoperState, InfoTableBuilder] r => QualifiedName -> Sem r ScopedIden -checkQualifiedExpr q@(QualifiedName (Path p) sym) = do +checkQualifiedExpr q@(QualifiedName (SymbolPath p) sym) = do es <- filter entryIsExpression <$> lookupQualifiedSymbol (toList p, sym) case es of [] -> notInScope @@ -384,25 +383,32 @@ exportScope Scope {..} = do (MultipleExportConflict _scopePath s (e :| es)) ) -readParseModule :: - Members '[Error ScoperError, Reader ScopeParameters, Files, Parser.InfoTableBuilder, NameIdGen] r => +withPath' :: + forall r a. + Members '[PathResolver, Error ScoperError] r => TopModulePath -> - Sem r (Module 'Parsed 'ModuleTop) -readParseModule mp = do - path <- modulePathToFilePath mp + (Path Abs File -> Sem r a) -> + Sem r a +withPath' mp a = withPathFile mp (either err a) + where + err :: PathResolverError -> Sem r a + err = throw . ErrTopModulePath . TopModulePathError mp + +readScopeModule :: + Members '[Error ScoperError, Reader ScopeParameters, Files, Parser.InfoTableBuilder, NameIdGen, PathResolver, State ScoperState, InfoTableBuilder] r => + Import 'Parsed -> + Sem r (ModuleRef'' 'S.NotConcrete 'ModuleTop) +readScopeModule import_ = withPath' (import_ ^. importModule) $ \path -> do txt <- readFile' path pr <- runModuleParser path txt case pr of Left err -> throw (ErrParser (MegaParsecError err)) - Right (tbl, m) -> Parser.mergeTable tbl $> m - -modulePathToFilePath :: - Members '[Reader ScopeParameters, Files] r => - TopModulePath -> - Sem r FilePath -modulePathToFilePath mp = do - ext <- asks (^. scopeFileExtension) - topModulePathToFilePath' (Just ext) mp + Right (tbl, m) -> do + Parser.mergeTable tbl + local addImport (checkTopModule m) + where + addImport :: ScopeParameters -> ScopeParameters + addImport = over scopeTopParents (cons import_) checkOperatorSyntaxDef :: forall r. @@ -510,7 +516,7 @@ createExportsTable ei = foldr (HashSet.insert . getNameId) HashSet.empty (HashMa checkTopModules :: forall r. - Members '[Error ScoperError, Reader ScopeParameters, Files, State ScoperState, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen] r => + Members '[Error ScoperError, Reader ScopeParameters, Files, State ScoperState, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen, PathResolver] r => NonEmpty (Module 'Parsed 'ModuleTop) -> Sem r (NonEmpty (Module 'Scoped 'ModuleTop), HashSet NameId) checkTopModules modules = do @@ -520,14 +526,14 @@ checkTopModules modules = do checkTopModule_ :: forall r. - Members '[Error ScoperError, Reader ScopeParameters, Files, State ScoperState, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen] r => + Members '[Error ScoperError, Reader ScopeParameters, Files, State ScoperState, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen, PathResolver] r => Module 'Parsed 'ModuleTop -> Sem r (Module 'Scoped 'ModuleTop) checkTopModule_ = fmap (^. moduleRefModule) . checkTopModule checkTopModule :: forall r. - Members '[Error ScoperError, Reader ScopeParameters, Files, State ScoperState, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen] r => + Members '[Error ScoperError, Reader ScopeParameters, Files, State ScoperState, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen, PathResolver] r => Module 'Parsed 'ModuleTop -> Sem r (ModuleRef'' 'S.NotConcrete 'ModuleTop) checkTopModule m@(Module path params doc body) = do @@ -536,11 +542,11 @@ checkTopModule m@(Module path params doc body) = do modify (over (scoperModulesCache . cachedModules) (HashMap.insert path r)) return r where - checkPath :: Members '[Files, Reader ScopeParameters, Error ScoperError] s => Sem s () + checkPath :: Members '[Error ScoperError, PathResolver] s => Sem s () checkPath = do - expectedPath <- modulePathToFilePath path - let actualPath = getLoc path ^. intervalFile - unlessM (fromMaybe True <$> equalPaths' expectedPath actualPath) $ + expectedPath <- expectedModulePath path + let actualPath = absFile (getLoc path ^. intervalFile) + unlessM (equalPaths expectedPath actualPath) $ throw ( ErrWrongTopModuleName WrongTopModuleName @@ -598,7 +604,7 @@ withScope ma = do checkModuleBody :: forall r. - Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, Files, Reader LocalVars, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen] r => + Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, Files, Reader LocalVars, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen, PathResolver] r => [Statement 'Parsed] -> Sem r (ExportInfo, [Statement 'Scoped]) checkModuleBody body = do @@ -610,7 +616,7 @@ checkModuleBody body = do checkLocalModule :: forall r. - Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, Files, Reader LocalVars, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen] r => + Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, Files, Reader LocalVars, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen, PathResolver] r => Module 'Parsed 'ModuleLocal -> Sem r (Module 'Scoped 'ModuleLocal) checkLocalModule Module {..} = do @@ -686,7 +692,7 @@ lookupModuleSymbol n = do notInScope = throw (ErrModuleNotInScope (ModuleNotInScope n)) (path, sym) = case n of NameUnqualified s -> ([], s) - NameQualified (QualifiedName (Path p) s) -> (toList p, s) + NameQualified (QualifiedName (SymbolPath p) s) -> (toList p, s) getModuleRef :: SymbolEntry -> Maybe (ModuleRef' 'S.NotConcrete) getModuleRef = \case @@ -706,7 +712,7 @@ getExportInfo modId = do _ :&: ent -> ent ^. moduleExportInfo checkOpenImportModule :: - Members '[Error ScoperError, Reader ScopeParameters, Files, State Scope, State ScoperState, Reader LocalVars, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen] r => + Members '[Error ScoperError, Reader ScopeParameters, Files, State Scope, State ScoperState, Reader LocalVars, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen, PathResolver] r => OpenModule 'Parsed -> Sem r (OpenModule 'Scoped) checkOpenImportModule op @@ -714,7 +720,7 @@ checkOpenImportModule op let moduleNameToTopModulePath :: Name -> TopModulePath moduleNameToTopModulePath = \case NameUnqualified s -> TopModulePath [] s - NameQualified (QualifiedName (Path p) s) -> TopModulePath (toList p) s + NameQualified (QualifiedName (SymbolPath p) s) -> TopModulePath (toList p) s import_ :: Import 'Parsed import_ = Import (moduleNameToTopModulePath (op ^. openModuleName)) in do @@ -783,7 +789,7 @@ checkOpenModuleNoImport OpenModule {..} checkOpenModule :: forall r. - Members '[Error ScoperError, Reader ScopeParameters, Files, State Scope, State ScoperState, Reader LocalVars, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen] r => + Members '[Error ScoperError, Reader ScopeParameters, Files, State Scope, State ScoperState, Reader LocalVars, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen, PathResolver] r => OpenModule 'Parsed -> Sem r (OpenModule 'Scoped) checkOpenModule op @@ -1102,14 +1108,14 @@ checkPatternName n = do Nothing -> PatternScopedVar <$> groupBindLocalVariable sym -- the symbol is a variable where (path, sym) = case n of - NameQualified (QualifiedName (Path p) s) -> (toList p, s) + NameQualified (QualifiedName (SymbolPath p) s) -> (toList p, s) NameUnqualified s -> ([], s) -- check whether the symbol is a constructor in scope getConstructorRef :: Sem r (Maybe ConstructorRef) getConstructorRef = do entries <- mapMaybe getConstructor <$> lookupQualifiedSymbol (path, sym) case entries of - [] -> case Path <$> nonEmpty path of + [] -> case SymbolPath <$> nonEmpty path of Nothing -> return Nothing -- There is no constructor with such a name Just pth -> throw (ErrQualSymNotInScope (QualSymNotInScope (QualifiedName pth sym))) [e] -> return (Just (set (constructorRefName . S.nameConcrete) n e)) -- There is one constructor with such a name @@ -1295,7 +1301,7 @@ checkParsePatternAtom :: checkParsePatternAtom = checkPatternAtom >=> parsePatternAtom checkStatement :: - Members '[Error ScoperError, Reader ScopeParameters, Files, State Scope, State ScoperState, Reader LocalVars, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen] r => + Members '[Error ScoperError, Reader ScopeParameters, Files, State Scope, State ScoperState, Reader LocalVars, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen, PathResolver] r => Statement 'Parsed -> Sem r (Statement 'Scoped) checkStatement s = case s of diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error.hs index 9c9817e6a..df9128865 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error.hs @@ -39,6 +39,7 @@ data ScoperError | ErrAliasBinderPattern AliasBinderPattern | ErrImplicitPatternLeftApplication ImplicitPatternLeftApplication | ErrConstructorExpectedLeftApplication ConstructorExpectedLeftApplication + | ErrTopModulePath TopModulePathError deriving stock (Show) instance ToGenericError ScoperError where @@ -71,3 +72,4 @@ instance ToGenericError ScoperError where ErrAliasBinderPattern e -> genericError e ErrImplicitPatternLeftApplication e -> genericError e ErrConstructorExpectedLeftApplication e -> genericError e + ErrTopModulePath e -> genericError e diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs index b58deaf13..9beb6d37c 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs @@ -13,11 +13,31 @@ import Juvix.Compiler.Concrete.Data.ScopedName qualified as S import Juvix.Compiler.Concrete.Language import Juvix.Compiler.Concrete.Language qualified as L import Juvix.Compiler.Concrete.Pretty.Options (Options, fromGenericOptions) +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error.Pretty import Juvix.Data.CodeAnn import Juvix.Parser.Error qualified as Parser import Juvix.Prelude +data TopModulePathError = TopModulePathError + { _topModulePathErrorPath :: TopModulePath, + _topModulePathError :: PathResolverError + } + deriving stock (Show) + +instance ToGenericError TopModulePathError where + genericError TopModulePathError {..} = do + let msg = ppCodeAnn _topModulePathError + return + GenericError + { _genericErrorLoc = i, + _genericErrorMessage = AnsiText msg, + _genericErrorIntervals = [i] + } + where + i :: Interval + i = getLoc _topModulePathErrorPath + data MultipleDeclarations = MultipleDeclarations { _multipleDeclEntry :: SymbolEntry, _multipleDeclSymbol :: Text, @@ -406,8 +426,8 @@ instance ToGenericError UnusedOperatorDef where <> ppCode opts' _unusedOperatorDef data WrongTopModuleName = WrongTopModuleName - { _wrongTopModuleNameExpectedPath :: FilePath, - _wrongTopModuleNameActualPath :: FilePath, + { _wrongTopModuleNameExpectedPath :: Path Abs File, + _wrongTopModuleNameActualPath :: Path Abs File, _wrongTopModuleNameActualName :: TopModulePath } deriving stock (Show) diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs index 174d1f99f..25808f416 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs @@ -34,7 +34,7 @@ fromSource e = mapError (JuvixError @ParserError) $ do goFile :: forall r. Members '[Files, Error ParserError, InfoTableBuilder, NameIdGen] r => - FilePath -> + Path Abs File -> Sem r (Module 'Parsed 'ModuleTop) goFile fileName = do input <- getFileContents fileName @@ -43,7 +43,7 @@ fromSource e = mapError (JuvixError @ParserError) $ do Left er -> throw er Right (tbl, m) -> mergeTable tbl $> m where - getFileContents :: FilePath -> Sem r Text + getFileContents :: Path Abs File -> Sem r Text getFileContents fp | fp == e ^. mainModulePath, Just txt <- e ^. entryPointStdin = @@ -65,12 +65,12 @@ expressionFromTextSource fp txt = mapError (JuvixError @ParserError) $ do -- | The fileName is only used for reporting errors. It is safe to pass -- an empty string. -runModuleParser :: Members '[NameIdGen] r => FilePath -> Text -> Sem r (Either ParserError (InfoTable, Module 'Parsed 'ModuleTop)) +runModuleParser :: Members '[NameIdGen] r => Path Abs File -> Text -> Sem r (Either ParserError (InfoTable, Module 'Parsed 'ModuleTop)) runModuleParser fileName input = do m <- runInfoTableBuilder $ evalState (Nothing @(Judoc 'Parsed)) $ - P.runParserT topModuleDef fileName input + P.runParserT topModuleDef (toFilePath fileName) input case m of (_, Left err) -> return (Left (ParserError err)) (tbl, Right r) -> return (Right (tbl, r)) @@ -118,7 +118,7 @@ name :: Members '[InfoTableBuilder, JudocStash, NameIdGen] r => ParsecS r Name name = do parts <- dottedSymbol return $ case nonEmptyUnsnoc parts of - (Just p, n) -> NameQualified (QualifiedName (Path p) n) + (Just p, n) -> NameQualified (QualifiedName (SymbolPath p) n) (Nothing, n) -> NameUnqualified n mkTopModulePath :: NonEmpty Symbol -> TopModulePath diff --git a/src/Juvix/Compiler/Core/Info.hs b/src/Juvix/Compiler/Core/Info.hs index 8ed52a849..02aa9ac01 100644 --- a/src/Juvix/Compiler/Core/Info.hs +++ b/src/Juvix/Compiler/Core/Info.hs @@ -4,7 +4,7 @@ module Juvix.Compiler.Core.Info where import Data.Dynamic import Data.HashMap.Strict qualified as HashMap -import Juvix.Prelude +import Juvix.Prelude hiding (insert) class Typeable a => IsInfo a @@ -21,7 +21,7 @@ empty :: Info empty = Info HashMap.empty singleton :: forall a. IsInfo a => a -> Info -singleton a = Juvix.Compiler.Core.Info.insert a Juvix.Compiler.Core.Info.empty +singleton a = insert a mempty member :: forall a. IsInfo a => Key a -> Info -> Bool member k i = HashMap.member (typeRep k) (i ^. infoMap) diff --git a/src/Juvix/Compiler/Internal/Translation/FromAbstract/Analysis/Termination/Data/FunctionCall.hs b/src/Juvix/Compiler/Internal/Translation/FromAbstract/Analysis/Termination/Data/FunctionCall.hs index 31cd6d05e..01de9c159 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromAbstract/Analysis/Termination/Data/FunctionCall.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromAbstract/Analysis/Termination/Data/FunctionCall.hs @@ -17,7 +17,7 @@ data FunCall = FunCall } newtype CallRow = CallRow - { _callRow :: Maybe (Int, Rel') + { _callRow :: Maybe (Int, SizeRel') } deriving stock (Eq, Show, Generic) diff --git a/src/Juvix/Compiler/Internal/Translation/FromAbstract/Analysis/Termination/Data/Graph.hs b/src/Juvix/Compiler/Internal/Translation/FromAbstract/Analysis/Termination/Data/Graph.hs index 68cfbef4a..e7f9b9487 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromAbstract/Analysis/Termination/Data/Graph.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromAbstract/Analysis/Termination/Data/Graph.hs @@ -28,7 +28,7 @@ data ReflexiveEdge = ReflexiveEdge data RecursiveBehaviour = RecursiveBehaviour { _recursiveBehaviourFun :: FunctionName, - _recursiveBehaviourMatrix :: [[Rel]] + _recursiveBehaviourMatrix :: [[SizeRel]] } deriving stock (Show) diff --git a/src/Juvix/Compiler/Internal/Translation/FromAbstract/Analysis/Termination/Data/SizeRelation.hs b/src/Juvix/Compiler/Internal/Translation/FromAbstract/Analysis/Termination/Data/SizeRelation.hs index 30656c68f..cdfb59b61 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromAbstract/Analysis/Termination/Data/SizeRelation.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromAbstract/Analysis/Termination/Data/SizeRelation.hs @@ -3,33 +3,33 @@ module Juvix.Compiler.Internal.Translation.FromAbstract.Analysis.Termination.Dat import Juvix.Prelude import Prettyprinter -data Rel - = RJust Rel' +data SizeRel + = RJust SizeRel' | RNothing deriving stock (Eq, Show, Generic) -data Rel' +data SizeRel' = REq | RLe deriving stock (Eq, Show, Generic) -instance Hashable Rel' +instance Hashable SizeRel' -instance Hashable Rel +instance Hashable SizeRel -toRel :: Rel' -> Rel -toRel = RJust +toSizeRel :: SizeRel' -> SizeRel +toSizeRel = RJust -mul' :: Rel' -> Rel' -> Rel' +mul' :: SizeRel' -> SizeRel' -> SizeRel' mul' REq a = a mul' RLe _ = RLe -instance Pretty Rel where +instance Pretty SizeRel where pretty r = case r of RJust r' -> pretty r' RNothing -> pretty ("?" :: Text) -instance Pretty Rel' where +instance Pretty SizeRel' where pretty r = case r of REq -> pretty ("=" :: Text) RLe -> pretty ("≺" :: Text) diff --git a/src/Juvix/Compiler/Internal/Translation/FromAbstract/Analysis/Termination/LexOrder.hs b/src/Juvix/Compiler/Internal/Translation/FromAbstract/Analysis/Termination/LexOrder.hs index dfb9d6b95..86a708453 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromAbstract/Analysis/Termination/LexOrder.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromAbstract/Analysis/Termination/LexOrder.hs @@ -115,10 +115,10 @@ reflexiveEdges (CompleteCallGraph es) = mapMaybe reflexive (toList es) Just $ ReflexiveEdge (e ^. edgeFrom) (e ^. edgeMatrices) | otherwise = Nothing -callMatrixDiag :: CallMatrix -> [Rel] +callMatrixDiag :: CallMatrix -> [SizeRel] callMatrixDiag m = [col i r | (i, r) <- zip [0 :: Int ..] m] where - col :: Int -> CallRow -> Rel + col :: Int -> CallRow -> SizeRel col i (CallRow row) = case row of Nothing -> RNothing Just (j, r') @@ -134,7 +134,7 @@ recursiveBehaviour re = findOrder :: RecursiveBehaviour -> Maybe LexOrder findOrder rb = LexOrder <$> listToMaybe (mapMaybe (isLexOrder >=> nonEmpty) allPerms) where - b0 :: [[Rel]] + b0 :: [[SizeRel]] b0 = rb ^. recursiveBehaviourMatrix indexed = map (zip [0 :: Int ..] . take minLength) b0 @@ -144,13 +144,13 @@ findOrder rb = LexOrder <$> listToMaybe (mapMaybe (isLexOrder >=> nonEmpty) allP startB = removeUselessColumns indexed -- removes columns that don't have at least one ≺ in them - removeUselessColumns :: [[(Int, Rel)]] -> [[(Int, Rel)]] + removeUselessColumns :: [[(Int, SizeRel)]] -> [[(Int, SizeRel)]] removeUselessColumns = transpose . filter (any (isLess . snd)) . transpose isLexOrder :: [Int] -> Maybe [Int] isLexOrder = go startB where - go :: [[(Int, Rel)]] -> [Int] -> Maybe [Int] + go :: [[(Int, SizeRel)]] -> [Int] -> Maybe [Int] go [] _ = Just [] go b perm = case perm of [] -> error "The permutation should have one element at least!" diff --git a/src/Juvix/Compiler/Pipeline.hs b/src/Juvix/Compiler/Pipeline.hs index 187c1fbba..a5b9e0394 100644 --- a/src/Juvix/Compiler/Pipeline.hs +++ b/src/Juvix/Compiler/Pipeline.hs @@ -1,6 +1,7 @@ module Juvix.Compiler.Pipeline ( module Juvix.Compiler.Pipeline, module Juvix.Compiler.Pipeline.EntryPoint, + module Juvix.Compiler.Pipeline.Artifacts, module Juvix.Compiler.Pipeline.ExpressionContext, ) where @@ -12,10 +13,12 @@ import Juvix.Compiler.Backend.C qualified as C import Juvix.Compiler.Builtins import Juvix.Compiler.Concrete qualified as Concrete import Juvix.Compiler.Concrete.Translation.FromParsed qualified as Scoper +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser import Juvix.Compiler.Core.Language qualified as Core import Juvix.Compiler.Core.Translation qualified as Core import Juvix.Compiler.Internal qualified as Internal +import Juvix.Compiler.Pipeline.Artifacts import Juvix.Compiler.Pipeline.EntryPoint import Juvix.Compiler.Pipeline.ExpressionContext import Juvix.Compiler.Pipeline.Setup @@ -23,7 +26,7 @@ import Juvix.Compiler.Reg.Data.InfoTable qualified as Reg import Juvix.Compiler.Reg.Translation.FromAsm qualified as Reg import Juvix.Prelude -type PipelineEff = '[Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError, Embed IO] +type PipelineEff = '[PathResolver, Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError, Embed IO] arityCheckExpression :: Members '[Error JuvixError, NameIdGen, Builtins] r => @@ -108,49 +111,49 @@ compile :: compile = typecheck >=> C.fromInternal upToParsing :: - Members '[Reader EntryPoint, Files, Error JuvixError, NameIdGen] r => + Members '[Reader EntryPoint, Files, Error JuvixError, NameIdGen, PathResolver] r => Sem r Parser.ParserResult upToParsing = entrySetup >>= Parser.fromSource upToScoping :: - Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError] r => + Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, PathResolver] r => Sem r Scoper.ScoperResult upToScoping = upToParsing >>= Scoper.fromParsed upToAbstract :: - Members '[Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError] r => + Members '[Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError, PathResolver] r => Sem r Abstract.AbstractResult upToAbstract = upToScoping >>= Abstract.fromConcrete upToInternal :: - Members '[Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError] r => + Members '[Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError, PathResolver] r => Sem r Internal.InternalResult upToInternal = upToAbstract >>= Internal.fromAbstract upToInternalArity :: - Members '[Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError] r => + Members '[Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError, PathResolver] r => Sem r Internal.InternalArityResult upToInternalArity = upToInternal >>= Internal.arityChecking upToInternalTyped :: - Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins] r => + Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, PathResolver] r => Sem r Internal.InternalTypedResult upToInternalTyped = upToInternalArity >>= Internal.typeChecking upToInternalReachability :: - Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins] r => + Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, PathResolver] r => Sem r Internal.InternalTypedResult upToInternalReachability = Internal.filterUnreachable <$> upToInternalTyped upToCore :: - Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins] r => + Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, PathResolver] r => Sem r Core.CoreResult upToCore = upToInternalReachability >>= Core.fromInternal upToMiniC :: - Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins] r => + Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, PathResolver] r => Sem r C.MiniCResult upToMiniC = upToInternalReachability >>= C.fromInternal @@ -168,17 +171,28 @@ regToMiniC lims = return . C.fromReg lims -- Run pipeline -------------------------------------------------------------------------------- -runIOEither :: forall a. BuiltinsState -> EntryPoint -> Sem PipelineEff a -> IO (Either JuvixError (BuiltinsState, a)) +runIOEither :: forall a. BuiltinsState -> EntryPoint -> Sem PipelineEff a -> IO (Either JuvixError (Artifacts, a)) runIOEither builtinsState entry = runM . runError + . fmap makeArtifacts . runBuiltins builtinsState . runNameIdGen . mapError (JuvixError @FilesError) - . runFilesIO (entry ^. entryPointRoot) + . runFilesIO . runReader entry + . runPathResolverPipe + where + makeArtifacts :: (BuiltinsState, (ResolverState, any)) -> (Artifacts, any) + makeArtifacts (builtins, (resolver, a)) = + ( Artifacts + { _artifactBuiltins = builtins, + _artifactResolver = resolver + }, + a + ) -runIO :: BuiltinsState -> GenericOptions -> EntryPoint -> Sem PipelineEff a -> IO (BuiltinsState, a) +runIO :: BuiltinsState -> GenericOptions -> EntryPoint -> Sem PipelineEff a -> IO (Artifacts, a) runIO builtinsState opts entry = runIOEither builtinsState entry >=> mayThrow where mayThrow :: Either JuvixError r -> IO r @@ -186,5 +200,5 @@ runIO builtinsState opts entry = runIOEither builtinsState entry >=> mayThrow Left err -> runM $ runReader opts $ printErrorAnsiSafe err >> embed exitFailure Right r -> return r -runIO' :: BuiltinsState -> EntryPoint -> Sem PipelineEff a -> IO (BuiltinsState, a) +runIO' :: BuiltinsState -> EntryPoint -> Sem PipelineEff a -> IO (Artifacts, a) runIO' builtinsState = runIO builtinsState defaultGenericOptions diff --git a/src/Juvix/Compiler/Pipeline/Artifacts.hs b/src/Juvix/Compiler/Pipeline/Artifacts.hs new file mode 100644 index 000000000..6728c2bf0 --- /dev/null +++ b/src/Juvix/Compiler/Pipeline/Artifacts.hs @@ -0,0 +1,13 @@ +-- | Stuff that is generated when the pipeline is run +module Juvix.Compiler.Pipeline.Artifacts where + +import Juvix.Compiler.Builtins +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver +import Juvix.Prelude + +data Artifacts = Artifacts + { _artifactBuiltins :: BuiltinsState, + _artifactResolver :: ResolverState + } + +makeLenses ''Artifacts diff --git a/src/Juvix/Compiler/Pipeline/EntryPoint.hs b/src/Juvix/Compiler/Pipeline/EntryPoint.hs index 2729eed62..5f5ae4f40 100644 --- a/src/Juvix/Compiler/Pipeline/EntryPoint.hs +++ b/src/Juvix/Compiler/Pipeline/EntryPoint.hs @@ -5,41 +5,45 @@ module Juvix.Compiler.Pipeline.EntryPoint where import Juvix.Compiler.Pipeline.Package -import Juvix.Extra.Paths (juvixStdlibDir) import Juvix.Prelude -- | The head of _entryModulePaths is assumed to be the Main module data EntryPoint = EntryPoint - { _entryPointRoot :: FilePath, + { _entryPointRoot :: Path Abs Dir, + -- | initial root for the path resolver. Usually it should be equal to + -- _entryPointRoot. Used only for the command `juvix repl`. + _entryPointResolverRoot :: Path Abs Dir, _entryPointNoTermination :: Bool, _entryPointNoPositivity :: Bool, _entryPointNoStdlib :: Bool, - _entryPointStdlibPath :: Maybe FilePath, _entryPointPackage :: Package, _entryPointStdin :: Maybe Text, _entryPointGenericOptions :: GenericOptions, - _entryPointModulePaths :: NonEmpty FilePath + _entryPointModulePaths :: NonEmpty (Path Abs File) } deriving stock (Eq, Show) -defaultStdlibPath :: FilePath -> FilePath -defaultStdlibPath root = root juvixStdlibDir +makeLenses ''EntryPoint -defaultEntryPoint :: FilePath -> EntryPoint -defaultEntryPoint mainFile = +defaultEntryPoint :: Path Abs Dir -> Path Abs File -> EntryPoint +defaultEntryPoint root mainFile = EntryPoint - { _entryPointRoot = ".", + { _entryPointRoot = root, + _entryPointResolverRoot = root, _entryPointNoTermination = False, _entryPointNoPositivity = False, _entryPointNoStdlib = False, - _entryPointStdlibPath = Nothing, _entryPointStdin = Nothing, - _entryPointPackage = emptyPackage, + _entryPointPackage = defaultPackage root, _entryPointGenericOptions = defaultGenericOptions, _entryPointModulePaths = pure mainFile } -makeLenses ''EntryPoint - -mainModulePath :: Lens' EntryPoint FilePath +mainModulePath :: Lens' EntryPoint (Path Abs File) mainModulePath = entryPointModulePaths . _head1 + +entryPointFromPackage :: Path Abs Dir -> Path Abs File -> Package -> EntryPoint +entryPointFromPackage root mainFile pkg = + (defaultEntryPoint root mainFile) + { _entryPointPackage = pkg + } diff --git a/src/Juvix/Compiler/Pipeline/Package.hs b/src/Juvix/Compiler/Pipeline/Package.hs index d8b4469e3..d4e072b76 100644 --- a/src/Juvix/Compiler/Pipeline/Package.hs +++ b/src/Juvix/Compiler/Pipeline/Package.hs @@ -1,40 +1,153 @@ -module Juvix.Compiler.Pipeline.Package where +module Juvix.Compiler.Pipeline.Package + ( module Juvix.Compiler.Pipeline.Package.Dependency, + RawPackage, + Package, + Package' (..), + defaultPackage, + packageName, + packageVersion, + packageDependencies, + rawPackage, + emptyPackage, + readPackage, + readPackageIO, + ) +where +import Data.Aeson (genericToEncoding) +import Data.Aeson.BetterErrors import Data.Aeson.TH +import Data.Kind qualified as GHC +import Data.Versions +import Data.Yaml +import Juvix.Compiler.Pipeline.Package.Dependency +import Juvix.Extra.Paths import Juvix.Prelude import Lens.Micro.Platform qualified as Lens -data Package = Package - { _packageName :: Maybe Text, - _packageVersion :: Maybe Text +type NameType :: IsProcessed -> GHC.Type +type family NameType s = res | res -> s where + NameType 'Raw = Maybe Text + NameType 'Processed = Text + +type VersionType :: IsProcessed -> GHC.Type +type family VersionType s = res | res -> s where + VersionType 'Raw = Maybe Text + VersionType 'Processed = Versioning + +type DependenciesType :: IsProcessed -> GHC.Type +type family DependenciesType s = res | res -> s where + DependenciesType 'Raw = Maybe [RawDependency] + DependenciesType 'Processed = [Dependency] + +data Package' (s :: IsProcessed) = Package + { _packageName :: NameType s, + _packageVersion :: VersionType s, + _packageDependencies :: DependenciesType s } - deriving stock (Eq, Show, Generic) + deriving stock (Generic) -$( deriveJSON - defaultOptions - { fieldLabelModifier = over Lens._head toLower . dropPrefix "_package", - rejectUnknownFields = True - } - ''Package - ) +makeLenses ''Package' +type Package = Package' 'Processed + +type RawPackage = Package' 'Raw + +deriving stock instance Eq RawPackage + +deriving stock instance Eq Package + +deriving stock instance Show RawPackage + +deriving stock instance Show Package + +instance ToJSON RawPackage where + toEncoding = genericToEncoding options + where + options :: Options + options = + defaultOptions + { fieldLabelModifier = over Lens._head toLower . dropPrefix "_package", + rejectUnknownFields = True + } + +-- | TODO: is it a good idea to return the empty package if it fails to parse? +instance FromJSON RawPackage where + parseJSON = toAesonParser' (fromMaybe rawDefaultPackage <$> p) + where + p :: Parse' (Maybe RawPackage) + p = perhaps $ do + _packageName <- keyMay "name" asText + _packageVersion <- keyMay "version" asText + _packageDependencies <- keyMay "dependencies" fromAesonParser + return Package {..} + +-- | Has the implicit stdlib dependency +rawDefaultPackage :: Package' 'Raw +rawDefaultPackage = + Package + { _packageName = Nothing, + _packageVersion = Nothing, + _packageDependencies = Nothing + } + +-- | Has the implicit stdlib dependency +defaultPackage :: Path Abs Dir -> Package +defaultPackage r = fromRight impossible . run . runError @Text . processPackage r $ rawDefaultPackage + +-- | Has no dependencies emptyPackage :: Package emptyPackage = Package - { _packageName = Nothing, - _packageVersion = Nothing + { _packageName = defaultPackageName, + _packageVersion = Ideal defaultVersion, + _packageDependencies = [] } -makeLenses ''Package +rawPackage :: Package -> RawPackage +rawPackage pkg = + Package + { _packageName = Just (pkg ^. packageName), + _packageVersion = Just (prettyV (pkg ^. packageVersion)), + _packageDependencies = Just (map rawDependency (pkg ^. packageDependencies)) + } -packageName' :: Getting r Package Text -packageName' f p = (\(Const r) -> Const r) (f name) +processPackage :: forall r. Members '[Error Text] r => Path Abs Dir -> Package' 'Raw -> Sem r Package +processPackage dir pkg = do + let _packageName = fromMaybe defaultPackageName (pkg ^. packageName) + _packageDependencies = + let rawDeps :: [RawDependency] = fromMaybe [stdlibDefaultDep] (pkg ^. packageDependencies) + in map (processDependency dir) rawDeps + _packageVersion <- getVersion + return Package {..} where - name :: Text - name = fromMaybe "my-package" (p ^. packageName) + getVersion :: Sem r Versioning + getVersion = case pkg ^. packageVersion of + Nothing -> return (Ideal defaultVersion) + Just ver -> case versioning ver of + Right v -> return v + Left err -> throw (pack (errorBundlePretty err)) -packageVersion' :: Getting r Package Text -packageVersion' f p = (\(Const r) -> Const r) (f name) +defaultPackageName :: Text +defaultPackageName = "my-project" + +defaultVersion :: SemVer +defaultVersion = SemVer 0 0 0 [] Nothing + +-- | given some directory d it tries to read the file d/juvix.yaml and parse its contents +readPackage :: forall r. Members '[Files, Error Text] r => Path Abs Dir -> Sem r Package +readPackage adir = do + bs <- readFileBS' yamlPath + either (throw . pack . prettyPrintParseException) (processPackage adir) (decodeEither' bs) where - name :: Text - name = fromMaybe "no version" (p ^. packageVersion) + yamlPath = adir juvixYamlFile + +readPackageIO :: Path Abs Dir -> IO Package +readPackageIO dir = do + let x :: Sem '[Error Text, Files, Embed IO] Package + x = readPackage dir + m <- runM $ runError $ runFilesIO (runError x) + case m of + Left err -> runM (runReader defaultGenericOptions (printErrorAnsiSafe err)) >> exitFailure + Right (Left err) -> putStrLn err >> exitFailure + Right (Right r) -> return r diff --git a/src/Juvix/Compiler/Pipeline/Package/Dependency.hs b/src/Juvix/Compiler/Pipeline/Package/Dependency.hs new file mode 100644 index 000000000..9496c7005 --- /dev/null +++ b/src/Juvix/Compiler/Pipeline/Package/Dependency.hs @@ -0,0 +1,65 @@ +module Juvix.Compiler.Pipeline.Package.Dependency + ( RawDependency, + Dependency, + Dependency' (..), + processDependency, + stdlibDefaultDep, + dependencyPath, + rawDependency, + ) +where + +-- import Lens.Micro.Platform qualified as Lens +import Data.Aeson.BetterErrors +import Data.Kind qualified as GHC +import Data.Yaml +import Juvix.Extra.Paths +import Juvix.Prelude + +type PathType :: IsProcessed -> GHC.Type +type family PathType s = res | res -> s where + PathType 'Raw = SomeBase Dir + PathType 'Processed = Path Abs Dir + +-- | dependencies paths are canonicalized just after reading the package +newtype Dependency' (s :: IsProcessed) = Dependency + { _dependencyPath :: PathType s + } + deriving stock (Generic) + +type RawDependency = Dependency' 'Raw + +type Dependency = Dependency' 'Processed + +deriving stock instance Eq RawDependency + +deriving stock instance Eq Dependency + +deriving stock instance Show RawDependency + +deriving stock instance Show Dependency + +instance ToJSON RawDependency where + toEncoding (Dependency p) = toEncoding (fromSomeDir p) + +instance FromJSON RawDependency where + parseJSON = toAesonParser id (Dependency <$> p) + where + p :: Parse Text (SomeBase Dir) + p = do + str <- asString + let dir = parseSomeDir str + maybe (throwCustomError ("failed to parse directory: " <> pack str)) pure dir + +rawDependency :: Dependency -> RawDependency +rawDependency (Dependency p) = Dependency (Abs p) + +processDependency :: Path Abs Dir -> RawDependency -> Dependency +processDependency r (Dependency p) = case p of + Rel a -> Dependency (r a) + Abs a -> Dependency a + +stdlibDefaultDep :: RawDependency +stdlibDefaultDep = Dependency (Rel juvixStdlibDir) + +makeLenses ''Dependency' diff --git a/src/Juvix/Compiler/Pipeline/Setup.hs b/src/Juvix/Compiler/Pipeline/Setup.hs index 3444ac50f..031f3e5e6 100644 --- a/src/Juvix/Compiler/Pipeline/Setup.hs +++ b/src/Juvix/Compiler/Pipeline/Setup.hs @@ -1,25 +1,34 @@ module Juvix.Compiler.Pipeline.Setup where +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver import Juvix.Compiler.Pipeline.EntryPoint +import Juvix.Extra.Paths +import Juvix.Extra.Stdlib import Juvix.Prelude entrySetup :: - Members '[Reader EntryPoint, Files] r => + Members '[Reader EntryPoint, Files, PathResolver] r => Sem r EntryPoint entrySetup = do e <- ask - unless (e ^. entryPointNoStdlib) setupStdlib + registerDependencies return e -setupStdlib :: - Members '[Reader EntryPoint, Files] r => - Sem r () -setupStdlib = do +registerDependencies :: Members '[Reader EntryPoint, PathResolver] r => Sem r () +registerDependencies = do e <- ask - stdlibRootPath <- case e ^. entryPointStdlibPath of - Nothing -> do - let d = defaultStdlibPath (e ^. entryPointRoot) - updateStdlib d + addDependency (Just e) (Dependency (e ^. entryPointRoot)) + +stdlibDep :: + forall r. + Members '[Reader EntryPoint, Files, PathResolver] r => + Sem r Dependency +stdlibDep = Dependency <$> getRoot + where + getRoot :: Sem r (Path Abs Dir) + getRoot = do + e <- ask + let d :: Path Abs Dir + d = defaultStdlibPath (e ^. entryPointRoot) + runReader d updateStdlib return d - Just p -> return p - registerStdlib stdlibRootPath diff --git a/src/Juvix/Data.hs b/src/Juvix/Data.hs index a828c20f6..bf19ace51 100644 --- a/src/Juvix/Data.hs +++ b/src/Juvix/Data.hs @@ -8,6 +8,8 @@ module Juvix.Data module Juvix.Data.IsImplicit, module Juvix.Data.Loc, module Juvix.Data.NameId, + module Juvix.Data.Processed, + module Juvix.Data.Uid, module Juvix.Data.Universe, module Juvix.Data.Usage, module Juvix.Data.Wildcard, @@ -26,6 +28,8 @@ import Juvix.Data.Hole import Juvix.Data.IsImplicit import Juvix.Data.Loc import Juvix.Data.NameId qualified +import Juvix.Data.Processed +import Juvix.Data.Uid import Juvix.Data.Universe import Juvix.Data.Usage import Juvix.Data.Wildcard diff --git a/src/Juvix/Data/CodeAnn.hs b/src/Juvix/Data/CodeAnn.hs index f95f5a162..07d3db9a0 100644 --- a/src/Juvix/Data/CodeAnn.hs +++ b/src/Juvix/Data/CodeAnn.hs @@ -42,6 +42,13 @@ stylize a = case a of AnnDef {} -> mempty AnnRef {} -> mempty +class PrettyCodeAnn a where + ppCodeAnn :: a -> Doc CodeAnn + +instance HasAnsiBackend (Doc CodeAnn) where + toAnsiDoc = fmap stylize + toAnsiStream = fmap stylize . layoutPretty defaultLayoutOptions + -- | for builtin stuff primitive :: Text -> Doc Ann primitive = annotate (AnnKind KNameAxiom) . pretty diff --git a/src/Juvix/Data/Effect/Files.hs b/src/Juvix/Data/Effect/Files.hs index 077cc3800..db014a544 100644 --- a/src/Juvix/Data/Effect/Files.hs +++ b/src/Juvix/Data/Effect/Files.hs @@ -3,10 +3,63 @@ module Juvix.Data.Effect.Files module Juvix.Data.Effect.Files.Base, module Juvix.Data.Effect.Files.Pure, module Juvix.Data.Effect.Files.IO, + module Juvix.Data.Effect.Files, ) where +import Data.HashSet qualified as HashSet import Juvix.Data.Effect.Files.Base import Juvix.Data.Effect.Files.Error import Juvix.Data.Effect.Files.IO import Juvix.Data.Effect.Files.Pure (runFilesPure) +import Juvix.Prelude.Base +import Juvix.Prelude.Path + +-- | for now we only check for string equality +equalPaths :: Path Abs File -> Path Abs File -> Sem r Bool +equalPaths a b = return (a == b) + +walkDirRelAccum :: + forall acc r. + Member Files r => + (Path Abs Dir -> [Path Rel Dir] -> [Path Rel File] -> acc -> Sem r (acc, Recurse Rel)) -> + Path Abs Dir -> + acc -> + Sem r acc +walkDirRelAccum handler topdir' ini = execState ini (walkDirRel helper topdir') + where + helper :: Path Abs Dir -> [Path Rel Dir] -> [Path Rel File] -> Sem (State acc ': r) (Recurse Rel) + helper cd dirs files = do + (acc', r) <- get >>= raise . handler cd dirs files + put acc' + return r + +walkDirRel :: + forall r. + Member Files r => + (Path Abs Dir -> [Path Rel Dir] -> [Path Rel File] -> Sem r (Recurse Rel)) -> + Path Abs Dir -> + Sem r () +walkDirRel handler topdir = do + let walkAvoidLoop :: Path Rel Dir -> Sem (State (HashSet Uid) ': r) () + walkAvoidLoop curdir = + unlessM (checkLoop (topdir curdir)) $ + walktree curdir + walktree :: Path Rel Dir -> Sem (State (HashSet Uid) ': r) () + walktree curdir = do + let fullDir :: Path Abs Dir = topdir curdir + (subdirs, files) <- listDirRel fullDir + action <- raise (handler fullDir subdirs files) + case action of + RecurseNever -> return () + RecurseFilter fi -> + let ds = map (curdir ) (filter fi subdirs) + in mapM_ walkAvoidLoop ds + checkLoop :: Path Abs Dir -> Sem (State (HashSet Uid) ': r) Bool + checkLoop dir = do + visited <- get + ufid <- pathUid dir + if + | HashSet.member ufid visited -> return True + | otherwise -> modify' (HashSet.insert ufid) $> False + evalState mempty (walkAvoidLoop $(mkRelDir ".")) diff --git a/src/Juvix/Data/Effect/Files/Base.hs b/src/Juvix/Data/Effect/Files/Base.hs index df2e9f381..5a3e78d57 100644 --- a/src/Juvix/Data/Effect/Files/Base.hs +++ b/src/Juvix/Data/Effect/Files/Base.hs @@ -1,10 +1,12 @@ module Juvix.Data.Effect.Files.Base ( module Juvix.Data.Effect.Files.Base, module Juvix.Data.Effect.Files.Error, + module Juvix.Data.Uid, ) where import Juvix.Data.Effect.Files.Error +import Juvix.Data.Uid import Juvix.Prelude.Base import Path @@ -14,31 +16,23 @@ data RecursorArgs = RecursorArgs _recFiles :: [Path Rel File] } +data Recurse r + = RecurseNever + | RecurseFilter (Path r Dir -> Bool) + makeLenses ''RecursorArgs data Files m a where - ReadFile' :: FilePath -> Files m Text - ReadFileBS' :: FilePath -> Files m ByteString - FileExists' :: FilePath -> Files m Bool - EqualPaths' :: FilePath -> FilePath -> Files m (Maybe Bool) - GetAbsPath :: FilePath -> Files m FilePath - CanonicalizePath' :: FilePath -> Files m FilePath - RegisterStdlib :: FilePath -> Files m () - UpdateStdlib :: FilePath -> Files m () + EnsureDir' :: Path Abs Dir -> Files m () + DirectoryExists' :: Path Abs Dir -> Files m Bool + FileExists' :: Path Abs File -> Files m Bool + GetDirAbsPath :: Path Rel Dir -> Files m (Path Abs Dir) + ListDirRel :: Path Abs Dir -> Files m ([Path Rel Dir], [Path Rel File]) + PathUid :: Path Abs b -> Files m Uid + ReadFile' :: Path Abs File -> Files m Text + ReadFileBS' :: Path Abs File -> Files m ByteString + RemoveDirectoryRecursive' :: Path Abs Dir -> Files m () + WriteFile' :: Path Abs File -> Text -> Files m () + WriteFileBS :: Path Abs File -> ByteString -> Files m () makeSem ''Files - -data StdlibState = StdlibState - { _stdlibRoot :: FilePath, - _stdlibFilePaths :: HashSet FilePath - } - -newtype FilesState = FilesState - { _stdlibState :: Maybe StdlibState - } - -makeLenses ''FilesState -makeLenses ''StdlibState - -initState :: FilesState -initState = FilesState Nothing diff --git a/src/Juvix/Data/Effect/Files/Error.hs b/src/Juvix/Data/Effect/Files/Error.hs index 554f7b20a..ae3c047b6 100644 --- a/src/Juvix/Data/Effect/Files/Error.hs +++ b/src/Juvix/Data/Effect/Files/Error.hs @@ -5,7 +5,8 @@ import Juvix.Data.Loc import Juvix.Prelude.Base import Juvix.Prelude.Pretty -data FilesErrorCause = StdlibConflict +data FilesErrorCause + = StdlibConflict deriving stock (Show) data FilesError = FilesError diff --git a/src/Juvix/Data/Effect/Files/IO.hs b/src/Juvix/Data/Effect/Files/IO.hs index 8c6f8d51b..fa08e3595 100644 --- a/src/Juvix/Data/Effect/Files/IO.hs +++ b/src/Juvix/Data/Effect/Files/IO.hs @@ -5,89 +5,34 @@ module Juvix.Data.Effect.Files.IO where import Data.ByteString qualified as ByteString -import Data.HashSet qualified as HashSet import Juvix.Data.Effect.Files.Base -import Juvix.Extra.Stdlib qualified as Stdlib import Juvix.Prelude.Base +import Juvix.Prelude.Path +import Path.IO qualified as Path +import System.Posix.Types qualified as P +import System.PosixCompat.Files qualified as P --- | Try to resolve a filepath `p` to a path within standard library. --- --- When `p` is not a member of the standard library or no stanard library is --- registered, resolve `p` to an absolute path based at `rootPath` instead. --- --- This function throws an error if `p` is a member of the standard library and --- also present within `rootPath`. -stdlibOrFile :: - forall r. - Members '[Embed IO, Error FilesError] r => - FilePath -> - FilePath -> - Maybe StdlibState -> - Sem r FilePath -stdlibOrFile p rootPath m = case m of - Nothing -> return (rootPath p) - Just s - | HashSet.member (normalise p) (s ^. stdlibFilePaths) -> - ifM - isConflict - ( throw - FilesError - { _filesErrorPath = pAbsPath, - _filesErrorCause = StdlibConflict - } - ) - (return (s ^. stdlibRoot p)) - | otherwise -> return pAbsPath - where - pAbsPath :: FilePath - pAbsPath = rootPath p - - isConflict :: Sem r Bool - isConflict = do - cRootPath <- embed (canonicalizePath rootPath) - cStdlibPath <- embed (canonicalizePath (s ^. stdlibRoot)) - andM [return (cRootPath /= cStdlibPath), embed (doesFileExist pAbsPath)] - -runFilesIO' :: - forall r a r'. - (r' ~ Embed IO : State FilesState ': Error FilesError ': r) => - FilePath -> +runFilesIO :: + forall r a. + Member (Embed IO) r => Sem (Files ': r) a -> - Sem r' a -runFilesIO' rootPath = reinterpret3 helper + Sem (Error FilesError ': r) a +runFilesIO = reinterpret helper where - helper :: forall rInitial x. Files (Sem rInitial) x -> Sem r' x + helper :: forall rInitial x. Files (Sem rInitial) x -> Sem (Error FilesError ': r) x helper = \case - ReadFile' f -> embed (readFile f) - ReadFileBS' f -> embed (ByteString.readFile f) - FileExists' f -> embed (doesFileExist f) - EqualPaths' f h -> - embed - ( do - f' <- canonicalizePath f - h' <- canonicalizePath h - return (Just (equalFilePath f' h')) - ) - RegisterStdlib stdlibRootPath -> do - absStdlibRootPath <- embed (makeAbsolute stdlibRootPath) - fs <- embed (getFilesRecursive absStdlibRootPath) - let paths = normalise . makeRelative absStdlibRootPath <$> fs - modify - ( set - stdlibState - ( Just - StdlibState - { _stdlibRoot = absStdlibRootPath, - _stdlibFilePaths = HashSet.fromList paths - } - ) - ) - UpdateStdlib p -> runReader p Stdlib.updateStdlib - CanonicalizePath' f -> embed (canonicalizePath f) - GetAbsPath f -> do - s <- gets (^. stdlibState) - p <- stdlibOrFile f rootPath s - embed (canonicalizePath p) - -runFilesIO :: Member (Embed IO) r => FilePath -> Sem (Files ': r) a -> Sem (Error FilesError ': r) a -runFilesIO rootPath = evalState initState . subsume . runFilesIO' rootPath + ReadFile' f -> embed (readFile (toFilePath f)) + WriteFileBS p bs -> embed (ByteString.writeFile (toFilePath p) bs) + WriteFile' f txt -> embed (writeFile (toFilePath f) txt) + EnsureDir' p -> Path.ensureDir p + DirectoryExists' p -> Path.doesDirExist p + ReadFileBS' f -> embed (ByteString.readFile (toFilePath f)) + FileExists' f -> Path.doesFileExist f + RemoveDirectoryRecursive' d -> removeDirRecur d + ListDirRel p -> embed @IO (Path.listDirRel p) + PathUid f -> do + status <- embed (P.getFileStatus (toFilePath f)) + let P.CDev dev = P.deviceID status + P.CIno fid = P.fileID status + return (Uid (dev, fid)) + GetDirAbsPath f -> canonicalizePath f diff --git a/src/Juvix/Data/Effect/Files/Pure.hs b/src/Juvix/Data/Effect/Files/Pure.hs index 5e3298c07..a05844006 100644 --- a/src/Juvix/Data/Effect/Files/Pure.hs +++ b/src/Juvix/Data/Effect/Files/Pure.hs @@ -8,7 +8,7 @@ import Juvix.Prelude.Path import Prelude qualified data FS = FS - { _fsRoot :: Path Rel Dir, + { _fsRoot :: Path Abs Dir, _fsNode :: FSNode } @@ -17,6 +17,13 @@ data FSNode = FSNode _dirDirs :: HashMap (Path Rel Dir) FSNode } +emptyFS :: FS +emptyFS = + FS + { _fsRoot = $(mkAbsDir "/"), + _fsNode = emptyNode + } + emptyNode :: FSNode emptyNode = FSNode @@ -27,25 +34,13 @@ emptyNode = makeLenses ''FS makeLenses ''FSNode --- | Files should have a common root -mkFS :: HashMap FilePath Text -> FS -mkFS tbl = case (HashMap.toList (rootNode ^. dirDirs), toList (rootNode ^. dirFiles)) of - ([(r, d')], []) -> FS r d' - _ -> impossible +mkFS :: HashMap (Path Abs File) Text -> FS +mkFS tbl = run (execState emptyFS go) where - rootNode :: FSNode - rootNode = HashMap.foldlWithKey' insertFile emptyNode tbl - insertFile :: FSNode -> FilePath -> Text -> FSNode - insertFile dir0 fp contents = go (splitPath fp) dir0 - where - go :: [FilePath] -> FSNode -> FSNode - go l dir = case l of - [] -> impossible - [f] -> set (dirFiles . at (relFile f)) (Just contents) dir - (d : ds) -> over dirDirs (HashMap.alter (Just . helper) (relDir d)) dir - where - helper :: Maybe FSNode -> FSNode - helper = maybe (helper (Just emptyNode)) (go ds) + go :: Sem '[State FS] () + go = forM_ (HashMap.toList tbl) $ \(p, txt) -> do + ensureDirHelper (parent p) + writeFileHelper p txt toTree :: FS -> Tree FilePath toTree fs = Node (toFilePath (fs ^. fsRoot)) (go (fs ^. fsNode)) @@ -62,27 +57,34 @@ toTree fs = Node (toFilePath (fs ^. fsRoot)) (go (fs ^. fsNode)) instance Show FS where show = drawTree . toTree -runFilesEmpty :: FilePath -> Sem (Files ': r) a -> Sem r a -runFilesEmpty rootPath = runFilesPure rootPath mempty +runFilesEmpty :: Sem (Files ': r) a -> Sem r a +runFilesEmpty = runFilesPure mempty $(mkAbsDir "/") -runFilesPure :: FilePath -> HashMap FilePath Text -> Sem (Files ': r) a -> Sem r a -runFilesPure rootPath fs = interpret $ \case - ReadFile' f -> return (readHelper f) - EqualPaths' {} -> return Nothing - FileExists' f -> return (HashMap.member f fs) - RegisterStdlib {} -> return () - UpdateStdlib {} -> return () - GetAbsPath f -> return (rootPath f) - CanonicalizePath' f -> return (normalise (rootPath f)) - ReadFileBS' f -> return (encodeUtf8 (readHelper f)) +runFilesPure :: HashMap (Path Abs File) Text -> Path Abs Dir -> Sem (Files ': r) a -> Sem r a +runFilesPure ini cwd a = evalState (mkFS ini) (re cwd a) + +re :: Path Abs Dir -> Sem (Files ': r) a -> Sem (State FS ': r) a +re cwd = reinterpret $ \case + ReadFile' f -> lookupFile' f + FileExists' f -> isJust <$> lookupFile f + PathUid p -> return (Uid (toFilePath p)) + ReadFileBS' f -> encodeUtf8 <$> lookupFile' f + GetDirAbsPath p -> return (absDir (cwd' toFilePath p)) + EnsureDir' p -> ensureDirHelper p + DirectoryExists' p -> isJust <$> lookupDir p + WriteFile' p t -> writeFileHelper p t + WriteFileBS p t -> writeFileHelper p (decodeUtf8 t) + RemoveDirectoryRecursive' p -> removeDirRecurHelper p + ListDirRel p -> do + n <- lookupDir' p + return (HashMap.keys (n ^. dirDirs), HashMap.keys (n ^. dirFiles)) where - root :: FS - root = mkFS fs - readHelper :: FilePath -> Text - readHelper f = fromMaybe (missingErr root f) (HashMap.lookup f fs) + cwd' :: FilePath + cwd' = toFilePath cwd -missingErr :: FS -> FilePath -> a -missingErr root f = +missingErr :: Members '[State FS] r => FilePath -> Sem r a +missingErr f = do + root <- get @FS error $ pack $ "file " @@ -91,37 +93,79 @@ missingErr root f = <> "\nThe contents of the mocked file system are:\n" <> Prelude.show root -findDir :: FS -> Path Rel Dir -> FSNode -findDir root p = go (root ^. fsNode) (destructPath p) - where - go :: FSNode -> [Path Rel Dir] -> FSNode - go d = \case - [] -> d - (h : hs) -> go (HashMap.lookupDefault err h (d ^. dirDirs)) hs - err :: a - err = missingErr root (toFilePath p) +checkRoot :: Members '[State FS] r => Path Abs Dir -> Sem r () +checkRoot r = do + root <- gets (^. fsRoot) + unless True (error ("roots do not match: " <> pack (toFilePath root) <> "\n" <> pack (toFilePath r))) -walkDirRel' :: - forall m. - Monad m => - FS -> - (RecursorArgs -> m (Path Rel Dir -> Bool)) -> - Maybe (Path Rel Dir) -> - m () -walkDirRel' root f start = go (root ^. fsRoot) fs0 +removeDirRecurHelper :: Members '[State FS] r => Path Abs Dir -> Sem r () +removeDirRecurHelper p = do + checkRoot r + modify (over fsNode (fromMaybe emptyNode . go dirs)) where - fs0 :: FSNode - fs0 = maybe (root ^. fsNode) (findDir root) start - go :: Path Rel Dir -> FSNode -> m () - go cur (FSNode files dirs) = do - w <- f args - let dirs' = filter (w . fst) (HashMap.toList dirs) - forM_ dirs' $ \(d, n) -> go (cur d) n - where - args :: RecursorArgs - args = - RecursorArgs - { _recCurDir = cur, - _recFiles = HashMap.keys files, - _recDirs = HashMap.keys dirs - } + (r, dirs) = destructAbsDir p + go :: [Path Rel Dir] -> FSNode -> Maybe FSNode + go = \case + [] -> const Nothing + (d : ds) -> Just . over dirDirs (HashMap.alter helper d) + where + helper :: Maybe FSNode -> Maybe FSNode + helper = go ds . fromMaybe emptyNode + +ensureDirHelper :: Members '[State FS] r => Path Abs Dir -> Sem r () +ensureDirHelper p = do + checkRoot r + modify (over fsNode (go dirs)) + where + (r, dirs) = destructAbsDir p + go :: [Path Rel Dir] -> FSNode -> FSNode + go = \case + [] -> id + (d : ds) -> over dirDirs (HashMap.alter (Just . helper) d) + where + helper :: Maybe FSNode -> FSNode + helper = go ds . fromMaybe emptyNode + +writeFileHelper :: Members '[State FS] r => Path Abs File -> Text -> Sem r () +writeFileHelper p contents = do + checkRoot r + modify (over fsNode (go dirs)) + where + (r, dirs, f) = destructAbsFile p + go :: [Path Rel Dir] -> FSNode -> FSNode + go = \case + [] -> set (dirFiles . at f) (Just contents) + (d : ds) -> over dirDirs (HashMap.alter (Just . helper) d) + where + helper :: Maybe FSNode -> FSNode + helper = maybe (error "directory does not exist") (go ds) + +lookupDir :: Members '[State FS] r => Path Abs Dir -> Sem r (Maybe FSNode) +lookupDir p = do + checkRoot p + r <- gets (^. fsNode) + return (go r (snd (destructAbsDir p))) + where + go :: FSNode -> [Path Rel Dir] -> Maybe FSNode + go d = \case + [] -> return d + (h : hs) -> do + d' <- HashMap.lookup h (d ^. dirDirs) + go d' hs + +lookupDir' :: forall r. Members '[State FS] r => Path Abs Dir -> Sem r FSNode +lookupDir' p = fromMaybeM err (lookupDir p) + where + err :: Sem r FSNode + err = missingErr (toFilePath p) + +lookupFile :: Members '[State FS] r => Path Abs File -> Sem r (Maybe Text) +lookupFile p = do + node <- lookupDir (parent p) + return (node >>= HashMap.lookup (filename p) . (^. dirFiles)) + +lookupFile' :: Members '[State FS] r => Path Abs File -> Sem r Text +lookupFile' p = + fromMaybeM err (lookupFile p) + where + err = missingErr (toFilePath p) diff --git a/src/Juvix/Data/Processed.hs b/src/Juvix/Data/Processed.hs new file mode 100644 index 000000000..91bb51142 --- /dev/null +++ b/src/Juvix/Data/Processed.hs @@ -0,0 +1,10 @@ +module Juvix.Data.Processed where + +import Juvix.Prelude.Base + +data IsProcessed + = Raw + | Processed + deriving stock (Eq, Show) + +$(genSingletons [''IsProcessed]) diff --git a/src/Juvix/Data/Uid.hs b/src/Juvix/Data/Uid.hs new file mode 100644 index 000000000..b373a40b1 --- /dev/null +++ b/src/Juvix/Data/Uid.hs @@ -0,0 +1,19 @@ +module Juvix.Data.Uid where + +import Data.Type.Equality +import Juvix.Prelude.Base +import Type.Reflection qualified as R + +data Uid = forall a. + (Typeable a, Hashable a, Eq a) => + Uid + { _fileUid :: a + } + +instance Eq Uid where + Uid a == Uid b = case testEquality (R.typeOf a) (R.typeOf b) of + Nothing -> False + Just Refl -> a == b + +instance Hashable Uid where + hashWithSalt s (Uid u) = hashWithSalt s u diff --git a/src/Juvix/Extra/Paths.hs b/src/Juvix/Extra/Paths.hs index c34762483..a54d8b3a7 100644 --- a/src/Juvix/Extra/Paths.hs +++ b/src/Juvix/Extra/Paths.hs @@ -1,23 +1,24 @@ -module Juvix.Extra.Paths where +module Juvix.Extra.Paths + ( module Juvix.Extra.Paths, + module Juvix.Extra.Paths.Base, + ) +where -import Data.FileEmbed qualified as FE +import Juvix.Extra.Paths.Base import Juvix.Prelude.Base +import Juvix.Prelude.Path import Language.Haskell.TH.Syntax -assetsDir :: Q Exp -assetsDir = FE.makeRelativeToProject "assets" >>= FE.embedDir +relToProject :: Path Rel a -> Path Abs a +relToProject r = $(projectPath) r -stdlibDir :: Q Exp -stdlibDir = FE.makeRelativeToProject "juvix-stdlib" >>= FE.embedDir +assetsDir :: [(Path Rel File, ByteString)] +assetsDir = map (first relFile) $(assetsDirQ) -juvixYamlFile :: FilePath -juvixYamlFile = "juvix.yaml" - -juvixBuildDir :: FilePath -juvixBuildDir = ".juvix-build" - -juvixStdlibDir :: FilePath -juvixStdlibDir = juvixBuildDir "stdlib" - -preludePath :: FilePath -preludePath = "Stdlib" "Prelude.juvix" +-- | Given a relative file from the root of the project, checks that the file +-- exists and returns the absolute path +mkProjFile :: Path Rel File -> Q Exp +mkProjFile r = do + let p = relToProject r + ensureFile p + lift p diff --git a/src/Juvix/Extra/Paths/Base.hs b/src/Juvix/Extra/Paths/Base.hs new file mode 100644 index 000000000..6f79bf25b --- /dev/null +++ b/src/Juvix/Extra/Paths/Base.hs @@ -0,0 +1,35 @@ +module Juvix.Extra.Paths.Base where + +import Data.FileEmbed qualified as FE +import Juvix.Prelude +import Language.Haskell.TH.Syntax + +assetsDirQ :: Q Exp +assetsDirQ = FE.makeRelativeToProject "assets" >>= FE.embedDir + +projectFilePath :: Q Exp +projectFilePath = FE.makeRelativeToProject "." >>= lift + +projectPath :: Q Exp +projectPath = FE.makeRelativeToProject "." >>= lift . absDir + +stdlibDir :: Q Exp +stdlibDir = FE.makeRelativeToProject "juvix-stdlib" >>= FE.embedDir + +juvixYamlFile :: Path Rel File +juvixYamlFile = $(mkRelFile "juvix.yaml") + +juvixBuildDir :: Path Rel Dir +juvixBuildDir = $(mkRelDir ".juvix-build") + +juvixIncludeDir :: Path Rel Dir +juvixIncludeDir = juvixBuildDir $(mkRelDir "include") + +juvixStdlibDir :: Path Rel Dir +juvixStdlibDir = juvixBuildDir $(mkRelDir "stdlib") + +preludePath :: Path Rel File +preludePath = $(mkRelFile "Stdlib/Prelude.juvix") + +defaultStdlibPath :: Path Abs Dir -> Path Abs Dir +defaultStdlibPath root = root juvixStdlibDir diff --git a/src/Juvix/Extra/Stdlib.hs b/src/Juvix/Extra/Stdlib.hs index 2c5d76a71..a6812882d 100644 --- a/src/Juvix/Extra/Stdlib.hs +++ b/src/Juvix/Extra/Stdlib.hs @@ -1,49 +1,72 @@ module Juvix.Extra.Stdlib where -import Data.ByteString qualified as BS +import Juvix.Compiler.Pipeline.Package.Dependency +import Juvix.Data.Effect.Files import Juvix.Extra.Paths import Juvix.Extra.Version -import Juvix.Prelude.Base +import Juvix.Prelude -type RootPath = FilePath +type StdlibRoot = Path Abs Dir -stdlibFiles :: [(FilePath, ByteString)] -stdlibFiles = filter isJuvixFile $(stdlibDir) +stdlibFiles :: [(Path Rel File, ByteString)] +stdlibFiles = mapMaybe helper $(stdlibDir) where - isJuvixFile :: (FilePath, ByteString) -> Bool - isJuvixFile (fp, _) = takeExtension fp == ".juvix" + helper :: (FilePath, ByteString) -> Maybe (Path Rel File, ByteString) + helper (fp', bs) + | isStdLibFile fp = Just (fp, bs) + | otherwise = Nothing + where + fp :: Path Rel File + fp = relFile fp' + isStdLibFile :: Path Rel File -> Bool + isStdLibFile = isJuvixFile .||. isYamlFile + isYamlFile :: Path Rel File -> Bool + isYamlFile = (== juvixYamlFile) -writeStdlib :: forall r. Members '[Reader RootPath, Embed IO] r => Sem r () +ensureStdlib :: Members '[Files] r => Path Abs Dir -> [Dependency] -> Sem r () +ensureStdlib pkgRoot deps = whenJust (firstJust isStdLib deps) $ \stdlibRoot -> + runReader stdlibRoot updateStdlib + where + isStdLib :: Dependency -> Maybe (Path Abs Dir) + isStdLib dep = do + case stripProperPrefix pkgRoot (dep ^. dependencyPath) of + Just p + | p == juvixStdlibDir -> Just (dep ^. dependencyPath) + _ -> Nothing + +writeStdlib :: forall r. Members '[Reader StdlibRoot, Files] r => Sem r () writeStdlib = do rootDir <- ask - forM_ (first (rootDir ) <$> stdlibFiles) (uncurry writeJuvixFile) + forM_ (first (rootDir ) <$> stdlibFiles) (uncurry writeJuvixFile) where - writeJuvixFile :: FilePath -> ByteString -> Sem r () - writeJuvixFile p bs = embed (createDirectoryIfMissing True (takeDirectory p) >> BS.writeFile p bs) + writeJuvixFile :: Path Abs File -> ByteString -> Sem r () + writeJuvixFile p bs = do + ensureDir' (parent p) + writeFileBS p bs -stdlibVersionFile :: Member (Reader RootPath) r => Sem r FilePath -stdlibVersionFile = ( ".version") <$> ask +stdlibVersionFile :: Member (Reader StdlibRoot) r => Sem r (Path Abs File) +stdlibVersionFile = ( $(mkRelFile ".version")) <$> ask -writeVersion :: forall r. Members '[Reader RootPath, Embed IO] r => Sem r () -writeVersion = (embed . flip writeFile versionTag) =<< stdlibVersionFile +writeVersion :: forall r. Members '[Reader StdlibRoot, Files] r => Sem r () +writeVersion = stdlibVersionFile >>= flip writeFile' versionTag -readVersion :: Members '[Reader RootPath, Embed IO] r => Sem r (Maybe Text) +readVersion :: Members '[Reader StdlibRoot, Files] r => Sem r (Maybe Text) readVersion = do vf <- stdlibVersionFile - embed (whenMaybeM (doesFileExist vf) (readFile vf)) + whenMaybeM (fileExists' vf) (readFile' vf) -updateStdlib :: forall r. Members '[Reader RootPath, Embed IO] r => Sem r () +updateStdlib :: forall r. Members '[Reader StdlibRoot, Files] r => Sem r () updateStdlib = whenM shouldUpdate $ do whenM - (embed . doesDirectoryExist =<< ask) - (embed . removeDirectoryRecursive =<< ask) + (ask @StdlibRoot >>= directoryExists') + (ask @StdlibRoot >>= removeDirectoryRecursive') writeStdlib writeVersion where shouldUpdate :: Sem r Bool shouldUpdate = orM - [ not <$> (embed . doesDirectoryExist =<< ask), + [ not <$> (ask @StdlibRoot >>= directoryExists'), (Just versionTag /=) <$> readVersion ] diff --git a/src/Juvix/Prelude.hs b/src/Juvix/Prelude.hs index cd4b11d05..5fb8268df 100644 --- a/src/Juvix/Prelude.hs +++ b/src/Juvix/Prelude.hs @@ -2,6 +2,7 @@ module Juvix.Prelude ( module Juvix.Prelude.Base, module Juvix.Prelude.Lens, module Juvix.Prelude.Trace, + module Juvix.Prelude.Path, module Juvix.Data, ) where @@ -9,4 +10,5 @@ where import Juvix.Data import Juvix.Prelude.Base import Juvix.Prelude.Lens +import Juvix.Prelude.Path import Juvix.Prelude.Trace diff --git a/src/Juvix/Prelude/Aeson.hs b/src/Juvix/Prelude/Aeson.hs new file mode 100644 index 000000000..e50303a36 --- /dev/null +++ b/src/Juvix/Prelude/Aeson.hs @@ -0,0 +1,14 @@ +module Juvix.Prelude.Aeson + ( module Juvix.Prelude.Aeson, + module Data.Aeson, + module Data.Aeson.Text, + ) +where + +import Data.Aeson +import Data.Aeson.Text +import Data.Text.Lazy qualified as Lazy +import Juvix.Prelude.Base + +encodeToText :: ToJSON a => a -> Text +encodeToText = Lazy.toStrict . encodeToLazyText diff --git a/src/Juvix/Prelude/Base.hs b/src/Juvix/Prelude/Base.hs index 7c50b0b65..32adf88bd 100644 --- a/src/Juvix/Prelude/Base.hs +++ b/src/Juvix/Prelude/Base.hs @@ -58,11 +58,11 @@ module Juvix.Prelude.Base module Polysemy.State, module Language.Haskell.TH.Syntax, module Prettyprinter, - module System.Directory, module System.Exit, module System.FilePath, module System.IO, module Text.Show, + module Control.Monad.Catch, Data, Text, pack, @@ -73,12 +73,15 @@ module Juvix.Prelude.Base HashSet, IsString (..), Alternative (..), + MonadIO (..), ) where import Control.Applicative +import Control.Monad.Catch (MonadMask, MonadThrow, throwM) import Control.Monad.Extra hiding (fail) import Control.Monad.Fix +import Control.Monad.IO.Class (MonadIO (..)) import Data.Bifunctor hiding (first, second) import Data.Bitraversable import Data.Bool @@ -99,7 +102,7 @@ import Data.Hashable import Data.Int import Data.IntMap.Strict (IntMap) import Data.IntSet (IntSet) -import Data.List.Extra hiding (groupSortOn, head, last, mconcatMap) +import Data.List.Extra hiding (allSame, groupSortOn, head, last, mconcatMap) import Data.List.Extra qualified as List import Data.List.NonEmpty qualified as NonEmpty import Data.List.NonEmpty.Extra @@ -141,8 +144,8 @@ import GHC.Real import GHC.Stack.Types import Language.Haskell.TH.Syntax (Lift) import Lens.Micro.Platform hiding (both) -import Path (parseAbsDir, toFilePath) -import Path.IO (listDirRecur) +import Path +import Path.IO qualified as Path import Polysemy import Polysemy.Embed import Polysemy.Error hiding (fromEither) @@ -153,9 +156,8 @@ import Polysemy.State import Prettyprinter (Doc, (<+>)) import Safe.Exact import Safe.Foldable -import System.Directory import System.Exit -import System.FilePath +import System.FilePath (FilePath, dropTrailingPathSeparator, normalise, (<.>), ()) import System.IO hiding ( appendFile, getContents, @@ -165,12 +167,15 @@ import System.IO hiding hPutStr, hPutStrLn, interact, + openBinaryTempFile, + openTempFile, putStr, putStrLn, readFile, readFile', writeFile, ) +import System.IO.Error import Text.Show (Show) import Text.Show qualified as Show @@ -198,6 +203,14 @@ toUpperFirst (x : xs) = Char.toUpper x : xs -- Foldable -------------------------------------------------------------------------------- +allSame :: forall t a. (Eq a, Foldable t) => t a -> Bool +allSame t + | null t = True + | otherwise = all (== h) t + where + h :: a + h = foldr1 const t + mconcatMap :: (Monoid c, Foldable t) => (a -> c) -> t a -> c mconcatMap f = List.mconcatMap f . toList @@ -346,19 +359,6 @@ fromRightIO' pp = do fromRightIO :: (e -> Text) -> IO (Either e r) -> IO r fromRightIO pp = fromRightIO' (putStrLn . pp) --------------------------------------------------------------------------------- --- Files --------------------------------------------------------------------------------- - --- | Recursively get all files in the given directory. --- --- The function returns absolute paths. -getFilesRecursive :: FilePath -> IO [FilePath] -getFilesRecursive p = do - pathP <- makeAbsolute p >>= parseAbsDir - (_, files) <- listDirRecur pathP - return (toFilePath <$> files) - -------------------------------------------------------------------------------- -- Misc -------------------------------------------------------------------------------- @@ -409,3 +409,9 @@ instance CanonicalProjection a () where -- | 'project' with type arguments swapped. Useful for type application project' :: forall b a. CanonicalProjection a b => a -> b project' = project + +ensureFile :: (MonadIO m, MonadThrow m) => Path Abs File -> m () +ensureFile f = + unlessM + (Path.doesFileExist f) + (throwM (mkIOError doesNotExistErrorType "" Nothing (Just (toFilePath f)))) diff --git a/src/Juvix/Prelude/Path.hs b/src/Juvix/Prelude/Path.hs index ca8471a1d..00d2ff394 100644 --- a/src/Juvix/Prelude/Path.hs +++ b/src/Juvix/Prelude/Path.hs @@ -1,28 +1,90 @@ module Juvix.Prelude.Path ( module Juvix.Prelude.Path, module Path, + module Path.IO, ) where +import Data.List.NonEmpty qualified as NonEmpty import Juvix.Prelude.Base -import Path hiding (()) +import Juvix.Prelude.Path.OrphanInstances () +import Path hiding ((<.>), ()) import Path qualified +import Path.IO hiding (listDirRel, walkDirRel) +import Path.Internal + +absDir :: FilePath -> Path Abs Dir +absDir r = fromMaybe (error ("not an absolute file path: " <> pack r)) (parseAbsDir r) --- | Synonym for Path.. Useful to avoid name clashes infixr 5 +-- | Synonym for Path.. Useful to avoid name clashes () :: Path b Dir -> Path Rel t -> Path b t () = (Path.) +someFile :: FilePath -> SomeBase File +someFile r = fromMaybe (error ("not a file path: " <> pack r)) (parseSomeFile r) + +someDir :: FilePath -> SomeBase Dir +someDir r = fromMaybe (error ("not a dir path: " <> pack r)) (parseSomeDir r) + relFile :: FilePath -> Path Rel File -relFile = fromJust . parseRelFile +relFile r = fromMaybe (error ("not a relative file path: " <> pack r)) (parseRelFile r) relDir :: FilePath -> Path Rel Dir -relDir = fromJust . parseRelDir +relDir r = fromMaybe (error ("not a relative directory path: " <> pack r)) (parseRelDir r) -destructPath :: Path b Dir -> [Path Rel Dir] -destructPath p = map relDir (splitPath (toFilePath p)) +absFile :: FilePath -> Path Abs File +absFile r = fromMaybe (error ("not an absolute file path: " <> pack r)) (parseAbsFile r) -destructFilePath :: Path b File -> ([Path Rel Dir], Path Rel File) -destructFilePath p = case nonEmptyUnsnoc (nonEmpty' (splitPath (toFilePath p))) of - (ps, f) -> (fmap relDir (maybe [] toList ps), relFile f) +destructAbsDir :: Path Abs Dir -> (Path Abs Dir, [Path Rel Dir]) +destructAbsDir d = go d [] + where + go :: Path Abs Dir -> [Path Rel Dir] -> (Path Abs Dir, [Path Rel Dir]) + go p acc + | isRoot p = (p, acc) + | otherwise = go (parent p) (dirname p : acc) + +isRoot :: Path a Dir -> Bool +isRoot p = parent p == p + +-- | is the root of absolute files always "/" ? +destructAbsFile :: Path Abs File -> (Path Abs Dir, [Path Rel Dir], Path Rel File) +destructAbsFile x = (root, dirs, filename x) + where + (root, dirs) = destructAbsDir (parent x) + +isJuvixFile :: Path b File -> Bool +isJuvixFile = (== Just ".juvix") . fileExtension + +isHiddenDirectory :: Path b Dir -> Bool +isHiddenDirectory p + | toFilePath p == relRootFP = False + | otherwise = case toFilePath (dirname p) of + '.' : _ -> True + _ -> False + +someBaseToAbs :: Path Abs Dir -> SomeBase b -> Path Abs b +someBaseToAbs root = \case + Rel r -> root r + Abs a -> a + +removeExtension :: Path b File -> Maybe (Path b File) +removeExtension = fmap fst . splitExtension + +removeExtension' :: Path b File -> Path b File +removeExtension' = fst . fromJust . splitExtension + +replaceExtension' :: String -> Path b File -> Path b File +replaceExtension' ext = fromJust . replaceExtension ext + +parents :: Path Abs a -> NonEmpty (Path Abs Dir) +parents = go [] . parent + where + go :: [Path Abs Dir] -> Path Abs Dir -> NonEmpty (Path Abs Dir) + go ac p + | isRoot p = NonEmpty.reverse (p :| ac) + | otherwise = go (p : ac) (parent p) + +withTempDir' :: (MonadIO m, MonadMask m) => (Path Abs Dir -> m a) -> m a +withTempDir' = withSystemTempDir "tmp" diff --git a/src/Juvix/Prelude/Path/OrphanInstances.hs b/src/Juvix/Prelude/Path/OrphanInstances.hs new file mode 100644 index 000000000..1cf6ed5fc --- /dev/null +++ b/src/Juvix/Prelude/Path/OrphanInstances.hs @@ -0,0 +1,65 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Avoid restricted extensions" #-} +{-# HLINT ignore "Avoid restricted flags" #-} + +module Juvix.Prelude.Path.OrphanInstances where + +import Juvix.Prelude.Base +import Path +import Path.IO +import Prettyprinter + +instance Pretty (Path a b) where + pretty = pretty . toFilePath + +deriving stock instance Data b => Data (SomeBase b) + +instance AnyPath (SomeBase File) where + type AbsPath (SomeBase File) = Path Abs File + type RelPath (SomeBase File) = Path Rel File + + canonicalizePath :: MonadIO m => SomeBase File -> m (Path Abs File) + canonicalizePath = \case + Abs a -> canonicalizePath a + Rel a -> canonicalizePath a + + makeAbsolute :: MonadIO m => SomeBase File -> m (Path Abs File) + makeAbsolute = \case + Abs a -> makeAbsolute a + Rel a -> makeAbsolute a + + makeRelative :: MonadThrow m => Path Abs Dir -> SomeBase File -> m (Path Rel File) + makeRelative r = \case + Abs a -> makeRelative r a + Rel a -> makeRelative r a + + makeRelativeToCurrentDir :: MonadIO m => SomeBase File -> m (Path Rel File) + makeRelativeToCurrentDir = \case + Abs a -> makeRelativeToCurrentDir a + Rel a -> makeRelativeToCurrentDir a + +instance AnyPath (SomeBase Dir) where + type AbsPath (SomeBase Dir) = Path Abs Dir + type RelPath (SomeBase Dir) = Path Rel Dir + + canonicalizePath :: MonadIO m => SomeBase Dir -> m (Path Abs Dir) + canonicalizePath = \case + Abs a -> canonicalizePath a + Rel a -> canonicalizePath a + + makeAbsolute :: MonadIO m => SomeBase Dir -> m (Path Abs Dir) + makeAbsolute = \case + Abs a -> makeAbsolute a + Rel a -> makeAbsolute a + + makeRelative :: MonadThrow m => Path Abs Dir -> SomeBase Dir -> m (Path Rel Dir) + makeRelative r = \case + Abs a -> makeRelative r a + Rel a -> makeRelative r a + + makeRelativeToCurrentDir :: MonadIO m => SomeBase Dir -> m (Path Rel Dir) + makeRelativeToCurrentDir = \case + Abs a -> makeRelativeToCurrentDir a + Rel a -> makeRelativeToCurrentDir a diff --git a/src/Juvix/Prelude/Pretty.hs b/src/Juvix/Prelude/Pretty.hs index c5482602e..7fc62a955 100644 --- a/src/Juvix/Prelude/Pretty.hs +++ b/src/Juvix/Prelude/Pretty.hs @@ -123,3 +123,6 @@ ordinal = \case 11 -> "eleventh" 12 -> "twelfth" n -> pretty n <> "th" + +itemize :: (Functor f, Foldable f) => f (Doc ann) -> Doc ann +itemize = vsep . fmap ("• " <>) diff --git a/test/Arity/Negative.hs b/test/Arity/Negative.hs index def0bcbd1..3b8a8cef9 100644 --- a/test/Arity/Negative.hs +++ b/test/Arity/Negative.hs @@ -9,19 +9,20 @@ type FailMsg = String data NegTest = NegTest { _name :: String, - _relDir :: FilePath, - _file :: FilePath, + _relDir :: Path Rel Dir, + _file :: Path Rel File, _checkErr :: ArityCheckerError -> Maybe FailMsg } testDescr :: NegTest -> TestDescr testDescr NegTest {..} = - let tRoot = root _relDir + let tRoot = root _relDir + file' = tRoot _file in TestDescr { _testName = _name, _testRoot = tRoot, _testAssertion = Single $ do - let entryPoint = defaultEntryPoint _file + let entryPoint = defaultEntryPoint tRoot file' result <- runIOEither iniState entryPoint upToInternalArity case mapLeft fromJuvixError result of Left (Just tyError) -> whenJust (_checkErr tyError) assertFailure @@ -35,8 +36,8 @@ allTests = "Arity checker negative tests" (map (mkTest . testDescr) tests) -root :: FilePath -root = "tests/negative" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/negative") wrongError :: Maybe FailMsg wrongError = Just "Incorrect error" @@ -45,43 +46,43 @@ tests :: [NegTest] tests = [ NegTest "Too many arguments in expression" - "Internal" - "TooManyArguments.juvix" + $(mkRelDir "Internal") + $(mkRelFile "TooManyArguments.juvix") $ \case ErrTooManyArguments {} -> Nothing _ -> wrongError, NegTest "Pattern match a function type" - "Internal" - "FunctionPattern.juvix" + $(mkRelDir "Internal") + $(mkRelFile "FunctionPattern.juvix") $ \case ErrPatternFunction {} -> Nothing _ -> wrongError, NegTest "Function type (* → *) application" - "Internal" - "FunctionApplied.juvix" + $(mkRelDir "Internal") + $(mkRelFile "FunctionApplied.juvix") $ \case ErrFunctionApplied {} -> Nothing _ -> wrongError, NegTest "Expected explicit pattern" - "Internal" - "ExpectedExplicitPattern.juvix" + $(mkRelDir "Internal") + $(mkRelFile "ExpectedExplicitPattern.juvix") $ \case ErrWrongPatternIsImplicit {} -> Nothing _ -> wrongError, NegTest "Expected explicit argument" - "Internal" - "ExpectedExplicitArgument.juvix" + $(mkRelDir "Internal") + $(mkRelFile "ExpectedExplicitArgument.juvix") $ \case ErrExpectedExplicitArgument {} -> Nothing _ -> wrongError, NegTest "Function clause with two many patterns in the lhs" - "Internal" - "LhsTooManyPatterns.juvix" + $(mkRelDir "Internal") + $(mkRelFile "LhsTooManyPatterns.juvix") $ \case ErrLhsTooManyPatterns {} -> Nothing _ -> wrongError diff --git a/test/Asm/Compile/Base.hs b/test/Asm/Compile/Base.hs index 7dab881cf..758f72686 100644 --- a/test/Asm/Compile/Base.hs +++ b/test/Asm/Compile/Base.hs @@ -8,23 +8,22 @@ import Juvix.Compiler.Backend qualified as Backend import Juvix.Compiler.Backend.C qualified as C import Juvix.Compiler.Pipeline qualified as Pipeline import Runtime.Base qualified as Runtime -import System.IO.Extra (withTempDir) -asmCompileAssertion :: FilePath -> FilePath -> (String -> IO ()) -> Assertion +asmCompileAssertion :: Path Abs File -> Path Abs File -> (String -> IO ()) -> Assertion asmCompileAssertion mainFile expectedFile step = do step "Parse" - s <- readFile mainFile - case runParser mainFile s of + s <- readFile (toFilePath mainFile) + case runParser (toFilePath mainFile) s of Left err -> assertFailure (show err) Right tab -> do step "Generate C code" case run $ runError @JuvixError $ Pipeline.asmToMiniC asmOpts tab of Left {} -> assertFailure "code generation failed" Right C.MiniCResult {..} -> - withTempDir + withTempDir' ( \dirPath -> do - let cFile = dirPath takeBaseName mainFile <> ".c" - TIO.writeFile cFile _resultCCode + let cFile = dirPath replaceExtension' ".c" (filename mainFile) + TIO.writeFile (toFilePath cFile) _resultCCode Runtime.clangAssertion cFile expectedFile "" step ) where diff --git a/test/Asm/Compile/Positive.hs b/test/Asm/Compile/Positive.hs index 9a90516a6..8c64b0e71 100644 --- a/test/Asm/Compile/Positive.hs +++ b/test/Asm/Compile/Positive.hs @@ -6,11 +6,13 @@ import Base testDescr :: Run.PosTest -> TestDescr testDescr Run.PosTest {..} = - let tRoot = Run.root _relDir + let tRoot = Run.root _relDir + file' = tRoot _file + expected' = tRoot _expectedFile in TestDescr { _testName = _name, _testRoot = tRoot, - _testAssertion = Steps $ asmCompileAssertion _file _expectedFile + _testAssertion = Steps $ asmCompileAssertion file' expected' } allTests :: TestTree diff --git a/test/Asm/Run/Base.hs b/test/Asm/Run/Base.hs index d1d20cf3a..e25af5ae1 100644 --- a/test/Asm/Run/Base.hs +++ b/test/Asm/Run/Base.hs @@ -10,9 +10,8 @@ import Juvix.Compiler.Asm.Pretty import Juvix.Compiler.Asm.Transformation.Validate import Juvix.Compiler.Asm.Translation.FromSource import Juvix.Data.PPOutput -import System.IO.Extra (withTempDir) -asmRunAssertion :: FilePath -> FilePath -> (InfoTable -> Either AsmError InfoTable) -> (InfoTable -> Assertion) -> (String -> IO ()) -> Assertion +asmRunAssertion :: Path Abs File -> Path Abs File -> (InfoTable -> Either AsmError InfoTable) -> (InfoTable -> Assertion) -> (String -> IO ()) -> Assertion asmRunAssertion mainFile expectedFile trans testTrans step = do step "Parse" r <- parseFile mainFile @@ -29,10 +28,10 @@ asmRunAssertion mainFile expectedFile trans testTrans step = do Nothing -> case tab ^. infoMainFunction of Just sym -> do - withTempDir + withTempDir' ( \dirPath -> do - let outputFile = dirPath "out.out" - hout <- openFile outputFile WriteMode + let outputFile = dirPath $(mkRelFile "out.out") + hout <- openFile (toFilePath outputFile) WriteMode step "Interpret" r' <- doRun hout tab (getFunInfo tab sym) case r' of @@ -44,14 +43,14 @@ asmRunAssertion mainFile expectedFile trans testTrans step = do ValVoid -> return () _ -> hPutStrLn hout (ppPrint tab value') hClose hout - actualOutput <- TIO.readFile outputFile + actualOutput <- TIO.readFile (toFilePath outputFile) step "Compare expected and actual program output" - expected <- TIO.readFile expectedFile - assertEqDiff ("Check: RUN output = " <> expectedFile) actualOutput expected + expected <- TIO.readFile (toFilePath expectedFile) + assertEqDiff ("Check: RUN output = " <> toFilePath expectedFile) actualOutput expected ) Nothing -> assertFailure "no 'main' function" -asmRunErrorAssertion :: FilePath -> (String -> IO ()) -> Assertion +asmRunErrorAssertion :: Path Abs File -> (String -> IO ()) -> Assertion asmRunErrorAssertion mainFile step = do step "Parse" r <- parseFile mainFile @@ -64,10 +63,10 @@ asmRunErrorAssertion mainFile step = do Nothing -> case tab ^. infoMainFunction of Just sym -> do - withTempDir + withTempDir' ( \dirPath -> do - let outputFile = dirPath "out.out" - hout <- openFile outputFile WriteMode + let outputFile = dirPath $(mkRelFile "out.out") + hout <- openFile (toFilePath outputFile) WriteMode step "Interpret" r' <- doRun hout tab (getFunInfo tab sym) hClose hout @@ -77,10 +76,11 @@ asmRunErrorAssertion mainFile step = do ) Nothing -> assertBool "" True -parseFile :: FilePath -> IO (Either ParserError InfoTable) +parseFile :: Path Abs File -> IO (Either ParserError InfoTable) parseFile f = do - s <- readFile f - return $ runParser f s + let f' = toFilePath f + s <- readFile f' + return $ runParser f' s doRun :: Handle -> diff --git a/test/Asm/Run/Negative.hs b/test/Asm/Run/Negative.hs index a44c4fab6..dfef0734f 100644 --- a/test/Asm/Run/Negative.hs +++ b/test/Asm/Run/Negative.hs @@ -5,20 +5,21 @@ import Base data NegTest = NegTest { _name :: String, - _relDir :: FilePath, - _file :: FilePath + _relDir :: Path Rel Dir, + _file :: Path Rel File } -root :: FilePath -root = "tests/Asm/negative" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/Asm/negative") testDescr :: NegTest -> TestDescr testDescr NegTest {..} = - let tRoot = root _relDir + let tRoot = root _relDir + file' = tRoot _file in TestDescr { _testName = _name, _testRoot = tRoot, - _testAssertion = Steps $ asmRunErrorAssertion _file + _testAssertion = Steps $ asmRunErrorAssertion file' } allTests :: TestTree @@ -31,14 +32,14 @@ tests :: [NegTest] tests = [ NegTest "Division by zero" - "." - "test001.jva", + $(mkRelDir ".") + $(mkRelFile "test001.jva"), NegTest "Invalid memory access" - "." - "test002.jva", + $(mkRelDir ".") + $(mkRelFile "test002.jva"), NegTest "No matching case branch" - "." - "test003.jva" + $(mkRelDir ".") + $(mkRelFile "test003.jva") ] diff --git a/test/Asm/Run/Positive.hs b/test/Asm/Run/Positive.hs index 5153c6f10..5bef060d9 100644 --- a/test/Asm/Run/Positive.hs +++ b/test/Asm/Run/Positive.hs @@ -5,21 +5,23 @@ import Base data PosTest = PosTest { _name :: String, - _relDir :: FilePath, - _file :: FilePath, - _expectedFile :: FilePath + _relDir :: Path Rel Dir, + _file :: Path Rel File, + _expectedFile :: Path Rel File } -root :: FilePath -root = "tests/Asm/positive" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/Asm/positive") testDescr :: PosTest -> TestDescr testDescr PosTest {..} = - let tRoot = root _relDir + let tRoot = root _relDir + file' = tRoot _file + expected' = tRoot _expectedFile in TestDescr { _testName = _name, _testRoot = tRoot, - _testAssertion = Steps $ asmRunAssertion _file _expectedFile return (const (return ())) + _testAssertion = Steps $ asmRunAssertion file' expected' return (const (return ())) } allTests :: TestTree @@ -32,182 +34,182 @@ tests :: [PosTest] tests = [ PosTest "Arithmetic opcodes" - "." - "test001.jva" - "out/test001.out", + $(mkRelDir ".") + $(mkRelFile "test001.jva") + $(mkRelFile "out/test001.out"), PosTest "Direct call" - "." - "test002.jva" - "out/test002.out", + $(mkRelDir ".") + $(mkRelFile "test002.jva") + $(mkRelFile "out/test002.out"), PosTest "Indirect call" - "." - "test003.jva" - "out/test003.out", + $(mkRelDir ".") + $(mkRelFile "test003.jva") + $(mkRelFile "out/test003.out"), PosTest "Tail calls" - "." - "test004.jva" - "out/test004.out", + $(mkRelDir ".") + $(mkRelFile "test004.jva") + $(mkRelFile "out/test004.out"), PosTest "Tracing IO" - "." - "test005.jva" - "out/test005.out", + $(mkRelDir ".") + $(mkRelFile "test005.jva") + $(mkRelFile "out/test005.out"), PosTest "IO builtins" - "." - "test006.jva" - "out/test006.out", + $(mkRelDir ".") + $(mkRelFile "test006.jva") + $(mkRelFile "out/test006.out"), PosTest "Higher-order functions" - "." - "test007.jva" - "out/test007.out", + $(mkRelDir ".") + $(mkRelFile "test007.jva") + $(mkRelFile "out/test007.out"), PosTest "Branch" - "." - "test008.jva" - "out/test008.out", + $(mkRelDir ".") + $(mkRelFile "test008.jva") + $(mkRelFile "out/test008.out"), PosTest "Case" - "." - "test009.jva" - "out/test009.out", + $(mkRelDir ".") + $(mkRelFile "test009.jva") + $(mkRelFile "out/test009.out"), PosTest "Recursion" - "." - "test010.jva" - "out/test010.out", + $(mkRelDir ".") + $(mkRelFile "test010.jva") + $(mkRelFile "out/test010.out"), PosTest "Tail recursion" - "." - "test011.jva" - "out/test011.out", + $(mkRelDir ".") + $(mkRelFile "test011.jva") + $(mkRelFile "out/test011.out"), PosTest "Temporary stack" - "." - "test012.jva" - "out/test012.out", + $(mkRelDir ".") + $(mkRelFile "test012.jva") + $(mkRelFile "out/test012.out"), PosTest "Fibonacci numbers in linear time" - "." - "test013.jva" - "out/test013.out", + $(mkRelDir ".") + $(mkRelFile "test013.jva") + $(mkRelFile "out/test013.out"), PosTest "Trees" - "." - "test014.jva" - "out/test014.out", + $(mkRelDir ".") + $(mkRelFile "test014.jva") + $(mkRelFile "out/test014.out"), PosTest "Functions returning functions" - "." - "test015.jva" - "out/test015.out", + $(mkRelDir ".") + $(mkRelFile "test015.jva") + $(mkRelFile "out/test015.out"), PosTest "Arithmetic" - "." - "test016.jva" - "out/test016.out", + $(mkRelDir ".") + $(mkRelFile "test016.jva") + $(mkRelFile "out/test016.out"), PosTest "Closures as arguments" - "." - "test017.jva" - "out/test017.out", + $(mkRelDir ".") + $(mkRelFile "test017.jva") + $(mkRelFile "out/test017.out"), PosTest "Closure extension" - "." - "test018.jva" - "out/test018.out", + $(mkRelDir ".") + $(mkRelFile "test018.jva") + $(mkRelFile "out/test018.out"), PosTest "Recursion through higher-order functions" - "." - "test019.jva" - "out/test019.out", + $(mkRelDir ".") + $(mkRelFile "test019.jva") + $(mkRelFile "out/test019.out"), PosTest "Tail recursion through higher-order functions" - "." - "test020.jva" - "out/test020.out", + $(mkRelDir ".") + $(mkRelFile "test020.jva") + $(mkRelFile "out/test020.out"), PosTest "Higher-order functions and recursion" - "." - "test021.jva" - "out/test021.out", + $(mkRelDir ".") + $(mkRelFile "test021.jva") + $(mkRelFile "out/test021.out"), PosTest "Self-application" - "." - "test022.jva" - "out/test022.out", + $(mkRelDir ".") + $(mkRelFile "test022.jva") + $(mkRelFile "out/test022.out"), PosTest "McCarthy's 91 function" - "." - "test023.jva" - "out/test023.out", + $(mkRelDir ".") + $(mkRelFile "test023.jva") + $(mkRelFile "out/test023.out"), PosTest "Higher-order recursive functions" - "." - "test024.jva" - "out/test024.out", + $(mkRelDir ".") + $(mkRelFile "test024.jva") + $(mkRelFile "out/test024.out"), PosTest "Dynamic closure extension" - "." - "test025.jva" - "out/test025.out", + $(mkRelDir ".") + $(mkRelFile "test025.jva") + $(mkRelFile "out/test025.out"), PosTest "Currying & uncurrying" - "." - "test026.jva" - "out/test026.out", + $(mkRelDir ".") + $(mkRelFile "test026.jva") + $(mkRelFile "out/test026.out"), PosTest "Fast exponentiation" - "." - "test027.jva" - "out/test027.out", + $(mkRelDir ".") + $(mkRelFile "test027.jva") + $(mkRelFile "out/test027.out"), PosTest "Lists" - "." - "test028.jva" - "out/test028.out", + $(mkRelDir ".") + $(mkRelFile "test028.jva") + $(mkRelFile "out/test028.out"), PosTest "Structural equality" - "." - "test029.jva" - "out/test029.out", + $(mkRelDir ".") + $(mkRelFile "test029.jva") + $(mkRelFile "out/test029.out"), PosTest "Mutual recursion" - "." - "test030.jva" - "out/test030.out", + $(mkRelDir ".") + $(mkRelFile "test030.jva") + $(mkRelFile "out/test030.out"), PosTest "Temporary stack with branching" - "." - "test031.jva" - "out/test031.out", + $(mkRelDir ".") + $(mkRelFile "test031.jva") + $(mkRelFile "out/test031.out"), PosTest "Church numerals" - "." - "test032.jva" - "out/test032.out", + $(mkRelDir ".") + $(mkRelFile "test032.jva") + $(mkRelFile "out/test032.out"), PosTest "Ackermann function" - "." - "test033.jva" - "out/test033.out", + $(mkRelDir ".") + $(mkRelFile "test033.jva") + $(mkRelFile "out/test033.out"), PosTest "Higher-order function composition" - "." - "test034.jva" - "out/test034.out", + $(mkRelDir ".") + $(mkRelFile "test034.jva") + $(mkRelFile "out/test034.out"), PosTest "Nested lists" - "." - "test035.jva" - "out/test035.out", + $(mkRelDir ".") + $(mkRelFile "test035.jva") + $(mkRelFile "out/test035.out"), PosTest "Streams without memoization" - "." - "test036.jva" - "out/test036.out" + $(mkRelDir ".") + $(mkRelFile "test036.jva") + $(mkRelFile "out/test036.out") ] diff --git a/test/Asm/Transformation/Base.hs b/test/Asm/Transformation/Base.hs index 4007b3fd6..672265bc7 100644 --- a/test/Asm/Transformation/Base.hs +++ b/test/Asm/Transformation/Base.hs @@ -15,15 +15,17 @@ data Test = Test fromTest :: Test -> TestTree fromTest = mkTest . toTestDescr -troot :: FilePath -troot = "tests/Asm/positive/" +troot :: Path Abs Dir +troot = relToProject $(mkRelDir "tests/Asm/positive/") toTestDescr :: Test -> TestDescr toTestDescr Test {..} = let Run.PosTest {..} = _testEval - tRoot = troot _relDir + tRoot = troot _relDir + file' = tRoot _file + expected' = tRoot _expectedFile in TestDescr { _testName = _name, _testRoot = tRoot, - _testAssertion = Steps $ asmRunAssertion _file _expectedFile _testTransformation _testAssertion + _testAssertion = Steps $ asmRunAssertion file' expected' _testTransformation _testAssertion } diff --git a/test/Asm/Validate/Base.hs b/test/Asm/Validate/Base.hs index 13a398474..f2da9def7 100644 --- a/test/Asm/Validate/Base.hs +++ b/test/Asm/Validate/Base.hs @@ -5,7 +5,7 @@ import Juvix.Compiler.Asm.Data.InfoTable import Juvix.Compiler.Asm.Transformation.Validate import Juvix.Compiler.Asm.Translation.FromSource -asmValidateErrorAssertion :: FilePath -> (String -> IO ()) -> Assertion +asmValidateErrorAssertion :: Path Abs File -> (String -> IO ()) -> Assertion asmValidateErrorAssertion mainFile step = do step "Parse" r <- parseFile mainFile @@ -17,7 +17,7 @@ asmValidateErrorAssertion mainFile step = do Just _ -> assertBool "" True Nothing -> assertFailure "no error" -parseFile :: FilePath -> IO (Either ParserError InfoTable) +parseFile :: Path Abs File -> IO (Either ParserError InfoTable) parseFile f = do - s <- readFile f - return $ runParser f s + s <- readFile (toFilePath f) + return $ runParser (toFilePath f) s diff --git a/test/Asm/Validate/Negative.hs b/test/Asm/Validate/Negative.hs index 7ad2c83ed..31f9d4340 100644 --- a/test/Asm/Validate/Negative.hs +++ b/test/Asm/Validate/Negative.hs @@ -5,20 +5,21 @@ import Base data NegTest = NegTest { _name :: String, - _relDir :: FilePath, - _file :: FilePath + _relDir :: Path Rel Dir, + _file :: Path Rel File } -root :: FilePath -root = "tests/Asm/negative" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/Asm/negative") testDescr :: NegTest -> TestDescr testDescr NegTest {..} = - let tRoot = root _relDir + let tRoot = root _relDir + file' = tRoot _file in TestDescr { _testName = _name, _testRoot = tRoot, - _testAssertion = Steps $ asmValidateErrorAssertion _file + _testAssertion = Steps $ asmValidateErrorAssertion file' } allTests :: TestTree @@ -31,42 +32,42 @@ tests :: [NegTest] tests = [ NegTest "Wrong stack height on exit" - "." - "vtest001.jva", + $(mkRelDir ".") + $(mkRelFile "vtest001.jva"), NegTest "Arithmetic type mismatch" - "." - "vtest002.jva", + $(mkRelDir ".") + $(mkRelFile "vtest002.jva"), NegTest "Function type mismatch" - "." - "vtest003.jva", + $(mkRelDir ".") + $(mkRelFile "vtest003.jva"), NegTest "Not enough function arguments" - "." - "vtest004.jva", + $(mkRelDir ".") + $(mkRelFile "vtest004.jva"), NegTest "Missing return" - "." - "vtest005.jva", + $(mkRelDir ".") + $(mkRelFile "vtest005.jva"), NegTest "Branch stack height mismatch" - "." - "vtest006.jva", + $(mkRelDir ".") + $(mkRelFile "vtest006.jva"), NegTest "Branch type mismatch" - "." - "vtest007.jva", + $(mkRelDir ".") + $(mkRelFile "vtest007.jva"), NegTest "Case stack height mismatch" - "." - "vtest008.jva", + $(mkRelDir ".") + $(mkRelFile "vtest008.jva"), NegTest "Case type mismatch" - "." - "vtest009.jva", + $(mkRelDir ".") + $(mkRelFile "vtest009.jva"), NegTest "Value stack type mismatch" - "." - "vtest010.jva" + $(mkRelDir ".") + $(mkRelFile "vtest010.jva") ] diff --git a/test/BackendC/Base.hs b/test/BackendC/Base.hs index 44fa16c8b..4a3f85640 100644 --- a/test/BackendC/Base.hs +++ b/test/BackendC/Base.hs @@ -6,21 +6,20 @@ import Data.Text.IO qualified as TIO import Juvix.Compiler.Backend.C.Translation.FromInternal as MiniC import Juvix.Compiler.Builtins (iniState) import Juvix.Compiler.Pipeline -import System.IO.Extra (withTempDir) import System.Process qualified as P clangCompile :: - (FilePath -> FilePath -> [String]) -> + (Path Abs File -> Path Abs File -> [String]) -> MiniC.MiniCResult -> - (FilePath -> IO Text) -> + (Path Abs File -> IO Text) -> (String -> IO ()) -> IO Text clangCompile mkClangArgs cResult execute step = - withTempDir + withTempDir' ( \dirPath -> do - let cOutputFile = dirPath "out.c" - wasmOutputFile = dirPath "Input.wasm" - TIO.writeFile cOutputFile (cResult ^. MiniC.resultCCode) + let cOutputFile = dirPath $(mkRelFile "out.c") + wasmOutputFile = dirPath $(mkRelFile "Input.wasm") + TIO.writeFile (toFilePath cOutputFile) (cResult ^. MiniC.resultCCode) step "WASM generation" P.callProcess "clang" @@ -29,129 +28,132 @@ clangCompile mkClangArgs cResult execute step = execute wasmOutputFile ) -wasmClangAssertionCGenOnly :: FilePath -> ((String -> IO ()) -> Assertion) +wasmClangAssertionCGenOnly :: Path Abs File -> ((String -> IO ()) -> Assertion) wasmClangAssertionCGenOnly mainFile step = do step "C Generation" - let entryPoint = defaultEntryPoint mainFile + root <- getCurrentDir + let entryPoint = defaultEntryPoint root mainFile (void . runIO' iniState entryPoint) upToMiniC -wasmClangAssertion :: WASMInfo -> FilePath -> FilePath -> ((String -> IO ()) -> Assertion) +wasmClangAssertion :: WASMInfo -> Path Abs File -> Path Abs File -> ((String -> IO ()) -> Assertion) wasmClangAssertion WASMInfo {..} mainFile expectedFile step = do step "Check clang and wasmer are on path" - assertCmdExists "clang" - assertCmdExists "wasmer" - + assertCmdExists $(mkRelFile "clang") + assertCmdExists $(mkRelFile "wasmer") + root <- getCurrentDir step "C Generation" - let entryPoint = defaultEntryPoint mainFile + let entryPoint = defaultEntryPoint root mainFile p :: MiniC.MiniCResult <- snd <$> runIO' iniState entryPoint upToMiniC - expected <- TIO.readFile expectedFile + expected <- TIO.readFile (toFilePath expectedFile) step "Compile C with wasm standalone runtime" actualStandalone <- clangCompile standaloneArgs p _wasmInfoActual step step "Compare expected and actual program output" - assertEqDiff ("Check: WASM output = " <> expectedFile) actualStandalone expected + assertEqDiff ("Check: WASM output = " <> toFilePath expectedFile) actualStandalone expected -wasiClangAssertion :: StdlibMode -> FilePath -> FilePath -> Text -> ((String -> IO ()) -> Assertion) +wasiClangAssertion :: StdlibMode -> Path Abs File -> Path Abs File -> Text -> ((String -> IO ()) -> Assertion) wasiClangAssertion stdlibMode mainFile expectedFile stdinText step = do step "Check clang and wasmer are on path" - assertCmdExists "clang" - assertCmdExists "wasmer" + assertCmdExists $(mkRelFile "clang") + assertCmdExists $(mkRelFile "wasmer") step "Lookup WASI_SYSROOT_PATH" sysrootPath <- - assertEnvVar - "Env var WASI_SYSROOT_PATH missing. Set to the location of the wasi-clib sysroot" - "WASI_SYSROOT_PATH" + absDir + <$> assertEnvVar + "Env var WASI_SYSROOT_PATH missing. Set to the location of the wasi-clib sysroot" + "WASI_SYSROOT_PATH" + root <- getCurrentDir step "C Generation" - let entryPoint = (defaultEntryPoint mainFile) {_entryPointNoStdlib = stdlibMode == StdlibExclude} + let entryPoint = (defaultEntryPoint root mainFile) {_entryPointNoStdlib = stdlibMode == StdlibExclude} p :: MiniC.MiniCResult <- snd <$> runIO' iniState entryPoint upToMiniC - expected <- TIO.readFile expectedFile + expected <- TIO.readFile (toFilePath expectedFile) - let execute :: FilePath -> IO Text - execute outputFile = pack <$> P.readProcess "wasmer" [outputFile] (unpack stdinText) + let execute :: Path Abs File -> IO Text + execute outputFile = pack <$> P.readProcess "wasmer" [toFilePath outputFile] (unpack stdinText) step "Compile C with standalone runtime" actualStandalone <- clangCompile (wasiStandaloneArgs sysrootPath) p execute step step "Compare expected and actual program output" - assertEqDiff ("check: WASM output = " <> expectedFile) actualStandalone expected + assertEqDiff ("check: WASM output = " <> toFilePath expectedFile) actualStandalone expected step "Compile C with libc runtime" actualLibc <- clangCompile (libcArgs sysrootPath) p execute step step "Compare expected and actual program output" - assertEqDiff ("check: WASM output = " <> expectedFile) actualLibc expected + assertEqDiff ("check: WASM output = " <> toFilePath expectedFile) actualLibc expected -builtinRuntime :: FilePath -builtinRuntime = $(makeRelativeToProject "c-runtime/builtins" >>= strToExp) +builtinRuntime :: Path Abs Dir +builtinRuntime = absDir $(makeRelativeToProject "c-runtime/builtins" >>= strToExp) -standaloneArgs :: FilePath -> FilePath -> [String] +standaloneArgs :: Path Abs File -> Path Abs File -> [String] standaloneArgs wasmOutputFile cOutputFile = [ "-nodefaultlibs", "-std=c99", "-Oz", "-I", - takeDirectory minicRuntime, + toFilePath (parent minicRuntime), "-I", - builtinRuntime, + toFilePath builtinRuntime, "-Werror", "--target=wasm32", "-nostartfiles", "-Wl,--no-entry", "-o", - wasmOutputFile, - wallocPath, - cOutputFile + toFilePath wasmOutputFile, + toFilePath wallocPath, + toFilePath cOutputFile ] where - minicRuntime :: FilePath - minicRuntime = $(makeRelativeToProject "c-runtime/standalone/c-runtime.h" >>= strToExp) - wallocPath :: FilePath - wallocPath = $(makeRelativeToProject "c-runtime/walloc/walloc.c" >>= strToExp) + minicRuntime :: Path Abs File + minicRuntime = absFile $(makeRelativeToProject "c-runtime/standalone/c-runtime.h" >>= strToExp) + wallocPath :: Path Abs File + wallocPath = absFile $(makeRelativeToProject "c-runtime/walloc/walloc.c" >>= strToExp) -wasiStandaloneArgs :: FilePath -> FilePath -> FilePath -> [String] +wasiStandaloneArgs :: Path Abs Dir -> Path Abs File -> Path Abs File -> [String] wasiStandaloneArgs sysrootPath wasmOutputFile cOutputFile = [ "-nodefaultlibs", "-std=c99", "-Oz", "-I", - takeDirectory minicRuntime, + toFilePath (parent minicRuntime), "-I", - builtinRuntime, + toFilePath builtinRuntime, "-Werror", "--target=wasm32-wasi", "--sysroot", - sysrootPath, + toFilePath sysrootPath, "-o", - wasmOutputFile, - wallocPath, - cOutputFile + toFilePath wasmOutputFile, + toFilePath wallocPath, + toFilePath cOutputFile ] where - minicRuntime :: FilePath - minicRuntime = $(makeRelativeToProject "c-runtime/wasi-standalone/c-runtime.h" >>= strToExp) - wallocPath :: FilePath - wallocPath = $(makeRelativeToProject "c-runtime/walloc/walloc.c" >>= strToExp) + minicRuntime :: Path Abs File + minicRuntime = absFile $(makeRelativeToProject "c-runtime/wasi-standalone/c-runtime.h" >>= strToExp) + wallocPath :: Path Abs File + wallocPath = absFile $(makeRelativeToProject "c-runtime/walloc/walloc.c" >>= strToExp) -libcArgs :: FilePath -> FilePath -> FilePath -> [String] +libcArgs :: Path Abs Dir -> Path Abs File -> Path Abs File -> [String] libcArgs sysrootPath wasmOutputFile cOutputFile = [ "-nodefaultlibs", "-std=c99", "-Oz", "-I", - takeDirectory minicRuntime, + toFilePath (parent minicRuntime), "-I", - builtinRuntime, + toFilePath builtinRuntime, "-Werror", "-lc", "--target=wasm32-wasi", "--sysroot", - sysrootPath, + toFilePath sysrootPath, "-o", - wasmOutputFile, - cOutputFile + toFilePath wasmOutputFile, + toFilePath cOutputFile ] where - minicRuntime :: FilePath - minicRuntime = $(makeRelativeToProject "c-runtime/wasi-libc/c-runtime.h" >>= strToExp) + minicRuntime :: Path Abs File + minicRuntime = absFile $(makeRelativeToProject "c-runtime/wasi-libc/c-runtime.h" >>= strToExp) diff --git a/test/BackendC/Examples.hs b/test/BackendC/Examples.hs index 83ab9cadf..4ead341f3 100644 --- a/test/BackendC/Examples.hs +++ b/test/BackendC/Examples.hs @@ -10,13 +10,13 @@ data ExampleTest data TestSpec = TestSpec { _name :: String, - _relDir :: FilePath, - _mainFile :: FilePath + _testDir :: Path Rel Dir, + _mainFile :: Path Rel File } data ExecTest = ExecTest { _spec :: TestSpec, - _expectedDir :: FilePath, + _expectedDir :: Path Rel Dir, _stdinText :: Text, _compileMode :: CompileMode } @@ -24,30 +24,32 @@ data ExecTest = ExecTest makeLenses ''ExecTest makeLenses ''TestSpec -execTest :: String -> FilePath -> FilePath -> FilePath -> Text -> CompileMode -> ExecTest -execTest _name _relDir _mainFile _expectedDir _stdinText _compileMode = ExecTest {_spec = TestSpec {..}, ..} +execTest :: String -> Path Rel Dir -> Path Rel File -> Path Rel Dir -> Text -> CompileMode -> ExecTest +execTest _name _testDir _mainFile _expectedDir _stdinText _compileMode = ExecTest {_spec = TestSpec {..}, ..} -exampleRoot :: FilePath -exampleRoot = "examples/milestone" +exampleRoot :: Path Abs Dir +exampleRoot = absDir $(makeRelativeToProject (toFilePath $(mkRelDir "examples/milestone")) >>= strToExp) testDescr :: ExampleTest -> TestDescr testDescr = \case - ExampleExecTest (ExecTest {..}) -> - let mainRoot = exampleRoot _spec ^. relDir - expectedFile = $(makeRelativeToProject "tests/examplesExpected" >>= strToExp) _expectedDir "expected.golden" + ExampleExecTest ExecTest {..} -> + let mainRoot = exampleRoot _spec ^. testDir + mainFile' = mainRoot (_spec ^. mainFile) + expectedFile = absDir $(makeRelativeToProject "tests/examplesExpected" >>= strToExp) _expectedDir $(mkRelFile "expected.golden") in TestDescr { _testName = _spec ^. name, _testRoot = mainRoot, _testAssertion = case _compileMode of - WASI stdlibMode -> Steps $ wasiClangAssertion stdlibMode (_spec ^. mainFile) expectedFile _stdinText - WASM i -> Steps $ wasmClangAssertion i (_spec ^. mainFile) expectedFile + WASI stdlibMode -> Steps $ wasiClangAssertion stdlibMode mainFile' expectedFile _stdinText + WASM i -> Steps $ wasmClangAssertion i mainFile' expectedFile } - ExampleCGenOnlyTest (TestSpec {..}) -> - let mainRoot = exampleRoot _relDir + ExampleCGenOnlyTest TestSpec {..} -> + let mainRoot = exampleRoot _testDir + mainFile' = mainRoot _mainFile in TestDescr { _testName = _name, _testRoot = mainRoot, - _testAssertion = Steps $ wasmClangAssertionCGenOnly _mainFile + _testAssertion = Steps $ wasmClangAssertionCGenOnly mainFile' } allTests :: TestTree @@ -58,11 +60,16 @@ allTests = tests :: [ExampleTest] tests = - [ ExampleExecTest $ execTest "Validity Predicate example" "ValidityPredicates" "Tests.juvix" "ValidityPredicates" "" (WASI StdlibInclude), - ExampleExecTest $ execTest "TicTacToe CLI example" "TicTacToe" "CLI/TicTacToe.juvix" "TicTacToe" "aaa\n0\n10\n1\n2\n3\n3\n4\n5\n6\n7\n8\n9\n" (WASI StdlibInclude), - ExampleCGenOnlyTest $ TestSpec "TicTacToe Web example (C gen only)" "TicTacToe" "Web/TicTacToe.juvix", - ExampleExecTest $ execTest "Fibonacci example" "Fibonacci" "Fibonacci.juvix" "Fibonacci" "" (WASI StdlibInclude), - ExampleExecTest $ execTest "Collatz sequence generator" "Collatz" "Collatz.juvix" "Collatz" "123\n" (WASI StdlibInclude), - ExampleExecTest $ execTest "Towers of Hanoi" "Hanoi" "Hanoi.juvix" "Hanoi" "" (WASI StdlibInclude), - ExampleExecTest $ execTest "Pascal's triangle" "PascalsTriangle" "PascalsTriangle.juvix" "PascalsTriangle" "" (WASI StdlibInclude) - ] + map ExampleExecTest execTests <> map ExampleCGenOnlyTest testSpecs + where + execTests :: [ExecTest] + execTests = + [ execTest "Validity Predicate example" $(mkRelDir "ValidityPredicates") $(mkRelFile "Tests.juvix") $(mkRelDir "ValidityPredicates") "" (WASI StdlibInclude), + execTest "TicTacToe CLI example" $(mkRelDir "TicTacToe") $(mkRelFile "CLI/TicTacToe.juvix") $(mkRelDir "TicTacToe") "aaa\n0\n10\n1\n2\n3\n3\n4\n5\n6\n7\n8\n9\n" (WASI StdlibInclude), + execTest "Fibonacci example" $(mkRelDir "Fibonacci") $(mkRelFile "Fibonacci.juvix") $(mkRelDir "Fibonacci") "" (WASI StdlibInclude), + execTest "Collatz sequence generator" $(mkRelDir "Collatz") $(mkRelFile "Collatz.juvix") $(mkRelDir "Collatz") "123\n" (WASI StdlibInclude), + execTest "Towers of Hanoi" $(mkRelDir "Hanoi") $(mkRelFile "Hanoi.juvix") $(mkRelDir "Hanoi") "" (WASI StdlibInclude), + execTest "Pascal's triangle" $(mkRelDir "PascalsTriangle") $(mkRelFile "PascalsTriangle.juvix") $(mkRelDir "PascalsTriangle") "" (WASI StdlibInclude) + ] + testSpecs :: [TestSpec] + testSpecs = [TestSpec "TicTacToe Web example (C gen only)" $(mkRelDir "TicTacToe") $(mkRelFile "Web/TicTacToe.juvix")] diff --git a/test/BackendC/Positive.hs b/test/BackendC/Positive.hs index 46960ba20..2a7ab61d3 100644 --- a/test/BackendC/Positive.hs +++ b/test/BackendC/Positive.hs @@ -6,53 +6,55 @@ import System.Process qualified as P data PosTest = PosTest { _name :: String, - _relDir :: FilePath, + _relDir :: Path Rel Dir, _compileMode :: CompileMode } makeLenses ''PosTest -root :: FilePath -root = "tests/positive/MiniC" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/positive/MiniC") -mainFile :: FilePath -mainFile = "Input.juvix" +mainFile :: Path Rel File +mainFile = $(mkRelFile "Input.juvix") -expectedFile :: FilePath -expectedFile = "expected.golden" +expectedFile :: Path Rel File +expectedFile = $(mkRelFile "expected.golden") -actualCallExport :: Text -> [Text] -> FilePath -> IO Text +actualCallExport :: Text -> [Text] -> Path Abs File -> IO Text actualCallExport funName funArgs outputFile = pack <$> P.readProcess "wasmer" - (["run", outputFile, "--invoke", unpack funName] <> (unpack <$> funArgs)) + (["run", toFilePath outputFile, "--invoke", unpack funName] <> (unpack <$> funArgs)) "" -actualCallNode :: FilePath -> FilePath -> IO Text +actualCallNode :: Path Rel File -> Path Abs File -> IO Text actualCallNode jsFile outputFile = do - assertCmdExists "node" - let outputDir = takeDirectory outputFile - outputJsFile = outputDir jsFile + assertCmdExists $(mkRelFile "node") + let outputDir = parent outputFile + outputJsFile = outputDir jsFile copyFile jsFile outputJsFile - withCurrentDirectory + withCurrentDir outputDir ( pack <$> P.readProcess "node" - [outputJsFile] + [toFilePath outputJsFile] "" ) testDescr :: PosTest -> TestDescr testDescr PosTest {..} = - let tRoot = root _relDir + let tRoot = root _relDir + mainFile' = tRoot mainFile + expectedFile' = tRoot expectedFile in TestDescr { _testName = _name, _testRoot = tRoot, _testAssertion = Steps $ case _compileMode of - WASI stdlibMode -> wasiClangAssertion stdlibMode mainFile expectedFile "" - WASM i -> wasmClangAssertion i mainFile expectedFile + WASI stdlibMode -> wasiClangAssertion stdlibMode mainFile' expectedFile' "" + WASM i -> wasmClangAssertion i mainFile' expectedFile' } allTests :: TestTree @@ -63,24 +65,24 @@ allTests = tests :: [PosTest] tests = - [ PosTest "HelloWorld" "HelloWorld" (WASI StdlibExclude), - PosTest "Inductive types and pattern matching" "Nat" (WASI StdlibExclude), - PosTest "Polymorphic types" "Polymorphism" (WASI StdlibExclude), - PosTest "Polymorphic axioms" "PolymorphicAxioms" (WASI StdlibExclude), - PosTest "Polymorphic target" "PolymorphicTarget" (WASI StdlibExclude), - PosTest "Multiple modules" "MultiModules" (WASI StdlibExclude), - PosTest "Higher Order Functions" "HigherOrder" (WASI StdlibExclude), - PosTest "Higher Order Functions and explicit holes" "PolymorphismHoles" (WASI StdlibExclude), - PosTest "Closures with no environment" "ClosureNoEnv" (WASI StdlibExclude), - PosTest "Closures with environment" "ClosureEnv" (WASI StdlibExclude), - PosTest "SimpleFungibleTokenImplicit" "SimpleFungibleTokenImplicit" (WASI StdlibExclude), - PosTest "Mutually recursive function" "MutuallyRecursive" (WASI StdlibExclude), - PosTest "Nested List type" "NestedList" (WASI StdlibExclude), - PosTest "Builtin types and functions" "Builtins" (WASI StdlibExclude), - PosTest "Import from embedded standard library" "StdlibImport" (WASI StdlibInclude), - PosTest "Axiom without a compile block" "AxiomNoCompile" (WASI StdlibInclude), - PosTest "Invoke a function using exported name" "ExportName" (WASM (WASMInfo (actualCallExport "fun" []))), - PosTest "Invoke a function using exported name with args" "ExportNameArgs" (WASM (WASMInfo (actualCallExport "fun" ["0"]))), - PosTest "Invoke an imported function in Juvix and exported function in JS" "ImportExportName" (WASM (WASMInfo (actualCallNode "input.js"))), - PosTest "Invoke an exported function using Anoma _validate_tx signature" "AlwaysValidVP" (WASM (WASMInfo (actualCallNode "input.js"))) + [ PosTest "HelloWorld" $(mkRelDir "HelloWorld") (WASI StdlibExclude), + PosTest "Inductive types and pattern matching" $(mkRelDir "Nat") (WASI StdlibExclude), + PosTest "Polymorphic types" $(mkRelDir "Polymorphism") (WASI StdlibExclude), + PosTest "Polymorphic axioms" $(mkRelDir "PolymorphicAxioms") (WASI StdlibExclude), + PosTest "Polymorphic target" $(mkRelDir "PolymorphicTarget") (WASI StdlibExclude), + PosTest "Multiple modules" $(mkRelDir "MultiModules") (WASI StdlibExclude), + PosTest "Higher Order Functions" $(mkRelDir "HigherOrder") (WASI StdlibExclude), + PosTest "Higher Order Functions and explicit holes" $(mkRelDir "PolymorphismHoles") (WASI StdlibExclude), + PosTest "Closures with no environment" $(mkRelDir "ClosureNoEnv") (WASI StdlibExclude), + PosTest "Closures with environment" $(mkRelDir "ClosureEnv") (WASI StdlibExclude), + PosTest "SimpleFungibleTokenImplicit" $(mkRelDir "SimpleFungibleTokenImplicit") (WASI StdlibExclude), + PosTest "Mutually recursive function" $(mkRelDir "MutuallyRecursive") (WASI StdlibExclude), + PosTest "Nested List type" $(mkRelDir "NestedList") (WASI StdlibExclude), + PosTest "Builtin types and functions" $(mkRelDir "Builtins") (WASI StdlibExclude), + PosTest "Import from embedded standard library" $(mkRelDir "StdlibImport") (WASI StdlibInclude), + PosTest "Axiom without a compile block" $(mkRelDir "AxiomNoCompile") (WASI StdlibInclude), + PosTest "Invoke a function using exported name" $(mkRelDir "ExportName") (WASM (WASMInfo (actualCallExport "fun" []))), + PosTest "Invoke a function using exported name with args" $(mkRelDir "ExportNameArgs") (WASM (WASMInfo (actualCallExport "fun" ["0"]))), + PosTest "Invoke an imported function in Juvix and exported function in JS" $(mkRelDir "ImportExportName") (WASM (WASMInfo (actualCallNode $(mkRelFile "input.js")))), + PosTest "Invoke an exported function using Anoma _validate_tx signature" $(mkRelDir "AlwaysValidVP") (WASM (WASMInfo (actualCallNode $(mkRelFile "input.js")))) ] diff --git a/test/Base.hs b/test/Base.hs index 3e2ca0392..acc5d29dc 100644 --- a/test/Base.hs +++ b/test/Base.hs @@ -3,12 +3,14 @@ module Base module Test.Tasty.HUnit, module Juvix.Prelude, module Base, + module Juvix.Extra.Paths, ) where import Control.Monad.Extra as Monad import Data.Algorithm.Diff import Data.Algorithm.DiffOutput +import Juvix.Extra.Paths import Juvix.Prelude import System.Environment (lookupEnv) import Test.Tasty @@ -21,13 +23,13 @@ data AssertionDescr data TestDescr = TestDescr { _testName :: String, - _testRoot :: FilePath, + _testRoot :: Path Abs Dir, -- | relative to root _testAssertion :: AssertionDescr } newtype WASMInfo = WASMInfo - { _wasmInfoActual :: FilePath -> IO Text + { _wasmInfoActual :: Path Abs File -> IO Text } makeLenses ''TestDescr @@ -39,8 +41,8 @@ data CompileMode = WASI StdlibMode | WASM WASMInfo mkTest :: TestDescr -> TestTree mkTest TestDescr {..} = case _testAssertion of - Single assertion -> testCase _testName $ withCurrentDirectory _testRoot assertion - Steps steps -> testCaseSteps _testName (withCurrentDirectory _testRoot . steps) + Single assertion -> testCase _testName $ withCurrentDir _testRoot assertion + Steps steps -> testCaseSteps _testName (withCurrentDir _testRoot . steps) assertEqDiff :: (Eq a, Show a) => String -> a -> a -> Assertion assertEqDiff msg a b @@ -53,9 +55,9 @@ assertEqDiff msg a b pa = lines $ ppShow a pb = lines $ ppShow b -assertCmdExists :: FilePath -> Assertion +assertCmdExists :: Path Rel File -> Assertion assertCmdExists cmd = - assertBool ("Command: " <> cmd <> " is not present on $PATH") + assertBool ("Command: " <> toFilePath cmd <> " is not present on $PATH") . isJust =<< findExecutable cmd diff --git a/test/Core/Eval/Base.hs b/test/Core/Eval/Base.hs index b027ecbd2..fc485e2d6 100644 --- a/test/Core/Eval/Base.hs +++ b/test/Core/Eval/Base.hs @@ -12,12 +12,11 @@ import Juvix.Compiler.Core.Language import Juvix.Compiler.Core.Pretty import Juvix.Compiler.Core.Transformation import Juvix.Compiler.Core.Translation.FromSource -import System.IO.Extra (withTempDir) import Text.Megaparsec.Pos qualified as M coreEvalAssertion :: - FilePath -> - FilePath -> + Path Abs File -> + Path Abs File -> [TransformationId] -> (InfoTable -> Assertion) -> (String -> IO ()) -> @@ -29,15 +28,15 @@ coreEvalAssertion mainFile expectedFile trans testTrans step = do Left err -> assertFailure (show (pretty err)) Right (_, Nothing) -> do step "Compare expected and actual program output" - expected <- TIO.readFile expectedFile - assertEqDiff ("Check: EVAL output = " <> expectedFile) "" expected + expected <- TIO.readFile (toFilePath expectedFile) + assertEqDiff ("Check: EVAL output = " <> toFilePath expectedFile) "" expected Right (tabIni, Just node) -> do let tab = applyTransformations trans tabIni testTrans tab - withTempDir + withTempDir' ( \dirPath -> do - let outputFile = dirPath "out.out" - hout <- openFile outputFile WriteMode + let outputFile = dirPath $(mkRelFile "out.out") + hout <- openFile (toFilePath outputFile) WriteMode step "Evaluate" r' <- doEval mainFile hout tab node case r' of @@ -49,13 +48,13 @@ coreEvalAssertion mainFile expectedFile trans testTrans step = do (Info.member kNoDisplayInfo (getInfo value)) (hPutStrLn hout (ppPrint value)) hClose hout - actualOutput <- TIO.readFile outputFile + actualOutput <- TIO.readFile (toFilePath outputFile) step "Compare expected and actual program output" - expected <- TIO.readFile expectedFile - assertEqDiff ("Check: EVAL output = " <> expectedFile) actualOutput expected + expected <- TIO.readFile (toFilePath expectedFile) + assertEqDiff ("Check: EVAL output = " <> toFilePath expectedFile) actualOutput expected ) -coreEvalErrorAssertion :: FilePath -> (String -> IO ()) -> Assertion +coreEvalErrorAssertion :: Path Abs File -> (String -> IO ()) -> Assertion coreEvalErrorAssertion mainFile step = do step "Parse" r <- parseFile mainFile @@ -63,10 +62,10 @@ coreEvalErrorAssertion mainFile step = do Left _ -> assertBool "" True Right (_, Nothing) -> assertFailure "no error" Right (tab, Just node) -> do - withTempDir + withTempDir' ( \dirPath -> do - let outputFile = dirPath "out.out" - hout <- openFile outputFile WriteMode + let outputFile = dirPath $(mkRelFile "out.out") + hout <- openFile (toFilePath outputFile) WriteMode step "Evaluate" r' <- doEval mainFile hout tab node hClose hout @@ -75,13 +74,14 @@ coreEvalErrorAssertion mainFile step = do Right _ -> assertFailure "no error" ) -parseFile :: FilePath -> IO (Either ParserError (InfoTable, Maybe Node)) +parseFile :: Path Abs File -> IO (Either ParserError (InfoTable, Maybe Node)) parseFile f = do - s <- readFile f - return $ runParser f emptyInfoTable s + let f' = toFilePath f + s <- readFile f' + return $ runParser f' emptyInfoTable s doEval :: - FilePath -> + Path Abs File -> Handle -> InfoTable -> Node -> @@ -89,4 +89,4 @@ doEval :: doEval f hout tab node = catchEvalErrorIO defaultLoc (hEvalIO stdin hout (tab ^. identContext) [] node) where - defaultLoc = singletonInterval (mkLoc 0 (M.initialPos f)) + defaultLoc = singletonInterval (mkLoc 0 (M.initialPos (toFilePath f))) diff --git a/test/Core/Eval/Negative.hs b/test/Core/Eval/Negative.hs index 6fcb414bb..04c3cd0bf 100644 --- a/test/Core/Eval/Negative.hs +++ b/test/Core/Eval/Negative.hs @@ -5,20 +5,21 @@ import Core.Eval.Base data NegTest = NegTest { _name :: String, - _relDir :: FilePath, - _file :: FilePath + _relDir :: Path Rel Dir, + _file :: Path Rel File } -root :: FilePath -root = "tests/Core/negative" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/Core/negative") testDescr :: NegTest -> TestDescr testDescr NegTest {..} = - let tRoot = root _relDir + let tRoot = root _relDir + file' = tRoot _file in TestDescr { _testName = _name, _testRoot = tRoot, - _testAssertion = Steps $ coreEvalErrorAssertion _file + _testAssertion = Steps $ coreEvalErrorAssertion file' } allTests :: TestTree @@ -31,42 +32,42 @@ tests :: [NegTest] tests = [ NegTest "Division by zero" - "." - "test001.jvc", + $(mkRelDir ".") + $(mkRelFile "test001.jvc"), NegTest "Arithmetic operations on non-numbers" - "." - "test002.jvc", + $(mkRelDir ".") + $(mkRelFile "test002.jvc"), NegTest "Matching on non-data" - "." - "test003.jvc", + $(mkRelDir ".") + $(mkRelFile "test003.jvc"), NegTest "If on non-boolean" - "." - "test004.jvc", + $(mkRelDir ".") + $(mkRelFile "test004.jvc"), NegTest "No matching case branch" - "." - "test005.jvc", + $(mkRelDir ".") + $(mkRelFile "test005.jvc"), NegTest "Invalid application" - "." - "test006.jvc", + $(mkRelDir ".") + $(mkRelFile "test006.jvc"), NegTest "Invalid builtin application" - "." - "test007.jvc", + $(mkRelDir ".") + $(mkRelFile "test007.jvc"), NegTest "Undefined symbol" - "." - "test008.jvc", + $(mkRelDir ".") + $(mkRelFile "test008.jvc"), NegTest "Erroneous Church numerals" - "." - "test009.jvc", + $(mkRelDir ".") + $(mkRelFile "test009.jvc"), NegTest "Empty letrec" - "." - "test010.jvc" + $(mkRelDir ".") + $(mkRelFile "test010.jvc") ] diff --git a/test/Core/Eval/Positive.hs b/test/Core/Eval/Positive.hs index 7b7889d0e..2090606c9 100644 --- a/test/Core/Eval/Positive.hs +++ b/test/Core/Eval/Positive.hs @@ -5,21 +5,23 @@ import Core.Eval.Base data PosTest = PosTest { _name :: String, - _relDir :: FilePath, - _file :: FilePath, - _expectedFile :: FilePath + _relDir :: Path Rel Dir, + _file :: Path Rel File, + _expectedFile :: Path Rel File } -root :: FilePath -root = "tests/Core/positive" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/Core/positive") testDescr :: PosTest -> TestDescr testDescr PosTest {..} = - let tRoot = root _relDir + let tRoot = root _relDir + file' = tRoot _file + expected' = tRoot _expectedFile in TestDescr { _testName = _name, _testRoot = tRoot, - _testAssertion = Steps $ coreEvalAssertion _file _expectedFile [] (const (return ())) + _testAssertion = Steps $ coreEvalAssertion file' expected' [] (const (return ())) } allTests :: TestTree @@ -32,237 +34,237 @@ tests :: [PosTest] tests = [ PosTest "Arithmetic operators" - "." - "test001.jvc" - "out/test001.out", + $(mkRelDir ".") + $(mkRelFile "test001.jvc") + $(mkRelFile "out/test001.out"), PosTest "Arithmetic operators inside lambdas" - "." - "test002.jvc" - "out/test002.out", + $(mkRelDir ".") + $(mkRelFile "test002.jvc") + $(mkRelFile "out/test002.out"), PosTest "Empty program with comments" - "." - "test003.jvc" - "out/test003.out", + $(mkRelDir ".") + $(mkRelFile "test003.jvc") + $(mkRelFile "out/test003.out"), PosTest "IO builtins" - "." - "test004.jvc" - "out/test004.out", + $(mkRelDir ".") + $(mkRelFile "test004.jvc") + $(mkRelFile "out/test004.out"), PosTest "Higher-order functions" - "." - "test005.jvc" - "out/test005.out", + $(mkRelDir ".") + $(mkRelFile "test005.jvc") + $(mkRelFile "out/test005.out"), PosTest "If-then-else" - "." - "test006.jvc" - "out/test006.out", + $(mkRelDir ".") + $(mkRelFile "test006.jvc") + $(mkRelFile "out/test006.out"), PosTest "Case" - "." - "test007.jvc" - "out/test007.out", + $(mkRelDir ".") + $(mkRelFile "test007.jvc") + $(mkRelFile "out/test007.out"), PosTest "Recursion" - "." - "test008.jvc" - "out/test008.out", + $(mkRelDir ".") + $(mkRelFile "test008.jvc") + $(mkRelFile "out/test008.out"), PosTest "Tail recursion" - "." - "test009.jvc" - "out/test009.out", + $(mkRelDir ".") + $(mkRelFile "test009.jvc") + $(mkRelFile "out/test009.out"), PosTest "Let" - "." - "test010.jvc" - "out/test010.out", + $(mkRelDir ".") + $(mkRelFile "test010.jvc") + $(mkRelFile "out/test010.out"), PosTest "Tail recursion: Fibonacci numbers in linear time" - "." - "test011.jvc" - "out/test011.out", + $(mkRelDir ".") + $(mkRelFile "test011.jvc") + $(mkRelFile "out/test011.out"), PosTest "Trees" - "." - "test012.jvc" - "out/test012.out", + $(mkRelDir ".") + $(mkRelFile "test012.jvc") + $(mkRelFile "out/test012.out"), PosTest "Functions returning functions with variable capture" - "." - "test013.jvc" - "out/test013.out", + $(mkRelDir ".") + $(mkRelFile "test013.jvc") + $(mkRelFile "out/test013.out"), PosTest "Arithmetic" - "." - "test014.jvc" - "out/test014.out", + $(mkRelDir ".") + $(mkRelFile "test014.jvc") + $(mkRelFile "out/test014.out"), PosTest "Local functions with free variables" - "." - "test015.jvc" - "out/test015.out", + $(mkRelDir ".") + $(mkRelFile "test015.jvc") + $(mkRelFile "out/test015.out"), PosTest "Recursion through higher-order functions" - "." - "test016.jvc" - "out/test016.out", + $(mkRelDir ".") + $(mkRelFile "test016.jvc") + $(mkRelFile "out/test016.out"), PosTest "Tail recursion through higher-order functions" - "." - "test017.jvc" - "out/test017.out", + $(mkRelDir ".") + $(mkRelFile "test017.jvc") + $(mkRelFile "out/test017.out"), PosTest "Higher-order functions and recursion" - "." - "test018.jvc" - "out/test018.out", + $(mkRelDir ".") + $(mkRelFile "test018.jvc") + $(mkRelFile "out/test018.out"), PosTest "Self-application" - "." - "test019.jvc" - "out/test019.out", + $(mkRelDir ".") + $(mkRelFile "test019.jvc") + $(mkRelFile "out/test019.out"), PosTest "Recursive functions: McCarthy's 91 function, subtraction by increments" - "." - "test020.jvc" - "out/test020.out", + $(mkRelDir ".") + $(mkRelFile "test020.jvc") + $(mkRelFile "out/test020.out"), PosTest "Higher-order recursive functions" - "." - "test021.jvc" - "out/test021.out", + $(mkRelDir ".") + $(mkRelFile "test021.jvc") + $(mkRelFile "out/test021.out"), PosTest "Fast exponentiation" - "." - "test022.jvc" - "out/test022.out", + $(mkRelDir ".") + $(mkRelFile "test022.jvc") + $(mkRelFile "out/test022.out"), PosTest "Lists" - "." - "test023.jvc" - "out/test023.out", + $(mkRelDir ".") + $(mkRelFile "test023.jvc") + $(mkRelFile "out/test023.out"), PosTest "Structural equality" - "." - "test024.jvc" - "out/test024.out", + $(mkRelDir ".") + $(mkRelFile "test024.jvc") + $(mkRelFile "out/test024.out"), PosTest "Mutual recursion" - "." - "test025.jvc" - "out/test025.out", + $(mkRelDir ".") + $(mkRelFile "test025.jvc") + $(mkRelFile "out/test025.out"), PosTest "Nested 'case', 'let' and 'if' with variable capture" - "." - "test026.jvc" - "out/test026.out", + $(mkRelDir ".") + $(mkRelFile "test026.jvc") + $(mkRelFile "out/test026.out"), PosTest "Euclid's algorithm" - "." - "test027.jvc" - "out/test027.out", + $(mkRelDir ".") + $(mkRelFile "test027.jvc") + $(mkRelFile "out/test027.out"), PosTest "Functional queues" - "." - "test028.jvc" - "out/test028.out", + $(mkRelDir ".") + $(mkRelFile "test028.jvc") + $(mkRelFile "out/test028.out"), PosTest "Church numerals" - "." - "test029.jvc" - "out/test029.out", + $(mkRelDir ".") + $(mkRelFile "test029.jvc") + $(mkRelFile "out/test029.out"), PosTest "Streams without memoization" - "." - "test030.jvc" - "out/test030.out", + $(mkRelDir ".") + $(mkRelFile "test030.jvc") + $(mkRelFile "out/test030.out"), PosTest "Ackermann function" - "." - "test031.jvc" - "out/test031.out", + $(mkRelDir ".") + $(mkRelFile "test031.jvc") + $(mkRelFile "out/test031.out"), PosTest "Ackermann function (higher-order definition)" - "." - "test032.jvc" - "out/test032.out", + $(mkRelDir ".") + $(mkRelFile "test032.jvc") + $(mkRelFile "out/test032.out"), PosTest "Nested lists" - "." - "test033.jvc" - "out/test033.out", + $(mkRelDir ".") + $(mkRelFile "test033.jvc") + $(mkRelFile "out/test033.out"), {- PosTest "Evaluation order" - "." - "test034.jvc" - "out/test034.out", -} + $(mkRelDir ".") + $(mkRelFile "test034.jvc") + $(mkRelFile "out/test034.out"), -} PosTest "Merge sort" - "." - "test035.jvc" - "out/test035.out", + $(mkRelDir ".") + $(mkRelFile "test035.jvc") + $(mkRelFile "out/test035.out"), PosTest "Big numbers" - "." - "test036.jvc" - "out/test036.out", + $(mkRelDir ".") + $(mkRelFile "test036.jvc") + $(mkRelFile "out/test036.out"), PosTest "Global variables" - "." - "test037.jvc" - "out/test037.out", + $(mkRelDir ".") + $(mkRelFile "test037.jvc") + $(mkRelFile "out/test037.out"), PosTest "Global variables and forward declarations" - "." - "test038.jvc" - "out/test038.out", + $(mkRelDir ".") + $(mkRelFile "test038.jvc") + $(mkRelFile "out/test038.out"), PosTest "Eta-expansion of builtins and constructors" - "." - "test039.jvc" - "out/test039.out", + $(mkRelDir ".") + $(mkRelFile "test039.jvc") + $(mkRelFile "out/test039.out"), PosTest "LetRec" - "." - "test040.jvc" - "out/test040.out", + $(mkRelDir ".") + $(mkRelFile "test040.jvc") + $(mkRelFile "out/test040.out"), PosTest "Match with complex patterns" - "." - "test041.jvc" - "out/test041.out", + $(mkRelDir ".") + $(mkRelFile "test041.jvc") + $(mkRelFile "out/test041.out"), PosTest "Type annotations" - "." - "test042.jvc" - "out/test042.out", + $(mkRelDir ".") + $(mkRelFile "test042.jvc") + $(mkRelFile "out/test042.out"), PosTest "Dependent lambda-abstractions" - "." - "test043.jvc" - "out/test043.out", + $(mkRelDir ".") + $(mkRelFile "test043.jvc") + $(mkRelFile "out/test043.out"), PosTest "Eta-expansion" - "." - "test044.jvc" - "out/test044.out", + $(mkRelDir ".") + $(mkRelFile "test044.jvc") + $(mkRelFile "out/test044.out"), PosTest "Type application and abstraction" - "." - "test045.jvc" - "out/test045.out", + $(mkRelDir ".") + $(mkRelFile "test045.jvc") + $(mkRelFile "out/test045.out"), PosTest "Applications with lets and cases in function position" - "." - "test046.jvc" - "out/test046.out", + $(mkRelDir ".") + $(mkRelFile "test046.jvc") + $(mkRelFile "out/test046.out"), PosTest "Builtin natural numbers" - "." - "test047.jvc" - "out/test047.out" + $(mkRelDir ".") + $(mkRelFile "test047.jvc") + $(mkRelFile "out/test047.out") ] diff --git a/test/Core/Transformation/Base.hs b/test/Core/Transformation/Base.hs index 2a178121a..ef31aae43 100644 --- a/test/Core/Transformation/Base.hs +++ b/test/Core/Transformation/Base.hs @@ -15,15 +15,17 @@ data Test = Test fromTest :: Test -> TestTree fromTest = mkTest . toTestDescr -troot :: FilePath -troot = "tests/Core/positive/" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/Core/positive/") toTestDescr :: Test -> TestDescr toTestDescr Test {..} = let Eval.PosTest {..} = _testEval - tRoot = troot _relDir + tRoot = root _relDir + file' = tRoot _file + expected' = tRoot _expectedFile in TestDescr { _testName = _name, _testRoot = tRoot, - _testAssertion = Steps $ coreEvalAssertion _file _expectedFile _testTransformations _testAssertion + _testAssertion = Steps $ coreEvalAssertion file' expected' _testTransformations _testAssertion } diff --git a/test/Internal/Eval/Base.hs b/test/Internal/Eval/Base.hs index 60879648f..84a53bd9d 100644 --- a/test/Internal/Eval/Base.hs +++ b/test/Internal/Eval/Base.hs @@ -12,19 +12,19 @@ import Juvix.Compiler.Core.Info.NoDisplayInfo import Juvix.Compiler.Core.Pretty import Juvix.Compiler.Core.Translation.FromInternal.Data as Core import Juvix.Compiler.Pipeline -import System.IO.Extra (withTempDir) -internalCoreAssertion :: FilePath -> FilePath -> (String -> IO ()) -> Assertion +internalCoreAssertion :: Path Abs File -> Path Abs File -> (String -> IO ()) -> Assertion internalCoreAssertion mainFile expectedFile step = do step "Translate to Core" - let entryPoint = defaultEntryPoint mainFile + cwd <- getCurrentDir + let entryPoint = defaultEntryPoint cwd mainFile tab <- (^. Core.coreResultTable) . snd <$> runIO' iniState entryPoint upToCore case (tab ^. infoMain) >>= ((tab ^. identContext) HashMap.!?) of Just node -> do - withTempDir + withTempDir' ( \dirPath -> do - let outputFile = dirPath "out.out" - hout <- openFile outputFile WriteMode + let outputFile = dirPath $(mkRelFile "out.out") + hout <- openFile (toFilePath outputFile) WriteMode step "Evaluate" r' <- doEval mainFile hout tab node case r' of @@ -36,9 +36,9 @@ internalCoreAssertion mainFile expectedFile step = do (Info.member kNoDisplayInfo (getInfo value)) (hPutStrLn hout (ppPrint value)) hClose hout - actualOutput <- TIO.readFile outputFile + actualOutput <- TIO.readFile (toFilePath outputFile) step "Compare expected and actual program output" - expected <- TIO.readFile expectedFile - assertEqDiff ("Check: EVAL output = " <> expectedFile) actualOutput expected + expected <- TIO.readFile (toFilePath expectedFile) + assertEqDiff ("Check: EVAL output = " <> toFilePath expectedFile) actualOutput expected ) - Nothing -> assertFailure ("No main function registered in: " <> mainFile) + Nothing -> assertFailure ("No main function registered in: " <> toFilePath mainFile) diff --git a/test/Internal/Eval/Positive.hs b/test/Internal/Eval/Positive.hs index 2a024e3ea..f6994ad97 100644 --- a/test/Internal/Eval/Positive.hs +++ b/test/Internal/Eval/Positive.hs @@ -5,24 +5,26 @@ import Internal.Eval.Base data PosTest = PosTest { _name :: String, - _relDir :: FilePath, - _file :: FilePath, - _expectedFile :: FilePath + _relDir :: Path Rel Dir, + _file :: Path Rel File, + _expectedFile :: Path Rel File } -root :: FilePath -root = "tests/Internal/positive" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/Internal/positive") -coreRoot :: FilePath -coreRoot = "tests/Internal/Core/positive" +coreRoot :: Path Abs Dir +coreRoot = relToProject $(mkRelDir "tests/Internal/Core/positive") -testDescr :: FilePath -> PosTest -> TestDescr +testDescr :: Path Abs Dir -> PosTest -> TestDescr testDescr r PosTest {..} = - let tRoot = r _relDir + let tRoot = r _relDir + file' = tRoot _file + expected' = tRoot _expectedFile in TestDescr { _testName = _name, _testRoot = tRoot, - _testAssertion = Steps $ internalCoreAssertion _file _expectedFile + _testAssertion = Steps $ internalCoreAssertion file' expected' } allTests :: TestTree @@ -35,131 +37,131 @@ coreTests :: [PosTest] coreTests = [ PosTest "If then else" - "." - "test006.juvix" - "out/test006.out", + $(mkRelDir ".") + $(mkRelFile "test006.juvix") + $(mkRelFile "out/test006.out"), PosTest "Fibonacci" - "." - "test011.juvix" - "out/test011.out" + $(mkRelDir ".") + $(mkRelFile "test011.juvix") + $(mkRelFile "out/test011.out") ] tests :: [PosTest] tests = [ PosTest "An integer literal" - "." - "IntegerLiteral.juvix" - "out/IntegerLiteral.out", + $(mkRelDir ".") + $(mkRelFile "IntegerLiteral.juvix") + $(mkRelFile "out/IntegerLiteral.out"), PosTest "A zero argument function" - "." - "IdenFunctionIntegerLiteral.juvix" - "out/IdenFunctionIntegerLiteral.out", + $(mkRelDir ".") + $(mkRelFile "IdenFunctionIntegerLiteral.juvix") + $(mkRelFile "out/IdenFunctionIntegerLiteral.out"), PosTest "A two argument function" - "." - "IdenFunctionArgs.juvix" - "out/IdenFunctionArgs.out", + $(mkRelDir ".") + $(mkRelFile "IdenFunctionArgs.juvix") + $(mkRelFile "out/IdenFunctionArgs.out"), PosTest "A function with implicit arguments" - "." - "IdenFunctionArgsImplicit.juvix" - "out/IdenFunctionArgsImplicit.out", + $(mkRelDir ".") + $(mkRelFile "IdenFunctionArgsImplicit.juvix") + $(mkRelFile "out/IdenFunctionArgsImplicit.out"), PosTest "A function with no explicit arguments" - "." - "IdenFunctionArgsNoExplicit.juvix" - "out/IdenFunctionArgsNoExplicit.out", + $(mkRelDir ".") + $(mkRelFile "IdenFunctionArgsNoExplicit.juvix") + $(mkRelFile "out/IdenFunctionArgsNoExplicit.out"), PosTest "A module that imports another" - "Import" - "Importer.juvix" - "out/Importer.out", + $(mkRelDir "Import") + $(mkRelFile "Importer.juvix") + $(mkRelFile "out/Importer.out"), PosTest "A constructor valued function" - "." - "FunctionReturnConstructor.juvix" - "out/FunctionReturnConstructor.out", + $(mkRelDir ".") + $(mkRelFile "FunctionReturnConstructor.juvix") + $(mkRelFile "out/FunctionReturnConstructor.out"), PosTest "Pattern matching on a constructor" - "." - "MatchConstructor.juvix" - "out/MatchConstructor.out", + $(mkRelDir ".") + $(mkRelFile "MatchConstructor.juvix") + $(mkRelFile "out/MatchConstructor.out"), PosTest "Pattern matching Nat under suc" - "." - "NatMatch1.juvix" - "out/NatMatch1.out", + $(mkRelDir ".") + $(mkRelFile "NatMatch1.juvix") + $(mkRelFile "out/NatMatch1.out"), PosTest "Pattern matching Nat as binder" - "." - "NatMatch2.juvix" - "out/NatMatch2.out", + $(mkRelDir ".") + $(mkRelFile "NatMatch2.juvix") + $(mkRelFile "out/NatMatch2.out"), PosTest "Literal integer is Core integer" - "." - "LitInteger.juvix" - "out/LitInteger.out", + $(mkRelDir ".") + $(mkRelFile "LitInteger.juvix") + $(mkRelFile "out/LitInteger.out"), PosTest "Literal integer is Core string" - "." - "LitString.juvix" - "out/LitString.out", + $(mkRelDir ".") + $(mkRelFile "LitString.juvix") + $(mkRelFile "out/LitString.out"), PosTest "Mutually defined functions" - "." - "Mutual.juvix" - "out/Mutual.out", + $(mkRelDir ".") + $(mkRelFile "Mutual.juvix") + $(mkRelFile "out/Mutual.out"), PosTest "Calling builtin addition" - "." - "BuiltinAdd.juvix" - "out/BuiltinAdd.out", + $(mkRelDir ".") + $(mkRelFile "BuiltinAdd.juvix") + $(mkRelFile "out/BuiltinAdd.out"), PosTest "Builtin bool" - "." - "BuiltinBool.juvix" - "out/BuiltinBool.out", + $(mkRelDir ".") + $(mkRelFile "BuiltinBool.juvix") + $(mkRelFile "out/BuiltinBool.out"), PosTest "Builtin if" - "." - "BuiltinIf.juvix" - "out/BuiltinIf.out", + $(mkRelDir ".") + $(mkRelFile "BuiltinIf.juvix") + $(mkRelFile "out/BuiltinIf.out"), PosTest "Lambda" - "." - "Lambda.juvix" - "out/Lambda.out", + $(mkRelDir ".") + $(mkRelFile "Lambda.juvix") + $(mkRelFile "out/Lambda.out"), PosTest "Pattern args" - "." - "PatternArgs.juvix" - "out/PatternArgs.out", + $(mkRelDir ".") + $(mkRelFile "PatternArgs.juvix") + $(mkRelFile "out/PatternArgs.out"), PosTest "QuickSort" - "." - "QuickSort.juvix" - "out/QuickSort.out", + $(mkRelDir ".") + $(mkRelFile "QuickSort.juvix") + $(mkRelFile "out/QuickSort.out"), PosTest "Universe" - "." - "Universe.juvix" - "out/Universe.out", + $(mkRelDir ".") + $(mkRelFile "Universe.juvix") + $(mkRelFile "out/Universe.out"), PosTest "Inductive type constructor" - "." - "Inductive.juvix" - "out/Inductive.out", + $(mkRelDir ".") + $(mkRelFile "Inductive.juvix") + $(mkRelFile "out/Inductive.out"), PosTest "Function type" - "." - "FunctionType.juvix" - "out/FunctionType.out", + $(mkRelDir ".") + $(mkRelFile "FunctionType.juvix") + $(mkRelFile "out/FunctionType.out"), PosTest "Builtin Inductive type" - "." - "BuiltinInductive.juvix" - "out/BuiltinInductive.out" + $(mkRelDir ".") + $(mkRelFile "BuiltinInductive.juvix") + $(mkRelFile "out/BuiltinInductive.out") ] diff --git a/test/Parsing/Negative.hs b/test/Parsing/Negative.hs index b64f1058f..52b17b83c 100644 --- a/test/Parsing/Negative.hs +++ b/test/Parsing/Negative.hs @@ -5,23 +5,24 @@ import Juvix.Compiler.Builtins (iniState) import Juvix.Compiler.Pipeline import Juvix.Parser.Error -root :: FilePath -root = "tests/negative" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/negative") data NegTest = NegTest { _name :: String, - _relDir :: FilePath, - _file :: FilePath + _relDir :: Path Rel Dir, + _file :: Path Rel File } testDescr :: NegTest -> TestDescr testDescr NegTest {..} = - let tRoot = root _relDir + let tRoot = root _relDir + file' = tRoot _file in TestDescr { _testName = _name, _testRoot = tRoot, _testAssertion = Single $ do - let entryPoint = defaultEntryPoint _file + let entryPoint = defaultEntryPoint tRoot file' res <- runIOEither iniState entryPoint upToParsing case mapLeft fromJuvixError res of Left (Just (_ :: ParserError)) -> return () @@ -40,6 +41,6 @@ scoperErrorTests :: [NegTest] scoperErrorTests = [ NegTest "Tab character" - "." - "Tab.juvix" + $(mkRelDir ".") + $(mkRelFile "Tab.juvix") ] diff --git a/test/Reachability/Positive.hs b/test/Reachability/Positive.hs index 6a718ad22..366547a1e 100644 --- a/test/Reachability/Positive.hs +++ b/test/Reachability/Positive.hs @@ -9,30 +9,29 @@ import Juvix.Compiler.Pipeline data PosTest = PosTest { _name :: String, - _relDir :: FilePath, + _relDir :: Path Rel Dir, _stdlibMode :: StdlibMode, - _file :: FilePath, + _file :: Path Rel File, _reachable :: HashSet String } makeLenses ''PosTest -root :: FilePath -root = "tests/positive" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/positive") testDescr :: PosTest -> TestDescr testDescr PosTest {..} = - let tRoot = root _relDir + let tRoot = root _relDir + file' = tRoot _file in TestDescr { _testName = _name, _testRoot = tRoot, _testAssertion = Steps $ \step -> do - cwd <- getCurrentDirectory - entryFile <- canonicalizePath _file let noStdlib = _stdlibMode == StdlibExclude entryPoint = - (defaultEntryPoint entryFile) - { _entryPointRoot = cwd, + (defaultEntryPoint tRoot file') + { _entryPointRoot = tRoot, _entryPointNoStdlib = noStdlib } @@ -67,25 +66,25 @@ tests :: [PosTest] tests = [ PosTest "Reachability with modules" - "Reachability" + $(mkRelDir "Reachability") StdlibInclude - "M.juvix" + $(mkRelFile "M.juvix") ( HashSet.fromList ["f", "g", "h", "Bool", "Maybe"] ), PosTest "Reachability with modules and standard library" - "Reachability" + $(mkRelDir "Reachability") StdlibInclude - "N.juvix" + $(mkRelFile "N.juvix") ( HashSet.fromList ["test", "Unit"] ), PosTest "Reachability with public imports" - "Reachability" + $(mkRelDir "Reachability") StdlibInclude - "O.juvix" + $(mkRelFile "O.juvix") ( HashSet.fromList ["f", "g", "h", "k", "Bool", "Maybe"] ) diff --git a/test/Runtime/Base.hs b/test/Runtime/Base.hs index a80969809..729164c2b 100644 --- a/test/Runtime/Base.hs +++ b/test/Runtime/Base.hs @@ -3,20 +3,19 @@ module Runtime.Base where import Base import Data.FileEmbed import Data.Text.IO qualified as TIO -import System.IO.Extra (withTempDir) import System.Process qualified as P clangCompile :: - (FilePath -> FilePath -> [String]) -> - FilePath -> - FilePath -> - (FilePath -> IO Text) -> + (Path Abs File -> Path Abs File -> [String]) -> + Path Abs File -> + Path Rel File -> + (Path Abs File -> IO Text) -> (String -> IO ()) -> IO Text clangCompile mkClangArgs inputFile outputFile execute step = - withTempDir + withTempDir' ( \dirPath -> do - let outputFile' = dirPath outputFile + let outputFile' = dirPath outputFile step "C compilation" P.callProcess "clang" @@ -25,37 +24,38 @@ clangCompile mkClangArgs inputFile outputFile execute step = execute outputFile' ) -clangAssertion :: FilePath -> FilePath -> Text -> ((String -> IO ()) -> Assertion) +clangAssertion :: Path Abs File -> Path Abs File -> Text -> ((String -> IO ()) -> Assertion) clangAssertion inputFile expectedFile stdinText step = do step "Check clang and wasmer are on path" - assertCmdExists "clang" - assertCmdExists "wasmer" + assertCmdExists $(mkRelFile "clang") + assertCmdExists $(mkRelFile "wasmer") step "Lookup WASI_SYSROOT_PATH" - sysrootPath <- - assertEnvVar - "Env var WASI_SYSROOT_PATH missing. Set to the location of the wasi-clib sysroot" - "WASI_SYSROOT_PATH" + sysrootPath :: Path Abs Dir <- + absDir + <$> assertEnvVar + "Env var WASI_SYSROOT_PATH missing. Set to the location of the wasi-clib sysroot" + "WASI_SYSROOT_PATH" - expected <- TIO.readFile expectedFile + expected <- TIO.readFile (toFilePath expectedFile) - let executeWasm :: FilePath -> IO Text - executeWasm outputFile = pack <$> P.readProcess "wasmer" [outputFile] (unpack stdinText) + let executeWasm :: Path Abs File -> IO Text + executeWasm outputFile = pack <$> P.readProcess "wasmer" [toFilePath outputFile] (unpack stdinText) - let executeNative :: FilePath -> IO Text - executeNative outputFile = pack <$> P.readProcess outputFile [] (unpack stdinText) + let executeNative :: Path Abs File -> IO Text + executeNative outputFile = pack <$> P.readProcess (toFilePath outputFile) [] (unpack stdinText) step "Compile C to WASM32-WASI" - actualWasm <- clangCompile (wasiArgs sysrootPath) inputFile "Program.wasm" executeWasm step + actualWasm <- clangCompile (wasiArgs sysrootPath) inputFile $(mkRelFile "Program.wasm") executeWasm step step "Compare expected and actual program output" - assertEqDiff ("check: WASM output = " <> expectedFile) actualWasm expected + assertEqDiff ("check: WASM output = " <> toFilePath expectedFile) actualWasm expected step "Compile C to native 64-bit code" - actualNative <- clangCompile native64Args inputFile "Program" executeNative step + actualNative <- clangCompile native64Args inputFile $(mkRelFile "Program") executeNative step step "Compare expected and actual program output" - assertEqDiff ("check: native output = " <> expectedFile) actualNative expected + assertEqDiff ("check: native output = " <> toFilePath expectedFile) actualNative expected -commonArgs :: FilePath -> [String] +commonArgs :: Path Abs File -> [String] commonArgs outputFile = [ "-DDEBUG", "-W", @@ -67,13 +67,13 @@ commonArgs outputFile = "-I", runtimeInclude, "-o", - outputFile + toFilePath outputFile ] where runtimeInclude :: FilePath runtimeInclude = $(makeRelativeToProject "runtime/include" >>= strToExp) -native64Args :: FilePath -> FilePath -> [String] +native64Args :: Path Abs File -> Path Abs File -> [String] native64Args outputFile inputFile = commonArgs outputFile <> [ "-DARCH_NATIVE64", @@ -82,14 +82,14 @@ native64Args outputFile inputFile = "-O3", "-L", juvixLibraryDir, - inputFile, + toFilePath inputFile, "-ljuvix" ] where juvixLibraryDir :: FilePath juvixLibraryDir = $(makeRelativeToProject "runtime/_build.native64-debug" >>= strToExp) -wasiArgs :: FilePath -> FilePath -> FilePath -> [String] +wasiArgs :: Path Abs Dir -> Path Abs File -> Path Abs File -> [String] wasiArgs sysrootPath outputFile inputFile = commonArgs outputFile <> [ "-DARCH_WASM32", @@ -98,12 +98,12 @@ wasiArgs sysrootPath outputFile inputFile = "-nodefaultlibs", "--target=wasm32-wasi", "--sysroot", - sysrootPath, + toFilePath sysrootPath, "-L", - juvixLibraryDir, - inputFile, + toFilePath juvixLibraryDir, + toFilePath inputFile, "-ljuvix" ] where - juvixLibraryDir :: FilePath - juvixLibraryDir = $(makeRelativeToProject "runtime/_build.wasm32-wasi-debug" >>= strToExp) + juvixLibraryDir :: Path Abs Dir + juvixLibraryDir = absDir $(makeRelativeToProject "runtime/_build.wasm32-wasi-debug" >>= strToExp) diff --git a/test/Runtime/Positive.hs b/test/Runtime/Positive.hs index 460a1f6ee..6671f2062 100644 --- a/test/Runtime/Positive.hs +++ b/test/Runtime/Positive.hs @@ -5,23 +5,25 @@ import Runtime.Base data PosTest = PosTest { _name :: String, - _relDir :: FilePath, - _file :: FilePath, - _expectedFile :: FilePath + _relDir :: Path Rel Dir, + _file :: Path Rel File, + _expectedFile :: Path Rel File } makeLenses ''PosTest -root :: FilePath -root = "tests/runtime/positive/" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/runtime/positive/") testDescr :: PosTest -> TestDescr testDescr PosTest {..} = - let tRoot = root _relDir + let tRoot = root _relDir + file' = tRoot _file + expected' = tRoot _expectedFile in TestDescr { _testName = _name, _testRoot = tRoot, - _testAssertion = Steps $ clangAssertion _file _expectedFile "" + _testAssertion = Steps $ clangAssertion file' expected' "" } allTests :: TestTree @@ -34,102 +36,102 @@ tests :: [PosTest] tests = [ PosTest "HelloWorld" - "." - "test001.c" - "out/test001.out", + $(mkRelDir ".") + $(mkRelFile "test001.c") + $(mkRelFile "out/test001.out"), PosTest "Page allocation" - "." - "test002.c" - "out/test002.out", + $(mkRelDir ".") + $(mkRelFile "test002.c") + $(mkRelFile "out/test002.out"), PosTest "Printing of integers" - "." - "test003.c" - "out/test003.out", + $(mkRelDir ".") + $(mkRelFile "test003.c") + $(mkRelFile "out/test003.out"), PosTest "Allocator for unstructured objects" - "." - "test004.c" - "out/test004.out", + $(mkRelDir ".") + $(mkRelFile "test004.c") + $(mkRelFile "out/test004.out"), PosTest "Allocator for unstructured objects (macro API)" - "." - "test005.c" - "out/test005.out", + $(mkRelDir ".") + $(mkRelFile "test005.c") + $(mkRelFile "out/test005.out"), PosTest "Stack" - "." - "test006.c" - "out/test006.out", + $(mkRelDir ".") + $(mkRelFile "test006.c") + $(mkRelFile "out/test006.out"), PosTest "Prologue and epilogue" - "." - "test007.c" - "out/test007.out", + $(mkRelDir ".") + $(mkRelFile "test007.c") + $(mkRelFile "out/test007.out"), PosTest "Basic arithmetic" - "." - "test008.c" - "out/test008.out", + $(mkRelDir ".") + $(mkRelFile "test008.c") + $(mkRelFile "out/test008.out"), PosTest "Direct call" - "." - "test009.c" - "out/test009.out", + $(mkRelDir ".") + $(mkRelFile "test009.c") + $(mkRelFile "out/test009.out"), PosTest "Indirect call" - "." - "test010.c" - "out/test010.out", + $(mkRelDir ".") + $(mkRelFile "test010.c") + $(mkRelFile "out/test010.out"), PosTest "Tail calls" - "." - "test011.c" - "out/test011.out", + $(mkRelDir ".") + $(mkRelFile "test011.c") + $(mkRelFile "out/test011.out"), PosTest "Tracing and strings" - "." - "test012.c" - "out/test012.out", + $(mkRelDir ".") + $(mkRelFile "test012.c") + $(mkRelFile "out/test012.out"), PosTest "IO builtins" - "." - "test013.c" - "out/test013.out", + $(mkRelDir ".") + $(mkRelFile "test013.c") + $(mkRelFile "out/test013.out"), PosTest "Higher-order functions" - "." - "test014.c" - "out/test014.out", + $(mkRelDir ".") + $(mkRelFile "test014.c") + $(mkRelFile "out/test014.out"), PosTest "Branching, matching and recursion on lists" - "." - "test015.c" - "out/test015.out", + $(mkRelDir ".") + $(mkRelFile "test015.c") + $(mkRelFile "out/test015.out"), PosTest "Closure extension" - "." - "test016.c" - "out/test016.out", + $(mkRelDir ".") + $(mkRelFile "test016.c") + $(mkRelFile "out/test016.out"), PosTest "Recursion through higher-order functions" - "." - "test017.c" - "out/test017.out", + $(mkRelDir ".") + $(mkRelFile "test017.c") + $(mkRelFile "out/test017.out"), PosTest "Tail recursion through higher-order functions" - "." - "test018.c" - "out/test018.out", + $(mkRelDir ".") + $(mkRelFile "test018.c") + $(mkRelFile "out/test018.out"), PosTest "Dynamic closure extension" - "." - "test019.c" - "out/test019.out", + $(mkRelDir ".") + $(mkRelFile "test019.c") + $(mkRelFile "out/test019.out"), PosTest "Higher-order function composition" - "." - "test020.c" - "out/test020.out" + $(mkRelDir ".") + $(mkRelFile "test020.c") + $(mkRelFile "out/test020.out") ] diff --git a/test/Scope/Negative.hs b/test/Scope/Negative.hs index 89823a1c0..05d26c197 100644 --- a/test/Scope/Negative.hs +++ b/test/Scope/Negative.hs @@ -2,6 +2,7 @@ module Scope.Negative (allTests) where import Base import Juvix.Compiler.Builtins (iniState) +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error import Juvix.Compiler.Pipeline @@ -9,27 +10,28 @@ type FailMsg = String data NegTest a = NegTest { _name :: String, - _relDir :: FilePath, - _file :: FilePath, + _relDir :: Path Rel Dir, + _file :: Path Rel File, _checkErr :: a -> Maybe FailMsg } -root :: FilePath -root = "tests/negative" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/negative") testDescr :: Typeable a => NegTest a -> TestDescr testDescr NegTest {..} = - let tRoot = root _relDir + let tRoot = root _relDir + file' = tRoot _file in TestDescr { _testName = _name, _testRoot = tRoot, _testAssertion = Single $ do - let entryPoint = defaultEntryPoint _file + let entryPoint = defaultEntryPoint tRoot file' res <- runIOEither iniState entryPoint upToAbstract case mapLeft fromJuvixError res of Left (Just err) -> whenJust (_checkErr err) assertFailure - Left Nothing -> assertFailure "The scope checker did not find an error." - Right _ -> assertFailure "An error ocurred but it was not in the scoper." + Left Nothing -> assertFailure "An error ocurred but it was not in the scoper." + Right {} -> assertFailure "The scope checker did not find an error." } allTests :: TestTree @@ -47,228 +49,232 @@ scoperErrorTests :: [NegTest ScoperError] scoperErrorTests = [ NegTest "Not in scope" - "." - "NotInScope.juvix" + $(mkRelDir ".") + $(mkRelFile "NotInScope.juvix") $ \case ErrSymNotInScope {} -> Nothing _ -> wrongError, NegTest "Qualified not in scope" - "." - "QualSymNotInScope.juvix" + $(mkRelDir ".") + $(mkRelFile "QualSymNotInScope.juvix") $ \case ErrQualSymNotInScope {} -> Nothing _ -> wrongError, NegTest "Multiple declarations" - "." - "MultipleDeclarations.juvix" + $(mkRelDir ".") + $(mkRelFile "MultipleDeclarations.juvix") $ \case ErrMultipleDeclarations {} -> Nothing _ -> wrongError, NegTest "Import cycle" - "ImportCycle" - "A.juvix" + $(mkRelDir "ImportCycle") + $(mkRelFile "A.juvix") $ \case ErrImportCycle {} -> Nothing _ -> wrongError, NegTest "Binding group conflict (function clause)" - "BindGroupConflict" - "Clause.juvix" + $(mkRelDir "BindGroupConflict") + $(mkRelFile "Clause.juvix") $ \case ErrBindGroup {} -> Nothing _ -> wrongError, NegTest "Binding group conflict (lambda clause)" - "BindGroupConflict" - "Lambda.juvix" + $(mkRelDir "BindGroupConflict") + $(mkRelFile "Lambda.juvix") $ \case ErrBindGroup {} -> Nothing _ -> wrongError, NegTest "Infix error (expression)" - "." - "InfixError.juvix" + $(mkRelDir ".") + $(mkRelFile "InfixError.juvix") $ \case ErrInfixParser {} -> Nothing _ -> wrongError, NegTest "Infix error (pattern)" - "." - "InfixErrorP.juvix" + $(mkRelDir ".") + $(mkRelFile "InfixErrorP.juvix") $ \case ErrInfixPattern {} -> Nothing _ -> wrongError, NegTest "Duplicate fixity declaration" - "." - "DuplicateFixity.juvix" + $(mkRelDir ".") + $(mkRelFile "DuplicateFixity.juvix") $ \case ErrDuplicateFixity {} -> Nothing _ -> wrongError, NegTest "Multiple export conflict" - "." - "MultipleExportConflict.juvix" + $(mkRelDir ".") + $(mkRelFile "MultipleExportConflict.juvix") $ \case ErrMultipleExport {} -> Nothing _ -> wrongError, NegTest "Module not in scope" - "." - "ModuleNotInScope.juvix" + $(mkRelDir ".") + $(mkRelFile "ModuleNotInScope.juvix") $ \case ErrModuleNotInScope {} -> Nothing _ -> wrongError, NegTest "Unused operator syntax definition" - "." - "UnusedOperatorDef.juvix" + $(mkRelDir ".") + $(mkRelFile "UnusedOperatorDef.juvix") $ \case ErrUnusedOperatorDef {} -> Nothing _ -> wrongError, NegTest "Ambiguous symbol" - "." - "AmbiguousSymbol.juvix" + $(mkRelDir ".") + $(mkRelFile "AmbiguousSymbol.juvix") $ \case ErrAmbiguousSym {} -> Nothing _ -> wrongError, NegTest "Lacks function clause" - "." - "LacksFunctionClause.juvix" + $(mkRelDir ".") + $(mkRelFile "LacksFunctionClause.juvix") $ \case ErrLacksFunctionClause {} -> Nothing _ -> wrongError, NegTest "Incorrect top module path" - "." - "WrongModuleName.juvix" + $(mkRelDir ".") + $(mkRelFile "WrongModuleName.juvix") $ \case ErrWrongTopModuleName {} -> Nothing _ -> wrongError, NegTest "Ambiguous export" - "." - "AmbiguousExport.juvix" + $(mkRelDir ".") + $(mkRelFile "AmbiguousExport.juvix") $ \case ErrMultipleExport {} -> Nothing _ -> wrongError, NegTest "Ambiguous nested modules" - "." - "AmbiguousModule.juvix" + $(mkRelDir ".") + $(mkRelFile "AmbiguousModule.juvix") $ \case ErrAmbiguousModuleSym {} -> Nothing _ -> wrongError, NegTest "Ambiguous nested constructors" - "." - "AmbiguousConstructor.juvix" + $(mkRelDir ".") + $(mkRelFile "AmbiguousConstructor.juvix") $ \case ErrAmbiguousSym {} -> Nothing _ -> wrongError, NegTest "Wrong location of a compile block" - "CompileBlocks" - "WrongLocationCompileBlock.juvix" + $(mkRelDir "CompileBlocks") + $(mkRelFile "WrongLocationCompileBlock.juvix") $ \case ErrWrongLocationCompileBlock {} -> Nothing _ -> wrongError, NegTest "Implicit argument on the left of an application" - "." - "AppLeftImplicit.juvix" + $(mkRelDir ".") + $(mkRelFile "AppLeftImplicit.juvix") $ \case ErrAppLeftImplicit {} -> Nothing _ -> wrongError, NegTest "Multiple compile blocks for the same name" - "CompileBlocks" - "MultipleCompileBlockSameName.juvix" + $(mkRelDir "CompileBlocks") + $(mkRelFile "MultipleCompileBlockSameName.juvix") $ \case ErrMultipleCompileBlockSameName {} -> Nothing _ -> wrongError, NegTest "Multiple rules for a backend inside a compile block" - "CompileBlocks" - "MultipleCompileRuleSameBackend.juvix" + $(mkRelDir "CompileBlocks") + $(mkRelFile "MultipleCompileRuleSameBackend.juvix") $ \case ErrMultipleCompileRuleSameBackend {} -> Nothing _ -> wrongError, NegTest "issue 230" - "230" - "Prod.juvix" + $(mkRelDir "230") + $(mkRelFile "Prod.juvix") $ \case ErrQualSymNotInScope {} -> Nothing _ -> wrongError, NegTest "Double braces in pattern" - "." - "NestedPatternBraces.juvix" + $(mkRelDir ".") + $(mkRelFile "NestedPatternBraces.juvix") $ \case ErrDoubleBracesPattern {} -> Nothing _ -> wrongError, NegTest "As-Pattern aliasing variable" - "." - "AsPatternAlias.juvix" + $(mkRelDir ".") + $(mkRelFile "AsPatternAlias.juvix") $ \case ErrAliasBinderPattern {} -> Nothing _ -> wrongError, NegTest "Nested As-Patterns" - "." - "NestedAsPatterns.juvix" + $(mkRelDir ".") + $(mkRelFile "NestedAsPatterns.juvix") $ \case ErrDoubleBinderPattern {} -> Nothing _ -> wrongError, NegTest "Pattern matching an implicit argument on the left of an application" - "." - "ImplicitPatternLeftApplication.juvix" + $(mkRelDir ".") + $(mkRelFile "ImplicitPatternLeftApplication.juvix") $ \case ErrImplicitPatternLeftApplication {} -> Nothing _ -> wrongError, NegTest "Constructor expected on the left of a pattern application" - "." - "ConstructorExpectedLeftApplication.juvix" + $(mkRelDir ".") + $(mkRelFile "ConstructorExpectedLeftApplication.juvix") $ \case ErrConstructorExpectedLeftApplication {} -> Nothing _ -> wrongError, NegTest "Compile block for a unsupported kind of expression" - "CompileBlocks" - "WrongKindExpressionCompileBlock.juvix" + $(mkRelDir "CompileBlocks") + $(mkRelFile "WrongKindExpressionCompileBlock.juvix") $ \case ErrWrongKindExpressionCompileBlock {} -> Nothing _ -> wrongError, NegTest "A type parameter name occurs twice when declaring an inductive type" - "." - "DuplicateInductiveParameterName.juvix" + $(mkRelDir ".") + $(mkRelFile "DuplicateInductiveParameterName.juvix") $ \case ErrDuplicateInductiveParameterName {} -> Nothing _ -> wrongError ] -filesErrorTests :: [NegTest FilesError] +filesErrorTests :: [NegTest ScoperError] filesErrorTests = [ NegTest "A module that conflicts with a module in the stdlib" - "StdlibConflict" - "Stdlib/Data/Bool.juvix" + $(mkRelDir "StdlibConflict") + $(mkRelFile "Input.juvix") $ \case - FilesError {} -> Nothing, + ErrTopModulePath + TopModulePathError {_topModulePathError = ErrDependencyConflict {}} -> Nothing + _ -> wrongError, NegTest "Importing a module that conflicts with a module in the stdlib" - "StdlibConflict" - "Input.juvix" + $(mkRelDir "StdlibConflict") + $(mkRelFile "Input.juvix") $ \case - FilesError {} -> Nothing + ErrTopModulePath + TopModulePathError {_topModulePathError = ErrDependencyConflict {}} -> Nothing + _ -> wrongError ] diff --git a/test/Scope/Positive.hs b/test/Scope/Positive.hs index 4caea77f7..e268c64ef 100644 --- a/test/Scope/Positive.hs +++ b/test/Scope/Positive.hs @@ -5,97 +5,106 @@ import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Builtins (iniState) import Juvix.Compiler.Concrete qualified as Concrete import Juvix.Compiler.Concrete.Extra +import Juvix.Compiler.Concrete.Language import Juvix.Compiler.Concrete.Pretty qualified as M +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser import Juvix.Compiler.Pipeline import Juvix.Compiler.Pipeline.Setup -import Juvix.Extra.Stdlib +import Juvix.Prelude.Aeson import Juvix.Prelude.Pretty data PosTest = PosTest { _name :: String, - _relDir :: FilePath, - _stdlibMode :: StdlibMode, - _file :: FilePath + _relDir :: Path Rel Dir, + _file :: Path Rel File } makeLenses ''PosTest -root :: FilePath -root = "tests/positive" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/positive") renderCode :: M.PrettyCode c => c -> Text renderCode = prettyText . M.ppOutDefault +type Pipe = + '[ PathResolver, + Reader EntryPoint, + Files, + NameIdGen, + Error JuvixError, + Reader GenericOptions, + Embed IO + ] + testDescr :: PosTest -> TestDescr testDescr PosTest {..} = - let tRoot = root _relDir + let tRoot = root _relDir + file' = tRoot _file in TestDescr { _testName = _name, _testRoot = tRoot, _testAssertion = Steps $ \step -> do - cwd <- getCurrentDirectory - entryFile <- canonicalizePath _file - let noStdlib = _stdlibMode == StdlibExclude - entryPoint = - (defaultEntryPoint entryFile) - { _entryPointRoot = cwd, - _entryPointNoStdlib = noStdlib - } - stdlibMap :: HashMap FilePath Text - stdlibMap = HashMap.mapKeys (cwd ) (HashMap.fromList (second decodeUtf8 <$> stdlibFiles)) - unionStdlib :: HashMap FilePath Text -> HashMap FilePath Text - unionStdlib fs - | noStdlib = fs - | otherwise = HashMap.union fs stdlibMap + pkg <- readPackageIO tRoot + let entryPoint = entryPointFromPackage tRoot file' pkg + runHelper :: HashMap (Path Abs File) Text -> Sem Pipe a -> IO (ResolverState, a) + runHelper files = + runM + . runErrorIO' @JuvixError + . runNameIdGen + . runFilesPure files tRoot + . runReader entryPoint + . runPathResolverPipe + evalHelper :: HashMap (Path Abs File) Text -> Sem Pipe a -> IO a + evalHelper files = fmap snd . runHelper files step "Parsing" p :: Parser.ParserResult <- snd <$> runIO' iniState entryPoint upToParsing - let p2 = head (p ^. Parser.resultModules) + let p2 :: Module 'Parsed 'ModuleTop = head (p ^. Parser.resultModules) step "Scoping" - s :: Scoper.ScoperResult <- - snd - <$> runIO' - iniState - entryPoint - ( do - void entrySetup - Concrete.fromParsed p - ) + (artif :: Artifacts, s :: Scoper.ScoperResult) <- + runIO' + iniState + entryPoint + ( do + void entrySetup + Concrete.fromParsed p + ) let s2 = head (s ^. Scoper.resultModules) - fs :: HashMap FilePath Text + yamlFiles :: [(Path Abs File, Text)] + yamlFiles = + [ (pkgi ^. packageRoot juvixYamlFile, encodeToText (rawPackage (pkgi ^. packagePackage))) + | pkgi <- toList (artif ^. artifactResolver . resolverPackages) + ] + fs :: HashMap (Path Abs File) Text fs = - unionStdlib - ( HashMap.fromList - [ (getModuleFileAbsPath cwd m, renderCode m) - | m <- toList (getAllModules s2) - ] - ) + HashMap.fromList $ + [ (absFile (getModuleFileAbsPath (toFilePath tRoot) m), renderCode m) + | m <- toList (getAllModules s2) + ] + <> yamlFiles let scopedPretty = renderCode s2 parsedPretty = renderCode p2 + onlyMainFile :: Text -> HashMap (Path Abs File) Text + onlyMainFile t = HashMap.fromList $ (file', t) : yamlFiles step "Parsing pretty scoped" - let fs2 = unionStdlib (HashMap.singleton entryFile scopedPretty) - p' :: Parser.ParserResult <- - (runM . runErrorIO' @JuvixError . runNameIdGen . runFilesPure cwd fs2 . runReader entryPoint) - upToParsing + let fs2 = onlyMainFile scopedPretty + p' :: Parser.ParserResult <- evalHelper fs2 upToParsing step "Parsing pretty parsed" - let fs3 = unionStdlib (HashMap.singleton entryFile parsedPretty) - parsedPretty' :: Parser.ParserResult <- - (runM . runErrorIO' @JuvixError . runNameIdGen . runFilesPure cwd fs3 . runReader entryPoint) - upToParsing + let fs3 = onlyMainFile parsedPretty + parsedPretty' :: Parser.ParserResult <- evalHelper fs3 upToParsing step "Scoping the scoped" - s' :: Scoper.ScoperResult <- - (runM . runErrorIO' @JuvixError . runNameIdGen . runFilesPure cwd fs . runReader entryPoint) - upToScoping + s' :: Scoper.ScoperResult <- evalHelper fs upToScoping step "Checks" let smodules = s ^. Scoper.resultModules @@ -120,102 +129,86 @@ tests :: [PosTest] tests = [ PosTest "Inductive" - "." - StdlibInclude - "Inductive.juvix", + $(mkRelDir ".") + $(mkRelFile "Inductive.juvix"), PosTest "Imports and qualified names" - "Imports" - StdlibInclude - "A.juvix", + $(mkRelDir "Imports") + $(mkRelFile "A.juvix"), PosTest "Data.Bool from the stdlib" - "StdlibList" - StdlibExclude - "Data/Bool.juvix", + $(mkRelDir "StdlibList") + $(mkRelFile "Data/Bool.juvix"), PosTest "Data.Nat from the stdlib" - "StdlibList" - StdlibExclude - "Data/Nat.juvix", + $(mkRelDir "StdlibList") + $(mkRelFile "Data/Nat.juvix"), PosTest "Data.Ord from the stdlib" - "StdlibList" - StdlibExclude - "Data/Ord.juvix", + $(mkRelDir "StdlibList") + $(mkRelFile "Data/Ord.juvix"), PosTest "Data.Product from the stdlib" - "StdlibList" - StdlibExclude - "Data/Product.juvix", + $(mkRelDir "StdlibList") + $(mkRelFile "Data/Product.juvix"), PosTest "Data.List and friends from the stdlib" - "StdlibList" - StdlibExclude - "Data/List.juvix", + $(mkRelDir "StdlibList") + $(mkRelFile "Data/List.juvix"), PosTest "Operators (+)" - "." - StdlibExclude - "Operators.juvix", + $(mkRelDir ".") + $(mkRelFile "Operators.juvix"), PosTest "Literals" - "." - StdlibExclude - "Literals.juvix", + $(mkRelDir ".") + $(mkRelFile "Literals.juvix"), PosTest "Axiom with backends" - "." - StdlibExclude - "Axiom.juvix", + $(mkRelDir ".") + $(mkRelFile "Axiom.juvix"), PosTest "Foreign block parsing" - "." - StdlibExclude - "Foreign.juvix", + $(mkRelDir ".") + $(mkRelFile "Foreign.juvix"), PosTest "Multiple modules non-ambiguous symbol - same file" - "QualifiedSymbol" - StdlibExclude - "M.juvix", + $(mkRelDir "QualifiedSymbol") + $(mkRelFile "M.juvix"), PosTest "Multiple modules non-ambiguous symbol" - "QualifiedSymbol2" - StdlibExclude - "N.juvix", + $(mkRelDir "QualifiedSymbol2") + $(mkRelFile "N.juvix"), PosTest "Multiple modules constructor non-ambiguous symbol" - "QualifiedConstructor" - StdlibExclude - "M.juvix", + $(mkRelDir "QualifiedConstructor") + $(mkRelFile "M.juvix"), PosTest "Parsing" - "." - StdlibExclude - "Parsing.juvix", + $(mkRelDir ".") + $(mkRelFile "Parsing.juvix"), PosTest "open overrides open public" - "." - StdlibExclude - "ShadowPublicOpen.juvix", + $(mkRelDir ".") + $(mkRelFile "ShadowPublicOpen.juvix"), PosTest "Infix chains" - "." - StdlibInclude - "Ape.juvix", + $(mkRelDir ".") + $(mkRelFile "Ape.juvix"), PosTest "Import embedded standard library" - "StdlibImport" - StdlibInclude - "StdlibImport.juvix", + $(mkRelDir "StdlibImport") + $(mkRelFile "StdlibImport.juvix"), + PosTest + "Basic dependencies" + $(mkRelDir "Dependencies") + $(mkRelFile "Input.juvix"), PosTest "Check Valid Symbols" - "" - StdlibInclude - "Symbols.juvix", + $(mkRelDir ".") + $(mkRelFile "Symbols.juvix"), PosTest "Builtin bool" - "." - StdlibExclude - "BuiltinsBool.juvix" + $(mkRelDir ".") + $(mkRelFile "BuiltinsBool.juvix") ] diff --git a/test/Termination/Negative.hs b/test/Termination/Negative.hs index be8e29f17..7e3207fb0 100644 --- a/test/Termination/Negative.hs +++ b/test/Termination/Negative.hs @@ -9,19 +9,20 @@ type FailMsg = String data NegTest = NegTest { _name :: String, - _relDir :: FilePath, - _file :: FilePath, + _relDir :: Path Rel Dir, + _file :: Path Rel File, _checkErr :: TerminationError -> Maybe FailMsg } testDescr :: NegTest -> TestDescr testDescr NegTest {..} = - let tRoot = root _relDir + let tRoot = root _relDir + file' = tRoot _file in TestDescr { _testName = _name, _testRoot = tRoot, _testAssertion = Single $ do - let entryPoint = (defaultEntryPoint _file) {_entryPointNoStdlib = True} + let entryPoint = (defaultEntryPoint tRoot file') {_entryPointNoStdlib = True} result <- runIOEither iniState entryPoint upToInternal case mapLeft fromJuvixError result of Left (Just lexError) -> whenJust (_checkErr lexError) assertFailure @@ -35,51 +36,51 @@ allTests = "Termination negative tests" (map (mkTest . testDescr) tests) -root :: FilePath -root = "tests/negative/Termination" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/negative/Termination") tests :: [NegTest] tests = [ NegTest "Mutual recursive functions non terminating" - "." - "Mutual.juvix" + $(mkRelDir ".") + $(mkRelFile "Mutual.juvix") $ \case ErrNoLexOrder {} -> Nothing, NegTest "Another mutual block non terminating" - "." - "Ord.juvix" + $(mkRelDir ".") + $(mkRelFile "Ord.juvix") $ \case ErrNoLexOrder {} -> Nothing, NegTest "Only one function, f, marked terminating in a mutual block" - "." - "TerminatingF.juvix" + $(mkRelDir ".") + $(mkRelFile "TerminatingF.juvix") $ \case ErrNoLexOrder {} -> Nothing, NegTest "Only one function, g, marked terminating in a mutual block" - "." - "TerminatingG.juvix" + $(mkRelDir ".") + $(mkRelFile "TerminatingG.juvix") $ \case ErrNoLexOrder {} -> Nothing, NegTest "f x := f x is not terminating" - "." - "ToEmpty.juvix" + $(mkRelDir ".") + $(mkRelFile "ToEmpty.juvix") $ \case ErrNoLexOrder {} -> Nothing, NegTest "Tree" - "." - "Data/Tree.juvix" + $(mkRelDir ".") + $(mkRelFile "Data/Tree.juvix") $ \case ErrNoLexOrder {} -> Nothing, NegTest "Quicksort is not terminating" - "." - "Data/QuickSort.juvix" + $(mkRelDir ".") + $(mkRelFile "Data/QuickSort.juvix") $ \case ErrNoLexOrder {} -> Nothing ] diff --git a/test/Termination/Positive.hs b/test/Termination/Positive.hs index e24cd076c..f2c7976fd 100644 --- a/test/Termination/Positive.hs +++ b/test/Termination/Positive.hs @@ -7,21 +7,22 @@ import Termination.Negative qualified as N data PosTest = PosTest { _name :: String, - _relDir :: FilePath, - _file :: FilePath + _relDir :: Path Rel Dir, + _file :: Path Rel File } -root :: FilePath -root = "tests/positive/Termination" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/positive/Termination") testDescr :: PosTest -> TestDescr testDescr PosTest {..} = - let tRoot = root _relDir + let tRoot = root _relDir + file' = tRoot _file in TestDescr { _testName = _name, _testRoot = tRoot, _testAssertion = Single $ do - let entryPoint = (defaultEntryPoint _file) {_entryPointNoStdlib = True} + let entryPoint = (defaultEntryPoint tRoot file') {_entryPointNoStdlib = True} (void . runIO' iniState entryPoint) upToInternal } @@ -29,20 +30,20 @@ testDescr PosTest {..} = -- Testing --no-termination flag with all termination negative tests -------------------------------------------------------------------------------- -rootNegTests :: FilePath -rootNegTests = "tests/negative/Termination" +rootNegTests :: Path Abs Dir +rootNegTests = relToProject $(mkRelDir "tests/negative/Termination") testDescrFlag :: N.NegTest -> TestDescr testDescrFlag N.NegTest {..} = - let tRoot = rootNegTests _relDir + let tRoot = rootNegTests _relDir + file' = tRoot _file in TestDescr { _testName = _name, _testRoot = tRoot, _testAssertion = Single $ do let entryPoint = - (defaultEntryPoint _file) - { _entryPointRoot = ".", - _entryPointNoTermination = True, + (defaultEntryPoint tRoot file') + { _entryPointNoTermination = True, _entryPointNoStdlib = True } @@ -53,16 +54,34 @@ testDescrFlag N.NegTest {..} = tests :: [PosTest] tests = - [ PosTest "Ackerman nice def. is terminating" "." "Ack.juvix", - PosTest "Fibonacci with nested pattern" "." "Fib.juvix", - PosTest "Recursive functions on Lists" "." "Data/List.juvix" + [ PosTest + "Ackerman nice def. is terminating" + $(mkRelDir ".") + $(mkRelFile "Ack.juvix"), + PosTest + "Fibonacci with nested pattern" + $(mkRelDir ".") + $(mkRelFile "Fib.juvix"), + PosTest + "Recursive functions on Lists" + $(mkRelDir ".") + $(mkRelFile "Data/List.juvix") ] testsWithKeyword :: [PosTest] testsWithKeyword = - [ PosTest "terminating added to fx:=fx" "." "ToEmpty.juvix", - PosTest "terminating for all functions in the mutual block" "." "Mutual.juvix", - PosTest "Undefined is terminating by assumption" "." "Undefined.juvix" + [ PosTest + "terminating added to fx:=fx" + $(mkRelDir ".") + $(mkRelFile "ToEmpty.juvix"), + PosTest + "terminating for all functions in the mutual block" + $(mkRelDir ".") + $(mkRelFile "Mutual.juvix"), + PosTest + "Undefined is terminating by assumption" + $(mkRelDir ".") + $(mkRelFile "Undefined.juvix") ] negTests :: [N.NegTest] diff --git a/test/Typecheck/Negative.hs b/test/Typecheck/Negative.hs index 7433fe52a..69365e581 100644 --- a/test/Typecheck/Negative.hs +++ b/test/Typecheck/Negative.hs @@ -9,19 +9,20 @@ type FailMsg = String data NegTest = NegTest { _name :: String, - _relDir :: FilePath, - _file :: FilePath, + _relDir :: Path Rel Dir, + _file :: Path Rel File, _checkErr :: TypeCheckerError -> Maybe FailMsg } testDescr :: NegTest -> TestDescr testDescr NegTest {..} = - let tRoot = root _relDir + let tRoot = root _relDir + file' = tRoot _file in TestDescr { _testName = _name, _testRoot = tRoot, _testAssertion = Single $ do - let entryPoint = defaultEntryPoint _file + let entryPoint = defaultEntryPoint tRoot file' result <- runIOEither iniState entryPoint upToInternalTyped case mapLeft fromJuvixError result of Left (Just tyError) -> whenJust (_checkErr tyError) assertFailure @@ -41,8 +42,8 @@ allTests = (map (mkTest . testDescr) negPositivityTests) ] -root :: FilePath -root = "tests/negative" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/negative") wrongError :: Maybe FailMsg wrongError = Just "Incorrect error" @@ -51,71 +52,71 @@ tests :: [NegTest] tests = [ NegTest "Constructor in pattern type error" - "Internal" - "PatternConstructor.juvix" + $(mkRelDir "Internal") + $(mkRelFile "PatternConstructor.juvix") $ \case ErrWrongConstructorType {} -> Nothing _ -> wrongError, NegTest "Check pattern with hole type" - "265" - "M.juvix" + $(mkRelDir "265") + $(mkRelFile "M.juvix") $ \case ErrWrongConstructorType {} -> Nothing _ -> wrongError, NegTest "Type vs inferred type mismatch" - "Internal" - "WrongType.juvix" + $(mkRelDir "Internal") + $(mkRelFile "WrongType.juvix") $ \case ErrWrongType {} -> Nothing _ -> wrongError, NegTest "Function application with non-function type" - "Internal" - "ExpectedFunctionType.juvix" + $(mkRelDir "Internal") + $(mkRelFile "ExpectedFunctionType.juvix") $ \case ErrExpectedFunctionType {} -> Nothing _ -> wrongError, NegTest "Unsolved hole" - "Internal" - "UnsolvedMeta.juvix" + $(mkRelDir "Internal") + $(mkRelFile "UnsolvedMeta.juvix") $ \case ErrUnsolvedMeta {} -> Nothing _ -> wrongError, NegTest "Multiple type errors are captured" - "Internal" - "MultiWrongType.juvix" + $(mkRelDir "Internal") + $(mkRelFile "MultiWrongType.juvix") $ \case ErrWrongType {} -> Nothing _ -> wrongError, NegTest "Unexpected braces in pattern" - "issue1337" - "Braces.juvix" + $(mkRelDir "issue1337") + $(mkRelFile "Braces.juvix") $ \case ErrArity (ErrWrongPatternIsImplicit {}) -> Nothing _ -> wrongError, NegTest "Wrong return type name for a constructor of a simple data type" - "Internal" - "WrongReturnType.juvix" + $(mkRelDir "Internal") + $(mkRelFile "WrongReturnType.juvix") $ \case ErrWrongReturnType {} -> Nothing _ -> wrongError, NegTest "Too few arguments for the return type of a constructor" - "Internal" - "WrongReturnTypeTooFewArguments.juvix" + $(mkRelDir "Internal") + $(mkRelFile "WrongReturnTypeTooFewArguments.juvix") $ \case ErrWrongType {} -> Nothing _ -> wrongError, NegTest "Too many arguments for the return type of a constructor" - "Internal" - "WrongReturnTypeTooManyArguments.juvix" + $(mkRelDir "Internal") + $(mkRelFile "WrongReturnTypeTooManyArguments.juvix") $ \case ErrExpectedFunctionType {} -> Nothing _ -> wrongError @@ -123,39 +124,39 @@ tests = negPositivityTests :: [NegTest] negPositivityTests = - [ NegTest "E1" "Internal/Positivity" "E1.juvix" $ + [ NegTest "E1" $(mkRelDir "Internal/Positivity") $(mkRelFile "E1.juvix") $ \case ErrNoPositivity {} -> Nothing _ -> wrongError, - NegTest "E2" "Internal/Positivity" "E2.juvix" $ + NegTest "E2" $(mkRelDir "Internal/Positivity") $(mkRelFile "E2.juvix") $ \case ErrNoPositivity {} -> Nothing _ -> wrongError, - NegTest "E3" "Internal/Positivity" "E3.juvix" $ + NegTest "E3" $(mkRelDir "Internal/Positivity") $(mkRelFile "E3.juvix") $ \case ErrNoPositivity {} -> Nothing _ -> wrongError, - NegTest "E4" "Internal/Positivity" "E4.juvix" $ + NegTest "E4" $(mkRelDir "Internal/Positivity") $(mkRelFile "E4.juvix") $ \case ErrNoPositivity {} -> Nothing _ -> wrongError, - NegTest "E5" "Internal/Positivity" "E5.juvix" $ + NegTest "E5" $(mkRelDir "Internal/Positivity") $(mkRelFile "E5.juvix") $ \case ErrNoPositivity {} -> Nothing _ -> wrongError, - NegTest "E6" "Internal/Positivity" "E6.juvix" $ + NegTest "E6" $(mkRelDir "Internal/Positivity") $(mkRelFile "E6.juvix") $ \case ErrNoPositivity {} -> Nothing _ -> wrongError, - NegTest "E7" "Internal/Positivity" "E7.juvix" $ + NegTest "E7" $(mkRelDir "Internal/Positivity") $(mkRelFile "E7.juvix") $ \case ErrNoPositivity {} -> Nothing _ -> wrongError, - NegTest "E8" "Internal/Positivity" "E8.juvix" $ + NegTest "E8" $(mkRelDir "Internal/Positivity") $(mkRelFile "E8.juvix") $ \case ErrNoPositivity {} -> Nothing _ -> wrongError, - NegTest "E9" "Internal/Positivity" "E9.juvix" $ + NegTest "E9" $(mkRelDir "Internal/Positivity") $(mkRelFile "E9.juvix") $ \case ErrNoPositivity {} -> Nothing _ -> wrongError diff --git a/test/Typecheck/Positive.hs b/test/Typecheck/Positive.hs index d3784169d..8ae65df95 100644 --- a/test/Typecheck/Positive.hs +++ b/test/Typecheck/Positive.hs @@ -7,21 +7,22 @@ import Typecheck.Negative qualified as N data PosTest = PosTest { _name :: String, - _relDir :: FilePath, - _file :: FilePath + _relDir :: Path Rel Dir, + _file :: Path Rel File } -root :: FilePath -root = "tests/positive" +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/positive") testDescr :: PosTest -> TestDescr testDescr PosTest {..} = - let tRoot = root _relDir + let tRoot = root _relDir + file' = tRoot _file in TestDescr { _testName = _name, _testRoot = tRoot, _testAssertion = Single $ do - let entryPoint = defaultEntryPoint _file + let entryPoint = defaultEntryPoint tRoot file' (void . runIO' iniState entryPoint) upToInternalTyped } @@ -29,18 +30,19 @@ testDescr PosTest {..} = -- Testing --no-positivity flag with all related negative tests -------------------------------------------------------------------------------- -rootNegTests :: FilePath -rootNegTests = "tests/negative/" +rootNegTests :: Path Abs Dir +rootNegTests = relToProject $(mkRelDir "tests/negative/") testNoPositivityFlag :: N.NegTest -> TestDescr testNoPositivityFlag N.NegTest {..} = - let tRoot = rootNegTests _relDir + let tRoot = rootNegTests _relDir + file' = tRoot _file in TestDescr { _testName = _name, _testRoot = tRoot, _testAssertion = Single $ do let entryPoint = - (defaultEntryPoint _file) + (defaultEntryPoint tRoot file') { _entryPointNoPositivity = True } @@ -54,8 +56,8 @@ testPositivityKeyword :: [PosTest] testPositivityKeyword = [ PosTest "Mark T0 data type as strictly positive" - "Internal/Positivity" - "E5.juvix" + $(mkRelDir "Internal/Positivity") + $(mkRelFile "E5.juvix") ] positivityTestGroup :: TestTree @@ -86,90 +88,90 @@ tests :: [PosTest] tests = [ PosTest "Simple" - "Internal" - "Simple.juvix", + $(mkRelDir "Internal") + $(mkRelFile "Simple.juvix"), PosTest "Literal String matches any type" - "Internal" - "LiteralString.juvix", + $(mkRelDir "Internal") + $(mkRelFile "LiteralString.juvix"), PosTest "Box type" - "Internal" - "Box.juvix", + $(mkRelDir "Internal") + $(mkRelFile "Box.juvix"), PosTest "Literal Int matches any type" - "Internal" - "LiteralInt.juvix", + $(mkRelDir "Internal") + $(mkRelFile "LiteralInt.juvix"), PosTest "PolySimpleFungibleToken" - "FullExamples" - "SimpleFungibleTokenImplicit.juvix", + $(mkRelDir "FullExamples") + $(mkRelFile "SimpleFungibleTokenImplicit.juvix"), PosTest "GHC backend MonoSimpleFungibleToken" - "FullExamples" - "MonoSimpleFungibleToken.juvix", + $(mkRelDir "FullExamples") + $(mkRelFile "MonoSimpleFungibleToken.juvix"), PosTest "Axiom" - "." - "Axiom.juvix", + $(mkRelDir ".") + $(mkRelFile "Axiom.juvix"), PosTest "Inductive" - "." - "Inductive.juvix", + $(mkRelDir ".") + $(mkRelFile "Inductive.juvix"), PosTest "Operators" - "." - "Operators.juvix", + $(mkRelDir ".") + $(mkRelFile "Operators.juvix"), PosTest "Holes in type signature" - "Internal" - "HoleInSignature.juvix", + $(mkRelDir "Internal") + $(mkRelFile "HoleInSignature.juvix"), PosTest "Polymorphism and higher rank functions" - "." - "Polymorphism.juvix", + $(mkRelDir ".") + $(mkRelFile "Polymorphism.juvix"), PosTest "Polymorphism and higher rank functions with explicit holes" - "." - "PolymorphismHoles.juvix", + $(mkRelDir ".") + $(mkRelFile "PolymorphismHoles.juvix"), PosTest "Implicit arguments" - "Internal" - "Implicit.juvix", + $(mkRelDir "Internal") + $(mkRelFile "Implicit.juvix"), PosTest "Simple type alias" - "." - "TypeAlias.juvix", + $(mkRelDir ".") + $(mkRelFile "TypeAlias.juvix"), PosTest "Refine hole in type signature" - "272" - "M.juvix", + $(mkRelDir "272") + $(mkRelFile "M.juvix"), PosTest "Pattern match a hole type" - "265" - "M.juvix", + $(mkRelDir "265") + $(mkRelFile "M.juvix"), PosTest "Pattern match type synonym" - "issue1466" - "M.juvix", + $(mkRelDir "issue1466") + $(mkRelFile "M.juvix"), PosTest "Import a builtin multiple times" - "BuiltinsMultiImport" - "Input.juvix", + $(mkRelDir "BuiltinsMultiImport") + $(mkRelFile "Input.juvix"), PosTest "Basic lambda functions" - "Internal" - "Lambda.juvix", + $(mkRelDir "Internal") + $(mkRelFile "Lambda.juvix"), PosTest "Simple mutual inference" - "Internal" - "Mutual.juvix", + $(mkRelDir "Internal") + $(mkRelFile "Mutual.juvix"), PosTest "open import a builtin multiple times" - "BuiltinsMultiOpenImport" - "Input.juvix", + $(mkRelDir "BuiltinsMultiOpenImport") + $(mkRelFile "Input.juvix"), PosTest "As Patterns" - "Internal" - "AsPattern.juvix" + $(mkRelDir "Internal") + $(mkRelFile "AsPattern.juvix") ] diff --git a/tests/CLI/Commands/repl.test b/tests/CLI/Commands/repl.test index 7ddde1f43..5ad1a3625 100644 --- a/tests/CLI/Commands/repl.test +++ b/tests/CLI/Commands/repl.test @@ -28,7 +28,7 @@ $ juvix repl < :t suc -$ juvix --stdlib-path juvix-stdlib repl +$ cd juvix-stdlib && juvix repl > /Nat → Nat/ >= 0 @@ -61,21 +61,21 @@ $ juvix repl >= 0 < -:load tests/Internal/positive/BuiltinBool.juvix -$ juvix repl +:load BuiltinBool.juvix +$ cd tests/Internal/positive/ && juvix repl > /BuiltinBool> / >= 0 < -:load tests/Internal/positive/BuiltinBool.juvix -$ juvix repl +:load BuiltinBool.juvix +$ cd tests/Internal/positive/ && juvix repl > /BuiltinBool> / >= 0 < -:l tests/Internal/positive/BuiltinBool.juvix +:l BuiltinBool.juvix main -$ juvix repl +$ cd tests/Internal/positive/ && juvix repl > /true/ >= 0 diff --git a/tests/Internal/positive/Dependencies/Dep1/Conflict.juvix b/tests/Internal/positive/Dependencies/Dep1/Conflict.juvix new file mode 100644 index 000000000..5b3978f4e --- /dev/null +++ b/tests/Internal/positive/Dependencies/Dep1/Conflict.juvix @@ -0,0 +1,3 @@ +module Conflict; + +end; diff --git a/tests/Internal/positive/Dependencies/Dep1/Dep1/Lib.juvix b/tests/Internal/positive/Dependencies/Dep1/Dep1/Lib.juvix new file mode 100644 index 000000000..600168b54 --- /dev/null +++ b/tests/Internal/positive/Dependencies/Dep1/Dep1/Lib.juvix @@ -0,0 +1,3 @@ +module Dep1.Lib; + +end; diff --git a/tests/Internal/positive/Dependencies/Dep1/juvix.yaml b/tests/Internal/positive/Dependencies/Dep1/juvix.yaml new file mode 100644 index 000000000..4c0019826 --- /dev/null +++ b/tests/Internal/positive/Dependencies/Dep1/juvix.yaml @@ -0,0 +1,3 @@ +dependencies: [] +name: dep1 +version: 0.0.0 diff --git a/tests/Internal/positive/Dependencies/Dep2/Conflict.juvix b/tests/Internal/positive/Dependencies/Dep2/Conflict.juvix new file mode 100644 index 000000000..5b3978f4e --- /dev/null +++ b/tests/Internal/positive/Dependencies/Dep2/Conflict.juvix @@ -0,0 +1,3 @@ +module Conflict; + +end; diff --git a/tests/Internal/positive/Dependencies/Dep2/Dep2/Lib.juvix b/tests/Internal/positive/Dependencies/Dep2/Dep2/Lib.juvix new file mode 100644 index 000000000..5f653706c --- /dev/null +++ b/tests/Internal/positive/Dependencies/Dep2/Dep2/Lib.juvix @@ -0,0 +1,3 @@ +module Dep2.Lib; + +end; diff --git a/tests/Internal/positive/Dependencies/Dep2/juvix.yaml b/tests/Internal/positive/Dependencies/Dep2/juvix.yaml new file mode 100644 index 000000000..977e6c26e --- /dev/null +++ b/tests/Internal/positive/Dependencies/Dep2/juvix.yaml @@ -0,0 +1,3 @@ +dependencies: [] +name: dep2 +version: 0.0.0 diff --git a/tests/Internal/positive/Dependencies/Main/Main.juvix b/tests/Internal/positive/Dependencies/Main/Main.juvix new file mode 100644 index 000000000..aa390de07 --- /dev/null +++ b/tests/Internal/positive/Dependencies/Main/Main.juvix @@ -0,0 +1,9 @@ +module Main; + +import Dep1.Lib; +import Dep2.Lib; + +import Conflict2; + + +end; diff --git a/tests/Internal/positive/Dependencies/Main/juvix.yaml b/tests/Internal/positive/Dependencies/Main/juvix.yaml new file mode 100644 index 000000000..bce91db20 --- /dev/null +++ b/tests/Internal/positive/Dependencies/Main/juvix.yaml @@ -0,0 +1,5 @@ +name: my-project +version: "1.0" +dependencies: +- "../Dep1" +- "../Dep2" diff --git a/tests/positive/Dependencies/.libs/Base/Base.juvix b/tests/positive/Dependencies/.libs/Base/Base.juvix new file mode 100644 index 000000000..29f0c9019 --- /dev/null +++ b/tests/positive/Dependencies/.libs/Base/Base.juvix @@ -0,0 +1,5 @@ +module Base; + + axiom Base : Type; + +end; diff --git a/tests/positive/Dependencies/.libs/Base/juvix.yaml b/tests/positive/Dependencies/.libs/Base/juvix.yaml new file mode 100644 index 000000000..e22412d96 --- /dev/null +++ b/tests/positive/Dependencies/.libs/Base/juvix.yaml @@ -0,0 +1,3 @@ +name: base +version: 1.0.0 +dependencies: [] diff --git a/tests/positive/Dependencies/.libs/Extra/Extra.juvix b/tests/positive/Dependencies/.libs/Extra/Extra.juvix new file mode 100644 index 000000000..02331e929 --- /dev/null +++ b/tests/positive/Dependencies/.libs/Extra/Extra.juvix @@ -0,0 +1,9 @@ +module Extra; + +open import Base; + +axiom Extra : Type; + +axiom _A : Base; + +end; diff --git a/tests/positive/Dependencies/.libs/Extra/juvix.yaml b/tests/positive/Dependencies/.libs/Extra/juvix.yaml new file mode 100644 index 000000000..e3faaf253 --- /dev/null +++ b/tests/positive/Dependencies/.libs/Extra/juvix.yaml @@ -0,0 +1,5 @@ +name: extra +version: 1.0.0 +dependencies: +- .juvix-build/stdlib +- parent/Base diff --git a/tests/positive/Dependencies/.libs/Extra/parent b/tests/positive/Dependencies/.libs/Extra/parent new file mode 120000 index 000000000..b870225aa --- /dev/null +++ b/tests/positive/Dependencies/.libs/Extra/parent @@ -0,0 +1 @@ +../ \ No newline at end of file diff --git a/tests/positive/Dependencies/Input.juvix b/tests/positive/Dependencies/Input.juvix new file mode 100644 index 000000000..e097a8df6 --- /dev/null +++ b/tests/positive/Dependencies/Input.juvix @@ -0,0 +1,9 @@ +module Input; + +open import Extra; +open import Base; +open import Stdlib.Prelude; + +axiom x : Extra; + +end; diff --git a/tests/positive/Dependencies/juvix.yaml b/tests/positive/Dependencies/juvix.yaml new file mode 100644 index 000000000..c19baf64c --- /dev/null +++ b/tests/positive/Dependencies/juvix.yaml @@ -0,0 +1,6 @@ +name: main-project +version: 0.0.1 +dependencies: +- .libs/Extra +- .libs/Base +- .juvix-build/stdlib diff --git a/tests/positive/StdlibList/juvix.yaml b/tests/positive/StdlibList/juvix.yaml index e69de29bb..32cf5dda7 100644 --- a/tests/positive/StdlibList/juvix.yaml +++ b/tests/positive/StdlibList/juvix.yaml @@ -0,0 +1 @@ +dependencies: []