-
Notifications
You must be signed in to change notification settings - Fork 843
/
Installed.hs
208 lines (192 loc) · 7.39 KB
/
Installed.hs
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
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
module Stack.Setup.Installed
( getCompilerVersion
, markInstalled
, unmarkInstalled
, listInstalled
, Tool (..)
, toolString
, toolNameString
, parseToolText
, ExtraDirs (..)
, extraDirs
, installDir
, tempInstallDir
) where
import Stack.Prelude
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import Data.List hiding (concat, elem, maximumBy)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Distribution.System (Platform (..))
import qualified Distribution.System as Cabal
import Generics.Deriving.Monoid (mappenddefault, memptydefault)
import Path
import Path.IO
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.Version
import RIO.Process
data Tool
= Tool PackageIdentifier -- ^ e.g. ghc-7.8.4, msys2-20150512
| ToolGhcjs (CompilerVersion 'CVActual) -- ^ e.g. ghcjs-0.1.0_ghc-7.10.2
toolString :: Tool -> String
toolString (Tool ident) = displayC ident
toolString (ToolGhcjs cv) = compilerVersionString cv
toolNameString :: Tool -> String
toolNameString (Tool ident) = displayC $ pkgName ident
toolNameString ToolGhcjs{} = "ghcjs"
parseToolText :: Text -> Maybe Tool
parseToolText (parseCompilerVersion -> Just cv@GhcjsVersion{}) = Just (ToolGhcjs cv)
parseToolText (parsePackageIdentifier . T.unpack -> Just pkgId) = Just (Tool pkgId)
parseToolText _ = Nothing
markInstalled :: (MonadIO m, MonadThrow m)
=> Path Abs Dir
-> Tool
-> m ()
markInstalled programsPath tool = do
fpRel <- parseRelFile $ toolString tool ++ ".installed"
liftIO $ B.writeFile (toFilePath $ programsPath </> fpRel) "installed"
unmarkInstalled :: MonadIO m
=> Path Abs Dir
-> Tool
-> m ()
unmarkInstalled programsPath tool = liftIO $ do
fpRel <- parseRelFile $ toolString tool ++ ".installed"
ignoringAbsence (removeFile $ programsPath </> fpRel)
listInstalled :: (MonadIO m, MonadThrow m)
=> Path Abs Dir
-> m [Tool]
listInstalled programsPath = do
doesDirExist programsPath >>= \case
False -> return []
True -> do (_, files) <- listDir programsPath
return $ mapMaybe toTool files
where
toTool fp = do
x <- T.stripSuffix ".installed" $ T.pack $ toFilePath $ filename fp
parseToolText x
-- | See https://github.com/commercialhaskell/stack/issues/4086.
warnAboutGHCJS :: HasLogFunc env => RIO env ()
warnAboutGHCJS =
logWarn $ "Building a GHCJS project. " <> fromString ghcjsWarning
ghcjsWarning :: String
ghcjsWarning = unwords
[ "Note that GHCJS support in Stack is EXPERIMENTAL"
]
getCompilerVersion
:: (HasProcessContext env, HasLogFunc env)
=> WhichCompiler
-> RIO env (CompilerVersion 'CVActual)
getCompilerVersion wc =
case wc of
Ghc -> do
logDebug "Asking GHC for its version"
bs <- fst <$> proc "ghc" ["--numeric-version"] readProcess_
let (_, ghcVersion) = versionFromEnd $ BL.toStrict bs
x <- GhcVersion <$> parseVersionThrowing (T.unpack $ T.decodeUtf8 ghcVersion)
logDebug $ "GHC version is: " <> display x
return x
Ghcjs -> do
warnAboutGHCJS
logDebug "Asking GHCJS for its version"
-- Output looks like
--
-- The Glorious Glasgow Haskell Compilation System for JavaScript, version 0.1.0 (GHC 7.10.2)
bs <- fst <$> proc "ghcjs" ["--version"] readProcess_
let (rest, ghcVersion) = T.unpack . T.decodeUtf8 <$> versionFromEnd (BL.toStrict bs)
(_, ghcjsVersion) = T.unpack . T.decodeUtf8 <$> versionFromEnd rest
GhcjsVersion <$> parseVersionThrowing ghcjsVersion <*> parseVersionThrowing ghcVersion
where
versionFromEnd = S8.spanEnd isValid . fst . S8.breakEnd isValid
isValid c = c == '.' || ('0' <= c && c <= '9')
-- | Binary directories for the given installed package
extraDirs :: HasConfig env => Tool -> RIO env ExtraDirs
extraDirs tool = do
config <- view configL
dir <- installDir (configLocalPrograms config) tool
case (configPlatform config, toolNameString tool) of
(Platform _ Cabal.Windows, isGHC -> True) -> return mempty
{ edBins =
[ dir </> $(mkRelDir "bin")
, dir </> $(mkRelDir "mingw") </> $(mkRelDir "bin")
]
}
(Platform Cabal.I386 Cabal.Windows, "msys2") -> return mempty
{ edBins =
[ dir </> $(mkRelDir "mingw32") </> $(mkRelDir "bin")
, dir </> $(mkRelDir "usr") </> $(mkRelDir "bin")
, dir </> $(mkRelDir "usr") </> $(mkRelDir "local") </> $(mkRelDir "bin")
]
, edInclude =
[ dir </> $(mkRelDir "mingw32") </> $(mkRelDir "include")
]
, edLib =
[ dir </> $(mkRelDir "mingw32") </> $(mkRelDir "lib")
, dir </> $(mkRelDir "mingw32") </> $(mkRelDir "bin")
]
}
(Platform Cabal.X86_64 Cabal.Windows, "msys2") -> return mempty
{ edBins =
[ dir </> $(mkRelDir "mingw64") </> $(mkRelDir "bin")
, dir </> $(mkRelDir "usr") </> $(mkRelDir "bin")
, dir </> $(mkRelDir "usr") </> $(mkRelDir "local") </> $(mkRelDir "bin")
]
, edInclude =
[ dir </> $(mkRelDir "mingw64") </> $(mkRelDir "include")
]
, edLib =
[ dir </> $(mkRelDir "mingw64") </> $(mkRelDir "lib")
, dir </> $(mkRelDir "mingw64") </> $(mkRelDir "bin")
]
}
(_, isGHC -> True) -> return mempty
{ edBins =
[ dir </> $(mkRelDir "bin")
]
}
(_, isGHCJS -> True) -> return mempty
{ edBins =
[ dir </> $(mkRelDir "bin")
]
}
(Platform _ x, toolName) -> do
logWarn $ "binDirs: unexpected OS/tool combo: " <> displayShow (x, toolName)
return mempty
where
isGHC n = "ghc" == n || "ghc-" `isPrefixOf` n
isGHCJS n = "ghcjs" == n
data ExtraDirs = ExtraDirs
{ edBins :: ![Path Abs Dir]
, edInclude :: ![Path Abs Dir]
, edLib :: ![Path Abs Dir]
} deriving (Show, Generic)
instance Semigroup ExtraDirs where
(<>) = mappenddefault
instance Monoid ExtraDirs where
mempty = memptydefault
mappend = (<>)
installDir :: (MonadReader env m, MonadThrow m)
=> Path Abs Dir
-> Tool
-> m (Path Abs Dir)
installDir programsDir tool = do
relativeDir <- parseRelDir $ toolString tool
return $ programsDir </> relativeDir
tempInstallDir :: (MonadReader env m, MonadThrow m)
=> Path Abs Dir
-> Tool
-> m (Path Abs Dir)
tempInstallDir programsDir tool = do
relativeDir <- parseRelDir $ toolString tool ++ ".temp"
return $ programsDir </> relativeDir