aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/Distribution/Helper.hs26
-rw-r--r--lib/Distribution/Helper/Discover.hs8
-rw-r--r--src/CabalHelper/Compiletime/Types.hs59
-rw-r--r--tests/Examples.hs2
-rw-r--r--tests/GhcSession.hs8
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 06:26:05 +0000