Commit 4fdc5234 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Use field names for all uses of datacon Match

This is refactoring only... elimiante all positional uses
of the data constructor Match in favour of field names.

No change in behaviour.
parent 7f2dee8e
......@@ -373,7 +373,7 @@ checkMatches' vars matches
(NotCovered, Diverged ) -> (final_prov, rs, final_u, m:is)
hsLMatchToLPats :: LMatch id body -> Located [LPat id]
hsLMatchToLPats (L l (Match _ pats _ _)) = L l pats
hsLMatchToLPats (L l (Match { m_pats = pats })) = L l pats
-- | Check an empty case expression. Since there are no clauses to process, we
-- only compute the uncovered set. See Note [Checking EmptyCase Expressions]
......@@ -748,7 +748,7 @@ translateConPatVec fam_insts univ_tys ex_tvs c (RecCon (HsRecFields fs _))
-- Translate a single match
translateMatch :: FamInstEnvs -> LMatch GhcTc (LHsExpr GhcTc)
-> DsM (PatVec,[PatVec])
translateMatch fam_insts (L _ (Match _ lpats _ grhss)) = do
translateMatch fam_insts (L _ (Match { m_pats = lpats, m_grhss = grhss })) = do
pats' <- concat <$> translatePatVec fam_insts pats
guards' <- mapM (translateGuards fam_insts) guards
return (pats', guards')
......
......@@ -657,10 +657,10 @@ addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
-> TM (Match GhcTc (LHsExpr GhcTc))
addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) =
addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats, m_grhss = gRHSs }) =
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
return $ Match mf pats opSig gRHSs'
return $ match { m_grhss = gRHSs' }
addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
......@@ -898,10 +898,10 @@ addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do
return $ mg { mg_alts = L l matches' }
addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
addTickCmdMatch (Match mf pats opSig gRHSs) =
addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickCmdGRHSs gRHSs
return $ Match mf pats opSig gRHSs'
return $ match { m_grhss = gRHSs' }
addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do
......@@ -1279,7 +1279,7 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
matchesOneOfMany :: [LMatch GhcTc body] -> Bool
matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
where
matchCount (L _ (Match _ _pats _ty (GRHSs grhss _binds))) = length grhss
matchCount (L _ (Match { m_grhss = GRHSs grhss _binds })) = length grhss
type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
......
......@@ -447,8 +447,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
-- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
dsCmd ids local_vars stack_ty res_ty
(HsCmdLam (MG { mg_alts = L _ [L _ (Match _ pats _
(GRHSs [L _ (GRHS [] body)] _ ))] }))
(HsCmdLam (MG { mg_alts = L _ [L _ (Match { m_pats = pats
, m_grhss = GRHSs [L _ (GRHS [] body)] _ })] }))
env_ids = do
let pat_vars = mkVarSet (collectPatsBinders pats)
let
......@@ -1106,7 +1106,7 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys"
leavesMatch :: LMatch GhcTc (Located (body GhcTc))
-> [(Located (body GhcTc), IdSet)]
leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds))))
leavesMatch (L _ (Match { m_pats = pats, m_grhss = GRHSs grhss (L _ binds) }))
= let
defined_vars = mkVarSet (collectPatsBinders pats)
`unionVarSet`
......@@ -1125,11 +1125,11 @@ replaceLeavesMatch
-> LMatch GhcTc (Located (body GhcTc)) -- the matches of a case command
-> ([Located (body' GhcTc)], -- remaining leaf expressions
LMatch GhcTc (Located (body' GhcTc))) -- updated match
replaceLeavesMatch _res_ty leaves (L loc (Match mf pat mt (GRHSs grhss binds)))
replaceLeavesMatch _res_ty leaves (L loc match@(Match { m_grhss = GRHSs grhss binds }))
= let
(leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
in
(leaves', L loc (Match mf pat mt (GRHSs grhss' binds)))
(leaves', L loc (match { m_grhss = GRHSs grhss' binds }))
replaceLeavesGRHS
:: [Located (body' GhcTc)] -- replacement leaf expressions of that type
......
......@@ -1257,7 +1257,7 @@ repE e = notHandled "Expression form" (ppr e)
-- Building representations of auxillary structures like Match, Clause, Stmt,
repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ)
repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) =
repMatchTup (L _ (Match { m_pats = [p], m_grhss = GRHSs guards (L _ wheres) })) =
do { ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
; p1 <- repLP p
......@@ -1269,7 +1269,7 @@ repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) =
repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ)
repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) =
repClauseTup (L _ (Match { m_pats = ps, m_grhss = GRHSs guards (L _ wheres) })) =
do { ss1 <- mkGenSyms (collectPatsBinders ps)
; addBinds ss1 $ do {
ps1 <- repLPs ps
......@@ -1439,8 +1439,8 @@ rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
rep_bind (L loc (FunBind
{ fun_id = fn,
fun_matches = MG { mg_alts
= L _ [L _ (Match _ [] _
(GRHSs guards (L _ wheres)))] } }))
= L _ [L _ (Match { m_pats = []
, m_grhss = GRHSs guards (L _ wheres) })] } }))
= do { (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; fn' <- lookupLBinder fn
......@@ -1581,7 +1581,8 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
-- (\ p1 .. pn -> exp) by causing an error.
repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)
repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds))))
repLambda (L _ (Match { m_pats = ps
, m_grhss = GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds) } ))
= do { let bndrs = collectPatsBinders ps ;
; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
......
......@@ -1484,7 +1484,7 @@ matchGroupArity (MG { mg_alts = alts })
| otherwise = panic "matchGroupArity"
hsLMatchPats :: LMatch id body -> [LPat id]
hsLMatchPats (L _ (Match _ pats _ _)) = pats
hsLMatchPats (L _ (Match { m_pats = pats })) = pats
-- | Guarded Right-Hand Sides
--
......
......@@ -146,7 +146,8 @@ mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP id))
-> LMatch id (Located (body id))
mkSimpleMatch ctxt pats rhs
= L loc $
Match ctxt pats Nothing (unguardedGRHSs rhs)
Match { m_ctxt = ctxt, m_pats = pats, m_type = Nothing
, m_grhss = unguardedGRHSs rhs }
where
loc = case pats of
[] -> getLoc rhs
......@@ -766,8 +767,10 @@ mkPrefixFunRhs n = FunRhs { mc_fun = n
mkMatch :: HsMatchContext (NameOrRdrName (IdP p)) -> [LPat p] -> LHsExpr p
-> Located (HsLocalBinds p) -> LMatch p (LHsExpr p)
mkMatch ctxt pats expr lbinds
= noLoc (Match ctxt (map paren pats) Nothing
(GRHSs (unguardedRHS noSrcSpan expr) lbinds))
= noLoc (Match { m_ctxt = ctxt
, m_pats = map paren pats
, m_type = Nothing
, m_grhss = GRHSs (unguardedRHS noSrcSpan expr) lbinds })
where
paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
| otherwise = lp
......
......@@ -425,8 +425,8 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
getMonoBind bind binds = (bind, binds)
has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
has_args [] = panic "RdrHsSyn:has_args"
has_args ((L _ (Match _ args _ _)) : _) = not (null args)
has_args [] = panic "RdrHsSyn:has_args"
has_args ((L _ (Match { m_pats = args })) : _) = not (null args)
-- Don't group together FunBinds if they have
-- no arguments. This is necessary now that variable bindings
-- with no arguments are now treated as FunBinds rather
......@@ -1247,9 +1247,9 @@ checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do
ms' <- mapM (locMap $ const convert) ms
return $ mg { mg_alts = L l ms' }
where convert (Match mf pat mty grhss) = do
where convert match@(Match { m_grhss = grhss }) = do
grhss' <- checkCmdGRHSs grhss
return $ Match mf pat mty grhss'
return $ match { m_grhss = grhss'}
checkCmdGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs))
checkCmdGRHSs (GRHSs grhss binds) = do
......
......@@ -577,7 +577,7 @@ methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesMatch (MG { mg_alts = L _ ms })
= plusFVs (map do_one ms)
where
do_one (L _ (Match _ _ _ grhss)) = methodNamesGRHSs grhss
do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss
-------------------------------------------------
-- gaw 2004
......
......@@ -1346,7 +1346,7 @@ checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM ()
checkPrecMatch op (MG { mg_alts = L _ ms })
= mapM_ check ms
where
check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _))
check (L _ (Match { m_pats = L l1 p1 : L l2 p2 :_ }))
= setSrcSpan (combineSrcSpans l1 l2) $
do checkPrec op p1 False
checkPrec op p2 True
......
......@@ -239,7 +239,7 @@ tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty)
tc_cmd env
(HsCmdLam (MG { mg_alts = L l [L mtch_loc
(match@(Match _ pats _maybe_rhs_sig grhss))],
(match@(Match { m_pats = pats, m_grhss = grhss }))],
mg_origin = origin }))
(cmd_stk, res_ty)
= addErrCtxt (pprMatchInCtxt match) $
......@@ -250,7 +250,8 @@ tc_cmd env
tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $
tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)
; let match' = L mtch_loc (Match LambdaExpr pats' Nothing grhss')
; let match' = L mtch_loc (Match { m_ctxt = LambdaExpr, m_pats = pats'
, m_type = Nothing, m_grhss = grhss' })
arg_tys = map hsLPatType pats'
cmd' = HsCmdLam (MG { mg_alts = L l [match'], mg_arg_tys = arg_tys
, mg_res_ty = res_ty, mg_origin = origin })
......
......@@ -565,10 +565,11 @@ zonkMatch :: ZonkEnv
-> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
-> LMatch GhcTcId (Located (body GhcTcId))
-> TcM (LMatch GhcTc (Located (body GhcTc)))
zonkMatch env zBody (L loc (Match mf pats _ grhss))
zonkMatch env zBody (L loc match@(Match { m_pats = pats, m_grhss = grhss }))
= do { (env1, new_pats) <- zonkPats env pats
; new_grhss <- zonkGRHSs env1 zBody grhss
; return (L loc (Match mf new_pats Nothing new_grhss)) }
; return (L loc (match { m_pats = new_pats, m_type = Nothing
, m_grhss = new_grhss })) }
-------------------------------------------------------------------------
zonkGRHSs :: ZonkEnv
......
......@@ -232,11 +232,13 @@ tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body
tcMatch ctxt pat_tys rhs_ty match
= wrapLocM (tc_match ctxt pat_tys rhs_ty) match
where
tc_match ctxt pat_tys rhs_ty match@(Match _ pats maybe_rhs_sig grhss)
tc_match ctxt pat_tys rhs_ty
match@(Match { m_pats = pats, m_type = maybe_rhs_sig, m_grhss = grhss })
= add_match_ctxt match $
do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
; return (Match (mc_what ctxt) pats' Nothing grhss') }
; return (Match { m_ctxt = mc_what ctxt, m_pats = pats'
, m_type = Nothing, m_grhss = grhss' }) }
tc_grhss ctxt Nothing grhss rhs_ty
= tcGRHSs ctxt grhss rhs_ty -- No result signature
......@@ -1135,4 +1137,4 @@ checkArgs fun (MG { mg_alts = L _ (match1:matches) })
bad_matches = [m | m <- matches, args_in_match m /= n_args1]
args_in_match :: LMatch GhcRn body -> Int
args_in_match (L _ (Match _ pats _ _)) = length pats
args_in_match (L _ (Match { m_pats = pats })) = length pats
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment