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
102
103
104
105
106
107
108
109
110
|
-- 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.Exception (handle, throwIO)
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class
import Data.Char
import Data.List hiding (filter)
import Data.String
import Data.Maybe
import Data.Function
import Data.Version
import System.Directory (findExecutable)
import System.FilePath hiding ((<.>))
import System.IO (hPutStrLn, stderr)
import Text.Printf (printf)
import Text.Show.Pretty
import Prelude
import CabalHelper.Compiletime.Types
import CabalHelper.Compiletime.Types.RelativePath
import CabalHelper.Shared.Common
getUnit :: QueryEnvI c 'Stack -> CabalFile -> IO (Unit 'Stack)
getUnit
qe@QueryEnv{qeProjLoc=ProjLocStackYaml stack_yaml}
cabal_file@(CabalFile cabal_file_path)
= do
let projdir = takeDirectory stack_yaml
let pkgdir = takeDirectory cabal_file_path
let pkg_name = dropExtension $ takeFileName cabal_file_path
look <- paths qe pkgdir
let distdirv1_rel = look "dist-dir:"
return $ Unit
{ uUnitId = UnitId pkg_name
, uPackageDir = pkgdir
, uCabalFile = cabal_file
, uDistDir = DistDirLib $ pkgdir </> distdirv1_rel
, uImpl = UnitImplStack
}
projPaths :: QueryEnvI c 'Stack -> IO StackProjPaths
projPaths qe@QueryEnv {qeProjLoc=ProjLocStackYaml stack_yaml} = do
look <- paths qe $ takeDirectory stack_yaml
return StackProjPaths
{ sppGlobalPkgDb = PackageDbDir $ look "global-pkg-db:"
, sppSnapPkgDb = PackageDbDir $ look "snapshot-pkg-db:"
, sppLocalPkgDb = PackageDbDir $ look "local-pkg-db:"
, sppCompExe = look "compiler-exe:"
}
paths :: QueryEnvI c 'Stack -> FilePath -> IO (String -> FilePath)
paths qe@QueryEnv{qeProjLoc=ProjLocStackYaml stack_yaml} cwd
= do
out <- readStackCmd qe (Just cwd) $
workdirArg qe ++ [ "path", "--stack-yaml="++stack_yaml ]
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{qeProjLoc=ProjLocStackYaml stack_yaml} = do
let projdir = takeDirectory stack_yaml
out <- readStackCmd qe (Just projdir)
[ "ide", "packages", "--cabal-files", "--stdout" ]
return $ map CabalFile $ lines out
workdirArg :: QueryEnvI c 'Stack -> [String]
workdirArg QueryEnv{qeDistDir=DistDirStack mworkdir} =
maybeToList $ ("--work-dir="++) . unRelativePath <$> mworkdir
patchCompPrograms :: StackProjPaths -> CompPrograms -> CompPrograms
patchCompPrograms StackProjPaths{sppCompExe} cprogs =
cprogs { ghcProgram = sppCompExe }
doStackCmd :: (QueryEnvI c 'Stack -> CallProcessWithCwd a)
-> QueryEnvI c 'Stack -> Maybe FilePath -> [String] -> IO a
doStackCmd procfn qe mcwd args =
let Programs{..} = qePrograms qe in
procfn qe mcwd stackProgram $ stackArgsBefore ++ args ++ stackArgsAfter
readStackCmd :: QueryEnvI c 'Stack -> Maybe FilePath -> [String] -> IO String
callStackCmd :: QueryEnvI c 'Stack -> Maybe FilePath -> [String] -> IO ()
readStackCmd = doStackCmd (\qe -> qeReadProcess qe "")
callStackCmd = doStackCmd qeCallProcess
|
