{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DerivingVia #-}
{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}
-- | @Show@ synthesizer: GHC-faithful @showsPrec@ (prefix \/ infix \/ record, with parens).
module Stock.Show 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.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

synthShow :: Class -> CtLoc -> Type -> Type -> Coercion -> [(DataCon, [Coercion])]
          -> TcPluginM (EvTerm, [Ct])
synthShow :: Class
-> CtLoc
-> Type
-> Type
-> Coercion
-> [(DataCon, [Coercion])]
-> TcPluginM (EvTerm, [Ct])
synthShow Class
showCls CtLoc
loc Type
wrappedTy Type
innerTy Coercion
co [(DataCon, [Coercion])]
dcons = do
  Id
appendId     <- Name -> TcPluginM Id
tcLookupId Name
appendName
  Name
showListName <- Module -> OccName -> TcPluginM Name
lookupOrig Module
gHC_INTERNAL_SHOW (String -> OccName
mkVarOcc String
"showList__")
  Id
showList__Id <- Name -> TcPluginM Id
tcLookupId Name
showListName
  Class
ordCls       <- Name -> TcPluginM Class
tcLookupClass Name
ordClassName

  let showsPrecSel :: Id
showsPrecSel = String -> Class -> Id
classMethod String
"showsPrec" Class
showCls         -- showsPrec
      geSel :: Id
geSel        = String -> Class -> Id
classMethod String
">=" Class
ordCls           -- (>=) — GHC parenthesises with @d >= prec+1@
      showSTy :: Type
showSTy      = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
stringTy Type
stringTy     -- ShowS
      scrut :: Id -> Expr b
scrut 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
      cons :: CoreExpr -> CoreExpr -> CoreExpr
cons CoreExpr
c CoreExpr
t     = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
consDataCon [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
charTy, CoreExpr
c, CoreExpr
t]   -- c : t
      append :: Arg b -> Arg b -> Arg b
append Arg b
s Arg b
t   = Arg b -> [Arg b] -> Arg b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Arg b
forall b. Id -> Expr b
Var Id
appendId) [Type -> Arg b
forall b. Type -> Expr b
Type Type
charTy, Arg b
s, Arg b
t]       -- s ++ t
      str :: String -> TcPluginM CoreExpr
str String
s        = TcM CoreExpr -> TcPluginM CoreExpr
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (FastString -> TcM CoreExpr
forall (m :: * -> *). MonadThings m => FastString -> m CoreExpr
mkStringExprFS (String -> FastString
fsLit String
s))     -- string literal

  CtEvidence
ordIntEv <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
ordCls [Type
intTy])
  let ordIntDict :: CoreExpr
ordIntDict = HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ordIntEv

  Id
dId <- Type -> String -> TcPluginM Id
freshId Type
intTy String
"d"
  Id
vId <- Type -> String -> TcPluginM Id
freshId Type
wrappedTy String
"v"

  ([Alt Id]
alts, [[CtEvidence]]
fieldWss) <- ([(Alt Id, [CtEvidence])] -> ([Alt Id], [[CtEvidence]]))
-> TcPluginM [(Alt Id, [CtEvidence])]
-> TcPluginM ([Alt Id], [[CtEvidence]])
forall a b. (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Alt Id, [CtEvidence])] -> ([Alt Id], [[CtEvidence]])
forall a b. [(a, b)] -> ([a], [b])
unzip (TcPluginM [(Alt Id, [CtEvidence])]
 -> TcPluginM ([Alt Id], [[CtEvidence]]))
-> TcPluginM [(Alt Id, [CtEvidence])]
-> TcPluginM ([Alt Id], [[CtEvidence]])
forall a b. (a -> b) -> a -> b
$ [(DataCon, [Coercion])]
-> ((DataCon, [Coercion]) -> TcPluginM (Alt Id, [CtEvidence]))
-> TcPluginM [(Alt Id, [CtEvidence])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(DataCon, [Coercion])]
dcons \(DataCon
dc, [Coercion]
cosI) -> do
    let realFts :: [Type]
realFts = Type -> DataCon -> [Type]
fieldTysAt Type
innerTy DataCon
dc           -- real (bind) types
        modFts :: [Type]
modFts  = (Coercion -> Type) -> [Coercion] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Coercion -> Type
coercionRKind [Coercion]
cosI          -- modifier (show-at) types; real when Refl
        name :: String
