{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
module Debian.GHC
    ( withCompilerVersion
    , newestAvailable
    , compilerIdFromDebianVersion
    , compilerFlavorOption
    , newestAvailableCompilerId
    -- , ghcNewestAvailableVersion'
    -- , ghcNewestAvailableVersion
    -- , compilerIdFromDebianVersion
    , withModifiedPATH
    -- , CompilerChoice(..), hcVendor, hcFlavor
    , 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 (hPutStrLn, stderr)
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
  -- liftIO $ hPutStrLn stderr $ "*** withCompilerPath vendor=" ++ show vendor
  -- liftIO $ hPutStrLn stderr $ "*** Setting $PATH to " ++ show path
  a
r <- m a
action
  -- liftIO $ hPutStrLn stderr $ "*** Resetting $PATH to " ++ show path0
  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

-- | Memoized version of newestAvailable'
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'

-- | Look up the newest version of a deb available
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

{-
-- | The IO portion of ghcVersion.  For there to be no version of ghc
-- available is an exceptional condition, it has been standard in
-- Debian and Ubuntu for a long time.
ghcNewestAvailableVersion :: CompilerFlavor -> IO DebianVersion
ghcNewestAvailableVersion hc = do
  versions <- try $ chroot $
                (readProcess "apt-cache" ["showpkg", map toLower (show hc)] "" >>=
                return . dropWhile (/= "Versions: ") . lines) :: IO (Either SomeException [String])
  case versions of
    Left e -> error $ "ghcNewestAvailableVersion failed in: " ++ show e
    Right (_ : versionLine : _) -> return . parseDebianVersion . takeWhile (/= ' ') $ versionLine
    _ -> error $ "No version of ghc available"

-- | Memoize the CompilerId built for the newest available version of
-- the compiler package so we don't keep running apt-cache showpkg
-- over and over.
ghcNewestAvailableVersion' :: CompilerFlavor -> CompilerId
ghcNewestAvailableVersion' hc =
    memoize f hc
    where
      f :: (CompilerFlavor, FilePath) -> CompilerId
      f hc' = unsafePerformIO (g hc')
      g hc = do
        ver <- ghcNewestAvailableVersion hc
        let cid = compilerIdFromDebianVersion ver
        -- hPutStrLn stderr ("GHC Debian version: " ++ show ver ++ ", Compiler ID: " ++ show cid)
        return cid
-}

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

-- | General function to build a command line option that reads most
-- of the possible values for CompilerFlavor.
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
      -- Most of the constructors in CompilerFlavor are arity zero and
      -- all caps, though two are capitalized - Hugs and Helium.  This
      -- won't read those, and it won't read HaskellSuite String or
      -- OtherCompiler String
      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))

{-
debName :: CompilerFlavor -> Maybe BinPkgName
debName hc =
    case map toLower (show hc) of
      s | any isSpace s -> Nothing
      s -> Just (BinPkgName s)
-}

-- | Compute the compiler package names by finding out what package
-- contains the corresponding executable.
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
          -- hcname is the package that contains the compiler
          -- executable.  This will be ghc or ghcjs for Debian
          -- packages, anything else is an hvr package.
          case (CompilerFlavor
hc, PackageType
typ, Bool
isDebian) of
            -- Debian puts the .haddock files in ghc-doc
            (CompilerFlavor
GHC, PackageType
Documentation, Bool
True) -> String -> BinPkgName
BinPkgName (String
hcname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-doc")
            -- In HVR repo the .haddock files required to buid html
            -- are in the main compiler package.  However, the html
            -- files in ghc-<version>-htmldocs are also needed to
            -- create links.
            (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

-- | IO based alternative to newestAvailableCompilerId - install the
-- compiler into the chroot if necessary and ask it for its version
-- number.  This has the benefit of working for ghcjs, which doesn't
-- make the base ghc version available in the version number.
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