AST changes to prepare for API annotations, for #9628
authorAlan Zimmerman <alan.zimm@gmail.com>
Fri, 21 Nov 2014 17:20:06 +0000 (11:20 -0600)
committerAustin Seipp <austin@well-typed.com>
Fri, 21 Nov 2014 17:26:10 +0000 (11:26 -0600)
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

47 files changed:
compiler/basicTypes/BasicTypes.lhs
compiler/deSugar/Check.lhs
compiler/deSugar/Coverage.lhs
compiler/deSugar/Desugar.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsForeign.lhs
compiler/deSugar/DsMeta.hs
compiler/deSugar/Match.lhs
compiler/deSugar/MatchCon.lhs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsExpr.lhs
compiler/hsSyn/HsImpExp.lhs
compiler/hsSyn/HsPat.lhs
compiler/hsSyn/HsSyn.lhs
compiler/hsSyn/HsTypes.lhs
compiler/hsSyn/HsUtils.lhs
compiler/main/HeaderInfo.hs
compiler/main/HscMain.hs
compiler/main/HscStats.hs
compiler/parser/HaddockUtils.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnBinds.lhs
compiler/rename/RnEnv.lhs
compiler/rename/RnExpr.lhs
compiler/rename/RnNames.lhs
compiler/rename/RnPat.lhs
compiler/rename/RnSource.lhs
compiler/rename/RnTypes.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcForeign.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcPatSyn.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRules.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/utils/Binary.hs
ghc/InteractiveUI.hs
testsuite/tests/haddock/haddock_examples/haddock.Test.stderr
utils/ghctags/Main.hs
utils/haddock

index 252d0fe..d8c6519 100644 (file)
@@ -89,6 +89,7 @@ module BasicTypes(
 
 import FastString
 import Outputable
+import SrcLoc ( Located,unLoc )
 
 import Data.Data hiding (Fixity)
 import Data.Function (on)
@@ -263,14 +264,14 @@ initialVersion = 1
 
 \begin{code}
 -- reason/explanation from a WARNING or DEPRECATED pragma
-data WarningTxt = WarningTxt [FastString]
-                | DeprecatedTxt [FastString]
+data WarningTxt = WarningTxt [Located FastString]
+                | DeprecatedTxt [Located FastString]
     deriving (Eq, Data, Typeable)
 
 instance Outputable WarningTxt where
-    ppr (WarningTxt    ws) = doubleQuotes (vcat (map ftext ws))
+    ppr (WarningTxt    ws) = doubleQuotes (vcat (map (ftext . unLoc) ws))
     ppr (DeprecatedTxt ds) = text "Deprecated:" <+>
-                             doubleQuotes (vcat (map ftext ds))
+                             doubleQuotes (vcat (map (ftext . unLoc) ds))
 \end{code}
 
 %************************************************************************
index 3e6912f..52d81ed 100644 (file)
@@ -166,8 +166,9 @@ untidy_con :: HsConPatDetails Name -> HsConPatDetails Name
 untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats)
 untidy_con (InfixCon p1 p2) = InfixCon  (untidy_pars p1) (untidy_pars p2)
 untidy_con (RecCon (HsRecFields flds dd))
-  = RecCon (HsRecFields [ fld { hsRecFieldArg = untidy_pars (hsRecFieldArg fld) }
-                        | fld <- flds ] dd)
+  = RecCon (HsRecFields [ L l (fld { hsRecFieldArg
+                                            = untidy_pars (hsRecFieldArg fld) })
+                        | L l fld <- flds ] dd)
 
 pars :: NeedPars -> WarningPat -> Pat Name
 pars True p = ParPat p
@@ -765,7 +766,8 @@ tidy_con con (RecCon (HsRecFields fs _))
     field_pats = case con of
         RealDataCon dc -> map (\ f -> (f, nlWildPatId)) (dataConFieldLabels dc)
         PatSynCon{}    -> panic "Check.tidy_con: pattern synonym with record syntax"
-    all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc)
+    all_pats = foldr (\(L _ (HsRecField id p _)) acc
+                                         -> insertNm (getName (unLoc id)) p acc)
                      field_pats fs
 
     insertNm nm p [] = [(nm,p)]
index 5e7289f..ae6cef2 100644 (file)
@@ -593,9 +593,10 @@ addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
 -- Others dhould never happen in expression content.
 addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
 
-addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
-addTickTupArg (Present e)  = do { e' <- addTickLHsExpr e; return (Present e') }
-addTickTupArg (Missing ty) = return (Missing ty)
+addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id)
+addTickTupArg (L l (Present e))  = do { e' <- addTickLHsExpr e
+                                      ; return (L l (Present e')) }
+addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
 
 addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))
 addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do
@@ -891,9 +892,9 @@ addTickHsRecordBinds (HsRecFields fields dd)
   = do  { fields' <- mapM process fields
         ; return (HsRecFields fields' dd) }
   where
-    process (HsRecField ids expr doc)
+    process (L l (HsRecField ids expr doc))
         = do { expr' <- addTickLHsExpr expr
-             ; return (HsRecField ids expr' doc) }
+             ; return (L l (HsRecField ids expr' doc)) }
 
 addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
 addTickArithSeqInfo (From e1) =
index e2170e7..500c411 100644 (file)
@@ -349,7 +349,7 @@ Reason
 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
   = putSrcSpanDs loc $
-    do  { let bndrs' = [var | RuleBndr (L _ var) <- vars]
+    do  { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]
 
         ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
                   unsetWOptM Opt_WarnIdentities $
@@ -373,7 +373,8 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
               fn_name   = idName fn_id
               final_rhs = simpleOptExpr rhs''    -- De-crap it
               rule      = mkRule False {- Not auto -} is_local
-                                 name act fn_name final_bndrs args final_rhs
+                                 (unLoc name) act fn_name final_bndrs args
+                                 final_rhs
 
               inline_shadows_rule   -- Function can be inlined before rule fires
                 | wopt Opt_WarnInlineRuleShadowing dflags
@@ -390,7 +391,8 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
                 | otherwise = False
 
         ; when inline_shadows_rule $
-          warnDs (vcat [ hang (ptext (sLit "Rule") <+> doubleQuotes (ftext name)
+          warnDs (vcat [ hang (ptext (sLit "Rule")
+                               <+> doubleQuotes (ftext $ unLoc name)
                                <+> ptext (sLit "may never fire"))
                             2 (ptext (sLit "because") <+> quotes (ppr fn_id)
                                <+> ptext (sLit "might inline first"))
index 6844f48..03544bb 100644 (file)
@@ -278,12 +278,12 @@ dsExpr (SectionR op expr) = do
             Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
 
 dsExpr (ExplicitTuple tup_args boxity)
-  = do { let go (lam_vars, args) (Missing ty)
+  = do { let go (lam_vars, args) (L _ (Missing ty))
                     -- For every missing expression, we need
                     -- another lambda in the desugaring.
                = do { lam_var <- newSysLocalDs ty
                     ; return (lam_var : lam_vars, Var lam_var : args) }
-             go (lam_vars, args) (Present expr)
+             go (lam_vars, args) (L _ (Present expr))
                     -- Expressions that are present don't generate
                     -- lambdas, just arguments.
                = do { core_expr <- dsLExpr expr
@@ -495,15 +495,15 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
         ; return (add_field_binds field_binds' $
                   bindNonRec discrim_var record_expr' matching_code) }
   where
-    ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
+    ds_field :: LHsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
       -- Clone the Id in the HsRecField, because its Name is that
       -- of the record selector, and we must not make that a lcoal binder
       -- else we shadow other uses of the record selector
       -- Hence 'lcl_id'.  Cf Trac #2735
-    ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
-                            ; let fld_id = unLoc (hsRecFieldId rec_field)
-                            ; lcl_id <- newSysLocalDs (idType fld_id)
-                            ; return (idName fld_id, lcl_id, rhs) }
+    ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
+                                  ; let fld_id = unLoc (hsRecFieldId rec_field)
+                                  ; lcl_id <- newSysLocalDs (idType fld_id)
+                                  ; return (idName fld_id, lcl_id, rhs) }
 
     add_field_binds [] expr = expr
     add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
@@ -613,9 +613,9 @@ dsExpr (HsType        {})  = panic "dsExpr:HsType"
 dsExpr (HsDo          {})  = panic "dsExpr:HsDo"
 
 
-findField :: [HsRecField Id arg] -> Name -> [arg]
+findField :: [LHsRecField Id arg] -> Name -> [arg]
 findField rbinds lbl 
-  = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds 
+  = [rhs | L _ (HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs }) <- rbinds
          , lbl == idName (unLoc id) ]
 \end{code}
 
index 311069e..660cbf0 100644 (file)
@@ -107,7 +107,8 @@ dsForeigns' fos = do
       traceIf (text "fi end" <+> ppr id)
       return (h, c, [], bs)
 
-   do_decl (ForeignExport (L _ id) _ co (CExport (CExportStatic ext_nm cconv))) = do
+   do_decl (ForeignExport (L _ id) _ co
+                          (CExport (L _ (CExportStatic ext_nm cconv)) _)) = do
       (h, c, _, _) <- dsFExport id co ext_nm cconv False
       return (h, c, [id], [])
 \end{code}
@@ -142,8 +143,8 @@ dsFImport :: Id
           -> Coercion
           -> ForeignImport
           -> DsM ([Binding], SDoc, SDoc)
-dsFImport id co (CImport cconv safety mHeader spec) = do
-    (ids, h, c) <- dsCImport id co spec cconv safety mHeader
+dsFImport id co (CImport cconv safety mHeader spec _) = do
+    (ids, h, c) <- dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader
     return (ids, h, c)
 
 dsCImport :: Id
index afdfae3..5bb933a 100644 (file)
@@ -63,6 +63,7 @@ import DynFlags
 import FastString
 import ForeignCall
 import Util
+import MonadUtils
 
 import Data.Maybe
 import Control.Monad
@@ -154,7 +155,8 @@ repTopDs group@(HsGroup { hs_valds   = valds
 
                         -- more needed
                      ;  return (de_loc $ sort_by_loc $
-                                val_ds ++ catMaybes tycl_ds ++ role_ds ++ fix_ds
+                                val_ds ++ catMaybes tycl_ds ++ role_ds
+                                       ++ (concat fix_ds)
                                        ++ inst_ds ++ rule_ds ++ for_ds
                                        ++ ann_ds ++ deriv_ds) }) ;
 
@@ -293,8 +295,15 @@ repDataDefn tc bndrs opt_tys tv_names
        ; derivs1  <- repDerivs mb_derivs
        ; case new_or_data of
            NewType  -> do { con1 <- repC tv_names (head cons)
-                          ; repNewtype cxt1 tc bndrs opt_tys con1 derivs1 }
-           DataType -> do { cons1 <- repList conQTyConName (repC tv_names) cons
+                          ; case con1 of
+                             [c] -> repNewtype cxt1 tc bndrs opt_tys c derivs1
+                             _cs -> failWithDs (ptext
+                                     (sLit "Multiple constructors for newtype:")
+                                      <+> pprQuotedList
+                                                (con_names $ unLoc $ head cons))
+                          }
+           DataType -> do { consL <- concatMapM (repC tv_names) cons
+                          ; cons1 <- coreList conQTyConName consL
                           ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
 
 repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
@@ -464,7 +473,7 @@ repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
             ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
 
 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
-repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
+repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _)))
  = do MkC name' <- lookupLOcc name
       MkC typ' <- repLTy typ
       MkC cc' <- repCCallConv cc
@@ -499,16 +508,18 @@ repSafety PlayRisky = rep2 unsafeName []
 repSafety PlayInterruptible = rep2 interruptibleName []
 repSafety PlaySafe = rep2 safeName []
 
-repFixD :: LFixitySig Name -> DsM (SrcSpan, Core TH.DecQ)
-repFixD (L loc (FixitySig name (Fixity prec dir)))
-  = do { MkC name' <- lookupLOcc name
-       ; MkC prec' <- coreIntLit prec
+repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)]
+repFixD (L loc (FixitySig names (Fixity prec dir)))
+  = do { MkC prec' <- coreIntLit prec
        ; let rep_fn = case dir of
                         InfixL -> infixLDName
                         InfixR -> infixRDName
                         InfixN -> infixNDName
-       ; dec <- rep2 rep_fn [prec', name']
-       ; return (loc, dec) }
+       ; let do_one name
+              = do { MkC name' <- lookupLOcc name
+                   ; dec <- rep2 rep_fn [prec', name']
+                   ; return (loc,dec) }
+       ; mapM do_one names }
 
 repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
 repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
@@ -516,7 +527,7 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
        ; ss <- mkGenSyms bndr_names
        ; rule1 <- addBinds ss $
                   do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
-                     ; n'   <- coreStringLit $ unpackFS n
+                     ; n'   <- coreStringLit $ unpackFS $ unLoc n
                      ; act' <- repPhases act
                      ; lhs' <- repLE lhs
                      ; rhs' <- repLE rhs
@@ -524,16 +535,16 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
        ; rule2 <- wrapGenSyms ss rule1
        ; return (loc, rule2) }
 
-ruleBndrNames :: RuleBndr Name -> [Name]
-ruleBndrNames (RuleBndr n)      = [unLoc n]
-ruleBndrNames (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs }))
+ruleBndrNames :: LRuleBndr Name -> [Name]
+ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]
+ruleBndrNames (L _ (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs })))
   = unLoc n : kvs ++ tvs
 
-repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ)
-repRuleBndr (RuleBndr n)
+repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
+repRuleBndr (L _ (RuleBndr n))
   = do { MkC n' <- lookupLBinder n
        ; rep2 ruleVarName [n'] }
-repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty }))
+repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty })))
   = do { MkC n'  <- lookupLBinder n
        ; MkC ty' <- repLTy ty
        ; rep2 typedRuleVarName [n', ty'] }
@@ -562,14 +573,14 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
 --                      Constructors
 -------------------------------------------------------
 
-repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
-repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ []
+repC :: [Name] -> LConDecl Name -> DsM [Core TH.ConQ]
+repC _ (L _ (ConDecl { con_names = con, con_qvars = con_tvs, con_cxt = L _ []
                      , con_details = details, con_res = ResTyH98 }))
   | null (hsQTvBndrs con_tvs)
-  = do { con1 <- lookupLOcc con         -- See Note [Binders and occurrences]
-       ; repConstr con1 details  }
+  = do { con1 <- mapM lookupLOcc con       -- See Note [Binders and occurrences]
+       ; mapM (\c -> repConstr c details) con1  }
 
-repC tvs (L _ (ConDecl { con_name = con
+repC tvs (L _ (ConDecl { con_names = cons
                        , con_qvars = con_tvs, con_cxt = L _ ctxt
                        , con_details = details
                        , con_res = res_ty }))
@@ -578,12 +589,14 @@ repC tvs (L _ (ConDecl { con_name = con
                              , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) }
 
        ; binds <- mapM dupBinder con_tv_subst
-       ; dsExtendMetaEnv (mkNameEnv binds) $     -- Binds some of the con_tvs
+       ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
          addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
-    do { con1      <- lookupLOcc con    -- See Note [Binders and occurrences]
-       ; c'        <- repConstr con1 details
+    do { cons1     <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
+       ; c'        <- mapM (\c -> repConstr c details) cons1
        ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
-       ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } }
+       ; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) }
+    ; return [b]
+    }
 
 in_subst :: [(Name,Name)] -> Name -> Bool
 in_subst []          _ = False
@@ -646,9 +659,9 @@ repBangTy ty= do
 --                      Deriving clause
 -------------------------------------------------------
 
-repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
+repDerivs :: Maybe (Located [LHsType Name]) -> DsM (Core [TH.Name])
 repDerivs Nothing = coreList nameTyConName []
-repDerivs (Just ctxt)
+repDerivs (Just (L _ ctxt))
   = repList nameTyConName rep_deriv ctxt
   where
     rep_deriv :: LHsType Name -> DsM (Core TH.Name)
@@ -680,7 +693,8 @@ rep_sig (L loc (GenericSig nms ty))   = mapM (rep_ty_sig defaultSigDName loc ty)
 rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)
 rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level
 rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
-rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
+rep_sig (L loc (SpecSig nm tys ispec))
+   = concatMapM (\t -> rep_specialise nm t ispec loc) tys
 rep_sig (L loc (SpecInstSig ty))      = rep_specialiseInst ty loc
 rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
 
@@ -1046,8 +1060,9 @@ repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
 repE e@(ExplicitTuple es boxed)
   | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
-  | isBoxed boxed              = do { xs <- repLEs [e | Present e <- es]; repTup xs }
-  | otherwise                  = do { xs <- repLEs [e | Present e <- es]; repUnboxedTup xs }
+  | isBoxed boxed  = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs }
+  | otherwise      = do { xs <- repLEs [e | L _ (Present e) <- es]
+                        ; repUnboxedTup xs }
 
 repE (RecordCon c _ flds)
  = do { x <- lookupLOcc c;
@@ -1133,9 +1148,9 @@ repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
 repFields (HsRecFields { rec_flds = flds })
   = repList fieldExpQTyConName rep_fld flds
   where
-    rep_fld fld = do { fn <- lookupLOcc (hsRecFieldId fld)
-                     ; e  <- repLE (hsRecFieldArg fld)
-                     ; repFieldExp fn e }
+    rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldId fld)
+                           ; e  <- repLE (hsRecFieldArg fld)
+                           ; repFieldExp fn e }
 
 
 -----------------------------------------------------------------------------
@@ -1360,9 +1375,9 @@ repP (ConPatIn dc details)
                                 repPinfix p1' con_str p2' }
    }
  where
