Commit af1e84e7 authored by Sebastian Graf's avatar Sebastian Graf Committed by Marge Bot
Browse files

PmCheck: Big refactor of module structure

  * Move everything from `GHC.HsToCore.PmCheck.*` to
    `GHC.HsToCore.Pmc.*` in analogy to `GHC.Tc`, rename exported
    `covCheck*` functions to `pmc*`
  * Rename `Pmc.Oracle` to `Pmc.Solver`
  * Split off the LYG desugaring and checking steps into their own
    modules (`Pmc.Desugar` and `Pmc.Check` respectively)
  * Split off a `Pmc.Utils` module with stuff shared by
    `Pmc.{,Desugar,Check,Solver}`
  * Move `Pmc.Types` to `Pmc.Solver.Types`, add a new `Pmc.Types` module
    with all the LYG types, which form the interfaces between
    `Pmc.{Desugar,Check,Solver,}`.
parent 83407ffc
......@@ -247,7 +247,7 @@ NoExtCon. But since (1) the field is strict and (2) NoExtCon is an empty data
type, there is no possible way to reach the right-hand side of the XHsDecl
case. As a result, the coverage checker concludes that the XHsDecl case is
inaccessible, so it can be removed.
(See Note [Strict argument type constraints] in GHC.HsToCore.PmCheck.Oracle for
(See Note [Strict argument type constraints] in GHC.HsToCore.Pmc.Solver for
more on how this works.)
Bottom line: if you add a TTG extension constructor that uses NoExtCon, make
......
......@@ -33,7 +33,7 @@ import {-# SOURCE #-} GHC.HsToCore.Match ( matchWrapper )
import GHC.HsToCore.Monad
import GHC.HsToCore.GuardedRHSs
import GHC.HsToCore.Utils
import GHC.HsToCore.PmCheck ( addTyCs, covCheckGRHSs )
import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )
import GHC.Hs -- lots of things
import GHC.Core -- lots of things
......@@ -159,7 +159,7 @@ dsHsBind dflags b@(FunBind { fun_id = L loc fun
-- oracle.
-- addTyCs: Add type evidence to the refinement type
-- predicate of the coverage checker
-- See Note [Long-distance information] in "GHC.HsToCore.PmCheck"
-- See Note [Long-distance information] in "GHC.HsToCore.Pmc"
matchWrapper
(mkPrefixFunRhs (L loc (idName fun)))
Nothing matches
......@@ -185,7 +185,7 @@ dsHsBind dflags b@(FunBind { fun_id = L loc fun
dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
, pat_ext = ty
, pat_ticks = (rhs_tick, var_ticks) })
= do { rhss_nablas <- covCheckGRHSs PatBindGuards grhss
= do { rhss_nablas <- pmcGRHSs PatBindGuards grhss
; body_expr <- dsGuarded grhss ty rhss_nablas
; let body' = mkOptTickBox rhs_tick body_expr
pat' = decideBangHood dflags pat
......
......@@ -31,7 +31,7 @@ import GHC.HsToCore.ListComp
import GHC.HsToCore.Utils
import GHC.HsToCore.Arrows
import GHC.HsToCore.Monad
import GHC.HsToCore.PmCheck ( addTyCs, covCheckGRHSs )
import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Core.FamInstEnv( topNormaliseType )
......@@ -215,7 +215,7 @@ dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss
, pat_ext = ty }) body
= -- let C x# y# = rhs in body
-- ==> case rhs of C x# y# -> body
do { match_nablas <- covCheckGRHSs PatBindGuards grhss
do { match_nablas <- pmcGRHSs PatBindGuards grhss
; rhs <- dsGuarded grhss ty match_nablas
; let upat = unLoc pat
eqn = EqnInfo { eqn_pats = [upat],
......@@ -490,7 +490,7 @@ dsExpr (HsMultiIf res_ty alts)
| otherwise
= do { let grhss = GRHSs noExtField alts (noLoc emptyLocalBinds)
; rhss_nablas <- covCheckGRHSs IfAlt grhss
; rhss_nablas <- pmcGRHSs IfAlt grhss
; match_result <- dsGRHSs IfAlt grhss res_ty rhss_nablas
; error_expr <- mkErrorExpr
; extractMatchResult match_result error_expr }
......
......@@ -25,7 +25,7 @@ import GHC.Core.Utils (bindNonRec)
import GHC.HsToCore.Monad
import GHC.HsToCore.Utils
import GHC.HsToCore.PmCheck.Types ( Nablas )
import GHC.HsToCore.Pmc.Types ( Nablas )
import GHC.Core.Type ( Type )
import GHC.Utils.Misc
import GHC.Types.SrcLoc
......
......@@ -34,8 +34,8 @@ import GHC.Hs
import GHC.Tc.Utils.Zonk
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad
import GHC.HsToCore.PmCheck
import GHC.HsToCore.PmCheck.Types ( Nablas, initNablas )
import GHC.HsToCore.Pmc
import GHC.HsToCore.Pmc.Types ( Nablas, initNablas )
import GHC.Core
import GHC.Types.Literal
import GHC.Core.Utils
......@@ -771,7 +771,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt
then addHsScrutTmCs mb_scr new_vars $
-- See Note [Long-distance information]
covCheckMatches (DsMatchContext ctxt locn) new_vars matches
pmcMatches (DsMatchContext ctxt locn) new_vars matches
else pure (initNablasMatches matches)
; eqns_info <- zipWithM mk_eqn_info matches matches_nablas
......@@ -881,7 +881,7 @@ matchSinglePatVar var mb_scrut ctx pat ty match_result
-- Pattern match check warnings
; when (isMatchContextPmChecked dflags FromSource ctx) $
addCoreScrutTmCs mb_scrut [var] $
covCheckPatBind (DsMatchContext ctx locn) var (unLoc pat)
pmcPatBind (DsMatchContext ctx locn) var (unLoc pat)
; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
, eqn_orig = FromSource
......
......@@ -75,7 +75,7 @@ import GHC.Core.DataCon
import GHC.Core.ConLike
import GHC.Core.TyCon
import GHC.HsToCore.Types
import GHC.HsToCore.PmCheck.Types
import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas)
import GHC.Types.Id
import GHC.Unit.Module
import GHC.Utils.Outputable
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleInstances #-}
-- | Coverage checking step of the
-- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989).
--
-- Coverage check guard trees (like @'PmMatch' 'Pre'@) to get a
-- 'CheckResult', containing
--
-- 1. The set of uncovered values, 'cr_uncov'
-- 2. And an annotated tree variant (like @'PmMatch' 'Post'@) that captures
-- redundancy and inaccessibility information as 'RedSets' annotations
--
-- Basically the UA function from Section 5.1, which is an optimised
-- interleaving of U and A from Section 3.2 (Figure 5).
-- The Normalised Refinement Types 'Nablas' are maintained in
-- "GHC.HsToCore.Pmc.Solver".
module GHC.HsToCore.Pmc.Check (
CheckAction(..),
checkMatchGroup, checkGRHSs, checkPatBind, checkEmptyCase
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.HsToCore.Monad ( DsM )
import GHC.HsToCore.Pmc.Types
import GHC.HsToCore.Pmc.Utils
import GHC.HsToCore.Pmc.Solver
import GHC.Driver.Session
import GHC.Utils.Outputable
import GHC.Tc.Utils.TcType (evVarPred)
import GHC.Data.OrdList
import qualified Data.Semigroup as Semi
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import Data.Coerce
-- | Coverage checking action. Can be composed 'leftToRight' or 'topToBottom'.
newtype CheckAction a = CA { unCA :: Nablas -> DsM (CheckResult a) }
deriving Functor
-- | Composes 'CheckAction's top-to-bottom:
-- If a value falls through the resulting action, then it must fall through the
-- first action and then through the second action.
-- If a value matches the resulting action, then it either matches the
-- first action or matches the second action.
-- Basically the semantics of the LYG branching construct.
topToBottom :: (top -> bot -> ret)
-> CheckAction top
-> CheckAction bot
-> CheckAction ret
topToBottom f (CA top) (CA bot) = CA $ \inc -> do
t <- top inc
b <- bot (cr_uncov t)
pure CheckResult { cr_ret = f (cr_ret t) (cr_ret b)
, cr_uncov = cr_uncov b
, cr_approx = cr_approx t Semi.<> cr_approx b }
-- | Composes 'CheckAction's left-to-right:
-- If a value falls through the resulting action, then it either falls through the
-- first action or through the second action.
-- If a value matches the resulting action, then it must match the first action
-- and then match the second action.
-- Basically the semantics of the LYG guard construct.
leftToRight :: (RedSets -> right -> ret)
-> CheckAction RedSets
-> CheckAction right
-> CheckAction ret
leftToRight f (CA left) (CA right) = CA $ \inc -> do
l <- left inc
r <- right (rs_cov (cr_ret l))
limit <- maxPmCheckModels <$> getDynFlags
let uncov = cr_uncov l Semi.<> cr_uncov r
-- See Note [Countering exponential blowup]
let (prec', uncov') = throttle limit inc uncov
pure CheckResult { cr_ret = f (cr_ret l) (cr_ret r)
, cr_uncov = uncov'
, cr_approx = prec' Semi.<> cr_approx l Semi.<> cr_approx r }
-- | @throttle limit old new@ returns @old@ if the number of 'Nabla's in @new@
-- is exceeding the given @limit@ and the @old@ number of 'Nabla's.
-- See Note [Countering exponential blowup].
throttle :: Int -> Nablas -> Nablas -> (Precision, Nablas)
throttle limit old@(MkNablas old_ds) new@(MkNablas new_ds)
--- | pprTrace "PmCheck:throttle" (ppr (length old_ds) <+> ppr (length new_ds) <+> ppr limit) False = undefined
| length new_ds > max limit (length old_ds) = (Approximate, old)
| otherwise = (Precise, new)
checkSequence :: (grdtree -> CheckAction anntree) -> NonEmpty grdtree -> CheckAction (NonEmpty anntree)
-- The implementation is pretty similar to
-- @traverse1 :: Apply f => (a -> f b) -> NonEmpty a -> f (NonEmpty b)@
checkSequence act (t :| []) = (:| []) <$> act t
checkSequence act (t1 :| (t2:ts)) =
topToBottom (NE.<|) (act t1) (checkSequence act (t2:|ts))
emptyRedSets :: RedSets
-- Semigroup instance would be misleading!
emptyRedSets = RedSets mempty mempty mempty
checkGrd :: PmGrd -> CheckAction RedSets
checkGrd grd = CA $ \inc -> case grd of
-- let x = e: Refine with x ~ e
PmLet x e -> do
matched <- addPhiCtNablas inc (PhiCoreCt x e)
tracePm "check:Let" (ppr x <+> char '=' <+> ppr e)
pure CheckResult { cr_ret = emptyRedSets { rs_cov = matched }
, cr_uncov = mempty
, cr_approx = Precise }
-- Bang x _: Diverge on x ~ ⊥, refine with x ≁ ⊥
PmBang x mb_info -> do
div <- addPhiCtNablas inc (PhiBotCt x)
matched <- addPhiCtNablas inc (PhiNotBotCt x)
-- See Note [Dead bang patterns]
-- mb_info = Just info <==> PmBang originates from bang pattern in source
let bangs | Just info <- mb_info = unitOL (div, info)
| otherwise = NilOL
tracePm "check:Bang" (ppr x <+> ppr div)
pure CheckResult { cr_ret = RedSets { rs_cov = matched, rs_div = div, rs_bangs = bangs }
, cr_uncov = mempty
, cr_approx = Precise }
-- Con: Fall through on x ≁ K and refine with x ~ K ys and type info
PmCon x con tvs dicts args -> do
!div <- if isPmAltConMatchStrict con
then addPhiCtNablas inc (PhiBotCt x)
else pure mempty
!matched <- addPhiCtNablas inc (PhiConCt x con tvs (map evVarPred dicts) args)
!uncov <- addPhiCtNablas inc (PhiNotConCt x con)
tracePm "check:Con" $ vcat
[ ppr grd
, ppr inc
, hang (text "div") 2 (ppr div)
, hang (text "matched") 2 (ppr matched)
, hang (text "uncov") 2 (ppr uncov)
]
pure CheckResult { cr_ret = emptyRedSets { rs_cov = matched, rs_div = div }
, cr_uncov = uncov
, cr_approx = Precise }
checkGrds :: [PmGrd] -> CheckAction RedSets
checkGrds [] = CA $ \inc ->
pure CheckResult { cr_ret = emptyRedSets { rs_cov = inc }
, cr_uncov = mempty
, cr_approx = Precise }
checkGrds (g:grds) = leftToRight merge (checkGrd g) (checkGrds grds)
where
merge ri_g ri_grds = -- This operation would /not/ form a Semigroup!
RedSets { rs_cov = rs_cov ri_grds
, rs_div = rs_div ri_g Semi.<> rs_div ri_grds
, rs_bangs = rs_bangs ri_g Semi.<> rs_bangs ri_grds }
checkMatchGroup :: PmMatchGroup Pre -> CheckAction (PmMatchGroup Post)
checkMatchGroup (PmMatchGroup matches) =
PmMatchGroup <$> checkSequence checkMatch matches
checkMatch :: PmMatch Pre -> CheckAction (PmMatch Post)
checkMatch (PmMatch { pm_pats = GrdVec grds, pm_grhss = grhss }) =
leftToRight PmMatch (checkGrds grds) (checkGRHSs grhss)
checkGRHSs :: NonEmpty (PmGRHS Pre) -> CheckAction (NonEmpty (PmGRHS Post))
checkGRHSs = checkSequence checkGRHS
checkGRHS :: PmGRHS Pre -> CheckAction (PmGRHS Post)
checkGRHS (PmGRHS { pg_grds = GrdVec grds, pg_rhs = rhs_info }) =
flip PmGRHS rhs_info <$> checkGrds grds
checkEmptyCase :: PmEmptyCase -> CheckAction PmEmptyCase
-- See Note [Checking EmptyCase]
checkEmptyCase pe@(PmEmptyCase { pe_var = var }) = CA $ \inc -> do
unc <- addPhiCtNablas inc (PhiNotBotCt var)
pure CheckResult { cr_ret = pe, cr_uncov = unc, cr_approx = mempty }
checkPatBind :: (PmPatBind Pre) -> CheckAction (PmPatBind Post)
checkPatBind = coerce checkGRHS
{- Note [Checking EmptyCase]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-XEmptyCase is useful for matching on empty data types like 'Void'. For example,
the following is a complete match:
f :: Void -> ()
f x = case x of {}
Really, -XEmptyCase is the only way to write a program that at the same time is
safe (@f _ = error "boom"@ is not because of ⊥), doesn't trigger a warning
(@f !_ = error "inaccessible" has inaccessible RHS) and doesn't turn an
exception into divergence (@f x = f x@).
Semantically, unlike every other case expression, -XEmptyCase is strict in its
match var x, which rules out ⊥ as an inhabitant. So we add x ≁ ⊥ to the
initial Nabla and check if there are any values left to match on.
Note [Dead bang patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
f :: Bool -> Int
f True = 1
f !x = 2
Whenever we fall through to the second equation, we will already have evaluated
the argument. Thus, the bang pattern serves no purpose and should be warned
about. We call this kind of bang patterns "dead". Dead bangs are the ones
that under no circumstances can force a thunk that wasn't already forced.
Dead bangs are a form of redundant bangs; see below.
We can detect dead bang patterns by checking whether @x ~ ⊥@ is satisfiable
where the PmBang appears in 'checkGrd'. If not, then clearly the bang is
dead. So for a source bang, we add the refined Nabla and the source info to
the 'RedSet's 'rs_bangs'. When collecting stuff to warn, we test that Nabla for
inhabitants. If it's empty, we'll warn that it's redundant.
Note that we don't want to warn for a dead bang that appears on a redundant
clause. That is because in that case, we recommend to delete the clause wholly,
including its leading pattern match.
Dead bang patterns are redundant. But there are bang patterns which are
redundant that aren't dead, for example
f !() = 0
the bang still forces the match variable, before we attempt to match on (). But
it is redundant with the forcing done by the () match. We currently don't
detect redundant bangs that aren't dead.
Note [Countering exponential blowup]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Precise pattern match exhaustiveness checking is necessarily exponential in
the size of some input programs. We implement a counter-measure in the form of
the -fmax-pmcheck-models flag, limiting the number of Nablas we check against
each pattern by a constant.
How do we do that? Consider
f True True = ()
f True True = ()
And imagine we set our limit to 1 for the sake of the example. The first clause
will be checked against the initial Nabla, {}. Doing so will produce an
Uncovered set of size 2, containing the models {x≁True} and {x~True,y≁True}.
Also we find the first clause to cover the model {x~True,y~True}.
But the Uncovered set we get out of the match is too huge! We somehow have to
ensure not to make things worse as they are already, so we continue checking
with a singleton Uncovered set of the initial Nabla {}. Why is this
sound (wrt. the notion in GADTs Meet Their Match)? Well, it basically amounts
to forgetting that we matched against the first clause. The values represented
by {} are a superset of those represented by its two refinements {x≁True} and
{x~True,y≁True}.
This forgetfulness becomes very apparent in the example above: By continuing
with {} we don't detect the second clause as redundant, as it again covers the
same non-empty subset of {}. So we don't flag everything as redundant anymore,
but still will never flag something as redundant that isn't.
For exhaustivity, the converse applies: We will report @f@ as non-exhaustive
and report @f _ _@ as missing, which is a superset of the actual missing
matches. But soundness means we will never fail to report a missing match.
This mechanism is implemented in 'throttle'.
Guards are an extreme example in this regard, with #11195 being a particularly
dreadful example: Since their RHS are often pretty much unique, we split on a
variable (the one representing the RHS) that doesn't occur anywhere else in the
program, so we don't actually get useful information out of that split!
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleInstances #-}
-- | Desugaring step of the
-- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989).
--
-- Desugars Haskell source syntax into guard tree variants Pm*.
-- In terms of the paper, this module is concerned with Sections 3.1, Figure 4,
-- in particular.
module GHC.HsToCore.Pmc.Desugar (
desugarPatBind, desugarGRHSs, desugarMatches, desugarEmptyCase
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.HsToCore.Pmc.Types
import GHC.HsToCore.Pmc.Utils
import GHC.Core (Expr(Var,App))
import GHC.Data.FastString (unpackFS, lengthFS)
import GHC.Driver.Session
import GHC.Hs
import GHC.Tc.Utils.Zonk (shortCutLit)
import GHC.Types.Id
import GHC.Core.ConLike
import GHC.Types.Name
import GHC.Builtin.Types
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Core.DataCon
import GHC.Types.Var (EvVar)
import GHC.Core.Coercion
import GHC.Tc.Types.Evidence (HsWrapper(..), isIdHsWrapper)
import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr)
import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper)
import GHC.HsToCore.Utils (selectMatchVar)
import GHC.HsToCore.Match.Literal (dsLit, dsOverLit)
import GHC.HsToCore.Monad
import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.HsToCore.Utils (isTrueLHsExpr)
import GHC.Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
import GHC.Utils.Monad (concatMapM)
import Control.Monad (zipWithM)
import Data.List (elemIndex)
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
-- | Smart constructor that eliminates trivial lets
mkPmLetVar :: Id -> Id -> [PmGrd]
mkPmLetVar x y | x == y = []
mkPmLetVar x y = [PmLet x (Var y)]
-- | ADT constructor pattern => no existentials, no local constraints
vanillaConGrd :: Id -> DataCon -> [Id] -> PmGrd
vanillaConGrd scrut con arg_ids =
PmCon { pm_id = scrut, pm_con_con = PmAltConLike (RealDataCon con)
, pm_con_tvs = [], pm_con_dicts = [], pm_con_args = arg_ids }
-- | Creates a '[PmGrd]' refining a match var of list type to a list,
-- where list fields are matched against the incoming tagged '[PmGrd]'s.
-- For example:
-- @mkListGrds "a" "[(x, True <- x),(y, !y)]"@
-- to
-- @"[(x:b) <- a, True <- x, (y:c) <- b, !y, [] <- c]"@
-- where @b@ and @c@ are freshly allocated in @mkListGrds@ and @a@ is the match
-- variable.
mkListGrds :: Id -> [(Id, [PmGrd])] -> DsM [PmGrd]
-- See Note [Order of guards matter] for why we need to intertwine guards
-- on list elements.
mkListGrds a [] = pure [vanillaConGrd a nilDataCon []]
mkListGrds a ((x, head_grds):xs) = do
b <- mkPmId (idType a)
tail_grds <- mkListGrds b xs
pure $ vanillaConGrd a consDataCon [x, b] : head_grds ++ tail_grds
-- | Create a '[PmGrd]' refining a match variable to a 'PmLit'.
mkPmLitGrds :: Id -> PmLit -> DsM [PmGrd]
mkPmLitGrds x (PmLit _ (PmLitString s)) = do
-- We desugar String literals to list literals for better overlap reasoning.
-- It's a little unfortunate we do this here rather than in
-- 'GHC.HsToCore.Pmc.Solver.trySolve' and
-- 'GHC.HsToCore.Pmc.Solver.addRefutableAltCon', but it's so much simpler
-- here. See Note [Representation of Strings in TmState] in
-- GHC.HsToCore.Pmc.Solver
vars <- traverse mkPmId (take (lengthFS s) (repeat charTy))
let mk_char_lit y c = mkPmLitGrds y (PmLit charTy (PmLitChar c))
char_grdss <- zipWithM mk_char_lit vars (unpackFS s)
mkListGrds x (zip vars char_grdss)
mkPmLitGrds x lit = do
let grd = PmCon { pm_id = x
, pm_con_con = PmAltLit lit
, pm_con_tvs = []
, pm_con_dicts = []
, pm_con_args = [] }
pure [grd]
-- | @desugarPat _ x pat@ transforms @pat@ into a '[PmGrd]', where
-- the variable representing the match is @x@.
desugarPat :: Id -> Pat GhcTc -> DsM [PmGrd]
desugarPat x pat = case pat of
WildPat _ty -> pure []
VarPat _ y -> pure (mkPmLetVar (unLoc y) x)
ParPat _ p -> desugarLPat x p
LazyPat _ _ -> pure [] -- like a wildcard
BangPat _ p@(L l p') ->
-- Add the bang in front of the list, because it will happen before any
-- nested stuff.
(PmBang x pm_loc :) <$> desugarLPat x p
where pm_loc = Just (SrcInfo (L l (ppr p')))
-- (x@pat) ==> Desugar pat with x as match var and handle impedance
-- mismatch with incoming match var
AsPat _ (L _ y) p -> (mkPmLetVar y x ++) <$> desugarLPat y p
SigPat _ p _ty -> desugarLPat x p
-- See Note [Desugar CoPats]
-- Generally the translation is
-- pat |> co ===> let y = x |> co, pat <- y where y is a match var of pat
XPat (CoPat wrapper p _ty)
| isIdHsWrapper wrapper -> desugarPat x p
| WpCast co <- wrapper, isReflexiveCo co -> desugarPat x p
| otherwise -> do
(y, grds) <- desugarPatV p
wrap_rhs_y <- dsHsWrapper wrapper
pure (PmLet y (wrap_rhs_y (Var x)) : grds)
-- (n + k) ===> let b = x >= k, True <- b, let n = x-k
NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do
b <- mkPmId boolTy
let grd_b = vanillaConGrd b trueDataCon []
[ke1, ke2] <- traverse dsOverLit [unLoc k1, k2]
rhs_b <- dsSyntaxExpr ge [Var x, ke1]
rhs_n <- dsSyntaxExpr minus [Var x, ke2]
pure [PmLet b rhs_b, grd_b, PmLet n rhs_n]
-- (fun -> pat) ===> let y = fun x, pat <- y where y is a match var of pat
ViewPat _arg_ty lexpr pat -> do
(y, grds) <- desugarLPatV pat
fun <- dsLExpr lexpr
pure $ PmLet y (App fun (Var x)) : grds
-- list
ListPat (ListPatTc _elem_ty Nothing) ps ->
desugarListPat x ps
-- overloaded list
ListPat (ListPatTc elem_ty (Just (pat_ty, to_list))) pats -> do
dflags <- getDynFlags
case splitListTyConApp_maybe pat_ty of
Just _e_ty
| not (xopt LangExt.RebindableSyntax dflags)
-- Just desugar it as a regular ListPat
-> desugarListPat x pats
_ -> do
y <- mkPmId (mkListTy elem_ty)
grds <- desugarListPat y pats
rhs_y <- dsSyntaxExpr to_list [Var x]
pure $ PmLet y rhs_y : grds
-- (a) In the presence of RebindableSyntax, we don't know anything about
-- `toList`, we should treat `ListPat` as any other view pattern.
--
-- (b) In the absence of RebindableSyntax,
-- - If the pat_ty is `[a]`, then we treat the overloaded list pattern
-- as ordinary list pattern. Although we can give an instance
-- `IsList [Int]` (more specific than the default `IsList [a]`), in
-- practice, we almost never do that. We assume the `to_list` is
-- the `toList` from `instance IsList [a]`.
--
-- - Otherwise, we treat the `ListPat` as ordinary view pattern.
--
-- See #14547, especially comment#9 and comment#10.
ConPat { pat_con = L _ con
, pat_args = ps
, pat_con_ext = ConPatTc
{ cpt_arg_tys = arg_tys
, cpt_tvs = ex_tvs
, cpt_dicts = dicts
}
} -> do
desugarConPatOut x con arg_tys ex_tvs dicts ps
NPat ty (L _ olit) mb_neg _ -> do
-- See Note [Literal short cut] in "GHC.HsToCore.Match.Literal"
-- We inline the Literal short cut for @ty@ here, because @ty@ is more
-- precise than the field of OverLitTc, which is all that dsOverLit (which
-- normally does the literal short cut) can look at. Also @ty@ matches the
-- type of the scrutinee, so info on both pattern and scrutinee (for which
-- short cutting in dsOverLit works properly) is overloaded iff either is.
dflags <- getDynFlags
let platform = targetPlatform dflags
core_expr <- case olit of
OverLit{ ol_val = val, ol_ext = OverLitTc rebindable _ }
| not rebindable
, Just expr <- shortCutLit platform val ty