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:
parent
445376e338
commit
af63c36574
40
app/App.hs
40
app/App.hs
@ -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
|
||||||
|
@ -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 =>
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
@ -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 ::
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
22
app/Commands/Dev/DisplayRoot/Options.hs
Normal file
22
app/Commands/Dev/DisplayRoot/Options.hs
Normal 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 {..}
|
@ -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)]))
|
||||||
|
@ -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"
|
||||||
)
|
)
|
||||||
|
@ -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)
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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) ->
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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)
|
||||||
|
@ -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"
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
@ -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)
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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 {..}
|
||||||
|
11
app/Main.hs
11
app/Main.hs
@ -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)
|
|
||||||
|
34
app/Root.hs
34
app/Root.hs
@ -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)
|
||||||
|
@ -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
|
11
package.yaml
11
package.yaml
@ -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.*
|
||||||
|
@ -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
|
||||||
|
@ -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))
|
||||||
|
@ -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)
|
||||||
|
@ -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]
|
||||||
|
@ -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]
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
@ -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
|
@ -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))
|
@ -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)]
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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)
|
||||||
|
@ -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!"
|
||||||
|
@ -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
|
||||||
|
13
src/Juvix/Compiler/Pipeline/Artifacts.hs
Normal file
13
src/Juvix/Compiler/Pipeline/Artifacts.hs
Normal 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
|
@ -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
|
||||||
|
}
|
||||||
|
@ -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
|
||||||
|
65
src/Juvix/Compiler/Pipeline/Package/Dependency.hs
Normal file
65
src/Juvix/Compiler/Pipeline/Package/Dependency.hs
Normal 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'
|
@ -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
|
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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 "."))
|
||||||
|
@ -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
|
|
||||||
|
@ -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
|
||||||
|
@ -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
|
|
||||||
|
@ -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)
|
||||||
|
10
src/Juvix/Data/Processed.hs
Normal file
10
src/Juvix/Data/Processed.hs
Normal 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
19
src/Juvix/Data/Uid.hs
Normal 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
|
@ -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"
|
|
||||||
|
35
src/Juvix/Extra/Paths/Base.hs
Normal file
35
src/Juvix/Extra/Paths/Base.hs
Normal 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
|
@ -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
|
||||||
]
|
]
|
||||||
|
@ -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
|
||||||
|
14
src/Juvix/Prelude/Aeson.hs
Normal file
14
src/Juvix/Prelude/Aeson.hs
Normal 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
|
@ -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))))
|
||||||
|
@ -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"
|
||||||
|
65
src/Juvix/Prelude/Path/OrphanInstances.hs
Normal file
65
src/Juvix/Prelude/Path/OrphanInstances.hs
Normal 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
|
@ -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 ("• " <>)
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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 ->
|
||||||
|
@ -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")
|
||||||
]
|
]
|
||||||
|
@ -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")
|
||||||
]
|
]
|
||||||
|
@ -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
|
||||||
}
|
}
|
||||||
|
@ -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
|
||||||
|
@ -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
Loading…
Reference in New Issue
Block a user