Commit 7915afc6 authored by Sebastian Graf's avatar Sebastian Graf Committed by Marge Bot

Encode shape information in `PmOracle`

Previously, we had an elaborate mechanism for selecting the warnings to
generate in the presence of different `COMPLETE` matching groups that,
albeit finely-tuned, produced wrong results from an end user's
perspective in some cases (#13363).

The underlying issue is that at the point where the `ConVar` case has to
commit to a particular `COMPLETE` group, there's not enough information
to do so and the status quo was to just enumerate all possible complete
sets nondeterministically.  The `getResult` function would then pick the
outcome according to metrics defined in accordance to the user's guide.
But crucially, it lacked knowledge about the order in which affected
clauses appear, leading to the surprising behavior in #13363.

In !1010 we taught the term oracle to reason about literal values a
variable can certainly not take on. This MR extends that idea to
`ConLike`s and thereby fixes #13363: Instead of committing to a
particular `COMPLETE` group in the `ConVar` case, we now split off the
matching constructor incrementally and record the newly covered case as
a refutable shape in the oracle. Whenever the set of refutable shapes
covers any `COMPLETE` set, the oracle recognises vacuosity of the
uncovered set.

This patch goes a step further: Since at this point the information
in value abstractions is merely a cut down representation of what the
oracle knows, value abstractions degenerate to a single `Id`, the
semantics of which is determined by the oracle state `Delta`.
Value vectors become lists of `[Id]` given meaning to by a single
`Delta`, value set abstractions (of which the uncovered set is an
instance) correspond to a union of `Delta`s which instantiate the
same `[Id]` (akin to models of formula).

Fixes #11528 #13021, #13363, #13965, #14059, #14253, #14851, #15753, #17096, #17149

-------------------------
Metric Decrease:
    ManyAlternatives
    T11195
-------------------------
parent b5ae3868
...@@ -25,9 +25,9 @@ module NameEnv ( ...@@ -25,9 +25,9 @@ module NameEnv (
emptyDNameEnv, emptyDNameEnv,
lookupDNameEnv, lookupDNameEnv,
delFromDNameEnv, delFromDNameEnv, filterDNameEnv,
mapDNameEnv, mapDNameEnv,
alterDNameEnv, adjustDNameEnv, alterDNameEnv, extendDNameEnv,
-- ** Dependency analysis -- ** Dependency analysis
depAnal depAnal
) where ) where
...@@ -151,8 +151,17 @@ lookupDNameEnv = lookupUDFM ...@@ -151,8 +151,17 @@ lookupDNameEnv = lookupUDFM
delFromDNameEnv :: DNameEnv a -> Name -> DNameEnv a delFromDNameEnv :: DNameEnv a -> Name -> DNameEnv a
delFromDNameEnv = delFromUDFM delFromDNameEnv = delFromUDFM
filterDNameEnv :: (a -> Bool) -> DNameEnv a -> DNameEnv a
filterDNameEnv = filterUDFM
mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b
mapDNameEnv = mapUDFM mapDNameEnv = mapUDFM
adjustDNameEnv :: (a -> a) -> DNameEnv a -> Name -> DNameEnv a
adjustDNameEnv = adjustUDFM
alterDNameEnv :: (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a alterDNameEnv :: (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a
alterDNameEnv = alterUDFM alterDNameEnv = alterUDFM
extendDNameEnv :: DNameEnv a -> Name -> a -> DNameEnv a
extendDNameEnv = addToUDFM
...@@ -184,6 +184,20 @@ to get the instantiation a := ty. ...@@ -184,6 +184,20 @@ to get the instantiation a := ty.
This is very unlike DataCons, where univ tyvars match 1-1 the This is very unlike DataCons, where univ tyvars match 1-1 the
arguments of the TyCon. arguments of the TyCon.
Side note: I (SG) get the impression that instantiated return types should
generate a *required* constraint for pattern synonyms, rather than a *provided*
constraint like it's the case for GADTs. For example, I'd expect these
declarations to have identical semantics:
pattern Just42 :: Maybe Int
pattern Just42 = Just 42
pattern Just'42 :: (a ~ Int) => Maybe a
pattern Just'42 = Just 42
The latter generates the proper required constraint, the former does not.
Also rather different to GADTs is the fact that Just42 doesn't have any
universally quantified type variables, whereas Just'42 or MkS above has.
Note [Pattern synonym representation] Note [Pattern synonym representation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
This diff is collapsed.
...@@ -29,7 +29,7 @@ import {-# SOURCE #-} Match( matchWrapper ) ...@@ -29,7 +29,7 @@ import {-# SOURCE #-} Match( matchWrapper )
import DsMonad import DsMonad
import DsGRHSs import DsGRHSs
import DsUtils import DsUtils
import Check ( checkGuardMatches ) import Check ( needToRunPmCheck, addTyCsDs, checkGuardMatches )
import HsSyn -- lots of things import HsSyn -- lots of things
import CoreSyn -- lots of things import CoreSyn -- lots of things
...@@ -186,11 +186,15 @@ dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts ...@@ -186,11 +186,15 @@ dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = exports , abs_exports = exports
, abs_ev_binds = ev_binds , abs_ev_binds = ev_binds
, abs_binds = binds, abs_sig = has_sig }) , abs_binds = binds, abs_sig = has_sig })
= do { ds_binds <- addDictsDs (listToBag dicts) $ = do { ds_binds <- applyWhen (needToRunPmCheck dflags FromSource)
dsLHsBinds binds -- FromSource might not be accurate, but at worst
-- addDictsDs: push type constraints deeper -- we do superfluous calls to the pattern match
-- for inner pattern match check -- oracle.
-- See Check, Note [Type and Term Equality Propagation] -- addTyCsDs: push type constraints deeper
-- for inner pattern match check
-- See Check, Note [Type and Term Equality Propagation]
(addTyCsDs (listToBag dicts))
(dsLHsBinds binds)
; ds_ev_binds <- dsTcEvBinds_s ev_binds ; ds_ev_binds <- dsTcEvBinds_s ev_binds
......
...@@ -23,7 +23,9 @@ import MkCore ...@@ -23,7 +23,9 @@ import MkCore
import CoreSyn import CoreSyn
import CoreUtils (bindNonRec) import CoreUtils (bindNonRec)
import Check (genCaseTmCs2) import BasicTypes (Origin(FromSource))
import DynFlags
import Check (needToRunPmCheck, addTyCsDs, addPatTmCs, addScrutTmCs)
import DsMonad import DsMonad
import DsUtils import DsUtils
import Type ( Type ) import Type ( Type )
...@@ -122,11 +124,16 @@ matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do ...@@ -122,11 +124,16 @@ matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
let upat = unLoc pat let upat = unLoc pat
dicts = collectEvVarsPat upat dicts = collectEvVarsPat upat
match_var <- selectMatchVar upat match_var <- selectMatchVar upat
tm_cs <- genCaseTmCs2 (Just bind_rhs) [upat] [match_var]
match_result <- addDictsDs dicts $ dflags <- getDynFlags
addTmCsDs tm_cs $ match_result <-
-- See Note [Type and Term Equality Propagation] in Check -- See Note [Type and Term Equality Propagation] in Check
matchGuards stmts ctx rhs rhs_ty applyWhen (needToRunPmCheck dflags FromSource)
-- FromSource might not be accurate, but at worst
-- we do superfluous calls to the pattern match
-- oracle.
(addTyCsDs dicts . addScrutTmCs (Just bind_rhs) [match_var] . addPatTmCs [upat] [match_var])
(matchGuards stmts ctx rhs rhs_ty)
core_rhs <- dsLExpr bind_rhs core_rhs <- dsLExpr bind_rhs
match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty
match_result match_result
......
...@@ -29,8 +29,8 @@ module DsMonad ( ...@@ -29,8 +29,8 @@ module DsMonad (
DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
-- Getting and setting EvVars and term constraints in local environment -- Getting and setting pattern match oracle states
getDictsDs, addDictsDs, getTmCsDs, addTmCsDs, getPmDelta, updPmDelta,
-- Iterations for pm checking -- Iterations for pm checking
incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches, incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches,
...@@ -70,7 +70,7 @@ import BasicTypes ( Origin ) ...@@ -70,7 +70,7 @@ import BasicTypes ( Origin )
import DataCon import DataCon
import ConLike import ConLike
import TyCon import TyCon
import PmExpr import {-# SOURCE #-} PmOracle
import Id import Id
import Module import Module
import Outputable import Outputable
...@@ -82,7 +82,6 @@ import NameEnv ...@@ -82,7 +82,6 @@ import NameEnv
import DynFlags import DynFlags
import ErrUtils import ErrUtils
import FastString import FastString
import Var (EvVar)
import UniqFM ( lookupWithDefaultUFM ) import UniqFM ( lookupWithDefaultUFM )
import Literal ( mkLitString ) import Literal ( mkLitString )
import CostCentreState import CostCentreState
...@@ -285,8 +284,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar cc_st_var ...@@ -285,8 +284,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar cc_st_var
} }
lcl_env = DsLclEnv { dsl_meta = emptyNameEnv lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
, dsl_loc = real_span , dsl_loc = real_span
, dsl_dicts = emptyBag , dsl_delta = initDelta
, dsl_tm_cs = emptyBag
, dsl_pm_iter = pmvar , dsl_pm_iter = pmvar
} }
in (gbl_env, lcl_env) in (gbl_env, lcl_env)
...@@ -386,23 +384,14 @@ the @SrcSpan@ being carried around. ...@@ -386,23 +384,14 @@ the @SrcSpan@ being carried around.
getGhcModeDs :: DsM GhcMode getGhcModeDs :: DsM GhcMode
getGhcModeDs = getDynFlags >>= return . ghcMode getGhcModeDs = getDynFlags >>= return . ghcMode
-- | Get in-scope type constraints (pm check) -- | Get the current pattern match oracle state. See 'dsl_delta'.
getDictsDs :: DsM (Bag EvVar) getPmDelta :: DsM Delta
getDictsDs = do { env <- getLclEnv; return (dsl_dicts env) } getPmDelta = do { env <- getLclEnv; return (dsl_delta env) }
-- | Add in-scope type constraints (pm check) -- | Set the pattern match oracle state within the scope of the given action.
addDictsDs :: Bag EvVar -> DsM a -> DsM a -- See 'dsl_delta'.
addDictsDs ev_vars updPmDelta :: Delta -> DsM a -> DsM a
= updLclEnv (\env -> env { dsl_dicts = unionBags ev_vars (dsl_dicts env) }) updPmDelta delta = updLclEnv (\env -> env { dsl_delta = delta })
-- | Get in-scope term constraints (pm check)
getTmCsDs :: DsM (Bag TmVarCt)
getTmCsDs = do { env <- getLclEnv; return (dsl_tm_cs env) }
-- | Add in-scope term constraints (pm check)
addTmCsDs :: Bag TmVarCt -> DsM a -> DsM a
addTmCsDs tm_cs
= updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) })
-- | Increase the counter for elapsed pattern match check iterations. -- | Increase the counter for elapsed pattern match check iterations.
-- If the current counter is already over the limit, fail -- If the current counter is already over the limit, fail
......
...@@ -289,7 +289,7 @@ ungroup group_ = ...@@ -289,7 +289,7 @@ ungroup group_ =
mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++ mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++
mkDecls (valbinds . hs_valds) (ValD noExtField) group_ mkDecls (valbinds . hs_valds) (ValD noExtField) group_
where where
typesigs (XValBindsLR (NValBinds _ sigs)) = filter (isUserSig . unLoc) sigs typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig
typesigs ValBinds{} = error "expected XValBindsLR" typesigs ValBinds{} = error "expected XValBindsLR"
valbinds (XValBindsLR (NValBinds binds _)) = valbinds (XValBindsLR (NValBinds binds _)) =
......
...@@ -690,7 +690,13 @@ Call @match@ with all of this information! ...@@ -690,7 +690,13 @@ Call @match@ with all of this information!
matchWrapper matchWrapper
:: HsMatchContext Name -- ^ For shadowing warning messages :: HsMatchContext Name -- ^ For shadowing warning messages
-> Maybe (LHsExpr GhcTc) -- ^ Scrutinee, if we check a case expr -> Maybe (LHsExpr GhcTc) -- ^ Scrutinee. (Just scrut) for a case expr
-- case scrut of { p1 -> e1 ... }
-- (and in this case the MatchGroup will
-- have all singleton patterns)
-- Nothing for a function definition
-- f p1 q1 = ... -- No "scrutinee"
-- f p2 q2 = ... -- in this case
-> MatchGroup GhcTc (LHsExpr GhcTc) -- ^ Matches being desugared -> MatchGroup GhcTc (LHsExpr GhcTc) -- ^ Matches being desugared
-> DsM ([Id], CoreExpr) -- ^ Results (usually passed to 'match') -> DsM ([Id], CoreExpr) -- ^ Results (usually passed to 'match')
...@@ -730,25 +736,30 @@ matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches) ...@@ -730,25 +736,30 @@ matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches)
; eqns_info <- mapM (mk_eqn_info new_vars) matches ; eqns_info <- mapM (mk_eqn_info new_vars) matches
-- pattern match check warnings -- Pattern match check warnings for /this match-group/
; unless (isGenerated origin) $ ; when (isMatchContextPmChecked dflags origin ctxt) $
when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $ addScrutTmCs mb_scr new_vars $
addTmCsDs (genCaseTmCs1 mb_scr new_vars) $ -- See Note [Type and Term Equality Propagation]
-- See Note [Type and Term Equality Propagation] checkMatches dflags (DsMatchContext ctxt locn) new_vars matches
checkMatches dflags (DsMatchContext ctxt locn) new_vars matches
; result_expr <- handleWarnings $ ; result_expr <- handleWarnings $
matchEquations ctxt new_vars eqns_info rhs_ty matchEquations ctxt new_vars eqns_info rhs_ty
; return (new_vars, result_expr) } ; return (new_vars, result_expr) }
where where
-- Called once per equation in the match, or alternative in the case
mk_eqn_info vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss })) mk_eqn_info vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }))
= do { dflags <- getDynFlags = do { dflags <- getDynFlags
; let upats = map (unLoc . decideBangHood dflags) pats ; let upats = map (unLoc . decideBangHood dflags) pats
dicts = collectEvVarsPats upats dicts = collectEvVarsPats upats
; tm_cs <- genCaseTmCs2 mb_scr upats vars
; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation] ; match_result <-
addTmCsDs tm_cs $ -- See Note [Type and Term Equality Propagation] -- Extend the environment with knowledge about
dsGRHSs ctxt grhss rhs_ty -- the matches before desguaring the RHS
-- See Note [Type and Term Equality Propagation]
applyWhen (needToRunPmCheck dflags origin)
(addTyCsDs dicts . addScrutTmCs mb_scr vars . addPatTmCs upats vars)
(dsGRHSs ctxt grhss rhs_ty)
; return (EqnInfo { eqn_pats = upats ; return (EqnInfo { eqn_pats = upats
, eqn_orig = FromSource , eqn_orig = FromSource
, eqn_rhs = match_result }) } , eqn_rhs = match_result }) }
......
This diff is collapsed.
This diff is collapsed.
module PmOracle where
import GhcPrelude ()
data Delta
initDelta :: Delta
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP, ViewPatterns #-}
-- | Provides factilities for pretty-printing 'PmExpr's in a way approriate for -- | Provides factilities for pretty-printing 'PmExpr's in a way approriate for
-- user facing pattern match warnings. -- user facing pattern match warnings.
...@@ -10,20 +10,20 @@ module PmPpr ( ...@@ -10,20 +10,20 @@ module PmPpr (
import GhcPrelude import GhcPrelude
import Name import Id
import NameEnv import VarEnv
import NameSet
import UniqDFM import UniqDFM
import UniqSet
import ConLike import ConLike
import DataCon import DataCon
import TysWiredIn import TysWiredIn
import Outputable import Outputable
import Control.Monad.Trans.State.Strict import Control.Monad.Trans.RWS.CPS
import Maybes
import Util import Util
import Maybes
import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)
import TmOracle import PmExpr
import PmOracle
-- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its -- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its
-- components and refutable shapes associated to any mentioned variables. -- components and refutable shapes associated to any mentioned variables.
...@@ -35,22 +35,31 @@ import TmOracle ...@@ -35,22 +35,31 @@ import TmOracle
-- where p is not one of {3, 4} -- where p is not one of {3, 4}
-- q is not one of {0, 5} -- q is not one of {0, 5}
-- @ -- @
pprUncovered :: ([PmExpr], PmRefutEnv) -> SDoc --
pprUncovered (expr_vec, refuts) -- When the set of refutable shapes contains more than 3 elements, the
| null cs = fsep vec -- there are no literal constraints -- additional elements are indicated by "...".
| otherwise = hang (fsep vec) 4 $ pprUncovered :: Delta -> [Id] -> SDoc
text "where" <+> vcat (map pprRefutableShapes cs) pprUncovered delta vas
| isNullUDFM refuts = fsep vec -- there are no refutations
| otherwise = hang (fsep vec) 4 $
text "where" <+> vcat (map (pprRefutableShapes . snd) (udfmToList refuts))
where where
sdoc_vec = mapM pprPmExprWithParens expr_vec ppr_action = mapM (pprPmExprVar 2) vas
(vec,cs) = runPmPpr sdoc_vec (prettifyRefuts refuts) (vec, renamings) = runPmPpr delta ppr_action
refuts = prettifyRefuts delta renamings
-- | Output refutable shapes of a variable in the form of @var is not one of {2, -- | Output refutable shapes of a variable in the form of @var is not one of {2,
-- Nothing, 3}@. -- Nothing, 3}@. Will never print more than 3 refutable shapes, the tail is
-- indicated by an ellipsis.
pprRefutableShapes :: (SDoc,[PmAltCon]) -> SDoc pprRefutableShapes :: (SDoc,[PmAltCon]) -> SDoc
pprRefutableShapes (var, alts) pprRefutableShapes (var, alts)
= var <+> text "is not one of" <+> braces (pprWithCommas ppr_alt alts) = var <+> text "is not one of" <+> format_alts alts
where where
ppr_alt (PmAltLit lit) = ppr lit format_alts = braces . fsep . punctuate comma . shorten . map ppr_alt
shorten (a:b:c:_:_) = a:b:c:[text "..."]
shorten xs = xs
ppr_alt (PmAltConLike cl) = ppr cl
ppr_alt (PmAltLit lit) = ppr lit
{- 1. Literals {- 1. Literals
~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~
...@@ -78,114 +87,115 @@ substitution to the vectors before printing them out (see function `pprOne' in ...@@ -78,114 +87,115 @@ substitution to the vectors before printing them out (see function `pprOne' in
Check.hs) to be more precise. Check.hs) to be more precise.
-} -}
-- | A 'PmRefutEnv' with pretty names for the occuring variables. -- | Extract and assigns pretty names to constraint variables with refutable
type PrettyPmRefutEnv = DNameEnv (SDoc, [PmAltCon]) -- shapes.
prettifyRefuts :: Delta -> DIdEnv SDoc -> DIdEnv (SDoc, [PmAltCon])
-- | Assigns pretty names to constraint variables in the domain of the given prettifyRefuts delta = listToUDFM . map attach_refuts . udfmToList
-- 'PmRefutEnv'.
prettifyRefuts :: PmRefutEnv -> PrettyPmRefutEnv
prettifyRefuts = listToUDFM . zipWith rename nameList . udfmToList
where where
rename new (old, lits) = (old, (new, lits)) attach_refuts (u, sdoc) = (u, (sdoc, lookupRefuts delta u))
-- Try nice names p,q,r,s,t before using the (ugly) t_i
nameList :: [SDoc]
nameList = map text ["p","q","r","s","t"] ++ type PmPprM a = RWS Delta () (DIdEnv SDoc, [SDoc]) a
[ text ('t':show u) | u <- [(0 :: Int)..] ]
-- Try nice names p,q,r,s,t before using the (ugly) t_i
type PmPprM a = State (PrettyPmRefutEnv, NameSet) a nameList :: [SDoc]
-- (the first part of the state is read only. make it a reader?) nameList = map text ["p","q","r","s","t"] ++
[ text ('t':show u) | u <- [(0 :: Int)..] ]
runPmPpr :: PmPprM a -> PrettyPmRefutEnv -> (a, [(SDoc,[PmAltCon])])
runPmPpr m lit_env = (result, mapMaybe is_used (udfmToList lit_env)) runPmPpr :: Delta -> PmPprM a -> (a, DIdEnv SDoc)
where runPmPpr delta m = case runRWS m delta (emptyDVarEnv, nameList) of
(result, (_lit_env, used)) = runState m (lit_env, emptyNameSet) (a, (renamings, _), _) -> (a, renamings)
is_used (k,v) -- | Allocates a new, clean name for the given 'Id' if it doesn't already have
| elemUniqSet_Directly k used = Just v -- one.
| otherwise = Nothing getCleanName :: Id -> PmPprM SDoc
getCleanName x = do
addUsed :: Name -> PmPprM () (renamings, name_supply) <- get
addUsed x = modify (\(negated, used) -> (negated, extendNameSet used x)) let (clean_name:name_supply') = name_supply
case lookupDVarEnv renamings x of
checkNegation :: Name -> PmPprM (Maybe SDoc) -- the clean name if it is negated Just nm -> pure nm
checkNegation x = do Nothing -> do
negated <- gets fst put (extendDVarEnv renamings x clean_name, name_supply')
return $ case lookupDNameEnv negated x of pure clean_name
Just (new, _) -> Just new
Nothing -> Nothing checkRefuts :: Id -> PmPprM (Maybe SDoc) -- the clean name if it has negative info attached
checkRefuts x = do
-- | Pretty print a pmexpr, but remember to prettify the names of the variables delta <- ask
case lookupRefuts delta x of
[] -> pure Nothing -- Will just be a wildcard later on
_ -> Just <$> getCleanName x
-- | Pretty print a variable, but remember to prettify the names of the variables
-- that refer to neg-literals. The ones that cannot be shown are printed as -- that refer to neg-literals. The ones that cannot be shown are printed as
-- underscores. -- underscores.
pprPmExpr :: PmExpr -> PmPprM SDoc pprPmExprVar :: Int -> Id -> PmPprM SDoc
pprPmExpr (PmExprVar x) = do pprPmExprVar prec x = do
mb_name <- checkNegation x delta <- ask
case mb_name of case lookupSolution delta x of
Just name -> addUsed x >> return name Just (alt, args) -> pprPmExprCon prec alt args
Nothing -> return underscore Nothing -> fromMaybe underscore <$> checkRefuts x
pprPmExpr (PmExprCon con args) = pprPmExprCon con args
pprPmExpr (PmExprLit l) = return (ppr l) pprPmExprCon :: Int -> PmAltCon -> [Id] -> PmPprM SDoc
pprPmExpr (PmExprOther _) = return underscore -- don't show pprPmExprCon _prec (PmAltLit l) _ = pure (ppr l)
pprPmExprCon prec (PmAltConLike cl) args = do
needsParens :: PmExpr -> Bool delta <- ask
needsParens (PmExprVar {}) = False pprConLike delta prec cl args
needsParens (PmExprLit l) = isNegatedPmLit l
needsParens (PmExprOther {}) = False -- will become a wildcard pprConLike :: Delta -> Int -> ConLike -> [Id] -> PmPprM SDoc
needsParens (PmExprCon (RealDataCon c) es) pprConLike delta _prec cl args
| isTupleDataCon c | Just pm_expr_list <- pmExprAsList delta (PmAltConLike cl) args
|| isConsDataCon c || null es = False = case pm_expr_list of
| otherwise = True NilTerminated list ->
needsParens (PmExprCon (PatSynCon _) es) = not (null es) brackets . fsep . punctuate comma <$> mapM (pprPmExprVar 0) list
WcVarTerminated pref x ->
pprPmExprWithParens :: PmExpr -> PmPprM SDoc parens . fcat . punctuate colon <$> mapM (pprPmExprVar 0) (toList pref ++ [x])
pprPmExprWithParens expr pprConLike _delta _prec (RealDataCon con) args
| needsParens expr = parens <$> pprPmExpr expr | isUnboxedTupleCon con
| otherwise = pprPmExpr expr , let hash_parens doc = text "(#" <+> doc <+> text "#)"
= hash_parens . fsep . punctuate comma <$> mapM (pprPmExprVar 0) args
pprPmExprCon :: ConLike -> [PmExpr] -> PmPprM SDoc | isTupleDataCon con
pprPmExprCon (RealDataCon con) args = parens . fsep . punctuate comma <$> mapM (pprPmExprVar 0) args
| isTupleDataCon con = mkTuple <$> mapM pprPmExpr args pprConLike _delta prec cl args
| isConsDataCon con = pretty_list
where
mkTuple :: [SDoc] -> SDoc
mkTuple = parens . fsep . punctuate comma
-- lazily, to be used in the list case only
pretty_list :: PmPprM SDoc
pretty_list = case isNilPmExpr (last list) of
True -> brackets . fsep . punctuate comma <$> mapM pprPmExpr (init list)
False -> parens . hcat . punctuate colon <$> mapM pprPmExpr list
list = list_elements args
list_elements [x,y]
| PmExprCon c es <- y, RealDataCon nilDataCon == c