Default.hs

{-
(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 decls =
  do
    tcg_env <- getGblEnv
    let here = tcg_mod tcg_env
        is_internal_unit = moduleUnit here == ghcInternalUnit
    case (is_internal_unit, decls) of
      -- No default declarations
      (_, []) -> 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'.
      (True, [L _ (DefaultDecl _ Nothing [])]) -> do
        h2010_dflt_clss <- foldMapM (fmap maybeToList . fmap fst . tryTc . tcLookupClass) =<< getH2010DefaultNames
        case NE.nonEmpty h2010_dflt_clss of
          Nothing -> return []
          Just h2010_dflt_clss' -> toClassDefaults h2010_dflt_clss' decls
      -- Otherwise we take apart the declaration into the class constructor and its default types.
      _ -> do
        h2010_dflt_clss <- 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 = mapM tcLookupClass =<< getH2010DefaultNames
    getH2010DefaultNames
      = do { ovl_str   <- xoptM LangExt.OverloadedStrings
           ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules
           ; let deflt_str = if ovl_str
                              then [isStringClassName]
                              else []
           ; let deflt_interactive = if ext_deflt
                                  then interactiveClassNames
                                  else []
           ; let extra_clss_names = deflt_str ++ deflt_interactive
           ; return $ numClassName :| extra_clss_names
           }
    declarationParts :: NonEmpty Class -> LDefaultDecl GhcRn -> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [Type]))
    declarationParts h2010_dflt_clss decl@(L locn (DefaultDecl _ mb_cls_name dflt_hs_tys))
      = setSrcSpan (locA locn) $
          case mb_cls_name of
            -- Haskell 98 default declaration
            Nothing ->
              do { tau_tys <- addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list = True })
                            $ mapMaybeM (check_instance_any h2010_dflt_clss) dflt_hs_tys
                 ; return $ Just (Nothing, decl, tau_tys) }
            -- Named default declaration
            Just cls_name ->
              do { named_deflt <- xoptM LangExt.NamedDefaults
                 ; checkErr named_deflt (TcRnIllegalNamedDefault decl)
                 ; mb_cls <- addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list = False })
                           $ tcDefaultDeclClass cls_name
                 ; for mb_cls $ \ cls ->
              do { tau_tys <- addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list = True })
                            $ mapMaybeM (check_instance_any (NE.singleton cls)) dflt_hs_tys
                 ; return (Just cls, decl, tau_tys)
                 } }

    toClassDefaults :: NonEmpty Class -> [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults]
    toClassDefaults h2010_dflt_clss dfs = do
        dfs <- mapMaybeM (declarationParts h2010_dflt_clss) dfs
        return $ concatMap (go False) dfs
      where
        go h98 = \case
          (Nothing, rn_decl, tys) -> concatMap (go True) [(Just cls, rn_decl, tys) | cls <- NE.toList h2010_dflt_clss]
          (Just cls, (L locn _), tys) -> [(L locn $ ClassDefaults cls tys (DP_Local (locA locn) h98) 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 decls action = do
  tcg_env <- getGblEnv
  let default_env = tcg_default tcg_env
  new_default_env <- insertDefaultDecls default_env decls
  updGblEnv (\gbl -> gbl { tcg_default = new_default_env } ) $ action

-- | Insert local default declarations into the default environment.
--
-- See 'insertDefaultDecl'.
insertDefaultDecls :: DefaultEnv -> [LocatedA ClassDefaults] -> TcM DefaultEnv
insertDefaultDecls = foldrM 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 (L decl_loc new_cls_defaults ) default_env =
  case lookupDefaultEnv default_env (className cls) of
    Just cls_defaults
      | DP_Local {} <- cd_provenance cls_defaults
      -> do { setSrcSpan (locA decl_loc) (addErrTc $ TcRnMultipleDefaultDeclarations cls cls_defaults)
            ; return default_env }
    _ -> return $ insertDefaultEnv new_cls_defaults default_env
      -- NB: this overrides imported and built-in default declarations
      -- for this class, if there were any.
  where
    cls = cd_class 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 deflt_clss ty
  = do  { oks <- mapM (\ cls -> simplifyDefault cls ty) deflt_clss
        ; case firstJusts oks of
            Nothing ->
             do { addErrTc $ TcRnBadDefaultType ty deflt_clss
                ; return Nothing }
            Just ty ->
             return $ Just 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 cls dflt_ty@(L l _)
  = do { let app_ty :: LHsType GhcRn
             app_ty = L l $ HsAppTy noExtField (nlHsTyVar NotPromoted (className cls)) dflt_ty
       ; (inst_pred, wtds) <- captureConstraints $ tcCheckLHsType app_ty constraintKind
       ; wtd_inst <- newWanted DefaultOrigin (Just TypeLevel) inst_pred
       ; let all_wanteds = wtds `andWC` mkSimpleWC [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 = isEmptyWC 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
-}