[TTG: Handling Source Locations] Foundation and Pat

This patch removes the ping-pong style from HsPat (only, for now),
using the plan laid out at
https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/HandlingSourceLocations (solution
A).

- the class `HasSrcSpan`, and its functions (e.g., `cL` and `dL`), are introduced
- some instances of `HasSrcSpan` are introduced
- some constructors `L` are replaced with `cL`
- some patterns `L` are replaced with `dL->L` view pattern
- some type annotation are necessarily updated (e.g., `Pat p` --> `Pat (GhcPass p)`)

Phab diff: D5036
Trac Issues #15495

Updates haddock submodule

1 files changed, 80 insertions, 64 deletions

diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 69f51b8758..450a7d9a86 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -12,6 +12,7 @@ checker.
 {-# LANGUAGE CPP, TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module TcHsSyn (
         -- * Extracting types from HsSyn
@@ -93,12 +94,12 @@ import Control.Arrow ( second )
 -}
 
 hsLPatType :: OutPat GhcTc -> Type
-hsLPatType (L _ pat) = hsPatType pat
+hsLPatType lpat = hsPatType (unLoc lpat)
 
 hsPatType :: Pat GhcTc -> Type
 hsPatType (ParPat _ pat)                = hsLPatType pat
 hsPatType (WildPat ty)                  = ty
-hsPatType (VarPat _ (L _ var))          = idType var
+hsPatType (VarPat _ lvar)               = idType (unLoc lvar)
 hsPatType (BangPat _ pat)               = hsLPatType pat
 hsPatType (LazyPat _ pat)               = hsLPatType pat
 hsPatType (LitPat _ lit)                = hsLitType lit
@@ -108,8 +109,9 @@ hsPatType (ListPat (ListPatTc ty Nothing) _)      = mkListTy ty
 hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty
 hsPatType (TuplePat tys _ bx)           = mkTupleTy bx tys
 hsPatType (SumPat tys _ _ _ )           = mkSumTy tys
-hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys })
-                                        = conLikeResTy con tys
+hsPatType (ConPatOut { pat_con = lcon
+                     , pat_arg_tys = tys })
+                                        = conLikeResTy (unLoc lcon) tys
 hsPatType (SigPat ty _ _)               = ty
 hsPatType (NPat ty _ _ _)               = ty
 hsPatType (NPlusKPat ty _ _ _ _ _)      = ty
@@ -328,7 +330,7 @@ zonkEnvIds (ZonkEnv { ze_id_env = id_env})
   -- immediately by creating a TypeEnv
 
 zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id
-zonkLIdOcc env (L loc id) = L loc (zonkIdOcc env id)
+zonkLIdOcc env = onHasSrcSpan (zonkIdOcc env)
 
 zonkIdOcc :: ZonkEnv -> TcId -> Id
 -- Ids defined in this module should be in the envt;
@@ -491,8 +493,8 @@ zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs)))
 zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do
     new_binds <- mapM (wrapLocM zonk_ip_bind) binds
     let
-        env1 = extendIdZonkEnvRec env [ n
-                                      | L _ (IPBind _ (Right n) _) <- new_binds]
+        env1 = extendIdZonkEnvRec env
+                 [ n | (dL->L _ (IPBind _ (Right n) _)) <- new_binds]
     (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
     return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds))
   where
@@ -540,12 +542,14 @@ zonk_bind env (VarBind { var_ext = x
                          , var_rhs = new_expr
                          , var_inline = inl }) }
 
-zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
+zonk_bind env bind@(FunBind { fun_id = (dL->L loc var)
+                            , fun_matches = ms
                             , fun_co_fn = co_fn })
   = do { new_var <- zonkIdBndr env var
        ; (env1, new_co_fn) <- zonkCoFn env co_fn
        ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
-       ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
+       ; return (bind { fun_id = cL loc new_var
+                      , fun_matches = new_ms
                       , fun_co_fn = new_co_fn }) }
 
 zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
