Major Overhaul of Pattern Match Checking (Fixes #595)
[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.Functor ((<$>))
29 import Data.Maybe (mapMaybe)
30 import Data.List (groupBy, sortBy)
31 import Control.Monad.Trans.State.Lazy
32
33 {-
34 %************************************************************************
35 %* *
36 Lifted Expressions
37 %* *
38 %************************************************************************
39 -}
40
41 {- Note [PmExprOther in PmExpr]
42 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
43 Since there is no plan to extend the (currently pretty naive) term oracle in
44 the near future, instead of playing with the verbose (HsExpr Id), we lift it to
45 PmExpr. All expressions the term oracle does not handle are wrapped by the
46 constructor PmExprOther. Note that we do not perform substitution in
47 PmExprOther. Because of this, we do not even print PmExprOther, since they may
48 refer to variables that are otherwise substituted away.
49 -}
50
51 -- ----------------------------------------------------------------------------
52 -- ** Types
53
54 -- | Lifted expressions for pattern match checking.
55 data PmExpr = PmExprVar Id
56 | PmExprCon DataCon [PmExpr]
57 | PmExprLit PmLit
58 | PmExprEq PmExpr PmExpr -- Syntactic equality
59 | PmExprOther (HsExpr Id) -- Note [PmExprOther in PmExpr]
60
61 -- | Literals (simple and overloaded ones) for pattern match checking.
62 data PmLit = PmSLit HsLit -- simple
63 | PmOLit Bool {- is it negated? -} (HsOverLit Id) -- overloaded
64
65 -- | PmLit equality. If both literals are overloaded, the equality check may be
66 -- inconclusive. Since an overloaded PmLit represents a function application
67 -- (e.g. fromInteger 5), if two literals look the same they are the same but
68 -- if they don't, whether they are depends on the implementation of the
69 -- from-function.
70 eqPmLit :: PmLit -> PmLit -> Maybe Bool
71 eqPmLit (PmSLit l1) (PmSLit l2 ) = Just (l1 == l2)
72 eqPmLit (PmOLit b1 l1) (PmOLit b2 l2) = if res then Just True else Nothing
73 where res = b1 == b2 && l1 == l2
74 eqPmLit _ _ = Just False -- this should not even happen I think
75
76 nubPmLit :: [PmLit] -> [PmLit]
77 nubPmLit [] = []
78 nubPmLit [x] = [x]
79 nubPmLit (x:xs) = x : nubPmLit (filter (neqPmLit x) xs)
80 where neqPmLit l1 l2 = case eqPmLit l1 l2 of
81 Just True -> False
82 Just False -> True
83 Nothing -> True
84
85 -- | Term equalities
86 type SimpleEq = (Id, PmExpr) -- We always use this orientation
87 type ComplexEq = (PmExpr, PmExpr)
88
89 -- | Expression `True'
90 truePmExpr :: PmExpr
91 truePmExpr = PmExprCon trueDataCon []
92
93 -- | Expression `False'
94 falsePmExpr :: PmExpr
95 falsePmExpr = PmExprCon falseDataCon []
96
97 -- ----------------------------------------------------------------------------
98 -- ** Predicates on PmExpr
99
100 -- | Check if an expression is lifted or not
101 isNotPmExprOther :: PmExpr -> Bool
102 isNotPmExprOther (PmExprOther _) = False
103 isNotPmExprOther _expr = True
104
105 -- | Check whether a literal is negated
106 isNegatedPmLit :: PmLit -> Bool
107 isNegatedPmLit (PmOLit b _) = b
108 isNegatedPmLit _other_lit = False
109
110 -- | Check whether a PmExpr is syntactically equal to term `True'.
111 isTruePmExpr :: PmExpr -> Bool
112 isTruePmExpr (PmExprCon c []) = c == trueDataCon
113 isTruePmExpr _other_expr = False
114
115 -- | Check whether a PmExpr is syntactically equal to term `False'.
116 isFalsePmExpr :: PmExpr -> Bool
117 isFalsePmExpr (PmExprCon c []) = c == falseDataCon
118 isFalsePmExpr _other_expr = False
119
120 -- | Check whether a PmExpr is syntactically e
121 isNilPmExpr :: PmExpr -> Bool
122 isNilPmExpr (PmExprCon c _) = c == nilDataCon
123 isNilPmExpr _other_expr = False
124
125 -- | Check whether a PmExpr is syntactically equal to (x == y).
126 -- Since (==) is overloaded and can have an arbitrary implementation, we use
127 -- the PmExprEq constructor to represent only equalities with non-overloaded
128 -- literals where it coincides with a syntactic equality check.
129 isPmExprEq :: PmExpr -> Maybe (PmExpr, PmExpr)
130 isPmExprEq (PmExprEq e1 e2) = Just (e1,e2)
131 isPmExprEq _other_expr = Nothing
132
133 -- | Check if a DataCon is (:).
134 isConsDataCon :: DataCon -> Bool
135 isConsDataCon con = consDataCon == con
136
137 -- ----------------------------------------------------------------------------
138 -- ** Substitution in PmExpr
139
140 -- | We return a boolean along with the expression. Hence, if substitution was
141 -- a no-op, we know that the expression still cannot progress.
142 substPmExpr :: Id -> PmExpr -> PmExpr -> (PmExpr, Bool)
143 substPmExpr x e1 e =
144 case e of
145 PmExprVar z | x == z -> (e1, True)
146 | otherwise -> (e, False)
147 PmExprCon c ps -> let (ps', bs) = mapAndUnzip (substPmExpr x e1) ps
148 in (PmExprCon c ps', or bs)
149 PmExprEq ex ey -> let (ex', bx) = substPmExpr x e1 ex
150 (ey', by) = substPmExpr x e1 ey
151 in (PmExprEq ex' ey', bx || by)
152 _other_expr -> (e, False) -- The rest are terminals (We silently ignore
153 -- Other). See Note [PmExprOther in PmExpr]
154
155 -- | Substitute in a complex equality. We return (Left eq) if the substitution
156 -- affected the equality or (Right eq) if nothing happened.
157 substComplexEq :: Id -> PmExpr -> ComplexEq -> Either ComplexEq ComplexEq
158 substComplexEq x e (ex, ey)
159 | bx || by = Left (ex', ey')
160 | otherwise = Right (ex', ey')
161 where
162 (ex', bx) = substPmExpr x e ex
163 (ey', by) = substPmExpr x e ey
164
165 -- -----------------------------------------------------------------------
166 -- ** Lift source expressions (HsExpr Id) to PmExpr
167
168 lhsExprToPmExpr :: LHsExpr Id -> PmExpr
169 lhsExprToPmExpr (L _ e) = hsExprToPmExpr e
170
171 hsExprToPmExpr :: HsExpr Id -> PmExpr
172
173 hsExprToPmExpr (HsVar x) = PmExprVar (unLoc x)
174 hsExprToPmExpr (HsOverLit olit) = PmExprLit (PmOLit False olit)
175 hsExprToPmExpr (HsLit lit) = PmExprLit (PmSLit lit)
176
177 hsExprToPmExpr e@(NegApp _ neg_e)
178 | PmExprLit (PmOLit False ol) <- hsExprToPmExpr neg_e
179 = PmExprLit (PmOLit True ol)
180 | otherwise = PmExprOther e
181 hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e
182
183 hsExprToPmExpr e@(ExplicitTuple ps boxity)
184 | all tupArgPresent ps = PmExprCon tuple_con tuple_args
185 | otherwise = PmExprOther e
186 where
187 tuple_con = tupleDataCon boxity (length ps)
188 tuple_args = [ lhsExprToPmExpr e | L _ (Present e) <- ps ]
189
190 hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems)
191 | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems)
192 | otherwise = PmExprOther e {- overloaded list: No PmExprApp -}
193 where
194 cons x xs = PmExprCon consDataCon [x,xs]
195 nil = PmExprCon nilDataCon []
196
197 hsExprToPmExpr (ExplicitPArr _elem_ty elems)
198 = PmExprCon (parrFakeCon (length elems)) (map lhsExprToPmExpr elems)
199
200 -- we want this but we would have to make evrything monadic :/
201 -- ./compiler/deSugar/DsMonad.hs:397:dsLookupDataCon :: Name -> DsM DataCon
202 --
203 -- hsExprToPmExpr (RecordCon c _ binds) = do
204 -- con <- dsLookupDataCon (unLoc c)
205 -- args <- mapM lhsExprToPmExpr (hsRecFieldsArgs binds)
206 -- return (PmExprCon con args)
207 hsExprToPmExpr e@(RecordCon _ _ _ _) = PmExprOther e
208
209 hsExprToPmExpr (HsTick _ e) = lhsExprToPmExpr e
210 hsExprToPmExpr (HsBinTick _ _ e) = lhsExprToPmExpr e
211 hsExprToPmExpr (HsTickPragma _ _ e) = lhsExprToPmExpr e
212 hsExprToPmExpr (HsSCC _ _ e) = lhsExprToPmExpr e
213 hsExprToPmExpr (HsCoreAnn _ _ e) = lhsExprToPmExpr e
214 hsExprToPmExpr (ExprWithTySig e _) = lhsExprToPmExpr e
215 hsExprToPmExpr (ExprWithTySigOut e _) = lhsExprToPmExpr e
216 hsExprToPmExpr (HsWrap _ e) = hsExprToPmExpr e
217 hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle
218
219 {-
220 %************************************************************************
221 %* *
222 Pretty printing
223 %* *
224 %************************************************************************
225 -}
226
227 {- 1. Literals
228 ~~~~~~~~~~~~~~
229 Starting with a function definition like:
230
231 f :: Int -> Bool
232 f 5 = True
233 f 6 = True
234
235 The uncovered set looks like:
236 { var |> False == (var == 5), False == (var == 6) }
237
238 Yet, we would like to print this nicely as follows:
239 x , where x not one of {5,6}
240
241 Function `filterComplex' takes the set of residual constraints and packs
242 together the negative constraints that refer to the same variable so we can do
243 just this. Since these variables will be shown to the programmer, we also give
244 them better names (t1, t2, ..), hence the SDoc in PmNegLitCt.
245
246 2. Residual Constraints
247 ~~~~~~~~~~~~~~~~~~~~~~~
248 Unhandled constraints that refer to HsExpr are typically ignored by the solver
249 (it does not even substitute in HsExpr so they are even printed as wildcards).
250 Additionally, the oracle returns a substitution if it succeeds so we apply this
251 substitution to the vectors before printing them out (see function `pprOne' in
252 Check.hs) to be more precice.
253 -}
254
255 -- -----------------------------------------------------------------------------
256 -- ** Transform residual constraints in appropriate form for pretty printing
257
258 type PmNegLitCt = (Id, (SDoc, [PmLit]))
259
260 filterComplex :: [ComplexEq] -> [PmNegLitCt]
261 filterComplex = zipWith rename nameList . map mkGroup
262 . groupBy name . sortBy order . mapMaybe isNegLitCs
263 where
264 order x y = compare (fst x) (fst y)
265 name x y = fst x == fst y
266 mkGroup l = (fst (head l), nubPmLit $ map snd l)
267 rename new (old, lits) = (old, (new, lits))
268
269 isNegLitCs (e1,e2)
270 | isFalsePmExpr e1, Just (x,y) <- isPmExprEq e2 = isNegLitCs' x y
271 | isFalsePmExpr e2, Just (x,y) <- isPmExprEq e1 = isNegLitCs' x y
272 | otherwise = Nothing
273
274 isNegLitCs' (PmExprVar x) (PmExprLit l) = Just (x, l)
275 isNegLitCs' (PmExprLit l) (PmExprVar x) = Just (x, l)
276 isNegLitCs' _ _ = Nothing
277
278 -- Try nice names p,q,r,s,t before using the (ugly) t_i
279 nameList :: [SDoc]
280 nameList = map (ptext . sLit) ["p","q","r","s","t"] ++
281 [ ptext (sLit ('t':show u)) | u <- [(0 :: Int)..] ]
282
283 -- ----------------------------------------------------------------------------
284
285 runPmPprM :: PmPprM a -> [PmNegLitCt] -> (a, [(SDoc,[PmLit])])
286 runPmPprM m lit_env = (result, mapMaybe is_used lit_env)
287 where
288 (result, (_lit_env, used)) = runState m (lit_env, emptyVarSet)
289
290 is_used (x,(name, lits))
291 | elemVarSet x used = Just (name, lits)
292 | otherwise = Nothing
293
294 type PmPprM a = State ([PmNegLitCt], IdSet) a
295 -- (the first part of the state is read only. make it a reader?)
296
297 addUsed :: Id -> PmPprM ()
298 addUsed x = modify (\(negated, used) -> (negated, extendVarSet used x))
299
300 checkNegation :: Id -> PmPprM (Maybe SDoc) -- the clean name if it is negated
301 checkNegation x = do
302 negated <- gets fst
303 return $ case lookup x negated of
304 Just (new, _) -> Just new
305 Nothing -> Nothing
306
307 -- | Pretty print a pmexpr, but remember to prettify the names of the variables
308 -- that refer to neg-literals. The ones that cannot be shown are printed as
309 -- underscores.
310 pprPmExpr :: PmExpr -> PmPprM SDoc
311 pprPmExpr (PmExprVar x) = do
312 mb_name <- checkNegation x
313 case mb_name of
314 Just name -> addUsed x >> return name
315 Nothing -> return underscore
316
317 pprPmExpr (PmExprCon con args) = pprPmExprCon con args
318 pprPmExpr (PmExprLit l) = return (ppr l)
319 pprPmExpr (PmExprEq _ _) = return underscore -- don't show
320 pprPmExpr (PmExprOther _) = return underscore -- don't show
321
322 needsParens :: PmExpr -> Bool
323 needsParens (PmExprVar {}) = False
324 needsParens (PmExprLit l) = isNegatedPmLit l
325 needsParens (PmExprEq {}) = False -- will become a wildcard
326 needsParens (PmExprOther {}) = False -- will become a wildcard
327 needsParens (PmExprCon c es)
328 | isTupleDataCon c || isPArrFakeCon c
329 || isConsDataCon c || null es = False
330 | otherwise = True
331
332 pprPmExprWithParens :: PmExpr -> PmPprM SDoc
333 pprPmExprWithParens expr
334 | needsParens expr = parens <$> pprPmExpr expr
335 | otherwise = pprPmExpr expr
336
337 pprPmExprCon :: DataCon -> [PmExpr] -> PmPprM SDoc
338 pprPmExprCon con args
339 | isTupleDataCon con = mkTuple <$> mapM pprPmExpr args
340 | isPArrFakeCon con = mkPArr <$> mapM pprPmExpr args
341 | isConsDataCon con = pretty_list
342 | dataConIsInfix con = case args of
343 [x, y] -> do x' <- pprPmExprWithParens x
344 y' <- pprPmExprWithParens y
345 return (x' <+> ppr con <+> y')
346 -- can it be infix but have more than two arguments?
347 list -> pprPanic "pprPmExprCon:" (ppr list)
348 | null args = return (ppr con)
349 | otherwise = do args' <- mapM pprPmExprWithParens args
350 return (fsep (ppr con : args'))
351 where
352 mkTuple, mkPArr :: [SDoc] -> SDoc
353 mkTuple = parens . fsep . punctuate comma
354 mkPArr = paBrackets . fsep . punctuate comma
355
356 -- lazily, to be used in the list case only
357 pretty_list :: PmPprM SDoc
358 pretty_list = case isNilPmExpr (last list) of
359 True -> brackets . fsep . punctuate comma <$> mapM pprPmExpr (init list)
360 False -> parens . hcat . punctuate colon <$> mapM pprPmExpr list
361
362 list = list_elements args
363
364 list_elements [x,y]
365 | PmExprCon c es <- y, nilDataCon == c = ASSERT (null es) [x,y]
366 | PmExprCon c es <- y, consDataCon == c = x : list_elements es
367 | otherwise = [x,y]
368 list_elements list = pprPanic "list_elements:" (ppr list)
369
370 instance Outputable PmLit where
371 ppr (PmSLit l) = pmPprHsLit l
372 ppr (PmOLit neg l) = (if neg then char '-' else empty) <> ppr l
373
374 -- not really useful for pmexprs per se
375 instance Outputable PmExpr where
376 ppr e = fst $ runPmPprM (pprPmExpr e) []
377