Add PackageDescription.Basic module Package variant (#2509)

This PR adds the `PackageDescription.Basic` module, available to
Package.juvix files.

```
module Package;

import PackageDescription.Basic open;

package : Package := basicPackage;
```

The `PackageDescription.Basic` module provides a Package type that is
translated to a Juvix Package with all default arguments. It is not
possible to customize a basic package.

A basic package does not depend on the standard library, so loads much
more quickly.

Additionally this PR:
* Adds `juvix init --basic/-b` option to generate a basic Package.juvix.
* Migrates Package.juvix files that only use default arguments, or only
customise the name field, to basic Package files.

* Closes #2508

app/Commands/Extra/Package.hs

@@ -9,10 +9,16 @@ import Juvix.Prelude
 renderPackage :: Package -> Text
 renderPackage = renderPackageVersion PackageVersion1
 
-writePackageFile :: (Member (Embed IO) r) => Path Abs Dir -> Package -> Sem r ()
-writePackageFile root pkg =
+writePackageFile' :: (Member (Embed IO) r) => PackageVersion -> Path Abs Dir -> Package -> Sem r ()
+writePackageFile' v root pkg =
   embed
     ( Utf8.writeFile @IO
         (toFilePath (root <//> packageFilePath))
-        (renderPackage pkg)
+        (renderPackageVersion v pkg)
     )
+
+writePackageFile :: (Member (Embed IO) r) => Path Abs Dir -> Package -> Sem r ()
+writePackageFile = writePackageFile' PackageVersion1
+
+writeBasicPackage :: (Member (Embed IO) r) => Path Abs Dir -> Sem r ()
+writeBasicPackage root = writePackageFile' PackageBasic root (emptyPackage DefaultBuildDir (root <//> packageFilePath))

app/Commands/Init.hs

@@ -24,27 +24,29 @@ ppErr = pack . errorBundlePretty
 init :: forall r. (Members '[Embed IO] r) => InitOptions -> Sem r ()
 init opts = do
   checkNotInProject
-  pkg <-
-    if
-        | isInteractive -> do
-            say "✨ Your next Juvix adventure is about to begin! ✨"
-            say "I will help you set it up"
-            getPackage
-        | otherwise -> do
-            cwd <- getCurrentDir
-            projectName <- getDefaultProjectName
-            let emptyPkg = emptyPackage DefaultBuildDir (cwd <//> packageFilePath)
-            return $ case projectName of
-              Nothing -> emptyPkg
-              Just n -> emptyPkg {_packageName = n}
-  when isInteractive (say ("creating " <> pack (toFilePath packageFilePath)))
   cwd <- getCurrentDir
-  writePackageFile cwd pkg
+  when isInteractive (say ("creating " <> pack (toFilePath packageFilePath)))
+  if
+      | opts ^. initOptionsBasic -> writeBasicPackage cwd
+      | otherwise -> do
+          pkg <-
+            if
+                | isInteractive -> do
+                    say "✨ Your next Juvix adventure is about to begin! ✨"
+                    say "I will help you set it up"
+                    getPackage
+                | otherwise -> do
+                    projectName <- getDefaultProjectName
+                    let emptyPkg = emptyPackage DefaultBuildDir (cwd <//> packageFilePath)
+                    return $ case projectName of
+                      Nothing -> emptyPkg
+                      Just n -> emptyPkg {_packageName = n}
+          writePackageFile cwd pkg
   checkPackage
   when isInteractive (say "you are all set")
   where
     isInteractive :: Bool
-    isInteractive = not (opts ^. initOptionsNonInteractive)
+    isInteractive = not (opts ^. initOptionsNonInteractive) && not (opts ^. initOptionsBasic)
 
 checkNotInProject :: forall r. (Members '[Embed IO] r) => Sem r ()
 checkNotInProject =

app/Commands/Init/Options.hs

@@ -2,8 +2,10 @@ module Commands.Init.Options where
 
 import CommonOptions
 
-newtype InitOptions = InitOptions
-  {_initOptionsNonInteractive :: Bool}
+data InitOptions = InitOptions
+  { _initOptionsNonInteractive :: Bool,
+    _initOptionsBasic :: Bool
+  }
   deriving stock (Data)
 
 makeLenses ''InitOptions
@@ -16,4 +18,10 @@ parseInitOptions = do
           <> short 'n'
           <> help "Run non-interactively. Generates a default Package.juvix"
       )
+  _initOptionsBasic <-
+    switch
+      ( long "basic"
+          <> short 'b'
+          <> help "Run non-interactively. Generates a basic Package.juvix that does not depend on the standard library"
+      )
   pure InitOptions {..}

include/package/PackageDescription/Basic.juvix

@@ -0,0 +1,15 @@
+module PackageDescription.Basic;
+
+--- A ;Package; defines the configuration for a Juvix package
+type Package :=
+  --- A package with the following settings:
+  ---
+  --- name: "my-project"
+  --- version: 0.0.0
+  --- dependencies: The default standard library
+  --- main: nothing
+  --- buildDir: nothing
+  ---
+  --- Use this in situations where you don't want the package configuration file
+  --- to use the standard library.
+  basicPackage;

src/Juvix/Compiler/Pipeline/Package/Loader.hs

@@ -5,13 +5,11 @@ module Juvix.Compiler.Pipeline.Package.Loader
 where
 
 import Data.FileEmbed qualified as FE
-import Data.Versions
 import Juvix.Compiler.Concrete.Gen
 import Juvix.Compiler.Concrete.Language
 import Juvix.Compiler.Concrete.Print (ppOutDefaultNoComments)
 import Juvix.Compiler.Concrete.Translation.FromSource hiding (symbol)
 import Juvix.Compiler.Core.Language qualified as Core
-import Juvix.Compiler.Core.Language.Value
 import Juvix.Compiler.Pipeline.Package.Base
 import Juvix.Compiler.Pipeline.Package.Loader.Error
 import Juvix.Compiler.Pipeline.Package.Loader.EvalEff
@@ -32,140 +30,36 @@ acceptableTypes = mapM go packageDescriptionTypes
       return
         TypeSpec
           { _typeSpecName = t ^. packageDescriptionTypeName,
-            _typeSpecFile = globalPackageDir <//> (t ^. packageDescriptionTypePath)
+            _typeSpecFile = globalPackageDir <//> (t ^. packageDescriptionTypePath),
+            _typeSpecVersion = t ^. packageDescriptionTypeVersion
           }
 
 renderPackageVersion :: PackageVersion -> Package -> Text
-renderPackageVersion v pkg = toPlainText (ppOutDefaultNoComments (toConcrete packageType pkg))
-  where
-    packageType :: PackageDescriptionType
-    packageType = case v of
-      PackageVersion1 -> v1PackageDescriptionType
+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
   scoped @(Path Abs File) @EvalEff packagePath $ do
-    v <- getPackageNode >>= eval'
-    toPackage buildDir packagePath v
+    (v, t) <- getPackageNode
+    ((getPackageType (t ^. typeSpecVersion)) ^. packageDescriptionTypeToPackage) buildDir packagePath =<< eval' v
   where
     -- Obtain the Node corresponding to the `package` identifier in the loaded
     -- Package
     --
     -- This function also checks that the type of the identifier is among the
     -- expected types from the specific PackageDescription modules that are
     -- provided by the PathResolver.
-    getPackageNode :: forall r. (Members '[Files, EvalEff] r) => Sem r Core.Node
+    getPackageNode :: forall r. (Members '[Files, EvalEff] r) => Sem r (Core.Node, TypeSpec)
     getPackageNode = do
       n <- lookupIdentifier Str.package
-      acceptableTypes >>= assertNodeType n
-      return n
-
-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
-  _ -> 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
-        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
-        [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 :: Dependency
-    defaultStdlib = mkPathDependency (fromSomeDir p)
-      where
-        p :: SomeBase Dir
-        p = resolveBuildDir buildDir <///> relStdlibDir
+      ty <- acceptableTypes >>= assertNodeType n
+      return (n, ty)
 
 toConcrete :: PackageDescriptionType -> Package -> Module 'Parsed 'ModuleTop
 toConcrete t p = run . runReader l $ do

src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff.hs

@@ -2,10 +2,12 @@ module Juvix.Compiler.Pipeline.Package.Loader.EvalEff where
 
 import Juvix.Compiler.Core.Language
 import Juvix.Compiler.Core.Language.Value
+import Juvix.Compiler.Pipeline.Package.Loader.Versions
 
 data TypeSpec = TypeSpec
   { _typeSpecName :: Text,
-    _typeSpecFile :: Path Abs File
+    _typeSpecFile :: Path Abs File,
+    _typeSpecVersion :: PackageVersion
   }
 
 makeLenses ''TypeSpec
@@ -14,7 +16,7 @@ data EvalEff m a where
   Eval' :: Node -> EvalEff m Value
   LookupIdentifier :: Text -> EvalEff m Node
   -- | Assert that the Node has a type given by one of the 'TypeSpec's
-  AssertNodeType :: (Foldable f) => Node -> f TypeSpec -> EvalEff m ()
+  AssertNodeType :: (Foldable f) => Node -> f TypeSpec -> EvalEff m TypeSpec
 
 makeSem ''EvalEff
 

src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs

@@ -87,14 +87,15 @@ runEvalFileEffIO = interpretScopedAs allocator handler
             packageLoc :: Interval
             packageLoc = singletonInterval (mkInitialLoc packagePath)
 
-        assertNodeType' :: (Foldable f) => Node -> f TypeSpec -> Sem r ()
+        assertNodeType' :: (Foldable f) => Node -> f TypeSpec -> Sem r TypeSpec
         assertNodeType' n tys = do
           evalN <- evalNode n
           case evalN of
             NCtr Constr {..} -> do
               let ci = Core.lookupConstructorInfo tab _constrTag
                   ii = Core.lookupInductiveInfo tab (ci ^. Core.constructorInductive)
-              unless (any (checkInductiveType ii) tys) err
+                  ty = find (checkInductiveType ii) tys
+              fromMaybeM err (return ty)
             _ -> err
           where
             err :: Sem r b