Encode shape information in `PmOracle`
[ghc.git] / compiler / deSugar / PmPpr.hs
1 {-# LANGUAGE CPP, ViewPatterns #-}
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 Id
14 import VarEnv
15 import UniqDFM
16 import ConLike
17 import DataCon
18 import TysWiredIn
19 import Outputable
20 import Control.Monad.Trans.RWS.CPS
21 import Util
22 import Maybes
23 import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)
24
25 import PmExpr
26 import PmOracle
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 --
39 -- When the set of refutable shapes contains more than 3 elements, the
40 -- additional elements are indicated by "...".
41 pprUncovered :: Delta -> [Id] -> SDoc
42 pprUncovered delta vas
43 | isNullUDFM refuts = fsep vec -- there are no refutations
44 | otherwise = hang (fsep vec) 4 $
45 text "where" <+> vcat (map (pprRefutableShapes . snd) (udfmToList refuts))
46 where
47 ppr_action = mapM (pprPmExprVar 2) vas
48 (vec, renamings) = runPmPpr delta ppr_action
49 refuts = prettifyRefuts delta renamings
50
51 -- | Output refutable shapes of a variable in the form of @var is not one of {2,
52 -- Nothing, 3}@. Will never print more than 3 refutable shapes, the tail is
53 -- indicated by an ellipsis.
54 pprRefutableShapes :: (SDoc,[PmAltCon]) -> SDoc
55 pprRefutableShapes (var, alts)
56 = var <+> text "is not one of" <+> format_alts alts
57 where
58 format_alts = braces . fsep . punctuate comma . shorten . map ppr_alt
59 shorten (a:b:c:_:_) = a:b:c:[text "..."]
60 shorten xs = xs
61 ppr_alt (PmAltConLike cl) = ppr cl
62 ppr_alt (PmAltLit lit) = ppr lit
63
64 {- 1. Literals
65 ~~~~~~~~~~~~~~
66 Starting with a function definition like:
67
68 f :: Int -> Bool
69 f 5 = True
70 f 6 = True
71
72 The uncovered set looks like:
73 { var |> var /= 5, var /= 6 }
74
75 Yet, we would like to print this nicely as follows:
76 x , where x not one of {5,6}
77
78 Since these variables will be shown to the programmer, we give them better names
79 (t1, t2, ..) in 'prettifyRefuts', hence the SDoc in 'PrettyPmRefutEnv'.
80
81 2. Residual Constraints
82 ~~~~~~~~~~~~~~~~~~~~~~~
83 Unhandled constraints that refer to HsExpr are typically ignored by the solver
84 (it does not even substitute in HsExpr so they are even printed as wildcards).
85 Additionally, the oracle returns a substitution if it succeeds so we apply this
86 substitution to the vectors before printing them out (see function `pprOne' in
87 Check.hs) to be more precise.
88 -}
89
90 -- | Extract and assigns pretty names to constraint variables with refutable
91 -- shapes.
92 prettifyRefuts :: Delta -> DIdEnv SDoc -> DIdEnv (SDoc, [PmAltCon])
93 prettifyRefuts delta = listToUDFM . map attach_refuts . udfmToList
94 where
95 attach_refuts (u, sdoc) = (u, (sdoc, lookupRefuts delta u))
96
97
98 type PmPprM a = RWS Delta () (DIdEnv SDoc, [SDoc]) a
99
100 -- Try nice names p,q,r,s,t before using the (ugly) t_i
101 nameList :: [SDoc]
102 nameList = map text ["p","q","r","s","t"] ++
103 [ text ('t':show u) | u <- [(0 :: Int)..] ]
104
105 runPmPpr :: Delta -> PmPprM a -> (a, DIdEnv SDoc)
106 runPmPpr delta m = case runRWS m delta (emptyDVarEnv, nameList) of
107 (a, (renamings, _), _) -> (a, renamings)
108
109 -- | Allocates a new, clean name for the given 'Id' if it doesn't already have
110 -- one.
111 getCleanName :: Id -> PmPprM SDoc
112 getCleanName x = do
113 (renamings, name_supply) <- get
114 let (clean_name:name_supply') = name_supply
115 case lookupDVarEnv renamings x of
116 Just nm -> pure nm
117 Nothing -> do
118 put (extendDVarEnv renamings x clean_name, name_supply')
119 pure clean_name
120
121 checkRefuts :: Id -> PmPprM (Maybe SDoc) -- the clean name if it has negative info attached
122 checkRefuts x = do
123 delta <- ask
124 case lookupRefuts delta x of
125 [] -> pure Nothing -- Will just be a wildcard later on
126 _ -> Just <$> getCleanName x
127
128 -- | Pretty print a variable, but remember to prettify the names of the variables
129 -- that refer to neg-literals. The ones that cannot be shown are printed as
130 -- underscores.
131 pprPmExprVar :: Int -> Id -> PmPprM SDoc
132 pprPmExprVar prec x = do
133 delta <- ask
134 case lookupSolution delta x of
135 Just (alt, args) -> pprPmExprCon prec alt args
136 Nothing -> fromMaybe underscore <$> checkRefuts x
137
138 pprPmExprCon :: Int -> PmAltCon -> [Id] -> PmPprM SDoc
139 pprPmExprCon _prec (PmAltLit l) _ = pure (ppr l)
140 pprPmExprCon prec (PmAltConLike cl) args = do
141 delta <- ask
142 pprConLike delta prec cl args
143
144 pprConLike :: Delta -> Int -> ConLike -> [Id] -> PmPprM SDoc
145 pprConLike delta _prec cl args
146 | Just pm_expr_list <- pmExprAsList delta (PmAltConLike cl) args
147 = case pm_expr_list of
148 NilTerminated list ->
149 brackets . fsep . punctuate comma <$> mapM (pprPmExprVar 0) list
150 WcVarTerminated pref x ->
151 parens . fcat . punctuate colon <$> mapM (pprPmExprVar 0) (toList pref ++ [x])
152 pprConLike _delta _prec (RealDataCon con) args
153 | isUnboxedTupleCon con
154 , let hash_parens doc = text "(#" <+> doc <+> text "#)"
155 = hash_parens . fsep . punctuate comma <$> mapM (pprPmExprVar 0) args
156 | isTupleDataCon con
157 = parens . fsep . punctuate comma <$> mapM (pprPmExprVar 0) args
158 pprConLike _delta prec cl args
159 | conLikeIsInfix cl = case args of
160 [x, y] -> do x' <- pprPmExprVar 1 x
161 y' <- pprPmExprVar 1 y
162 return (cparen (prec > 0) (x' <+> ppr cl <+> y'))
163 -- can it be infix but have more than two arguments?
164 list -> pprPanic "pprPmExprCon:" (ppr list)
165 | null args = return (ppr cl)
166 | otherwise = do args' <- mapM (pprPmExprVar 2) args
167 return (cparen (prec > 1) (fsep (ppr cl : args')))
168
169 -- | The result of 'pmExprAsList'.
170 data PmExprList
171 = NilTerminated [Id]
172 | WcVarTerminated (NonEmpty Id) Id
173
174 -- | Extract a list of 'PmExpr's out of a sequence of cons cells, optionally
175 -- terminated by a wildcard variable instead of @[]@. Some examples:
176 --
177 -- * @pmExprAsList (1:2:[]) == Just ('NilTerminated' [1,2])@, a regular,
178 -- @[]@-terminated list. Should be pretty-printed as @[1,2]@.
179 -- * @pmExprAsList (1:2:x) == Just ('WcVarTerminated' [1,2] x)@, a list prefix
180 -- ending in a wildcard variable x (of list type). Should be pretty-printed as
181 -- (1:2:_).
182 -- * @pmExprAsList [] == Just ('NilTerminated' [])@
183 pmExprAsList :: Delta -> PmAltCon -> [Id] -> Maybe PmExprList
184 pmExprAsList delta = go_con []
185 where
186 go_var rev_pref x
187 | Just (alt, args) <- lookupSolution delta x
188 = go_con rev_pref alt args
189 go_var rev_pref x
190 | Just pref <- nonEmpty (reverse rev_pref)
191 = Just (WcVarTerminated pref x)
192 go_var _ _
193 = Nothing
194
195 go_con rev_pref (PmAltConLike (RealDataCon c)) es
196 | c == nilDataCon
197 = ASSERT( null es ) Just (NilTerminated (reverse rev_pref))
198 | c == consDataCon
199 = ASSERT( length es == 2 ) go_var (es !! 0 : rev_pref) (es !! 1)
200 go_con _ _ _
201 = Nothing