Split SProjType along build-tool line

This makes it much easier to deal with differences between the build tools
as we can now have functions that only make sense for Cabal and statically
enforce this by passing a 'SCabalProjType pt' as evidence that $pt \in {V1,
V2}$.

5 files changed, 60 insertions, 43 deletions

diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs
index d9c9285..b72fd2a 100644
--- a/lib/Distribution/Helper.hs
+++ b/lib/Distribution/Helper.hs
@@ -65,10 +65,13 @@ module Distribution.Helper (
 
   -- * GADTs
   , ProjType(..)
-  , SProjType(..)
-  , demoteSProjType
   , ProjLoc(..)
   , DistDir(..)
+  , SProjType(..)
+  , demoteSProjType
+  , projTypeOfDistDir
+  , projTypeOfProjLoc
+  , SCabalProjType(..)
   , Ex(..)
 
   -- * Programs
@@ -373,18 +376,18 @@ discardInactiveUnitInfos active_units uis0 =
 shallowReconfigureProject :: QueryEnvI c pt -> IO ()
 shallowReconfigureProject QueryEnv
   { qeProjLoc = _
-  , qeDistDir = DistDirV1 _distdirv1 } =
+  , qeDistDir = DistDirCabal SCV1 _distdirv1 } =
     return ()
 shallowReconfigureProject QueryEnv
   { qeProjLoc = ProjLocV2File projfile
-  , qeDistDir = DistDirV2 _distdirv2, .. } = do
+  , qeDistDir = DistDirCabal SCV2 _distdirv2, .. } = do
     let projdir = takeDirectory projfile
     _ <- qeCallProcess (Just projdir) (cabalProgram qePrograms)
            ["new-build", "--dry-run", "--project-file="++projfile, "all"]
     return ()
 shallowReconfigureProject QueryEnv
   { qeProjLoc = ProjLocV2Dir projdir
-  , qeDistDir = DistDirV2 _distdirv2, .. } = do
+  , qeDistDir = DistDirCabal SCV2 _distdirv2, .. } = do
     _ <- qeCallProcess (Just projdir) (cabalProgram qePrograms)
            ["new-build", "--dry-run", "all"]
     return ()
@@ -398,7 +401,7 @@ shallowReconfigureProject QueryEnv
     return ()
 
 reconfigureUnit :: QueryEnvI c pt -> Unit pt -> IO ()
-reconfigureUnit QueryEnv{qeDistDir=DistDirV1{}, ..} Unit{uPackageDir=_} = do
+reconfigureUnit QueryEnv{qeDistDir=(DistDirCabal SCV1 _), ..} Unit{uPackageDir=_} = do
   return ()
 reconfigureUnit
   QueryEnv{qeProjLoc=ProjLocV2File projfile, ..}
@@ -434,8 +437,7 @@ readProjInfo
 readProjInfo qe pc pcm = withVerbosity $ do
   let projloc = qeProjLoc qe
   case (qeDistDir qe, pc) of
-    (DistDirV1 distdir, ProjConfV1{pcV1CabalFile}) -> do
-      let pkgdir = plV1Dir projloc
+    (DistDirCabal SCV1 distdir, ProjConfV1{pcV1CabalFile}) -> do
       setup_config_path <- canonicalizePath (distdir </> "setup-config")
       mhdr <- readSetupConfigHeader setup_config_path
       case mhdr of