@@ -571,16 +575,16 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
   where
     zonk_val_bind env lbind
       | has_sig
-      , L loc bind@(FunBind { fun_id      = L mloc mono_id
-                            , fun_matches = ms
-                            , fun_co_fn   = co_fn }) <- lbind
+      , (dL->L loc bind@(FunBind { fun_id      = (dL->L mloc mono_id)
+                                 , fun_matches = ms
+                                 , fun_co_fn   = co_fn })) <- lbind
       = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id
                             -- Specifically /not/ zonkIdBndr; we do not
                             -- want to complain about a levity-polymorphic binder
            ; (env', new_co_fn) <- zonkCoFn env co_fn
            ; new_ms            <- zonkMatchGroup env' zonkLExpr ms
-           ; return $ L loc $
-             bind { fun_id      = L mloc new_mono_id
+           ; return $ cL loc $
+             bind { fun_id      = cL mloc new_mono_id
                   , fun_matches = new_ms
                   , fun_co_fn   = new_co_fn } }
       | otherwise
@@ -601,7 +605,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                         , abe_prags = new_prags })
     zonk_export _ (XABExport _) = panic "zonk_bind: XABExport"
 
-zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id
+zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id)
                                       , psb_args = details
                                       , psb_def = lpat
                                       , psb_dir = dir }))
