06b60a6806f7f17a713bb68a45e9b67b85bed7f1
[ghc.git] / compiler / deSugar / PmPpr.hs
1 {-# LANGUAGE CPP #-}
2
3 -- | Provides factilities for pretty-printing 'PmExpr's in a way approriate for
4 -- user facing pattern match warnings.
5 module PmPpr (
6 pprUncovered
7 ) where
8
9 #include "HsVersions.h"
10
11 import GhcPrelude
12
13 import Name
14 import NameEnv
15 import NameSet
16 import UniqDFM
17 import UniqSet
18 import ConLike
19 import DataCon
20 import TysWiredIn
21 import Outputable
22 import Control.Monad.Trans.State.Strict
23 import Maybes
24 import Util
25
26 import TmOracle
27
28 -- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its
29 -- components and refutable shapes associated to any mentioned variables.
30 --
31 -- Example for @([Just p, q], [p :-> [3,4], q :-> [0,5]]):
32 --
33 -- @
34 -- (Just p) q
35 -- where p is not one of {3, 4}
36 -- q is not one of {0, 5}
37 -- @
38 pprUncovered :: ([PmExpr], PmRefutEnv) -> SDoc
39 pprUncovered (expr_vec, refuts)
40 | null cs = fsep vec -- there are no literal constraints
41 | otherwise = hang (fsep vec) 4 $
42 text "where" <+> vcat (map pprRefutableShapes cs)
43 where
44 sdoc_vec = mapM pprPmExprWithParens expr_vec
45 (vec,cs) = runPmPpr sdoc_vec (prettifyRefuts refuts)
46
47 -- | Output refutable shapes of a variable in the form of @var is not one of {2,
48 -- Nothing, 3}@.
49 pprRefutableShapes :: (SDoc,[PmAltCon]) -> SDoc
50 pprRefutableShapes (var, alts)
51 = var <+> text "is not one of" <+> braces (pprWithCommas ppr_alt alts)
52 where
53 ppr_alt (PmAltLit lit) = ppr lit
54
55 {- 1. Literals
56 ~~~~~~~~~~~~~~
57 Starting with a function definition like:
58
59 f :: Int -> Bool
60 f 5 = True
61 f 6 = True
62
63 The uncovered set looks like:
64 { var |> var /= 5, var /= 6 }
65
66 Yet, we would like to print this nicely as follows:
67 x , where x not one of {5,6}
68
69 Since these variables will be shown to the programmer, we give them better names
70 (t1, t2, ..) in 'prettifyRefuts', hence the SDoc in 'PrettyPmRefutEnv'.
71
72 2. Residual Constraints
73 ~~~~~~~~~~~~~~~~~~~~~~~
74 Unhandled constraints that refer to HsExpr are typically ignored by the solver
75 (it does not even substitute in HsExpr so they are even printed as wildcards).
76 Additionally, the oracle returns a substitution if it succeeds so we apply this
77 substitution to the vectors before printing them out (see function `pprOne' in
78 Check.hs) to be more precise.
79 -}
80
81 -- | A 'PmRefutEnv' with pretty names for the occuring variables.
82 type PrettyPmRefutEnv = DNameEnv (SDoc, [PmAltCon])
83
84 -- | Assigns pretty names to constraint variables in the domain of the given
85 -- 'PmRefutEnv'.
86 prettifyRefuts :: PmRefutEnv -> PrettyPmRefutEnv
87 prettifyRefuts = listToUDFM . zipWith rename nameList . udfmToList
88 where
89 rename new (old, lits) = (old, (new, lits))
90 -- Try nice names p,q,r,s,t before using the (ugly) t_i
91 nameList :: [SDoc]
92 nameList = map text ["p","q","r","s","t"] ++
93 [ text ('t':show u) | u <- [(0 :: Int)..] ]
94
95 type PmPprM a = State (PrettyPmRefutEnv, NameSet) a
96 -- (the first part of the state is read only. make it a reader?)
97
98 runPmPpr :: PmPprM a -> PrettyPmRefutEnv -> (a, [(SDoc,[PmAltCon])])
99 runPmPpr m lit_env = (result, mapMaybe is_used (udfmToList lit_env))
100 where
101 (result, (_lit_env, used)) = runState m (lit_env, emptyNameSet)
102
103 is_used (k,v)
104 | elemUniqSet_Directly k used = Just v
105 | otherwise = Nothing
106
107 addUsed :: Name -> PmPprM ()
108 addUsed x = modify (\(negated, used) -> (negated, extendNameSet used x))
109
110 checkNegation :: Name -> PmPprM (Maybe SDoc) -- the clean name if it is negated
111 checkNegation x = do
112 negated <- gets fst
113 return $ case lookupDNameEnv negated x of
114 Just (new, _) -> Just new
115 Nothing -> Nothing
116
117 -- | Pretty print a pmexpr, but remember to prettify the names of the variables
118 -- that refer to neg-literals. The ones that cannot be shown are printed as
119 -- underscores.
120 pprPmExpr :: PmExpr -> PmPprM SDoc
121 pprPmExpr (PmExprVar x) = do
122 mb_name <- checkNegation x
123 case mb_name of
124 Just name -> addUsed x >> return name
125 Nothing -> return underscore
126 pprPmExpr (PmExprCon con args) = pprPmExprCon con args
127 pprPmExpr (PmExprLit l) = return (ppr l)
128 pprPmExpr (PmExprOther _) = return underscore -- don't show
129
130 needsParens :: PmExpr -> Bool
131 needsParens (PmExprVar {}) = False
132 needsParens (PmExprLit l) = isNegatedPmLit l
133 needsParens (PmExprOther {}) = False -- will become a wildcard
134 needsParens (PmExprCon (RealDataCon c) es)
135 | isTupleDataCon c
136 || isConsDataCon c || null es = False
137 | otherwise = True
138 needsParens (PmExprCon (PatSynCon _) es) = not (null es)
139
140 pprPmExprWithParens :: PmExpr -> PmPprM SDoc
141 pprPmExprWithParens expr
142 | needsParens expr = parens <$> pprPmExpr expr
143 | otherwise = pprPmExpr expr
144
145 pprPmExprCon :: ConLike -> [PmExpr] -> PmPprM SDoc
146 pprPmExprCon (RealDataCon con) args
147 | isTupleDataCon con = mkTuple <$> mapM pprPmExpr args
148 | isConsDataCon con = pretty_list
149 where
150 mkTuple :: [SDoc] -> SDoc
151 mkTuple = parens . fsep . punctuate comma
152
153 -- lazily, to be used in the list case only
154 pretty_list :: PmPprM SDoc
155 pretty_list = case isNilPmExpr (last list) of
156 True -> brackets . fsep . punctuate comma <$> mapM pprPmExpr (init list)
157 False -> parens . hcat . punctuate colon <$> mapM pprPmExpr list
158
159 list = list_elements args
160
161 list_elements [x,y]
162 | PmExprCon c es <- y, RealDataCon nilDataCon == c
163 = ASSERT(null es) [x,y]
164 | PmExprCon c es <- y, RealDataCon consDataCon == c
165 = x : list_elements es
166 | otherwise = [x,y]
167 list_elements list = pprPanic "list_elements:" (ppr list)
168 pprPmExprCon cl args
169 | conLikeIsInfix cl = case args of
170 [x, y] -> do x' <- pprPmExprWithParens x
171 y' <- pprPmExprWithParens y
172 return (x' <+> ppr cl <+> y')
173 -- can it be infix but have more than two arguments?
174 list -> pprPanic "pprPmExprCon:" (ppr list)
175 | null args = return (ppr cl)
176 | otherwise = do args' <- mapM pprPmExprWithParens args
177 return (fsep (ppr cl : args'))
178
179 -- | Check whether a literal is negated
180 isNegatedPmLit :: PmLit -> Bool
181 isNegatedPmLit (PmOLit b _) = b
182 isNegatedPmLit _other_lit = False
183
184 -- | Check whether a PmExpr is syntactically e
185 isNilPmExpr :: PmExpr -> Bool
186 isNilPmExpr (PmExprCon c _) = c == RealDataCon nilDataCon
187 isNilPmExpr _other_expr = False
188
189 -- | Check if a DataCon is (:).
190 isConsDataCon :: DataCon -> Bool
191 isConsDataCon con = consDataCon == con