blob: 9e6a7ca407318ab2622953fe36f002858fd67522 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
-- cabal-helper: Simple interface to Cabal's configuration state
-- Copyright (C) 2019 Daniel Gröber <cabal-helper@dxld.at>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE GADTs, TypeFamilies, DataKinds #-}
{-|
Module : Distribution.Helper.Discover
Description : Finding project contexts
License : GPL-3
Maintainer : cabal-helper@dxld.at
Portability : portable
-}
-- TODO: $ sed -e s/DistDir/BuildDir/
module Distribution.Helper.Discover
( findProjects
, getDefaultDistDir
, isValidDistDir
) where
import Control.Monad.Writer
import System.Directory
import System.FilePath
import CabalHelper.Compiletime.Types
import CabalHelper.Compiletime.Cabal
-- | @findProjects dir@. Find available project instances in @dir@.
--
-- For example, if the given directory contains both a @cabal.project@ and
-- a @stack.yaml@ file:
--
-- >>> findProjects "."
-- [ Ex (ProjLocStackYaml "./stack.yaml"), Ex (ProjLocCabalV2File "./cabal.project") ]
--
-- Note that this function only looks for "default" project markers. If you
-- want to for example support the common pattern of having multiple
-- @stack-<GHC_VER>.yaml@ files simply fill out a 'ProjLoc' yourself. In
-- this case 'ProjLocStackYaml'.
findProjects :: FilePath -> IO [Ex ProjLoc]
findProjects dir = execWriterT $ do
let cabalProject = dir </> "cabal.project"
whenM (liftIO $ doesFileExist cabalProject) $
tell [Ex $ ProjLocV2File cabalProject]
let stackYaml = dir </> "stack.yaml"
whenM (liftIO $ doesFileExist stackYaml) $
tell [Ex $ ProjLocStackYaml stackYaml]
join $ traverse (tell . pure . Ex . ProjLocV1Dir . takeDirectory) <$>
liftIO (findCabalFile dir)
-- | @getDefaultDistDir pl@. Get the default dist-dir for the given project.
--
-- Note that the path in the returned dist-dir might not exist yet if the
-- build-tool has never been run for this project before. This is fine as
-- far as @cabal-helper@ is concerned. It will simply invoke the build-tool
-- as needed to answer the requested queries.
getDefaultDistDir :: ProjLoc pt -> DistDir pt
getDefaultDistDir (ProjLocV1CabalFile _cabal_file pkgdir) =
DistDirCabal SCV1 $ pkgdir </> "dist"
getDefaultDistDir (ProjLocV1Dir pkgdir) =
DistDirCabal SCV1 $ pkgdir </> "dist"
getDefaultDistDir (ProjLocV2File cabal_project) =
DistDirCabal SCV2 $ replaceFileName cabal_project "dist-newstyle"
getDefaultDistDir (ProjLocV2Dir projdir) =
DistDirCabal SCV2 $ projdir </> "dist-newstyle"
getDefaultDistDir (ProjLocStackYaml _) =
DistDirStack Nothing
-- | @isValidDistDir distdir@. Check if @distdir@ looks like a valid
-- build-dir for it's project type. We just check if characteristic marker
-- files for the associated project type exist.
--
-- If the project type does not have a way to do this (for example
-- 'DistDirStack') check we return 'Nothing'.
isValidDistDir :: DistDir pt -> IO (Maybe Bool)
isValidDistDir (DistDirCabal cpt dir) = do
fmap Just $ doesFileExist $ dir </> cabalProjTypeMarkerFile cpt
isValidDistDir DistDirStack{} =
return Nothing
cabalProjTypeMarkerFile :: SCabalProjType pt -> FilePath
cabalProjTypeMarkerFile SCV1 = "setup-config"
cabalProjTypeMarkerFile SCV2 = "cache" </> "plan.json"
whenM :: Monad m => m Bool -> m () -> m ()
whenM p x = p >>= (`when` x)
|
