module UHC.Light.Compiler.Base.Trace
( (><)
, TraceOn (..), allTraceOnMp
, TrPP, trppIsEmpty, trppEmpty
, trPPOnIO, trPP, trOnPP, trOn )
where
import UHC.Util.Pretty
import UHC.Util.Utils
import GHC.Generics (Generic)
import Data.Typeable
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.Map as Map
import qualified Data.Sequence as Sq
import qualified Data.Foldable as Fld
import Data.Sequence ((><))
import UHC.Light.Compiler.Base.Common

{-# LINE 31 "src/ehc/Base/Trace.chs" #-}
-- | Trace on specific topic(s)
data TraceOn
  = TraceOn_BldFun					-- build functions (bcall, ...)
  | TraceOn_BldFlow					-- build flow
  | TraceOn_BldFPaths				-- build fpaths constructed
  | TraceOn_BldSearchPaths			-- build searchpath used
  | TraceOn_BldSccImports			-- build compile order (scc = strongly connected components)
  | TraceOn_BldTypeables			-- build Typeable instances encountered
  | TraceOn_BldPipe					-- build Pipe related
  | TraceOn_BldPlan					-- build Plan related
  | TraceOn_BldFold					-- build folds related
  | TraceOn_BldTimes				-- build file times related
  | TraceOn_BldResult				-- build results related
  | TraceOn_BldImport				-- build import related
  | TraceOn_BldRef					-- build reference related
  | TraceOn_BldMod					-- build module related
  | TraceOn_HsScc					-- HS scc of name dependency analysis
  | TraceOn_HsDpd					-- HS dpd info of name dependency analysis
  | TraceOn_HsOcc					-- HS name occurrence info
  | TraceOn_EhClsGam				-- EH class gam lookup results
  | TraceOn_EhDataGam				-- EH data gam lookup results
  | TraceOn_EhValGam				-- EH value gam lookup results
  | TraceOn_RunMod					-- run module related
  | TraceOn_RunHeap					-- run heap related
  | TraceOn_RunGlobals				-- run globals related
  | TraceOn_RunFrame				-- run frame (minimally) related
  | TraceOn_RunFrames				-- run frames related
  | TraceOn_RunEval					-- run evaluation related
  | TraceOn_RunRef					-- run reference related
  deriving (Eq,Ord,Enum,Show,Typeable,Bounded,Generic)

instance DataAndConName TraceOn

allTraceOnMp :: Map.Map String TraceOn
allTraceOnMp = str2stMpWithShow (strToLower . showUnprefixed 1)

{-# LINE 75 "src/ehc/Base/Trace.chs" #-}
type TrPP = Sq.Seq PP_Doc

trppIsEmpty :: TrPP -> Bool
trppIsEmpty = Sq.null

trppEmpty :: TrPP
trppEmpty = Sq.empty

{-# LINE 85 "src/ehc/Base/Trace.chs" #-}
-- | Tracing PPs
trPP :: (TraceOn -> Bool) -> TraceOn -> [PP_Doc] -> TrPP
trPP onTr ton ms = if onTr ton then pr ms else trppEmpty
  where pr []      = trppEmpty
        pr [m]     = Sq.singleton $ show ton >|< ":" >#< m
        pr (m:ms)  = pr [m] >< (Sq.fromList $ map (indent 2) ms)

-- | Dump trace IO monadically
trPPOnIO :: (Monad m, MonadIO m) => TrPP -> m ()
trPPOnIO ppl = liftIO $ mapM_ putPPLn $ Fld.toList ppl

-- | Tracing PPs, producing output on IO
trOnPP :: (Monad m, MonadIO m) => (TraceOn -> Bool) -> TraceOn -> [PP_Doc] -> m ()
trOnPP onTr ton ms = when (onTr ton) $ trPPOnIO $ trPP onTr ton ms
{-
  where pr []      = return ()
        pr [m]     = putPPLn $ show ton >|< ":" >#< m
        pr (m:ms)  = do pr [m]
                        forM_ ms $ \m -> putPPLn $ indent 2 m
-}
{-# INLINE trOnPP #-}

-- | Tracing Strings, producing output on IO
trOn :: (Monad m, MonadIO m) => (TraceOn -> Bool) -> TraceOn -> [String] -> m ()
trOn onTr ton ms = trOnPP onTr ton $ map pp ms
{-# INLINE trOn #-}