Default.hs

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

-}
{-# LANGUAGE TypeFamilies #-}

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

import GHC.Prelude

import GHC.Hs
import GHC.Core.Class
import GHC.Core.TyCon (TyCon)
import GHC.Core.Type( typeKind )

import GHC.Types.Var( tyVarKind )
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.HsType
import GHC.Tc.Zonk.Type
import GHC.Tc.Solver
import GHC.Tc.Validity
import GHC.Tc.Utils.TcType
import GHC.Builtin.Names
import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults (..), defaultEnv )
import GHC.Types.Error
import GHC.Types.SrcLoc
import GHC.Unit.Types (Module, bignumUnit, ghcInternalUnit, moduleUnit, primUnit)
import GHC.Utils.Misc (fstOf3, sndOf3)
import GHC.Utils.Outputable
import qualified GHC.LanguageExtensions as LangExt

import Control.Monad (void)
import Data.Function (on)
import Data.List.NonEmpty ( NonEmpty (..), groupBy )


{- 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 []
  = 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 decls
  = do  { 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 []
        ; tcg_env <- getGblEnv
        ; let extra_clss = deflt_str ++ deflt_interactive
              here = tcg_mod tcg_env
              is_internal_unit = moduleUnit here `elem` [bignumUnit, ghcInternalUnit, primUnit]
        ; decls' <- 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.
            (True, [L _ (DefaultDecl _ Nothing [])]) -> pure []
            -- Otherwise we take apart the declaration into the class constructor and its default types.
            _ ->  mapM (declarationParts extra_clss) decls
        ; defaultEnv . concat <$> mapM (reportDuplicates here extra_clss) (groupBy ((==) `on` sndOf3) decls') }
  where
    declarationParts :: [Class] -> LDefaultDecl GhcRn -> TcM (LDefaultDecl GhcRn, TyCon, [Type])
    reportDuplicates :: Module -> [Class] -> NonEmpty (LDefaultDecl GhcRn, TyCon, [Type]) -> TcM [ClassDefaults]
    declarationParts extra_clss decl@(L locn (DefaultDecl _ cls_tyMaybe mono_tys))
      = addErrCtxt defaultDeclCtxt $
        setSrcSpan (locA locn)     $
        do { tau_tys <- mapAndReportM tc_default_ty mono_tys
           ; def_clsCon <- case cls_tyMaybe of
               Nothing ->
                 do { numTyCon <- tcLookupTyCon numClassName
                    ; let classTyConAndArgKinds cls = (classTyCon cls, [], tyVarKind <$> classTyVars cls)
                          tyConsAndArgKinds = (numTyCon, [], [liftedTypeKind]) : map classTyConAndArgKinds extra_clss
                    ; void $ mapAndReportM (check_instance_any tyConsAndArgKinds) tau_tys
                    ; return numTyCon }
               Just cls_name ->
                 do { named_deflt <- xoptM LangExt.NamedDefaults
                    ; checkErr named_deflt (TcRnIllegalNamedDefault decl)
                    ; let cls_ty = noLocA (HsSig { sig_ext   = noExtField
                                                 , sig_bndrs = HsOuterImplicit{hso_ximplicit = []}
                                                 , sig_body  = noLocA $ HsTyVar noAnn NotPromoted cls_name})
                    ; (_cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDefault cls_ty
                    ; let clsTyCon = classTyCon cls
                    ; case cls_arg_kinds
                      of [k] -> void $ mapAndReportM (check_instance_any [(clsTyCon, cls_tys, [k])]) tau_tys
                         _ -> addErrTc (TcRnNonUnaryTypeclassConstraint DefaultDeclCtxt cls_ty)
                    ; return clsTyCon }
           ; return (decl, def_clsCon, tau_tys) }
    reportDuplicates here extra_clss ((_, clsCon, tys) :| [])
      = pure [ ClassDefaults{cd_class = c, cd_types = tys, cd_module = Just here, cd_warn = Nothing}
             | c <- clsCon : map classTyCon extra_clss ]
    -- 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 _ _ decls@((L locn _, cls, _) :| _)
      = setSrcSpan (locA locn) (addErrTc $ dupDefaultDeclErr cls (fstOf3 <$> decls))
        >> pure []

tc_default_ty :: LHsType GhcRn -> TcM Type
tc_default_ty hs_ty
 = do   { ty <- solveEqualities "tc_default_ty" $
                tcInferLHsType hs_ty
        ; ty <- zonkTcTypeToType ty   -- establish Type invariants
        ; checkValidType DefaultDeclCtxt ty
        ; return ty }

-- Check that the type is an instance of at least one of the default classes.
-- Beside the class type constructor, we take the already-supplied type
-- parameters and the expected kinds of the remaining parameters. We report
-- an error unless there's only one remaining parameter to fill and the given
-- type has the expected kind.
check_instance_any :: [(TyCon, [Type], [Kind])] -> Type -> TcM ()
check_instance_any deflt_clss ty
 = do   { oks <- mapM (check_instance ty) deflt_clss
        ; checkTc (or oks) (TcRnBadDefaultType ty (map fstOf3 deflt_clss))
        }

check_instance :: Type -> (TyCon, [Type], [Kind]) -> TcM Bool
-- Check that ty is an instance of cls
-- We only care about whether it worked or not; return a boolean
-- This checks that  cls :: k -> Constraint
-- with just one argument and no polymorphism; if we need to add
-- polymorphism we can make it more complicated.  For now we are
-- concerned with classes like
--    Num      :: Type -> Constraint
--    Foldable :: (Type->Type) -> Constraint
check_instance ty (clsTyCon, clsArgs, [cls_argKind])
  | cls_argKind `tcEqType` typeKind ty
  = simplifyDefault [mkTyConApp clsTyCon (clsArgs ++ [ty])]
check_instance _ _
  = return False

defaultDeclCtxt :: SDoc
defaultDeclCtxt = text "When checking the types in a default declaration"

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