AST changes to prepare for API annotations, for #9628

Summary:
AST changes to prepare for API annotations

Add locations to parts of the AST so that API annotations can
then be added.

The outline of the whole process is captured here
https://ghc.haskell.org/trac/ghc/wiki/GhcAstAnnotations

This change updates the haddock submodule.

Test Plan: sh ./validate

Reviewers: austin, simonpj, Mikolaj

Reviewed By: simonpj, Mikolaj

Subscribers: thomie, goldfire, carter

Differential Revision: https://phabricator.haskell.org/D426

GHC Trac Issues: #9628

11 files changed, 179 insertions, 104 deletions

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 00f9f628f9..acd469ed15 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -822,7 +822,8 @@ tcSpecPrags :: Id -> [LSig Name]
 tcSpecPrags poly_id prag_sigs
   = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)
        ; unless (null bad_sigs) warn_discarded_sigs
-       ; mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs }
+       ; pss <- mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs
+       ; return $ concatMap (\(L l ps) -> map (L l) ps) pss }
   where
     spec_sigs = filter isSpecLSig prag_sigs
     bad_sigs  = filter is_bad_sig prag_sigs
@@ -833,21 +834,21 @@ tcSpecPrags poly_id prag_sigs
 
 
 --------------
-tcSpec :: TcId -> Sig Name -> TcM TcSpecPrag
-tcSpec poly_id prag@(SpecSig fun_name hs_ty inl)
+tcSpec :: TcId -> Sig Name -> TcM [TcSpecPrag]
+tcSpec poly_id prag@(SpecSig fun_name hs_tys inl)
   -- The Name fun_name in the SpecSig may not be the same as that of the poly_id
   -- Example: SPECIALISE for a class method: the Name in the SpecSig is
   --          for the selector Id, but the poly_id is something like $cop
   -- However we want to use fun_name in the error message, since that is
   -- what the user wrote (Trac #8537)
   = addErrCtxt (spec_ctxt prag) $
-    do  { spec_ty <- tcHsSigType sig_ctxt hs_ty
+    do  { spec_tys <- mapM (tcHsSigType sig_ctxt) hs_tys
         ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
                  (ptext (sLit "SPECIALISE pragma for non-overloaded function")
                   <+> quotes (ppr fun_name))
                   -- Note [SPECIALISE pragmas]
-        ; wrap <- tcSubType sig_ctxt (idType poly_id) spec_ty
-        ; return (SpecPrag poly_id wrap inl) }
+        ; wraps <- mapM (tcSubType origin sig_ctxt (idType poly_id)) spec_tys
+        ; return [ (SpecPrag poly_id wrap inl) | wrap <- wraps ] }
   where
     name      = idName poly_id
     poly_ty   = idType poly_id
@@ -864,10 +865,12 @@ tcImpPrags prags
        ; dflags <- getDynFlags
        ; if (not_specialising dflags) then
             return []
-         else
-            mapAndRecoverM (wrapLocM tcImpSpec)
-            [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
-                               , not (nameIsLocalOrFrom this_mod name) ] }
+         else do
+            { pss <- mapAndRecoverM (wrapLocM tcImpSpec)
+                     [L loc (name,prag)
+                               | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
+                               , not (nameIsLocalOrFrom this_mod name) ]
+            ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } }
   where
     -- Ignore SPECIALISE pragmas for imported things
     -- when we aren't specialising, or when we aren't generating
@@ -880,7 +883,7 @@ tcImpPrags prags
                       HscInterpreted -> True
                       _other         -> False
 
-tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag
+tcImpSpec :: (Name, Sig Name) -> TcM [TcSpecPrag]
 tcImpSpec (name, prag)
  = do { id <- tcLookupId name
       ; unless (isAnyInlinePragma (idInlinePragma id))
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index b5616538eb..dd746a5a99 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -577,8 +577,8 @@ deriveTyDecl (L _ decl@(DataDecl { tcdLName = L _ tc_name
              tys  = mkTyVarTys tvs
 
        ; case preds of
-           Just preds' -> concatMapM (deriveTyData False tvs tc tys) preds'
-           Nothing     -> return [] }
+          Just (L _ preds') -> concatMapM (deriveTyData False tvs tc tys) preds'
+          Nothing           -> return [] }
 
 deriveTyDecl _ = return []
 
@@ -592,8 +592,10 @@ deriveInstDecl (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam
 
 ------------------------------------------------------------------
 deriveFamInst :: DataFamInstDecl Name -> TcM [EarlyDerivSpec]
-deriveFamInst decl@(DataFamInstDecl { dfid_tycon = L _ tc_name, dfid_pats = pats
-                                    , dfid_defn = defn@(HsDataDefn { dd_derivs = Just preds }) })
+deriveFamInst decl@(DataFamInstDecl
+                       { dfid_tycon = L _ tc_name, dfid_pats = pats
+                       , dfid_defn
+                         = defn@(HsDataDefn { dd_derivs = Just (L _ preds) }) })
   = tcAddDataFamInstCtxt decl $
     do { fam_tc <- tcLookupTyCon tc_name
        ; tcFamTyPats (famTyConShape fam_tc) pats (kcDataDefn defn) $
@@ -659,7 +661,8 @@ deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode))
                     ; mkPolyKindedTypeableEqn cls tc }
 
               | isAlgTyCon tc  -- All other classes
-              -> do { spec <- mkEqnHelp overlap_mode tvs cls cls_tys tc tc_args (Just theta)
+              -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
+                                        tvs cls cls_tys tc tc_args (Just theta)
                     ; return [spec] }
 
            _  -> -- Complain about functions, primitive types, etc,
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 1a2deba879..d8db986c8b 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -389,8 +389,8 @@ tcExpr (ExplicitTuple tup_args boxity) res_ty
 
        ; arg_tys <- newFlexiTyVarTys (tyConArity tup_tc) kind
        ; let actual_res_ty
-                 = mkFunTys [ty | (ty, Missing _) <- arg_tys `zip` tup_args]
-                            (mkTyConApp tup_tc arg_tys)
+               = mkFunTys [ty | (ty, L _ (Missing _)) <- arg_tys `zip` tup_args]
+                          (mkTyConApp tup_tc arg_tys)
 
        ; coi <- unifyType actual_res_ty res_ty
 
@@ -640,7 +640,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
         ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
                          | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
                            not (isRecordSelector sel_id),       -- Excludes class ops
-                           let L loc fld_name = hsRecFieldId fld ]
+                           let L loc fld_name = hsRecFieldId (unLoc fld) ]
         ; unless (null bad_guys) (sequence bad_guys >> failM)
 
         -- STEP 1
@@ -968,13 +968,13 @@ tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no)
                                          (tcPolyExprNC arg ty)
 
 ----------------
-tcTupArgs :: [HsTupArg Name] -> [TcSigmaType] -> TcM [HsTupArg TcId]
+tcTupArgs :: [LHsTupArg Name] -> [TcSigmaType] -> TcM [LHsTupArg TcId]
 tcTupArgs args tys
   = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
   where