-   rep_fld fld = do { MkC v <- lookupLOcc (hsRecFieldId fld)
-                    ; MkC p <- repLP (hsRecFieldArg fld)
-                    ; rep2 fieldPatName [v,p] }
+   rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldId fld)
+                          ; MkC p <- repLP (hsRecFieldArg fld)
+                          ; rep2 fieldPatName [v,p] }
 
 repP (NPat l Nothing _)  = do { a <- repOverloadedLiteral l; repPlit a }
 repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
@@ -1831,13 +1846,16 @@ repConstr :: Core TH.Name -> HsConDeclDetails Name
 repConstr con (PrefixCon ps)
     = do arg_tys  <- repList strictTypeQTyConName repBangTy ps
          rep2 normalCName [unC con, unC arg_tys]
+
 repConstr con (RecCon ips)
-    = do { arg_vtys <- repList varStrictTypeQTyConName rep_ip ips
+    = do { args <- concatMapM rep_ip ips
+         ; arg_vtys <- coreList varStrictTypeQTyConName args
          ; rep2 recCName [unC con, unC arg_vtys] }
     where
-      rep_ip ip = do { MkC v  <- lookupLOcc (cd_fld_name ip)
-                     ; MkC ty <- repBangTy  (cd_fld_type ip)
-                     ; rep2 varStrictTypeName [v,ty] }
+      rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
+      rep_one_ip t n = do { MkC v  <- lookupLOcc n
+                          ; MkC ty <- repBangTy  t
+                          ; rep2 varStrictTypeName [v,ty] }
 
 repConstr con (InfixCon st1 st2)
     = do arg1 <- repBangTy st1
index ddcd089..8bc8a11 100644 (file)
@@ -973,8 +973,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     exp _ _  = False
 
     ---------
-    tup_arg (Present e1) (Present e2) = lexp e1 e2
-    tup_arg (Missing t1) (Missing t2) = eqType t1 t2
+    tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2
+    tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2
     tup_arg _ _ = False
 
     ---------
index 611d48e..8377e2a 100644 (file)
@@ -187,8 +187,8 @@ matchOneConLike vars ty (eqn1 : eqns)   -- All eqns for a single constructor
       = arg_vars
       where
         fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars
-        lookup_fld rpat = lookupNameEnv_NF fld_var_env
-                                           (idName (unLoc (hsRecFieldId rpat)))
+        lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env
+                                            (idName (unLoc (hsRecFieldId rpat)))
     select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"
 matchOneConLike _ _ [] = panic "matchOneCon []"
 
@@ -203,7 +203,8 @@ compatible_pats _                 _                 = True -- Prefix or infix co
 
 same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool
 same_fields flds1 flds2
-  = all2 (\f1 f2 -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
+  = all2 (\(L _ f1) (L _ f2)
+                          -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
          (rec_flds flds1) (rec_flds flds2)
 
 
@@ -224,7 +225,7 @@ conArgPats  arg_tys (RecCon (HsRecFields { rec_flds = rpats }))
   | null rpats = map WildPat arg_tys
         -- Important special case for C {}, which can be used for a
         -- datacon that isn't declared to have fields at all
-  | otherwise  = map (unLoc . hsRecFieldArg) rpats
+  | otherwise  = map (unLoc . hsRecFieldArg . unLoc) rpats
 \end{code}
 
 Note [Record patterns]
index 141b8b8..c7c31f3 100644 (file)
@@ -176,7 +176,7 @@ cvtDec (TH.InfixD fx nm)
   -- the RdrName says it's a variable or a constructor. So, just assume
   -- it's a variable or constructor and proceed.
   = do { nm' <- vcNameL nm
-       ; returnJustL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) }
+       ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }
 
 cvtDec (PragmaD prag)
   = cvtPragmaD prag
@@ -208,7 +208,8 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs)
         ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
                                 , dd_ctxt = ctxt'
                                 , dd_kindSig = Nothing
-                                , dd_cons = [con'], dd_derivs = derivs' }
+                                , dd_cons = [con']
+                                , dd_derivs = derivs' }
         ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
                                     , tcdDataDefn = defn
                                     , tcdFVs = placeHolderNames }) }
@@ -416,7 +417,8 @@ cvtConstr (RecC c varstrtys)
   = do  { c'    <- cNameL c
         ; cxt'  <- returnL []
         ; args' <- mapM cvt_id_arg varstrtys
-        ; returnL $ mkSimpleConDecl c' noExistentials cxt' (RecCon args') }
+        ; returnL $ mkSimpleConDecl c' noExistentials cxt'
+                                   (RecCon args') }
 
 cvtConstr (InfixC st1 c st2)
   = do  { c' <- cNameL c
@@ -437,16 +439,18 @@ cvt_arg (NotStrict, ty) = cvtType ty
 cvt_arg (IsStrict,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang Nothing     True) ty' }
 cvt_arg (Unpacked,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang (Just True) True) ty' }
 
-cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
+cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName)
 cvt_id_arg (i, str, ty)
   = do  { i' <- vNameL i
         ; ty' <- cvt_arg (str,ty)
-        ; return (ConDeclField { cd_fld_name = i', cd_fld_type =  ty', cd_fld_doc = Nothing}) }
+        ; return $ noLoc (ConDeclField { cd_fld_names = [i']
+                                       , cd_fld_type =  ty'
+                                       , cd_fld_doc = Nothing}) }
 
-cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName])
+cvtDerivs :: [TH.Name] -> CvtM (Maybe (Located [LHsType RdrName]))
 cvtDerivs [] = return Nothing
 cvtDerivs cs = do { cs' <- mapM cvt_one cs
-                  ; return (Just cs') }
+                  ; return (Just (noLoc cs')) }
         where
           cvt_one c = do { c' <- tconName c
                          ; returnL $ HsTyVar c' }
@@ -463,8 +467,9 @@ noExistentials = []
 
 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
 cvtForD (ImportF callconv safety from nm ty)
-  | Just impspec <- parseCImport (cvt_conv callconv) safety'
-                                 (mkFastString (TH.nameBase nm)) from
+  | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
+                                 (mkFastString (TH.nameBase nm))
+                                 from (noLoc (mkFastString from))
   = do { nm' <- vNameL nm
        ; ty' <- cvtType ty
        ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
@@ -480,7 +485,9 @@ cvtForD (ImportF callconv safety from nm ty)
 cvtForD (ExportF callconv as nm ty)
   = do  { nm' <- vNameL nm
         ; ty' <- cvtType ty
-        ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
+        ; let e = CExport (noLoc (CExportStatic (mkFastString as)
+                                                (cvt_conv callconv)))
+                                                (noLoc (mkFastString as))
         ; return $ ForeignExport nm' ty' noForeignExportCoercionYet e }
 
 cvt_conv :: TH.Callconv -> CCallConv
@@ -514,7 +521,7 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
                                , inl_rule   = Hs.FunLike
                                , inl_act    = cvtPhases phases dflt
                                , inl_sat    = Nothing }
-       ; returnJustL $ Hs.SigD $ SpecSig nm' ty' ip }
+       ; returnJustL $ Hs.SigD $ SpecSig nm' [ty'] ip }
 
 cvtPragmaD (SpecialiseInstP ty)
   = do { ty' <- cvtType ty
@@ -526,7 +533,7 @@ cvtPragmaD (RuleP nm bndrs lhs rhs phases)
        ; bndrs' <- mapM cvtRuleBndr bndrs
        ; lhs'   <- cvtl lhs
        ; rhs'   <- cvtl rhs
-       ; returnJustL $ Hs.RuleD $ HsRule nm' act bndrs'
+       ; returnJustL $ Hs.RuleD $ HsRule (noLoc nm') act bndrs'
                                      lhs' placeHolderNames
                                      rhs' placeHolderNames
        }
@@ -567,14 +574,14 @@ cvtPhases AllPhases       dflt = dflt
 cvtPhases (FromPhase i)   _    = ActiveAfter i
 cvtPhases (BeforePhase i) _    = ActiveBefore i
 
-cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.RuleBndr RdrName)
+cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName)
 cvtRuleBndr (RuleVar n)
   = do { n' <- vNameL n
-       ; return $ Hs.RuleBndr n' }
+       ; return $ noLoc $ Hs.RuleBndr n' }
 cvtRuleBndr (TypedRuleVar n ty)
   = do { n'  <- vNameL n
        ; ty' <- cvtType ty
-       ; return $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' }
+       ; return $ noLoc $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' }
 
 ---------------------------------------------------
 --              Declarations
@@ -622,8 +629,12 @@ cvtl e = wrapL (cvt e)
     cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar e' }
                                  -- Note [Dropping constructors]
                                  -- Singleton tuples treated like nothing (just parens)
-    cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }
-    cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed }
+    cvt (TupE es)      = do { es' <- mapM cvtl es
+                            ; return $ ExplicitTuple (map (noLoc . Present) es')
+                                                      Boxed }
+    cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es
+                                   ; return $ ExplicitTuple
+                                           (map (noLoc . Present) es') Unboxed }
     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
                             ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
     cvt (MultiIfE alts)
@@ -694,10 +705,11 @@ and the above expression would be reassociated to
 which we don't want.
 -}
 
-cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
+cvtFld :: (TH.Name, TH.Exp) -> CvtM (LHsRecField RdrName (LHsExpr RdrName))
 cvtFld (v,e)
   = do  { v' <- vNameL v; e' <- cvtl e
-        ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
+        ; return (noLoc $ HsRecField { hsRecFieldId = v', hsRecFieldArg = e'
+                                     , hsRecPun = False}) }
 
 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
 cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
@@ -907,10 +919,11 @@ cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t
 cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p
                             ; return $ ViewPat e' p' placeHolderType }
 
-cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
+cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName))
 cvtPatFld (s,p)
   = do  { s' <- vNameL s; p' <- cvtPat p
-        ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
+        ; return (noLoc $ HsRecField { hsRecFieldId = s', hsRecFieldArg = p'
+                                     , hsRecPun = False}) }
 
 {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
 The produced tree of infix patterns will be left-biased, provided @x@ is.
index b345e88..28e2343 100644 (file)
@@ -607,7 +607,7 @@ data Sig name
         -- > {-# SPECIALISE f :: Int -> Int #-}
         --
   | SpecSig     (Located name)  -- Specialise a function or datatype  ...
-                (LHsType name)  -- ... to these types
+                [LHsType name]  -- ... to these types
                 InlinePragma    -- The pragma on SPECIALISE_INLINE form.
                                 -- If it's just defaultInlinePragma, then we said
                                 --    SPECIALISE, not SPECIALISE_INLINE
@@ -630,7 +630,7 @@ deriving instance (DataId name) => Data (Sig name)
 
 
 type LFixitySig name = Located (FixitySig name)
-data FixitySig name = FixitySig (Located name) Fixity
+data FixitySig name = FixitySig [Located name] Fixity
   deriving (Data, Typeable)
 
 -- | TsSpecPrags conveys pragmas from the type checker to the desugarer
@@ -727,7 +727,8 @@ ppr_sig (TypeSig vars ty)         = pprVarSig (map unLoc vars) (ppr ty)
 ppr_sig (GenericSig vars ty)      = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty)
 ppr_sig (IdSig id)                = pprVarSig [id] (ppr (varType id))
 ppr_sig (FixSig fix_sig)          = ppr fix_sig
-ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec (unLoc var) (ppr ty) inl)
+ppr_sig (SpecSig var ty inl)
+  = pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl)
 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
 ppr_sig (MinimalSig bf)           = pragBrackets (pprMinimalSig bf)
@@ -750,7 +751,9 @@ pprPatSynSig ident _is_bidir tvs prov req ty
         (Just prov, Just req) -> prov <+> darrow <+> req <+> darrow
 
 instance OutputableBndr name => Outputable (FixitySig name) where
-  ppr (FixitySig name fixity) = sep [ppr fixity, pprInfixOcc (unLoc name)]
+  ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
+    where
+      pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
 
 pragBrackets :: SDoc -> SDoc
 pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}")
index 323f0cd..f8f370c 100644 (file)
@@ -12,6 +12,8 @@
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                       -- in module PlaceHolder
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- | Abstract syntax of global declarations.
 --
@@ -42,7 +44,7 @@ module HsDecls (
   -- ** Standalone deriving declarations
   DerivDecl(..), LDerivDecl,
   -- ** @RULE@ declarations
-  RuleDecl(..), LRuleDecl, RuleBndr(..),
+  RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr,
   collectRuleBndrSigTys,
   -- ** @VECTORISE@ declarations
   VectDecl(..), LVectDecl,
@@ -770,7 +772,7 @@ data HsDataDefn name   -- The payload of a data type defn
     -- @
     HsDataDefn { dd_ND     :: NewOrData,
                  dd_ctxt   :: LHsContext name,           -- ^ Context
-                 dd_cType  :: Maybe CType,
+                 dd_cType  :: Maybe (Located CType),
                  dd_kindSig:: Maybe (LHsKind name),
                      -- ^ Optional kind signature.
                      --
@@ -787,7 +789,7 @@ data HsDataDefn name   -- The payload of a data type defn
                      -- For @data T a where { T1 :: T a }@
                      --   the 'LConDecls' all have 'ResTyGADT'.
 
-                 dd_derivs :: Maybe [LHsType name]
+                 dd_derivs :: Maybe (Located [LHsType name])
                      -- ^ Derivings; @Nothing@ => not specified,
                      --              @Just []@ => derive exactly what is asked
                      --
@@ -822,10 +824,11 @@ type LConDecl name = Located (ConDecl name)
 
 data ConDecl name
   = ConDecl
-    { con_name      :: Located name
-        -- ^ Constructor name.  This is used for the DataCon itself, and for
+    { con_names     :: [Located name]
+        -- ^ Constructor names.  This is used for the DataCon itself, and for
         -- the user-callable wrapper Id.
-
+        -- It is a list to deal with GADT constructors of the form
+        --   T1, T2, T3 :: <payload>
     , con_explicit  :: HsExplicitFlag
         -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy')
 
@@ -860,12 +863,12 @@ data ConDecl name
     } deriving (Typeable)
 deriving instance (DataId name) => Data (ConDecl name)
 
-type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name]
+type HsConDeclDetails name = HsConDetails (LBangType name) [LConDeclField name]
 
 hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
 hsConDeclArgTys (PrefixCon tys)    = tys
 hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
-hsConDeclArgTys (RecCon flds)      = map cd_fld_type flds
+hsConDeclArgTys (RecCon flds)      = map (cd_fld_type . unLoc) flds
 
 data ResType ty
    = ResTyH98           -- Constructor was declared using Haskell 98 syntax
@@ -899,8 +902,9 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
                Nothing   -> empty
                Just kind -> dcolon <+> ppr kind
     pp_derivings = case derivings of
-                     Nothing -> empty
-                     Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]
+                     Nothing       -> empty
+                     Just (L _ ds) -> hsep [ptext (sLit "deriving"),
+                                            parens (interpp'SP ds)]
 
 instance OutputableBndr name => Outputable (HsDataDefn name) where
    ppr d = pp_data_defn (\_ -> ptext (sLit "Naked HsDataDefn")) d
@@ -919,32 +923,47 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where
     ppr = pprConDecl
 
 pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
-pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
+pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
                     , con_cxt = cxt, con_details = details
                     , con_res = ResTyH98, con_doc = doc })
   = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
   where
-    ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc (unLoc con), ppr t2]
-    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc (unLoc con) : map (pprParendHsType . unLoc) tys)
-    ppr_details (RecCon fields)  = ppr con <+> pprConDeclFields fields
+    ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc cons, ppr t2]
+    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc cons
+                                   : map (pprParendHsType . unLoc) tys)
+    ppr_details (RecCon fields)  = ppr_con_names cons
+                                 <+> pprConDeclFields fields
 
-pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
+pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
                     , con_cxt = cxt, con_details = PrefixCon arg_tys
                     , con_res = ResTyGADT res_ty })
-  = ppr con <+> dcolon <+>
+  = ppr_con_names cons <+> dcolon <+>
     sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
   where
     mk_fun_ty a b = noLoc (HsFunTy a b)
 
-pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
+pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
                     , con_cxt = cxt, con_details = RecCon fields, con_res = ResTyGADT res_ty })
-  = sep [ppr con <+> dcolon <+> pprHsForAll expl tvs cxt,
+  = sep [ppr_con_names cons <+> dcolon <+> pprHsForAll expl tvs cxt,
          pprConDeclFields fields <+> arrow <+> ppr res_ty]
 
 pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {} })
   = pprConDecl (decl { con_details = PrefixCon [ty1,ty2] })
         -- In GADT syntax we don't allow infix constructors
         -- but the renamer puts them in this form (Note [Infix GADT constructors] in RnSource)
+
+ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc
+ppr_con_names [x] = ppr x
+ppr_con_names xs  = interpp'SP xs
+
+instance (Outputable name) => OutputableBndr [Located name] where
+  pprBndr _bs xs = cat $ punctuate comma (map ppr xs)
+
+  pprPrefixOcc [x] = ppr x
+  pprPrefixOcc xs  = cat $ punctuate comma (map ppr xs)
+
+  pprInfixOcc [x] = ppr x
+  pprInfixOcc xs  = cat $ punctuate comma (map ppr xs)
 \end{code}
 
 %************************************************************************
@@ -1027,7 +1046,7 @@ data ClsInstDecl name
       , cid_sigs          :: [LSig name]             -- User-supplied pragmatic info
       , cid_tyfam_insts   :: [LTyFamInstDecl name]   -- Type family instances
       , cid_datafam_insts :: [LDataFamInstDecl name] -- Data family instances
