aboutsummaryrefslogtreecommitdiff
path: root/src/CabalHelper
diff options
context:
space:
mode:
authorDaniel Gröber <dxld@darkboxed.org>2018-10-22 01:20:25 +0200
committerDaniel Gröber <dxld@darkboxed.org>2018-10-27 20:48:56 +0200
commit069225e2e61562c8166a446d201457425b91ce57 (patch)
treeac9ef1123d7b7024f932a16fa67abda283d84153 /src/CabalHelper
parente91d57a4655d69b306190506c488450f42391fb3 (diff)
Refactor Unit handling
Diffstat (limited to 'src/CabalHelper')
-rw-r--r--src/CabalHelper/Compiletime/Compile.hs55
-rw-r--r--src/CabalHelper/Compiletime/Program/Stack.hs11
-rw-r--r--src/CabalHelper/Compiletime/Types.hs79
-rw-r--r--src/CabalHelper/Runtime/Main.hs11
4 files changed, 89 insertions, 67 deletions
diff --git a/src/CabalHelper/Compiletime/Compile.hs b/src/CabalHelper/Compiletime/Compile.hs
index 3126128..3f8a771 100644
--- a/src/CabalHelper/Compiletime/Compile.hs
+++ b/src/CabalHelper/Compiletime/Compile.hs
@@ -96,18 +96,19 @@ data CompPaths = CompPaths
-- executable.
data CompilationProductScope = CPSGlobal | CPSProject
-compileHelper
- :: Env
- => Version
- -> Maybe PackageDbDir
- -> FilePath
- -> Maybe (PlanJson, FilePath)
- -> FilePath
- -> IO (Either ExitCode FilePath)
-compileHelper hdrCabalVersion cabalPkgDb projdir mnewstyle cachedir = do
+data CompHelperEnv = CompHelperEnv
+ { cheCabalVer :: Version
+ , chePkgDb :: Maybe PackageDbDir
+ , cheProjDir :: FilePath
+ , cheNewstyle :: Maybe (PlanJson, FilePath)
+ , cheCacheDir :: FilePath
+ }
+
+compileHelper :: Env => CompHelperEnv -> IO (Either ExitCode FilePath)
+compileHelper CompHelperEnv{..} = do
ghcVer <- ghcVersion
Just (prepare, comp) <- runMaybeT $ msum $
- case cabalPkgDb of
+ case chePkgDb of
Nothing ->
[ compileCabalSource
, compileNewBuild ghcVer
@@ -116,12 +117,12 @@ compileHelper hdrCabalVersion cabalPkgDb projdir mnewstyle cachedir = do
, MaybeT $ Just <$> compileWithCabalInPrivatePkgDb
]
Just db ->
- [ pure $ (pure (), compileWithPkg (Just db) hdrCabalVersion CPSProject)
+ [ pure $ (pure (), compileWithPkg (Just db) cheCabalVer CPSProject)
]
appdir <- appCacheDir
- let cp@CompPaths {compExePath} = compPaths appdir cachedir comp
+ let cp@CompPaths {compExePath} = compPaths appdir cheCacheDir comp
exists <- doesFileExist compExePath
if exists
then do
@@ -134,32 +135,32 @@ compileHelper hdrCabalVersion cabalPkgDb projdir mnewstyle cachedir = do
where
logMsg = "using helper compiled with Cabal from "
--- for relaxed deps: find (sameMajorVersionAs hdrCabalVersion) . reverse . sort
+-- for relaxed deps: find (sameMajorVersionAs cheCabalVer) . reverse . sort
-- | Check if this version is globally available
compileGlobal :: Env => MaybeT IO (IO (), Compile)
compileGlobal = do
cabal_versions <- listCabalVersions' Nothing
- ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions
+ ver <- MaybeT $ return $ find (== cheCabalVer) cabal_versions
vLog $ logMsg ++ "user/global package-db"
return $ (return (), compileWithPkg Nothing ver CPSGlobal)
-- | Check if this version is available in the project sandbox
compileSandbox :: Env => Version -> MaybeT IO (IO (), Compile)
compileSandbox ghcVer = do
- let mdb_path = getSandboxPkgDb (display buildPlatform) ghcVer projdir
+ let mdb_path = getSandboxPkgDb (display buildPlatform) ghcVer cheProjDir
sandbox <- PackageDbDir <$> MaybeT mdb_path
cabal_versions <- listCabalVersions' (Just sandbox)
- ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions
+ ver <- MaybeT $ return $ find (== cheCabalVer) cabal_versions
vLog $ logMsg ++ "sandbox package-db"
return $ (return (), compileWithPkg (Just sandbox) ver CPSProject)
compileNewBuild :: Env => Version -> MaybeT IO (IO (), Compile)
compileNewBuild ghcVer = do
- (PlanJson {pjUnits}, distdir_newstyle) <- maybe mzero pure mnewstyle
+ (PlanJson {pjUnits}, distdir_newstyle) <- maybe mzero pure cheNewstyle
let cabal_pkgid =
PkgId (PkgName (Text.pack "Cabal"))
- (Ver $ versionBranch hdrCabalVersion)
+ (Ver $ versionBranch cheCabalVer)
mcabal_unit = listToMaybe $
Map.elems $ Map.filter (\CP.Unit{..} -> uPId == cabal_pkgid) pjUnits
CP.Unit {} <- maybe mzero pure mcabal_unit
@@ -167,7 +168,7 @@ compileHelper hdrCabalVersion cabalPkgDb projdir mnewstyle cachedir = do
</> "packagedb" </> ("ghc-" ++ showVersion ghcVer)
inplace_db = PackageDbDir inplace_db_path
cabal_versions <- listCabalVersions' (Just inplace_db)
- ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions
+ ver <- MaybeT $ return $ find (== cheCabalVer) cabal_versions
vLog $ logMsg ++ "v2-build package-db " ++ inplace_db_path
return $ (return (), compileWithPkg (Just inplace_db) ver CPSProject)
@@ -176,22 +177,22 @@ compileHelper hdrCabalVersion cabalPkgDb projdir mnewstyle cachedir = do
compileWithCabalInPrivatePkgDb :: Env => IO (IO (), Compile)
compileWithCabalInPrivatePkgDb = do
db@(PackageDbDir db_path)
- <- getPrivateCabalPkgDb (CabalVersion hdrCabalVersion)
+ <- getPrivateCabalPkgDb (CabalVersion cheCabalVer)
vLog $ logMsg ++ "private package-db in " ++ db_path
- return (prepare db, compileWithPkg (Just db) hdrCabalVersion CPSGlobal)
+ return (prepare db, compileWithPkg (Just db) cheCabalVer CPSGlobal)
where
prepare db = do
- db_exists <- liftIO $ cabalVersionExistsInPkgDb hdrCabalVersion db
+ db_exists <- liftIO $ cabalVersionExistsInPkgDb cheCabalVer db
when (not db_exists) $
- void $ installCabal (Right hdrCabalVersion) `E.catch`
- \(SomeException _) -> errorInstallCabal hdrCabalVersion
+ void $ installCabal (Right cheCabalVer) `E.catch`
+ \(SomeException _) -> errorInstallCabal cheCabalVer
-- | See if we're in a cabal source tree
compileCabalSource :: Env => MaybeT IO (IO (), Compile)
compileCabalSource = do
- let cabalFile = projdir </> "Cabal.cabal"
+ let cabalFile = cheProjDir </> "Cabal.cabal"
cabalSrc <- liftIO $ doesFileExist cabalFile
- let projdir' = CabalSourceDir projdir
+ let projdir = CabalSourceDir cheProjDir
case cabalSrc of
False -> mzero
True -> do
@@ -206,7 +207,7 @@ compileHelper hdrCabalVersion cabalPkgDb projdir mnewstyle cachedir = do
mzero
"custom" -> do
vLog $ "compiling helper with local Cabal source tree"
- return $ (return (), compileWithCabalSource projdir' ver)
+ return $ (return (), compileWithCabalSource projdir ver)
_ -> error $ "compileCabalSource: unknown build-type: '"++buildType++"'"
compileWithCabalSource srcDir ver =
diff --git a/src/CabalHelper/Compiletime/Program/Stack.hs b/src/CabalHelper/Compiletime/Program/Stack.hs
index 4751f0a..e7f280d 100644
--- a/src/CabalHelper/Compiletime/Program/Stack.hs
+++ b/src/CabalHelper/Compiletime/Program/Stack.hs
@@ -37,14 +37,15 @@ import CabalHelper.Compiletime.Types
import CabalHelper.Compiletime.Types.RelativePath
getUnit :: QueryEnvI c 'Stack -> CabalFile -> IO Unit
-getUnit qe (CabalFile cabal_file) = do
- let pkgdir = takeDirectory cabal_file
- let pkg_name = dropExtension $ takeFileName cabal_file
+getUnit qe cabal_file@(CabalFile cabal_file_path) = do
+ let pkgdir = takeDirectory cabal_file_path
+ let pkg_name = dropExtension $ takeFileName cabal_file_path
look <- paths qe pkgdir
let distdirv1 = look "dist-dir:"
return $ Unit
{ uUnitId = UnitId pkg_name
, uPackageDir = pkgdir
+ , uCabalFile = cabal_file
, uDistDir = DistDirLib distdirv1
}
@@ -57,7 +58,7 @@ packageDistDir qe pkgdir = do
return $ look "dist-dir:"
projPaths :: QueryEnvI c 'Stack -> IO StackProjPaths
-projPaths qe@QueryEnv {qeProjectDir=ProjDirStack projdir} = do
+projPaths qe@QueryEnv {qeProjLoc=ProjLocStackDir projdir} = do
look <- paths qe projdir
return StackProjPaths
{ sppGlobalPkgDb = PackageDbDir $ look "global-pkg-db:"
@@ -76,7 +77,7 @@ paths qe dir = do
split l = let (key, ' ' : val) = span (not . isSpace) l in (key, val)
listPackageCabalFiles :: QueryEnvI c 'Stack -> IO [CabalFile]
-listPackageCabalFiles qe@QueryEnv{qeProjectDir=ProjDirStack projdir} = do
+listPackageCabalFiles qe@QueryEnv{qeProjLoc=ProjLocStackDir projdir} = do
out <- qeReadProcess qe (Just projdir) (stackProgram $ qePrograms qe)
[ "ide", "packages", "--cabal-files" ] ""
return $ map CabalFile $ lines out
diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs
index e803ae6..cc8561f 100644
--- a/src/CabalHelper/Compiletime/Types.hs
+++ b/src/CabalHelper/Compiletime/Types.hs
@@ -33,6 +33,7 @@ import Data.Version
import Data.Typeable
import Data.Map.Strict (Map)
import GHC.Generics
+import System.FilePath
import System.Posix.Types
import CabalHelper.Compiletime.Types.RelativePath
import CabalHelper.Shared.InterfaceTypes
@@ -44,23 +45,27 @@ data ProjType
| V2 -- ^ @cabal v2-build@ project, see 'DistDirV2'
| Stack -- ^ @stack@ project.
--- | A project directory. The project type of a given directory can be
--- determined by trying to access a set of marker files. See below.
-data ProjDir (pt :: ProjType) where
+-- | The location of a project. The kind of location marker given determines the
+-- 'ProjType'. The project type of a given directory can be determined by trying
+-- to access a set of marker files. See below.
+data ProjLoc (pt :: ProjType) where
-- | A @cabal v1-build@ project directory can be identified by one file
-- ending in @.cabal@ existing in the directory. More than one such files
-- existing is a user error. Note: For this project type the concepts of
-- project and package coincide.
- ProjDirV1 :: FilePath -> ProjDir 'V1
+ ProjLocCabalFile :: { plCabalFile :: FilePath } -> ProjLoc 'V1
-- | A @cabal v2-build@ project\'s marker file is called
-- @cabal.project@. This configuration file points to the packages that make
-- up this project.
- ProjDirV2 :: FilePath -> ProjDir 'V2
+ ProjLocV2Dir :: { plV2Dir :: FilePath } -> ProjLoc 'V2
-- | A @stack@ project\'s marker file is called @stack.yaml@. This
-- configuration file points to the packages that make up this project.
- ProjDirStack :: FilePath -> ProjDir 'Stack
+ ProjLocStackDir :: { plStackDir :: FilePath } -> ProjLoc 'Stack
+
+plV1Dir :: ProjLoc 'V1 -> FilePath
+plV1Dir (ProjLocCabalFile cabal_file) = takeDirectory cabal_file
data DistDir (pt :: ProjType) where
-- | Build directory for cabal /old-build/ aka. /v1-build/ aka. just
@@ -99,7 +104,7 @@ data QueryEnvI cache (proj_type :: ProjType) = QueryEnv
, qePrograms :: Programs
-- ^ Field accessor for 'QueryEnv'.
- , qeProjectDir :: ProjDir proj_type
+ , qeProjLoc :: !(ProjLoc proj_type)
-- ^ Field accessor for 'QueryEnv'. Defines path to the project directory,
-- i.e. a directory containing a @cabal.project@ file
@@ -135,6 +140,7 @@ newtype DistDirLib = DistDirLib FilePath
data Unit = Unit
{ uUnitId :: !UnitId
, uPackageDir :: !FilePath
+ , uCabalFile :: !CabalFile
, uDistDir :: !DistDirLib
}
@@ -173,32 +179,47 @@ data UnitInfo = UnitInfo
, uiModTimes :: !UnitModTimes
} deriving (Eq, Ord, Read, Show)
-data ProjInfo pt where
- ProjInfoV1 ::
- { piV1ProjConfModTimes :: !(ProjConfModTimes 'V1)
- } -> ProjInfo 'V1
+-- | Files relevant to the project-scope configuration of a project. We gather
+-- them here so we can refer to their paths conveniently.
+data ProjConf pt where
+ ProjConfV1 ::
+ { pcV1CabalFile :: !FilePath
+ } -> ProjConf 'V1
+
+ ProjConfV2 ::
+ { pcV2CabalProjFile :: !FilePath
+ , pcV2CabalProjLocalFile :: !FilePath
+ , pcV2CabalProjFreezeFile :: !FilePath
+ } -> ProjConf 'V2
+
+ ProjConfStack ::
+ { pcStackYaml :: !FilePath
+ } -> ProjConf 'Stack
+
+-- these are supposed to be opaque, as they are meant to be used only for cache
+-- invalidation
+newtype ProjConfModTimes = ProjConfModTimes [(FilePath, EpochTime)]
+ deriving (Eq)
+
+data ProjInfo pt = ProjInfo
+ { piCabalVersion :: !Version
+ , piProjConfModTimes :: !ProjConfModTimes
+ , piUnits :: ![Unit]
+ , piImpl :: !(ProjInfoImpl pt)
+ }
+
+data ProjInfoImpl pt where
+ ProjInfoV1 :: ProjInfoImpl 'V1
ProjInfoV2 ::
- { piV2ProjConfModTimes :: !(ProjConfModTimes 'V2)
- , piV2Plan :: !PlanJson
- , piV2PlanModTime :: !EpochTime
- } -> ProjInfo 'V2
+ { piV2Plan :: !PlanJson
+ , piV2PlanModTime :: !EpochTime
+ , piV2CompilerId :: !(String, Version)
+ } -> ProjInfoImpl 'V2
ProjInfoStack ::
- { piStackProjConfModTimes :: !(ProjConfModTimes 'Stack)
- , piStackUnits :: ![Unit]
- , piStackProjPaths :: !StackProjPaths
- } -> ProjInfo 'Stack
-
-data ProjConfModTimes pt where
- ProjConfModTimesV1
- :: !(FilePath, EpochTime) -> ProjConfModTimes 'V1
- ProjConfModTimesV2
- :: !([(FilePath, EpochTime)]) -> ProjConfModTimes 'V2
- ProjConfModTimesStack
- :: !(FilePath, EpochTime) -> ProjConfModTimes 'Stack
-
-deriving instance Eq (ProjConfModTimes pt)
+ { piStackProjPaths :: !StackProjPaths
+ } -> ProjInfoImpl 'Stack
data UnitModTimes = UnitModTimes
{ umtCabalFile :: !(FilePath, EpochTime)
diff --git a/src/CabalHelper/Runtime/Main.hs b/src/CabalHelper/Runtime/Main.hs
index d0eea1a..70a0cc5 100644
--- a/src/CabalHelper/Runtime/Main.hs
+++ b/src/CabalHelper/Runtime/Main.hs
@@ -263,20 +263,19 @@ main :: IO ()
main = do
args <- getArgs
- projdir:distdir:args' <- case args of
- [] -> usage >> exitFailure
- _ -> return args
+ cfile : distdir : args'
+ <- case args of
+ [] -> usage >> exitFailure
+ _ -> return args
ddexists <- doesDirectoryExist distdir
when (not ddexists) $ do
errMsg $ "distdir '"++distdir++"' does not exist"
exitFailure
- [cfile] <- filter isCabalFile <$> getDirectoryContents projdir
-
v <- maybe silent (const deafening) . lookup "CABAL_HELPER_DEBUG" <$> getEnvironment
lbi <- unsafeInterleaveIO $ getPersistBuildConfig distdir
- gpd <- unsafeInterleaveIO $ readPackageDescription v (projdir </> cfile)
+ gpd <- unsafeInterleaveIO $ readPackageDescription v cfile
let pd = localPkgDescr lbi
let lvd = (lbi, v, distdir)