name   = OccName -> String
occNameString (DataCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName DataCon
dc)
        labels :: [String]
labels = (FieldLabel -> String) -> [FieldLabel] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> String
occNameString (OccName -> String)
-> (FieldLabel -> OccName) -> FieldLabel -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName) -> (FieldLabel -> Name) -> FieldLabel -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLabel -> Name
flSelector) (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc)
    CoreExpr
nameStr  <- String -> TcPluginM CoreExpr
str String
name
    CoreExpr
nameSp   <- String -> TcPluginM CoreExpr
str (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ")   -- name + the separating space, baked into one literal (as GHC does)
    [Id]
xs       <- (Int -> Type -> TcPluginM Id) -> [Int] -> [Type] -> TcPluginM [Id]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Int
n Type
ft -> Type -> String -> TcPluginM Id
freshId Type
ft (String
"x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [Int
0 :: Int ..] [Type]
realFts
    [CtEvidence]
fieldEvs <- (Type -> TcPluginM CtEvidence) -> [Type] -> TcPluginM [CtEvidence]
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 (\Type
ft -> CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
showCls [Type
ft])) [Type]
modFts
    Id
rest     <- Type -> String -> TcPluginM Id
freshId Type
stringTy String
"r"
    Id
gtBndr   <- Type -> String -> TcPluginM Id
freshId Type
boolTy String
"p"
    Integer
prec     <- DataCon -> TcPluginM Integer
conPrec DataCon
dc

    -- each field shown at its modifier type, with its bound value coerced
    let triples :: [(Type, CtEvidence, CoreExpr)]
triples = [Type]
-> [CtEvidence] -> [CoreExpr] -> [(Type, CtEvidence, CoreExpr)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Type]
modFts [CtEvidence]
fieldEvs ((CoreExpr -> Coercion -> CoreExpr)
-> [CoreExpr] -> [Coercion] -> [CoreExpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith CoreExpr -> Coercion -> CoreExpr
castInto ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
Var [Id]
xs) [Coercion]
cosI)
        spField :: Integer -> (Type, CtEvidence, CoreExpr) -> CoreExpr
spField Integer
p (Type
ft, CtEvidence
ev, CoreExpr
v) =
          CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
showsPrecSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ft, HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ev, Integer -> CoreExpr
mkUncheckedIntExpr Integer
p, CoreExpr
v]
        -- prefix: "K " ++ sp 11 x0 (' ' : sp 11 x1 (… t)) — GHC bakes the first
        -- space into the constructor-name literal, then separates the rest.
        goPrefix :: CoreExpr -> CoreExpr
        goPrefix :: CoreExpr -> CoreExpr
goPrefix CoreExpr
t = case [(Type, CtEvidence, CoreExpr)]
triples of
          []          -> CoreExpr
t
          ((Type, CtEvidence, CoreExpr)
f0 : [(Type, CtEvidence, CoreExpr)]
more) -> CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Integer -> (Type, CtEvidence, CoreExpr) -> CoreExpr
spField Integer
11 (Type, CtEvidence, CoreExpr)
f0)
                             (((Type, CtEvidence, CoreExpr) -> CoreExpr -> CoreExpr)
-> CoreExpr -> [(Type, CtEvidence, 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 (\(Type, CtEvidence, CoreExpr)
fld CoreExpr
acc -> CoreExpr -> CoreExpr -> CoreExpr
cons (Char -> CoreExpr
mkCharExpr Char
' ') (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Integer -> (Type, CtEvidence, CoreExpr) -> CoreExpr
spField Integer
11 (Type, CtEvidence, CoreExpr)
fld) CoreExpr
acc)) CoreExpr
t [(Type, CtEvidence, CoreExpr)]
more)
        -- parenthesise the body when @d >= thr+1@ (i.e. @d > thr@), matching the
        -- @showParen (d >= appPrec1) p@ that GHC's stock @deriving@ emits.  The
        -- shared continuation @g = \\s -> mk s@ is built once (a single join
        -- point, not duplicated inline); an optional @lead@ literal (the
        -- constructor name) is prepended /outside/ @g@ in each branch, exactly
        -- as GHC floats @showString name@ out of the shared part.
        parenAt :: Integer -> Maybe CoreExpr -> (CoreExpr -> CoreExpr) -> CoreExpr -> TcPluginM CoreExpr
        parenAt :: Integer
-> Maybe CoreExpr
-> (CoreExpr -> CoreExpr)
-> CoreExpr
-> TcPluginM CoreExpr
parenAt Integer
thr Maybe CoreExpr
lead CoreExpr -> CoreExpr
mk CoreExpr
t = do
          Id
pId <- Type -> String -> TcPluginM Id
freshId Type
showSTy String
"p"
          Id
sId <- Type -> String -> TcPluginM Id
freshId Type
stringTy String
"s"
          let test :: CoreExpr
              test :: CoreExpr
test = 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
dId, Integer -> CoreExpr
mkUncheckedIntExpr (Integer
thr Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)]
              p :: CoreExpr -> CoreExpr   -- lead ++ g t' (lead prepended outside the shared g)
              p :: CoreExpr -> CoreExpr