-      , cid_overlap_mode :: Maybe OverlapMode
+      , cid_overlap_mode  :: Maybe (Located OverlapMode)
       }
   deriving (Typeable)
 deriving instance (DataId id) => Data (ClsInstDecl id)
@@ -1123,15 +1142,15 @@ instance (OutputableBndr name) => Outputable (ClsInstDecl name) where
         top_matter = ptext (sLit "instance") <+> ppOverlapPragma mbOverlap
                                              <+> ppr inst_ty
 
-ppOverlapPragma :: Maybe OverlapMode -> SDoc
+ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc
 ppOverlapPragma mb =
   case mb of
     Nothing           -> empty
-    Just NoOverlap    -> ptext (sLit "{-# NO_OVERLAP #-}")
-    Just Overlappable -> ptext (sLit "{-# OVERLAPPABLE #-}")
-    Just Overlapping  -> ptext (sLit "{-# OVERLAPPING #-}")
-    Just Overlaps     -> ptext (sLit "{-# OVERLAPS #-}")
-    Just Incoherent   -> ptext (sLit "{-# INCOHERENT #-}")
+    Just (L _ NoOverlap)    -> ptext (sLit "{-# NO_OVERLAP #-}")
+    Just (L _ Overlappable) -> ptext (sLit "{-# OVERLAPPABLE #-}")
+    Just (L _ Overlapping)  -> ptext (sLit "{-# OVERLAPPING #-}")
+    Just (L _ Overlaps)     -> ptext (sLit "{-# OVERLAPS #-}")
+    Just (L _ Incoherent)   -> ptext (sLit "{-# INCOHERENT #-}")
 
 
 
@@ -1162,9 +1181,10 @@ instDeclDataFamInsts inst_decls
 \begin{code}
 type LDerivDecl name = Located (DerivDecl name)
 
-data DerivDecl name = DerivDecl { deriv_type :: LHsType name
-                                , deriv_overlap_mode :: Maybe OverlapMode
-                                }
+data DerivDecl name = DerivDecl
+        { deriv_type :: LHsType name
+        , deriv_overlap_mode :: Maybe (Located OverlapMode)
+        }
   deriving (Typeable)
 deriving instance (DataId name) => Data (DerivDecl name)
 
@@ -1257,10 +1277,12 @@ data ForeignImport = -- import of a C entity
                      --
                      --  * `Safety' is irrelevant for `CLabel' and `CWrapper'
                      --
-                     CImport  CCallConv       -- ccall or stdcall
-                              Safety          -- interruptible, safe or unsafe
+                     CImport  (Located CCallConv) -- ccall or stdcall
+                              (Located Safety)  -- interruptible, safe or unsafe
                               (Maybe Header)  -- name of C header
                               CImportSpec     -- details of the C entity
+                              (Located FastString) -- original source text for
+                                                   -- the C entity
   deriving (Data, Typeable)
 
 -- details of an external C entity
@@ -1274,7 +1296,10 @@ data CImportSpec = CLabel    CLabelString     -- import address of a C label
 -- specification of an externally exported entity in dependence on the calling
 -- convention
 --
-data ForeignExport = CExport  CExportSpec    -- contains the calling convention
+data ForeignExport = CExport  (Located CExportSpec) -- contains the calling
+                                                    -- convention
+                              (Located FastString)  -- original source text for
+                                                    -- the C entity
   deriving (Data, Typeable)
 
 -- pretty printing of foreign declarations
@@ -1289,7 +1314,7 @@ instance OutputableBndr name => Outputable (ForeignDecl name) where
        2 (dcolon <+> ppr ty)
 
 instance Outputable ForeignImport where
-  ppr (CImport  cconv safety mHeader spec) =
+  ppr (CImport  cconv safety mHeader spec _) =
     ppr cconv <+> ppr safety <+>
     char '"' <> pprCEntity spec <> char '"'
     where
@@ -1309,7 +1334,7 @@ instance Outputable ForeignImport where
       pprCEntity (CWrapper) = ptext (sLit "wrapper")
 
 instance Outputable ForeignExport where
-  ppr (CExport  (CExportStatic lbl cconv)) =
+  ppr (CExport  (L _ (CExportStatic lbl cconv)) _) =
     ppr cconv <+> char '"' <> ppr lbl <> char '"'
 \end{code}
 
@@ -1325,16 +1350,18 @@ type LRuleDecl name = Located (RuleDecl name)
 
 data RuleDecl name
   = HsRule                      -- Source rule
-        RuleName                -- Rule name
+        (Located RuleName)      -- Rule name
         Activation
-        [RuleBndr name]         -- Forall'd vars; after typechecking this includes tyvars
+        [LRuleBndr name]        -- Forall'd vars; after typechecking this
+                                --   includes tyvars
         (Located (HsExpr name)) -- LHS
-        (PostRn name NameSet)        -- Free-vars from the LHS
+        (PostRn name NameSet)   -- Free-vars from the LHS
         (Located (HsExpr name)) -- RHS
-        (PostRn name NameSet)        -- Free-vars from the RHS
+        (PostRn name NameSet)   -- Free-vars from the RHS
   deriving (Typeable)
 deriving instance (DataId name) => Data (RuleDecl name)
 
+type LRuleBndr name = Located (RuleBndr name)
 data RuleBndr name
   = RuleBndr (Located name)
   | RuleBndrSig (Located name) (HsWithBndrs name (LHsType name))
@@ -1346,7 +1373,8 @@ collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
 
 instance OutputableBndr name => Outputable (RuleDecl name) where
   ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)
-        = sep [text "{-# RULES" <+> doubleQuotes (ftext name) <+> ppr act,
+        = sep [text "{-# RULES" <+> doubleQuotes (ftext $ unLoc name)
+                                <+> ppr act,
                nest 4 (pp_forall <+> pprExpr (unLoc lhs)),
                nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ]
         where
index eaac719..79c30a0 100644 (file)
@@ -161,8 +161,8 @@ data HsExpr id
                 (LHsExpr id)    -- operand
 
   -- | Used for explicit tuples and sections thereof
-  | ExplicitTuple               
-        [HsTupArg id]
+  | ExplicitTuple
+        [LHsTupArg id]
         Boxity
 
   | HsCase      (LHsExpr id)
@@ -339,17 +339,18 @@ data HsExpr id
 deriving instance (DataId id) => Data (HsExpr id)
 
 -- | HsTupArg is used for tuple sections
---  (,a,) is represented by  ExplicitTuple [Mising ty1, Present a, Missing ty3]
+--  (,a,) is represented by  ExplicitTuple [Missing ty1, Present a, Missing ty3]
 --  Which in turn stands for (\x:ty1 \y:ty2. (x,a,y))
+type LHsTupArg id = Located (HsTupArg id)
 data HsTupArg id
   = Present (LHsExpr id)     -- ^ The argument
   | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type
   deriving (Typeable)
 deriving instance (DataId id) => Data (HsTupArg id)
 
-tupArgPresent :: HsTupArg id -> Bool
-tupArgPresent (Present {}) = True
-tupArgPresent (Missing {}) = False
+tupArgPresent :: LHsTupArg id -> Bool
+tupArgPresent (L _ (Present {})) = True
+tupArgPresent (L _ (Missing {})) = False
 \end{code}
 
 Note [Parens in HsSyn]
@@ -477,7 +478,8 @@ ppr_expr (SectionR op expr)
     pp_infixly v = sep [pprInfixOcc v, pp_expr]
 
 ppr_expr (ExplicitTuple exprs boxity)
-  = tupleParens (boxityNormalTupleSort boxity) (fcat (ppr_tup_args exprs))
+  = tupleParens (boxityNormalTupleSort boxity)
+                (fcat (ppr_tup_args $ map unLoc exprs))
   where
     ppr_tup_args []               = []
     ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
index 7163cbf..dd23dba 100644 (file)
@@ -41,7 +41,8 @@ data ImportDecl name
       ideclQualified :: Bool,               -- ^ True => qualified
       ideclImplicit  :: Bool,               -- ^ True => implicit import (of Prelude)
       ideclAs        :: Maybe ModuleName,   -- ^ as Module
-      ideclHiding    :: Maybe (Bool, [LIE name]) -- ^ (True => hiding, names)
+      ideclHiding    :: Maybe (Bool, Located [LIE name])
+                                            -- ^ (True => hiding, names)
     } deriving (Data, Typeable)
 
 simpleImportDecl :: ModuleName -> ImportDecl name
@@ -86,8 +87,8 @@ instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name)
         ppr_imp False = empty
 
         pp_spec Nothing             = empty
-        pp_spec (Just (False, ies)) = ppr_ies ies
-        pp_spec (Just (True,  ies)) = ptext (sLit "hiding") <+> ppr_ies ies
+        pp_spec (Just (False, (L _ ies))) = ppr_ies ies
+        pp_spec (Just (True, (L _ ies))) = ptext (sLit "hiding") <+> ppr_ies ies
 
         ppr_ies []  = ptext (sLit "()")
         ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')'
@@ -104,11 +105,12 @@ type LIE name = Located (IE name)
 
 -- | Imported or exported entity.
 data IE name
-  = IEVar               name
-  | IEThingAbs          name             -- ^ Class/Type (can't tell)
-  | IEThingAll          name             -- ^ Class/Type plus all methods/constructors
-  | IEThingWith         name [name]      -- ^ Class/Type plus some methods/constructors
-  | IEModuleContents    ModuleName       -- ^ (Export Only)
+  = IEVar       (Located name)
+  | IEThingAbs           name      -- ^ Class/Type (can't tell)
+  | IEThingAll  (Located name)     -- ^ Class/Type plus all methods/constructors
+  | IEThingWith (Located name) [Located name]
+                 -- ^ Class/Type plus some methods/constructors
+  | IEModuleContents  (Located ModuleName) -- ^ (Export Only)
   | IEGroup             Int HsDocString  -- ^ Doc section heading
   | IEDoc               HsDocString      -- ^ Some documentation
   | IEDocNamed          String           -- ^ Reference to named doc
@@ -117,21 +119,21 @@ data IE name
 
 \begin{code}
 ieName :: IE name -> name
-ieName (IEVar n)         = n
-ieName (IEThingAbs  n)   = n
-ieName (IEThingWith n _) = n
-ieName (IEThingAll  n)   = n
+ieName (IEVar (L _ n))         = n
+ieName (IEThingAbs  n)         = n
+ieName (IEThingWith (L _ n) _) = n
+ieName (IEThingAll  (L _ n))   = n
 ieName _ = panic "ieName failed pattern match!"
 
 ieNames :: IE a -> [a]
-ieNames (IEVar            n   ) = [n]
-ieNames (IEThingAbs       n   ) = [n]
-ieNames (IEThingAll       n   ) = [n]
-ieNames (IEThingWith      n ns) = n : ns
-ieNames (IEModuleContents _   ) = []
-ieNames (IEGroup          _ _ ) = []
-ieNames (IEDoc            _   ) = []
-ieNames (IEDocNamed       _   ) = []
+ieNames (IEVar       (L _ n)   ) = [n]
+ieNames (IEThingAbs       n    ) = [n]
+ieNames (IEThingAll  (L _ n)   ) = [n]
+ieNames (IEThingWith (L _ n) ns) = n : map unLoc ns
+ieNames (IEModuleContents _    ) = []
+ieNames (IEGroup          _ _  ) = []
+ieNames (IEDoc            _    ) = []
+ieNames (IEDocNamed       _    ) = []
 \end{code}
 
 \begin{code}
@@ -144,16 +146,15 @@ pprImpExp name = type_pref <+> pprPrefixOcc name
               | otherwise                   = empty
 
 instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where
-    ppr (IEVar          var)    = pprPrefixOcc var
+    ppr (IEVar          var)    = pprPrefixOcc (unLoc var)
     ppr (IEThingAbs     thing)  = pprImpExp thing
-    ppr (IEThingAll     thing)  = hcat [pprImpExp thing, text "(..)"]
+    ppr (IEThingAll      thing) = hcat [pprImpExp (unLoc thing), text "(..)"]
     ppr (IEThingWith thing withs)
-        = pprImpExp thing <> parens (fsep (punctuate comma (map pprImpExp withs)))
+        = pprImpExp (unLoc thing) <> parens (fsep (punctuate comma
+                                            (map pprImpExp $ map unLoc withs)))
     ppr (IEModuleContents mod')
         = ptext (sLit "module") <+> ppr mod'
     ppr (IEGroup n _)           = text ("<IEGroup: " ++ (show n) ++ ">")
     ppr (IEDoc doc)             = ppr doc
     ppr (IEDocNamed string)     = text ("<IEDocNamed: " ++ string ++ ">")
 \end{code}
-
-
index bbd37bc..145a8cd 100644 (file)
@@ -18,7 +18,7 @@ module HsPat (
 
         HsConDetails(..),
         HsConPatDetails, hsConPatArgs,
-        HsRecFields(..), HsRecField(..), hsRecFields,
+        HsRecFields(..), HsRecField(..), LHsRecField, hsRecFields,
 
         mkPrefixConPat, mkCharLitPat, mkNilPat,
 
@@ -187,7 +187,7 @@ type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id))
 
 hsConPatArgs :: HsConPatDetails id -> [LPat id]
 hsConPatArgs (PrefixCon ps)   = ps
-hsConPatArgs (RecCon fs)      = map hsRecFieldArg (rec_flds fs)
+hsConPatArgs (RecCon fs)      = map (hsRecFieldArg . unLoc) (rec_flds fs)
 hsConPatArgs (InfixCon p1 p2) = [p1,p2]
 \end{code}
 
@@ -198,7 +198,7 @@ However HsRecFields is used only for patterns and expressions
 data HsRecFields id arg         -- A bunch of record fields
                                 --      { x = 3, y = True }
         -- Used for both expressions and patterns
-  = HsRecFields { rec_flds   :: [HsRecField id arg],
+  = HsRecFields { rec_flds   :: [LHsRecField id arg],
                   rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
   deriving (Data, Typeable)
 
@@ -216,6 +216,7 @@ data HsRecFields id arg         -- A bunch of record fields
 --                     the first 'n' being the user-written ones
 --                     and the remainder being 'filled in' implicitly
 
+type LHsRecField id arg = Located (HsRecField id arg)
 data HsRecField id arg = HsRecField {
         hsRecFieldId  :: Located id,
         hsRecFieldArg :: arg,           -- Filled in by renamer
@@ -235,7 +236,7 @@ data HsRecField id arg = HsRecField {
 --    T { A.x } means T { A.x = x }
 
 hsRecFields :: HsRecFields id arg -> [id]
-hsRecFields rbinds = map (unLoc . hsRecFieldId) (rec_flds rbinds)
+hsRecFields rbinds = map (unLoc . hsRecFieldId . unLoc) (rec_flds rbinds)
 \end{code}
 
 %************************************************************************
index 7aecfea..bd1b2b2 100644 (file)
@@ -63,7 +63,7 @@ data HsModule name
       hsmodName :: Maybe (Located ModuleName),
         -- ^ @Nothing@: \"module X where\" is omitted (in which case the next
         --     field is Nothing too)
-      hsmodExports :: Maybe [LIE name],
+      hsmodExports :: Maybe (Located [LIE name]),
         -- ^ Export list
         --
         --  - @Nothing@: export list omitted, so export everything
@@ -78,7 +78,7 @@ data HsModule name
         -- downstream.
       hsmodDecls :: [LHsDecl name],
         -- ^ Type, class, value, and interface signature decls
-      hsmodDeprecMessage :: Maybe WarningTxt,
+      hsmodDeprecMessage :: Maybe (Located WarningTxt),
         -- ^ reason\/explanation for warning/deprecation of this module
       hsmodHaddockModHeader :: Maybe LHsDocString
         -- ^ Haddock module info and description, unparsed
@@ -92,7 +92,8 @@ instance (OutputableBndr name, HasOccName name)
         => Outputable (HsModule name) where
 
     ppr (HsModule Nothing _ imports decls _ mbDoc)
-      = pp_mb mbDoc $$ pp_nonnull imports $$ pp_nonnull decls
+      = pp_mb mbDoc $$ pp_nonnull imports
+                    $$ pp_nonnull decls
 
     ppr (HsModule (Just name) exports imports decls deprec mbDoc)
       = vcat [
@@ -101,7 +102,7 @@ instance (OutputableBndr name, HasOccName name)
               Nothing -> pp_header (ptext (sLit "where"))
               Just es -> vcat [
                            pp_header lparen,
-                           nest 8 (fsep (punctuate comma (map ppr es))),
+                           nest 8 (fsep (punctuate comma (map ppr (unLoc es)))),
                            nest 4 (ptext (sLit ") where"))
                           ],
             pp_nonnull imports,
index 4a01948..46cf096 100644 (file)
@@ -30,7 +30,7 @@ module HsTypes (
         LBangType, BangType, HsBang(..), 
         getBangType, getBangStrictness, 
 
-        ConDeclField(..), pprConDeclFields,
+        ConDeclField(..), LConDeclField, pprConDeclFields,
         
         mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded,
         mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy,
@@ -258,18 +258,18 @@ data HsType name
   | HsDocTy             (LHsType name) LHsDocString -- A documented type
 
   | HsBangTy    HsBang (LHsType name)   -- Bang-style type annotations 
-  | HsRecTy [ConDeclField name]         -- Only in data type declarations
+  | HsRecTy     [LConDeclField name]    -- Only in data type declarations
 
   | HsCoreTy Type       -- An escape hatch for tunnelling a *closed* 
                         -- Core Type through HsSyn.  
 
   | HsExplicitListTy       -- A promoted explicit list
         (PostTc name Kind) -- See Note [Promoted lists and tuples]
-        [LHsType name]   
-                         
+        [LHsType name]
+
   | HsExplicitTupleTy      -- A promoted explicit tuple
         [PostTc name Kind] -- See Note [Promoted lists and tuples]
-        [LHsType name]   
+        [LHsType name]
 
   | HsTyLit HsTyLit      -- A promoted numeric literal.
 
@@ -398,10 +398,11 @@ data HsTupleSort = HsUnboxedTuple
 
 data HsExplicitFlag = Qualified | Implicit | Explicit deriving (Data, Typeable)
 
+type LConDeclField name = Located (ConDeclField name)
 data ConDeclField name  -- Record fields have Haddoc docs on them
-  = ConDeclField { cd_fld_name :: Located name,
-                   cd_fld_type :: LBangType name, 
-                   cd_fld_doc  :: Maybe LHsDocString }
+  = ConDeclField { cd_fld_names :: [Located name],
+                   cd_fld_type  :: LBangType name,
+                   cd_fld_doc   :: Maybe LHsDocString }
   deriving (Typeable)
 deriving instance (DataId name) => Data (ConDeclField name)
 
@@ -616,12 +617,14 @@ pprHsContextMaybe []         = Nothing
 pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty FunPrec pred
 pprHsContextMaybe cxt        = Just $ parens (interpp'SP cxt)
 
-pprConDeclFields :: OutputableBndr name => [ConDeclField name] -> SDoc
+pprConDeclFields :: OutputableBndr name => [LConDeclField name] -> SDoc
 pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
   where
-    ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty, 
-                            cd_fld_doc = doc })
-        = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
+    ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
+                                 cd_fld_doc = doc }))
+        = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
+    ppr_names [n] = ppr n
+    ppr_names ns = sep (punctuate comma (map ppr ns))
 \end{code}
 
 Note [Printing KindedTyVars]
index df2406f..f64471b 100644 (file)
@@ -416,7 +416,7 @@ types on the tuple.
 mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
 -- Makes a pre-typechecker boxed tuple, deals with 1 case
 mkLHsTupleExpr [e] = e
-mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map Present es) Boxed
+mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed
 
 mkLHsVarTuple :: [a] -> LHsExpr a
 mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
@@ -792,7 +792,8 @@ hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
 -------------------
 -- the SrcLoc returned are for the whole declarations, not just the names
 hsDataDefnBinders :: Eq name => HsDataDefn name -> [Located name]
-hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons
+hsDataDefnBinders (HsDataDefn { dd_cons = cons })
+  = hsConDeclsBinders cons
   -- See Note [Binders in family instances]
 
 -------------------
@@ -809,12 +810,12 @@ hsConDeclsBinders cons = go id cons
           case r of
              -- remove only the first occurrence of any seen field in order to
              -- avoid circumventing detection of duplicate fields (#9156)
-             L loc (ConDecl { con_name = L _ name , con_details = RecCon flds }) ->
-               (L loc name) : r' ++ go remSeen' rs
-                  where r' = remSeen (map cd_fld_name flds)
+             L loc (ConDecl { con_names = names, con_details = RecCon flds }) ->
+               (map (L loc . unLoc) names) ++ r' ++ go remSeen' rs
+                  where r' = remSeen (concatMap (cd_fld_names . unLoc) flds)
                         remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc) v | v <- r']
-             L loc (ConDecl { con_name = L _ name }) ->
-                (L loc name) : go remSeen rs
+             L loc (ConDecl { con_names = names }) ->
+                (map (L loc . unLoc) names) ++ go remSeen rs
 
 \end{code}
 
@@ -898,7 +899,8 @@ lPatImplicits = hs_lpat
     details (RecCon fs)      = hs_lpats explicit `unionNameSets` mkNameSet (collectPatsBinders implicit)
       where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat
                                                     | (i, fld) <- [0..] `zip` rec_flds fs
-                                                    , let pat = hsRecFieldArg fld
+                                                    , let pat = hsRecFieldArg
+                                                                     (unLoc fld)
                                                           pat_explicit = maybe True (i<) (rec_dotdot fs)]
     details (InfixCon p1 p2) = hs_lpat p1 `unionNameSets` hs_lpat p2
 \end{code}
index c6d72b2..9ac2243 100644 (file)
@@ -81,7 +81,8 @@ getImports dflags buf filename source_filename = do
                                        ord_idecls
 
                 implicit_prelude = xopt Opt_ImplicitPrelude dflags
-                implicit_imports = mkPrelImports (unLoc mod) main_loc implicit_prelude imps
+                implicit_imports = mkPrelImports (unLoc mod) main_loc
+                                                 implicit_prelude imps
               in
               return (src_idecls, implicit_imports ++ ordinary_imps, mod)
 
index c9baa5a..3763e55 100644 (file)
@@ -813,7 +813,7 @@ hscCheckSafeImports tcg_env = do
     warns dflags rules = listToBag $ map (warnRules dflags) rules
     warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) =
         mkPlainWarnMsg dflags loc $