@@ -445,7 +447,7 @@ readProjInfo qe pc pcm = withVerbosity $ do
             , piProjConfModTimes = pcm
             , piUnits = (:|[]) $ Unit
               { uUnitId = UnitId ""
-              , uPackageDir = pkgdir
+              , uPackageDir = plV1Dir projloc
               , uCabalFile = CabalFile pcV1CabalFile
               , uDistDir = DistDirLib distdir
               , uImpl = UnitImplV1
@@ -460,7 +462,7 @@ readProjInfo qe pc pcm = withVerbosity $ do
         Nothing ->
           panicIO $ printf "Could not read '%s' header" setup_config_path
 
-    (DistDirV2 distdirv2, _) -> do
+    (DistDirCabal SCV2 distdirv2, _) -> do
       let plan_path = distdirv2 </> "cache" </> "plan.json"
       plan_mtime <- modificationTime <$> getFileStatus plan_path
       plan@PlanJson { pjCabalLibVersion=Ver pjCabalLibVersion
@@ -673,7 +675,7 @@ mkCompHelperEnv
     -> CompHelperEnv
 mkCompHelperEnv
   projloc
-  (DistDirV1 distdir)
+  (DistDirCabal SCV1 distdir)
   ProjInfo{piCabalVersion}
   = CompHelperEnv
     { cheCabalVer = CabalVersion piCabalVersion
@@ -685,7 +687,7 @@ mkCompHelperEnv
     }
 mkCompHelperEnv
   projloc
-  (DistDirV2 distdir)
+  (DistDirCabal SCV2 distdir)
   ProjInfo{piImpl=ProjInfoV2{piV2Plan=plan}}
   = case projloc of
       ProjLocV2Dir projdir ->
diff --git a/lib/Distribution/Helper/Discover.hs b/lib/Distribution/Helper/Discover.hs
index 635474d..b074261 100644
--- a/lib/Distribution/Helper/Discover.hs
+++ b/lib/Distribution/Helper/Discover.hs
@@ -56,11 +56,11 @@ findProjects dir = execWriterT $ do
     liftIO (findCabalFiles dir)
 
 findDistDirs (ProjLocV1CabalFile cabal _) =
-  [DistDirV1 $ replaceFileName cabal "dist/"]
-findDistDirs (ProjLocV1Dir dir) = [DistDirV1 $ dir </> "dist/"]
+  [DistDirCabal SCV1 $ replaceFileName cabal "dist/"]
+findDistDirs (ProjLocV1Dir dir) = [DistDirCabal SCV1 $ dir </> "dist/"]
 findDistDirs (ProjLocV2File cabal) =
-  [DistDirV2 $ replaceFileName cabal "dist-newstyle/"]
-findDistDirs (ProjLocV2Dir dir) = [DistDirV2 $ dir </> "dist-newstyle/"]
+  [DistDirCabal SCV2 $ replaceFileName cabal "dist-newstyle/"]
+findDistDirs (ProjLocV2Dir dir) = [DistDirCabal SCV2 $ dir </> "dist-newstyle/"]
 findDistDirs (ProjLocStackYaml _) = [DistDirStack Nothing]
 
 findDistDirsWithHints = undefined
diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs
index f9900bb..edbcd46 100644
--- a/src/CabalHelper/Compiletime/Types.hs
+++ b/src/CabalHelper/Compiletime/Types.hs
@@ -50,13 +50,23 @@ data ProjType
       deriving (Eq, Ord, Show, Read)
 
 data SProjType pt where
-    SV1 :: SProjType 'V1
-    SV2 :: SProjType 'V2
+    SCabal :: !(SCabalProjType pt) -> SProjType pt
     SStack :: SProjType 'Stack
 
+deriving instance Show (SProjType pt)
+
+-- | This is a singleton, like 'SProjType', but restricted to just the
+-- Cabal project types. We use this to restrict some functions which don't
+-- make sense for Stack to just the Cabal project types.
+data SCabalProjType pt where
+    SCV1 :: SCabalProjType 'V1
+    SCV2 :: SCabalProjType 'V2
+
+deriving instance Show (SCabalProjType pt)
+
 demoteSProjType :: SProjType pt -> ProjType
-demoteSProjType SV1 = V1
-demoteSProjType SV2 = V2
+demoteSProjType (SCabal SCV1) = V1
+demoteSProjType (SCabal SCV2) = V2
 demoteSProjType SStack = Stack
 
 -- | Location of project sources. The project type of a given directory can be
@@ -89,29 +99,34 @@ plV1Dir :: ProjLoc 'V1 -> FilePath
 plV1Dir ProjLocV1CabalFile {plPackageDir} = plPackageDir
 plV1Dir ProjLocV1Dir {plPackageDir} = plPackageDir
 
+projTypeOfProjLoc :: ProjLoc pt -> SProjType pt
+projTypeOfProjLoc ProjLocV1CabalFile{} = SCabal SCV1
+projTypeOfProjLoc ProjLocV1Dir{}       = SCabal SCV1
+projTypeOfProjLoc ProjLocV2File{}      = SCabal SCV2
+projTypeOfProjLoc ProjLocV2Dir{}       = SCabal SCV2
+projTypeOfProjLoc ProjLocStackYaml{}   = SStack
+
+-- | A build directory for a certain project type. The @pt@ type variable
+-- must match the value of 'ProjLoc'. This is enforced by the type system
+-- so you can't get this wrong :)
 data DistDir (pt :: ProjType) where
-    -- | Build directory for cabal /old-build/ aka. /v1-build/ aka. just
-    -- /build/. Planned to be superceeded by /v2-build/, see 'DistDirV2' for
-    -- that.
-    --
-    -- You can tell a builddir is a /v1/ builddir by looking for a file
-    -- called @setup-config@ directly underneath it.
-    DistDirV1 :: !FilePath -> DistDir 'V1
-
-    -- | Build directory for cabal /new-build/ aka. /v2-build/, as of the time
-    -- of this writing it is usually called @dist-newstyle/@ but this will
-    -- presumably change once it becomes the default /build/ command.
-    --
-    -- You can tell a builddir is a /v2/ builddir by trying to access the path
-    -- @cache/plan.json@ directly underneath it.
-    DistDirV2 :: !FilePath -> DistDir 'V2
-
-    -- | Build directory for stack, aka. /work-dir/. Optionally override Stack's
-    -- /work-dir/. If you just want to use Stack's default set to @Nothing@
+    -- | A build-directory for cabal, aka. dist-dir in Cabal
+    -- terminology. 'SCabalProjType' specifies whether we should use
+    -- /v2-build/ or /v1-build/. This choice must correspond to
+    -- 'ProjLoc'\'s project type.
+    DistDirCabal :: !(SCabalProjType pt) -> !FilePath -> DistDir pt
+
+    -- | A build-directory for stack, aka. /work-dir/. Optionally override
+    -- Stack's /work-dir/. If you just want to use Stack's default set to
+    -- @Nothing@
     DistDirStack :: !(Maybe RelativePath) -> DistDir 'Stack
 
 deriving instance Show (DistDir pt)
 
+projTypeOfDistDir :: DistDir pt -> SProjType pt
+projTypeOfDistDir (DistDirCabal pt _) = SCabal pt
+projTypeOfDistDir DistDirStack{} = SStack
+
 -- | General purpose existential wrapper. Useful for hiding a phantom type
 -- argument.
 --
diff --git a/tests/Examples.hs b/tests/Examples.hs
index 607b83d..e1fda9e 100644
--- a/tests/Examples.hs
+++ b/tests/Examples.hs
@@ -49,7 +49,7 @@ parseOpts argv =
 doCabalV2 :: IO ()
 doCabalV2 = do
   _ <- systemV "cabal new-build --builddir=dist-newstyle"
-  qe <- mkQueryEnv (ProjLocV2Dir ".") (DistDirV2 "dist-newstyle/")
+  qe <- mkQueryEnv (ProjLocV2Dir ".") (DistDirCabal SCV2 "dist-newstyle/")
   printUnitInfos qe
 
 doCabalV1 :: IO ()
diff --git a/tests/GhcSession.hs b/tests/GhcSession.hs
index 871fddd..22b94b4 100644
--- a/tests/GhcSession.hs
+++ b/tests/GhcSession.hs
@@ -419,8 +419,8 @@ data ProjSetupImpl pt =
 
 oldBuildProjSetup :: ProjSetup0
 oldBuildProjSetup = ProjSetupDescr "cabal-v1" $ Right $ Ex $ ProjSetupImpl
-    { psiProjType  = SV1
-    , psiDistDir   = \dir -> DistDirV1 (dir </> "dist")
+    { psiProjType  = SCabal SCV1
+    , psiDistDir   = \dir -> DistDirCabal SCV1 (dir </> "dist")
     , psiProjLoc   = \(CabalFile cf) projdir -> ProjLocV1CabalFile cf projdir
     , psiConfigure = \progs dir ->
         runWithCwd dir (cabalProgram progs) [ "configure" ]
@@ -433,8 +433,8 @@ oldBuildProjSetup = ProjSetupDescr "cabal-v1" $ Right $ Ex $ ProjSetupImpl
 
 newBuildProjSetup :: ProjSetup0
 newBuildProjSetup = ProjSetupDescr "cabal-v2" $ Right $ Ex $ ProjSetupImpl
-    { psiProjType  = SV2
-    , psiDistDir   = \dir  -> DistDirV2 (dir </> "dist-newstyle")
+    { psiProjType  = SCabal SCV2
+    , psiDistDir   = \dir  -> DistDirCabal SCV2 (dir </> "dist-newstyle")
     , psiProjLoc   = \_cabal_file projdir -> ProjLocV2File $ projdir </> "cabal.project"
                      -- TODO: check if cabal.project is there and only use
                      -- V2File then, also remove addCabalProject below so we