{-# 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
  appendId     <- Name -> TcPluginM Id
tcLookupId Name
appendName
  showListName <- lookupOrig gHC_INTERNAL_SHOW (mkVarOcc "showList__")
  showList__Id <- tcLookupId showListName
  ordCls       <- tcLookupClass ordClassName

  let showsPrecSel = String -> Class -> Id
classMethod String
"showsPrec" Class
showCls         -- showsPrec
      geSel        = String -> Class -> Id
classMethod String
">=" Class
ordCls           -- (>=) — GHC parenthesises with @d >= prec+1@
      showSTy      = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
stringTy Type
stringTy     -- ShowS
      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
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
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
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

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

  dId <- freshId intTy "d"
  vId <- freshId wrappedTy "v"

  (alts, fieldWss) <- fmap unzip $ forM 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)
    nameStr  <- String -> TcPluginM CoreExpr
str String
name
    nameSp   <- str (name ++ " ")   -- name + the separating space, baked into one literal (as GHC does)
    xs       <- 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)) [0 :: Int ..] realFts
    fieldEvs <- mapM (\Type
ft -> CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
showCls [Type
ft])) modFts
    rest     <- freshId stringTy "r"
    gtBndr   <- freshId boolTy "p"
    prec     <- conPrec dc

    -- each field shown at its modifier type, with its bound value coerced
    let 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
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
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
thr Maybe CoreExpr
lead CoreExpr -> CoreExpr
mk CoreExpr
t = do
          pId <- Type -> String -> TcPluginM Id
freshId Type
showSTy String
"p"
          sId <- freshId stringTy "s"
          let 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
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')
          pure $ Let (NonRec pId (Lam sId (mk (Var sId)))) $
            Case test gtBndr stringTy
              [ Alt (DataAlt falseDataCon) [] (p t)
              , Alt (DataAlt trueDataCon)  []
                  (cons (mkCharExpr '(') (p (cons (mkCharExpr ')') t))) ]

    showsBody <-
      if dataConIsInfix dc                                 -- infix: x `op` y at prec
        then do
          opStr <- str (" " ++ name ++ " ")
          let [l, r] = triples
              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))
          parenAt prec Nothing body (Var rest)
        else if not (null labels)
          then do                                          -- record: K {l1 = v1, l2 = v2}
            openB  <- str " {"; eqB <- str " = "; commaB <- str ", "; closeB <- str "}"
            lblStrs <- mapM str labels
            let 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
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
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))
            parenAt 10 Nothing recBody (Var rest)
          else if null xs
            then pure (append nameStr (Var rest))          -- nullary: never parenthesised
            else parenAt 10 (Just nameSp) goPrefix (Var rest)  -- prefix: share fields, prepend name

    pure (Alt (DataAlt dc) xs (Lam rest showsBody), fieldEvs)

  caseBndr <- freshId innerTy "cb"
  let 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)
  vShow <- freshId wrappedTy "v"
  vList <- freshId wrappedTy "v"
  let 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      = 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 -> [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 = Class -> Type -> [CoreExpr] -> CoreExpr
mkClassDict Class
showCls Type
wrappedTy [CoreExpr
spImpl, CoreExpr
showImpl, CoreExpr
showListImpl]
      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)
  pure (EvExpr dict, 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@.