Use field names for all uses of datacon Match
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 31 Jul 2017 12:27:54 +0000 (13:27 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 31 Jul 2017 12:36:49 +0000 (13:36 +0100)
This is refactoring only... elimiante all positional uses
of the data constructor Match in favour of field names.

No change in behaviour.

12 files changed:
compiler/deSugar/Check.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsMeta.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsUtils.hs
compiler/parser/RdrHsSyn.hs
compiler/rename/RnExpr.hs
compiler/rename/RnTypes.hs
compiler/typecheck/TcArrows.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcMatches.hs

index 365524a..2b1995c 100644 (file)
@@ -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')
index d44c203..1889203 100644 (file)
@@ -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)
 
index fb16d53..ec0f419 100644 (file)
@@ -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
index cc2ff13..b78e366 100644 (file)
@@ -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 (
index ae95b9c..1bde776 100644 (file)
@@ -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
 --
index f409c2a..97ab76f 100644 (file)
@@ -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
index 408da04..ecfae76 100644 (file)
@@ -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
index c5c75ab..0e2022d 100644 (file)
@@ -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
index a0ceb32..5f52d2f 100644 (file)
@@ -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
index d747949..d56a8d8 100644 (file)
@@ -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 })
index c5de0dc..b6d40df 100644 (file)
@@ -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
index d4fdc11..142e6b5 100644 (file)
@@ -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