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
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
-- 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.List.NonEmpty (NonEmpty(..))
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 Prelude
import CabalHelper.Compiletime.Types
import CabalHelper.Compiletime.Types.RelativePath
import CabalHelper.Shared.Common
getPackage :: QueryEnvI c 'Stack -> CabalFile -> IO (Package 'Stack)
getPackage qe cabal_file@(CabalFile cabal_file_path) = do
let pkgdir = takeDirectory cabal_file_path
-- this is kind of a hack but works even for unicode package names and
-- besides stack even enforces this naming convention unlike cabal. This
-- is the error you get if the names don't match:
--
-- cabal file path foo-bla.cabal does not match the package name it defines.
-- Please rename the file to: foo.cabal
-- For more information, see:
-- https://github.com/commercialhaskell/stack/issues/317
let pkg_name = dropExtension $ takeFileName cabal_file_path
look <- paths qe pkgdir
let distdirv1_rel = look "dist-dir:"
let pkg = Package
{ pPackageName = pkg_name
, pSourceDir = pkgdir
, pCabalFile = cabal_file
, pFlags = []
, pUnits = (:|[]) $ Unit
{ uUnitId = UnitId pkg_name
, uDistDir = DistDirLib $ pkgdir </> distdirv1_rel
, uPackage = pkg { pUnits = () }
, uImpl = UnitImplStack
}
}
return pkg
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}
= handle ioerror $ do
let projdir = takeDirectory stack_yaml
out <- readStackCmd qe (Just projdir)
[ "ide", "packages", "--cabal-files", "--stdout" ]
return $ map CabalFile $ lines out
where
ioerror :: IOError -> IO a
ioerror ioe = (fromMaybe (throwIO ioe) =<<) $ runMaybeT $ do
stack_exe <- MaybeT $ findExecutable $ stackProgram $ qePrograms qe
stack_ver_str
<- liftIO $ trim <$> readStackCmd qe Nothing ["--numeric-version"]
stack_ver <- MaybeT $ return $ parseVerMay stack_ver_str
guard $ stack_ver < makeVersion [1,9,4]
let prog_cfg = show $ qePrograms qe
liftIO $ hPutStrLn stderr $ printf
"\nerror: stack version too old!\
\\n\n\
\You have '%s' installed but cabal-helper needs at least\n\
\stack version 1.9.4+.\n\
\\n\
\FYI cabal-helper is using the following `stack` executable:\n\
\ %s\n\
\\n\
\Additional debugging info: QueryEnv qePrograms =\n\
\ %s\n" stack_ver_str stack_exe prog_cfg
mzero
workdirArg :: QueryEnvI c 'Stack -> [String]
workdirArg QueryEnv{qeDistDir=DistDirStack mworkdir} =
maybeToList $ ("--work-dir="++) . unRelativePath <$> mworkdir
doStackCmd :: (QueryEnvI c 'Stack -> CallProcessWithCwdAndEnv a)
-> QueryEnvI c 'Stack
-> Maybe FilePath -> [String] -> IO a
doStackCmd procfn qe mcwd args =
let Programs{..} = qePrograms qe in
procfn qe mcwd stackEnv stackProgram $
stackProjArgs ++ args ++ stackUnitArgs
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
patchCompPrograms :: StackProjPaths -> Programs -> Programs
patchCompPrograms StackProjPaths{sppCompExe} progs =
progs { ghcProgram = sppCompExe }
|