p CoreExpr
t' = (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr -> CoreExpr)
-> Maybe CoreExpr
-> CoreExpr
-> CoreExpr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CoreExpr -> CoreExpr
forall a. a -> a
id CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append Maybe CoreExpr
lead (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
pId) CoreExpr
t')
          CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> TcPluginM CoreExpr) -> CoreExpr -> TcPluginM CoreExpr
forall a b. (a -> b) -> a -> b
$ Bind Id -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> Bind Id
forall b. b -> Expr b -> Bind b
NonRec Id
pId (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
sId (CoreExpr -> CoreExpr
mk (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
sId)))) (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
test Id
gtBndr Type
stringTy
              [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
falseDataCon) [] (CoreExpr -> CoreExpr
p CoreExpr
t)
              , AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
trueDataCon)  []
                  (CoreExpr -> CoreExpr -> CoreExpr
cons (Char -> CoreExpr
mkCharExpr Char
'(') (CoreExpr -> CoreExpr
p (CoreExpr -> CoreExpr -> CoreExpr
cons (Char -> CoreExpr
mkCharExpr Char
')') CoreExpr
t))) ]

    CoreExpr
showsBody <-
      if DataCon -> Bool
dataConIsInfix DataCon
dc                                 -- infix: x `op` y at prec
        then do
          CoreExpr
opStr <- String -> TcPluginM CoreExpr
str (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ")
          let [(Type, CtEvidence, CoreExpr)
l, (Type, CtEvidence, CoreExpr)
r] = [(Type, CtEvidence, CoreExpr)]
triples
              body :: CoreExpr -> CoreExpr
body CoreExpr
t = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Integer -> (Type, CtEvidence, CoreExpr) -> CoreExpr
spField (Integer
prec Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) (Type, CtEvidence, CoreExpr)
l) (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
opStr (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Integer -> (Type, CtEvidence, CoreExpr) -> CoreExpr
spField (Integer
prec Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) (Type, CtEvidence, CoreExpr)
r) CoreExpr
t))
          Integer
-> Maybe CoreExpr
-> (CoreExpr -> CoreExpr)
-> CoreExpr
-> TcPluginM CoreExpr
parenAt Integer
prec Maybe CoreExpr
forall a. Maybe a
Nothing CoreExpr -> CoreExpr
body (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
rest)
        else if Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
labels)
          then do                                          -- record: K {l1 = v1, l2 = v2}
            CoreExpr
openB  <- String -> TcPluginM CoreExpr
str String
" {"; CoreExpr
eqB <- String -> TcPluginM CoreExpr
str String
" = "; CoreExpr
commaB <- String -> TcPluginM CoreExpr
str String
", "; CoreExpr
closeB <- String -> TcPluginM CoreExpr
str String
"}"
            [CoreExpr]
lblStrs <- (String -> TcPluginM CoreExpr) -> [String] -> TcPluginM [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 String -> TcPluginM CoreExpr
str [String]
labels
            let recF :: [(CoreExpr, (Type, CtEvidence, CoreExpr))]
recF = [CoreExpr]
-> [(Type, CtEvidence, CoreExpr)]
-> [(CoreExpr, (Type, CtEvidence, CoreExpr))]
forall a b. [a] -> [b] -> [(a, b)]
zip [CoreExpr]
lblStrs [(Type, CtEvidence, CoreExpr)]
triples
                goRec :: [(CoreExpr, (Type, CtEvidence, CoreExpr))] -> CoreExpr -> CoreExpr
goRec [(CoreExpr
lbl, (Type, CtEvidence, CoreExpr)
fld)] CoreExpr
c = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
lbl (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
eqB (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Integer -> (Type, CtEvidence, CoreExpr) -> CoreExpr
spField Integer
0 (Type, CtEvidence, CoreExpr)
fld) (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
closeB CoreExpr
c)))
                goRec ((CoreExpr
lbl, (Type, CtEvidence, CoreExpr)
fld) : [(CoreExpr, (Type, CtEvidence, CoreExpr))]
more) CoreExpr
c =
                  CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
