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
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
{-# LANGUAGE DeriveDataTypeable #-}
-- | Warnings for a module
module GHC.Unit.Module.Warnings
( Warnings (..)
, WarningTxt (..)
, pprWarningTxtForMsg
, mkIfaceWarnCache
, emptyIfaceWarnCache
, plusWarns
)
where
import GHC.Prelude
import GHC.Types.SourceText
import GHC.Types.Name.Occurrence
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Binary
import Data.Data
-- | Warning Text
--
-- reason/explanation from a WARNING or DEPRECATED pragma
data WarningTxt
= WarningTxt
(Located SourceText)
[Located StringLiteral]
| DeprecatedTxt
(Located SourceText)
[Located StringLiteral]
deriving (Eq, Data)
instance Outputable WarningTxt where
ppr (WarningTxt lsrc ws)
= case unLoc lsrc of
NoSourceText -> pp_ws ws
SourceText src -> text src <+> pp_ws ws <+> text "#-}"
ppr (DeprecatedTxt lsrc ds)
= case unLoc lsrc of
NoSourceText -> pp_ws ds
SourceText src -> text src <+> pp_ws ds <+> text "#-}"
instance Binary WarningTxt where
put_ bh (WarningTxt s w) = do
putByte bh 0
put_ bh s
put_ bh w
put_ bh (DeprecatedTxt s d) = do
putByte bh 1
put_ bh s
put_ bh d
get bh = do
h <- getByte bh
case h of
0 -> do s <- get bh
w <- get bh
return (WarningTxt s w)
_ -> do s <- get bh
d <- get bh
return (DeprecatedTxt s d)
pp_ws :: [Located StringLiteral] -> SDoc
pp_ws [l] = ppr $ unLoc l
pp_ws ws
= text "["
<+> vcat (punctuate comma (map (ppr . unLoc) ws))
<+> text "]"
pprWarningTxtForMsg :: WarningTxt -> SDoc
pprWarningTxtForMsg (WarningTxt _ ws)
= doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))
pprWarningTxtForMsg (DeprecatedTxt _ ds)
= text "Deprecated:" <+>
doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))
-- | Warning information for a module
data Warnings
= NoWarnings -- ^ Nothing deprecated
| WarnAll WarningTxt -- ^ Whole module deprecated
| WarnSome [(OccName,WarningTxt)] -- ^ Some specific things deprecated
-- Only an OccName is needed because
-- (1) a deprecation always applies to a binding
-- defined in the module in which the deprecation appears.
-- (2) deprecations are only reported outside the defining module.
-- this is important because, otherwise, if we saw something like
--
-- {-# DEPRECATED f "" #-}
-- f = ...
-- h = f
-- g = let f = undefined in f
--
-- we'd need more information than an OccName to know to say something
-- about the use of f in h but not the use of the locally bound f in g
--
-- however, because we only report about deprecations from the outside,
-- and a module can only export one value called f,
-- an OccName suffices.
--
-- this is in contrast with fixity declarations, where we need to map
-- a Name to its fixity declaration.
deriving( Eq )
instance Binary Warnings where
put_ bh NoWarnings = putByte bh 0
put_ bh (WarnAll t) = do
putByte bh 1
put_ bh t
put_ bh (WarnSome ts) = do
putByte bh 2
put_ bh ts
get bh = do
h <- getByte bh
case h of
0 -> return NoWarnings
1 -> do aa <- get bh
return (WarnAll aa)
_ -> do aa <- get bh
return (WarnSome aa)
-- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'
mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt
mkIfaceWarnCache NoWarnings = \_ -> Nothing
mkIfaceWarnCache (WarnAll t) = \_ -> Just t
mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs)
emptyIfaceWarnCache :: OccName -> Maybe WarningTxt
emptyIfaceWarnCache _ = Nothing
plusWarns :: Warnings -> Warnings -> Warnings
plusWarns d NoWarnings = d
plusWarns NoWarnings d = d
plusWarns _ (WarnAll t) = WarnAll t
plusWarns (WarnAll t) _ = WarnAll t
plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2)
|
