Refactor lookupFixityRn-related code following D1744
[ghc.git] / compiler / deSugar / PmExpr.hs
1 {-
2 Author: George Karachalias <george.karachalias@cs.kuleuven.be>
3
4 Haskell expressions (as used by the pattern matching checker) and utilities.
5 -}
6
7 {-# LANGUAGE CPP #-}
8
9 module PmExpr (
10 PmExpr(..), PmLit(..), SimpleEq, ComplexEq, eqPmLit,
11 truePmExpr, falsePmExpr, isTruePmExpr, isFalsePmExpr, isNotPmExprOther,
12 lhsExprToPmExpr, hsExprToPmExpr, substComplexEq, filterComplex,
13 pprPmExprWithParens, runPmPprM
14 ) where
15
16 #include "HsVersions.h"
17
18 import HsSyn
19 import Id
20 import DataCon
21 import TysWiredIn
22 import Outputable
23 import Util
24 import SrcLoc
25 import FastString -- sLit
26 import VarSet
27
28 import Data.Maybe (mapMaybe)
29 import Data.List (groupBy, sortBy, nubBy)
30 import Control.Monad.Trans.State.Lazy
31
32 {-
33 %************************************************************************
34 %* *
35 Lifted Expressions
36 %* *
37 %************************************************************************
38 -}
39
40 {- Note [PmExprOther in PmExpr]
41 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
42 Since there is no plan to extend the (currently pretty naive) term oracle in
43 the near future, instead of playing with the verbose (HsExpr Id), we lift it to
44 PmExpr. All expressions the term oracle does not handle are wrapped by the
45 constructor PmExprOther. Note that we do not perform substitution in
46 PmExprOther. Because of this, we do not even print PmExprOther, since they may
47 refer to variables that are otherwise substituted away.
48 -}
49
50 -- ----------------------------------------------------------------------------
51 -- ** Types
52
53 -- | Lifted expressions for pattern match checking.
54 data PmExpr = PmExprVar Id
55 | PmExprCon DataCon [PmExpr]
56 | PmExprLit PmLit
57 | PmExprEq PmExpr PmExpr -- Syntactic equality
58 | PmExprOther (HsExpr Id) -- Note [PmExprOther in PmExpr]
59
60 -- | Literals (simple and overloaded ones) for pattern match checking.
61 data PmLit = PmSLit HsLit -- simple
62 | PmOLit Bool {- is it negated? -} (HsOverLit Id) -- overloaded
63
64 -- | Equality between literals for pattern match checking.
65 eqPmLit :: PmLit -> PmLit -> Bool
66 eqPmLit (PmSLit l1) (PmSLit l2) = l1 == l2
67 eqPmLit (PmOLit b1 l1) (PmOLit b2 l2) = b1 == b2 && l1 == l2
68 -- See Note [Undecidable Equality for Overloaded Literals]
69 eqPmLit _ _ = False
70
71 {- Note [Undecidable Equality for Overloaded Literals]
72 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
73 Equality on overloaded literals is undecidable in the general case. Consider
74 the following example:
75
76 instance Num Bool where
77 ...
78 fromInteger 0 = False -- C-like representation of booleans
79 fromInteger _ = True
80
81 f :: Bool -> ()
82 f 1 = () -- Clause A
83 f 2 = () -- Clause B
84
85 Clause B is redundant but to detect this, we should be able to solve the
86 constraint: False ~ (fromInteger 2 ~ fromInteger 1) which means that we
87 have to look through function `fromInteger`, whose implementation could
88 be anything. This poses difficulties for:
89
90 1. The expressive power of the check.
91 We cannot expect a reasonable implementation of pattern matching to detect
92 that fromInteger 2 ~ fromInteger 1 is True, unless we unfold function
93 fromInteger. This puts termination at risk and is undecidable in the
94 general case.
95
96 2. Performance.
97 Having an unresolved constraint False ~ (fromInteger 2 ~ fromInteger 1)
98 lying around could become expensive really fast. Ticket #11161 illustrates
99 how heavy use of overloaded literals can generate plenty of those
100 constraints, effectively undermining the term oracle's performance.
101
102 3. Error nessages/Warnings.
103 What should our message for `f` above be? A reasonable approach would be
104 to issue:
105
106 Pattern matches are (potentially) redundant:
107 f 2 = ... under the assumption that 1 == 2
108
109 but seems to complex and confusing for the user.
110
111 We choose to treat overloaded literals that look different as different. The
112 impact of this is the following:
113
114 * Redundancy checking is rather conservative, since it cannot see that clause
115 B above is redundant.
116
117 * We have instant equality check for overloaded literals (we do not rely on
118 the term oracle which is rather expensive, both in terms of performance and
119 memory). This significantly improves the performance of functions `covered`
120 `uncovered` and `divergent` in deSugar/Check.hs and effectively addresses
121 #11161.
122
123 * The warnings issued are simpler.
124
125 * We do not play on the safe side, strictly speaking. The assumption that
126 1 /= 2 makes the redundancy check more conservative but at the same time
127 makes its dual (exhaustiveness check) unsafe. This we can live with, mainly
128 for two reasons:
129 1. At the moment we do not use the results of the check during compilation
130 where this would be a disaster (could result in runtime errors even if
131 our function was deemed exhaustive).
132 2. Pattern matcing on literals can never be considered exhaustive unless we
133 have a catch-all clause. Hence, this assumption affects mainly the
134 appearance of the warnings and is, in practice safe.
135 -}
136
137 nubPmLit :: [PmLit] -> [PmLit]
138 nubPmLit = nubBy eqPmLit
139
140 -- | Term equalities
141 type SimpleEq = (Id, PmExpr) -- We always use this orientation
142 type ComplexEq = (PmExpr, PmExpr)
143
144 -- | Expression `True'
145 truePmExpr :: PmExpr
146 truePmExpr = PmExprCon trueDataCon []
147
148 -- | Expression `False'
149 falsePmExpr :: PmExpr
150 falsePmExpr = PmExprCon falseDataCon []
151
152 -- ----------------------------------------------------------------------------
153 -- ** Predicates on PmExpr
154
155 -- | Check if an expression is lifted or not
156 isNotPmExprOther :: PmExpr -> Bool
157 isNotPmExprOther (PmExprOther _) = False
158 isNotPmExprOther _expr = True
159
160 -- | Check whether a literal is negated
161 isNegatedPmLit :: PmLit -> Bool
162 isNegatedPmLit (PmOLit b _) = b
163 isNegatedPmLit _other_lit = False
164
165 -- | Check whether a PmExpr is syntactically equal to term `True'.
166 isTruePmExpr :: PmExpr -> Bool
167 isTruePmExpr (PmExprCon c []) = c == trueDataCon
168 isTruePmExpr _other_expr = False
169
170 -- | Check whether a PmExpr is syntactically equal to term `False'.
171 isFalsePmExpr :: PmExpr -> Bool
172 isFalsePmExpr (PmExprCon c []) = c == falseDataCon
173 isFalsePmExpr _other_expr = False
174
175 -- | Check whether a PmExpr is syntactically e
176 isNilPmExpr :: PmExpr -> Bool
177 isNilPmExpr (PmExprCon c _) = c == nilDataCon
178 isNilPmExpr _other_expr = False
179
180 -- | Check whether a PmExpr is syntactically equal to (x == y).
181 -- Since (==) is overloaded and can have an arbitrary implementation, we use
182 -- the PmExprEq constructor to represent only equalities with non-overloaded
183 -- literals where it coincides with a syntactic equality check.
184 isPmExprEq :: PmExpr -> Maybe (PmExpr, PmExpr)
185 isPmExprEq (PmExprEq e1 e2) = Just (e1,e2)
186 isPmExprEq _other_expr = Nothing
187
188 -- | Check if a DataCon is (:).
189 isConsDataCon :: DataCon -> Bool
190 isConsDataCon con = consDataCon == con
191
192 -- ----------------------------------------------------------------------------
193 -- ** Substitution in PmExpr
194
195 -- | We return a boolean along with the expression. Hence, if substitution was
196 -- a no-op, we know that the expression still cannot progress.
197 substPmExpr :: Id -> PmExpr -> PmExpr -> (PmExpr, Bool)
198 substPmExpr x e1 e =
199 case e of
200 PmExprVar z | x == z -> (e1, True)
201 | otherwise -> (e, False)
202 PmExprCon c ps -> let (ps', bs) = mapAndUnzip (substPmExpr x e1) ps
203 in (PmExprCon c ps', or bs)
204 PmExprEq ex ey -> let (ex', bx) = substPmExpr x e1 ex
205 (ey', by) = substPmExpr x e1 ey
206 in (PmExprEq ex' ey', bx || by)
207 _other_expr -> (e, False) -- The rest are terminals (We silently ignore
208 -- Other). See Note [PmExprOther in PmExpr]
209
210 -- | Substitute in a complex equality. We return (Left eq) if the substitution
211 -- affected the equality or (Right eq) if nothing happened.
212 substComplexEq :: Id -> PmExpr -> ComplexEq -> Either ComplexEq ComplexEq
213 substComplexEq x e (ex, ey)
214 | bx || by = Left (ex', ey')
215 | otherwise = Right (ex', ey')
216 where
217 (ex', bx) = substPmExpr x e ex
218 (ey', by) = substPmExpr x e ey
219
220 -- -----------------------------------------------------------------------
221 -- ** Lift source expressions (HsExpr Id) to PmExpr
222
223 lhsExprToPmExpr :: LHsExpr Id -> PmExpr
224 lhsExprToPmExpr (L _ e) = hsExprToPmExpr e
225
226 hsExprToPmExpr :: HsExpr Id -> PmExpr
227
228 hsExprToPmExpr (HsVar x) = PmExprVar (unLoc x)
229 hsExprToPmExpr (HsOverLit olit) = PmExprLit (PmOLit False olit)
230 hsExprToPmExpr (HsLit lit) = PmExprLit (PmSLit lit)
231
232 hsExprToPmExpr e@(NegApp _ neg_e)
233 | PmExprLit (PmOLit False ol) <- hsExprToPmExpr neg_e
234 = PmExprLit (PmOLit True ol)
235 | otherwise = PmExprOther e
236 hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e
237
238 hsExprToPmExpr e@(ExplicitTuple ps boxity)
239 | all tupArgPresent ps = PmExprCon tuple_con tuple_args
240 | otherwise = PmExprOther e
241 where
242 tuple_con = tupleDataCon boxity (length ps)
243 tuple_args = [ lhsExprToPmExpr e | L _ (Present e) <- ps ]
244
245 hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems)
246 | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems)
247 | otherwise = PmExprOther e {- overloaded list: No PmExprApp -}
248 where
249 cons x xs = PmExprCon consDataCon [x,xs]
250 nil = PmExprCon nilDataCon []
251
252 hsExprToPmExpr (ExplicitPArr _elem_ty elems)
253 = PmExprCon (parrFakeCon (length elems)) (map lhsExprToPmExpr elems)
254
255 -- we want this but we would have to make evrything monadic :/
256 -- ./compiler/deSugar/DsMonad.hs:397:dsLookupDataCon :: Name -> DsM DataCon
257 --
258 -- hsExprToPmExpr (RecordCon c _ binds) = do
259 -- con <- dsLookupDataCon (unLoc c)
260 -- args <- mapM lhsExprToPmExpr (hsRecFieldsArgs binds)
261 -- return (PmExprCon con args)
262 hsExprToPmExpr e@(RecordCon _ _ _ _) = PmExprOther e
263
264 hsExprToPmExpr (HsTick _ e) = lhsExprToPmExpr e
265 hsExprToPmExpr (HsBinTick _ _ e) = lhsExprToPmExpr e
266 hsExprToPmExpr (HsTickPragma _ _ e) = lhsExprToPmExpr e
267 hsExprToPmExpr (HsSCC _ _ e) = lhsExprToPmExpr e
268 hsExprToPmExpr (HsCoreAnn _ _ e) = lhsExprToPmExpr e
269 hsExprToPmExpr (ExprWithTySig e _) = lhsExprToPmExpr e
270 hsExprToPmExpr (ExprWithTySigOut e _) = lhsExprToPmExpr e
271 hsExprToPmExpr (HsWrap _ e) = hsExprToPmExpr e
272 hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle
273
274 {-
275 %************************************************************************
276 %* *
277 Pretty printing
278 %* *
279 %************************************************************************
280 -}
281
282 {- 1. Literals
283 ~~~~~~~~~~~~~~
284 Starting with a function definition like:
285
286 f :: Int -> Bool
287 f 5 = True
288 f 6 = True
289
290 The uncovered set looks like:
291 { var |> False == (var == 5), False == (var == 6) }
292
293 Yet, we would like to print this nicely as follows:
294 x , where x not one of {5,6}
295
296 Function `filterComplex' takes the set of residual constraints and packs
297 together the negative constraints that refer to the same variable so we can do
298 just this. Since these variables will be shown to the programmer, we also give
299 them better names (t1, t2, ..), hence the SDoc in PmNegLitCt.
300
301 2. Residual Constraints
302 ~~~~~~~~~~~~~~~~~~~~~~~
303 Unhandled constraints that refer to HsExpr are typically ignored by the solver
304 (it does not even substitute in HsExpr so they are even printed as wildcards).
305 Additionally, the oracle returns a substitution if it succeeds so we apply this
306 substitution to the vectors before printing them out (see function `pprOne' in
307 Check.hs) to be more precice.
308 -}
309
310 -- -----------------------------------------------------------------------------
311 -- ** Transform residual constraints in appropriate form for pretty printing
312
313 type PmNegLitCt = (Id, (SDoc, [PmLit]))
314
315 filterComplex :: [ComplexEq] -> [PmNegLitCt]
316 filterComplex = zipWith rename nameList . map mkGroup
317 . groupBy name . sortBy order . mapMaybe isNegLitCs
318 where
319 order x y = compare (fst x) (fst y)
320 name x y = fst x == fst y
321 mkGroup l = (fst (head l), nubPmLit $ map snd l)
322 rename new (old, lits) = (old, (new, lits))
323
324 isNegLitCs (e1,e2)
325 | isFalsePmExpr e1, Just (x,y) <- isPmExprEq e2 = isNegLitCs' x y
326 | isFalsePmExpr e2, Just (x,y) <- isPmExprEq e1 = isNegLitCs' x y
327 | otherwise = Nothing
328
329 isNegLitCs' (PmExprVar x) (PmExprLit l) = Just (x, l)
330 isNegLitCs' (PmExprLit l) (PmExprVar x) = Just (x, l)
331 isNegLitCs' _ _ = Nothing
332
333 -- Try nice names p,q,r,s,t before using the (ugly) t_i
334 nameList :: [SDoc]
335 nameList = map (ptext . sLit) ["p","q","r","s","t"] ++
336 [ ptext (sLit ('t':show u)) | u <- [(0 :: Int)..] ]
337
338 -- ----------------------------------------------------------------------------
339
340 runPmPprM :: PmPprM a -> [PmNegLitCt] -> (a, [(SDoc,[PmLit])])
341 runPmPprM m lit_env = (result, mapMaybe is_used lit_env)
342 where
343 (result, (_lit_env, used)) = runState m (lit_env, emptyVarSet)
344
345 is_used (x,(name, lits))
346 | elemVarSet x used = Just (name, lits)
347 | otherwise = Nothing
348
349 type PmPprM a = State ([PmNegLitCt], IdSet) a
350 -- (the first part of the state is read only. make it a reader?)
351
352 addUsed :: Id -> PmPprM ()
353 addUsed x = modify (\(negated, used) -> (negated, extendVarSet used x))
354
355 checkNegation :: Id -> PmPprM (Maybe SDoc) -- the clean name if it is negated
356 checkNegation x = do
357 negated <- gets fst
358 return $ case lookup x negated of
359 Just (new, _) -> Just new
360 Nothing -> Nothing
361
362 -- | Pretty print a pmexpr, but remember to prettify the names of the variables
363 -- that refer to neg-literals. The ones that cannot be shown are printed as
364 -- underscores.
365 pprPmExpr :: PmExpr -> PmPprM SDoc
366 pprPmExpr (PmExprVar x) = do
367 mb_name <- checkNegation x
368 case mb_name of
369 Just name -> addUsed x >> return name
370 Nothing -> return underscore
371
372 pprPmExpr (PmExprCon con args) = pprPmExprCon con args
373 pprPmExpr (PmExprLit l) = return (ppr l)
374 pprPmExpr (PmExprEq _ _) = return underscore -- don't show
375 pprPmExpr (PmExprOther _) = return underscore -- don't show
376
377 needsParens :: PmExpr -> Bool
378 needsParens (PmExprVar {}) = False
379 needsParens (PmExprLit l) = isNegatedPmLit l
380 needsParens (PmExprEq {}) = False -- will become a wildcard
381 needsParens (PmExprOther {}) = False -- will become a wildcard
382 needsParens (PmExprCon c es)
383 | isTupleDataCon c || isPArrFakeCon c
384 || isConsDataCon c || null es = False
385 | otherwise = True
386
387 pprPmExprWithParens :: PmExpr -> PmPprM SDoc
388 pprPmExprWithParens expr
389 | needsParens expr = parens <$> pprPmExpr expr
390 | otherwise = pprPmExpr expr
391
392 pprPmExprCon :: DataCon -> [PmExpr] -> PmPprM SDoc
393 pprPmExprCon con args
394 | isTupleDataCon con = mkTuple <$> mapM pprPmExpr args
395 | isPArrFakeCon con = mkPArr <$> mapM pprPmExpr args
396 | isConsDataCon con = pretty_list
397 | dataConIsInfix con = case args of
398 [x, y] -> do x' <- pprPmExprWithParens x
399 y' <- pprPmExprWithParens y
400 return (x' <+> ppr con <+> y')
401 -- can it be infix but have more than two arguments?
402 list -> pprPanic "pprPmExprCon:" (ppr list)
403 | null args = return (ppr con)
404 | otherwise = do args' <- mapM pprPmExprWithParens args
405 return (fsep (ppr con : args'))
406 where
407 mkTuple, mkPArr :: [SDoc] -> SDoc
408 mkTuple = parens . fsep . punctuate comma
409 mkPArr = paBrackets . fsep . punctuate comma
410
411 -- lazily, to be used in the list case only
412 pretty_list :: PmPprM SDoc
413 pretty_list = case isNilPmExpr (last list) of
414 True -> brackets . fsep . punctuate comma <$> mapM pprPmExpr (init list)
415 False -> parens . hcat . punctuate colon <$> mapM pprPmExpr list
416
417 list = list_elements args
418
419 list_elements [x,y]
420 | PmExprCon c es <- y, nilDataCon == c = ASSERT(null es) [x,y]
421 | PmExprCon c es <- y, consDataCon == c = x : list_elements es
422 | otherwise = [x,y]
423 list_elements list = pprPanic "list_elements:" (ppr list)
424
425 instance Outputable PmLit where
426 ppr (PmSLit l) = pmPprHsLit l
427 ppr (PmOLit neg l) = (if neg then char '-' else empty) <> ppr l
428
429 -- not really useful for pmexprs per se
430 instance Outputable PmExpr where
431 ppr e = fst $ runPmPprM (pprPmExpr e) []