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
|
-- cabal-helper: Simple interface to Cabal's configuration state
-- Copyright (C) 2018 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/>.
{-|
Module : CabalHelper.Compiletime.Program.Stack
Description : Stack program interface
License : GPL-3
-}
{-# LANGUAGE GADTs, DataKinds #-}
module CabalHelper.Compiletime.Program.Stack where
import Control.Monad
import Data.Char
import Data.List hiding (filter)
import Data.String
import Data.Maybe
import Data.Function
import System.FilePath hiding ((<.>))
import Prelude
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
look <- paths qe pkgdir
let distdirv1 = look "dist-dir:"
return $ Unit
{ uUnitId = UnitId pkg_name
, uPackageDir = pkgdir
, uDistDir = DistDirLib distdirv1
}
-- TODO: patch ghc/ghc-pkg program paths like in ghc-mod when using stack so
-- compilation logic works even if no system compiler is installed
packageDistDir :: QueryEnvI c 'Stack -> FilePath -> IO FilePath
packageDistDir qe pkgdir = do
look <- paths qe pkgdir
return $ look "dist-dir:"
projPaths :: QueryEnvI c 'Stack -> IO StackProjPaths
projPaths qe@QueryEnv {qeProjectDir=ProjDirStack projdir} = do
look <- paths qe projdir
return StackProjPaths
{ sppGlobalPkgDb = PackageDbDir $ look "global-pkg-db:"
, sppSnapPkgDb = PackageDbDir $ look "snapshot-pkg-db:"
, sppLocalPkgDb = PackageDbDir $ look "local-pkg-db:"
}
paths :: QueryEnvI c 'Stack
-> FilePath
-> IO (String -> FilePath)
paths qe dir = do
out <- qeReadProcess qe (Just dir) (stackProgram $ qePrograms qe)
(workdirArg qe ++ [ "path" ]) ""
return $ \k -> let Just x = lookup k $ map split $ lines out in x
where
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
out <- qeReadProcess qe (Just projdir) (stackProgram $ qePrograms qe)
[ "ide", "packages", "--cabal-files" ] ""
return $ map CabalFile $ lines out
workdirArg :: QueryEnvI c 'Stack -> [String]
workdirArg QueryEnv{qeDistDir=DistDirStack mworkdir} =
maybeToList $ ("--work-dir="++) . unRelativePath <$> mworkdir
|