-            text "Rule \"" <> ftext n <> text "\" ignored" $+$
+            text "Rule \"" <> ftext (unLoc n) <> text "\" ignored" $+$
             text "User defined rules are disabled under Safe Haskell"
 
 -- | Validate that safe imported modules are actually safe.  For modules in the
@@ -1519,7 +1519,7 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do
     (L _ (HsModule{hsmodImports=is})) <-
        hscParseThing parseModule str
     case is of
-        [i] -> return (unLoc i)
+        [L _ i] -> return i
         _ -> liftIO $ throwOneError $
                  mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $
                      ptext (sLit "parse error in import declaration")
index 4f901b1..582cb31 100644 (file)
@@ -78,7 +78,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls
     val_decls  = [d | ValD d <- decls]
 
-    real_exports = case exports of { Nothing -> []; Just es -> es }
+    real_exports = case exports of { Nothing -> []; Just (L _ es) -> es }
     n_exports    = length real_exports
     export_ms    = count (\ e -> case unLoc e of { IEModuleContents{} -> True;_ -> False})
                          real_exports
@@ -124,9 +124,10 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     spec_info (Just (False, _)) = (0,0,0,0,0,1,0)
     spec_info (Just (True, _))  = (0,0,0,0,0,0,1)
 
-    data_info (DataDecl { tcdDataDefn = HsDataDefn {dd_cons = cs, dd_derivs = derivs}})
-        = (length cs, case derivs of Nothing -> 0
-                                     Just ds -> length ds)
+    data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs
+                                                   , dd_derivs = derivs}})
+        = (length cs, case derivs of Nothing       -> 0
+                                     Just (L _ ds) -> length ds)
     data_info _ = (0,0)
 
     class_info decl@(ClassDecl {})
index bf22cd7..387cbf8 100644 (file)
@@ -9,13 +9,15 @@ import Control.Monad
 -- -----------------------------------------------------------------------------
 -- Adding documentation to record fields (used in parsing).
 
-addFieldDoc :: ConDeclField a -> Maybe LHsDocString -> ConDeclField a
-addFieldDoc fld doc = fld { cd_fld_doc = cd_fld_doc fld `mplus` doc }
+addFieldDoc :: LConDeclField a -> Maybe LHsDocString -> LConDeclField a
+addFieldDoc (L l fld) doc
+  = L l (fld { cd_fld_doc = cd_fld_doc fld `mplus` doc })
 
-addFieldDocs :: [ConDeclField a] -> Maybe LHsDocString -> [ConDeclField a]
+addFieldDocs :: [LConDeclField a] -> Maybe LHsDocString -> [LConDeclField a]
 addFieldDocs [] _ = []
 addFieldDocs (x:xs) doc = addFieldDoc x doc : xs
 
+
 addConDoc :: LConDecl a -> Maybe LHsDocString -> LConDecl a
 addConDoc decl    Nothing = decl
 addConDoc (L p c) doc     = L p ( c { con_doc = con_doc c `mplus` doc } )
index 4117d06..30cd552 100644 (file)
@@ -452,9 +452,11 @@ maybedocheader :: { Maybe LHsDocString }
 missing_module_keyword :: { () }
         : {- empty -}                           {% pushCurrentContext }
 
-maybemodwarning :: { Maybe WarningTxt }
-    : '{-# DEPRECATED' strings '#-}' { Just (DeprecatedTxt $ unLoc $2) }
-    | '{-# WARNING' strings '#-}'    { Just (WarningTxt $ unLoc $2) }
+maybemodwarning :: { Maybe (Located WarningTxt) }
+    : '{-# DEPRECATED' strings '#-}' { Just (sLL $1 $> $
+                                                    DeprecatedTxt $ unLoc $2) }
+    | '{-# WARNING' strings '#-}'    { Just (sLL $1 $> $
+                                                    WarningTxt $ unLoc $2) }
     |  {- empty -}                  { Nothing }
 
 body    :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
@@ -497,8 +499,8 @@ header_body2 :: { [LImportDecl RdrName] }
 -----------------------------------------------------------------------------
 -- The Export List
 
-maybeexports :: { Maybe [LIE RdrName] }
-        :  '(' exportlist ')'                   { Just (fromOL $2) }
+maybeexports :: { Maybe (Located [LIE RdrName]) }
+        :  '(' exportlist ')'                   { Just (sLL $1 $> (fromOL $2)) }
         |  {- empty -}                          { Nothing }
 
 exportlist :: { OrdList (LIE RdrName) }
@@ -523,10 +525,10 @@ exp_doc :: { OrdList (LIE RdrName) }
    -- No longer allow things like [] and (,,,) to be exported
    -- They are built in syntax, always available
 export  :: { OrdList (LIE RdrName) }
-        : qcname_ext export_subspec     { unitOL (sLL $1 $> (mkModuleImpExp (unLoc $1)
+        : qcname_ext export_subspec     { unitOL (sLL $1 $> (mkModuleImpExp $1
                                                                      (unLoc $2))) }
-        |  'module' modid               { unitOL (sLL $1 $> (IEModuleContents (unLoc $2))) }
-        |  'pattern' qcon               { unitOL (sLL $1 $> (IEVar (unLoc $2))) }
+        |  'module' modid               { unitOL (sLL $1 $> (IEModuleContents $2)) }
+        |  'pattern' qcon               { unitOL (sLL $1 $> (IEVar $2)) }
 
 export_subspec :: { Located ImpExpSubSpec }
         : {- empty -}                   { sL0 ImpExpAbs }
@@ -534,9 +536,9 @@ export_subspec :: { Located ImpExpSubSpec }
         | '(' ')'                       { sLL $1 $> (ImpExpList []) }
         | '(' qcnames ')'               { sLL $1 $> (ImpExpList (reverse $2)) }
 
-qcnames :: { [RdrName] }     -- A reversed list
-        :  qcnames ',' qcname_ext       { unLoc $3 : $1 }
-        |  qcname_ext                   { [unLoc $1]  }
+qcnames :: { [Located RdrName] }     -- A reversed list
+        :  qcnames ',' qcname_ext       { $3 : $1 }
+        |  qcname_ext                   { [$1]  }
 
 qcname_ext :: { Located RdrName }       -- Variable or data constructor
                                         -- or tagged type constructor
@@ -555,7 +557,7 @@ qcname  :: { Located RdrName }  -- Variable or data constructor
 -- whereas topdecls must contain at least one topdecl.
 
 importdecls :: { [LImportDecl RdrName] }
-        : importdecls ';' importdecl            { $3 : $1 }
+        : importdecls ';' importdecl            { ($3 : $1) }
         | importdecls ';'                       { $1 }
         | importdecl                            { [ $1 ] }
         | {- empty -}                           { [] }
@@ -588,13 +590,15 @@ maybeas :: { Located (Maybe ModuleName) }
         : 'as' modid                            { sLL $1 $> (Just (unLoc $2)) }
         | {- empty -}                           { noLoc Nothing }
 
-maybeimpspec :: { Located (Maybe (Bool, [LIE RdrName])) }
+maybeimpspec :: { Located (Maybe (Bool, Located [LIE RdrName])) }
         : impspec                               { sL1 $1 (Just (unLoc $1)) }
         | {- empty -}                           { noLoc Nothing }
 
-impspec :: { Located (Bool, [LIE RdrName]) }
-        :  '(' exportlist ')'                   { sLL $1 $> (False, fromOL $2) }
-        |  'hiding' '(' exportlist ')'          { sLL $1 $> (True,  fromOL $3) }
+impspec :: { Located (Bool, Located [LIE RdrName]) }
+        :  '(' exportlist ')'                   { sLL $1 $> (False,
+                                                      (sLL $1 $> $ fromOL $2)) }
+        |  'hiding' '(' exportlist ')'          { sLL $1 $> (True,
+                                                      (sLL $2 $> $ fromOL $3)) }
 
 -----------------------------------------------------------------------------
 -- Fixity Declarations
@@ -658,7 +662,8 @@ topdecl :: { OrdList (LHsDecl RdrName) }
 -- Type classes
 --
 cl_decl :: { LTyClDecl RdrName }
-        : 'class' tycl_hdr fds where_cls        {% mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 $4 }
+        : 'class' tycl_hdr fds where_cls
+                           {% mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (unLoc $4) }
 
 -- Type declarations (toplevel)
 --
@@ -716,7 +721,7 @@ inst_decl :: { LInstDecl RdrName }
           -- data/newtype instance declaration
         | data_or_newtype 'instance' capi_ctype tycl_hdr constrs deriving
                 {% mkDataFamInst (comb4 $1 $4 $5 $6) (unLoc $1) $3 $4
-                                      Nothing (reverse (unLoc $5)) (unLoc $6) }
+                                 Nothing (reverse (unLoc $5)) (unLoc $6) }
 
           -- GADT instance declaration
         | data_or_newtype 'instance' capi_ctype tycl_hdr opt_kind_sig
@@ -725,11 +730,11 @@ inst_decl :: { LInstDecl RdrName }
                 {% mkDataFamInst (comb4 $1 $4 $6 $7) (unLoc $1) $3 $4
                                      (unLoc $5) (unLoc $6) (unLoc $7) }
 
-overlap_pragma :: { Maybe OverlapMode }
-  : '{-# OVERLAPPABLE'    '#-}' { Just Overlappable }
-  | '{-# OVERLAPPING'     '#-}' { Just Overlapping }
-  | '{-# OVERLAPS'        '#-}' { Just Overlaps }
-  | '{-# INCOHERENT'      '#-}' { Just Incoherent }
+overlap_pragma :: { Maybe (Located OverlapMode) }
+  : '{-# OVERLAPPABLE'    '#-}' { Just (sLL $1 $> Overlappable) }
+  | '{-# OVERLAPPING'     '#-}' { Just (sLL $1 $> Overlapping) }
+  | '{-# OVERLAPS'        '#-}' { Just (sLL $1 $> Overlaps) }
+  | '{-# INCOHERENT'      '#-}' { Just (sLL $1 $> Incoherent) }
   | {- empty -}                 { Nothing }
 
 
@@ -829,10 +834,14 @@ tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
         : context '=>' type             { sLL $1 $> (Just $1, $3) }
         | type                          { sL1 $1 (Nothing, $1) }
 
-capi_ctype :: { Maybe CType }
-capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTRING $2))) (getSTRING $3)) }
-           | '{-# CTYPE'        STRING '#-}' { Just (CType Nothing                        (getSTRING $2)) }
-           |                                 { Nothing }
+capi_ctype :: { Maybe (Located CType) }
+capi_ctype : '{-# CTYPE' STRING STRING '#-}'
+                           { Just $ sLL $1 $> (CType
+                                    (Just (Header (getSTRING $2)))
+                                                  (getSTRING $3)) }
+           | '{-# CTYPE'        STRING '#-}'
+                           { Just $ sLL $1 $> (CType Nothing (getSTRING $2)) }
+           |               { Nothing }
 
 -----------------------------------------------------------------------------
 -- Stand-alone deriving
@@ -1008,7 +1017,7 @@ rules   :: { OrdList (LHsDecl RdrName) }
 
 rule    :: { LHsDecl RdrName }
         : STRING rule_activation rule_forall infixexp '=' exp
