{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall #-}

{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP
-- {-# OPTIONS_GHC -fno-warn-unused-binds   #-} -- TEMP

----------------------------------------------------------------------
-- |
-- Module      :  ConCat.BuildDictionary
-- Copyright   :  (c) 2016 Conal Elliott
-- License     :  BSD3
--
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
--
-- Adaptation of HERMIT's buildDictionaryT
----------------------------------------------------------------------

module ConCat.BuildDictionary
  (buildDictionary
  ,WithType
  ,withType, withExplicitType
  ,varWithType
  ,uniqSetToList
  ,annotateEvidence
  ) where

import Data.Monoid (Any(..))
import Data.Char (isSpace)
import Control.Monad (filterM,when)
import Control.Arrow (second)

#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
import GHC.Core.Predicate
import GHC.Core.TyCo.Rep (CoercionHole(..), Type(..))
import GHC.Core.TyCon (isTupleTyCon)
import GHC.HsToCore.Binds
import GHC.HsToCore.Monad
import GHC.Plugins
import GHC.Tc.Errors(warnAllUnsolved)
import GHC.Tc.Module
import GHC.Tc.Solver
import GHC.Tc.Solver.Interact (solveSimpleGivens)
import GHC.Tc.Solver.Monad -- (TcS,runTcS)
import GHC.Tc.Types
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Evidence (evBindMapBinds)
import GHC.Tc.Types.Origin
import qualified GHC.Tc.Utils.Instantiate as TcMType
import GHC.Tc.Utils.Monad (getCtLocM,traceTc)
import GHC.Tc.Utils.Zonk (emptyZonkEnv,zonkEvBinds)
import GHC.Types.Unique (mkUniqueGrimily)
import qualified GHC.Types.Unique.Set as NonDetSet
import GHC.Core.FVs (exprFreeVars)
#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
import GHC.Runtime.Eval.Types (IcGlobalRdrEnv(..))
import GHC.Driver.Config.Finder (initFinderOpts)
import GHC.Core.InstEnv (mkInstEnv)
import GHC.Data.Maybe (expectJust)
#endif
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
import GHC.Runtime.Context (InteractiveContext (..), InteractiveImport (..))
import GHC.Types.Error (getErrorMessages, getWarningMessages)
import GHC.Unit.Finder (FindResult (..), findExposedPackageModule)
import GHC.Unit.Module.Deps (Dependencies (..))
import GHC.Utils.Error (pprMsgEnvelopeBagWithLoc)
#else
import GHC.Driver.Finder (findExposedPackageModule)
import GHC.Utils.Error (pprErrMsgBagWithLoc)
#endif
#else
import GhcPlugins
import TyCoRep (CoercionHole(..), Type(..))
import TyCon (isTupleTyCon)
import TcHsSyn (emptyZonkEnv,zonkEvBinds)
import           TcRnMonad (getCtLocM,traceTc)
import Constraint
import TcOrigin
import Predicate
import TcInteract (solveSimpleGivens)
import TcSMonad -- (TcS,runTcS)
import TcEvidence (evBindMapBinds)
import TcErrors(warnAllUnsolved)
import qualified TcMType as TcMType

import DsMonad
import DsBinds
import           TcSimplify
import           TcRnTypes
import ErrUtils (pprErrMsgBagWithLoc)
import Unique (mkUniqueGrimily)
import Finder (findExposedPackageModule)

import TcRnDriver
import qualified UniqSet as NonDetSet
#endif
-- Temp
-- import HERMIT.GHC.Typechecker (initTcFromModGuts)
-- import ConCat.GHC

import ConCat.Simplify

#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
import GHC.Utils.Trace
#endif

isEvVarType' :: Type -> Bool
isEvVarType' :: Type -> Bool
isEvVarType' = Type -> Bool
isEvVarType

isFound :: FindResult -> Bool
isFound :: FindResult -> Bool
isFound (Found ModLocation
_ Module
_) = Bool
True
isFound FindResult
_           = Bool
False

moduleIsOkay :: HscEnv -> DynFlags -> ModuleName -> IO Bool
#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
moduleIsOkay :: HscEnv -> DynFlags -> ModuleName -> IO Bool
moduleIsOkay HscEnv
env DynFlags
dflags ModuleName
mname =
  FindResult -> Bool
isFound (FindResult -> Bool) -> IO FindResult -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FinderCache
-> FinderOpts
-> UnitState
-> ModuleName
-> PkgQual
-> IO FindResult
findExposedPackageModule (HscEnv -> FinderCache
hsc_FC HscEnv
env) (DynFlags -> FinderOpts
initFinderOpts DynFlags
dflags) ((() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
env) ModuleName
mname PkgQual
NoPkgQual
#else
moduleIsOkay env _dflags mname = isFound <$> findExposedPackageModule env mname Nothing
#endif

mkLocalId' :: HasDebugCallStack => Name -> Type -> Id
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
mkLocalId' :: (() :: Constraint) => Name -> Type -> Var
mkLocalId' Name
n = (() :: Constraint) => Name -> Type -> Type -> Var
Name -> Type -> Type -> Var
mkLocalId Name
n Type
One
#else
mkLocalId' = mkLocalId
#endif

mkWildCase' :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
mkWildCase' :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase' CoreExpr
ce Type
t = CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
ce (Type -> Scaled Type
forall a. a -> Scaled a
linear Type
t)
#else
mkWildCase' = mkWildCase
#endif

uniqSetToList ::  UniqSet a -> [a]
uniqSetToList :: forall a. UniqSet a -> [a]
uniqSetToList = UniqSet a -> [a]
forall a. UniqSet a -> [a]
NonDetSet.nonDetEltsUniqSet
-- #define TRACING

pprTrace' :: String -> SDoc -> a -> a
#ifdef TRACING
pprTrace' = pprTrace
#else
pprTrace' :: forall a. String -> SDoc -> a -> a
pprTrace' String
_ SDoc
_ = a -> a
forall a. a -> a
id
#endif

traceTcS' :: String -> SDoc -> TcS ()
traceTcS' :: String -> SDoc -> TcS ()
traceTcS' String
str SDoc
doc = String -> SDoc -> TcS () -> TcS ()
forall a. String -> SDoc -> a -> a
pprTrace' String
str SDoc
doc (() -> TcS ()
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

traceTc' :: String -> SDoc -> TcRn ()
traceTc' :: String -> SDoc -> TcRn ()
traceTc' String
str SDoc
doc = String -> SDoc -> TcRn () -> TcRn ()
forall a. String -> SDoc -> a -> a
pprTrace' String
str SDoc
doc (() -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

runTcM :: HscEnv -> DynFlags -> ModGuts -> TcM a -> IO a
runTcM :: forall a. HscEnv -> DynFlags -> ModGuts -> TcM a -> IO a
runTcM HscEnv
env0 DynFlags
dflags ModGuts
guts TcM a
m = do
    -- Remove hidden modules from dep_orphans
    [ModuleName]
orphans <- (ModuleName -> IO Bool) -> [ModuleName] -> IO [ModuleName]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (HscEnv -> DynFlags -> ModuleName -> IO Bool
moduleIsOkay HscEnv
env0 DynFlags
dflags) (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName) -> [Module] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dependencies -> [Module]
dep_orphs (ModGuts -> Dependencies
mg_deps ModGuts
guts))
    -- pprTrace' "runTcM orphans" (ppr orphans) (return ())
    (Messages TcRnMessage
msgs, Maybe a
mr) <- HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a)
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive ([ModuleName] -> HscEnv
env [ModuleName]
orphans) TcM a
m
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
    let showMsgs :: Messages e -> String
showMsgs Messages e
msg = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$
              String -> SDoc
text String
"Errors:"   SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: Bag (MsgEnvelope e) -> [SDoc]
forall e. Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc (Messages e -> Bag (MsgEnvelope e)
forall e. Diagnostic e => Messages e -> Bag (MsgEnvelope e)
getErrorMessages Messages e
msg)
           [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ String -> SDoc
text String
"Warnings:" SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: Bag (MsgEnvelope e) -> [SDoc]
forall e. Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc (Messages e -> Bag (MsgEnvelope e)
forall e. Diagnostic e => Messages e -> Bag (MsgEnvelope e)
getWarningMessages Messages e
msg)
#else
    let showMsgs (warns, errs) = showSDoc dflags $ vcat $
              text "Errors:"   : pprErrMsgBagWithLoc errs
           ++ text "Warnings:" : pprErrMsgBagWithLoc warns
#endif
    IO a -> (a -> IO a) -> Maybe a -> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO a
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ Messages TcRnMessage -> String
forall {e}. Diagnostic e => Messages e -> String
showMsgs Messages TcRnMessage
msgs) a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mr
 where
   imports0 :: [InteractiveImport]
imports0 = InteractiveContext -> [InteractiveImport]
ic_imports (HscEnv -> InteractiveContext
hsc_IC HscEnv
env0)
   env :: [ModuleName] -> HscEnv
   env :: [ModuleName] -> HscEnv
env [ModuleName]
extraModuleNames =
     -- pprTrace' "runTcM extraModuleNames" (ppr extraModuleNames) $
     -- pprTrace' "runTcM dep_mods" (ppr (dep_mods (mg_deps guts))) $
     -- pprTrace' "runTcM dep_orphs" (ppr (dep_orphs (mg_deps guts))) $
     -- pprTrace' "runTcM dep_finsts" (ppr (dep_finsts (mg_deps guts))) $
     -- pprTrace' "runTcM mg_insts" (ppr (mg_insts guts)) $
     -- pprTrace' "runTcM fam_mg_insts" (ppr (mg_fam_insts guts)) $
     -- pprTrace' "runTcM imports0" (ppr imports0) $
     -- pprTrace' "runTcM mg_rdr_env guts" (ppr (mg_rdr_env guts)) $
     -- pprTrace' "runTcM ic_rn_gbl_env" (ppr (ic_rn_gbl_env (hsc_IC env0))) $
     HscEnv
env0 { hsc_IC :: InteractiveContext
hsc_IC = (HscEnv -> InteractiveContext
hsc_IC HscEnv
env0)
             { ic_imports :: [InteractiveImport]
ic_imports = (ModuleName -> InteractiveImport)
-> [ModuleName] -> [InteractiveImport]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> InteractiveImport
IIModule [ModuleName]
extraModuleNames [InteractiveImport] -> [InteractiveImport] -> [InteractiveImport]
forall a. [a] -> [a] -> [a]
++ [InteractiveImport]
imports0
#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
             , ic_gre_cache :: IcGlobalRdrEnv
ic_gre_cache = IcGlobalRdrEnv { igre_env :: GlobalRdrEnv
igre_env = ModGuts -> GlobalRdrEnv
mg_rdr_env ModGuts
guts, igre_prompt_env :: GlobalRdrEnv
igre_prompt_env = GlobalRdrEnv
emptyGlobalRdrEnv }
             , ic_instances :: (InstEnv, [FamInst])
ic_instances = ([ClsInst] -> InstEnv
mkInstEnv (ModGuts -> [ClsInst]
mg_insts ModGuts
guts), ModGuts -> [FamInst]
mg_fam_insts ModGuts
guts)
#else
             , ic_rn_gbl_env = mg_rdr_env guts
             , ic_instances = (mg_insts guts, mg_fam_insts guts)
#endif
             } }
     -- env0

-- TODO: Try initTcForLookup or initTcInteractive in place of initTcFromModGuts.
-- If successful, drop dflags and guts arguments.

runDsM :: HscEnv -> DynFlags -> ModGuts -> DsM a -> IO a
#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
runDsM :: forall a. HscEnv -> DynFlags -> ModGuts -> DsM a -> IO a
runDsM HscEnv
env DynFlags
dflags ModGuts
guts DsM a
dsm = HscEnv -> DynFlags -> ModGuts -> TcM a -> IO a
forall a. HscEnv -> DynFlags -> ModGuts -> TcM a -> IO a
runTcM HscEnv
env DynFlags
dflags ModGuts
guts (TcM a -> IO a) -> TcM a -> IO a
forall a b. (a -> b) -> a -> b
$ do
  (Messages DsMessage
_tc_msgs, Maybe a
mb_result) <- DsM a -> TcM (Messages DsMessage, Maybe a)
forall a. DsM a -> TcM (Messages DsMessage, Maybe a)
initDsTc DsM a
dsm
  a -> TcM a
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe a -> a
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"initDsTc" Maybe a
mb_result)
#else
runDsM env dflags guts = runTcM env dflags guts . initDsTc
#endif

#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
unkskol :: SkolemInfoAnon
unkskol :: SkolemInfoAnon
unkskol = SkolemInfoAnon
HasCallStack => SkolemInfoAnon
unkSkolAnon
#else
unkskol :: SkolemInfo
unkskol = UnkSkol
#endif



-- | Build a dictionary for the given id
buildDictionary' :: HscEnv -> DynFlags -> ModGuts -> VarSet -> Type
                 -> IO (Maybe (Id, [CoreBind]))
buildDictionary' :: HscEnv
-> DynFlags
-> ModGuts
-> VarSet
-> Type
-> IO (Maybe (Var, [CoreBind]))
buildDictionary' HscEnv
env DynFlags
dflags ModGuts
guts VarSet
evIds Type
predTy =
  do Maybe (Var, Bag EvBind)
res <-
       HscEnv
-> DynFlags
-> ModGuts
-> TcM (Maybe (Var, Bag EvBind))
-> IO (Maybe (Var, Bag EvBind))
forall a. HscEnv -> DynFlags -> ModGuts -> TcM a -> IO a
runTcM HscEnv
env DynFlags
dflags ModGuts
guts (TcM (Maybe (Var, Bag EvBind)) -> IO (Maybe (Var, Bag EvBind)))
-> TcM (Maybe (Var, Bag EvBind)) -> IO (Maybe (Var, Bag EvBind))
forall a b. (a -> b) -> a -> b
$
       do CtLoc
loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM (SkolemInfoAnon -> CtOrigin
GivenOrigin SkolemInfoAnon
unkskol) Maybe TypeOrKind
forall a. Maybe a
Nothing
          CtEvidence
evidence <- CtOrigin -> Maybe TypeOrKind -> Type -> TcM CtEvidence
TcMType.newWanted (SkolemInfoAnon -> CtOrigin
GivenOrigin SkolemInfoAnon
unkskol) Maybe TypeOrKind
forall a. Maybe a
Nothing Type
predTy
          let EvVarDest Var
evarDest = CtEvidence -> TcEvDest
ctev_dest CtEvidence
evidence
              givens :: [Ct]
givens = CtLoc -> [Var] -> [Ct]
mkGivens CtLoc
loc (VarSet -> [Var]
forall a. UniqSet a -> [a]
uniqSetToList VarSet
evIds)
              wCs :: WantedConstraints
wCs = [CtEvidence] -> WantedConstraints
mkSimpleWC [CtEvidence
evidence]
          -- TODO: Make sure solveWanteds is the right function to call.
          String -> SDoc -> TcRn ()
traceTc' String
"buildDictionary': givens" ([Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
givens)
          (WantedConstraints
wantedConstraints, Bag EvBind
bnds0) <-
            (EvBindMap -> Bag EvBind)
-> (WantedConstraints, EvBindMap)
-> (WantedConstraints, Bag EvBind)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second EvBindMap -> Bag EvBind
evBindMapBinds ((WantedConstraints, EvBindMap) -> (WantedConstraints, Bag EvBind))
-> IOEnv (Env TcGblEnv TcLclEnv) (WantedConstraints, EvBindMap)
-> IOEnv (Env TcGblEnv TcLclEnv) (WantedConstraints, Bag EvBind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            TcS WantedConstraints
-> IOEnv (Env TcGblEnv TcLclEnv) (WantedConstraints, EvBindMap)
forall a. TcS a -> TcM (a, EvBindMap)
runTcS (do ()
_ <- [Ct] -> TcS ()
solveSimpleGivens [Ct]
givens
                       String -> SDoc -> TcS ()
traceTcS' String
"buildDictionary' back from solveSimpleGivens" SDoc
empty
                       WantedConstraints
z <- WantedConstraints -> TcS WantedConstraints
solveWanteds WantedConstraints
wCs
                       String -> SDoc -> TcS ()
traceTcS' String
"buildDictionary' back from solveWanteds" (WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
z)
                       WantedConstraints -> TcS WantedConstraints
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
z
                   )
          String -> SDoc -> TcRn ()
traceTc' String
"buildDictionary' back from runTcS" (Bag EvBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag EvBind
bnds0)
          ZonkEnv
ez <- TcM ZonkEnv
emptyZonkEnv
          -- Use the newly exported zonkEvBinds. <https://phabricator.haskell.org/D2088>
          (ZonkEnv
_env',Bag EvBind
bnds) <- ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
zonkEvBinds ZonkEnv
ez Bag EvBind
bnds0
          -- traceTc "buildDictionary' _wCs'" (ppr _wCs')
          -- changed next line from reportAllUnsolved, which panics. revisit and fix!
          -- warnAllUnsolved _wCs'
          String -> SDoc -> TcRn ()
traceTc' String
"buildDictionary' zonked" (Bag EvBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag EvBind
bnds)
          if WantedConstraints -> Bool
isEmptyWC WantedConstraints
wantedConstraints
          then Maybe (Var, Bag EvBind) -> TcM (Maybe (Var, Bag EvBind))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Var, Bag EvBind) -> Maybe (Var, Bag EvBind)
forall a. a -> Maybe a
Just (Var
evarDest, Bag EvBind
bnds))
          else Maybe (Var, Bag EvBind) -> TcM (Maybe (Var, Bag EvBind))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Var, Bag EvBind)
forall a. Maybe a
Nothing
     case Maybe (Var, Bag EvBind)
res of
       Just (Var
i, Bag EvBind
bs) ->
         do [CoreBind]
bs' <- HscEnv -> DynFlags -> ModGuts -> DsM [CoreBind] -> IO [CoreBind]
forall a. HscEnv -> DynFlags -> ModGuts -> DsM a -> IO a
runDsM HscEnv
env DynFlags
dflags ModGuts
guts (Bag EvBind -> DsM [CoreBind]
dsEvBinds Bag EvBind
bs)
            Maybe (Var, [CoreBind]) -> IO (Maybe (Var, [CoreBind]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Var, [CoreBind]) -> Maybe (Var, [CoreBind])
forall a. a -> Maybe a
Just (Var
i, [CoreBind]
bs'))
       Maybe (Var, Bag EvBind)
Nothing -> Maybe (Var, [CoreBind]) -> IO (Maybe (Var, [CoreBind]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Var, [CoreBind])
forall a. Maybe a
Nothing


-- TODO: Try to combine the two runTcM calls.

buildDictionary :: HscEnv -> DynFlags -> ModGuts -> UniqSupply -> InScopeEnv -> Type -> CoreExpr -> Type -> IO (Either SDoc CoreExpr)
buildDictionary :: HscEnv
-> DynFlags
-> ModGuts
-> UniqSupply
-> InScopeEnv
-> Type
-> CoreExpr
-> Type
-> IO (Either SDoc CoreExpr)
buildDictionary HscEnv
env DynFlags
dflags ModGuts
guts UniqSupply
uniqSupply InScopeEnv
inScope evType :: Type
evType@(TyConApp TyCon
tyCon [Type]
evTypes) CoreExpr
ev Type
goalTy | TyCon -> Bool
isTupleTyCon TyCon
tyCon =
  HscEnv
-> DynFlags
-> ModGuts
-> UniqSupply
-> InScopeEnv
-> Type
-> [Type]
-> CoreExpr
-> Type
-> IO (Either SDoc CoreExpr)
reallyBuildDictionary HscEnv
env DynFlags
dflags ModGuts
guts UniqSupply
uniqSupply InScopeEnv
inScope Type
evType [Type]
evTypes CoreExpr
ev Type
goalTy
-- only 1-tuples in Haskell  
buildDictionary HscEnv
env DynFlags
dflags ModGuts
guts UniqSupply
uniqSupply InScopeEnv
inScope Type
evType CoreExpr
ev Type
goalTy | Type -> Bool
isEvVarType' Type
evType =
  HscEnv
-> DynFlags
-> ModGuts
-> UniqSupply
-> InScopeEnv
-> Type
-> [Type]
-> CoreExpr
-> Type
-> IO (Either SDoc CoreExpr)
reallyBuildDictionary HscEnv
env DynFlags
dflags ModGuts
guts UniqSupply
uniqSupply InScopeEnv
inScope Type
evType [Type
evType] CoreExpr
ev Type
goalTy
buildDictionary HscEnv
_env DynFlags
_dflags ModGuts
_guts UniqSupply
_uniqSupply InScopeEnv
_inScope Type
evT CoreExpr
_ev Type
_goalTy = String -> SDoc -> IO (Either SDoc CoreExpr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"evidence type mismatch" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
evT)
                                                         
reallyBuildDictionary :: HscEnv -> DynFlags -> ModGuts -> UniqSupply -> InScopeEnv -> Type -> [Type] -> CoreExpr -> Type -> IO (Either SDoc CoreExpr)
reallyBuildDictionary :: HscEnv
-> DynFlags
-> ModGuts
-> UniqSupply
-> InScopeEnv
-> Type
-> [Type]
-> CoreExpr
-> Type
-> IO (Either SDoc CoreExpr)
reallyBuildDictionary HscEnv
env DynFlags
dflags ModGuts
guts UniqSupply
uniqSupply InScopeEnv
inScope Type
evType [Type]
evTypes CoreExpr
ev Type
goalTy =
  String
-> SDoc -> IO (Either SDoc CoreExpr) -> IO (Either SDoc CoreExpr)
forall a. String -> SDoc -> a -> a
pprTrace' String
"\nbuildDictionary" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
goalTy) (IO (Either SDoc CoreExpr) -> IO (Either SDoc CoreExpr))
-> IO (Either SDoc CoreExpr) -> IO (Either SDoc CoreExpr)
forall a b. (a -> b) -> a -> b
$
  String
-> SDoc -> IO (Either SDoc CoreExpr) -> IO (Either SDoc CoreExpr)
forall a. String -> SDoc -> a -> a
pprTrace' String
"buildDictionary in-scope evidence" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
ev) (IO (Either SDoc CoreExpr) -> IO (Either SDoc CoreExpr))
-> IO (Either SDoc CoreExpr) -> IO (Either SDoc CoreExpr)
forall a b. (a -> b) -> a -> b
$
  Maybe (Var, [CoreBind]) -> Either SDoc CoreExpr
reassemble (Maybe (Var, [CoreBind]) -> Either SDoc CoreExpr)
-> IO (Maybe (Var, [CoreBind])) -> IO (Either SDoc CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv
-> DynFlags
-> ModGuts
-> VarSet
-> Type
-> IO (Maybe (Var, [CoreBind]))
buildDictionary' HscEnv
env DynFlags
dflags ModGuts
guts VarSet
evIdSet Type
goalTy
 where
   evIds :: [Var]
evIds = [ Var
local
           | (Type
evTy, Unique
unq) <- [Type]
evTypes [Type] -> [Unique] -> [(Type, Unique)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
uniqSupply)
           , let local :: Var
local = (() :: Constraint) => Name -> Type -> Var
Name -> Type -> Var
mkLocalId' (Unique -> FastString -> Name
mkSystemVarName Unique
unq FastString
evVarName) Type
evTy ]
   evIdSet :: VarSet
evIdSet = [Var] -> VarSet
mkVarSet [Var]
evIds
   reassemble :: Maybe (Var, [CoreBind]) -> Either SDoc CoreExpr
reassemble Maybe (Var, [CoreBind])
Nothing =
     SDoc -> Either SDoc CoreExpr
forall a b. a -> Either a b
Left (String -> SDoc
text String
"unsolved constraints")
   reassemble (Just (Var
i,[CoreBind]
bnds)) =
     String -> SDoc -> Either SDoc CoreExpr -> Either SDoc CoreExpr
forall a. String -> SDoc -> a -> a
pprTrace' String
"buildDictionary" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
goalTy SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"-->" SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr) (Either SDoc CoreExpr -> Either SDoc CoreExpr)
-> Either SDoc CoreExpr -> Either SDoc CoreExpr
forall a b. (a -> b) -> a -> b
$
     String -> SDoc -> Either SDoc CoreExpr -> Either SDoc CoreExpr
forall a. String -> SDoc -> a -> a
pprTrace' String
"buildDictionary evIds" ([Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
evIds) (Either SDoc CoreExpr -> Either SDoc CoreExpr)
-> Either SDoc CoreExpr -> Either SDoc CoreExpr
forall a b. (a -> b) -> a -> b
$
     String -> SDoc -> Either SDoc CoreExpr -> Either SDoc CoreExpr
forall a. String -> SDoc -> a -> a
pprTrace' String
"buildDictionary expr" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr) (Either SDoc CoreExpr -> Either SDoc CoreExpr)
-> Either SDoc CoreExpr -> Either SDoc CoreExpr
forall a b. (a -> b) -> a -> b
$
     (SDoc -> Either SDoc CoreExpr)
-> (CoreExpr -> Either SDoc CoreExpr)
-> Either SDoc CoreExpr
-> Either SDoc CoreExpr
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ SDoc
e -> String -> SDoc -> Either SDoc CoreExpr -> Either SDoc CoreExpr
forall a. String -> SDoc -> a -> a
pprTrace' String
"buildDictionary fail" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
goalTy SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"-->" SDoc -> SDoc -> SDoc
$$ SDoc
e) Either SDoc CoreExpr
res) (Either SDoc CoreExpr -> CoreExpr -> Either SDoc CoreExpr
forall a b. a -> b -> a
const Either SDoc CoreExpr
res) (Either SDoc CoreExpr -> Either SDoc CoreExpr)
-> Either SDoc CoreExpr -> Either SDoc CoreExpr
forall a b. (a -> b) -> a -> b
$
     Either SDoc CoreExpr
res
    where
      res :: Either SDoc CoreExpr
res | [CoreBind] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreBind]
bnds          = SDoc -> Either SDoc CoreExpr
forall a b. a -> Either a b
Left (String -> SDoc
text String
"no bindings")
          | Bool
