{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DerivingVia #-}
{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}
-- | @Enum@ and @Ix@ synthesizers.  @Enum@ is for enumerations (all-nullary
-- constructors); its @toEnum@ range-checks like GHC.  @Ix@ covers both
-- enumerations ('synthIx') and single-constructor products ('synthIxProduct',
-- Cartesian range \/ mixed-radix index).  (@Bounded@ lives in "Stock.Bounded".)
module Stock.Enum where
-- Most names below (data-con/type builders, coercion builders, occ-name
-- helpers, …) are re-exported by 'GHC.Plugins', so we only import explicitly
-- the ones it does not provide.
import GHC.Plugins hiding (TcPlugin)
import GHC.Tc.Plugin
import GHC.Tc.Types
import GHC.Tc.Types.Constraint
#if MIN_VERSION_ghc(9,12,0)
import GHC.Tc.Types.CtLoc (CtLoc)
#else
import GHC.Tc.Types.Constraint (CtLoc)
#endif
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad (addErrTc)
import GHC.Tc.Errors.Types (mkTcRnUnknownMessage)
import GHC.Types.Error (mkPlainError, noHints)
import GHC.Core.Class (Class, className, classMethods, classOpItems, classTyCon)
import GHC.Core.Predicate (classifyPredType, Pred(ClassPred), mkClassPred)
import GHC.Builtin.Types.Prim (intPrimTy)
import GHC.Builtin.PrimOps (PrimOp(TagToEnumOp))
import GHC.Core.Make (mkRuntimeErrorApp, pAT_ERROR_ID)
import GHC.Builtin.PrimOps.Ids (primOpId)
import GHC.Builtin.Names ( eqClassName, ordClassName, appendName
                         , enumClassName, mapName, numClassName
                         , enumFromToName, enumFromThenToName
                         , eqStringName
                         , genClassName, repTyConName, u1TyConName, k1TyConName
                         , prodTyConName, sumTyConName
                         , monoidClassName, foldableClassName, functorClassName
                         , semigroupClassName )
import Stock.Compat ( gHC_INTERNAL_SHOW, gHC_INTERNAL_READ
                    , gHC_INTERNAL_LIST, gHC_INTERNAL_GENERICS )
import GHC.Core.Reduction (mkReduction)
import GHC.Core.TyCo.Rep (UnivCoProvenance(PluginProv))
import GHC.Rename.Fixity (lookupFixityRn)
import GHC.Types.Fixity (Fixity(..), defaultFixity)
import GHC.Core.TyCo.Compare (eqType)
import GHC.Core.Multiplicity (scaledThing)
import GHC.Core.SimpleOpt (defaultSimpleOpts)
import GHC.Core.Unfold.Make (mkInlineUnfoldingWithArity)
import GHC.Core.InstEnv (classInstances, is_dfun, is_tys)
import GHC.Runtime.Loader (getValueSafely)
import Stock.Derive
import Data.Maybe (catMaybes, fromJust, isJust, fromMaybe)
import qualified Data.Monoid as Mon (Alt(..))  -- 'Alt' clashes with GHC.Core's case-alt 'Alt'
import Stock.Trans (MaybeT(..))
import Control.Monad (forM, zipWithM, unless, guard)
import Data.IORef (IORef, newIORef, readIORef, modifyIORef')
import Stock.Internal
import Stock.Ord

-- | A constructor's fixity precedence (default 9), used for @Show@/@Read@ of
-- infix constructors (@showParen (d > prec)@, args at @prec+1@).
synthEnum :: Class -> CtLoc -> Type -> Type -> Coercion -> [(DataCon, [Coercion])]
          -> TcPluginM (EvTerm, [Ct])
synthEnum :: Class
-> CtLoc
-> Type
-> Type
-> Coercion
-> [(DataCon, [Coercion])]
-> TcPluginM (EvTerm, [Ct])
synthEnum Class
cls CtLoc
loc Type
wrappedTy Type
innerTy Coercion
co [(DataCon, [Coercion])]
dcons0 = do
  ordCls <- Name -> TcPluginM Class
tcLookupClass Name
ordClassName
  mapId  <- tcLookupId mapName
  eftId  <- tcLookupId enumFromToName        -- enumFromTo  (class method)
  efttId <- tcLookupId enumFromThenToName    -- enumFromThenTo (class method)
  let dcons       = ((DataCon, [Coercion]) -> DataCon)
-> [(DataCon, [Coercion])] -> [DataCon]
forall a b. (a -> b) -> [a] -> [b]
map (DataCon, [Coercion]) -> DataCon
forall a b. (a, b) -> a
fst [(DataCon, [Coercion])]
dcons0           -- enumerations have no fields to override
      tagToEnumId = PrimOp -> Id
primOpId PrimOp
TagToEnumOp
      geSel       = String -> Class -> Id
classMethod String
">=" Class
ordCls   -- (>=)
      maxTag      = Integer -> CoreExpr
mkUncheckedIntExpr (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([DataCon] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataCon]
dcons Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
      toWrapped Expr b
e = Expr b -> Coercion -> Expr b
forall b. Expr b -> Coercion -> Expr b
Cast Expr b
e (Coercion -> Coercion
mkSymCo Coercion
co)
      fromInner Id
v = Expr b -> Coercion -> Expr b
forall b. Expr b -> Coercion -> Expr b
Cast (Id -> Expr b
forall b. Id -> Expr b
Var Id
v) Coercion
co

  enumIntEv <- newWanted loc (mkClassPred cls    [intTy])
  ordIntEv  <- newWanted loc (mkClassPred ordCls [intTy])
  let enumIntDict = HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
enumIntEv
      ordIntDict  = HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ordIntEv

  -- fromEnum v = <tag of v>
  fv  <- freshId wrappedTy "v"
  fcb <- freshId innerTy "cb"
  let fromEnumImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
fv] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
        CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
fromInner Id
fv) Id
fcb Type
intTy
          [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [] (Integer -> CoreExpr
mkUncheckedIntExpr (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i))
          | (Int
i, DataCon
dc) <- [Int] -> [DataCon] -> [(Int, DataCon)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [DataCon]
dcons ]

  -- toEnum i: GHC's derived toEnum RANGE-CHECKS and errors when out of range.
  -- Without the check, @tagToEnum#@ on a bad tag is undefined behaviour (it
  -- segfaults), so we replicate the guard: @if 0 <= i && i <= maxTag then
  -- tagToEnum# i else error@.
  ti  <- freshId intTy "i"
  tcb <- freshId intTy "ib"
  tip <- freshId intPrimTy "i#"
  bLo <- freshId boolTy "blo"
  bHi <- freshId boolTy "bhi"
  let leSel  = String -> Class -> Id
classMethod String
"<=" Class
ordCls
      okCon  = CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ti) Id