-             { sLL $1 $> $ RuleD (HsRule (getSTRING $1)
+             { sLL $1 $> $ RuleD (HsRule (sL1 $1 (getSTRING $1))
                                   ($2 `orElse` AlwaysActive)
                                   $3 $4 placeHolderNames $6 placeHolderNames) }
 
@@ -1022,17 +1031,17 @@ rule_explicit_activation :: { Activation }  -- In brackets
         | '[' '~' INTEGER ']'           { ActiveBefore (fromInteger (getINTEGER $3)) }
         | '[' '~' ']'                   { NeverActive }
 
-rule_forall :: { [RuleBndr RdrName] }
+rule_forall :: { [LRuleBndr RdrName] }
         : 'forall' rule_var_list '.'            { $2 }
         | {- empty -}                           { [] }
 
-rule_var_list :: { [RuleBndr RdrName] }
+rule_var_list :: { [LRuleBndr RdrName] }
         : rule_var                              { [$1] }
         | rule_var rule_var_list                { $1 : $2 }
 
-rule_var :: { RuleBndr RdrName }
-        : varid                                 { RuleBndr $1 }
-        | '(' varid '::' ctype ')'              { RuleBndrSig $2 (mkHsWithBndrs $4) }
+rule_var :: { LRuleBndr RdrName }
+        : varid                       { sLL $1 $> $ RuleBndr $1 }
+        | '(' varid '::' ctype ')'    { sLL $1 $> $ RuleBndrSig $2 (mkHsWithBndrs $4) }
 
 -----------------------------------------------------------------------------
 -- Warnings and deprecations (c.f. rules)
@@ -1061,13 +1070,14 @@ deprecation :: { OrdList (LHsDecl RdrName) }
                 { toOL [ sLL $1 $> $ WarningD (Warning n (DeprecatedTxt $ unLoc $2))
                        | n <- unLoc $1 ] }
 
-strings :: { Located [FastString] }
-    : STRING { sL1 $1 [getSTRING $1] }
+strings :: { Located [Located FastString] }
+    : STRING { sL1 $1 [sL1 $1 (getSTRING $1)] }
     | '[' stringlist ']' { sLL $1 $> $ fromOL (unLoc $2) }
 
-stringlist :: { Located (OrdList FastString) }
-    : stringlist ',' STRING { sLL $1 $> (unLoc $1 `snocOL` getSTRING $3) }
-    | STRING                { sLL $1 $> (unitOL (getSTRING $1)) }
+stringlist :: { Located (OrdList (Located FastString)) }
+    : stringlist ',' STRING { sLL $1 $> (unLoc $1 `snocOL`
+                                               (L (getLoc $3) (getSTRING $3))) }
+    | STRING                { sLL $1 $> (unitOL (sLL $1 $> (getSTRING $1))) }
 
 -----------------------------------------------------------------------------
 -- Annotations
@@ -1084,22 +1094,22 @@ fdecl :: { LHsDecl RdrName }
 fdecl : 'import' callconv safety fspec
                 {% mkImport $2 $3 (unLoc $4) >>= return.sLL $1 $> }
       | 'import' callconv        fspec
-                {% do { d <- mkImport $2 PlaySafe (unLoc $3);
+                {% do { d <- mkImport $2 (noLoc PlaySafe) (unLoc $3);
                         return (sLL $1 $> d) } }
       | 'export' callconv fspec
                 {% mkExport $2 (unLoc $3) >>= return.sLL $1 $> }
 
-callconv :: { CCallConv }
-          : 'stdcall'                   { StdCallConv }
-          | 'ccall'                     { CCallConv   }
-          | 'capi'                      { CApiConv    }
-          | 'prim'                      { PrimCallConv}
-          | 'javascript'                { JavaScriptCallConv }
+callconv :: { Located CCallConv }
+          : 'stdcall'                   { sLL $1 $> StdCallConv  }
+          | 'ccall'                     { sLL $1 $> CCallConv    }
+          | 'capi'                      { sLL $1 $> CApiConv     }
+          | 'prim'                      { sLL $1 $> PrimCallConv }
+          | 'javascript'                { sLL $1 $> JavaScriptCallConv }
 
-safety :: { Safety }
-        : 'unsafe'                      { PlayRisky }
-        | 'safe'                        { PlaySafe }
-        | 'interruptible'               { PlayInterruptible }
+safety :: { Located Safety }
+        : 'unsafe'                      { sLL $1 $> PlayRisky }
+        | 'safe'                        { sLL $1 $> PlaySafe }
+        | 'interruptible'               { sLL $1 $> PlayInterruptible }
 
 fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
        : STRING var '::' sigtypedoc     { sLL $1 $> (L (getLoc $1) (getSTRING $1), $2, $4) }
@@ -1348,14 +1358,14 @@ both become a HsTyVar ("Zero", DataName) after the renamer.
 -----------------------------------------------------------------------------
 -- Datatype declarations
 
-gadt_constrlist :: { Located [LConDecl RdrName] }       -- Returned in order
+gadt_constrlist :: { Located [LConDecl RdrName] } -- Returned in order
         : 'where' '{'        gadt_constrs '}'      { L (comb2 $1 $3) (unLoc $3) }
         | 'where' vocurly    gadt_constrs close    { L (comb2 $1 $3) (unLoc $3) }
         | {- empty -}                              { noLoc [] }
 
 gadt_constrs :: { Located [LConDecl RdrName] }
-        : gadt_constr ';' gadt_constrs  { L (comb2 (head $1) $3) ($1 ++ unLoc $3) }
-        | gadt_constr                   { L (getLoc (head $1)) $1 }
+        : gadt_constr ';' gadt_constrs  { sLL $1 $> ($1 : unLoc $3) }
+        | gadt_constr                   { sLL $1 $> [$1] }
         | {- empty -}                   { noLoc [] }
 
 -- We allow the following forms:
@@ -1364,15 +1374,16 @@ gadt_constrs :: { Located [LConDecl RdrName] }
 --      D { x,y :: a } :: T a
 --      forall a. Eq a => D { x,y :: a } :: T a
 
-gadt_constr :: { [LConDecl RdrName] }   -- Returns a list because of:   C,D :: ty
+gadt_constr :: { LConDecl RdrName }
+                                   -- Returns a list because of:   C,D :: ty
         : con_list '::' sigtype
-                { map (sL (comb2 $1 $3)) (mkGadtDecl (unLoc $1) $3) }
+                { sLL $1 $> $ mkGadtDecl (unLoc $1) $3 }
 
                 -- Deprecated syntax for GADT record declarations
         | oqtycon '{' fielddecls '}' '::' sigtype
                 {% do { cd <- mkDeprecatedGadtRecordDecl (comb2 $1 $6) $1 $3 $6
                       ; cd' <- checkRecordSyntax cd
-                      ; return [cd'] } }
+                      ; return cd' } }
 
 constrs :: { Located [LConDecl RdrName] }
         : maybe_docnext '=' constrs1    { L (comb2 $2 $3) (addConDocs (unLoc $3) $1) }
@@ -1406,30 +1417,32 @@ constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) }
         : btype                         {% splitCon $1 >>= return.sLL $1 $> }
         | btype conop btype             {  sLL $1 $> ($2, InfixCon $1 $3) }
 
-fielddecls :: { [ConDeclField RdrName] }
+fielddecls :: { [LConDeclField RdrName] }
         : {- empty -}     { [] }
         | fielddecls1     { $1 }
 
-fielddecls1 :: { [ConDeclField RdrName] }
+fielddecls1 :: { [LConDeclField RdrName] }
         : fielddecl maybe_docnext ',' maybe_docprev fielddecls1
-                      { [ addFieldDoc f $4 | f <- $1 ] ++ addFieldDocs $5 $2 }
-                             -- This adds the doc $4 to each field separately
-        | fielddecl   { $1 }
+            { (addFieldDoc $1 $4) : addFieldDocs $5 $2 }
+        | fielddecl   { [$1] }
 
-fielddecl :: { [ConDeclField RdrName] }    -- A list because of   f,g :: Int
-        : maybe_docnext sig_vars '::' ctype maybe_docprev      { [ ConDeclField fld $4 ($1 `mplus` $5)
-                                                                 | fld <- reverse (unLoc $2) ] }
+fielddecl :: { LConDeclField RdrName }
+                                              -- A list because of   f,g :: Int
+        : maybe_docnext sig_vars '::' ctype maybe_docprev
+                  { L (comb2 $2 $4)
+                      (ConDeclField (reverse (unLoc $2)) $4 ($1 `mplus` $5)) }
 
 -- We allow the odd-looking 'inst_type' in a deriving clause, so that
 -- we can do deriving( forall a. C [a] ) in a newtype (GHC extension).
 -- The 'C [a]' part is converted to an HsPredTy by checkInstType
 -- We don't allow a context, but that's sorted out by the type checker.
-deriving :: { Located (Maybe [LHsType RdrName]) }
-        : {- empty -}                           { noLoc Nothing }
-        | 'deriving' qtycon                     { let { L loc tv = $2 }
-                                                  in sLL $1 $> (Just [L loc (HsTyVar tv)]) }
-        | 'deriving' '(' ')'                    { sLL $1 $> (Just []) }
-        | 'deriving' '(' inst_types1 ')'        { sLL $1 $> (Just $3) }
+deriving :: { Located (Maybe (Located [LHsType RdrName])) }
+        : {- empty -}                       { noLoc Nothing }
+        | 'deriving' qtycon
+                       { let { L loc tv = $2 }
+                         in sLL $1 $>  (Just (sLL $1 $> [L loc (HsTyVar tv)])) }
+        | 'deriving' '(' ')'                { sLL $1 $> (Just (noLoc [])) }
+        | 'deriving' '(' inst_types1 ')'    { sLL $1 $> (Just (sLL $1 $> $3)) }
              -- Glasgow extension: allow partial
              -- applications in derivings
 
@@ -1512,19 +1525,24 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
                         {% do s <- checkValSig $1 $3
                         ; return (sLL $1 $> $ unitOL (sLL $1 $> $ SigD s)) }
         | var ',' sig_vars '::' sigtypedoc
-                                { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (TypeSig ($1 : reverse (unLoc $3)) $5) ] }
-        | infix prec ops        { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
-                                             | n <- unLoc $3 ] }
+                { sLL $1 $> $ toOL [ sLL $1 $> $ SigD
+                              (TypeSig ($1 : reverse (unLoc $3)) $5) ] }
+        | infix prec ops
+                { sLL $1 $> $ toOL [ sLL $1 $> $ SigD
+                      (FixSig (FixitySig (unLoc $3) (Fixity $2 (unLoc $1)))) ] }
+
         | pattern_synonym_sig   { sLL $1 $> $ unitOL $ sLL $1 $> . SigD . unLoc $ $1 }
+
         | '{-# INLINE' activation qvar '#-}'
                 { sLL $1 $> $ unitOL (sLL $1 $> $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) }
         | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
                 { let inl_prag = mkInlinePragma (EmptyInlineSpec, FunLike) $2
-                  in sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 t inl_prag)
-                               | t <- $5] }
+                  in sLL $1 $> $
+                            toOL [ sLL $1 $> $ SigD (SpecSig $3 $5 inl_prag) ] }
+
         | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
-                { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 t (mkInlinePragma (getSPEC_INLINE $1) $2))
-                            | t <- $5] }
+                { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 $5
+                                    (mkInlinePragma (getSPEC_INLINE $1) $2)) ] }
         | '{-# SPECIALISE' 'instance' inst_type '#-}'
                 { sLL $1 $> $ unitOL (sLL $1 $> $ SigD (SpecInstSig $3)) }
         -- A minimal complete definition
@@ -1694,7 +1712,8 @@ aexp2   :: { LHsExpr RdrName }
         | '(' texp ')'                  { sLL $1 $> (HsPar $2) }
         | '(' tup_exprs ')'             { sLL $1 $> (ExplicitTuple $2 Boxed) }
 
-        | '(#' texp '#)'                { sLL $1 $> (ExplicitTuple [Present $2] Unboxed) }
+        | '(#' texp '#)'                { sLL $1 $> (ExplicitTuple [L (getLoc $2)
+                                                       (Present $2)] Unboxed) }
         | '(#' tup_exprs '#)'           { sLL $1 $> (ExplicitTuple $2 Unboxed) }
 
         | '[' list ']'                  { sLL $1 $> (unLoc $2) }
@@ -1773,19 +1792,20 @@ texp :: { LHsExpr RdrName }
         | exp '->' texp   { sLL $1 $> $ EViewPat $1 $3 }
 
 -- Always at least one comma
-tup_exprs :: { [HsTupArg RdrName] }
-           : texp commas_tup_tail  { Present $1 : $2 }
-           | commas tup_tail       { replicate $1 missingTupArg ++ $2 }
+tup_exprs :: { [LHsTupArg RdrName] }
+           : texp commas_tup_tail  { sL1 $1 (Present $1) : $2 }
+           | commas tup_tail       { replicate $1 (noLoc missingTupArg) ++ $2 }
 
 -- Always starts with commas; always follows an expr
-commas_tup_tail :: { [HsTupArg RdrName] }
-commas_tup_tail : commas tup_tail  { replicate ($1-1) missingTupArg ++ $2 }
+commas_tup_tail :: { [LHsTupArg RdrName] }
+commas_tup_tail : commas tup_tail
+                                { replicate ($1-1) (noLoc missingTupArg) ++ $2 }
 
 -- Always follows a comma
-tup_tail :: { [HsTupArg RdrName] }
-          : texp commas_tup_tail        { Present $1 : $2 }
-          | texp                        { [Present $1] }
-          | {- empty -}                 { [missingTupArg] }
+tup_tail :: { [LHsTupArg RdrName] }
+          : texp commas_tup_tail        { sL1 $1 (Present $1) : $2 }
+          | texp                        { [sL1 $1 $ Present $1] }
+          | {- empty -}                 { [noLoc missingTupArg] }
 
 -----------------------------------------------------------------------------
 -- List expressions
@@ -1993,22 +2013,22 @@ qual  :: { LStmt RdrName (LHsExpr RdrName) }
 -----------------------------------------------------------------------------
 -- Record Field Update/Construction
 
-fbinds  :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) }
+fbinds  :: { ([LHsRecField RdrName (LHsExpr RdrName)], Bool) }
         : fbinds1                       { $1 }
         | {- empty -}                   { ([], False) }
 
-fbinds1 :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) }
+fbinds1 :: { ([LHsRecField RdrName (LHsExpr RdrName)], Bool) }
         : fbind ',' fbinds1             { case $3 of (flds, dd) -> ($1 : flds, dd) }
         | fbind                         { ([$1], False) }
         | '..'                          { ([],   True) }
 
-fbind   :: { HsRecField RdrName (LHsExpr RdrName) }
-        : qvar '=' texp { HsRecField $1 $3                False }
+fbind   :: { LHsRecField RdrName (LHsExpr RdrName) }
+        : qvar '=' texp { sLL $1 $> $ HsRecField $1 $3                False }
                         -- RHS is a 'texp', allowing view patterns (Trac #6038)
                         -- and, incidentaly, sections.  Eg
                         -- f (R { x = show -> s }) = ...
 
-        | qvar          { HsRecField $1 placeHolderPunRhs True }
+        | qvar          { sLL $1 $> $ HsRecField $1 placeHolderPunRhs True }
                         -- In the punning case, use a place-holder
                         -- The renamer fills in the final value
 
@@ -2419,7 +2439,7 @@ sL span a = span `seq` a `seq` L span a
 sL0 = L noSrcSpan       -- #define L0   L noSrcSpan
 
 {-# INLINE sL1 #-}
-sL1 x = sL (getLoc x)   -- #define L1   sL (getLoc $1)
+sL1 x = sL (getLoc x)   -- #define sL1   sL (getLoc $1)
 
 {-# INLINE sLL #-}
 sLL x y = sL (comb2 x y) -- #define LL   sL (comb2 $1 $>)
index e57af70..eb15b81 100644 (file)
@@ -121,12 +121,12 @@ mkInstD (L loc d) = L loc (InstD d)
 mkClassDecl :: SrcSpan
             -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
             -> Located [Located (FunDep RdrName)]
-            -> Located (OrdList (LHsDecl RdrName))
+            -> OrdList (LHsDecl RdrName)
             -> P (LTyClDecl RdrName)
 
 mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
-  = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs (unLoc where_cls)
-       ; let cxt = fromMaybe (noLoc []) mcxt
+  = do { let (binds, sigs, ats, at_insts, _, docs) = cvBindsAndSigs where_cls
+             cxt = fromMaybe (noLoc []) mcxt
        ; (cls, tparams) <- checkTyClHdr tycl_hdr
        ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams
        ; at_defs <- mapM (eitherToP . mkATDefault) at_insts
@@ -152,11 +152,11 @@ mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
 
 mkTyData :: SrcSpan
          -> NewOrData
-         -> Maybe CType
+         -> Maybe (Located CType)
          -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
          -> Maybe (LHsKind RdrName)
          -> [LConDecl RdrName]
-         -> Maybe [LHsType RdrName]
+         -> Maybe (Located [LHsType RdrName])
          -> P (LTyClDecl RdrName)
 mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
@@ -167,11 +167,11 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
                                    tcdFVs = placeHolderNames })) }
 
 mkDataDefn :: NewOrData
-           -> Maybe CType
+           -> Maybe (Located CType)
            -> Maybe (LHsContext RdrName)
            -> Maybe (LHsKind RdrName)
            -> [LConDecl RdrName]
