never executed always true always false
1 {-# LANGUAGE DeriveDataTypeable #-}
2
3 -- | Warnings for a module
4 module GHC.Unit.Module.Warnings
5 ( Warnings (..)
6 , WarningTxt (..)
7 , pprWarningTxtForMsg
8 , mkIfaceWarnCache
9 , emptyIfaceWarnCache
10 , plusWarns
11 )
12 where
13
14 import GHC.Prelude
15
16 import GHC.Types.SourceText
17 import GHC.Types.Name.Occurrence
18 import GHC.Types.SrcLoc
19
20 import GHC.Utils.Outputable
21 import GHC.Utils.Binary
22
23 import Data.Data
24
25 -- | Warning Text
26 --
27 -- reason/explanation from a WARNING or DEPRECATED pragma
28 data WarningTxt
29 = WarningTxt
30 (Located SourceText)
31 [Located StringLiteral]
32 | DeprecatedTxt
33 (Located SourceText)
34 [Located StringLiteral]
35 deriving (Eq, Data)
36
37 instance Outputable WarningTxt where
38 ppr (WarningTxt lsrc ws)
39 = case unLoc lsrc of
40 NoSourceText -> pp_ws ws
41 SourceText src -> text src <+> pp_ws ws <+> text "#-}"
42
43 ppr (DeprecatedTxt lsrc ds)
44 = case unLoc lsrc of
45 NoSourceText -> pp_ws ds
46 SourceText src -> text src <+> pp_ws ds <+> text "#-}"
47
48 instance Binary WarningTxt where
49 put_ bh (WarningTxt s w) = do
50 putByte bh 0
51 put_ bh s
52 put_ bh w
53 put_ bh (DeprecatedTxt s d) = do
54 putByte bh 1
55 put_ bh s
56 put_ bh d
57
58 get bh = do
59 h <- getByte bh
60 case h of
61 0 -> do s <- get bh
62 w <- get bh
63 return (WarningTxt s w)
64 _ -> do s <- get bh
65 d <- get bh
66 return (DeprecatedTxt s d)
67
68
69 pp_ws :: [Located StringLiteral] -> SDoc
70 pp_ws [l] = ppr $ unLoc l
71 pp_ws ws
72 = text "["
73 <+> vcat (punctuate comma (map (ppr . unLoc) ws))
74 <+> text "]"
75
76
77 pprWarningTxtForMsg :: WarningTxt -> SDoc
78 pprWarningTxtForMsg (WarningTxt _ ws)
79 = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))
80 pprWarningTxtForMsg (DeprecatedTxt _ ds)
81 = text "Deprecated:" <+>
82 doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))
83
84
85 -- | Warning information for a module
86 data Warnings
87 = NoWarnings -- ^ Nothing deprecated
88 | WarnAll WarningTxt -- ^ Whole module deprecated
89 | WarnSome [(OccName,WarningTxt)] -- ^ Some specific things deprecated
90
91 -- Only an OccName is needed because
92 -- (1) a deprecation always applies to a binding
93 -- defined in the module in which the deprecation appears.
94 -- (2) deprecations are only reported outside the defining module.
95 -- this is important because, otherwise, if we saw something like
96 --
97 -- {-# DEPRECATED f "" #-}
98 -- f = ...
99 -- h = f
100 -- g = let f = undefined in f
101 --
102 -- we'd need more information than an OccName to know to say something
103 -- about the use of f in h but not the use of the locally bound f in g
104 --
105 -- however, because we only report about deprecations from the outside,
106 -- and a module can only export one value called f,
107 -- an OccName suffices.
108 --
109 -- this is in contrast with fixity declarations, where we need to map
110 -- a Name to its fixity declaration.
111 deriving( Eq )
112
113 instance Binary Warnings where
114 put_ bh NoWarnings = putByte bh 0
115 put_ bh (WarnAll t) = do
116 putByte bh 1
117 put_ bh t
118 put_ bh (WarnSome ts) = do
119 putByte bh 2
120 put_ bh ts
121
122 get bh = do
123 h <- getByte bh
124 case h of
125 0 -> return NoWarnings
126 1 -> do aa <- get bh
127 return (WarnAll aa)
128 _ -> do aa <- get bh
129 return (WarnSome aa)
130
131 -- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'
132 mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt
133 mkIfaceWarnCache NoWarnings = \_ -> Nothing
134 mkIfaceWarnCache (WarnAll t) = \_ -> Just t
135 mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs)
136
137 emptyIfaceWarnCache :: OccName -> Maybe WarningTxt
138 emptyIfaceWarnCache _ = Nothing
139
140 plusWarns :: Warnings -> Warnings -> Warnings
141 plusWarns d NoWarnings = d
142 plusWarns NoWarnings d = d
143 plusWarns _ (WarnAll t) = WarnAll t
144 plusWarns (WarnAll t) _ = WarnAll t
145 plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2)
146