{-# LANGUAGE TypeFamilies #-}
module GHC.Tc.Gen.Default ( tcDefaults ) where
import GHC.Prelude
import GHC.Hs
import GHC.Core.Class
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.Utils.Zonk
import GHC.Tc.Solver
import GHC.Tc.Validity
import GHC.Tc.Utils.TcType
import GHC.Builtin.Names
import GHC.Types.Error
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import qualified GHC.LanguageExtensions as LangExt
import Data.List.NonEmpty ( NonEmpty (..) )
tcDefaults :: [LDefaultDecl GhcRn]
-> TcM (Maybe [Type])
tcDefaults :: [LDefaultDecl GhcRn] -> TcM (Maybe [Type])
tcDefaults []
= TcM (Maybe [Type])
getDeclaredDefaultTys
tcDefaults [L SrcSpanAnnA
_ (DefaultDecl XCDefaultDecl GhcRn
_ [])]
= Maybe [Type] -> TcM (Maybe [Type])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> Maybe [Type]
forall a. a -> Maybe a
Just [])
tcDefaults [L SrcSpanAnnA
locn (DefaultDecl XCDefaultDecl GhcRn
_ [LHsType GhcRn]
mono_tys)]
= SrcSpan -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
locn) (TcM (Maybe [Type]) -> TcM (Maybe [Type]))
-> TcM (Maybe [Type]) -> TcM (Maybe [Type])
forall a b. (a -> b) -> a -> b
$
SDoc -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
defaultDeclCtxt (TcM (Maybe [Type]) -> TcM (Maybe [Type]))
-> TcM (Maybe [Type]) -> TcM (Maybe [Type])
forall a b. (a -> b) -> a -> b
$
do { Bool
ovl_str <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.OverloadedStrings
; Bool
ext_deflt <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ExtendedDefaultRules
; Class
num_class <- Name -> TcM Class
tcLookupClass Name
numClassName
; [Class]
deflt_str <- if Bool
ovl_str
then (Name -> TcM Class)
-> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) [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) -> [a] -> m [b]
mapM Name -> TcM Class
tcLookupClass [Name
isStringClassName]
else [Class] -> IOEnv (Env TcGblEnv TcLclEnv) [Class]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
; [Class]
deflt_interactive <- if Bool
ext_deflt
then (Name -> TcM Class)
-> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) [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) -> [a] -> m [b]
mapM Name -> TcM Class
tcLookupClass [Name]
interactiveClassNames
else [Class] -> IOEnv (Env TcGblEnv TcLclEnv) [Class]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
; let deflt_clss :: [Class]
deflt_clss = Class
num_class Class -> [Class] -> [Class]
forall a. a -> [a] -> [a]
: [Class]
deflt_str [Class] -> [Class] -> [Class]
forall a. [a] -> [a] -> [a]
++ [Class]
deflt_interactive
; [Type]
tau_tys <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> TcRn Type)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> TcRn [Type]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM ([Class] -> LHsType GhcRn -> TcRn Type
tc_default_ty [Class]
deflt_clss) [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
mono_tys
; Maybe [Type] -> TcM (Maybe [Type])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> Maybe [Type]
forall a. a -> Maybe a
Just [Type]
tau_tys) }
tcDefaults (decl :: LDefaultDecl GhcRn
decl@(L SrcSpanAnnA
locn (DefaultDecl XCDefaultDecl GhcRn
_ [LHsType GhcRn]
_)) : [LDefaultDecl GhcRn]
decls)
= SrcSpan -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
locn) (TcM (Maybe [Type]) -> TcM (Maybe [Type]))
-> TcM (Maybe [Type]) -> TcM (Maybe [Type])
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcM (Maybe [Type])
forall a. TcRnMessage -> TcM a
failWithTc (NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage
dupDefaultDeclErr (LDefaultDecl GhcRn
GenLocated SrcSpanAnnA (DefaultDecl GhcRn)
declGenLocated SrcSpanAnnA (DefaultDecl GhcRn)
-> [GenLocated SrcSpanAnnA (DefaultDecl GhcRn)]
-> NonEmpty (GenLocated SrcSpanAnnA (DefaultDecl GhcRn))
forall a. a -> [a] -> NonEmpty a
:|[LDefaultDecl GhcRn]
[GenLocated SrcSpanAnnA (DefaultDecl GhcRn)]
decls))
tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type
tc_default_ty :: [Class] -> LHsType GhcRn -> TcRn Type
tc_default_ty [Class]
deflt_clss LHsType GhcRn
hs_ty
= do { Type
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
; Type
ty <- Type -> TcRn Type
zonkTcTypeToType Type
ty
; UserTypeCtxt -> Type -> TcM ()
checkValidType UserTypeCtxt
DefaultDeclCtxt Type
ty
; [Bool]
oks <- (Class -> TcRnIf TcGblEnv TcLclEnv Bool)
-> [Class] -> 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 -> Class -> TcRnIf TcGblEnv TcLclEnv Bool
check_instance Type
ty) [Class]
deflt_clss
; Bool -> TcRnMessage -> TcM ()
checkTc ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
oks) (Type -> [Class] -> TcRnMessage
TcRnBadDefaultType Type
ty [Class]
deflt_clss)
; Type -> TcRn Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty }
check_instance :: Type -> Class -> TcM Bool
check_instance :: Type -> Class -> TcRnIf TcGblEnv TcLclEnv Bool
check_instance Type
ty Class
cls
| [TyVar
cls_tv] <- Class -> [TyVar]
classTyVars Class
cls
, TyVar -> Type
tyVarKind TyVar
cls_tv (() :: Constraint) => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqType` (() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
ty
= [Type] -> TcRnIf TcGblEnv TcLclEnv Bool
simplifyDefault [Class -> [Type] -> Type
mkClassPred Class
cls [Type
ty]]
| Bool
otherwise
= 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 :: NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage
dupDefaultDeclErr :: NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage
dupDefaultDeclErr (L SrcSpanAnnA
_ (DefaultDecl XCDefaultDecl GhcRn
_ [LHsType GhcRn]
_) :| [LDefaultDecl GhcRn]
dup_things)
= [LDefaultDecl GhcRn] -> TcRnMessage
TcRnMultipleDefaultDeclarations [LDefaultDecl GhcRn]
dup_things