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

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

-- | Typechecking @default@ declarations
module GHC.Tc.Gen.Default ( tcDefaultDecls, extendDefaultEnvWithLocalDefaults ) 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, maybeToList )

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 (..), lookupDefaultEnv, insertDefaultEnv, DefaultProvenance (..) )
import GHC.Types.SrcLoc

import GHC.Unit.Types (ghcInternalUnit, moduleUnit)

import GHC.Utils.Outputable

import qualified GHC.LanguageExtensions as LangExt

import Data.List.NonEmpty ( NonEmpty (..) )
import qualified Data.List.NonEmpty as NE
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.tcDefaultDecls` 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 [Builtin 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.
  For example,
        module M( ..., default C, ... )
  exports the defaults for class C.

  A module's exported defaults are computed by exports_from_avail,
  tracked in tcg_default_exports, which are then transferred to mg_defaults,
  md_defaults, and mi_defaults_.

  Only defaults explicitly exported are actually exported.
  (i.e. No defaults are exported in a module header like:
          module M where ...)

  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.
-}

-- | Typecheck a collection of default declarations. These can be either:
--
--  - Haskell 98 default declarations, of the form @default (Float, Double)@
--  - Named default declarations, of the form @default Cls(Int, Char)@.
--    See Note [Named default declarations]
tcDefaultDecls :: [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults]
tcDefaultDecls :: [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults]
tcDefaultDecls [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
      -- No default declarations
      (Bool
_, []) -> [LocatedA ClassDefaults] -> TcM [LocatedA ClassDefaults]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      -- As per Remark [default () in ghc-internal] in Note [Builtin class defaults],
      -- some modules in ghc-internal include an empty `default ()` declaration, in order
      -- to disable built-in defaults. This is no longer necessary (see `GHC.Tc.Utils.Env.tcGetDefaultTys`),
      -- but we must still make sure not to error if we fail to look up e.g. the 'Num'
      -- typeclass when typechecking such a default declaration. To do this, we wrap
      -- calls of 'tcLookupClass' in 'tryTc'.
      (Bool
True, [L SrcSpanAnnA
_ (DefaultDecl XCDefaultDecl GhcRn
_ Maybe (LIdP GhcRn)
Nothing [])]) -> do
        h2010_dflt_clss <- (Name -> IOEnv (Env TcGblEnv TcLclEnv) [Class])
-> NonEmpty Name -> IOEnv (Env TcGblEnv TcLclEnv) [Class]
forall (m :: * -> *) (t :: * -> *) b a.
(Applicative m, Foldable t, Monoid b) =>
(a -> m b) -> t a -> m b
foldMapM ((Maybe Class -> [Class])
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Class)
-> IOEnv (Env TcGblEnv TcLclEnv) [Class]
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Class -> [Class]
forall a. Maybe a -> [a]
maybeToList (IOEnv (Env TcGblEnv TcLclEnv) (Maybe Class)
 -> IOEnv (Env TcGblEnv TcLclEnv) [Class])
-> (Name -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Class))
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) [Class]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe Class, Messages TcRnMessage) -> Maybe Class)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Maybe Class, Messages TcRnMessage)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Class)
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Class, Messages TcRnMessage) -> Maybe Class
forall a b. (a, b) -> a
fst (IOEnv (Env TcGblEnv TcLclEnv) (Maybe Class, Messages TcRnMessage)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Class))
-> (Name
    -> IOEnv
         (Env TcGblEnv TcLclEnv) (Maybe Class, Messages TcRnMessage))
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Class)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcRn Class
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Maybe Class, Messages TcRnMessage)
forall a. TcRn a -> TcRn (Maybe a, Messages TcRnMessage)
tryTc (TcRn Class
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (Maybe Class, Messages TcRnMessage))
-> (Name -> TcRn Class)
-> Name
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Maybe Class, Messages TcRnMessage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TcRn Class
tcLookupClass) (NonEmpty Name -> IOEnv (Env TcGblEnv TcLclEnv) [Class])
-> IOEnv (Env TcGblEnv TcLclEnv) (NonEmpty Name)
-> IOEnv (Env TcGblEnv TcLclEnv) [Class]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IOEnv (Env TcGblEnv TcLclEnv) (NonEmpty Name)
forall {gbl} {lcl}. IOEnv (Env gbl lcl) (NonEmpty Name)
getH2010DefaultNames
        case NE.nonEmpty h2010_dflt_clss of
          Maybe (NonEmpty Class)
Nothing -> [LocatedA ClassDefaults] -> TcM [LocatedA ClassDefaults]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
          Just NonEmpty Class
h2010_dflt_clss' -> NonEmpty Class
-> [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults]
toClassDefaults NonEmpty Class
h2010_dflt_clss' [LDefaultDecl GhcRn]
decls
      -- 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
        toClassDefaults h2010_dflt_clss decls
  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 = (Name -> TcRn Class) -> NonEmpty Name -> TcM (NonEmpty Class)
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 Name -> TcRn Class
tcLookupClass (NonEmpty Name -> TcM (NonEmpty Class))
-> IOEnv (Env TcGblEnv TcLclEnv) (NonEmpty Name)
-> TcM (NonEmpty Class)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IOEnv (Env TcGblEnv TcLclEnv) (NonEmpty Name)
forall {gbl} {lcl}. IOEnv (Env gbl lcl) (NonEmpty Name)
getH2010DefaultNames
    getH2010DefaultNames :: IOEnv (Env gbl lcl) (NonEmpty Name)
getH2010DefaultNames
      = do { ovl_str   <- Extension -> TcRnIf gbl lcl Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.OverloadedStrings
           ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules
           ; let deflt_str = if Bool
ovl_str
                              then [Name
isStringClassName]
                              else []
           ; let deflt_interactive = if Bool
ext_deflt
                                  then [Name]
interactiveClassNames
                                  else []
           ; let extra_clss_names = [Name]
deflt_str [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
deflt_interactive
           ; return $ numClassName :| extra_clss_names
           }
    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)
                 } }

    toClassDefaults :: NonEmpty Class -> [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults]
    toClassDefaults :: NonEmpty Class
-> [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults]
toClassDefaults NonEmpty Class
h2010_dflt_clss [LDefaultDecl GhcRn]
dfs = do
        dfs <- (GenLocated SrcSpanAnnA (DefaultDecl GhcRn)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Maybe
         (Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
          [TcType])))
-> [GenLocated SrcSpanAnnA (DefaultDecl GhcRn)]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [(Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
       [TcType])]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (NonEmpty Class
-> LDefaultDecl GhcRn
-> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [TcType]))
declarationParts NonEmpty Class
h2010_dflt_clss) [LDefaultDecl GhcRn]
[GenLocated SrcSpanAnnA (DefaultDecl GhcRn)]
dfs
        return $ concatMap (go False) dfs
      where
        go :: Bool
-> (Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
    [TcType])
-> [LocatedA ClassDefaults]
go Bool
h98 = \case
          (Maybe Class
Nothing, GenLocated SrcSpanAnnA (DefaultDecl GhcRn)
rn_decl, [TcType]
tys) -> ((Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
  [TcType])
 -> [LocatedA ClassDefaults])
-> [(Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
     [TcType])]
-> [LocatedA ClassDefaults]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Bool
-> (Maybe Class, GenLocated SrcSpanAnnA (DefaultDecl GhcRn),
    [TcType])
-> [LocatedA ClassDefaults]
go Bool
True) [(Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls, GenLocated SrcSpanAnnA (DefaultDecl GhcRn)
rn_decl, [TcType]
tys) | Class
cls <- NonEmpty Class -> [Class]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Class
h2010_dflt_clss]
          (Just Class
cls, (L SrcSpanAnnA
locn DefaultDecl GhcRn
_), [TcType]
tys) -> [(SrcSpanAnnA -> ClassDefaults -> LocatedA ClassDefaults
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
locn (ClassDefaults -> LocatedA ClassDefaults)
-> ClassDefaults -> LocatedA ClassDefaults
forall a b. (a -> b) -> a -> b
$ Class
-> [TcType]
-> DefaultProvenance
-> Maybe (WarningTxt GhcRn)
-> ClassDefaults
ClassDefaults Class
cls [TcType]
tys (SrcSpan -> Bool -> DefaultProvenance
DP_Local (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
locn) Bool
h98) Maybe (WarningTxt GhcRn)
forall a. Maybe a
Nothing)]

-- | Extend the default environment with the local default declarations
-- and do the action in the extended environment.
extendDefaultEnvWithLocalDefaults :: [LocatedA ClassDefaults] -> TcM a -> TcM a
extendDefaultEnvWithLocalDefaults :: forall a. [LocatedA ClassDefaults] -> TcM a -> TcM a
extendDefaultEnvWithLocalDefaults [LocatedA ClassDefaults]
decls TcM a
action = do
  tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
  let default_env = TcGblEnv -> DefaultEnv
tcg_default TcGblEnv
tcg_env
  new_default_env <- insertDefaultDecls default_env decls
  updGblEnv (\TcGblEnv
gbl -> TcGblEnv
gbl { tcg_default = new_default_env } ) $ action

-- | Insert local default declarations into the default environment.
--
-- See 'insertDefaultDecl'.
insertDefaultDecls :: DefaultEnv -> [LocatedA ClassDefaults] -> TcM DefaultEnv
insertDefaultDecls :: DefaultEnv -> [LocatedA ClassDefaults] -> TcM DefaultEnv
insertDefaultDecls = (LocatedA ClassDefaults -> DefaultEnv -> TcM DefaultEnv)
-> DefaultEnv -> [LocatedA ClassDefaults] -> TcM DefaultEnv
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM LocatedA ClassDefaults -> DefaultEnv -> TcM DefaultEnv
insertDefaultDecl
-- | Insert a local default declaration into the default environment.
--
-- If the class already has a local default declaration in the DefaultEnv,
-- report an error and return the original DefaultEnv. Otherwise, override
-- any existing default declarations (e.g. imported default declarations).
--
-- See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module
insertDefaultDecl :: LocatedA ClassDefaults -> DefaultEnv -> TcM DefaultEnv
insertDefaultDecl :: LocatedA ClassDefaults -> DefaultEnv -> TcM DefaultEnv
insertDefaultDecl (L SrcSpanAnnA
decl_loc ClassDefaults
new_cls_defaults ) DefaultEnv
default_env =
  case DefaultEnv -> Name -> Maybe ClassDefaults
lookupDefaultEnv DefaultEnv
default_env (Class -> Name
className Class
cls) of
    Just ClassDefaults
cls_defaults
      | DP_Local {} <- ClassDefaults -> DefaultProvenance
cd_provenance ClassDefaults
cls_defaults
      -> do { SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
decl_loc) (TcRnMessage -> TcRn ()
addErrTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Class -> ClassDefaults -> TcRnMessage
TcRnMultipleDefaultDeclarations Class
cls ClassDefaults
cls_defaults)
            ; DefaultEnv -> TcM DefaultEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return DefaultEnv
default_env }
    Maybe ClassDefaults
_ -> 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
insertDefaultEnv ClassDefaults
new_cls_defaults DefaultEnv
default_env
      -- NB: this overrides imported and built-in default declarations
      -- for this class, if there were any.
  where
    cls :: Class
cls = ClassDefaults -> Class
cd_class ClassDefaults
new_cls_defaults


-- | 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
       }

{- 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
-}