@@ -610,7 +614,7 @@ zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id
        ; let details' = zonkPatSynDetails env1 details
        ; (_env2, dir') <- zonkPatSynDir env1 dir
        ; return $ PatSynBind x $
-                  bind { psb_id = L loc id'
+                  bind { psb_id = cL loc id'
                        , psb_args = details'
                        , psb_def = lpat'
                        , psb_dir = dir' } }
@@ -645,9 +649,9 @@ zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
 zonkLTcSpecPrags env ps
   = mapM zonk_prag ps
   where
-    zonk_prag (L loc (SpecPrag id co_fn inl))
+    zonk_prag (dL->L loc (SpecPrag id co_fn inl))
         = do { (_, co_fn') <- zonkCoFn env co_fn
-             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
+             ; return (cL loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
 
 {-
 ************************************************************************
@@ -661,13 +665,13 @@ zonkMatchGroup :: ZonkEnv
             -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
             -> MatchGroup GhcTcId (Located (body GhcTcId))
             -> TcM (MatchGroup GhcTc (Located (body GhcTc)))
-zonkMatchGroup env zBody (MG { mg_alts = L l ms
+zonkMatchGroup env zBody (MG { mg_alts = (dL->L l ms)
                              , mg_ext = MatchGroupTc arg_tys res_ty
                              , mg_origin = origin })
   = do  { ms' <- mapM (zonkMatch env zBody) ms
         ; arg_tys' <- zonkTcTypesToTypesX env arg_tys
         ; res_ty'  <- zonkTcTypeToTypeX env res_ty
-        ; return (MG { mg_alts = L l ms'
+        ; return (MG { mg_alts = cL l ms'
                      , mg_ext = MatchGroupTc arg_tys' res_ty'
                      , mg_origin = origin }) }
 zonkMatchGroup _ _ (XMatchGroup {}) = panic "zonkMatchGroup"
@@ -676,11 +680,14 @@ 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@(Match { m_pats = pats, m_grhss = grhss }))
+zonkMatch env zBody (dL->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 { m_pats = new_pats, m_grhss = new_grhss })) }
-zonkMatch _ _ (L  _ (XMatch _)) = panic "zonkMatch"
+        ; return (cL loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
+zonkMatch _ _ (dL->L  _ (XMatch _)) = panic "zonkMatch"
+zonkMatch _ _ _ = panic "zonkMatch: Impossible Match"
+                             -- due to #15884
 
 -------------------------------------------------------------------------
 zonkGRHSs :: ZonkEnv
@@ -688,7 +695,7 @@ zonkGRHSs :: ZonkEnv
           -> GRHSs GhcTcId (Located (body GhcTcId))
           -> TcM (GRHSs GhcTc (Located (body GhcTc)))
 
-zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do
+zonkGRHSs env zBody (GRHSs x grhss (dL->L l binds)) = do
     (new_env, new_binds) <- zonkLocalBinds env binds
     let
         zonk_grhs (GRHS xx guarded rhs)
@@ -697,7 +704,7 @@ zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do
                return (GRHS xx new_guarded new_rhs)
         zonk_grhs (XGRHS _) = panic "zonkGRHSs"
     new_grhss <- mapM (wrapLocM zonk_grhs) grhss
-    return (GRHSs x new_grhss (L l new_binds))
+    return (GRHSs x new_grhss (cL l new_binds))
 zonkGRHSs _ _ (XGRHSs _) = panic "zonkGRHSs"
 
 {-
@@ -715,9 +722,9 @@ zonkExpr   :: ZonkEnv -> HsExpr GhcTcId    -> TcM (HsExpr GhcTc)
 zonkLExprs env exprs = mapM (zonkLExpr env) exprs
 zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
 
-zonkExpr env (HsVar x (L l id))
+zonkExpr env (HsVar x (dL->L l id))
   = ASSERT2( isNothing (isDataConId_maybe id), ppr id )
-    return (HsVar x (L l (zonkIdOcc env id)))
+    return (HsVar x (cL l (zonkIdOcc env id)))
 
 zonkExpr _ e@(HsConLikeOut {}) = return e
 
@@ -797,11 +804,14 @@ zonkExpr env (ExplicitTuple x tup_args boxed)
   = do { new_tup_args <- mapM zonk_tup_arg tup_args
        ; return (ExplicitTuple x new_tup_args boxed) }
   where
-    zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e
-                                          ; return (L l (Present x e')) }
-    zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t
-                                        ; return (L l (Missing t')) }
-    zonk_tup_arg (L _ (XTupArg{})) = panic "zonkExpr.XTupArg"
+    zonk_tup_arg (dL->L l (Present x e)) = do { e' <- zonkLExpr env e
+                                              ; return (cL l (Present x e')) }
+    zonk_tup_arg (dL->L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t
+                                            ; return (cL l (Missing t')) }
+    zonk_tup_arg (dL->L _ (XTupArg{})) = panic "zonkExpr.XTupArg"
+    zonk_tup_arg _ = panic "zonk_tup_arg: Impossible Match"
+                             -- due to #15884
+
 
 zonkExpr env (ExplicitSum args alt arity expr)
   = do new_args <- mapM (zonkTcTypeToTypeX env) args
@@ -836,15 +846,15 @@ zonkExpr env (HsMultiIf ty alts)
                ; return $ GRHS x guard' expr' }
         zonk_alt (XGRHS _) = panic "zonkExpr.HsMultiIf"
 
-zonkExpr env (HsLet x (L l binds) expr)
+zonkExpr env (HsLet x (dL->L l binds) expr)
   = do (new_env, new_binds) <- zonkLocalBinds env binds
        new_expr <- zonkLExpr new_env expr
-       return (HsLet x (L l new_binds) new_expr)
+       return (HsLet x (cL l new_binds) new_expr)
 
-zonkExpr env (HsDo ty do_or_lc (L l stmts))
+zonkExpr env (HsDo ty do_or_lc (dL->L l stmts))
   = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
        new_ty <- zonkTcTypeToTypeX env ty
-       return (HsDo new_ty do_or_lc (L l new_stmts))
+       return (HsDo new_ty do_or_lc (cL l new_stmts))
 
 zonkExpr env (ExplicitList ty wit exprs)
   = do (env1, new_wit) <- zonkWit env wit
@@ -1004,15 +1014,15 @@ zonkCmd env (HsCmdIf x eCond ePred cThen cElse)
     zonkWit env Nothing  = return (env, Nothing)
     zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w
 
-zonkCmd env (HsCmdLet x (L l binds) cmd)
+zonkCmd env (HsCmdLet x (dL->L l binds) cmd)
   = do (new_env, new_binds) <- zonkLocalBinds env binds
        new_cmd <- zonkLCmd new_env cmd
-       return (HsCmdLet x (L l new_binds) new_cmd)
+       return (HsCmdLet x (cL l new_binds) new_cmd)
 
-zonkCmd env (HsCmdDo ty (L l stmts))
+zonkCmd env (HsCmdDo ty (dL->L l stmts))
   = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
        new_ty <- zonkTcTypeToTypeX env ty
-       return (HsCmdDo new_ty (L l new_stmts))
+       return (HsCmdDo new_ty (cL l new_stmts))
 
 zonkCmd _ (XCmd{}) = panic "zonkCmd"
 
@@ -1195,9 +1205,9 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
         newBinder' <- zonkIdBndr env newBinder
         return (oldBinder', newBinder')
 
-zonkStmt env _ (LetStmt x (L l binds))
+zonkStmt env _ (LetStmt x (dL->L l binds))
   = do (env1, new_binds) <- zonkLocalBinds env binds
-       return (env1, LetStmt x (L l new_binds))
+       return (env1, LetStmt x (cL l new_binds))
 
 zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op)
   = do  { (env1, new_bind) <- zonkSyntaxExpr env bind_op
@@ -1261,21 +1271,21 @@ zonkRecFields env (HsRecFields flds dd)
   = do  { flds' <- mapM zonk_rbind flds
         ; return (HsRecFields flds' dd) }
   where
-    zonk_rbind (L l fld)
+    zonk_rbind (dL->L l fld)
       = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld)
            ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
-           ; return (L l (fld { hsRecFieldLbl = new_id
+           ; return (cL l (fld { hsRecFieldLbl = new_id
                               , hsRecFieldArg = new_expr })) }
 
 zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId]
                  -> TcM [LHsRecUpdField GhcTcId]
 zonkRecUpdFields env = mapM zonk_rbind
   where
-    zonk_rbind (L l fld)
+    zonk_rbind (dL->L l fld)
       = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld)
            ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
-           ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id
-                              , hsRecFieldArg = new_expr })) }
+           ; return (cL l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id
+                               , hsRecFieldArg = new_expr })) }
 
 -------------------------------------------------------------------------
 mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a
@@ -1309,9 +1319,9 @@ zonk_pat env (WildPat ty)
             (text "In a wildcard pattern")
         ; return (env, WildPat ty') }
 
-zonk_pat env (VarPat x (L l v))
+zonk_pat env (VarPat x (dL->L l v))
   = do  { v' <- zonkIdBndr env v
-        ; return (extendIdZonkEnv1 env v', VarPat x (L l v')) }
+        ; return (extendIdZonkEnv1 env v', VarPat x (cL l v')) }
 
 zonk_pat env (LazyPat x pat)
   = do  { (env', pat') <- zonkPat env pat
@@ -1321,10 +1331,10 @@ zonk_pat env (BangPat x pat)
   = do  { (env', pat') <- zonkPat env pat
         ; return (env',  BangPat x pat') }
 
-zonk_pat env (AsPat x (L loc v) pat)
+zonk_pat env (AsPat x (dL->L loc v) pat)
   = do  { v' <- zonkIdBndr env v
         ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat
-        ; return (env', AsPat x (L loc v') pat') }
+        ; return (env', AsPat x (cL loc v') pat') }
 
 zonk_pat env (ViewPat ty expr pat)
   = do  { expr' <- zonkLExpr env expr
@@ -1354,10 +1364,13 @@ zonk_pat env (SumPat tys pat alt arity )
         ; (env', pat') <- zonkPat env pat
         ; return (env', SumPat tys' pat' alt arity) }
 
-zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars
-                          , pat_dicts = evs, pat_binds = binds
-                          , pat_args = args, pat_wrap = wrapper
-                          , pat_con = L _ con })
+zonk_pat env p@(ConPatOut { pat_arg_tys = tys
+                          , pat_tvs = tyvars
+                          , pat_dicts = evs
+                          , pat_binds = binds
+                          , pat_args = args
+                          , pat_wrap = wrapper
+                          , pat_con = (dL->L _ con) })
   = ASSERT( all isImmutableTyVar tyvars )
     do  { new_tys <- mapM (zonkTcTypeToTypeX env) tys
 
@@ -1393,7 +1406,7 @@ zonk_pat env (SigPat ty pat hs_ty)
         ; (env', pat') <- zonkPat env pat
         ; return (env', SigPat ty' pat' hs_ty) }
 
-zonk_pat env (NPat ty (L l lit) mb_neg eq_expr)
+zonk_pat env (NPat ty (dL->L l lit) mb_neg eq_expr)
   = do  { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr
         ; (env2, mb_neg') <- case mb_neg of
             Nothing -> return (env1, Nothing)
@@ -1401,9 +1414,9 @@ zonk_pat env (NPat ty (L l lit) mb_neg eq_expr)
 
         ; lit' <- zonkOverLit env2 lit
         ; ty' <- zonkTcTypeToTypeX env2 ty
-        ; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') }
+        ; return (env2, NPat ty' (cL l lit') mb_neg' eq_expr') }
 
-zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2)
+zonk_pat env (NPlusKPat ty (dL->L loc n) (dL->L l lit1) lit2 e1 e2)
   = do  { (env1, e1') <- zonkSyntaxExpr env  e1
         ; (env2, e2') <- zonkSyntaxExpr env1 e2
         ; n' <- zonkIdBndr env2 n
@@ -1411,7 +1424,7 @@ zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2)
         ; lit2' <- zonkOverLit env2 lit2
         ; ty' <- zonkTcTypeToTypeX env2 ty
         ; return (extendIdZonkEnv1 env2 n',
-                  NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') }
+                  NPlusKPat ty' (cL loc n') (cL l lit1') lit2' e1' e2') }
 
 zonk_pat env (CoPat x co_fn pat ty)
   = do { (env', co_fn') <- zonkCoFn env co_fn
@@ -1437,7 +1450,8 @@ zonkConStuff env (InfixCon p1 p2)
 
 zonkConStuff env (RecCon (HsRecFields rpats dd))
   = do  { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats)
-        ; let rpats' = zipWith (\(L l rp) p' -> L l (rp { hsRecFieldArg = p' }))
+        ; let rpats' = zipWith (\(dL->L l rp) p' ->
+                                  cL l (rp { hsRecFieldArg = p' }))
                                rpats pats'
         ; return (env', RecCon (HsRecFields rpats' dd)) }
         -- Field selectors have declared types; hence no zonking
@@ -1489,11 +1503,13 @@ zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}
                        , rd_lhs  = new_lhs
                        , rd_rhs  = new_rhs } }
   where
-   zonk_tm_bndr env (L l (RuleBndr x (L loc v)))
+   zonk_tm_bndr env (dL->L l (RuleBndr x (dL->L loc v)))
       = do { (env', v') <- zonk_it env v
-           ; return (env', L l (RuleBndr x (L loc v'))) }
-   zonk_tm_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"
-   zonk_tm_bndr _ (L _ (XRuleBndr {})) = panic "zonk_tm_bndr XRuleBndr"
+           ; return (env', cL l (RuleBndr x (cL loc v'))) }
+   zonk_tm_bndr _ (dL->L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"
+   zonk_tm_bndr _ (dL->L _ (XRuleBndr {})) = panic "zonk_tm_bndr XRuleBndr"
+   zonk_tm_bndr _ _ = panic "zonk_tm_bndr: Impossible Match"
+                            -- due to #15884
 
    zonk_it env v
      | isId v     = do { v' <- zonkIdBndr env v