blob: c8106858b9f2711e3660be1414829ef551edcef1 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
{-
(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.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]) -- 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 [L _ (DefaultDecl _ [])]
= return (Just []) -- Default declaration specifying no types
tcDefaults [L locn (DefaultDecl _ mono_tys)]
= setSrcSpan locn $
addErrCtxt defaultDeclCtxt $
do { ovl_str <- xoptM LangExt.OverloadedStrings
; ext_deflt <- xoptM LangExt.ExtendedDefaultRules
; num_class <- tcLookupClass numClassName
; deflt_str <- if ovl_str
then mapM tcLookupClass [isStringClassName]
else return []
; deflt_interactive <- if ext_deflt
then mapM tcLookupClass interactiveClassNames
else return []
; let deflt_clss = num_class : deflt_str ++ deflt_interactive
; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys
; return (Just tau_tys) }
tcDefaults decls@(L locn (DefaultDecl _ _) : _)
= setSrcSpan locn $
failWithTc (dupDefaultDeclErr decls)
tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type
tc_default_ty deflt_clss hs_ty
= do { ty <- solveEqualities "tc_default_ty" $
tcInferLHsType hs_ty
; ty <- zonkTcTypeToType ty -- establish Type invariants
; checkValidType DefaultDeclCtxt ty
-- Check that the type is an instance of at least one of the deflt_clss
; oks <- mapM (check_instance ty) deflt_clss
; checkTc (or oks) (badDefaultTy ty deflt_clss)
; return ty }
check_instance :: Type -> Class -> 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 cls
| [cls_tv] <- classTyVars cls
, tyVarKind cls_tv `tcEqType` typeKind ty
= simplifyDefault [mkClassPred cls [ty]]
| otherwise
= return False
defaultDeclCtxt :: SDoc
defaultDeclCtxt = text "When checking the types in a default declaration"
dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc
dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things)
= hang (text "Multiple default declarations")
2 (vcat (map pp dup_things))
where
pp :: Located (DefaultDecl GhcRn) -> SDoc
pp (L locn (DefaultDecl _ _))
= text "here was another default declaration" <+> ppr locn
dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"
badDefaultTy :: Type -> [Class] -> SDoc
badDefaultTy ty deflt_clss
= hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))
2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss))
|