-           -> Maybe [LHsType RdrName]
+           -> Maybe (Located [LHsType RdrName])
            -> P (HsDataDefn RdrName)
 mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
   = do { checkDatatypeContext mcxt
@@ -203,11 +203,11 @@ mkTyFamInstEqn lhs rhs
 
 mkDataFamInst :: SrcSpan
          -> NewOrData
-         -> Maybe CType
+         -> Maybe (Located CType)
          -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
          -> Maybe (LHsKind RdrName)
          -> [LConDecl RdrName]
-         -> Maybe [LHsType RdrName]
+         -> Maybe (Located [LHsType RdrName])
          -> P (LInstDecl RdrName)
 mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
@@ -458,7 +458,7 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
 
 mkDeprecatedGadtRecordDecl :: SrcSpan
                            -> Located RdrName
-                           -> [ConDeclField RdrName]
+                           -> [LConDeclField RdrName]
                            -> LHsType RdrName
                            ->  P (LConDecl  RdrName)
 -- This one uses the deprecated syntax
@@ -467,7 +467,7 @@ mkDeprecatedGadtRecordDecl :: SrcSpan
 mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
   = do { data_con <- tyConToDataCon con_loc con
        ; return (L loc (ConDecl { con_old_rec  = True
-                                , con_name     = data_con
+                                , con_names    = [data_con]
                                 , con_explicit = Implicit
                                 , con_qvars    = mkHsQTvs []
                                 , con_cxt      = noLoc []
@@ -481,7 +481,7 @@ mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
 
 mkSimpleConDecl name qvars cxt details
   = ConDecl { con_old_rec  = False
-            , con_name     = name
+            , con_names    = [name]
             , con_explicit = Explicit
             , con_qvars    = mkHsQTvs qvars
             , con_cxt      = cxt
@@ -491,22 +491,22 @@ mkSimpleConDecl name qvars cxt details
 
 mkGadtDecl :: [Located RdrName]
            -> LHsType RdrName     -- Always a HsForAllTy
-           -> [ConDecl RdrName]
+           -> ConDecl RdrName
 -- We allow C,D :: ty
 -- and expand it as if it had been
 --    C :: ty; D :: ty
 -- (Just like type signatures in general.)
 mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
-  = [mk_gadt_con name | name <- names]
+  = mk_gadt_con names
   where
     (details, res_ty)           -- See Note [Sorting out the result type]
       = case tau of
           L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds,  res_ty)
           _other                                    -> (PrefixCon [], tau)
 
-    mk_gadt_con name
+    mk_gadt_con names
        = ConDecl { con_old_rec  = False
-                 , con_name     = name
+                 , con_names    = names
                  , con_explicit = imp
                  , con_qvars    = qvars
                  , con_cxt      = cxt
@@ -726,7 +726,8 @@ checkAPat msg loc e0 = do
                             return (PArrPat ps placeHolderType)
 
    ExplicitTuple es b
-     | all tupArgPresent es  -> do ps <- mapM (checkLPat msg) [e | Present e <- es]
+     | all tupArgPresent es  -> do ps <- mapM (checkLPat msg)
+                                              [e | L _ (Present e) <- es]
                                    return (TuplePat ps b [])
      | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
 
@@ -748,9 +749,10 @@ plus_RDR = mkUnqual varName (fsLit "+") -- Hack
 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
 pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")
 
-checkPatField :: SDoc -> HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
-checkPatField msg fld = do p <- checkLPat msg (hsRecFieldArg fld)
-                           return (fld { hsRecFieldArg = p })
+checkPatField :: SDoc -> LHsRecField RdrName (LHsExpr RdrName)
+              -> P (LHsRecField RdrName (LPat RdrName))
+checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
+                                 return (L l (fld { hsRecFieldArg = p }))
 
 patFail :: SDoc -> SrcSpan -> HsExpr RdrName -> P a
 patFail msg loc e = parseErrorSDoc loc err
@@ -771,12 +773,12 @@ checkValDef msg lhs (Just sig) grhss
         -- x :: ty = rhs  parses as a *pattern* binding
   = checkPatBind msg (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
 
-checkValDef msg lhs opt_sig grhss
+checkValDef msg lhs opt_sig g@(L l grhss)
   = do  { mb_fun <- isFunLhs lhs
         ; case mb_fun of
             Just (fun, is_infix, pats) -> checkFunBind msg (getLoc lhs)
-                                                fun is_infix pats opt_sig grhss
-            Nothing -> checkPatBind msg lhs grhss }
+                                           fun is_infix pats opt_sig (L l grhss)
+            Nothing -> checkPatBind msg lhs g }
 
 checkFunBind :: SDoc
              -> SrcSpan
@@ -1036,7 +1038,7 @@ checkPrecP (L l i)
 mkRecConstrOrUpdate
         :: LHsExpr RdrName
         -> SrcSpan
-        -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
+        -> ([LHsRecField RdrName (LHsExpr RdrName)], Bool)
         -> P (HsExpr RdrName)
 
 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd)
@@ -1045,7 +1047,7 @@ mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd)
 mkRecConstrOrUpdate exp _ (fs,dd)
   = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
 
-mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
+mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
 
@@ -1070,30 +1072,34 @@ mkInlinePragma (inl, match_info) mb_act
 
 -- construct a foreign import declaration
 --
-mkImport :: CCallConv
-         -> Safety
+mkImport :: Located CCallConv
+         -> Located Safety
          -> (Located FastString, Located RdrName, LHsType RdrName)
          -> P (HsDecl RdrName)
-mkImport cconv safety (L loc entity, v, ty)
+mkImport (L lc cconv) (L ls safety) (L loc entity, v, ty)
   | cconv == PrimCallConv                      = do
   let funcTarget = CFunction (StaticTarget entity Nothing True)
-      importSpec = CImport PrimCallConv safety Nothing funcTarget
+      importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget
+                           (L loc entity)
   return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
   | cconv == JavaScriptCallConv = do
   let funcTarget = CFunction (StaticTarget entity Nothing True)
-      importSpec = CImport JavaScriptCallConv safety Nothing funcTarget
+      importSpec = CImport (L lc JavaScriptCallConv) (L ls safety) Nothing
+                           funcTarget (L loc entity)
   return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
   | otherwise = do
-    case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
+    case parseCImport (L lc cconv) (L ls safety) (mkExtName (unLoc v))
+                      (unpackFS entity) (L loc entity) of
       Nothing         -> parseErrorSDoc loc (text "Malformed entity string")
       Just importSpec -> return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
 
 -- the string "foo" is ambigous: either a header or a C identifier.  The
 -- C identifier case comes first in the alternatives below, so we pick
 -- that one.
-parseCImport :: CCallConv -> Safety -> FastString -> String
+parseCImport :: Located CCallConv -> Located Safety -> FastString -> String
+             -> Located FastString
              -> Maybe ForeignImport
-parseCImport cconv safety nm str =
+parseCImport cconv safety nm str sourceText =
  listToMaybe $ map fst $ filter (null.snd) $
      readP_to_S parse str
  where
@@ -1118,7 +1124,7 @@ parseCImport cconv safety nm str =
                        | id_char c -> pfail
                       _            -> return ()
 
-   mk = CImport cconv safety
+   mk h n = CImport cconv safety h n sourceText
 
    hdr_char c = not (isSpace c) -- header files are filenames, which can contain
                                 -- pretty much any char (depending on the platform),
@@ -1128,7 +1134,7 @@ parseCImport cconv safety nm str =
 
    cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
              +++ (do isFun <- case cconv of
-                              CApiConv ->
+                              L _ CApiConv ->
                                   option True
                                          (do token "value"
                                              skipSpaces
@@ -1145,11 +1151,12 @@ parseCImport cconv safety nm str =
 
 -- construct a foreign export declaration
 --
-mkExport :: CCallConv
+mkExport :: Located CCallConv
          -> (Located FastString, Located RdrName, LHsType RdrName)
          -> P (HsDecl RdrName)
-mkExport cconv (L _ entity, v, ty) = return $
-  ForD (ForeignExport v ty noForeignExportCoercionYet (CExport (CExportStatic entity' cconv)))
+mkExport (L lc cconv) (L le entity, v, ty) = return $
+  ForD (ForeignExport v ty noForeignExportCoercionYet
+                   (CExport (L lc (CExportStatic entity' cconv)) (L le entity)))
   where
     entity' | nullFS entity = mkExtName (unLoc v)
             | otherwise     = entity
@@ -1166,16 +1173,16 @@ mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
 --------------------------------------------------------------------------------
 -- Help with module system imports/exports
 
-data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [ RdrName ]
+data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [Located RdrName]
 
-mkModuleImpExp :: RdrName -> ImpExpSubSpec -> IE RdrName
-mkModuleImpExp name subs =
+mkModuleImpExp :: Located RdrName -> ImpExpSubSpec -> IE RdrName
+mkModuleImpExp n@(L l name) subs =
   case subs of
     ImpExpAbs
-      | isVarNameSpace (rdrNameSpace name) -> IEVar       name
+      | isVarNameSpace (rdrNameSpace name) -> IEVar       n
       | otherwise                          -> IEThingAbs  nameT
-    ImpExpAll                              -> IEThingAll  nameT
-    ImpExpList xs                          -> IEThingWith nameT xs
+    ImpExpAll                              -> IEThingAll  (L l nameT)
+    ImpExpList xs                          -> IEThingWith (L l nameT) xs
 
   where
     nameT = setRdrNameSpace name tcClsName
index e0f5d0a..99040e7 100644 (file)
@@ -385,9 +385,13 @@ rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs)
 
 makeMiniFixityEnv :: [LFixitySig RdrName] -> RnM MiniFixityEnv
 
-makeMiniFixityEnv decls = foldlM add_one emptyFsEnv decls
+makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls
  where
-   add_one env (L loc (FixitySig (L name_loc name) fixity)) = do
+   add_one_sig env (L loc (FixitySig names fixity)) =
+     foldlM add_one env [ (loc,name_loc,name,fixity)
+                        | L name_loc name <- names ]
+
+   add_one env (loc, name_loc, name,fixity) = do
      { -- this fixity decl is a duplicate iff
        -- the ReaderName's OccName's FastString is already in the env
        -- (we only need to check the local fix_env because
@@ -821,20 +825,25 @@ renameSig _ (SpecInstSig ty)
 -- so, in the top-level case (when mb_names is Nothing)
 -- we use lookupOccRn.  If there's both an imported and a local 'f'
 -- then the SPECIALISE pragma is ambiguous, unlike all other signatures
-renameSig ctxt sig@(SpecSig v ty inl)
+renameSig ctxt sig@(SpecSig v tys inl)
   = do  { new_v <- case ctxt of
                      TopSigCtxt {} -> lookupLocatedOccRn v
                      _             -> lookupSigOccRn ctxt sig v
-        ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty
+        -- ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty
+        ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys
         ; return (SpecSig new_v new_ty inl, fvs) }
+  where
+    do_one (tys,fvs) ty
+      = do { (new_ty, fvs_ty) <- rnHsSigType (quotes (ppr v)) ty
+           ; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
 
 renameSig ctxt sig@(InlineSig v s)
   = do  { new_v <- lookupSigOccRn ctxt sig v
         ; return (InlineSig new_v s, emptyFVs) }
 
-renameSig ctxt sig@(FixSig (FixitySig v f))
-  = do  { new_v <- lookupSigOccRn ctxt sig v
-        ; return (FixSig (FixitySig new_v f), emptyFVs) }
+renameSig ctxt sig@(FixSig (FixitySig vs f))
+  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
+        ; return (FixSig (FixitySig new_vs f), emptyFVs) }
 
 renameSig ctxt sig@(MinimalSig bf)
   = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
@@ -912,7 +921,7 @@ findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]]
 findDupSigs sigs
   = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)
   where
-    expand_sig sig@(FixSig (FixitySig n _)) = [(n,sig)]
+    expand_sig sig@(FixSig (FixitySig ns _)) = zip ns (repeat sig)
     expand_sig sig@(InlineSig n _)          = [(n,sig)]
     expand_sig sig@(TypeSig  ns _)   = [(n,sig) | n <- ns]
     expand_sig sig@(GenericSig ns _) = [(n,sig) | n <- ns]
index 0a73585..28f54c8 100644 (file)
@@ -1855,7 +1855,7 @@ data HsDocContext
   | TyDataCtx (Located RdrName)
   | TySynCtx (Located RdrName)
   | TyFamilyCtx (Located RdrName)
-  | ConDeclCtx (Located RdrName)
+  | ConDeclCtx [Located RdrName]
   | ClassDeclCtx (Located RdrName)
   | ExprWithTySigCtx
   | TypBrCtx
@@ -1878,7 +1878,12 @@ docOfHsDocContext (RuleCtx name) = text "In the transformation rule" <+> ftext n
 docOfHsDocContext (TyDataCtx tycon) = text "In the data type declaration for" <+> quotes (ppr tycon)
 docOfHsDocContext (TySynCtx name) = text "In the declaration for type synonym" <+> quotes (ppr name)
 docOfHsDocContext (TyFamilyCtx name) = text "In the declaration for type family" <+> quotes (ppr name)
-docOfHsDocContext (ConDeclCtx name) = text "In the definition of data constructor" <+> quotes (ppr name)
+
+docOfHsDocContext (ConDeclCtx [name])
+   = text "In the definition of data constructor" <+> quotes (ppr name)
+docOfHsDocContext (ConDeclCtx names)
+   = text "In the definition of data constructors" <+> interpp'SP names
+
 docOfHsDocContext (ClassDeclCtx name) = text "In the declaration for class"     <+> ppr name
 docOfHsDocContext ExprWithTySigCtx = text "In an expression type signature"
 docOfHsDocContext TypBrCtx = ptext (sLit "In a Template-Haskell quoted type")
index b24956c..98b1358 100644 (file)
@@ -241,8 +241,10 @@ rnExpr (ExplicitTuple tup_args boxity)
        ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
        ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
   where
-    rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
-    rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
+    rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e
+                                    ; return (L l (Present e'), fvs) }
+    rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType)
+                                        , emptyFVs)
 
 rnExpr (RecordCon con_id _ rbinds)
   = do  { conname <- lookupLocatedOccRn con_id
@@ -372,8 +374,8 @@ rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
        ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
                  fvs `plusFV` plusFVs fvss) }
   where
-    rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
-                      ; return (fld { hsRecFieldArg = arg' }, fvs) }
+    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
+                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
 \end{code}
 
 
@@ -1288,7 +1290,7 @@ okPArrStmt dflags _ stmt
        LastStmt {}  -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)
 
 ---------
-checkTupleSection :: [HsTupArg RdrName] -> RnM ()
+checkTupleSection :: [LHsTupArg RdrName] -> RnM ()
 checkTupleSection args
   = do  { tuple_section <- xoptM Opt_TupleSections
         ; checkErr (all tupArgPresent args || tuple_section) msg }
index 51c71b0..c3e8c70 100644 (file)
@@ -227,7 +227,7 @@ rnImportDecl this_mod
 
         -- True <=> import M ()
         import_all = case imp_details of
-                        Just (is_hiding, ls) -> not is_hiding && null ls
+                        Just (is_hiding, L _ ls) -> not is_hiding && null ls
                         _                    -> False
 
         -- should the import be safe?
@@ -613,18 +613,19 @@ Note that the imp_occ_env will have entries for data constructors too,
 although we never look up data constructors.
 
 \begin{code}
-filterImports :: ModIface
-              -> ImpDeclSpec                    -- The span for the entire import decl
-              -> Maybe (Bool, [LIE RdrName])    -- Import spec; True => hiding
-              -> RnM (Maybe (Bool, [LIE Name]), -- Import spec w/ Names
-                      [GlobalRdrElt])           -- Same again, but in GRE form
+filterImports
+    :: ModIface
+    -> ImpDeclSpec                     -- The span for the entire import decl
+    -> Maybe (Bool, Located [LIE RdrName])    -- Import spec; True => hiding
+    -> RnM (Maybe (Bool, Located [LIE Name]), -- Import spec w/ Names
+            [GlobalRdrElt])                   -- Same again, but in GRE form
 filterImports iface decl_spec Nothing
   = return (Nothing, gresFromAvails prov (mi_exports iface))
   where
     prov = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll }]
 
 
-filterImports iface decl_spec (Just (want_hiding, import_items))
+filterImports iface decl_spec (Just (want_hiding, L l import_items))
   = do  -- check for errors, convert RdrNames to Names
         items1 <- mapM lookup_lie import_items
 
@@ -641,7 +642,7 @@ filterImports iface decl_spec (Just (want_hiding, import_items))
             gres | want_hiding = gresFromAvails hiding_prov pruned_avails
                  | otherwise   = concatMap (gresFromIE decl_spec) items2
 
-        return (Just (want_hiding, map fst items2), gres)
+        return (Just (want_hiding, L l (map fst items2)), gres)
   where
     all_avails = mi_exports iface
 
@@ -709,22 +710,23 @@ filterImports iface decl_spec (Just (want_hiding, import_items))
     lookup_ie :: IE RdrName -> IELookupM ([(IE Name, AvailInfo)], [IELookupWarning])
     lookup_ie ie = handle_bad_import $ do
       case ie of
-        IEVar n -> do
+        IEVar (L l n) -> do
             (name, avail, _) <- lookup_name n
-            return ([(IEVar name, trimAvail avail name)], [])
+            return ([(IEVar (L l name), trimAvail avail name)], [])
 
-        IEThingAll tc -> do
+        IEThingAll (L l tc) -> do
             (name, avail@(AvailTC name2 subs), mb_parent) <- lookup_name tc
             let warns | null (drop 1 subs)      = [DodgyImport tc]
                       | not (is_qual decl_spec) = [MissingImportList]
                       | otherwise               = []
             case mb_parent of
               -- non-associated ty/cls
-              Nothing     -> return ([(IEThingAll name, avail)], warns)
+              Nothing     -> return ([(IEThingAll (L l name), avail)], warns)
               -- associated ty
-              Just parent -> return ([(IEThingAll name,
+              Just parent -> return ([(IEThingAll (L l name),
                                        AvailTC name2 (subs \\ [name])),
-                                      (IEThingAll name, AvailTC parent [name])],
+                                      (IEThingAll (L l name),
+                                       AvailTC parent [name])],
                                      warns)
 
         IEThingAbs tc
@@ -741,7 +743,7 @@ filterImports iface decl_spec (Just (want_hiding, import_items))
             -> do nameAvail <- lookup_name tc
                   return ([mkIEThingAbs nameAvail], [])
 
-        IEThingWith rdr_tc rdr_ns -> do
+        IEThingWith (L l rdr_tc) rdr_ns -> do
            (name, AvailTC _ ns, mb_parent) <- lookup_name rdr_tc
 
            -- Look up the children in the sub-names of the parent
@@ -758,13 +760,13 @@ filterImports iface decl_spec (Just (want_hiding, import_items))
 
            case mb_parent of
              -- non-associated ty/cls
-             Nothing     -> return ([(IEThingWith name children,
-                                      AvailTC name (name:children))],
+             Nothing     -> return ([(IEThingWith (L l name) children,
+                                      AvailTC name (name:map unLoc children))],
                                     [])
              -- associated ty
-             Just parent -> return ([(IEThingWith name children,
-                                      AvailTC name children),
-                                     (IEThingWith name children,
+             Just parent -> return ([(IEThingWith (L l name) children,
+                                      AvailTC name (map unLoc children)),
+                                     (IEThingWith (L l name) children,
                                       AvailTC parent [name])],
                                     [])
 
@@ -860,8 +862,8 @@ gresFromIE decl_spec (L loc ie, avail)
   = gresFromAvail prov_fn avail
   where
     is_explicit = case ie of
-                    IEThingAll name -> \n -> n == name
-                    _               -> \_ -> True
+                    IEThingAll (L _ name) -> \n -> n == name
+                    _                     -> \_ -> True
     prov_fn name = Imported [imp_spec]
         where
           imp_spec  = ImpSpec { is_decl = decl_spec, is_item = item_spec }
@@ -876,7 +878,7 @@ mkChildEnv gres = foldr add emptyNameEnv gres
 findChildren :: NameEnv [Name] -> Name -> [Name]
 findChildren env n = lookupNameEnv env n `orElse` []
 
-lookupChildren :: [Name] -> [RdrName] -> [Maybe Name]
+lookupChildren :: [Name] -> [Located RdrName] -> [Maybe (Located Name)]
 -- (lookupChildren all_kids rdr_items) maps each rdr_item to its
 -- corresponding Name all_kids, if the former exists
 -- The matching is done by FastString, not OccName, so that
@@ -885,8 +887,13 @@ lookupChildren :: [Name] -> [RdrName] -> [Maybe Name]
 -- the RdrName for AssocTy may have a (bogus) DataName namespace
 -- (Really the rdr_items should be FastStrings in the first place.)
 lookupChildren all_kids rdr_items
-  = map (lookupFsEnv kid_env . occNameFS . rdrNameOcc) rdr_items
+  -- = map (lookupFsEnv kid_env . occNameFS . rdrNameOcc) rdr_items
+  = map doOne rdr_items
   where
+    doOne (L l r) = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc) r of
+      Just n -> Just (L l n)
+      Nothing -> Nothing
+
     kid_env = mkFsEnv [(occNameFS (nameOccName n), n) | n <- all_kids]
 
 -- | Combines 'AvailInfo's from the same family
@@ -964,7 +971,7 @@ type ExportOccMap = OccEnv (Name, IE RdrName)
         --   that have the same occurrence name
 
 rnExports :: Bool       -- False => no 'module M(..) where' header at all
-          -> Maybe [LIE RdrName]        -- Nothing => no explicit export list
+          -> Maybe (Located [LIE RdrName]) -- Nothing => no explicit export list
           -> TcGblEnv
           -> RnM TcGblEnv
 
@@ -991,7 +998,8 @@ rnExports explicit_mod exports
         ; let real_exports
                  | explicit_mod = exports
                  | ghcLink dflags == LinkInMemory = Nothing
-                 | otherwise = Just [noLoc (IEVar main_RDR_Unqual)]
+                 | otherwise
+                          = Just (noLoc [noLoc (IEVar (noLoc main_RDR_Unqual))])
                         -- ToDo: the 'noLoc' here is unhelpful if 'main'
                         --       turns out to be out of scope
 
@@ -1007,7 +1015,7 @@ rnExports explicit_mod exports
                             tcg_dus = tcg_dus tcg_env `plusDU`
                                       usesOnly (availsToNameSet final_avails) }) }
 
-exports_from_avail :: Maybe [LIE RdrName]
+exports_from_avail :: Maybe (Located [LIE RdrName])
                          -- Nothing => no explicit export list
                    -> GlobalRdrEnv
                    -> ImportAvails
@@ -1024,9 +1032,8 @@ exports_from_avail Nothing rdr_env _imports _this_mod
    in
    return (Nothing, avails)
 
-exports_from_avail (Just rdr_items) rdr_env imports this_mod
+exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
   = do (ie_names, _, exports) <- foldlM do_litem emptyExportAccum rdr_items
-
        return (Just ie_names, exports)
   where
     do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum
@@ -1041,8 +1048,9 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
 
     exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum
     exports_from_item acc@(ie_names, occs, exports)
-                      (L loc (IEModuleContents mod))
-        | let earlier_mods = [ mod | (L _ (IEModuleContents mod)) <- ie_names ]
+                      (L loc (IEModuleContents (L lm mod)))
+        | let earlier_mods = [ mod
+                             | (L _ (IEModuleContents (L _ mod))) <- ie_names ]
         , mod `elem` earlier_mods    -- Duplicate export of M
         = do { warn_dup_exports <- woptM Opt_WarnDuplicateExports ;
                warnIf warn_dup_exports (dupModuleExport mod) ;
@@ -1067,7 +1075,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
                         -- The qualified and unqualified version of all of
                         -- these names are, in effect, used by this export
 
-             ; occs' <- check_occs (IEModuleContents mod) occs names
+             ; occs' <- check_occs (IEModuleContents (noLoc mod)) occs names
                       -- This check_occs not only finds conflicts
                       -- between this item and others, but also
                       -- internally within this item.  That is, if
@@ -1076,7 +1084,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
                       -- OccName.
              ; traceRn (vcat [ text "export mod" <+> ppr mod
                              , ppr new_exports ])
-             ; return (L loc (IEModuleContents mod) : ie_names,
+             ; return (L loc (IEModuleContents (L lm mod)) : ie_names,
                        occs', new_exports ++ exports) }
 
     exports_from_item acc@(lie_names, occs, exports) (L loc ie)
@@ -1096,9 +1104,9 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
 
     -------------
     lookup_ie :: IE RdrName -> RnM (IE Name, AvailInfo)
-    lookup_ie (IEVar rdr)
+    lookup_ie (IEVar (L l rdr))
         = do gre <- lookupGreRn rdr
-             return (IEVar (gre_name gre), greExportAvail gre)
+             return (IEVar (L l (gre_name gre)), greExportAvail gre)
 
     lookup_ie (IEThingAbs rdr)
         = do gre <- lookupGreRn rdr
@@ -1106,7 +1114,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
                  avail = greExportAvail gre
              return (IEThingAbs name, avail)
 
-    lookup_ie ie@(IEThingAll rdr)
+    lookup_ie ie@(IEThingAll (L l rdr))
         = do name <- lookupGlobalOccRn rdr
              let kids = findChildren kids_env name
              addUsedKids rdr kids
@@ -1118,20 +1126,21 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
                        -- only import T abstractly, or T is a synonym.
                        addErr (exportItemErr ie)
 
-             return (IEThingAll name, AvailTC name (name:kids))
+             return (IEThingAll (L l name), AvailTC name (name:kids))
 
-    lookup_ie ie@(IEThingWith rdr sub_rdrs)
+    lookup_ie ie@(IEThingWith (L l rdr) sub_rdrs)
         = do name <- lookupGlobalOccRn rdr
              if isUnboundName name
-                then return (IEThingWith name [], AvailTC name [name])
+                then return (IEThingWith (L l name) [], AvailTC name [name])
                 else do
              let mb_names = lookupChildren (findChildren kids_env name) sub_rdrs
              if any isNothing mb_names
                 then do addErr (exportItemErr ie)
-                        return (IEThingWith name [], AvailTC name [name])
+                        return (IEThingWith (L l name) [], AvailTC name [name])
                 else do let names = catMaybes mb_names
-                        addUsedKids rdr names
-                        return (IEThingWith name names, AvailTC name (name:names))
+                        addUsedKids rdr (map unLoc names)
+                        return (IEThingWith (L l name) names
+                               , AvailTC name (name:map unLoc names))
 
     lookup_ie _ = panic "lookup_ie"    -- Other cases covered earlier
 
@@ -1238,7 +1247,7 @@ dupExport_ok n ie1 ie2
         || (explicit_in ie1 && explicit_in ie2) )
   where
     explicit_in (IEModuleContents _) = False                -- module M
-    explicit_in (IEThingAll r) = nameOccName n == rdrNameOcc r  -- T(..)
+    explicit_in (IEThingAll r) = nameOccName n == rdrNameOcc (unLoc r)  -- T(..)
     explicit_in _              = True
 
     single (IEVar {})      = True
@@ -1254,7 +1263,7 @@ dupExport_ok n ie1 ie2
 %*********************************************************
 
 \begin{code}
-reportUnusedNames :: Maybe [LIE RdrName]    -- Export list
+reportUnusedNames :: Maybe (Located [LIE RdrName])  -- Export list
                   -> TcGblEnv -> RnM ()
 reportUnusedNames _export_decls gbl_env
   = do  { traceRn ((text "RUN") <+> (ppr (tcg_dus gbl_env)))
@@ -1381,15 +1390,17 @@ findImportUsage imports rdr_env rdrs
 
         unused_imps   -- Not trivial; see eg Trac #7454
           = case imps of
-              Just (False, imp_ies) -> foldr (add_unused . unLoc) emptyNameSet imp_ies
+              Just (False, L _ imp_ies) ->
+                                 foldr (add_unused . unLoc) emptyNameSet imp_ies
               _other -> emptyNameSet -- No explicit import list => no unused-name list
 
         add_unused :: IE Name -> NameSet -> NameSet
-        add_unused (IEVar n)          acc = add_unused_name n acc
-        add_unused (IEThingAbs n)     acc = add_unused_name n acc
-        add_unused (IEThingAll n)     acc = add_unused_all  n acc
-        add_unused (IEThingWith p ns) acc = add_unused_with p ns acc
-        add_unused _                  acc = acc
+        add_unused (IEVar (L _ n))      acc = add_unused_name n acc
+        add_unused (IEThingAbs n)       acc = add_unused_name n acc
+        add_unused (IEThingAll (L _ n)) acc = add_unused_all  n acc
+        add_unused (IEThingWith (L _ p) ns) acc
+                                          = add_unused_with p (map unLoc ns) acc
+        add_unused _                    acc = acc
 
         add_unused_name n acc
           | n `elemNameSet` used_names = acc
@@ -1447,10 +1458,10 @@ extendImportMap rdr_env rdr imp_map
 \begin{code}
 warnUnusedImport :: ImportDeclUsage -> RnM ()
 warnUnusedImport (L loc decl, used, unused)
-  | Just (False,[]) <- ideclHiding decl
+  | Just (False,L _ []) <- ideclHiding decl
                 = return ()            -- Do not warn for 'import M()'
 
-  | Just (True, hides) <- ideclHiding decl
+  | Just (True, L _ hides) <- ideclHiding decl
   , not (null hides)
   , pRELUDE_NAME == unLoc (ideclName decl)
                 = return ()            -- Note [Do not warn about Prelude hiding]
@@ -1527,7 +1538,7 @@ printMinimalImports imports_w_usage
                             , ideclPkgQual = mb_pkg } = decl
            ; iface <- loadSrcInterface doc mod_name is_boot mb_pkg
            ; let lies = map (L l) (concatMap (to_ie iface) used)
-           ; return (L l (decl { ideclHiding = Just (False, lies) })) }
+           ; return (L l (decl { ideclHiding = Just (False, L l lies) })) }
       where
         doc = text "Compute minimal imports for" <+> ppr decl
 
@@ -1536,7 +1547,7 @@ printMinimalImports imports_w_usage
     -- we want to say "T(..)", but if we're importing only a subset we want
     -- to say "T(A,B,C)".  So we have to find out what the module exports.
     to_ie _ (Avail n)
-       = [IEVar n]
+       = [IEVar (noLoc n)]
     to_ie _ (AvailTC n [m])
        | n==m = [IEThingAbs n]
     to_ie iface (AvailTC n ns)
@@ -1544,9 +1555,10 @@ printMinimalImports imports_w_usage
                  , x == n
                  , x `elem` xs    -- Note [Partial export]
                  ] of
-           [xs] | all_used xs -> [IEThingAll n]
-                | otherwise   -> [IEThingWith n (filter (/= n) ns)]
-           _other             -> map IEVar ns
+           [xs] | all_used xs -> [IEThingAll (noLoc n)]
+                | otherwise   -> [IEThingWith (noLoc n)
+                                              (map noLoc (filter (/= n) ns))]
+           _other             -> map (IEVar . noLoc)  ns
         where
           all_used avail_occs = all (`elem` ns) avail_occs
 \end{code}
@@ -1640,7 +1652,8 @@ dodgyExportWarn item = dodgyMsg (ptext (sLit "export")) item
 
 dodgyMsg :: (OutputableBndr n, HasOccName n) => SDoc -> n -> SDoc
 dodgyMsg kind tc
-  = sep [ ptext (sLit "The") <+> kind <+> ptext (sLit "item") <+> quotes (ppr (IEThingAll tc))
+  = sep [ ptext (sLit "The") <+> kind <+> ptext (sLit "item")
+                             <+> quotes (ppr (IEThingAll (noLoc tc)))
                 <+> ptext (sLit "suggests that"),
           quotes (ppr tc) <+> ptext (sLit "has (in-scope) constructors or class methods,"),
           ptext (sLit "but it has none") ]
index d80b05e..4b9fe62 100644 (file)
@@ -491,9 +491,9 @@ rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd })
        ; flds' <- mapM rn_field (flds `zip` [1..])
        ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
   where 
-    rn_field (fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n') 
-                                                    (hsRecFieldArg fld)
-                            ; return (fld { hsRecFieldArg = arg' }) }
+    rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n')
+                                                        (hsRecFieldArg fld)
+                                ; return (L l (fld { hsRecFieldArg = arg' })) }
 
         -- Suppress unused-match reporting for fields introduced by ".."
     nested_mk Nothing  mk                    _  = mk
@@ -519,7 +519,7 @@ rnHsRecFields
        HsRecFieldContext
     -> (RdrName -> arg) -- When punning, use this to build a new field
     -> HsRecFields RdrName (Located arg)
-    -> RnM ([HsRecField Name (Located arg)], FreeVars)
+    -> RnM ([LHsRecField Name (Located arg)], FreeVars)
 
 -- This surprisingly complicated pass
 --   a) looks up the field name (possibly using disambiguation)
@@ -560,23 +560,23 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
             Nothing  -> ptext (sLit "constructor field name")
             Just con -> ptext (sLit "field of constructor") <+> quotes (ppr con)
 
-    rn_fld pun_ok parent (HsRecField { hsRecFieldId = fld
-                                     , hsRecFieldArg = arg
-                                     , hsRecPun = pun })
+    rn_fld pun_ok parent (L l (HsRecField { hsRecFieldId = fld
+                                          , hsRecFieldArg = arg
+                                          , hsRecPun = pun }))
       = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndrOcc True parent doc) fld
            ; arg' <- if pun 
                      then do { checkErr pun_ok (badPun fld)
                              ; return (L loc (mk_arg (mkRdrUnqual (nameOccName fld_nm)))) }
                      else return arg
-           ; return (HsRecField { hsRecFieldId = fld'
-                                , hsRecFieldArg = arg'
-                                , hsRecPun = pun }) }
+           ; return (L l (HsRecField { hsRecFieldId = fld'
+                                     , hsRecFieldArg = arg'
+                                     , hsRecPun = pun })) }
 
     rn_dotdot :: Maybe Int      -- See Note [DotDot fields] in HsPat
               -> Maybe Name     -- The constructor (Nothing for an update
                                 --    or out of scope constructor)
-              -> [HsRecField Name (Located arg)]   -- Explicit fields
-              -> RnM [HsRecField Name (Located arg)]   -- Filled in .. fields
+              -> [LHsRecField Name (Located arg)] -- Explicit fields
+              -> RnM [LHsRecField Name (Located arg)]   -- Filled in .. fields
     rn_dotdot Nothing _mb_con _flds     -- No ".." at all
       = return []
     rn_dotdot (Just {}) Nothing _flds   -- ".." on record update
@@ -619,10 +619,10 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                                     _other           -> True ] 
 
            ; addUsedRdrNames (map greRdrName dot_dot_gres)
-           ; return [ HsRecField
+           ; return [ L loc (HsRecField
                         { hsRecFieldId  = L loc fld
                         , hsRecFieldArg = L loc (mk_arg arg_rdr)
-                        , hsRecPun      = False }
+                        , hsRecPun      = False })
                     | gre <- dot_dot_gres
                     , let fld     = gre_name gre
                           arg_rdr = mkRdrUnqual (nameOccName fld) ] }
@@ -654,8 +654,8 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
         -- Each list in dup_fields is non-empty
     (_, dup_flds) = removeDups compare (getFieldIds flds)
 
-getFieldIds :: [HsRecField id arg] -> [id]
-getFieldIds flds = map (unLoc . hsRecFieldId) flds
+getFieldIds :: [LHsRecField id arg] -> [id]
+getFieldIds flds = map (unLoc . hsRecFieldId . unLoc) flds
 
 needFlagDotDot :: HsRecFieldContext -> SDoc
 needFlagDotDot ctxt = vcat [ptext (sLit "Illegal `..' in record") <+> pprRFC ctxt,
index 8b8eff3..80db79a 100644 (file)
@@ -273,12 +273,17 @@ rnSrcFixityDecls bndr_set fix_decls
         -- for con-like things; hence returning a list
         -- If neither are in scope, report an error; otherwise
         -- return a fixity sig for each (slightly odd)
-    rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
+    rn_decl (L loc (FixitySig fnames fixity))
+      = do names <- mapM lookup_one fnames
+           return [ L loc (FixitySig name fixity)
+                  | name <- names ]
+
+    lookup_one :: Located RdrName -> RnM [Located Name]
+    lookup_one (L name_loc rdr_name)
       = setSrcSpan name_loc $
                     -- this lookup will fail if the definition isn't local
         do names <- lookupLocalTcNames sig_ctxt what rdr_name
-           return [ L loc (FixitySig (L name_loc name) fixity)
-                  | name <- names ]
+           return [ L name_loc name | name <- names ]
     what = ptext (sLit "fixity signature")
 \end{code}
 
@@ -405,8 +410,8 @@ rnHsForeignDecl (ForeignExport name ty _ spec)
 --      know where they're from.
 --
 patchForeignImport :: PackageKey -> ForeignImport -> ForeignImport
-patchForeignImport packageKey (CImport cconv safety fs spec)
-        = CImport cconv safety fs (patchCImportSpec packageKey spec)
+patchForeignImport packageKey (CImport cconv safety fs spec src)
+        = CImport cconv safety fs (patchCImportSpec packageKey spec) src
 
 patchCImportSpec :: PackageKey -> CImportSpec -> CImportSpec
 patchCImportSpec packageKey spec
@@ -683,18 +688,18 @@ rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
        ; checkDupRdrNames rdr_names_w_loc
        ; checkShadowedRdrNames rdr_names_w_loc
        ; names <- newLocalBndrsRn rdr_names_w_loc
-       ; bindHsRuleVars rule_name vars names $ \ vars' ->
+       ; bindHsRuleVars (unLoc rule_name) vars names $ \ vars' ->
     do { (lhs', fv_lhs') <- rnLExpr lhs
        ; (rhs', fv_rhs') <- rnLExpr rhs
-       ; checkValidRule rule_name names lhs' fv_lhs'
+       ; checkValidRule (unLoc rule_name) names lhs' fv_lhs'
        ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
                  fv_lhs' `plusFV` fv_rhs') } }
   where
-    get_var (RuleBndrSig v _) = v
-    get_var (RuleBndr v) = v
+    get_var (L _ (RuleBndrSig v _)) = v
+    get_var (L _ (RuleBndr v)) = v
 
-bindHsRuleVars :: RuleName -> [RuleBndr RdrName] -> [Name]
-               -> ([RuleBndr Name] -> RnM (a, FreeVars))
+bindHsRuleVars :: RuleName -> [LRuleBndr RdrName] -> [Name]
+               -> ([LRuleBndr Name] -> RnM (a, FreeVars))
                -> RnM (a, FreeVars)
 bindHsRuleVars rule_name vars names thing_inside
   = go vars names $ \ vars' ->
@@ -702,14 +707,14 @@ bindHsRuleVars rule_name vars names thing_inside
   where
     doc = RuleCtx rule_name
 
-    go (RuleBndr (L loc _) : vars) (n : ns) thing_inside
+    go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside
       = go vars ns $ \ vars' ->
-        thing_inside (RuleBndr (L loc n) : vars')
+        thing_inside (L l (RuleBndr (L loc n)) : vars')
 
-    go (RuleBndrSig (L loc _) bsig : vars) (n : ns) thing_inside
+    go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside
       = rnHsBndrSig doc bsig $ \ bsig' ->
         go vars ns $ \ vars' ->
-        thing_inside (RuleBndrSig (L loc n) bsig' : vars')
+        thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars')
 
     go [] [] thing_inside = thing_inside []
     go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
@@ -1106,8 +1111,7 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
         -- data T a where { T1 :: forall b. b-> b }
         ; let { zap_lcl_env | h98_style = \ thing -> thing
                             | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
-        ; (condecls', con_fvs) <- zap_lcl_env $
-                                  rnConDecls condecls
+        ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls
            -- No need to check for duplicate constructor decls
            -- since that is done by RnNames.extendGlobalRdrEnvRn
 
@@ -1115,17 +1119,18 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
                         con_fvs `plusFV` sig_fvs
         ; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
                               , dd_ctxt = context', dd_kindSig = sig'
-                              , dd_cons = condecls', dd_derivs = derivs' }
+                              , dd_cons = condecls'
+                              , dd_derivs = derivs' }
                  , all_fvs )
         }
   where
-    h98_style = case condecls of         -- Note [Stupid theta]
+    h98_style = case condecls of  -- Note [Stupid theta]
                      L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
                      _                                             -> True
 
     rn_derivs Nothing   = return (Nothing, emptyFVs)
-    rn_derivs (Just ds) = do { (ds', fvs) <- rnLHsTypes doc ds
-                             ; return (Just ds', fvs) }
+    rn_derivs (Just (L ld ds)) = do { (ds', fvs) <- rnLHsTypes doc ds
+                                    ; return (Just (L ld ds'), fvs) }
 
 badGadtStupidTheta :: HsDocContext -> SDoc
 badGadtStupidTheta _
@@ -1187,18 +1192,18 @@ depAnalTyClDecls ds_w_fvs
 
     assoc_env :: NameEnv Name   -- Maps a data constructor back
                                 -- to its parent type constructor
-    assoc_env = mkNameEnv assoc_env_list
+    assoc_env = mkNameEnv $ concat assoc_env_list
     assoc_env_list = do
       (L _ d, _) <- ds_w_fvs
       case d of
         ClassDecl { tcdLName = L _ cls_name
                   , tcdATs = ats }
           -> do L _ (FamilyDecl { fdLName = L _ fam_name }) <- ats
-                return (fam_name, cls_name)
+                return [(fam_name, cls_name)]
         DataDecl { tcdLName = L _ data_name
                  , tcdDataDefn = HsDataDefn { dd_cons = cons } }
           -> do L _ dc <- cons
-                return (unLoc (con_name dc), data_name)
+                return $ zip (map unLoc $ con_names dc) (repeat data_name)
         _ -> []
 \end{code}
 
@@ -1265,13 +1270,13 @@ rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
 
 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
-rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
+rnConDecl decl@(ConDecl { con_names = names, con_qvars = tvs
                         , con_cxt = lcxt@(L loc cxt), con_details = details
                         , con_res = res_ty, con_doc = mb_doc
                         , con_old_rec = old_rec, con_explicit = expl })
-  = do  { addLocM checkConName name
+  = do  { mapM_ (addLocM checkConName) names
         ; when old_rec (addWarn (deprecRecSyntax decl))
-        ; new_name <- lookupLocatedTopBndrRn name
+        ; new_names <- mapM lookupLocatedTopBndrRn names
 
            -- For H98 syntax, the tvs are the existential ones
            -- For GADT syntax, the tvs are all the quantified tyvars
@@ -1299,21 +1304,23 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
         ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do
         { (new_context, fvs1) <- rnContext doc lcxt
         ; (new_details, fvs2) <- rnConDeclDetails doc details
-        ; (new_details', new_res_ty, fvs3) <- rnConResult doc (unLoc new_name) new_details res_ty
-        ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context
-                       , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' },
+        ; (new_details', new_res_ty, fvs3)
+                     <- rnConResult doc (map unLoc new_names) new_details res_ty
+        ; return (decl { con_names = new_names, con_qvars = new_tyvars
+                       , con_cxt = new_context, con_details = new_details'
+                       , con_res = new_res_ty, con_doc = mb_doc' },
                   fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
  where
-    doc = ConDeclCtx name
+    doc = ConDeclCtx names
     get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
 
-rnConResult :: HsDocContext -> Name
-            -> HsConDetails (LHsType Name) [ConDeclField Name]
+rnConResult :: HsDocContext -> [Name]
+            -> HsConDetails (LHsType Name) [LConDeclField Name]
             -> ResType (LHsType RdrName)
-            -> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
+            -> RnM (HsConDetails (LHsType Name) [LConDeclField Name],
                     ResType (LHsType Name), FreeVars)
 rnConResult _   _   details ResTyH98 = return (details, ResTyH98, emptyFVs)
-rnConResult doc con details (ResTyGADT ty)
+rnConResult doc _con details (ResTyGADT ty)
   = do { (ty', fvs) <- rnLHsType doc ty
        ; let (arg_tys, res_ty) = splitHsFunType ty'
                 -- We can finally split it up,
@@ -1328,19 +1335,12 @@ rnConResult doc con details (ResTyGADT ty)
                                        (addErr (badRecResTy (docOfHsDocContext doc)))
                               ; return (details, ResTyGADT res_ty, fvs) }
 
-           PrefixCon {} | isSymOcc (getOccName con)  -- See Note [Infix GADT cons]
-                        , [ty1,ty2] <- arg_tys
-                        -> do { fix_env <- getFixityEnv
-                              ; return (if   con `elemNameEnv` fix_env
-                                        then InfixCon ty1 ty2
-                                        else PrefixCon arg_tys
-                                       , ResTyGADT res_ty, fvs) }
-                        | otherwise
-                        -> return (PrefixCon arg_tys, ResTyGADT res_ty, fvs) }
-
-rnConDeclDetails :: HsDocContext
-                 -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
-                 -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], FreeVars)
+           PrefixCon {} -> return (PrefixCon arg_tys, ResTyGADT res_ty, fvs) }
+
+rnConDeclDetails
+    :: HsDocContext
+    -> HsConDetails (LHsType RdrName) [LConDeclField RdrName]
+    -> RnM (HsConDetails (LHsType Name) [LConDeclField Name], FreeVars)
 rnConDeclDetails doc (PrefixCon tys)
   = do { (new_tys, fvs) <- rnLHsTypes doc tys
        ; return (PrefixCon new_tys, fvs) }
@@ -1359,7 +1359,7 @@ rnConDeclDetails doc (RecCon fields)
 -------------------------------------------------
 deprecRecSyntax :: ConDecl RdrName -> SDoc
 deprecRecSyntax decl
-  = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
+  = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_names decl))
                  <+> ptext (sLit "uses deprecated syntax")
          , ptext (sLit "Instead, use the form")
          , nest 2 (ppr decl) ]   -- Pretty printer uses new form
@@ -1368,19 +1368,6 @@ badRecResTy :: SDoc -> SDoc
 badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
 \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
-
 %*********************************************************
 %*                                                      *
 \subsection{Support code for type/data declarations}
@@ -1408,14 +1395,17 @@ extendRecordFieldEnv tycl_decls inst_decls
     all_data_cons :: [ConDecl RdrName]
     all_data_cons = [con | HsDataDefn { dd_cons = cons } <- all_ty_defs
                          , L _ con <- cons ]
-    all_ty_defs = [ defn | L _ (DataDecl { tcdDataDefn = defn }) <- tyClGroupConcat tycl_decls ]
-               ++ map dfid_defn (instDeclDataFamInsts inst_decls)  -- Do not forget associated types!
+    all_ty_defs = [ defn | L _ (DataDecl { tcdDataDefn = defn })
+                                                 <- tyClGroupConcat tycl_decls ]
+               ++ map dfid_defn (instDeclDataFamInsts inst_decls)
+                                              -- Do not forget associated types!
 
-    get_con (ConDecl { con_name = con, con_details = RecCon flds })
+    get_con (ConDecl { con_names = cons, con_details = RecCon flds })
             (RecFields env fld_set)
-        = do { con' <- lookup con
-             ; flds' <- mapM lookup (map cd_fld_name flds)
-             ; let env'    = extendNameEnv env con' flds'
+        = do { cons' <- mapM lookup cons
+             ; flds' <- mapM lookup (concatMap (cd_fld_names . unLoc) flds)
+             ; let env'    = foldl (\e c -> extendNameEnv e c flds') env cons'
+
                    fld_set' = addListToNameSet fld_set flds'
              ; return $ (RecFields env' fld_set') }
     get_con _ env = return env
index 38985a4..c3692d3 100644 (file)
@@ -536,16 +536,17 @@ but it seems tiresome to do so.
 %*********************************************************
 
 \begin{code}
-rnConDeclFields :: HsDocContext -> [ConDeclField RdrName]
-                -> RnM ([ConDeclField Name], FreeVars)
+rnConDeclFields :: HsDocContext -> [LConDeclField RdrName]
+                -> RnM ([LConDeclField Name], FreeVars)
 rnConDeclFields doc fields = mapFvRn (rnField doc) fields
 
-rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name, FreeVars)
-rnField doc (ConDeclField name ty haddock_doc)
-  = do { new_name <- lookupLocatedTopBndrRn name
+rnField :: HsDocContext -> LConDeclField RdrName
+        -> RnM (LConDeclField Name, FreeVars)
+rnField doc (L l (ConDeclField names ty haddock_doc))
+  = do { new_names <- mapM lookupLocatedTopBndrRn names
        ; (new_ty, fvs) <- rnLHsType doc ty
        ; new_haddock_doc <- rnMbLHsDoc haddock_doc
-       ; return (ConDeclField new_name new_ty new_haddock_doc, fvs) }
+       ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
 
 rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
 rnContext doc (L loc cxt)
@@ -958,7 +959,7 @@ extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
                                     , dd_cons = cons, dd_derivs = derivs })
   = fst $ extract_lctxt ctxt $
           extract_mb extract_lkind ksig $
-          extract_mb extract_ltys derivs $
+          extract_mb (extract_ltys . unLoc) derivs $
           foldr (extract_con . unLoc) ([],[]) cons
   where
     extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc
@@ -989,7 +990,8 @@ extract_lty (L _ ty) acc
   = case ty of
       HsTyVar tv                -> extract_tv tv acc
       HsBangTy _ ty             -> extract_lty ty acc
-      HsRecTy flds              -> foldr (extract_lty . cd_fld_type) acc flds
+      HsRecTy flds              -> foldr (extract_lty . cd_fld_type . unLoc) acc
+                                         flds
       HsAppTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
       HsListTy ty               -> extract_lty ty acc
       HsPArrTy ty               -> extract_lty ty acc
index 00f9f62..acd469e 100644 (file)
@@ -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))
index b561653..dd746a5 100644 (file)
@@ -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,
index 1a2deba..d8db986 100644 (file)
@@ -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 }
index 9d1da3f..73b3b1c 100644 (file)
@@ -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.
index d5dfd8e..0265dec 100644 (file)
@@ -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
index 215aa2d..033ee0e 100644 (file)
@@ -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
index cfa995d..b7f8d2e 100644 (file)
@@ -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
index 0796472..23262f3 100644 (file)
@@ -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}
index d2bfd25..c2eabbf 100644 (file)
@@ -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]
index f1d528f..cd4776f 100644 (file)
@@ -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
index f5f19bd..1cffcf0 100644 (file)
@@ -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)
 
index ea53b31..1e85a73 100644 (file)
@@ -1,4 +1,6 @@
 {-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
+{-# LANGUAGE FlexibleInstances #-}
+
 {-# OPTIONS_GHC -O -funbox-strict-fields #-}
 -- We always optimise this, otherwise performance of a non-optimised
 -- compiler is severely affected
@@ -67,6 +69,7 @@ import UniqFM
 import FastMutInt
 import Fingerprint
 import BasicTypes
+import SrcLoc
 
 import Foreign
 import Data.Array
@@ -892,3 +895,38 @@ instance Binary WarningTxt where
               _ -> do d <- get bh
                       return (DeprecatedTxt d)
 
+instance Binary a => Binary (GenLocated SrcSpan a) where
+    put_ bh (L l x) = do
+            put_ bh l
+            put_ bh x
+
+    get bh = do
+            l <- get bh
+            x <- get bh
+            return (L l x)
+
+instance Binary SrcSpan where
+  put_ bh (RealSrcSpan ss) = do
+          putByte bh 0
+          put_ bh (srcSpanFile ss)
+          put_ bh (srcSpanStartLine ss)
+          put_ bh (srcSpanStartCol ss)
+          put_ bh (srcSpanEndLine ss)
+          put_ bh (srcSpanEndCol ss)
+
+  put_ bh (UnhelpfulSpan s) = do
+          putByte bh 1
+          put_ bh s
+
+  get bh = do
+          h <- getByte bh
+          case h of
+            0 -> do f <- get bh
+                    sl <- get bh
+                    sc <- get bh
+                    el <- get bh
+                    ec <- get bh
+                    return (mkSrcSpan (mkSrcLoc f sl sc)
+                                      (mkSrcLoc f el ec))
+            _ -> do s <- get bh
+                    return (UnhelpfulSpan s)
index 1d45048..03a6790 100644 (file)
@@ -1948,9 +1948,10 @@ iiSubsumes (IIDecl d1) (IIDecl d2)      -- A bit crude
      && (not (ideclQualified d1) || ideclQualified d2)
      && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)
   where
-     _                `hidingSubsumes` Just (False,[]) = True
-     Just (False, xs) `hidingSubsumes` Just (False,ys) = all (`elem` xs) ys
-     h1               `hidingSubsumes` h2              = h1 == h2
+     _                    `hidingSubsumes` Just (False,L _ []) = True
+     Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)
+                                                           = all (`elem` xs) ys
+     h1                   `hidingSubsumes` h2              = h1 == h2
 iiSubsumes _ _ = False
 
 
index 7ce82d0..cde205a 100644 (file)
@@ -110,13 +110,11 @@ data R
   =  This is the 'C1' record constructor, with the following fields:
     C1 {p :: Int  This comment applies to the 'p' field,
         q :: forall a. a -> a  This comment applies to the 'q' field,
-        r :: Int  This comment applies to both 'r' and 's',
-        s :: Int  This comment applies to both 'r' and 's'} |
+        r, s :: Int  This comment applies to both 'r' and 's'} |
      This is the 'C2' record constructor, also with some fields:
     C2 {t :: T1
              -> (T2 Int Int) -> (T3 Bool Bool) -> (T4 Float Float) -> T5 () (),
-        u :: Int,
-        v :: Int}
+        u, v :: Int}
 <document comment>
 data R1
   =  This is the 'C3' record constructor
index 4a094f5..a377953 100644 (file)
@@ -307,7 +307,7 @@ boundThings modname lbinding =
                _ -> error "boundThings"
         conArgs (PrefixCon ps) tl = foldr patThings tl ps
         conArgs (RecCon (HsRecFields { rec_flds = flds })) tl
-             = foldr (\f tl' -> patThings (hsRecFieldArg f) tl') tl flds
+             = foldr (\(L _ f) tl' -> patThings (hsRecFieldArg f) tl') tl flds
         conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl
 
 
index 2b3712d..5d8117d 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 2b3712d701c1df626abbc60525c35e735272e45d
+Subproject commit 5d8117d8f1f910c85d36865d646b65510b23583d