{-# LANGUAGE LambdaCase    #-}
{-# LANGUAGE TupleSections #-}

module GHC.Core.LateCC.OverloadedCalls
  ( overloadedCallsCC
  ) where

import GHC.Prelude

import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State.Strict
import qualified GHC.Data.Strict as Strict

import GHC.Data.FastString
import GHC.Core
import GHC.Core.LateCC.Utils
import GHC.Core.LateCC.Types
import GHC.Core.Make
import GHC.Core.Predicate
import GHC.Core.Type
import GHC.Core.Utils
import GHC.Tc.Utils.TcType
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.SrcLoc
import GHC.Types.Tickish
import GHC.Types.Var

type OverloadedCallsCCState = Strict.Maybe SrcSpan

-- | Insert cost centres on function applications with dictionary arguments. The
-- source locations attached to the cost centres is approximated based on the
-- "closest" source note encountered in the traversal.
overloadedCallsCC :: CoreBind -> LateCCM OverloadedCallsCCState CoreBind
overloadedCallsCC :: CoreBind -> LateCCM OverloadedCallsCCState CoreBind
overloadedCallsCC =
    CoreBind -> LateCCM OverloadedCallsCCState CoreBind
processBind
  where
    processBind :: CoreBind -> LateCCM OverloadedCallsCCState CoreBind
    processBind :: CoreBind -> LateCCM OverloadedCallsCCState CoreBind
processBind CoreBind
core_bind =
        case CoreBind
core_bind of
          NonRec CoreBndr
b Expr CoreBndr
e ->
            CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b (Expr CoreBndr -> CoreBind)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
-> LateCCM OverloadedCallsCCState CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreBndr
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
wrap_if_join CoreBndr
b (Expr CoreBndr
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
processExpr Expr CoreBndr
e)
          Rec [(CoreBndr, Expr CoreBndr)]
es ->
            [(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(CoreBndr, Expr CoreBndr)] -> CoreBind)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     [(CoreBndr, Expr CoreBndr)]
-> LateCCM OverloadedCallsCCState CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((CoreBndr, Expr CoreBndr)
 -> ReaderT
      LateCCEnv
      (State (LateCCState OverloadedCallsCCState))
      (CoreBndr, Expr CoreBndr))
-> [(CoreBndr, Expr CoreBndr)]
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     [(CoreBndr, Expr CoreBndr)]
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 (\(CoreBndr
b,Expr CoreBndr
e) -> (CoreBndr
b,) (Expr CoreBndr -> (CoreBndr, Expr CoreBndr))
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (CoreBndr, Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreBndr
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
wrap_if_join CoreBndr
b (Expr CoreBndr
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
processExpr Expr CoreBndr
e)) [(CoreBndr, Expr CoreBndr)]
es
      where
        -- If an overloaded function is turned into a join point, we won't add
        -- SCCs directly to calls since it makes them non-tail calls. Instead,
        -- we look for join points here and add an SCC to their RHS if they are
        -- overloaded.
        wrap_if_join ::
             CoreBndr
          -> LateCCM OverloadedCallsCCState CoreExpr
          -> LateCCM OverloadedCallsCCState CoreExpr
        wrap_if_join :: CoreBndr
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
wrap_if_join CoreBndr
b ReaderT
  LateCCEnv
  (State (LateCCState OverloadedCallsCCState))
  (Expr CoreBndr)
pexpr = do
            expr <- ReaderT
  LateCCEnv
  (State (LateCCState OverloadedCallsCCState))
  (Expr CoreBndr)
pexpr
            if isJoinId b && isOverloadedTy (exprType expr) then do
              let
                cc_name :: FastString
                cc_name = String -> FastString
fsLit String
"join-rhs-" FastString -> FastString -> FastString
`appendFS` CoreBndr -> FastString
forall a. NamedThing a => a -> FastString
getOccFS CoreBndr
b

              cc_srcspan <-
                fmap (Strict.fromMaybe (UnhelpfulSpan UnhelpfulNoLocationInfo)) $
                  lift $ gets lateCCState_extra

              insertCC cc_name cc_srcspan expr
            else
              return expr


    processExpr :: CoreExpr -> LateCCM OverloadedCallsCCState CoreExpr
    processExpr :: Expr CoreBndr
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
processExpr Expr CoreBndr
expr =
      case Expr CoreBndr
expr of
        -- The case we care about: Application
        app :: Expr CoreBndr
app@App{} -> do
          -- Here we have some application like `f v1 ... vN`, where v1 ... vN
          -- should be the function's type arguments followed by the value
          -- arguments. To determine if the `f` is an overloaded function, we
          -- check if any of the arguments v1 ... vN are dictionaries.
          let
            (Expr CoreBndr
f, [Expr CoreBndr]
xs) = Expr CoreBndr -> (Expr CoreBndr, [Expr CoreBndr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs Expr CoreBndr
app
            resultTy :: Type
resultTy = HasDebugCallStack => Type -> [Expr CoreBndr] -> Type
Type -> [Expr CoreBndr] -> Type
applyTypeToArgs (HasDebugCallStack => Expr CoreBndr -> Type
Expr CoreBndr -> Type
exprType Expr CoreBndr
f) [Expr CoreBndr]
xs

          -- Recursively process the arguments first for no particular reason
          args <- (Expr CoreBndr
 -> ReaderT
      LateCCEnv
      (State (LateCCState OverloadedCallsCCState))
      (Expr CoreBndr))
-> [Expr CoreBndr]
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     [Expr CoreBndr]
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 Expr CoreBndr
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
processExpr [Expr CoreBndr]
xs
          let app' = Expr CoreBndr -> [Expr CoreBndr] -> Expr CoreBndr
mkCoreApps Expr CoreBndr
f [Expr CoreBndr]
args

          if
              -- Check if any of the arguments are dictionaries
              any isDictExpr args

              -- Avoid instrumenting dictionary functions, which may be
              -- overloaded if there are superclasses, by checking if the result
              -- type of the function is a dictionary type.
            && not (isDictTy resultTy)

              -- Avoid instrumenting constraint selectors like eq_sel
            && (typeTypeOrConstraint resultTy /= ConstraintLike)

              -- Avoid instrumenting join points.
              -- (See comment in processBind above)
            && not (isJoinVarExpr f)
          then do
            -- Extract a name and source location from the function being
            -- applied
            let
              cc_name :: FastString
              cc_name =
                FastString -> (Name -> FastString) -> Maybe Name -> FastString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> FastString
fsLit String
"<no name available>") Name -> FastString
forall a. NamedThing a => a -> FastString
getOccFS (Expr CoreBndr -> Maybe Name
exprName Expr CoreBndr
app)

            cc_srcspan <-
              fmap (Strict.fromMaybe (UnhelpfulSpan UnhelpfulNoLocationInfo)) $
                lift $ gets lateCCState_extra

            insertCC cc_name cc_srcspan app'
          else
            return app'

        -- For recursive constructors of Expr, we traverse the nested Exprs
        Lam CoreBndr
b Expr CoreBndr
e ->
          [CoreBndr] -> Expr CoreBndr -> Expr CoreBndr
mkCoreLams [CoreBndr
b] (Expr CoreBndr -> Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr CoreBndr
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
processExpr Expr CoreBndr
e
        Let CoreBind
b Expr CoreBndr
e ->
          CoreBind -> Expr CoreBndr -> Expr CoreBndr
mkCoreLet (CoreBind -> Expr CoreBndr -> Expr CoreBndr)
-> LateCCM OverloadedCallsCCState CoreBind
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr -> Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreBind -> LateCCM OverloadedCallsCCState CoreBind
processBind CoreBind
b ReaderT
  LateCCEnv
  (State (LateCCState OverloadedCallsCCState))
  (Expr CoreBndr -> Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
forall a b.
ReaderT
  LateCCEnv (State (LateCCState OverloadedCallsCCState)) (a -> b)
-> ReaderT LateCCEnv (State (LateCCState OverloadedCallsCCState)) a
-> ReaderT LateCCEnv (State (LateCCState OverloadedCallsCCState)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr CoreBndr
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
processExpr Expr CoreBndr
e
        Case Expr CoreBndr
e CoreBndr
b Type
t [Alt CoreBndr]
alts ->
              Expr CoreBndr
-> CoreBndr -> Type -> [Alt CoreBndr] -> Expr CoreBndr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case
          (Expr CoreBndr
 -> CoreBndr -> Type -> [Alt CoreBndr] -> Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (CoreBndr -> Type -> [Alt CoreBndr] -> Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr CoreBndr
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
processExpr Expr CoreBndr
e
          ReaderT
  LateCCEnv
  (State (LateCCState OverloadedCallsCCState))
  (CoreBndr -> Type -> [Alt CoreBndr] -> Expr CoreBndr)
-> ReaderT
     LateCCEnv (State (LateCCState OverloadedCallsCCState)) CoreBndr
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Type -> [Alt CoreBndr] -> Expr CoreBndr)
forall a b.
ReaderT
  LateCCEnv (State (LateCCState OverloadedCallsCCState)) (a -> b)
-> ReaderT LateCCEnv (State (LateCCState OverloadedCallsCCState)) a
-> ReaderT LateCCEnv (State (LateCCState OverloadedCallsCCState)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoreBndr
-> ReaderT
     LateCCEnv (State (LateCCState OverloadedCallsCCState)) CoreBndr
forall a.
a
-> ReaderT LateCCEnv (State (LateCCState OverloadedCallsCCState)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoreBndr
b
          ReaderT
  LateCCEnv
  (State (LateCCState OverloadedCallsCCState))
  (Type -> [Alt CoreBndr] -> Expr CoreBndr)
-> ReaderT
     LateCCEnv (State (LateCCState OverloadedCallsCCState)) Type
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     ([Alt CoreBndr] -> Expr CoreBndr)
forall a b.
ReaderT
  LateCCEnv (State (LateCCState OverloadedCallsCCState)) (a -> b)
-> ReaderT LateCCEnv (State (LateCCState OverloadedCallsCCState)) a
-> ReaderT LateCCEnv (State (LateCCState OverloadedCallsCCState)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type
-> ReaderT
     LateCCEnv (State (LateCCState OverloadedCallsCCState)) Type
forall a.
a
-> ReaderT LateCCEnv (State (LateCCState OverloadedCallsCCState)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
          ReaderT
  LateCCEnv
  (State (LateCCState OverloadedCallsCCState))
  ([Alt CoreBndr] -> Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     [Alt CoreBndr]
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
forall a b.
ReaderT
  LateCCEnv (State (LateCCState OverloadedCallsCCState)) (a -> b)
-> ReaderT LateCCEnv (State (LateCCState OverloadedCallsCCState)) a
-> ReaderT LateCCEnv (State (LateCCState OverloadedCallsCCState)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Alt CoreBndr
 -> ReaderT
      LateCCEnv
      (State (LateCCState OverloadedCallsCCState))
      (Alt CoreBndr))
-> [Alt CoreBndr]
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     [Alt CoreBndr]
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 Alt CoreBndr
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Alt CoreBndr)
processAlt [Alt CoreBndr]
alts
        Cast Expr CoreBndr
e CoercionR
co ->
          HasDebugCallStack => Expr CoreBndr -> CoercionR -> Expr CoreBndr
Expr CoreBndr -> CoercionR -> Expr CoreBndr
mkCast (Expr CoreBndr -> CoercionR -> Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (CoercionR -> Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr CoreBndr
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
processExpr Expr CoreBndr
e ReaderT
  LateCCEnv
  (State (LateCCState OverloadedCallsCCState))
  (CoercionR -> Expr CoreBndr)
-> ReaderT
     LateCCEnv (State (LateCCState OverloadedCallsCCState)) CoercionR
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
forall a b.
ReaderT
  LateCCEnv (State (LateCCState OverloadedCallsCCState)) (a -> b)
-> ReaderT LateCCEnv (State (LateCCState OverloadedCallsCCState)) a
-> ReaderT LateCCEnv (State (LateCCState OverloadedCallsCCState)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoercionR
-> ReaderT
     LateCCEnv (State (LateCCState OverloadedCallsCCState)) CoercionR
forall a.
a
-> ReaderT LateCCEnv (State (LateCCState OverloadedCallsCCState)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoercionR
co
        Tick CoreTickish
t Expr CoreBndr
e -> do
          CoreTickish
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
forall a.
CoreTickish
-> LateCCM OverloadedCallsCCState a
-> LateCCM OverloadedCallsCCState a
trackSourceNote CoreTickish
t (ReaderT
   LateCCEnv
   (State (LateCCState OverloadedCallsCCState))
   (Expr CoreBndr)
 -> ReaderT
      LateCCEnv
      (State (LateCCState OverloadedCallsCCState))
      (Expr CoreBndr))
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$
            CoreTickish -> Expr CoreBndr -> Expr CoreBndr
mkTick CoreTickish
t (Expr CoreBndr -> Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr CoreBndr
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
processExpr Expr CoreBndr
e

        -- For non-recursive constructors of Expr, we do nothing
        Expr CoreBndr
x -> Expr CoreBndr
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
forall a.
a
-> ReaderT LateCCEnv (State (LateCCState OverloadedCallsCCState)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr CoreBndr
x

    processAlt :: CoreAlt -> LateCCM OverloadedCallsCCState CoreAlt
    processAlt :: Alt CoreBndr
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Alt CoreBndr)
processAlt (Alt AltCon
c [CoreBndr]
bs Expr CoreBndr
e) = AltCon -> [CoreBndr] -> Expr CoreBndr -> Alt CoreBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
c [CoreBndr]
bs (Expr CoreBndr -> Alt CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Alt CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr CoreBndr
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Expr CoreBndr)
processExpr Expr CoreBndr
e

    trackSourceNote :: CoreTickish -> LateCCM OverloadedCallsCCState a -> LateCCM OverloadedCallsCCState a
    trackSourceNote :: forall a.
CoreTickish
-> LateCCM OverloadedCallsCCState a
-> LateCCM OverloadedCallsCCState a
trackSourceNote CoreTickish
tick LateCCM OverloadedCallsCCState a
act =
      case CoreTickish
tick of
        SourceNote RealSrcSpan
rss LexicalFastString
_ -> do
          -- Prefer source notes from the current file
          in_current_file <-
            Bool -> (FastString -> Bool) -> Maybe FastString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ) (Ordering -> Bool)
-> (FastString -> Ordering) -> FastString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> FastString -> Ordering
lexicalCompareFS (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
rss)) (Maybe FastString -> Bool)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Maybe FastString)
-> ReaderT
     LateCCEnv (State (LateCCState OverloadedCallsCCState)) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              (LateCCEnv -> Maybe FastString)
-> ReaderT
     LateCCEnv
     (State (LateCCState OverloadedCallsCCState))
     (Maybe FastString)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks LateCCEnv -> Maybe FastString
lateCCEnv_file
          if not in_current_file then
            act
          else do
            loc <- lift $ gets lateCCState_extra
            lift . modify $ \LateCCState OverloadedCallsCCState
s ->
              LateCCState OverloadedCallsCCState
s { lateCCState_extra =
                    Strict.Just $ RealSrcSpan rss mempty
                }
            x <- act
            lift . modify $ \LateCCState OverloadedCallsCCState
s ->
              LateCCState OverloadedCallsCCState
s { lateCCState_extra = loc
                }
            return x
        CoreTickish
_ ->
          LateCCM OverloadedCallsCCState a
act

    -- Utility functions

    -- Extract a Name from an expression. If it is an application, attempt to
    -- extract a name from the applied function. If it is a variable, return the
    -- Name of the variable. If it is a tick/cast, attempt to extract a Name
    -- from the expression held in the tick/cast. Otherwise return Nothing.
    exprName :: CoreExpr -> Maybe Name
    exprName :: Expr CoreBndr -> Maybe Name
exprName =
        \case
          App Expr CoreBndr
f Expr CoreBndr
_ ->
            Expr CoreBndr -> Maybe Name
exprName Expr CoreBndr
f
          Var CoreBndr
f ->
            Name -> Maybe Name
forall a. a -> Maybe a
Just (CoreBndr -> Name
idName CoreBndr
f)
          Tick CoreTickish
_ Expr CoreBndr
e ->
            Expr CoreBndr -> Maybe Name
exprName Expr CoreBndr
e
          Cast Expr CoreBndr
e CoercionR
_ ->
            Expr CoreBndr -> Maybe Name
exprName Expr CoreBndr
e
          Expr CoreBndr
_ ->
            Maybe Name
forall a. Maybe a
Nothing

    -- Determine whether an expression is a dictionary
    isDictExpr :: CoreExpr -> Bool
    isDictExpr :: Expr CoreBndr -> Bool
isDictExpr =
        Bool -> (Type -> Bool) -> Maybe Type -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Type -> Bool
isDictTy (Maybe Type -> Bool)
-> (Expr CoreBndr -> Maybe Type) -> Expr CoreBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr CoreBndr -> Maybe Type
exprType'
      where
        exprType' :: CoreExpr -> Maybe Type
        exprType' :: Expr CoreBndr -> Maybe Type
exprType' = \case
            Type{} -> Maybe Type
forall a. Maybe a
Nothing
            Expr CoreBndr
expr -> Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Expr CoreBndr -> Type
Expr CoreBndr -> Type
exprType Expr CoreBndr
expr

    -- Determine whether an expression is a join variable
    isJoinVarExpr :: CoreExpr -> Bool
    isJoinVarExpr :: Expr CoreBndr -> Bool
isJoinVarExpr =
        \case
          Var CoreBndr
var -> CoreBndr -> Bool
isJoinId CoreBndr
var
          Tick CoreTickish
_ Expr CoreBndr
e -> Expr CoreBndr -> Bool
isJoinVarExpr Expr CoreBndr
e
          Cast Expr CoreBndr
e CoercionR
_ -> Expr CoreBndr -> Bool
isJoinVarExpr Expr CoreBndr
e
          Expr CoreBndr
_ -> Bool
False