Redesign withDict (formerly magicDict)

This gives a more precise type signature to `magicDict` as proposed in #16646.
In addition, this replaces the constant-folding rule for `magicDict` in
`GHC.Core.Opt.ConstantFold` with a special case in the desugarer in
`GHC.HsToCore.Expr.dsHsWrapped`. I have also renamed `magicDict` to `withDict`
in light of the discussion in
https://mail.haskell.org/pipermail/ghc-devs/2021-April/019833.html.
All of this has the following benefits:

* `withDict` is now more type safe than before. Moreover, if a user applies
  `withDict` at an incorrect type, the special-casing in `dsHsWrapped` will
  now throw an error message indicating what the user did incorrectly.
* `withDict` can now work with classes that have multiple type arguments, such
  as `Typeable @k a`. This means that `Data.Typeable.Internal.withTypeable` can
  now be implemented in terms of `withDict`.
* Since the special-casing for `withDict` no longer needs to match on the
  structure of the expression passed as an argument to `withDict`, it no
  longer cares about the presence or absence of `Tick`s. In effect, this
  obsoletes the fix for #19667.

The new `T16646` test case demonstrates the new version of `withDict` in
action, both in terms of `base` functions defined in terms of `withDict`
as well as in terms of functions from the `reflection` and `singletons`
libraries. The `T16646Fail` test case demonstrates the error message that GHC
throws when `withDict` is applied incorrectly.

This fixes #16646. By adding more tests for `withDict`, this also
fixes #19673 as a side effect.

1 files changed, 3 insertions, 21 deletions

diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index 88439edcc6..33ceebe70a 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -37,7 +37,7 @@ import GHC.Prelude
 
 import GHC.Driver.Ppr
 
-import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, magicDictId, voidPrimId )
+import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, voidPrimId )
 
 import GHC.Core
 import GHC.Core.Make
@@ -49,11 +49,11 @@ import GHC.Builtin.Types
 import GHC.Builtin.Types.Prim
 import GHC.Core.TyCon
    ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon
-   , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons
+   , isNewTyCon, tyConDataCons
    , tyConFamilySize )
 import GHC.Core.DataCon ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )
 import GHC.Core.Utils  ( eqExpr, cheapEqExpr, exprIsHNF, exprType
-                       , stripTicksTop, stripTicksTopT, mkTicks, stripTicksE )
+                       , stripTicksTop, stripTicksTopT, mkTicks )
 import GHC.Core.Multiplicity
 import GHC.Core.FVs
 import GHC.Core.Type
@@ -70,7 +70,6 @@ import GHC.Types.Basic
 import GHC.Platform
 import GHC.Utils.Misc
 import GHC.Utils.Panic
-import GHC.Core.Coercion   (mkUnbranchedAxInstCo,mkSymCo,Role(..))
 
 import Control.Applicative ( Alternative(..) )
 
@@ -1739,8 +1738,6 @@ builtinRules
                    ru_nargs = 1, ru_try = match_cstring_length },
      BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
                    ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
-     BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,
-                   ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict },
 
      mkBasicRule unsafeEqualityProofName 3 unsafeEqualityProofRule,
 
@@ -2239,21 +2236,6 @@ match_inline (Type _ : e : _)
 
 match_inline _ = Nothing
 
----------------------------------------------------
--- See Note [magicDictId magic] in "GHC.Types.Id.Make"
--- for a description of what is going on here.
-match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-match_magicDict [Type _, (stripTicksE (const True) -> (Var wrap `App` Type a `App` Type _ `App` f)), x, y ]
-  | Just (_, fieldTy, _)  <- splitFunTy_maybe $ dropForAlls $ idType wrap
-  , Just (_, dictTy, _)   <- splitFunTy_maybe fieldTy
-  , Just dictTc           <- tyConAppTyCon_maybe dictTy
-  , Just (_,_,co)         <- unwrapNewTyCon_maybe dictTc
-  = Just
-  $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] []))
-      `App` y
-
-match_magicDict _ = Nothing
-
 --------------------------------------------------------
 -- Note [Constant folding through nested expressions]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~