content: -- | This is a modified copy of compiler/ghci/Debugger.hs
  {-# LANGUAGE MagicHash, CPP #-}
  module Break (
      evaluateIds
    , resolveNames
    , parseNames
    ) where
  
  import Prelude hiding (id)
  
  import Linker
  import RtClosureInspect
  
  import GhcMonad
  import HscTypes
  import Id
  import Name
  import Var hiding ( varName )
  import VarSet
  import UniqSupply
  import TcType (
      emptyTvSubst
    , TvSubst
    , substTy
    , isUnliftedTypeKind
    , unionTvSubst
    )
  import GHC
  import MonadUtils
  
  import Control.Monad
  import Data.List
  import Data.Maybe
  import Data.IORef
  
  import GhcShim
  
  -------------------------------------
  -- | The :print & friends commands
  -------------------------------------
  
  -- | This is basically 'pprintClosureCommand' from Debugger.hs except that
  -- we don't take a string as argument but a set of names (and defined a
  -- separate 'parseNames' and 'resolveNames' if we do want to start with a
  -- String), and that we return a set of terms rather than pretty-printing
  -- them directly to stdout.
  evaluateIds :: GhcMonad m => Bool -> Bool -> [Id] -> m [(Id, Term)]
  evaluateIds bindThings force ids = do
    -- Obtain the terms and the recovered type information
    (subst, terms) <- mapAccumLM go emptyTvSubst ids
  
    -- Apply the substitutions obtained after recovering the types
    modifySession $ \hsc_env ->
      hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}
  
    return (zip ids terms)
   where
     -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
     go :: GhcMonad m => TvSubst -> Id -> m (TvSubst, Term)
     go subst id = do
         let id' = id `setIdType` substTy subst (idType id)
         term_    <- GHC.obtainTermFromId maxBound force id'
         term     <- tidyTermTyVars term_
         term'    <- if bindThings &&
                        False == isUnliftedTypeKind (termType term)
                       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 (idType id) (reconstructed_type)) of
           Nothing     -> return (subst, term')
           Just subst' -> return (subst `unionTvSubst` subst', term')
  
     tidyTermTyVars :: GhcMonad m => Term -> m Term
     tidyTermTyVars t =
       withSession $ \hsc_env -> do
       let env_tvs      = tyThingsTyVars $ ic_tythings $ hsc_IC hsc_env
           my_tvs       = termTyVars t
           tvs          = env_tvs `minusVarSet` my_tvs
           tyvarOccName = nameOccName . tyVarName
           tidyEnv      = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
                          , env_tvs `intersectVarSet` my_tvs)
       return$ mapTermType (snd . 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
  #if __GLASGOW_HASKELL__ >= 710
  -- TODO: Not implemented for 7.10 and up
  bindSuspensions _ = undefined
  #else
  bindSuspensions t = do
        hsc_env <- getSession
        inScope <- GHC.getBindings
        let ictxt        = hsc_IC hsc_env
            prefix       = "_t"
            alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
            availNames   = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
        availNames_var  <- liftIO $ newIORef availNames
        (t', stuff)     <- liftIO $ foldTerm (nameSuspensionsAndGetInfos availNames_var) t
        let (names, tys, hvals) = unzip3 stuff
        let ids = [ mkVanillaGlobal name ty
                  | (name,ty) <- zip names tys]
            new_ic = extendInteractiveContext ictxt (map AnId ids)
        liftIO $ extendLinkEnv (zip names hvals)
        modifySession $ \_ -> hsc_env {hsc_IC = new_ic }
        return t'
       where
  
  --    Processing suspensions. Give names and recopilate info
          nameSuspensionsAndGetInfos :: IORef [String] ->
                                         TermFold (IO (Term, [(Name,Type,HValue)]))
          nameSuspensionsAndGetInfos freeNames = TermFold
                        {
                          fSuspension = doSuspension freeNames
                        , fTerm = \ty dc v acts -> do
                                      tt' <- sequence acts
                                      let (terms,names) = unzip tt'
                                      return (Term ty dc v terms, concat names)
                        , fPrim    = \ty n ->return (Prim ty n,[])
                        , fNewtypeWrap  =
                                  \ty dc act -> do
                                      (term, names) <- act
                                      return (NewtypeWrap ty dc term, names)
                        , fRefWrap = \ty act -> do
                                      (term, names) <- act
                                      return (RefWrap ty term, names)
                        }
          doSuspension freeNames ct ty hval _name = do
            name <- atomicModifyIORef freeNames (\x->(tail x, head x))
            n <- newGrimName name
            return (Suspension ct ty hval (Just n), [(n,ty,hval)])
  #endif
  
  --    Create new uniques and give them sequentially numbered names
  newGrimName :: MonadIO m => String -> m Name
  newGrimName userName  = do
      us <- liftIO $ mkSplitUniqSupply 'b'
      let unique  = uniqFromSupply us
          occname = mkOccName varName userName
          name    = mkInternalName unique occname noSrcSpan
      return name
  
  {------------------------------------------------------------------------------
    Resolving names
  ------------------------------------------------------------------------------}
  
  resolveNames :: GhcMonad m => [Name] -> m [Id]
  resolveNames names = do
      tyThings <- catMaybes `liftM` mapM lookupName names
      return $ idsFromTyThings tyThings
    where
      idsFromTyThings :: [TyThing] -> [Id]
      idsFromTyThings = catMaybes . map aux
        where
          aux (AnId id) = Just id
          aux _         = Nothing
  
  parseNames :: GhcMonad m => String -> m [Name]
  parseNames str = concatMapM parseName (words str)
  
  