{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1993-1998

-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}

-- | Typechecking @default@ declarations
module GHC.Tc.Gen.Default ( tcDefaults ) where

import GHC.Prelude
import GHC.Hs

import GHC.Builtin.Names
import GHC.Core.Class
import GHC.Core.Predicate ( Pred (..), classifyPredType )

import GHC.Data.Maybe ( firstJusts )

import GHC.Tc.Errors.Types
import GHC.Tc.Gen.HsType
import GHC.Tc.Solver.Monad  ( runTcS )
import GHC.Tc.Solver.Solve  ( solveWanteds )
import GHC.Tc.Types.Constraint ( isEmptyWC, andWC, mkSimpleWC )
import GHC.Tc.Types.Origin  ( CtOrigin(DefaultOrigin) )
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcMType ( newWanted )
import GHC.Tc.Utils.TcType

import GHC.Types.Basic ( TypeOrKind(..) )
import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults (..), defaultEnv )
import GHC.Types.SrcLoc

import GHC.Unit.Types (Module, ghcInternalUnit, moduleUnit)

import GHC.Utils.Misc (fstOf3, sndOf3)
import GHC.Utils.Outputable

import qualified GHC.LanguageExtensions as LangExt

import Data.Function (on)
import Data.List.NonEmpty ( NonEmpty (..), groupBy )
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe)
import Data.Traversable ( for )

{- Note [Named default declarations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
With the `NamedDefaults` language extension, a `default` declaration can specify type-class
defaulting behaviour for specific classes. For example

      class C a where
        ...
      default C( Int, Bool )  -- The default types for class C

The `default` declaration tells GHC to default unresolved constraints (C a) to (C Int) or
(C Bool), in that order. Of course, if you don't specify a class, thus

    default (Int, Bool)

the default declaration behaves as before, affecting primarily the `Num` class.

Moreover, a module export list can specify a list of classes whose defaults should be
exported.  For example

    module M( C, default C )

would export the above `default` declaration for `C`.

See details at
https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0409-exportable-named-default.rst

The moving parts are as follows:

* Language.Haskell.Syntax.Decls.DefaultDecl: A `DefaultDecl` optionally carries
  the specified class.

* Parsing and renaming are entirely straightforward.

* The typechecker maintains a `DefaultEnv` (see GHC.Types.DefaultEnv)
  which maps a class to a `ClassDefaults`.  The `ClassDefaults` for a class
  specifies the defaults for that class, in the current module.

* The `DefaultEnv` of all defaults in scope in a module is kept in the `tcg_default`
  field of `TcGblEnv`.

* This field is populated by `GHC.Tc.Gen.Default.tcDefaults` which typechecks
  any local or imported `default` declarations.

* Only a single default declaration can be in effect in any single module for
  any particular class. We issue an error if a single module contains two
  default declarations for the same class, a possible warning if it imports
  them.

  See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module

* There is a _default_ `DefaultEnv` even in absence of any user-declared
  `default` declarations. It is determined by the presence of the
  `ExtendedDefaultRules` and `OverloadedStrings` extensions. If neither of these
  extensions nor user-declared declarations are present, the `DefaultEnv` will
  in effect be `default Num (Integer, Double)` as specified by Haskell Language
  Report.

  See Note [Default class defaults] in GHC.Tc.Utils.Env

* Beside the defaults, the `ExtendedDefaultRules` and `OverloadedStrings`
  extensions also affect the traditional `default` declarations that don't name
  the class. They have no effect on declarations with explicit class name.
  For details of their operation see the corresponding sections of GHC User's Guide:
  - https://downloads.haskell.org/ghc/latest/docs/users_guide/ghci.html#extension-ExtendedDefaultRules
  - https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/overloaded_strings.html#extension-OverloadedStrings

* The module's `tcg_default` is consulted when defaulting unsolved constraints,
  in GHC.Tc.Solver.applyDefaultingRules.
  See Note [How type-class constraints are defaulted] in GHC.Tc.Solver

* Class defaults are imported automatically, like class instances. They are
  tracked separately from `ImportAvails`, and returned separately from them by
  `GHC.Rename.Names.rnImports`.

* Class defaults are exported explicitly, as the example above shows. A module's
  exported defaults are tracked in `tcg_default_exports`, which are then
  transferred to `mg_defaults`, `md_defaults`, and `mi_defaults_`.
  See Note [Default exports] in GHC.Tc.Gen.Export

* Since the class defaults merely help the solver infer the correct types, they
  leave no trace in Haskell Core.
-}

-- See Note [Named default declarations]
tcDefaults :: [LDefaultDecl GhcRn]
           -> TcM DefaultEnv  -- Defaulting types to heave
                              -- into Tc monad for later use
                              -- in Disambig.

tcDefaults :: [LDefaultDecl GhcRn] -> TcM DefaultEnv
tcDefaults []
  = TcM DefaultEnv
getDeclaredDefaultTys       -- No default declaration, so get the
                                -- default types from the envt;
                                -- i.e. use the current ones
                                -- (the caller will put them back there)
        -- It's important not to return defaultDefaultTys here (which
        -- we used to do) because in a TH program, tcDefaults [] is called
        -- repeatedly, once for each group of declarations between top-level
        -- splices.  We don't want to carefully set the default types in
        -- one group, only for the next group to ignore them and install
        -- defaultDefaultTys

