module GHC.Driver.Messager (Messager, oneShotMsg, batchMsg, batchMultiMsg, showModuleIndex) where

import GHC.Prelude
import GHC.Driver.Env
import GHC.Unit.Module.Graph
import GHC.Iface.Recomp
import GHC.Utils.Logger
import GHC.Utils.Outputable
import GHC.Utils.Error
import GHC.Unit.State

type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()

--------------------------------------------------------------
-- Progress displayers.
--------------------------------------------------------------

oneShotMsg :: Logger -> RecompileRequired -> IO ()
oneShotMsg :: Logger -> RecompileRequired -> IO ()
oneShotMsg Logger
logger RecompileRequired
recomp =
    case RecompileRequired
recomp of
        RecompileRequired
UpToDate -> Logger -> SDoc -> IO ()
compilationProgressMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"compilation IS NOT required"
        NeedsRecompile CompileReason
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

batchMsg :: Messager
batchMsg :: Messager
batchMsg = (HscEnv
 -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc)
-> Messager
batchMsgWith (\HscEnv
_ (Int, Int)
_ RecompileRequired
_ ModuleGraphNode
_ -> SDoc
forall doc. IsOutput doc => doc
empty)
batchMultiMsg :: Messager
batchMultiMsg :: Messager
batchMultiMsg = (HscEnv
 -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc)
-> Messager
batchMsgWith (\HscEnv
_ (Int, Int)
_ RecompileRequired
_ ModuleGraphNode
node -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModuleGraphNode -> UnitId
mgNodeUnitId ModuleGraphNode
node)))

batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager
batchMsgWith :: (HscEnv
 -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc)
-> Messager
batchMsgWith HscEnv
-> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc
extra HscEnv
hsc_env_start (Int, Int)
mod_index RecompileRequired
recomp ModuleGraphNode
node =
      case RecompileRequired
recomp of
        RecompileRequired
UpToDate
          | Logger -> Int -> Bool
logVerbAtLeast Logger
logger Int
2 -> SDoc -> SDoc -> IO ()
showMsg (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Skipping") SDoc
forall doc. IsOutput doc => doc
empty
          | Bool
otherwise -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        NeedsRecompile CompileReason
reason0 -> SDoc -> SDoc -> IO ()
showMsg (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
herald) (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ case CompileReason
reason0 of
          CompileReason
MustCompile            -> SDoc
forall doc. IsOutput doc => doc
empty
          (RecompBecause RecompReason
reason) -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" [" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state (RecompReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecompReason
reason) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"]"
    where
        herald :: String
herald = case ModuleGraphNode
node of
                    LinkNode {} -> String
"Linking"
                    InstantiationNode {} -> String
"Instantiating"
                    ModuleNode {} -> String
"Compiling"
                    UnitNode {} -> String
"Loading"
        hsc_env :: HscEnv
hsc_env = HasDebugCallStack => UnitId -> HscEnv -> HscEnv
UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (ModuleGraphNode -> UnitId
mgNodeUnitId ModuleGraphNode
node) HscEnv
hsc_env_start
        dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
        state :: UnitState
state  = HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
        showMsg :: SDoc -> SDoc -> IO ()
showMsg SDoc
msg SDoc
reason =
            Logger -> SDoc -> IO ()
compilationProgressMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
            ((Int, Int) -> SDoc
showModuleIndex (Int, Int)
mod_index SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
            SDoc
msg SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> DynFlags -> Bool -> ModuleGraphNode -> SDoc
showModMsg DynFlags
dflags (RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp) ModuleGraphNode
node)
                SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> HscEnv
-> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc
extra HscEnv
hsc_env (Int, Int)
mod_index RecompileRequired
recomp ModuleGraphNode
node
                SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
reason

{- **********************************************************************
%*                                                                      *
        Progress Messages: Module i of n
%*                                                                      *
%********************************************************************* -}

showModuleIndex :: (Int, Int) -> SDoc
showModuleIndex :: (Int, Int) -> SDoc
showModuleIndex (Int
i,Int
n) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"[" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
pad SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
i SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" of " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"] "
  where
    -- compute the length of x > 0 in base 10
    len :: a -> b
len a
x = Float -> b
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Float -> Float -> Float
forall a. Floating a => a -> a -> a
logBase Float
10 (a -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
xFloat -> Float -> Float
forall a. Num a => a -> a -> a
+Float
1) :: Float)
    pad :: SDoc
pad = String -> SDoc
forall doc. IsLine doc => String -> doc
text (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int -> Int
forall {b} {a}. (Integral b, Integral a) => a -> b
len Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
forall {b} {a}. (Integral b, Integral a) => a -> b
len Int
i) Char
' ') -- TODO: use GHC.Utils.Ppr.RStr