diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/CabalHelper/Compiletime/Compile.hs | 55 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Program/Stack.hs | 11 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Types.hs | 79 | ||||
| -rw-r--r-- | src/CabalHelper/Runtime/Main.hs | 11 |
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) |