anoma/juvix
1
1
Fork 0
mirror of https://github.com/anoma/juvix.git synced 2024-10-05 20:47:36 +03:00
Code Issues Projects Releases Wiki Activity

Run test suite in parallel (#2507)

Browse Source 
## Overview

This PR makes the compiler pipeline thread-safe so that the test suite
can be run in parallel.

This is achieved by:
* Removing use of `{get, set, with}CurrentDir` functions.
* Adding locking around shared file resources like the the
global-project and internal build directory.

NB: **Locking is disabled for the main compiler target**, as it is
single threaded they are not required.

## Run test suite in parallel

To run the test suite in parallel you must add `--ta '+RTS -N -RTS'` to
your stack test arguments. For example:

```
stack test --fast --ta '+RTS -N -RTS'
```

The `-N` instructs the Haskell runtime to choose the number of threads
to use based on how many processors there are on your machine. You can
use `-Nn` to see the number of threads to `n`.

These flags are already [set in the
Makefile](e6dca22cfd/Makefile (L26))
when you or CI uses `stack test`.

## Locking

The Haskell package
[filelock](https://hackage.haskell.org/package/filelock) is used for
locking. File locks are used instead of MVars because Juvix code does
not control when new threads are created, they are created by the test
suite. This means that MVars created by Juvix code will have no effect,
because they are created independently on each test-suite thread.
Additionally the resources we're locking live on the filesystem and so
can be conveniently tagged by path.

### FileLock

The filelock library is wrapped in a FileLock effect:


e6dca22cfd/src/Juvix/Data/Effect/FileLock/Base.hs (L6-L8)

There is an [IO
interpreter](e6dca22cfd/src/Juvix/Data/Effect/FileLock/IO.hs (L8))
that uses filelock and an [no-op
interpreter](e6dca22cfd/src/Juvix/Data/Effect/FileLock/Permissive.hs (L7))
that just runs actions unconditionally.

### TaggedLock

To make the file locks simpler to use a TaggedLock effect is introduced:


e6dca22cfd/src/Juvix/Data/Effect/TaggedLock/Base.hs (L5-L11)

And convenience function:


e6dca22cfd/src/Juvix/Data/Effect/TaggedLock.hs (L28)

This allows an action to be locked, tagged by a directory that may or
may not exist. For example in the following code, an action is performed
on a directory `root` that may delete the directory before repopulating
the files. So the lockfile cannot be stored in the `root` itself.


e6dca22cfd/src/Juvix/Extra/Files.hs (L55-L60)

## Pipeline

As noted above, we only use locking in the test suite. The main app
target pipeline is single threaded and so locking is unnecessary. So the
interpretation of locks is parameterised so that locking can be disabled
e6dca22cfd/src/Juvix/Compiler/Pipeline/Run.hs (L64)
This commit is contained in:
Paul Cadman 2023-11-16 15:19:52 +00:00 committed by GitHub
parent 8616370fb2
commit 2f4a3f809b
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
63 changed files with 395 additions and 152 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -23,7 +23,7 @@ METAFILES:=README.md \
LICENSE.md
STACKFLAGS?=--jobs $(THREADS)
STACKTESTFLAGS?=--ta --hide-successes --ta --ansi-tricks=false
STACKTESTFLAGS?=--ta --hide-successes --ta --ansi-tricks=false --ta "+RTS -N -RTS"
SMOKEFLAGS?=--color --diff=git
STACK?=stack

3
app/Commands/Init.hs
View File

@ -6,6 +6,7 @@ import Data.Text qualified as Text
import Data.Versions
import Juvix.Compiler.Pipeline.Package
import Juvix.Data.Effect.Fail.Extra qualified as Fail
import Juvix.Data.Effect.TaggedLock
import Juvix.Extra.Paths
import Juvix.Prelude
import Juvix.Prelude.Pretty
@ -60,7 +61,7 @@ checkNotInProject =
checkPackage :: forall r. (Members '[Embed IO] r) => Sem r ()
checkPackage = do
cwd <- getCurrentDir
ep <- runError @JuvixError (loadPackageFileIO cwd DefaultBuildDir)
ep <- runError @JuvixError (runTaggedLockPermissive (loadPackageFileIO cwd DefaultBuildDir))
case ep of
Left {} -> do
say "Package.juvix is invalid. Please raise an issue at https://github.com/anoma/juvix/issues"

2
app/Commands/Repl.hs
View File

@ -39,6 +39,7 @@ import Juvix.Compiler.Pipeline.Setup (entrySetup)
import Juvix.Data.CodeAnn (Ann)
import Juvix.Data.Effect.Git
import Juvix.Data.Effect.Process
import Juvix.Data.Effect.TaggedLock
import Juvix.Data.Error.GenericError qualified as Error
import Juvix.Data.NameKind
import Juvix.Extra.Paths qualified as P
@ -152,6 +153,7 @@ loadDefaultPrelude = whenJustM defaultPreludeEntryPoint $ \e -> do
. runFilesIO
. runError @JuvixError
. runReader e
. runTaggedLockPermissive
. runLogIO
. runProcessIO
. runError @GitProcessError

3
app/Main.hs
View File

@ -7,6 +7,7 @@ import CommonOptions
import Data.String.Interpolate (i)
import GlobalOptions
import Juvix.Compiler.Pipeline.Root
import Juvix.Data.Effect.TaggedLock
import TopCommand
import TopCommand.Options
@ -18,7 +19,7 @@ main = do
mbuildDir <- mapM (prepathToAbsDir invokeDir) (_runAppIOArgsGlobalOptions ^? globalBuildDir . _Just . pathPath)
mainFile <- topCommandInputPath cli
mapM_ checkMainFile mainFile
_runAppIOArgsRoot <- findRootAndChangeDir (containingDir <$> mainFile) mbuildDir invokeDir
_runAppIOArgsRoot <- findRootAndChangeDir LockModePermissive (containingDir <$> mainFile) mbuildDir invokeDir
runFinal
. resourceToIOFinal
. embedToFinal @IO

3
package.yaml
View File

@ -54,6 +54,7 @@ dependencies:
- exceptions == 0.10.*
- extra == 1.7.*
- file-embed == 0.0.*
- filelock == 0.1.*
- filepath == 1.4.*
- githash == 0.1.*
- hashable == 1.4.*
@ -174,6 +175,8 @@ tests:
- juvix
verbatim:
default-language: GHC2021
ghc-options:
- -threaded
benchmarks:
juvix-bench:

25
src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs
View File

@ -25,6 +25,7 @@ import Juvix.Compiler.Pipeline.Lockfile
import Juvix.Compiler.Pipeline.Package
import Juvix.Compiler.Pipeline.Package.Loader.EvalEff
import Juvix.Data.Effect.Git
import Juvix.Data.Effect.TaggedLock
import Juvix.Extra.Paths
import Juvix.Extra.Stdlib (ensureStdlib)
import Juvix.Prelude
@ -43,7 +44,7 @@ mkPackage mpackageEntry _packageRoot = do
mkPackageInfo ::
forall r.
(Members '[Files, Error JuvixError, Reader ResolverEnv, Error DependencyError, GitClone] r) =>
(Members '[TaggedLock, Files, Error JuvixError, Reader ResolverEnv, Error DependencyError, GitClone] r) =>
Maybe EntryPoint ->
Path Abs Dir ->
Package ->
@ -162,7 +163,7 @@ resolveDependency i = case i ^. packageDepdendencyInfoDependency of
registerDependencies' ::
forall r.
(Members '[Reader EntryPoint, State ResolverState, Reader ResolverEnv, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) =>
(Members '[TaggedLock, Reader EntryPoint, State ResolverState, Reader ResolverEnv, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) =>
DependenciesConfig ->
Sem r ()
registerDependencies' conf = do
@ -186,7 +187,7 @@ registerDependencies' conf = do
addRootDependency ::
forall r.
(Members '[State ResolverState, Reader ResolverEnv, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) =>
(Members '[TaggedLock, State ResolverState, Reader ResolverEnv, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) =>
DependenciesConfig ->
EntryPoint ->
Path Abs Dir ->
@ -207,7 +208,7 @@ addRootDependency conf e root = do
addDependency ::
forall r.
(Members '[State ResolverState, Reader ResolverEnv, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) =>
(Members '[TaggedLock, State ResolverState, Reader ResolverEnv, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) =>
Maybe EntryPoint ->
PackageDependencyInfo ->
Sem r LockfileDependency
@ -224,7 +225,7 @@ addDependency me d = do
addDependency' ::
forall r.
(Members '[State ResolverState, Reader ResolverEnv, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) =>
(Members '[TaggedLock, State ResolverState, Reader ResolverEnv, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) =>
Package ->
Maybe EntryPoint ->
ResolvedDependency ->
@ -314,7 +315,7 @@ expectedPath' actualPath m = do
re ::
forall r a.
(Members '[Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) =>
(Members '[TaggedLock, Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) =>
Sem (PathResolver ': r) a ->
Sem (Reader ResolverEnv ': State ResolverState ': r) a
re = reinterpret2H helper
@ -337,13 +338,13 @@ re = reinterpret2H helper
Right (r, _) -> r
raise (evalPathResolver' st' root' (a' x'))
evalPathResolver' :: (Members '[Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) => ResolverState -> Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r a
evalPathResolver' :: (Members '[TaggedLock, Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) => ResolverState -> Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r a
evalPathResolver' st root = fmap snd . runPathResolver' st root
runPathResolver :: (Members '[Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) => Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a)
runPathResolver :: (Members '[TaggedLock, Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) => Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a)
runPathResolver = runPathResolver' iniResolverState
runPathResolver' :: (Members '[Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) => ResolverState -> Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a)
runPathResolver' :: (Members '[TaggedLock, Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) => ResolverState -> Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a)
runPathResolver' st root x = do
e <- ask
let _envSingleFile :: Maybe (Path Abs File)
@ -359,15 +360,15 @@ runPathResolver' st root x = do
}
runState st (runReader env (re x))
runPathResolverPipe' :: (Members '[Files, Reader EntryPoint, Error DependencyError, GitClone, Error JuvixError, EvalFileEff] r) => ResolverState -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a)
runPathResolverPipe' :: (Members '[TaggedLock, Files, Reader EntryPoint, Error DependencyError, GitClone, Error JuvixError, EvalFileEff] r) => ResolverState -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a)
runPathResolverPipe' iniState a = do
r <- asks (^. entryPointResolverRoot)
runPathResolver' iniState r a
runPathResolverPipe :: (Members '[Files, Reader EntryPoint, Error DependencyError, GitClone, Error JuvixError, EvalFileEff] r) => Sem (PathResolver ': r) a -> Sem r (ResolverState, a)
runPathResolverPipe :: (Members '[TaggedLock, Files, Reader EntryPoint, Error DependencyError, GitClone, Error JuvixError, EvalFileEff] r) => Sem (PathResolver ': r) a -> Sem r (ResolverState, a)
runPathResolverPipe a = do
r <- asks (^. entryPointResolverRoot)
runPathResolver r a
evalPathResolverPipe :: (Members '[Files, Reader EntryPoint, Error DependencyError, GitClone, Error JuvixError, EvalFileEff] r) => Sem (PathResolver ': r) a -> Sem r a
evalPathResolverPipe :: (Members '[TaggedLock, Files, Reader EntryPoint, Error DependencyError, GitClone, Error JuvixError, EvalFileEff] r) => Sem (PathResolver ': r) a -> Sem r a
evalPathResolverPipe = fmap snd . runPathResolverPipe

5
src/Juvix/Compiler/Pipeline.hs
View File

@ -37,11 +37,12 @@ import Juvix.Compiler.Reg.Data.InfoTable qualified as Reg
import Juvix.Compiler.Reg.Translation.FromAsm qualified as Reg
import Juvix.Data.Effect.Git
import Juvix.Data.Effect.Process
import Juvix.Data.Effect.TaggedLock
import Juvix.Prelude
type PipelineEff = '[PathResolver, EvalFileEff, Error PackageLoaderError, Error DependencyError, GitClone, Error GitProcessError, Process, Log, Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError, HighlightBuilder, Internet, Embed IO]
type PipelineEff = '[PathResolver, EvalFileEff, Error PackageLoaderError, Error DependencyError, GitClone, Error GitProcessError, Process, Log, TaggedLock, Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError, HighlightBuilder, Internet, Embed IO, Resource, Final IO]
type TopPipelineEff = '[PathResolver, EvalFileEff, Error PackageLoaderError, Error DependencyError, GitClone, Error GitProcessError, Process, Log, Reader EntryPoint, Files, NameIdGen, Builtins, State Artifacts, Error JuvixError, HighlightBuilder, Embed IO]
type TopPipelineEff = '[PathResolver, EvalFileEff, Error PackageLoaderError, Error DependencyError, GitClone, Error GitProcessError, Process, Log, TaggedLock, Reader EntryPoint, Files, NameIdGen, Builtins, State Artifacts, Error JuvixError, HighlightBuilder, Embed IO, Resource, Final IO]
--------------------------------------------------------------------------------
-- Workflows

5
src/Juvix/Compiler/Pipeline/Artifacts/PathResolver.hs
View File

@ -6,10 +6,11 @@ import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Compiler.Pipeline.Package.Loader.EvalEff
import Juvix.Compiler.Pipeline.Package.Loader.PathResolver
import Juvix.Data.Effect.Git
import Juvix.Data.Effect.TaggedLock
import Juvix.Prelude
runPathResolverArtifacts :: (Members '[Files, Reader EntryPoint, State Artifacts, Error DependencyError, GitClone, Error JuvixError, EvalFileEff] r) => Sem (PathResolver ': r) a -> Sem r a
runPathResolverArtifacts :: (Members '[TaggedLock, Files, Reader EntryPoint, State Artifacts, Error DependencyError, GitClone, Error JuvixError, EvalFileEff] r) => Sem (PathResolver ': r) a -> Sem r a
runPathResolverArtifacts = runStateLikeArtifacts runPathResolverPipe' artifactResolver
runPackagePathResolverArtifacts :: (Members '[Files, Reader EntryPoint, State Artifacts, Error DependencyError, GitClone, Error JuvixError, EvalFileEff] r) => Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r a
runPackagePathResolverArtifacts :: (Members '[TaggedLock, Files, Reader EntryPoint, State Artifacts, Error DependencyError, GitClone, Error JuvixError, EvalFileEff] r) => Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r a
runPackagePathResolverArtifacts root = runStateLikeArtifacts (runPackagePathResolver'' root) artifactResolver

21
src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs
View File

@ -2,16 +2,21 @@ module Juvix.Compiler.Pipeline.EntryPoint.IO where
import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Compiler.Pipeline.Root
import Juvix.Data.Effect.TaggedLock
import Juvix.Prelude
defaultEntryPointCwdIO :: Path Abs File -> IO EntryPoint
defaultEntryPointCwdIO mainFile = do
cwd <- getCurrentDir
root <- findRootAndChangeDir (Just (parent mainFile)) Nothing cwd
defaultEntryPointIO :: Path Abs Dir -> Path Abs File -> IO EntryPoint
defaultEntryPointIO = defaultEntryPointIO' LockModePermissive
defaultEntryPointIO' :: LockMode -> Path Abs Dir -> Path Abs File -> IO EntryPoint
defaultEntryPointIO' lockMode cwd mainFile = do
root <- findRootAndChangeDir lockMode (Just (parent mainFile)) Nothing cwd
return (defaultEntryPoint root mainFile)
defaultEntryPointNoFileCwdIO :: IO EntryPoint
defaultEntryPointNoFileCwdIO = do
cwd <- getCurrentDir
root <- findRootAndChangeDir Nothing Nothing cwd
defaultEntryPointNoFileIO :: Path Abs Dir -> IO EntryPoint
defaultEntryPointNoFileIO = defaultEntryPointNoFileIO' LockModePermissive
defaultEntryPointNoFileIO' :: LockMode -> Path Abs Dir -> IO EntryPoint
defaultEntryPointNoFileIO' lockMode cwd = do
root <- findRootAndChangeDir lockMode Nothing Nothing cwd
return (defaultEntryPointNoFile root)

25
src/Juvix/Compiler/Pipeline/Package.hs
View File

@ -18,6 +18,7 @@ import Juvix.Compiler.Pipeline.Package.Loader
import Juvix.Compiler.Pipeline.Package.Loader.Error
import Juvix.Compiler.Pipeline.Package.Loader.EvalEff
import Juvix.Compiler.Pipeline.Package.Loader.EvalEff.IO
import Juvix.Data.Effect.TaggedLock
import Juvix.Extra.Paths
import Juvix.Prelude
@ -124,35 +125,41 @@ readPackageFile root buildDir f = mapError (JuvixError @PackageLoaderError) $ do
checkNoDuplicateDepNames f (pkg ^. packageDependencies)
return (pkg {_packageLockfile = mLockfile})
loadPackageFileIO :: (Members '[Error JuvixError, Embed IO] r) => Path Abs Dir -> BuildDir -> Sem r Package
loadPackageFileIO :: (Members '[TaggedLock, Error JuvixError, Embed IO] r) => Path Abs Dir -> BuildDir -> Sem r Package
loadPackageFileIO root buildDir =
runFilesIO
. mapError (JuvixError @PackageLoaderError)
. runEvalFileEffIO
$ loadPackage buildDir (mkPackagePath root)
readPackageIO :: Path Abs Dir -> BuildDir -> IO Package
readPackageIO root buildDir =
runM
readPackageIO :: LockMode -> Path Abs Dir -> BuildDir -> IO Package
readPackageIO lockMode root buildDir =
runFinal
. resourceToIOFinal
. embedToFinal @IO
. runFilesIO
. runErrorIO' @JuvixError
. mapError (JuvixError @PackageLoaderError)
. runTaggedLock lockMode
. runEvalFileEffIO
$ readPackage root buildDir
readGlobalPackageIO :: IO Package
readGlobalPackageIO =
runM
readGlobalPackageIO :: LockMode -> IO Package
readGlobalPackageIO lockMode =
runFinal
. resourceToIOFinal
. embedToFinal @IO
. runFilesIO
. runErrorIO' @JuvixError
. mapError (JuvixError @PackageLoaderError)
. runTaggedLock lockMode
. runEvalFileEffIO
$ readGlobalPackage
readGlobalPackage :: (Members '[Error JuvixError, EvalFileEff, Files] r) => Sem r Package
readGlobalPackage :: (Members '[TaggedLock, Error JuvixError, EvalFileEff, Files] r) => Sem r Package
readGlobalPackage = do
packagePath <- globalPackageJuvix
unlessM (fileExists' packagePath) writeGlobalPackage
withTaggedLockDir (parent packagePath) (unlessM (fileExists' packagePath) writeGlobalPackage)
readPackage (parent packagePath) DefaultBuildDir
writeGlobalPackage :: (Members '[Files] r) => Sem r ()

5
src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs
View File

@ -18,6 +18,7 @@ import Juvix.Compiler.Pipeline.Package.Loader.EvalEff
import Juvix.Compiler.Pipeline.Package.Loader.PathResolver
import Juvix.Data.Effect.Git
import Juvix.Data.Effect.Process
import Juvix.Data.Effect.TaggedLock
data LoaderResource = LoaderResource
{ _loaderResourceResult :: CoreResult,
@ -26,7 +27,7 @@ data LoaderResource = LoaderResource
makeLenses ''LoaderResource
runEvalFileEffIO :: forall r a. (Members '[Embed IO, Error PackageLoaderError] r) => Sem (EvalFileEff ': r) a -> Sem r a
runEvalFileEffIO :: forall r a. (Members '[TaggedLock, Embed IO, Error PackageLoaderError] r) => Sem (EvalFileEff ': r) a -> Sem r a
runEvalFileEffIO = interpretScopedAs allocator handler
where
allocator :: Path Abs File -> Sem r LoaderResource
@ -114,7 +115,7 @@ runEvalFileEffIO = interpretScopedAs allocator handler
Just l -> l ^. intervalFile == f
Nothing -> False
loadPackage' :: (Members '[Embed IO, Error PackageLoaderError] r) => Path Abs File -> Sem r CoreResult
loadPackage' :: (Members '[TaggedLock, Embed IO, Error PackageLoaderError] r) => Path Abs File -> Sem r CoreResult
loadPackage' packagePath = do
( mapError
( \e ->

7
src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs
View File

@ -7,13 +7,14 @@ import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Data
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Paths
import Juvix.Compiler.Core.Language
import Juvix.Data.Effect.TaggedLock
import Juvix.Extra.PackageFiles
import Juvix.Extra.Paths
import Juvix.Extra.Stdlib
-- | A PackageResolver interpreter intended to be used to load a Package file.
-- It aggregates files at `rootPath` and files from the global package stdlib.
runPackagePathResolver :: forall r a. (Members '[Files] r) => Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r a
runPackagePathResolver :: forall r a. (Members '[TaggedLock, Files] r) => Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r a
runPackagePathResolver rootPath sem = do
globalStdlib <- juvixStdlibDir . rootBuildDir <$> globalRoot
globalPackageDir <- globalPackageDescriptionRoot
@ -43,10 +44,10 @@ runPackagePathResolver rootPath sem = do
| relPath == packageFilePath = Just rootPath
| otherwise = Nothing
runPackagePathResolver' :: (Members '[Files] r) => Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a)
runPackagePathResolver' :: (Members '[TaggedLock, Files] r) => Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a)
runPackagePathResolver' root eff = do
res <- runPackagePathResolver root eff
return (iniResolverState, res)
runPackagePathResolver'' :: (Members '[Files] r) => Path Abs Dir -> ResolverState -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a)
runPackagePathResolver'' :: (Members '[TaggedLock, Files] r) => Path Abs Dir -> ResolverState -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a)
runPackagePathResolver'' root _ eff = runPackagePathResolver' root eff

2
src/Juvix/Compiler/Pipeline/Repl.hs
View File

@ -20,6 +20,7 @@ import Juvix.Compiler.Pipeline.Package.Loader.EvalEff.IO
import Juvix.Data.Effect.Git.Process
import Juvix.Data.Effect.Git.Process.Error
import Juvix.Data.Effect.Process (runProcessIO)
import Juvix.Data.Effect.TaggedLock
import Juvix.Prelude
arityCheckExpression ::
@ -196,6 +197,7 @@ compileReplInputIO fp txt = do
hasInternet <- not <$> asks (^. entryPointOffline)
runError
. evalInternet hasInternet
. runTaggedLockPermissive
. runLogIO
. runFilesIO
. mapError (JuvixError @GitProcessError)

13
src/Juvix/Compiler/Pipeline/Root.hs
View File

@ -7,16 +7,17 @@ where
import Control.Exception qualified as IO
import Juvix.Compiler.Pipeline.Package
import Juvix.Compiler.Pipeline.Root.Base
import Juvix.Data.Effect.TaggedLock
import Juvix.Extra.Paths qualified as Paths
import Juvix.Prelude
findRootAndChangeDir ::
LockMode ->
Maybe (Path Abs Dir) ->
Maybe (Path Abs Dir) ->
Path Abs Dir ->
IO Root
findRootAndChangeDir minputFileDir mbuildDir _rootInvokeDir = do
whenJust minputFileDir setCurrentDir
findRootAndChangeDir lockMode minputFileDir mbuildDir _rootInvokeDir = do
r <- IO.try go
case r of
Left (err :: IO.SomeException) -> do
@ -30,8 +31,8 @@ findRootAndChangeDir minputFileDir mbuildDir _rootInvokeDir = do
findPackageFile :: IO (Maybe (Path Abs File))
findPackageFile = do
cwd <- getCurrentDir
let findPackageFile' = findFile (possiblePaths cwd)
let cwd = fromMaybe _rootInvokeDir minputFileDir
findPackageFile' = findFile (possiblePaths cwd)
yamlFile <- findPackageFile' Paths.juvixYamlFile
pFile <- findPackageFile' Paths.packageFilePath
return (pFile <|> yamlFile)
@ -41,7 +42,7 @@ findRootAndChangeDir minputFileDir mbuildDir _rootInvokeDir = do
l <- findPackageFile
case l of
Nothing -> do
_rootPackage <- readGlobalPackageIO
_rootPackage <- readGlobalPackageIO lockMode
_rootRootDir <- runM (runFilesIO globalRoot)
let _rootPackageGlobal = True
_rootBuildDir = getBuildDir mbuildDir
@ -50,7 +51,7 @@ findRootAndChangeDir minputFileDir mbuildDir _rootInvokeDir = do
let _rootRootDir = parent yamlPath
_rootPackageGlobal = False
_rootBuildDir = getBuildDir mbuildDir
_rootPackage <- readPackageIO _rootRootDir _rootBuildDir
_rootPackage <- readPackageIO lockMode _rootRootDir _rootBuildDir
return Root {..}
getBuildDir :: Maybe (Path Abs Dir) -> BuildDir

46
src/Juvix/Compiler/Pipeline/Run.hs
View File

@ -25,26 +25,38 @@ import Juvix.Compiler.Pipeline.Package.Loader.EvalEff.IO
import Juvix.Compiler.Pipeline.Package.Loader.PathResolver
import Juvix.Data.Effect.Git
import Juvix.Data.Effect.Process
import Juvix.Data.Effect.TaggedLock
import Juvix.Prelude
-- | It returns `ResolverState` so that we can retrieve the `juvix.yaml` files,
-- which we require for `Scope` tests.
runIOEither :: forall a. EntryPoint -> Sem PipelineEff a -> IO (Either JuvixError (ResolverState, a))
runIOEither entry = fmap snd . runIOEitherHelper entry
runIOEither = runIOEither' LockModePermissive
runIOEither' :: forall a. LockMode -> EntryPoint -> Sem PipelineEff a -> IO (Either JuvixError (ResolverState, a))
runIOEither' lockMode entry = fmap snd . runIOEitherHelper' lockMode entry
runIOEitherTermination :: forall a. EntryPoint -> Sem (Termination ': PipelineEff) a -> IO (Either JuvixError (ResolverState, a))
runIOEitherTermination entry = fmap snd . runIOEitherHelper entry . evalTermination iniTerminationState
runIOEitherTermination = runIOEitherTermination' LockModePermissive
runIOEitherTermination' :: forall a. LockMode -> EntryPoint -> Sem (Termination ': PipelineEff) a -> IO (Either JuvixError (ResolverState, a))
runIOEitherTermination' lockMode entry = fmap snd . runIOEitherHelper' lockMode entry . evalTermination iniTerminationState
runPipelineHighlight :: forall a. EntryPoint -> Sem PipelineEff a -> IO HighlightInput
runPipelineHighlight entry = fmap fst . runIOEitherHelper entry
runIOEitherHelper :: forall a. EntryPoint -> Sem PipelineEff a -> IO (HighlightInput, (Either JuvixError (ResolverState, a)))
runIOEitherHelper entry = do
runIOEitherHelper = runIOEitherHelper' LockModePermissive
runIOEitherHelper' :: forall a. LockMode -> EntryPoint -> Sem PipelineEff a -> IO (HighlightInput, (Either JuvixError (ResolverState, a)))
runIOEitherHelper' lockMode entry = do
let hasInternet = not (entry ^. entryPointOffline)
runPathResolver'
| mainIsPackageFile entry = runPackagePathResolver' (entry ^. entryPointResolverRoot)
| otherwise = runPathResolverPipe
runM
runFinal
. resourceToIOFinal
. embedToFinal @IO
. evalInternet hasInternet
. runHighlightBuilder
. runJuvixError
@ -52,6 +64,7 @@ runIOEitherHelper entry = do
. evalTopNameIdGen
. runFilesIO
. runReader entry
. runTaggedLock lockMode
. runLogIO
. runProcessIO
. mapError (JuvixError @GitProcessError)
@ -66,6 +79,14 @@ mainIsPackageFile entry = case entry ^? entryPointModulePaths . _head of
Just p -> p == mkPackagePath (entry ^. entryPointResolverRoot)
Nothing -> False
runIOLockMode :: LockMode -> GenericOptions -> EntryPoint -> Sem PipelineEff a -> IO (ResolverState, a)
runIOLockMode lockMode opts entry = runIOEither' lockMode entry >=> mayThrow
where
mayThrow :: Either JuvixError r -> IO r
mayThrow = \case
Left err -> runM . runReader opts $ printErrorAnsiSafe err >> embed exitFailure
Right r -> return r
runIO :: GenericOptions -> EntryPoint -> Sem PipelineEff a -> IO (ResolverState, a)
runIO opts entry = runIOEither entry >=> mayThrow
where
@ -74,8 +95,8 @@ runIO opts entry = runIOEither entry >=> mayThrow
Left err -> runM . runReader opts $ printErrorAnsiSafe err >> embed exitFailure
Right r -> return r
runIO' :: EntryPoint -> Sem PipelineEff a -> IO (ResolverState, a)
runIO' = runIO defaultGenericOptions
runIOExclusive :: EntryPoint -> Sem PipelineEff a -> IO (ResolverState, a)
runIOExclusive = runIOLockMode LockModeExclusive defaultGenericOptions
corePipelineIO' :: EntryPoint -> IO Artifacts
corePipelineIO' = corePipelineIO defaultGenericOptions
@ -91,13 +112,21 @@ corePipelineIO opts entry = corePipelineIOEither entry >>= mayThrow
corePipelineIOEither ::
EntryPoint ->
IO (Either JuvixError Artifacts)
corePipelineIOEither entry = do
corePipelineIOEither = corePipelineIOEither' LockModePermissive
corePipelineIOEither' ::
LockMode ->
EntryPoint ->
IO (Either JuvixError Artifacts)
corePipelineIOEither' lockMode entry = do
let hasInternet = not (entry ^. entryPointOffline)
runPathResolver'
| mainIsPackageFile entry = runPackagePathResolverArtifacts (entry ^. entryPointResolverRoot)
| otherwise = runPathResolverArtifacts
eith <-
runM
runFinal
. resourceToIOFinal
. embedToFinal @IO
. evalInternet hasInternet
. ignoreHighlightBuilder
. runError
@ -106,6 +135,7 @@ corePipelineIOEither entry = do
. runNameIdGenArtifacts
. runFilesIO
. runReader entry
. runTaggedLock lockMode
. runLogIO
. mapError (JuvixError @GitProcessError)
. runProcessIO

10
src/Juvix/Data/Effect/FileLock.hs Normal file
View File

@ -0,0 +1,10 @@
module Juvix.Data.Effect.FileLock
( module Juvix.Data.Effect.FileLock.Base,
module Juvix.Data.Effect.FileLock.IO,
module Juvix.Data.Effect.FileLock.Permissive,
)
where
import Juvix.Data.Effect.FileLock.Base
import Juvix.Data.Effect.FileLock.IO
import Juvix.Data.Effect.FileLock.Permissive

9
src/Juvix/Data/Effect/FileLock/Base.hs Normal file
View File

@ -0,0 +1,9 @@
module Juvix.Data.Effect.FileLock.Base where
import Juvix.Prelude
-- | An effect for wrapping an action in file lock
data FileLock m a where
WithFileLock' :: Path Abs File -> m a -> FileLock m a
makeSem ''FileLock

10
src/Juvix/Data/Effect/FileLock/IO.hs Normal file
View File

@ -0,0 +1,10 @@
module Juvix.Data.Effect.FileLock.IO where
import Juvix.Data.Effect.FileLock.Base
import Juvix.Prelude
import System.FileLock hiding (FileLock)
-- | Interpret `FileLock` using `System.FileLock`
runFileLockIO :: (Members '[Resource, Embed IO] r) => Sem (FileLock ': r) a -> Sem r a
runFileLockIO = interpretH $ \case
WithFileLock' p ma -> bracket (embed $ lockFile (toFilePath p) Exclusive) (embed . unlockFile) (const (runTSimple ma))

9
src/Juvix/Data/Effect/FileLock/Permissive.hs Normal file
View File

@ -0,0 +1,9 @@
module Juvix.Data.Effect.FileLock.Permissive where
import Juvix.Data.Effect.FileLock.Base
import Juvix.Prelude
-- | Interpret `FileLock` by executing all actions unconditionally
runFileLockPermissive :: Sem (FileLock ': r) a -> Sem r a
runFileLockPermissive = interpretH $ \case
WithFileLock' _ ma -> runTSimple ma

1
src/Juvix/Data/Effect/Files/Base.hs
View File

@ -44,5 +44,6 @@ data Files m a where
JuvixConfigDir :: Files m (Path Abs Dir)
CanonicalDir :: Path Abs Dir -> Prepath Dir -> Files m (Path Abs Dir)
NormalizeDir :: Path b Dir -> Files m (Path Abs Dir)
NormalizeFile :: Path b File -> Files m (Path Abs File)
makeSem ''Files

1
src/Juvix/Data/Effect/Files/IO.hs
View File

@ -50,6 +50,7 @@ runFilesIO = interpret helper
JuvixConfigDir -> juvixConfigDirIO
CanonicalDir root d -> prepathToAbsDir root d
NormalizeDir p -> canonicalizePath p
NormalizeFile b -> canonicalizePath b
juvixConfigDirIO :: IO (Path Abs Dir)
juvixConfigDirIO = (<//> versionDir) . absDir <$> getUserConfigDir "juvix"

1
src/Juvix/Data/Effect/Files/Pure.hs
View File

@ -86,6 +86,7 @@ re cwd = reinterpret $ \case
JuvixConfigDir -> return juvixConfigDirPure
CanonicalDir root d -> return (canonicalDirPure root d)
NormalizeDir p -> return (absDir (cwd' </> toFilePath p))
NormalizeFile p -> return (absFile (cwd' </> toFilePath p))
where
cwd' :: FilePath
cwd' = toFilePath cwd

22
src/Juvix/Data/Effect/Git/Process.hs
View File

@ -4,6 +4,7 @@ import Data.Text qualified as T
import Juvix.Data.Effect.Git.Base
import Juvix.Data.Effect.Git.Process.Error
import Juvix.Data.Effect.Process
import Juvix.Data.Effect.TaggedLock
import Juvix.Prelude
import Polysemy.Opaque
@ -62,15 +63,15 @@ gitHeadRef :: (Members '[Process, Error GitProcessError, Reader CloneEnv] r) =>
gitHeadRef = gitNormalizeRef "HEAD"
-- | Checkout the clone at a particular ref
gitCheckout :: (Members '[Process, Error GitProcessError, Reader CloneEnv] r) => Text -> Sem r ()
gitCheckout ref = void (runGitCmdInDir ["checkout", ref])
gitCheckout :: (Members '[TaggedLock, Process, Error GitProcessError, Reader CloneEnv] r) => Text -> Sem r ()
gitCheckout ref = withTaggedLockDir' (void (runGitCmdInDir ["checkout", ref]))
-- | Fetch in the clone
gitFetch :: (Members '[Process, Error GitProcessError, Reader CloneEnv, Internet] r) => Sem r ()
gitFetch :: (Members '[TaggedLock, Process, Error GitProcessError, Reader CloneEnv, Internet] r) => Sem r ()
gitFetch = whenHasInternet gitFetchOnline
gitFetchOnline :: (Members '[Reader CloneEnv, Error GitProcessError, Process, Online] r) => Sem r ()
gitFetchOnline = void (runGitCmdInDir ["fetch"])
gitFetchOnline :: (Members '[TaggedLock, Reader CloneEnv, Error GitProcessError, Process, Online] r) => Sem r ()
gitFetchOnline = withTaggedLockDir' (void (runGitCmdInDir ["fetch"]))
gitCloneOnline :: (Members '[Log, Error GitProcessError, Process, Online, Reader CloneEnv] r) => Text -> Sem r ()
gitCloneOnline url = do
@ -81,10 +82,10 @@ gitCloneOnline url = do
cloneGitRepo :: (Members '[Log, Files, Process, Error GitProcessError, Reader CloneEnv, Internet] r) => Text -> Sem r ()
cloneGitRepo = whenHasInternet . gitCloneOnline
initGitRepo :: (Members '[Log, Files, Process, Error GitProcessError, Reader CloneEnv, Internet] r) => Text -> Sem r (Path Abs Dir)
initGitRepo :: (Members '[TaggedLock, Log, Files, Process, Error GitProcessError, Reader CloneEnv, Internet] r) => Text -> Sem r (Path Abs Dir)
initGitRepo url = do
p <- asks (^. cloneEnvDir)
unlessM (directoryExists' p) (cloneGitRepo url)
withTaggedLockDir' (unlessM (directoryExists' p) (cloneGitRepo url))
return p
handleNotACloneError :: (Member (Error GitProcessError) r, Monad m) => (GitError -> m x) -> Tactical e m r x -> Tactical e m r x
@ -97,9 +98,14 @@ handleNormalizeRefError errorHandler ref eff = catch @GitProcessError eff $ \cas
GitCmdError GitCmdErrorDetails {_gitCmdErrorDetailsExitCode = ExitFailure 128} -> runTSimple (return (NoSuchRef ref)) >>= bindTSimple errorHandler
e -> throw e
withTaggedLockDir' :: (Members '[TaggedLock, Reader CloneEnv] r) => Sem r a -> Sem r a
withTaggedLockDir' ma = do
p <- asks (^. cloneEnvDir)
withTaggedLockDir p ma
runGitProcess ::
forall r a.
(Members '[Log, Files, Process, Error GitProcessError, Internet] r) =>
(Members '[TaggedLock, Log, Files, Process, Error GitProcessError, Internet] r) =>
Sem (Scoped CloneArgs Git ': r) a ->
Sem r a
runGitProcess = interpretScopedH allocator handler

39
src/Juvix/Data/Effect/TaggedLock.hs Normal file
View File

@ -0,0 +1,39 @@
module Juvix.Data.Effect.TaggedLock
( module Juvix.Data.Effect.TaggedLock,
module Juvix.Data.Effect.TaggedLock.Base,
module Juvix.Data.Effect.TaggedLock.Permissive,
module Juvix.Data.Effect.TaggedLock.IO,
)
where
import Juvix.Data.Effect.TaggedLock.Base
import Juvix.Data.Effect.TaggedLock.IO
import Juvix.Data.Effect.TaggedLock.Permissive
import Juvix.Prelude
-- | A variant of `withTaggedLock` that accepts an absolute directory as a tag.
--
-- The absolute path does not need to exist in the filesystem.
--
-- Example:
--
-- @
-- runFinal
-- . resourceToIOFinal
-- . embedToFinal @IO
-- . runFilesIO
-- . runTaggedLockIO
-- $ withTaggedLockDir $(mkAbsDir "/a/b/c") (embed (putStrLn "Hello" >> hFlush stdout))
-- @
withTaggedLockDir :: (Member TaggedLock r) => Path Abs Dir -> Sem r a -> Sem r a
withTaggedLockDir d = do
let lockFile = $(mkRelFile ".lock")
p = maybe lockFile (<//> lockFile) (dropDrive d)
withTaggedLock p
data LockMode = LockModePermissive | LockModeExclusive
runTaggedLock :: (Members '[Resource, Embed IO] r) => LockMode -> Sem (TaggedLock ': r) a -> Sem r a
runTaggedLock = \case
LockModePermissive -> runTaggedLockPermissive
LockModeExclusive -> runTaggedLockIO

12
src/Juvix/Data/Effect/TaggedLock/Base.hs Normal file
View File

@ -0,0 +1,12 @@
module Juvix.Data.Effect.TaggedLock.Base where
import Juvix.Prelude
-- | An effect that wraps an action with a lock that is tagged with a relative
-- path.
--
-- The relative path does not need to exist in the filesystem.
data TaggedLock m a where
WithTaggedLock :: Path Rel File -> m a -> TaggedLock m a
makeSem ''TaggedLock

21
src/Juvix/Data/Effect/TaggedLock/IO.hs Normal file
View File

@ -0,0 +1,21 @@
module Juvix.Data.Effect.TaggedLock.IO where
import Juvix.Data.Effect.FileLock
import Juvix.Data.Effect.TaggedLock.Base
import Juvix.Prelude
-- | Interpret `TaggedLock` using `FileLock`.
--
-- When multiple processes or threads call `withTaggedLock` with the same tag,
-- then only one of them can perform the action at a time.
runTaggedLockIO :: forall r a. (Members '[Resource, Embed IO] r) => Sem (TaggedLock ': r) a -> Sem r a
runTaggedLockIO sem = do
rootLockPath <- (<//> $(mkRelDir "juvix-file-locks")) <$> getTempDir
runFileLockIO (runFilesIO (go rootLockPath sem))
where
go :: Path Abs Dir -> Sem (TaggedLock ': r) a -> Sem (Files ': FileLock ': r) a
go r = reinterpret2H $ \case
WithTaggedLock t ma -> do
p <- normalizeFile (r <//> t)
ensureDir' (parent p)
withFileLock' p (runTSimple ma)

8
src/Juvix/Data/Effect/TaggedLock/Permissive.hs Normal file
View File

@ -0,0 +1,8 @@
module Juvix.Data.Effect.TaggedLock.Permissive where
import Juvix.Data.Effect.TaggedLock.Base
import Juvix.Prelude
runTaggedLockPermissive :: Sem (TaggedLock ': r) a -> Sem r a
runTaggedLockPermissive = interpretH $ \case
WithTaggedLock _ ma -> runTSimple ma

21
src/Juvix/Extra/Files.hs
View File

@ -1,6 +1,7 @@
module Juvix.Extra.Files where
import Juvix.Data.Effect.Files
import Juvix.Data.Effect.TaggedLock
import Juvix.Extra.Paths
import Juvix.Extra.Version
import Juvix.Prelude
@ -38,23 +39,27 @@ versionFile :: (Member (Reader OutputRoot) r) => Sem r (Path Abs File)
versionFile = (<//> $(mkRelFile ".version")) <$> ask
writeVersion :: forall r. (Members '[Reader OutputRoot, Files] r) => Sem r ()
writeVersion = versionFile >>= flip writeFile' versionTag
writeVersion = do
vf <- versionFile
ensureDir' (parent vf)
writeFile' vf versionTag
readVersion :: (Members '[Reader OutputRoot, Files] r) => Sem r (Maybe Text)
readVersion = do
vf <- versionFile
whenMaybeM (fileExists' vf) (readFile' vf)
updateFiles :: forall r. (Members '[Reader OutputRoot, Files] r) => Sem r () -> Sem r ()
updateFiles action =
whenM shouldUpdate $ do
updateFiles :: (Members '[TaggedLock, Reader OutputRoot, Files] r) => (forall r0. (Members '[Files, Reader OutputRoot] r0) => Sem r0 ()) -> Sem r ()
updateFiles action = do
root <- ask @OutputRoot
withTaggedLockDir root . whenM shouldUpdate $ do
whenM
(ask @OutputRoot >>= directoryExists')
(ask @OutputRoot >>= removeDirectoryRecursive')
action
(directoryExists' root)
(removeDirectoryRecursive' root)
writeVersion
action
where
shouldUpdate :: Sem r Bool
shouldUpdate :: (Members '[Files, Reader OutputRoot] r) => Sem r Bool
shouldUpdate =
orM
[ not <$> (ask @OutputRoot >>= directoryExists'),

3
src/Juvix/Extra/PackageFiles.hs
View File

@ -1,6 +1,7 @@
module Juvix.Extra.PackageFiles where
import Juvix.Data.Effect.Files
import Juvix.Data.Effect.TaggedLock
import Juvix.Extra.Files
import Juvix.Extra.Paths
import Juvix.Prelude
@ -11,5 +12,5 @@ packageFiles = juvixFiles $(packageDescriptionDirContents)
writePackageFiles :: forall r. (Members '[Reader OutputRoot, Files] r) => Sem r ()
writePackageFiles = writeFiles packageFiles
updatePackageFiles :: (Members '[Reader OutputRoot, Files] r) => Sem r ()
updatePackageFiles :: (Members '[TaggedLock, Reader OutputRoot, Files] r) => Sem r ()
updatePackageFiles = updateFiles writePackageFiles

5
src/Juvix/Extra/Stdlib.hs
View File

@ -2,6 +2,7 @@ module Juvix.Extra.Stdlib where
import Juvix.Compiler.Pipeline.Package.Dependency
import Juvix.Data.Effect.Files
import Juvix.Data.Effect.TaggedLock
import Juvix.Extra.Files
import Juvix.Extra.Paths
import Juvix.Prelude
@ -9,7 +10,7 @@ import Juvix.Prelude
stdlibFiles :: [(Path Rel File, ByteString)]
stdlibFiles = juvixFiles $(stdlibDir)
ensureStdlib :: (Members '[Files] r) => Path Abs Dir -> Path Abs Dir -> [Dependency] -> Sem r ()
ensureStdlib :: (Members '[TaggedLock, Files] r) => Path Abs Dir -> Path Abs Dir -> [Dependency] -> Sem r ()
ensureStdlib rootDir buildDir deps =
whenJustM (packageStdlib rootDir buildDir deps) $ \stdlibRoot ->
runReader stdlibRoot updateStdlib
@ -35,5 +36,5 @@ packageStdlib rootDir buildDir = firstJustM isStdLib
writeStdlib :: forall r. (Members '[Reader OutputRoot, Files] r) => Sem r ()
writeStdlib = writeFiles stdlibFiles
updateStdlib :: (Members '[Reader OutputRoot, Files] r) => Sem r ()
updateStdlib :: (Members '[TaggedLock, Reader OutputRoot, Files] r) => Sem r ()
updateStdlib = updateFiles writeStdlib

2
src/Juvix/Prelude/Base.hs
View File

@ -163,7 +163,7 @@ import GHC.Stack.Types
import Language.Haskell.TH.Syntax (Lift)
import Lens.Micro.Platform
import Path
import Path.IO qualified as Path
import Path.IO qualified as Path hiding (getCurrentDir, setCurrentDir, withCurrentDir)
import Polysemy
import Polysemy.Embed
import Polysemy.Error hiding (fromEither)

18
src/Juvix/Prelude/Path.hs
View File

@ -14,6 +14,7 @@ import Path hiding ((<.>), (</>))
import Path qualified
import Path.IO hiding (listDirRel, walkDirRel)
import Path.Internal
import System.FilePath qualified as FilePath
data FileOrDir
@ -122,3 +123,20 @@ withTempDir' = withSystemTempDir "tmp"
-- | 'pure True' if the file exists and is executable, 'pure False' otherwise
isExecutable :: (MonadIO m) => Path b File -> m Bool
isExecutable f = doesFileExist f &&^ (executable <$> getPermissions f)
-- | Split an absolute path into a drive and, perhaps, a path. On POSIX, @/@ is
-- a drive.
-- Remove when we upgrade to path-0.9.5
splitDrive :: Path Abs t -> (Path Abs Dir, Maybe (Path Rel t))
splitDrive (Path fp) =
let (d, rest) = FilePath.splitDrive fp
mRest = if null rest then Nothing else Just (Path rest)
in (Path d, mRest)
-- | Drop the drive from an absolute path. May result in 'Nothing' if the path
-- is just a drive.
--
-- > dropDrive x = snd (splitDrive x)
-- Remove when we upgrade to path-0.9.5
dropDrive :: Path Abs t -> Maybe (Path Rel t)
dropDrive = snd . splitDrive

6
src/Juvix/Prelude/Prepath.hs
View File

@ -111,9 +111,9 @@ prepathToAbsDir :: Path Abs Dir -> Prepath Dir -> IO (Path Abs Dir)
prepathToAbsDir root = fmap absDir . prepathToFilePath root
prepathToFilePath :: Path Abs Dir -> Prepath d -> IO FilePath
prepathToFilePath root pre =
withCurrentDir root $
expandPrepath pre >>= System.canonicalizePath
prepathToFilePath root pre = do
expandedPre <- expandPrepath pre
System.canonicalizePath (toFilePath root </> expandedPre)
fromPreFileOrDir :: Path Abs Dir -> Prepath FileOrDir -> IO (Either (Path Abs File) (Path Abs Dir))
fromPreFileOrDir cwd fp = do

3
test/Arity/Negative.hs
View File

@ -2,6 +2,7 @@ module Arity.Negative (allTests) where
import Base
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.ArityChecking.Error
import Juvix.Data.Effect.TaggedLock
type FailMsg = String
@ -20,7 +21,7 @@ testDescr NegTest {..} =
{ _testName = _name,
_testRoot = tRoot,
_testAssertion = Single $ do
entryPoint <- defaultEntryPointCwdIO file'
entryPoint <- defaultEntryPointIO' LockModeExclusive tRoot file'
result <- runIOEitherTermination entryPoint upToInternalArity
case mapLeft fromJuvixError result of
Left (Just tyError) -> whenJust (_checkErr tyError) assertFailure

8
test/BackendGeb/Compilation/Base.hs
View File

@ -4,14 +4,16 @@ import BackendGeb.FromCore.Base
import Base
import Juvix.Compiler.Backend (Target (TargetGeb))
import Juvix.Compiler.Core qualified as Core
import Juvix.Data.Effect.TaggedLock
gebCompilationAssertion ::
Path Abs Dir ->
Path Abs File ->
Path Abs File ->
(String -> IO ()) ->
Assertion
gebCompilationAssertion mainFile expectedFile step = do
gebCompilationAssertion root mainFile expectedFile step = do
step "Translate to JuvixCore"
entryPoint <- set entryPointTarget TargetGeb <$> defaultEntryPointCwdIO mainFile
tab <- (^. Core.coreResultTable) . snd <$> runIO' entryPoint upToCore
entryPoint <- set entryPointTarget TargetGeb <$> defaultEntryPointIO' LockModeExclusive root mainFile
tab <- (^. Core.coreResultTable) . snd <$> runIOExclusive entryPoint upToCore
coreToGebTranslationAssertion' tab entryPoint expectedFile step

2
test/BackendGeb/Compilation/Positive.hs
View File

@ -23,7 +23,7 @@ testDescr PosTest {..} =
_testRoot = tRoot,
_testAssertion =
Steps $
gebCompilationAssertion file' expected'
gebCompilationAssertion tRoot file' expected'
}
allTests :: TestTree

6
test/BackendGeb/FromCore/Base.hs
View File

@ -7,17 +7,19 @@ import Juvix.Compiler.Backend (Target (TargetGeb))
import Juvix.Compiler.Backend.Geb qualified as Geb
import Juvix.Compiler.Core qualified as Core
import Juvix.Compiler.Core.Pretty qualified as Core
import Juvix.Data.Effect.TaggedLock
import Juvix.Prelude.Pretty
coreToGebTranslationAssertion ::
Path Abs Dir ->
Path Abs File ->
Path Abs File ->
(String -> IO ()) ->
Assertion
coreToGebTranslationAssertion mainFile expectedFile step = do
coreToGebTranslationAssertion root mainFile expectedFile step = do
step "Parse Juvix Core file"
input <- readFile . toFilePath $ mainFile
entryPoint <- set entryPointTarget TargetGeb <$> defaultEntryPointCwdIO mainFile
entryPoint <- set entryPointTarget TargetGeb <$> defaultEntryPointIO' LockModeExclusive root mainFile
case Core.runParserMain mainFile Core.emptyInfoTable input of
Left err -> assertFailure . show . pretty $ err
Right coreInfoTable -> coreToGebTranslationAssertion' coreInfoTable entryPoint expectedFile step

2
test/BackendGeb/FromCore/Positive.hs
View File

@ -23,7 +23,7 @@ testDescr PosTest {..} =
_testRoot = tRoot,
_testAssertion =
Steps $
coreToGebTranslationAssertion file' expected'
coreToGebTranslationAssertion tRoot file' expected'
}
filterOutTests :: [String] -> [PosTest] -> [PosTest]

5
test/BackendMarkdown/Negative.hs
View File

@ -2,6 +2,7 @@ module BackendMarkdown.Negative where
import Base
import Juvix.Compiler.Backend.Markdown.Error
import Juvix.Data.Effect.TaggedLock
import Juvix.Parser.Error
type FailMsg = String
@ -21,8 +22,8 @@ testDescr NegTest {..} =
{ _testName = _name,
_testRoot = tRoot,
_testAssertion = Single $ do
entryPoint <- defaultEntryPointCwdIO file'
result <- runIOEither entryPoint upToParsing
entryPoint <- defaultEntryPointIO' LockModeExclusive tRoot file'
result <- runIOEither' LockModeExclusive entryPoint upToParsing
case mapLeft fromJuvixError result of
Left (Just err) -> whenJust (_checkErr err) assertFailure
Right _ -> assertFailure "Unexpected success."

7
test/BackendMarkdown/Positive.hs
View File

@ -6,6 +6,7 @@ import Juvix.Compiler.Concrete qualified as Concrete
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper
import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser
import Juvix.Compiler.Pipeline.Setup
import Juvix.Data.Effect.TaggedLock
data PosTest = PosTest
{ _name :: String,
@ -35,13 +36,13 @@ testDescr PosTest {..} =
{ _testName = _name,
_testRoot = _dir,
_testAssertion = Steps $ \step -> do
entryPoint <- defaultEntryPointCwdIO _file
entryPoint <- defaultEntryPointIO' LockModeExclusive _dir _file
step "Parsing"
p :: Parser.ParserResult <- snd <$> runIO' entryPoint upToParsing
p :: Parser.ParserResult <- snd <$> runIOExclusive entryPoint upToParsing
step "Scoping"
s :: Scoper.ScoperResult <-
snd
<$> runIO'
<$> runIOExclusive
entryPoint
( do
void (entrySetup defaultDependenciesConfig)

15
test/Compilation/Base.hs
View File

@ -4,6 +4,7 @@ import Base
import Core.Compile.Base
import Core.Eval.Base
import Juvix.Compiler.Core qualified as Core
import Juvix.Data.Effect.TaggedLock
import Juvix.Data.PPOutput
data CompileAssertionMode
@ -13,16 +14,17 @@ data CompileAssertionMode
| EvalAndCompile
compileAssertion ::
Path Abs Dir ->
Int ->
CompileAssertionMode ->
Path Abs File ->
Path Abs File ->
(String -> IO ()) ->
Assertion
compileAssertion optLevel mode mainFile expectedFile step = do
compileAssertion root' optLevel mode mainFile expectedFile step = do
step "Translate to JuvixCore"
entryPoint <- defaultEntryPointCwdIO mainFile
tab <- (^. Core.coreResultTable) . snd <$> runIO' entryPoint upToCore
entryPoint <- defaultEntryPointIO' LockModeExclusive root' mainFile
tab <- (^. Core.coreResultTable) . snd <$> runIOExclusive entryPoint upToCore
case run $ runReader Core.defaultCoreOptions $ runError $ Core.toEval' tab of
Left err -> assertFailure (show (pretty (fromJuvixError @GenericError err)))
Right tab' -> do
@ -34,13 +36,14 @@ compileAssertion optLevel mode mainFile expectedFile step = do
EvalAndCompile -> evalAssertion >> compileAssertion' ""
compileErrorAssertion ::
Path Abs Dir ->
Path Abs File ->
(String -> IO ()) ->
Assertion
compileErrorAssertion mainFile step = do
compileErrorAssertion root' mainFile step = do
step "Translate to JuvixCore"
entryPoint <- defaultEntryPointCwdIO mainFile
tab <- (^. Core.coreResultTable) . snd <$> runIO' entryPoint upToCore
entryPoint <- defaultEntryPointIO' LockModeExclusive root' mainFile
tab <- (^. Core.coreResultTable) . snd <$> runIOExclusive entryPoint upToCore
case run $ runReader Core.defaultCoreOptions $ runError @JuvixError $ Core.toStripped' tab of
Left _ -> assertBool "" True
Right _ -> assertFailure "no error"

2
test/Compilation/Negative.hs
View File

@ -19,7 +19,7 @@ testDescr NegTest {..} =
in TestDescr
{ _testName = _name,
_testRoot = tRoot,
_testAssertion = Steps $ compileErrorAssertion file'
_testAssertion = Steps $ compileErrorAssertion tRoot file'
}
allTests :: TestTree

2
test/Compilation/Positive.hs
View File

@ -24,7 +24,7 @@ toTestDescr optLevel PosTest {..} =
in TestDescr
{ _testName = _name,
_testRoot = tRoot,
_testAssertion = Steps $ compileAssertion optLevel _assertionMode file' expected'
_testAssertion = Steps $ compileAssertion _dir optLevel _assertionMode file' expected'
}
allTests :: TestTree

2
test/Examples/Positive.hs
View File

@ -24,7 +24,7 @@ toTestDescr PosTest {..} =
TestDescr
{ _testRoot = _dir,
_testName = _name,
_testAssertion = Steps $ compileAssertion 3 (CompileOnly _stdin) _file _expectedFile
_testAssertion = Steps $ compileAssertion _dir 3 (CompileOnly _stdin) _file _expectedFile
}
allTests :: TestTree

7
test/Format.hs
View File

@ -5,6 +5,7 @@ import Juvix.Compiler.Concrete qualified as Concrete
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper
import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser
import Juvix.Compiler.Pipeline.Setup
import Juvix.Data.Effect.TaggedLock
import Juvix.Formatter
data PosTest = PosTest
@ -33,19 +34,19 @@ testDescr PosTest {..} =
{ _testName = _name,
_testRoot = _dir,
_testAssertion = Steps $ \step -> do
entryPoint <- defaultEntryPointCwdIO _file
entryPoint <- defaultEntryPointIO' LockModeExclusive _dir _file
let maybeFile = entryPoint ^? entryPointModulePaths . _head
f <- fromMaybeM (assertFailure "Not a module") (return maybeFile)
original :: Text <- readFile (toFilePath f)
step "Parsing"
p :: Parser.ParserResult <- snd <$> runIO' entryPoint upToParsing
p :: Parser.ParserResult <- snd <$> runIOExclusive entryPoint upToParsing
step "Scoping"
s :: Scoper.ScoperResult <-
snd
<$> runIO'
<$> runIOExclusive
entryPoint
( do
void (entrySetup defaultDependenciesConfig)

15
test/Formatter/Positive.hs
View File

@ -1,18 +1,19 @@
module Formatter.Positive where
import Base
import Juvix.Data.Effect.TaggedLock
import Juvix.Formatter
import Scope.Positive qualified
import Scope.Positive qualified as Scope
runScopeEffIO :: (Member (Embed IO) r) => Sem (ScopeEff ': r) a -> Sem r a
runScopeEffIO = interpret $ \case
runScopeEffIO :: (Member (Embed IO) r) => Path Abs Dir -> Sem (ScopeEff ': r) a -> Sem r a
runScopeEffIO root = interpret $ \case
ScopeFile p -> do
entry <- embed (defaultEntryPointCwdIO p)
embed (snd <$> runIO' entry upToScoping)
entry <- embed (defaultEntryPointIO' LockModeExclusive root p)
embed (snd <$> runIOExclusive entry upToScoping)
ScopeStdin -> do
entry <- embed defaultEntryPointNoFileCwdIO
embed (snd <$> runIO' entry upToScoping)
entry <- embed (defaultEntryPointNoFileIO' LockModeExclusive root)
embed (snd <$> runIOExclusive entry upToScoping)
makeFormatTest' :: Scope.PosTest -> TestDescr
makeFormatTest' Scope.PosTest {..} =
@ -26,7 +27,7 @@ makeFormatTest' Scope.PosTest {..} =
runM
. runError
. runOutputList @FormattedFileInfo
. runScopeEffIO
. runScopeEffIO tRoot
. runFilesIO
$ format file'
case d of

9
test/Internal/Eval/Base.hs
View File

@ -11,12 +11,13 @@ import Juvix.Compiler.Core.Info.NoDisplayInfo
import Juvix.Compiler.Core.Pretty
import Juvix.Compiler.Core.Transformation (etaExpansionApps)
import Juvix.Compiler.Core.Translation.FromInternal.Data as Core
import Juvix.Data.Effect.TaggedLock
internalCoreAssertion :: Path Abs File -> Path Abs File -> (String -> IO ()) -> Assertion
internalCoreAssertion mainFile expectedFile step = do
internalCoreAssertion :: Path Abs Dir -> Path Abs File -> Path Abs File -> (String -> IO ()) -> Assertion
internalCoreAssertion root' mainFile expectedFile step = do
step "Translate to Core"
entryPoint <- defaultEntryPointCwdIO mainFile
tab0 <- (^. Core.coreResultTable) . snd <$> runIO' entryPoint upToCore
entryPoint <- defaultEntryPointIO' LockModeExclusive root' mainFile
tab0 <- (^. Core.coreResultTable) . snd <$> runIOExclusive entryPoint upToCore
let tab = etaExpansionApps tab0
case (tab ^. infoMain) >>= ((tab ^. identContext) HashMap.!?) of
Just node -> do

2
test/Internal/Eval/Positive.hs
View File

@ -24,7 +24,7 @@ testDescr r PosTest {..} =
in TestDescr
{ _testName = _name,
_testRoot = tRoot,
_testAssertion = Steps $ internalCoreAssertion file' expected'
_testAssertion = Steps $ internalCoreAssertion tRoot file' expected'
}
allTests :: TestTree

3
test/Main.hs
View File

@ -51,5 +51,4 @@ fastTests =
]
main :: IO ()
main = do
defaultMain (testGroup "Juvix tests" [fastTests, slowTests])
main = defaultMain (testGroup "Juvix tests" [fastTests, slowTests])

6
test/Package/Negative.hs
View File

@ -3,6 +3,7 @@ module Package.Negative where
import Base
import Juvix.Compiler.Pipeline.Package
import Juvix.Compiler.Pipeline.Package.Loader.EvalEff.IO
import Juvix.Data.Effect.TaggedLock
type FailMsg = String
@ -24,10 +25,13 @@ testDescr NegTest {..} =
_testAssertion = Single $ do
res <-
withTempDir'
( runM
( runFinal
. resourceToIOFinal
. embedToFinal @IO
. runError
. runFilesIO
. mapError (JuvixError @PackageLoaderError)
. runTaggedLock LockModeExclusive
. runEvalFileEffIO
. readPackage tRoot
. CustomBuildDir

6
test/Package/Positive.hs
View File

@ -3,6 +3,7 @@ module Package.Positive where
import Base
import Juvix.Compiler.Pipeline.Package
import Juvix.Compiler.Pipeline.Package.Loader.EvalEff.IO
import Juvix.Data.Effect.TaggedLock
type FailMsg = String
@ -25,10 +26,13 @@ testDescr PosTest {..} =
withTempDir' $ \d -> do
let buildDir = CustomBuildDir (Abs d)
res <-
runM
runFinal
. resourceToIOFinal
. embedToFinal @IO
. runError @JuvixError
. runFilesIO
. mapError (JuvixError @PackageLoaderError)
. runTaggedLock LockModeExclusive
. runEvalFileEffIO
. readPackage tRoot
$ buildDir

5
test/Parsing/Negative.hs
View File

@ -2,6 +2,7 @@ module Parsing.Negative where
import Base
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error
import Juvix.Data.Effect.TaggedLock
import Juvix.Parser.Error
root :: Path Abs Dir
@ -23,8 +24,8 @@ testDescr NegTest {..} =
{ _testName = _name,
_testRoot = tRoot,
_testAssertion = Single $ do
entryPoint <- defaultEntryPointCwdIO _file
res <- runIOEither entryPoint upToParsing
entryPoint <- defaultEntryPointIO' LockModeExclusive tRoot _file
res <- runIOEither' LockModeExclusive entryPoint upToParsing
case mapLeft fromJuvixError res of
Left (Just parErr) -> whenJust (_checkErr parErr) assertFailure
Left Nothing -> assertFailure "An error ocurred but it was not in the parser."

5
test/Reachability/Positive.hs
View File

@ -4,6 +4,7 @@ import Base
import Data.HashSet qualified as HashSet
import Juvix.Compiler.Internal.Language qualified as Internal
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context qualified as Internal
import Juvix.Data.Effect.TaggedLock
data PosTest = PosTest
{ _name :: String,
@ -29,10 +30,10 @@ testDescr PosTest {..} =
let noStdlib = _stdlibMode == StdlibExclude
entryPoint <-
set entryPointNoStdlib noStdlib
<$> defaultEntryPointCwdIO file'
<$> defaultEntryPointIO' LockModeExclusive tRoot file'
step "Pipeline up to reachability"
p :: Internal.InternalTypedResult <- snd <$> runIO' entryPoint upToInternalReachability
p :: Internal.InternalTypedResult <- snd <$> runIOExclusive entryPoint upToInternalReachability
step "Check reachability results"
let names = concatMap getNames (p ^. Internal.resultModules)

5
test/Scope/Negative.hs
View File

@ -2,6 +2,7 @@ module Scope.Negative (allTests) where
import Base
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error
import Juvix.Data.Effect.TaggedLock
type FailMsg = String
@ -23,8 +24,8 @@ testDescr NegTest {..} =
{ _testName = _name,
_testRoot = tRoot,
_testAssertion = Single $ do
entryPoint <- defaultEntryPointCwdIO file'
res <- runIOEitherTermination entryPoint upToInternal
entryPoint <- defaultEntryPointIO' LockModeExclusive tRoot file'
res <- runIOEitherTermination' LockModeExclusive entryPoint upToInternal
case mapLeft fromJuvixError res of
Left (Just err) -> whenJust (_checkErr err) assertFailure
Left Nothing -> assertFailure "An error ocurred but it was not in the scoper."

12
test/Scope/Positive.hs
View File

@ -16,6 +16,7 @@ import Juvix.Compiler.Pipeline.Package.Loader.PathResolver
import Juvix.Compiler.Pipeline.Setup
import Juvix.Data.Effect.Git
import Juvix.Data.Effect.Process
import Juvix.Data.Effect.TaggedLock
import Juvix.Prelude.Aeson
import Juvix.Prelude.Pretty
@ -53,13 +54,15 @@ testDescr PosTest {..} = helper renderCodeNew
{ _testName = _name,
_testRoot = tRoot,
_testAssertion = Steps $ \step -> do
entryPoint <- defaultEntryPointCwdIO file'
entryPoint <- defaultEntryPointIO' LockModeExclusive tRoot file'
let runHelper :: HashMap (Path Abs File) Text -> Sem PipelineEff a -> IO (ResolverState, a)
runHelper files = do
let runPathResolver' = case _pathResolverMode of
FullPathResolver -> runPathResolverPipe
PackagePathResolver -> runPackagePathResolver' (entryPoint ^. entryPointResolverRoot)
runM
runFinal
. resourceToIOFinal
. embedToFinal @IO
. evalInternetOffline
. ignoreHighlightBuilder
. runErrorIO' @JuvixError
@ -67,6 +70,7 @@ testDescr PosTest {..} = helper renderCodeNew
. evalTopNameIdGen
. runFilesPure files tRoot
. runReader entryPoint
. runTaggedLock LockModeExclusive
. ignoreLog
. runProcessIO
. mapError (JuvixError @GitProcessError)
@ -79,11 +83,11 @@ testDescr PosTest {..} = helper renderCodeNew
evalHelper files = fmap snd . runHelper files
step "Parsing"
p :: Parser.ParserResult <- snd <$> runIO' entryPoint upToParsing
p :: Parser.ParserResult <- snd <$> runIOExclusive entryPoint upToParsing
step "Scoping"
(resolverState :: ResolverState, s :: Scoper.ScoperResult) <-
runIO'
runIOExclusive
entryPoint
( do
void (entrySetup defaultDependenciesConfig)

5
test/Termination/Negative.hs
View File

@ -2,6 +2,7 @@ module Termination.Negative (module Termination.Negative) where
import Base
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination
import Juvix.Data.Effect.TaggedLock
type FailMsg = String
@ -20,8 +21,8 @@ testDescr NegTest {..} =
{ _testName = _name,
_testRoot = tRoot,
_testAssertion = Single $ do
entryPoint <- set entryPointNoStdlib True <$> defaultEntryPointCwdIO file'
result <- runIOEither entryPoint upToInternalTyped
entryPoint <- set entryPointNoStdlib True <$> defaultEntryPointIO' LockModeExclusive tRoot file'
result <- runIOEither' LockModeExclusive entryPoint upToInternalTyped
case mapLeft fromJuvixError result of
Left (Just lexError) -> whenJust (_checkErr lexError) assertFailure
Left Nothing -> assertFailure "The termination checker did not find an error."

11
test/Termination/Positive.hs
View File

@ -1,6 +1,7 @@
module Termination.Positive where
import Base
import Juvix.Data.Effect.TaggedLock (LockMode (LockModeExclusive))
import Termination.Negative qualified as N
data PosTest = PosTest
@ -20,8 +21,8 @@ testDescr PosTest {..} =
{ _testName = _name,
_testRoot = tRoot,
_testAssertion = Single $ do
entryPoint <- set entryPointNoStdlib True <$> defaultEntryPointCwdIO file'
(void . runIO' entryPoint) upToInternalTyped
entryPoint <- set entryPointNoStdlib True <$> defaultEntryPointIO' LockModeExclusive tRoot file'
(void . runIOExclusive entryPoint) upToInternalTyped
}
--------------------------------------------------------------------------------
@ -42,8 +43,8 @@ testDescrFlag N.NegTest {..} =
entryPoint <-
set entryPointNoTermination True
. set entryPointNoStdlib True
<$> defaultEntryPointCwdIO file'
(void . runIO' entryPoint) upToInternalTyped
<$> defaultEntryPointIO' LockModeExclusive tRoot file'
(void . runIOExclusive entryPoint) upToInternalTyped
}
tests :: [PosTest]
@ -88,7 +89,7 @@ negTests = N.tests
allTests :: TestTree
allTests =
testGroup
"Positive tests"
"Termination positive tests"
[ testGroup
"Well-known terminating functions"
(map (mkTest . testDescr) tests),

5
test/Typecheck/Negative.hs
View File

@ -2,6 +2,7 @@ module Typecheck.Negative where
import Base
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Error
import Juvix.Data.Effect.TaggedLock
type FailMsg = String
@ -20,8 +21,8 @@ testDescr NegTest {..} =
{ _testName = _name,
_testRoot = tRoot,
_testAssertion = Single $ do
entryPoint <- defaultEntryPointCwdIO file'
result <- runIOEither entryPoint upToInternalTyped
entryPoint <- defaultEntryPointIO' LockModeExclusive tRoot file'
result <- runIOEither' LockModeExclusive entryPoint upToInternalTyped
case mapLeft fromJuvixError result of
Left (Just tyError) -> whenJust (_checkErr tyError) assertFailure
Left Nothing -> assertFailure "An error ocurred but it was not in the type checker."

9
test/Typecheck/Positive.hs
View File

@ -2,6 +2,7 @@ module Typecheck.Positive where
import Base
import Compilation.Positive qualified as Compilation
import Juvix.Data.Effect.TaggedLock
import Typecheck.Negative qualified as N
data PosTest = PosTest
@ -27,8 +28,8 @@ testDescr PosTest {..} =
{ _testName = _name,
_testRoot = _dir,
_testAssertion = Single $ do
entryPoint <- defaultEntryPointCwdIO _file
(void . runIO' entryPoint) upToInternalTyped
entryPoint <- defaultEntryPointIO' LockModeExclusive _dir _file
(void . runIOExclusive entryPoint) upToInternalTyped
}
rootNegTests :: Path Abs Dir
@ -45,8 +46,8 @@ testNoPositivityFlag N.NegTest {..} =
_testAssertion = Single $ do
entryPoint <-
set entryPointNoPositivity True
<$> defaultEntryPointCwdIO file'
(void . runIO' entryPoint) upToInternalTyped
<$> defaultEntryPointIO' LockModeExclusive tRoot file'
(void . runIOExclusive entryPoint) upToInternalTyped
}
negPositivityTests :: [N.NegTest]

5
test/Typecheck/PositiveNew.hs
View File

@ -2,6 +2,7 @@ module Typecheck.PositiveNew where
import Base
import Data.HashSet qualified as HashSet
import Juvix.Data.Effect.TaggedLock
import Typecheck.Positive qualified as Old
root :: Path Abs Dir
@ -19,8 +20,8 @@ testDescr Old.PosTest {..} =
{ _testName = _name,
_testRoot = _dir,
_testAssertion = Single $ do
entryPoint <- set entryPointNewTypeCheckingAlgorithm True <$> defaultEntryPointCwdIO _file
(void . runIO' entryPoint) upToInternalTyped
entryPoint <- set entryPointNewTypeCheckingAlgorithm True <$> defaultEntryPointIO' LockModeExclusive _dir _file
(void . runIOExclusive entryPoint) upToInternalTyped
}
allTests :: TestTree

14
test/VampIR/Compilation/Base.hs
View File

@ -4,23 +4,25 @@ import Base
import Core.VampIR.Base (coreVampIRAssertion')
import Juvix.Compiler.Core
import Juvix.Compiler.Core.Data.TransformationId
import Juvix.Data.Effect.TaggedLock
import VampIR.Core.Base (VampirBackend (..), vampirAssertion')
vampirCompileAssertion :: Path Abs File -> Path Abs File -> (String -> IO ()) -> Assertion
vampirCompileAssertion mainFile dataFile step = do
vampirCompileAssertion :: Path Abs Dir -> Path Abs File -> Path Abs File -> (String -> IO ()) -> Assertion
vampirCompileAssertion root' mainFile dataFile step = do
step "Translate to JuvixCore"
entryPoint <- defaultEntryPointCwdIO mainFile
tab <- (^. coreResultTable) . snd <$> runIO' entryPoint upToCore
entryPoint <- defaultEntryPointIO' LockModeExclusive root' mainFile
tab <- (^. coreResultTable) . snd <$> runIOExclusive entryPoint upToCore
coreVampIRAssertion' tab toVampIRTransformations mainFile dataFile step
vampirAssertion' VampirHalo2 tab dataFile step
vampirCompileErrorAssertion ::
Path Abs Dir ->
Path Abs File ->
(String -> IO ()) ->
Assertion
vampirCompileErrorAssertion mainFile step = do
vampirCompileErrorAssertion root' mainFile step = do
step "Translate to JuvixCore"
entryPoint <- defaultEntryPointCwdIO mainFile
entryPoint <- defaultEntryPointIO' LockModeExclusive root' mainFile
r <- runIOEither entryPoint upToCore
case r of
Left _ -> return ()

2
test/VampIR/Compilation/Negative.hs
View File

@ -19,7 +19,7 @@ testDescr NegTest {..} =
in TestDescr
{ _testName = _name,
_testRoot = tRoot,
_testAssertion = Steps $ vampirCompileErrorAssertion file'
_testAssertion = Steps $ vampirCompileErrorAssertion tRoot file'
}
allTests :: TestTree

2
test/VampIR/Compilation/Positive.hs
View File

@ -26,7 +26,7 @@ toTestDescr PosTest {..} =
in TestDescr
{ _testName = _name,
_testRoot = tRoot,
_testAssertion = Steps $ vampirCompileAssertion file' data'
_testAssertion = Steps $ vampirCompileAssertion _dir file' data'
}
allTests :: TestTree