{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingVia #-}

module GHC.Toolchain.Monad
    ( Env(..)
    , M
    , runM
    , getEnv
    , makeM
    , throwE
    , ifCrossCompiling

      -- * File I/O
    , readFile
    , writeFile
    , appendFile
    , createFile

      -- * Logging
    , 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 System.Directory
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
              -- Use T.readfile to read the file strictly, or otherwise run
              -- into file locking bugs on Windows

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

-- | Create an empty file.
createFile :: FilePath -> M ()
createFile :: String -> M ()
createFile String
path = String -> String -> M ()
writeFile String
path String
""

-- | Branch on whether we can execute target code locally.
ifCrossCompiling
    :: M a  -- ^ what to do when cross-compiling
    -> M a  -- ^ what to do otherwise
    -> 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 -- can't execute, this is a cross target
                 else M a
other -- can execute, run the other action