{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
module Debian.GHC
( withCompilerVersion
, newestAvailable
, compilerIdFromDebianVersion
, compilerFlavorOption
, newestAvailableCompilerId
, withModifiedPATH
, compilerPackageName
, getCompilerInfo
) where
import Control.Exception (SomeException, throw, try)
import Control.Lens (_2, over)
import Control.Monad ((<=<))
import Control.Monad.Trans (MonadIO, liftIO)
import Data.Char (isSpace, toLower, toUpper)
import Data.List (intercalate)
import Debian.Debianize.BinaryDebDescription (PackageType(..))
import Debian.Relation (BinPkgName(BinPkgName))
import Debian.Version (DebianVersion, parseDebianVersion')
import Distribution.Compiler (CompilerFlavor(..), CompilerId(CompilerId))
import Distribution.Compiler (CompilerInfo(..), unknownCompilerInfo, AbiTag(NoAbiTag))
import Distribution.Pretty (prettyShow)
import Distribution.Version (mkVersion', mkVersion, Version, versionNumbers)
import Data.Version (parseVersion)
import System.Console.GetOpt (ArgDescr(ReqArg), OptDescr(..))
import System.Environment (getEnv)
import System.Exit (ExitCode(ExitFailure, ExitSuccess))
import System.IO.Error (isDoesNotExistError)
import System.Process (readProcess, showCommandForUser, readProcessWithExitCode)
import System.Posix.Env (setEnv)
import Text.ParserCombinators.ReadP (readP_to_S)
import Text.Read (readMaybe)
import Text.Regex.TDFA ((=~))
import UnliftIO.Memoize (memoizeMVar, runMemoized, Memoized)
toVersion :: String -> Maybe Version
toVersion :: String -> Maybe Version
toVersion String
s = case ((Version, String) -> Bool)
-> [(Version, String)] -> [(Version, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace (String -> Bool)
-> ((Version, String) -> String) -> (Version, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version, String) -> String
forall a b. (a, b) -> b
snd) (ReadP Version -> ReadS Version
forall a. ReadP a -> ReadS a
readP_to_S ReadP Version
parseVersion String
s) of
[(Version
v, String
_)] -> Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Version
mkVersion' Version
v)
[(Version, String)]
_ -> Maybe Version
forall a. Maybe a
Nothing
withCompilerVersion :: CompilerFlavor -> (DebianVersion -> a) -> IO (Either String a)
withCompilerVersion :: forall a.
CompilerFlavor -> (DebianVersion -> a) -> IO (Either String a)
withCompilerVersion CompilerFlavor
hc DebianVersion -> a
f = CompilerFlavor -> IO (Either String DebianVersion)
newestAvailableCompiler CompilerFlavor
hc IO (Either String DebianVersion)
-> (Either String DebianVersion -> IO (Either String a))
-> IO (Either String a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either String DebianVersion
nac -> Either String a -> IO (Either String a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((DebianVersion -> a)
-> Either String DebianVersion -> Either String a
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DebianVersion -> a
f Either String DebianVersion
nac)
withModifiedPATH :: MonadIO m => (String -> String) -> m a -> m a
withModifiedPATH :: forall (m :: * -> *) a.
MonadIO m =>
(String -> String) -> m a -> m a
withModifiedPATH String -> String
f m a
action = do
String
path0 <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
getEnv String
"PATH"
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> Bool -> IO ()
setEnv String
"PATH" (String -> String
f String
path0) Bool
True
a
r <- m a
action
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> Bool -> IO ()
setEnv String
"PATH" String
path0 Bool
True
a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
newestAvailable :: BinPkgName -> IO (Memoized (Either String DebianVersion))
newestAvailable :: BinPkgName -> IO (Memoized (Either String DebianVersion))
newestAvailable BinPkgName
pkg = IO (Either String DebianVersion)
-> IO (Memoized (Either String DebianVersion))
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Memoized a)
memoizeMVar (BinPkgName -> IO (Either String DebianVersion)
f BinPkgName
pkg)
where
f :: BinPkgName -> IO (Either String DebianVersion)
f :: BinPkgName -> IO (Either String DebianVersion)
f = BinPkgName -> IO (Either String DebianVersion)
newestAvailable'
newestAvailable' :: BinPkgName -> IO (Either String DebianVersion)
newestAvailable' :: BinPkgName -> IO (Either String DebianVersion)
newestAvailable' (BinPkgName String
name) = do
Either SomeException [String]
versions <- IO [String] -> IO (Either SomeException [String])
forall e a. Exception e => IO a -> IO (Either e a)
try (IO [String] -> IO (Either SomeException [String]))
-> IO [String] -> IO (Either SomeException [String])
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"Versions: ") ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"apt-cache" [String
"showpkg", String
name] String
"" :: IO (Either SomeException [String])
case Either SomeException [String]
versions of
Left SomeException
e -> Either String DebianVersion -> IO (Either String DebianVersion)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String DebianVersion -> IO (Either String DebianVersion))
-> Either String DebianVersion -> IO (Either String DebianVersion)
forall a b. (a -> b) -> a -> b
$ String -> Either String DebianVersion
forall a b. a -> Either a b
Left (String -> Either String DebianVersion)
-> String -> Either String DebianVersion
forall a b. (a -> b) -> a -> b
$ String
"newestAvailable failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
Right (String
_ : String
versionLine : [String]
_) -> Either String DebianVersion -> IO (Either String DebianVersion)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String DebianVersion -> IO (Either String DebianVersion))
-> (String -> Either String DebianVersion)
-> String
-> IO (Either String DebianVersion)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebianVersion -> Either String DebianVersion
forall a b. b -> Either a b
Right (DebianVersion -> Either String DebianVersion)
-> (String -> DebianVersion)
-> String
-> Either String DebianVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> DebianVersion
forall string. ParseDebianVersion string => string -> DebianVersion
parseDebianVersion' (String -> DebianVersion)
-> (String -> String) -> String -> DebianVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') (String -> IO (Either String DebianVersion))
-> String -> IO (Either String DebianVersion)
forall a b. (a -> b) -> a -> b
$ String
versionLine
Right [String]
x -> Either String DebianVersion -> IO (Either String DebianVersion)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String DebianVersion -> IO (Either String DebianVersion))
-> Either String DebianVersion -> IO (Either String DebianVersion)
forall a b. (a -> b) -> a -> b
$ String -> Either String DebianVersion
forall a b. a -> Either a b
Left (String -> Either String DebianVersion)
-> String -> Either String DebianVersion
forall a b. (a -> b) -> a -> b
$ String
"Unexpected result from apt-cache showpkg: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
x
newestAvailableCompiler :: CompilerFlavor -> IO (Either String DebianVersion)
newestAvailableCompiler :: CompilerFlavor -> IO (Either String DebianVersion)
newestAvailableCompiler CompilerFlavor
hc = IO (Either String DebianVersion)
-> (BinPkgName -> IO (Either String DebianVersion))
-> Maybe BinPkgName
-> IO (Either String DebianVersion)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Either String DebianVersion -> IO (Either String DebianVersion)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String DebianVersion
forall a b. a -> Either a b
Left String
"No compiler package")) (Memoized (Either String DebianVersion)
-> IO (Either String DebianVersion)
forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized (Memoized (Either String DebianVersion)
-> IO (Either String DebianVersion))
-> (BinPkgName -> IO (Memoized (Either String DebianVersion)))
-> BinPkgName
-> IO (Either String DebianVersion)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< BinPkgName -> IO (Memoized (Either String DebianVersion))
newestAvailable) (Maybe BinPkgName -> IO (Either String DebianVersion))
-> IO (Maybe BinPkgName) -> IO (Either String DebianVersion)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CompilerFlavor -> PackageType -> IO (Maybe BinPkgName)
compilerPackageName CompilerFlavor
hc PackageType
Development
newestAvailableCompilerId :: CompilerFlavor -> IO (Either String CompilerId)
newestAvailableCompilerId :: CompilerFlavor -> IO (Either String CompilerId)
newestAvailableCompilerId CompilerFlavor
hc = (DebianVersion -> CompilerId)
-> Either String DebianVersion -> Either String CompilerId
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CompilerFlavor -> DebianVersion -> CompilerId
compilerIdFromDebianVersion CompilerFlavor
hc) (Either String DebianVersion -> Either String CompilerId)
-> IO (Either String DebianVersion)
-> IO (Either String CompilerId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompilerFlavor -> IO (Either String DebianVersion)
newestAvailableCompiler CompilerFlavor
hc
compilerIdFromDebianVersion :: CompilerFlavor -> DebianVersion -> CompilerId
compilerIdFromDebianVersion :: CompilerFlavor -> DebianVersion -> CompilerId
compilerIdFromDebianVersion CompilerFlavor
hc DebianVersion
debVersion =
let ds :: [Int]
ds = Version -> [Int]
versionNumbers (DebianVersion -> [Version] -> Version
greatestLowerBound DebianVersion
debVersion ((Int -> Version) -> [Int] -> [Version]
forall a b. (a -> b) -> [a] -> [b]
map (\ Int
d -> [Int] -> Version
mkVersion [Int
d]) [Int
0..])) in
CompilerFlavor -> Version -> CompilerId
CompilerId CompilerFlavor
hc (DebianVersion -> [Version] -> Version
greatestLowerBound DebianVersion
debVersion ((Int -> Version) -> [Int] -> [Version]
forall a b. (a -> b) -> [a] -> [b]
map (\ Int
d -> [Int] -> Version
mkVersion ([Int]
ds [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
d])) [Int
0..]))
where
greatestLowerBound :: DebianVersion -> [Version] -> Version
greatestLowerBound :: DebianVersion -> [Version] -> Version
greatestLowerBound DebianVersion
b [Version]
xs = [Version] -> Version
forall a. HasCallStack => [a] -> a
last ([Version] -> Version) -> [Version] -> Version
forall a b. (a -> b) -> a -> b
$ (Version -> Bool) -> [Version] -> [Version]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\ Version
v -> String -> DebianVersion
forall string. ParseDebianVersion string => string -> DebianVersion
parseDebianVersion' (Version -> String
forall a. Pretty a => a -> String
prettyShow Version
v) DebianVersion -> DebianVersion -> Bool
forall a. Ord a => a -> a -> Bool
< DebianVersion
b) [Version]
xs
compilerFlavorOption :: forall a. (CompilerFlavor -> a -> a) -> OptDescr (a -> a)
compilerFlavorOption :: forall a. (CompilerFlavor -> a -> a) -> OptDescr (a -> a)
compilerFlavorOption CompilerFlavor -> a -> a
f =
String
-> [String] -> ArgDescr (a -> a) -> String -> OptDescr (a -> a)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"hc", String
"compiler-flavor"] ((String -> a -> a) -> String -> ArgDescr (a -> a)
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> a -> a
readHC String
"COMPILER") String
"Build packages using this Haskell compiler"
where
readHC :: String -> a -> a
readHC :: String -> a -> a
readHC String
s = (a -> a)
-> (CompilerFlavor -> a -> a) -> Maybe CompilerFlavor -> a -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> a -> a
forall a. HasCallStack => String -> a
error (String -> a -> a) -> String -> a -> a
forall a b. (a -> b) -> a -> b
$ String
"Invalid CompilerFlavor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s) CompilerFlavor -> a -> a
f (String -> Maybe CompilerFlavor
forall a. Read a => String -> Maybe a
readMaybe ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
s))
compilerPackageName :: CompilerFlavor -> PackageType -> IO (Maybe BinPkgName)
compilerPackageName :: CompilerFlavor -> PackageType -> IO (Maybe BinPkgName)
compilerPackageName CompilerFlavor
hc PackageType
typ = do
Maybe BinPkgName
mcp <- CompilerFlavor -> IO (Maybe BinPkgName)
compilerPackage CompilerFlavor
hc
Maybe BinPkgName -> IO (Maybe BinPkgName)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe BinPkgName -> IO (Maybe BinPkgName))
-> Maybe BinPkgName -> IO (Maybe BinPkgName)
forall a b. (a -> b) -> a -> b
$ (BinPkgName -> BinPkgName) -> Maybe BinPkgName -> Maybe BinPkgName
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BinPkgName -> BinPkgName
finish Maybe BinPkgName
mcp
where
finish :: BinPkgName -> BinPkgName
finish (BinPkgName String
hcname) =
let isDebian :: Bool
isDebian = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (CompilerFlavor -> String
forall a. Show a => a -> String
show CompilerFlavor
hc) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
hcname in
case (CompilerFlavor
hc, PackageType
typ, Bool
isDebian) of
(CompilerFlavor
GHC, PackageType
Documentation, Bool
True) -> String -> BinPkgName
BinPkgName (String
hcname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-doc")
(CompilerFlavor
GHC, PackageType
Documentation, Bool
False) -> String -> BinPkgName
BinPkgName (String
hcname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-htmldocs")
(CompilerFlavor
GHC, PackageType
Profiling, Bool
_) -> String -> BinPkgName
BinPkgName (String
hcname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-prof")
(CompilerFlavor, PackageType, Bool)
_ -> String -> BinPkgName
BinPkgName String
hcname
compilerPackage :: CompilerFlavor -> IO (Maybe BinPkgName)
compilerPackage :: CompilerFlavor -> IO (Maybe BinPkgName)
compilerPackage CompilerFlavor
GHC = String -> IO (Memoized (Maybe BinPkgName))
filePackage String
"ghc" IO (Memoized (Maybe BinPkgName))
-> (Memoized (Maybe BinPkgName) -> IO (Maybe BinPkgName))
-> IO (Maybe BinPkgName)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Memoized (Maybe BinPkgName) -> IO (Maybe BinPkgName)
forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized
compilerPackage CompilerFlavor
GHCJS = String -> IO (Memoized (Maybe BinPkgName))
filePackage String
"ghcjs" IO (Memoized (Maybe BinPkgName))
-> (Memoized (Maybe BinPkgName) -> IO (Maybe BinPkgName))
-> IO (Maybe BinPkgName)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Memoized (Maybe BinPkgName) -> IO (Maybe BinPkgName)
forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized
compilerPackage CompilerFlavor
x = String -> IO (Maybe BinPkgName)
forall a. HasCallStack => String -> a
error (String -> IO (Maybe BinPkgName))
-> String -> IO (Maybe BinPkgName)
forall a b. (a -> b) -> a -> b
$ String
"compilerPackage - unsupported CompilerFlavor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CompilerFlavor -> String
forall a. Show a => a -> String
show CompilerFlavor
x
filePackage :: FilePath -> IO (Memoized (Maybe BinPkgName))
filePackage :: String -> IO (Memoized (Maybe BinPkgName))
filePackage = IO (Maybe BinPkgName) -> IO (Memoized (Maybe BinPkgName))
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Memoized a)
memoizeMVar (IO (Maybe BinPkgName) -> IO (Memoized (Maybe BinPkgName)))
-> (String -> IO (Maybe BinPkgName))
-> String
-> IO (Memoized (Maybe BinPkgName))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Maybe BinPkgName)
f
where
f :: FilePath -> IO (Maybe BinPkgName)
f :: String -> IO (Maybe BinPkgName)
f String
p = String -> IO (Maybe String)
which String
p IO (Maybe String)
-> (Maybe String -> IO (Maybe BinPkgName)) -> IO (Maybe BinPkgName)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe BinPkgName)
-> (String -> IO (Maybe BinPkgName))
-> Maybe String
-> IO (Maybe BinPkgName)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe BinPkgName -> IO (Maybe BinPkgName)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe BinPkgName
forall a. Maybe a
Nothing) (\String
x -> String -> Maybe BinPkgName
package (String -> Maybe BinPkgName) -> IO String -> IO (Maybe BinPkgName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"dpkg-query" [String
"-S", String
x] String
"")
package :: String -> Maybe BinPkgName
package :: String -> Maybe BinPkgName
package String
s =
case String
s String -> String -> (String, String, String, [String])
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
=~ String
"^(.*): .*$" :: (String, String, String, [String]) of
(String
_, String
_, String
_, [String
name]) -> BinPkgName -> Maybe BinPkgName
forall a. a -> Maybe a
Just (String -> BinPkgName
BinPkgName String
name)
(String, String, String, [String])
_ -> Maybe BinPkgName
forall a. Maybe a
Nothing
which :: String -> IO (Maybe FilePath)
which :: String -> IO (Maybe String)
which String
bin = (ExitCode, [String], String) -> Maybe String
toPath ((ExitCode, [String], String) -> Maybe String)
-> ((ExitCode, String, String) -> (ExitCode, [String], String))
-> (ExitCode, String, String)
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter
(ExitCode, String, String)
(ExitCode, [String], String)
String
[String]
-> (String -> [String])
-> (ExitCode, String, String)
-> (ExitCode, [String], String)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
(ExitCode, String, String)
(ExitCode, [String], String)
String
[String]
forall s t a b. Field2 s t a b => Lens s t a b
Lens
(ExitCode, String, String)
(ExitCode, [String], String)
String
[String]
_2 String -> [String]
lines ((ExitCode, String, String) -> Maybe String)
-> IO (ExitCode, String, String) -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"which" [String
bin] String
""
where
toPath :: (ExitCode, [String], String) -> Maybe String
toPath :: (ExitCode, [String], String) -> Maybe String
toPath (ExitCode
ExitSuccess, [String
path], String
_) = String -> Maybe String
forall a. a -> Maybe a
Just String
path
toPath (ExitCode, [String], String)
_ = Maybe String
forall a. Maybe a
Nothing
getCompilerInfo :: MonadIO m => CompilerFlavor -> m (Either String CompilerInfo)
getCompilerInfo :: forall (m :: * -> *).
MonadIO m =>
CompilerFlavor -> m (Either String CompilerInfo)
getCompilerInfo CompilerFlavor
flavor = IO (Either String CompilerInfo) -> m (Either String CompilerInfo)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String CompilerInfo) -> m (Either String CompilerInfo))
-> IO (Either String CompilerInfo)
-> m (Either String CompilerInfo)
forall a b. (a -> b) -> a -> b
$ CompilerFlavor -> IO (Either String CompilerInfo)
getCompilerInfo' CompilerFlavor
flavor
getCompilerInfo' :: CompilerFlavor -> IO (Either String CompilerInfo)
getCompilerInfo' :: CompilerFlavor -> IO (Either String CompilerInfo)
getCompilerInfo' CompilerFlavor
flavor = do
Either IOError (ExitCode, String, String)
r <- IO (ExitCode, String, String)
-> IO (Either IOError (ExitCode, String, String))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (ExitCode, String, String)
-> IO (Either IOError (ExitCode, String, String)))
-> IO (ExitCode, String, String)
-> IO (Either IOError (ExitCode, String, String))
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode (CompilerFlavor -> String
hcCommand CompilerFlavor
flavor) [String
"--numeric-version"] String
""
case Either IOError (ExitCode, String, String)
r of
Left IOError
e | IOError -> Bool
isDoesNotExistError IOError
e -> Either String CompilerInfo -> IO (Either String CompilerInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String CompilerInfo -> IO (Either String CompilerInfo))
-> Either String CompilerInfo -> IO (Either String CompilerInfo)
forall a b. (a -> b) -> a -> b
$ String -> Either String CompilerInfo
forall a b. a -> Either a b
Left (String -> Either String CompilerInfo)
-> String -> Either String CompilerInfo
forall a b. (a -> b) -> a -> b
$ String
"getCompilerInfo - " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOError -> String
forall a. Show a => a -> String
show IOError
e
Left IOError
e -> IOError -> IO (Either String CompilerInfo)
forall a e. Exception e => e -> a
throw IOError
e
Right r' :: (ExitCode, String, String)
r'@(ExitFailure Int
_, String
_, String
_) ->
String -> IO (Either String CompilerInfo)
forall a. HasCallStack => String -> a
error (String -> IO (Either String CompilerInfo))
-> String -> IO (Either String CompilerInfo)
forall a b. (a -> b) -> a -> b
$ String
-> String -> [String] -> (ExitCode, String, String) -> String
processErrorMessage String
"getCompilerInfo" (CompilerFlavor -> String
hcCommand CompilerFlavor
flavor) [String
"--numeric-version"] (ExitCode, String, String)
r'
Right (ExitCode
_, String
out, String
_) -> do
let compilerId :: CompilerId
compilerId = CompilerId
-> (Version -> CompilerId) -> Maybe Version -> CompilerId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> CompilerId
forall a. HasCallStack => String -> a
error (String -> CompilerId) -> String -> CompilerId
forall a b. (a -> b) -> a -> b
$ String
"Parse error in version string: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
out) (CompilerFlavor -> Version -> CompilerId
CompilerId CompilerFlavor
flavor) (String -> Maybe Version
toVersion String
out)
Maybe [CompilerId]
compilerCompat <- case CompilerFlavor
flavor of
CompilerFlavor
GHCJS -> do
(Either IOError (ExitCode, String, String)
r' :: Either IOError (ExitCode, String, String)) <- IO (ExitCode, String, String)
-> IO (Either IOError (ExitCode, String, String))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (ExitCode, String, String)
-> IO (Either IOError (ExitCode, String, String)))
-> IO (ExitCode, String, String)
-> IO (Either IOError (ExitCode, String, String))
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode (CompilerFlavor -> String
hcCommand CompilerFlavor
flavor) [String
"--numeric-ghc-version"] String
""
case Either IOError (ExitCode, String, String)
r' of
Right (ExitCode
ExitSuccess, String
out', String
_) ->
IO (Maybe [CompilerId])
-> (Version -> IO (Maybe [CompilerId]))
-> Maybe Version
-> IO (Maybe [CompilerId])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO (Maybe [CompilerId])
forall a. HasCallStack => String -> a
error (String -> IO (Maybe [CompilerId]))
-> String -> IO (Maybe [CompilerId])
forall a b. (a -> b) -> a -> b
$ String
"getCompilerInfo - parse error in version string: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
out') (Maybe [CompilerId] -> IO (Maybe [CompilerId])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [CompilerId] -> IO (Maybe [CompilerId]))
-> (Version -> Maybe [CompilerId])
-> Version
-> IO (Maybe [CompilerId])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CompilerId] -> Maybe [CompilerId]
forall a. a -> Maybe a
Just ([CompilerId] -> Maybe [CompilerId])
-> (Version -> [CompilerId]) -> Version -> Maybe [CompilerId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompilerId -> [CompilerId] -> [CompilerId]
forall a. a -> [a] -> [a]
: []) (CompilerId -> [CompilerId])
-> (Version -> CompilerId) -> Version -> [CompilerId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerFlavor -> Version -> CompilerId
CompilerId CompilerFlavor
GHC) (String -> Maybe Version
toVersion String
out')
Either IOError (ExitCode, String, String)
_ -> String -> IO (Maybe [CompilerId])
forall a. HasCallStack => String -> a
error String
"getCompilerInfo - failure computing compilerCompat"
CompilerFlavor
_ -> Maybe [CompilerId] -> IO (Maybe [CompilerId])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [CompilerId]
forall a. Maybe a
Nothing
Either String CompilerInfo -> IO (Either String CompilerInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String CompilerInfo -> IO (Either String CompilerInfo))
-> Either String CompilerInfo -> IO (Either String CompilerInfo)
forall a b. (a -> b) -> a -> b
$ CompilerInfo -> Either String CompilerInfo
forall a b. b -> Either a b
Right (CompilerInfo -> Either String CompilerInfo)
-> CompilerInfo -> Either String CompilerInfo
forall a b. (a -> b) -> a -> b
$ (CompilerId -> AbiTag -> CompilerInfo
unknownCompilerInfo CompilerId
compilerId AbiTag
NoAbiTag) {compilerInfoCompat = compilerCompat}
processErrorMessage :: String -> String -> [String] -> (ExitCode, String, String) -> String
processErrorMessage :: String
-> String -> [String] -> (ExitCode, String, String) -> String
processErrorMessage String
msg String
cmd [String]
args (ExitFailure Int
n, String
out, String
err) =
String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" - " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showCommandForUser String
cmd [String]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n stdout: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
indent String
out String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n stderr: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
indent String
err
where
indent :: String -> String
indent :: String -> String
indent = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n " ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
processErrorMessage String
_msg String
_cmd [String]
_args (ExitCode
ExitSuccess, String
_out, String
_err) = String
""
hcCommand :: CompilerFlavor -> String
hcCommand :: CompilerFlavor -> String
hcCommand CompilerFlavor
GHC = String
"ghc"
hcCommand CompilerFlavor
GHCJS = String
"ghcjs"
hcCommand CompilerFlavor
flavor = String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"hcCommand - unexpected CompilerFlavor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CompilerFlavor -> String
forall a. Show a => a -> String
show CompilerFlavor
flavor