{-# LANGUAGE TypeFamilies #-}
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 )
tcDefaults :: [LDefaultDecl GhcRn]
-> TcM DefaultEnv
tcDefaults :: [LDefaultDecl GhcRn] -> TcM DefaultEnv
tcDefaults []
= TcM DefaultEnv
getDeclaredDefaultTys
tcDefaults [LDefaultDecl GhcRn]
decls
= do { ovl_str <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
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 = [Class]
deflt_str [Class] -> [Class] -> [Class]
forall a. [a] -> [a] -> [a]
++ [Class]
deflt_interactive
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
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unit
bignumUnit, Unit
ghcInternalUnit, Unit
primUnit]
; decls' <- case (is_internal_unit, decls) of
(Bool
True, [L SrcSpanAnnA
_ (DefaultDecl XCDefaultDecl GhcRn
_ Maybe (LIdP GhcRn)
Nothing [])]) -> [(GenLocated SrcSpanAnnA (DefaultDecl GhcRn), TyCon, [Type])]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated SrcSpanAnnA (DefaultDecl GhcRn), TyCon, [Type])]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
(Bool, [GenLocated SrcSpanAnnA (DefaultDecl GhcRn)])
_ -> (GenLocated SrcSpanAnnA (DefaultDecl GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (DefaultDecl GhcRn), TyCon, [Type]))
-> [GenLocated SrcSpanAnnA (DefaultDecl GhcRn)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated SrcSpanAnnA (DefaultDecl GhcRn), TyCon, [Type])]
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) -> [a] -> m [b]
mapM ([Class]
-> LDefaultDecl GhcRn -> TcM (LDefaultDecl GhcRn, TyCon, [Type])
declarationParts [Class]
extra_clss) [LDefaultDecl GhcRn]
[GenLocated SrcSpanAnnA (DefaultDecl GhcRn)]
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 :: [Class]
-> LDefaultDecl GhcRn -> TcM (LDefaultDecl GhcRn, TyCon, [Type])
declarationParts [Class]
extra_clss decl :: LDefaultDecl GhcRn
decl@(L SrcSpanAnnA
locn (DefaultDecl XCDefaultDecl GhcRn
_ Maybe (LIdP GhcRn)
cls_tyMaybe [LHsType GhcRn]
mono_tys))
= SDoc
-> TcM (LDefaultDecl GhcRn, TyCon, [Type])
-> TcM (LDefaultDecl GhcRn, TyCon, [Type])
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
defaultDeclCtxt (TcM (LDefaultDecl GhcRn, TyCon, [Type])
-> TcM (LDefaultDecl GhcRn, TyCon, [Type]))
-> TcM (LDefaultDecl GhcRn, TyCon, [Type])
-> TcM (LDefaultDecl GhcRn, TyCon, [Type])
forall a b. (a -> b) -> a -> b
$
SrcSpan
-> TcM (LDefaultDecl GhcRn, TyCon, [Type])
-> TcM (LDefaultDecl GhcRn, TyCon, [Type])
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
locn) (TcM (LDefaultDecl GhcRn, TyCon, [Type])
-> TcM (LDefaultDecl GhcRn, TyCon, [Type]))
-> TcM (LDefaultDecl GhcRn, TyCon, [Type])
-> TcM (LDefaultDecl GhcRn, TyCon, [Type])
forall a b. (a -> b) -> a -> b
$
do { tau_tys <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> TcRn Type)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> TcRn [Type]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM LHsType GhcRn -> TcRn Type
GenLocated SrcSpanAnnA (HsType GhcRn) -> TcRn Type
tc_default_ty [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
mono_tys
; def_clsCon <- case cls_tyMaybe of
Maybe (LIdP GhcRn)
Nothing ->
do { numTyCon <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupTyCon Name
numClassName
; let classTyConAndArgKinds Class
cls = (Class -> TyCon
classTyCon Class
cls, [], TyVar -> Type
tyVarKind (TyVar -> Type) -> [TyVar] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Class -> [TyVar]
classTyVars Class
cls)
tyConsAndArgKinds = (TyCon
numTyCon, [], [Type
liftedTypeKind]) (TyCon, [Type], [Type])
-> [(TyCon, [Type], [Type])] -> [(TyCon, [Type], [Type])]
forall a. a -> [a] -> [a]
: (Class -> (TyCon, [Type], [Type]))
-> [Class] -> [(TyCon, [Type], [Type])]
forall a b. (a -> b) -> [a] -> [b]
map Class -> (TyCon, [Type], [Type])
forall {a}. Class -> (TyCon, [a], [Type])
classTyConAndArgKinds [Class]
extra_clss
; void $ mapAndReportM (check_instance_any tyConsAndArgKinds) tau_tys
; return numTyCon }
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)
; let cls_ty = HsSigType GhcRn -> GenLocated SrcSpanAnnA (HsSigType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsSig { sig_ext :: XHsSig GhcRn
sig_ext = XHsSig GhcRn
NoExtField
noExtField
, sig_bndrs :: HsOuterSigTyVarBndrs GhcRn
sig_bndrs = HsOuterImplicit{hso_ximplicit :: XHsOuterImplicit GhcRn
hso_ximplicit = []}
, sig_body :: LHsType GhcRn
sig_body = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$ XTyVar GhcRn -> PromotionFlag -> LIdP GhcRn -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcRn
forall a. NoAnn a => a
noAnn PromotionFlag
NotPromoted LIdP GhcRn
cls_name})
; (_cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDefault cls_ty
; let clsTyCon = Class -> TyCon
classTyCon Class
cls
; case cls_arg_kinds
of [Type
k] -> IOEnv (Env TcGblEnv TcLclEnv) [()]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOEnv (Env TcGblEnv TcLclEnv) [()]
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) [()]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ (Type -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [Type] -> IOEnv (Env TcGblEnv TcLclEnv) [()]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM ([(TyCon, [Type], [Type])]
-> Type -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_instance_any [(TyCon
clsTyCon, [Type]
cls_tys, [Type
k])]) [Type]
tau_tys
[Type]
_ -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrTc (UserTypeCtxt -> LHsSigType GhcRn -> TcRnMessage
TcRnNonUnaryTypeclassConstraint UserTypeCtxt
DefaultDeclCtxt LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
cls_ty)
; return clsTyCon }
; return (decl, def_clsCon, tau_tys) }
reportDuplicates :: Module
-> [Class]
-> NonEmpty (LDefaultDecl GhcRn, TyCon, [Type])
-> IOEnv (Env TcGblEnv TcLclEnv) [ClassDefaults]
reportDuplicates Module
here [Class]
extra_clss ((LDefaultDecl GhcRn
_, TyCon
clsCon, [Type]
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 :: TyCon
cd_class = TyCon
c, cd_types :: [Type]
cd_types = [Type]
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}
| TyCon
c <- TyCon
clsCon TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: (Class -> TyCon) -> [Class] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map Class -> TyCon
classTyCon [Class]
extra_clss ]
reportDuplicates Module
_ [Class]
_ decls :: NonEmpty (LDefaultDecl GhcRn, TyCon, [Type])
decls@((L SrcSpanAnnA
locn DefaultDecl GhcRn
_, TyCon
cls, [Type]
_) :| [(LDefaultDecl GhcRn, TyCon, [Type])]
_)
= SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
locn) (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrTc (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ TyCon -> NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage
dupDefaultDeclErr TyCon
cls ((GenLocated SrcSpanAnnA (DefaultDecl GhcRn), TyCon, [Type])
-> GenLocated SrcSpanAnnA (DefaultDecl GhcRn)
forall a b c. (a, b, c) -> a
fstOf3 ((GenLocated SrcSpanAnnA (DefaultDecl GhcRn), TyCon, [Type])
-> GenLocated SrcSpanAnnA (DefaultDecl GhcRn))
-> NonEmpty
(GenLocated SrcSpanAnnA (DefaultDecl GhcRn), TyCon, [Type])
-> NonEmpty (GenLocated SrcSpanAnnA (DefaultDecl GhcRn))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (LDefaultDecl GhcRn, TyCon, [Type])
NonEmpty
(GenLocated SrcSpanAnnA (DefaultDecl GhcRn), TyCon, [Type])
decls))
IOEnv (Env TcGblEnv TcLclEnv) ()
-> 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 []
tc_default_ty :: LHsType GhcRn -> TcM Type
tc_default_ty :: LHsType GhcRn -> TcRn Type
tc_default_ty LHsType GhcRn
hs_ty
= do { ty <- String -> TcRn Type -> TcRn Type
forall a. String -> TcM a -> TcM a
solveEqualities String
"tc_default_ty" (TcRn Type -> TcRn Type) -> TcRn Type -> TcRn Type
forall a b. (a -> b) -> a -> b
$
LHsType GhcRn -> TcRn Type
tcInferLHsType LHsType GhcRn
hs_ty
; ty <- zonkTcTypeToType ty
; checkValidType DefaultDeclCtxt ty
; return ty }
check_instance_any :: [(TyCon, [Type], [Kind])] -> Type -> TcM ()
check_instance_any :: [(TyCon, [Type], [Type])]
-> Type -> IOEnv (Env TcGblEnv TcLclEnv) ()
check_instance_any [(TyCon, [Type], [Type])]
deflt_clss Type
ty
= do { oks <- ((TyCon, [Type], [Type]) -> TcRnIf TcGblEnv TcLclEnv Bool)
-> [(TyCon, [Type], [Type])]
-> IOEnv (Env TcGblEnv TcLclEnv) [Bool]
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) -> [a] -> m [b]
mapM (Type -> (TyCon, [Type], [Type]) -> TcRnIf TcGblEnv TcLclEnv Bool
check_instance Type
ty) [(TyCon, [Type], [Type])]
deflt_clss
; checkTc (or oks) (TcRnBadDefaultType ty (map fstOf3 deflt_clss))
}
check_instance :: Type -> (TyCon, [Type], [Kind]) -> TcM Bool
check_instance :: Type -> (TyCon, [Type], [Type]) -> TcRnIf TcGblEnv TcLclEnv Bool
check_instance Type
ty (TyCon
clsTyCon, [Type]
clsArgs, [Type
cls_argKind])
| Type
cls_argKind HasDebugCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqType` HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty
= [Type] -> TcRnIf TcGblEnv TcLclEnv Bool
simplifyDefault [TyCon -> [Type] -> Type
mkTyConApp TyCon
clsTyCon ([Type]
clsArgs [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
ty])]
check_instance Type
_ (TyCon, [Type], [Type])
_
= Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
defaultDeclCtxt :: SDoc
defaultDeclCtxt :: SDoc
defaultDeclCtxt = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"When checking the types in a default declaration"
dupDefaultDeclErr :: TyCon -> NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage
dupDefaultDeclErr :: TyCon -> NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage
dupDefaultDeclErr TyCon
cls (L SrcSpanAnnA
_ DefaultDecl {} :| [LDefaultDecl GhcRn]
dup_things)
= TyCon -> [LDefaultDecl GhcRn] -> TcRnMessage
TcRnMultipleDefaultDeclarations TyCon
cls [LDefaultDecl GhcRn]
dup_things