{-# LANGUAGE TupleSections #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE MultiWayIf #-}

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

-- | GHC plugin converting to CCC form.

module ConCat.Plugin where

import Data.Monoid (Any(..))
import Control.Arrow (first,second,(***))
import Control.Applicative (liftA2,(<|>))
import Control.Monad (unless,when,guard,(<=<))
import Data.Foldable (toList)
import Data.Either (isRight)
import Data.Maybe (isNothing,isJust,fromMaybe,catMaybes,listToMaybe)
import Data.List (isPrefixOf,isSuffixOf,elemIndex,sort,stripPrefix)
import Data.Char (toLower)
import Data.Data (Data)
import Data.Generics (GenericQ,GenericM,gmapM,mkQ,mkT,mkM,everything,everywhere',everywhereM)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
--import qualified Data.Set (Set) as OrdSet
import qualified Data.Set as OrdSet
--import qualified Data.Map (Map) as OrdMap
import qualified Data.Map as OrdMap
import Text.Printf (printf)
import System.IO.Unsafe (unsafePerformIO)
import Data.IORef

#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
import GHC.Utils.Trace
import GHC.Core.Reduction (reductionCoercion, reductionReducedType)
#endif
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
import GHC.Builtin.Names (leftDataConName,rightDataConName
                         ,floatTyConKey,doubleTyConKey,integerTyConKey
                         ,intTyConKey,boolTyConKey
                         ,typeRepTyConName)
import GHC.Builtin.Types.Prim (intPrimTyCon)
import GHC.Core.Class (classAllSelIds)
-- For normaliseType etc
import GHC.Core.FamInstEnv
import GHC.Core.Lint (lintExpr)
import GHC.Utils.Error (pprMessageBag)
import GHC.Core.Opt.Arity (etaExpand)
import GHC.Core.SimpleOpt (simpleOptExpr)
import GHC.Core.TyCo.Rep
import GHC.Core.Type (coreView)
import GHC.Core.Coercion.Axiom
import GHC.Core.Coercion.Opt (optCoercion)
import GHC.Core.TyCo.Subst (emptyTCvSubst)
import GHC.Data.Pair (Pair(..), swap)
import GHC.Driver.Backend (Backend(..))
import GHC.Plugins as GHC hiding (substTy,cat)
import GHC.Runtime.Loader
import GHC.Tc.Utils.TcType (isFloatTy,isDoubleTy,isIntegerTy,isIntTy,isBoolTy,isUnitTy
                           ,tcSplitTyConApp_maybe)
import GHC.Types.Id.Make (mkDictSelRhs,coerceId)
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
import GHC.Types.TyThing (MonadThings(..))
import GHC.Unit.External (eps_rule_base)
import GHC.Driver.Config (initSimpleOpts)
import GHC.Builtin.Uniques (mkBuiltinUnique)
import GHC.Driver.Config (initOptCoercionOpts)
#else
import GHC.Driver.Types (eps_rule_base)
import GHC.Types.Unique (mkBuiltinUnique)
#endif
import qualified GHC.Types.Unique.DFM as DFMap
#else
import GhcPlugins as GHC hiding (substTy,cat)
import Class (classAllSelIds)
import CoreArity (etaExpand)
import CoreLint (lintExpr)
import DynamicLoading
import MkId (mkDictSelRhs,coerceId)
import Pair (Pair(..), swap)
import PrelNames (leftDataConName,rightDataConName
                 ,floatTyConKey,doubleTyConKey,integerTyConKey
                 ,intTyConKey,boolTyConKey
                 ,typeRepTyConName)
import Type (coreView)
import TcType (isFloatTy,isDoubleTy,isIntegerTy,isIntTy,isBoolTy,isUnitTy
              ,tcSplitTyConApp_maybe)
import TysPrim (intPrimTyCon)
-- For normaliseType etc
import FamInstEnv
#if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0)
import CoreOpt (simpleOptExpr)
import qualified UniqDFM as DFMap
#endif
import TyCoRep
import Unique (mkBuiltinUnique)
import CoAxiom (coAxiomNthBranch, coAxBranchTyVars, coAxBranchRHS)
import OptCoercion (optCoercion)
import TyCoSubst (emptyTCvSubst)
#endif
import GHC.Classes

import ConCat.Misc (Unop,Binop,Ternop,PseudoFun(..),(~>))
import ConCat.BuildDictionary
import ConCat.NormaliseType (eqTypeM)

-- import ConCat.Simplify

pattern FunCo' :: Role -> Coercion -> Coercion -> Coercion
mkFunCo' :: Role -> Coercion -> Coercion -> Coercion
pattern FunTy' :: Type -> Type -> Type
mkFunTy' :: Type -> Type -> Type
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
pattern $mFunCo' :: forall {r}.
Coercion
-> (Role -> Coercion -> Coercion -> r) -> ((# #) -> r) -> r
FunCo' r a b <- FunCo r _ a b
mkFunCo' :: Role -> Coercion -> Coercion -> Coercion
mkFunCo' Role
r = Role -> Coercion -> Coercion -> Coercion -> Coercion
FunCo Role
r (Type -> Coercion
multToCo Type
Many)
pattern $mFunTy' :: forall {r}. Type -> (Type -> Type -> r) -> ((# #) -> r) -> r
FunTy' a r <- FunTy _ _ a r
mkFunTy' :: Type -> Type -> Type
mkFunTy' = AnonArgFlag -> Type -> Type -> Type -> Type
FunTy AnonArgFlag
VisArg Type
Many
-- GHC 8.10 FunTy as an extra operand
#else
pattern FunCo' r a b = FunCo r a b
mkFunCo' = FunCo
pattern FunTy' a r <- FunTy _ a r
mkFunTy' = FunTy VisArg
#endif

#if !MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
pattern Alt :: AltCon -> [b] -> (Expr b) -> (AltCon, [b], Expr b)
pattern Alt con bs rhs = (con, bs, rhs)
#endif

splitFunTy_maybe' :: Type -> Maybe (Type, Type)
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
splitFunTy_maybe' :: Type -> Maybe (Type, Type)
splitFunTy_maybe' = ((Type, Type, Type) -> (Type, Type))
-> Maybe (Type, Type, Type) -> Maybe (Type, Type)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Type
_, Type
a, Type
b) -> (Type
a, Type
b)) (Maybe (Type, Type, Type) -> Maybe (Type, Type))
-> (Type -> Maybe (Type, Type, Type)) -> Type -> Maybe (Type, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe (Type, Type, Type)
splitFunTy_maybe
#else
splitFunTy_maybe' = splitFunTy_maybe
#endif

-- Information needed for reification. We construct this info in
-- CoreM and use it in the ccc rule, which must be pure.
data CccEnv = CccEnv { CccEnv -> forall a. [Char] -> SDoc -> a -> a
dtrace           :: forall a. String -> SDoc -> a -> a
                     , CccEnv -> CoreBndr
cccV             :: Id
                     , CccEnv -> CoreBndr
cccPV            :: Id -- evidence-annotated version, toCcc''
                     , CccEnv -> CoreBndr
uncccV           :: Id
                     , CccEnv -> TyCon
closedTc         :: TyCon
                     , CccEnv -> CoreBndr
idV              :: Id
                     , CccEnv -> CoreBndr
constV           :: Id
                     , CccEnv -> CoreBndr
forkV            :: Id
                     , CccEnv -> CoreBndr
applyV           :: Id
                     , CccEnv -> CoreBndr
composeV         :: Id
                     , CccEnv -> CoreBndr
curryV           :: Id
                     , CccEnv -> CoreBndr
uncurryV         :: Id
                     , CccEnv -> CoreBndr
ifV              :: Id
                     , CccEnv -> CoreBndr
exlV             :: Id
                     , CccEnv -> CoreBndr
exrV             :: Id
                     , CccEnv -> CoreBndr
constFunV        :: Id
                     , CccEnv -> CoreBndr
fmapV            :: Id
                     , CccEnv -> CoreBndr
fmapT1V          :: Id
                     , CccEnv -> CoreBndr
fmapT2V          :: Id
                     , CccEnv -> CoreBndr
casePairTopTV    :: Id
                     , CccEnv -> CoreBndr
casePairTV       :: Id
                     , CccEnv -> CoreBndr
casePairLTV      :: Id
                     , CccEnv -> CoreBndr
casePairRTV      :: Id
                     , CccEnv -> CoreBndr
flipForkTV       :: Id
                     , CccEnv -> CoreBndr
castConstTV      :: Id
                     , CccEnv -> CoreBndr
reprCV           :: Id
                     , CccEnv -> CoreBndr
abstCV           :: Id
                     , CccEnv -> CoreBndr
coerceV          :: Id
                     , CccEnv -> CoreBndr
bottomTV         :: Id
                     , CccEnv -> TyCon
repTc            :: TyCon
                  -- , hasRepMeth       :: HasRepMeth
                     -- , hasRepFromAbstCo :: Coercion   -> CoreExpr
                     , CccEnv -> CoreBndr
prePostV         :: Id
                  -- , lazyV            :: Id
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
                     , CccEnv -> UniqDFM TyCon CoreBndr
boxers           :: DFMap.UniqDFM TyCon Id  -- to remove
#else
                     , boxers           :: DFMap.UniqDFM Id  -- to remove
#endif
                     , CccEnv -> CoreBndr
tagToEnumV       :: Id
                     , CccEnv -> CoreBndr
bottomV          :: Id
                     , CccEnv -> CoreBndr
boxIBV           :: Id
                     , CccEnv -> CoreBndr
ifEqIntHash      :: Id
                  -- , reboxV           :: Id
                     , CccEnv -> CoreBndr
inlineV          :: Id
                     , CccEnv -> UniqSupply
uniqSupply       :: UniqSupply
                  -- , coercibleTc      :: TyCon
                  -- , coerceV          :: Id
                  -- , polyOps          :: PolyOpsMap
                  -- , monoOps          :: MonoOpsMap
                     , CccEnv -> HscEnv
hsc_env          :: HscEnv
                     , CccEnv -> RuleBase
ruleBase         :: RuleBase  -- to remove
                     , CccEnv -> TyCon
okTypeTc         :: TyCon
                     , CccEnv -> Bool
enablePolymorphism :: Bool -- experimental
                     }

-- Whether to run Core Lint after every step
lintSteps :: Bool
lintSteps :: Bool
lintSteps = Bool
True -- False

type Rewrite a = a -> Maybe a
type ReExpr = Rewrite CoreExpr
type ReExpr2 = CoreExpr -> Rewrite CoreExpr

trying :: (String -> SDoc -> Bool -> Bool) -> String -> a -> Bool
trying :: forall a. ([Char] -> SDoc -> Bool -> Bool) -> [Char] -> a -> Bool
trying [Char] -> SDoc -> Bool -> Bool
tr [Char]
str a
a = [Char] -> SDoc -> Bool -> Bool
tr ([Char]
"Trying " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
str) (a
a a -> SDoc -> SDoc
forall a b. a -> b -> b
`seq` SDoc
empty) Bool
False
{-# NOINLINE trying #-}

-- #define Trying(str) e_ | trying dtrace (str) e_ -> undefined
#define Trying(str)

#define Doing(str) dtrace "Doing" (text (str)) id $
-- #define Doing(str) pprTrace "Doing" (text (str)) id $
-- #define Doing(str)

-- Category
type Cat = Type

ccc :: CccEnv -> Ops -> Type -> ReExpr
-- ccc _ _ _ _ _ | pprTrace "ccc" empty False = undefined
ccc :: CccEnv -> Ops -> Type -> ReExpr
ccc (CccEnv {Bool
CoreBndr
TyCon
RuleBase
UniqSupply
UniqDFM TyCon CoreBndr
HscEnv
forall a. [Char] -> SDoc -> a -> a
dtrace :: CccEnv -> forall a. [Char] -> SDoc -> a -> a
cccV :: CccEnv -> CoreBndr
cccPV :: CccEnv -> CoreBndr
uncccV :: CccEnv -> CoreBndr
closedTc :: CccEnv -> TyCon
idV :: CccEnv -> CoreBndr
constV :: CccEnv -> CoreBndr
forkV :: CccEnv -> CoreBndr
applyV :: CccEnv -> CoreBndr
composeV :: CccEnv -> CoreBndr
curryV :: CccEnv -> CoreBndr
uncurryV :: CccEnv -> CoreBndr
ifV :: CccEnv -> CoreBndr
exlV :: CccEnv -> CoreBndr
exrV :: CccEnv -> CoreBndr
constFunV :: CccEnv -> CoreBndr
fmapV :: CccEnv -> CoreBndr
fmapT1V :: CccEnv -> CoreBndr
fmapT2V :: CccEnv -> CoreBndr
casePairTopTV :: CccEnv -> CoreBndr
casePairTV :: CccEnv -> CoreBndr
casePairLTV :: CccEnv -> CoreBndr
casePairRTV :: CccEnv -> CoreBndr
flipForkTV :: CccEnv -> CoreBndr
castConstTV :: CccEnv -> CoreBndr
reprCV :: CccEnv -> CoreBndr
abstCV :: CccEnv -> CoreBndr
coerceV :: CccEnv -> CoreBndr
bottomTV :: CccEnv -> CoreBndr
repTc :: CccEnv -> TyCon
prePostV :: CccEnv -> CoreBndr
boxers :: CccEnv -> UniqDFM TyCon CoreBndr
tagToEnumV :: CccEnv -> CoreBndr
bottomV :: CccEnv -> CoreBndr
boxIBV :: CccEnv -> CoreBndr
ifEqIntHash :: CccEnv -> CoreBndr
inlineV :: CccEnv -> CoreBndr
uniqSupply :: CccEnv -> UniqSupply
hsc_env :: CccEnv -> HscEnv
ruleBase :: CccEnv -> RuleBase
okTypeTc :: CccEnv -> TyCon
enablePolymorphism :: CccEnv -> Bool
dtrace :: forall a. [Char] -> SDoc -> a -> a
cccV :: CoreBndr
cccPV :: CoreBndr
uncccV :: CoreBndr
closedTc :: TyCon
idV :: CoreBndr
constV :: CoreBndr
forkV :: CoreBndr
applyV :: CoreBndr
composeV :: CoreBndr
curryV :: CoreBndr
uncurryV :: CoreBndr
ifV :: CoreBndr
exlV :: CoreBndr
exrV :: CoreBndr
constFunV :: CoreBndr
fmapV :: CoreBndr
fmapT1V :: CoreBndr
fmapT2V :: CoreBndr
casePairTopTV :: CoreBndr
casePairTV :: CoreBndr
casePairLTV :: CoreBndr
casePairRTV :: CoreBndr
flipForkTV :: CoreBndr
castConstTV :: CoreBndr
reprCV :: CoreBndr
abstCV :: CoreBndr
coerceV :: CoreBndr
bottomTV :: CoreBndr
repTc :: TyCon
prePostV :: CoreBndr
boxers :: UniqDFM TyCon CoreBndr
tagToEnumV :: CoreBndr
bottomV :: CoreBndr
boxIBV :: CoreBndr
ifEqIntHash :: CoreBndr
inlineV :: CoreBndr
uniqSupply :: UniqSupply
hsc_env :: HscEnv
ruleBase :: RuleBase
okTypeTc :: TyCon
enablePolymorphism :: Bool
..}) (Ops {[CoreBndr] -> [(CoreBndr, CoreExpr)] -> Unop CoreExpr
CoreBndr -> Maybe CoreExpr
Rewrite Coercion
Coercion -> Coercion
Type -> Bool
Type -> Maybe (Type, Type)
Type -> Either SDoc CoreExpr
Type -> (Type, Type)
Type -> Type
Type -> CoreBndr -> [Type] -> Maybe CoreExpr
Type -> CoreBndr -> [Type] -> CoreExpr
Type -> CoreBndr -> Unop CoreExpr
Type -> Type -> Maybe (Type, Type)
Type -> Type -> Maybe CoreExpr
Type -> Type -> CoreExpr
Type -> Type -> Type -> Maybe CoreExpr
Type -> Type -> Type -> CoreExpr
Type -> Type -> ReExpr
Type -> Type -> Ternop CoreExpr
Type -> ReExpr
Type -> Unop CoreExpr
Type -> ReExpr2
Type -> Binop CoreExpr
Role -> Type -> (Coercion, Type)
CoreExpr -> Bool
ReExpr
CoreExpr -> Either SDoc CoreExpr
Unop CoreExpr
Unop ReExpr
forall a. SDoc -> Either SDoc a -> a
forall a b. (Outputable a, Outputable b) => [Char] -> a -> b -> b
forall (f :: * -> *) a b.
(Functor f, Outputable a, Outputable b) =>
[Char] -> Unop (a -> f b)
inlineE :: Unop CoreExpr
boxCon :: ReExpr
catTy :: Type -> Type
reCatCo :: Rewrite Coercion
repTy :: Type -> Type
unfoldMaybe' :: ReExpr
unfoldMaybe :: ReExpr
inlineMaybe :: CoreBndr -> Maybe CoreExpr
noDictErr :: forall a. SDoc -> Either SDoc a -> a
onDictTry :: CoreExpr -> Either SDoc CoreExpr
onDictMaybe :: ReExpr
onDict :: Unop CoreExpr
onDicts :: Unop CoreExpr
buildDictMaybe :: Type -> Either SDoc CoreExpr
catOp :: Type -> CoreBndr -> [Type] -> CoreExpr
catOpMaybe :: Type -> CoreBndr -> [Type] -> Maybe CoreExpr
mkCcc :: Unop CoreExpr
mkId :: Type -> Type -> CoreExpr
mkCompose :: Type -> Binop CoreExpr
mkCompose' :: Type -> ReExpr2
mkEx :: Type -> CoreBndr -> Unop CoreExpr
mkFork :: Type -> Binop CoreExpr
mkFork' :: Type -> ReExpr2
mkApplyMaybe :: Type -> Type -> Type -> Maybe CoreExpr
isClosed :: Type -> Bool
mkCurry :: Type -> Unop CoreExpr
mkCurry' :: Type -> ReExpr
mkUncurryMaybe :: Type -> ReExpr
mkIfC :: Type -> Type -> Ternop CoreExpr
mkBottomC :: Type -> Type -> Type -> Maybe CoreExpr
mkConst :: Type -> Type -> ReExpr
mkConst' :: Type -> Type -> ReExpr
mkConstFun :: Type -> Type -> ReExpr
mkAbstC :: Type -> Type -> CoreExpr
mkReprC :: Type -> Type -> CoreExpr
mkReprC' :: Type -> Type -> CoreExpr
mkAbstC' :: Type -> Type -> CoreExpr
mkReprC'_maybe :: Type -> Type -> Maybe CoreExpr
mkAbstC'_maybe :: Type -> Type -> Maybe CoreExpr
mkCoerceC :: Type -> Type -> Type -> CoreExpr
mkCoerceC_maybe :: Type -> Type -> Type -> Maybe CoreExpr
traceRewrite :: forall (f :: * -> *) a b.
(Functor f, Outputable a, Outputable b) =>
[Char] -> Unop (a -> f b)
tyArgs2_maybe :: Type -> Maybe (Type, Type)
tyArgs2 :: Type -> (Type, Type)
pprTrans :: forall a b. (Outputable a, Outputable b) => [Char] -> a -> b -> b
lintReExpr :: Unop ReExpr
transCatOp :: ReExpr
reCat :: ReExpr
isPseudoApp :: CoreExpr -> Bool
normType :: Role -> Type -> (Coercion, Type)
okType :: Type -> Bool
optimizeCoercion :: Coercion -> Coercion
subst :: [CoreBndr] -> [(CoreBndr, CoreExpr)] -> Unop CoreExpr
eqTypeNormalising :: Type -> Type -> Maybe (Type, Type)
inlineE :: Ops -> Unop CoreExpr
boxCon :: Ops -> ReExpr
catTy :: Ops -> Type -> Type
reCatCo :: Ops -> Rewrite Coercion
repTy :: Ops -> Type -> Type
unfoldMaybe' :: Ops -> ReExpr
unfoldMaybe :: Ops -> ReExpr
inlineMaybe :: Ops -> CoreBndr -> Maybe CoreExpr
noDictErr :: Ops -> forall a. SDoc -> Either SDoc a -> a
onDictTry :: Ops -> CoreExpr -> Either SDoc CoreExpr
onDictMaybe :: Ops -> ReExpr
onDict :: Ops -> Unop CoreExpr
onDicts :: Ops -> Unop CoreExpr
buildDictMaybe :: Ops -> Type -> Either SDoc CoreExpr
catOp :: Ops -> Type -> CoreBndr -> [Type] -> CoreExpr
catOpMaybe :: Ops -> Type -> CoreBndr -> [Type] -> Maybe CoreExpr
mkCcc :: Ops -> Unop CoreExpr
mkId :: Ops -> Type -> Type -> CoreExpr
mkCompose :: Ops -> Type -> Binop CoreExpr
mkCompose' :: Ops -> Type -> ReExpr2
mkEx :: Ops -> Type -> CoreBndr -> Unop CoreExpr
mkFork :: Ops -> Type -> Binop CoreExpr
mkFork' :: Ops -> Type -> ReExpr2
mkApplyMaybe :: Ops -> Type -> Type -> Type -> Maybe CoreExpr
isClosed :: Ops -> Type -> Bool
mkCurry :: Ops -> Type -> Unop CoreExpr
mkCurry' :: Ops -> Type -> ReExpr
mkUncurryMaybe :: Ops -> Type -> ReExpr
mkIfC :: Ops -> Type -> Type -> Ternop CoreExpr
mkBottomC :: Ops -> Type -> Type -> Type -> Maybe CoreExpr
mkConst :: Ops -> Type -> Type -> ReExpr
mkConst' :: Ops -> Type -> Type -> ReExpr
mkConstFun :: Ops -> Type -> Type -> ReExpr
mkAbstC :: Ops -> Type -> Type -> CoreExpr
mkReprC :: Ops -> Type -> Type -> CoreExpr
mkReprC' :: Ops -> Type -> Type -> CoreExpr
mkAbstC' :: Ops -> Type -> Type -> CoreExpr
mkReprC'_maybe :: Ops -> Type -> Type -> Maybe CoreExpr
mkAbstC'_maybe :: Ops -> Type -> Type -> Maybe CoreExpr
mkCoerceC :: Ops -> Type -> Type -> Type -> CoreExpr
mkCoerceC_maybe :: Ops -> Type -> Type -> Type -> Maybe CoreExpr
traceRewrite :: Ops
-> forall (f :: * -> *) a b.
   (Functor f, Outputable a, Outputable b) =>
   [Char] -> Unop (a -> f b)
tyArgs2_maybe :: Ops -> Type -> Maybe (Type, Type)
tyArgs2 :: Ops -> Type -> (Type, Type)
pprTrans :: Ops
-> forall a b.
   (Outputable a, Outputable b) =>
   [Char] -> a -> b -> b
lintReExpr :: Ops -> Unop ReExpr
transCatOp :: Ops -> ReExpr
reCat :: Ops -> ReExpr
isPseudoApp :: Ops -> CoreExpr -> Bool
normType :: Ops -> Role -> Type -> (Coercion, Type)
okType :: Ops -> Type -> Bool
optimizeCoercion :: Ops -> Coercion -> Coercion
subst :: Ops -> [CoreBndr] -> [(CoreBndr, CoreExpr)] -> Unop CoreExpr
eqTypeNormalising :: Ops -> Type -> Type -> Maybe (Type, Type)
..}) Type
cat =
  [Char] -> Unop ReExpr
forall (f :: * -> *) a b.
(Functor f, Outputable a, Outputable b) =>
[Char] -> Unop (a -> f b)
traceRewrite [Char]
"toCcc''" Unop ReExpr -> Unop ReExpr
forall a b. (a -> b) -> a -> b
$
  (if Bool
lintSteps then Unop ReExpr
lintReExpr else Unop ReExpr
forall a. a -> a
id) Unop ReExpr -> Unop ReExpr
forall a b. (a -> b) -> a -> b
$
  ReExpr
go
 where
   go :: ReExpr
   go :: ReExpr
go = \ case
     -- Temporarily make `ccc` bail on polymorphic terms. Doing so will speed up
     -- my experiments, since much time is spent optimizing rules, IIUC. It'll
     -- be important to restore polymorphic transformation later for useful
     -- separate compilation. Put first, to remove tracing clutter
     -- Trying("top poly bail")
     (CoreExpr -> Bool
isMono -> Bool
False) | Bool -> Bool
not Bool
enablePolymorphism ->
       -- Doing("top poly bail")
       Maybe CoreExpr
forall a. Maybe a
Nothing
     CoreExpr
e | [Char] -> SDoc -> Bool -> Bool
forall a. [Char] -> SDoc -> a -> a
dtrace ([Char]
"go ccc "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Type -> [Char]
forall a. Outputable a => a -> [Char]
pp Type
cat[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
":") (CoreExpr -> SDoc
pprWithType' CoreExpr
e) Bool
False -> Maybe CoreExpr
forall a. HasCallStack => a
undefined
     -- Sanity check: ccc should only take functions.
     e :: CoreExpr
e@((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType -> Type -> Bool
isFunTy -> Bool
False) ->
       [Char] -> SDoc -> Maybe CoreExpr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"ccc/go: not of function type" (CoreExpr -> SDoc
pprWithType CoreExpr
e)
#if 0
     -- An alternative to curry. Play with this one later.
     Trying("top flipForkT")
     -- f | pprTrace "flipForkT tests"
     --      (ppr ( splitFunTy (exprType f)
     --              , second splitFunTy_maybe' (splitFunTy (exprType f))
     --              , not catClosed)) False = undefined
     f | z `FunTy` (a `FunTy` b) <- exprType f
       , not catClosed
       -> Doing("top flipForkT")
          -- pprTrace "flipForkT type" (ppr (varType flipForkTV)) $
          return (onDicts (varApps flipForkTV [cat,z,a,b] []) `App` f)
#endif
     Trying("top Lam")
     Lam CoreBndr
x CoreExpr
body -> CoreBndr -> ReExpr
goLam CoreBndr
x CoreExpr
body
     Trying("top Let")
     Let bind :: Bind CoreBndr
bind@(NonRec CoreBndr
v CoreExpr
rhs) CoreExpr
body ->
       -- Experiment: always float.
       if CoreExpr -> Bool
alwaysSubst CoreExpr
rhs then
         -- Experiment:
         Doing("top Let subst")
         ReExpr
go (CoreBndr -> Binop CoreExpr
subst1 CoreBndr
v CoreExpr
rhs CoreExpr
body)
         -- return (mkCcc (subst1 v rhs body))
       else if
          -- dtrace "top Let tests" (ppr (not catClosed, substFriendly catClosed rhs, idOccs False v body)) $
          Bool -> Bool
not (Type -> Bool
isMonoTy (CoreBndr -> Type
varType CoreBndr
v)) Bool -> Bool -> Bool
||
          Bool -> Bool
not Bool
catClosed Bool -> Bool -> Bool
||  -- experiment
          Bool -> CoreExpr -> Bool
substFriendly Bool
catClosed CoreExpr
rhs Bool -> Bool -> Bool
|| Bool -> CoreBndr -> CoreExpr -> Int
idOccs Bool
False CoreBndr
v CoreExpr
body Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 then
         Doing("top Let float")
         ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bind CoreBndr -> Unop CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let Bind CoreBndr
bind (Unop CoreExpr
mkCcc CoreExpr
body))
       else
         Doing("top Let to beta-redex")
         ReExpr
go (Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
v CoreExpr
body) CoreExpr
rhs)
     Trying("top reCat")
     (ReExpr
reCat -> Just CoreExpr
e') ->
       Doing("top reCat")
       ReExpr
forall a. a -> Maybe a
Just CoreExpr
e'
     Trying("top Avoid pseudo-app")
     (CoreExpr -> Bool
isPseudoApp -> Bool
True) ->
       Doing("top Avoid pseudo-app")
       Maybe CoreExpr
forall a. Maybe a
Nothing
     Trying("top Case of bottom")
     e :: CoreExpr
e@(Case (CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs -> (Var CoreBndr
v,[CoreExpr]
_args)) CoreBndr
_wild Type
_rhsTy [Alt CoreBndr]
_alts)
       |  CoreBndr
v CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
bottomV
       ,  FunTy' Type
dom Type
cod <- (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e
       -> Doing("top Case of bottom")
          Type -> Type -> Type -> Maybe CoreExpr
mkBottomC Type
cat Type
dom Type
cod
     Trying("top Case live wild")
     (ReExpr
deadifyCaseWild -> Just CoreExpr
e') ->
       Doing("top Case live wild")
       ReExpr
go CoreExpr
e'
     -- See journal 2018-02-02.
     Trying("top Case of product")
     Case CoreExpr
scrut CoreBndr
_ Type
_rhsTy [Alt (DataAlt DataCon
dc) [CoreBndr
b,CoreBndr
c] CoreExpr
rhs]
         | TyCon -> Bool
isBoxedTupleTyCon (DataCon -> TyCon
dataConTyCon DataCon
dc)
         -- prevent infinite loop
         , Bool -> Bool
not (CoreExpr -> Bool
forall b. Expr b -> Bool
isCast CoreExpr
rhs) ->
       Doing("top Case of product")
       ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop ReExpr
forall a b. (a -> b) -> a -> b
$ Unop CoreExpr
mkCcc Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$
         CoreBndr -> [Type] -> [CoreExpr] -> CoreExpr
varApps CoreBndr
casePairTopTV
           [CoreBndr -> Type
varType CoreBndr
b,CoreBndr -> Type
varType CoreBndr
c,Type
_rhsTy]
           [CoreExpr
scrut, [CoreBndr] -> Unop CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr
b,CoreBndr
c] CoreExpr
rhs]
     -- ccc-of-case. Maybe restrict to isTyCoDictArg for all bound variables, but
     -- perhaps I don't need to.
     Trying("top Case unfold")
     -- Case scrut@(unfoldMaybe -> Nothing) _wild _rhsTy _alts
     --   \| pprTrace "top Case failed to unfold scrutinee" (ppr scrut) False -> undefined
     Case CoreExpr
scrut CoreBndr
wild Type
rhsTy [Alt CoreBndr]
alts
       | Just CoreExpr
scrut' <- ReExpr
unfoldMaybe CoreExpr
scrut
       -> Doing("top Case unfold")  --  of dictionary
          ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop ReExpr
forall a b. (a -> b) -> a -> b
$ Unop CoreExpr
mkCcc (CoreExpr -> CoreBndr -> Type -> [Alt CoreBndr] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut' CoreBndr
wild Type
rhsTy [Alt CoreBndr]
alts)
          -- TODO: also for lam?
     Trying("top nominal Cast")
     Cast CoreExpr
e co :: Coercion
co@( -- dtrace "top nominal cast co" (pprCoWithType co {-<+> (ppr (setNominalRole_maybe co))-}) id
                Rewrite Coercion
setNominalRole_maybe' -> Just (Rewrite Coercion
reCatCo -> Just Coercion
co')) ->
       -- etaExpand turns cast lambdas into themselves
       Doing("top nominal cast")
       let co'' :: Coercion
co'' = Role -> Role -> Coercion -> Coercion
downgradeRole (Coercion -> Role
coercionRole Coercion
co) (Coercion -> Role
coercionRole Coercion
co') Coercion
co' in
         -- pprTrace "top nominal Cast" (ppr co $$ text "-->" $$ ppr co'') $
         ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (Unop CoreExpr
mkCcc CoreExpr
e) Coercion
co'')
       -- I think GHC is undoing this transformation, so continue eagerly
       -- (`Cast` co') <$> go e
     Trying("top const cast")
     Cast (Lam CoreBndr
v CoreExpr
e) (FunCo' Role
_r Coercion
_ co' :: Coercion
co'@(Coercion -> Pair Type
coercionKind -> Pair Type
b Type
b'))
       | Bool -> Bool
not (CoreBndr
v CoreBndr -> CoreExpr -> Bool
`isFreeIn` CoreExpr
e)
       -- , dtrace "top const cast" (ppr (varWithType castConstTV)) True
       , Just CoreExpr
mk <- ReExpr
onDictMaybe ReExpr -> Unop ReExpr
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ReExpr
onDictMaybe Unop ReExpr
forall a b. (a -> b) -> a -> b
$
                      CoreBndr -> [Type] -> [CoreExpr] -> CoreExpr
varApps CoreBndr
castConstTV [Type
cat,CoreBndr -> Type
varType CoreBndr
v,Type
b,Type
b'] []
       -> Doing("top const cast")
          ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
mk Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Type -> Type -> Type -> Coercion -> CoreExpr
mkCoercible Type
starKind Type
b Type
b' Coercion
co' Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
e)
     Trying("top representational cast")
     -- This version fails gracefully when we can't make the coercions.
     -- Then we can see further into the error.
     e :: CoreExpr
e@(Cast CoreExpr
e' co :: Coercion
co@(Coercion -> Role
coercionRole -> Role
Representational))
       | [Char] -> SDoc -> Bool -> Bool
forall a. [Char] -> SDoc -> a -> a
dtrace [Char]
"found representational cast" ((Type, Type, Coercion) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e, (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e', Coercion
co)) Bool
False -> Maybe CoreExpr
forall a. HasCallStack => a
undefined
       -- \| FunTy' a  b  <- exprType e
       -- \| FunTy' a' b' <- exprType e'
       | FunCo' Role
Representational Coercion
co1 Coercion
co2 <- Coercion -> Coercion
optimizeCoercion Coercion
co
       --, Just coA    <- mkCoerceC_maybe cat a a'
       --, Just coB    <- mkCoerceC_maybe cat b' b
       , let coA :: CoreExpr
coA    = Bool -> Coercion -> [Type] -> CoreExpr
goCoercion Bool
True Coercion
co1 [] -- a a'
       , let coB :: CoreExpr
coB    = Bool -> Coercion -> [Type] -> CoreExpr
goCoercion Bool
True Coercion
co2 [] -- b' b
       ->
          Doing("top representational cast")
          -- Will I get unnecessary coerceCs due to nominal-able sub-coercions?
          ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop ReExpr
forall a b. (a -> b) -> a -> b
$ Type -> Binop CoreExpr
mkCompose Type
cat CoreExpr
coB Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$ Type -> Binop CoreExpr
mkCompose Type
cat (Unop CoreExpr
mkCcc CoreExpr
e') Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr
coA
     Trying("top cast unfold")
     Cast (ReExpr
unfoldMaybe -> Just CoreExpr
body') Coercion
co ->
       Doing("top cast unfoldMaybe")
       ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop ReExpr
forall a b. (a -> b) -> a -> b
$ Unop CoreExpr
mkCcc Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
body' Coercion
co
     Trying("top con abstRepr")
     -- Constructor application
     e :: CoreExpr
e@(CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs -> (Var (CoreBndr -> Maybe DataCon
isDataConId_maybe -> Just DataCon
dc),[CoreExpr]
_))
       | let ([CoreBndr]
binds,CoreExpr
body) = CoreExpr -> ([CoreBndr], CoreExpr)
forall b. Expr b -> ([b], Expr b)
collectBinders (Int -> Unop CoreExpr
etaExpand (DataCon -> Int
dataConRepArity DataCon
dc) CoreExpr
e)
             bodyTy :: Type
bodyTy = (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body
       -- , dtrace "top con abstRepr abst type" (ppr bodyTy) True
       , Just CoreExpr
repr <- Type -> Type -> Maybe CoreExpr
mkReprC'_maybe Type
funCat Type
bodyTy
       , Just CoreExpr
abst <- Type -> Type -> Maybe CoreExpr
mkAbstC'_maybe Type
funCat Type
bodyTy
       -> Doing("top con abstRepr")
          ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop ReExpr
forall a b. (a -> b) -> a -> b
$ Unop CoreExpr
mkCcc Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$
           [CoreBndr] -> Unop CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
binds Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$
            CoreExpr
abst Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` (Unop CoreExpr
inlineE CoreExpr
repr Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
body)
     Trying("top unfold")
     e :: CoreExpr
e@(CoreExpr -> Maybe CoreBndr
exprHead -> Just CoreBndr
_v)
       | -- Temp hack: avoid unfold/case-of-product loop.
         {- isCast e || not (isSelectorId _v || isAbstReprId _v)
       , -} Just CoreExpr
e' <- ReExpr
unfoldMaybe CoreExpr
e
       -> Doing("top unfold")
          -- , dtrace "top unfold" (ppr e <+> text "-->" <+> ppr e') True
          ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Unop CoreExpr
mkCcc CoreExpr
e')
     Trying("top App")
     e :: CoreExpr
e@(App CoreExpr
u CoreExpr
v)
       -- \| dtrace "top App tests" (ppr (exprType v,liftedExpr v, mkConst' cat dom v,mkUncurryMaybe cat (mkCcc u))) False -> undefined
       | Bool
catClosed, CoreExpr -> Bool
liftedExpr CoreExpr
v
       , Just CoreExpr
v' <- Type -> Type -> ReExpr
mkConst' Type
cat Type
dom CoreExpr
v
       -- , dtrace "top App  --> " (pprWithType v') True
       , Just CoreExpr
uncU' <- Type -> ReExpr
mkUncurryMaybe Type
cat (Unop CoreExpr
mkCcc CoreExpr
u)
       -- , dtrace "top App uncU'" (pprWithType uncU') True
       -> Doing("top App")
          -- u v == uncurry u . (constFun v &&& id)
          -- dtrace "mkFork cat v' (mkId cat dom) -->" (ppr (mkFork cat v' (mkId cat dom))) $
          -- dtrace "mkCompose cat uncU' (mkFork cat v' (mkId cat dom)) -->" (ppr (mkCompose cat uncU' (mkFork cat v' (mkId cat dom)))) $
          -- dtrace "top App result" (ppr (mkCompose cat uncU' (mkFork cat v' (mkId cat dom)))) $
          ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Binop CoreExpr
mkCompose Type
cat CoreExpr
uncU' (Type -> Binop CoreExpr
mkFork Type
cat CoreExpr
v' (Type -> Type -> CoreExpr
mkId Type
cat Type
dom)))
      where
        Just (Type
dom,Type
_) = Type -> Maybe (Type, Type)
splitFunTy_maybe' ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e)
     Tick CoreTickish
t CoreExpr
e -> Doing("top tick")
                 ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop ReExpr
forall a b. (a -> b) -> a -> b
$ CoreTickish -> Unop CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t (Unop CoreExpr
mkCcc CoreExpr
e)
     CoreExpr
_e -> Doing("top Unhandled")
           -- pprTrace "ccc go. Unhandled" (ppr _e) $ Nothing
           -- pprPanic "ccc go. Unhandled" (ppr _e)
           Maybe CoreExpr
forall a. Maybe a
Nothing
   -- go _ = Nothing
   -- goLam x body | dtrace "goLam:" (ppr (Lam x body)) False = undefined
   -- goLam x body | dtrace ("goLam body constr: " ++ exprConstr body) (ppr (Lam x body)) False = undefined
    where
      catClosed :: Bool
catClosed = Type -> Bool
isClosed Type
cat
      subst1 :: CoreBndr -> Binop CoreExpr
subst1 CoreBndr
v CoreExpr
e = [CoreBndr] -> [(CoreBndr, CoreExpr)] -> Unop CoreExpr
subst [] [(CoreBndr
v,CoreExpr
e)]
   goLam' :: CoreBndr -> ReExpr
goLam' CoreBndr
x CoreExpr
body =
     [Char] -> SDoc -> Maybe CoreExpr -> Maybe CoreExpr
forall a. [Char] -> SDoc -> a -> a
dtrace ([Char]
"goLam "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++CoreBndr -> [Char]
forall a. Outputable a => a -> [Char]
pp CoreBndr
x[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Type -> [Char]
forall a. Outputable a => a -> [Char]
pp Type
cat[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
":") (CoreExpr -> SDoc
pprWithType CoreExpr
body) (Maybe CoreExpr -> Maybe CoreExpr)
-> Maybe CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$
     CoreBndr -> ReExpr
goLam CoreBndr
x CoreExpr
body
#if 0
   goLam x body
     | Just e' <- etaReduce_maybe (Lam x body) =
    Doing("lam eta-reduce")
    return (mkCcc e')
#endif
   goLam :: CoreBndr -> ReExpr
goLam CoreBndr
x CoreExpr
body = case CoreExpr
body of
     Trying("lam Id")
     Var CoreBndr
y | CoreBndr
x CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
y -> Doing("lam Id")
                       ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type -> CoreExpr
mkId Type
cat Type
xty)
     Trying("lam Poly const")
     CoreExpr
_ | Bool -> Bool
not Bool
enablePolymorphism, Bool
isConst, Bool -> Bool
not (Type -> Bool
isFunTy Type
bty), Bool -> Bool
not (Type -> Bool
isMonoTy Type
bty)
       -> Doing("lam Poly const bail")
          -- dtrace("lam Poly const: bty, isFunTy, isMonoTy") (ppr (bty, isFunTy bty, isMonoTy bty)) $
          Maybe CoreExpr
forall a. Maybe a
Nothing
     Trying("lam bottom") -- must come before "lam Const" and "lam App"
     -- TODO: translate to bottomC in Rebox or AltCat.
     -- Maybe I don't need anything here.
     -- toCcc (\ x -> bottom @ t) --> bottomC
     (CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs -> (Var ((CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
bottomV) -> Bool
True),[Type Type
ty]))
       | Just CoreExpr
e' <- Type -> Type -> Type -> Maybe CoreExpr
mkBottomC Type
cat Type
xty Type
ty
       -> Doing("lam bottom")
          ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e'
     Trying("lam Const")
     -- _ | isConst, dtrace "goLam mkConst'" (ppr (exprType body,mkConst' cat xty body)) False -> undefined
     CoreExpr
_ | Bool
isConst, Just CoreExpr
body' <- Type -> Type -> ReExpr
mkConst' Type
cat Type
xty CoreExpr
body
       -> Doing("lam mkConst'")
       ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
body'

     Trying("lam Avoid pseudo-app")
     (CoreExpr -> Bool
isPseudoApp -> Bool
True) ->
       -- let (Var _v, _) = collectArgs body in -- TEMP
       --   pprTrace ("lam Avoid pseudo-app " ++ uqVarName _v) empty $
         Doing("lam Avoid pseudo-app")
         Maybe CoreExpr
forall a. Maybe a
Nothing

     Trying("lam Pair")
     (CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs -> (CoreExpr
PairVar,(Type Type
a : Type Type
b : [CoreExpr]
rest))) ->
       --  \| dtrace "Pair" (ppr rest) False -> undefined
       case [CoreExpr]
rest of
         []    -> -- (,) == curry id
                  -- Do we still need this case, or is it handled by catFun?
                  Doing("lam Plain (,)")
                  -- return (mkCurry cat (mkId cat (pairTy a b)))
                  Type -> ReExpr
mkCurry' Type
cat (Type -> Type -> CoreExpr
mkId Type
cat (Type -> Type -> Type
pairTy Type
a Type
b))
         [CoreExpr
_]   -> Doing("lam Pair eta-expand")
                  CoreBndr -> ReExpr
goLam' CoreBndr
x (Int -> Unop CoreExpr
etaExpand Int
1 CoreExpr
body)
         [CoreExpr
u,CoreExpr
v] -> Doing("lam Pair")
                  -- dtrace "Pair test" (pprWithType u <> comma <+> pprWithType v) $
                  ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Binop CoreExpr
mkFork Type
cat (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
u)) (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
v)))
         [CoreExpr]
_     -> [Char] -> SDoc -> Maybe CoreExpr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"goLam Pair: too many arguments: " ([CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
rest)
     -- Revisit.
     Trying("lam con abstRepr")
     -- Constructor applied to ty/co/dict arguments
     e :: CoreExpr
e@(CoreExpr -> (CoreExpr, [CoreExpr])
collectNonTyCoDictArgs ->
        (CoreExpr -> (CoreExpr, [CoreExpr])
collectTyCoDictArgs -> (Var (CoreBndr -> Maybe DataCon
isDataConId_maybe -> Just DataCon
dc),[CoreExpr]
_), [CoreExpr]
args))
       | let ([CoreBndr]
binds,CoreExpr
body') = CoreExpr -> ([CoreBndr], CoreExpr)
forall b. Expr b -> ([b], Expr b)
collectBinders (Int -> Unop CoreExpr
etaExpand (DataCon -> Int
dataConRepArity DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- [CoreExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
args) CoreExpr
e)
             bodyTy :: Type
bodyTy = (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body'
       , Just CoreExpr
repr <- Type -> Type -> Maybe CoreExpr
mkReprC'_maybe Type
funCat Type
bodyTy
       , Just CoreExpr
abst <- Type -> Type -> Maybe CoreExpr
mkAbstC'_maybe Type
funCat Type
bodyTy
       -> Doing("lam con abstRepr")
          ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop ReExpr
forall a b. (a -> b) -> a -> b
$ Unop CoreExpr
mkCcc Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$
            [CoreBndr] -> Unop CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
binds Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr
abst Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` (Unop CoreExpr
inlineE CoreExpr
repr Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
body')
     -- (\ x -> let y = f x in g y) --> g . f
     -- (\ x -> let y = RHS in BODY) --> (\ y -> BODY) . (\ x -> RHS)
     --    if x not free in B
     Trying("lam Let")
     -- TODO: refactor with top Let
     _e :: CoreExpr
_e@(Let bind :: Bind CoreBndr
bind@(NonRec CoreBndr
v CoreExpr
rhs) CoreExpr
body') ->
       -- dtrace "lam Let subst criteria" (ppr (substFriendly catClosed rhs, not xInRhs, idOccs True v body')) $
       if Bool -> Bool
not Bool
catClosed Bool -> Bool -> Bool
|| -- experiment
          Bool -> CoreExpr -> Bool
substFriendly Bool
catClosed CoreExpr
rhs Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
xInRhs Bool -> Bool -> Bool
|| Bool -> CoreBndr -> CoreExpr -> Int
idOccs Bool
True CoreBndr
v CoreExpr
body' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 then
         -- TODO: decide whether to float or substitute.
         -- To float, x must not occur freely in rhs
         -- return (mkCcc (Lam x (subst1 v rhs body'))) The simplifier seems to
         -- re-let my dicts if I let it. Will the simplifier re-hoist later? If
         -- so, we can still let-hoist instead of substituting.
         if Bool
xInRhs then
           Doing("lam Let subst")
           -- TODO: mkCcc instead of goLam?
           -- Just (mkCcc (Lam x (subst1 v rhs body')))
           -- Sometimes GHC then un-substitutes, leading to a loop.
           -- Using goLam prevents GHC from getting that chance. (Always?)
           CoreBndr -> ReExpr
goLam' CoreBndr
x ([CoreBndr] -> CoreBndr -> Binop CoreExpr
subst1 [CoreBndr
x] CoreBndr
v CoreExpr
rhs CoreExpr
body')
           -- Yet another choice is to lambda-lift the binding over x and then
           -- float the let past the x binding.
         else
           Doing("lam Let float")
           ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bind CoreBndr -> Unop CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let Bind CoreBndr
bind (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
body')))
       else
         Doing("lam Let to beta-redex")
         CoreBndr -> ReExpr
goLam' CoreBndr
x (Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
v CoreExpr
body') CoreExpr
rhs)
      where
        xInRhs :: Bool
xInRhs = CoreBndr
x CoreBndr -> CoreExpr -> Bool
`isFreeIn` CoreExpr
rhs
     -- Trying("lam letrec")
     -- _e@(Let bind@(Rec [(v,rhs)]) body') ->
     --    Doing("lam letrec")
     --    undefined
     Trying("lam Let compose")
     Let (NonRec CoreBndr
y CoreExpr
rhs) CoreExpr
body'
       | Bool -> Bool
not (CoreBndr
x CoreBndr -> CoreExpr -> Bool
`isFreeIn` CoreExpr
body')
       , Just CoreExpr
comp <- Type -> ReExpr2
mkCompose' Type
cat (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
y CoreExpr
body')) (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
rhs))
       -> Doing("lam Let compose")
          ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
comp
     Trying("lam inner eta-reduce")
     (ReExpr
etaReduce_maybe -> Just CoreExpr
e') ->
       Doing("lam inner eta-reduce")
       CoreBndr -> ReExpr
goLam' CoreBndr
x CoreExpr
e'
     Trying("lam Lam")
     Lam CoreBndr
y CoreExpr
e ->
       -- (\ x -> \ y -> U) --> curry (\ z -> U[fst z/x, snd z/y])
       Doing("lam Lam")
       -- dtrace "Lam isDeads" (ppr (isDeadBinder x, isDeadBinder y)) $
       -- dtrace "Lam sub" (ppr sub) $
       -- TODO: maybe let instead of subst
       -- Substitute rather than making a Let, to prevent infinite regress.
       -- return $ mkCurry cat (mkCcc (Lam z (subst sub e)))
       -- Fail gracefully when we can't mkCurry, giving inlining a chance to
       -- resolve polymorphism to monomorphism. See 2017-10-18 notes.
       (if Maybe CoreExpr -> Bool
forall a. Maybe a -> Bool
isNothing Maybe CoreExpr
mbe' then [Char]
-> SDoc
-> (Maybe CoreExpr -> Maybe CoreExpr)
-> Maybe CoreExpr
-> Maybe CoreExpr
forall a. [Char] -> SDoc -> a -> a
dtrace [Char]
"lam Lam fail" SDoc
empty Maybe CoreExpr -> Maybe CoreExpr
forall a. a -> a
id else Maybe CoreExpr -> Maybe CoreExpr
forall a. a -> a
id) (Maybe CoreExpr -> Maybe CoreExpr)
-> Maybe CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$
       Maybe CoreExpr
mbe'
      where
        yty :: Type
yty = CoreBndr -> Type
varType CoreBndr
y
        z :: CoreBndr
z = VarSet -> [Char] -> Type -> CoreBndr
freshId (CoreExpr -> VarSet
exprFreeVars CoreExpr
e) [Char]
zName (Type -> Type -> Type
pairTy Type
xty Type
yty)
        zName :: [Char]
zName = CoreBndr -> [Char]
uqVarName CoreBndr
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CoreBndr -> [Char]
uqVarName CoreBndr
y
        sub :: [(CoreBndr, CoreExpr)]
sub = [(CoreBndr
x,Type -> CoreBndr -> Unop CoreExpr
mkEx Type
funCat CoreBndr
exlV (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
z)),(CoreBndr
y,Type -> CoreBndr -> Unop CoreExpr
mkEx Type
funCat CoreBndr
exrV (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
z))]
        -- TODO: consider using fst & snd instead of exl and exr here
        mbe' :: Maybe CoreExpr
mbe' = Type -> ReExpr
mkCurry' Type
cat (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
z ([CoreBndr] -> [(CoreBndr, CoreExpr)] -> Unop CoreExpr
subst [] [(CoreBndr, CoreExpr)]
sub CoreExpr
e)))
     Trying("lam boxer")
     (ReExpr
boxCon -> Just CoreExpr
e') ->
       Doing("lam boxer")
       ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
e'))
     Trying("lam Case of boxer")
     e :: CoreExpr
e@(Case CoreExpr
scrut CoreBndr
wild Type
_ty [Alt AltCon
_dc [CoreBndr
unboxedV] CoreExpr
rhs])
       | Just (TyCon
tc,[]) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe (CoreBndr -> Type
varType CoreBndr
wild)
       , Just CoreBndr
boxV <- (UniqDFM TyCon CoreBndr -> TyCon -> Maybe CoreBndr)
-> TyCon -> UniqDFM TyCon CoreBndr -> Maybe CoreBndr
forall a b c. (a -> b -> c) -> b -> a -> c
flip UniqDFM TyCon CoreBndr -> TyCon -> Maybe CoreBndr
forall key elt.
Uniquable key =>
UniqDFM key elt -> key -> Maybe elt
DFMap.lookupUDFM TyCon
tc UniqDFM TyCon CoreBndr
boxers
       -> Doing("lam Case of boxer")
          -- dtrace "boxV" (ppr boxV) $
          let wild' :: CoreBndr
wild' = CoreBndr -> OccInfo -> CoreBndr
setIdOccInfo CoreBndr
wild OccInfo
compatNoOccInfo
              tweak :: Unop CoreExpr
              tweak :: Unop CoreExpr
tweak (Var CoreBndr
v) | CoreBndr
v CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
unboxedV =
                [Char] -> SDoc -> CoreExpr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic ([Char]
"lam Case of boxer: bare unboxed var") (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e)
              tweak (App (Var CoreBndr
f) (Var CoreBndr
v)) | CoreBndr
f CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
boxV, CoreBndr
v CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
unboxedV = CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
wild'
              tweak CoreExpr
e' = CoreExpr
e'
              compatNoOccInfo :: OccInfo
compatNoOccInfo = OccInfo
noOccInfo
          in
            -- Note top-down (everywhere') instead of bottom-up (everywhere)
            -- so that we can find 'boxI v' before v.
            ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x (Bind CoreBndr -> Unop CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (CoreBndr -> CoreExpr -> Bind CoreBndr
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
wild' CoreExpr
scrut) ((forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere' (Unop CoreExpr -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Unop CoreExpr
tweak) CoreExpr
rhs))))
     Trying("lam Case hoist")
     Case CoreExpr
scrut CoreBndr
wild Type
ty [Alt AltCon
dc [CoreBndr]
vs CoreExpr
rhs]
       | Bool -> Bool
not (CoreBndr
x CoreBndr -> CoreExpr -> Bool
`isFreeIn` CoreExpr
scrut)
       -> Doing("lam Case hoist")
          ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop ReExpr
forall a b. (a -> b) -> a -> b
$
           Unop CoreExpr
mkCcc (CoreExpr -> CoreBndr -> Type -> [Alt CoreBndr] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut CoreBndr
wild (Type -> Type -> Type
mkFunTy' Type
xty Type
ty) [AltCon -> [CoreBndr] -> CoreExpr -> Alt CoreBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
dc [CoreBndr]
vs (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
rhs)])
          -- pprPanic ("lam Case hoist") empty
     Trying("lam Case to let")
     Case CoreExpr
scrut v :: CoreBndr
v@(CoreBndr -> Bool
isDeadBinder -> Bool
False) Type
_rhsTy [Alt AltCon
_ [CoreBndr]
bs CoreExpr
rhs]
       | VarSet -> Bool
isEmptyVarSet ([CoreBndr] -> VarSet
mkVarSet [CoreBndr]
bs VarSet -> VarSet -> VarSet
`intersectVarSet` CoreExpr -> VarSet
exprFreeVars CoreExpr
rhs) ->
       Doing("lam Case to let")
       ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x (Bind CoreBndr -> Unop CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (CoreBndr -> CoreExpr -> Bind CoreBndr
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
v CoreExpr
scrut) CoreExpr
rhs)))
     Trying("lam Case live wild")
     (ReExpr
deadifyCaseWild -> Just CoreExpr
e') ->
       Doing("lam Case live wild")
       CoreBndr -> ReExpr
goLam' CoreBndr
x CoreExpr
e'
     Trying("lam Case default")
     Case CoreExpr
_scrut CoreBndr
_ Type
_rhsTy [Alt AltCon
DEFAULT [] CoreExpr
rhs] ->
       Doing("lam case-default")
       ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
rhs))
     Trying("lam Case nullary")
     Case CoreExpr
_scrut CoreBndr
_ Type
_rhsTy [Alt AltCon
_ [] CoreExpr
rhs] ->
       Doing("lam Case nullary")
       ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
rhs))
       -- TODO: abstract return (mkCcc (Lam x ...))
     Trying("lam Case of Bool")
     Case CoreExpr
scrut CoreBndr
_ Type
rhsTy [Alt (DataAlt DataCon
false) [] CoreExpr
rhsF, Alt (DataAlt DataCon
true) [] CoreExpr
rhsT]
         | DataCon
false DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
falseDataCon Bool -> Bool -> Bool
&& DataCon
true DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
trueDataCon ->
       -- To start, require v to be unused. Later, extend.
       -- if not (isDeadBinder wild) && wild `isFreeIns` [rhsF,rhsT] then
       --      pprPanic "lam Case of Bool: live wild var (not yet handled)" (ppr e)
       -- else
          Doing("lam Case of Bool")
          ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop ReExpr
forall a b. (a -> b) -> a -> b
$
            Type -> Type -> Ternop CoreExpr
mkIfC Type
cat Type
rhsTy (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
scrut))
              (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
rhsT)) (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
rhsF))
     Trying("lam Case of product")
     Case CoreExpr
scrut CoreBndr
_ Type
_rhsTy [Alt (DataAlt DataCon
dc) [CoreBndr
a,CoreBndr
b] CoreExpr
rhs]
         | TyCon -> Bool
isBoxedTupleTyCon (DataCon -> TyCon
dataConTyCon DataCon
dc) ->
       Doing("lam Case of product")
       if -- \| not (isDeadBinder wild) ->  -- About to remove
          --     pprPanic "lam Case of product live wild binder" (ppr e)
          | Bool -> Bool
not (CoreBndr
b CoreBndr -> CoreExpr -> Bool
`isFreeIn` CoreExpr
rhs) ->
              ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop ReExpr
forall a b. (a -> b) -> a -> b
$ Unop CoreExpr
mkCcc Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$ -- inlineE $  -- already inlines early
                CoreBndr -> [Type] -> [CoreExpr] -> CoreExpr
varApps CoreBndr
casePairLTV
                  [Type
xty,CoreBndr -> Type
varType CoreBndr
a,CoreBndr -> Type
varType CoreBndr
b,Type
_rhsTy]
                  [CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
scrut, [CoreBndr] -> Unop CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr
x,CoreBndr
a] CoreExpr
rhs]
          | Bool -> Bool
not (CoreBndr
a CoreBndr -> CoreExpr -> Bool
`isFreeIn` CoreExpr
rhs) ->
              ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop ReExpr
forall a b. (a -> b) -> a -> b
$ Unop CoreExpr
mkCcc Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$ -- inlineE $  -- already inlines early
                CoreBndr -> [Type] -> [CoreExpr] -> CoreExpr
varApps CoreBndr
casePairRTV
                  [Type
xty,CoreBndr -> Type
varType CoreBndr
a, CoreBndr -> Type
varType CoreBndr
b,Type
_rhsTy]
                  [CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
scrut, [CoreBndr] -> Unop CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr
x,CoreBndr
b] CoreExpr
rhs]
          -- TODO: do the L & R optimizations help?
          | Bool
otherwise ->
              ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop ReExpr
forall a b. (a -> b) -> a -> b
$ Unop CoreExpr
mkCcc Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$ Unop CoreExpr
inlineE Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$  -- wasn't inlining early
                CoreBndr -> [Type] -> [CoreExpr] -> CoreExpr
varApps CoreBndr
casePairTV
                  [Type
xty,CoreBndr -> Type
varType CoreBndr
a,CoreBndr -> Type
varType CoreBndr
b,Type
_rhsTy]
                  [CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
scrut, [CoreBndr] -> Unop CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr
x,CoreBndr
a,CoreBndr
b] CoreExpr
rhs]

     -- Trying("lam Case cast")
     -- Case (Cast scrut (setNominalRole_maybe -> Just co')) v altsTy alts
     --   -> Doing("lam Case cast")
     --           Trying("lam Case cast")
     Trying("lam Case unfold")
     Case CoreExpr
scrut CoreBndr
v Type
altsTy [Alt CoreBndr]
alts
       -- \| pprTrace "lam Case unfold" (ppr (scrut,unfoldMaybe' scrut)) False -> undefined
       | Just CoreExpr
scrut' <- ReExpr
unfoldMaybe' CoreExpr
scrut
       -> Doing("lam Case unfold")
          ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop ReExpr
forall a b. (a -> b) -> a -> b
$ Unop CoreExpr
mkCcc Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$
           CoreExpr -> CoreBndr -> Type -> [Alt CoreBndr] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut' CoreBndr
v Type
altsTy [Alt CoreBndr]
alts
     -- Does unfolding suffice as an alternative? Not quite, since lambda-bound
     -- variables can appear as scrutinees. Maybe we could eliminate that
     -- possibility with another transformation.
     -- 2016-01-04: I moved lam case abstRepr after unfold
     -- Do I also need top case abstRepr?
     Trying("lam case abstRepr")
     Case CoreExpr
scrut v :: CoreBndr
v@(CoreBndr -> Type
varType -> Type
vty) Type
altsTy [Alt CoreBndr]
alts
       | Just CoreExpr
repr <- Type -> Type -> Maybe CoreExpr
mkReprC'_maybe Type
funCat Type
vty
       , Just CoreExpr
abst <- Type -> Type -> Maybe CoreExpr
mkAbstC'_maybe Type
funCat Type
vty
       -> Doing("lam case abstRepr")
          ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop ReExpr
forall a b. (a -> b) -> a -> b
$ Unop CoreExpr
mkCcc Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$
           CoreExpr -> CoreBndr -> Type -> [Alt CoreBndr] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Unop CoreExpr
inlineE CoreExpr
abst Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` (CoreExpr
repr Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
scrut)) CoreBndr
v Type
altsTy [Alt CoreBndr]
alts
     Trying("lam nominal Cast")
     Cast CoreExpr
body' co :: Coercion
co@(Rewrite Coercion
setNominalRole_maybe' -> Just Coercion
co') ->
       -- etaExpand turns cast lambdas into themselves
       Doing("lam nominal cast")
       let r :: Role
r  = Coercion -> Role
coercionRole Coercion
co
           r' :: Role
r' = Coercion -> Role
coercionRole Coercion
co'         -- always Nominal, isn't it?
           co'' :: Coercion
co'' = Role -> Role -> Coercion -> Coercion
downgradeRole Role
r Role
r' Coercion
co' -- same as co?
       in
         -- pprTrace "lam nominal Cast" (ppr co $$ text "-->" $$ ppr co'') $
         ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Unop CoreExpr
mkCcc (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
body') (Role -> Coercion -> Coercion -> Coercion
mkFunCo' Role
r (Role -> Type -> Coercion
mkReflCo Role
r Type
xty) Coercion
co'')))
     Trying("lam representational cast")
     e :: CoreExpr
e@(Cast CoreExpr
e' Coercion
_) ->
       Doing("lam representational cast")
       -- Will I get unnecessary coerceCs due to nominal-able sub-coercions?
       -- TODO: convert to mkCoerceC also. Then eliminate mkCoerceC, and
       -- rename mkCoerceC.
       ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop ReExpr
forall a b. (a -> b) -> a -> b
$ Type -> Binop CoreExpr
mkCompose Type
cat (Type -> Type -> Type -> CoreExpr
mkCoerceC Type
cat ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e') ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e)) Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$
                Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
e')
     Trying("lam fmap unfold")
     e :: CoreExpr
e@(CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs -> (Var CoreBndr
v, Type (Type -> Bool
isFunCat -> Bool
False) : [CoreExpr]
_))
        | CoreBndr
v CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
fmapV
        , Just CoreExpr
body' <- ReExpr
unfoldMaybe CoreExpr
e
        -> Doing("lam fmap unfold")
           -- dtrace "lam fmap unfold" (ppr body') $
           ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
body'))

     Trying("lam fmap 1")
     _e :: CoreExpr
_e@(CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs -> (Var CoreBndr
v, [Type Type
_ {-(isFunTy -> True)-},Type Type
h,Type Type
b,Type Type
c,CoreExpr
_dict,CoreExpr
_ok,CoreExpr
f])) | CoreBndr
v CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
fmapV ->
        Doing("lam fmap 1")
        -- pprTrace "lam fmap body" (ppr _e) $
        -- pprTrace "lam fmap pieces" (ppr (h,xty,b,c,f)) $
        -- -- (\ x -> fmap F BS)  -->  fmapTrans' (\ x -> F)
        -- pprTrace "fmapT1" (ppr (varWithType fmapT1V)) $
        let e' :: CoreExpr
e' = Unop CoreExpr
onDicts (CoreBndr -> [Type] -> [CoreExpr] -> CoreExpr
varApps CoreBndr
fmapT1V [Type
h,Type
xty,Type
b,Type
c] []) CoreExpr -> [CoreExpr] -> CoreExpr
`mkCoreApps` [CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
f] in
          -- pprTrace "fmap constructed expression" (ppr e') $
          -- pprPanic "lam fmap bailing" empty
          ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Unop CoreExpr
mkCcc CoreExpr
e')

     Trying("lam App compose")
     -- (\ x -> U V) --> U . (\ x -> V) if x not free in U
     CoreExpr
u `App` CoreExpr
v | CoreExpr -> Bool
liftedExpr CoreExpr
v
               , Bool -> Bool
not (CoreBndr
x CoreBndr -> CoreExpr -> Bool
`isFreeIn` CoreExpr
u)
               , Type -> Bool
okType ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
v)
               -> case Type -> ReExpr2
mkCompose' Type
cat (Unop CoreExpr
mkCcc CoreExpr
u) (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
v)) of
                    Maybe CoreExpr
Nothing ->
                      Doing("lam App compose bail")
                      Maybe CoreExpr
forall a. Maybe a
Nothing
                    Just CoreExpr
e' ->
                      Doing("lam App compose")
                      ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e'

     Trying("lam fmap 2")
     -- This rule goes after lam App compose, so we know that the fmap'd
     -- function depends on x, and the extra complexity is warranted.
     -- HM. It's *not* after lam App compose.
     _e :: CoreExpr
_e@(CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs -> (Var CoreBndr
v, [Type Type
_ {-(isFunTy -> True)-},Type Type
h,Type Type
b,Type Type
c,CoreExpr
_dict,CoreExpr
_ok,CoreExpr
f,CoreExpr
bs])) | CoreBndr
v CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
fmapV ->
        Doing("lam fmap 2")
        -- pprTrace "lam fmap body" (ppr _e) $
        -- pprTrace "lam fmap pieces" (ppr (h,xty,b,c,f,bs)) $
        -- -- (\ x -> fmap F BS)  -->  fmapTrans' (\ x -> F) (\ x -> BS)
        -- pprTrace "fmapT2" (ppr (varWithType fmapT2V)) $
        let e' :: CoreExpr
e' = Unop CoreExpr
onDicts (CoreBndr -> [Type] -> [CoreExpr] -> CoreExpr
varApps CoreBndr
fmapT2V [Type
h,Type
xty,Type
b,Type
c] []) CoreExpr -> [CoreExpr] -> CoreExpr
`mkCoreApps` [CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
f, CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
bs] in
          -- pprTrace "fmap constructed expression" (ppr e') $
          -- pprPanic "lam fmap bailing" empty
          ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Unop CoreExpr
mkCcc CoreExpr
e')

     Trying("lam App")
     -- (\ x -> U V) --> apply . (\ x -> U) &&& (\ x -> V)
     CoreExpr
u `App` CoreExpr
v --  \| pprTrace "lam App" (ppr (u,v)) False -> undefined
               | Bool
catClosed, CoreExpr -> Bool
liftedExpr CoreExpr
v, Type -> Bool
okType ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
v)
               -- , pprTrace "lam App mkApplyMaybe -->" (ppr (mkApplyMaybe cat vty bty, cat)) True
               , Maybe CoreExpr
mbComp <- do CoreExpr
app  <- Type -> Type -> Type -> Maybe CoreExpr
mkApplyMaybe Type
cat Type
vty Type
bty
                              CoreExpr
fork <- Type -> ReExpr2
mkFork' Type
cat (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
u)) (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
v))
                              Type -> ReExpr2
mkCompose' Type
cat CoreExpr
app CoreExpr
fork
               -> case Maybe CoreExpr
mbComp of
                    Maybe CoreExpr
Nothing ->
                      Doing("lam App bail")
                      Maybe CoreExpr
forall a. Maybe a
Nothing
                    Just CoreExpr
e' ->
                      Doing("lam App")
                      ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e'
      where
        vty :: Type
vty = (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
v
     Trying("lam unfold")
     CoreExpr
e'| Just CoreExpr
body' <- ReExpr
unfoldMaybe CoreExpr
e'
       -> Doing("lam unfold")
          -- dtrace "lam unfold" (ppr body $$ text "-->" $$ ppr body') $
          ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
body'))
          -- goLam' x body'
          -- TODO: factor out Lam x (mkCcc ...)
     Tick CoreTickish
t CoreExpr
e -> Doing("lam tick")
                 ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop ReExpr
forall a b. (a -> b) -> a -> b
$ CoreTickish -> Unop CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t (Unop CoreExpr
mkCcc (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
e))
     -- Give up
     CoreExpr
_e -> -- pprPanic "ccc" ("lam Unhandled" <+> ppr (Lam x _e))
           -- pprTrace "goLam" ("Unhandled" <+> ppr _e) $
           Maybe CoreExpr
forall a. Maybe a
Nothing
    where
      xty :: Type
xty = CoreBndr -> Type
varType CoreBndr
x
      bty :: Type
bty = (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body
      isConst :: Bool
isConst = Bool -> Bool
not (CoreBndr
x CoreBndr -> CoreExpr -> Bool
`isFreeIn` CoreExpr
body)
      catClosed :: Bool
catClosed = Type -> Bool
isClosed Type
cat
      subst1 :: [CoreBndr] -> CoreBndr -> Binop CoreExpr
subst1 [CoreBndr]
vars CoreBndr
v CoreExpr
e = [CoreBndr] -> [(CoreBndr, CoreExpr)] -> Unop CoreExpr
subst [CoreBndr]
vars [(CoreBndr
v,CoreExpr
e)]

   -- Given
   --
   --  * a desired polarity
   --  * a representational coercion co :: t1 ~ t2
   --  * a list of type arguments `ts`
   --
   -- returns  an expression of type
   --   t1 ts `cat` t2 ts (if polarity = True)
   --   t2 ts `cat` t1 ts (if polarity = False)
   --
   -- built using (.), fmapC, reprC and abstC
   --
   --
   -- goCoercion checks that the output types make sense; goCoercion' does the work
   goCoercion :: Bool -> Coercion -> [Type] -> CoreExpr
   goCoercion :: Bool -> Coercion -> [Type] -> CoreExpr
goCoercion Bool
pol Coercion
co [Type]
ts
     | Just (Type
t1',Type
t2') <- Type -> Maybe (Type, Type)
tyArgs2_maybe ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
exp_out)
     , (Type
t1 Type -> [Type] -> Type
`mkAppTys` [Type]
ts) Type -> Type -> Bool
`eqType` Type
t1'
     , (Type
t2 Type -> [Type] -> Type
`mkAppTys` [Type]
ts) Type -> Type -> Bool
`eqType` Type
t2'
     = CoreExpr
exp_out
     | Just (Type
t1',Type
t2') <- Type -> Maybe (Type, Type)
tyArgs2_maybe ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
exp_out)
     = [Char] -> SDoc -> CoreExpr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"goCoercion mismatch:" (SDoc -> CoreExpr) -> SDoc -> CoreExpr
forall a b. (a -> b) -> a -> b
$
       Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
pol SDoc -> SDoc -> SDoc
$$ Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co SDoc -> SDoc -> SDoc
$$ Pair Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Coercion -> Pair Type
coercionKind Coercion
co) SDoc -> SDoc -> SDoc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
ts SDoc -> SDoc -> SDoc
$$ Pair Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> Type -> Pair Type
forall a. a -> a -> Pair a
Pair Type
t1' Type
t2') SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
exp_out
     | Bool
otherwise
     = [Char] -> SDoc -> CoreExpr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"goCoercion not returning categorial arrow:" (SDoc -> CoreExpr) -> SDoc -> CoreExpr
forall a b. (a -> b) -> a -> b
$
       Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
pol SDoc -> SDoc -> SDoc
$$ Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co SDoc -> SDoc -> SDoc
$$ Pair Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Coercion -> Pair Type
coercionKind Coercion
co) SDoc -> SDoc -> SDoc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
ts SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
pprWithType CoreExpr
exp_out

     where exp_out :: CoreExpr
exp_out = Bool -> Coercion -> [Type] -> CoreExpr
goCoercion' Bool
pol Coercion
co [Type]
ts
           Pair Type
t1 Type
t2 = (if Bool
pol then Pair Type -> Pair Type
forall a. a -> a
id else Pair Type -> Pair Type
forall a. Pair a -> Pair a
swap) (Pair Type -> Pair Type) -> Pair Type -> Pair Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
co

   -- Reflexivity
   goCoercion' :: Bool -> Coercion -> [Type] -> CoreExpr
goCoercion' Bool
_ Coercion
co [Type]
ts | Just (Type
ty, Role
_) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co = Type -> Type -> CoreExpr
mkId Type
cat (Type
ty Type -> [Type] -> Type
`mkAppTys` [Type]
ts)

   -- Symmetry
   goCoercion' Bool
pol (SymCo Coercion
co) [Type]
ts = Bool -> Coercion -> [Type] -> CoreExpr
goCoercion (Bool -> Bool
not Bool
pol) Coercion
co [Type]
ts

   -- Transitivity
   goCoercion' Bool
pol (TransCo Coercion
co1 Coercion
co2) [Type]
ts
     = (if Bool
pol then Binop CoreExpr -> Binop CoreExpr
forall a. a -> a
id else Binop CoreExpr -> Binop CoreExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip) (Type -> Binop CoreExpr
mkCompose Type
cat) (Bool -> Coercion -> [Type] -> CoreExpr
goCoercion' Bool
pol Coercion
co2 [Type]
ts) (Bool -> Coercion -> [Type] -> CoreExpr
goCoercion Bool
pol Coercion
co1 [Type]
ts)

   -- Coercion application: reflexive argument
   goCoercion' Bool
pol (AppCo Coercion
co1 Coercion
co2) [Type]
ts | Just (Type
t, Role
_role) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co2
     = Bool -> Coercion -> [Type] -> CoreExpr
goCoercion Bool
pol Coercion
co1 (Type
t Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
ts)

   -- Coercion application: non-reflexive argument.
   -- Must be a nominal coercion, so treat it similar to SubCo below, and use mkCast
   goCoercion' Bool
pol (AppCo Coercion
co1 Coercion
co2) [Type]
ts
     = CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
out_exp Coercion
out_co
     where
     Pair Type
t11 Type
t12 = (if Bool
pol then Pair Type -> Pair Type
forall a. a -> a
id else Pair Type -> Pair Type
forall a. Pair a -> Pair a
swap) (Pair Type -> Pair Type) -> Pair Type -> Pair Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
co1
     Pair Type
t21 Type
t22 = (if Bool
pol then Pair Type -> Pair Type
forall a. a -> a
id else Pair Type -> Pair Type
forall a. Pair a -> Pair a
swap) (Pair Type -> Pair Type) -> Pair Type -> Pair Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
co2
     out_exp :: CoreExpr
out_exp = Bool -> Coercion -> [Type] -> CoreExpr
goCoercion Bool
pol Coercion
co1 (Type
t21 Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
ts)
     out_co :: Coercion
out_co = (if Bool
pol then Coercion -> Coercion
forall a. a -> a
id else Coercion -> Coercion
mkSymCo) (Coercion -> Coercion) -> Coercion -> Coercion
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => Coercion -> Coercion
Coercion -> Coercion
mkSubCo (Coercion -> Coercion) -> Coercion -> Coercion
forall a b. (a -> b) -> a -> b
$
        Coercion -> [Coercion] -> Coercion
mkAppCos (Role -> Type -> Coercion
mkReflCo Role
Nominal Type
cat)
            [ Role -> Type -> Coercion
mkReflCo Role
Nominal (Type
t11 Type -> [Type] -> Type
`mkAppTys` (Type
t21 Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
ts))
            , Coercion -> [Coercion] -> Coercion
mkAppCos (Role -> Type -> Coercion
mkReflCo Role
Nominal Type
t12) (Coercion
co2 Coercion -> [Coercion] -> [Coercion]
forall a. a -> [a] -> [a]
: [ Role -> Type -> Coercion
mkReflCo Role
Nominal Type
t | Type
t <- [Type]
ts ])
            ]

   -- Nominal coercions are a bit like the identity, but we cast the resulting categorial arrow
   goCoercion' Bool
pol (SubCo Coercion
co) [Type]
ts
     = CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
out_exp Coercion
out_co
     where
     Pair Type
t1 Type
t2 = Coercion -> Pair Type
coercionKind Coercion
co
     out_exp :: CoreExpr
out_exp = Type -> Type -> CoreExpr
mkId Type
cat (Type
t1 Type -> [Type] -> Type
`mkAppTys` [Type]
ts)
     out_co :: Coercion
out_co = (if Bool
pol then Coercion -> Coercion
forall a. a -> a
id else Coercion -> Coercion
mkSymCo) (Coercion -> Coercion) -> Coercion -> Coercion
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => Coercion -> Coercion
Coercion -> Coercion
mkSubCo (Coercion -> Coercion) -> Coercion -> Coercion
forall a b. (a -> b) -> a -> b
$
        Coercion -> [Coercion] -> Coercion
mkAppCos (Role -> Type -> Coercion
mkReflCo Role
Nominal Type
cat) [Role -> Type -> Coercion
mkReflCo Role
Nominal Type
t1, Coercion
co]

   -- Newtype wrapper
   -- This is (very likely) a newtype, so lets see if mkReprC (or mkAbstC) works
   -- For now, the type arguments must not be coerced (usually there are none for newtypes)
   goCoercion' Bool
pol co :: Coercion
co@(AxiomInstCo CoAxiom Branched
_ Int
0 [Coercion]
cos1) [Type]
ts | (Coercion -> Bool) -> [Coercion] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Coercion -> Bool
isReflCo [Coercion]
cos1
    -- = mkReprC' cat (t1 `mkAppTys` ts)
    = CoreExpr -> Maybe CoreExpr -> CoreExpr
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> SDoc -> CoreExpr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"goCoercion AxiomInstCo: failed catOpMaybe" (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)) (Maybe CoreExpr -> CoreExpr) -> Maybe CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
      Type -> CoreBndr -> [Type] -> Maybe CoreExpr
catOpMaybe Type
cat (if Bool
pol then CoreBndr
reprCV else CoreBndr
abstCV) [Type
t1 Type -> [Type] -> Type
`mkAppTys` [Type]
ts, Type
t2 Type -> [Type] -> Type
`mkAppTys` [Type]
ts]
     where Pair Type
t1 Type
t2 = Coercion -> Pair Type
coercionKind Coercion
co


   -- If the a arguments are casted, e.g. the coercion is
   --   NDual (co) <Double> <Float> :: Dual t1 Double Float ~ t2 Float Double
   -- where co :: t1 ~ t2 is a non-refl coercion, we have a slight problem. We
   -- cannot create a categorical term that changes the first parameter of NDual
   -- (we'd need generalization of Functor that are univariant, and that for each type parameter)
   --
   -- So instead we de-normalize the coercion to
   --
   --  co <Float> <Double> ; NDual <t1> <Double> <Float>
   --
   -- by looking at the RHS type of the newtype equation, and building a coercion from it
   -- where we insert the argument coercinos instead of the type variables (using liftCoSubstWith).
   --
   -- This will probably loop for recursive newtypes (newtype Stream = MkS (Double, Stream))
   --
   -- TODO: think this through for pol = False
   goCoercion' Bool
pol (AxiomInstCo CoAxiom Branched
ax Int
0 [Coercion]
cos1) [Type]
ts
     = Bool -> Coercion -> [Type] -> CoreExpr
goCoercion Bool
pol (Coercion -> Coercion -> Coercion
mkTransCo Coercion
co1 Coercion
co2) [Type]
ts
     where
       co1 :: Coercion
co1 = CoAxiom Branched -> Int -> [Coercion] -> Coercion
AxiomInstCo CoAxiom Branched
ax Int
0 [Coercion]
cos1'
       ax_branch :: CoAxBranch
ax_branch = CoAxiom Branched -> Int -> CoAxBranch
forall (br :: BranchFlag). CoAxiom br -> Int -> CoAxBranch
coAxiomNthBranch CoAxiom Branched
ax Int
0
       -- Experimental hack: Hardcoded for the Dual newtype’s RHS
       --co2 = mkAppCos c1 [c3,c2]
       co2 :: Coercion
co2 = Role -> [CoreBndr] -> [Coercion] -> Type -> Coercion
liftCoSubstWith Role
Representational (CoAxBranch -> [CoreBndr]
coAxBranchTyVars CoAxBranch
ax_branch) [Coercion]
cos1 (CoAxBranch -> Type
coAxBranchRHS CoAxBranch
ax_branch)
       cos1' :: [Coercion]
cos1' = [ Role -> Type -> Coercion
mkReflCo (Coercion -> Role
coercionRole Coercion
arg_co) (Pair Type -> Type
forall a. Pair a -> a
pFst (Coercion -> Pair Type
coercionKind Coercion
arg_co)) | Coercion
arg_co <- [Coercion]
cos1 ]

   goCoercion' Bool
pol co :: Coercion
co@(FunCo' Role
Representational Coercion
co1 Coercion
co2) [Type]
ts
    | Bool -> Bool
not ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
ts)
    = [Char] -> SDoc -> CoreExpr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"goCoercion': oddly kinded FunCo" (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co SDoc -> SDoc -> SDoc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
ts)

   -- If we have "<t>_R -> co2", and a suitable FuncorCat instance exists,
   -- we can use fmapC
    | Just (Type
ty1, Role
_role) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co1
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
    , let h :: Type
h = TyCon -> [Type] -> Type
mkTyConApp TyCon
funTyCon [Type
Many, Type
liftedRepTy, Type
liftedRepTy, Type
ty1]
#else
    , let h = mkTyConApp funTyCon [liftedRepTy, liftedRepTy, ty1]
#endif
    , Just CoreExpr
exp_out <- ReExpr
onDictMaybe ReExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> CoreBndr -> [Type] -> Maybe CoreExpr
catOpMaybe Type
cat CoreBndr
fmapV [Type
h, Type
ty21, Type
ty22]
    = CoreExpr
exp_out Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Bool -> Coercion -> [Type] -> CoreExpr
goCoercion Bool
pol Coercion
co2 []
    where Pair Type
ty21 Type
ty22 = (if Bool
pol then Pair Type -> Pair Type
forall a. a -> a
id else Pair Type -> Pair Type
forall a. Pair a -> Pair a
swap) (Pair Type -> Pair Type) -> Pair Type -> Pair Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
co2

   goCoercion' Bool
pol Coercion
co [Type]
ts
     = [Char] -> SDoc -> Unop CoreExpr
forall a. [Char] -> SDoc -> a -> a
dtrace [Char]
"goCoercion giving up, falling back to mkCoerceC" (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co SDoc -> SDoc -> SDoc
$$ Pair Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Coercion -> Pair Type
coercionKind Coercion
co)) Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$
       Type -> Type -> Type -> CoreExpr
mkCoerceC Type
cat (Type
t1 Type -> [Type] -> Type
`mkAppTys` [Type]
ts) (Type
t2 Type -> [Type] -> Type
`mkAppTys` [Type]
ts)
     where Pair Type
t1 Type
t2 = (if Bool
pol then Pair Type -> Pair Type
forall a. a -> a
id else Pair Type -> Pair Type
forall a. Pair a -> Pair a
swap) (Pair Type -> Pair Type) -> Pair Type -> Pair Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
co

pattern Coerce :: Cat -> Type -> Type -> CoreExpr
pattern $mCoerce :: forall {r}.
CoreExpr -> (Type -> Type -> Type -> r) -> ((# #) -> r) -> r
Coerce k a b <-
  -- (collectArgs -> (Var (isCoerceV -> True), [Type k,Type a,Type b,_dict]))
  (collectArgs -> (Var (catSuffix -> Just "coerceC"), [Type k,Type a,Type b,_dict]))
  -- (collectArgs -> (Var (CatVar "coerceC"), [Type k,Type a,Type b,_dict]))

pattern Compose :: Cat -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
pattern $mCompose :: forall {r}.
CoreExpr
-> (Type -> Type -> Type -> Type -> CoreExpr -> CoreExpr -> r)
-> ((# #) -> r)
-> r
Compose k a b c g f <-
  -- (collectArgs -> (Var (isComposeV -> True), [Type k,Type b,Type c, Type a,_catDict,_ok,g,f]))
  (collectArgs -> (Var (catSuffix -> Just "."), [Type k,Type b,Type c, Type a,_catDict,_ok,g,f]))
  -- (collectArgs -> (Var (CatVar "."), [Type k,Type b,Type c, Type a,_catDict,_ok,g,f]))

-- TODO: when the nested-pattern definition bug
-- (https://ghc.haskell.org/trac/ghc/ticket/12007) gets fixed (GHC 8.0.2), use
-- the CatVar version of Compose and Coerce.

-- For the composition BuiltinRule
composeR :: CccEnv -> Ops -> ReExpr2
-- composeR _ _ g f | pprTrace "composeR try" (ppr (g,f)) False = undefined
composeR :: CccEnv -> Ops -> ReExpr2
composeR (CccEnv {Bool
CoreBndr
TyCon
RuleBase
UniqSupply
UniqDFM TyCon CoreBndr
HscEnv
forall a. [Char] -> SDoc -> a -> a
dtrace :: CccEnv -> forall a. [Char] -> SDoc -> a -> a
cccV :: CccEnv -> CoreBndr
cccPV :: CccEnv -> CoreBndr
uncccV :: CccEnv -> CoreBndr
closedTc :: CccEnv -> TyCon
idV :: CccEnv -> CoreBndr
constV :: CccEnv -> CoreBndr
forkV :: CccEnv -> CoreBndr
applyV :: CccEnv -> CoreBndr
composeV :: CccEnv -> CoreBndr
curryV :: CccEnv -> CoreBndr
uncurryV :: CccEnv -> CoreBndr
ifV :: CccEnv -> CoreBndr
exlV :: CccEnv -> CoreBndr
exrV :: CccEnv -> CoreBndr
constFunV :: CccEnv -> CoreBndr
fmapV :: CccEnv -> CoreBndr
fmapT1V :: CccEnv -> CoreBndr
fmapT2V :: CccEnv -> CoreBndr
casePairTopTV :: CccEnv -> CoreBndr
casePairTV :: CccEnv -> CoreBndr
casePairLTV :: CccEnv -> CoreBndr
casePairRTV :: CccEnv -> CoreBndr
flipForkTV :: CccEnv -> CoreBndr
castConstTV :: CccEnv -> CoreBndr
reprCV :: CccEnv -> CoreBndr
abstCV :: CccEnv -> CoreBndr
coerceV :: CccEnv -> CoreBndr
bottomTV :: CccEnv -> CoreBndr
repTc :: CccEnv -> TyCon
prePostV :: CccEnv -> CoreBndr
boxers :: CccEnv -> UniqDFM TyCon CoreBndr
tagToEnumV :: CccEnv -> CoreBndr
bottomV :: CccEnv -> CoreBndr
boxIBV :: CccEnv -> CoreBndr
ifEqIntHash :: CccEnv -> CoreBndr
inlineV :: CccEnv -> CoreBndr
uniqSupply :: CccEnv -> UniqSupply
hsc_env :: CccEnv -> HscEnv
ruleBase :: CccEnv -> RuleBase
okTypeTc :: CccEnv -> TyCon
enablePolymorphism :: CccEnv -> Bool
dtrace :: forall a. [Char] -> SDoc -> a -> a
cccV :: CoreBndr
cccPV :: CoreBndr
uncccV :: CoreBndr
closedTc :: TyCon
idV :: CoreBndr
constV :: CoreBndr
forkV :: CoreBndr
applyV :: CoreBndr
composeV :: CoreBndr
curryV :: CoreBndr
uncurryV :: CoreBndr
ifV :: CoreBndr
exlV :: CoreBndr
exrV :: CoreBndr
constFunV :: CoreBndr
fmapV :: CoreBndr
fmapT1V :: CoreBndr
fmapT2V :: CoreBndr
casePairTopTV :: CoreBndr
casePairTV :: CoreBndr
casePairLTV :: CoreBndr
casePairRTV :: CoreBndr
flipForkTV :: CoreBndr
castConstTV :: CoreBndr
reprCV :: CoreBndr
abstCV :: CoreBndr
coerceV :: CoreBndr
bottomTV :: CoreBndr
repTc :: TyCon
prePostV :: CoreBndr
boxers :: UniqDFM TyCon CoreBndr
tagToEnumV :: CoreBndr
bottomV :: CoreBndr
boxIBV :: CoreBndr
ifEqIntHash :: CoreBndr
inlineV :: CoreBndr
uniqSupply :: UniqSupply
hsc_env :: HscEnv
ruleBase :: RuleBase
okTypeTc :: TyCon
enablePolymorphism :: Bool
..}) (Ops {[CoreBndr] -> [(CoreBndr, CoreExpr)] -> Unop CoreExpr
CoreBndr -> Maybe CoreExpr
Rewrite Coercion
Coercion -> Coercion
Type -> Bool
Type -> Maybe (Type, Type)
Type -> Either SDoc CoreExpr
Type -> (Type, Type)
Type -> Type
Type -> CoreBndr -> [Type] -> Maybe CoreExpr
Type -> CoreBndr -> [Type] -> CoreExpr
Type -> CoreBndr -> Unop CoreExpr
Type -> Type -> Maybe (Type, Type)
Type -> Type -> Maybe CoreExpr
Type -> Type -> CoreExpr
Type -> Type -> Type -> Maybe CoreExpr
Type -> Type -> Type -> CoreExpr
Type -> Type -> ReExpr
Type -> Type -> Ternop CoreExpr
Type -> ReExpr
Type -> Unop CoreExpr
Type -> ReExpr2
Type -> Binop CoreExpr
Role -> Type -> (Coercion, Type)
CoreExpr -> Bool
ReExpr
CoreExpr -> Either SDoc CoreExpr
Unop CoreExpr
Unop ReExpr
forall a. SDoc -> Either SDoc a -> a
forall a b. (Outputable a, Outputable b) => [Char] -> a -> b -> b
forall (f :: * -> *) a b.
(Functor f, Outputable a, Outputable b) =>
[Char] -> Unop (a -> f b)
inlineE :: Ops -> Unop CoreExpr
boxCon :: Ops -> ReExpr
catTy :: Ops -> Type -> Type
reCatCo :: Ops -> Rewrite Coercion
repTy :: Ops -> Type -> Type
unfoldMaybe' :: Ops -> ReExpr
unfoldMaybe :: Ops -> ReExpr
inlineMaybe :: Ops -> CoreBndr -> Maybe CoreExpr
noDictErr :: Ops -> forall a. SDoc -> Either SDoc a -> a
onDictTry :: Ops -> CoreExpr -> Either SDoc CoreExpr
onDictMaybe :: Ops -> ReExpr
onDict :: Ops -> Unop CoreExpr
onDicts :: Ops -> Unop CoreExpr
buildDictMaybe :: Ops -> Type -> Either SDoc CoreExpr
catOp :: Ops -> Type -> CoreBndr -> [Type] -> CoreExpr
catOpMaybe :: Ops -> Type -> CoreBndr -> [Type] -> Maybe CoreExpr
mkCcc :: Ops -> Unop CoreExpr
mkId :: Ops -> Type -> Type -> CoreExpr
mkCompose :: Ops -> Type -> Binop CoreExpr
mkCompose' :: Ops -> Type -> ReExpr2
mkEx :: Ops -> Type -> CoreBndr -> Unop CoreExpr
mkFork :: Ops -> Type -> Binop CoreExpr
mkFork' :: Ops -> Type -> ReExpr2
mkApplyMaybe :: Ops -> Type -> Type -> Type -> Maybe CoreExpr
isClosed :: Ops -> Type -> Bool
mkCurry :: Ops -> Type -> Unop CoreExpr
mkCurry' :: Ops -> Type -> ReExpr
mkUncurryMaybe :: Ops -> Type -> ReExpr
mkIfC :: Ops -> Type -> Type -> Ternop CoreExpr
mkBottomC :: Ops -> Type -> Type -> Type -> Maybe CoreExpr
mkConst :: Ops -> Type -> Type -> ReExpr
mkConst' :: Ops -> Type -> Type -> ReExpr
mkConstFun :: Ops -> Type -> Type -> ReExpr
mkAbstC :: Ops -> Type -> Type -> CoreExpr
mkReprC :: Ops -> Type -> Type -> CoreExpr
mkReprC' :: Ops -> Type -> Type -> CoreExpr
mkAbstC' :: Ops -> Type -> Type -> CoreExpr
mkReprC'_maybe :: Ops -> Type -> Type -> Maybe CoreExpr
mkAbstC'_maybe :: Ops -> Type -> Type -> Maybe CoreExpr
mkCoerceC :: Ops -> Type -> Type -> Type -> CoreExpr
mkCoerceC_maybe :: Ops -> Type -> Type -> Type -> Maybe CoreExpr
traceRewrite :: Ops
-> forall (f :: * -> *) a b.
   (Functor f, Outputable a, Outputable b) =>
   [Char] -> Unop (a -> f b)
tyArgs2_maybe :: Ops -> Type -> Maybe (Type, Type)
tyArgs2 :: Ops -> Type -> (Type, Type)
pprTrans :: Ops
-> forall a b.
   (Outputable a, Outputable b) =>
   [Char] -> a -> b -> b
lintReExpr :: Ops -> Unop ReExpr
transCatOp :: Ops -> ReExpr
reCat :: Ops -> ReExpr
isPseudoApp :: Ops -> CoreExpr -> Bool
normType :: Ops -> Role -> Type -> (Coercion, Type)
okType :: Ops -> Type -> Bool
optimizeCoercion :: Ops -> Coercion -> Coercion
subst :: Ops -> [CoreBndr] -> [(CoreBndr, CoreExpr)] -> Unop CoreExpr
eqTypeNormalising :: Ops -> Type -> Type -> Maybe (Type, Type)
inlineE :: Unop CoreExpr
boxCon :: ReExpr
catTy :: Type -> Type
reCatCo :: Rewrite Coercion
repTy :: Type -> Type
unfoldMaybe' :: ReExpr
unfoldMaybe :: ReExpr
inlineMaybe :: CoreBndr -> Maybe CoreExpr
noDictErr :: forall a. SDoc -> Either SDoc a -> a
onDictTry :: CoreExpr -> Either SDoc CoreExpr
onDictMaybe :: ReExpr
onDict :: Unop CoreExpr
onDicts :: Unop CoreExpr
buildDictMaybe :: Type -> Either SDoc CoreExpr
catOp :: Type -> CoreBndr -> [Type] -> CoreExpr
catOpMaybe :: Type -> CoreBndr -> [Type] -> Maybe CoreExpr
mkCcc :: Unop CoreExpr
mkId :: Type -> Type -> CoreExpr
mkCompose :: Type -> Binop CoreExpr
mkCompose' :: Type -> ReExpr2
mkEx :: Type -> CoreBndr -> Unop CoreExpr
mkFork :: Type -> Binop CoreExpr
mkFork' :: Type -> ReExpr2
mkApplyMaybe :: Type -> Type -> Type -> Maybe CoreExpr
isClosed :: Type -> Bool
mkCurry :: Type -> Unop CoreExpr
mkCurry' :: Type -> ReExpr
mkUncurryMaybe :: Type -> ReExpr
mkIfC :: Type -> Type -> Ternop CoreExpr
mkBottomC :: Type -> Type -> Type -> Maybe CoreExpr
mkConst :: Type -> Type -> ReExpr
mkConst' :: Type -> Type -> ReExpr
mkConstFun :: Type -> Type -> ReExpr
mkAbstC :: Type -> Type -> CoreExpr
mkReprC :: Type -> Type -> CoreExpr
mkReprC' :: Type -> Type -> CoreExpr
mkAbstC' :: Type -> Type -> CoreExpr
mkReprC'_maybe :: Type -> Type -> Maybe CoreExpr
mkAbstC'_maybe :: Type -> Type -> Maybe CoreExpr
mkCoerceC :: Type -> Type -> Type -> CoreExpr
mkCoerceC_maybe :: Type -> Type -> Type -> Maybe CoreExpr
traceRewrite :: forall (f :: * -> *) a b.
(Functor f, Outputable a, Outputable b) =>
[Char] -> Unop (a -> f b)
tyArgs2_maybe :: Type -> Maybe (Type, Type)
tyArgs2 :: Type -> (Type, Type)
pprTrans :: forall a b. (Outputable a, Outputable b) => [Char] -> a -> b -> b
lintReExpr :: Unop ReExpr
transCatOp :: ReExpr
reCat :: ReExpr
isPseudoApp :: CoreExpr -> Bool
normType :: Role -> Type -> (Coercion, Type)
okType :: Type -> Bool
optimizeCoercion :: Coercion -> Coercion
subst :: [CoreBndr] -> [(CoreBndr, CoreExpr)] -> Unop CoreExpr
eqTypeNormalising :: Type -> Type -> Maybe (Type, Type)
..}) _g :: CoreExpr
_g@(Coerce Type
k Type
_b Type
c) _f :: CoreExpr
_f@(Coerce Type
_k Type
a Type
_b')
  = -- pprTrace "composeR coerce" (ppr _g $$ ppr _f) $
    ReExpr
forall a. a -> Maybe a
Just (Type -> Type -> Type -> CoreExpr
mkCoerceC Type
k Type
a Type
c)

-- composeR (CccEnv {..}) (Ops {..}) h (Compose _k _ _a _b' g f)
--   \| pprTrace "composeR try re-assoc" (ppr h $$ ppr g $$ ppr f) False = undefined

composeR (CccEnv {Bool
CoreBndr
TyCon
RuleBase
UniqSupply
UniqDFM TyCon CoreBndr
HscEnv
forall a. [Char] -> SDoc -> a -> a
dtrace :: CccEnv -> forall a. [Char] -> SDoc -> a -> a
cccV :: CccEnv -> CoreBndr
cccPV :: CccEnv -> CoreBndr
uncccV :: CccEnv -> CoreBndr
closedTc :: CccEnv -> TyCon
idV :: CccEnv -> CoreBndr
constV :: CccEnv -> CoreBndr
forkV :: CccEnv -> CoreBndr
applyV :: CccEnv -> CoreBndr
composeV :: CccEnv -> CoreBndr
curryV :: CccEnv -> CoreBndr
uncurryV :: CccEnv -> CoreBndr
ifV :: CccEnv -> CoreBndr
exlV :: CccEnv -> CoreBndr
exrV :: CccEnv -> CoreBndr
constFunV :: CccEnv -> CoreBndr
fmapV :: CccEnv -> CoreBndr
fmapT1V :: CccEnv -> CoreBndr
fmapT2V :: CccEnv -> CoreBndr
casePairTopTV :: CccEnv -> CoreBndr
casePairTV :: CccEnv -> CoreBndr
casePairLTV :: CccEnv -> CoreBndr
casePairRTV :: CccEnv -> CoreBndr
flipForkTV :: CccEnv -> CoreBndr
castConstTV :: CccEnv -> CoreBndr
reprCV :: CccEnv -> CoreBndr
abstCV :: CccEnv -> CoreBndr
coerceV :: CccEnv -> CoreBndr
bottomTV :: CccEnv -> CoreBndr
repTc :: CccEnv -> TyCon
prePostV :: CccEnv -> CoreBndr
boxers :: CccEnv -> UniqDFM TyCon CoreBndr
tagToEnumV :: CccEnv -> CoreBndr
bottomV :: CccEnv -> CoreBndr
boxIBV :: CccEnv -> CoreBndr
ifEqIntHash :: CccEnv -> CoreBndr
inlineV :: CccEnv -> CoreBndr
uniqSupply :: CccEnv -> UniqSupply
hsc_env :: CccEnv -> HscEnv
ruleBase :: CccEnv -> RuleBase
okTypeTc :: CccEnv -> TyCon
enablePolymorphism :: CccEnv -> Bool
dtrace :: forall a. [Char] -> SDoc -> a -> a
cccV :: CoreBndr
cccPV :: CoreBndr
uncccV :: CoreBndr
closedTc :: TyCon
idV :: CoreBndr
constV :: CoreBndr
forkV :: CoreBndr
applyV :: CoreBndr
composeV :: CoreBndr
curryV :: CoreBndr
uncurryV :: CoreBndr
ifV :: CoreBndr
exlV :: CoreBndr
exrV :: CoreBndr
constFunV :: CoreBndr
fmapV :: CoreBndr
fmapT1V :: CoreBndr
fmapT2V :: CoreBndr
casePairTopTV :: CoreBndr
casePairTV :: CoreBndr
casePairLTV :: CoreBndr
casePairRTV :: CoreBndr
flipForkTV :: CoreBndr
castConstTV :: CoreBndr
reprCV :: CoreBndr
abstCV :: CoreBndr
coerceV :: CoreBndr
bottomTV :: CoreBndr
repTc :: TyCon
prePostV :: CoreBndr
boxers :: UniqDFM TyCon CoreBndr
tagToEnumV :: CoreBndr
bottomV :: CoreBndr
boxIBV :: CoreBndr
ifEqIntHash :: CoreBndr
inlineV :: CoreBndr
uniqSupply :: UniqSupply
hsc_env :: HscEnv
ruleBase :: RuleBase
okTypeTc :: TyCon
enablePolymorphism :: Bool
..}) (Ops {[CoreBndr] -> [(CoreBndr, CoreExpr)] -> Unop CoreExpr
CoreBndr -> Maybe CoreExpr
Rewrite Coercion
Coercion -> Coercion
Type -> Bool
Type -> Maybe (Type, Type)
Type -> Either SDoc CoreExpr
Type -> (Type, Type)
Type -> Type
Type -> CoreBndr -> [Type] -> Maybe CoreExpr
Type -> CoreBndr -> [Type] -> CoreExpr
Type -> CoreBndr -> Unop CoreExpr
Type -> Type -> Maybe (Type, Type)
Type -> Type -> Maybe CoreExpr
Type -> Type -> CoreExpr
Type -> Type -> Type -> Maybe CoreExpr
Type -> Type -> Type -> CoreExpr
Type -> Type -> ReExpr
Type -> Type -> Ternop CoreExpr
Type -> ReExpr
Type -> Unop CoreExpr
Type -> ReExpr2
Type -> Binop CoreExpr
Role -> Type -> (Coercion, Type)
CoreExpr -> Bool
ReExpr
CoreExpr -> Either SDoc CoreExpr
Unop CoreExpr
Unop ReExpr
forall a. SDoc -> Either SDoc a -> a
forall a b. (Outputable a, Outputable b) => [Char] -> a -> b -> b
forall (f :: * -> *) a b.
(Functor f, Outputable a, Outputable b) =>
[Char] -> Unop (a -> f b)
inlineE :: Ops -> Unop CoreExpr
boxCon :: Ops -> ReExpr
catTy :: Ops -> Type -> Type
reCatCo :: Ops -> Rewrite Coercion
repTy :: Ops -> Type -> Type
unfoldMaybe' :: Ops -> ReExpr
unfoldMaybe :: Ops -> ReExpr
inlineMaybe :: Ops -> CoreBndr -> Maybe CoreExpr
noDictErr :: Ops -> forall a. SDoc -> Either SDoc a -> a
onDictTry :: Ops -> CoreExpr -> Either SDoc CoreExpr
onDictMaybe :: Ops -> ReExpr
onDict :: Ops -> Unop CoreExpr
onDicts :: Ops -> Unop CoreExpr
buildDictMaybe :: Ops -> Type -> Either SDoc CoreExpr
catOp :: Ops -> Type -> CoreBndr -> [Type] -> CoreExpr
catOpMaybe :: Ops -> Type -> CoreBndr -> [Type] -> Maybe CoreExpr
mkCcc :: Ops -> Unop CoreExpr
mkId :: Ops -> Type -> Type -> CoreExpr
mkCompose :: Ops -> Type -> Binop CoreExpr
mkCompose' :: Ops -> Type -> ReExpr2
mkEx :: Ops -> Type -> CoreBndr -> Unop CoreExpr
mkFork :: Ops -> Type -> Binop CoreExpr
mkFork' :: Ops -> Type -> ReExpr2
mkApplyMaybe :: Ops -> Type -> Type -> Type -> Maybe CoreExpr
isClosed :: Ops -> Type -> Bool
mkCurry :: Ops -> Type -> Unop CoreExpr
mkCurry' :: Ops -> Type -> ReExpr
mkUncurryMaybe :: Ops -> Type -> ReExpr
mkIfC :: Ops -> Type -> Type -> Ternop CoreExpr
mkBottomC :: Ops -> Type -> Type -> Type -> Maybe CoreExpr
mkConst :: Ops -> Type -> Type -> ReExpr
mkConst' :: Ops -> Type -> Type -> ReExpr
mkConstFun :: Ops -> Type -> Type -> ReExpr
mkAbstC :: Ops -> Type -> Type -> CoreExpr
mkReprC :: Ops -> Type -> Type -> CoreExpr
mkReprC' :: Ops -> Type -> Type -> CoreExpr
mkAbstC' :: Ops -> Type -> Type -> CoreExpr
mkReprC'_maybe :: Ops -> Type -> Type -> Maybe CoreExpr
mkAbstC'_maybe :: Ops -> Type -> Type -> Maybe CoreExpr
mkCoerceC :: Ops -> Type -> Type -> Type -> CoreExpr
mkCoerceC_maybe :: Ops -> Type -> Type -> Type -> Maybe CoreExpr
traceRewrite :: Ops
-> forall (f :: * -> *) a b.
   (Functor f, Outputable a, Outputable b) =>
   [Char] -> Unop (a -> f b)
tyArgs2_maybe :: Ops -> Type -> Maybe (Type, Type)
tyArgs2 :: Ops -> Type -> (Type, Type)
pprTrans :: Ops
-> forall a b.
   (Outputable a, Outputable b) =>
   [Char] -> a -> b -> b
lintReExpr :: Ops -> Unop ReExpr
transCatOp :: Ops -> ReExpr
reCat :: Ops -> ReExpr
isPseudoApp :: Ops -> CoreExpr -> Bool
normType :: Ops -> Role -> Type -> (Coercion, Type)
okType :: Ops -> Type -> Bool
optimizeCoercion :: Ops -> Coercion -> Coercion
subst :: Ops -> [CoreBndr] -> [(CoreBndr, CoreExpr)] -> Unop CoreExpr
eqTypeNormalising :: Ops -> Type -> Type -> Maybe (Type, Type)
inlineE :: Unop CoreExpr
boxCon :: ReExpr
catTy :: Type -> Type
reCatCo :: Rewrite Coercion
repTy :: Type -> Type
unfoldMaybe' :: ReExpr
unfoldMaybe :: ReExpr
inlineMaybe :: CoreBndr -> Maybe CoreExpr
noDictErr :: forall a. SDoc -> Either SDoc a -> a
onDictTry :: CoreExpr -> Either SDoc CoreExpr
onDictMaybe :: ReExpr
onDict :: Unop CoreExpr
onDicts :: Unop CoreExpr
buildDictMaybe :: Type -> Either SDoc CoreExpr
catOp :: Type -> CoreBndr -> [Type] -> CoreExpr
catOpMaybe :: Type -> CoreBndr -> [Type] -> Maybe CoreExpr
mkCcc :: Unop CoreExpr
mkId :: Type -> Type -> CoreExpr
mkCompose :: Type -> Binop CoreExpr
mkCompose' :: Type -> ReExpr2
mkEx :: Type -> CoreBndr -> Unop CoreExpr
mkFork :: Type -> Binop CoreExpr
mkFork' :: Type -> ReExpr2
mkApplyMaybe :: Type -> Type -> Type -> Maybe CoreExpr
isClosed :: Type -> Bool
mkCurry :: Type -> Unop CoreExpr
mkCurry' :: Type -> ReExpr
mkUncurryMaybe :: Type -> ReExpr
mkIfC :: Type -> Type -> Ternop CoreExpr
mkBottomC :: Type -> Type -> Type -> Maybe CoreExpr
mkConst :: Type -> Type -> ReExpr
mkConst' :: Type -> Type -> ReExpr
mkConstFun :: Type -> Type -> ReExpr
mkAbstC :: Type -> Type -> CoreExpr
mkReprC :: Type -> Type -> CoreExpr
mkReprC' :: Type -> Type -> CoreExpr
mkAbstC' :: Type -> Type -> CoreExpr
mkReprC'_maybe :: Type -> Type -> Maybe CoreExpr
mkAbstC'_maybe :: Type -> Type -> Maybe CoreExpr
mkCoerceC :: Type -> Type -> Type -> CoreExpr
mkCoerceC_maybe :: Type -> Type -> Type -> Maybe CoreExpr
traceRewrite :: forall (f :: * -> *) a b.
(Functor f, Outputable a, Outputable b) =>
[Char] -> Unop (a -> f b)
tyArgs2_maybe :: Type -> Maybe (Type, Type)
tyArgs2 :: Type -> (Type, Type)
pprTrans :: forall a b. (Outputable a, Outputable b) => [Char] -> a -> b -> b
lintReExpr :: Unop ReExpr
transCatOp :: ReExpr
reCat :: ReExpr
isPseudoApp :: CoreExpr -> Bool
normType :: Role -> Type -> (Coercion, Type)
okType :: Type -> Bool
optimizeCoercion :: Coercion -> Coercion
subst :: [CoreBndr] -> [(CoreBndr, CoreExpr)] -> Unop CoreExpr
eqTypeNormalising :: Type -> Type -> Maybe (Type, Type)
..}) _h :: CoreExpr
_h@(Coerce Type
k Type
_b Type
c) (Compose Type
_k Type
_ Type
a Type
_b' _g :: CoreExpr
_g@(Coerce Type
_k' Type
_z Type
_a') CoreExpr
f)
  = -- pprTrace "composeR coerce re-assoc" (ppr _h $$ ppr _g $$ ppr f) $
    ReExpr
forall a. a -> Maybe a
Just (Type -> Binop CoreExpr
mkCompose Type
k (Type -> Type -> Type -> CoreExpr
mkCoerceC Type
k Type
a Type
c) CoreExpr
f)
composeR CccEnv
_ Ops
_ CoreExpr
_ CoreExpr
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

pattern CatVar :: String -> Id
pattern $mCatVar :: forall {r}. CoreBndr -> ([Char] -> r) -> ((# #) -> r) -> r
CatVar str <- (fqVarName -> stripPrefix (catModule ++ ".") -> Just str)

catSuffix :: Id -> Maybe String
catSuffix :: CoreBndr -> Maybe [Char]
catSuffix (CatVar [Char]
suff) = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
suff
catSuffix CoreBndr
_             = Maybe [Char]
forall a. Maybe a
Nothing

isCoerceV :: Id -> Bool
isCoerceV :: CoreBndr -> Bool
isCoerceV (CatVar [Char]
"coerceC") = Bool
True
isCoerceV CoreBndr
_ = Bool
False
-- isCoerceV v = fqVarName v == catModule ++ "." ++ "coerceC"

isComposeV :: Id -> Bool
isComposeV :: CoreBndr -> Bool
isComposeV (CatVar [Char]
".") = Bool
True
isComposeV CoreBndr
_ = Bool
False
-- isComposeV v = fqVarName v == catModule ++ "." ++ "."

data Ops = Ops
 { Ops -> Unop CoreExpr
inlineE        :: Unop CoreExpr
 , Ops -> ReExpr
boxCon         :: ReExpr
 , Ops -> Type -> Type
catTy          :: Unop Type
 , Ops -> Rewrite Coercion
reCatCo        :: Rewrite Coercion
 , Ops -> Type -> Type
repTy          :: Unop Type
 -- , unfoldOkay     :: CoreExpr -> Bool
 , Ops -> ReExpr
unfoldMaybe'   :: ReExpr
 , Ops -> ReExpr
unfoldMaybe    :: ReExpr
 , Ops -> CoreBndr -> Maybe CoreExpr
inlineMaybe    :: Id -> Maybe CoreExpr
 , Ops -> forall a. SDoc -> Either SDoc a -> a
noDictErr      :: forall a. SDoc -> Either SDoc a -> a
 , Ops -> CoreExpr -> Either SDoc CoreExpr
onDictTry      :: CoreExpr -> Either SDoc CoreExpr
 , Ops -> ReExpr
onDictMaybe    :: ReExpr
 , Ops -> Unop CoreExpr
onDict         :: Unop CoreExpr
 , Ops -> Unop CoreExpr
onDicts        :: Unop CoreExpr
 , Ops -> Type -> Either SDoc CoreExpr
buildDictMaybe :: Type -> Either SDoc CoreExpr
 , Ops -> Type -> CoreBndr -> [Type] -> CoreExpr
catOp          :: Cat -> Var -> [Type] -> CoreExpr
 , Ops -> Type -> CoreBndr -> [Type] -> Maybe CoreExpr
catOpMaybe     :: Cat -> Var -> [Type] -> Maybe CoreExpr
 , Ops -> Unop CoreExpr
mkCcc          :: Unop CoreExpr  -- Any reason to parametrize over Cat?
 , Ops -> Type -> Type -> CoreExpr
mkId           :: Cat -> Type -> CoreExpr
 , Ops -> Type -> Binop CoreExpr
mkCompose      :: Cat -> Binop CoreExpr
 , Ops -> Type -> ReExpr2
mkCompose'     :: Cat -> ReExpr2  -- experiment
 , Ops -> Type -> CoreBndr -> Unop CoreExpr
mkEx           :: Cat -> Var -> Unop CoreExpr
 , Ops -> Type -> Binop CoreExpr
mkFork         :: Cat -> Binop CoreExpr
 , Ops -> Type -> ReExpr2
mkFork'        :: Cat -> ReExpr2 -- experiment
 , Ops -> Type -> Type -> Type -> Maybe CoreExpr
mkApplyMaybe   :: Cat -> Type -> Type -> Maybe CoreExpr
 , Ops -> Type -> Bool
isClosed       :: Cat -> Bool
 , Ops -> Type -> Unop CoreExpr
mkCurry        :: Cat -> Unop CoreExpr
 , Ops -> Type -> ReExpr
mkCurry'       :: Cat -> ReExpr
 , Ops -> Type -> ReExpr
mkUncurryMaybe :: Cat -> ReExpr
 , Ops -> Type -> Type -> Ternop CoreExpr
mkIfC          :: Cat -> Type -> Ternop CoreExpr
 , Ops -> Type -> Type -> Type -> Maybe CoreExpr
mkBottomC      :: Cat -> Type -> Type -> Maybe CoreExpr
 , Ops -> Type -> Type -> ReExpr
mkConst        :: Cat -> Type -> ReExpr
 , Ops -> Type -> Type -> ReExpr
mkConst'       :: Cat -> Type -> ReExpr
 , Ops -> Type -> Type -> ReExpr
mkConstFun     :: Cat -> Type -> ReExpr
 , Ops -> Type -> Type -> CoreExpr
mkAbstC        :: Cat -> Type -> CoreExpr
 , Ops -> Type -> Type -> CoreExpr
mkReprC        :: Cat -> Type -> CoreExpr
 , Ops -> Type -> Type -> CoreExpr
mkReprC'       :: Cat -> Type -> CoreExpr
 , Ops -> Type -> Type -> CoreExpr
mkAbstC'       :: Cat -> Type -> CoreExpr
 , Ops -> Type -> Type -> Maybe CoreExpr
mkReprC'_maybe :: Cat -> Type -> Maybe CoreExpr
 , Ops -> Type -> Type -> Maybe CoreExpr
mkAbstC'_maybe :: Cat -> Type -> Maybe CoreExpr
 , Ops -> Type -> Type -> Type -> CoreExpr
mkCoerceC      :: Cat -> Type -> Type -> CoreExpr
 , Ops -> Type -> Type -> Type -> Maybe CoreExpr
mkCoerceC_maybe :: Cat -> Type -> Type -> Maybe CoreExpr
 , Ops
-> forall (f :: * -> *) a b.
   (Functor f, Outputable a, Outputable b) =>
   [Char] -> Unop (a -> f b)
traceRewrite   :: forall f a b. (Functor f, Outputable a, Outputable b) => String -> Unop (a -> f b)
 , Ops -> Type -> Maybe (Type, Type)
tyArgs2_maybe  :: Type -> Maybe (Type,Type)
 , Ops -> Type -> (Type, Type)
tyArgs2        :: Type -> (Type,Type)
 , Ops
-> forall a b.
   (Outputable a, Outputable b) =>
   [Char] -> a -> b -> b
pprTrans       :: forall a b. (Outputable a, Outputable b) => String -> a -> b -> b
 , Ops -> Unop ReExpr
lintReExpr     :: Unop ReExpr
 -- , catFun         :: ReExpr
 , Ops -> ReExpr
transCatOp     :: ReExpr
 , Ops -> ReExpr
reCat          :: ReExpr
 , Ops -> CoreExpr -> Bool
isPseudoApp    :: CoreExpr -> Bool
 , Ops -> Role -> Type -> (Coercion, Type)
normType       :: Role -> Type -> (Coercion, Type)
 , Ops -> Type -> Bool
okType         :: Type -> Bool
 , Ops -> Coercion -> Coercion
optimizeCoercion :: Coercion -> Coercion
 , Ops -> [CoreBndr] -> [(CoreBndr, CoreExpr)] -> Unop CoreExpr
subst          :: [Var] -> [(Id,CoreExpr)] -> Unop CoreExpr
 , Ops -> Type -> Type -> Maybe (Type, Type)
eqTypeNormalising :: Type -> Type -> Maybe (Type, Type)
 }

mkOps :: CccEnv -> ModGuts -> AnnEnv -> FamInstEnvs
      -> DynFlags -> InScopeEnv -> Type -> CoreExpr -> Type -> Ops
mkOps :: CccEnv
-> ModGuts
-> AnnEnv
-> FamInstEnvs
-> DynFlags
-> InScopeEnv
-> Type
-> CoreExpr
-> Type
-> Ops
mkOps (CccEnv {Bool
CoreBndr
TyCon
RuleBase
UniqSupply
UniqDFM TyCon CoreBndr
HscEnv
forall a. [Char] -> SDoc -> a -> a
dtrace :: CccEnv -> forall a. [Char] -> SDoc -> a -> a
cccV :: CccEnv -> CoreBndr
cccPV :: CccEnv -> CoreBndr
uncccV :: CccEnv -> CoreBndr
closedTc :: CccEnv -> TyCon
idV :: CccEnv -> CoreBndr
constV :: CccEnv -> CoreBndr
forkV :: CccEnv -> CoreBndr
applyV :: CccEnv -> CoreBndr
composeV :: CccEnv -> CoreBndr
curryV :: CccEnv -> CoreBndr
uncurryV :: CccEnv -> CoreBndr
ifV :: CccEnv -> CoreBndr
exlV :: CccEnv -> CoreBndr
exrV :: CccEnv -> CoreBndr
constFunV :: CccEnv -> CoreBndr
fmapV :: CccEnv -> CoreBndr
fmapT1V :: CccEnv -> CoreBndr
fmapT2V :: CccEnv -> CoreBndr
casePairTopTV :: CccEnv -> CoreBndr
casePairTV :: CccEnv -> CoreBndr
casePairLTV :: CccEnv -> CoreBndr
casePairRTV :: CccEnv -> CoreBndr
flipForkTV :: CccEnv -> CoreBndr
castConstTV :: CccEnv -> CoreBndr
reprCV :: CccEnv -> CoreBndr
abstCV :: CccEnv -> CoreBndr
coerceV :: CccEnv -> CoreBndr
bottomTV :: CccEnv -> CoreBndr
repTc :: CccEnv -> TyCon
prePostV :: CccEnv -> CoreBndr
boxers :: CccEnv -> UniqDFM TyCon CoreBndr
tagToEnumV :: CccEnv -> CoreBndr
bottomV :: CccEnv -> CoreBndr
boxIBV :: CccEnv -> CoreBndr
ifEqIntHash :: CccEnv -> CoreBndr
inlineV :: CccEnv -> CoreBndr
uniqSupply :: CccEnv -> UniqSupply
hsc_env :: CccEnv -> HscEnv
ruleBase :: CccEnv -> RuleBase
okTypeTc :: CccEnv -> TyCon
enablePolymorphism :: CccEnv -> Bool
dtrace :: forall a. [Char] -> SDoc -> a -> a
cccV :: CoreBndr
cccPV :: CoreBndr
uncccV :: CoreBndr
closedTc :: TyCon
idV :: CoreBndr
constV :: CoreBndr
forkV :: CoreBndr
applyV :: CoreBndr
composeV :: CoreBndr
curryV :: CoreBndr
uncurryV :: CoreBndr
ifV :: CoreBndr
exlV :: CoreBndr
exrV :: CoreBndr
constFunV :: CoreBndr
fmapV :: CoreBndr
fmapT1V :: CoreBndr
fmapT2V :: CoreBndr
casePairTopTV :: CoreBndr
casePairTV :: CoreBndr
casePairLTV :: CoreBndr
casePairRTV :: CoreBndr
flipForkTV :: CoreBndr
castConstTV :: CoreBndr
reprCV :: CoreBndr
abstCV :: CoreBndr
coerceV :: CoreBndr
bottomTV :: CoreBndr
repTc :: TyCon
prePostV :: CoreBndr
boxers :: UniqDFM TyCon CoreBndr
tagToEnumV :: CoreBndr
bottomV :: CoreBndr
boxIBV :: CoreBndr
ifEqIntHash :: CoreBndr
inlineV :: CoreBndr
uniqSupply :: UniqSupply
hsc_env :: HscEnv
ruleBase :: RuleBase
okTypeTc :: TyCon
enablePolymorphism :: Bool
..}) ModGuts
guts AnnEnv
annotations FamInstEnvs
famEnvs DynFlags
dflags InScopeEnv
inScope Type
evTy CoreExpr
ev Type
cat = Ops {[Char] -> a -> b -> b
[Char] -> (a -> f b) -> a -> f b
[CoreBndr] -> [(CoreBndr, CoreExpr)] -> Unop CoreExpr
SDoc -> Either SDoc a -> a
CoreBndr -> Maybe CoreExpr
Rewrite Coercion
Coercion -> Coercion
Type -> Bool
Type -> Maybe (Type, Type)
Type -> Either SDoc CoreExpr
Type -> (Type, Type)
Type -> Type
Type -> CoreBndr -> [Type] -> Maybe CoreExpr
Type -> CoreBndr -> [Type] -> CoreExpr
Type -> CoreBndr -> Unop CoreExpr
Type -> Type -> Maybe (Type, Type)
Type -> Type -> Maybe CoreExpr
Type -> Type -> CoreExpr
Type -> Type -> Type -> Maybe CoreExpr
Type -> Type -> Type -> CoreExpr
Type -> Type -> ReExpr
Type -> Type -> Ternop CoreExpr
Type -> ReExpr
Type -> Unop CoreExpr
Type -> ReExpr2
Type -> Binop CoreExpr
Role -> Type -> (Coercion, Type)
CoreExpr -> Bool
ReExpr
CoreExpr -> Either SDoc CoreExpr
Unop CoreExpr
Unop ReExpr
forall a. SDoc -> Either SDoc a -> a
forall a b. (Outputable a, Outputable b) => [Char] -> a -> b -> b
forall (f :: * -> *) a b.
(Functor f, Outputable a, Outputable b) =>
[Char] -> Unop (a -> f b)
inlineE :: Unop CoreExpr
boxCon :: ReExpr
catTy :: Type -> Type
reCatCo :: Rewrite Coercion
repTy :: Type -> Type
unfoldMaybe' :: ReExpr
unfoldMaybe :: ReExpr
inlineMaybe :: CoreBndr -> Maybe CoreExpr
noDictErr :: forall a. SDoc -> Either SDoc a -> a
onDictTry :: CoreExpr -> Either SDoc CoreExpr
onDictMaybe :: ReExpr
onDict :: Unop CoreExpr
onDicts :: Unop CoreExpr
buildDictMaybe :: Type -> Either SDoc CoreExpr
catOp :: Type -> CoreBndr -> [Type] -> CoreExpr
catOpMaybe :: Type -> CoreBndr -> [Type] -> Maybe CoreExpr
mkCcc :: Unop CoreExpr
mkId :: Type -> Type -> CoreExpr
mkCompose :: Type -> Binop CoreExpr
mkCompose' :: Type -> ReExpr2
mkEx :: Type -> CoreBndr -> Unop CoreExpr
mkFork :: Type -> Binop CoreExpr
mkFork' :: Type -> ReExpr2
mkApplyMaybe :: Type -> Type -> Type -> Maybe CoreExpr
isClosed :: Type -> Bool
mkCurry :: Type -> Unop CoreExpr
mkCurry' :: Type -> ReExpr
mkUncurryMaybe :: Type -> ReExpr
mkIfC :: Type -> Type -> Ternop CoreExpr
mkBottomC :: Type -> Type -> Type -> Maybe CoreExpr
mkConst :: Type -> Type -> ReExpr
mkConst' :: Type -> Type -> ReExpr
mkConstFun :: Type -> Type -> ReExpr
mkAbstC :: Type -> Type -> CoreExpr
mkReprC :: Type -> Type -> CoreExpr
mkReprC' :: Type -> Type -> CoreExpr
mkAbstC' :: Type -> Type -> CoreExpr
mkReprC'_maybe :: Type -> Type -> Maybe CoreExpr
mkAbstC'_maybe :: Type -> Type -> Maybe CoreExpr
mkCoerceC :: Type -> Type -> Type -> CoreExpr
mkCoerceC_maybe :: Type -> Type -> Type -> Maybe CoreExpr
traceRewrite :: forall (f :: * -> *) a b.
(Functor f, Outputable a, Outputable b) =>
[Char] -> Unop (a -> f b)
tyArgs2_maybe :: Type -> Maybe (Type, Type)
tyArgs2 :: Type -> (Type, Type)
pprTrans :: forall a b. (Outputable a, Outputable b) => [Char] -> a -> b -> b
lintReExpr :: Unop ReExpr
transCatOp :: ReExpr
reCat :: ReExpr
isPseudoApp :: CoreExpr -> Bool
normType :: Role -> Type -> (Coercion, Type)
okType :: Type -> Bool
optimizeCoercion :: Coercion -> Coercion
subst :: [CoreBndr] -> [(CoreBndr, CoreExpr)] -> Unop CoreExpr
eqTypeNormalising :: Type -> Type -> Maybe (Type, Type)
okType :: Type -> Bool
inlineE :: Unop CoreExpr
boxCon :: ReExpr
catTy :: Type -> Type
reCatCo :: Rewrite Coercion
repTy :: Type -> Type
unfoldMaybe' :: ReExpr
unfoldMaybe :: ReExpr
inlineMaybe :: CoreBndr -> Maybe CoreExpr
noDictErr :: forall a. SDoc -> Either SDoc a -> a
onDictTry :: CoreExpr -> Either SDoc CoreExpr
onDictMaybe :: ReExpr
onDict :: Unop CoreExpr
onDicts :: Unop CoreExpr
buildDictMaybe :: Type -> Either SDoc CoreExpr
catOp :: Type -> CoreBndr -> [Type] -> CoreExpr
catOpMaybe :: Type -> CoreBndr -> [Type] -> Maybe CoreExpr
mkCcc :: Unop CoreExpr
mkId :: Type -> Type -> CoreExpr
mkCompose :: Type -> Binop CoreExpr
mkCompose' :: Type -> ReExpr2
mkEx :: Type -> CoreBndr -> Unop CoreExpr
mkFork :: Type -> Binop CoreExpr
mkFork' :: Type -> ReExpr2
mkApplyMaybe :: Type -> Type -> Type -> Maybe CoreExpr
isClosed :: Type -> Bool
normType :: Role -> Type -> (Coercion, Type)
mkCurry' :: Type -> ReExpr
mkCurry :: Type -> Unop CoreExpr
mkUncurryMaybe :: Type -> ReExpr
mkIfC :: Type -> Type -> Ternop CoreExpr
mkBottomC :: Type -> Type -> Type -> Maybe CoreExpr
mkConst :: Type -> Type -> ReExpr
mkConstFun :: Type -> Type -> ReExpr
mkConst' :: Type -> Type -> ReExpr
mkAbstC :: Type -> Type -> CoreExpr
mkReprC :: Type -> Type -> CoreExpr
mkReprC' :: Type -> Type -> CoreExpr
mkAbstC' :: Type -> Type -> CoreExpr
mkReprC'_maybe :: Type -> Type -> Maybe CoreExpr
mkAbstC'_maybe :: Type -> Type -> Maybe CoreExpr
mkCoerceC :: Type -> Type -> Type -> CoreExpr
mkCoerceC_maybe :: Type -> Type -> Type -> Maybe CoreExpr
tyArgs2_maybe :: Type -> Maybe (Type, Type)
tyArgs2 :: Type -> (Type, Type)
traceRewrite :: forall (f :: * -> *) a b.
(Functor f, Outputable a, Outputable b) =>
[Char] -> Unop (a -> f b)
pprTrans :: forall a b. (Outputable a, Outputable b) => [Char] -> a -> b -> b
lintReExpr :: Unop ReExpr
transCatOp :: ReExpr
reCat :: ReExpr
isPseudoApp :: CoreExpr -> Bool
optimizeCoercion :: Coercion -> Coercion
subst :: [CoreBndr] -> [(CoreBndr, CoreExpr)] -> Unop CoreExpr
eqTypeNormalising :: Type -> Type -> Maybe (Type, Type)
..}
 where
   okType :: Type -> Bool
okType Type
t = Either SDoc CoreExpr -> Bool
forall a b. Either a b -> Bool
isRight (Type -> Either SDoc CoreExpr
buildDictMaybe (TyCon -> [Type] -> Type
mkTyConApp TyCon
okTypeTc [Type
t]))
   -- okType _ = True
   inlineE :: Unop CoreExpr
   inlineE :: Unop CoreExpr
inlineE CoreExpr
e = CoreBndr -> [Type] -> [CoreExpr] -> CoreExpr
varApps CoreBndr
inlineV [(() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e] [CoreExpr
e]  -- move outward
   -- Replace boxing constructors by their boxing function synonyms (boxI etc)
   boxCon :: ReExpr
   boxCon :: ReExpr
boxCon CoreExpr
e0 | Bool
tweaked   = -- dtrace "boxCon" (ppr (e0,e1)) $
                           ReExpr
forall a. a -> Maybe a
Just CoreExpr
e1
             | Bool
otherwise = Maybe CoreExpr
forall a. Maybe a
Nothing
    where
      (Any Bool
tweaked,CoreExpr
e1) = GenericM ((,) Any) -> GenericM ((,) Any)
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM ((CoreExpr -> (Any, CoreExpr)) -> a -> (Any, a)
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM CoreExpr -> (Any, CoreExpr)
tweak) CoreExpr
e0
      success :: t -> (Any, t)
success = (Bool -> Any
Any Bool
True,)
      tweak :: CoreExpr -> (Any,CoreExpr)
      tweak :: CoreExpr -> (Any, CoreExpr)
tweak e :: CoreExpr
e@(App (Var CoreBndr
con) CoreExpr
e')
        | CoreBndr -> Bool
isDataConWorkId CoreBndr
con
        , Just (TyCon
tc,[]) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e)
        , Just  CoreBndr
boxV <- (UniqDFM TyCon CoreBndr -> TyCon -> Maybe CoreBndr)
-> TyCon -> UniqDFM TyCon CoreBndr -> Maybe CoreBndr
forall a b c. (a -> b -> c) -> b -> a -> c
flip UniqDFM TyCon CoreBndr -> TyCon -> Maybe CoreBndr
forall key elt.
Uniquable key =>
UniqDFM key elt -> key -> Maybe elt
DFMap.lookupUDFM  TyCon
tc UniqDFM TyCon CoreBndr
boxers
        = CoreExpr -> (Any, CoreExpr)
forall {t}. t -> (Any, t)
success (CoreExpr -> (Any, CoreExpr)) -> CoreExpr -> (Any, CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
boxV Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
e'
      tweak ((Var CoreBndr
v `App` Type Type
ty) `App` CoreExpr
e')
        | CoreBndr
v CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
tagToEnumV Bool -> Bool -> Bool
&& Type
ty Type -> Type -> Bool
`eqType` Type
boolTy
        = CoreExpr -> (Any, CoreExpr)
forall {t}. t -> (Any, t)
success (CoreExpr -> (Any, CoreExpr)) -> CoreExpr -> (Any, CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
boxIBV Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
e'
      -- Int equality turns into matching, which takes some care.
      tweak (Case CoreExpr
scrut CoreBndr
v Type
rhsTy ((Alt AltCon
DEFAULT [] CoreExpr
d) : ((Alt CoreBndr -> Maybe (Literal, CoreExpr))
-> [Alt CoreBndr] -> Maybe [(Literal, 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 Alt CoreBndr -> Maybe (Literal, CoreExpr)
forall {b}. Alt b -> Maybe (Literal, Expr b)
litAlt -> Just [(Literal, CoreExpr)]
las)))
       | [(Literal, CoreExpr)] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [(Literal, CoreExpr)]
las
       , TyCon -> Type -> Bool
hasTyCon TyCon
intPrimTyCon Type
vty
       = Doing("lam Case of Int#")
         -- TODO: let-bind scrut or use live binder
         CoreExpr -> (Any, CoreExpr)
forall {t}. t -> (Any, t)
success (CoreExpr -> (Any, CoreExpr)) -> CoreExpr -> (Any, CoreExpr)
forall a b. (a -> b) -> a -> b
$ Bind CoreBndr -> Unop CoreExpr
mkCoreLet (CoreBndr -> CoreExpr -> Bind CoreBndr
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
scrutV CoreExpr
scrut) Unop CoreExpr -> Unop CoreExpr
forall a b. (a -> b) -> a -> b
$ ((Literal, CoreExpr) -> Unop CoreExpr)
-> CoreExpr -> [(Literal, CoreExpr)] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Literal, CoreExpr) -> Unop CoreExpr
mkIf CoreExpr
d [(Literal, CoreExpr)]
las
        where
         vty :: Type
vty = CoreBndr -> Type
varType CoreBndr
v
         scrutV :: CoreBndr
scrutV = CoreBndr -> CoreBndr
zapIdOccInfo CoreBndr
v
         scrut' :: Expr b
scrut' = CoreBndr -> Expr b
forall b. CoreBndr -> Expr b
Var CoreBndr
scrutV
         mkIf :: (Literal, CoreExpr) -> Unop CoreExpr
mkIf (Literal
lit,CoreExpr
rhs) CoreExpr
e = CoreBndr -> [Type] -> [CoreExpr] -> CoreExpr
varApps CoreBndr
ifEqIntHash [Type
rhsTy] [CoreExpr
forall {b}. Expr b
scrut',Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit,CoreExpr
rhs,CoreExpr
e]
      tweak CoreExpr
e = (Bool -> Any
Any Bool
False, CoreExpr
e)
      litAlt :: Alt b -> Maybe (Literal, Expr b)
litAlt (Alt (LitAlt Literal
lit) [] Expr b
rhs) = (Literal, Expr b) -> Maybe (Literal, Expr b)
forall a. a -> Maybe a
Just (Literal
lit,Expr b
rhs)
      litAlt Alt b
_ = Maybe (Literal, Expr b)
forall a. Maybe a
Nothing
   -- hrMeth :: Type -> Maybe (Id -> CoreExpr)
   -- hrMeth ty = -- dtrace "hasRepMeth:" (ppr ty) $
   --             hasRepMeth dflags guts inScope ty
   -- Change categories
   catTy :: Unop Type
   catTy :: Type -> Type
catTy (Type -> (Type, Type)
tyArgs2 -> (Type
a,Type
b)) = Type -> [Type] -> Type
mkAppTys Type
cat [Type
a,Type
b]
   reCatCo :: Rewrite Coercion
   -- reCatCo co | dtrace "reCatCo" (ppr co) False = undefined
   reCatCo :: Rewrite Coercion
reCatCo (FunCo' Role
r Coercion
a Coercion
b) = Rewrite Coercion
forall a. a -> Maybe a
Just (Coercion -> [Coercion] -> Coercion
mkAppCos (Role -> Type -> Coercion
mkReflCo Role
r Type
cat) [Coercion
a,Coercion
b])
   reCatCo (Coercion -> Maybe (Coercion, Coercion)
splitAppCo_maybe -> Just
            (Coercion -> Maybe (Coercion, Coercion)
splitAppCo_maybe -> Just
             (GRefl Role
r Type
_k MCoercionN
mrefl,Coercion
a),Coercion
b)) =
     -- dtrace "reCatCo app" (ppr (r,_k,a,b)) $
     Rewrite Coercion
forall a. a -> Maybe a
Just (Coercion -> [Coercion] -> Coercion
mkAppCos (Role -> Type -> MCoercionN -> Coercion
mkGReflCo Role
r Type
cat MCoercionN
mrefl) [Coercion
a,Coercion
b])
   reCatCo (Coercion
co1 `TransCo` Coercion
co2) = Coercion -> Coercion -> Coercion
TransCo (Coercion -> Coercion -> Coercion)
-> Maybe Coercion -> Maybe (Coercion -> Coercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rewrite Coercion
reCatCo Coercion
co1 Maybe (Coercion -> Coercion) -> Maybe Coercion -> Maybe Coercion
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rewrite Coercion
reCatCo Coercion
co2
   reCatCo Coercion
co = [Char] -> SDoc -> Maybe Coercion -> Maybe Coercion
forall a. [Char] -> SDoc -> a -> a
pprTrace [Char]
"ccc reCatCo: unhandled coercion" (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co) (Maybe Coercion -> Maybe Coercion)
-> Maybe Coercion -> Maybe Coercion
forall a b. (a -> b) -> a -> b
$
                Maybe Coercion
forall a. Maybe a
Nothing
   -- Interpret a representational cast
   -- TODO: Try swapping argument order
   repTy :: Unop Type
   repTy :: Type -> Type
repTy Type
t = TyCon -> [Type] -> Type
mkTyConApp TyCon
repTc [Type
t]
   -- coercibleTy :: Unop Type
   -- coercibleTy t = mkTyConApp coercibleTc [t]
   -- Temp hack: avoid exl/exr and reprC/abstC.
   unfoldMaybe' :: ReExpr
   -- unfoldMaybe' e | pprTrace "unfoldMaybe'" (ppr (e,exprHead e)) False = undefined
   unfoldMaybe' :: ReExpr
unfoldMaybe' e :: CoreExpr
e@(CoreExpr -> Maybe CoreBndr
exprHead -> Just CoreBndr
v)
     | Bool -> Bool
not (CoreBndr -> Bool
isSelectorId CoreBndr
v Bool -> Bool -> Bool
|| CoreBndr -> Bool
isAbstReprId CoreBndr
v) = ReExpr
unfoldMaybe CoreExpr
e
   unfoldMaybe' CoreExpr
_ = Maybe CoreExpr
forall a. Maybe a
Nothing
   unfoldMaybe :: ReExpr
   -- unfoldMaybe e | dtrace "unfoldMaybe" (ppr (e,collectArgsPred isTyCoDictArg e)) False = undefined
   unfoldMaybe :: ReExpr
unfoldMaybe CoreExpr
e -- \| unfoldOkay e
                 --  \| (Var v, _) <- collectArgsPred isTyCoDictArg e
                 -- -- , dtrace "unfoldMaybe" (text (fqVarName v)) True
                 -- , isNothing (catFun (Var v))
                 --  \| True  -- experiment: don't restrict unfolding
                 = DynFlags -> (CoreBndr -> Maybe CoreExpr) -> ReExpr
onExprHead DynFlags
dflags ({- traceRewrite "inlineMaybe" -} CoreBndr -> Maybe CoreExpr
inlineMaybe) CoreExpr
e
                 -- \| otherwise = Nothing
   -- unfoldMaybe = -- traceRewrite "unfoldMaybe" $
   --               onExprHead ({-traceRewrite "inlineMaybe"-} inlineMaybe)
   inlineMaybe :: Id -> Maybe CoreExpr
   -- inlineMaybe v | dtrace ("inlineMaybe " ++ fqVarName v) (ppr ()) False = undefined
   -- inlineMaybe v | dtrace "inlineMaybe" (ppr v) False = undefined
   inlineMaybe :: CoreBndr -> Maybe CoreExpr
inlineMaybe CoreBndr
v = (CoreBndr -> Maybe CoreExpr
inlineId Binop (CoreBndr -> Maybe CoreExpr)
forall a b. Binop (a -> Maybe b)
<+ -- onInlineFail <+ traceRewrite "inlineClassOp"
                                CoreBndr -> Maybe CoreExpr
inlineClassOp) CoreBndr
v
   -- onInlineFail :: Id -> Maybe CoreExpr
   -- onInlineFail v =
   --   pprTrace "onInlineFail idDetails" (ppr v <+> colon <+> ppr (idDetails v))
   --   Nothing
   noDictErr :: SDoc -> Either SDoc a -> a
   noDictErr :: forall a. SDoc -> Either SDoc a -> a
noDictErr SDoc
doc =
     (SDoc -> a) -> (a -> a) -> Either SDoc a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ SDoc
msg -> [Char] -> SDoc -> a
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"ccc - couldn't build dictionary for" (SDoc
doc SDoc -> SDoc -> SDoc
GHC.<> SDoc
colon SDoc -> SDoc -> SDoc
$$ SDoc
msg)) a -> a
forall a. a -> a
id
   onDictTry :: CoreExpr -> Either SDoc CoreExpr
   onDictTry :: CoreExpr -> Either SDoc CoreExpr
onDictTry CoreExpr
e | Just (Type
ty,Type
_) <- Type -> Maybe (Type, Type)
splitFunTy_maybe' ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e)
               , Type -> Bool
isPredTy' Type
ty = Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
e Unop CoreExpr -> Either SDoc CoreExpr -> Either SDoc CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Either SDoc CoreExpr
buildDictMaybe Type
ty
               | Bool
otherwise = CoreExpr -> Either SDoc CoreExpr
forall a. a -> Either SDoc a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e
                             -- pprPanic "ccc / onDictTy: not a function from pred" (pprWithType e)
   onDictMaybe :: ReExpr
   -- TODO: refactor onDictMaybe
   onDictMaybe :: ReExpr
onDictMaybe CoreExpr
e = case CoreExpr -> Either SDoc CoreExpr
onDictTry CoreExpr
e of
                     Left  SDoc
msg  -> [Char] -> SDoc -> Maybe CoreExpr -> Maybe CoreExpr
forall a. [Char] -> SDoc -> a -> a
dtrace [Char]
"Couldn't build dictionary for"
                                     (CoreExpr -> SDoc
pprWithType CoreExpr
e SDoc -> SDoc -> SDoc
GHC.<> SDoc
colon SDoc -> SDoc -> SDoc
$$ SDoc
msg) (Maybe CoreExpr -> Maybe CoreExpr)
-> Maybe CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$
                                   Maybe CoreExpr
forall a. Maybe a
Nothing
                     Right CoreExpr
dict -> ReExpr
forall a. a -> Maybe a
Just CoreExpr
dict
   onDict :: Unop CoreExpr
   onDict :: Unop CoreExpr
onDict CoreExpr
f = -- trace "onDict" $
              SDoc -> Either SDoc CoreExpr -> CoreExpr
forall a. SDoc -> Either SDoc a -> a
noDictErr (CoreExpr -> SDoc
pprWithType CoreExpr
f) (CoreExpr -> Either SDoc CoreExpr
onDictTry CoreExpr
f)
   -- Yet another variant: keep applying to dictionaries as long as we have
   -- a predicate type. TODO: reassess and refactor these variants.
   onDicts :: Unop CoreExpr
   onDicts :: Unop CoreExpr
onDicts CoreExpr
e | Just (Type
ty,Type
_) <- Type -> Maybe (Type, Type)
splitFunTy_maybe' ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e)
             , Type -> Bool
isPredTy' Type
ty = Unop CoreExpr
onDicts (Unop CoreExpr
onDict CoreExpr
e)
             | Bool
otherwise    = CoreExpr
e
   buildDictMaybe :: Type -> Either SDoc CoreExpr
   buildDictMaybe :: Type -> Either SDoc CoreExpr
buildDictMaybe Type
ty = IO (Either SDoc CoreExpr) -> Either SDoc CoreExpr
forall a. IO a -> a
unsafePerformIO (IO (Either SDoc CoreExpr) -> Either SDoc CoreExpr)
-> IO (Either SDoc CoreExpr) -> Either SDoc CoreExpr
forall a b. (a -> b) -> a -> b
$
                       HscEnv
-> DynFlags
-> ModGuts
-> UniqSupply
-> InScopeEnv
-> Type
-> CoreExpr
-> Type
-> IO (Either SDoc CoreExpr)
buildDictionary HscEnv
hsc_env DynFlags
dflags ModGuts
guts UniqSupply
uniqSupply InScopeEnv
inScope Type
evTy CoreExpr
ev Type
ty
   catOp :: Cat -> Var -> [Type] -> CoreExpr
   -- catOp k op tys | dtrace "catOp" (ppr (k,op,tys)) False = undefined
   catOp :: Type -> CoreBndr -> [Type] -> CoreExpr
catOp Type
k CoreBndr
op [Type]
tys --  \| dtrace "catOp" (pprWithType (Var op `mkTyApps` (k : tys))) True
                  = Unop CoreExpr
onDicts (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
op CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
`mkTyApps` (Type
k Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
tys))
   -- TODO: refactor catOp and catOpMaybe when the dust settles
   -- catOp :: Cat -> Var -> CoreExpr
   -- catOp k op = catOp k op []
   catOpMaybe :: Cat -> Var -> [Type] -> Maybe CoreExpr
   catOpMaybe :: Type -> CoreBndr -> [Type] -> Maybe CoreExpr
catOpMaybe Type
k CoreBndr
op [Type]
tys = ReExpr
onDictMaybe (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
op CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
`mkTyApps` (Type
k Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
tys))
   mkCcc' :: Unop CoreExpr  -- Any reason to parametrize over Cat?
   mkCcc' :: Unop CoreExpr
mkCcc' CoreExpr
e = CoreBndr -> [Type] -> [CoreExpr] -> CoreExpr
varApps CoreBndr
cccPV [Type
cat,Type
a,Type
b,Type
evTy] [CoreExpr
ev,CoreExpr
e]
    where
      (Type
a,Type
b) = (Type, Type) -> Maybe (Type, Type) -> (Type, Type)
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> SDoc -> (Type, Type)
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"mkCcc non-function:" (CoreExpr -> SDoc
pprWithType CoreExpr
e)) (Maybe (Type, Type) -> (Type, Type))
-> Maybe (Type, Type) -> (Type, Type)
forall a b. (a -> b) -> a -> b
$
              Type -> Maybe (Type, Type)
splitFunTy_maybe' ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e)
   mkCcc :: Unop CoreExpr  -- Any reason to parametrize over Cat?
   mkCcc :: Unop CoreExpr
mkCcc CoreExpr
e = -- dtrace "mkCcc" (ppr (cat, e)) $
             Unop CoreExpr
mkCcc' CoreExpr
e
   -- TODO: replace composeV with mkCompose in CccEnv
   -- Maybe other variables as well
   mkId :: Cat -> Type -> CoreExpr
   mkId :: Type -> Type -> CoreExpr
mkId Type
k Type
ty = Unop CoreExpr
onDict (Type -> CoreBndr -> [Type] -> CoreExpr
catOp Type
k CoreBndr
idV [Type
ty])
               -- onDict (catOp k idV `App` Type ty)
   mkCompose :: Cat -> Binop CoreExpr
   -- (.) :: forall b c a. (b -> c) -> (a -> b) -> a -> c
   mkCompose :: Type -> Binop CoreExpr
mkCompose Type
k CoreExpr
g CoreExpr
f
     | Just (Type
b,Type
c ) <- Type -> Maybe (Type, Type)
tyArgs2_maybe ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
g)
     , Just (Type
a,Type
b') <- Type -> Maybe (Type, Type)
tyArgs2_maybe ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
f)
     = -- mkCoreApps (onDict (catOp k composeV `mkTyApps` [b,c,a])) [g,f]
       case Type
b Type -> Type -> Maybe (Type, Type)
`eqTypeNormalising` Type
b' of
         Just (Type
bNormalised, Type
b'Normalised) ->
           [Char] -> SDoc -> CoreExpr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"mkCompose mismatch:" (SDoc -> CoreExpr) -> SDoc -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
bNormalised SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
b'Normalised SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
pprWithType CoreExpr
g SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
pprWithType CoreExpr
f
         Maybe (Type, Type)
Nothing ->
           CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps (Unop CoreExpr
onDict (Type -> CoreBndr -> [Type] -> CoreExpr
catOp Type
k CoreBndr
composeV [Type
b,Type
c,Type
a])) [CoreExpr
g,CoreExpr
f]
     | Bool
otherwise
     = [Char] -> SDoc -> CoreExpr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"mkCompose arguments not arrays:" (SDoc -> CoreExpr) -> SDoc -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> SDoc
pprWithType CoreExpr
g SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
pprWithType CoreExpr
f

   -- Experiment
   mkCompose' :: Cat -> ReExpr2
   -- (.) :: forall b c a. (b -> c) -> (a -> b) -> a -> c
   mkCompose' :: Type -> ReExpr2
mkCompose' Type
k CoreExpr
g CoreExpr
f
     | Just (Type
b,Type
c ) <- Type -> Maybe (Type, Type)
tyArgs2_maybe ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
g)
     , Just (Type
a,Type
b') <- Type -> Maybe (Type, Type)
tyArgs2_maybe ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
f)
     =       
       -- flip mkCoreApps [g,f] <$> onDictMaybe (catOp k composeV [b,c,a])         
       -- (flip mkCoreApps [g,f] . onDict) <$> catOpMaybe k composeV [b,c,a]
       case Type
b Type -> Type -> Maybe (Type, Type)
`eqTypeNormalising` Type
b' of
         Maybe (Type, Type)
Nothing -> (CoreExpr -> [CoreExpr] -> CoreExpr) -> [CoreExpr] -> Unop CoreExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps [CoreExpr
g,CoreExpr
f] Unop CoreExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReExpr
onDictMaybe ReExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> CoreBndr -> [Type] -> Maybe CoreExpr
catOpMaybe Type
k CoreBndr
composeV [Type
b,Type
c,Type
a])
         Just (Type
bNormalised, Type
b'Normalised) ->
           [Char] -> SDoc -> Maybe CoreExpr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"mkCompose' mismatch:" (CoreExpr -> Type -> SDoc
pprWithExplicitType CoreExpr
g Type
bNormalised SDoc -> SDoc -> SDoc
$$ CoreExpr -> Type -> SDoc
pprWithExplicitType CoreExpr
f Type
b'Normalised)
     | Bool
otherwise = [Char] -> SDoc -> Maybe CoreExpr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"mkCompose' mismatch:" (CoreExpr -> SDoc
pprWithType CoreExpr
g SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
pprWithType CoreExpr
f)

   mkEx :: Cat -> Var -> Unop CoreExpr
   mkEx :: Type -> CoreBndr -> Unop CoreExpr
mkEx Type
k CoreBndr
ex CoreExpr
z =
     -- -- For the class method aliases (exl, exr):
     -- pprTrace "mkEx" (pprWithType z) $
     -- pprTrace "mkEx" (pprWithType (Var ex)) $
     -- pprTrace "mkEx" (pprWithType (catOp k ex [a,b])) $
     -- pprTrace "mkEx" (pprWithType (onDict (catOp k ex [a,b]))) $
     -- pprTrace "mkEx" (pprWithType (onDict (catOp k ex [a,b]) `App` z)) $
     -- -- pprPanic "mkEx" (text "bailing")
     Unop CoreExpr
onDict (Type -> CoreBndr -> [Type] -> CoreExpr
catOp Type
k CoreBndr
ex [Type
a,Type
b]) Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
z
    where
      (Type
a,Type
b)  = Type -> (Type, Type)
tyArgs2 ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
z)
   mkFork :: Cat -> Binop CoreExpr
   -- mkFork k f g | pprTrace "mkFork" (sep [ppr k, ppr f, ppr g]) False = undefined
   mkFork :: Type -> Binop CoreExpr
mkFork Type
k CoreExpr
f CoreExpr
g =
     -- (&&&) :: forall {k :: * -> * -> *} {a} {c} {d}.
     --          (ProductCat k, Ok k d, Ok k c, Ok k a)
     --       => k a c -> k a d -> k a (Prod k c d)
     -- onDict (catOp k forkV `mkTyApps` [a,c,d]) `mkCoreApps` [f,g]
     Unop CoreExpr
onDict (Type -> CoreBndr -> [Type] -> CoreExpr
catOp Type
k CoreBndr
forkV [Type
a,Type
c,Type
d]) CoreExpr -> [CoreExpr] -> CoreExpr
`mkCoreApps` [CoreExpr
f,CoreExpr
g]
    where
      (Type
a,Type
c) = Type -> (Type, Type)
tyArgs2 ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
f)
      (Type
_,Type
d) = Type -> (Type, Type)
tyArgs2 ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
g)
   mkFork' :: Cat -> ReExpr2
   -- mkFork k f g | pprTrace "mkFork" (sep [ppr k, ppr f, ppr g]) False = undefined
   mkFork' :: Type -> ReExpr2
mkFork' Type
k CoreExpr
f CoreExpr
g =
     -- (&&&) :: forall {k :: * -> * -> *} {a} {c} {d}.
     --          (ProductCat k, Ok k d, Ok k c, Ok k a)
     --       => k a c -> k a d -> k a (Prod k c d)
     -- return $ onDict (catOp k forkV [a,c,d]) `mkCoreApps` [f,g]
     (CoreExpr -> [CoreExpr] -> CoreExpr) -> [CoreExpr] -> Unop CoreExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps [CoreExpr
f,CoreExpr
g] Unop CoreExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReExpr
onDictMaybe ReExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> CoreBndr -> [Type] -> Maybe CoreExpr
catOpMaybe Type
k CoreBndr
forkV [Type
a,Type
c,Type
d])
    where
      (Type
a,Type
c) = Type -> (Type, Type)
tyArgs2 ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
f)
      (Type
_,Type
d) = Type -> (Type, Type)
tyArgs2 ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
g)
   mkApplyMaybe :: Cat -> Type -> Type -> Maybe CoreExpr
   mkApplyMaybe :: Type -> Type -> Type -> Maybe CoreExpr
mkApplyMaybe Type
k Type
a Type
b =
     -- apply :: forall {k :: * -> * -> *} {a} {b}. (ClosedCat k, Ok k b, Ok k a)
     --       => k (Prod k (Exp k a b) a) b
     -- onDict (catOp k applyV `mkTyApps` [a,b])
     ReExpr
onDictMaybe ReExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> CoreBndr -> [Type] -> Maybe CoreExpr
catOpMaybe Type
k CoreBndr
applyV [Type
a,Type
b]
   isClosed :: Cat -> Bool
   -- isClosed k = isJust (mkApplyMaybe k unitTy unitTy)
   isClosed :: Type -> Bool
isClosed Type
k = Either SDoc CoreExpr -> Bool
forall a b. Either a b -> Bool
isRight (Type -> Either SDoc CoreExpr
buildDictMaybe (TyCon -> [Type] -> Type
TyConApp TyCon
closedTc [Type
k]))
#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
   normType :: Role -> Type -> (Coercion, Type)
normType Role
role Type
ty = let reduction :: Reduction
reduction = FamInstEnvs -> Role -> Type -> Reduction
normaliseType FamInstEnvs
famEnvs Role
role Type
ty
                      in (Reduction -> Coercion
reductionCoercion Reduction
reduction, Reduction -> Type
reductionReducedType Reduction
reduction)
#else
   normType = normaliseType famEnvs
#endif

   mkCurry' :: Cat -> ReExpr
   -- mkCurry' k e | dtrace "mkCurry'" (ppr k <+> pprWithType e) False = undefined
   mkCurry' :: Type -> ReExpr
mkCurry' Type
k CoreExpr
e =
     -- curry :: forall {k :: * -> * -> *} {a} {b} {c}.
     --          (ClosedCat k, Ok k c, Ok k b, Ok k a)
     --       => k (Prod k a b) c -> k a (Exp k b c)
     -- onDict (catOp k curryV `mkTyApps` [a,b,c]) `App` e
     -- dtrace "mkCurry: (a,b,c) ==" (ppr (a,b,c)) $
     (Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
e) Unop CoreExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReExpr
onDictMaybe ReExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> CoreBndr -> [Type] -> Maybe CoreExpr
catOpMaybe Type
k CoreBndr
curryV [Type
a,Type
b,Type
c])
    where
      (Type -> (Type, Type)
tyArgs2 -> (Type -> (Type, Type)
tyArgs2 -> (Type
a,Type
b),Type
c)) = (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e
      -- (splitAppTys -> (_,[splitAppTys -> (_,[a,b]),c])) = exprType e

   mkCurry :: Cat -> Unop CoreExpr
   -- mkCurry k e | dtrace "mkCurry" (ppr k <+> pprWithType e) False = undefined
   mkCurry :: Type -> Unop CoreExpr
mkCurry Type
k CoreExpr
e =
     -- curry :: forall {k :: * -> * -> *} {a} {b} {c}.
     --          (ClosedCat k, Ok k c, Ok k b, Ok k a)
     --       => k (Prod k a b) c -> k a (Exp k b c)
     -- onDict (catOp k curryV `mkTyApps` [a,b,c]) `App` e
     -- dtrace "mkCurry: (a,b,c) ==" (ppr (a,b,c)) $
     Unop CoreExpr
onDict (Type -> CoreBndr -> [Type] -> CoreExpr
catOp Type
k CoreBndr
curryV [Type
a,Type
b,Type
c]) Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
e
    where
      (Type -> (Type, Type)
tyArgs2 -> (Type -> (Type, Type)
tyArgs2 -> (Type
a,Type
b),Type
c)) = (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e
      -- (splitAppTys -> (_,[splitAppTys -> (_,[a,b]),c])) = exprType e
   mkUncurryMaybe :: Cat -> ReExpr
   mkUncurryMaybe :: Type -> ReExpr
mkUncurryMaybe Type
k CoreExpr
e =
     -- uncurry :: forall {k :: * -> * -> *} {a} {b} {c}.
     --            (ClosedCat k, Ok k c, Ok k b, C1 (Ok k) a)
     --         => k a (Exp k b c) -> k (Prod k a b) c
     -- onDict (catOp k uncurryV `mkTyApps` [a,b,c]) `App` e
     (Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
e) Unop CoreExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReExpr
onDictMaybe ReExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> CoreBndr -> [Type] -> Maybe CoreExpr
catOpMaybe Type
k CoreBndr
uncurryV [Type
a,Type
b,Type
c] )
    where
      (Type -> (Type, Type)
tyArgs2 -> (Type
a, Type -> (Type, Type)
tyArgs2 -> (Type
b,Type
c))) = (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e
   mkIfC :: Cat -> Type -> Ternop CoreExpr
   mkIfC :: Type -> Type -> Ternop CoreExpr
mkIfC Type
k Type
ty CoreExpr
cond CoreExpr
true CoreExpr
false =
     Type -> Binop CoreExpr
mkCompose Type
cat (Type -> CoreBndr -> [Type] -> CoreExpr
catOp Type
k CoreBndr
ifV [Type
ty])
       (Type -> Binop CoreExpr
mkFork Type
cat CoreExpr
cond (Type -> Binop CoreExpr
mkFork Type
cat CoreExpr
true CoreExpr
false))
   mkBottomC :: Cat -> Type -> Type -> Maybe CoreExpr
   mkBottomC :: Type -> Type -> Type -> Maybe CoreExpr
mkBottomC Type
k Type
dom Type
cod =
     -- dtrace "mkBottomC bottomTV" (pprWithType (Var bottomTV)) $
     Unop CoreExpr
onDicts Unop CoreExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CoreBndr -> [Type] -> Maybe CoreExpr
catOpMaybe Type
k CoreBndr
bottomTV [Type
dom,Type
cod]
   mkConst :: Cat -> Type -> ReExpr
   -- mkConst k dom e | dtrace "mkConst1" (ppr (k,dom,e)) False = undefined
   -- mkConst k dom e | dtrace "mkConst2" (ppr ((`App` e) <$> (onDictMaybe =<< catOpMaybe k constV [exprType e, dom]))) False = undefined
   mkConst :: Type -> Type -> ReExpr
mkConst Type
k Type
dom CoreExpr
e =
     -- const :: forall (k :: * -> * -> *) b. ConstCat k b => forall dom.
     --          Ok k dom => b -> k dom (ConstObj k b)
     -- (`App` e) <$> onDictMaybe (catOp k constV [exprType e, dom])
     (Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
e) Unop CoreExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReExpr
onDictMaybe ReExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> CoreBndr -> [Type] -> Maybe CoreExpr
catOpMaybe Type
k CoreBndr
constV [(() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e, Type
dom])
     -- onDict (catOp k constV [exprType e] `App` Type dom) `App` e
   mkConstFun :: Cat -> Type -> ReExpr
   -- mkConstFun k dom e | dtrace "mkConstFun" (ppr (k,dom,e)) False = undefined
   mkConstFun :: Type -> Type -> ReExpr
mkConstFun Type
k Type
dom CoreExpr
e =
     -- constFun :: forall k p a b. (ClosedCat k, Oks k '[p, a, b])
     --          => k a b -> k p (Exp k a b)
     -- (`App` e) <$> onDictMaybe (catOp k constFunV [dom,a,b])
     -- constFun isn't inlining on its own, so push it.
     (Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
e) Unop CoreExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReExpr
onDictMaybe ReExpr -> Unop CoreExpr -> ReExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unop CoreExpr
inlineE ReExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> CoreBndr -> [Type] -> Maybe CoreExpr
catOpMaybe Type
k CoreBndr
constFunV [Type
dom,Type
a,Type
b])
    where
      (Type
a,Type
b) = Type -> (Type, Type)
tyArgs2 ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e)
   -- Split k a b into a & b.
   -- TODO: check that k == cat
   -- Turn U into either const U or constFun (mkCcc U) if possible.
   mkConst' :: Cat -> Type -> ReExpr
   -- mkConst' k dom e | dtrace "mkConst'" (ppr (k,dom) <+> pprWithType e) False = undefined
   -- mkConst' k dom e = (mkConst k dom <+ (mkConstFun k dom . mkCcc)) e
   mkConst' :: Type -> Type -> ReExpr
mkConst' Type
k Type
dom CoreExpr
e | Type -> Bool
isFunTy ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e) = Type -> Type -> ReExpr
mkConstFun Type
k Type
dom (Unop CoreExpr
mkCcc CoreExpr
e)
                    | Bool
otherwise            = Type -> Type -> ReExpr
mkConst Type
k Type
dom CoreExpr
e
   -- TODO: refactor mkReprC and mkAbstC into one function that takes an Id. p
   mkAbstC :: Cat -> Type -> CoreExpr
   mkAbstC :: Type -> Type -> CoreExpr
mkAbstC Type
k Type
ty =
     -- pprTrace "mkAbstC" (ppr ty) $
     -- pprTrace "mkAbstC" (pprWithType (Var abstCV)) $
     -- pprTrace "mkAbstC" (pprWithType (catOp k abstCV [ty])) $
     -- pprPanic "mkAbstC" (text "bailing")
     Type -> CoreBndr -> [Type] -> CoreExpr
catOp Type
k CoreBndr
abstCV [Type
ty]
   mkReprC :: Cat -> Type -> CoreExpr
   mkReprC :: Type -> Type -> CoreExpr
mkReprC Type
k Type
ty =
     -- pprTrace "mkReprC" (ppr ty) $
     -- pprTrace "mkReprC" (pprWithType (Var reprCV)) $
     -- pprTrace "mkReprC" (pprWithType (catOp k reprCV [ty])) $
     -- pprPanic "mkReprC" (text "bailing")
     Type -> CoreBndr -> [Type] -> CoreExpr
catOp Type
k CoreBndr
reprCV [Type
ty]
   mkReprC',mkAbstC' :: Cat -> Type -> CoreExpr
   mkReprC' :: Type -> Type -> CoreExpr
mkReprC' Type
k Type
ty =
     CoreExpr -> Maybe CoreExpr -> CoreExpr
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> SDoc -> CoreExpr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"mkReprC' fail" ((Type, Type) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type
k,Type
ty))) (Type -> Type -> Maybe CoreExpr
mkReprC'_maybe Type
k Type
ty)
   mkAbstC' :: Type -> Type -> CoreExpr
mkAbstC' Type
k Type
ty =
     CoreExpr -> Maybe CoreExpr -> CoreExpr
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> SDoc -> CoreExpr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"mkAbstC' fail" ((Type, Type) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type
k,Type
ty))) (Type -> Type -> Maybe CoreExpr
mkAbstC'_maybe Type
k Type
ty)
   -- TODO: Combine mkReprC'_maybe and mkAbstC'_maybe for efficiency.
   -- TODO: Remove non-maybe versions, and drop "_maybe" from names.
   mkReprC'_maybe :: Cat -> Type -> Maybe CoreExpr
   mkReprC'_maybe :: Type -> Type -> Maybe CoreExpr
mkReprC'_maybe Type
k Type
a =
     -- pprTrace "mkReprC 1" (ppr (a,r)) $
     -- pprTrace "mkReprC 2" (pprWithType (Var reprCV)) $
     -- pprTrace "mkReprC 3" (pprMbWithType (catOpMaybe k reprCV [a,r])) $
     Type -> CoreBndr -> [Type] -> Maybe CoreExpr
catOpMaybe Type
k CoreBndr
reprCV [Type
a,Type
r]
    where
      (Coercion
_co,Type
r) = Role -> Type -> (Coercion, Type)
normType Role
Nominal (Type -> Type
repTy Type
a)
   mkAbstC'_maybe :: Cat -> Type -> Maybe CoreExpr
   mkAbstC'_maybe :: Type -> Type -> Maybe CoreExpr
mkAbstC'_maybe Type
k Type
a =
     -- pprTrace "mkAbstC 1" (ppr (r,a)) $
     -- pprTrace "mkAbstC 2" (pprWithType (Var abstCV)) $
     -- pprTrace "mkAbstC 3" (pprMbWithType (catOpMaybe k abstCV [a,r])) $
     Type -> CoreBndr -> [Type] -> Maybe CoreExpr
catOpMaybe Type
k CoreBndr
abstCV [Type
a,Type
r]
    where
      (Coercion
_co,Type
r) = Role -> Type -> (Coercion, Type)
normType Role
Nominal (Type -> Type
repTy Type
a)
   mkCoerceC :: Cat -> Type -> Type -> CoreExpr
   mkCoerceC :: Type -> Type -> Type -> CoreExpr
mkCoerceC Type
k Type
dom Type
cod
     | Type
dom Type -> Type -> Bool
`eqType` Type
cod = Type -> Type -> CoreExpr
mkId Type
k Type
dom
     | Bool
otherwise = Type -> CoreBndr -> [Type] -> CoreExpr
catOp Type
k CoreBndr
coerceV [Type
dom,Type
cod]
   mkCoerceC_maybe :: Cat -> Type -> Type -> Maybe CoreExpr
   mkCoerceC_maybe :: Type -> Type -> Type -> Maybe CoreExpr
mkCoerceC_maybe Type
k Type
dom Type
cod
     | Type
dom Type -> Type -> Bool
`eqType` Type
cod = ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Unop ReExpr
forall a b. (a -> b) -> a -> b
$ Type -> Type -> CoreExpr
mkId Type
k Type
dom
     | Bool
otherwise = Type -> CoreBndr -> [Type] -> Maybe CoreExpr
catOpMaybe Type
k CoreBndr
coerceV [Type
dom,Type
cod]
   tyArgs2_maybe :: Type -> Maybe (Type,Type)
   -- tyArgs2_maybe (splitAppTys -> (_,(a:b:_))) = Just (a,b)
   tyArgs2_maybe :: Type -> Maybe (Type, Type)
tyArgs2_maybe _ty :: Type
_ty@(Type -> Maybe (Type, Type)
splitAppTy_maybe -> Just (Type -> Maybe (Type, Type)
splitAppTy_maybe -> Just (Type
_,Type
a),Type
b)) =
     -- dtrace "tyArgs2_maybe" (ppr _ty <+> text "-->" <+> (ppr (a,b))) $
     (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (Type
a,Type
b)
   tyArgs2_maybe Type
_ = Maybe (Type, Type)
forall a. Maybe a
Nothing
   -- tyArgs2_maybe ty = do (t1,b) <- splitAppTy_maybe ty
   --                          (_ ,a) <- splitAppTy_maybe t1
   --                          return (a,b)
   tyArgs2 :: Type -> (Type,Type)
   tyArgs2 :: Type -> (Type, Type)
tyArgs2 (Type -> Maybe (Type, Type)
tyArgs2_maybe -> Just (Type, Type)
ab) = (Type, Type)
ab
   tyArgs2 Type
ty = [Char] -> SDoc -> (Type, Type)
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"tyArgs2" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
   -- traceRewrite :: (Outputable a, Outputable (f b)) => String -> Unop (a -> f b)
   -- traceRewrite str f a = pprTrans str a (f a)
   -- traceRewrite :: (Outputable a, Outputable (f b)) => String -> Unop (a -> f b)
   traceRewrite :: [Char] -> (t -> f b) -> t -> f b
traceRewrite [Char]
str t -> f b
f t
a = [Char] -> t -> b -> b
forall a b. (Outputable a, Outputable b) => [Char] -> a -> b -> b
pprTrans [Char]
str t
a (b -> b) -> f b -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> f b
f t
a
   pprTrans :: (Outputable a, Outputable b) => String -> a -> b -> b
   pprTrans :: forall a b. (Outputable a, Outputable b) => [Char] -> a -> b -> b
pprTrans [Char]
str a
a b
b = [Char] -> SDoc -> b -> b
forall a. [Char] -> SDoc -> a -> a
dtrace [Char]
str (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
a SDoc -> SDoc -> SDoc
$$ SDoc
"-->" SDoc -> SDoc -> SDoc
$$ b -> SDoc
forall a. Outputable a => a -> SDoc
ppr b
b) b
b
   lintReExpr :: Unop ReExpr
   lintReExpr :: Unop ReExpr
lintReExpr ReExpr
rew CoreExpr
before =
     do CoreExpr
after <- ReExpr
rew CoreExpr
before
        let before' :: CoreExpr
before' = Unop CoreExpr
mkCcc' CoreExpr
before
            oops :: [Char] -> SDoc -> a
oops [Char]
str SDoc
doc = [Char] -> SDoc -> a
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic ([Char]
"ccc post-transfo check. " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
str)
                             (SDoc
doc SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
before' SDoc -> SDoc -> SDoc
$$ SDoc
"-->" SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
after)
            beforeTy :: Type
beforeTy = (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
before'
            afterTy :: Type
afterTy  = (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
after
        Maybe CoreExpr
-> (Bag SDoc -> Maybe CoreExpr)
-> Maybe (Bag SDoc)
-> Maybe CoreExpr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (case Type
beforeTy Type -> Type -> Maybe (Type, Type)
`eqTypeNormalising` Type
afterTy of
                 Maybe (Type, Type)
Nothing -> ReExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
after
                 Just (Type
beforeTyNormalised, Type
afterTyNormalised) ->
                   [Char] -> SDoc -> Maybe CoreExpr
forall {a}. [Char] -> SDoc -> a
oops [Char]
"type change"
                    (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
beforeTyNormalised SDoc -> SDoc -> SDoc
<+> SDoc
"vs" SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
afterTyNormalised SDoc -> SDoc -> SDoc
<+> SDoc
"in"))
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
              ([Char] -> SDoc -> Maybe CoreExpr
forall {a}. [Char] -> SDoc -> a
oops [Char]
"Lint" (SDoc -> Maybe CoreExpr)
-> (Bag SDoc -> SDoc) -> Bag SDoc -> Maybe CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag SDoc -> SDoc
pprMessageBag)
#else
              (oops "Lint")
#endif
          (DynFlags -> [CoreBndr] -> CoreExpr -> Maybe (Bag SDoc)
lintExpr DynFlags
dflags (VarSet -> [CoreBndr]
forall a. UniqSet a -> [a]
uniqSetToList (CoreExpr -> VarSet
exprFreeVars CoreExpr
after)) CoreExpr
after)
   transCatOp :: ReExpr
   transCatOp :: ReExpr
transCatOp orig :: CoreExpr
orig@(CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs -> (Var CoreBndr
v, Type (Type -> Bool
isFunCat -> Bool
True) : [CoreExpr]
rest))
     | Type -> Bool
isFunCat Type
cat = ReExpr
forall a. a -> Maybe a
Just CoreExpr
orig
     -- Take care with const, so we don't transform it alone.
     -- TODO: look for a more general suitable test for wrong number of arguments.
     -- \| pprTrace "transCatOp" (ppr (WithType (Var v),WithType <$> rest,length rest, orig)) False = undefined
     | CoreBndr
v CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
constV Bool -> Bool -> Bool
&& [CoreExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
rest Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
5 = Maybe CoreExpr
forall a. Maybe a
Nothing
     | CoreBndr -> Maybe [Char]
varModuleName CoreBndr
v Maybe [Char] -> Maybe [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
catModule
     , CoreBndr -> [Char]
uqVarName CoreBndr
v [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`
         [[Char]
"forkF",[Char]
"crossF",[Char]
"joinF",[Char]
"plusF",[Char]
"joinPF",[Char]
"plusPF"]
     , [CoreExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
rest Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
6 = Maybe CoreExpr
forall a. Maybe a
Nothing
     | Bool
otherwise
     = -- dtrace "transCatOp v rest" (text (fqVarName v) <+> ppr rest) $
       let -- Track how many regular (non-TyCo, non-pred) arguments we've seen
           addArg :: Maybe CoreExpr -> CoreExpr -> Maybe CoreExpr
           -- addArg a b | -- dtrace "transCatOp addArg" (ppr (a,b)) False = undefined
           addArg :: Maybe CoreExpr -> ReExpr
addArg Maybe CoreExpr
Nothing CoreExpr
_ = -- dtrace "transCatOp Nothing" (text "bailing") $
                              Maybe CoreExpr
forall a. Maybe a
Nothing
           addArg (Just CoreExpr
e) CoreExpr
arg
             | CoreExpr -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreExpr
arg
             = -- dtrace "addArg isTyCoArg" (ppr arg) $
               ReExpr
forall a. a -> Maybe a
Just (CoreExpr
e Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
arg)
             | CoreExpr -> Bool
isPred CoreExpr
arg
             = -- dtrace "addArg isPred" (ppr arg) $
               -- onDictMaybe may fail (Nothing) in the target category.
               ReExpr
onDictMaybe CoreExpr
e  --  fails gracefully
             | FunTy' Type
dom Type
_ <- (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e
             = -- dtrace "addArg otherwise" (ppr arg) $
               -- TODO: logic to sort out cat vs non-cat args.
               -- We currently don't have both.
               ReExpr
forall a. a -> Maybe a
Just (CoreExpr
e Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` (if Type -> Bool
isCatTy Type
dom then Unop CoreExpr
mkCcc else Unop CoreExpr
forall a. a -> a
id) CoreExpr
arg)
               -- Just (e `App` (if isFunTy (exprType arg) then mkCcc else id) arg)
             | Bool
otherwise
             = -- dtrace "addArg: not a function type" (ppr (exprType e)) $
               Maybe CoreExpr
forall a. Maybe a
Nothing
           final :: Maybe CoreExpr
final = (Maybe CoreExpr -> ReExpr)
-> Maybe CoreExpr -> [CoreExpr] -> Maybe CoreExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Maybe CoreExpr -> ReExpr
addArg (ReExpr
forall a. a -> Maybe a
Just (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
v Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Type -> CoreExpr
forall b. Type -> Expr b
Type Type
cat)) [CoreExpr]
rest
       in
         -- Make sure we have no remaining cat arguments
         -- dtrace "transCatOp final" (ppr final) $
         case Maybe CoreExpr
final of
           Just CoreExpr
e' | -- dtrace "hasCatArg" (ppr (hasCatArg e')) $
                     Bool -> Bool
not (CoreExpr -> Bool
hasCatArg CoreExpr
e') -> ReExpr
forall a. a -> Maybe a
Just CoreExpr
e'
           Maybe CoreExpr
_                            -> Maybe CoreExpr
forall a. Maybe a
Nothing
   transCatOp CoreExpr
_ = -- dtrace "transCatOp" (text "fail") $
                  Maybe CoreExpr
forall a. Maybe a
Nothing

   isCatTy :: Type -> Bool
   isCatTy :: Type -> Bool
isCatTy (Type -> Maybe (Type, Type)
splitAppTy_maybe -> Just (Type -> Maybe (Type, Type)
splitAppTy_maybe -> Just (Type
k,Type
_),Type
_)) =
     Type
k Type -> Type -> Bool
`eqType` Type
cat
   isCatTy Type
_ = Bool
False
   hasCatArg :: CoreExpr -> Bool
   hasCatArg :: CoreExpr -> Bool
hasCatArg ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType -> FunTy' Type
t Type
_) = Type -> Bool
isCatTy Type
t
   hasCatArg CoreExpr
_                       = Bool
False
   reCat :: ReExpr
   reCat :: ReExpr
reCat = -- (traceFail "reCat" <+ ) $
           -- 2017-10-17: disable catFun to see if everything still works
           ReExpr
transCatOp -- <+ catFun
   traceFail :: String -> ReExpr
   traceFail :: [Char] -> ReExpr
traceFail [Char]
str CoreExpr
a = [Char] -> SDoc -> Maybe CoreExpr -> Maybe CoreExpr
forall a. [Char] -> SDoc -> a -> a
dtrace [Char]
str (CoreExpr -> SDoc
pprWithType CoreExpr
a) Maybe CoreExpr
forall a. Maybe a
Nothing
   -- TODO: refactor transCatOp & isPartialCatOp
   -- TODO: phase out hasRules, since I'm using annotations instead
   isPseudoApp :: CoreExpr -> Bool
   isPseudoApp :: CoreExpr -> Bool
isPseudoApp (CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs -> (Var CoreBndr
v,[CoreExpr]
args)) =
     case CoreBndr -> Maybe Int
isPseudoFun CoreBndr
v of
       Just Int
n -> Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [CoreExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((CoreExpr -> Bool) -> [CoreExpr] -> [CoreExpr]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (CoreExpr -> Bool) -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Bool
isTyCoDictArg) [CoreExpr]
args)
       Maybe Int
Nothing -> Bool
False
   isPseudoApp CoreExpr
_ = Bool
False
   isPseudoFun :: Id -> Maybe Int
   isPseudoFun :: CoreBndr -> Maybe Int
isPseudoFun = (PseudoFun -> Int) -> Maybe PseudoFun -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PseudoFun -> Int
pseudoArgs (Maybe PseudoFun -> Maybe Int)
-> (CoreBndr -> Maybe PseudoFun) -> CoreBndr -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PseudoFun] -> Maybe PseudoFun
forall a. [a] -> Maybe a
listToMaybe ([PseudoFun] -> Maybe PseudoFun)
-> (CoreBndr -> [PseudoFun]) -> CoreBndr -> Maybe PseudoFun
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> [PseudoFun]
pseudoAnns
    where
      pseudoAnns :: Id -> [PseudoFun]
      pseudoAnns :: CoreBndr -> [PseudoFun]
pseudoAnns = ([Word8] -> PseudoFun) -> AnnEnv -> CoreAnnTarget -> [PseudoFun]
forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns [Word8] -> PseudoFun
forall a. Data a => [Word8] -> a
deserializeWithData AnnEnv
annotations (CoreAnnTarget -> [PseudoFun])
-> (CoreBndr -> CoreAnnTarget) -> CoreBndr -> [PseudoFun]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> CoreAnnTarget
forall name. name -> AnnTarget name
NamedTarget (Name -> CoreAnnTarget)
-> (CoreBndr -> Name) -> CoreBndr -> CoreAnnTarget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Name
varName
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
   optimizeCoercion :: Coercion -> Coercion
optimizeCoercion = OptCoercionOpts -> TCvSubst -> Coercion -> Coercion
optCoercion (DynFlags -> OptCoercionOpts
initOptCoercionOpts DynFlags
dflags) TCvSubst
emptyTCvSubst
#else
   optimizeCoercion = optCoercion dflags emptyTCvSubst
#endif
#if MIN_VERSION_GLASGOW_HASKELL(9,4,8,0)
   extendInScopeList :: Subst -> [CoreBndr] -> Subst
extendInScopeList = Subst -> [CoreBndr] -> Subst
extendSubstInScopeList
#endif
    -- | Substitute new subexpressions for variables in an expression. Drop any dead
    -- binders, which is handy as dead binders can appear with live binders of the
    -- same variable.
   subst :: [Var] -> [(Id,CoreExpr)] -> Unop CoreExpr
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
   -- substExpr / lookupIdSubst expects Vars to be in inScope, so pass it along
   subst :: [CoreBndr] -> [(CoreBndr, CoreExpr)] -> Unop CoreExpr
subst [CoreBndr]
vars [(CoreBndr, CoreExpr)]
ps = (() :: Constraint) => Subst -> Unop CoreExpr
Subst -> Unop CoreExpr
substExpr (((CoreBndr, CoreExpr) -> Subst -> Subst)
-> Subst -> [(CoreBndr, CoreExpr)] -> Subst
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CoreBndr, CoreExpr) -> Subst -> Subst
add (Subst -> [CoreBndr] -> Subst
extendInScopeList (InScopeSet -> Subst
mkEmptySubst (InScopeEnv -> InScopeSet
forall a b. (a, b) -> a
fst InScopeEnv
inScope)) [CoreBndr]
vars) [(CoreBndr, CoreExpr)]
ps')
#else
   subst vars ps = substExpr "subst" (foldr add emptySubst ps')
#endif
    where
      add :: (CoreBndr, CoreExpr) -> Subst -> Subst
add (CoreBndr
v,CoreExpr
new) Subst
sub = Subst -> CoreBndr -> CoreExpr -> Subst
extendIdSubst Subst
sub CoreBndr
v CoreExpr
new
      ps' :: [(CoreBndr, CoreExpr)]
ps' = ((CoreBndr, CoreExpr) -> Bool)
-> [(CoreBndr, CoreExpr)] -> [(CoreBndr, CoreExpr)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((CoreBndr, CoreExpr) -> Bool) -> (CoreBndr, CoreExpr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Bool
isDeadBinder (CoreBndr -> Bool)
-> ((CoreBndr, CoreExpr) -> CoreBndr)
-> (CoreBndr, CoreExpr)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreBndr, CoreExpr) -> CoreBndr
forall a b. (a, b) -> a
fst) [(CoreBndr, CoreExpr)]
ps
   eqTypeNormalising :: Type -> Type -> Maybe (Type, Type)
   eqTypeNormalising :: Type -> Type -> Maybe (Type, Type)
eqTypeNormalising Type
ty1 Type
ty2 =
     IO (Maybe (Type, Type)) -> Maybe (Type, Type)
forall a. IO a -> a
unsafePerformIO (HscEnv
-> DynFlags -> ModGuts -> Type -> Type -> IO (Maybe (Type, Type))
eqTypeM HscEnv
hsc_env DynFlags
dflags ModGuts
guts Type
ty1 Type
ty2)

substFriendly :: Bool -> CoreExpr -> Bool
-- substFriendly catClosed rhs
 --  \| pprTrace "substFriendly"
 --    (ppr ((catClosed,rhs),not (liftedExpr rhs),incompleteCatOp rhs,isTrivial rhs,isFunTy ty && not catClosed,isIntegerTy ty))
 --    False = undefined
 -- where
 --   ty = exprType rhs
substFriendly :: Bool -> CoreExpr -> Bool
substFriendly Bool
catClosed CoreExpr
rhs =
     Bool -> Bool
not (CoreExpr -> Bool
liftedExpr CoreExpr
rhs)
  --  || substFriendlyTy (exprType rhs)
  Bool -> Bool -> Bool
|| Type -> Bool
substFriendlyTy' ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
rhs) -- experiment
  Bool -> Bool -> Bool
|| CoreExpr -> Bool
incompleteCatOp CoreExpr
rhs
  Bool -> Bool -> Bool
|| -- pprTrace "isTrivial" (ppr rhs <+> text "-->" <+> ppr (isTrivial rhs))
     (CoreExpr -> Bool
isTrivial CoreExpr
rhs)
  Bool -> Bool -> Bool
|| Type -> Bool
isFunTy Type
ty Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
catClosed
  Bool -> Bool -> Bool
|| Type -> Bool
isIntegerTy Type
ty -- TODO: replace with something more general
  --  || isVarTyCos rhs
 where
   ty :: Type
ty = (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
rhs

isVarTyCos :: CoreExpr -> Bool
isVarTyCos :: CoreExpr -> Bool
isVarTyCos (CoreExpr -> (CoreExpr, [CoreExpr])
collectTyCoDictArgs -> (Var CoreBndr
_,[CoreExpr]
_)) = Bool
True
isVarTyCos CoreExpr
_ = Bool
False

-- Adapted from exprIsTrivial in CoreUtils. This version considers dictionaries
-- trivial as well as application of exl/exr.
isTrivial :: CoreExpr -> Bool
-- isTrivial e | pprTrace "isTrivial" (ppr e) False = undefined
isTrivial :: CoreExpr -> Bool
isTrivial (Var CoreBndr
_) = Bool
True -- See Note [Variables are trivial]
isTrivial (Type Type
_) = Bool
True
isTrivial (Coercion Coercion
_) = Bool
True
isTrivial (Lit Literal
lit) = Literal -> Bool
litIsTrivial Literal
lit
isTrivial (App (CoreExpr -> Bool
isTrivialCatOp -> Bool
True) CoreExpr
arg) = CoreExpr -> Bool
isTrivial CoreExpr
arg
isTrivial (App CoreExpr
e CoreExpr
arg) = CoreExpr -> Bool
isTyCoDictArg CoreExpr
arg Bool -> Bool -> Bool
&& CoreExpr -> Bool
isTrivial CoreExpr
e
isTrivial (Tick CoreTickish
_ CoreExpr
e) = CoreExpr -> Bool
isTrivial CoreExpr
e
isTrivial (Cast CoreExpr
e Coercion
_) = CoreExpr -> Bool
isTrivial CoreExpr
e
isTrivial (Lam CoreBndr
b CoreExpr
body) = Bool -> Bool
not (CoreBndr -> Bool
isRuntimeVar CoreBndr
b) Bool -> Bool -> Bool
&& CoreExpr -> Bool
isTrivial CoreExpr
body
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
isTrivial (Case CoreExpr
_ CoreBndr
_ Type
_ [Alt AltCon
DEFAULT [] CoreExpr
rhs]) = CoreExpr -> Bool
isTrivial CoreExpr
rhs
#else
isTrivial (Case _ _ _ [(DEFAULT,[],rhs)]) = isTrivial rhs
#endif
isTrivial (Case CoreExpr
e CoreBndr
_ Type
_ [Alt CoreBndr]
alts) = CoreExpr -> Bool
isTrivial CoreExpr
e Bool -> Bool -> Bool
&& (Alt CoreBndr -> Bool) -> [Alt CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (CoreExpr -> Bool
isTrivial (CoreExpr -> Bool)
-> (Alt CoreBndr -> CoreExpr) -> Alt CoreBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alt CoreBndr -> CoreExpr
forall b. Alt b -> Expr b
altRhs) [Alt CoreBndr]
alts
isTrivial CoreExpr
_ = Bool
False

incompleteCatOp :: CoreExpr -> Bool
-- incompleteCatOp e | dtrace "incompleteCatOp" (ppr e) False = undefined
incompleteCatOp :: CoreExpr -> Bool
incompleteCatOp e :: CoreExpr
e@(CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs -> (Var CoreBndr
_v, Type (TyConApp (TyCon -> Bool
isFunTyCon -> Bool
True) []) : [CoreExpr]
_rest))
  = -- pprTrace "incompleteCatOp v rest" (text (fqVarName v) <+> ppr rest) $
    Type -> Bool
isFunTy ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e)
incompleteCatOp CoreExpr
_ = Bool
False

-- Whether to substitute based on type. Experimental. This version: substitute
-- if a function or has a subst-friendly type argument (e.g., pair components).
substFriendlyTy :: Type -> Bool
substFriendlyTy :: Type -> Bool
substFriendlyTy (Type -> Maybe Type
coreView -> Just Type
ty) = Type -> Bool
substFriendlyTy Type
ty
substFriendlyTy ((() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe -> Just (TyCon
tc,[Type]
tys)) = TyCon -> Bool
isFunTyCon TyCon
tc Bool -> Bool -> Bool
|| (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Type -> Bool
substFriendlyTy [Type]
tys
substFriendlyTy Type
_ = Bool
False

-- This variant only checks if we're dealing with TypeRep expressions.
-- These are effectively dictionary constructions for Typeable, but aren't
-- applications of dictionary constructors.  We want the bindings for these
-- to let-float, definitely not turned into a beta redex.
substFriendlyTy' :: Type -> Bool
substFriendlyTy' :: Type -> Bool
substFriendlyTy' (TyConApp tc :: TyCon
tc@(TyCon -> Bool
isAlgTyCon -> Bool
True) [Type]
_) = TyCon -> Name
tyConName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeRepTyConName
substFriendlyTy' Type
_ = Bool
False

catModule :: String
catModule :: [Char]
catModule = [Char]
"ConCat.AltCat"

trnModule :: String
trnModule :: [Char]
trnModule = [Char]
"ConCat.Translators"

repModule :: String
repModule :: [Char]
repModule = [Char]
"ConCat.Rep"

boxModule :: String
boxModule :: [Char]
boxModule = [Char]
"ConCat.Rebox"

okTypeModule :: String
okTypeModule :: [Char]
okTypeModule = [Char]
"ConCat.OkType"

extModule :: String
extModule :: [Char]
extModule =  [Char]
"GHC.Exts"

isTrivialCatOp :: CoreExpr -> Bool
-- isTrivialCatOp = liftA2 (||) isSelection isAbstRepr
isTrivialCatOp :: CoreExpr -> Bool
isTrivialCatOp (CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs -> (Var CoreBndr
v,[CoreExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length -> Int
n))
  --  \| pprTrace "isTrivialCatOp" (ppr (v,n,isSelectorId v,isAbstReprId v)) True
  =    (CoreBndr -> Bool
isSelectorId CoreBndr
v Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5)  -- exl cat tya tyb dict ok
    Bool -> Bool -> Bool
|| (CoreBndr -> Bool
isAbstReprId CoreBndr
v Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4)  -- reprCf cat a r repCat
isTrivialCatOp CoreExpr
_ = Bool
False

isSelectorId :: Id -> Bool
isSelectorId :: CoreBndr -> Bool
isSelectorId CoreBndr
v = CoreBndr -> [Char]
fqVarName CoreBndr
v [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((([Char]
catModule [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".") [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]
"exl",[Char]
"exr"])

isAbstReprId :: Id -> Bool
isAbstReprId :: CoreBndr -> Bool
isAbstReprId CoreBndr
v = CoreBndr -> [Char]
fqVarName CoreBndr
v [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((([Char]
catModule [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".") [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]
"reprC",[Char]
"abstC"])

-- TODO: refactor

pprWithType :: CoreExpr -> SDoc
pprWithType :: CoreExpr -> SDoc
pprWithType = WithType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (WithType -> SDoc) -> (CoreExpr -> WithType) -> CoreExpr -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> WithType
withType
-- pprWithType e = ppr e <+> dcolon <+> ppr (exprType e)

pprWithExplicitType :: CoreExpr -> Type -> SDoc
pprWithExplicitType :: CoreExpr -> Type -> SDoc
pprWithExplicitType CoreExpr
e Type
ty = WithType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreExpr -> Type -> WithType
withExplicitType CoreExpr
e Type
ty)

pprWithType' :: CoreExpr -> SDoc
pprWithType' :: CoreExpr -> SDoc
pprWithType' CoreExpr
e = 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 ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e)

pprMbWithType :: Maybe CoreExpr -> SDoc
pprMbWithType :: Maybe CoreExpr -> SDoc
pprMbWithType = SDoc -> (CoreExpr -> SDoc) -> Maybe CoreExpr -> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> SDoc
text [Char]
"failed") CoreExpr -> SDoc
pprWithType

cccRuleName :: FastString
cccRuleName :: FastString
cccRuleName = [Char] -> FastString
fsLit [Char]
"toCcc'"

composeRuleName :: FastString
composeRuleName :: FastString
composeRuleName = [Char] -> FastString
fsLit [Char]
"compose/coerce"

evidenceRuleName :: FastString
evidenceRuleName :: FastString
evidenceRuleName = [Char] -> FastString
fsLit [Char]
"evidence annotation"

cccRules :: Maybe (IORef Int) -> FamInstEnvs -> CccEnv -> ModGuts -> AnnEnv -> DynFlags -> [CoreRule]
cccRules :: Maybe (IORef Int)
-> FamInstEnvs
-> CccEnv
-> ModGuts
-> AnnEnv
-> DynFlags
-> [CoreRule]
cccRules Maybe (IORef Int)
steps FamInstEnvs
famEnvs env :: CccEnv
env@(CccEnv {Bool
CoreBndr
TyCon
RuleBase
UniqSupply
UniqDFM TyCon CoreBndr
HscEnv
forall a. [Char] -> SDoc -> a -> a
dtrace :: CccEnv -> forall a. [Char] -> SDoc -> a -> a
cccV :: CccEnv -> CoreBndr
cccPV :: CccEnv -> CoreBndr
uncccV :: CccEnv -> CoreBndr
closedTc :: CccEnv -> TyCon
idV :: CccEnv -> CoreBndr
constV :: CccEnv -> CoreBndr
forkV :: CccEnv -> CoreBndr
applyV :: CccEnv -> CoreBndr
composeV :: CccEnv -> CoreBndr
curryV :: CccEnv -> CoreBndr
uncurryV :: CccEnv -> CoreBndr
ifV :: CccEnv -> CoreBndr
exlV :: CccEnv -> CoreBndr
exrV :: CccEnv -> CoreBndr
constFunV :: CccEnv -> CoreBndr
fmapV :: CccEnv -> CoreBndr
fmapT1V :: CccEnv -> CoreBndr
fmapT2V :: CccEnv -> CoreBndr
casePairTopTV :: CccEnv -> CoreBndr
casePairTV :: CccEnv -> CoreBndr
casePairLTV :: CccEnv -> CoreBndr
casePairRTV :: CccEnv -> CoreBndr
flipForkTV :: CccEnv -> CoreBndr
castConstTV :: CccEnv -> CoreBndr
reprCV :: CccEnv -> CoreBndr
abstCV :: CccEnv -> CoreBndr
coerceV :: CccEnv -> CoreBndr
bottomTV :: CccEnv -> CoreBndr
repTc :: CccEnv -> TyCon
prePostV :: CccEnv -> CoreBndr
boxers :: CccEnv -> UniqDFM TyCon CoreBndr
tagToEnumV :: CccEnv -> CoreBndr
bottomV :: CccEnv -> CoreBndr
boxIBV :: CccEnv -> CoreBndr
ifEqIntHash :: CccEnv -> CoreBndr
inlineV :: CccEnv -> CoreBndr
uniqSupply :: CccEnv -> UniqSupply
hsc_env :: CccEnv -> HscEnv
ruleBase :: CccEnv -> RuleBase
okTypeTc :: CccEnv -> TyCon
enablePolymorphism :: CccEnv -> Bool
dtrace :: forall a. [Char] -> SDoc -> a -> a
cccV :: CoreBndr
cccPV :: CoreBndr
uncccV :: CoreBndr
closedTc :: TyCon
idV :: CoreBndr
constV :: CoreBndr
forkV :: CoreBndr
applyV :: CoreBndr
composeV :: CoreBndr
curryV :: CoreBndr
uncurryV :: CoreBndr
ifV :: CoreBndr
exlV :: CoreBndr
exrV :: CoreBndr
constFunV :: CoreBndr
fmapV :: CoreBndr
fmapT1V :: CoreBndr
fmapT2V :: CoreBndr
casePairTopTV :: CoreBndr
casePairTV :: CoreBndr
casePairLTV :: CoreBndr
casePairRTV :: CoreBndr
flipForkTV :: CoreBndr
castConstTV :: CoreBndr
reprCV :: CoreBndr
abstCV :: CoreBndr
coerceV :: CoreBndr
bottomTV :: CoreBndr
repTc :: TyCon
prePostV :: CoreBndr
boxers :: UniqDFM TyCon CoreBndr
tagToEnumV :: CoreBndr
bottomV :: CoreBndr
boxIBV :: CoreBndr
ifEqIntHash :: CoreBndr
inlineV :: CoreBndr
uniqSupply :: UniqSupply
hsc_env :: HscEnv
ruleBase :: RuleBase
okTypeTc :: TyCon
enablePolymorphism :: Bool
..}) ModGuts
guts AnnEnv
annotations DynFlags
dflags =
  [ BuiltinRule { ru_name :: FastString
ru_name  = FastString
cccRuleName
                , ru_fn :: Name
ru_fn    = CoreBndr -> Name
varName CoreBndr
cccPV
                , ru_nargs :: Int
ru_nargs = Int
6  -- including type args
                , ru_try :: RuleFun
ru_try   = \ RuleOpts
_rOpts InScopeEnv
inScope CoreBndr
_fn ->
                                \ case
                                  -- _args | pprTrace "ccc ru_try args" (ppr _args) False -> undefined
                                  _es :: [CoreExpr]
_es@(Type Type
k : Type Type
_a : Type Type
_b : Type Type
evType : CoreExpr
ev : CoreExpr
arg : [CoreExpr]
_) ->
                                    -- pprTrace "ccc: going in" (ppr es) $
                                    -- ccc env (ops dflags inScope k) k arg
                                    Maybe (IORef Int) -> Maybe CoreExpr -> Maybe CoreExpr
forall a. Maybe (IORef Int) -> Unop (Maybe a)
unsafeLimit Maybe (IORef Int)
steps (Maybe CoreExpr -> Maybe CoreExpr)
-> Maybe CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$
                                      CccEnv -> Ops -> Type -> ReExpr
ccc CccEnv
env (DynFlags -> InScopeEnv -> Type -> CoreExpr -> Type -> Ops
ops DynFlags
dflags InScopeEnv
inScope Type
evType CoreExpr
ev Type
k) Type
k CoreExpr
arg
                                  [CoreExpr]
_args -> -- pprTrace "ccc ru_try mismatch args" (ppr _args) $
                                           Maybe CoreExpr
forall a. Maybe a
Nothing
                }
#if 0
  -- Are we still using the special composition rules?
  -- FIXME: needs a version with evidence argument
  , BuiltinRule { ru_name  = composeRuleName
                , ru_fn    = varName composeV
                , ru_nargs = 8  -- including type args and dicts
                , ru_try   = \ dflags inScope _fn ->
                                \ case
                                  [Type k, Type _b,Type _c, Type _a,_catDict,_ok,g,f] ->
                                       composeR env (ops dflags inScope k) g f
                                  _args -> -- pprTrace "compose/coerce ru_try args" (ppr _args) $
                                           Nothing
                }
#endif
  ]
  where
    ops :: DynFlags -> InScopeEnv -> Type -> CoreExpr -> Type -> Ops
ops = CccEnv
-> ModGuts
-> AnnEnv
-> FamInstEnvs
-> DynFlags
-> InScopeEnv
-> Type
-> CoreExpr
-> Type
-> Ops
mkOps CccEnv
env ModGuts
guts AnnEnv
annotations FamInstEnvs
famEnvs

evidencePass :: CccEnv -> ModGuts -> CoreM ModGuts
evidencePass :: CccEnv -> ModGuts -> CoreM ModGuts
evidencePass (CccEnv {Bool
CoreBndr
TyCon
RuleBase
UniqSupply
UniqDFM TyCon CoreBndr
HscEnv
forall a. [Char] -> SDoc -> a -> a
dtrace :: CccEnv -> forall a. [Char] -> SDoc -> a -> a
cccV :: CccEnv -> CoreBndr
cccPV :: CccEnv -> CoreBndr
uncccV :: CccEnv -> CoreBndr
closedTc :: CccEnv -> TyCon
idV :: CccEnv -> CoreBndr
constV :: CccEnv -> CoreBndr
forkV :: CccEnv -> CoreBndr
applyV :: CccEnv -> CoreBndr
composeV :: CccEnv -> CoreBndr
curryV :: CccEnv -> CoreBndr
uncurryV :: CccEnv -> CoreBndr
ifV :: CccEnv -> CoreBndr
exlV :: CccEnv -> CoreBndr
exrV :: CccEnv -> CoreBndr
constFunV :: CccEnv -> CoreBndr
fmapV :: CccEnv -> CoreBndr
fmapT1V :: CccEnv -> CoreBndr
fmapT2V :: CccEnv -> CoreBndr
casePairTopTV :: CccEnv -> CoreBndr
casePairTV :: CccEnv -> CoreBndr
casePairLTV :: CccEnv -> CoreBndr
casePairRTV :: CccEnv -> CoreBndr
flipForkTV :: CccEnv -> CoreBndr
castConstTV :: CccEnv -> CoreBndr
reprCV :: CccEnv -> CoreBndr
abstCV :: CccEnv -> CoreBndr
coerceV :: CccEnv -> CoreBndr
bottomTV :: CccEnv -> CoreBndr
repTc :: CccEnv -> TyCon
prePostV :: CccEnv -> CoreBndr
boxers :: CccEnv -> UniqDFM TyCon CoreBndr
tagToEnumV :: CccEnv -> CoreBndr
bottomV :: CccEnv -> CoreBndr
boxIBV :: CccEnv -> CoreBndr
ifEqIntHash :: CccEnv -> CoreBndr
inlineV :: CccEnv -> CoreBndr
uniqSupply :: CccEnv -> UniqSupply
hsc_env :: CccEnv -> HscEnv
ruleBase :: CccEnv -> RuleBase
okTypeTc :: CccEnv -> TyCon
enablePolymorphism :: CccEnv -> Bool
dtrace :: forall a. [Char] -> SDoc -> a -> a
cccV :: CoreBndr
cccPV :: CoreBndr
uncccV :: CoreBndr
closedTc :: TyCon
idV :: CoreBndr
constV :: CoreBndr
forkV :: CoreBndr
applyV :: CoreBndr
composeV :: CoreBndr
curryV :: CoreBndr
uncurryV :: CoreBndr
ifV :: CoreBndr
exlV :: CoreBndr
exrV :: CoreBndr
constFunV :: CoreBndr
fmapV :: CoreBndr
fmapT1V :: CoreBndr
fmapT2V :: CoreBndr
casePairTopTV :: CoreBndr
casePairTV :: CoreBndr
casePairLTV :: CoreBndr
casePairRTV :: CoreBndr
flipForkTV :: CoreBndr
castConstTV :: CoreBndr
reprCV :: CoreBndr
abstCV :: CoreBndr
coerceV :: CoreBndr
bottomTV :: CoreBndr
repTc :: TyCon
prePostV :: CoreBndr
boxers :: UniqDFM TyCon CoreBndr
tagToEnumV :: CoreBndr
bottomV :: CoreBndr
boxIBV :: CoreBndr
ifEqIntHash :: CoreBndr
inlineV :: CoreBndr
uniqSupply :: UniqSupply
hsc_env :: HscEnv
ruleBase :: RuleBase
okTypeTc :: TyCon
enablePolymorphism :: Bool
..}) ModGuts
guts = (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
bindsOnlyPass ((Bind CoreBndr -> CoreM (Bind CoreBndr))
-> CoreProgram -> CoreM CoreProgram
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
-> CoreBndr -> Int -> Bind CoreBndr -> CoreM (Bind CoreBndr)
annotateEvidence CoreBndr
cccV CoreBndr
cccPV Int
3)) ModGuts
guts

plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin { installCoreToDos :: CorePlugin
installCoreToDos = CorePlugin
install
                       , pluginRecompile :: [[Char]] -> IO PluginRecompile
pluginRecompile = [[Char]] -> IO PluginRecompile
purePlugin
                       }

-- Find an option "foo=bar" for optName "foo", returning a read of "bar".
parseOpt :: Read a => String -> [CommandLineOption] -> Maybe a
parseOpt :: forall a. Read a => [Char] -> [[Char]] -> Maybe a
parseOpt [Char]
optName = [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe ([a] -> Maybe a) -> ([[Char]] -> [a]) -> [[Char]] -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe a] -> [a]) -> ([[Char]] -> [Maybe a]) -> [[Char]] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Maybe a) -> [[Char]] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Maybe a
parse
 where
   parse :: [Char] -> Maybe a
parse = ([Char] -> a) -> Maybe [Char] -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> a
forall a. Read a => [Char] -> a
read (Maybe [Char] -> Maybe a)
-> ([Char] -> Maybe [Char]) -> [Char] -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix ([Char]
optName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"=")

install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install :: CorePlugin
install [[Char]]
opts [CoreToDo]
todos =
  do -- pprTrace ("CCC install " ++ show opts) empty (return ())
     DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
     -- Unfortunately, the plugin doesn't work in GHCi. Until fixed,
     -- disable under GHCi, so we can at least type-check conveniently.
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
     if DynFlags -> Backend
backend DynFlags
dflags Backend -> Backend -> Bool
forall a. Eq a => a -> a -> Bool
== Backend
Interpreter then
#else
     if hscTarget dflags == HscInterpreted then
#endif
        [CoreToDo] -> CoreM [CoreToDo]
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return [CoreToDo]
todos
      else
       do
          HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
          PackageFamInstEnv
pkgFamEnv <- CoreM PackageFamInstEnv
getPackageFamInstEnv
          CccEnv
env <- [[Char]] -> CoreM CccEnv
mkCccEnv [[Char]]
opts
          -- Add the rule after existing ones, so that automatically generated
          -- specialized ccc rules are tried first.
          let addCccRule, delCccRule :: ModGuts -> CoreM ModGuts
              addCccRule :: ModGuts -> CoreM ModGuts
addCccRule ModGuts
guts =
                -- pprTrace "Program binds before ccc" (ppr (mg_binds guts)) $
                do AnnEnv
allAnns <- IO AnnEnv -> CoreM AnnEnv
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> Maybe ModGuts -> IO AnnEnv
prepareAnnotations HscEnv
hsc_env (ModGuts -> Maybe ModGuts
forall a. a -> Maybe a
Just ModGuts
guts))
                   let famEnvs :: FamInstEnvs
famEnvs = (PackageFamInstEnv
pkgFamEnv, ModGuts -> PackageFamInstEnv
mg_fam_inst_env ModGuts
guts)
                       maxSteps :: Maybe (IORef Int)
maxSteps = (IO (IORef Int) -> IORef Int
forall a. IO a -> a
unsafePerformIO (IO (IORef Int) -> IORef Int)
-> (Int -> IO (IORef Int)) -> Int -> IORef Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef) (Int -> IORef Int) -> Maybe Int -> Maybe (IORef Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                  [Char] -> [[Char]] -> Maybe Int
forall a. Read a => [Char] -> [[Char]] -> Maybe a
parseOpt [Char]
"maxSteps" [[Char]]
opts
                   ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Unop [CoreRule] -> Unop ModGuts
on_mg_rules ([CoreRule] -> Unop [CoreRule]
forall a. [a] -> [a] -> [a]
++ Maybe (IORef Int)
-> FamInstEnvs
-> CccEnv
-> ModGuts
-> AnnEnv
-> DynFlags
-> [CoreRule]
cccRules Maybe (IORef Int)
maxSteps FamInstEnvs
famEnvs CccEnv
env ModGuts
guts AnnEnv
allAnns DynFlags
dflags) ModGuts
guts)
              delCccRule :: ModGuts -> CoreM ModGuts
delCccRule ModGuts
guts = ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Unop [CoreRule] -> Unop ModGuts
on_mg_rules ((CoreRule -> Bool) -> Unop [CoreRule]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (CoreRule -> Bool) -> CoreRule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreRule -> Bool
isCccRule)) ModGuts
guts)
              isCccRule :: CoreRule -> Bool
isCccRule CoreRule
r = CoreRule -> Bool
isBuiltinRule CoreRule
r Bool -> Bool -> Bool
&& CoreRule -> FastString
ru_name CoreRule
r FastString -> [FastString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FastString
cccRuleName,FastString
composeRuleName]
              -- isCCC r | is = pprTrace "delRule" (ppr cccRuleName) is
              --         \| otherwise = is
              --  where
              --    is = isBuiltinRule r && ru_name r == cccRuleName
              ([CoreToDo]
pre,[CoreToDo]
post) = -- (todos,[])
                           -- ([],todos)
                           Int -> [CoreToDo] -> ([CoreToDo], [CoreToDo])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
5 [CoreToDo]
todos  -- guess
                           -- (swap . (reverse *** reverse) . splitAt 1 . reverse) todos
              annotateEvidencePass :: CoreToDo
annotateEvidencePass = [Char] -> (ModGuts -> CoreM ModGuts) -> CoreToDo
CoreDoPluginPass [Char]
"evidence-annotate toCcc'" (CccEnv -> ModGuts -> CoreM ModGuts
evidencePass CccEnv
env)
              ours :: [CoreToDo]
ours = [ CoreToDo
annotateEvidencePass
                     , [Char] -> (ModGuts -> CoreM ModGuts) -> CoreToDo
CoreDoPluginPass [Char]
"Ccc insert rule" ModGuts -> CoreM ModGuts
addCccRule
                     , Int -> SimplMode -> CoreToDo
CoreDoSimplify Int
7 (HscEnv -> DynFlags -> SimplMode
mode HscEnv
hsc_env DynFlags
dflags)
                     , [Char] -> (ModGuts -> CoreM ModGuts) -> CoreToDo
CoreDoPluginPass [Char]
"Ccc remove rule" ModGuts -> CoreM ModGuts
delCccRule
                     , [Char] -> (ModGuts -> CoreM ModGuts) -> CoreToDo
CoreDoPluginPass [Char]
"Flag remaining ccc calls" (CccEnv -> ModGuts -> CoreM ModGuts
flagCcc CccEnv
env)
                     ]
          -- pprTrace "ccc pre-install todos:" (ppr todos) (return ())
          -- pprTrace "ccc post-install todos:" (ppr (pre ++ ours ++ post)) (return ())
          [CoreToDo] -> CoreM [CoreToDo]
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreToDo]
pre [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++ [CoreToDo]
ours [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++ [CoreToDo]
post)
 where
   flagCcc :: CccEnv -> CorePluginPass
   flagCcc :: CccEnv -> ModGuts -> CoreM ModGuts
flagCcc (CccEnv {Bool
CoreBndr
TyCon
RuleBase
UniqSupply
UniqDFM TyCon CoreBndr
HscEnv
forall a. [Char] -> SDoc -> a -> a
dtrace :: CccEnv -> forall a. [Char] -> SDoc -> a -> a
cccV :: CccEnv -> CoreBndr
cccPV :: CccEnv -> CoreBndr
uncccV :: CccEnv -> CoreBndr
closedTc :: CccEnv -> TyCon
idV :: CccEnv -> CoreBndr
constV :: CccEnv -> CoreBndr
forkV :: CccEnv -> CoreBndr
applyV :: CccEnv -> CoreBndr
composeV :: CccEnv -> CoreBndr
curryV :: CccEnv -> CoreBndr
uncurryV :: CccEnv -> CoreBndr
ifV :: CccEnv -> CoreBndr
exlV :: CccEnv -> CoreBndr
exrV :: CccEnv -> CoreBndr
constFunV :: CccEnv -> CoreBndr
fmapV :: CccEnv -> CoreBndr
fmapT1V :: CccEnv -> CoreBndr
fmapT2V :: CccEnv -> CoreBndr
casePairTopTV :: CccEnv -> CoreBndr
casePairTV :: CccEnv -> CoreBndr
casePairLTV :: CccEnv -> CoreBndr
casePairRTV :: CccEnv -> CoreBndr
flipForkTV :: CccEnv -> CoreBndr
castConstTV :: CccEnv -> CoreBndr
reprCV :: CccEnv -> CoreBndr
abstCV :: CccEnv -> CoreBndr
coerceV :: CccEnv -> CoreBndr
bottomTV :: CccEnv -> CoreBndr
repTc :: CccEnv -> TyCon
prePostV :: CccEnv -> CoreBndr
boxers :: CccEnv -> UniqDFM TyCon CoreBndr
tagToEnumV :: CccEnv -> CoreBndr
bottomV :: CccEnv -> CoreBndr
boxIBV :: CccEnv -> CoreBndr
ifEqIntHash :: CccEnv -> CoreBndr
inlineV :: CccEnv -> CoreBndr
uniqSupply :: CccEnv -> UniqSupply
hsc_env :: CccEnv -> HscEnv
ruleBase :: CccEnv -> RuleBase
okTypeTc :: CccEnv -> TyCon
enablePolymorphism :: CccEnv -> Bool
dtrace :: forall a. [Char] -> SDoc -> a -> a
cccV :: CoreBndr
cccPV :: CoreBndr
uncccV :: CoreBndr
closedTc :: TyCon
idV :: CoreBndr
constV :: CoreBndr
forkV :: CoreBndr
applyV :: CoreBndr
composeV :: CoreBndr
curryV :: CoreBndr
uncurryV :: CoreBndr
ifV :: CoreBndr
exlV :: CoreBndr
exrV :: CoreBndr
constFunV :: CoreBndr
fmapV :: CoreBndr
fmapT1V :: CoreBndr
fmapT2V :: CoreBndr
casePairTopTV :: CoreBndr
casePairTV :: CoreBndr
casePairLTV :: CoreBndr
casePairRTV :: CoreBndr
flipForkTV :: CoreBndr
castConstTV :: CoreBndr
reprCV :: CoreBndr
abstCV :: CoreBndr
coerceV :: CoreBndr
bottomTV :: CoreBndr
repTc :: TyCon
prePostV :: CoreBndr
boxers :: UniqDFM TyCon CoreBndr
tagToEnumV :: CoreBndr
bottomV :: CoreBndr
boxIBV :: CoreBndr
ifEqIntHash :: CoreBndr
inlineV :: CoreBndr
uniqSupply :: UniqSupply
hsc_env :: HscEnv
ruleBase :: RuleBase
okTypeTc :: TyCon
enablePolymorphism :: Bool
..}) ModGuts
guts
     | Bool
showCcc Bool -> Bool -> Bool
&& [Char] -> SDoc -> Bool -> Bool
forall a. [Char] -> SDoc -> a -> a
pprTrace [Char]
"ccc final:" (CoreProgram -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModGuts -> CoreProgram
mg_binds ModGuts
guts)) Bool
False = CoreM ModGuts
forall a. HasCallStack => a
undefined
     | Bool -> Bool
not (Seq CoreExpr -> Bool
forall a. Seq a -> Bool
Seq.null Seq CoreExpr
remaining) Bool -> Bool -> Bool
&&
       Bool
showResiduals Bool -> Bool -> Bool
&&
       [Char] -> SDoc -> Bool -> Bool
forall a. [Char] -> SDoc -> a -> a
pprTrace [Char]
"ccc residuals:" ([CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Seq CoreExpr -> [CoreExpr]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq CoreExpr
remaining)) Bool
False = CoreM ModGuts
forall a. HasCallStack => a
undefined
     | Bool
otherwise = ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
    where
      showCcc :: Bool
showCcc = [Char]
"showCcc" [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
opts
      showResiduals :: Bool
showResiduals = [Char]
"showResiduals" [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
opts
      remaining :: Seq CoreExpr
      remaining :: Seq CoreExpr
remaining = (CoreExpr -> Seq CoreExpr) -> GenericQ (Seq CoreExpr)
forall a m. (Data a, Monoid m) => (a -> m) -> GenericQ m
collectQ CoreExpr -> Seq CoreExpr
cccArgs (ModGuts -> CoreProgram
mg_binds ModGuts
guts)
      cccArgs :: CoreExpr -> Seq CoreExpr
      -- unVarApps :: CoreExpr -> Maybe (Id,[Type],[CoreExpr])
      -- ccc :: forall k a b. (a -> b) -> k a b
      -- cccArgs c@(unVarApps -> Just (v,_tys,[_])) | v == cccV = Seq.singleton c
      cccArgs :: CoreExpr -> Seq CoreExpr
cccArgs c :: CoreExpr
c@(CoreExpr -> Maybe (CoreBndr, [Type], [CoreExpr])
unVarApps -> Just (CoreBndr
v,[Type]
_tys,[CoreExpr
arg]))
        | CoreBndr
v CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
cccPV, Bool
enablePolymorphism Bool -> Bool -> Bool
|| CoreExpr -> Bool
isMono CoreExpr
arg = CoreExpr -> Seq CoreExpr
forall a. a -> Seq a
Seq.singleton CoreExpr
c
      cccArgs CoreExpr
_                                  = Seq CoreExpr
forall a. Monoid a => a
mempty
      -- cccArgs = const mempty  -- for now
      collectQ :: (Data a, Monoid m) => (a -> m) -> GenericQ m
      collectQ :: forall a m. (Data a, Monoid m) => (a -> m) -> GenericQ m
collectQ a -> m
f = (m -> m -> m) -> GenericQ m -> GenericQ m
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything m -> m -> m
forall a. Monoid a => a -> a -> a
mappend (m -> (a -> m) -> a -> m
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ m
forall a. Monoid a => a
mempty a -> m
f)
   -- Extra simplifier pass
   mode :: HscEnv -> DynFlags -> SimplMode
mode
     HscEnv
hsc_env
     DynFlags
dflags
        = SimplMode { sm_names :: [[Char]]
sm_names      = [[Char]
"Ccc simplifier pass"]
                    , sm_phase :: CompilerPhase
sm_phase      = Int -> CompilerPhase
Phase Int
2 -- avoid inlining i.e. Vector which is at phase 1
                    , sm_rules :: Bool
sm_rules      = Bool
True  -- important
                    , sm_inline :: Bool
sm_inline     = Bool
True -- False -- ??
                    , sm_eta_expand :: Bool
sm_eta_expand = Bool
False -- ??
                    , sm_case_case :: Bool
sm_case_case  = Bool
True
                    , sm_dflags :: DynFlags
sm_dflags     = DynFlags
dflags
#if MIN_VERSION_GLASGOW_HASKELL(9,2,2,0)
                    , sm_cast_swizzle :: Bool
sm_cast_swizzle = Bool
True
#endif
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
                    , sm_uf_opts :: UnfoldingOpts
sm_uf_opts    = DynFlags -> UnfoldingOpts
unfoldingOpts DynFlags
dflags
                    , sm_pre_inline :: Bool
sm_pre_inline = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SimplPreInlining DynFlags
dflags
                    , sm_logger :: Logger
sm_logger     = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
#endif
                    }

mkCccEnv :: [CommandLineOption] -> CoreM CccEnv
mkCccEnv :: [[Char]] -> CoreM CccEnv
mkCccEnv [[Char]]
opts = do
  -- liftIO $ putStrLn ("Options: " ++ show opts)
  HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
  let tracing :: Bool
tracing = [Char]
"trace" [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
opts
      dtrace :: String -> SDoc -> a -> a
      dtrace :: forall a. [Char] -> SDoc -> a -> a
dtrace [Char]
str SDoc
doc | Bool
tracing   = [Char] -> SDoc -> a -> a
forall a. [Char] -> SDoc -> a -> a
pprTrace [Char]
str SDoc
doc
                     | Bool
otherwise = a -> a
forall a. a -> a
id
      lookupRdr :: ModuleName -> (String -> OccName) -> (Name -> CoreM a) -> String -> CoreM a
      lookupRdr :: forall a.
ModuleName
-> ([Char] -> OccName) -> (Name -> CoreM a) -> [Char] -> CoreM a
lookupRdr ModuleName
modu [Char] -> OccName
mkOcc Name -> CoreM a
mkThing [Char]
str =
        CoreM a
-> ((Name, ModIface) -> CoreM a)
-> Maybe (Name, ModIface)
-> CoreM a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> CoreM a
forall a. [Char] -> a
panic [Char]
err) (Name, ModIface) -> CoreM a
forall {b}. (Name, b) -> CoreM a
mkThing' (Maybe (Name, ModIface) -> CoreM a)
-> CoreM (Maybe (Name, ModIface)) -> CoreM a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
          IO (Maybe (Name, ModIface)) -> CoreM (Maybe (Name, ModIface))
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> ModuleName -> RdrName -> IO (Maybe (Name, ModIface))
lookupRdrNameInModuleForPlugins HscEnv
hsc_env ModuleName
modu (OccName -> RdrName
Unqual ([Char] -> OccName
mkOcc [Char]
str)))
       where
         err :: [Char]
err = [Char]
"ccc installation: couldn't find "
               [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
str [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ModuleName -> [Char]
moduleNameString ModuleName
modu

         -- In GHC 8.6, lookupRdrNameInModuleForPlugins returns a (Name, Module)
         -- where earlier it was just a Name
         mkThing' :: (Name, b) -> CoreM a
mkThing' = Name -> CoreM a
mkThing (Name -> CoreM a) -> ((Name, b) -> Name) -> (Name, b) -> CoreM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, b) -> Name
forall a b. (a, b) -> a
fst

      lookupTh :: ([Char] -> OccName)
-> (Name -> CoreM a) -> [Char] -> [Char] -> CoreM a
lookupTh [Char] -> OccName
mkOcc Name -> CoreM a
mk [Char]
modu = ModuleName
-> ([Char] -> OccName) -> (Name -> CoreM a) -> [Char] -> CoreM a
forall a.
ModuleName
-> ([Char] -> OccName) -> (Name -> CoreM a) -> [Char] -> CoreM a
lookupRdr ([Char] -> ModuleName
mkModuleName [Char]
modu) [Char] -> OccName
mkOcc Name -> CoreM a
mk
      enablePolymorphism :: Bool
enablePolymorphism = [Char]
"enablePolymorphism" [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
opts
      findId :: [Char] -> [Char] -> CoreM CoreBndr
findId      = ([Char] -> OccName)
-> (Name -> CoreM CoreBndr) -> [Char] -> [Char] -> CoreM CoreBndr
forall {a}.
([Char] -> OccName)
-> (Name -> CoreM a) -> [Char] -> [Char] -> CoreM a
lookupTh [Char] -> OccName
mkVarOcc Name -> CoreM CoreBndr
forall (m :: * -> *). MonadThings m => Name -> m CoreBndr
lookupId
      findTc :: [Char] -> [Char] -> CoreM TyCon
findTc      = ([Char] -> OccName)
-> (Name -> CoreM TyCon) -> [Char] -> [Char] -> CoreM TyCon
forall {a}.
([Char] -> OccName)
-> (Name -> CoreM a) -> [Char] -> [Char] -> CoreM a
lookupTh [Char] -> OccName
mkTcOcc  Name -> CoreM TyCon
forall (m :: * -> *). MonadThings m => Name -> m TyCon
lookupTyCon
      -- findFloatTy = fmap mkTyConTy . findTc floatModule -- TODO: eliminate
      findCatId :: [Char] -> CoreM CoreBndr
findCatId   = [Char] -> [Char] -> CoreM CoreBndr
findId [Char]
catModule
      findTrnId :: [Char] -> CoreM CoreBndr
findTrnId   = [Char] -> [Char] -> CoreM CoreBndr
findId [Char]
trnModule
      findRepTc :: [Char] -> CoreM TyCon
findRepTc   = [Char] -> [Char] -> CoreM TyCon
findTc [Char]
repModule
      findOkTyTc :: [Char] -> CoreM TyCon
findOkTyTc  = [Char] -> [Char] -> CoreM TyCon
findTc [Char]
okTypeModule
      findRepId :: [Char] -> CoreM CoreBndr
findRepId   = [Char] -> [Char] -> CoreM CoreBndr
findId [Char]
repModule
      findBoxId :: [Char] -> CoreM CoreBndr
findBoxId   = [Char] -> [Char] -> CoreM CoreBndr
findId [Char]
boxModule
      findExtTc :: [Char] -> CoreM TyCon
findExtTc   = [Char] -> [Char] -> CoreM TyCon
findTc [Char]
extModule
      findExtId :: [Char] -> CoreM CoreBndr
findExtId   = [Char] -> [Char] -> CoreM CoreBndr
findId [Char]
extModule
  TyCon
closedTc      <- [Char] -> [Char] -> CoreM TyCon
findTc [Char]
catModule [Char]
"ClosedCat"
  CoreBndr
idV           <- [Char] -> CoreM CoreBndr
findCatId [Char]
"id"
  CoreBndr
constV        <- [Char] -> CoreM CoreBndr
findCatId [Char]
"const"
  CoreBndr
composeV      <- [Char] -> CoreM CoreBndr
findCatId [Char]
"."
  CoreBndr
exlV          <- [Char] -> CoreM CoreBndr
findCatId [Char]
"exl"
  CoreBndr
exrV          <- [Char] -> CoreM CoreBndr
findCatId [Char]
"exr"
  CoreBndr
forkV         <- [Char] -> CoreM CoreBndr
findCatId [Char]
"&&&"
  CoreBndr
applyV        <- [Char] -> CoreM CoreBndr
findCatId [Char]
"apply"
  CoreBndr
curryV        <- [Char] -> CoreM CoreBndr
findCatId [Char]
"curry"
  CoreBndr
uncurryV      <- [Char] -> CoreM CoreBndr
findCatId [Char]
"uncurry"
  CoreBndr
ifV           <- [Char] -> CoreM CoreBndr
findCatId [Char]
"ifC"
  CoreBndr
constFunV     <- [Char] -> CoreM CoreBndr
findCatId [Char]
"constFun"
  CoreBndr
abstCV        <- [Char] -> CoreM CoreBndr
findCatId [Char]
"abstC"
  CoreBndr
reprCV        <- [Char] -> CoreM CoreBndr
findCatId [Char]
"reprC"
  CoreBndr
coerceV       <- [Char] -> CoreM CoreBndr
findCatId [Char]
"coerceC"
  CoreBndr
cccV          <- [Char] -> CoreM CoreBndr
findCatId [Char]
"toCcc'"
  CoreBndr
cccPV         <- [Char] -> CoreM CoreBndr
findCatId [Char]
"toCcc''"
  CoreBndr
uncccV        <- [Char] -> CoreM CoreBndr
findCatId [Char]
"unCcc'"
  CoreBndr
fmapV         <- [Char] -> CoreM CoreBndr
findCatId [Char]
"fmapC"
  CoreBndr
fmapT1V       <- [Char] -> CoreM CoreBndr
findTrnId [Char]
"fmapT1"
  CoreBndr
fmapT2V       <- [Char] -> CoreM CoreBndr
findTrnId [Char]
"fmapT2"
  CoreBndr
casePairTopTV <- [Char] -> CoreM CoreBndr
findTrnId [Char]
"casePairTopT"
  CoreBndr
casePairTV    <- [Char] -> CoreM CoreBndr
findTrnId [Char]
"casePairT"
  CoreBndr
casePairLTV   <- [Char] -> CoreM CoreBndr
findTrnId [Char]
"casePairLT"
  CoreBndr
casePairRTV   <- [Char] -> CoreM CoreBndr
findTrnId [Char]
"casePairRT"
  CoreBndr
flipForkTV    <- [Char] -> CoreM CoreBndr
findTrnId [Char]
"flipForkT"
  CoreBndr
castConstTV   <- [Char] -> CoreM CoreBndr
findTrnId [Char]
"castConstT"
  CoreBndr
bottomTV      <- [Char] -> CoreM CoreBndr
findTrnId [Char]
"bottomT"
  TyCon
repTc         <- [Char] -> CoreM TyCon
findRepTc [Char]
"Rep"
  TyCon
okTypeTc      <- [Char] -> CoreM TyCon
findOkTyTc [Char]
"OkType"
  CoreBndr
prePostV      <- [Char] -> [Char] -> CoreM CoreBndr
findId [Char]
"ConCat.Misc" [Char]
"~>"
  CoreBndr
boxIV         <- [Char] -> CoreM CoreBndr
findBoxId [Char]
"boxI"
  CoreBndr
boxFV         <- [Char] -> CoreM CoreBndr
findBoxId [Char]
"boxF"
  CoreBndr
boxDV         <- [Char] -> CoreM CoreBndr
findBoxId [Char]
"boxD"
  CoreBndr
boxIBV        <- [Char] -> CoreM CoreBndr
findBoxId [Char]
"boxIB"
  CoreBndr
ifEqIntHash   <- [Char] -> CoreM CoreBndr
findBoxId [Char]
"ifEqInt#"
  CoreBndr
tagToEnumV    <- [Char] -> [Char] -> CoreM CoreBndr
findId [Char]
"GHC.Prim" [Char]
"tagToEnum#"
  CoreBndr
bottomV       <- [Char] -> [Char] -> CoreM CoreBndr
findId [Char]
"ConCat.Misc" [Char]
"bottom"
  CoreBndr
inlineV       <- [Char] -> CoreM CoreBndr
findExtId [Char]
"inline"
  UniqSupply
uniqSupply    <- CoreM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
  let mkPolyOp :: (String,(String,String)) -> CoreM (String,Var)
      mkPolyOp :: ([Char], ([Char], [Char])) -> CoreM ([Char], CoreBndr)
mkPolyOp ([Char]
stdName,([Char]
cmod,[Char]
cop)) =
        do CoreBndr
cv <- [Char] -> [Char] -> CoreM CoreBndr
findId [Char]
cmod [Char]
cop
           ([Char], CoreBndr) -> CoreM ([Char], CoreBndr)
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
stdName, CoreBndr
cv)
  RuleBase
ruleBase <- ExternalPackageState -> RuleBase
eps_rule_base (ExternalPackageState -> RuleBase)
-> CoreM ExternalPackageState -> CoreM RuleBase
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO ExternalPackageState -> CoreM ExternalPackageState
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExternalPackageState -> CoreM ExternalPackageState)
-> IO ExternalPackageState -> CoreM ExternalPackageState
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env)
  -- pprTrace "ruleBase" (ppr ruleBase) (return ())
#if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0)
  -- TODO: refactor to eliminate duplicate code here and elsewhere.
  let boxers :: UniqDFM TyCon CoreBndr
boxers = [(TyCon, CoreBndr)] -> UniqDFM TyCon CoreBndr
forall key elt. Uniquable key => [(key, elt)] -> UniqDFM key elt
DFMap.listToUDFM [(TyCon
intTyCon,CoreBndr
boxIV),(TyCon
doubleTyCon,CoreBndr
boxDV),(TyCon
floatTyCon,CoreBndr
boxFV)]
#else
  let boxers = OrdMap.fromList  [(intTyCon,boxIV),(doubleTyCon,boxDV),(floatTyCon,boxFV)]
#endif
  -- _ <- findId "GHC.Num" "subtract" -- help the plugin find instances for Float and Double

  -- toCcc' is defined to throw an exception, but this shouldn't matter as the plugin
  -- transforms calls to toCcc'.
  -- However, if ghc knows it throws an exception it elides calls to toCcc' before
  -- the plugin gets to it.
  -- See ConCat.Oops for the trick we're using to keep ghc from discoverng that toCcc'
  -- throws an exception.  Make sure here that it works.
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
  Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CoreBndr -> Bool
isDeadEndId CoreBndr
cccV) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> SDoc -> CoreM ()
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"isDeadEndId cccV" SDoc
empty
#else
  when (isBottomingId cccV) $
    pprPanic "isBottomingId cccV" empty
#endif
  CccEnv -> CoreM CccEnv
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CccEnv { Bool
CoreBndr
TyCon
RuleBase
UniqSupply
UniqDFM TyCon CoreBndr
HscEnv
[Char] -> SDoc -> a -> a
forall a. [Char] -> SDoc -> a -> a
dtrace :: forall a. [Char] -> SDoc -> a -> a
cccV :: CoreBndr
cccPV :: CoreBndr
uncccV :: CoreBndr
closedTc :: TyCon
idV :: CoreBndr
constV :: CoreBndr
forkV :: CoreBndr
applyV :: CoreBndr
composeV :: CoreBndr
curryV :: CoreBndr
uncurryV :: CoreBndr
ifV :: CoreBndr
exlV :: CoreBndr
exrV :: CoreBndr
constFunV :: CoreBndr
fmapV :: CoreBndr
fmapT1V :: CoreBndr
fmapT2V :: CoreBndr
casePairTopTV :: CoreBndr
casePairTV :: CoreBndr
casePairLTV :: CoreBndr
casePairRTV :: CoreBndr
flipForkTV :: CoreBndr
castConstTV :: CoreBndr
reprCV :: CoreBndr
abstCV :: CoreBndr
coerceV :: CoreBndr
bottomTV :: CoreBndr
repTc :: TyCon
prePostV :: CoreBndr
boxers :: UniqDFM TyCon CoreBndr
tagToEnumV :: CoreBndr
bottomV :: CoreBndr
boxIBV :: CoreBndr
ifEqIntHash :: CoreBndr
inlineV :: CoreBndr
uniqSupply :: UniqSupply
hsc_env :: HscEnv
ruleBase :: RuleBase
okTypeTc :: TyCon
enablePolymorphism :: Bool
hsc_env :: HscEnv
dtrace :: forall a. [Char] -> SDoc -> a -> a
enablePolymorphism :: Bool
closedTc :: TyCon
idV :: CoreBndr
constV :: CoreBndr
composeV :: CoreBndr
exlV :: CoreBndr
exrV :: CoreBndr
forkV :: CoreBndr
applyV :: CoreBndr
curryV :: CoreBndr
uncurryV :: CoreBndr
ifV :: CoreBndr
constFunV :: CoreBndr
abstCV :: CoreBndr
reprCV :: CoreBndr
coerceV :: CoreBndr
cccV :: CoreBndr
cccPV :: CoreBndr
uncccV :: CoreBndr
fmapV :: CoreBndr
fmapT1V :: CoreBndr
fmapT2V :: CoreBndr
casePairTopTV :: CoreBndr
casePairTV :: CoreBndr
casePairLTV :: CoreBndr
casePairRTV :: CoreBndr
flipForkTV :: CoreBndr
castConstTV :: CoreBndr
bottomTV :: CoreBndr
repTc :: TyCon
okTypeTc :: TyCon
prePostV :: CoreBndr
boxIBV :: CoreBndr
ifEqIntHash :: CoreBndr
tagToEnumV :: CoreBndr
bottomV :: CoreBndr
inlineV :: CoreBndr
uniqSupply :: UniqSupply
ruleBase :: RuleBase
boxers :: UniqDFM TyCon CoreBndr
.. })

-- Variables that have associated ccc rewrite rules in AltCat. If we have
-- sufficient arity for the rule, including types, give it a chance to kick in.
cccRuledArities :: OrdMap.Map String Int
cccRuledArities :: Map [Char] Int
cccRuledArities = [([Char], Int)] -> Map [Char] Int
forall k a. Ord k => [(k, a)] -> Map k a
OrdMap.fromList
  [([Char]
"Data.Tuple.curry",Int
4),([Char]
"Data.Tuple.uncurry",Int
4)]


-- Monomorphic operations. Given newtype-wrapped (Float,Double), yield an assoc
-- list from the fully qualified standard Haskell operation name to
-- * module name for categorical counterpart (always catModule now)
-- * categorical operation name
-- * type arguments to cat op
monoInfo :: [(String,(String,String,[Type]))]
monoInfo :: [([Char], ([Char], [Char], [Type]))]
monoInfo =
  [ ([Char]
hop,([Char]
catModule,[Char]
cop,[Type]
tyArgs))
  | ([Char]
cop,[([Char], [Type])]
ps) <- [([Char], [([Char], [Type])])]
info
  , ([Char]
hop,[Type]
tyArgs) <- [([Char], [Type])]
ps
  ]
 where
   -- (cat-name, [(std-name,cat-type-args)])
   info :: [(String, [(String, [Type])])]
   info :: [([Char], [([Char], [Type])])]
info =
     [ ([Char]
"notC",[Char] -> [([Char], [Type])]
forall {a}. [Char] -> [([Char], [a])]
boolOp [Char]
"not"), ([Char]
"andC",[Char] -> [([Char], [Type])]
forall {a}. [Char] -> [([Char], [a])]
boolOp [Char]
"&&"), ([Char]
"orC",[Char] -> [([Char], [Type])]
forall {a}. [Char] -> [([Char], [a])]
boolOp [Char]
"||")
     , ([Char]
"equal", [Char] -> Type -> ([Char], [Type])
eqOp [Char]
"==" (Type -> ([Char], [Type])) -> [Type] -> [([Char], [Type])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
ifd)
     , ([Char]
"notEqual", [Char] -> Type -> ([Char], [Type])
eqOp [Char]
"/=" (Type -> ([Char], [Type])) -> [Type] -> [([Char], [Type])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
ifd)
     , ([Char]
"lessThan", [Char] -> [Char] -> [([Char], [Type])]
compOps [Char]
"lt" [Char]
"<")
     , ([Char]
"greaterThan", [Char] -> [Char] -> [([Char], [Type])]
compOps [Char]
"gt" [Char]
">")
     , ([Char]
"lessThanOrEqual", [Char] -> [Char] -> [([Char], [Type])]
compOps [Char]
"le" [Char]
"<=")
     , ([Char]
"greaterThanOrEqual", [Char] -> [Char] -> [([Char], [Type])]
compOps [Char]
"ge" [Char]
">=")
#if 1
     , ([Char]
"negateC",[Char] -> [([Char], [Type])]
numOps [Char]
"negate"), ([Char]
"addC",[Char] -> [([Char], [Type])]
numOps [Char]
"+")
     , ([Char]
"subC",[Char] -> [([Char], [Type])]
numOps [Char]
"-"), ([Char]
"mulC",[Char] -> [([Char], [Type])]
numOps [Char]
"*")
#endif
       -- powIC
     -- , ("negateC",fdOps "negate"), ("addC",fdOps "plus")
     -- , ("subC",fdOps "minus"), ("mulC",fdOps "times")
     -- , ("recipC", fdOps "recip"), ("divideC", fdOps "divide")
     -- , ("expC", fdOps "exp") , ("cosC", fdOps "cos") , ("sinC", fdOps "sin")

     , ([Char]
"succC",[([Char]
"GHC.Enum.$fEnumInt_$csucc",[Type
intTy])])
     , ([Char]
"predC",[([Char]
"GHC.Enum.$fEnumInt_$cpred",[Type
intTy])])
     , ([Char]
"divC",[([Char]
"GHC.Real.$fIntegralInt_$cdiv",[Type
intTy])])
     , ([Char]
"modC",[([Char]
"GHC.Real.$fIntegralInt_$cmod",[Type
intTy])])
     --
     , ([Char]
"floorC",[([Char]
"GHC.Float.RealFracMethods.floorDoubleInt",[Type
doubleTy,Type
intTy])])
     , ([Char]
"ceilingC",[([Char]
"GHC.Float.RealFracMethods.ceilingDoubleInt",[Type
doubleTy,Type
intTy])])
     ]
    where
      ifd :: [Type]
ifd = Type
intTy Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
fd
      fd :: [Type]
fd = [Type
floatTy,Type
doubleTy]
      boolOp :: [Char] -> [([Char], [a])]
boolOp [Char]
op = [([Char]
"GHC.Classes."[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
op,[])]
      -- eqOp ty = ("GHC.Classes.eq"++pp ty,[ty])
      eqOp :: [Char] -> Type -> ([Char], [Type])
eqOp [Char]
op Type
ty = ([Char]
"GHC.Classes."[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
clsOp,[Type
ty])
       where
         tyName :: [Char]
tyName = Type -> [Char]
forall a. Outputable a => a -> [Char]
pp Type
ty
         clsOp :: [Char]
clsOp =
           case ([Char]
op,Type
ty) of
             ([Char]
"==",Type
_) -> [Char]
"eq"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
tyName
             ([Char]
"/=",Type -> Bool
isIntTy -> Bool
True) -> [Char]
"ne"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
tyName
             ([Char], Type)
_ -> [Char]
"$fEq"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
tyName[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"_$c"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
op
      compOps :: [Char] -> [Char] -> [([Char], [Type])]
compOps [Char]
opI [Char]
opFD = Type -> ([Char], [Type])
compOp (Type -> ([Char], [Type])) -> [Type] -> [([Char], [Type])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
ifd
       where
         compOp :: Type -> ([Char], [Type])
compOp Type
ty = ([Char]
"GHC.Classes."[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
clsOp,[Type
ty])
          where
            clsOp :: [Char]
clsOp | Type -> Bool
isIntTy Type
ty = [Char]
opI [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
tyName
                  | Bool
otherwise  = [Char]
"$fOrd" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
tyName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_$c" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
opFD
            tyName :: [Char]
tyName = Type -> [Char]
forall a. Outputable a => a -> [Char]
pp Type
ty
      numOps :: [Char] -> [([Char], [Type])]
numOps [Char]
op = Type -> ([Char], [Type])
numOp (Type -> ([Char], [Type])) -> [Type] -> [([Char], [Type])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
ifd
       where
         numOp :: Type -> ([Char], [Type])
numOp Type
ty = ([Char]
modu[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
".$fNum"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
tyName[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"_$c"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
op,[Type
ty])
          where
            tyName :: [Char]
tyName = Type -> [Char]
forall a. Outputable a => a -> [Char]
pp Type
ty
            modu :: [Char]
modu | Type -> Bool
isIntTy Type
ty = [Char]
"GHC.Num"
                 | Bool
otherwise  = [Char]
floatModule  -- Really?
      fdOps :: [Char] -> [([Char], [Type])]
fdOps [Char]
op = Type -> ([Char], [Type])
fdOp (Type -> ([Char], [Type])) -> [Type] -> [([Char], [Type])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
fd
       where
         fdOp :: Type -> (String, [Type])
         fdOp :: Type -> ([Char], [Type])
fdOp Type
ty = ([Char]
floatModule[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"."[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
op[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Type -> [Char]
forall a. Outputable a => a -> [Char]
pp Type
ty,[Type
ty]) -- GHC.Float.sinFloat

#if 0
-- An orphan instance to help me debug
instance Show Type where show = pp
#endif

floatModule :: String
floatModule :: [Char]
floatModule = [Char]
"GHC.Float"

--    fracOp op ty = ("GHC.Float.$fFractional"++pp ty++"_$c"++op,[ty])
--    floatingOp op ty = ("GHC.Float.$fFloating"++pp ty++"_$c"++op,[ty])

-- (==): eqInt, eqFloat, eqDouble
-- (/=): neInt, $fEqFloat_$c/=, $fEqDouble_$c/=
-- (<):  ltI, $fOrdFloat_$c<

pp :: Outputable a => a -> String
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
pp :: forall a. Outputable a => a -> [Char]
pp = a -> [Char]
forall a. Outputable a => a -> [Char]
showPprUnsafe
#else
pp = showPpr unsafeGlobalDynFlags
#endif

{--------------------------------------------------------------------
    Misc
--------------------------------------------------------------------}

on_mg_rules :: Unop [CoreRule] -> Unop ModGuts
on_mg_rules :: Unop [CoreRule] -> Unop ModGuts
on_mg_rules Unop [CoreRule]
f ModGuts
mg = ModGuts
mg { mg_rules :: [CoreRule]
mg_rules = Unop [CoreRule]
f (ModGuts -> [CoreRule]
mg_rules ModGuts
mg) }

fqVarName :: Var -> String
fqVarName :: CoreBndr -> [Char]
fqVarName = Name -> [Char]
qualifiedName (Name -> [Char]) -> (CoreBndr -> Name) -> CoreBndr -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Name
varName

uqVarName :: Var -> String
uqVarName :: CoreBndr -> [Char]
uqVarName = Name -> [Char]
forall a. NamedThing a => a -> [Char]
getOccString (Name -> [Char]) -> (CoreBndr -> Name) -> CoreBndr -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Name
varName

varModuleName :: Var -> Maybe String
varModuleName :: CoreBndr -> Maybe [Char]
varModuleName = Name -> Maybe [Char]
nameModuleName_maybe (Name -> Maybe [Char])
-> (CoreBndr -> Name) -> CoreBndr -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Name
varName

-- With dot
nameModuleName_maybe :: Name -> Maybe String
nameModuleName_maybe :: Name -> Maybe [Char]
nameModuleName_maybe =
  (GenModule Unit -> [Char])
-> Maybe (GenModule Unit) -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModuleName -> [Char]
moduleNameString (ModuleName -> [Char])
-> (GenModule Unit -> ModuleName) -> GenModule Unit -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName) (Maybe (GenModule Unit) -> Maybe [Char])
-> (Name -> Maybe (GenModule Unit)) -> Name -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe (GenModule Unit)
nameModule_maybe

-- Keep consistent with stripName in Exp.
uniqVarName :: Var -> String
uniqVarName :: CoreBndr -> [Char]
uniqVarName CoreBndr
v = CoreBndr -> [Char]
uqVarName CoreBndr
v [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Unique -> [Char]
forall a. Show a => a -> [Char]
show (CoreBndr -> Unique
varUnique CoreBndr
v)

-- Adapted from HERMIT.GHC
-- | Get the fully qualified name from a 'Name'.
qualifiedName :: Name -> String
qualifiedName :: Name -> [Char]
qualifiedName Name
nm =
  [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".") (Name -> Maybe [Char]
nameModuleName_maybe Name
nm) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. NamedThing a => a -> [Char]
getOccString Name
nm

onHead :: Unop a -> Unop [a]
onHead :: forall a. Unop a -> Unop [a]
onHead Unop a
f (a
c:[a]
cs) = Unop a
f a
c a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
cs
onHead Unop a
_ []     = []

collectTyArgs :: CoreExpr -> (CoreExpr,[Type])
collectTyArgs :: CoreExpr -> (CoreExpr, [Type])
collectTyArgs = [Type] -> CoreExpr -> (CoreExpr, [Type])
forall {b}. [Type] -> Expr b -> (Expr b, [Type])
go []
 where
   go :: [Type] -> Expr b -> (Expr b, [Type])
go [Type]
tys (App Expr b
e (Type Type
ty)) = [Type] -> Expr b -> (Expr b, [Type])
go (Type
tyType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
tys) Expr b
e
   go [Type]
tys Expr b
e                 = (Expr b
e,[Type]
tys)

collectTysDictsArgs :: CoreExpr -> (CoreExpr,[Type],[CoreExpr])
collectTysDictsArgs :: CoreExpr -> (CoreExpr, [Type], [CoreExpr])
collectTysDictsArgs CoreExpr
e = (CoreExpr
h,[Type]
tys,[CoreExpr]
dicts)
 where
   (CoreExpr
e',[CoreExpr]
dicts) = (CoreExpr -> Bool) -> CoreExpr -> (CoreExpr, [CoreExpr])
collectArgsPred CoreExpr -> Bool
isPred CoreExpr
e
   (CoreExpr
h,[Type]
tys)    = CoreExpr -> (CoreExpr, [Type])
collectTyArgs CoreExpr
e'

collectArgsPred :: (CoreExpr -> Bool) -> CoreExpr -> (CoreExpr,[CoreExpr])
collectArgsPred :: (CoreExpr -> Bool) -> CoreExpr -> (CoreExpr, [CoreExpr])
collectArgsPred CoreExpr -> Bool
p = [CoreExpr] -> CoreExpr -> (CoreExpr, [CoreExpr])
go []
 where
   go :: [CoreExpr] -> CoreExpr -> (CoreExpr, [CoreExpr])
go [CoreExpr]
args (App CoreExpr
fun CoreExpr
arg) | CoreExpr -> Bool
p CoreExpr
arg = [CoreExpr] -> CoreExpr -> (CoreExpr, [CoreExpr])
go (CoreExpr
argCoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
:[CoreExpr]
args) CoreExpr
fun
   go [CoreExpr]
args CoreExpr
e                     = (CoreExpr
e,[CoreExpr]
args)

collectTyCoDictArgs :: CoreExpr -> (CoreExpr,[CoreExpr])
collectTyCoDictArgs :: CoreExpr -> (CoreExpr, [CoreExpr])
collectTyCoDictArgs = (CoreExpr -> Bool) -> CoreExpr -> (CoreExpr, [CoreExpr])
collectArgsPred CoreExpr -> Bool
isTyCoDictArg

collectNonTyCoDictArgs :: CoreExpr -> (CoreExpr,[CoreExpr])
collectNonTyCoDictArgs :: CoreExpr -> (CoreExpr, [CoreExpr])
collectNonTyCoDictArgs = (CoreExpr -> Bool) -> CoreExpr -> (CoreExpr, [CoreExpr])
collectArgsPred (Bool -> Bool
not (Bool -> Bool) -> (CoreExpr -> Bool) -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Bool
isTyCoDictArg)

isTyCoDictArg :: CoreExpr -> Bool
isTyCoDictArg :: CoreExpr -> Bool
isTyCoDictArg CoreExpr
e = CoreExpr -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreExpr
e Bool -> Bool -> Bool
|| Type -> Bool
isPredTy' ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e)

-- isConApp :: CoreExpr -> Bool
-- isConApp (collectArgs -> (Var (isDataConId_maybe -> Just _), _)) = True
-- isConApp _ = False

-- TODO: More efficient isConApp, discarding args early.

isPred :: CoreExpr -> Bool
isPred :: CoreExpr -> Bool
isPred CoreExpr
e  = Bool -> Bool
not (CoreExpr -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreExpr
e) Bool -> Bool -> Bool
&& Type -> Bool
isPredTy' ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e)

stringExpr :: String -> CoreExpr
stringExpr :: [Char] -> CoreExpr
stringExpr = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Literal -> CoreExpr) -> ([Char] -> Literal) -> [Char] -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Literal
mkLitString

varNameExpr :: Id -> CoreExpr
varNameExpr :: CoreBndr -> CoreExpr
varNameExpr = [Char] -> CoreExpr
stringExpr ([Char] -> CoreExpr)
-> (CoreBndr -> [Char]) -> CoreBndr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> [Char]
uniqVarName

onCaseRhs :: Type -> Unop (Unop CoreExpr)
onCaseRhs :: Type -> Unop CoreExpr -> Unop CoreExpr
onCaseRhs Type
altsTy' Unop CoreExpr
f (Case CoreExpr
scrut CoreBndr
v Type
_ [Alt CoreBndr]
alts) =
  CoreExpr -> CoreBndr -> Type -> [Alt CoreBndr] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut CoreBndr
v Type
altsTy' (Unop CoreExpr -> Unop (Alt CoreBndr)
onAltRhs Unop CoreExpr
f Unop (Alt CoreBndr) -> [Alt CoreBndr] -> [Alt CoreBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Alt CoreBndr]
alts)
onCaseRhs Type
_ Unop CoreExpr
_ CoreExpr
e = [Char] -> SDoc -> CoreExpr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"onCaseRhs. Not a case: " (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e)

onAltRhs :: Unop CoreExpr -> Unop CoreAlt
onAltRhs :: Unop CoreExpr -> Unop (Alt CoreBndr)
onAltRhs Unop CoreExpr
f (Alt AltCon
con [CoreBndr]
bs CoreExpr
rhs) = AltCon -> [CoreBndr] -> CoreExpr -> Alt CoreBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [CoreBndr]
bs (Unop CoreExpr
f CoreExpr
rhs)

-- To help debug. Sometimes I'm unsure what constructor goes with what ppr.
coercionTag :: Coercion -> String
coercionTag :: Coercion -> [Char]
coercionTag Refl        {} = [Char]
"Refl"
coercionTag GRefl        {} = [Char]
"GRefl"
coercionTag FunCo       {} = [Char]
"FunCo" -- pattern synonym
coercionTag TyConAppCo  {} = [Char]
"TyConAppCo"
coercionTag AppCo       {} = [Char]
"AppCo"
coercionTag ForAllCo    {} = [Char]
"ForAllCo"
coercionTag CoVarCo     {} = [Char]
"CoVarCo"
coercionTag AxiomInstCo {} = [Char]
"AxiomInstCo"
coercionTag UnivCo      {} = [Char]
"UnivCo"
coercionTag SymCo       {} = [Char]
"SymCo"
coercionTag TransCo     {} = [Char]
"TransCo"
coercionTag AxiomRuleCo {} = [Char]
"AxiomRuleCo"
coercionTag NthCo       {} = [Char]
"NthCo"
coercionTag LRCo        {} = [Char]
"LRCo"
coercionTag InstCo      {} = [Char]
"InstCo"
coercionTag KindCo      {} = [Char]
"KindCo"
coercionTag SubCo       {} = [Char]
"SubCo"
coercionTag HoleCo      {} = [Char]
"HoleCo"

-- TODO: Should I unfold (inline application head) earlier? Doing so might
-- result in much simpler generated code by avoiding many beta-redexes. If I
-- do, take care not to inline "primitives". I think it'd be fairly easy.

-- Try to inline an identifier.
-- TODO: Also class ops
inlineId :: Id -> Maybe CoreExpr
-- inlineId v | pprTrace ("inlineId " ++ fqVarName v) (ppr (realIdUnfolding v)) False = undefined
-- inlineId v | pprTrace ("inlineId " ++ uqVarName v) (ppr (maybeUnfoldingTemplate (realIdUnfolding v))) False = undefined
inlineId :: CoreBndr -> Maybe CoreExpr
inlineId CoreBndr
v = Unfolding -> Maybe CoreExpr
maybeUnfoldingTemplate (CoreBndr -> Unfolding
realIdUnfolding CoreBndr
v)  -- idUnfolding

-- Adapted from Andrew Farmer's getUnfoldingsT in HERMIT.Dictionary.Inline:
inlineClassOp :: Id -> Maybe CoreExpr
inlineClassOp :: CoreBndr -> Maybe CoreExpr
inlineClassOp CoreBndr
v =
  case CoreBndr -> IdDetails
idDetails CoreBndr
v of
    ClassOpId Class
cls -> Class -> Int -> CoreExpr
mkDictSelRhs Class
cls (Int -> CoreExpr) -> Maybe Int -> Maybe CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreBndr -> [CoreBndr] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex CoreBndr
v (Class -> [CoreBndr]
classAllSelIds Class
cls)
    IdDetails
_             -> Maybe CoreExpr
forall a. Maybe a
Nothing

-- TODO: reconcile with inlineClassOp from ConCat.Inline.ClassOp

exprHead :: CoreExpr -> Maybe Id
exprHead :: CoreExpr -> Maybe CoreBndr
exprHead (Var CoreBndr
v)     = CoreBndr -> Maybe CoreBndr
forall a. a -> Maybe a
Just CoreBndr
v
exprHead (App CoreExpr
fun CoreExpr
_) = CoreExpr -> Maybe CoreBndr
exprHead CoreExpr
fun
exprHead (Cast CoreExpr
e Coercion
_)  = CoreExpr -> Maybe CoreBndr
exprHead CoreExpr
e
exprHead CoreExpr
_           = Maybe CoreBndr
forall a. Maybe a
Nothing

onExprHead :: DynFlags -> (Id -> Maybe CoreExpr) -> ReExpr
onExprHead :: DynFlags -> (CoreBndr -> Maybe CoreExpr) -> ReExpr
onExprHead DynFlags
_dflags CoreBndr -> Maybe CoreExpr
h = ((Maybe CoreExpr -> Maybe CoreExpr) -> Unop ReExpr
forall a b. (a -> b) -> (CoreExpr -> a) -> CoreExpr -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap((Maybe CoreExpr -> Maybe CoreExpr) -> Unop ReExpr)
-> (Unop CoreExpr -> Maybe CoreExpr -> Maybe CoreExpr)
-> Unop CoreExpr
-> Unop ReExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Unop CoreExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Unop CoreExpr
simpleOptExpr' Unop ReExpr -> Unop ReExpr
forall a b. (a -> b) -> a -> b
$
                       Unop CoreExpr -> ReExpr
forall {c}. (CoreExpr -> c) -> CoreExpr -> Maybe c
go Unop CoreExpr
forall a. a -> a
id
 where
   go :: (CoreExpr -> c) -> CoreExpr -> Maybe c
go CoreExpr -> c
cont (Var CoreBndr
v)       = CoreExpr -> c
cont (CoreExpr -> c) -> Maybe CoreExpr -> Maybe c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreBndr -> Maybe CoreExpr
h CoreBndr
v
   go CoreExpr -> c
cont (App CoreExpr
fun CoreExpr
arg) = (CoreExpr -> c) -> CoreExpr -> Maybe c
go (CoreExpr -> c
cont (CoreExpr -> c) -> Unop CoreExpr -> CoreExpr -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
arg)) CoreExpr
fun
   go CoreExpr -> c
cont (Cast CoreExpr
e Coercion
co)   = (CoreExpr -> c) -> CoreExpr -> Maybe c
go (CoreExpr -> c
cont (CoreExpr -> c) -> Unop CoreExpr -> CoreExpr -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
`Cast` Coercion
co)) CoreExpr
e
   go CoreExpr -> c
_ CoreExpr
_                = Maybe c
forall a. Maybe a
Nothing

#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
   simpleOptExpr' :: Unop CoreExpr
simpleOptExpr' = (() :: Constraint) => SimpleOpts -> Unop CoreExpr
SimpleOpts -> Unop CoreExpr
simpleOptExpr (DynFlags -> SimpleOpts
initSimpleOpts DynFlags
_dflags)
#else
   simpleOptExpr' = simpleOptExpr _dflags
#endif

-- TODO: try go using Maybe fmap instead of continuation.

-- The simpleOptExpr here helped keep simplification going.
-- TODO: try without.

-- Identifier not occurring in a given variable set
freshId :: VarSet -> String -> Type -> Id
freshId :: VarSet -> [Char] -> Type -> CoreBndr
freshId VarSet
used [Char]
nm Type
ty =
  InScopeSet -> CoreBndr -> CoreBndr
uniqAway (VarSet -> InScopeSet
mkInScopeSet VarSet
used) (CoreBndr -> CoreBndr) -> CoreBndr -> CoreBndr
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
  FastString -> Unique -> Type -> Type -> CoreBndr
mkSysLocal ([Char] -> FastString
fsLit [Char]
nm) (Int -> Unique
mkBuiltinUnique Int
17) Type
Many Type
ty
#else
  mkSysLocal (fsLit nm) (mkBuiltinUnique 17) ty
#endif

freshDeadId :: VarSet -> String -> Type -> Id
freshDeadId :: VarSet -> [Char] -> Type -> CoreBndr
freshDeadId VarSet
used [Char]
nm Type
ty = CoreBndr -> OccInfo -> CoreBndr
setIdOccInfo (VarSet -> [Char] -> Type -> CoreBndr
freshId VarSet
used [Char]
nm Type
ty) OccInfo
IAmDead

infixl 3 <+
(<+) :: Binop (a -> Maybe b)
<+ :: forall a b. Binop (a -> Maybe b)
(<+) = (Maybe b -> Maybe b -> Maybe b)
-> (a -> Maybe b) -> (a -> Maybe b) -> a -> Maybe b
forall a b c. (a -> b -> c) -> (a -> a) -> (a -> b) -> a -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Maybe b -> Maybe b -> Maybe b
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

apps :: CoreExpr -> [Type] -> [CoreExpr] -> CoreExpr
apps :: CoreExpr -> [Type] -> [CoreExpr] -> CoreExpr
apps CoreExpr
e [Type]
tys [CoreExpr]
es = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
e ((Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> CoreExpr
forall b. Type -> Expr b
Type [Type]
tys [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
es)

varApps :: Id -> [Type] -> [CoreExpr] -> CoreExpr
varApps :: CoreBndr -> [Type] -> [CoreExpr] -> CoreExpr
varApps = CoreExpr -> [Type] -> [CoreExpr] -> CoreExpr
apps (CoreExpr -> [Type] -> [CoreExpr] -> CoreExpr)
-> (CoreBndr -> CoreExpr)
-> CoreBndr
-> [Type]
-> [CoreExpr]
-> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var

conApps :: DataCon -> [Type] -> [CoreExpr] -> CoreExpr
conApps :: DataCon -> [Type] -> [CoreExpr] -> CoreExpr
conApps = CoreBndr -> [Type] -> [CoreExpr] -> CoreExpr
varApps (CoreBndr -> [Type] -> [CoreExpr] -> CoreExpr)
-> (DataCon -> CoreBndr)
-> DataCon
-> [Type]
-> [CoreExpr]
-> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> CoreBndr
dataConWorkId

-- Split into Var head, type arguments, and other arguments (breaking at first
-- non-type).
unVarApps :: CoreExpr -> Maybe (Id,[Type],[CoreExpr])
unVarApps :: CoreExpr -> Maybe (CoreBndr, [Type], [CoreExpr])
unVarApps (CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs -> (Var CoreBndr
v,[CoreExpr]
allArgs)) = (CoreBndr, [Type], [CoreExpr])
-> Maybe (CoreBndr, [Type], [CoreExpr])
forall a. a -> Maybe a
Just (CoreBndr
v,[Type]
tys,[CoreExpr]
others)
 where
   ([Type]
tys,[CoreExpr]
others) = ([CoreExpr] -> [Type])
-> ([CoreExpr], [CoreExpr]) -> ([Type], [CoreExpr])
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((CoreExpr -> Type) -> [CoreExpr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map CoreExpr -> Type
forall {b}. OutputableBndr b => Expr b -> Type
unType) ((CoreExpr -> Bool) -> [CoreExpr] -> ([CoreExpr], [CoreExpr])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span CoreExpr -> Bool
forall b. Expr b -> Bool
isTypeArg [CoreExpr]
allArgs)
   unType :: Expr b -> Type
unType (Type Type
t) = Type
t
   unType Expr b
e        = [Char] -> SDoc -> Type
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"unVarApps - unType" (Expr b -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr b
e)
unVarApps CoreExpr
_ = Maybe (CoreBndr, [Type], [CoreExpr])
forall a. Maybe a
Nothing

isFreeIn :: Var -> CoreExpr -> Bool
CoreBndr
v isFreeIn :: CoreBndr -> CoreExpr -> Bool
`isFreeIn` CoreExpr
e = CoreBndr
v CoreBndr -> VarSet -> Bool
`elemVarSet` (CoreExpr -> VarSet
exprFreeVars CoreExpr
e)

isFreeIns :: Var -> [CoreExpr] -> Bool
CoreBndr
v isFreeIns :: CoreBndr -> [CoreExpr] -> Bool
`isFreeIns` [CoreExpr]
es = (CoreExpr -> Bool) -> [CoreExpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (CoreBndr
v CoreBndr -> CoreExpr -> Bool
`isFreeIn`) [CoreExpr]
es

-- exprFreeVars :: CoreExpr -> VarSet
-- elemVarSet      :: Var -> VarSet -> Bool

pairTy :: Binop Type
pairTy :: Type -> Type -> Type
pairTy Type
a Type
b = [Type] -> Type
mkBoxedTupleTy [Type
a,Type
b]

etaReduce_maybe :: ReExpr
etaReduce_maybe :: ReExpr
etaReduce_maybe (Lam CoreBndr
x (App CoreExpr
e (Var CoreBndr
y))) | CoreBndr
x CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
y Bool -> Bool -> Bool
&& Bool -> Bool
not (CoreBndr
x CoreBndr -> CoreExpr -> Bool
`isFreeIn` CoreExpr
e) = ReExpr
forall a. a -> Maybe a
Just CoreExpr
e
etaReduce_maybe CoreExpr
_ = Maybe CoreExpr
forall a. Maybe a
Nothing

-- TODO: phase out etaReduce1 and etaReduce1N in favor of etaReduce_maybe.
-- Then rename etaReduce_maybe to "etaReduce"
etaReduce1 :: Unop CoreExpr
etaReduce1 :: Unop CoreExpr
etaReduce1 CoreExpr
e = CoreExpr -> Maybe CoreExpr -> CoreExpr
forall a. a -> Maybe a -> a
fromMaybe CoreExpr
e (ReExpr
etaReduce_maybe CoreExpr
e)

etaReduceN :: Unop CoreExpr
etaReduceN :: Unop CoreExpr
etaReduceN (Lam CoreBndr
x (Unop CoreExpr
etaReduceN -> CoreExpr
body')) = Unop CoreExpr
etaReduce1 (CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
body')
etaReduceN CoreExpr
e = CoreExpr
e

-- The function category
funCat :: Cat
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
funCat :: Type
funCat = TyCon -> [Type] -> Type
mkTyConApp TyCon
funTyCon [Type
Many, Type
liftedRepTy, Type
liftedRepTy]
#else
funCat = mkTyConApp funTyCon [liftedRepDataConTy, liftedRepDataConTy]
#endif

liftedExpr :: CoreExpr -> Bool
liftedExpr :: CoreExpr -> Bool
liftedExpr CoreExpr
e = Bool -> Bool
not (CoreExpr -> Bool
isTyCoDictArg CoreExpr
e) Bool -> Bool -> Bool
&& Type -> Bool
liftedType ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e)

liftedType :: Type -> Bool
liftedType :: Type -> Bool
liftedType = Type -> Bool
isLiftedTypeKind (Type -> Bool) -> (Type -> Type) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => Type -> Type
Type -> Type
typeKind

pattern PairVar :: CoreExpr
pattern $mPairVar :: forall {r}. CoreExpr -> ((# #) -> r) -> ((# #) -> r) -> r
PairVar <- Var (isPairVar -> True)
                   -- Var PairVarName
                   -- Var (fqVarName -> "GHC.Tuple.(,)")

isPairVar :: Var -> Bool
isPairVar :: CoreBndr -> Bool
isPairVar = ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"GHC.Tuple.(,)") ([Char] -> Bool) -> (CoreBndr -> [Char]) -> CoreBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> [Char]
fqVarName

isMonoTy :: Type -> Bool
isMonoTy :: Type -> Bool
isMonoTy (TyConApp TyCon
_ [Type]
tys) = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isMonoTy [Type]
tys
isMonoTy (AppTy Type
u Type
v)      = Type -> Bool
isMonoTy Type
u Bool -> Bool -> Bool
&& Type -> Bool
isMonoTy Type
v
isMonoTy (FunTy' Type
u Type
v)     = Type -> Bool
isMonoTy Type
u Bool -> Bool -> Bool
&& Type -> Bool
isMonoTy Type
v
isMonoTy (LitTy TyLit
_)        = Bool
True
isMonoTy Type
_                = Bool
False

isMono :: CoreExpr -> Bool
isMono :: CoreExpr -> Bool
isMono = Type -> Bool
isMonoTy (Type -> Bool) -> (CoreExpr -> Type) -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType

-- isMonoTy t | pprTrace "isMonoTy" (ppr t) False = undefined

-- | Number of occurrences of a given Id in an expression.
-- Gives a large value if the Id appears under a lambda.
idOccs :: Bool -> Id -> CoreExpr -> Int
idOccs :: Bool -> CoreBndr -> CoreExpr -> Int
idOccs Bool
penalizeUnderLambda CoreBndr
x = CoreExpr -> Int
go
 where
   lamFactor :: Int
lamFactor | Bool
penalizeUnderLambda = Int
100
             | Bool
otherwise           = Int
1
   -- go e | pprTrace "idOccs go" (ppr e) False = undefined
   go :: CoreExpr -> Int
go (Type Type
_)                 = Int
0
   go (Coercion Coercion
_)             = Int
0
   go _e :: CoreExpr
_e@((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType -> Type -> Bool
isPredTy' -> Bool
True)
     -- \| pprTrace "idOccs predicate" (pprWithType _e) False = undefined
     = Int
0
   go (Lit Literal
_)                  = Int
0
   go (Var CoreBndr
y)      | CoreBndr
y CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
x    = -- pprTrace "idOccs found" (ppr y) $
                                 Int
1
                   | Bool
otherwise = Int
0
   go (App CoreExpr
u CoreExpr
v)                = CoreExpr -> Int
go CoreExpr
u Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CoreExpr -> Int
go CoreExpr
v
   go (Tick CoreTickish
_ CoreExpr
e)               = CoreExpr -> Int
go CoreExpr
e
   go (Cast CoreExpr
e Coercion
_)               = CoreExpr -> Int
go CoreExpr
e
   go (Lam CoreBndr
y CoreExpr
body) | CoreBndr
y CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
x    = Int
0
                   | Bool
otherwise = Int
lamFactor Int -> Int -> Int
forall a. Num a => a -> a -> a
* CoreExpr -> Int
go CoreExpr
body
   go (Let Bind CoreBndr
bind CoreExpr
body)          = Bind CoreBndr -> Int
goBind Bind CoreBndr
bind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CoreExpr -> Int
go CoreExpr
body
   go (Case CoreExpr
e CoreBndr
_ Type
_ [Alt CoreBndr]
alts)        = CoreExpr -> Int
go CoreExpr
e Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Alt CoreBndr -> Int
goAlt (Alt CoreBndr -> Int) -> [Alt CoreBndr] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Alt CoreBndr]
alts)
   goBind :: Bind CoreBndr -> Int
goBind (NonRec CoreBndr
y CoreExpr
rhs) = (CoreBndr, CoreExpr) -> Int
goB (CoreBndr
y,CoreExpr
rhs)
   goBind (Rec [(CoreBndr, CoreExpr)]
ps)       = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((CoreBndr, CoreExpr) -> Int
goB ((CoreBndr, CoreExpr) -> Int) -> [(CoreBndr, CoreExpr)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(CoreBndr, CoreExpr)]
ps)
   goB :: (CoreBndr, CoreExpr) -> Int
goB (CoreBndr
y,CoreExpr
rhs) | CoreBndr
y CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
x    = Int
0
               | Bool
otherwise = CoreExpr -> Int
go CoreExpr
rhs
   -- goAlt alt | pprTrace "idOccs goAlt" (ppr alt) False = undefined
   goAlt :: Alt CoreBndr -> Int
goAlt (Alt AltCon
_ [CoreBndr]
ys CoreExpr
rhs) | CoreBndr
x CoreBndr -> [CoreBndr] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CoreBndr]
ys = Int
0
                    | Bool
otherwise   = CoreExpr -> Int
go CoreExpr
rhs

-- GHC's isPredTy says "no" to unboxed tuples of pred types.
isPredTy' :: Type -> Bool
-- isPredTy' ty | pprTrace "isPredTy'" (ppr (ty,isPredTy ty,splitTyConApp_maybe ty)) False = undefined
isPredTy' :: Type -> Bool
isPredTy' Type
ty = (() :: Constraint) => Type -> Bool
Type -> Bool
isPredTy Type
ty Bool -> Bool -> Bool
|| Type -> Bool
others Type
ty
 where
   others :: Type -> Bool
others ((() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe -> Just (TyCon
tc,[Type]
tys)) =
     -- pprTrace "isPredTy' tyCon arity" (ppr (tyConArity tc)) $
     -- The first half of the arguments are representation types ('PtrRepLifted)
     TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc Bool -> Bool -> Bool
&& (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isPredTy' (Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [Type]
tys)
   others Type
_ = Bool
False

starKind :: Kind
starKind :: Type
starKind = Type
liftedTypeKind

castE :: Coercion -> CoreExpr
castE :: Coercion -> CoreExpr
castE Coercion
co = CoreBndr -> Unop CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x (CoreExpr -> Coercion -> CoreExpr
mkCast (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
x) Coercion
co)
 where
   x :: CoreBndr
x = VarSet -> [Char] -> Type -> CoreBndr
freshId VarSet
emptyVarSet [Char]
"w" Type
dom
   Pair Type
dom Type
_ = Coercion -> Pair Type
coercionKind Coercion
co

pprCoWithType :: Coercion -> SDoc
pprCoWithType :: Coercion -> SDoc
pprCoWithType Coercion
co = Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Coercion -> Type
coercionType Coercion
co)

setNominalRole_maybe' :: Coercion -> Maybe Coercion
setNominalRole_maybe' :: Rewrite Coercion
setNominalRole_maybe' Coercion
c = Role -> Rewrite Coercion
setNominalRole_maybe (Coercion -> Role
coercionRole Coercion
c) Coercion
c

-- Exists somewhere?
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe :: forall a b. Either a b -> Maybe b
eitherToMaybe = (a -> Maybe b) -> (b -> Maybe b) -> Either a b -> Maybe b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe b -> a -> Maybe b
forall a b. a -> b -> a
const Maybe b
forall a. Maybe a
Nothing) b -> Maybe b
forall a. a -> Maybe a
Just

altRhs :: Alt b -> Expr b
altRhs :: forall b. Alt b -> Expr b
altRhs (Alt AltCon
_ [b]
_ Expr b
rhs) = Expr b
rhs

altVars :: Alt b -> [b]
altVars :: forall b. Alt b -> [b]
altVars (Alt AltCon
_ [b]
bs Expr b
_) = [b]
bs

isCast :: Expr b -> Bool
isCast :: forall b. Expr b -> Bool
isCast (Cast {}) = Bool
True
isCast Expr b
_         = Bool
False

-- | Monadic variation on everywhere (bottom-up)
-- everywhereM :: Monad m => GenericM m -> GenericM m
-- everywhereM f = f <=< gmapM (everywhereM2 f)

-- | Monadic variation on everywhere' (top-down)
everywhereM' :: Monad m => GenericM m -> GenericM m
everywhereM' :: forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM' GenericM m
f = GenericM m -> a -> m a
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a
gmapM (GenericM m -> GenericM m
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM' a -> m a
GenericM m
f) (a -> m a) -> (a -> m a) -> a -> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< a -> m a
GenericM m
f

exprConstr :: Expr b -> String
exprConstr :: forall b. Expr b -> [Char]
exprConstr (Var {})      = [Char]
"Var"
exprConstr (Lit {})      = [Char]
"Lit"
exprConstr (App {})      = [Char]
"App"
exprConstr (Lam {})      = [Char]
"Lam"
exprConstr (Let {})      = [Char]
"Let"
exprConstr (Case {})     = [Char]
"Case"
exprConstr (Cast {})     = [Char]
"Cast"
exprConstr (Tick {})     = [Char]
"Tick"
exprConstr (Type {})     = [Char]
"Type"
exprConstr (Coercion {}) = [Char]
"Coercion"

hasTyCon :: TyCon -> Type -> Bool
hasTyCon :: TyCon -> Type -> Bool
hasTyCon TyCon
tc (HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe -> Just (TyCon
tc', [Type]
_)) = TyCon
tc' TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc
hasTyCon TyCon
_ Type
_ = Bool
False

-- Alternative to Case when we don't want to work out the alternatives type, and
-- we're willing to crash on empty alternatives.
mkCase1 :: CoreExpr -> Id -> [CoreAlt] -> CoreExpr
mkCase1 :: CoreExpr -> CoreBndr -> [Alt CoreBndr] -> CoreExpr
mkCase1 CoreExpr
scrut CoreBndr
v alts :: [Alt CoreBndr]
alts@(Alt CoreBndr
alt0:[Alt CoreBndr]
_) = CoreExpr -> CoreBndr -> Type -> [Alt CoreBndr] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut CoreBndr
v ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType (Alt CoreBndr -> CoreExpr
forall b. Alt b -> Expr b
altRhs Alt CoreBndr
alt0)) [Alt CoreBndr]
alts
mkCase1 CoreExpr
_ CoreBndr
_ [Alt CoreBndr]
_ = [Char] -> SDoc -> CoreExpr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"mkCase1 with empty alts" SDoc
empty

-- Experiment: wrap a stateful counter around a Maybe.
unsafeLimit :: Maybe (IORef Int) -> Unop (Maybe a)
unsafeLimit :: forall a. Maybe (IORef Int) -> Unop (Maybe a)
unsafeLimit Maybe (IORef Int)
Nothing = Maybe a -> Maybe a
forall a. a -> a
id
unsafeLimit (Just IORef Int
r) = \ Maybe a
a -> IO (Maybe a) -> Maybe a
forall a. IO a -> a
unsafePerformIO (IO (Maybe a) -> Maybe a) -> IO (Maybe a) -> Maybe a
forall a b. (a -> b) -> a -> b
$
  do Int
n <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
r
     if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then
       Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
      else
       do -- pprTrace "unsafeLimit" (ppr n) (return ())
          IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
r (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
          Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
a
{-# NOINLINE unsafeLimit #-}

-- experiment
alwaysSubst :: CoreExpr -> Bool
-- alwaysSubst e@(collectArgs -> (Var _, args))
--   \| pprTrace "alwaysSubst" (ppr (e,not (isTyCoDictArg e), all isTyCoDictArg args)) False = undefined
alwaysSubst :: CoreExpr -> Bool
alwaysSubst e :: CoreExpr
e@(CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs -> (Var CoreBndr
_, [CoreExpr]
args)) =
  Bool -> Bool
not (CoreExpr -> Bool
isTyCoDictArg CoreExpr
e) Bool -> Bool -> Bool
&& (CoreExpr -> Bool) -> [CoreExpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CoreExpr -> Bool
isTyCoDictArg [CoreExpr]
args
alwaysSubst CoreExpr
_ = Bool
False

mkCoercible :: Kind -> Type -> Type -> Coercion -> CoreExpr
mkCoercible :: Type -> Type -> Type -> Coercion -> CoreExpr
mkCoercible Type
k Type
a Type
b Coercion
co =
  CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var (DataCon -> CoreBndr
dataConWrapId DataCon
coercibleDataCon) CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
`mkTyApps` [Type
k,Type
a,Type
b] Binop CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion Coercion
co

isFunCat :: Type -> Bool
isFunCat :: Type -> Bool
isFunCat (TyConApp TyCon
tc [Type]
_) = TyCon -> Bool
isFunTyCon TyCon
tc
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
  Bool -> Bool -> Bool
|| TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unrestrictedFunTyCon -- ghc 9 has two representations for ->
#endif
isFunCat Type
_               = Bool
False

-- If the wild variable in a Case is not dead, make a new dead wild var and
-- transform to a Let.
deadifyCaseWild :: ReExpr
deadifyCaseWild :: ReExpr
deadifyCaseWild e :: CoreExpr
e@(Case CoreExpr
scrut CoreBndr
wild Type
_rhsTy [Alt (DataAlt DataCon
dc) [CoreBndr
a,CoreBndr
b] CoreExpr
rhs])
  | Bool -> Bool
not (CoreBndr -> Bool
isDeadBinder CoreBndr
wild) =
  ReExpr
forall a. a -> Maybe a
Just (Bind CoreBndr -> Unop CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (CoreBndr -> CoreExpr -> Bind CoreBndr
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
wild CoreExpr
scrut)
         (CoreExpr -> CoreBndr -> Type -> [Alt CoreBndr] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
wild) CoreBndr
wild' Type
_rhsTy [AltCon -> [CoreBndr] -> CoreExpr -> Alt CoreBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [CoreBndr
a,CoreBndr
b] CoreExpr
rhs]))
 where
   wild' :: CoreBndr
wild' = VarSet -> [Char] -> Type -> CoreBndr
freshDeadId (CoreExpr -> VarSet
exprFreeVars CoreExpr
e) [Char]
"newWild" (CoreBndr -> Type
varType CoreBndr
wild)
deadifyCaseWild CoreExpr
_ = Maybe CoreExpr
forall a. Maybe a
Nothing