content: -----------------------------------------------------------------------------
  --
  -- GHCi Interactive debugging commands
  --
  -- Pepe Iborra (supported by Google SoC) 2006
  --
  -- ToDo: lots of violation of layering here.  This module should
  -- decide whether it is above the GHC API (import GHC and nothing
  -- else) or below it.
  --
  -----------------------------------------------------------------------------
  
  module GHC.Runtime.Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
  
  import GHC.Prelude
  
  import GHC
  
  import GHC.Data.List.Infinite (Infinite (..))
  import qualified GHC.Data.List.Infinite as Inf
  
  import GHC.Driver.DynFlags
  import GHC.Driver.Ppr
  import GHC.Driver.Monad
  import GHC.Driver.Env
  
  import GHC.Linker.Loader
  
  import GHC.Runtime.Heap.Inspect
  import GHC.Runtime.Interpreter
  import GHC.Runtime.Context
  
  import GHC.Iface.Syntax ( showToHeader )
  import GHC.Iface.Env    ( newInteractiveBinder )
  import GHC.Core.Type
  import GHC.Core.TyCo.Tidy( tidyOpenType )
  
  import GHC.Utils.Outputable
  import GHC.Utils.Error
  import GHC.Utils.Monad
  import GHC.Utils.Exception
  import GHC.Utils.Logger
  
  import GHC.Types.Id
  import GHC.Types.Id.Make (ghcPrimIds)
  import GHC.Types.Name
  import GHC.Types.Var hiding ( varName )
  import GHC.Types.Var.Set
  import GHC.Types.Unique.Set
  import GHC.Types.TyThing.Ppr
  import GHC.Types.TyThing
  
  import Control.Monad
  import Control.Monad.Catch as MC
  import Data.List ( partition )
  import qualified Data.List.NonEmpty as NE
  import Data.Maybe
  import Data.IORef
  
  -------------------------------------
  -- | The :print & friends commands
  -------------------------------------
  pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()
  pprintClosureCommand bindThings force str = do
    tythings <- (catMaybes . concatMap NE.toList) `liftM`
                   mapM (\w -> GHC.parseName w >>=
                                  mapM GHC.lookupName)
                        (words str)
  
    -- Sort out good and bad tythings for :print and friends
    let (pprintables, unpprintables) = partition can_pprint tythings
  
    -- Obtain the terms and the recovered type information
    let ids = [id | AnId id <- pprintables]
    (subst, terms) <- mapAccumLM go emptySubst ids
  
    -- Apply the substitutions obtained after recovering the types
    modifySession $ \hsc_env ->
      hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}
  
    -- Finally, print the Results
    docterms <- mapM showTerm terms
    let sdocTerms = zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
                            ids
                            docterms
    printSDocs $ (no_pprint <$> unpprintables) ++ sdocTerms
   where
     -- Check whether a TyThing can be processed by :print and friends.
     -- Take only Ids, exclude pseudoops, they don't have any HValues.
     can_pprint :: TyThing -> Bool                              -- #19394
     can_pprint (AnId x)
         | x `notElem` ghcPrimIds = True
         | otherwise              = False
     can_pprint _                 = False
  
     -- Create a short message for a TyThing, that cannot processed by :print
     no_pprint :: TyThing -> SDoc
     no_pprint tything = ppr tything <+>
            text "is not eligible for the :print, :sprint or :force commands."
  
     -- Helper to print out the results of :print and friends
     printSDocs :: GhcMonad m => [SDoc] -> m ()
     printSDocs sdocs = do
        logger <- getLogger
        name_ppr_ctx <- GHC.getNamePprCtx
        liftIO $ printOutputForUser logger name_ppr_ctx $ vcat sdocs
  
     -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
     go :: GhcMonad m => Subst -> Id -> m (Subst, Term)
     go subst id = do
         let id' = updateIdTypeAndMult (substTy subst) id
             id_ty' = idType id'
         term_    <- GHC.obtainTermFromId maxBound force id'
         term     <- tidyTermTyVars term_
         term'    <- if bindThings
                       then bindSuspensions term
                       else return term
       -- Before leaving, we compare the type obtained to see if it's more specific
       --  Then, we extract a substitution,
       --  mapping the old tyvars to the reconstructed types.
         let reconstructed_type = termType term
         hsc_env <- getSession
         case (improveRTTIType hsc_env id_ty' reconstructed_type) of
           Nothing     -> return (subst, term')
           Just subst' -> do { logger <- getLogger
                             ; liftIO $
                                 putDumpFileMaybe logger Opt_D_dump_rtti "RTTI"
                                   FormatText
                                   (fsep $ [text "RTTI Improvement for", ppr id,
                                    text "old substitution:" , ppr subst,
                                    text "new substitution:" , ppr subst'])
                             ; return (subst `unionSubst` subst', term')}
  
     tidyTermTyVars :: GhcMonad m => Term -> m Term
     tidyTermTyVars t =
       withSession $ \hsc_env -> do
       let env_tvs      = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env
           my_tvs       = termTyCoVars t
           tvs          = env_tvs `minusVarSet` my_tvs
           tyvarOccName = nameOccName . tyVarName
           tidyEnv      = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs))
             -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv
             -- forgets the ordering immediately by creating an env
                          , getUniqSet $ env_tvs `intersectVarSet` my_tvs)
       return $ mapTermType (tidyOpenType tidyEnv) t
  
  -- | Give names, and bind in the interactive environment, to all the suspensions
  --   included (inductively) in a term
  bindSuspensions :: GhcMonad m => Term -> m Term
  bindSuspensions t = do
        hsc_env <- getSession
        inScope <- GHC.getBindings
        let ictxt        = hsc_IC hsc_env
            prefix       = "_t"
            alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
            availNames   = (Inf.filter (`notElem` alreadyUsedNames) . fmap ((prefix++) . show)) (Inf.enumFrom (1::Int))
        availNames_var  <- liftIO $ newIORef availNames
        (t', stuff)     <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t
        let (names, tys, fhvs) = unzip3 stuff
        let ids = [ mkVanillaGlobal name ty
                  | (name,ty) <- zip names tys]
            new_ic = extendInteractiveContextWithIds ictxt ids
            interp = hscInterp hsc_env
        liftIO $ extendLoadedEnv interp (zip names fhvs)
        setSession hsc_env {hsc_IC = new_ic }
        return t'
       where
  
  --    Processing suspensions. Give names and collect info
          nameSuspensionsAndGetInfos :: HscEnv -> IORef (Infinite String)
                                     -> TermFold (IO (Term, [(Name,Type,ForeignHValue)]))
          nameSuspensionsAndGetInfos hsc_env freeNames = TermFold
                        {
                          fSuspension = doSuspension hsc_env freeNames
                        , fTerm = \ty dc v tt -> do
                                      tt' <- sequence tt
                                      let (terms,names) = unzip tt'
                                      return (Term ty dc v terms, concat names)
                        , fPrim    = \ty n ->return (Prim ty n,[])
                        , fNewtypeWrap  =
                                  \ty dc t -> do
                                      (term, names) <- t
                                      return (NewtypeWrap ty dc term, names)
                        , fRefWrap = \ty t -> do
                                      (term, names) <- t
                                      return (RefWrap ty term, names)
                        }
          doSuspension hsc_env freeNames ct ty hval _name ipe = do
            name <- atomicModifyIORef' freeNames (\(Inf x xs)->(xs, x))
            n <- newGrimName hsc_env name
            return (Suspension ct ty hval (Just n) ipe, [(n,ty,hval)])
  
  
  --  A custom Term printer to enable the use of Show instances
  showTerm :: GhcMonad m => Term -> m SDoc
  showTerm term = do
      dflags       <- GHC.getSessionDynFlags
      if gopt Opt_PrintEvldWithShow dflags
         then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
         else cPprTerm cPprTermBase term
   where
    cPprShowable prec t@Term{ty=ty, val=fhv} =
      if not (isFullyEvaluatedTerm t)
       then return Nothing
       else do
          let set_session = do
                  hsc_env <- getSession
                  (new_env, bname) <- bindToFreshName hsc_env ty "showme"
                  setSession new_env
  
                  -- this disables logging of errors
                  let noop_log _ _ _ _ = return ()
                  pushLogHookM (const noop_log)
  
                  return (hsc_env, bname)
  
              reset_session (old_env,_) = setSession old_env
  
          MC.bracket set_session reset_session $ \(_,bname) -> do
             hsc_env <- getSession
             dflags  <- GHC.getSessionDynFlags
             let expr = "Prelude.return (Prelude.show " ++
                           showPpr dflags bname ++
                        ") :: Prelude.IO Prelude.String"
                 interp = hscInterp hsc_env
             txt_ <- withExtendedLoadedEnv interp
                                         [(bname, fhv)]
                                         (GHC.compileExprRemote expr)
             let myprec = 10 -- application precedence. TODO Infix constructors
             txt <- liftIO $ evalString interp txt_
             if not (null txt) then
               return $ Just $ cparen (prec >= myprec && needsParens txt)
                                      (text txt)
              else return Nothing
  
    cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
        cPprShowable prec t{ty=new_ty}
    cPprShowable _ _ = return Nothing
  
    needsParens ('"':_) = False   -- some simple heuristics to see whether parens
                                  -- are redundant in an arbitrary Show output
    needsParens ('(':_) = False
    needsParens txt = ' ' `elem` txt
  
  
    bindToFreshName hsc_env ty userName = do
      name <- newGrimName hsc_env userName
      let id       = mkVanillaGlobal name ty
          new_ic   = extendInteractiveContextWithIds (hsc_IC hsc_env) [id]
      return (hsc_env {hsc_IC = new_ic }, name)
  
  --    Create new uniques and give them sequentially numbered names
  newGrimName :: MonadIO m => HscEnv -> String -> m Name
  newGrimName hsc_env userName
    = liftIO (newInteractiveBinder hsc_env occ noSrcSpan)
    where
      occ = mkOccName varName userName
  
  pprTypeAndContents :: GhcMonad m => Id -> m SDoc
  pprTypeAndContents id = do
    dflags  <- GHC.getSessionDynFlags
    let pcontents = gopt Opt_PrintBindContents dflags
        pprdId    = (pprTyThing showToHeader . AnId) id
    if pcontents
      then do
        let depthBound = 100
        -- If the value is an exception, make sure we catch it and
        -- show the exception, rather than propagating the exception out.
        e_term <- MC.try $ GHC.obtainTermFromId depthBound False id
        docs_term <- case e_term of
                        Right term -> showTerm term
                        Left  exn  -> return (text "*** Exception:" <+>
                                              text (show (exn :: SomeException)))
        return $ pprdId <+> equals <+> docs_term
      else return pprdId
  