{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingVia #-}
module GHC.Toolchain.Monad
( Env(..)
, M
, runM
, getEnv
, makeM
, throwE
, ifCrossCompiling
, readFile
, writeFile
, appendFile
, createFile
, logInfo
, logDebug
, checking
, withLogContext
) where
import Prelude hiding (readFile, writeFile, appendFile)
import qualified Prelude
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import qualified Control.Monad.Trans.Reader as Reader
import qualified Control.Monad.Trans.Except as Except
import System.IO hiding (readFile, writeFile, appendFile)
import qualified Data.Text as T
import qualified Data.Text.IO as T
data Env = Env { Env -> Int
verbosity :: Int
, Env -> Maybe String
targetPrefix :: Maybe String
, Env -> Bool
keepTemp :: Bool
, Env -> Bool
canLocallyExecute :: Bool
, Env -> [String]
logContexts :: [String]
}
newtype M a = M (Except.ExceptT [Error] (Reader.ReaderT Env IO) a)
deriving ((forall a b. (a -> b) -> M a -> M b)
-> (forall a b. a -> M b -> M a) -> Functor M
forall a b. a -> M b -> M a
forall a b. (a -> b) -> M a -> M b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> M a -> M b
fmap :: forall a b. (a -> b) -> M a -> M b
$c<$ :: forall a b. a -> M b -> M a
<$ :: forall a b. a -> M b -> M a
Functor, Functor M
Functor M =>
(forall a. a -> M a)
-> (forall a b. M (a -> b) -> M a -> M b)
-> (forall a b c. (a -> b -> c) -> M a -> M b -> M c)
-> (forall a b. M a -> M b -> M b)
-> (forall a b. M a -> M b -> M a)
-> Applicative M
forall a. a -> M a
forall a b. M a -> M b -> M a
forall a b. M a -> M b -> M b
forall a b. M (a -> b) -> M a -> M b
forall a b c. (a -> b -> c) -> M a -> M b -> M c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> M a
pure :: forall a. a -> M a
$c<*> :: forall a b. M (a -> b) -> M a -> M b
<*> :: forall a b. M (a -> b) -> M a -> M b
$cliftA2 :: forall a b c. (a -> b -> c) -> M a -> M b -> M c
liftA2 :: forall a b c. (a -> b -> c) -> M a -> M b -> M c
$c*> :: forall a b. M a -> M b -> M b
*> :: forall a b. M a -> M b -> M b
$c<* :: forall a b. M a -> M b -> M a
<* :: forall a b. M a -> M b -> M a
Applicative, Applicative M
Applicative M =>
(forall a b. M a -> (a -> M b) -> M b)
-> (forall a b. M a -> M b -> M b)
-> (forall a. a -> M a)
-> Monad M
forall a. a -> M a
forall a b. M a -> M b -> M b
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. M a -> (a -> M b) -> M b
>>= :: forall a b. M a -> (a -> M b) -> M b
$c>> :: forall a b. M a -> M b -> M b
>> :: forall a b. M a -> M b -> M b
$creturn :: forall a. a -> M a
return :: forall a. a -> M a
Monad, Monad M
Monad M => (forall a. IO a -> M a) -> MonadIO M
forall a. IO a -> M a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> M a
liftIO :: forall a. IO a -> M a
MonadIO, Applicative M
Applicative M =>
(forall a. M a)
-> (forall a. M a -> M a -> M a)
-> (forall a. M a -> M [a])
-> (forall a. M a -> M [a])
-> Alternative M
forall a. M a
forall a. M a -> M [a]
forall a. M a -> M a -> M a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
$cempty :: forall a. M a
empty :: forall a. M a
$c<|> :: forall a. M a -> M a -> M a
<|> :: forall a. M a -> M a -> M a
$csome :: forall a. M a -> M [a]
some :: forall a. M a -> M [a]
$cmany :: forall a. M a -> M [a]
many :: forall a. M a -> M [a]
Alternative)
runM :: Env -> M a -> IO (Either [Error] a)
runM :: forall a. Env -> M a -> IO (Either [Error] a)
runM Env
env (M ExceptT [Error] (ReaderT Env IO) a
k) =
ReaderT Env IO (Either [Error] a) -> Env -> IO (Either [Error] a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
Reader.runReaderT (ExceptT [Error] (ReaderT Env IO) a
-> ReaderT Env IO (Either [Error] a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT ExceptT [Error] (ReaderT Env IO) a
k) Env
env
getEnv :: M Env
getEnv :: M Env
getEnv = ExceptT [Error] (ReaderT Env IO) Env -> M Env
forall a. ExceptT [Error] (ReaderT Env IO) a -> M a
M (ExceptT [Error] (ReaderT Env IO) Env -> M Env)
-> ExceptT [Error] (ReaderT Env IO) Env -> M Env
forall a b. (a -> b) -> a -> b
$ ReaderT Env IO Env -> ExceptT [Error] (ReaderT Env IO) Env
forall (m :: * -> *) a. Monad m => m a -> ExceptT [Error] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT Env IO Env
forall (m :: * -> *) r. Monad m => ReaderT r m r
Reader.ask
makeM :: IO (Either [Error] a) -> M a
makeM :: forall a. IO (Either [Error] a) -> M a
makeM IO (Either [Error] a)
io = ExceptT [Error] (ReaderT Env IO) a -> M a
forall a. ExceptT [Error] (ReaderT Env IO) a -> M a
M (ReaderT Env IO (Either [Error] a)
-> ExceptT [Error] (ReaderT Env IO) a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
Except.ExceptT ((Env -> IO (Either [Error] a)) -> ReaderT Env IO (Either [Error] a)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
Reader.ReaderT (\Env
_env -> IO (Either [Error] a)
io)))
data Error = Error { Error -> String
errorMessage :: String
, Error -> [String]
errorLogContexts :: [String]
}
deriving (Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Error -> ShowS
showsPrec :: Int -> Error -> ShowS
$cshow :: Error -> String
show :: Error -> String
$cshowList :: [Error] -> ShowS
showList :: [Error] -> ShowS
Show)
throwE :: String -> M a
throwE :: forall a. String -> M a
throwE String
msg = do
Env
e <- M Env
getEnv
String -> M ()
logInfo String
msg
let err :: Error
err = Error { errorMessage :: String
errorMessage = String
msg
, errorLogContexts :: [String]
errorLogContexts = Env -> [String]
logContexts Env
e
}
ExceptT [Error] (ReaderT Env IO) a -> M a
forall a. ExceptT [Error] (ReaderT Env IO) a -> M a
M ([Error] -> ExceptT [Error] (ReaderT Env IO) a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Except.throwE [Error
err])
withLogContext :: String -> M a -> M a
withLogContext :: forall a. String -> M a -> M a
withLogContext String
ctxt M a
k = do
Env
env <- M Env
getEnv
let env' :: Env
env' = Env
env { logContexts = ctxt : logContexts env }
String -> M ()
logDebug (String -> M ()) -> String -> M ()
forall a b. (a -> b) -> a -> b
$ String
"Entering: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ctxt
Either [Error] a
r <- IO (Either [Error] a) -> M (Either [Error] a)
forall a. IO a -> M a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either [Error] a) -> M (Either [Error] a))
-> IO (Either [Error] a) -> M (Either [Error] a)
forall a b. (a -> b) -> a -> b
$ Env -> M a -> IO (Either [Error] a)
forall a. Env -> M a -> IO (Either [Error] a)
runM Env
env' M a
k
([Error] -> M a) -> (a -> M a) -> Either [Error] a -> M a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ExceptT [Error] (ReaderT Env IO) a -> M a
forall a. ExceptT [Error] (ReaderT Env IO) a -> M a
M (ExceptT [Error] (ReaderT Env IO) a -> M a)
-> ([Error] -> ExceptT [Error] (ReaderT Env IO) a)
-> [Error]
-> M a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Error] -> ExceptT [Error] (ReaderT Env IO) a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Except.throwE) a -> M a
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Either [Error] a
r
checking :: Show a => String -> M a -> M a
checking :: forall a. Show a => String -> M a -> M a
checking String
what M a
k = do
String -> M ()
logInfo (String -> M ()) -> String -> M ()
forall a b. (a -> b) -> a -> b
$ String
"checking " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
what String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"..."
a
r <- String -> M a -> M a
forall a. String -> M a -> M a
withLogContext (String
"checking " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
what) M a
k
String -> M ()
logInfo (String -> M ()) -> String -> M ()
forall a b. (a -> b) -> a -> b
$ String
"found " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
what String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
r
a -> M a
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
logDebug :: String -> M ()
logDebug :: String -> M ()
logDebug = Int -> String -> M ()
logMsg Int
2
logInfo :: String -> M ()
logInfo :: String -> M ()
logInfo = Int -> String -> M ()
logMsg Int
1
logMsg :: Int -> String -> M ()
logMsg :: Int -> String -> M ()
logMsg Int
v String
msg = do
Env
e <- M Env
getEnv
let n :: Int
n = [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> Int) -> [String] -> Int
forall a b. (a -> b) -> a -> b
$ Env -> [String]
logContexts Env
e
indent :: String
indent = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> [String]
forall a. Int -> a -> [a]
replicate Int
n String
" "
Bool -> M () -> M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Env -> Int
verbosity Env
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
v) (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
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
indent String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg)
readFile :: FilePath -> M String
readFile :: String -> M String
readFile String
path = 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
$ Text -> String
T.unpack (Text -> String) -> IO Text -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
T.readFile String
path
writeFile :: FilePath -> String -> M ()
writeFile :: String -> String -> M ()
writeFile String
path String
s = 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 -> IO ()
Prelude.writeFile String
path String
s
appendFile :: FilePath -> String -> M ()
appendFile :: String -> String -> M ()
appendFile String
path String
s = 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 -> IO ()
Prelude.appendFile String
path String
s
createFile :: FilePath -> M ()
createFile :: String -> M ()
createFile String
path = String -> String -> M ()
writeFile String
path String
""
ifCrossCompiling
:: M a
-> M a
-> M a
ifCrossCompiling :: forall a. M a -> M a -> M a
ifCrossCompiling M a
cross M a
other = do
Bool
canExec <- Env -> Bool
canLocallyExecute (Env -> Bool) -> M Env -> M Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> M Env
getEnv
if Bool -> Bool
not Bool
canExec then M a
cross
else M a
other