tcb Type
wrappedTy
                 [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
intDataCon) [Id
tip]
                     (CoreExpr -> CoreExpr
forall {b}. Expr b -> Expr b
toWrapped (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
tagToEnumId) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
innerTy, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
tip])) ]
      errOut = Id -> Type -> String -> CoreExpr
mkRuntimeErrorApp Id
pAT_ERROR_ID Type
wrappedTy
                 String
"toEnum: argument out of range (derived via Stock)"
      toEnumImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
ti] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
        CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
geSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
intTy, CoreExpr
ordIntDict, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ti, Integer -> CoreExpr
mkUncheckedIntExpr Integer
0]) Id
bLo Type
wrappedTy
          [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
falseDataCon) [] CoreExpr
errOut
          , AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
trueDataCon)  []
              (CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
leSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
intTy, CoreExpr
ordIntDict, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ti, CoreExpr
maxTag]) Id
bHi Type
wrappedTy
                 [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
falseDataCon) [] CoreExpr
errOut
                 , AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
trueDataCon)  [] CoreExpr
okCon ]) ]

  -- enumFrom x = map toEnum (enumFromTo (fromEnum x) maxTag)
  ex <- freshId wrappedTy "x"
  let mapToCon CoreExpr
es = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
mapId) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
intTy, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
wrappedTy, CoreExpr
toEnumImpl, CoreExpr
es]
      enumFromImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
