From 8f3e134457e144f5f2487e01d38d5a62689aae29 Mon Sep 17 00:00:00 2001 From: Paul Cadman Date: Tue, 8 Aug 2023 18:46:16 +0100 Subject: [PATCH] Use a BuildDir type instead of Maybe to handle default build dir --- app/Commands/Init.hs | 2 +- .../FromParsed/Analysis/PathResolver.hs | 6 +-- src/Juvix/Compiler/Pipeline/Package.hs | 37 +++++++++++-------- src/Juvix/Compiler/Pipeline/Root.hs | 2 +- 4 files changed, 27 insertions(+), 20 deletions(-) diff --git a/app/Commands/Init.hs b/app/Commands/Init.hs index 91ef860536..1d1351c85a 100644 --- a/app/Commands/Init.hs +++ b/app/Commands/Init.hs @@ -50,7 +50,7 @@ getPackage = do _packageVersion = tversion, _packageBuildDir = Nothing, _packageMain = Nothing, - _packageDependencies = [defaultStdlibDep (Just (Rel relBuildDir))] + _packageDependencies = [defaultStdlibDep DefaultBuildDir] } getProjName :: forall r. (Members '[Embed IO] r) => Sem r Text diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs index 88507cf827..56891bbdb0 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs @@ -74,9 +74,9 @@ mkPackageInfo :: Sem r PackageInfo mkPackageInfo mpackageEntry _packageRoot = do let buildDir :: Path Abs Dir = maybe (rootBuildDir _packageRoot) (someBaseToAbs _packageRoot . (^. entryPointBuildDir)) mpackageEntry - buildDirDep :: Maybe (SomeBase Dir) - | isJust mpackageEntry = Just (Abs buildDir) - | otherwise = Nothing + buildDirDep :: BuildDir + | isJust mpackageEntry = CustomBuildDir (Abs buildDir) + | otherwise = DefaultBuildDir _packagePackage <- maybe (readPackage _packageRoot buildDirDep) (return . (^. entryPointPackage)) mpackageEntry let deps :: [Dependency] = _packagePackage ^. packageDependencies diff --git a/src/Juvix/Compiler/Pipeline/Package.hs b/src/Juvix/Compiler/Pipeline/Package.hs index 18d59e16cf..ef988889e5 100644 --- a/src/Juvix/Compiler/Pipeline/Package.hs +++ b/src/Juvix/Compiler/Pipeline/Package.hs @@ -1,5 +1,6 @@ module Juvix.Compiler.Pipeline.Package ( module Juvix.Compiler.Pipeline.Package.Dependency, + BuildDir (..), RawPackage, Package, Package' (..), @@ -95,13 +96,22 @@ instance FromJSON RawPackage where err :: a err = error "Failed to parse juvix.yaml" +data BuildDir + = DefaultBuildDir + | CustomBuildDir (SomeBase Dir) + +resolveBuildDir :: BuildDir -> SomeBase Dir +resolveBuildDir = \case + DefaultBuildDir -> Rel (relBuildDir) + CustomBuildDir d -> d + -- | This is used when juvix.yaml exists but it is empty -emptyPackage :: Maybe (SomeBase Dir) -> Package -emptyPackage mbuildDir = +emptyPackage :: BuildDir -> Package +emptyPackage buildDir = Package { _packageName = defaultPackageName, _packageVersion = defaultVersion, - _packageDependencies = [defaultStdlibDep mbuildDir], + _packageDependencies = [defaultStdlibDep buildDir], _packageMain = Nothing, _packageBuildDir = Nothing } @@ -116,10 +126,10 @@ rawPackage pkg = _packageMain = pkg ^. packageMain } -processPackage :: forall r. (Members '[Error Text] r) => Maybe (SomeBase Dir) -> RawPackage -> Sem r Package +processPackage :: forall r. (Members '[Error Text] r) => BuildDir -> RawPackage -> Sem r Package processPackage buildDir pkg = do let _packageName = fromMaybe defaultPackageName (pkg ^. packageName) - base :: SomeBase Dir = fromMaybe (Rel relBuildDir) buildDir relStdlibDir + base :: SomeBase Dir = (resolveBuildDir buildDir) relStdlibDir stdlib = Dependency (mkPrepath (fromSomeDir base)) _packageDependencies = fromMaybe [stdlib] (pkg ^. packageDependencies) _packageVersion <- getVersion @@ -137,11 +147,8 @@ processPackage buildDir pkg = do Right v -> return v Left err -> throw (pack (errorBundlePretty err)) -defaultStdlibDep :: Maybe (SomeBase Dir) -> Dependency -defaultStdlibDep mbuildDir = Dependency (mkPrepath (fromSomeDir (buildDir relStdlibDir))) - where - buildDir :: SomeBase Dir - buildDir = fromMaybe (Rel relBuildDir) mbuildDir +defaultStdlibDep :: BuildDir -> Dependency +defaultStdlibDep buildDir = Dependency (mkPrepath (fromSomeDir (resolveBuildDir buildDir relStdlibDir))) defaultPackageName :: Text defaultPackageName = "my-project" @@ -152,7 +159,7 @@ defaultVersion = SemVer 0 0 0 [] Nothing globalPackage :: Package globalPackage = Package - { _packageDependencies = [defaultStdlibDep Nothing], + { _packageDependencies = [defaultStdlibDep DefaultBuildDir], _packageName = "global-juvix-package", _packageVersion = defaultVersion, _packageMain = Nothing, @@ -164,7 +171,7 @@ readPackage :: forall r. (Members '[Files, Error Text] r) => Path Abs Dir -> - Maybe (SomeBase Dir) -> + BuildDir -> Sem r Package readPackage root buildDir = do bs <- readFileBS' yamlPath @@ -174,10 +181,10 @@ readPackage root buildDir = do where yamlPath = root juvixYamlFile -readPackageIO :: Path Abs Dir -> SomeBase Dir -> IO Package +readPackageIO :: Path Abs Dir -> BuildDir -> IO Package readPackageIO root buildDir = do let x :: Sem '[Error Text, Files, Embed IO] Package - x = readPackage root (Just buildDir) + x = readPackage root buildDir m <- runM $ runFilesIO (runError x) case m of Left err -> putStrLn err >> exitFailure @@ -194,7 +201,7 @@ readGlobalPackage :: Members '[Error Text, Files] r => Sem r Package readGlobalPackage = do yamlPath <- globalYaml unlessM (fileExists' yamlPath) writeGlobalPackage - readPackage (parent yamlPath) Nothing + readPackage (parent yamlPath) DefaultBuildDir writeGlobalPackage :: Members '[Files] r => Sem r () writeGlobalPackage = do diff --git a/src/Juvix/Compiler/Pipeline/Root.hs b/src/Juvix/Compiler/Pipeline/Root.hs index 5de86b1feb..1ecbfddee5 100644 --- a/src/Juvix/Compiler/Pipeline/Root.hs +++ b/src/Juvix/Compiler/Pipeline/Root.hs @@ -49,7 +49,7 @@ findRootAndChangeDir minputFileDir mbuildDir _rootsInvokeDir = do let _rootsRootDir = parent yamlPath _rootsPackageGlobal = False _rootsBuildDir = getBuildDir mbuildDir _rootsRootDir - _rootsPackage <- readPackageIO _rootsRootDir (Abs _rootsBuildDir) + _rootsPackage <- readPackageIO _rootsRootDir (CustomBuildDir (Abs _rootsBuildDir)) return Roots {..} getBuildDir :: Maybe (Path Abs Dir) -> Path Abs Dir -> Path Abs Dir