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

module GHC.Toolchain.Monad
    ( Env(..)
    , M
    , runM
    , getEnv
    , makeM
    , throwE, throwEs
    , 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 = [String] -> M a
forall a. [String] -> M a
throwEs [String
msg]

-- | Throw an error with multiple lines.
-- This should be used rather than `throwE . unlines` to preserve proper
-- logging indentation.
throwEs :: [String] -> M a
throwEs :: forall a. [String] -> M a
throwEs [String]
msgs = do
    e <- M Env
getEnv
    forM_ msgs $ \String
msg -> do
      String -> M ()
logInfo String
msg
    let err = Error { errorMessage :: String
errorMessage = [String] -> String
unlines [String]
msgs
                    , errorLogContexts :: [String]
errorLogContexts = Env -> [String]
logContexts Env
e
                    }
    M (Except.throwE [err])

withLogContext :: String -> M a -> M a
withLogContext :: forall a. String -> M a -> M a
withLogContext String
ctxt M a
k = do
    env <- M Env
getEnv
    let env' = Env
env { logContexts = ctxt : logContexts env }
    logDebug $ "Entering: " ++ ctxt
    r <- liftIO $ runM env' k
    either (M . Except.throwE) return 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
"..."
    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
    logInfo $ "found " ++ what ++ ": " ++ show r
    return 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
    e <- M Env
getEnv
    let 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] -> 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
"  "
    when (verbosity e >= v) (liftIO $ hPutStrLn stderr $ indent ++ 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
  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 not canExec then cross -- can't execute, this is a cross target
                 else other -- can execute, run the other action