Refactor Unit handling

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)