ex] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
mapToCon (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
        CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
eftId) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
intTy, CoreExpr
enumIntDict, CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
fromEnumImpl [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ex], CoreExpr
maxTag]

  -- enumFromThen x y = map toEnum (enumFromThenTo (fromEnum x) (fromEnum y) lim)
  --   where lim = if fromEnum y >= fromEnum x then maxTag else 0
  etx <- freshId wrappedTy "x"
  ety <- freshId wrappedTy "y"
  lbn <- freshId boolTy "b"
  let fx = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
fromEnumImpl [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
etx]
      fy = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
fromEnumImpl [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ety]
      lim = CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
geSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
intTy, CoreExpr
ordIntDict, CoreExpr
fy, CoreExpr
fx]) Id
lbn Type
intTy
              [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
falseDataCon) [] (Integer -> CoreExpr
mkUncheckedIntExpr Integer
0)
              , AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
trueDataCon)  [] CoreExpr
maxTag ]
      enumFromThenImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
etx, Id
ety] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
mapToCon (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
        CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
efttId) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
intTy, CoreExpr
enumIntDict, CoreExpr
fx, CoreExpr
fy, CoreExpr
lim]

  -- succ / pred / enumFromTo / enumFromThenTo via class defaults (recursive dict)
  dmSucc <- defMethId cls 0
  dmPred <- defMethId cls 1
  dmEFT  <- defMethId cls 6
  dmEFTT <- defMethId cls 7
  dict <- recClassDict cls wrappedTy \Id
dvar ->
    let useDef :: Id -> Expr b
useDef Id
dm = Expr b -> [Expr b] -> Expr b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Expr b
forall b. Id -> Expr b
Var Id
dm) [Type -> Expr b
forall b. Type -> Expr b
Type Type
wrappedTy, Id -> Expr b
forall b. Id -> Expr b
Var Id
dvar]
    in [CoreExpr] -> TcPluginM [CoreExpr]
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Id -> CoreExpr
forall b. Id -> Expr b
useDef Id
dmSucc, Id -> CoreExpr
forall b. Id -> Expr b
useDef Id
dmPred
            , CoreExpr
toEnumImpl, CoreExpr
fromEnumImpl
            , CoreExpr
enumFromImpl, CoreExpr
enumFromThenImpl
            , Id -> CoreExpr
forall b. Id -> Expr b
useDef Id
dmEFT, Id -> CoreExpr
forall b. Id -> Expr b
useDef Id
dmEFTT ]
  pure (EvExpr dict, [mkNonCanonical enumIntEv, mkNonCanonical ordIntEv])

-- | Synthesize an @Ix@ dictionary for an enumeration.  @range@/@unsafeIndex@/
-- @inRange@ work on constructor tags; @index@/@rangeSize@/@unsafeRangeSize@
-- come from the class defaults; the @Ord@ superclass is synthesized too.
synthIx :: Class -> CtLoc -> Type -> Type -> Coercion -> [(DataCon, [Coercion])]
        -> TcPluginM (EvTerm, [Ct])
synthIx :: Class
-> CtLoc
-> Type
-> Type
-> Coercion
-> [(DataCon, [Coercion])]
-> TcPluginM (EvTerm, [Ct])
synthIx Class
cls CtLoc
loc Type
wrappedTy Type
innerTy Coercion
co [(DataCon, [Coercion])]
dcons0 = do
  ordCls  <- Name -> TcPluginM Class
tcLookupClass Name
ordClassName
  numCls  <- tcLookupClass numClassName
  enumCls <- tcLookupClass enumClassName
  mapId   <- tcLookupId mapName
  eftId   <- tcLookupId enumFromToName
  let dcons       = ((DataCon, [Coercion]) -> DataCon)
-> [(DataCon, [Coercion])] -> [DataCon]
forall a b. (a -> b) -> [a] -> [b]
map (DataCon, [Coercion]) -> DataCon
forall a b. (a, b) -> a
fst [(DataCon, [Coercion])]
dcons0           -- enumerations have no fields to override
      tagToEnumId = PrimOp -> Id
primOpId PrimOp
TagToEnumOp
      leSel  = String -> Class -> Id
