1
1
mirror of https://github.com/anoma/juvix.git synced 2024-08-16 19:50:26 +03:00

Support basic dependencies (#1622)

This commit is contained in:
janmasrovira 2022-12-20 13:05:40 +01:00 committed by GitHub
parent 445376e338
commit af63c36574
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
137 changed files with 2903 additions and 1892 deletions

View File

@ -13,18 +13,19 @@ data App m a where
ExitMsg :: ExitCode -> Text -> App m a ExitMsg :: ExitCode -> Text -> App m a
ExitJuvixError :: JuvixError -> App m a ExitJuvixError :: JuvixError -> App m a
PrintJuvixError :: JuvixError -> App m () PrintJuvixError :: JuvixError -> App m ()
AskRoot :: App m FilePath AskInvokeDir :: App m (Path Abs Dir)
AskPkgDir :: App m (Path Abs Dir)
AskPackage :: App m Package AskPackage :: App m Package
AskGlobalOptions :: App m GlobalOptions AskGlobalOptions :: App m GlobalOptions
RenderStdOut :: (HasAnsiBackend a, HasTextBackend a) => a -> App m () 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 () Say :: Text -> App m ()
Raw :: ByteString -> App m () SayRaw :: ByteString -> App m ()
makeSem ''App makeSem ''App
runAppIO :: forall r a. Member (Embed IO) r => GlobalOptions -> FilePath -> Package -> Sem (App ': r) a -> Sem r a 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 root pkg = interpret $ \case runAppIO g invokeDir pkgDir pkg = interpret $ \case
RenderStdOut t RenderStdOut t
| g ^. globalOnlyErrors -> return () | g ^. globalOnlyErrors -> return ()
| otherwise -> embed $ do | otherwise -> embed $ do
@ -32,9 +33,10 @@ runAppIO g root pkg = interpret $ \case
renderIO (not (g ^. globalNoColors) && sup) t renderIO (not (g ^. globalNoColors) && sup) t
AskGlobalOptions -> return g AskGlobalOptions -> return g
AskPackage -> return pkg AskPackage -> return pkg
AskRoot -> return root AskInvokeDir -> return invokeDir
AskPkgDir -> return pkgDir
RunPipelineEither input p -> do RunPipelineEither input p -> do
entry <- embed (getEntryPoint' g root pkg input) entry <- embed (getEntryPoint' invokeDir g pkgDir pkg input)
embed (runIOEither iniState entry p) embed (runIOEither iniState entry p)
Say t Say t
| g ^. globalOnlyErrors -> return () | g ^. globalOnlyErrors -> return ()
@ -45,13 +47,13 @@ runAppIO g root pkg = interpret $ \case
printErr e printErr e
embed exitFailure embed exitFailure
ExitMsg exitCode t -> embed (putStrLn t >> exitWith exitCode) ExitMsg exitCode t -> embed (putStrLn t >> exitWith exitCode)
Raw b -> embed (ByteString.putStr b) SayRaw b -> embed (ByteString.putStr b)
where where
printErr e = printErr e =
embed $ hPutStrLn stderr $ run $ runReader (project' @GenericOptions g) $ Error.render (not (g ^. globalNoColors)) (g ^. globalOnlyErrors) 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' :: Path Abs Dir -> GlobalOptions -> Path Abs Dir -> Package -> AppPath File -> IO EntryPoint
getEntryPoint' opts root pkg inputFile = do getEntryPoint' invokeDir opts root pkg inputFile = do
estdin <- estdin <-
if if
| opts ^. globalStdin -> Just <$> getContents | opts ^. globalStdin -> Just <$> getContents
@ -59,27 +61,33 @@ getEntryPoint' opts root pkg inputFile = do
return return
EntryPoint EntryPoint
{ _entryPointRoot = root, { _entryPointRoot = root,
_entryPointResolverRoot = root,
_entryPointNoTermination = opts ^. globalNoTermination, _entryPointNoTermination = opts ^. globalNoTermination,
_entryPointNoPositivity = opts ^. globalNoPositivity, _entryPointNoPositivity = opts ^. globalNoPositivity,
_entryPointNoStdlib = opts ^. globalNoStdlib, _entryPointNoStdlib = opts ^. globalNoStdlib,
_entryPointStdlibPath = opts ^. globalStdlibPath,
_entryPointPackage = pkg, _entryPointPackage = pkg,
_entryPointModulePaths = pure (inputFile ^. pathPath), _entryPointModulePaths = pure (someBaseToAbs invokeDir (inputFile ^. pathPath)),
_entryPointGenericOptions = project opts, _entryPointGenericOptions = project opts,
_entryPointStdin = estdin _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 :: Members '[App] r => Sem r GenericOptions
askGenericOptions = project <$> askGlobalOptions 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 getEntryPoint inputFile = do
opts <- askGlobalOptions opts <- askGlobalOptions
root <- askRoot root <- askPkgDir
pkg <- askPackage 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 runPipeline input p = do
r <- runPipelineEither input p r <- runPipelineEither input p
case r of case r of

View File

@ -12,54 +12,37 @@ import System.Process qualified as P
runCommand :: Members '[Embed IO, App] r => CompileOptions -> Sem r () runCommand :: Members '[Embed IO, App] r => CompileOptions -> Sem r ()
runCommand opts@CompileOptions {..} = do runCommand opts@CompileOptions {..} = do
root <- askRoot
miniC <- (^. MiniC.resultCCode) <$> runPipeline _compileInputFile upToMiniC miniC <- (^. MiniC.resultCCode) <$> runPipeline _compileInputFile upToMiniC
let inputFile = _compileInputFile ^. pathPath inputFile <- someBaseToAbs' (_compileInputFile ^. pathPath)
result <- embed (runCompile root inputFile opts miniC) result <- runCompile inputFile opts miniC
case result of case result of
Left err -> printFailureExit err Left err -> printFailureExit err
_ -> return () _ -> return ()
inputCFile :: FilePath -> FilePath -> FilePath inputCFile :: Members '[App] r => Path Abs File -> Sem r (Path Abs File)
inputCFile projRoot inputFileCompile = inputCFile inputFileCompile = do
projRoot </> juvixBuildDir </> outputMiniCFile root <- askPkgDir
return (root <//> juvixBuildDir <//> outputMiniCFile)
where where
outputMiniCFile :: FilePath outputMiniCFile :: Path Rel File
outputMiniCFile = takeBaseName inputFileCompile <> ".c" outputMiniCFile = replaceExtension' ".c" (filename inputFileCompile)
runCompile :: FilePath -> FilePath -> CompileOptions -> Text -> IO (Either Text ()) runCompile :: Members '[Embed IO, App] r => Path Abs File -> CompileOptions -> Text -> Sem r (Either Text ())
runCompile projRoot inputFileCompile o minic = do runCompile inputFileCompile o minic = do
createDirectoryIfMissing True (projRoot </> juvixBuildDir) root <- askPkgDir
TIO.writeFile (inputCFile projRoot inputFileCompile) minic ensureDir (root <//> juvixBuildDir)
prepareRuntime projRoot o f <- inputCFile inputFileCompile
embed (TIO.writeFile (toFilePath f) minic)
prepareRuntime o
case o ^. compileTarget of case o ^. compileTarget of
TargetWasm -> runM (runError (clangCompile projRoot inputFileCompile o)) TargetWasm -> runError (clangCompile inputFileCompile o)
TargetC -> return (Right ()) TargetC -> return (Right ())
TargetNative -> runM (runError (clangNativeCompile projRoot inputFileCompile o)) TargetNative -> runError (clangNativeCompile inputFileCompile o)
prepareRuntime :: FilePath -> CompileOptions -> IO () prepareRuntime :: forall r. Members '[Embed IO, App] r => CompileOptions -> Sem r ()
prepareRuntime projRoot o = do prepareRuntime o = mapM_ writeRuntime runtimeProjectDir
mapM_ writeRuntime runtimeProjectDir
where where
wasiStandaloneRuntimeDir :: [(FilePath, BS.ByteString)] runtimeProjectDir :: [(Path Rel File, 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 = case o ^. compileTarget of runtimeProjectDir = case o ^. compileTarget of
TargetNative -> libcRuntime TargetNative -> libcRuntime
_ -> case o ^. compileRuntime of _ -> case o ^. compileRuntime of
@ -67,99 +50,135 @@ prepareRuntime projRoot o = do
RuntimeWasiLibC -> libcRuntime RuntimeWasiLibC -> libcRuntime
RuntimeStandalone -> standaloneRuntimeDir <> builtinCRuntimeDir <> wallocDir RuntimeStandalone -> standaloneRuntimeDir <> builtinCRuntimeDir <> wallocDir
writeRuntime :: (FilePath, BS.ByteString) -> IO () writeRuntime :: (Path Rel File, BS.ByteString) -> Sem r ()
writeRuntime (filePath, contents) = writeRuntime (filePath, contents) = do
BS.writeFile (projRoot </> juvixBuildDir </> takeFileName filePath) contents 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 :: clangNativeCompile ::
forall r. forall r.
Members '[Embed IO, Error Text] r => Members '[Embed IO, App, Error Text] r =>
FilePath -> Path Abs File ->
FilePath ->
CompileOptions -> CompileOptions ->
Sem r () Sem r ()
clangNativeCompile projRoot inputFileCompile o = runClang (nativeArgs outputFile inputFile) clangNativeCompile inputFileCompile o = do
inputFile <- getInputFile
outputFile <- getOutputFile
runClang (nativeArgs outputFile inputFile)
where where
outputFile :: FilePath getOutputFile :: Sem r (Path Abs File)
outputFile = maybe (takeBaseName inputFileCompile) (^. pathPath) (o ^. compileOutputFile) getOutputFile = case o ^. compileOutputFile of
Nothing -> return (removeExtension' inputFileCompile)
Just f -> someBaseToAbs' (f ^. pathPath)
inputFile :: FilePath getInputFile :: Sem r (Path Abs File)
inputFile = inputCFile projRoot inputFileCompile getInputFile = inputCFile inputFileCompile
clangCompile :: clangCompile ::
forall r. forall r.
Members '[Embed IO, Error Text] r => Members '[Embed IO, App, Error Text] r =>
FilePath -> Path Abs File ->
FilePath ->
CompileOptions -> CompileOptions ->
Sem r () 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 where
clangArgs :: Sem r [String] getOutputFile :: Sem r (Path Abs File)
clangArgs = case o ^. compileRuntime of getOutputFile = maybe (return defaultOutputFile) someBaseToAbs' (o ^? compileOutputFile . _Just . pathPath)
RuntimeStandalone ->
return (standaloneLibArgs projRoot outputFile inputFile)
RuntimeWasiStandalone -> wasiStandaloneArgs projRoot outputFile inputFile <$> sysrootEnvVar
RuntimeWasiLibC -> wasiLibcArgs outputFile inputFile <$> sysrootEnvVar
outputFile :: FilePath defaultOutputFile :: Path Abs File
outputFile = maybe (takeBaseName inputFileCompile <> ".wasm") (^. pathPath) (o ^. compileOutputFile) defaultOutputFile = replaceExtension' ".wasm" inputFileCompile
inputFile :: FilePath getInputFile :: Sem r (Path Abs File)
inputFile = inputCFile projRoot inputFileCompile getInputFile = inputCFile inputFileCompile
sysrootEnvVar :: Sem r String sysrootEnvVar :: Members '[Error Text, Embed IO] r => Sem r (Path Abs Dir)
sysrootEnvVar = sysrootEnvVar =
fromMaybeM (throw msg) (embed (lookupEnv "WASI_SYSROOT_PATH")) absDir
where <$> fromMaybeM (throw msg) (embed (lookupEnv "WASI_SYSROOT_PATH"))
msg :: Text where
msg = "Missing environment variable WASI_SYSROOT_PATH" msg :: Text
msg = "Missing environment variable WASI_SYSROOT_PATH"
commonArgs :: FilePath -> [String] commonArgs :: Path Abs File -> [String]
commonArgs wasmOutputFile = commonArgs wasmOutputFile =
[ "-std=c99", [ "-std=c99",
"-Oz", "-Oz",
"-I", "-I",
juvixBuildDir, toFilePath juvixBuildDir,
"-o", "-o",
wasmOutputFile toFilePath wasmOutputFile
] ]
standaloneLibArgs :: FilePath -> FilePath -> FilePath -> [String] standaloneLibArgs :: Members '[App, Embed IO] r => Path Abs File -> Path Abs File -> Sem r [String]
standaloneLibArgs projRoot wasmOutputFile inputFile = standaloneLibArgs wasmOutputFile inputFile = do
commonArgs wasmOutputFile root <- askPkgDir
<> [ "--target=wasm32", return $
"-nodefaultlibs", commonArgs wasmOutputFile
"-nostartfiles", <> [ "--target=wasm32",
"-Wl,--no-entry", "-nodefaultlibs",
projRoot </> juvixBuildDir </> "walloc.c", "-nostartfiles",
inputFile "-Wl,--no-entry",
] toFilePath (root <//> juvixBuildDir <//> $(mkRelFile "walloc.c")),
toFilePath inputFile
]
wasiStandaloneArgs :: FilePath -> FilePath -> FilePath -> FilePath -> [String] wasiStandaloneArgs :: Members '[App, Error Text, Embed IO] r => Path Abs File -> Path Abs File -> Sem r [String]
wasiStandaloneArgs projRoot wasmOutputFile inputFile sysrootPath = wasiStandaloneArgs wasmOutputFile inputFile = do
wasiCommonArgs sysrootPath wasmOutputFile root <- askPkgDir
<> [ projRoot </> juvixBuildDir </> "walloc.c", com <- wasiCommonArgs wasmOutputFile
inputFile return $
] com
<> [ toFilePath (root <//> juvixBuildDir <//> $(mkRelFile "walloc.c")),
toFilePath inputFile
]
wasiLibcArgs :: FilePath -> FilePath -> FilePath -> [String] wasiLibcArgs :: Members '[App, Error Text, Embed IO] r => Path Abs File -> Path Abs File -> Sem r [String]
wasiLibcArgs wasmOutputFile inputFile sysrootPath = wasiLibcArgs wasmOutputFile inputFile = do
wasiCommonArgs sysrootPath wasmOutputFile com <- wasiCommonArgs wasmOutputFile
<> ["-lc", inputFile] return $ com <> ["-lc", toFilePath inputFile]
nativeArgs :: FilePath -> FilePath -> [String] nativeArgs :: Path Abs File -> Path Abs File -> [String]
nativeArgs outputFile inputFile = nativeArgs outputFile inputFile =
commonArgs outputFile <> [inputFile] commonArgs outputFile <> [toFilePath inputFile]
wasiCommonArgs :: FilePath -> FilePath -> [String] wasiCommonArgs :: Members '[App, Error Text, Embed IO] r => Path Abs File -> Sem r [String]
wasiCommonArgs sysrootPath wasmOutputFile = wasiCommonArgs wasmOutputFile = do
commonArgs wasmOutputFile sysrootPath <- sysrootEnvVar
<> [ "-nodefaultlibs", return $
"--target=wasm32-wasi", commonArgs wasmOutputFile
"--sysroot", <> [ "-nodefaultlibs",
sysrootPath "--target=wasm32-wasi",
] "--sysroot",
toFilePath sysrootPath
]
runClang :: runClang ::
Members '[Embed IO, Error Text] r => Members '[Embed IO, Error Text] r =>

View File

@ -2,7 +2,10 @@ module Commands.Compile.Options where
import CommonOptions import CommonOptions
data CompileTarget = TargetC | TargetWasm | TargetNative data CompileTarget
= TargetC
| TargetWasm
| TargetNative
deriving stock (Show, Data) deriving stock (Show, Data)
data CompileRuntime data CompileRuntime
@ -14,8 +17,8 @@ data CompileRuntime
data CompileOptions = CompileOptions data CompileOptions = CompileOptions
{ _compileTarget :: CompileTarget, { _compileTarget :: CompileTarget,
_compileRuntime :: CompileRuntime, _compileRuntime :: CompileRuntime,
_compileOutputFile :: Maybe Path, _compileOutputFile :: Maybe (AppPath File),
_compileInputFile :: Path _compileInputFile :: AppPath File
} }
deriving stock (Data) deriving stock (Data)

View File

@ -30,4 +30,4 @@ runCommand = \case
Core opts -> Core.runCommand opts Core opts -> Core.runCommand opts
Asm opts -> Asm.runCommand opts Asm opts -> Asm.runCommand opts
Runtime opts -> Runtime.runCommand opts Runtime opts -> Runtime.runCommand opts
DisplayRoot -> DisplayRoot.runCommand DisplayRoot opts -> DisplayRoot.runCommand opts

View File

@ -12,20 +12,21 @@ import Juvix.Extra.Paths
runCommand :: forall r. Members '[Embed IO, App] r => AsmCompileOptions -> Sem r () runCommand :: forall r. Members '[Embed IO, App] r => AsmCompileOptions -> Sem r ()
runCommand opts = do runCommand opts = do
s <- embed (readFile file) file <- getFile
case Asm.runParser file s of s <- embed (readFile (toFilePath file))
case Asm.runParser (toFilePath file) s of
Left err -> exitJuvixError (JuvixError err) Left err -> exitJuvixError (JuvixError err)
Right tab -> case run $ runError $ asmToMiniC asmOpts tab of Right tab -> case run $ runError $ asmToMiniC asmOpts tab of
Left err -> exitJuvixError err Left err -> exitJuvixError err
Right C.MiniCResult {..} -> do Right C.MiniCResult {..} -> do
root <- askRoot root <- askPkgDir
embed $ createDirectoryIfMissing True (root </> juvixBuildDir) ensureDir (root <//> juvixBuildDir)
let cFile = inputCFile root file cFile <- inputCFile file
embed $ TIO.writeFile cFile _resultCCode embed $ TIO.writeFile (toFilePath cFile) _resultCCode
Compile.runCommand opts {_compileInputFile = Path cFile False} Compile.runCommand opts {_compileInputFile = AppPath (Abs cFile) False}
where where
file :: FilePath getFile :: Sem r (Path Abs File)
file = opts ^. compileInputFile . pathPath getFile = someBaseToAbs' (opts ^. compileInputFile . pathPath)
asmOpts :: Asm.Options asmOpts :: Asm.Options
asmOpts = Asm.makeOptions (asmTarget (opts ^. compileTarget)) (opts ^. compileDebug) asmOpts = Asm.makeOptions (asmTarget (opts ^. compileTarget)) (opts ^. compileDebug)
@ -36,9 +37,10 @@ runCommand opts = do
TargetNative64 -> Backend.TargetCNative64 TargetNative64 -> Backend.TargetCNative64
TargetC -> Backend.TargetCWasm32Wasi TargetC -> Backend.TargetCWasm32Wasi
inputCFile :: FilePath -> FilePath -> FilePath inputCFile :: Members '[App] r => Path Abs File -> Sem r (Path Abs File)
inputCFile projRoot inputFileCompile = inputCFile inputFileCompile = do
projRoot </> juvixBuildDir </> outputMiniCFile root <- askPkgDir
return (root <//> juvixBuildDir <//> outputMiniCFile)
where where
outputMiniCFile :: FilePath outputMiniCFile :: Path Rel File
outputMiniCFile = takeBaseName inputFileCompile <> ".c" outputMiniCFile = replaceExtension' ".c" (filename inputFileCompile)

View File

@ -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 :: forall r. Members '[Embed IO, App] r => AsmRunOptions -> Sem r ()
runCommand opts = do runCommand opts = do
s <- embed (readFile file) afile :: Path Abs File <- someBaseToAbs' file
case Asm.runParser file s of s <- embed (readFile (toFilePath afile))
case Asm.runParser (toFilePath afile) s of
Left err -> exitJuvixError (JuvixError err) Left err -> exitJuvixError (JuvixError err)
Right tab -> Right tab ->
let v = if opts ^. asmRunNoValidate then Nothing else Asm.validate' tab let v = if opts ^. asmRunNoValidate then Nothing else Asm.validate' tab
@ -35,7 +36,7 @@ runCommand opts = do
Nothing -> Nothing ->
exitMsg (ExitFailure 1) "no 'main' function" exitMsg (ExitFailure 1) "no 'main' function"
where where
file :: FilePath file :: SomeBase File
file = opts ^. asmRunInputFile . pathPath file = opts ^. asmRunInputFile . pathPath
doRun :: doRun ::

View File

@ -4,7 +4,7 @@ import CommonOptions
data AsmRunOptions = AsmRunOptions data AsmRunOptions = AsmRunOptions
{ _asmRunNoValidate :: Bool, { _asmRunNoValidate :: Bool,
_asmRunInputFile :: Path _asmRunInputFile :: AppPath File
} }
deriving stock (Data) deriving stock (Data)

View File

@ -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 :: forall r. Members '[Embed IO, App] r => AsmValidateOptions -> Sem r ()
runCommand opts = do runCommand opts = do
s <- embed (readFile file) afile :: Path Abs File <- someBaseToAbs' file
case Asm.runParser file s of s <- embed (readFile (toFilePath afile))
case Asm.runParser (toFilePath afile) s of
Left err -> exitJuvixError (JuvixError err) Left err -> exitJuvixError (JuvixError err)
Right tab -> do Right tab -> do
case Asm.validate' tab of case Asm.validate' tab of
@ -23,5 +24,5 @@ runCommand opts = do
renderStdOut (Asm.ppOutDefault tab tab) renderStdOut (Asm.ppOutDefault tab tab)
exitMsg ExitSuccess "" exitMsg ExitSuccess ""
where where
file :: FilePath file :: SomeBase File
file = opts ^. asmValidateInputFile . pathPath file = opts ^. asmValidateInputFile . pathPath

View File

@ -3,7 +3,7 @@ module Commands.Dev.Asm.Validate.Options where
import CommonOptions import CommonOptions
data AsmValidateOptions = AsmValidateOptions data AsmValidateOptions = AsmValidateOptions
{ _asmValidateInputFile :: Path, { _asmValidateInputFile :: AppPath File,
_asmValidateNoPrint :: Bool _asmValidateNoPrint :: Bool
} }
deriving stock (Data) deriving stock (Data)

View File

@ -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 :: forall r. Members '[Embed IO, App] r => CoreEvalOptions -> Sem r ()
runCommand opts = do runCommand opts = do
s <- embed (readFile f) f :: Path Abs File <- someBaseToAbs' b
case Core.runParser f Core.emptyInfoTable s of s <- embed (readFile (toFilePath f))
case Core.runParser (toFilePath f) Core.emptyInfoTable s of
Left err -> exitJuvixError (JuvixError err) Left err -> exitJuvixError (JuvixError err)
Right (tab, Just node) -> do evalAndPrint opts tab node Right (tab, Just node) -> do evalAndPrint opts tab node
Right (_, Nothing) -> return () Right (_, Nothing) -> return ()
where where
f :: FilePath b :: SomeBase File
f = opts ^. coreEvalInputFile . pathPath b = opts ^. coreEvalInputFile . pathPath

View File

@ -6,7 +6,7 @@ import Juvix.Compiler.Core.Pretty.Options qualified as Core
data CoreEvalOptions = CoreEvalOptions data CoreEvalOptions = CoreEvalOptions
{ _coreEvalNoIO :: Bool, { _coreEvalNoIO :: Bool,
_coreEvalInputFile :: Path, _coreEvalInputFile :: AppPath File,
_coreEvalShowDeBruijn :: Bool _coreEvalShowDeBruijn :: Bool
} }
deriving stock (Data) deriving stock (Data)

View File

@ -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 :: 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 runCommand opts = do
s' <- embed (readFile f) inputFile :: Path Abs File <- someBaseToAbs' sinputFile
(tab, mnode) <- getRight (mapLeft JuvixError (Core.runParser f Core.emptyInfoTable s')) 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 let tab' = Core.applyTransformations (project opts ^. coreReadTransformations) tab
embed (Scoper.scopeTrace tab') embed (Scoper.scopeTrace tab')
unless (project opts ^. coreReadNoPrint) $ do unless (project opts ^. coreReadNoPrint) $ do
@ -30,5 +31,5 @@ runCommand opts = do
embed (putStrLn "-- Node") embed (putStrLn "-- Node")
renderStdOut (Core.ppOut opts node) renderStdOut (Core.ppOut opts node)
embed (putStrLn "") embed (putStrLn "")
f :: FilePath sinputFile :: SomeBase File
f = project opts ^. coreReadInputFile . pathPath sinputFile = project opts ^. coreReadInputFile . pathPath

View File

@ -11,7 +11,7 @@ data CoreReadOptions = CoreReadOptions
_coreReadShowDeBruijn :: Bool, _coreReadShowDeBruijn :: Bool,
_coreReadEval :: Bool, _coreReadEval :: Bool,
_coreReadNoPrint :: Bool, _coreReadNoPrint :: Bool,
_coreReadInputFile :: Path _coreReadInputFile :: AppPath File
} }
deriving stock (Data) deriving stock (Data)

View File

@ -1,6 +1,15 @@
module Commands.Dev.DisplayRoot where module Commands.Dev.DisplayRoot where
import Commands.Base import Commands.Base
import Commands.Dev.DisplayRoot.Options
import Data.Yaml
runCommand :: Members '[Embed IO, App] r => Sem r () runCommand :: forall r. Members '[Embed IO, App] r => RootOptions -> Sem r ()
runCommand = askRoot >>= say . pack runCommand RootOptions {..} = do
askPkgDir >>= say . pack . toFilePath
when _rootPrintPackage printPackage
where
printPackage :: Sem r ()
printPackage = do
say "+----------------------------+"
askPackage >>= say . decodeUtf8 . encode . rawPackage

View File

@ -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 {..}

View File

@ -9,8 +9,8 @@ import System.Process qualified as Process
runCommand :: Members '[Embed IO, App] r => DocOptions -> Sem r () runCommand :: Members '[Embed IO, App] r => DocOptions -> Sem r ()
runCommand DocOptions {..} = do runCommand DocOptions {..} = do
ctx <- runPipeline _docInputFile upToInternalTyped ctx <- runPipeline _docInputFile upToInternalTyped
let docDir = _docOutputDir ^. pathPath docDir <- someBaseToAbs' (_docOutputDir ^. pathPath)
Doc.compile docDir "proj" ctx Doc.compile docDir "proj" ctx
when _docOpen $ case openCmd of when _docOpen $ case openCmd of
Nothing -> say "Could not recognize the 'open' command for your OS" 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)]))

View File

@ -3,9 +3,9 @@ module Commands.Dev.Doc.Options where
import CommonOptions import CommonOptions
data DocOptions = DocOptions data DocOptions = DocOptions
{ _docOutputDir :: Path, { _docOutputDir :: AppPath Dir,
_docOpen :: Bool, _docOpen :: Bool,
_docInputFile :: Path _docInputFile :: AppPath File
} }
deriving stock (Data) deriving stock (Data)
@ -15,7 +15,7 @@ parseDoc :: Parser DocOptions
parseDoc = do parseDoc = do
_docOutputDir <- _docOutputDir <-
parseGenericOutputDir parseGenericOutputDir
( value "doc" ( value (Rel (relDir "doc"))
<> showDefault <> showDefault
<> help "html output directory" <> help "html output directory"
) )

View File

@ -15,10 +15,10 @@ runCommand HighlightOptions {..} = do
genOpts <- askGenericOptions genOpts <- askGenericOptions
say (Highlight.goError (run $ runReader genOpts $ errorIntervals err)) say (Highlight.goError (run $ runReader genOpts $ errorIntervals err))
Right r -> do Right r -> do
inputFile <- someBaseToAbs' (_highlightInputFile ^. pathPath)
let tbl = r ^. _2 . Scoper.resultParserTable let tbl = r ^. _2 . Scoper.resultParserTable
items = tbl ^. Parser.infoParsedItems items = tbl ^. Parser.infoParsedItems
names = r ^. _2 . (Scoper.resultScoperTable . Scoper.infoNames) names = r ^. _2 . (Scoper.resultScoperTable . Scoper.infoNames)
inputFile = _highlightInputFile ^. pathPath
hinput = hinput =
Highlight.filterInput Highlight.filterInput
inputFile inputFile
@ -26,4 +26,4 @@ runCommand HighlightOptions {..} = do
{ _highlightNames = names, { _highlightNames = names,
_highlightParsed = items _highlightParsed = items
} }
raw (Highlight.go _highlightBackend hinput) sayRaw (Highlight.go _highlightBackend hinput)

View File

@ -9,7 +9,7 @@ import Juvix.Compiler.Concrete.Data.Highlight
data HighlightOptions = HighlightOptions data HighlightOptions = HighlightOptions
{ _highlightBackend :: HighlightBackend, { _highlightBackend :: HighlightBackend,
_highlightInputFile :: Path _highlightInputFile :: AppPath File
} }
deriving stock (Data) deriving stock (Data)

View File

@ -3,7 +3,7 @@ module Commands.Dev.Internal.Arity.Options where
import CommonOptions import CommonOptions
newtype InternalArityOptions = InternalArityOptions newtype InternalArityOptions = InternalArityOptions
{ _internalArityInputFile :: Path { _internalArityInputFile :: AppPath File
} }
deriving stock (Data) deriving stock (Data)

View File

@ -9,7 +9,7 @@ data InternalCoreEvalOptions = InternalCoreEvalOptions
{ _internalCoreEvalTransformations :: [TransformationId], { _internalCoreEvalTransformations :: [TransformationId],
_internalCoreEvalShowDeBruijn :: Bool, _internalCoreEvalShowDeBruijn :: Bool,
_internalCoreEvalNoIO :: Bool, _internalCoreEvalNoIO :: Bool,
_internalCoreEvalInputFile :: Path _internalCoreEvalInputFile :: AppPath File
} }
deriving stock (Data) deriving stock (Data)

View File

@ -3,7 +3,7 @@ module Commands.Dev.Internal.Pretty.Options where
import CommonOptions import CommonOptions
newtype InternalPrettyOptions = InternalPrettyOptions newtype InternalPrettyOptions = InternalPrettyOptions
{ _internalPrettyInputFile :: Path { _internalPrettyInputFile :: AppPath File
} }
deriving stock (Data) deriving stock (Data)

View File

@ -4,7 +4,7 @@ import CommonOptions
data InternalTypeOptions = InternalTypeOptions data InternalTypeOptions = InternalTypeOptions
{ _internalTypePrint :: Bool, { _internalTypePrint :: Bool,
_internalTypeInputFile :: Path _internalTypeInputFile :: AppPath File
} }
deriving stock (Data) deriving stock (Data)

View File

@ -3,7 +3,7 @@ module Commands.Dev.MiniC.Options where
import CommonOptions import CommonOptions
newtype MiniCOptions = MiniCOptions newtype MiniCOptions = MiniCOptions
{ _miniCInputFile :: Path { _miniCInputFile :: AppPath File
} }
deriving stock (Data) deriving stock (Data)

View File

@ -8,11 +8,13 @@ module Commands.Dev.Options
module Commands.Dev.Scope.Options, module Commands.Dev.Scope.Options,
module Commands.Dev.Doc.Options, module Commands.Dev.Doc.Options,
module Commands.Dev.Termination.Options, module Commands.Dev.Termination.Options,
module Commands.Dev.DisplayRoot.Options,
) )
where where
import Commands.Dev.Asm.Options hiding (Compile) import Commands.Dev.Asm.Options hiding (Compile)
import Commands.Dev.Core.Options import Commands.Dev.Core.Options
import Commands.Dev.DisplayRoot.Options
import Commands.Dev.Doc.Options import Commands.Dev.Doc.Options
import Commands.Dev.Highlight.Options import Commands.Dev.Highlight.Options
import Commands.Dev.Internal.Options import Commands.Dev.Internal.Options
@ -24,7 +26,7 @@ import Commands.Dev.Termination.Options
import CommonOptions import CommonOptions
data DevCommand data DevCommand
= DisplayRoot = DisplayRoot RootOptions
| Highlight HighlightOptions | Highlight HighlightOptions
| Internal InternalCommand | Internal InternalCommand
| Core CoreCommand | Core CoreCommand
@ -122,7 +124,7 @@ commandShowRoot :: Mod CommandFields DevCommand
commandShowRoot = commandShowRoot =
command "root" $ command "root" $
info info
(pure DisplayRoot) (DisplayRoot <$> parseRoot)
(progDesc "Show the root path for a Juvix project") (progDesc "Show the root path for a Juvix project")
commandTermination :: Mod CommandFields DevCommand commandTermination :: Mod CommandFields DevCommand

View File

@ -4,7 +4,7 @@ import CommonOptions
data ParseOptions = ParseOptions data ParseOptions = ParseOptions
{ _parseNoPrettyShow :: Bool, { _parseNoPrettyShow :: Bool,
_parseInputFile :: Path _parseInputFile :: AppPath File
} }
deriving stock (Data) deriving stock (Data)

View File

@ -6,7 +6,7 @@ import Juvix.Compiler.Concrete.Pretty qualified as Scoper
data ScopeOptions = ScopeOptions data ScopeOptions = ScopeOptions
{ _scopeInlineImports :: Bool, { _scopeInlineImports :: Bool,
_scopeInputFile :: Path _scopeInputFile :: AppPath File
} }
deriving stock (Data) deriving stock (Data)

View File

@ -5,7 +5,7 @@ import Data.Text qualified as Text
data CallGraphOptions = CallGraphOptions data CallGraphOptions = CallGraphOptions
{ _graphFunctionNameFilter :: Maybe (NonEmpty Text), { _graphFunctionNameFilter :: Maybe (NonEmpty Text),
_graphInputFile :: Path _graphInputFile :: AppPath File
} }
deriving stock (Data) deriving stock (Data)

View File

@ -8,7 +8,7 @@ import Juvix.Compiler.Abstract.Pretty.Base qualified as Abstract
data CallsOptions = CallsOptions data CallsOptions = CallsOptions
{ _callsFunctionNameFilter :: Maybe (NonEmpty Text), { _callsFunctionNameFilter :: Maybe (NonEmpty Text),
_callsShowDecreasingArgs :: Abstract.ShowDecrArgs, _callsShowDecreasingArgs :: Abstract.ShowDecrArgs,
_callsInputFile :: Path _callsInputFile :: AppPath File
} }
deriving stock (Data) deriving stock (Data)

View File

@ -68,7 +68,7 @@ type DoctorEff = '[Log, Embed IO]
checkCmdOnPath :: Members DoctorEff r => String -> [Text] -> Sem r () checkCmdOnPath :: Members DoctorEff r => String -> [Text] -> Sem r ()
checkCmdOnPath cmd errMsg = 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 :: Members DoctorEff r => String -> [Text] -> Sem r ()
checkClangTargetSupported target errMsg = do checkClangTargetSupported target errMsg = do

View File

@ -10,27 +10,24 @@ import System.Process qualified as P
runCommand :: forall r. Members '[Embed IO, App] r => CompileOptions -> Sem r () runCommand :: forall r. Members '[Embed IO, App] r => CompileOptions -> Sem r ()
runCommand opts = do runCommand opts = do
root <- askRoot root <- askPkgDir
let inputFile = opts ^. compileInputFile . pathPath inputFile <- someBaseToAbs' (opts ^. compileInputFile . pathPath)
result <- embed (runCompile root inputFile opts) result <- runCompile root inputFile opts
case result of case result of
Left err -> printFailureExit err Left err -> printFailureExit err
_ -> return () _ -> return ()
juvixIncludeDir :: FilePath runCompile :: Members '[App, Embed IO] r => Path Abs Dir -> Path Abs File -> CompileOptions -> Sem r (Either Text ())
juvixIncludeDir = juvixBuildDir </> "include"
runCompile :: FilePath -> FilePath -> CompileOptions -> IO (Either Text ())
runCompile projRoot inputFile o = do runCompile projRoot inputFile o = do
createDirectoryIfMissing True (projRoot </> juvixBuildDir) ensureDir (projRoot <//> juvixBuildDir)
createDirectoryIfMissing True (projRoot </> juvixIncludeDir) ensureDir (projRoot <//> juvixIncludeDir)
prepareRuntime projRoot o prepareRuntime projRoot o
case o ^. compileTarget of case o ^. compileTarget of
TargetWasm32Wasi -> runM (runError (clangWasmWasiCompile inputFile o)) TargetWasm32Wasi -> runError (clangWasmWasiCompile inputFile o)
TargetNative64 -> runM (runError (clangNativeCompile inputFile o)) TargetNative64 -> runError (clangNativeCompile inputFile o)
TargetC -> return $ Right () 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 prepareRuntime projRoot o = do
mapM_ writeHeader headersDir mapM_ writeHeader headersDir
case o ^. compileTarget of case o ^. compileTarget of
@ -52,64 +49,74 @@ prepareRuntime projRoot o = do
nativeDebugRuntime :: BS.ByteString nativeDebugRuntime :: BS.ByteString
nativeDebugRuntime = $(FE.makeRelativeToProject "runtime/_build.native64-debug/libjuvix.a" >>= FE.embedFile) nativeDebugRuntime = $(FE.makeRelativeToProject "runtime/_build.native64-debug/libjuvix.a" >>= FE.embedFile)
headersDir :: [(FilePath, BS.ByteString)] writeRuntime :: BS.ByteString -> Sem r ()
headersDir = $(FE.makeRelativeToProject "runtime/include" >>= FE.embedDir)
writeRuntime :: BS.ByteString -> IO ()
writeRuntime = writeRuntime =
BS.writeFile (projRoot </> juvixBuildDir </> "libjuvix.a") embed
. BS.writeFile (toFilePath (projRoot <//> juvixBuildDir <//> $(mkRelFile "libjuvix.a")))
writeHeader :: (FilePath, BS.ByteString) -> IO () headersDir :: [(Path Rel File, BS.ByteString)]
writeHeader (filePath, contents) = do headersDir = map (first relFile) $(FE.makeRelativeToProject "runtime/include" >>= FE.embedDir)
createDirectoryIfMissing True (projRoot </> juvixIncludeDir </> takeDirectory filePath)
BS.writeFile (projRoot </> juvixIncludeDir </> filePath) contents 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 :: clangNativeCompile ::
forall r. forall r.
Members '[Embed IO, Error Text] r => Members '[App, Embed IO, Error Text] r =>
FilePath -> Path Abs File ->
CompileOptions -> CompileOptions ->
Sem r () Sem r ()
clangNativeCompile inputFile o = clangNativeCompile inputFile o = do
runClang (native64Args o outputFile inputFile) outputFile' <- outputFile
runClang (native64Args o outputFile' inputFile)
where where
outputFile :: FilePath outputFile :: Sem r (Path Abs File)
outputFile = maybe defaultOutputFile (^. pathPath) (o ^. compileOutputFile) outputFile = maybe (return defaultOutputFile) someBaseToAbs' (o ^? compileOutputFile . _Just . pathPath)
defaultOutputFile :: FilePath defaultOutputFile :: Path Abs File
defaultOutputFile defaultOutputFile
| o ^. compilePreprocess = takeBaseName inputFile <> ".out.c" | o ^. compilePreprocess = replaceExtension' ".out.c" inputFile
| o ^. compileAssembly = takeBaseName inputFile <> ".s" | o ^. compileAssembly = replaceExtension' ".s" inputFile
| otherwise = takeBaseName inputFile | otherwise = removeExtension' inputFile
clangWasmWasiCompile :: clangWasmWasiCompile ::
forall r. forall r.
Members '[Embed IO, Error Text] r => Members '[App, Embed IO, Error Text] r =>
FilePath -> Path Abs File ->
CompileOptions -> CompileOptions ->
Sem r () Sem r ()
clangWasmWasiCompile inputFile o = clangArgs >>= runClang clangWasmWasiCompile inputFile o = clangArgs >>= runClang
where where
clangArgs :: Sem r [String] clangArgs :: Sem r [String]
clangArgs = wasiArgs o outputFile inputFile <$> sysrootEnvVar clangArgs = do
outputFile' <- outputFile
wasiArgs o outputFile' inputFile <$> sysrootEnvVar
outputFile :: FilePath outputFile :: Sem r (Path Abs File)
outputFile = maybe defaultOutputFile (^. pathPath) (o ^. compileOutputFile) outputFile = case o ^? compileOutputFile . _Just . pathPath of
Just f -> someBaseToAbs' f
Nothing -> return defaultOutputFile
defaultOutputFile :: FilePath defaultOutputFile :: Path Abs File
defaultOutputFile defaultOutputFile = replaceExtension' extension inputFile
| o ^. compilePreprocess = takeBaseName inputFile <> ".out.c" where
| o ^. compileAssembly = takeBaseName inputFile <> ".wat" extension :: String
| otherwise = takeBaseName inputFile <> ".wasm" extension
| o ^. compilePreprocess = ".out.c"
| o ^. compileAssembly = ".wat"
| otherwise = ".wasm"
sysrootEnvVar :: Sem r String sysrootEnvVar :: Sem r (Path Abs Dir)
sysrootEnvVar = sysrootEnvVar =
fromMaybeM (throw msg) (embed (lookupEnv "WASI_SYSROOT_PATH")) absDir
<$> fromMaybeM (throw msg) (embed (lookupEnv "WASI_SYSROOT_PATH"))
where where
msg :: Text msg :: Text
msg = "Missing environment variable WASI_SYSROOT_PATH" msg = "Missing environment variable WASI_SYSROOT_PATH"
commonArgs :: CompileOptions -> FilePath -> [String] commonArgs :: CompileOptions -> Path Abs File -> [String]
commonArgs o outputFile = commonArgs o outputFile =
["-E" | o ^. compilePreprocess] ["-E" | o ^. compilePreprocess]
<> ["-S" | o ^. compileAssembly] <> ["-S" | o ^. compileAssembly]
@ -121,26 +128,26 @@ commonArgs o outputFile =
"-Werror", "-Werror",
"-std=c11", "-std=c11",
"-I", "-I",
juvixIncludeDir, toFilePath juvixIncludeDir,
"-o", "-o",
outputFile toFilePath outputFile
] ]
<> ( if <> ( if
| not (o ^. compilePreprocess || o ^. compileAssembly) -> | not (o ^. compilePreprocess || o ^. compileAssembly) ->
[ "-L", [ "-L",
juvixBuildDir toFilePath juvixBuildDir
] ]
| otherwise -> [] | otherwise -> []
) )
native64Args :: CompileOptions -> FilePath -> FilePath -> [String] native64Args :: CompileOptions -> Path Abs File -> Path Abs File -> [String]
native64Args o outputFile inputFile = native64Args o outputFile inputFile =
commonArgs o outputFile commonArgs o outputFile
<> [ "-DARCH_NATIVE64", <> [ "-DARCH_NATIVE64",
"-DAPI_LIBC", "-DAPI_LIBC",
"-m64", "-m64",
"-O3", "-O3",
inputFile toFilePath inputFile
] ]
<> ( if <> ( if
| not (o ^. compilePreprocess || o ^. compileAssembly) -> | not (o ^. compilePreprocess || o ^. compileAssembly) ->
@ -148,7 +155,7 @@ native64Args o outputFile inputFile =
| otherwise -> [] | otherwise -> []
) )
wasiArgs :: CompileOptions -> FilePath -> FilePath -> FilePath -> [String] wasiArgs :: CompileOptions -> Path Abs File -> Path Abs File -> Path Abs Dir -> [String]
wasiArgs o outputFile inputFile sysrootPath = wasiArgs o outputFile inputFile sysrootPath =
commonArgs o outputFile commonArgs o outputFile
<> [ "-DARCH_WASM32", <> [ "-DARCH_WASM32",
@ -157,8 +164,8 @@ wasiArgs o outputFile inputFile sysrootPath =
"-nodefaultlibs", "-nodefaultlibs",
"--target=wasm32-wasi", "--target=wasm32-wasi",
"--sysroot", "--sysroot",
sysrootPath, toFilePath sysrootPath,
inputFile toFilePath inputFile
] ]
<> ( if <> ( if
| not (o ^. compilePreprocess || o ^. compileAssembly) -> | not (o ^. compilePreprocess || o ^. compileAssembly) ->

View File

@ -2,16 +2,19 @@ module Commands.Extra.Compile.Options where
import CommonOptions import CommonOptions
data CompileTarget = TargetWasm32Wasi | TargetNative64 | TargetC data CompileTarget
= TargetWasm32Wasi
| TargetNative64
| TargetC
deriving stock (Show, Data) deriving stock (Show, Data)
data CompileOptions = CompileOptions data CompileOptions = CompileOptions
{ _compileDebug :: Bool, { _compileDebug :: Bool,
_compilePreprocess :: Bool, _compilePreprocess :: Bool,
_compileAssembly :: Bool, _compileAssembly :: Bool,
_compileOutputFile :: Maybe Path, _compileOutputFile :: Maybe (AppPath File),
_compileTarget :: CompileTarget, _compileTarget :: CompileTarget,
_compileInputFile :: Path _compileInputFile :: AppPath File
} }
deriving stock (Data) deriving stock (Data)

View File

@ -10,4 +10,5 @@ runCommand :: Members '[Embed IO, App] r => HtmlOptions -> Sem r ()
runCommand HtmlOptions {..} = do runCommand HtmlOptions {..} = do
res <- runPipeline _htmlInputFile upToScoping res <- runPipeline _htmlInputFile upToScoping
let m = head (res ^. Scoper.resultModules) 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)

View File

@ -6,8 +6,8 @@ import Juvix.Compiler.Backend.Html.Data.Theme
data HtmlOptions = HtmlOptions data HtmlOptions = HtmlOptions
{ _htmlRecursive :: Bool, { _htmlRecursive :: Bool,
_htmlTheme :: Theme, _htmlTheme :: Theme,
_htmlOutputDir :: Path, _htmlOutputDir :: AppPath Dir,
_htmlInputFile :: Path, _htmlInputFile :: AppPath File,
_htmlPrintMetadata :: Bool _htmlPrintMetadata :: Bool
} }
deriving stock (Data) deriving stock (Data)
@ -33,7 +33,7 @@ parseHtml = do
) )
_htmlOutputDir <- _htmlOutputDir <-
parseGenericOutputDir parseGenericOutputDir
( value "html" ( value (Rel $(mkRelDir "html"))
<> showDefault <> showDefault
<> help "html output directory" <> help "html output directory"
<> action "directory" <> action "directory"

View File

@ -26,13 +26,13 @@ init = do
say "✨ Your next Juvix adventure is about to begin! ✨" say "✨ Your next Juvix adventure is about to begin! ✨"
say "I will help you set it up" say "I will help you set it up"
pkg <- getPackage pkg <- getPackage
say ("creating " <> pack juvixYamlFile) say ("creating " <> pack (toFilePath juvixYamlFile))
embed (encodeFile juvixYamlFile pkg) embed (encodeFile (toFilePath juvixYamlFile) (rawPackage pkg))
say "you are all set" say "you are all set"
checkNotInProject :: forall r. Members '[Embed IO] r => Sem r () checkNotInProject :: forall r. Members '[Embed IO] r => Sem r ()
checkNotInProject = checkNotInProject =
whenM (embed (doesFileExist juvixYamlFile)) err whenM (doesFileExist juvixYamlFile) err
where where
err :: Sem r () err :: Sem r ()
err = do err = do
@ -43,11 +43,12 @@ getPackage :: forall r. Members '[Embed IO] r => Sem r Package
getPackage = do getPackage = do
tproj <- getProjName tproj <- getProjName
say "Tell me the version of your project [leave empty for 0.0.0]" say "Tell me the version of your project [leave empty for 0.0.0]"
tversion <- getVersion tversion :: SemVer <- getVersion
return return
Package Package
{ _packageName = Just tproj, { _packageName = tproj,
_packageVersion = Just (prettySemVer tversion) _packageVersion = Ideal tversion,
_packageDependencies = mempty
} }
getProjName :: forall r. Members '[Embed IO] r => Sem r Text getProjName :: forall r. Members '[Embed IO] r => Sem r Text
@ -66,7 +67,7 @@ getProjName = do
where where
getDefault :: Sem r (Maybe Text) getDefault :: Sem r (Maybe Text)
getDefault = runFail $ do getDefault = runFail $ do
dir <- map toLower <$> (embed getCurrentDirectory >>= Fail.last . splitDirectories) dir <- map toLower . dropTrailingPathSeparator . toFilePath . dirname <$> getCurrentDir
Fail.fromRight (parse projectNameParser (pack dir)) Fail.fromRight (parse projectNameParser (pack dir))
readName :: Maybe Text -> Sem r Text readName :: Maybe Text -> Sem r Text
readName def = go readName def = go

View File

@ -5,7 +5,6 @@ module Commands.Repl where
import Commands.Base hiding (command) import Commands.Base hiding (command)
import Commands.Repl.Options import Commands.Repl.Options
import Control.Exception (throwIO) import Control.Exception (throwIO)
import Control.Monad.IO.Class
import Control.Monad.State.Strict qualified as State import Control.Monad.State.Strict qualified as State
import Data.String.Interpolate (i, __i) import Data.String.Interpolate (i, __i)
import Evaluator import Evaluator
@ -23,7 +22,6 @@ import Juvix.Data.Error.GenericError qualified as Error
import Juvix.Extra.Paths import Juvix.Extra.Paths
import Juvix.Extra.Version import Juvix.Extra.Version
import Juvix.Prelude.Pretty qualified as P import Juvix.Prelude.Pretty qualified as P
import Root
import System.Console.ANSI qualified as Ansi import System.Console.ANSI qualified as Ansi
import System.Console.Haskeline import System.Console.Haskeline
import System.Console.Repline import System.Console.Repline
@ -41,10 +39,10 @@ data ReplContext = ReplContext
} }
data ReplState = ReplState data ReplState = ReplState
{ _replStateReplRoot :: FilePath, { _replStatePkgDir :: Path Abs Dir,
_replStateInvokeDir :: Path Abs Dir,
_replStateContext :: Maybe ReplContext, _replStateContext :: Maybe ReplContext,
_replStateGlobalOptions :: GlobalOptions, _replStateGlobalOptions :: GlobalOptions
_replStateMkEntryPoint :: FilePath -> Repl EntryPoint
} }
makeLenses ''ReplState 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 :: Members '[Embed IO, App] r => ReplOptions -> Sem r ()
runCommand opts = do 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 printHelpTxt _ = helpTxt
multilineCmd :: String multilineCmd :: String
@ -88,21 +105,21 @@ runCommand opts = do
loadEntryPoint :: EntryPoint -> Repl () loadEntryPoint :: EntryPoint -> Repl ()
loadEntryPoint ep = do loadEntryPoint ep = do
(bs, res) <- liftIO (runIO' iniState ep upToCore) (artif, res) <- liftIO (runIO' iniState ep upToCore)
State.modify State.modify
( set ( set
replStateContext replStateContext
( Just ( Just
( ReplContext ( ReplContext
{ _replContextBuiltins = bs, { _replContextBuiltins = artif ^. artifactBuiltins,
_replContextExpContext = expressionContext res, _replContextExpContext = expressionContext res,
_replContextEntryPoint = ep _replContextEntryPoint = ep
} }
) )
) )
) )
let epPath :: FilePath = ep ^. entryPointModulePaths . _head1 let epPath :: Path Abs File = ep ^. entryPointModulePaths . _head1
liftIO (putStrLn [i|OK loaded: #{epPath}|]) liftIO (putStrLn [i|OK loaded: #{toFilePath epPath}|])
reloadFile :: String -> Repl () reloadFile :: String -> Repl ()
reloadFile _ = do reloadFile _ = do
@ -112,29 +129,24 @@ runCommand opts = do
loadEntryPoint entryPoint loadEntryPoint entryPoint
Nothing -> noFileLoadedMsg Nothing -> noFileLoadedMsg
loadFile :: String -> Repl () pSomeFile :: String -> SomeBase File
loadFile args = do pSomeFile = someFile . unpack . strip . pack
mkEntryPoint <- State.gets (^. replStateMkEntryPoint)
let f = unpack (strip (pack args)) loadFile :: SomeBase File -> Repl ()
entryPoint <- mkEntryPoint f loadFile f = do
entryPoint <- getReplEntryPoint f
loadEntryPoint entryPoint loadEntryPoint entryPoint
loadPrelude :: Repl () loadPrelude :: Repl ()
loadPrelude = do loadPrelude = loadDefaultPrelude
mStdlibPath <- State.gets (^. replStateGlobalOptions . globalStdlibPath)
case mStdlibPath of
Nothing -> loadDefaultPrelude
Just stdlibDir' -> do
absStdlibDir <- liftIO (makeAbsolute stdlibDir')
loadFile (absStdlibDir </> preludePath)
loadDefaultPrelude :: Repl () loadDefaultPrelude :: Repl ()
loadDefaultPrelude = defaultPreludeEntryPoint >>= loadEntryPoint loadDefaultPrelude = defaultPreludeEntryPoint >>= loadEntryPoint
printRoot :: String -> Repl () printRoot :: String -> Repl ()
printRoot _ = do printRoot _ = do
r <- State.gets (^. replStateReplRoot) r <- State.gets (^. replStatePkgDir)
liftIO $ putStrLn (pack r) liftIO $ putStrLn (pack (toFilePath r))
displayVersion :: String -> Repl () displayVersion :: String -> Repl ()
displayVersion _ = liftIO (putStrLn versionTag) displayVersion _ = liftIO (putStrLn versionTag)
@ -202,7 +214,7 @@ runCommand opts = do
-- `repline`'s `multilineCommand` logic overrides this no-op. -- `repline`'s `multilineCommand` logic overrides this no-op.
(multilineCmd, Repline.dontCrash . \_ -> return ()), (multilineCmd, Repline.dontCrash . \_ -> return ()),
("quit", quit), ("quit", quit),
("load", Repline.dontCrash . loadFile), ("load", Repline.dontCrash . loadFile . pSomeFile),
("reload", Repline.dontCrash . reloadFile), ("reload", Repline.dontCrash . reloadFile),
("prelude", Repline.dontCrash . const loadPrelude), ("prelude", Repline.dontCrash . const loadPrelude),
("root", printRoot), ("root", printRoot),
@ -249,18 +261,30 @@ runCommand opts = do
tabComplete = Prefix (wordCompleter optsCompleter) defaultMatcher tabComplete = Prefix (wordCompleter optsCompleter) defaultMatcher
replAction :: ReplS () 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 globalOptions <- askGlobalOptions
embed embed
( State.evalStateT ( State.evalStateT
replAction replAction
( ReplState ( ReplState
{ _replStateReplRoot = root, { _replStatePkgDir = pkgDir,
_replStateInvokeDir = invokeDir,
_replStateContext = Nothing, _replStateContext = Nothing,
_replStateGlobalOptions = globalOptions, _replStateGlobalOptions = globalOptions
_replStateMkEntryPoint = getReplEntryPoint
} }
) )
) )
@ -268,38 +292,26 @@ runCommand opts = do
defaultPreludeEntryPoint :: Repl EntryPoint defaultPreludeEntryPoint :: Repl EntryPoint
defaultPreludeEntryPoint = do defaultPreludeEntryPoint = do
opts <- State.gets (^. replStateGlobalOptions) opts <- State.gets (^. replStateGlobalOptions)
root <- State.gets (^. replStateReplRoot) root <- State.gets (^. replStatePkgDir)
return $ return $
EntryPoint EntryPoint
{ _entryPointRoot = root, { _entryPointRoot = root,
_entryPointResolverRoot = defaultStdlibPath root,
_entryPointNoTermination = opts ^. globalNoTermination, _entryPointNoTermination = opts ^. globalNoTermination,
_entryPointNoPositivity = opts ^. globalNoPositivity, _entryPointNoPositivity = opts ^. globalNoPositivity,
_entryPointNoStdlib = opts ^. globalNoStdlib, _entryPointNoStdlib = opts ^. globalNoStdlib,
_entryPointStdlibPath = opts ^. globalStdlibPath, _entryPointPackage = defaultPackage root,
_entryPointPackage = emptyPackage, _entryPointModulePaths = pure (defaultStdlibPath root <//> preludePath),
_entryPointModulePaths = pure (defaultStdlibPath root </> preludePath),
_entryPointGenericOptions = project opts, _entryPointGenericOptions = project opts,
_entryPointStdin = Nothing _entryPointStdin = Nothing
} }
getReplEntryPoint :: FilePath -> Repl EntryPoint replMakeAbsolute :: SomeBase b -> Repl (Path Abs b)
getReplEntryPoint inputFile = do replMakeAbsolute = \case
opts <- State.gets (^. replStateGlobalOptions) Abs p -> return p
absInputFile <- liftIO (makeAbsolute inputFile) Rel r -> do
absStdlibPath <- liftIO (mapM makeAbsolute (opts ^. globalStdlibPath)) invokeDir <- State.gets (^. replStateInvokeDir)
(root, package) <- liftIO (findRoot (Just absInputFile)) return (invokeDir <//> r)
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
}
inferExpressionIO' :: ReplContext -> Text -> IO (Either JuvixError Internal.Expression) inferExpressionIO' :: ReplContext -> Text -> IO (Either JuvixError Internal.Expression)
inferExpressionIO' ctx = inferExpressionIO "" (ctx ^. replContextExpContext) (ctx ^. replContextBuiltins) inferExpressionIO' ctx = inferExpressionIO "" (ctx ^. replContextExpContext) (ctx ^. replContextBuiltins)

View File

@ -3,7 +3,7 @@ module Commands.Repl.Options where
import CommonOptions import CommonOptions
data ReplOptions = ReplOptions data ReplOptions = ReplOptions
{ _replInputFile :: Maybe Path, { _replInputFile :: Maybe (AppPath File),
_replNoPrelude :: Bool _replNoPrelude :: Bool
} }
deriving stock (Data) deriving stock (Data)

View File

@ -4,7 +4,7 @@ import Commands.Dev.Internal.Typecheck.Options qualified as Internal
import CommonOptions import CommonOptions
newtype TypecheckOptions = TypecheckOptions newtype TypecheckOptions = TypecheckOptions
{ _typecheckInputFile :: Path { _typecheckInputFile :: AppPath File
} }
deriving stock (Data) deriving stock (Data)

View File

@ -14,86 +14,98 @@ import System.Process
import Prelude (show) import Prelude (show)
-- | Paths that are input are used to detect the root of the project. -- | Paths that are input are used to detect the root of the project.
data Path = Path data AppPath f = AppPath
{ _pathPath :: FilePath, { _pathPath :: SomeBase f,
_pathIsInput :: Bool _pathIsInput :: Bool
} }
deriving stock (Data) deriving stock (Data)
makeLenses ''Path makeLenses ''AppPath
instance Show Path where instance Show (AppPath f) where
show = (^. pathPath) show = Prelude.show . (^. pathPath)
parseInputJuvixFile :: Parser Path parseInputJuvixFile :: Parser (AppPath File)
parseInputJuvixFile = do parseInputJuvixFile = do
_pathPath <- _pathPath <-
argument argument
str someFileOpt
( metavar "JUVIX_FILE" ( metavar "JUVIX_FILE"
<> help "Path to a .juvix file" <> help "Path to a .juvix file"
<> completer juvixCompleter <> completer juvixCompleter
) )
pure Path {_pathIsInput = True, ..} pure AppPath {_pathIsInput = True, ..}
parseInputJuvixCoreFile :: Parser Path parseInputJuvixCoreFile :: Parser (AppPath File)
parseInputJuvixCoreFile = do parseInputJuvixCoreFile = do
_pathPath <- _pathPath <-
argument argument
str someFileOpt
( metavar "JUVIX_CORE_FILE" ( metavar "JUVIX_CORE_FILE"
<> help "Path to a .jvc file" <> help "Path to a .jvc file"
<> completer juvixCoreCompleter <> completer juvixCoreCompleter
) )
pure Path {_pathIsInput = True, ..} pure AppPath {_pathIsInput = True, ..}
parseInputJuvixAsmFile :: Parser Path parseInputJuvixAsmFile :: Parser (AppPath File)
parseInputJuvixAsmFile = do parseInputJuvixAsmFile = do
_pathPath <- _pathPath <-
argument argument
str someFileOpt
( metavar "JUVIX_ASM_FILE" ( metavar "JUVIX_ASM_FILE"
<> help "Path to a .jva file" <> help "Path to a .jva file"
<> completer juvixAsmCompleter <> completer juvixAsmCompleter
) )
pure Path {_pathIsInput = True, ..} pure AppPath {_pathIsInput = True, ..}
parseInputCFile :: Parser Path parseInputCFile :: Parser (AppPath File)
parseInputCFile = do parseInputCFile = do
_pathPath <- _pathPath <-
argument argument
str someFileOpt
( metavar "C_FILE" ( metavar "C_FILE"
<> help "Path to a .c file" <> help "Path to a .c file"
<> completer juvixCCompleter <> completer juvixCCompleter
) )
pure Path {_pathIsInput = True, ..} pure AppPath {_pathIsInput = True, ..}
parseGenericOutputFile :: Parser Path parseGenericOutputFile :: Parser (AppPath File)
parseGenericOutputFile = do parseGenericOutputFile = do
_pathPath <- _pathPath <-
option option
str someFileOpt
( long "output" ( long "output"
<> short 'o' <> short 'o'
<> metavar "OUTPUT_FILE" <> metavar "OUTPUT_FILE"
<> help "Path to output file" <> help "Path to output file"
<> action "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 parseGenericOutputDir m = do
_pathPath <- _pathPath <-
option option
str someDirOpt
( long "output-dir" ( long "output-dir"
<> metavar "OUTPUT_DIR" <> metavar "OUTPUT_DIR"
<> help "Path to output directory" <> help "Path to output directory"
<> action "directory" <> action "directory"
<> m <> 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 :: String -> Completer
extCompleter ext = mkCompleter $ \word -> do extCompleter ext = mkCompleter $ \word -> do
@ -186,7 +198,7 @@ requote s =
goX [] = goX [] =
[] []
class HasPaths a where class HasAppPaths a where
paths :: Traversal' a FilePath paths :: Traversal' a FilePath
optDeBruijn :: Parser Bool optDeBruijn :: Parser Bool

View File

@ -13,7 +13,7 @@ import Juvix.Compiler.Core.Pretty qualified as Core
import Text.Megaparsec.Pos qualified as M import Text.Megaparsec.Pos qualified as M
data EvalOptions = EvalOptions data EvalOptions = EvalOptions
{ _evalInputFile :: Path, { _evalInputFile :: AppPath File,
_evalNoIO :: Bool _evalNoIO :: Bool
} }
@ -58,6 +58,6 @@ evalAndPrint opts tab node = do
embed (putStrLn "") embed (putStrLn "")
where where
defaultLoc :: Interval defaultLoc :: Interval
defaultLoc = singletonInterval (mkLoc 0 (M.initialPos f)) defaultLoc = singletonInterval (mkLoc 0 (M.initialPos (fromSomeFile f)))
f :: FilePath f :: SomeBase File
f = project opts ^. evalInputFile . pathPath f = project opts ^. evalInputFile . pathPath

View File

@ -3,11 +3,10 @@ module GlobalOptions
) )
where where
import CommonOptions
import Juvix.Compiler.Abstract.Pretty.Options qualified as Abstract import Juvix.Compiler.Abstract.Pretty.Options qualified as Abstract
import Juvix.Compiler.Internal.Pretty.Options qualified as Internal import Juvix.Compiler.Internal.Pretty.Options qualified as Internal
import Juvix.Data.Error.GenericError qualified as E import Juvix.Data.Error.GenericError qualified as E
import Juvix.Prelude
import Options.Applicative hiding (hidden)
data GlobalOptions = GlobalOptions data GlobalOptions = GlobalOptions
{ _globalNoColors :: Bool, { _globalNoColors :: Bool,
@ -17,10 +16,9 @@ data GlobalOptions = GlobalOptions
_globalStdin :: Bool, _globalStdin :: Bool,
_globalNoTermination :: Bool, _globalNoTermination :: Bool,
_globalNoPositivity :: Bool, _globalNoPositivity :: Bool,
_globalNoStdlib :: Bool, _globalNoStdlib :: Bool
_globalStdlibPath :: Maybe FilePath
} }
deriving stock (Eq, Show, Data) deriving stock (Eq, Show)
makeLenses ''GlobalOptions makeLenses ''GlobalOptions
@ -53,8 +51,7 @@ defaultGlobalOptions =
_globalNoTermination = False, _globalNoTermination = False,
_globalStdin = False, _globalStdin = False,
_globalNoPositivity = False, _globalNoPositivity = False,
_globalNoStdlib = False, _globalNoStdlib = False
_globalStdlibPath = Nothing
} }
-- | Get a parser for global flags which can be hidden or not depending on -- | Get a parser for global flags which can be hidden or not depending on
@ -101,14 +98,4 @@ parseGlobalFlags = do
( long "no-stdlib" ( long "no-stdlib"
<> help "Do not use the standard library" <> 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 {..} return GlobalOptions {..}

View File

@ -2,7 +2,6 @@ module Main (main) where
import App import App
import CommonOptions import CommonOptions
import Juvix.Compiler.Pipeline
import Root import Root
import TopCommand import TopCommand
import TopCommand.Options import TopCommand.Options
@ -10,9 +9,7 @@ import TopCommand.Options
main :: IO () main :: IO ()
main = do main = do
let p = prefs showHelpOnEmpty let p = prefs showHelpOnEmpty
(global, cli) <- customExecParser p descr >>= secondM makeAbsPaths cwd <- getCurrentDir
(root, pkg) <- findRoot' cli (global, cli) <- customExecParser p descr
runM (runAppIO global root pkg (runTopCommand cli)) (root, pkg) <- findRootAndChangeDir (topCommandInputFile cli)
where runM (runAppIO global cwd root pkg (runTopCommand cli))
findRoot' :: TopCommand -> IO (FilePath, Package)
findRoot' cli = findRoot (topCommandInputFile cli)

View File

@ -2,14 +2,15 @@ module Root where
import Control.Exception qualified as IO import Control.Exception qualified as IO
import Data.ByteString qualified as ByteString import Data.ByteString qualified as ByteString
import Data.Yaml
import Juvix.Compiler.Pipeline import Juvix.Compiler.Pipeline
import Juvix.Extra.Paths qualified as Paths import Juvix.Extra.Paths qualified as Paths
import Juvix.Prelude import Juvix.Prelude
findRoot :: Maybe FilePath -> IO (FilePath, Package) findRootAndChangeDir :: Maybe (SomeBase File) -> IO (Path Abs Dir, Package)
findRoot minputFile = do findRootAndChangeDir minputFile = do
whenJust (takeDirectory <$> minputFile) setCurrentDirectory whenJust minputFile $ \case
Abs d -> setCurrentDir (parent d)
Rel d -> setCurrentDir (parent d)
r <- IO.try go r <- IO.try go
case r of case r of
Left (err :: IO.SomeException) -> do Left (err :: IO.SomeException) -> do
@ -18,22 +19,21 @@ findRoot minputFile = do
exitFailure exitFailure
Right root -> return root Right root -> return root
where where
possiblePaths :: FilePath -> [FilePath] possiblePaths :: Path Abs Dir -> [Path Abs Dir]
possiblePaths start = takeWhile (/= "/") (aux start) possiblePaths p = p : toList (parents p)
where
aux f = f : aux (takeDirectory f)
go :: IO (FilePath, Package) go :: IO (Path Abs Dir, Package)
go = do go = do
c <- getCurrentDirectory cwd <- getCurrentDir
l <- findFile (possiblePaths c) Paths.juvixYamlFile l <- findFile (possiblePaths cwd) Paths.juvixYamlFile
case l of case l of
Nothing -> return (c, emptyPackage) Nothing -> return (cwd, defaultPackage cwd)
Just yaml -> do Just yamlPath -> do
bs <- ByteString.readFile yaml bs <- ByteString.readFile (toFilePath yamlPath)
let isEmpty = ByteString.null bs let isEmpty = ByteString.null bs
root = parent yamlPath
pkg <- pkg <-
if if
| isEmpty -> return emptyPackage | isEmpty -> return (defaultPackage root)
| otherwise -> decodeThrow bs | otherwise -> readPackageIO root
return (takeDirectory yaml, pkg) return (root, pkg)

View File

@ -23,10 +23,10 @@ data TopCommand
| JuvixRepl ReplOptions | JuvixRepl ReplOptions
deriving stock (Data) deriving stock (Data)
topCommandInputFile :: TopCommand -> Maybe FilePath topCommandInputFile :: TopCommand -> Maybe (SomeBase File)
topCommandInputFile = firstJust getInputFile . universeBi topCommandInputFile = firstJust getInputFile . universeBi
where where
getInputFile :: Path -> Maybe FilePath getInputFile :: AppPath File -> Maybe (SomeBase File)
getInputFile p getInputFile p
| p ^. pathIsInput = Just (p ^. pathPath) | p ^. pathIsInput = Just (p ^. pathPath)
| otherwise = Nothing | otherwise = Nothing
@ -134,12 +134,6 @@ parseTopCommand =
<|> parseCompilerCommand <|> parseCompilerCommand
<|> parseUtility <|> parseUtility
makeAbsPaths :: TopCommand -> IO TopCommand
makeAbsPaths = transformBiM go
where
go :: Path -> IO Path
go = traverseOf pathPath canonicalizePath
descr :: ParserInfo (GlobalOptions, TopCommand) descr :: ParserInfo (GlobalOptions, TopCommand)
descr = descr =
info info

@ -1 +1 @@
Subproject commit c91ec2eb6daf49c993a1f55673e75d97cb8dada3 Subproject commit a2790ca49ceeb569559224abe1587305ea1861fa

View File

@ -15,6 +15,7 @@ github: anoma/juvix
extra-source-files: extra-source-files:
- README.org - README.org
- assets/* - assets/*
- juvix-stdlib/juvix.yaml
- juvix-stdlib/**/*.juvix - juvix-stdlib/**/*.juvix
- runtime/include/**/*.h - runtime/include/**/*.h
- runtime/**/*.a - runtime/**/*.a
@ -23,6 +24,7 @@ extra-source-files:
dependencies: dependencies:
- aeson == 2.0.* - aeson == 2.0.*
- aeson-better-errors == 0.9.*
- ansi-terminal == 0.11.* - ansi-terminal == 0.11.*
- base == 4.16.* - base == 4.16.*
- blaze-html == 0.9.* - blaze-html == 0.9.*
@ -31,8 +33,8 @@ dependencies:
- directory == 1.3.* - directory == 1.3.*
- dlist == 1.0.* - dlist == 1.0.*
- edit-distance == 0.2.* - edit-distance == 0.2.*
- exceptions == 0.10.*
- extra == 1.7.* - extra == 1.7.*
- transformers == 0.5.*
- file-embed == 0.0.* - file-embed == 0.0.*
- filepath == 1.4.* - filepath == 1.4.*
- gitrev == 1.3.* - gitrev == 1.3.*
@ -45,19 +47,20 @@ dependencies:
- path-io == 1.7.* - path-io == 1.7.*
- polysemy == 1.7.* - polysemy == 1.7.*
- polysemy-plugin == 0.4.* - polysemy-plugin == 0.4.*
- pretty == 1.1.*
- prettyprinter == 1.7.* - prettyprinter == 1.7.*
- prettyprinter-ansi-terminal == 1.1.* - prettyprinter-ansi-terminal == 1.1.*
- pretty == 1.1.*
- process == 1.6.* - process == 1.6.*
- safe == 0.3.* - safe == 0.3.*
- semirings == 0.6.*
- singletons == 3.0.* - singletons == 3.0.*
- singletons-th == 3.1.* - singletons-th == 3.1.*
- Stream == 0.4.* - Stream == 0.4.*
- time == 1.11.*
- template-haskell == 2.18.* - template-haskell == 2.18.*
- text == 1.2.* - text == 1.2.*
- th-utilities == 0.2.* - th-utilities == 0.2.*
- time == 1.11.*
- transformers == 0.5.*
- unix-compat == 0.5.*
- unordered-containers == 0.2.* - unordered-containers == 0.2.*
- versions == 5.0.* - versions == 5.0.*
- yaml == 0.11.* - yaml == 0.11.*

View File

@ -9,6 +9,7 @@ import Data.ByteString qualified as BS
import Data.ByteString.Builder qualified as Builder import Data.ByteString.Builder qualified as Builder
import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict qualified as HashMap
import Data.Time.Clock import Data.Time.Clock
import Data.Versions (prettyV)
import Juvix.Compiler.Abstract.Translation.FromConcrete qualified as Abstract import Juvix.Compiler.Abstract.Translation.FromConcrete qualified as Abstract
import Juvix.Compiler.Backend.Html.Data import Juvix.Compiler.Backend.Html.Data
import Juvix.Compiler.Backend.Html.Extra import Juvix.Compiler.Backend.Html.Extra
@ -34,7 +35,7 @@ import Text.Blaze.Html5.Attributes qualified as Attr
data DocParams = DocParams data DocParams = DocParams
{ _docParamBase :: Text, { _docParamBase :: Text,
_docOutputDir :: FilePath _docOutputDir :: Path Abs Dir
} }
makeLenses ''DocParams makeLenses ''DocParams
@ -64,8 +65,8 @@ indexTree = foldr insertModule emptyTree
emptyTree :: Tree Symbol (Maybe TopModulePath) emptyTree :: Tree Symbol (Maybe TopModulePath)
emptyTree = Tree Nothing mempty emptyTree = Tree Nothing mempty
indexFileName :: FilePath indexFileName :: Path Rel File
indexFileName = "index.html" indexFileName = $(mkRelFile "index.html")
createIndexFile :: createIndexFile ::
forall r. forall r.
@ -74,7 +75,7 @@ createIndexFile ::
Sem r () Sem r ()
createIndexFile ps = do createIndexFile ps = do
outDir <- asks (^. docOutputDir) outDir <- asks (^. docOutputDir)
indexHtml >>= (template mempty >=> writeHtml (outDir </> indexFileName)) indexHtml >>= (template mempty >=> writeHtml (outDir <//> indexFileName))
where where
indexHtml :: Sem r Html indexHtml :: Sem r Html
indexHtml = do indexHtml = do
@ -126,7 +127,7 @@ createIndexFile ps = do
summary "Subtree" summary "Subtree"
<> ul (mconcatMap li c') <> 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 compile dir baseName ctx = runReader params . runReader normTable . runReader entry $ do
copyAssets copyAssets
mapM_ goTopModule topModules mapM_ goTopModule topModules
@ -147,15 +148,15 @@ compile dir baseName ctx = runReader params . runReader normTable . runReader en
. Scoped.mainModule . Scoped.mainModule
copyAssets :: forall s. Members '[Embed IO, Reader DocParams] s => Sem s () copyAssets :: forall s. Members '[Embed IO, Reader DocParams] s => Sem s ()
copyAssets = do copyAssets = do
toAssetsDir <- (</> "assets") <$> asks (^. docOutputDir) toAssetsDir <- (<//> $(mkRelDir "assets")) <$> asks (^. docOutputDir)
let writeAsset :: (FilePath, BS.ByteString) -> Sem s () let writeAsset :: (Path Rel File, BS.ByteString) -> Sem s ()
writeAsset (filePath, fileContents) = writeAsset (filePath, fileContents) =
Prelude.embed $ BS.writeFile (toAssetsDir </> takeFileName filePath) fileContents Prelude.embed $ BS.writeFile (toFilePath (toAssetsDir <//> filePath)) fileContents
Prelude.embed (createDirectoryIfMissing True toAssetsDir) ensureDir toAssetsDir
mapM_ writeAsset assetFiles mapM_ writeAsset assetFiles
where where
assetFiles :: [(FilePath, BS.ByteString)] assetFiles :: [(Path Rel File, BS.ByteString)]
assetFiles = $(assetsDir) assetFiles = assetsDir
params :: DocParams params :: DocParams
params = params =
@ -166,19 +167,19 @@ compile dir baseName ctx = runReader params . runReader normTable . runReader en
topModules :: HashMap NameId (Module 'Scoped 'ModuleTop) topModules :: HashMap NameId (Module 'Scoped 'ModuleTop)
topModules = getAllModules mainMod 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 writeHtml f h = Prelude.embed $ do
createDirectoryIfMissing True dir ensureDir dir
Builder.writeFile f (Html.renderHtmlBuilder h) Builder.writeFile (toFilePath f) (Html.renderHtmlBuilder h)
where where
dir :: FilePath dir :: Path Abs Dir
dir = takeDirectory f 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 moduleDocPath m = do
relPath <- moduleDocRelativePath (m ^. modulePath . S.nameConcrete) relPath <- moduleDocRelativePath (m ^. modulePath . S.nameConcrete)
outDir <- asks (^. docOutputDir) outDir <- asks (^. docOutputDir)
return (outDir </> relPath) return (outDir <//> relPath)
topModulePath :: topModulePath ::
Module 'Scoped 'ModuleTop -> TopModulePath Module 'Scoped 'ModuleTop -> TopModulePath
@ -215,8 +216,8 @@ template rightMenu' content' = do
packageHeader :: Sem r Html packageHeader :: Sem r Html
packageHeader = do packageHeader = do
pkgName' <- toHtml <$> asks (^. entryPointPackage . packageName') pkgName' <- toHtml <$> asks (^. entryPointPackage . packageName)
version' <- toHtml <$> asks (^. entryPointPackage . packageVersion') version' <- toHtml <$> asks (^. entryPointPackage . packageVersion . to prettyV)
return $ return $
Html.div ! Attr.id "package-header" $ Html.div ! Attr.id "package-header" $
( Html.span ! Attr.class_ "caption" $ ( Html.span ! Attr.class_ "caption" $
@ -258,7 +259,7 @@ goTopModule ::
goTopModule m = do goTopModule m = do
runReader docHtmlOpts $ do runReader docHtmlOpts $ do
fpath <- moduleDocPath m fpath <- moduleDocPath m
Prelude.embed (putStrLn ("processing " <> pack fpath)) Prelude.embed (putStrLn ("processing " <> pack (toFilePath fpath)))
docHtml >>= writeHtml fpath docHtml >>= writeHtml fpath
runReader srcHtmlOpts $ do runReader srcHtmlOpts $ do
@ -285,7 +286,7 @@ goTopModule m = do
return $ return $
ul ! Attr.id "page-menu" ! Attr.class_ "links" $ ul ! Attr.id "page-menu" ! Attr.class_ "links" $
li (a ! Attr.href sourceRef' $ "Source") 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 :: Sem s Html
content = do content = do

View File

@ -12,6 +12,7 @@ import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
import Juvix.Compiler.Concrete.Extra import Juvix.Compiler.Concrete.Extra
import Juvix.Compiler.Concrete.Language import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Concrete.Pretty.Base import Juvix.Compiler.Concrete.Pretty.Base
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver
import Juvix.Compiler.Internal.Pretty qualified as Internal import Juvix.Compiler.Internal.Pretty qualified as Internal
import Juvix.Extra.Paths import Juvix.Extra.Paths
import Juvix.Extra.Version import Juvix.Extra.Version
@ -34,11 +35,11 @@ kindSuffix = \case
HtmlSrc -> "-src" HtmlSrc -> "-src"
HtmlOnly -> "" 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 genHtml opts recursive theme outputDir printMetadata entry = do
createDirectoryIfMissing True outputDir ensureDir outputDir
copyAssetFiles copyAssetFiles
withCurrentDirectory outputDir $ do withCurrentDir outputDir $ do
mapM_ outputModule allModules mapM_ outputModule allModules
where where
allModules allModules
@ -47,25 +48,26 @@ genHtml opts recursive theme outputDir printMetadata entry = do
copyAssetFiles :: IO () copyAssetFiles :: IO ()
copyAssetFiles = do copyAssetFiles = do
createDirectoryIfMissing True toAssetsDir ensureDir toAssetsDir
mapM_ writeAsset assetFiles mapM_ writeAsset assetFiles
where where
assetFiles :: [(FilePath, BS.ByteString)] assetFiles :: [(Path Rel File, BS.ByteString)]
assetFiles = $(assetsDir) assetFiles = assetsDir
writeAsset :: (FilePath, BS.ByteString) -> IO () writeAsset :: (Path Rel File, BS.ByteString) -> IO ()
writeAsset (filePath, fileContents) = writeAsset (filePath, fileContents) =
BS.writeFile (toAssetsDir </> takeFileName filePath) fileContents BS.writeFile (toFilePath (toAssetsDir <//> filePath)) fileContents
toAssetsDir = outputDir </> "assets" toAssetsDir = outputDir <//> $(mkRelDir "assets")
outputModule :: Module 'Scoped 'ModuleTop -> IO () outputModule :: Module 'Scoped 'ModuleTop -> IO ()
outputModule m = do outputModule m = do
createDirectoryIfMissing True (takeDirectory htmlFile) ensureDir (parent htmlFile)
putStrLn $ "Writing " <> pack htmlFile putStrLn $ "Writing " <> pack (toFilePath htmlFile)
utc <- getCurrentTime utc <- getCurrentTime
Text.writeFile htmlFile (genModule opts HtmlOnly printMetadata utc theme m) Text.writeFile (toFilePath htmlFile) (genModule opts HtmlOnly printMetadata utc theme m)
where 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 :: Options -> HtmlKind -> Bool -> UTCTime -> Theme -> Module 'Scoped 'ModuleTop -> Html
genModuleHtml opts htmlKind printMetadata utc theme m = genModuleHtml opts htmlKind printMetadata utc theme m =
@ -215,15 +217,12 @@ putTag ann x = case ann of
nameIdAttr :: S.NameId -> AttributeValue nameIdAttr :: S.NameId -> AttributeValue
nameIdAttr (S.NameId k) = fromString . show $ k 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 moduleDocRelativePath m = do
suff <- kindSuffix <$> asks (^. htmlOptionsKind) suff <- kindSuffix <$> asks (^. htmlOptionsKind)
return (topModulePathToRelativeFilePath (Just "html") suff joinDot m) return (topModulePathToRelativePathDot ".html" suff m)
where
joinDot :: FilePath -> FilePath -> FilePath
joinDot l r = l <.> r
nameIdAttrRef :: Members '[Reader HtmlOptions] r => TopModulePath -> Maybe S.NameId -> Sem r AttributeValue nameIdAttrRef :: Members '[Reader HtmlOptions] r => TopModulePath -> Maybe S.NameId -> Sem r AttributeValue
nameIdAttrRef tp s = do nameIdAttrRef tp s = do
pth <- moduleDocRelativePath tp pth <- toFilePath <$> moduleDocRelativePath tp
return (fromString pth <> preEscapedToValue '#' <>? (nameIdAttr <$> s)) return (fromString pth <> preEscapedToValue '#' <>? (nameIdAttr <$> s))

View File

@ -15,12 +15,12 @@ data HighlightInput = HighlightInput
makeLenses ''HighlightInput makeLenses ''HighlightInput
filterInput :: FilePath -> HighlightInput -> HighlightInput filterInput :: Path Abs File -> HighlightInput -> HighlightInput
filterInput absPth HighlightInput {..} = filterInput absPth HighlightInput {..} =
HighlightInput HighlightInput
{ _highlightNames = filterByLoc absPth _highlightNames, { _highlightNames = filterByLoc absPth _highlightNames,
_highlightParsed = filterByLoc absPth _highlightParsed _highlightParsed = filterByLoc absPth _highlightParsed
} }
filterByLoc :: HasLoc p => FilePath -> [p] -> [p] filterByLoc :: HasLoc p => Path Abs File -> [p] -> [p]
filterByLoc absPth = filter ((== absPth) . (^. intervalFile) . getLoc) filterByLoc p = filter ((== toFilePath p) . (^. intervalFile) . getLoc)

View File

@ -23,7 +23,7 @@ instance HasLoc Name where
NameUnqualified s -> getLoc s NameUnqualified s -> getLoc s
instance Pretty QualifiedName where instance Pretty QualifiedName where
pretty (QualifiedName (Path path) s) = pretty (QualifiedName (SymbolPath path) s) =
let symbols = snoc (toList path) s let symbols = snoc (toList path) s
in dotted (map pretty symbols) in dotted (map pretty symbols)
where where
@ -35,13 +35,13 @@ instance Pretty Name where
NameQualified q -> pretty q NameQualified q -> pretty q
NameUnqualified s -> pretty s NameUnqualified s -> pretty s
newtype Path = Path newtype SymbolPath = SymbolPath
{ _pathParts :: NonEmpty Symbol { _pathParts :: NonEmpty Symbol
} }
deriving stock (Show, Eq, Ord) deriving stock (Show, Eq, Ord)
data QualifiedName = QualifiedName data QualifiedName = QualifiedName
{ _qualifiedPath :: Path, { _qualifiedPath :: SymbolPath,
_qualifiedSymbol :: Symbol _qualifiedSymbol :: Symbol
} }
deriving stock (Show, Eq, Ord, Generic) deriving stock (Show, Eq, Ord, Generic)
@ -52,13 +52,13 @@ instance HasLoc QualifiedName where
instance Hashable QualifiedName instance Hashable QualifiedName
instance HasLoc Path where instance HasLoc SymbolPath where
getLoc (Path p) = getLoc (NonEmpty.head p) <> getLoc (NonEmpty.last p) getLoc (SymbolPath p) = getLoc (NonEmpty.head p) <> getLoc (NonEmpty.last p)
deriving newtype instance Hashable Path deriving newtype instance Hashable SymbolPath
makeLenses ''QualifiedName makeLenses ''QualifiedName
makeLenses ''Path makeLenses ''SymbolPath
-- | A.B.C corresponds to TopModulePath [A,B] C -- | A.B.C corresponds to TopModulePath [A,B] C
data TopModulePath = TopModulePath data TopModulePath = TopModulePath
@ -79,31 +79,6 @@ instance HasLoc TopModulePath where
[] -> getLoc _modulePathName [] -> getLoc _modulePathName
(x : _) -> getLoc x <> 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 :: IsString s => TopModulePath -> s
topModulePathToDottedPath (TopModulePath l r) = topModulePathToDottedPath (TopModulePath l r) =
fromText $ mconcat $ intersperse "." $ map (^. symbolText) $ l ++ [r] fromText $ mconcat $ intersperse "." $ map (^. symbolText) $ l ++ [r]

View File

@ -52,10 +52,8 @@ newtype ModulesCache = ModulesCache
makeLenses ''ModulesCache makeLenses ''ModulesCache
data ScopeParameters = ScopeParameters newtype ScopeParameters = ScopeParameters
{ -- | Usually set to ".juvix". { -- | Used for import cycle detection.
_scopeFileExtension :: String,
-- | Used for import cycle detection.
_scopeTopParents :: [Import 'Parsed] _scopeTopParents :: [Import 'Parsed]
} }

View File

@ -40,11 +40,11 @@ instance Hashable AbsModulePath
-- | Tells whether the first argument is an immediate child of the second argument. -- | 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. -- In other words, tells whether the first argument is a local module of the second.
isChildOf :: AbsModulePath -> AbsModulePath -> Bool isChildOf :: AbsModulePath -> AbsModulePath -> Bool
isChildOf child parent isChildOf child parentMod
| null (child ^. absLocalPath) = False | null (child ^. absLocalPath) = False
| otherwise = | otherwise =
init (child ^. absLocalPath) == parent ^. absLocalPath init (child ^. absLocalPath) == parentMod ^. absLocalPath
&& child ^. absTopModulePath == parent ^. absTopModulePath && child ^. absTopModulePath == parentMod ^. absTopModulePath
-- | Appends a local path to the absolute path -- | Appends a local path to the absolute path
-- e.g. TopMod.Local <.> Inner == TopMod.Local.Inner -- e.g. TopMod.Local <.> Inner == TopMod.Local.Inner

View File

@ -3,6 +3,7 @@ module Juvix.Compiler.Concrete.Translation where
-- import Juvix.Compiler.Concrete.Translation.FromParsed -- import Juvix.Compiler.Concrete.Translation.FromParsed
import Juvix.Compiler.Concrete.Language import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Concrete.Translation.FromParsed qualified as Scoper 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.Concrete.Translation.FromSource qualified as Parser
import Juvix.Compiler.Pipeline.EntryPoint import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Prelude import Juvix.Prelude
@ -10,7 +11,7 @@ import Juvix.Prelude
type JudocStash = State (Maybe (Judoc 'Parsed)) type JudocStash = State (Maybe (Judoc 'Parsed))
fromSource :: fromSource ::
Members '[Files, Error JuvixError, NameIdGen] r => Members '[Files, Error JuvixError, NameIdGen, Reader EntryPoint, PathResolver] r =>
EntryPoint -> EntryPoint ->
Sem r Scoper.ScoperResult Sem r Scoper.ScoperResult
fromSource = Parser.fromSource >=> Scoper.fromParsed fromSource = Parser.fromSource >=> Scoper.fromParsed

View File

@ -7,14 +7,16 @@ where
import Juvix.Compiler.Concrete.Data.InfoTable import Juvix.Compiler.Concrete.Data.InfoTable
import Juvix.Compiler.Concrete.Language 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
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context 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 qualified as Parser
import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context qualified as Parsed import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context qualified as Parsed
import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Prelude import Juvix.Prelude
fromParsed :: fromParsed ::
Members '[Error JuvixError, Files, NameIdGen] r => Members '[Error JuvixError, Files, NameIdGen, Reader EntryPoint, PathResolver] r =>
Parsed.ParserResult -> Parsed.ParserResult ->
Sem r ScoperResult Sem r ScoperResult
fromParsed pr = mapError (JuvixError @ScoperError) $ do fromParsed pr = mapError (JuvixError @ScoperError) $ do

View File

@ -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

View File

@ -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

View File

@ -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))

View File

@ -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)]

View File

@ -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.Data.ScopedName qualified as S
import Juvix.Compiler.Concrete.Extra qualified as P import Juvix.Compiler.Concrete.Extra qualified as P
import Juvix.Compiler.Concrete.Language 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.Data.Context
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error
import Juvix.Compiler.Concrete.Translation.FromSource (runModuleParser) import Juvix.Compiler.Concrete.Translation.FromSource (runModuleParser)
import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser
import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context (ParserResult) import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context (ParserResult)
import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Prelude import Juvix.Prelude
iniScoperState :: ScoperState iniScoperState :: ScoperState
@ -38,12 +40,11 @@ iniScoperState =
iniScopeParameters :: ScopeParameters iniScopeParameters :: ScopeParameters
iniScopeParameters = iniScopeParameters =
ScopeParameters ScopeParameters
{ _scopeFileExtension = ".juvix", { _scopeTopParents = mempty
_scopeTopParents = mempty
} }
scopeCheck :: scopeCheck ::
Members '[Files, Error ScoperError, NameIdGen] r => Members '[Files, Error ScoperError, NameIdGen, Reader EntryPoint, PathResolver] r =>
ParserResult -> ParserResult ->
InfoTable -> InfoTable ->
NonEmpty (Module 'Parsed 'ModuleTop) -> NonEmpty (Module 'Parsed 'ModuleTop) ->
@ -216,13 +217,13 @@ bindLocalModuleSymbol _moduleExportInfo _moduleRefModule =
checkImport :: checkImport ::
forall r. 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 -> Import 'Parsed ->
Sem r (Import 'Scoped) Sem r (Import 'Scoped)
checkImport import_@(Import path) = do checkImport import_@(Import path) = do
checkCycle checkCycle
cache <- gets (^. scoperModulesCache . cachedModules) 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 let checked = moduleRef ^. moduleRefModule
sname = checked ^. modulePath sname = checked ^. modulePath
moduleId = sname ^. S.nameId moduleId = sname ^. S.nameId
@ -232,8 +233,6 @@ checkImport import_@(Import path) = do
modify (over scoperModules (HashMap.insert moduleId moduleRef')) modify (over scoperModules (HashMap.insert moduleId moduleRef'))
return (Import checked) return (Import checked)
where where
addImport :: ScopeParameters -> ScopeParameters
addImport = over scopeTopParents (cons import_)
checkCycle :: Sem r () checkCycle :: Sem r ()
checkCycle = do checkCycle = do
topp <- asks (^. scopeTopParents) topp <- asks (^. scopeTopParents)
@ -334,7 +333,7 @@ checkQualifiedExpr ::
Members '[Error ScoperError, State Scope, State ScoperState, InfoTableBuilder] r => Members '[Error ScoperError, State Scope, State ScoperState, InfoTableBuilder] r =>
QualifiedName -> QualifiedName ->
Sem r ScopedIden Sem r ScopedIden
checkQualifiedExpr q@(QualifiedName (Path p) sym) = do checkQualifiedExpr q@(QualifiedName (SymbolPath p) sym) = do
es <- filter entryIsExpression <$> lookupQualifiedSymbol (toList p, sym) es <- filter entryIsExpression <$> lookupQualifiedSymbol (toList p, sym)
case es of case es of
[] -> notInScope [] -> notInScope
@ -384,25 +383,32 @@ exportScope Scope {..} = do
(MultipleExportConflict _scopePath s (e :| es)) (MultipleExportConflict _scopePath s (e :| es))
) )
readParseModule :: withPath' ::
Members '[Error ScoperError, Reader ScopeParameters, Files, Parser.InfoTableBuilder, NameIdGen] r => forall r a.
Members '[PathResolver, Error ScoperError] r =>
TopModulePath -> TopModulePath ->
Sem r (Module 'Parsed 'ModuleTop) (Path Abs File -> Sem r a) ->
readParseModule mp = do Sem r a
path <- modulePathToFilePath mp 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 txt <- readFile' path
pr <- runModuleParser path txt pr <- runModuleParser path txt
case pr of case pr of
Left err -> throw (ErrParser (MegaParsecError err)) Left err -> throw (ErrParser (MegaParsecError err))
Right (tbl, m) -> Parser.mergeTable tbl $> m Right (tbl, m) -> do
Parser.mergeTable tbl
modulePathToFilePath :: local addImport (checkTopModule m)
Members '[Reader ScopeParameters, Files] r => where
TopModulePath -> addImport :: ScopeParameters -> ScopeParameters
Sem r FilePath addImport = over scopeTopParents (cons import_)
modulePathToFilePath mp = do
ext <- asks (^. scopeFileExtension)
topModulePathToFilePath' (Just ext) mp
checkOperatorSyntaxDef :: checkOperatorSyntaxDef ::
forall r. forall r.
@ -510,7 +516,7 @@ createExportsTable ei = foldr (HashSet.insert . getNameId) HashSet.empty (HashMa
checkTopModules :: checkTopModules ::
forall r. 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) -> NonEmpty (Module 'Parsed 'ModuleTop) ->
Sem r (NonEmpty (Module 'Scoped 'ModuleTop), HashSet NameId) Sem r (NonEmpty (Module 'Scoped 'ModuleTop), HashSet NameId)
checkTopModules modules = do checkTopModules modules = do
@ -520,14 +526,14 @@ checkTopModules modules = do
checkTopModule_ :: checkTopModule_ ::
forall r. 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 -> Module 'Parsed 'ModuleTop ->
Sem r (Module 'Scoped 'ModuleTop) Sem r (Module 'Scoped 'ModuleTop)
checkTopModule_ = fmap (^. moduleRefModule) . checkTopModule checkTopModule_ = fmap (^. moduleRefModule) . checkTopModule
checkTopModule :: checkTopModule ::
forall r. 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 -> Module 'Parsed 'ModuleTop ->
Sem r (ModuleRef'' 'S.NotConcrete 'ModuleTop) Sem r (ModuleRef'' 'S.NotConcrete 'ModuleTop)
checkTopModule m@(Module path params doc body) = do 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)) modify (over (scoperModulesCache . cachedModules) (HashMap.insert path r))
return r return r
where where
checkPath :: Members '[Files, Reader ScopeParameters, Error ScoperError] s => Sem s () checkPath :: Members '[Error ScoperError, PathResolver] s => Sem s ()
checkPath = do checkPath = do
expectedPath <- modulePathToFilePath path expectedPath <- expectedModulePath path
let actualPath = getLoc path ^. intervalFile let actualPath = absFile (getLoc path ^. intervalFile)
unlessM (fromMaybe True <$> equalPaths' expectedPath actualPath) $ unlessM (equalPaths expectedPath actualPath) $
throw throw
( ErrWrongTopModuleName ( ErrWrongTopModuleName
WrongTopModuleName WrongTopModuleName
@ -598,7 +604,7 @@ withScope ma = do
checkModuleBody :: checkModuleBody ::
forall r. 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] -> [Statement 'Parsed] ->
Sem r (ExportInfo, [Statement 'Scoped]) Sem r (ExportInfo, [Statement 'Scoped])
checkModuleBody body = do checkModuleBody body = do
@ -610,7 +616,7 @@ checkModuleBody body = do
checkLocalModule :: checkLocalModule ::
forall r. 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 -> Module 'Parsed 'ModuleLocal ->
Sem r (Module 'Scoped 'ModuleLocal) Sem r (Module 'Scoped 'ModuleLocal)
checkLocalModule Module {..} = do checkLocalModule Module {..} = do
@ -686,7 +692,7 @@ lookupModuleSymbol n = do
notInScope = throw (ErrModuleNotInScope (ModuleNotInScope n)) notInScope = throw (ErrModuleNotInScope (ModuleNotInScope n))
(path, sym) = case n of (path, sym) = case n of
NameUnqualified s -> ([], s) 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 :: SymbolEntry -> Maybe (ModuleRef' 'S.NotConcrete)
getModuleRef = \case getModuleRef = \case
@ -706,7 +712,7 @@ getExportInfo modId = do
_ :&: ent -> ent ^. moduleExportInfo _ :&: ent -> ent ^. moduleExportInfo
checkOpenImportModule :: 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 -> OpenModule 'Parsed ->
Sem r (OpenModule 'Scoped) Sem r (OpenModule 'Scoped)
checkOpenImportModule op checkOpenImportModule op
@ -714,7 +720,7 @@ checkOpenImportModule op
let moduleNameToTopModulePath :: Name -> TopModulePath let moduleNameToTopModulePath :: Name -> TopModulePath
moduleNameToTopModulePath = \case moduleNameToTopModulePath = \case
NameUnqualified s -> TopModulePath [] s 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 'Parsed
import_ = Import (moduleNameToTopModulePath (op ^. openModuleName)) import_ = Import (moduleNameToTopModulePath (op ^. openModuleName))
in do in do
@ -783,7 +789,7 @@ checkOpenModuleNoImport OpenModule {..}
checkOpenModule :: checkOpenModule ::
forall r. 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 -> OpenModule 'Parsed ->
Sem r (OpenModule 'Scoped) Sem r (OpenModule 'Scoped)
checkOpenModule op checkOpenModule op
@ -1102,14 +1108,14 @@ checkPatternName n = do
Nothing -> PatternScopedVar <$> groupBindLocalVariable sym -- the symbol is a variable Nothing -> PatternScopedVar <$> groupBindLocalVariable sym -- the symbol is a variable
where where
(path, sym) = case n of (path, sym) = case n of
NameQualified (QualifiedName (Path p) s) -> (toList p, s) NameQualified (QualifiedName (SymbolPath p) s) -> (toList p, s)
NameUnqualified s -> ([], s) NameUnqualified s -> ([], s)
-- check whether the symbol is a constructor in scope -- check whether the symbol is a constructor in scope
getConstructorRef :: Sem r (Maybe ConstructorRef) getConstructorRef :: Sem r (Maybe ConstructorRef)
getConstructorRef = do getConstructorRef = do
entries <- mapMaybe getConstructor <$> lookupQualifiedSymbol (path, sym) entries <- mapMaybe getConstructor <$> lookupQualifiedSymbol (path, sym)
case entries of case entries of
[] -> case Path <$> nonEmpty path of [] -> case SymbolPath <$> nonEmpty path of
Nothing -> return Nothing -- There is no constructor with such a name Nothing -> return Nothing -- There is no constructor with such a name
Just pth -> throw (ErrQualSymNotInScope (QualSymNotInScope (QualifiedName pth sym))) 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 [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 checkParsePatternAtom = checkPatternAtom >=> parsePatternAtom
checkStatement :: 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 -> Statement 'Parsed ->
Sem r (Statement 'Scoped) Sem r (Statement 'Scoped)
checkStatement s = case s of checkStatement s = case s of

View File

@ -39,6 +39,7 @@ data ScoperError
| ErrAliasBinderPattern AliasBinderPattern | ErrAliasBinderPattern AliasBinderPattern
| ErrImplicitPatternLeftApplication ImplicitPatternLeftApplication | ErrImplicitPatternLeftApplication ImplicitPatternLeftApplication
| ErrConstructorExpectedLeftApplication ConstructorExpectedLeftApplication | ErrConstructorExpectedLeftApplication ConstructorExpectedLeftApplication
| ErrTopModulePath TopModulePathError
deriving stock (Show) deriving stock (Show)
instance ToGenericError ScoperError where instance ToGenericError ScoperError where
@ -71,3 +72,4 @@ instance ToGenericError ScoperError where
ErrAliasBinderPattern e -> genericError e ErrAliasBinderPattern e -> genericError e
ErrImplicitPatternLeftApplication e -> genericError e ErrImplicitPatternLeftApplication e -> genericError e
ErrConstructorExpectedLeftApplication e -> genericError e ErrConstructorExpectedLeftApplication e -> genericError e
ErrTopModulePath e -> genericError e

View File

@ -13,11 +13,31 @@ import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
import Juvix.Compiler.Concrete.Language import Juvix.Compiler.Concrete.Language
import Juvix.Compiler.Concrete.Language qualified as L import Juvix.Compiler.Concrete.Language qualified as L
import Juvix.Compiler.Concrete.Pretty.Options (Options, fromGenericOptions) 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.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error.Pretty
import Juvix.Data.CodeAnn import Juvix.Data.CodeAnn
import Juvix.Parser.Error qualified as Parser import Juvix.Parser.Error qualified as Parser
import Juvix.Prelude 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 data MultipleDeclarations = MultipleDeclarations
{ _multipleDeclEntry :: SymbolEntry, { _multipleDeclEntry :: SymbolEntry,
_multipleDeclSymbol :: Text, _multipleDeclSymbol :: Text,
@ -406,8 +426,8 @@ instance ToGenericError UnusedOperatorDef where
<> ppCode opts' _unusedOperatorDef <> ppCode opts' _unusedOperatorDef
data WrongTopModuleName = WrongTopModuleName data WrongTopModuleName = WrongTopModuleName
{ _wrongTopModuleNameExpectedPath :: FilePath, { _wrongTopModuleNameExpectedPath :: Path Abs File,
_wrongTopModuleNameActualPath :: FilePath, _wrongTopModuleNameActualPath :: Path Abs File,
_wrongTopModuleNameActualName :: TopModulePath _wrongTopModuleNameActualName :: TopModulePath
} }
deriving stock (Show) deriving stock (Show)

View File

@ -34,7 +34,7 @@ fromSource e = mapError (JuvixError @ParserError) $ do
goFile :: goFile ::
forall r. forall r.
Members '[Files, Error ParserError, InfoTableBuilder, NameIdGen] r => Members '[Files, Error ParserError, InfoTableBuilder, NameIdGen] r =>
FilePath -> Path Abs File ->
Sem r (Module 'Parsed 'ModuleTop) Sem r (Module 'Parsed 'ModuleTop)
goFile fileName = do goFile fileName = do
input <- getFileContents fileName input <- getFileContents fileName
@ -43,7 +43,7 @@ fromSource e = mapError (JuvixError @ParserError) $ do
Left er -> throw er Left er -> throw er
Right (tbl, m) -> mergeTable tbl $> m Right (tbl, m) -> mergeTable tbl $> m
where where
getFileContents :: FilePath -> Sem r Text getFileContents :: Path Abs File -> Sem r Text
getFileContents fp getFileContents fp
| fp == e ^. mainModulePath, | fp == e ^. mainModulePath,
Just txt <- e ^. entryPointStdin = 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 -- | The fileName is only used for reporting errors. It is safe to pass
-- an empty string. -- 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 runModuleParser fileName input = do
m <- m <-
runInfoTableBuilder $ runInfoTableBuilder $
evalState (Nothing @(Judoc 'Parsed)) $ evalState (Nothing @(Judoc 'Parsed)) $
P.runParserT topModuleDef fileName input P.runParserT topModuleDef (toFilePath fileName) input
case m of case m of
(_, Left err) -> return (Left (ParserError err)) (_, Left err) -> return (Left (ParserError err))
(tbl, Right r) -> return (Right (tbl, r)) (tbl, Right r) -> return (Right (tbl, r))
@ -118,7 +118,7 @@ name :: Members '[InfoTableBuilder, JudocStash, NameIdGen] r => ParsecS r Name
name = do name = do
parts <- dottedSymbol parts <- dottedSymbol
return $ case nonEmptyUnsnoc parts of 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 (Nothing, n) -> NameUnqualified n
mkTopModulePath :: NonEmpty Symbol -> TopModulePath mkTopModulePath :: NonEmpty Symbol -> TopModulePath

View File

@ -4,7 +4,7 @@ module Juvix.Compiler.Core.Info where
import Data.Dynamic import Data.Dynamic
import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict qualified as HashMap
import Juvix.Prelude import Juvix.Prelude hiding (insert)
class Typeable a => IsInfo a class Typeable a => IsInfo a
@ -21,7 +21,7 @@ empty :: Info
empty = Info HashMap.empty empty = Info HashMap.empty
singleton :: forall a. IsInfo a => a -> Info 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 :: forall a. IsInfo a => Key a -> Info -> Bool
member k i = HashMap.member (typeRep k) (i ^. infoMap) member k i = HashMap.member (typeRep k) (i ^. infoMap)

View File

@ -17,7 +17,7 @@ data FunCall = FunCall
} }
newtype CallRow = CallRow newtype CallRow = CallRow
{ _callRow :: Maybe (Int, Rel') { _callRow :: Maybe (Int, SizeRel')
} }
deriving stock (Eq, Show, Generic) deriving stock (Eq, Show, Generic)

View File

@ -28,7 +28,7 @@ data ReflexiveEdge = ReflexiveEdge
data RecursiveBehaviour = RecursiveBehaviour data RecursiveBehaviour = RecursiveBehaviour
{ _recursiveBehaviourFun :: FunctionName, { _recursiveBehaviourFun :: FunctionName,
_recursiveBehaviourMatrix :: [[Rel]] _recursiveBehaviourMatrix :: [[SizeRel]]
} }
deriving stock (Show) deriving stock (Show)

View File

@ -3,33 +3,33 @@ module Juvix.Compiler.Internal.Translation.FromAbstract.Analysis.Termination.Dat
import Juvix.Prelude import Juvix.Prelude
import Prettyprinter import Prettyprinter
data Rel data SizeRel
= RJust Rel' = RJust SizeRel'
| RNothing | RNothing
deriving stock (Eq, Show, Generic) deriving stock (Eq, Show, Generic)
data Rel' data SizeRel'
= REq = REq
| RLe | RLe
deriving stock (Eq, Show, Generic) deriving stock (Eq, Show, Generic)
instance Hashable Rel' instance Hashable SizeRel'
instance Hashable Rel instance Hashable SizeRel
toRel :: Rel' -> Rel toSizeRel :: SizeRel' -> SizeRel
toRel = RJust toSizeRel = RJust
mul' :: Rel' -> Rel' -> Rel' mul' :: SizeRel' -> SizeRel' -> SizeRel'
mul' REq a = a mul' REq a = a
mul' RLe _ = RLe mul' RLe _ = RLe
instance Pretty Rel where instance Pretty SizeRel where
pretty r = case r of pretty r = case r of
RJust r' -> pretty r' RJust r' -> pretty r'
RNothing -> pretty ("?" :: Text) RNothing -> pretty ("?" :: Text)
instance Pretty Rel' where instance Pretty SizeRel' where
pretty r = case r of pretty r = case r of
REq -> pretty ("=" :: Text) REq -> pretty ("=" :: Text)
RLe -> pretty ("" :: Text) RLe -> pretty ("" :: Text)

View File

@ -115,10 +115,10 @@ reflexiveEdges (CompleteCallGraph es) = mapMaybe reflexive (toList es)
Just $ ReflexiveEdge (e ^. edgeFrom) (e ^. edgeMatrices) Just $ ReflexiveEdge (e ^. edgeFrom) (e ^. edgeMatrices)
| otherwise = Nothing | otherwise = Nothing
callMatrixDiag :: CallMatrix -> [Rel] callMatrixDiag :: CallMatrix -> [SizeRel]
callMatrixDiag m = [col i r | (i, r) <- zip [0 :: Int ..] m] callMatrixDiag m = [col i r | (i, r) <- zip [0 :: Int ..] m]
where where
col :: Int -> CallRow -> Rel col :: Int -> CallRow -> SizeRel
col i (CallRow row) = case row of col i (CallRow row) = case row of
Nothing -> RNothing Nothing -> RNothing
Just (j, r') Just (j, r')
@ -134,7 +134,7 @@ recursiveBehaviour re =
findOrder :: RecursiveBehaviour -> Maybe LexOrder findOrder :: RecursiveBehaviour -> Maybe LexOrder
findOrder rb = LexOrder <$> listToMaybe (mapMaybe (isLexOrder >=> nonEmpty) allPerms) findOrder rb = LexOrder <$> listToMaybe (mapMaybe (isLexOrder >=> nonEmpty) allPerms)
where where
b0 :: [[Rel]] b0 :: [[SizeRel]]
b0 = rb ^. recursiveBehaviourMatrix b0 = rb ^. recursiveBehaviourMatrix
indexed = map (zip [0 :: Int ..] . take minLength) b0 indexed = map (zip [0 :: Int ..] . take minLength) b0
@ -144,13 +144,13 @@ findOrder rb = LexOrder <$> listToMaybe (mapMaybe (isLexOrder >=> nonEmpty) allP
startB = removeUselessColumns indexed startB = removeUselessColumns indexed
-- removes columns that don't have at least one ≺ in them -- 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 removeUselessColumns = transpose . filter (any (isLess . snd)) . transpose
isLexOrder :: [Int] -> Maybe [Int] isLexOrder :: [Int] -> Maybe [Int]
isLexOrder = go startB isLexOrder = go startB
where where
go :: [[(Int, Rel)]] -> [Int] -> Maybe [Int] go :: [[(Int, SizeRel)]] -> [Int] -> Maybe [Int]
go [] _ = Just [] go [] _ = Just []
go b perm = case perm of go b perm = case perm of
[] -> error "The permutation should have one element at least!" [] -> error "The permutation should have one element at least!"

View File

@ -1,6 +1,7 @@
module Juvix.Compiler.Pipeline module Juvix.Compiler.Pipeline
( module Juvix.Compiler.Pipeline, ( module Juvix.Compiler.Pipeline,
module Juvix.Compiler.Pipeline.EntryPoint, module Juvix.Compiler.Pipeline.EntryPoint,
module Juvix.Compiler.Pipeline.Artifacts,
module Juvix.Compiler.Pipeline.ExpressionContext, module Juvix.Compiler.Pipeline.ExpressionContext,
) )
where where
@ -12,10 +13,12 @@ import Juvix.Compiler.Backend.C qualified as C
import Juvix.Compiler.Builtins import Juvix.Compiler.Builtins
import Juvix.Compiler.Concrete qualified as Concrete import Juvix.Compiler.Concrete qualified as Concrete
import Juvix.Compiler.Concrete.Translation.FromParsed qualified as Scoper 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.Concrete.Translation.FromSource qualified as Parser
import Juvix.Compiler.Core.Language qualified as Core import Juvix.Compiler.Core.Language qualified as Core
import Juvix.Compiler.Core.Translation qualified as Core import Juvix.Compiler.Core.Translation qualified as Core
import Juvix.Compiler.Internal qualified as Internal import Juvix.Compiler.Internal qualified as Internal
import Juvix.Compiler.Pipeline.Artifacts
import Juvix.Compiler.Pipeline.EntryPoint import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Compiler.Pipeline.ExpressionContext import Juvix.Compiler.Pipeline.ExpressionContext
import Juvix.Compiler.Pipeline.Setup 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.Compiler.Reg.Translation.FromAsm qualified as Reg
import Juvix.Prelude 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 :: arityCheckExpression ::
Members '[Error JuvixError, NameIdGen, Builtins] r => Members '[Error JuvixError, NameIdGen, Builtins] r =>
@ -108,49 +111,49 @@ compile ::
compile = typecheck >=> C.fromInternal compile = typecheck >=> C.fromInternal
upToParsing :: upToParsing ::
Members '[Reader EntryPoint, Files, Error JuvixError, NameIdGen] r => Members '[Reader EntryPoint, Files, Error JuvixError, NameIdGen, PathResolver] r =>
Sem r Parser.ParserResult Sem r Parser.ParserResult
upToParsing = entrySetup >>= Parser.fromSource upToParsing = entrySetup >>= Parser.fromSource
upToScoping :: upToScoping ::
Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError] r => Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, PathResolver] r =>
Sem r Scoper.ScoperResult Sem r Scoper.ScoperResult
upToScoping = upToParsing >>= Scoper.fromParsed upToScoping = upToParsing >>= Scoper.fromParsed
upToAbstract :: upToAbstract ::
Members '[Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError] r => Members '[Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError, PathResolver] r =>
Sem r Abstract.AbstractResult Sem r Abstract.AbstractResult
upToAbstract = upToScoping >>= Abstract.fromConcrete upToAbstract = upToScoping >>= Abstract.fromConcrete
upToInternal :: upToInternal ::
Members '[Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError] r => Members '[Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError, PathResolver] r =>
Sem r Internal.InternalResult Sem r Internal.InternalResult
upToInternal = upToAbstract >>= Internal.fromAbstract upToInternal = upToAbstract >>= Internal.fromAbstract
upToInternalArity :: upToInternalArity ::
Members '[Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError] r => Members '[Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError, PathResolver] r =>
Sem r Internal.InternalArityResult Sem r Internal.InternalArityResult
upToInternalArity = upToInternal >>= Internal.arityChecking upToInternalArity = upToInternal >>= Internal.arityChecking
upToInternalTyped :: upToInternalTyped ::
Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins] r => Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, PathResolver] r =>
Sem r Internal.InternalTypedResult Sem r Internal.InternalTypedResult
upToInternalTyped = upToInternalArity >>= Internal.typeChecking upToInternalTyped = upToInternalArity >>= Internal.typeChecking
upToInternalReachability :: upToInternalReachability ::
Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins] r => Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, PathResolver] r =>
Sem r Internal.InternalTypedResult Sem r Internal.InternalTypedResult
upToInternalReachability = upToInternalReachability =
Internal.filterUnreachable <$> upToInternalTyped Internal.filterUnreachable <$> upToInternalTyped
upToCore :: upToCore ::
Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins] r => Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, PathResolver] r =>
Sem r Core.CoreResult Sem r Core.CoreResult
upToCore = upToCore =
upToInternalReachability >>= Core.fromInternal upToInternalReachability >>= Core.fromInternal
upToMiniC :: upToMiniC ::
Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins] r => Members '[Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, PathResolver] r =>
Sem r C.MiniCResult Sem r C.MiniCResult
upToMiniC = upToInternalReachability >>= C.fromInternal upToMiniC = upToInternalReachability >>= C.fromInternal
@ -168,17 +171,28 @@ regToMiniC lims = return . C.fromReg lims
-- Run pipeline -- 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 = runIOEither builtinsState entry =
runM runM
. runError . runError
. fmap makeArtifacts
. runBuiltins builtinsState . runBuiltins builtinsState
. runNameIdGen . runNameIdGen
. mapError (JuvixError @FilesError) . mapError (JuvixError @FilesError)
. runFilesIO (entry ^. entryPointRoot) . runFilesIO
. runReader entry . 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 runIO builtinsState opts entry = runIOEither builtinsState entry >=> mayThrow
where where
mayThrow :: Either JuvixError r -> IO r 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 Left err -> runM $ runReader opts $ printErrorAnsiSafe err >> embed exitFailure
Right r -> return r 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 runIO' builtinsState = runIO builtinsState defaultGenericOptions

View File

@ -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

View File

@ -5,41 +5,45 @@ module Juvix.Compiler.Pipeline.EntryPoint
where where
import Juvix.Compiler.Pipeline.Package import Juvix.Compiler.Pipeline.Package
import Juvix.Extra.Paths (juvixStdlibDir)
import Juvix.Prelude import Juvix.Prelude
-- | The head of _entryModulePaths is assumed to be the Main module -- | The head of _entryModulePaths is assumed to be the Main module
data EntryPoint = EntryPoint 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, _entryPointNoTermination :: Bool,
_entryPointNoPositivity :: Bool, _entryPointNoPositivity :: Bool,
_entryPointNoStdlib :: Bool, _entryPointNoStdlib :: Bool,
_entryPointStdlibPath :: Maybe FilePath,
_entryPointPackage :: Package, _entryPointPackage :: Package,
_entryPointStdin :: Maybe Text, _entryPointStdin :: Maybe Text,
_entryPointGenericOptions :: GenericOptions, _entryPointGenericOptions :: GenericOptions,
_entryPointModulePaths :: NonEmpty FilePath _entryPointModulePaths :: NonEmpty (Path Abs File)
} }
deriving stock (Eq, Show) deriving stock (Eq, Show)
defaultStdlibPath :: FilePath -> FilePath makeLenses ''EntryPoint
defaultStdlibPath root = root </> juvixStdlibDir
defaultEntryPoint :: FilePath -> EntryPoint defaultEntryPoint :: Path Abs Dir -> Path Abs File -> EntryPoint
defaultEntryPoint mainFile = defaultEntryPoint root mainFile =
EntryPoint EntryPoint
{ _entryPointRoot = ".", { _entryPointRoot = root,
_entryPointResolverRoot = root,
_entryPointNoTermination = False, _entryPointNoTermination = False,
_entryPointNoPositivity = False, _entryPointNoPositivity = False,
_entryPointNoStdlib = False, _entryPointNoStdlib = False,
_entryPointStdlibPath = Nothing,
_entryPointStdin = Nothing, _entryPointStdin = Nothing,
_entryPointPackage = emptyPackage, _entryPointPackage = defaultPackage root,
_entryPointGenericOptions = defaultGenericOptions, _entryPointGenericOptions = defaultGenericOptions,
_entryPointModulePaths = pure mainFile _entryPointModulePaths = pure mainFile
} }
makeLenses ''EntryPoint mainModulePath :: Lens' EntryPoint (Path Abs File)
mainModulePath :: Lens' EntryPoint FilePath
mainModulePath = entryPointModulePaths . _head1 mainModulePath = entryPointModulePaths . _head1
entryPointFromPackage :: Path Abs Dir -> Path Abs File -> Package -> EntryPoint
entryPointFromPackage root mainFile pkg =
(defaultEntryPoint root mainFile)
{ _entryPointPackage = pkg
}

View File

@ -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.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 Juvix.Prelude
import Lens.Micro.Platform qualified as Lens import Lens.Micro.Platform qualified as Lens
data Package = Package type NameType :: IsProcessed -> GHC.Type
{ _packageName :: Maybe Text, type family NameType s = res | res -> s where
_packageVersion :: Maybe Text 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 makeLenses ''Package'
defaultOptions
{ fieldLabelModifier = over Lens._head toLower . dropPrefix "_package",
rejectUnknownFields = True
}
''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
emptyPackage = emptyPackage =
Package Package
{ _packageName = Nothing, { _packageName = defaultPackageName,
_packageVersion = Nothing _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 processPackage :: forall r. Members '[Error Text] r => Path Abs Dir -> Package' 'Raw -> Sem r Package
packageName' f p = (\(Const r) -> Const r) (f name) 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 where
name :: Text getVersion :: Sem r Versioning
name = fromMaybe "my-package" (p ^. packageName) 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 defaultPackageName :: Text
packageVersion' f p = (\(Const r) -> Const r) (f name) 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 where
name :: Text yamlPath = adir <//> juvixYamlFile
name = fromMaybe "no version" (p ^. packageVersion)
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

View File

@ -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'

View File

@ -1,25 +1,34 @@
module Juvix.Compiler.Pipeline.Setup where module Juvix.Compiler.Pipeline.Setup where
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver
import Juvix.Compiler.Pipeline.EntryPoint import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Extra.Paths
import Juvix.Extra.Stdlib
import Juvix.Prelude import Juvix.Prelude
entrySetup :: entrySetup ::
Members '[Reader EntryPoint, Files] r => Members '[Reader EntryPoint, Files, PathResolver] r =>
Sem r EntryPoint Sem r EntryPoint
entrySetup = do entrySetup = do
e <- ask e <- ask
unless (e ^. entryPointNoStdlib) setupStdlib registerDependencies
return e return e
setupStdlib :: registerDependencies :: Members '[Reader EntryPoint, PathResolver] r => Sem r ()
Members '[Reader EntryPoint, Files] r => registerDependencies = do
Sem r ()
setupStdlib = do
e <- ask e <- ask
stdlibRootPath <- case e ^. entryPointStdlibPath of addDependency (Just e) (Dependency (e ^. entryPointRoot))
Nothing -> do
let d = defaultStdlibPath (e ^. entryPointRoot) stdlibDep ::
updateStdlib d 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 return d
Just p -> return p
registerStdlib stdlibRootPath

View File

@ -8,6 +8,8 @@ module Juvix.Data
module Juvix.Data.IsImplicit, module Juvix.Data.IsImplicit,
module Juvix.Data.Loc, module Juvix.Data.Loc,
module Juvix.Data.NameId, module Juvix.Data.NameId,
module Juvix.Data.Processed,
module Juvix.Data.Uid,
module Juvix.Data.Universe, module Juvix.Data.Universe,
module Juvix.Data.Usage, module Juvix.Data.Usage,
module Juvix.Data.Wildcard, module Juvix.Data.Wildcard,
@ -26,6 +28,8 @@ import Juvix.Data.Hole
import Juvix.Data.IsImplicit import Juvix.Data.IsImplicit
import Juvix.Data.Loc import Juvix.Data.Loc
import Juvix.Data.NameId qualified import Juvix.Data.NameId qualified
import Juvix.Data.Processed
import Juvix.Data.Uid
import Juvix.Data.Universe import Juvix.Data.Universe
import Juvix.Data.Usage import Juvix.Data.Usage
import Juvix.Data.Wildcard import Juvix.Data.Wildcard

View File

@ -42,6 +42,13 @@ stylize a = case a of
AnnDef {} -> mempty AnnDef {} -> mempty
AnnRef {} -> 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 -- | for builtin stuff
primitive :: Text -> Doc Ann primitive :: Text -> Doc Ann
primitive = annotate (AnnKind KNameAxiom) . pretty primitive = annotate (AnnKind KNameAxiom) . pretty

View File

@ -3,10 +3,63 @@ module Juvix.Data.Effect.Files
module Juvix.Data.Effect.Files.Base, module Juvix.Data.Effect.Files.Base,
module Juvix.Data.Effect.Files.Pure, module Juvix.Data.Effect.Files.Pure,
module Juvix.Data.Effect.Files.IO, module Juvix.Data.Effect.Files.IO,
module Juvix.Data.Effect.Files,
) )
where where
import Data.HashSet qualified as HashSet
import Juvix.Data.Effect.Files.Base import Juvix.Data.Effect.Files.Base
import Juvix.Data.Effect.Files.Error import Juvix.Data.Effect.Files.Error
import Juvix.Data.Effect.Files.IO import Juvix.Data.Effect.Files.IO
import Juvix.Data.Effect.Files.Pure (runFilesPure) 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 "."))

View File

@ -1,10 +1,12 @@
module Juvix.Data.Effect.Files.Base module Juvix.Data.Effect.Files.Base
( module Juvix.Data.Effect.Files.Base, ( module Juvix.Data.Effect.Files.Base,
module Juvix.Data.Effect.Files.Error, module Juvix.Data.Effect.Files.Error,
module Juvix.Data.Uid,
) )
where where
import Juvix.Data.Effect.Files.Error import Juvix.Data.Effect.Files.Error
import Juvix.Data.Uid
import Juvix.Prelude.Base import Juvix.Prelude.Base
import Path import Path
@ -14,31 +16,23 @@ data RecursorArgs = RecursorArgs
_recFiles :: [Path Rel File] _recFiles :: [Path Rel File]
} }
data Recurse r
= RecurseNever
| RecurseFilter (Path r Dir -> Bool)
makeLenses ''RecursorArgs makeLenses ''RecursorArgs
data Files m a where data Files m a where
ReadFile' :: FilePath -> Files m Text EnsureDir' :: Path Abs Dir -> Files m ()
ReadFileBS' :: FilePath -> Files m ByteString DirectoryExists' :: Path Abs Dir -> Files m Bool
FileExists' :: FilePath -> Files m Bool FileExists' :: Path Abs File -> Files m Bool
EqualPaths' :: FilePath -> FilePath -> Files m (Maybe Bool) GetDirAbsPath :: Path Rel Dir -> Files m (Path Abs Dir)
GetAbsPath :: FilePath -> Files m FilePath ListDirRel :: Path Abs Dir -> Files m ([Path Rel Dir], [Path Rel File])
CanonicalizePath' :: FilePath -> Files m FilePath PathUid :: Path Abs b -> Files m Uid
RegisterStdlib :: FilePath -> Files m () ReadFile' :: Path Abs File -> Files m Text
UpdateStdlib :: FilePath -> Files m () 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 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

View File

@ -5,7 +5,8 @@ import Juvix.Data.Loc
import Juvix.Prelude.Base import Juvix.Prelude.Base
import Juvix.Prelude.Pretty import Juvix.Prelude.Pretty
data FilesErrorCause = StdlibConflict data FilesErrorCause
= StdlibConflict
deriving stock (Show) deriving stock (Show)
data FilesError = FilesError data FilesError = FilesError

View File

@ -5,89 +5,34 @@ module Juvix.Data.Effect.Files.IO
where where
import Data.ByteString qualified as ByteString import Data.ByteString qualified as ByteString
import Data.HashSet qualified as HashSet
import Juvix.Data.Effect.Files.Base import Juvix.Data.Effect.Files.Base
import Juvix.Extra.Stdlib qualified as Stdlib
import Juvix.Prelude.Base 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. runFilesIO ::
-- forall r a.
-- When `p` is not a member of the standard library or no stanard library is Member (Embed IO) r =>
-- 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 ->
Sem (Files ': r) a -> Sem (Files ': r) a ->
Sem r' a Sem (Error FilesError ': r) a
runFilesIO' rootPath = reinterpret3 helper runFilesIO = reinterpret helper
where 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 helper = \case
ReadFile' f -> embed (readFile f) ReadFile' f -> embed (readFile (toFilePath f))
ReadFileBS' f -> embed (ByteString.readFile f) WriteFileBS p bs -> embed (ByteString.writeFile (toFilePath p) bs)
FileExists' f -> embed (doesFileExist f) WriteFile' f txt -> embed (writeFile (toFilePath f) txt)
EqualPaths' f h -> EnsureDir' p -> Path.ensureDir p
embed DirectoryExists' p -> Path.doesDirExist p
( do ReadFileBS' f -> embed (ByteString.readFile (toFilePath f))
f' <- canonicalizePath f FileExists' f -> Path.doesFileExist f
h' <- canonicalizePath h RemoveDirectoryRecursive' d -> removeDirRecur d
return (Just (equalFilePath f' h')) ListDirRel p -> embed @IO (Path.listDirRel p)
) PathUid f -> do
RegisterStdlib stdlibRootPath -> do status <- embed (P.getFileStatus (toFilePath f))
absStdlibRootPath <- embed (makeAbsolute stdlibRootPath) let P.CDev dev = P.deviceID status
fs <- embed (getFilesRecursive absStdlibRootPath) P.CIno fid = P.fileID status
let paths = normalise . makeRelative absStdlibRootPath <$> fs return (Uid (dev, fid))
modify GetDirAbsPath f -> canonicalizePath f
( 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

View File

@ -8,7 +8,7 @@ import Juvix.Prelude.Path
import Prelude qualified import Prelude qualified
data FS = FS data FS = FS
{ _fsRoot :: Path Rel Dir, { _fsRoot :: Path Abs Dir,
_fsNode :: FSNode _fsNode :: FSNode
} }
@ -17,6 +17,13 @@ data FSNode = FSNode
_dirDirs :: HashMap (Path Rel Dir) FSNode _dirDirs :: HashMap (Path Rel Dir) FSNode
} }
emptyFS :: FS
emptyFS =
FS
{ _fsRoot = $(mkAbsDir "/"),
_fsNode = emptyNode
}
emptyNode :: FSNode emptyNode :: FSNode
emptyNode = emptyNode =
FSNode FSNode
@ -27,25 +34,13 @@ emptyNode =
makeLenses ''FS makeLenses ''FS
makeLenses ''FSNode makeLenses ''FSNode
-- | Files should have a common root mkFS :: HashMap (Path Abs File) Text -> FS
mkFS :: HashMap FilePath Text -> FS mkFS tbl = run (execState emptyFS go)
mkFS tbl = case (HashMap.toList (rootNode ^. dirDirs), toList (rootNode ^. dirFiles)) of
([(r, d')], []) -> FS r d'
_ -> impossible
where where
rootNode :: FSNode go :: Sem '[State FS] ()
rootNode = HashMap.foldlWithKey' insertFile emptyNode tbl go = forM_ (HashMap.toList tbl) $ \(p, txt) -> do
insertFile :: FSNode -> FilePath -> Text -> FSNode ensureDirHelper (parent p)
insertFile dir0 fp contents = go (splitPath fp) dir0 writeFileHelper p txt
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)
toTree :: FS -> Tree FilePath toTree :: FS -> Tree FilePath
toTree fs = Node (toFilePath (fs ^. fsRoot)) (go (fs ^. fsNode)) 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 instance Show FS where
show = drawTree . toTree show = drawTree . toTree
runFilesEmpty :: FilePath -> Sem (Files ': r) a -> Sem r a runFilesEmpty :: Sem (Files ': r) a -> Sem r a
runFilesEmpty rootPath = runFilesPure rootPath mempty runFilesEmpty = runFilesPure mempty $(mkAbsDir "/")
runFilesPure :: FilePath -> HashMap FilePath Text -> Sem (Files ': r) a -> Sem r a runFilesPure :: HashMap (Path Abs File) Text -> Path Abs Dir -> Sem (Files ': r) a -> Sem r a
runFilesPure rootPath fs = interpret $ \case runFilesPure ini cwd a = evalState (mkFS ini) (re cwd a)
ReadFile' f -> return (readHelper f)
EqualPaths' {} -> return Nothing re :: Path Abs Dir -> Sem (Files ': r) a -> Sem (State FS ': r) a
FileExists' f -> return (HashMap.member f fs) re cwd = reinterpret $ \case
RegisterStdlib {} -> return () ReadFile' f -> lookupFile' f
UpdateStdlib {} -> return () FileExists' f -> isJust <$> lookupFile f
GetAbsPath f -> return (rootPath </> f) PathUid p -> return (Uid (toFilePath p))
CanonicalizePath' f -> return (normalise (rootPath </> f)) ReadFileBS' f -> encodeUtf8 <$> lookupFile' f
ReadFileBS' f -> return (encodeUtf8 (readHelper 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 where
root :: FS cwd' :: FilePath
root = mkFS fs cwd' = toFilePath cwd
readHelper :: FilePath -> Text
readHelper f = fromMaybe (missingErr root f) (HashMap.lookup f fs)
missingErr :: FS -> FilePath -> a missingErr :: Members '[State FS] r => FilePath -> Sem r a
missingErr root f = missingErr f = do
root <- get @FS
error $ error $
pack $ pack $
"file " "file "
@ -91,37 +93,79 @@ missingErr root f =
<> "\nThe contents of the mocked file system are:\n" <> "\nThe contents of the mocked file system are:\n"
<> Prelude.show root <> Prelude.show root
findDir :: FS -> Path Rel Dir -> FSNode checkRoot :: Members '[State FS] r => Path Abs Dir -> Sem r ()
findDir root p = go (root ^. fsNode) (destructPath p) checkRoot r = do
where root <- gets (^. fsRoot)
go :: FSNode -> [Path Rel Dir] -> FSNode unless True (error ("roots do not match: " <> pack (toFilePath root) <> "\n" <> pack (toFilePath r)))
go d = \case
[] -> d
(h : hs) -> go (HashMap.lookupDefault err h (d ^. dirDirs)) hs
err :: a
err = missingErr root (toFilePath p)
walkDirRel' :: removeDirRecurHelper :: Members '[State FS] r => Path Abs Dir -> Sem r ()
forall m. removeDirRecurHelper p = do
Monad m => checkRoot r
FS -> modify (over fsNode (fromMaybe emptyNode . go dirs))
(RecursorArgs -> m (Path Rel Dir -> Bool)) ->
Maybe (Path Rel Dir) ->
m ()
walkDirRel' root f start = go (root ^. fsRoot) fs0
where where
fs0 :: FSNode (r, dirs) = destructAbsDir p
fs0 = maybe (root ^. fsNode) (findDir root) start go :: [Path Rel Dir] -> FSNode -> Maybe FSNode
go :: Path Rel Dir -> FSNode -> m () go = \case
go cur (FSNode files dirs) = do [] -> const Nothing
w <- f args (d : ds) -> Just . over dirDirs (HashMap.alter helper d)
let dirs' = filter (w . fst) (HashMap.toList dirs) where
forM_ dirs' $ \(d, n) -> go (cur <//> d) n helper :: Maybe FSNode -> Maybe FSNode
where helper = go ds . fromMaybe emptyNode
args :: RecursorArgs
args = ensureDirHelper :: Members '[State FS] r => Path Abs Dir -> Sem r ()
RecursorArgs ensureDirHelper p = do
{ _recCurDir = cur, checkRoot r
_recFiles = HashMap.keys files, modify (over fsNode (go dirs))
_recDirs = HashMap.keys 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)

View File

@ -0,0 +1,10 @@
module Juvix.Data.Processed where
import Juvix.Prelude.Base
data IsProcessed
= Raw
| Processed
deriving stock (Eq, Show)
$(genSingletons [''IsProcessed])

19
src/Juvix/Data/Uid.hs Normal file
View File

@ -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

View File

@ -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.Base
import Juvix.Prelude.Path
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
assetsDir :: Q Exp relToProject :: Path Rel a -> Path Abs a
assetsDir = FE.makeRelativeToProject "assets" >>= FE.embedDir relToProject r = $(projectPath) <//> r
stdlibDir :: Q Exp assetsDir :: [(Path Rel File, ByteString)]
stdlibDir = FE.makeRelativeToProject "juvix-stdlib" >>= FE.embedDir assetsDir = map (first relFile) $(assetsDirQ)
juvixYamlFile :: FilePath -- | Given a relative file from the root of the project, checks that the file
juvixYamlFile = "juvix.yaml" -- exists and returns the absolute path
mkProjFile :: Path Rel File -> Q Exp
juvixBuildDir :: FilePath mkProjFile r = do
juvixBuildDir = ".juvix-build" let p = relToProject r
ensureFile p
juvixStdlibDir :: FilePath lift p
juvixStdlibDir = juvixBuildDir </> "stdlib"
preludePath :: FilePath
preludePath = "Stdlib" </> "Prelude.juvix"

View File

@ -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

View File

@ -1,49 +1,72 @@
module Juvix.Extra.Stdlib where 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.Paths
import Juvix.Extra.Version import Juvix.Extra.Version
import Juvix.Prelude.Base import Juvix.Prelude
type RootPath = FilePath type StdlibRoot = Path Abs Dir
stdlibFiles :: [(FilePath, ByteString)] stdlibFiles :: [(Path Rel File, ByteString)]
stdlibFiles = filter isJuvixFile $(stdlibDir) stdlibFiles = mapMaybe helper $(stdlibDir)
where where
isJuvixFile :: (FilePath, ByteString) -> Bool helper :: (FilePath, ByteString) -> Maybe (Path Rel File, ByteString)
isJuvixFile (fp, _) = takeExtension fp == ".juvix" 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 writeStdlib = do
rootDir <- ask rootDir <- ask
forM_ (first (rootDir </>) <$> stdlibFiles) (uncurry writeJuvixFile) forM_ (first (rootDir <//>) <$> stdlibFiles) (uncurry writeJuvixFile)
where where
writeJuvixFile :: FilePath -> ByteString -> Sem r () writeJuvixFile :: Path Abs File -> ByteString -> Sem r ()
writeJuvixFile p bs = embed (createDirectoryIfMissing True (takeDirectory p) >> BS.writeFile p bs) writeJuvixFile p bs = do
ensureDir' (parent p)
writeFileBS p bs
stdlibVersionFile :: Member (Reader RootPath) r => Sem r FilePath stdlibVersionFile :: Member (Reader StdlibRoot) r => Sem r (Path Abs File)
stdlibVersionFile = (</> ".version") <$> ask stdlibVersionFile = (<//> $(mkRelFile ".version")) <$> ask
writeVersion :: forall r. Members '[Reader RootPath, Embed IO] r => Sem r () writeVersion :: forall r. Members '[Reader StdlibRoot, Files] r => Sem r ()
writeVersion = (embed . flip writeFile versionTag) =<< stdlibVersionFile 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 readVersion = do
vf <- stdlibVersionFile 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 = updateStdlib =
whenM shouldUpdate $ do whenM shouldUpdate $ do
whenM whenM
(embed . doesDirectoryExist =<< ask) (ask @StdlibRoot >>= directoryExists')
(embed . removeDirectoryRecursive =<< ask) (ask @StdlibRoot >>= removeDirectoryRecursive')
writeStdlib writeStdlib
writeVersion writeVersion
where where
shouldUpdate :: Sem r Bool shouldUpdate :: Sem r Bool
shouldUpdate = shouldUpdate =
orM orM
[ not <$> (embed . doesDirectoryExist =<< ask), [ not <$> (ask @StdlibRoot >>= directoryExists'),
(Just versionTag /=) <$> readVersion (Just versionTag /=) <$> readVersion
] ]

View File

@ -2,6 +2,7 @@ module Juvix.Prelude
( module Juvix.Prelude.Base, ( module Juvix.Prelude.Base,
module Juvix.Prelude.Lens, module Juvix.Prelude.Lens,
module Juvix.Prelude.Trace, module Juvix.Prelude.Trace,
module Juvix.Prelude.Path,
module Juvix.Data, module Juvix.Data,
) )
where where
@ -9,4 +10,5 @@ where
import Juvix.Data import Juvix.Data
import Juvix.Prelude.Base import Juvix.Prelude.Base
import Juvix.Prelude.Lens import Juvix.Prelude.Lens
import Juvix.Prelude.Path
import Juvix.Prelude.Trace import Juvix.Prelude.Trace

View File

@ -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

View File

@ -58,11 +58,11 @@ module Juvix.Prelude.Base
module Polysemy.State, module Polysemy.State,
module Language.Haskell.TH.Syntax, module Language.Haskell.TH.Syntax,
module Prettyprinter, module Prettyprinter,
module System.Directory,
module System.Exit, module System.Exit,
module System.FilePath, module System.FilePath,
module System.IO, module System.IO,
module Text.Show, module Text.Show,
module Control.Monad.Catch,
Data, Data,
Text, Text,
pack, pack,
@ -73,12 +73,15 @@ module Juvix.Prelude.Base
HashSet, HashSet,
IsString (..), IsString (..),
Alternative (..), Alternative (..),
MonadIO (..),
) )
where where
import Control.Applicative import Control.Applicative
import Control.Monad.Catch (MonadMask, MonadThrow, throwM)
import Control.Monad.Extra hiding (fail) import Control.Monad.Extra hiding (fail)
import Control.Monad.Fix import Control.Monad.Fix
import Control.Monad.IO.Class (MonadIO (..))
import Data.Bifunctor hiding (first, second) import Data.Bifunctor hiding (first, second)
import Data.Bitraversable import Data.Bitraversable
import Data.Bool import Data.Bool
@ -99,7 +102,7 @@ import Data.Hashable
import Data.Int import Data.Int
import Data.IntMap.Strict (IntMap) import Data.IntMap.Strict (IntMap)
import Data.IntSet (IntSet) 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.Extra qualified as List
import Data.List.NonEmpty qualified as NonEmpty import Data.List.NonEmpty qualified as NonEmpty
import Data.List.NonEmpty.Extra import Data.List.NonEmpty.Extra
@ -141,8 +144,8 @@ import GHC.Real
import GHC.Stack.Types import GHC.Stack.Types
import Language.Haskell.TH.Syntax (Lift) import Language.Haskell.TH.Syntax (Lift)
import Lens.Micro.Platform hiding (both) import Lens.Micro.Platform hiding (both)
import Path (parseAbsDir, toFilePath) import Path
import Path.IO (listDirRecur) import Path.IO qualified as Path
import Polysemy import Polysemy
import Polysemy.Embed import Polysemy.Embed
import Polysemy.Error hiding (fromEither) import Polysemy.Error hiding (fromEither)
@ -153,9 +156,8 @@ import Polysemy.State
import Prettyprinter (Doc, (<+>)) import Prettyprinter (Doc, (<+>))
import Safe.Exact import Safe.Exact
import Safe.Foldable import Safe.Foldable
import System.Directory
import System.Exit import System.Exit
import System.FilePath import System.FilePath (FilePath, dropTrailingPathSeparator, normalise, (<.>), (</>))
import System.IO hiding import System.IO hiding
( appendFile, ( appendFile,
getContents, getContents,
@ -165,12 +167,15 @@ import System.IO hiding
hPutStr, hPutStr,
hPutStrLn, hPutStrLn,
interact, interact,
openBinaryTempFile,
openTempFile,
putStr, putStr,
putStrLn, putStrLn,
readFile, readFile,
readFile', readFile',
writeFile, writeFile,
) )
import System.IO.Error
import Text.Show (Show) import Text.Show (Show)
import Text.Show qualified as Show import Text.Show qualified as Show
@ -198,6 +203,14 @@ toUpperFirst (x : xs) = Char.toUpper x : xs
-- Foldable -- 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 :: (Monoid c, Foldable t) => (a -> c) -> t a -> c
mconcatMap f = List.mconcatMap f . toList mconcatMap f = List.mconcatMap f . toList
@ -346,19 +359,6 @@ fromRightIO' pp = do
fromRightIO :: (e -> Text) -> IO (Either e r) -> IO r fromRightIO :: (e -> Text) -> IO (Either e r) -> IO r
fromRightIO pp = fromRightIO' (putStrLn . pp) 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 -- Misc
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -409,3 +409,9 @@ instance CanonicalProjection a () where
-- | 'project' with type arguments swapped. Useful for type application -- | 'project' with type arguments swapped. Useful for type application
project' :: forall b a. CanonicalProjection a b => a -> b project' :: forall b a. CanonicalProjection a b => a -> b
project' = project project' = project
ensureFile :: (MonadIO m, MonadThrow m) => Path Abs File -> m ()
ensureFile f =
unlessM
(Path.doesFileExist f)
(throwM (mkIOError doesNotExistErrorType "" Nothing (Just (toFilePath f))))

View File

@ -1,28 +1,90 @@
module Juvix.Prelude.Path module Juvix.Prelude.Path
( module Juvix.Prelude.Path, ( module Juvix.Prelude.Path,
module Path, module Path,
module Path.IO,
) )
where where
import Data.List.NonEmpty qualified as NonEmpty
import Juvix.Prelude.Base import Juvix.Prelude.Base
import Path hiding ((</>)) import Juvix.Prelude.Path.OrphanInstances ()
import Path hiding ((<.>), (</>))
import Path qualified 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 <//> infixr 5 <//>
-- | Synonym for Path.</>. Useful to avoid name clashes
(<//>) :: Path b Dir -> Path Rel t -> Path b t (<//>) :: Path b Dir -> Path Rel t -> Path b t
(<//>) = (Path.</>) (<//>) = (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 :: 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 :: 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] absFile :: FilePath -> Path Abs File
destructPath p = map relDir (splitPath (toFilePath p)) absFile r = fromMaybe (error ("not an absolute file path: " <> pack r)) (parseAbsFile r)
destructFilePath :: Path b File -> ([Path Rel Dir], Path Rel File) destructAbsDir :: Path Abs Dir -> (Path Abs Dir, [Path Rel Dir])
destructFilePath p = case nonEmptyUnsnoc (nonEmpty' (splitPath (toFilePath p))) of destructAbsDir d = go d []
(ps, f) -> (fmap relDir (maybe [] toList ps), relFile f) 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"

View File

@ -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

View File

@ -123,3 +123,6 @@ ordinal = \case
11 -> "eleventh" 11 -> "eleventh"
12 -> "twelfth" 12 -> "twelfth"
n -> pretty n <> "th" n -> pretty n <> "th"
itemize :: (Functor f, Foldable f) => f (Doc ann) -> Doc ann
itemize = vsep . fmap ("" <>)

View File

@ -9,19 +9,20 @@ type FailMsg = String
data NegTest = NegTest data NegTest = NegTest
{ _name :: String, { _name :: String,
_relDir :: FilePath, _relDir :: Path Rel Dir,
_file :: FilePath, _file :: Path Rel File,
_checkErr :: ArityCheckerError -> Maybe FailMsg _checkErr :: ArityCheckerError -> Maybe FailMsg
} }
testDescr :: NegTest -> TestDescr testDescr :: NegTest -> TestDescr
testDescr NegTest {..} = testDescr NegTest {..} =
let tRoot = root </> _relDir let tRoot = root <//> _relDir
file' = tRoot <//> _file
in TestDescr in TestDescr
{ _testName = _name, { _testName = _name,
_testRoot = tRoot, _testRoot = tRoot,
_testAssertion = Single $ do _testAssertion = Single $ do
let entryPoint = defaultEntryPoint _file let entryPoint = defaultEntryPoint tRoot file'
result <- runIOEither iniState entryPoint upToInternalArity result <- runIOEither iniState entryPoint upToInternalArity
case mapLeft fromJuvixError result of case mapLeft fromJuvixError result of
Left (Just tyError) -> whenJust (_checkErr tyError) assertFailure Left (Just tyError) -> whenJust (_checkErr tyError) assertFailure
@ -35,8 +36,8 @@ allTests =
"Arity checker negative tests" "Arity checker negative tests"
(map (mkTest . testDescr) tests) (map (mkTest . testDescr) tests)
root :: FilePath root :: Path Abs Dir
root = "tests/negative" root = relToProject $(mkRelDir "tests/negative")
wrongError :: Maybe FailMsg wrongError :: Maybe FailMsg
wrongError = Just "Incorrect error" wrongError = Just "Incorrect error"
@ -45,43 +46,43 @@ tests :: [NegTest]
tests = tests =
[ NegTest [ NegTest
"Too many arguments in expression" "Too many arguments in expression"
"Internal" $(mkRelDir "Internal")
"TooManyArguments.juvix" $(mkRelFile "TooManyArguments.juvix")
$ \case $ \case
ErrTooManyArguments {} -> Nothing ErrTooManyArguments {} -> Nothing
_ -> wrongError, _ -> wrongError,
NegTest NegTest
"Pattern match a function type" "Pattern match a function type"
"Internal" $(mkRelDir "Internal")
"FunctionPattern.juvix" $(mkRelFile "FunctionPattern.juvix")
$ \case $ \case
ErrPatternFunction {} -> Nothing ErrPatternFunction {} -> Nothing
_ -> wrongError, _ -> wrongError,
NegTest NegTest
"Function type (* → *) application" "Function type (* → *) application"
"Internal" $(mkRelDir "Internal")
"FunctionApplied.juvix" $(mkRelFile "FunctionApplied.juvix")
$ \case $ \case
ErrFunctionApplied {} -> Nothing ErrFunctionApplied {} -> Nothing
_ -> wrongError, _ -> wrongError,
NegTest NegTest
"Expected explicit pattern" "Expected explicit pattern"
"Internal" $(mkRelDir "Internal")
"ExpectedExplicitPattern.juvix" $(mkRelFile "ExpectedExplicitPattern.juvix")
$ \case $ \case
ErrWrongPatternIsImplicit {} -> Nothing ErrWrongPatternIsImplicit {} -> Nothing
_ -> wrongError, _ -> wrongError,
NegTest NegTest
"Expected explicit argument" "Expected explicit argument"
"Internal" $(mkRelDir "Internal")
"ExpectedExplicitArgument.juvix" $(mkRelFile "ExpectedExplicitArgument.juvix")
$ \case $ \case
ErrExpectedExplicitArgument {} -> Nothing ErrExpectedExplicitArgument {} -> Nothing
_ -> wrongError, _ -> wrongError,
NegTest NegTest
"Function clause with two many patterns in the lhs" "Function clause with two many patterns in the lhs"
"Internal" $(mkRelDir "Internal")
"LhsTooManyPatterns.juvix" $(mkRelFile "LhsTooManyPatterns.juvix")
$ \case $ \case
ErrLhsTooManyPatterns {} -> Nothing ErrLhsTooManyPatterns {} -> Nothing
_ -> wrongError _ -> wrongError

View File

@ -8,23 +8,22 @@ import Juvix.Compiler.Backend qualified as Backend
import Juvix.Compiler.Backend.C qualified as C import Juvix.Compiler.Backend.C qualified as C
import Juvix.Compiler.Pipeline qualified as Pipeline import Juvix.Compiler.Pipeline qualified as Pipeline
import Runtime.Base qualified as Runtime 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 asmCompileAssertion mainFile expectedFile step = do
step "Parse" step "Parse"
s <- readFile mainFile s <- readFile (toFilePath mainFile)
case runParser mainFile s of case runParser (toFilePath mainFile) s of
Left err -> assertFailure (show err) Left err -> assertFailure (show err)
Right tab -> do Right tab -> do
step "Generate C code" step "Generate C code"
case run $ runError @JuvixError $ Pipeline.asmToMiniC asmOpts tab of case run $ runError @JuvixError $ Pipeline.asmToMiniC asmOpts tab of
Left {} -> assertFailure "code generation failed" Left {} -> assertFailure "code generation failed"
Right C.MiniCResult {..} -> Right C.MiniCResult {..} ->
withTempDir withTempDir'
( \dirPath -> do ( \dirPath -> do
let cFile = dirPath </> takeBaseName mainFile <> ".c" let cFile = dirPath <//> replaceExtension' ".c" (filename mainFile)
TIO.writeFile cFile _resultCCode TIO.writeFile (toFilePath cFile) _resultCCode
Runtime.clangAssertion cFile expectedFile "" step Runtime.clangAssertion cFile expectedFile "" step
) )
where where

View File

@ -6,11 +6,13 @@ import Base
testDescr :: Run.PosTest -> TestDescr testDescr :: Run.PosTest -> TestDescr
testDescr Run.PosTest {..} = testDescr Run.PosTest {..} =
let tRoot = Run.root </> _relDir let tRoot = Run.root <//> _relDir
file' = tRoot <//> _file
expected' = tRoot <//> _expectedFile
in TestDescr in TestDescr
{ _testName = _name, { _testName = _name,
_testRoot = tRoot, _testRoot = tRoot,
_testAssertion = Steps $ asmCompileAssertion _file _expectedFile _testAssertion = Steps $ asmCompileAssertion file' expected'
} }
allTests :: TestTree allTests :: TestTree

View File

@ -10,9 +10,8 @@ import Juvix.Compiler.Asm.Pretty
import Juvix.Compiler.Asm.Transformation.Validate import Juvix.Compiler.Asm.Transformation.Validate
import Juvix.Compiler.Asm.Translation.FromSource import Juvix.Compiler.Asm.Translation.FromSource
import Juvix.Data.PPOutput 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 asmRunAssertion mainFile expectedFile trans testTrans step = do
step "Parse" step "Parse"
r <- parseFile mainFile r <- parseFile mainFile
@ -29,10 +28,10 @@ asmRunAssertion mainFile expectedFile trans testTrans step = do
Nothing -> Nothing ->
case tab ^. infoMainFunction of case tab ^. infoMainFunction of
Just sym -> do Just sym -> do
withTempDir withTempDir'
( \dirPath -> do ( \dirPath -> do
let outputFile = dirPath </> "out.out" let outputFile = dirPath <//> $(mkRelFile "out.out")
hout <- openFile outputFile WriteMode hout <- openFile (toFilePath outputFile) WriteMode
step "Interpret" step "Interpret"
r' <- doRun hout tab (getFunInfo tab sym) r' <- doRun hout tab (getFunInfo tab sym)
case r' of case r' of
@ -44,14 +43,14 @@ asmRunAssertion mainFile expectedFile trans testTrans step = do
ValVoid -> return () ValVoid -> return ()
_ -> hPutStrLn hout (ppPrint tab value') _ -> hPutStrLn hout (ppPrint tab value')
hClose hout hClose hout
actualOutput <- TIO.readFile outputFile actualOutput <- TIO.readFile (toFilePath outputFile)
step "Compare expected and actual program output" step "Compare expected and actual program output"
expected <- TIO.readFile expectedFile expected <- TIO.readFile (toFilePath expectedFile)
assertEqDiff ("Check: RUN output = " <> expectedFile) actualOutput expected assertEqDiff ("Check: RUN output = " <> toFilePath expectedFile) actualOutput expected
) )
Nothing -> assertFailure "no 'main' function" Nothing -> assertFailure "no 'main' function"
asmRunErrorAssertion :: FilePath -> (String -> IO ()) -> Assertion asmRunErrorAssertion :: Path Abs File -> (String -> IO ()) -> Assertion
asmRunErrorAssertion mainFile step = do asmRunErrorAssertion mainFile step = do
step "Parse" step "Parse"
r <- parseFile mainFile r <- parseFile mainFile
@ -64,10 +63,10 @@ asmRunErrorAssertion mainFile step = do
Nothing -> Nothing ->
case tab ^. infoMainFunction of case tab ^. infoMainFunction of
Just sym -> do Just sym -> do
withTempDir withTempDir'
( \dirPath -> do ( \dirPath -> do
let outputFile = dirPath </> "out.out" let outputFile = dirPath <//> $(mkRelFile "out.out")
hout <- openFile outputFile WriteMode hout <- openFile (toFilePath outputFile) WriteMode
step "Interpret" step "Interpret"
r' <- doRun hout tab (getFunInfo tab sym) r' <- doRun hout tab (getFunInfo tab sym)
hClose hout hClose hout
@ -77,10 +76,11 @@ asmRunErrorAssertion mainFile step = do
) )
Nothing -> assertBool "" True Nothing -> assertBool "" True
parseFile :: FilePath -> IO (Either ParserError InfoTable) parseFile :: Path Abs File -> IO (Either ParserError InfoTable)
parseFile f = do parseFile f = do
s <- readFile f let f' = toFilePath f
return $ runParser f s s <- readFile f'
return $ runParser f' s
doRun :: doRun ::
Handle -> Handle ->

View File

@ -5,20 +5,21 @@ import Base
data NegTest = NegTest data NegTest = NegTest
{ _name :: String, { _name :: String,
_relDir :: FilePath, _relDir :: Path Rel Dir,
_file :: FilePath _file :: Path Rel File
} }
root :: FilePath root :: Path Abs Dir
root = "tests/Asm/negative" root = relToProject $(mkRelDir "tests/Asm/negative")
testDescr :: NegTest -> TestDescr testDescr :: NegTest -> TestDescr
testDescr NegTest {..} = testDescr NegTest {..} =
let tRoot = root </> _relDir let tRoot = root <//> _relDir
file' = tRoot <//> _file
in TestDescr in TestDescr
{ _testName = _name, { _testName = _name,
_testRoot = tRoot, _testRoot = tRoot,
_testAssertion = Steps $ asmRunErrorAssertion _file _testAssertion = Steps $ asmRunErrorAssertion file'
} }
allTests :: TestTree allTests :: TestTree
@ -31,14 +32,14 @@ tests :: [NegTest]
tests = tests =
[ NegTest [ NegTest
"Division by zero" "Division by zero"
"." $(mkRelDir ".")
"test001.jva", $(mkRelFile "test001.jva"),
NegTest NegTest
"Invalid memory access" "Invalid memory access"
"." $(mkRelDir ".")
"test002.jva", $(mkRelFile "test002.jva"),
NegTest NegTest
"No matching case branch" "No matching case branch"
"." $(mkRelDir ".")
"test003.jva" $(mkRelFile "test003.jva")
] ]

View File

@ -5,21 +5,23 @@ import Base
data PosTest = PosTest data PosTest = PosTest
{ _name :: String, { _name :: String,
_relDir :: FilePath, _relDir :: Path Rel Dir,
_file :: FilePath, _file :: Path Rel File,
_expectedFile :: FilePath _expectedFile :: Path Rel File
} }
root :: FilePath root :: Path Abs Dir
root = "tests/Asm/positive" root = relToProject $(mkRelDir "tests/Asm/positive")
testDescr :: PosTest -> TestDescr testDescr :: PosTest -> TestDescr
testDescr PosTest {..} = testDescr PosTest {..} =
let tRoot = root </> _relDir let tRoot = root <//> _relDir
file' = tRoot <//> _file
expected' = tRoot <//> _expectedFile
in TestDescr in TestDescr
{ _testName = _name, { _testName = _name,
_testRoot = tRoot, _testRoot = tRoot,
_testAssertion = Steps $ asmRunAssertion _file _expectedFile return (const (return ())) _testAssertion = Steps $ asmRunAssertion file' expected' return (const (return ()))
} }
allTests :: TestTree allTests :: TestTree
@ -32,182 +34,182 @@ tests :: [PosTest]
tests = tests =
[ PosTest [ PosTest
"Arithmetic opcodes" "Arithmetic opcodes"
"." $(mkRelDir ".")
"test001.jva" $(mkRelFile "test001.jva")
"out/test001.out", $(mkRelFile "out/test001.out"),
PosTest PosTest
"Direct call" "Direct call"
"." $(mkRelDir ".")
"test002.jva" $(mkRelFile "test002.jva")
"out/test002.out", $(mkRelFile "out/test002.out"),
PosTest PosTest
"Indirect call" "Indirect call"
"." $(mkRelDir ".")
"test003.jva" $(mkRelFile "test003.jva")
"out/test003.out", $(mkRelFile "out/test003.out"),
PosTest PosTest
"Tail calls" "Tail calls"
"." $(mkRelDir ".")
"test004.jva" $(mkRelFile "test004.jva")
"out/test004.out", $(mkRelFile "out/test004.out"),
PosTest PosTest
"Tracing IO" "Tracing IO"
"." $(mkRelDir ".")
"test005.jva" $(mkRelFile "test005.jva")
"out/test005.out", $(mkRelFile "out/test005.out"),
PosTest PosTest
"IO builtins" "IO builtins"
"." $(mkRelDir ".")
"test006.jva" $(mkRelFile "test006.jva")
"out/test006.out", $(mkRelFile "out/test006.out"),
PosTest PosTest
"Higher-order functions" "Higher-order functions"
"." $(mkRelDir ".")
"test007.jva" $(mkRelFile "test007.jva")
"out/test007.out", $(mkRelFile "out/test007.out"),
PosTest PosTest
"Branch" "Branch"
"." $(mkRelDir ".")
"test008.jva" $(mkRelFile "test008.jva")
"out/test008.out", $(mkRelFile "out/test008.out"),
PosTest PosTest
"Case" "Case"
"." $(mkRelDir ".")
"test009.jva" $(mkRelFile "test009.jva")
"out/test009.out", $(mkRelFile "out/test009.out"),
PosTest PosTest
"Recursion" "Recursion"
"." $(mkRelDir ".")
"test010.jva" $(mkRelFile "test010.jva")
"out/test010.out", $(mkRelFile "out/test010.out"),
PosTest PosTest
"Tail recursion" "Tail recursion"
"." $(mkRelDir ".")
"test011.jva" $(mkRelFile "test011.jva")
"out/test011.out", $(mkRelFile "out/test011.out"),
PosTest PosTest
"Temporary stack" "Temporary stack"
"." $(mkRelDir ".")
"test012.jva" $(mkRelFile "test012.jva")
"out/test012.out", $(mkRelFile "out/test012.out"),
PosTest PosTest
"Fibonacci numbers in linear time" "Fibonacci numbers in linear time"
"." $(mkRelDir ".")
"test013.jva" $(mkRelFile "test013.jva")
"out/test013.out", $(mkRelFile "out/test013.out"),
PosTest PosTest
"Trees" "Trees"
"." $(mkRelDir ".")
"test014.jva" $(mkRelFile "test014.jva")
"out/test014.out", $(mkRelFile "out/test014.out"),
PosTest PosTest
"Functions returning functions" "Functions returning functions"
"." $(mkRelDir ".")
"test015.jva" $(mkRelFile "test015.jva")
"out/test015.out", $(mkRelFile "out/test015.out"),
PosTest PosTest
"Arithmetic" "Arithmetic"
"." $(mkRelDir ".")
"test016.jva" $(mkRelFile "test016.jva")
"out/test016.out", $(mkRelFile "out/test016.out"),
PosTest PosTest
"Closures as arguments" "Closures as arguments"
"." $(mkRelDir ".")
"test017.jva" $(mkRelFile "test017.jva")
"out/test017.out", $(mkRelFile "out/test017.out"),
PosTest PosTest
"Closure extension" "Closure extension"
"." $(mkRelDir ".")
"test018.jva" $(mkRelFile "test018.jva")
"out/test018.out", $(mkRelFile "out/test018.out"),
PosTest PosTest
"Recursion through higher-order functions" "Recursion through higher-order functions"
"." $(mkRelDir ".")
"test019.jva" $(mkRelFile "test019.jva")
"out/test019.out", $(mkRelFile "out/test019.out"),
PosTest PosTest
"Tail recursion through higher-order functions" "Tail recursion through higher-order functions"
"." $(mkRelDir ".")
"test020.jva" $(mkRelFile "test020.jva")
"out/test020.out", $(mkRelFile "out/test020.out"),
PosTest PosTest
"Higher-order functions and recursion" "Higher-order functions and recursion"
"." $(mkRelDir ".")
"test021.jva" $(mkRelFile "test021.jva")
"out/test021.out", $(mkRelFile "out/test021.out"),
PosTest PosTest
"Self-application" "Self-application"
"." $(mkRelDir ".")
"test022.jva" $(mkRelFile "test022.jva")
"out/test022.out", $(mkRelFile "out/test022.out"),
PosTest PosTest
"McCarthy's 91 function" "McCarthy's 91 function"
"." $(mkRelDir ".")
"test023.jva" $(mkRelFile "test023.jva")
"out/test023.out", $(mkRelFile "out/test023.out"),
PosTest PosTest
"Higher-order recursive functions" "Higher-order recursive functions"
"." $(mkRelDir ".")
"test024.jva" $(mkRelFile "test024.jva")
"out/test024.out", $(mkRelFile "out/test024.out"),
PosTest PosTest
"Dynamic closure extension" "Dynamic closure extension"
"." $(mkRelDir ".")
"test025.jva" $(mkRelFile "test025.jva")
"out/test025.out", $(mkRelFile "out/test025.out"),
PosTest PosTest
"Currying & uncurrying" "Currying & uncurrying"
"." $(mkRelDir ".")
"test026.jva" $(mkRelFile "test026.jva")
"out/test026.out", $(mkRelFile "out/test026.out"),
PosTest PosTest
"Fast exponentiation" "Fast exponentiation"
"." $(mkRelDir ".")
"test027.jva" $(mkRelFile "test027.jva")
"out/test027.out", $(mkRelFile "out/test027.out"),
PosTest PosTest
"Lists" "Lists"
"." $(mkRelDir ".")
"test028.jva" $(mkRelFile "test028.jva")
"out/test028.out", $(mkRelFile "out/test028.out"),
PosTest PosTest
"Structural equality" "Structural equality"
"." $(mkRelDir ".")
"test029.jva" $(mkRelFile "test029.jva")
"out/test029.out", $(mkRelFile "out/test029.out"),
PosTest PosTest
"Mutual recursion" "Mutual recursion"
"." $(mkRelDir ".")
"test030.jva" $(mkRelFile "test030.jva")
"out/test030.out", $(mkRelFile "out/test030.out"),
PosTest PosTest
"Temporary stack with branching" "Temporary stack with branching"
"." $(mkRelDir ".")
"test031.jva" $(mkRelFile "test031.jva")
"out/test031.out", $(mkRelFile "out/test031.out"),
PosTest PosTest
"Church numerals" "Church numerals"
"." $(mkRelDir ".")
"test032.jva" $(mkRelFile "test032.jva")
"out/test032.out", $(mkRelFile "out/test032.out"),
PosTest PosTest
"Ackermann function" "Ackermann function"
"." $(mkRelDir ".")
"test033.jva" $(mkRelFile "test033.jva")
"out/test033.out", $(mkRelFile "out/test033.out"),
PosTest PosTest
"Higher-order function composition" "Higher-order function composition"
"." $(mkRelDir ".")
"test034.jva" $(mkRelFile "test034.jva")
"out/test034.out", $(mkRelFile "out/test034.out"),
PosTest PosTest
"Nested lists" "Nested lists"
"." $(mkRelDir ".")
"test035.jva" $(mkRelFile "test035.jva")
"out/test035.out", $(mkRelFile "out/test035.out"),
PosTest PosTest
"Streams without memoization" "Streams without memoization"
"." $(mkRelDir ".")
"test036.jva" $(mkRelFile "test036.jva")
"out/test036.out" $(mkRelFile "out/test036.out")
] ]

View File

@ -15,15 +15,17 @@ data Test = Test
fromTest :: Test -> TestTree fromTest :: Test -> TestTree
fromTest = mkTest . toTestDescr fromTest = mkTest . toTestDescr
troot :: FilePath troot :: Path Abs Dir
troot = "tests/Asm/positive/" troot = relToProject $(mkRelDir "tests/Asm/positive/")
toTestDescr :: Test -> TestDescr toTestDescr :: Test -> TestDescr
toTestDescr Test {..} = toTestDescr Test {..} =
let Run.PosTest {..} = _testEval let Run.PosTest {..} = _testEval
tRoot = troot </> _relDir tRoot = troot <//> _relDir
file' = tRoot <//> _file
expected' = tRoot <//> _expectedFile
in TestDescr in TestDescr
{ _testName = _name, { _testName = _name,
_testRoot = tRoot, _testRoot = tRoot,
_testAssertion = Steps $ asmRunAssertion _file _expectedFile _testTransformation _testAssertion _testAssertion = Steps $ asmRunAssertion file' expected' _testTransformation _testAssertion
} }

View File

@ -5,7 +5,7 @@ import Juvix.Compiler.Asm.Data.InfoTable
import Juvix.Compiler.Asm.Transformation.Validate import Juvix.Compiler.Asm.Transformation.Validate
import Juvix.Compiler.Asm.Translation.FromSource import Juvix.Compiler.Asm.Translation.FromSource
asmValidateErrorAssertion :: FilePath -> (String -> IO ()) -> Assertion asmValidateErrorAssertion :: Path Abs File -> (String -> IO ()) -> Assertion
asmValidateErrorAssertion mainFile step = do asmValidateErrorAssertion mainFile step = do
step "Parse" step "Parse"
r <- parseFile mainFile r <- parseFile mainFile
@ -17,7 +17,7 @@ asmValidateErrorAssertion mainFile step = do
Just _ -> assertBool "" True Just _ -> assertBool "" True
Nothing -> assertFailure "no error" Nothing -> assertFailure "no error"
parseFile :: FilePath -> IO (Either ParserError InfoTable) parseFile :: Path Abs File -> IO (Either ParserError InfoTable)
parseFile f = do parseFile f = do
s <- readFile f s <- readFile (toFilePath f)
return $ runParser f s return $ runParser (toFilePath f) s

View File

@ -5,20 +5,21 @@ import Base
data NegTest = NegTest data NegTest = NegTest
{ _name :: String, { _name :: String,
_relDir :: FilePath, _relDir :: Path Rel Dir,
_file :: FilePath _file :: Path Rel File
} }
root :: FilePath root :: Path Abs Dir
root = "tests/Asm/negative" root = relToProject $(mkRelDir "tests/Asm/negative")
testDescr :: NegTest -> TestDescr testDescr :: NegTest -> TestDescr
testDescr NegTest {..} = testDescr NegTest {..} =
let tRoot = root </> _relDir let tRoot = root <//> _relDir
file' = tRoot <//> _file
in TestDescr in TestDescr
{ _testName = _name, { _testName = _name,
_testRoot = tRoot, _testRoot = tRoot,
_testAssertion = Steps $ asmValidateErrorAssertion _file _testAssertion = Steps $ asmValidateErrorAssertion file'
} }
allTests :: TestTree allTests :: TestTree
@ -31,42 +32,42 @@ tests :: [NegTest]
tests = tests =
[ NegTest [ NegTest
"Wrong stack height on exit" "Wrong stack height on exit"
"." $(mkRelDir ".")
"vtest001.jva", $(mkRelFile "vtest001.jva"),
NegTest NegTest
"Arithmetic type mismatch" "Arithmetic type mismatch"
"." $(mkRelDir ".")
"vtest002.jva", $(mkRelFile "vtest002.jva"),
NegTest NegTest
"Function type mismatch" "Function type mismatch"
"." $(mkRelDir ".")
"vtest003.jva", $(mkRelFile "vtest003.jva"),
NegTest NegTest
"Not enough function arguments" "Not enough function arguments"
"." $(mkRelDir ".")
"vtest004.jva", $(mkRelFile "vtest004.jva"),
NegTest NegTest
"Missing return" "Missing return"
"." $(mkRelDir ".")
"vtest005.jva", $(mkRelFile "vtest005.jva"),
NegTest NegTest
"Branch stack height mismatch" "Branch stack height mismatch"
"." $(mkRelDir ".")
"vtest006.jva", $(mkRelFile "vtest006.jva"),
NegTest NegTest
"Branch type mismatch" "Branch type mismatch"
"." $(mkRelDir ".")
"vtest007.jva", $(mkRelFile "vtest007.jva"),
NegTest NegTest
"Case stack height mismatch" "Case stack height mismatch"
"." $(mkRelDir ".")
"vtest008.jva", $(mkRelFile "vtest008.jva"),
NegTest NegTest
"Case type mismatch" "Case type mismatch"
"." $(mkRelDir ".")
"vtest009.jva", $(mkRelFile "vtest009.jva"),
NegTest NegTest
"Value stack type mismatch" "Value stack type mismatch"
"." $(mkRelDir ".")
"vtest010.jva" $(mkRelFile "vtest010.jva")
] ]

Some files were not shown because too many files have changed in this diff Show More