anoma/juvix
1
1
Fork 0
mirror of https://github.com/anoma/juvix.git synced 2024-08-17 04:01:05 +03:00
Code Issues Projects Releases Wiki Activity

Extract builtin definitions for loading a Package into bundled package-base package (#2535)

Browse Source 
This PR creates a new package that's bundled with the compiler in a
similar way to the stdlib and the package description package.

## The `package-base` Package

This package is called
[package-base](ab4376cf9e/include/package-base)
and contains the minimal set of definitions required to load a Package
file.

The
[`Juvix.Builtin`](ab4376cf9e/include/package-base/Juvix/Builtin/V1.juvix)
module contains:

```
module Juvix.Builtin.V1;

import Juvix.Builtin.V1.Nat open public;
import Juvix.Builtin.V1.Trait.Natural open public;
import Juvix.Builtin.V1.String open public;
import Juvix.Builtin.V1.Bool open public;
import Juvix.Builtin.V1.Maybe open public;
import Juvix.Builtin.V1.List open public;
import Juvix.Builtin.V1.Fixity open public;
```

`Juvix.Builtin.V1.Bool` is required to support backend primitive
integers `Juvix.Builtin.V1.Trait.Natural` is required to support numeric
literals.

## The `PackageDescription.V2` module

This PR also adds a new
[`PackageDescription.V2`](ab4376cf9e/include/package/PackageDescription/V2.juvix)
type that uses the `package-base`. This is to avoid breaking existing
Package files. The Packages files in the repo (except those that test
`PackageDescription.V1`) have also been updated.

## Updating the stdlib

The standard library will be updated to use `Juvix.Builtin.*` modules in
a subsequent PR.

* Part of https://github.com/anoma/juvix/issues/2511
This commit is contained in:
Paul Cadman 2023-11-30 16:22:18 +00:00 committed by GitHub
parent 7de9f2f0f3
commit 20a95ec42d
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
66 changed files with 796 additions and 415 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
app/App.hs
View File

@ -49,7 +49,7 @@ runAppIO ::
Sem r a
runAppIO args@RunAppIOArgs {..} =
interpret $ \case
AskPackageGlobal -> return (_runAppIOArgsRoot ^. rootPackageGlobal)
AskPackageGlobal -> return (_runAppIOArgsRoot ^. rootPackageType `elem` [GlobalStdlib, GlobalPackageDescription, GlobalPackageBase])
FromAppPathFile p -> embed (prepathToAbsFile invDir (p ^. pathPath))
GetMainFile m -> getMainFile' m
FromAppPathDir p -> embed (prepathToAbsDir invDir (p ^. pathPath))

7
app/Commands/Extra/Package.hs
View File

@ -6,8 +6,11 @@ import Juvix.Compiler.Pipeline.Package.Loader
import Juvix.Extra.Paths
import Juvix.Prelude
currentPackageVersion :: PackageVersion
currentPackageVersion = PackageVersion2
renderPackage :: Package -> Text
renderPackage = renderPackageVersion PackageVersion1
renderPackage = renderPackageVersion currentPackageVersion
writePackageFile' :: (Member (Embed IO) r) => PackageVersion -> Path Abs Dir -> Package -> Sem r ()
writePackageFile' v root pkg =
@ -18,7 +21,7 @@ writePackageFile' v root pkg =
)
writePackageFile :: (Member (Embed IO) r) => Path Abs Dir -> Package -> Sem r ()
writePackageFile = writePackageFile' PackageVersion1
writePackageFile = writePackageFile' currentPackageVersion
writeBasicPackage :: (Member (Embed IO) r) => Path Abs Dir -> Sem r ()
writeBasicPackage root = writePackageFile' PackageBasic root (emptyPackage DefaultBuildDir (root <//> packageFilePath))

2
examples/demo/Package.juvix
View File

@ -1,6 +1,6 @@
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage

2
examples/midsquare/Package.juvix
View File

@ -1,6 +1,6 @@
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage

2
examples/milestone/Bank/Package.juvix
View File

@ -1,5 +1,5 @@
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package := defaultPackage {name := "bank"};

3
examples/milestone/Collatz/Package.juvix
View File

@ -1,7 +1,6 @@
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage

3
examples/milestone/Fibonacci/Package.juvix
View File

@ -1,7 +1,6 @@
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage

3
examples/milestone/Hanoi/Package.juvix
View File

@ -1,7 +1,6 @@
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage

3
examples/milestone/HelloWorld/Package.juvix
View File

@ -1,7 +1,6 @@
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage

3
examples/milestone/PascalsTriangle/Package.juvix
View File

@ -1,7 +1,6 @@
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage

3
examples/milestone/TicTacToe/Package.juvix
View File

@ -1,7 +1,6 @@
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage

2
examples/milestone/Tutorial/Package.juvix
View File

@ -1,6 +1,6 @@
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage

9
include/package-base/Juvix/Builtin/V1.juvix Normal file
View File

@ -0,0 +1,9 @@
module Juvix.Builtin.V1;
import Juvix.Builtin.V1.Nat open public;
import Juvix.Builtin.V1.Trait.Natural open public;
import Juvix.Builtin.V1.String open public;
import Juvix.Builtin.V1.Bool open public;
import Juvix.Builtin.V1.Maybe open public;
import Juvix.Builtin.V1.List open public;
import Juvix.Builtin.V1.Fixity open public;

7
include/package-base/Juvix/Builtin/V1/Bool.juvix Normal file
View File

@ -0,0 +1,7 @@
module Juvix.Builtin.V1.Bool;
--- Inductive definition of booleans.
builtin bool
type Bool :=
| true
| false;

23
include/package-base/Juvix/Builtin/V1/Fixity.juvix Normal file
View File

@ -0,0 +1,23 @@
module Juvix.Builtin.V1.Fixity;
syntax fixity none := none;
syntax fixity rapp := binary {assoc := right};
syntax fixity lapp := binary {assoc := left; same := rapp};
syntax fixity seq := binary {assoc := left; above := [lapp]};
syntax fixity functor := binary {assoc := right};
syntax fixity logical := binary {assoc := right; above := [seq]};
syntax fixity comparison := binary {assoc := none; above := [logical]};
syntax fixity pair := binary {assoc := right};
syntax fixity cons := binary {assoc := right; above := [pair]};
syntax fixity step := binary {assoc := right};
syntax fixity range := binary {assoc := right; above := [step]};
syntax fixity additive := binary {assoc := left; above := [comparison; range; cons]};
syntax fixity multiplicative := binary {assoc := left; above := [additive]};
syntax fixity composition := binary {assoc := right; above := [multiplicative]};

12
include/package-base/Juvix/Builtin/V1/List.juvix Normal file
View File

@ -0,0 +1,12 @@
module Juvix.Builtin.V1.List;
import Juvix.Builtin.V1.Fixity open;
syntax operator :: cons;
--- Inductive list.
builtin list
type List (a : Type) :=
| --- The empty list
nil
| --- An element followed by a list
:: a (List a);

7
include/package-base/Juvix/Builtin/V1/Maybe.juvix Normal file
View File

@ -0,0 +1,7 @@
module Juvix.Builtin.V1.Maybe;
--- Represents an optional value that may or may not be present. Provides a way
--- to handle null or missing values in a type-safe manner.
type Maybe A :=
| nothing
| just A;

16
include/package-base/Juvix/Builtin/V1/Nat.juvix Normal file
View File