classMethod String
"<=" Class
ordCls          -- (<=)
      subSel = String -> Class -> Id
classMethod String
"-" Class
numCls          -- (-)
      pairTy = [Type] -> Type
mkBoxedTupleTy [Type
wrappedTy, Type
wrappedTy]
      tupCon = Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed Int
2
      toWrapped Expr b
e = Expr b -> Coercion -> Expr b
forall b. Expr b -> Coercion -> Expr b
Cast Expr b
e (Coercion -> Coercion
mkSymCo Coercion
co)
      fromInner Id
v = Expr b -> Coercion -> Expr b
forall b. Expr b -> Coercion -> Expr b
Cast (Id -> Expr b
forall b. Id -> Expr b
Var Id
v) Coercion
co

  enumIntEv <- newWanted loc (mkClassPred enumCls [intTy])
  ordIntEv  <- newWanted loc (mkClassPred ordCls  [intTy])
  numIntEv  <- newWanted loc (mkClassPred numCls  [intTy])
  let enumIntDict = HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
enumIntEv
      ordIntDict  = HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ordIntEv
      numIntDict  = HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
numIntEv

  -- tag function (fromEnum) and tagToEnum (toEnum), as in synthEnum
  fv <- freshId wrappedTy "v"; fcb <- freshId innerTy "cb"
  let fromEnumImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
fv] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
fromInner Id
fv) Id
fcb Type
intTy
        [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [] (Integer -> CoreExpr
mkUncheckedIntExpr (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i))
        | (Int
i, DataCon
dc) <- [Int] -> [DataCon] -> [(Int, DataCon)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [DataCon]
dcons ]
      tagOf CoreExpr
e = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
fromEnumImpl [CoreExpr
e]
  ti <- freshId intTy "i"; tcb <- freshId intTy "ib"; tip <- freshId intPrimTy "i#"
  let toEnumImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
ti] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ti) Id
tcb Type
wrappedTy
        [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
intDataCon) [Id
tip]
            (CoreExpr -> CoreExpr
forall {b}. Expr b -> Expr b
toWrapped (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
tagToEnumId) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
innerTy, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
tip])) ]

  -- range (l,u) = map toEnum (enumFromTo (tag l) (tag u))
  rlu <- freshId pairTy "lu"; rcb <- freshId pairTy "cb"
  rl  <- freshId wrappedTy "l"; ru <- freshId wrappedTy "u"
  let rangeImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
rlu] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
rlu) Id
rcb (Type -> Type
mkListTy Type
wrappedTy)
        [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
tupCon) [Id
rl, Id
ru]
            (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
mapId) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
intTy, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
wrappedTy, CoreExpr
toEnumImpl,
               CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
eftId) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
intTy, CoreExpr
enumIntDict, CoreExpr -> CoreExpr
tagOf (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
rl), CoreExpr -> CoreExpr
tagOf (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ru)]]) ]

  -- unsafeIndex (l,u) i = tag i - tag l
  ulu <- freshId pairTy "lu"; ucb <- freshId pairTy "cb"
  ul  <- freshId wrappedTy "l"; uu <- freshId wrappedTy "u"; ui <- freshId wrappedTy "i"
  let unsafeIndexImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
ulu, Id
ui] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ulu) Id
ucb Type
intTy
        [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
tupCon) [Id
ul, Id
uu]
            (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
subSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
intTy, CoreExpr
numIntDict, CoreExpr -> CoreExpr
tagOf (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ui), CoreExpr -> CoreExpr
tagOf (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ul)]) ]

  -- inRange (l,u) i = tag l <= tag i && tag i <= tag u
  ilu <- freshId pairTy "lu"; icb <- freshId pairTy "cb"
  il  <- freshId wrappedTy "l"; iu <- freshId wrappedTy "u"; ii <- freshId wrappedTy "i"
  ib  <- freshId boolTy "b"
  let le CoreExpr
a CoreExpr
b = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
leSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
intTy, CoreExpr
ordIntDict, CoreExpr
a, CoreExpr
b]
      inRangeImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