otherwise          = CoreExpr -> Either SDoc CoreExpr
forall a. a -> Either SDoc a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> Either SDoc CoreExpr)
-> CoreExpr -> Either SDoc CoreExpr
forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags -> InScopeSet -> Bool -> CoreExpr -> CoreExpr
simplifyE HscEnv
env DynFlags
dflags (InScopeEnv -> InScopeSet
forall a b. (a, b) -> a
fst InScopeEnv
inScope) Bool
False
                                          CoreExpr
expr
      dict :: CoreExpr
dict =
        case [CoreBind]
bnds of
          -- Common case with single non-recursive let
          [NonRec Var
v CoreExpr
e] | Var
i Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
v -> CoreExpr
e
          [CoreBind]
_                     -> [CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
bnds (Var -> CoreExpr
forall b. Var -> Expr b
varToCoreExpr Var
i)
      -- could optimize if these things are already variables
      expr :: CoreExpr
expr = if [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
evTypes
             then CoreExpr
dict
             else case [Var]
evIds of
                    [Var
evId] -> CoreBind -> CoreExpr -> CoreExpr
mkCoreLet (Var -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Var
evId CoreExpr
ev) CoreExpr
dict
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
                    [Var]
_ -> CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase' CoreExpr
ev Type
evType Type
goalTy [AltCon -> [Var] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Boxed ([Var] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Var]
evIds))) [Var]
evIds CoreExpr
dict]
#else
                    _ -> mkWildCase' ev evType goalTy [(DataAlt (tupleDataCon Boxed (length evIds)), evIds, dict)]
