{-# 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.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.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
tcDefaults :: [LDefaultDecl GhcRn]
-> TcM (Maybe [Type])
tcDefaults :: [LDefaultDecl GhcRn] -> TcM (Maybe [Type])
tcDefaults []
= TcM (Maybe [Type])
getDeclaredDefaultTys
tcDefaults [L _ (DefaultDecl _ [])]
= Maybe [Type] -> TcM (Maybe [Type])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> Maybe [Type]
forall a. a -> Maybe a
Just [])
tcDefaults [L locn (DefaultDecl _ mono_tys)]
= SrcSpan -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
locn (TcM (Maybe [Type]) -> TcM (Maybe [Type]))
-> TcM (Maybe [Type]) -> TcM (Maybe [Type])
forall a b. (a -> b) -> a -> b
$
MsgDoc -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt MsgDoc
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)
mapM Name -> TcM Class
tcLookupClass [Name
isStringClassName]
else [Class] -> IOEnv (Env TcGblEnv TcLclEnv) [Class]
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)
mapM Name -> TcM Class
tcLookupClass [Name]
interactiveClassNames
else [Class] -> IOEnv (Env TcGblEnv TcLclEnv) [Class]
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 <- (Located (HsType GhcRn) -> TcRn Type)
-> [Located (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) [Located (HsType GhcRn)]
[LHsType GhcRn]
mono_tys
; Maybe [Type] -> TcM (Maybe [Type])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> Maybe [Type]
forall a. a -> Maybe a
Just [Type]
tau_tys) }
tcDefaults decls :: [LDefaultDecl GhcRn]
decls@(L locn (DefaultDecl _ _) : [LDefaultDecl GhcRn]
_)
= SrcSpan -> TcM (Maybe [Type]) -> TcM (Maybe [Type])
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
locn (TcM (Maybe [Type]) -> TcM (Maybe [Type]))
-> TcM (Maybe [Type]) -> TcM (Maybe [Type])
forall a b. (a -> b) -> a -> b
$
MsgDoc -> TcM (Maybe [Type])
forall a. MsgDoc -> TcM a
failWithTc ([Located (DefaultDecl GhcRn)] -> MsgDoc
dupDefaultDeclErr [Located (DefaultDecl GhcRn)]
[LDefaultDecl 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)
mapM (Type -> Class -> TcRnIf TcGblEnv TcLclEnv Bool
check_instance Type
ty) [Class]
deflt_clss
; Bool -> MsgDoc -> TcM ()
checkTc ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
oks) (Type -> [Class] -> MsgDoc
badDefaultTy Type
ty [Class]
deflt_clss)
; Type -> TcRn Type
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 HasDebugCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqType` HasDebugCallStack => 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 (m :: * -> *) a. Monad m => a -> m a
return Bool
False
defaultDeclCtxt :: SDoc
defaultDeclCtxt :: MsgDoc
defaultDeclCtxt = String -> MsgDoc
text String
"When checking the types in a default declaration"
dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc
dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> MsgDoc
dupDefaultDeclErr (L SrcSpan
_ (DefaultDecl XCDefaultDecl GhcRn
_ [LHsType GhcRn]
_) : [Located (DefaultDecl GhcRn)]
dup_things)
= MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Multiple default declarations")
Int
2 ([MsgDoc] -> MsgDoc
vcat ((Located (DefaultDecl GhcRn) -> MsgDoc)
-> [Located (DefaultDecl GhcRn)] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map Located (DefaultDecl GhcRn) -> MsgDoc
pp [Located (DefaultDecl GhcRn)]
dup_things))
where
pp :: Located (DefaultDecl GhcRn) -> SDoc
pp :: Located (DefaultDecl GhcRn) -> MsgDoc
pp (L SrcSpan
locn (DefaultDecl XCDefaultDecl GhcRn
_ [LHsType GhcRn]
_))
= String -> MsgDoc
text String
"here was another default declaration" MsgDoc -> MsgDoc -> MsgDoc
<+> SrcSpan -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr SrcSpan
locn
dupDefaultDeclErr [] = String -> MsgDoc
forall a. String -> a
panic String
"dupDefaultDeclErr []"
badDefaultTy :: Type -> [Class] -> SDoc
badDefaultTy :: Type -> [Class] -> MsgDoc
badDefaultTy Type
ty [Class]
deflt_clss
= MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"The default type" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
ty) MsgDoc -> MsgDoc -> MsgDoc
<+> PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"is not an instance of"))
Int
2 ((MsgDoc -> MsgDoc -> MsgDoc) -> [MsgDoc] -> MsgDoc
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\MsgDoc
a MsgDoc
b -> MsgDoc
a MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"or" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
b) ((Class -> MsgDoc) -> [Class] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map (MsgDoc -> MsgDoc
quotes(MsgDoc -> MsgDoc) -> (Class -> MsgDoc) -> Class -> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr) [Class]
deflt_clss))