tcDefaults [LDefaultDecl GhcRn]
decls
  = do  { tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; let
            here = TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
            is_internal_unit = Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
here Unit -> Unit -> Bool
forall a. Eq a => a -> a -> Bool
== Unit
ghcInternalUnit
        ; case (is_internal_unit, decls) of
            -- Some internal GHC modules contain @default ()@ to declare that no defaults can take place
            -- in the module.
            -- We shortcut the treatment of such a default declaration with no class nor types: we won't
            -- try to point 'cd_class' to 'Num' since it may not even exist yet.
          { (Bool
True, [L SrcSpanAnnA
_ (DefaultDecl XCDefaultDecl GhcRn
_ Maybe (LIdP GhcRn)
Nothing [])])
              -> DefaultEnv -> TcM DefaultEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DefaultEnv -> TcM DefaultEnv) -> DefaultEnv -> TcM DefaultEnv
forall a b. (a -> b) -> a -> b
$ [ClassDefaults] -> DefaultEnv
defaultEnv []
            -- Otherwise we take apart the declaration into the class constructor and its default types.
          ; (Bool, [GenLocated SrcSpanAnnA (DefaultDecl GhcRn)])
_ ->
    do  { h2010_dflt_clss <- TcM (NonEmpty Class)
getH2010DefaultClasses
        ; decls' <- mapMaybeM (declarationParts h2010_dflt_clss) decls
        ; let
            -- Find duplicate default declarations
            decl_tag (Maybe Class
mb_cls, GenLocated SrcSpanAnnA (DefaultDecl GhcRn)
_, [TcType]
_) =
              case Maybe Class
mb_cls of
                Maybe Class
Nothing -> Maybe Class
forall a. Maybe a
Nothing
                Just Class
cls -> if Class
cls Class -> NonEmpty Class -> Bool
forall a. Eq a => a -> NonEmpty a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` NonEmpty Class
h2010_dflt_clss
                            then Maybe Class
forall a. Maybe a
Nothing
                            else Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls
            decl_groups = ((Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
  [TcType])
 -> (Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
     [TcType])
 -> Bool)
-> [(Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
     [TcType])]
-> [NonEmpty
      (Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
       [TcType])]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
groupBy (Maybe Class -> Maybe Class -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Maybe Class -> Maybe Class -> Bool)
-> ((Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
     [TcType])
    -> Maybe Class)
-> (Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
    [TcType])
-> (Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
    [TcType])
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn), [TcType])
-> Maybe Class
decl_tag) [(Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
  [TcType])]
decls'
        ; decls_without_dups <- mapM (reportDuplicates here h2010_dflt_clss) decl_groups
        ; return $ defaultEnv (concat decls_without_dups)
        } } }
  where
    getH2010DefaultClasses :: TcM (NonEmpty Class)
    -- All the classes subject to defaulting with a Haskell 2010 default
    -- declaration, of the form:
    --
    --   default (Int, Bool, Float)
    --
    -- Specifically:
    --    No extensions:       Num
    --    OverloadedStrings:   add IsString
    --    ExtendedDefaults:    add Show, Eq, Ord, Foldable, Traversable
    getH2010DefaultClasses :: TcM (NonEmpty Class)
getH2010DefaultClasses
      = do { num_cls <- Name -> TcM Class
tcLookupClass Name
numClassName
           ; ovl_str   <- xoptM LangExt.OverloadedStrings
           ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules
           ; deflt_str <- if ovl_str
                          then mapM tcLookupClass [isStringClassName]
                          else return []
           ; deflt_interactive <- if ext_deflt
                                  then mapM tcLookupClass interactiveClassNames
                                  else return []
           ; let extra_clss = [Class]
deflt_str [Class] -> [Class] -> [Class]
forall a. [a] -> [a] -> [a]
++ [Class]
deflt_interactive
           ; return $ num_cls :| extra_clss
           }
    declarationParts :: NonEmpty Class -> LDefaultDecl GhcRn -> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [Type]))
    declarationParts :: NonEmpty Class
-> LDefaultDecl GhcRn
-> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [TcType]))
declarationParts NonEmpty Class
h2010_dflt_clss decl :: LDefaultDecl GhcRn
decl@(L SrcSpanAnnA
locn (DefaultDecl XCDefaultDecl GhcRn
_ Maybe (LIdP GhcRn)
mb_cls_name [LHsType GhcRn]
dflt_hs_tys))
      = SrcSpan
-> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [TcType]))
-> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [TcType]))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
locn) (TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [TcType]))
 -> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [TcType])))
-> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [TcType]))
-> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [TcType]))
forall a b. (a -> b) -> a -> b
$
          case Maybe (LIdP GhcRn)
mb_cls_name of
            -- Haskell 98 default declaration
            Maybe (LIdP GhcRn)
Nothing ->
              do { tau_tys <- ErrCtxtMsg -> TcM [TcType] -> TcM [TcType]
forall a. ErrCtxtMsg -> TcM a -> TcM a
addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list :: Bool
ddec_in_type_list = Bool
True })
                            (TcM [TcType] -> TcM [TcType]) -> TcM [TcType] -> TcM [TcType]
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsType GhcRn)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType))
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> TcM [TcType]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (NonEmpty Class
-> LHsType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType)
check_instance_any NonEmpty Class
h2010_dflt_clss) [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
dflt_hs_tys
                 ; return $ Just (Nothing, decl, tau_tys) }
            -- Named default declaration
            Just LIdP GhcRn
cls_name ->
              do { named_deflt <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.NamedDefaults
                 ; checkErr named_deflt (TcRnIllegalNamedDefault decl)
                 ; mb_cls <- addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list = False })
                           $ tcDefaultDeclClass cls_name
                 ; for mb_cls $ \ Class
cls ->
              do { tau_tys <- ErrCtxtMsg -> TcM [TcType] -> TcM [TcType]
forall a. ErrCtxtMsg -> TcM a -> TcM a
addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list :: Bool
ddec_in_type_list = Bool
True })
                            (TcM [TcType] -> TcM [TcType]) -> TcM [TcType] -> TcM [TcType]
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsType GhcRn)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType))
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> TcM [TcType]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (NonEmpty Class
-> LHsType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType)
check_instance_any (Class -> NonEmpty Class
forall a. a -> NonEmpty a
NE.singleton Class
cls)) [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
dflt_hs_tys
                 ; return (Just cls, decl, tau_tys)
                 } }

    reportDuplicates :: Module -> NonEmpty Class -> NonEmpty (Maybe Class, LDefaultDecl GhcRn, [Type]) -> TcM [ClassDefaults]
    reportDuplicates :: Module
-> NonEmpty Class
-> NonEmpty (Maybe Class, LDefaultDecl GhcRn, [TcType])
-> IOEnv (Env TcGblEnv TcLclEnv) [ClassDefaults]
reportDuplicates Module
here NonEmpty Class
h2010_dflt_clss ((Maybe Class
mb_cls, LDefaultDecl GhcRn
_, [TcType]
tys) :| [])
      = [ClassDefaults] -> IOEnv (Env TcGblEnv TcLclEnv) [ClassDefaults]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ ClassDefaults{cd_class :: Class
cd_class = Class
c, cd_types :: [TcType]
cd_types = [TcType]
tys, cd_module :: Maybe Module
cd_module = Module -> Maybe Module
forall a. a -> Maybe a
Just Module
here, cd_warn :: Maybe (WarningTxt GhcRn)
cd_warn = Maybe (WarningTxt GhcRn)
forall a. Maybe a
Nothing }
             | Class
c <- case Maybe Class
mb_cls of
                      Maybe Class
Nothing  -> NonEmpty Class -> [Class]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Class
h2010_dflt_clss
                      Just Class
cls -> [Class
cls]
             ]
    -- Report an error on multiple default declarations for the same class in the same module.
    -- See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module
    reportDuplicates Module
_ (Class
num_cls :| [Class]
_) decls :: NonEmpty (Maybe Class, LDefaultDecl GhcRn, [TcType])
decls@((Maybe Class
_, L SrcSpanAnnA
locn DefaultDecl GhcRn
_, [TcType]
_) :| [(Maybe Class, LDefaultDecl GhcRn, [TcType])]
_)
      = SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
locn) (TcRnMessage -> TcRn ()
addErrTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Class -> NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage
dupDefaultDeclErr Class
cls ((Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn), [TcType])
-> GenLocated SrcSpanAnnA (DefaultDecl GhcRn)
forall a b c. (a, b, c) -> b
sndOf3 ((Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
  [TcType])
 -> GenLocated SrcSpanAnnA (DefaultDecl GhcRn))
-> NonEmpty
     (Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn), [TcType])
-> NonEmpty (GenLocated SrcSpanAnnA (DefaultDecl GhcRn))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Maybe Class, LDefaultDecl GhcRn, [TcType])
NonEmpty
  (Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn), [TcType])
decls))
        TcRn ()
-> IOEnv (Env TcGblEnv TcLclEnv) [ClassDefaults]
-> IOEnv (Env TcGblEnv TcLclEnv) [ClassDefaults]
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [ClassDefaults] -> IOEnv (Env TcGblEnv TcLclEnv) [ClassDefaults]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      where
        cls :: Class
cls = Class -> Maybe Class -> Class
forall a. a -> Maybe a -> a
fromMaybe Class
num_cls (Maybe Class -> Class) -> Maybe Class -> Class
forall a b. (a -> b) -> a -> b
$ NonEmpty (Maybe Class) -> Maybe Class
forall (f :: * -> *) a. Foldable f => f (Maybe a) -> Maybe a
firstJusts (((Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
  [TcType])
 -> Maybe Class)
-> NonEmpty
     (Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn), [TcType])
-> NonEmpty (Maybe Class)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn), [TcType])
-> Maybe Class
forall a b c. (a, b, c) -> a
fstOf3 NonEmpty (Maybe Class, LDefaultDecl GhcRn, [TcType])
NonEmpty
  (Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn), [TcType])
decls)

-- | Check that the type is an instance of at least one of the default classes.
--
-- See Note [Instance check for default declarations]
check_instance_any :: NonEmpty Class
                        -- ^ classes, all assumed to be unary
                   -> LHsType GhcRn
                        -- ^ default type
                   -> TcM (Maybe Type)
check_instance_any :: NonEmpty Class
-> LHsType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType)
check_instance_any NonEmpty Class
deflt_clss LHsType GhcRn
ty
  = do  { oks <- (Class -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType))
-> NonEmpty Class
-> IOEnv (Env TcGblEnv TcLclEnv) (NonEmpty (Maybe TcType))
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) -> NonEmpty a -> m (NonEmpty b)
mapM (\ Class
cls -> Class
-> LHsType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType)
simplifyDefault Class
cls LHsType GhcRn
ty) NonEmpty Class
deflt_clss
        ; case firstJusts oks of
            Maybe TcType
Nothing ->
             do { TcRnMessage -> TcRn ()
addErrTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ LHsType GhcRn -> NonEmpty Class -> TcRnMessage
TcRnBadDefaultType LHsType GhcRn
ty NonEmpty Class
deflt_clss
                ; Maybe TcType -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TcType
forall a. Maybe a
Nothing }
            Just TcType
ty ->
             Maybe TcType -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TcType -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType))
-> Maybe TcType -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType)
forall a b. (a -> b) -> a -> b
$ TcType -> Maybe TcType
forall a. a -> Maybe a
Just TcType
ty
        }

-- | Given a class @C@ and a type @ty@, is @C ty@ soluble?
--
-- Used to check that a type is an instance of a class in a default
-- declaration.
--
-- See Note [Instance check for default declarations] in GHC.Tc.Solver.Default.
simplifyDefault
  :: Class -- ^ class, assumed to be unary,i.e. it takes some invisible arguments
           -- and then a single (final) visible argument
  -> LHsType GhcRn -- ^ default type
  -> TcM (Maybe Type)
simplifyDefault :: Class
-> LHsType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TcType)
simplifyDefault Class
cls dflt_ty :: LHsType GhcRn
dflt_ty@(L SrcSpanAnnA
l HsType GhcRn
_)
  = do { let app_ty :: LHsType GhcRn
             app_ty :: LHsType GhcRn
app_ty = SrcSpanAnnA
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XAppTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy XAppTy GhcRn
NoExtField
noExtField (PromotionFlag -> IdP GhcRn -> LHsType GhcRn
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar PromotionFlag
NotPromoted (Class -> Name
className Class
cls)) LHsType GhcRn
dflt_ty
       ; (inst_pred, wtds) <- TcM TcType -> TcM (TcType, WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM TcType -> TcM (TcType, WantedConstraints))
-> TcM TcType -> TcM (TcType, WantedConstraints)
forall a b. (a -> b) -> a -> b
$ LHsType GhcRn -> TcType -> TcM TcType
tcCheckLHsType LHsType GhcRn
app_ty TcType
constraintKind
       ; wtd_inst <- newWanted DefaultOrigin (Just TypeLevel) inst_pred
       ; let all_wanteds = WantedConstraints
wtds WantedConstraints -> WantedConstraints -> WantedConstraints
`andWC` [CtEvidence] -> WantedConstraints
mkSimpleWC [CtEvidence
wtd_inst]
       ; (unsolved, _) <- runTcS $ solveWanteds all_wanteds
       ; traceTc "simplifyDefault" $
           vcat [ text "cls:" <+> ppr cls
                , text "dflt_ty:" <+> ppr dflt_ty
                , text "inst_pred:" <+> ppr inst_pred
                , text "all_wanteds " <+> ppr all_wanteds
                , text "unsolved:" <+> ppr unsolved ]
       ; let is_instance = WantedConstraints -> Bool
isEmptyWC WantedConstraints
unsolved
       ; return $
           if | is_instance
              , ClassPred _ tys <- classifyPredType inst_pred
              -- inst_pred looks like (C @k1 .. @kn t);
              -- we want the final (visible) argument `t`
              , Just tys_ne <- NE.nonEmpty tys
              -> Just $ NE.last tys_ne
              | otherwise
              -> Nothing
       }

dupDefaultDeclErr :: Class -> NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage
dupDefaultDeclErr :: Class -> NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage
dupDefaultDeclErr Class
cls (L SrcSpanAnnA
_ DefaultDecl {} :| [LDefaultDecl GhcRn]
dup_things)
  = Class -> [LDefaultDecl GhcRn] -> TcRnMessage
TcRnMultipleDefaultDeclarations Class
cls [LDefaultDecl GhcRn]
dup_things

{- Note [Instance check for default declarations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we see a named default declaration, such as:

  default C(ty_1, ..., ty_n)

we must check that each of the types 'ty1', ..., 'ty_n' is an instance of
the class 'C'. For each individual type 'ty', the strategy is thus:

  - Create a new Wanted constraint 'C ty', and run the solver on it.
    The default declaration 'default C(ty)' is valid iff the solver succeeds
    in solving this constraint (with no residual unsolved Wanteds).

This is implemented in GHC.Tc.Gen.Default.check_instance, and tested in T25882.

The only slightly subtle point is that we want to allow classes such as

  Typeable :: forall k. k -> Constraint

which take invisible arguments and a (single) visible argument. The function
GHC.Tc.Gen.HsType.tcDefaultDeclClass checks that the class 'C' takes a single
visible parameter.

Note that Haskell98 default declarations, of the form

  default (ty_1, ..., ty_n)

work similarly, except that instead of checking for a single class, we check
whether each type is an instance of:

  - only the Num class, by default
  - ... or the IsString class, with -XOverloadedStrings
  - ... or any of the Show, Eq, Ord, Foldable, and Traversable classes,
        with -XExtendedDefaultRules
-}