-    go (Missing {},   arg_ty) = return (Missing arg_ty)
-    go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
-                                   ; return (Present expr') }
+    go (L l (Missing {}),   arg_ty) = return (L l (Missing arg_ty))
+    go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
+                                         ; return (L l (Present expr')) }
 
 ----------------
 unifyOpFunTysWrap :: LHsExpr Name -> Arity -> TcRhoType
@@ -1342,7 +1342,8 @@ tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
         ; return (HsRecFields (catMaybes mb_binds) dd) }
   where
     flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
-    do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs })
+    do_bind (L l fld@(HsRecField { hsRecFieldId = L loc field_lbl
+                                 , hsRecFieldArg = rhs }))
       | Just field_ty <- assocMaybe flds_w_tys field_lbl
       = addErrCtxt (fieldCtxt field_lbl)        $
         do { rhs' <- tcPolyExprNC rhs field_ty
@@ -1353,7 +1354,8 @@ tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
                 --          (so we can find it easily)
                 --      but is a LocalId with the appropriate type of the RHS
                 --          (so the desugarer knows the type of local binder to make)
-           ; return (Just (fld { hsRecFieldId = L loc field_id, hsRecFieldArg = rhs' })) }
+           ; return (Just (L l (fld { hsRecFieldId = L loc field_id
+                                    , hsRecFieldArg = rhs' }))) }
       | otherwise
       = do { addErrTc (badFieldCon (RealDataCon data_con) field_lbl)
            ; return Nothing }
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 9d1da3fc48..73b3b1cf65 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -263,16 +263,16 @@ tcFImport d = pprPanic "tcFImport" (ppr d)
 \begin{code}
 tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport
 
-tcCheckFIType arg_tys res_ty (CImport cconv safety mh l@(CLabel _))
+tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src)
   -- Foreign import label
   = do checkCg checkCOrAsmOrLlvmOrInterp
        -- NB check res_ty not sig_ty!
        --    In case sig_ty is (forall a. ForeignPtr a)
        check (isFFILabelTy (mkFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)
        cconv' <- checkCConv cconv
-       return (CImport cconv' safety mh l)
+       return (CImport (L lc cconv') safety mh l src)
 
-tcCheckFIType arg_tys res_ty (CImport cconv safety mh CWrapper) = do
+tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do
         -- Foreign wrapper (former f.e.d.)
         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid
         -- foreign type.  For legacy reasons ft -> IO (Ptr ft) is accepted, too.
@@ -286,9 +286,10 @@ tcCheckFIType arg_tys res_ty (CImport cconv safety mh CWrapper) = do
                   where
                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
         _ -> addErrTc (illegalForeignTyErr Outputable.empty (ptext (sLit "One argument expected")))
-    return (CImport cconv' safety mh CWrapper)
+    return (CImport (L lc cconv') safety mh CWrapper src)
 
-tcCheckFIType arg_tys res_ty idecl@(CImport cconv safety mh (CFunction target))
+tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
+                                            (CFunction target) src)
   | isDynamicTarget target = do -- Foreign import dynamic
       checkCg checkCOrAsmOrLlvmOrInterp
       cconv' <- checkCConv cconv
@@ -302,7 +303,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport cconv safety mh (CFunction target))
                 (illegalForeignTyErr argument)
           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
           checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
-      return $ CImport cconv' safety mh (CFunction target)
+      return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src
   | cconv == PrimCallConv = do
       dflags <- getDynFlags
       checkTc (xopt Opt_GHCForeignImportPrim dflags)
@@ -328,7 +329,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport cconv safety mh (CFunction target))
            | not (null arg_tys) ->
               addErrTc (text "`value' imports cannot have function types")
           _ -> return ()
-      return $ CImport cconv' safety mh (CFunction target)
+      return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src
 
 
 -- This makes a convenient place to check
@@ -402,13 +403,13 @@ tcFExport d = pprPanic "tcFExport" (ppr d)
 
 \begin{code}
 tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport
-tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
+tcCheckFEType sig_ty (CExport (L l (CExportStatic str cconv)) src) = do
     checkCg checkCOrAsmOrLlvm
     checkTc (isCLabelString str) (badCName str)
     cconv' <- checkCConv cconv
     checkForeignArgs isFFIExternalTy arg_tys
     checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
-    return (CExport (CExportStatic str cconv'))
+    return (CExport (L l (CExportStatic str cconv')) src)
   where
       -- Drop the foralls before inspecting n
       -- the structure of the foreign type.
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index d5dfd8e07c..0265dec38d 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -651,8 +651,10 @@ zonkExpr env (ExplicitTuple tup_args boxed)
   = do { new_tup_args <- mapM zonk_tup_arg tup_args
        ; return (ExplicitTuple new_tup_args boxed) }
   where
-    zonk_tup_arg (Present e) = do { e' <- zonkLExpr env e; return (Present e') }
-    zonk_tup_arg (Missing t) = do { t' <- zonkTcTypeToType env t; return (Missing t') }
+    zonk_tup_arg (L l (Present e)) = do { e' <- zonkLExpr env e
+                                        ; return (L l (Present e')) }
+    zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t
+                                        ; return (L l (Missing t')) }
 
 zonkExpr env (HsCase expr ms)
   = do new_expr <- zonkLExpr env expr
@@ -985,10 +987,11 @@ zonkRecFields env (HsRecFields flds dd)
   = do  { flds' <- mapM zonk_rbind flds
         ; return (HsRecFields flds' dd) }
   where
-    zonk_rbind fld
+    zonk_rbind (L l fld)
       = do { new_id   <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld)
            ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
-           ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) }
+           ; return (L l (fld { hsRecFieldId = new_id
+                              , hsRecFieldArg = new_expr })) }
 
 -------------------------------------------------------------------------
 mapIPNameTc :: (a -> TcM b) -> Either HsIPName a -> TcM (Either HsIPName b)
@@ -1128,8 +1131,9 @@ zonkConStuff env (InfixCon p1 p2)
         ; return (env', InfixCon p1' p2') }
 
 zonkConStuff env (RecCon (HsRecFields rpats dd))
-  = do  { (env', pats') <- zonkPats env (map hsRecFieldArg rpats)
-        ; let rpats' = zipWith (\rp p' -> rp { hsRecFieldArg = p' }) rpats pats'
+  = do  { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats)
+        ; let rpats' = zipWith (\(L l rp) p' -> L l (rp { hsRecFieldArg = p' }))
+                               rpats pats'
         ; return (env', RecCon (HsRecFields rpats' dd)) }
         -- Field selectors have declared types; hence no zonking
 
@@ -1176,18 +1180,18 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
 
        ; unbound_tkvs <- readMutVar unbound_tkv_set
 
-       ; let final_bndrs :: [RuleBndr Var]
-             final_bndrs = map (RuleBndr . noLoc)
+       ; let final_bndrs :: [LRuleBndr Var]
+             final_bndrs = map (noLoc . RuleBndr . noLoc)
                                (varSetElemsKvsFirst unbound_tkvs)
                            ++ new_bndrs
 
        ; return $
          HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs }
   where
-   zonk_bndr env (RuleBndr (L loc v))
+   zonk_bndr env (L l (RuleBndr (L loc v)))
       = do { (env', v') <- zonk_it env v
-           ; return (env', RuleBndr (L loc v')) }
-   zonk_bndr _ (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig"
+           ; return (env', L l (RuleBndr (L loc v'))) }
+   zonk_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_bndr RuleBndrSig"
 
    zonk_it env v
      | isId v     = do { v' <- zonkIdBndr env v
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 215aa2d175..033ee0ef6c 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -543,7 +543,8 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
         ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
                 -- Dfun location is that of instance *header*
 
-        ; ispec <- newClsInst overlap_mode dfun_name tyvars theta clas inst_tys
+        ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name tyvars theta
+                              clas inst_tys
         ; let inst_info = InstInfo { iSpec  = ispec
                                    , iBinds = InstBindings
                                      { ib_binds = binds
@@ -706,7 +707,7 @@ tcDataFamInstDecl mb_clsinfo
 
        ; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) ->
            do { data_cons <- tcConDecls new_or_data rec_rep_tc
-                                       (tvs', orig_res_ty) cons
+                                        (tvs', orig_res_ty) cons
               ; tc_rhs <- case new_or_data of
                      DataType -> return (mkDataTyConRhs data_cons)
                      NewType  -> ASSERT( not (null data_cons) )
@@ -717,7 +718,9 @@ tcDataFamInstDecl mb_clsinfo
                                                (mkTyConApp rep_tc (mkTyVarTys eta_tvs))
                     parent   = FamInstTyCon axiom fam_tc pats'
                     roles    = map (const Nominal) tvs'
-                    rep_tc   = buildAlgTyCon rep_tc_name tvs' roles cType stupid_theta tc_rhs
+                    rep_tc   = buildAlgTyCon rep_tc_name tvs' roles
+                                             (fmap unLoc cType) stupid_theta
+                                             tc_rhs
                                              Recursive
                                              False      -- No promotable to the kind level
                                              gadt_syntax parent
diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index cfa995d9d0..b7f8d2e9db 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -965,11 +965,12 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
   = do  { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside
         ; return (RecCon (HsRecFields rpats' dd), res) }
   where
-    tc_field :: Checker (HsRecField FieldLabel (LPat Name)) (HsRecField TcId (LPat TcId))
-    tc_field (HsRecField field_lbl pat pun) penv thing_inside
+    tc_field :: Checker (LHsRecField FieldLabel (LPat Name))
+                        (LHsRecField TcId (LPat TcId))
+    tc_field (L l (HsRecField field_lbl pat pun)) penv thing_inside
       = do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl
            ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside
-           ; return (HsRecField sel_id pat' pun, res) }
+           ; return (L l (HsRecField sel_id pat' pun), res) }
 
     find_field_ty :: FieldLabel -> TcM (Id, TcType)
     find_field_ty field_lbl
diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs
index 0796472202..23262f3db8 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -509,7 +509,7 @@ tcPatToExpr args = go
            ; return $ ExplicitList ptt (fmap snd reb) exprs }
     go1   (TuplePat pats box _)
       = do { exprs <- mapM go pats
-           ; return (ExplicitTuple (map Present exprs) box)
+           ; return (ExplicitTuple (map (noLoc . Present) exprs) box)
            }
     go1   (LitPat lit)             = return $ HsLit lit
     go1   (NPat n Nothing _)       = return $ HsOverLit n
@@ -558,7 +558,7 @@ tcCollectEx = return . go
     goConDetails (RecCon HsRecFields{ rec_flds = flds })
       = mconcat . map goRecFd $ flds
 
-    goRecFd :: HsRecField Id (LPat Id) -> (TyVarSet, [EvVar])
-    goRecFd HsRecField{ hsRecFieldArg = p } = go p
+    goRecFd :: LHsRecField Id (LPat Id) -> (TyVarSet, [EvVar])
+    goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p
 
 \end{code}
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index d2bfd25898..c2eabbf67d 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -293,9 +293,9 @@ tcRnModuleTcRnM hsc_env hsc_src
           -- If the whole module is warned about or deprecated 
           -- (via mod_deprec) record that in tcg_warns. If we do thereby add
           -- a WarnAll, it will override any subseqent depracations added to tcg_warns
-        let { tcg_env1 = case mod_deprec of 
-                         Just txt -> tcg_env { tcg_warns = WarnAll txt } 
-                         Nothing  -> tcg_env 
+        let { tcg_env1 = case mod_deprec of
+                         Just (L _ txt) -> tcg_env { tcg_warns = WarnAll txt }
+                         Nothing        -> tcg_env
             } ;
 
         setGblEnv tcg_env1 $ do {
@@ -1241,8 +1241,8 @@ tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls
       = concatMap (get_fi_cons . unLoc) fids
 
     get_fi_cons :: DataFamInstDecl Name -> [Name]
-    get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } }) 
-      = map (unLoc . con_name . unLoc) cons
+    get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
+      = map unLoc $ concatMap (con_names . unLoc) cons
 \end{code}
 
 Note [AFamDataCon: not promoting data family constructors]
diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs
index f1d528f098..cd4776f69a 100644
--- a/compiler/typecheck/TcRules.lhs
+++ b/compiler/typecheck/TcRules.lhs
@@ -124,7 +124,7 @@ tcRules decls = mapM (wrapLocM tcRule) decls
 
 tcRule :: RuleDecl Name -> TcM (RuleDecl TcId)
 tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
-  = addErrCtxt (ruleCtxt name)  $
+  = addErrCtxt (ruleCtxt $ unLoc name)  $
     do { traceTc "---- Rule ------" (ppr name)
 
         -- Note [Typechecking rules]
@@ -137,7 +137,8 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
                   ; (rhs', rhs_wanted) <- captureConstraints (tcMonoExpr rhs rule_ty)
                   ; return (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) }
 
-       ; (lhs_evs, other_lhs_wanted) <- simplifyRule name lhs_wanted rhs_wanted
+       ; (lhs_evs, other_lhs_wanted) <- simplifyRule (unLoc name) lhs_wanted
+                                                     rhs_wanted
 
         -- Now figure out what to quantify over
         -- c.f. TcSimplify.simplifyInfer
@@ -156,7 +157,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
        ; gbls  <- tcGetGlobalTyVars   -- Even though top level, there might be top-level
                                       -- monomorphic bindings from the MR; test tc111
        ; qtkvs <- quantifyTyVars gbls forall_tvs
-       ; traceTc "tcRule" (vcat [ doubleQuotes (ftext name)
+       ; traceTc "tcRule" (vcat [ doubleQuotes (ftext $ unLoc name)
                                 , ppr forall_tvs
                                 , ppr qtkvs
                                 , ppr rule_ty
@@ -173,7 +174,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
                                   , ic_wanted = rhs_wanted
                                   , ic_insol  = insolubleWC rhs_wanted
                                   , ic_binds  = rhs_binds_var
-                                  , ic_info   = RuleSkol name
+                                  , ic_info   = RuleSkol (unLoc name)
                                   , ic_env    = lcl_env }
 
            -- For the LHS constraints we must solve the remaining constraints
@@ -187,22 +188,22 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
                                   , ic_wanted = other_lhs_wanted
                                   , ic_insol  = insolubleWC other_lhs_wanted
                                   , ic_binds  = lhs_binds_var
-                                  , ic_info   = RuleSkol name
+                                  , ic_info   = RuleSkol (unLoc name)
                                   , ic_env    = lcl_env }
 
        ; return (HsRule name act
-                    (map (RuleBndr . noLoc) (qtkvs ++ tpl_ids))
+                    (map (noLoc . RuleBndr . noLoc) (qtkvs ++ tpl_ids))
                     (mkHsDictLet (TcEvBinds lhs_binds_var) lhs') fv_lhs
                     (mkHsDictLet (TcEvBinds rhs_binds_var) rhs') fv_rhs) }
 
-tcRuleBndrs :: [RuleBndr Name] -> TcM [Var]
+tcRuleBndrs :: [LRuleBndr Name] -> TcM [Var]
 tcRuleBndrs []
   = return []
-tcRuleBndrs (RuleBndr (L _ name) : rule_bndrs)
+tcRuleBndrs (L _ (RuleBndr (L _ name)) : rule_bndrs)
   = do  { ty <- newFlexiTyVarTy openTypeKind
         ; vars <- tcRuleBndrs rule_bndrs
         ; return (mkLocalId name ty : vars) }
-tcRuleBndrs (RuleBndrSig (L _ name) rn_ty : rule_bndrs)
+tcRuleBndrs (L _ (RuleBndrSig (L _ name) rn_ty) : rule_bndrs)
 --  e.g         x :: a->a
 --  The tyvar 'a' is brought into scope first, just as if you'd written
 --              a::*, x :: a->a
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index f5f19bd86d..1cffcf04a1 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -378,18 +378,20 @@ getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs =
        ; return (main_pr : inner_prs) }
 
 getInitialKind decl@(DataDecl { tcdLName = L _ name
-                                , tcdTyVars = ktvs
-                                , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
-                                                           , dd_cons = cons } })
-  = do { (decl_kind, _) <-
+                              , tcdTyVars = ktvs
+                              , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
+                                                         , dd_cons = cons' } })
+  = let cons = cons' -- AZ list monad coming
+    in
+     do { (decl_kind, _) <-
            kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $
            do { res_k <- case m_sig of
                            Just ksig -> tcLHsKind ksig
                            Nothing   -> return liftedTypeKind
               ; return (res_k, ()) }
        ; let main_pr = (name, AThing decl_kind)
-             inner_prs = [ (unLoc (con_name con), APromotionErr RecDataConPE)
-                         | L _ con <- cons ]
+             inner_prs = [ (unLoc con, APromotionErr RecDataConPE)
+                         | L _ con' <- cons, con <- con_names con' ]
        ; return (main_pr : inner_prs) }
 
 getInitialKind (FamDecl { tcdFam = decl })
@@ -501,10 +503,10 @@ kcTyClDecl (FamDecl {})    = return ()
 
 -------------------
 kcConDecl :: ConDecl Name -> TcM ()
-kcConDecl (ConDecl { con_name = name, con_qvars = ex_tvs
+kcConDecl (ConDecl { con_names = names, con_qvars = ex_tvs
                    , con_cxt = ex_ctxt, con_details = details
                    , con_res = res })
-  = addErrCtxt (dataConCtxt name) $
+  = addErrCtxt (dataConCtxtName names) $
          -- the 'False' says that the existentials don't have a CUSK, as the
          -- concept doesn't really apply here. We just need to bring the variables
          -- into scope!
@@ -760,8 +762,9 @@ tcDataDefn :: RecTyInfo -> Name
 tcDataDefn rec_info tc_name tvs kind
          (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
                      , dd_ctxt = ctxt, dd_kindSig = mb_ksig
-                     , dd_cons = cons })
-  = do { extra_tvs <- tcDataKindSig kind
+                     , dd_cons = cons' })
+ = let cons = cons' -- AZ List monad coming
+   in do { extra_tvs <- tcDataKindSig kind
        ; let final_tvs  = tvs ++ extra_tvs
              roles      = rti_roles rec_info tc_name
        ; stupid_tc_theta <- tcHsContext ctxt
@@ -789,7 +792,8 @@ tcDataDefn rec_info tc_name tvs kind
                    DataType -> return (mkDataTyConRhs data_cons)
                    NewType  -> ASSERT( not (null data_cons) )
                                     mkNewTyConRhs tc_name tycon (head data_cons)
-             ; return (buildAlgTyCon tc_name final_tvs roles cType stupid_theta tc_rhs
+             ; return (buildAlgTyCon tc_name final_tvs roles (fmap unLoc cType)
+                                     stupid_theta tc_rhs
                                      (rti_is_rec rec_info tc_name)
                                      (rti_promotable rec_info)
                                      gadt_syntax NoParentTyCon) }
@@ -1144,29 +1148,31 @@ consUseGadtSyntax _                                             = False
 tcConDecls :: NewOrData -> TyCon -> ([TyVar], Type)
            -> [LConDecl Name] -> TcM [DataCon]
 tcConDecls new_or_data rep_tycon (tmpl_tvs, res_tmpl) cons
-  = mapM (addLocM  $ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl) cons
+  = concatMapM (addLocM  $ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl)
+               cons
 
 tcConDecl :: NewOrData
           -> TyCon             -- Representation tycon
           -> [TyVar] -> Type   -- Return type template (with its template tyvars)
                                --    (tvs, T tys), where T is the family TyCon
           -> ConDecl Name
-          -> TcM DataCon
+          -> TcM [DataCon]
 
 tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl        -- Data types
-          (ConDecl { con_name = name
+          (ConDecl { con_names = names
                    , con_qvars = hs_tvs, con_cxt = hs_ctxt
                    , con_details = hs_details, con_res = hs_res_ty })
-  = addErrCtxt (dataConCtxt name) $
-    do { traceTc "tcConDecl 1" (ppr name)
-       ; (ctxt, arg_tys, res_ty, is_infix, field_lbls, stricts)
+  = addErrCtxt (dataConCtxtName names) $
+    do { traceTc "tcConDecl 1" (ppr names)
+       ; (ctxt, arg_tys, res_ty, field_lbls, stricts)
            <- tcHsTyVarBndrs hs_tvs $ \ _ ->
               do { ctxt    <- tcHsContext hs_ctxt
                  ; details <- tcConArgs new_or_data hs_details
                  ; res_ty  <- tcConRes hs_res_ty
-                 ; let (is_infix, field_lbls, btys) = details
-                       (arg_tys, stricts)           = unzip btys
-                 ; return (ctxt, arg_tys, res_ty, is_infix, field_lbls, stricts) }
+                 ; let (field_lbls, btys) = details
+                       (arg_tys, stricts) = unzip btys
+                 ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)
+                 }
 
              -- Generalise the kind variables (returning quantified TcKindVars)
              -- and quantify the type variables (substituting their kinds)
@@ -1189,29 +1195,60 @@ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl        -- Data types
        ; let (univ_tvs, ex_tvs, eq_preds, res_ty') = rejigConRes tmpl_tvs res_tmpl qtkvs res_ty
 
        ; fam_envs <- tcGetFamInstEnvs
-       ; buildDataCon fam_envs (unLoc name) is_infix
-                      stricts field_lbls
-                      univ_tvs ex_tvs eq_preds ctxt arg_tys
-                      res_ty' rep_tycon
-                -- NB:  we put data_tc, the type constructor gotten from the
-                --      constructor type signature into the data constructor;
-                --      that way checkValidDataCon can complain if it's wrong.
+       ; let
+           buildOneDataCon (L _ name) = do
+             { is_infix <- tcConIsInfix name hs_details res_ty
+             ; buildDataCon fam_envs name is_infix
+                            stricts field_lbls
+                            univ_tvs ex_tvs eq_preds ctxt arg_tys
+                            res_ty' rep_tycon
+                  -- NB:  we put data_tc, the type constructor gotten from the
+                  --      constructor type signature into the data constructor;
+                  --      that way checkValidDataCon can complain if it's wrong.
+             }
+       ; mapM buildOneDataCon names
        }
 
-tcConArgs :: NewOrData -> HsConDeclDetails Name -> TcM (Bool, [Name], [(TcType, HsBang)])
+
+tcConIsInfix :: Name
+             -> HsConDetails (LHsType Name) [LConDeclField Name]
+             -> ResType Type
+             -> TcM Bool
+tcConIsInfix _   details ResTyH98
+  = case details of
+           InfixCon {}  -> return True
+           _            -> return False
+tcConIsInfix con details (ResTyGADT _)
+  = case details of
+           InfixCon {}  -> return True
+           RecCon {}    -> return False
+           PrefixCon arg_tys           -- See Note [Infix GADT cons]
+               | isSymOcc (getOccName con)
+               , [_ty1,_ty2] <- arg_tys
+                  -> do { fix_env <- getFixityEnv
+                        ; return (con `elemNameEnv` fix_env) }
+               | otherwise -> return False
+
+
+
+tcConArgs :: NewOrData -> HsConDeclDetails Name
+          -> TcM ([Name], [(TcType, HsBang)])
 tcConArgs new_or_data (PrefixCon btys)
   = do { btys' <- mapM (tcConArg new_or_data) btys
-       ; return (False, [], btys') }
+       ; return ([], btys') }
 tcConArgs new_or_data (InfixCon bty1 bty2)
   = do { bty1' <- tcConArg new_or_data bty1
        ; bty2' <- tcConArg new_or_data bty2
-       ; return (True, [], [bty1', bty2']) }
+       ; return ([], [bty1', bty2']) }
 tcConArgs new_or_data (RecCon fields)
   = do { btys' <- mapM (tcConArg new_or_data) btys
-       ; return (False, field_names, btys') }
+       ; return (field_names, btys') }
   where
-    field_names = map (unLoc . cd_fld_name) fields
-    btys        = map cd_fld_type fields
+    -- We need a one-to-one mapping from field_names to btys
+    combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) fields
+    explode (ns,ty) = zip (map unLoc ns) (repeat ty)
+    exploded = concatMap explode combined
+    (field_names,btys) = unzip exploded
 
 tcConArg :: NewOrData -> LHsType Name -> TcM (TcType, HsBang)
 tcConArg new_or_data bty
@@ -1227,6 +1264,20 @@ tcConRes (ResTyGADT res_ty) = do { res_ty' <- tcHsLiftedType res_ty
 
 \end{code}
 
+Note [Infix GADT constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not currently have syntax to declare an infix constructor in GADT syntax,
+but it makes a (small) difference to the Show instance.  So as a slightly
+ad-hoc solution, we regard a GADT data constructor as infix if
+  a) it is an operator symbol
+  b) it has two arguments
+  c) there is a fixity declaration for it
+For example:
+   infix 6 (:--:)
+   data T a where
+     (:--:) :: t1 -> t2 -> T Int
+
+
 Note [Checking GADT return types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 There is a delicacy around checking the return types of a datacon. The
@@ -1905,9 +1956,9 @@ mkRecSelBind (tycon, sel_name)
                                  (L loc (HsVar field_var))
     mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
     rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
-    rec_field  = HsRecField { hsRecFieldId = sel_lname
-                            , hsRecFieldArg = L loc (VarPat field_var)
-                            , hsRecPun = False }
+    rec_field  = noLoc (HsRecField { hsRecFieldId = sel_lname
+                                   , hsRecFieldArg = L loc (VarPat field_var)
+                                   , hsRecPun = False })
     sel_lname = L loc sel_name
     field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
 
@@ -2073,6 +2124,12 @@ fieldTypeMisMatch field_name con1 con2
   = sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
          ptext (sLit "give different types for field"), quotes (ppr field_name)]
 
+dataConCtxtName :: [Located Name] -> SDoc
+dataConCtxtName [con]
+   = ptext (sLit "In the definition of data constructor") <+> quotes (ppr con)
+dataConCtxtName con
+   = ptext (sLit "In the definition of data constructors") <+> interpp'SP con
+
 dataConCtxt :: Outputable a => a -> SDoc
 dataConCtxt con = ptext (sLit "In the definition of data constructor") <+> quotes (ppr con)