#endif

evVarName :: FastString
evVarName :: FastString
evVarName = String -> FastString
mkFastString String
"evidence"

-- Transform calls to a function that requires a dictionary into one
-- another one that also takes a tuple of available locally-bound
-- dictionaries.  (Note that inScope contains a superset of these
-- variables, including some that will be unbound in the final output
-- code.)

extendEvVars :: DVarSet -> Var -> DVarSet
extendEvVars :: DVarSet -> Var -> DVarSet
extendEvVars DVarSet
evVars Var
var =
  -- isEvType would also include constraints, which are unboxed and
  -- thus we can't put those in a boxed tuple
  if (() :: Constraint) => Type -> Bool
Type -> Bool
isPredTy (Var -> Type
varType Var
var)
  then DVarSet -> Var -> DVarSet
extendDVarSet DVarSet
evVars Var
var
  else DVarSet
evVars

extendEvVarsList :: DVarSet -> [Var] -> DVarSet
extendEvVarsList :: DVarSet -> [Var] -> DVarSet
extendEvVarsList DVarSet
evVars [Var]
vars =
  DVarSet -> [Var] -> DVarSet
extendDVarSetList DVarSet
evVars ((Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filter Var -> Bool
isEvVar [Var]
vars)

annotateEvidence :: Id -> Id -> Int -> CoreBind -> CoreM CoreBind
annotateEvidence :: Var -> Var -> Arity -> CoreBind -> CoreM CoreBind
annotateEvidence Var
fnId Var
fnId' Arity
typeArgsCount (NonRec Var
var CoreExpr
expr) =
  do let expr' :: CoreExpr
expr' = Var -> Var -> Arity -> CoreExpr -> CoreExpr
annotateExpr Var
fnId Var
fnId' Arity
typeArgsCount CoreExpr
expr
     CoreBind -> CoreM CoreBind
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Var
var CoreExpr
expr')
annotateEvidence Var
fnId Var
fnId' Arity
typeArgsCount (Rec [(Var, CoreExpr)]
bindings) =
  do [(Var, CoreExpr)]
bindings' <- ((Var, CoreExpr) -> CoreM (Var, CoreExpr))
-> [(Var, CoreExpr)] -> CoreM [(Var, CoreExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ (Var
var, CoreExpr
expr) ->
                          do let expr' :: CoreExpr
expr' = Var -> Var -> Arity -> CoreExpr -> CoreExpr
annotateExpr Var
fnId Var
fnId' Arity
typeArgsCount CoreExpr
expr
                             (Var, CoreExpr) -> CoreM (Var, CoreExpr)
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var
var, CoreExpr
expr'))
                       [(Var, CoreExpr)]
bindings
     CoreBind -> CoreM CoreBind
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Var, CoreExpr)]
bindings')

annotateExpr :: Id -> Id -> Int -> CoreExpr -> CoreExpr
-- annotateExpr _fnId _fnId' _typeArgsCount expr | pprTrace "annotateExpr" (ppr expr) False = undefined
annotateExpr :: Var -> Var -> Arity -> CoreExpr -> CoreExpr
annotateExpr Var
fnId Var
fnId' Arity
typeArgsCount CoreExpr
expr0 =
  DVarSet -> CoreExpr -> CoreExpr
go DVarSet
emptyDVarSet CoreExpr
expr0
  where
    go :: DVarSet -> CoreExpr -> CoreExpr
go DVarSet
_evVars expr :: CoreExpr
expr@(Var Var
_) = CoreExpr
expr
    go DVarSet
_evVars expr :: CoreExpr
expr@(Lit Literal
_) = CoreExpr
expr
    go DVarSet
evVars expr :: CoreExpr
expr@(CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs -> (Var ((Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
fnId) -> Bool
True), [CoreExpr]
args)) =
       let ([CoreExpr]
tyArgs, [CoreExpr]
valArgs) = Arity -> [CoreExpr] -> ([CoreExpr], [CoreExpr])
forall a. Arity -> [a] -> ([a], [a])
splitAt Arity
typeArgsCount [CoreExpr]
args
       in if [CoreExpr] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [CoreExpr]
tyArgs Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
< Arity
typeArgsCount
          then String -> SDoc -> CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unsaturated call to target function" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr)
          else
            let evVarExp :: CoreExpr
evVarExp = [CoreExpr] -> CoreExpr
mkCoreTup ((Var -> CoreExpr) -> [Var] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Var -> CoreExpr
forall b. Var -> Expr b
Var (DVarSet -> [Var]
dVarSetElems DVarSet
evVars))
                valArgs' :: [CoreExpr]
valArgs' = (CoreExpr -> CoreExpr) -> [CoreExpr] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars) [CoreExpr]
valArgs
            in CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
fnId') ([CoreExpr]
tyArgs [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [Type -> CoreExpr
forall b. Type -> Expr b
Type ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
evVarExp), CoreExpr
evVarExp] [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
valArgs')
    go DVarSet
evVars (App CoreExpr
fn CoreExpr
arg) =
      let fn' :: CoreExpr
fn' = DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars CoreExpr
fn
          arg' :: CoreExpr
arg' = DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars CoreExpr
arg
      in CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fn' CoreExpr
arg'
    go DVarSet
evVars (Lam Var
var CoreExpr
body) =
      let evVars' :: DVarSet
evVars' = DVarSet -> Var -> DVarSet
extendEvVars DVarSet
evVars Var
var
          body' :: CoreExpr
body' = DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars' CoreExpr
body
      in Var -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Var
var CoreExpr
body'
    go DVarSet
evVars (Let (NonRec Var
var CoreExpr
rhs) CoreExpr
body) =
      let rhs' :: CoreExpr
rhs' = DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars CoreExpr
rhs
          body' :: CoreExpr
body' = DVarSet -> CoreExpr -> CoreExpr
go (DVarSet -> Var -> DVarSet
extendEvVars DVarSet
evVars Var
var) CoreExpr
body
      in CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Var -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Var
var CoreExpr
rhs') CoreExpr
body'
    go DVarSet
evVars (Let (Rec [(Var, CoreExpr)]
bindings) CoreExpr
body) =
      let evVars' :: DVarSet
evVars' = DVarSet -> [Var] -> DVarSet
extendEvVarsList DVarSet
evVars (((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
bindings)
          bindings' :: [(Var, CoreExpr)]
bindings' = ((Var, CoreExpr) -> (Var, CoreExpr))
-> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Var
var, CoreExpr
expr) -> (Var
var, DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars' CoreExpr
expr))
                           [(Var, CoreExpr)]
bindings
          body' :: CoreExpr
body' = DVarSet -> CoreExpr -> CoreExpr
go  DVarSet
evVars' CoreExpr
body
      in CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let ([(Var, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Var, CoreExpr)]
bindings') CoreExpr
body'
    go DVarSet
evVars (Case CoreExpr
scrutinee Var
var Type
ty [CoreAlt]
alts) =
      let evVars' :: DVarSet
evVars' = DVarSet -> Var -> DVarSet
extendEvVars DVarSet
evVars Var
var
          scrutinee' :: CoreExpr
scrutinee' = DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars CoreExpr
scrutinee
          alts' :: [CoreAlt]
alts' = (CoreAlt -> CoreAlt) -> [CoreAlt] -> [CoreAlt]
forall a b. (a -> b) -> [a] -> [b]
map (DVarSet -> CoreAlt -> CoreAlt
annotateAlt DVarSet
evVars') [CoreAlt]
alts
      in CoreExpr -> Var -> Type -> [CoreAlt] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrutinee' Var
var Type
ty [CoreAlt]
alts'
    go DVarSet
evVars (Cast CoreExpr
expr CoercionR
coercion) =
      let expr' :: CoreExpr
expr' = DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars CoreExpr
expr
      in CoreExpr -> CoercionR -> CoreExpr
forall b. Expr b -> CoercionR -> Expr b
Cast CoreExpr
expr' CoercionR
coercion
    go DVarSet
evVars (Tick CoreTickish
tickish CoreExpr
expr) =
      let expr' :: CoreExpr
expr' = DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars CoreExpr
expr
      in CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish CoreExpr
expr'
    go DVarSet
_evVars expr :: CoreExpr
expr@(Type Type
_) = CoreExpr
expr
    go DVarSet
_evVars expr :: CoreExpr
expr@(Coercion CoercionR
_) = CoreExpr
expr

#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
    annotateAlt :: DVarSet -> CoreAlt -> CoreAlt
annotateAlt DVarSet
evVars (Alt AltCon
con [Var]
binders CoreExpr
rhs) =
      AltCon -> [Var] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Var]
binders (CoreExpr -> CoreAlt) -> CoreExpr -> CoreAlt
forall a b. (a -> b) -> a -> b
$ DVarSet -> CoreExpr -> CoreExpr
go (DVarSet -> [Var] -> DVarSet
extendEvVarsList DVarSet
evVars [Var]
binders) CoreExpr
rhs
#else
    annotateAlt evVars (con, binders, rhs) =
      (con, binders, go (extendEvVarsList evVars binders) rhs)
#endif

-- Maybe place in a GHC utils module.

withType :: CoreExpr -> WithType
withType :: CoreExpr -> WithType
withType CoreExpr
e = CoreExpr -> Type -> WithType
WithType CoreExpr
e ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e)

withExplicitType :: CoreExpr -> Type -> WithType
withExplicitType :: CoreExpr -> Type -> WithType
withExplicitType CoreExpr
e Type
ty = CoreExpr -> Type -> WithType
WithType CoreExpr
e Type
ty 

varWithType :: Var -> WithType
varWithType :: Var -> WithType
varWithType = CoreExpr -> WithType
withType (CoreExpr -> WithType) -> (Var -> CoreExpr) -> Var -> WithType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> CoreExpr
forall b. Var -> Expr b
Var

data WithType = WithType CoreExpr Type

instance Outputable WithType where
  ppr :: WithType -> SDoc
ppr (WithType CoreExpr
e Type
ty) = CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty

newtype WithIdInfo = WithIdInfo Id

instance Outputable WithIdInfo where
  -- I wanted the full IdInfo, but it's not Outputtable
  -- ppr (WithIdInfo v) = ppr v <+> colon <+> ppr (occInfo (idInfo v))
  ppr :: WithIdInfo -> SDoc
ppr (WithIdInfo Var
v) = Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<+> SDoc
colon SDoc -> SDoc -> SDoc
<+> Maybe (TyCon, [Type]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe (Var -> Type
varType Var
v))