ilu, Id
ii] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ilu) Id
icb Type
boolTy
        [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
tupCon) [Id
il, Id
iu]
            (CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (CoreExpr -> CoreExpr -> CoreExpr
le (CoreExpr -> CoreExpr
tagOf (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
il)) (CoreExpr -> CoreExpr
tagOf (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ii))) Id
ib Type
boolTy
               [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
falseDataCon) [] (Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
falseDataCon))
               , AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
trueDataCon)  [] (CoreExpr -> CoreExpr -> CoreExpr
le (CoreExpr -> CoreExpr
tagOf (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
ii)) (CoreExpr -> CoreExpr
tagOf (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
iu))) ]) ]

  ordSuper <- unwrapEv . fst <$> synthOrd ordCls loc wrappedTy innerTy co dcons0
  dmIndex  <- defMethId cls 1
  dmRSize  <- defMethId cls 4
  dmURSize <- defMethId cls 5
  dict <- recClassDict cls wrappedTy \Id
dvar ->
    let useDef :: Id -> Expr b
useDef Id
dm = Expr b -> [Expr b] -> Expr b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Expr b
forall b. Id -> Expr b
Var Id
dm) [Type -> Expr b
forall b. Type -> Expr b
Type Type
wrappedTy, Id -> Expr b
forall b. Id -> Expr b
Var Id
dvar]
    in [CoreExpr] -> TcPluginM [CoreExpr]
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ CoreExpr
ordSuper
            , CoreExpr
rangeImpl, Id -> CoreExpr
forall b. Id -> Expr b
useDef Id
dmIndex, CoreExpr
unsafeIndexImpl, CoreExpr
inRangeImpl
            , Id -> CoreExpr
forall b. Id -> Expr b
useDef Id
dmRSize, Id -> CoreExpr
forall b. Id -> Expr b
useDef Id
dmURSize ]
  pure (EvExpr dict, map mkNonCanonical [enumIntEv, ordIntEv, numIntEv])

-- | Synthesize @Ix (Stock P)@ for a single-constructor PRODUCT (like GHC):
-- @range@ is the Cartesian product of the per-field ranges (row-major nested
-- @concatMap@\/@map@), @unsafeIndex@ the mixed-radix index
-- (@acc * unsafeRangeSize fj + unsafeIndex fj@), @inRange@ the conjunction of
-- per-field @inRange@.  @index@\/@rangeSize@\/@unsafeRangeSize@ come from the
-- class defaults; the @Ord@ superclass is synthesized.
synthIxProduct :: Class -> CtLoc -> Type -> Type -> Coercion -> [(DataCon, [Coercion])]
               -> TcPluginM (EvTerm, [Ct])
synthIxProduct :: Class
-> CtLoc
-> Type
-> Type
-> Coercion
-> [(DataCon, [Coercion])]
-> TcPluginM (EvTerm, [Ct])
synthIxProduct Class
cls CtLoc
loc Type
wrappedTy Type
innerTy Coercion
co [(DataCon, [Coercion])]
dcons0 = do
  ordCls      <- Name -> TcPluginM Class
tcLookupClass Name
ordClassName
  numCls      <- tcLookupClass numClassName
  mapId       <- tcLookupId mapName
  concatMapId <- lookupOrig gHC_INTERNAL_LIST (mkVarOcc "concatMap") >>= tcLookupId
  let dc  = (DataCon, [Coercion]) -> DataCon
forall a b. (a, b) -> a
fst ([(DataCon, [Coercion])] -> (DataCon, [Coercion])
forall a. HasCallStack => [a] -> a
head [(DataCon, [Coercion])]
dcons0)
      fts = Type -> DataCon -> [Type]
fieldTysAt Type
innerTy DataCon
dc
      rangeSel   = String -> Class -> Id
classMethod String
"range"           Class
cls
      uIndexSel  = String -> Class -> Id
classMethod String
"unsafeIndex"     Class
cls
      inRangeSel = String -> Class -> Id
classMethod String
"inRange"         Class
cls
      uRSizeSel  = String -> Class -> Id
classMethod String
"unsafeRangeSize" Class
cls
      mulSel     = String -> Class -> Id
classMethod String
"*" Class
numCls
      addSel     = String -> Class -> Id