@ -0,0 +1,16 @@
module Juvix.Builtin.V1.Nat;
import Juvix.Builtin.V1.Trait.Natural open public;
import Juvix.Builtin.V1.Nat.Base open hiding {+; *; div; mod} public;
import Juvix.Builtin.V1.Nat.Base as Nat;
{-# specialize: true, inline: case #-}
instance
naturalNatI : Natural Nat :=
mkNatural@{
+ := (Nat.+);
* := (Nat.*);
div := Nat.div;
mod := Nat.mod;
fromNat (x : Nat) : Nat := x
};

47
include/package-base/Juvix/Builtin/V1/Nat/Base.juvix Normal file
View File

@ -0,0 +1,47 @@
module Juvix.Builtin.V1.Nat.Base;
import Juvix.Builtin.V1.Fixity open;
--- Inductive natural numbers. I.e. whole non-negative numbers.
builtin nat
type Nat :=
| zero
| suc Nat;
syntax operator + additive;
--- Addition for ;Nat;s.
builtin nat-plus
+ : Nat → Nat → Nat
| zero b := b
| (suc a) b := suc (a + b);
syntax operator * multiplicative;
--- Multiplication for ;Nat;s.
builtin nat-mul
* : Nat → Nat → Nat
| zero _ := zero
| (suc a) b := b + a * b;
--- Truncated subtraction for ;Nat;s.
builtin nat-sub
sub : Nat → Nat → Nat
| zero _ := zero
| n zero := n
| (suc n) (suc m) := sub n m;
--- Division for ;Nat;s. Returns ;zero; if the first element is ;zero;.
builtin nat-udiv
terminating
udiv : Nat → Nat → Nat
| zero _ := zero
| n m := suc (udiv (sub n m) m);
--- Division for ;Nat;s.
builtin nat-div
div (n m : Nat) : Nat := udiv (sub (suc n) m) m;
--- Modulo for ;Nat;s.
builtin nat-mod
mod (n m : Nat) : Nat := sub n (div n m * m);

12
include/package-base/Juvix/Builtin/V1/String.juvix Normal file
View File

@ -0,0 +1,12 @@
module Juvix.Builtin.V1.String;
import Juvix.Builtin.V1.Fixity open;
--- Primitive representation of a sequence of characters.
builtin string
axiom String : Type;
syntax operator ++str cons;
--- Concatenation of two ;String;s.
builtin string-concat
axiom ++str : String -> String -> String;

19
include/package-base/Juvix/Builtin/V1/Trait/Natural.juvix Normal file
View File

@ -0,0 +1,19 @@
module Juvix.Builtin.V1.Trait.Natural;
import Juvix.Builtin.V1.Nat.Base open using {Nat};
import Juvix.Builtin.V1.Fixity open;
trait
type Natural A :=
mkNatural {
syntax operator + additive;
+ : A -> A -> A;
syntax operator * multiplicative;
* : A -> A -> A;
div : A -> A -> A;
mod : A -> A -> A;
builtin from-nat
fromNat : Nat -> A
};
open Natural public;

72
include/package/PackageDescription/V2.juvix Normal file
View File

@ -0,0 +1,72 @@
module PackageDescription.V2;
import Juvix.Builtin.V1 open public;
--- A ;Package; defines the configuration for a Juvix package
type Package :=
mkPackage {
-- The name of the package
name : String;
-- The version for the package
version : SemVer;
-- The dependencies of this package
dependencies : List Dependency;
-- A path to the Main module for this package
main : Maybe String;
-- A path to a directory where Juvix should output intermediate build products
buildDir : Maybe String
};
--- Construct a ;Package; with useful default arguments.
defaultPackage {name : String := "my-project"} {version : SemVer := defaultVersion} {dependencies : List
Dependency := [defaultStdlib]} {main : Maybe
String := nothing} {buildDir : Maybe String := nothing}
: Package :=
mkPackage name version dependencies main buildDir;
--- A ;SemVer; defines a version that conforms to the Semantic Versioning specification.
type SemVer :=
mkSemVer {
major : Nat;
minor : Nat;
patch : Nat;
release : Maybe String;
meta : Maybe String
};
--- Construct a ;SemVer; with useful default arguments.
mkVersion (major minor patch : Nat) {release : Maybe
String := nothing} {meta : Maybe String := nothing}
: SemVer :=
mkSemVer
(major := major;
minor := minor;
patch := patch;
release := release;
meta := meta);
--- The default version used in `defaultPackage`.
defaultVersion : SemVer := mkVersion 0 0 0;
--- A ;Dependency; defines a Juvix package dependency.
type Dependency :=
| --- A filesystem path to another Juvix Package.
path {path : String}
| --- A ;git; repository containing a Juvix package at its root
git {
-- A name for this dependency
name : String;
-- The URL to the git repository
url : String;
-- The git ref to checkout
ref : String
}
| --- The ;defaultStdlib; that is bundled with the Juvix compiler.
defaultStdlib;
--- Constructs a GitHub dependency.
github (org repo ref : String) : Dependency :=
git
(org ++str "_" ++str repo)
("https://github.com/" ++str org ++str "/" ++str repo)
ref;

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

@ -24,9 +24,11 @@ import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Compiler.Pipeline.Lockfile
import Juvix.Compiler.Pipeline.Package
import Juvix.Compiler.Pipeline.Package.Loader.EvalEff
import Juvix.Compiler.Pipeline.Root.Base (PackageType (..))
import Juvix.Data.Effect.Git
import Juvix.Data.Effect.TaggedLock
import Juvix.Data.SHA256 qualified as SHA256
import Juvix.Extra.PackageFiles
import Juvix.Extra.Paths
import Juvix.Extra.Stdlib (ensureStdlib)
import Juvix.Prelude
@ -58,9 +60,10 @@ mkPackageInfo mpackageEntry _packageRoot pkg = do
ensureStdlib _packageRoot buildDir deps
files :: [Path Rel File] <-
map (fromJust . stripProperPrefix _packageRoot) <$> walkDirRelAccum juvixAccum _packageRoot []
packageBaseAbsDir <- globalPackageBaseRoot
let _packageRelativeFiles = HashSet.fromList files
_packageAvailableRoots =
HashSet.fromList (_packageRoot : depsPaths)
HashSet.fromList (packageBaseAbsDir : _packageRoot : depsPaths)
return PackageInfo {..}
where
juvixAccum :: Path Abs Dir -> [Path Rel Dir] -> [Path Rel File] -> [Path Abs File] -> Sem r ([Path Abs File], Recurse Rel)
@ -162,6 +165,35 @@ resolveDependency i = case i ^. packageDepdendencyInfoDependency of
_dependencyErrorPackageFile = i ^. packageDependencyInfoPackageFile
}
registerPackageBase ::
forall r.
(Members '[TaggedLock, State ResolverState, Reader ResolverEnv, Files] r) =>
Sem r ()
registerPackageBase = do
packageBaseAbsDir <- globalPackageBaseRoot
runReader packageBaseAbsDir updatePackageBaseFiles
packageBaseRelFiles <- relFiles packageBaseAbsDir
let pkgInfo =
PackageInfo
{ _packageRoot = packageBaseAbsDir,
_packageRelativeFiles = packageBaseRelFiles,
_packagePackage = packageBasePackage,
_packageAvailableRoots = HashSet.singleton packageBaseAbsDir
}
dep =
LockfileDependency
{ _lockfileDependencyDependency = mkPathDependency (toFilePath packageBaseAbsDir),
_lockfileDependencyDependencies = []
}
cacheItem =
ResolverCacheItem
{ _resolverCacheItemPackage = pkgInfo,
_resolverCacheItemDependency = dep
}
setResolverCacheItem packageBaseAbsDir (Just cacheItem)
forM_ (pkgInfo ^. packageRelativeFiles) $ \f -> do
modify' (over resolverFiles (HashMap.insertWith (<>) f (pure pkgInfo)))
registerDependencies' ::
forall r.
(Members '[TaggedLock, Reader EntryPoint, State ResolverState, Reader ResolverEnv, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) =>
@ -169,17 +201,19 @@ registerDependencies' ::
Sem r ()
registerDependencies' conf = do
e <- ask @EntryPoint
isGlobal <- asks (^. entryPointPackageGlobal)
if
| isGlobal -> do
glob <- globalRoot
void (addRootDependency conf e glob)
| otherwise -> do
lockfile <- addRootDependency conf e (e ^. entryPointRoot)
whenM shouldWriteLockfile $ do
packageFileChecksum <- SHA256.digestFile (e ^. entryPointPackage . packageFile)
lockfilePath' <- lockfilePath
writeLockfile lockfilePath' packageFileChecksum lockfile
registerPackageBase
case e ^. entryPointPackageType of
GlobalStdlib -> do
glob <- globalRoot
void (addRootDependency conf e glob)
GlobalPackageBase -> return ()
GlobalPackageDescription -> void (addRootDependency conf e (e ^. entryPointRoot))
LocalPackage -> do
lockfile <- addRootDependency conf e (e ^. entryPointRoot)
whenM shouldWriteLockfile $ do
packageFileChecksum <- SHA256.digestFile (e ^. entryPointPackage . packageFile)
lockfilePath' <- lockfilePath
writeLockfile lockfilePath' packageFileChecksum lockfile
where
shouldWriteLockfile :: Sem r Bool
shouldWriteLockfile = do
@ -341,17 +375,17 @@ isModuleOrphan ::
Sem r Bool
isModuleOrphan topJuvixPath = do
let actualPath = getLoc topJuvixPath ^. intervalFile
possiblePaths :: Path Abs Dir -> [Path Abs Dir]
possiblePaths p = p : toList (parents p)
packageFileExists <- findFile' (possiblePaths (parent actualPath)) packageFilePath
yamlFileExists <- findFile' (possiblePaths (parent actualPath)) juvixYamlFile
pathPackageDescription <- globalPackageDescriptionRoot
return $ isNothing (packageFileExists <|> yamlFileExists) && not (pathPackageDescription `isProperPrefixOf` actualPath)
pathPackageBase <- globalPackageBaseRoot
return
( isNothing (packageFileExists <|> yamlFileExists)
&& not (pathPackageDescription `isProperPrefixOf` actualPath)
&& not (pathPackageBase `isProperPrefixOf` actualPath)
)
expectedPath' ::
(Members '[Reader ResolverEnv, Files] r) =>
@ -403,7 +437,7 @@ runPathResolver' st root x = do
e <- ask
let _envSingleFile :: Maybe (Path Abs File)
_envSingleFile
| e ^. entryPointPackageGlobal = e ^? entryPointModulePaths . _head
| e ^. entryPointPackageType == GlobalStdlib = e ^? entryPointModulePaths . _head
| otherwise = Nothing
env :: ResolverEnv
env =

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

@ -164,4 +164,4 @@ instance PrettyCodeAnn PackageInvalidImport where
<+> pcode _packageInvalidImport
<+> "cannot be imported by the Package file."
<> line
<> "Package files may only import modules from the Juvix standard library or from the PackageDescription module."
<> "Package files may only import modules from the Juvix standard library, Juvix.Builtin modules, or from the PackageDescription module."

47
src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Checker.hs
View File

@ -813,29 +813,30 @@ inferExpression' hint e = case e of
return (TypedExpression uni (ExpressionFunction (Function l' r')))
goLiteral :: LiteralLoc -> Sem r TypedExpression
goLiteral lit@(WithLoc i l) = case l of
LitNumeric v -> outHole v >> typedLitNumeric v
LitInteger {} -> do
ty <- getIntTy
return $
TypedExpression
{ _typedType = ty,
_typedExpression = ExpressionLiteral lit
}
LitNatural {} -> do
ty <- getNatTy
return $
TypedExpression
{ _typedType = ty,
_typedExpression = ExpressionLiteral lit
}
LitString {} -> do
str <- getBuiltinName i BuiltinString
return
TypedExpression
{ _typedExpression = ExpressionLiteral lit,
_typedType = ExpressionIden (IdenAxiom str)
}
goLiteral lit@(WithLoc i l) = do
case l of
LitNumeric v -> outHole v >> typedLitNumeric v
LitInteger {} -> do
ty <- getIntTy
return $
TypedExpression
{ _typedType = ty,
_typedExpression = ExpressionLiteral lit
}
LitNatural {} -> do
ty <- getNatTy
return $
TypedExpression
{ _typedType = ty,
_typedExpression = ExpressionLiteral lit
}
LitString {} -> do
str <- getBuiltinName i BuiltinString
return
TypedExpression
{ _typedExpression = ExpressionLiteral lit,
_typedType = ExpressionIden (IdenAxiom str)
}
where
typedLitNumeric :: Integer -> Sem r TypedExpression
typedLitNumeric v

4
src/Juvix/Compiler/Pipeline/EntryPoint.hs
View File

@ -27,7 +27,7 @@ data EntryPoint = EntryPoint
_entryPointNoCoverage :: Bool,
_entryPointNoStdlib :: Bool,
_entryPointPackage :: Package,
_entryPointPackageGlobal :: Bool,
_entryPointPackageType :: PackageType,
_entryPointStdin :: Maybe Text,
_entryPointTarget :: Target,
_entryPointDebug :: Bool,
@ -63,7 +63,7 @@ defaultEntryPointNoFile root =
_entryPointNoStdlib = False,
_entryPointStdin = Nothing,
_entryPointPackage = root ^. rootPackage,
_entryPointPackageGlobal = root ^. rootPackageGlobal,
_entryPointPackageType = root ^. rootPackageType,
_entryPointGenericOptions = defaultGenericOptions,
_entryPointTarget = TargetCore,
_entryPointDebug = False,

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

@ -5,6 +5,7 @@ module Juvix.Compiler.Pipeline.Package
readGlobalPackageIO,
readGlobalPackage,
loadPackageFileIO,
packageBasePackage,
)
where
@ -167,3 +168,15 @@ writeGlobalPackage = do
packagePath <- globalPackageJuvix
ensureDir' (parent packagePath)
writeFile' packagePath (renderPackageVersion PackageVersion1 (globalPackage packagePath))
packageBasePackage :: Package
packageBasePackage =
Package
{ _packageVersion = defaultVersion,
_packageName = "package-base",
_packageMain = Nothing,
_packageLockfile = Nothing,
_packageFile = $(mkAbsFile "/<package-base>"),
_packageDependencies = [],
_packageBuildDir = Nothing
}

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

@ -37,11 +37,6 @@ acceptableTypes = mapM go packageDescriptionTypes
renderPackageVersion :: PackageVersion -> Package -> Text
renderPackageVersion v pkg = toPlainText (ppOutDefaultNoComments (toConcrete (getPackageType v) pkg))
getPackageType :: PackageVersion -> PackageDescriptionType
getPackageType = \case
PackageVersion1 -> v1PackageDescriptionType
PackageBasic -> basicPackageDescriptionType
-- | Load a package file in the context of the PackageDescription module and the global package stdlib.
loadPackage :: (Members '[Files, EvalFileEff, Error PackageLoaderError] r) => BuildDir -> Path Abs File -> Sem r Package
loadPackage buildDir packagePath = do

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

@ -149,7 +149,7 @@ loadPackage' packagePath = do
root =
Root
{ _rootRootDir = rootPath,
_rootPackageGlobal = False,
_rootPackageType = GlobalPackageDescription,
_rootPackage = rootPkg,
_rootInvokeDir = rootPath,
_rootBuildDir = DefaultBuildDir

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

@ -12,16 +12,28 @@ import Juvix.Extra.PackageFiles
import Juvix.Extra.Paths
import Juvix.Extra.Stdlib
data RootInfoDirs = RootInfoDirs
{ _rootInfoArgPackageDir :: Path Abs Dir,
_rootInfoArgPackageBaseDir :: Path Abs Dir,
_rootInfoArgGlobalStdlibDir :: Path Abs Dir
}
data RootInfoFiles = RootInfoFiles
{ _rootInfoFilesPackage :: HashSet (Path Rel File),
_rootInfoFilesPackageBase :: HashSet (Path Rel File)
}
makeLenses ''RootInfoDirs
makeLenses ''RootInfoFiles
-- | 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 '[TaggedLock, Files] r) => Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r a
runPackagePathResolver rootPath sem = do
globalStdlib <- juvixStdlibDir . rootBuildDir <$> globalRoot
globalPackageDir <- globalPackageDescriptionRoot
runReader globalStdlib updateStdlib
runReader globalPackageDir updatePackageFiles
packageFiles' <- relFiles globalPackageDir
let mkRootInfo' = mkRootInfo packageFiles' globalPackageDir globalStdlib
ds <- rootInfoDirs
initFiles ds
fs <- rootInfoFiles ds
let mkRootInfo' = mkRootInfo ds fs
( interpretH $ \case
RegisterDependencies {} -> pureT ()
ExpectedPathInfoTopModule m -> do
@ -41,27 +53,40 @@ runPackagePathResolver rootPath sem = do
)
sem
where
mkRootInfo :: HashSet (Path Rel File) -> Path Abs Dir -> Path Abs Dir -> Path Rel File -> Maybe RootInfo
mkRootInfo pkgFiles globalPackageDir globalStdlib relPath
| parent preludePath `isProperPrefixOf` relPath =
Just $
RootInfo
{ _rootInfoPath = globalStdlib,
_rootInfoKind = RootKindPackage
}
| relPath == packageFilePath =
Just $
RootInfo
{ _rootInfoPath = rootPath,
_rootInfoKind = RootKindPackage
}
| relPath `HashSet.member` pkgFiles =
Just $
RootInfo
{ _rootInfoPath = globalPackageDir,
_rootInfoKind = RootKindPackage
}
rootInfoDirs :: Sem r RootInfoDirs
rootInfoDirs = do
_rootInfoArgGlobalStdlibDir <- juvixStdlibDir . rootBuildDir <$> globalRoot
_rootInfoArgPackageDir <- globalPackageDescriptionRoot
_rootInfoArgPackageBaseDir <- globalPackageBaseRoot
return RootInfoDirs {..}
initFiles :: RootInfoDirs -> Sem r ()
initFiles ds = do
runReader (ds ^. rootInfoArgGlobalStdlibDir) updateStdlib
runReader (ds ^. rootInfoArgPackageDir) updatePackageFiles
runReader (ds ^. rootInfoArgPackageBaseDir) updatePackageBaseFiles
rootInfoFiles :: RootInfoDirs -> Sem r RootInfoFiles
rootInfoFiles ds = do
_rootInfoFilesPackage <- relFiles (ds ^. rootInfoArgPackageDir)
_rootInfoFilesPackageBase <- relFiles (ds ^. rootInfoArgPackageBaseDir)
return RootInfoFiles {..}
mkRootInfo :: RootInfoDirs -> RootInfoFiles -> Path Rel File -> Maybe RootInfo
mkRootInfo ds fs relPath
| parent preludePath `isProperPrefixOf` relPath = mkInfo (ds ^. rootInfoArgGlobalStdlibDir)
| relPath == packageFilePath = mkInfo rootPath
| relPath `HashSet.member` (fs ^. rootInfoFilesPackage) = mkInfo (ds ^. rootInfoArgPackageDir)
| relPath `HashSet.member` (fs ^. rootInfoFilesPackageBase) = mkInfo (ds ^. rootInfoArgPackageBaseDir)
| otherwise = Nothing
where
mkInfo :: Path Abs Dir -> Maybe RootInfo
mkInfo d =
Just $
RootInfo
{ _rootInfoPath = d,
_rootInfoKind = RootKindPackage
}
runPackagePathResolver' :: (Members '[TaggedLock, Files] r) => Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a)
runPackagePathResolver' root eff = do

497
src/Juvix/Compiler/Pipeline/Package/Loader/Versions.hs
View File

@ -14,7 +14,9 @@ import Juvix.Prelude
data PackageVersion
= PackageVersion1
| PackageVersion2
| PackageBasic
deriving stock (Bounded, Enum)
data PackageDescriptionType = PackageDescriptionType
{ _packageDescriptionTypePath :: Path Rel File,
@ -27,9 +29,15 @@ data PackageDescriptionType = PackageDescriptionType
makeLenses ''PackageDescriptionType
getPackageType :: PackageVersion -> PackageDescriptionType
getPackageType = \case
PackageVersion1 -> v1PackageDescriptionType
PackageVersion2 -> v2PackageDescriptionType
PackageBasic -> basicPackageDescriptionType
-- | The names of the Package type name in every version of the PackageDescription module
packageDescriptionTypes :: [PackageDescriptionType]
packageDescriptionTypes = [v1PackageDescriptionType, basicPackageDescriptionType]
packageDescriptionTypes = map getPackageType allElements
basicPackageDescriptionType :: PackageDescriptionType
basicPackageDescriptionType =
@ -57,13 +65,24 @@ basicPackageDescriptionType =
Sem r Package
toPackage buildDir f _ = return (emptyPackage buildDir f)
v2PackageDescriptionType :: PackageDescriptionType
v2PackageDescriptionType =
PackageDescriptionType
{ _packageDescriptionTypePath = v2PackageDescriptionFile,
_packageDescriptionTypeName = "Package",
_packageDescriptionTypeTransform = v1v2FromPackage,
_packageDescriptionTypeToPackage = v1v2ToPackage,
_packageDescriptionTypeNeedsStdlibImport = const False,
_packageDescriptionTypeVersion = PackageVersion2
}
v1PackageDescriptionType :: PackageDescriptionType
v1PackageDescriptionType =
PackageDescriptionType
{ _packageDescriptionTypePath = v1PackageDescriptionFile,
_packageDescriptionTypeName = "Package",
_packageDescriptionTypeTransform = fromPackage,
_packageDescriptionTypeToPackage = toPackage,
_packageDescriptionTypeTransform = v1v2FromPackage,
_packageDescriptionTypeToPackage = v1v2ToPackage,
_packageDescriptionTypeNeedsStdlibImport = needsStdlib,
_packageDescriptionTypeVersion = PackageVersion1
}
@ -73,246 +92,246 @@ v1PackageDescriptionType =
let SemVer {..} = p ^. packageVersion
in isJust _svMeta || isJust _svPreRel || isJust (p ^. packageMain) || isJust (p ^. packageBuildDir)
toPackage ::
forall r.
(Member (Error PackageLoaderError) r) =>
BuildDir ->
Path Abs File ->
Value ->
Sem r Package
toPackage buildDir packagePath = \case
ValueConstrApp ctor -> do
case ctor ^. constrAppArgs of
[vName, vVersion, vDeps, vMain, vBuildDir] -> do
_packageName <- toText vName
_packageMain <- toMaybeMain vMain
_packageBuildDir <- toMaybeBuildDir vBuildDir
_packageDependencies <- toList' toDependency vDeps
_packageVersion <- toVersion vVersion
return Package {_packageLockfile = Nothing, _packageFile = packagePath, ..}
_ -> err
v1v2FromPackage :: Package -> FunctionDefBody 'Parsed
v1v2FromPackage p = run . runReader l $ do
bodyExpression <-
maybeM
defaultPackageNoArgs
defaultPackageWithArgs
(nonEmpty <$> mkNamedArgs)
functionDefExpression bodyExpression
where
defaultPackageStr :: Text
defaultPackageStr = "defaultPackage"
defaultPackageNoArgs :: (Member (Reader Interval) r) => Sem r (NonEmpty (ExpressionAtom 'Parsed))
defaultPackageNoArgs = NEL.singleton <$> identifier defaultPackageStr
defaultPackageWithArgs :: (Member (Reader Interval) r) => NonEmpty (NamedArgument 'Parsed) -> Sem r (NonEmpty (ExpressionAtom 'Parsed))
defaultPackageWithArgs as = do
defaultPackageName' <- NameUnqualified <$> symbol defaultPackageStr
argBlock <- argumentBlock Implicit as
let defaultPackageArg = namedApplication defaultPackageName' (argBlock :| [])
return (defaultPackageArg :| [])
l :: Interval
l = singletonInterval (mkInitialLoc (p ^. packageFile))
mkNamedArgs :: forall r. (Member (Reader Interval) r) => Sem r [NamedArgument 'Parsed]
mkNamedArgs = do
catMaybes <$> sequence [mkNameArg, mkVersionArg, mkDependenciesArg, mkMainArg, mkBuildDirArg]
where
mkNameArg :: Sem r (Maybe (NamedArgument 'Parsed))
mkNameArg
| defaultPackageName == p ^. packageName = return Nothing
| otherwise = do
n <- literalString (p ^. packageName)
Just <$> namedArgument "name" (n :| [])
mkDependenciesArg :: Sem r (Maybe (NamedArgument 'Parsed))
mkDependenciesArg = do
let deps = p ^. packageDependencies
dependenciesArg = Just <$> mkDependenciesArg' (p ^. packageDependencies)
case deps of
[d] ->
if
| d == defaultStdlibDep DefaultBuildDir -> return Nothing
| otherwise -> dependenciesArg
_ -> dependenciesArg
where
mkDependenciesArg' :: [Dependency] -> Sem r (NamedArgument 'Parsed)
mkDependenciesArg' ds = do
deps <- mkList =<< mapM mkDependencyArg ds
namedArgument "dependencies" (deps :| [])
mkDependencyArg :: Dependency -> Sem r (NonEmpty (ExpressionAtom 'Parsed))
mkDependencyArg = \case
DependencyPath x ->
sequence
( identifier "path"
:| [literalString (pack (unsafePrepathToFilePath (x ^. pathDependencyPath)))]
)
DependencyGit x ->
sequence
( identifier "git"
:| ( literalString
<$> [ x ^. gitDependencyName,
x ^. gitDependencyUrl,
x ^. gitDependencyRef
]
)
)
mkMainArg :: Sem r (Maybe (NamedArgument 'Parsed))
mkMainArg = do
arg <- mapM mainArg (p ^. packageMain)
mapM (namedArgument "main") arg
where
mainArg :: Prepath File -> Sem r (NonEmpty (ExpressionAtom 'Parsed))
mainArg p' = mkJust =<< literalString (pack (unsafePrepathToFilePath p'))
mkBuildDirArg :: Sem r (Maybe (NamedArgument 'Parsed))
mkBuildDirArg = do
arg <- mapM buildDirArg (p ^. packageBuildDir)
mapM (namedArgument "buildDir") arg
where
buildDirArg :: SomeBase Dir -> Sem r (NonEmpty (ExpressionAtom 'Parsed))
buildDirArg d = mkJust =<< literalString (pack (fromSomeDir d))
mkVersionArg :: Sem r (Maybe (NamedArgument 'Parsed))
mkVersionArg
| p ^. packageVersion == defaultVersion = return Nothing
| otherwise = Just <$> mkVersionArg'
where
mkVersionArg' :: Sem r (NamedArgument 'Parsed)
mkVersionArg' = do
mkVersionArgs <- liftM2 (++) explicitArgs implicitArgs
mkVersionName <- identifier "mkVersion"
namedArgument "version" (mkVersionName :| mkVersionArgs)
explicitArgs :: Sem r [ExpressionAtom 'Parsed]
explicitArgs =
let SemVer {..} = p ^. packageVersion
in mapM literalInteger [_svMajor, _svMinor, _svPatch]
implicitArgs :: Sem r [ExpressionAtom 'Parsed]
implicitArgs = do
releaseArg' <- releaseArg
metaArg' <- metaArg
mapM
(>>= braced)
( case (releaseArg', metaArg') of
(Nothing, Nothing) -> []
(Nothing, Just ma) -> [mkNothing, mkJust ma]
(Just ra, Nothing) -> [mkJust ra]
(Just ra, Just ma) -> [mkJust ra, mkJust ma]
)
releaseArg :: Sem r (Maybe (ExpressionAtom 'Parsed))
releaseArg = let SemVer {..} = p ^. packageVersion in mapM mkReleaseArg _svPreRel
where
mkReleaseArg :: Release -> Sem r (ExpressionAtom 'Parsed)
mkReleaseArg = literalString . prettyRelease
prettyRelease :: Release -> Text
prettyRelease (Release cs) = T.intercalate "." . map prettyChunk $ NEL.toList cs
prettyChunk :: Chunk -> Text
prettyChunk (Numeric n) = show n
prettyChunk (Alphanum s) = s
metaArg :: Sem r (Maybe (ExpressionAtom 'Parsed))
metaArg = let SemVer {..} = p ^. packageVersion in mapM literalString _svMeta
mkJust :: ExpressionAtom 'Parsed -> Sem r (NonEmpty (ExpressionAtom 'Parsed))
mkJust a = do
justIdent <- identifier "just"
return (justIdent :| [a])
mkNothing :: Sem r (NonEmpty (ExpressionAtom 'Parsed))
mkNothing = do
nothingIdent <- identifier "nothing"
return (nothingIdent :| [])
v1v2ToPackage ::
forall r.
(Member (Error PackageLoaderError) r) =>
BuildDir ->
Path Abs File ->
Value ->
Sem r Package
v1v2ToPackage buildDir packagePath = \case
ValueConstrApp ctor -> do
case ctor ^. constrAppArgs of
[vName, vVersion, vDeps, vMain, vBuildDir] -> do
_packageName <- toText vName
_packageMain <- toMaybeMain vMain
_packageBuildDir <- toMaybeBuildDir vBuildDir
_packageDependencies <- toList' toDependency vDeps
_packageVersion <- toVersion vVersion
return Package {_packageLockfile = Nothing, _packageFile = packagePath, ..}
_ -> err
_ -> err
where
err :: Sem r a
err =
throw
PackageLoaderError
{ _packageLoaderErrorPath = packagePath,
_packageLoaderErrorCause = ErrPackageTypeError
}
toMaybe :: (Value -> Sem r a) -> Value -> Sem r (Maybe a)
toMaybe f = \case
ValueConstrApp c -> case c ^. constrAppArgs of
[] -> return Nothing
[v] -> Just <$> f v
_ -> err
_ -> err
toList' :: (Value -> Sem r a) -> Value -> Sem r [a]
toList' f = \case
ValueConstrApp c -> case c ^. constrAppArgs of
[] -> return []
[x, xs] -> do
v <- f x
vs <- toList' f xs
return (v : vs)
_ -> err
_ -> err
toText :: Value -> Sem r Text
toText = \case
ValueConstant (Core.ConstString s) -> return s
_ -> err
toInteger' :: Value -> Sem r Integer
toInteger' = \case
ValueConstant (Core.ConstInteger i) -> return i
_ -> err
toWord :: Value -> Sem r Word
toWord = fmap fromInteger . toInteger'
toMaybeMain :: Value -> Sem r (Maybe (Prepath File))
toMaybeMain = toMaybe (fmap (mkPrepath . unpack) . toText)
toMaybeBuildDir :: Value -> Sem r (Maybe (SomeBase Dir))
toMaybeBuildDir = toMaybe go
where
err :: Sem r a
err =
throw
PackageLoaderError
{ _packageLoaderErrorPath = packagePath,
_packageLoaderErrorCause = ErrPackageTypeError
}
go :: Value -> Sem r (SomeBase Dir)
go v = do
s <- unpack <$> toText v
let p :: Maybe (SomeBase Dir)
p = (Abs <$> parseAbsDir s) <|> (Rel <$> parseRelDir s)
maybe err return p
toMaybe :: (Value -> Sem r a) -> Value -> Sem r (Maybe a)
toMaybe f = \case
ValueConstrApp c -> case c ^. constrAppArgs of
[] -> return Nothing
[v] -> Just <$> f v
_ -> err
_ -> err
toVersion :: Value -> Sem r SemVer
toVersion = \case
ValueConstrApp c -> case c ^. constrAppArgs of
[vMaj, vMin, vPatch, _, vMeta] -> do
maj <- toWord vMaj
min' <- toWord vMin
patch' <- toWord vPatch
meta' <- toMaybe toText vMeta
return (SemVer maj min' patch' Nothing meta')
_ -> err
_ -> err
toList' :: (Value -> Sem r a) -> Value -> Sem r [a]
toList' f = \case
ValueConstrApp c -> case c ^. constrAppArgs of
[] -> return []
[x, xs] -> do
v <- f x
vs <- toList' f xs
return (v : vs)
_ -> err
_ -> err
toText :: Value -> Sem r Text
toText = \case
ValueConstant (Core.ConstString s) -> return s
_ -> err
toInteger' :: Value -> Sem r Integer
toInteger' = \case
ValueConstant (Core.ConstInteger i) -> return i
_ -> err
toWord :: Value -> Sem r Word
toWord = fmap fromInteger . toInteger'
toMaybeMain :: Value -> Sem r (Maybe (Prepath File))
toMaybeMain = toMaybe (fmap (mkPrepath . unpack) . toText)
toMaybeBuildDir :: Value -> Sem r (Maybe (SomeBase Dir))
toMaybeBuildDir = toMaybe go
where
go :: Value -> Sem r (SomeBase Dir)
go v = do
s <- unpack <$> toText v
let p :: Maybe (SomeBase Dir)
p = (Abs <$> parseAbsDir s) <|> (Rel <$> parseRelDir s)
maybe err return p
toVersion :: Value -> Sem r SemVer
toVersion = \case
ValueConstrApp c -> case c ^. constrAppArgs of
[vMaj, vMin, vPatch, _, vMeta] -> do
maj <- toWord vMaj
min' <- toWord vMin
patch' <- toWord vPatch
meta' <- toMaybe toText vMeta
return (SemVer maj min' patch' Nothing meta')
_ -> err
_ -> err
toDependency :: Value -> Sem r Dependency
toDependency = \case
ValueConstrApp c -> case c ^. constrAppArgs of
[] -> return (defaultStdlib buildDir)
[v] -> do
p <- mkPrepath . unpack <$> toText v
return (DependencyPath (PathDependency {_pathDependencyPath = p}))
[vName, vUrl, vRef] -> do
_gitDependencyUrl <- toText vUrl
_gitDependencyName <- toText vName
_gitDependencyRef <- toText vRef
return (DependencyGit (GitDependency {..}))
_ -> err
_ -> err
fromPackage :: Package -> FunctionDefBody 'Parsed
fromPackage p = run . runReader l $ do
bodyExpression <-
maybeM
defaultPackageNoArgs
defaultPackageWithArgs
(nonEmpty <$> mkNamedArgs)
functionDefExpression bodyExpression
where
defaultPackageStr :: Text
defaultPackageStr = "defaultPackage"
defaultPackageNoArgs :: (Member (Reader Interval) r) => Sem r (NonEmpty (ExpressionAtom 'Parsed))
defaultPackageNoArgs = NEL.singleton <$> identifier defaultPackageStr
defaultPackageWithArgs :: (Member (Reader Interval) r) => NonEmpty (NamedArgument 'Parsed) -> Sem r (NonEmpty (ExpressionAtom 'Parsed))
defaultPackageWithArgs as = do
defaultPackageName' <- NameUnqualified <$> symbol defaultPackageStr
argBlock <- argumentBlock Implicit as
let defaultPackageArg = namedApplication defaultPackageName' (argBlock :| [])
return (defaultPackageArg :| [])
l :: Interval
l = singletonInterval (mkInitialLoc (p ^. packageFile))
mkNamedArgs :: forall r. (Member (Reader Interval) r) => Sem r [NamedArgument 'Parsed]
mkNamedArgs = do
catMaybes <$> sequence [mkNameArg, mkVersionArg, mkDependenciesArg, mkMainArg, mkBuildDirArg]
where
mkNameArg :: Sem r (Maybe (NamedArgument 'Parsed))
mkNameArg
| defaultPackageName == p ^. packageName = return Nothing
| otherwise = do
n <- literalString (p ^. packageName)
Just <$> namedArgument "name" (n :| [])
mkDependenciesArg :: Sem r (Maybe (NamedArgument 'Parsed))
mkDependenciesArg = do
let deps = p ^. packageDependencies
dependenciesArg = Just <$> mkDependenciesArg' (p ^. packageDependencies)
case deps of
[d] ->
if
| d == defaultStdlibDep DefaultBuildDir -> return Nothing
| otherwise -> dependenciesArg
_ -> dependenciesArg
where
mkDependenciesArg' :: [Dependency] -> Sem r (NamedArgument 'Parsed)
mkDependenciesArg' ds = do
deps <- mkList =<< mapM mkDependencyArg ds
namedArgument "dependencies" (deps :| [])
mkDependencyArg :: Dependency -> Sem r (NonEmpty (ExpressionAtom 'Parsed))
mkDependencyArg = \case
DependencyPath x ->
sequence
( identifier "path"
:| [literalString (pack (unsafePrepathToFilePath (x ^. pathDependencyPath)))]
)
DependencyGit x ->
sequence
( identifier "git"
:| ( literalString
<$> [ x ^. gitDependencyName,
x ^. gitDependencyUrl,
x ^. gitDependencyRef
]
)
)
mkMainArg :: Sem r (Maybe (NamedArgument 'Parsed))
mkMainArg = do
arg <- mapM mainArg (p ^. packageMain)
mapM (namedArgument "main") arg
where
mainArg :: Prepath File -> Sem r (NonEmpty (ExpressionAtom 'Parsed))
mainArg p' = mkJust =<< literalString (pack (unsafePrepathToFilePath p'))
mkBuildDirArg :: Sem r (Maybe (NamedArgument 'Parsed))
mkBuildDirArg = do
arg <- mapM buildDirArg (p ^. packageBuildDir)
mapM (namedArgument "buildDir") arg
where
buildDirArg :: SomeBase Dir -> Sem r (NonEmpty (ExpressionAtom 'Parsed))
buildDirArg d = mkJust =<< literalString (pack (fromSomeDir d))
mkVersionArg :: Sem r (Maybe (NamedArgument 'Parsed))
mkVersionArg
| p ^. packageVersion == defaultVersion = return Nothing
| otherwise = Just <$> mkVersionArg'
where
mkVersionArg' :: Sem r (NamedArgument 'Parsed)
mkVersionArg' = do
mkVersionArgs <- liftM2 (++) explicitArgs implicitArgs
mkVersionName <- identifier "mkVersion"
namedArgument "version" (mkVersionName :| mkVersionArgs)
explicitArgs :: Sem r [ExpressionAtom 'Parsed]
explicitArgs =
let SemVer {..} = p ^. packageVersion
in mapM literalInteger [_svMajor, _svMinor, _svPatch]
implicitArgs :: Sem r [ExpressionAtom 'Parsed]
implicitArgs = do
releaseArg' <- releaseArg
metaArg' <- metaArg
mapM
(>>= braced)
( case (releaseArg', metaArg') of
(Nothing, Nothing) -> []
(Nothing, Just ma) -> [mkNothing, mkJust ma]
(Just ra, Nothing) -> [mkJust ra]
(Just ra, Just ma) -> [mkJust ra, mkJust ma]
)
releaseArg :: Sem r (Maybe (ExpressionAtom 'Parsed))
releaseArg = let SemVer {..} = p ^. packageVersion in mapM mkReleaseArg _svPreRel
where
mkReleaseArg :: Release -> Sem r (ExpressionAtom 'Parsed)
mkReleaseArg = literalString . prettyRelease
prettyRelease :: Release -> Text
prettyRelease (Release cs) = T.intercalate "." . map prettyChunk $ NEL.toList cs
prettyChunk :: Chunk -> Text
prettyChunk (Numeric n) = show n
prettyChunk (Alphanum s) = s
metaArg :: Sem r (Maybe (ExpressionAtom 'Parsed))
metaArg = let SemVer {..} = p ^. packageVersion in mapM literalString _svMeta
mkJust :: ExpressionAtom 'Parsed -> Sem r (NonEmpty (ExpressionAtom 'Parsed))
mkJust a = do
justIdent <- identifier "just"
return (justIdent :| [a])
mkNothing :: Sem r (NonEmpty (ExpressionAtom 'Parsed))
mkNothing = do
nothingIdent <- identifier "nothing"
return (nothingIdent :| [])
toDependency :: Value -> Sem r Dependency
toDependency = \case
ValueConstrApp c -> case c ^. constrAppArgs of
[] -> return (defaultStdlib buildDir)
[v] -> do
p <- mkPrepath . unpack <$> toText v
return (DependencyPath (PathDependency {_pathDependencyPath = p}))
[vName, vUrl, vRef] -> do
_gitDependencyUrl <- toText vUrl
_gitDependencyName <- toText vName
_gitDependencyRef <- toText vRef
return (DependencyGit (GitDependency {..}))
_ -> err
_ -> err
defaultStdlib :: BuildDir -> Dependency
defaultStdlib buildDir = mkPathDependency (fromSomeDir p)

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

@ -42,14 +42,24 @@ findRootAndChangeDir lockMode minputFileDir mbuildDir _rootInvokeDir = do
l <- findPackageFile
case l of
Nothing -> do
_rootPackage <- readGlobalPackageIO lockMode
_rootRootDir <- runM (runFilesIO globalRoot)
let _rootPackageGlobal = True
_rootBuildDir = getBuildDir mbuildDir
let cwd = fromMaybe _rootInvokeDir minputFileDir
packageBaseRootDir <- runM (runFilesIO globalPackageBaseRoot)
(_rootPackage, _rootRootDir, _rootPackageType) <-
if
| isPathPrefix packageBaseRootDir cwd ->
return (packageBasePackage, packageBaseRootDir, GlobalPackageBase)
| otherwise -> do
globalPkg <- readGlobalPackageIO lockMode
r <- runM (runFilesIO globalRoot)
return (globalPkg, r, GlobalStdlib)
let _rootBuildDir = getBuildDir mbuildDir
return Root {..}
Just yamlPath -> do
let _rootRootDir = parent yamlPath
_rootPackageGlobal = False
Just pkgPath -> do
packageDescriptionRootDir <- runM (runFilesIO globalPackageDescriptionRoot)
let _rootRootDir = parent pkgPath
_rootPackageType
| isPathPrefix packageDescriptionRootDir _rootRootDir = GlobalPackageDescription
| otherwise = LocalPackage
_rootBuildDir = getBuildDir mbuildDir
_rootPackage <- readPackageIO lockMode _rootRootDir _rootBuildDir
return Root {..}

9
src/Juvix/Compiler/Pipeline/Root/Base.hs
View File

@ -3,10 +3,17 @@ module Juvix.Compiler.Pipeline.Root.Base where
import Juvix.Compiler.Pipeline.Package.Base
import Juvix.Prelude
data PackageType
= GlobalStdlib
| GlobalPackageBase
| GlobalPackageDescription
| LocalPackage
deriving stock (Eq, Show)
data Root = Root
{ _rootRootDir :: Path Abs Dir,
_rootPackage :: Package,
_rootPackageGlobal :: Bool,
_rootPackageType :: PackageType,
_rootBuildDir :: BuildDir,
_rootInvokeDir :: Path Abs Dir
}

3
src/Juvix/Data/Effect/Files.hs
View File

@ -112,3 +112,6 @@ globalRoot = (<//> $(mkRelDir "global-project")) <$> juvixConfigDir
globalPackageDescriptionRoot :: (Members '[Files] r) => Sem r (Path Abs Dir)
globalPackageDescriptionRoot = (<//> $(mkRelDir "package")) <$> juvixConfigDir
globalPackageBaseRoot :: (Members '[Files] r) => Sem r (Path Abs Dir)
globalPackageBaseRoot = (<//> $(mkRelDir "package-base")) <$> juvixConfigDir

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

@ -9,8 +9,17 @@ import Juvix.Prelude
packageFiles :: [(Path Rel File, ByteString)]
packageFiles = juvixFiles $(packageDescriptionDirContents)
packageBaseFiles :: [(Path Rel File, ByteString)]
packageBaseFiles = juvixFiles $(packageBaseDirContents)
writePackageFiles :: forall r. (Members '[Reader OutputRoot, Files] r) => Sem r ()
writePackageFiles = writeFiles packageFiles
writePackageBaseFiles :: forall r. (Members '[Reader OutputRoot, Files] r) => Sem r ()
writePackageBaseFiles = writeFiles packageBaseFiles
updatePackageFiles :: (Members '[TaggedLock, Reader OutputRoot, Files] r) => Sem r ()
updatePackageFiles = updateFiles writePackageFiles
updatePackageBaseFiles :: (Members '[TaggedLock, Reader OutputRoot, Files] r) => Sem r ()
updatePackageBaseFiles = updateFiles writePackageBaseFiles

9
src/Juvix/Extra/Paths/Base.hs
View File

@ -29,6 +29,9 @@ stdlibDir = FE.makeRelativeToProject "juvix-stdlib" >>= FE.embedDir
packageDescriptionDirContents :: Q Exp
packageDescriptionDirContents = FE.makeRelativeToProject (toFilePath packageDescriptionDir) >>= FE.embedDir
packageBaseDirContents :: Q Exp
packageBaseDirContents = FE.makeRelativeToProject (toFilePath packageBaseDir) >>= FE.embedDir
juvixYamlFile :: Path Rel File
juvixYamlFile = $(mkRelFile "juvix.yaml")
@ -38,9 +41,15 @@ juvixLockfile = $(mkRelFile "juvix.lock.yaml")
packageDescriptionDir :: Path Rel Dir
packageDescriptionDir = $(mkRelDir "include/package")
packageBaseDir :: Path Rel Dir
packageBaseDir = $(mkRelDir "include/package-base")
v1PackageDescriptionFile :: Path Rel File
v1PackageDescriptionFile = $(mkRelFile "PackageDescription/V1.juvix")
v2PackageDescriptionFile :: Path Rel File
v2PackageDescriptionFile = $(mkRelFile "PackageDescription/V2.juvix")
basicPackageDescriptionFile :: Path Rel File
basicPackageDescriptionFile = $(mkRelFile "PackageDescription/Basic.juvix")

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

@ -6,6 +6,7 @@ module Juvix.Prelude.Path
)
where
import Data.List qualified as L
import Data.List.NonEmpty qualified as NonEmpty
import Juvix.Prelude.Base
import Juvix.Prelude.Path.OrphanInstances ()
@ -140,3 +141,8 @@ splitDrive (Path fp) =
-- Remove when we upgrade to path-0.9.5
dropDrive :: Path Abs t -> Maybe (Path Rel t)
dropDrive = snd . splitDrive
isPathPrefix :: Path b Dir -> Path b t -> Bool
isPathPrefix p1 p2 = case L.stripPrefix (toFilePath p1) (toFilePath p2) of
Nothing -> False
Just {} -> True

27
test/Package/Positive.hs
View File

@ -13,11 +13,14 @@ data PosTest = PosTest
_checkPackage :: Package -> BuildDir -> Maybe FailMsg
}
root :: Path Abs Dir
root = relToProject $(mkRelDir "tests/positive/PackageLoader")
v1Root :: Path Abs Dir
v1Root = relToProject $(mkRelDir "tests/positive/PackageLoader")
testDescr :: PosTest -> TestDescr
testDescr PosTest {..} =
v2Root :: Path Abs Dir
v2Root = relToProject $(mkRelDir "tests/positive/PackageLoaderV2")
testDescr :: Path Abs Dir -> PosTest -> TestDescr
testDescr root PosTest {..} =
let tRoot = root <//> _relDir
in TestDescr
{ _testName = _name,
@ -45,11 +48,13 @@ allTests :: TestTree
allTests =
testGroup
"Package loading positive tests"
( map (mkTest . testDescr) packageLoadingTests
( map (mkTest . testDescr v1Root) yamlTests
<> map (mkTest . testDescr v1Root) packageLoadingTests
<> map (mkTest . testDescr v2Root) packageLoadingTests
)
packageLoadingTests :: [PosTest]
packageLoadingTests =
yamlTests :: [PosTest]
yamlTests =
[ PosTest
"empty YAML is valid"
$(mkRelDir "YamlEmpty")
@ -72,8 +77,12 @@ packageLoadingTests =
$ \p _ ->
if
| null (p ^. packageDependencies) -> Nothing
| otherwise -> Just "Expected dependencies to be empty",
PosTest
| otherwise -> Just "Expected dependencies to be empty"
]
packageLoadingTests :: [PosTest]
packageLoadingTests =
[ PosTest
"Package.juvix is read"
$(mkRelDir "PackageJuvix")
$ \p _ ->

2
tests/Compilation/positive/test072/Package.juvix
View File

@ -1,5 +1,5 @@
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package := defaultPackage {name := "monads"};

2
tests/Internal/positive/Dependencies/Dep1/Package.juvix
View File

@ -1,6 +1,6 @@
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage {name := "dep1"; dependencies := []};

2
tests/Internal/positive/Dependencies/Dep2/Package.juvix
View File

@ -1,6 +1,6 @@
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage {name := "dep2"; dependencies := []};

2
tests/negative/NoDependencies/Package.juvix
View File

@ -1,5 +1,5 @@
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package := defaultPackage {dependencies := []};

3
tests/negative/Package/PackageJuvixDuplicateDependencies/Package.juvix
View File

@ -1,7 +1,6 @@
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package := defaultPackage {name := "abc"; version := mkVersion 0 0 1 ; dependencies := [ github "org" "repo" "ref1" ; github "org" "repo" "ref2" ]};

3
tests/negative/Package/PackageJuvixNoPackageSymbol/Package.juvix
View File

@ -1,6 +1,5 @@
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
abc : Nat := 1;

3
tests/negative/Package/PackageJuvixPackageSymbolWrongType1/Package.juvix
View File

@ -1,6 +1,5 @@
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Nat := 1;

2
tests/positive/Dependencies/.libs/Extra/Package.juvix
View File

@ -1,6 +1,6 @@
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage

2
tests/positive/Dependencies/Package.juvix
View File

@ -1,6 +1,6 @@
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage

2
tests/positive/FancyPaths/Package.juvix
View File

@ -1,6 +1,6 @@
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage

2
tests/positive/FancyPaths/home/Package.juvix
View File

@ -1,5 +1,5 @@
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package := defaultPackage {dependencies := []};

2
tests/positive/FancyPaths/other dep/Package.juvix
View File

@ -1,5 +1,5 @@
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package := defaultPackage {dependencies := []};

2
tests/positive/FancyPaths/path with spaces/Package.juvix
View File

@ -1,5 +1,5 @@
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package := defaultPackage {dependencies := []};

2
tests/positive/MarkdownImport/Package.juvix
View File

@ -1,6 +1,6 @@
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage {name := "MarkdownImport"};

2
tests/positive/NoDependencies/Package.juvix
View File

@ -1,5 +1,5 @@
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package := defaultPackage {dependencies := []};

6
tests/positive/PackageLoaderV2/PackageJuvix/Package.juvix Normal file
View File

@ -0,0 +1,6 @@
module Package;
import PackageDescription.V2 open;
package : Package :=
defaultPackage {name := "package-juvix"};

6
tests/positive/PackageLoaderV2/PackageJuvixAndYaml/Package.juvix Normal file
View File

@ -0,0 +1,6 @@
module Package;
import PackageDescription.V2 open;
package : Package :=
defaultPackage {name := "package-juvix"};

0
tests/positive/PackageLoaderV2/PackageJuvixAndYaml/juvix.yaml Normal file
View File

5
tests/positive/PackageLoaderV2/PackageJuvixBasic/Package.juvix Normal file
View File

@ -0,0 +1,5 @@
module Package;
import PackageDescription.Basic open;
package : Package := basicPackage;

7
tests/positive/PackageLoaderV2/PackageJuvixEmptyDependencies/Package.juvix Normal file
View File

@ -0,0 +1,7 @@
module Package;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
{name := "package-juvix"; dependencies := []};

5
tests/positive/PackageLoaderV2/PackageJuvixNoDependencies/Package.juvix Normal file
View File

@ -0,0 +1,5 @@
module Package;
import PackageDescription.Basic open;
package : Package := basicPackage;

9
tests/positive/PackageLoaderV2/PackageJuvixUsesLockfile/Package.juvix Normal file
View File

@ -0,0 +1,9 @@
module Package;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
{name := "abc";
version := mkVersion 0 0 0;
dependencies := [git "name" "url" "ref1"]};

6
tests/positive/PackageLoaderV2/PackageJuvixUsesLockfile/juvix.lock.yaml Normal file
View File

@ -0,0 +1,6 @@
dependencies:
- git:
url: url
name: name
ref: ref2
dependencies: []

2
tests/positive/StdlibList/Package.juvix
View File

@ -1,5 +1,5 @@
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package := defaultPackage {dependencies := []};

3
tests/positive/package/Package.juvix
View File

@ -1,7 +1,6 @@
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage

57
tests/smoke/Commands/compile-dependencies-package-juvix.smoke.yaml
View File

@ -34,8 +34,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -100,8 +99,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -170,8 +168,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -217,8 +214,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -279,8 +275,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -304,8 +299,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -420,8 +414,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -515,8 +508,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -548,8 +540,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -623,8 +614,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -661,8 +651,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -737,8 +726,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -775,8 +763,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -826,8 +813,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -873,8 +859,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -920,8 +905,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -989,8 +973,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -1042,8 +1025,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage
@ -1107,8 +1089,7 @@ tests:
-- juvix-package-version:1
module Package;
import Stdlib.Prelude open;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package :=
defaultPackage

5
tests/smoke/Commands/compile-dependencies.smoke.yaml
View File

@ -993,8 +993,7 @@ tests:
- bash
script: |
temp=$(mktemp -d)
# trap 'rm -rf -- "$temp"' EXIT
echo $temp
trap 'rm -rf -- "$temp"' EXIT
# create dependency
mkdir $temp/dep
@ -1022,7 +1021,7 @@ tests:
cat <<-EOF > Package.juvix
module Package;
import PackageDescription.V1 open;
import PackageDescription.V2 open;
package : Package := defaultPackage {dependencies := [defaultStdlib ; git "dep1" "$temp/dep" "main"]}
EOF

2
tests/smoke/Commands/typecheck.smoke.yaml
View File

@ -72,7 +72,7 @@ tests:
# side-effect: initializes the global project / the package package
globalPackageDir=$(juvix dev root)
packagePackageDir="$(dirname $globalPackageDir)"/package
juvix typecheck "$packagePackageDir/PackageDescription/V1.juvix"
juvix typecheck "$packagePackageDir/PackageDescription/V2.juvix"
stdout:
equals: "Well done! It type checks\n"
exit-status: 0