never executed always true always false
1
2
3 {-
4 (c) The University of Glasgow 2006
5 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6
7
8 Matching guarded right-hand-sides (GRHSs)
9 -}
10
11 module GHC.HsToCore.GuardedRHSs ( dsGuarded, dsGRHSs, isTrueLHsExpr ) where
12
13 import GHC.Prelude
14
15 import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsLocalBinds )
16 import {-# SOURCE #-} GHC.HsToCore.Match ( matchSinglePatVar )
17
18 import GHC.Hs
19 import GHC.Core.Make
20 import GHC.Core
21 import GHC.Core.Utils (bindNonRec)
22
23 import GHC.HsToCore.Monad
24 import GHC.HsToCore.Utils
25 import GHC.HsToCore.Pmc.Types ( Nablas )
26 import GHC.Core.Type ( Type )
27 import GHC.Utils.Misc
28 import GHC.Types.SrcLoc
29 import GHC.Utils.Outputable
30 import GHC.Utils.Panic
31 import GHC.Utils.Panic.Plain
32 import GHC.Core.Multiplicity
33 import Control.Monad ( zipWithM )
34 import Data.List.NonEmpty ( NonEmpty, toList )
35
36 {-
37 @dsGuarded@ is used for GRHSs.
38 It desugars:
39 \begin{verbatim}
40 | g1 -> e1
41 ...
42 | gn -> en
43 where binds
44 \end{verbatim}
45 producing an expression with a runtime error in the corner case if
46 necessary. The type argument gives the type of the @ei@.
47 -}
48
49 dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> NonEmpty Nablas -> DsM CoreExpr
50 dsGuarded grhss rhs_ty rhss_nablas = do
51 match_result <- dsGRHSs PatBindRhs grhss rhs_ty rhss_nablas
52 error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty
53 (text "pattern binding")
54 extractMatchResult match_result error_expr
55
56 -- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr@.
57
58 dsGRHSs :: HsMatchContext GhcRn
59 -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs
60 -> Type -- ^ Type of RHS
61 -> NonEmpty Nablas -- ^ Refined pattern match checking
62 -- models, one for the pattern part and
63 -- one for each GRHS.
64 -> DsM (MatchResult CoreExpr)
65 dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas
66 = assert (notNull grhss) $
67 do { match_results <- assert (length grhss == length rhss_nablas) $
68 zipWithM (dsGRHS hs_ctx rhs_ty) (toList rhss_nablas) grhss
69 ; nablas <- getPmNablas
70 -- We need to remember the Nablas from the particular match context we
71 -- are in, which might be different to when dsLocalBinds is actually
72 -- called.
73 ; let ds_binds = updPmNablas nablas . dsLocalBinds binds
74 match_result1 = foldr1 combineMatchResults match_results
75 match_result2 = adjustMatchResultDs ds_binds match_result1
76 -- NB: nested dsLet inside matchResult
77 ; return match_result2 }
78
79 dsGRHS :: HsMatchContext GhcRn -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc)
80 -> DsM (MatchResult CoreExpr)
81 dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))
82 = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs_nablas rhs rhs_ty
83
84 {-
85 ************************************************************************
86 * *
87 * matchGuard : make a MatchResult CoreExpr CoreExpr from a guarded RHS *
88 * *
89 ************************************************************************
90 -}
91
92 matchGuards :: [GuardStmt GhcTc] -- Guard
93 -> HsStmtContext GhcRn -- Context
94 -> Nablas -- The RHS's covered set for PmCheck
95 -> LHsExpr GhcTc -- RHS
96 -> Type -- Type of RHS of guard
97 -> DsM (MatchResult CoreExpr)
98
99 -- See comments with HsExpr.Stmt re what a BodyStmt means
100 -- Here we must be in a guard context (not do-expression, nor list-comp)
101
102 matchGuards [] _ nablas rhs _
103 = do { core_rhs <- updPmNablas nablas (dsLExpr rhs)
104 ; return (cantFailMatchResult core_rhs) }
105
106 -- BodyStmts must be guards
107 -- Turn an "otherwise" guard is a no-op. This ensures that
108 -- you don't get a "non-exhaustive eqns" message when the guards
109 -- finish in "otherwise".
110 -- NB: The success of this clause depends on the typechecker not
111 -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
112 -- If it does, you'll get bogus overlap warnings
113 matchGuards (BodyStmt _ e _ _ : stmts) ctx nablas rhs rhs_ty
114 | Just addTicks <- isTrueLHsExpr e = do
115 match_result <- matchGuards stmts ctx nablas rhs rhs_ty
116 return (adjustMatchResultDs addTicks match_result)
117 matchGuards (BodyStmt _ expr _ _ : stmts) ctx nablas rhs rhs_ty = do
118 match_result <- matchGuards stmts ctx nablas rhs rhs_ty
119 pred_expr <- dsLExpr expr
120 return (mkGuardedMatchResult pred_expr match_result)
121
122 matchGuards (LetStmt _ binds : stmts) ctx nablas rhs rhs_ty = do
123 match_result <- matchGuards stmts ctx nablas rhs rhs_ty
124 return (adjustMatchResultDs (dsLocalBinds binds) match_result)
125 -- NB the dsLet occurs inside the match_result
126 -- Reason: dsLet takes the body expression as its argument
127 -- so we can't desugar the bindings without the
128 -- body expression in hand
129
130 matchGuards (BindStmt _ pat bind_rhs : stmts) ctx nablas rhs rhs_ty = do
131 let upat = unLoc pat
132 match_var <- selectMatchVar Many upat
133 -- We only allow unrestricted patterns in guard, hence the `Many`
134 -- above. It isn't clear what linear patterns would mean, maybe we will
135 -- figure it out in the future.
136
137 match_result <- matchGuards stmts ctx nablas rhs rhs_ty
138 core_rhs <- dsLExpr bind_rhs
139 match_result' <- matchSinglePatVar match_var (Just core_rhs) (StmtCtxt ctx)
140 pat rhs_ty match_result
141 pure $ bindNonRec match_var core_rhs <$> match_result'
142
143 matchGuards (LastStmt {} : _) _ _ _ _ = panic "matchGuards LastStmt"
144 matchGuards (ParStmt {} : _) _ _ _ _ = panic "matchGuards ParStmt"
145 matchGuards (TransStmt {} : _) _ _ _ _ = panic "matchGuards TransStmt"
146 matchGuards (RecStmt {} : _) _ _ _ _ = panic "matchGuards RecStmt"
147 matchGuards (ApplicativeStmt {} : _) _ _ _ _ =
148 panic "matchGuards ApplicativeLastStmt"
149
150 {-
151 Should {\em fail} if @e@ returns @D@
152 \begin{verbatim}
153 f x | p <- e', let C y# = e, f y# = r1
154 | otherwise = r2
155 \end{verbatim}
156 -}