classMethod String
"+" Class
numCls
      pairW      = [Type] -> Type
mkBoxedTupleTy [Type
wrappedTy, Type
wrappedTy]
      tup2       = Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed Int
2
      listW      = Type -> Type
mkListTy Type
wrappedTy
      toWrapped Expr b
e = Expr b -> Coercion -> Expr b
forall b. Expr b -> Coercion -> Expr b
Cast Expr b
e (Coercion -> Coercion
mkSymCo Coercion
co)
      fromInner Expr b
e = Expr b -> Coercion -> Expr b
forall b. Expr b -> Coercion -> Expr b
Cast Expr b
e Coercion
co
      conApp [CoreExpr]
args = CoreExpr -> CoreExpr
forall {b}. Expr b -> Expr b
toWrapped (Type -> DataCon -> [CoreExpr] -> CoreExpr
conAppAt Type
innerTy DataCon
dc [CoreExpr]
args)
  fieldEvs <- mapM (\Type
ft -> CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
cls [Type
ft])) fts
  numIntEv <- newWanted loc (mkClassPred numCls [intTy])
  let dicts      = (CtEvidence -> CoreExpr) -> [CtEvidence] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr [CtEvidence]
fieldEvs
      numIntDict = HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
numIntEv
      pairOf Type
ft CoreExpr
l CoreExpr
u    = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
tup2 [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ft, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ft, CoreExpr
l, CoreExpr
u]      -- (l,u)::(ft,ft)
      rangeFE  Type
ft CoreExpr
d CoreExpr
l CoreExpr
u   = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
rangeSel)   [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ft, CoreExpr
d, Type -> CoreExpr -> CoreExpr -> CoreExpr
pairOf Type
ft CoreExpr
l CoreExpr
u]
      uIdxFE   Type
ft CoreExpr
d CoreExpr
l CoreExpr
u CoreExpr
i = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
uIndexSel)  [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ft, CoreExpr
d, Type -> CoreExpr -> CoreExpr -> CoreExpr
pairOf Type
ft CoreExpr
l CoreExpr
u, CoreExpr
i]
      inRngFE  Type
ft CoreExpr
d CoreExpr
l CoreExpr
u CoreExpr
i = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
inRangeSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ft, CoreExpr
d, Type -> CoreExpr -> CoreExpr -> CoreExpr
pairOf Type
ft CoreExpr
l CoreExpr
u, CoreExpr
i]
      uRSzFE   Type
ft CoreExpr
d CoreExpr
l CoreExpr
u   = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
uRSizeSel)  [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ft, CoreExpr
d, Type -> CoreExpr -> CoreExpr -> CoreExpr
pairOf Type
ft CoreExpr
l CoreExpr
u]
      mul CoreExpr
a CoreExpr
b = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
mulSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
intTy, CoreExpr
numIntDict, CoreExpr
a, CoreExpr
b]
      add CoreExpr
a CoreExpr
b = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
addSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
intTy, CoreExpr
numIntDict, CoreExpr
a, CoreExpr
b]

  -- destructure a @wrappedTy@ bound into its field binders, wrapping a body
  let destr Id
v [Id]
binders Type
resTy CoreExpr
body = do
        cb <- Type -> String -> TcPluginM Id
freshId Type
innerTy String
"cb"
        pure (Case (fromInner (Var v)) cb resTy [Alt (DataAlt dc) binders body])

  -- range (lo,hi) = [ P x.. | xj <- range (lj,uj) ]  (nested concatMap/map)
  luR <- freshId pairW "lu"; lcb <- freshId pairW "lcb"
  loR <- freshId wrappedTy "lo"; hiR <- freshId wrappedTy "hi"
  lsR <- mapM (`freshId` "l") fts; usR <- mapM (`freshId` "u") fts
  let mkRange []                 [Id]
chosen = CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> [CoreExpr] -> CoreExpr
mkListExpr Type
wrappedTy [[CoreExpr] -> CoreExpr
conApp ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
Var [Id]
chosen)])
      mkRange [(Type
ft, CoreExpr
d, Id
l, Id
u)]    [Id]
chosen = do
        x <- Type -> String -> TcPluginM Id