lbl (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
eqB (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Integer -> (Type, CtEvidence, CoreExpr) -> CoreExpr
spField Integer
0 (Type, CtEvidence, CoreExpr)
fld) (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
commaB ([(CoreExpr, (Type, CtEvidence, CoreExpr))] -> CoreExpr -> CoreExpr
goRec [(CoreExpr, (Type, CtEvidence, CoreExpr))]
more CoreExpr
c))))
                goRec [] CoreExpr
c = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
closeB CoreExpr
c               -- unreachable (record has fields)
                recBody :: CoreExpr -> CoreExpr
recBody CoreExpr
t = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
nameStr (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
openB ([(CoreExpr, (Type, CtEvidence, CoreExpr))] -> CoreExpr -> CoreExpr
goRec [(CoreExpr, (Type, CtEvidence, CoreExpr))]
recF CoreExpr
t))
            Integer
-> Maybe CoreExpr
-> (CoreExpr -> CoreExpr)
-> CoreExpr
-> TcPluginM CoreExpr
parenAt Integer
10 Maybe CoreExpr
forall a. Maybe a
Nothing CoreExpr -> CoreExpr
recBody (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
rest)
          else if [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
xs
            then CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
append CoreExpr
nameStr (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
rest))          -- nullary: never parenthesised
            else Integer
-> Maybe CoreExpr
-> (CoreExpr -> CoreExpr)
-> CoreExpr
-> TcPluginM CoreExpr
parenAt Integer
10 (CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
nameSp) CoreExpr -> CoreExpr
goPrefix (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
rest)  -- prefix: share fields, prepend name

    (Alt Id, [CtEvidence]) -> TcPluginM (Alt Id, [CtEvidence])
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [Id]
xs (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
rest CoreExpr
showsBody), [CtEvidence]
fieldEvs)

  Id
caseBndr <- Type -> String -> TcPluginM Id
freshId Type
innerTy String
"cb"
  let spImpl :: CoreExpr
spImpl = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
dId, Id
vId] (CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
scrut Id
vId) Id
caseBndr Type
showSTy [Alt Id]
alts)

  -- show x      = showsPrec 0 x ""
  -- showList    = showList__ (showsPrec 0)
  Id
vShow <- Type -> String -> TcPluginM Id
freshId Type
wrappedTy String
"v"
  Id
vList <- Type -> String -> TcPluginM Id
freshId Type
wrappedTy String
"v"
  let showImpl :: CoreExpr
showImpl = Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
vShow (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
spImpl [Integer -> CoreExpr
mkUncheckedIntExpr Integer
0, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
vShow, Type -> CoreExpr
mkNilExpr Type
charTy])
      sp0 :: CoreExpr
sp0      = Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
vList (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
spImpl [Integer -> CoreExpr
mkUncheckedIntExpr Integer
0, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
vList])
      showListImpl :: CoreExpr
showListImpl = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
showList__Id) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
wrappedTy, CoreExpr
sp0]
      dict :: CoreExpr
dict = Class -> Type -> [CoreExpr] -> CoreExpr
mkClassDict Class
showCls Type
wrappedTy [CoreExpr
spImpl, CoreExpr
showImpl, CoreExpr
showListImpl]
      wanteds :: [Ct]
wanteds = CtEvidence -> Ct
mkNonCanonical CtEvidence
ordIntEv
              Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: (CtEvidence -> Ct) -> [CtEvidence] -> [Ct]
forall a b. (a -> b) -> [a] -> [b]
map CtEvidence -> Ct
mkNonCanonical ([[CtEvidence]] -> [CtEvidence]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CtEvidence]]
fieldWss)
  (EvTerm, [Ct]) -> TcPluginM (EvTerm, [Ct])
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> EvTerm
EvExpr CoreExpr
dict, [Ct]
wanteds)

-- | Synthesize a @Bounded@ dictionary.  For an enumeration, @minBound@/@maxBound@
-- are the first/last constructors.  For a single-constructor product, they are
-- that constructor applied to the field types' own @minBound@/@maxBound@.