never executed always true always false
1
2
3 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
4
5 -- | Provides factilities for pretty-printing 'Nabla's in a way appropriate for
6 -- user facing pattern match warnings.
7 module GHC.HsToCore.Pmc.Ppr (
8 pprUncovered
9 ) where
10
11 import GHC.Prelude
12
13 import GHC.Types.Basic
14 import GHC.Types.Id
15 import GHC.Types.Var.Env
16 import GHC.Types.Unique.DFM
17 import GHC.Core.ConLike
18 import GHC.Core.DataCon
19 import GHC.Builtin.Types
20 import GHC.Utils.Outputable
21 import GHC.Utils.Panic
22 import GHC.Utils.Panic.Plain
23 import Control.Monad.Trans.RWS.CPS
24 import GHC.Data.Maybe
25 import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)
26
27 import GHC.HsToCore.Pmc.Types
28
29 -- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its
30 -- components and refutable shapes associated to any mentioned variables.
31 --
32 -- Example for @([Just p, q], [p :-> [3,4], q :-> [0,5]])@:
33 --
34 -- @
35 -- (Just p) q
36 -- where p is not one of {3, 4}
37 -- q is not one of {0, 5}
38 -- @
39 --
40 -- When the set of refutable shapes contains more than 3 elements, the
41 -- additional elements are indicated by "...".
42 pprUncovered :: Nabla -> [Id] -> SDoc
43 pprUncovered nabla vas
44 | isNullUDFM refuts = fsep vec -- there are no refutations
45 | otherwise = hang (fsep vec) 4 $
46 text "where" <+> vcat (map (pprRefutableShapes . snd) (udfmToList refuts))
47 where
48 init_prec
49 -- No outer parentheses when it's a unary pattern by assuming lowest
50 -- precedence
51 | [_] <- vas = topPrec
52 | otherwise = appPrec
53 ppr_action = mapM (pprPmVar init_prec) vas
54 (vec, renamings) = runPmPpr nabla ppr_action
55 refuts = prettifyRefuts nabla renamings
56
57 -- | Output refutable shapes of a variable in the form of @var is not one of {2,
58 -- Nothing, 3}@. Will never print more than 3 refutable shapes, the tail is
59 -- indicated by an ellipsis.
60 pprRefutableShapes :: (SDoc,[PmAltCon]) -> SDoc
61 pprRefutableShapes (var, alts)
62 = var <+> text "is not one of" <+> format_alts alts
63 where
64 format_alts = braces . fsep . punctuate comma . shorten . map ppr_alt
65 shorten (a:b:c:_:_) = a:b:c:[text "..."]
66 shorten xs = xs
67 ppr_alt (PmAltConLike cl) = ppr cl
68 ppr_alt (PmAltLit lit) = ppr lit
69
70 {- 1. Literals
71 ~~~~~~~~~~~~~~
72 Starting with a function definition like:
73
74 f :: Int -> Bool
75 f 5 = True
76 f 6 = True
77
78 The uncovered set looks like:
79 { var |> var /= 5, var /= 6 }
80
81 Yet, we would like to print this nicely as follows:
82 x , where x not one of {5,6}
83
84 Since these variables will be shown to the programmer, we give them better names
85 (t1, t2, ..) in 'prettifyRefuts', hence the SDoc in 'PrettyPmRefutEnv'.
86
87 2. Residual Constraints
88 ~~~~~~~~~~~~~~~~~~~~~~~
89 Unhandled constraints that refer to HsExpr are typically ignored by the solver
90 (it does not even substitute in HsExpr so they are even printed as wildcards).
91 Additionally, the oracle returns a substitution if it succeeds so we apply this
92 substitution to the vectors before printing them out (see function `pprOne' in
93 "GHC.HsToCore.Pmc") to be more precise.
94 -}
95
96 -- | Extract and assigns pretty names to constraint variables with refutable
97 -- shapes.
98 prettifyRefuts :: Nabla -> DIdEnv (Id, SDoc) -> DIdEnv (SDoc, [PmAltCon])
99 prettifyRefuts nabla = listToUDFM_Directly . map attach_refuts . udfmToList
100 where
101 attach_refuts (u, (x, sdoc)) = (u, (sdoc, lookupRefuts nabla x))
102
103
104 type PmPprM a = RWS Nabla () (DIdEnv (Id, SDoc), [SDoc]) a
105
106 -- Try nice names p,q,r,s,t before using the (ugly) t_i
107 nameList :: [SDoc]
108 nameList = map text ["p","q","r","s","t"] ++
109 [ text ('t':show u) | u <- [(0 :: Int)..] ]
110
111 runPmPpr :: Nabla -> PmPprM a -> (a, DIdEnv (Id, SDoc))
112 runPmPpr nabla m = case runRWS m nabla (emptyDVarEnv, nameList) of
113 (a, (renamings, _), _) -> (a, renamings)
114
115 -- | Allocates a new, clean name for the given 'Id' if it doesn't already have
116 -- one.
117 getCleanName :: Id -> PmPprM SDoc
118 getCleanName x = do
119 (renamings, name_supply) <- get
120 let (clean_name:name_supply') = name_supply
121 case lookupDVarEnv renamings x of
122 Just (_, nm) -> pure nm
123 Nothing -> do
124 put (extendDVarEnv renamings x (x, clean_name), name_supply')
125 pure clean_name
126
127 checkRefuts :: Id -> PmPprM (Maybe SDoc) -- the clean name if it has negative info attached
128 checkRefuts x = do
129 nabla <- ask
130 case lookupRefuts nabla x of
131 [] -> pure Nothing -- Will just be a wildcard later on
132 _ -> Just <$> getCleanName x
133
134 -- | Pretty print a variable, but remember to prettify the names of the variables
135 -- that refer to neg-literals. The ones that cannot be shown are printed as
136 -- underscores.
137 pprPmVar :: PprPrec -> Id -> PmPprM SDoc
138 pprPmVar prec x = do
139 nabla <- ask
140 case lookupSolution nabla x of
141 Just (PACA alt _tvs args) -> pprPmAltCon prec alt args
142 Nothing -> fromMaybe underscore <$> checkRefuts x
143
144 pprPmAltCon :: PprPrec -> PmAltCon -> [Id] -> PmPprM SDoc
145 pprPmAltCon _prec (PmAltLit l) _ = pure (ppr l)
146 pprPmAltCon prec (PmAltConLike cl) args = do
147 nabla <- ask
148 pprConLike nabla prec cl args
149
150 pprConLike :: Nabla -> PprPrec -> ConLike -> [Id] -> PmPprM SDoc
151 pprConLike nabla _prec cl args
152 | Just pm_expr_list <- pmExprAsList nabla (PmAltConLike cl) args
153 = case pm_expr_list of
154 NilTerminated list ->
155 brackets . fsep . punctuate comma <$> mapM (pprPmVar appPrec) list
156 WcVarTerminated pref x ->
157 parens . fcat . punctuate colon <$> mapM (pprPmVar appPrec) (toList pref ++ [x])
158 pprConLike _nabla _prec (RealDataCon con) args
159 | isUnboxedTupleDataCon con
160 , let hash_parens doc = text "(#" <+> doc <+> text "#)"
161 = hash_parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args
162 | isTupleDataCon con
163 = parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args
164 pprConLike _nabla prec cl args
165 | conLikeIsInfix cl = case args of
166 [x, y] -> do x' <- pprPmVar funPrec x
167 y' <- pprPmVar funPrec y
168 return (cparen (prec > opPrec) (x' <+> ppr cl <+> y'))
169 -- can it be infix but have more than two arguments?
170 list -> pprPanic "pprConLike:" (ppr list)
171 | null args = return (ppr cl)
172 | otherwise = do args' <- mapM (pprPmVar appPrec) args
173 return (cparen (prec > funPrec) (fsep (ppr cl : args')))
174
175 -- | The result of 'pmExprAsList'.
176 data PmExprList
177 = NilTerminated [Id]
178 | WcVarTerminated (NonEmpty Id) Id
179
180 -- | Extract a list of 'Id's out of a sequence of cons cells, optionally
181 -- terminated by a wildcard variable instead of @[]@. Some examples:
182 --
183 -- * @pmExprAsList (1:2:[]) == Just ('NilTerminated' [1,2])@, a regular,
184 -- @[]@-terminated list. Should be pretty-printed as @[1,2]@.
185 -- * @pmExprAsList (1:2:x) == Just ('WcVarTerminated' [1,2] x)@, a list prefix
186 -- ending in a wildcard variable x (of list type). Should be pretty-printed as
187 -- (1:2:_).
188 -- * @pmExprAsList [] == Just ('NilTerminated' [])@
189 pmExprAsList :: Nabla -> PmAltCon -> [Id] -> Maybe PmExprList
190 pmExprAsList nabla = go_con []
191 where
192 go_var rev_pref x
193 | Just (PACA alt _tvs args) <- lookupSolution nabla x
194 = go_con rev_pref alt args
195 go_var rev_pref x
196 | Just pref <- nonEmpty (reverse rev_pref)
197 = Just (WcVarTerminated pref x)
198 go_var _ _
199 = Nothing
200
201 go_con rev_pref (PmAltConLike (RealDataCon c)) es
202 | c == nilDataCon
203 = assert (null es) $ Just (NilTerminated (reverse rev_pref))
204 | c == consDataCon
205 = assert (length es == 2) $ go_var (es !! 0 : rev_pref) (es !! 1)
206 go_con _ _ _
207 = Nothing