freshId Type
ft String
"x"
        pure (mkApps (Var mapId) [Type ft, Type wrappedTy
               , Lam x (conApp (map Var (chosen ++ [x]))), rangeFE ft d (Var l) (Var u)])
      mkRange ((Type
ft, CoreExpr
d, Id
l, Id
u) : [(Type, CoreExpr, Id, Id)]
r) [Id]
chosen = do
        x  <- Type -> String -> TcPluginM Id
freshId Type
ft String
"x"
        bd <- mkRange r (chosen ++ [x])
        pure (mkApps (Var concatMapId) [Type ft, Type wrappedTy, Lam x bd, rangeFE ft d (Var l) (Var u)])
  rangeInner <- mkRange (zip4 fts dicts lsR usR) []
  rangeUs    <- destr hiR usR listW rangeInner
  rangeLs    <- destr loR lsR listW rangeUs
  let rangeImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
luR] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
luR) Id
lcb Type
listW
        [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
tup2) [Id
loR, Id
hiR] CoreExpr
rangeLs ]

  -- unsafeIndex (lo,hi) i = mixed-radix: foldl (\a (l,u,i) -> a*urs(l,u) + uidx(l,u) i) 0
  luI <- freshId pairW "lu"; icb <- freshId pairW "icb"; iV <- freshId wrappedTy "i"
  loI <- freshId wrappedTy "lo"; hiI <- freshId wrappedTy "hi"
  lsI <- mapM (`freshId` "l") fts; usI <- mapM (`freshId` "u") fts; isI <- mapM (`freshId` "i") fts
  let idxBody = (CoreExpr -> (Type, CoreExpr, Id, Id, Id) -> CoreExpr)
-> CoreExpr -> [(Type, CoreExpr, Id, Id, Id)] -> CoreExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\CoreExpr
acc (Type
ft, CoreExpr
d, Id
l, Id
u, Id
i) -> CoreExpr -> CoreExpr -> CoreExpr
add (CoreExpr -> CoreExpr -> CoreExpr
mul CoreExpr
acc (Type -> CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
uRSzFE Type
ft CoreExpr
d (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
l) (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
u)))
                                                    (Type -> CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
uIdxFE Type
ft CoreExpr
d (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
l) (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
u) (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
i)))
                      (Integer -> CoreExpr
mkUncheckedIntExpr Integer
0) ([Type]
-> [CoreExpr]
-> [Id]
-> [Id]
-> [Id]
-> [(Type, CoreExpr, Id, Id, Id)]
zipWith5q [Type]
fts [CoreExpr]
dicts [Id]
lsI [Id]
usI [Id]
isI)
  idxIs <- destr iV  isI intTy idxBody
  idxUs <- destr hiI usI intTy idxIs
  idxLs <- destr loI lsI intTy idxUs
  let uIndexImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
luI, Id
iV] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
luI) Id
icb Type
intTy
        [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
tup2) [Id
loI, Id
hiI] CoreExpr
idxLs ]
        -- note: iV is the second lambda arg; destr on iV is inside (uses iV bound above)

  -- inRange (lo,hi) i = and [ inRange (lj,uj) ij ]
  luN <- freshId pairW "lu"; ncb <- freshId pairW "ncb"; nV <- freshId wrappedTy "i"
  loN <- freshId wrappedTy "lo"; hiN <- freshId wrappedTy "hi"
  lsN <- mapM (`freshId` "l") fts; usN <- mapM (`freshId` "u") fts; isN <- mapM (`freshId` "i") fts
  let conj []                  = CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
trueDataCon))
      conj ((Type
ft, CoreExpr
d, Id
l, Id
u, Id
i) : [(Type, CoreExpr, Id, Id, Id)]
more) = do
        b    <- Type -> String -> TcPluginM Id
freshId Type
boolTy String
"b"
        rest <- conj more
        pure (Case (inRngFE ft d (Var l) (Var u) (Var i)) b boolTy
               [ Alt (DataAlt falseDataCon) [] (Var (dataConWorkId falseDataCon))
               , Alt (DataAlt trueDataCon)  [] rest ])
  inRBody <- conj (zipWith5q fts dicts lsN usN isN)
  inRIs   <- destr nV  isN boolTy inRBody
  inRUs   <- destr hiN usN boolTy inRIs
  inRLs   <- destr loN lsN boolTy inRUs
  let inRangeImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
luN, Id
nV] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
luN) Id
ncb Type
boolTy
        [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
tup2) [Id
loN, Id
hiN] CoreExpr
inRLs ]

  (ordEv, ordWs) <- synthOrd ordCls loc wrappedTy innerTy co dcons0
  let ordSuper = EvTerm -> CoreExpr
unwrapEv EvTerm
ordEv
  dmIndex  <- defMethId cls 1
  dmRSize  <- defMethId cls 4
  dmURSize <- defMethId cls 5
  dict <- recClassDict cls wrappedTy \Id
dvar ->
    let useDef :: Id -> Expr b
useDef Id
dm = Expr b -> [Expr b] -> Expr b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Expr b
forall b. Id -> Expr b
Var Id
dm) [Type -> Expr b
forall b. Type -> Expr b
Type Type
wrappedTy, Id -> Expr b
forall b. Id -> Expr b
Var Id
dvar]
    in [CoreExpr] -> TcPluginM [CoreExpr]
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ CoreExpr
ordSuper, CoreExpr
rangeImpl, Id -> CoreExpr
forall b. Id -> Expr b
useDef Id
dmIndex, CoreExpr
uIndexImpl, CoreExpr
inRangeImpl
            , Id -> CoreExpr
forall b. Id -> Expr b
useDef Id
dmRSize, Id -> CoreExpr
forall b. Id -> Expr b
useDef Id
dmURSize ]
  pure (EvExpr dict, map mkNonCanonical (fieldEvs ++ [numIntEv]) ++ ordWs)

-- 4-/5-way zips into tuples (local; avoid Data.List name clutter)
zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 :: forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 (a
a:[a]
as) (b
b:[b]
bs) (c
c:[c]
cs) (d
d:[d]
ds) = (a
a,b
b,c
c,d
d) (a, b, c, d) -> [(a, b, c, d)] -> [(a, b, c, d)]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [a]
as [b]
bs [c]
cs [d]
ds
zip4 [a]
_ [b]
_ [c]
_ [d]
_ = []
zipWith5q :: [Type] -> [CoreExpr] -> [Id] -> [Id] -> [Id] -> [(Type, CoreExpr, Id, Id, Id)]
zipWith5q :: [Type]
-> [CoreExpr]
-> [Id]
-> [Id]
-> [Id]
-> [(Type, CoreExpr, Id, Id, Id)]
zipWith5q (Type
a:[Type]
as) (CoreExpr
b:[CoreExpr]
bs) (Id
c:[Id]
cs) (Id
d:[Id]
ds) (Id
e:[Id]
es) = (Type
a,CoreExpr
b,Id
c,Id
d,Id
e) (Type, CoreExpr, Id, Id, Id)
-> [(Type, CoreExpr, Id, Id, Id)] -> [(Type, CoreExpr, Id, Id, Id)]
forall a. a -> [a] -> [a]
: [Type]
-> [CoreExpr]
-> [Id]
-> [Id]
-> [Id]
-> [(Type, CoreExpr, Id, Id, Id)]
zipWith5q [Type]
as [CoreExpr]
bs [Id]
cs [Id]
ds [Id]
es
zipWith5q [Type]
_ [CoreExpr]
_ [Id]
_ [Id]
_ [Id]
_ = []

-- | Synthesize a @Read@ dictionary for prefix (non-record, non-infix)
-- constructors, mirroring the Report's derived @readsPrec@:
--
--   readsPrec d = foldr (++) [] [ readParen (paren K) (parse K) | K <- cons ]
--   parse K r = [ (K a1..an, rn) | (tok,r1) <- lex r, tok == "K"
--                                , (a1,r2) <- readsPrec 11 r1, ... ]
--
-- @readList@/@readPrec@/@readListPrec@ come from the class default methods via
-- a recursive dictionary, so @read@ (which goes through @readPrec@) works too.