API Annotations tweaks.
authorAlan Zimmerman <alan.zimm@gmail.com>
Thu, 15 Jan 2015 19:11:21 +0000 (13:11 -0600)
committerAustin Seipp <austin@well-typed.com>
Fri, 16 Jan 2015 16:16:05 +0000 (10:16 -0600)
Summary:
HsTyLit now has SourceText

Update documentation of HsSyn to reflect which annotations are attached to which element.

Ensure that the parser always keeps HsSCC and HsTickPragma values, to
be ignored in the desugar phase if not needed

Bringing in SourceText for pragmas

Add Location in NPlusKPat

Add Location in FunDep

Make RecCon payload Located

Explicitly add AnnVal to RdrName where it is compound

Add Location in IPBind

Add Location to name in IEThingAbs

Add Maybe (Located id,Bool) to Match to track fun_id,infix
  This includes converting Match into a record and adding a note about why
  the fun_id needs to be replicated in the Match.

Add Location in KindedTyVar

Sort out semi-colons for parsing

  - import statements
  - stmts
  - decls
  - decls_cls
  - decls_inst

This updates the haddock submodule.

Test Plan: ./validate

Reviewers: hvr, austin, goldfire, simonpj

Reviewed By: simonpj

Subscribers: thomie, carter

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

69 files changed:
compiler/basicTypes/BasicTypes.hs
compiler/basicTypes/DataCon.hs
compiler/basicTypes/MkId.hs
compiler/basicTypes/RdrName.hs
compiler/basicTypes/SrcLoc.hs
compiler/deSugar/Check.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/Desugar.hs
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsForeign.hs
compiler/deSugar/DsMeta.hs
compiler/deSugar/Match.hs
compiler/deSugar/MatchLit.hs
compiler/ghc.mk
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsBinds.hs
compiler/hsSyn/HsDecls.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsImpExp.hs
compiler/hsSyn/HsLit.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/main/GHC.hs
compiler/main/HeaderInfo.hs
compiler/main/HscMain.hs
compiler/main/HscTypes.hs
compiler/main/InteractiveEval.hs
compiler/parser/ApiAnnotation.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/prelude/ForeignCall.hs
compiler/prelude/TysWiredIn.hs
compiler/rename/RnBinds.hs
compiler/rename/RnExpr.hs
compiler/rename/RnNames.hs
compiler/rename/RnPat.hs
compiler/rename/RnSource.hs
compiler/rename/RnTypes.hs
compiler/stranal/WorkWrap.hs
compiler/typecheck/Inst.hs
compiler/typecheck/TcAnnotations.hs
compiler/typecheck/TcArrows.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcClassDcl.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcGenGenerics.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcMatches.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRules.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/types/Class.hs
compiler/types/InstEnv.hs
compiler/utils/Binary.hs
compiler/utils/OrdList.hs
testsuite/tests/ghc-api/annotations/AnnotationLet.hs
testsuite/tests/ghc-api/annotations/Makefile
testsuite/tests/ghc-api/annotations/annotations.stdout
testsuite/tests/ghc-api/annotations/parseTree.stdout
testsuite/tests/ghc-api/landmines/landmines.stdout
utils/haddock

index f4b7e80..5bbc0ce 100644 (file)
@@ -84,7 +84,9 @@ module BasicTypes(
 
         FractionalLit(..), negateFractionalLit, integralFractionalLit,
 
-        HValue(..)
+        HValue(..),
+
+        SourceText
    ) where
 
 import FastString
@@ -263,14 +265,15 @@ initialVersion = 1
 -}
 
 -- reason/explanation from a WARNING or DEPRECATED pragma
-data WarningTxt = WarningTxt [Located FastString]
-                | DeprecatedTxt [Located FastString]
+-- For SourceText usage, see note [Pragma source text]
+data WarningTxt = WarningTxt (Located SourceText) [Located FastString]
+                | DeprecatedTxt (Located SourceText) [Located FastString]
     deriving (Eq, Data, Typeable)
 
 instance Outputable WarningTxt where
-    ppr (WarningTxt    ws) = doubleQuotes (vcat (map (ftext . unLoc) ws))
-    ppr (DeprecatedTxt ds) = text "Deprecated:" <+>
-                             doubleQuotes (vcat (map (ftext . unLoc) ds))
+    ppr (WarningTxt    ws) = doubleQuotes (vcat (map (ftext . unLoc) ws))
+    ppr (DeprecatedTxt ds) = text "Deprecated:" <+>
+                               doubleQuotes (vcat (map (ftext . unLoc) ds))
 
 {-
 ************************************************************************
@@ -448,6 +451,13 @@ instance Outputable Origin where
 -- | The semantics allowed for overlapping instances for a particular
 -- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.lhs`) for a
 -- explanation of the `isSafeOverlap` field.
+--
+-- - 'ApiAnnotation.AnnKeywordId' :
+--      'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or
+--                              @'\{-\# OVERLAPPING'@ or
+--                              @'\{-\# OVERLAPS'@ or
+--                              @'\{-\# INCOHERENT'@,
+--      'ApiAnnotation.AnnClose' @`\#-\}`@,
 data OverlapFlag = OverlapFlag
   { overlapMode   :: OverlapMode
   , isSafeOverlap :: Bool
@@ -460,27 +470,29 @@ setOverlapModeMaybe f (Just m) = f { overlapMode = m }
 hasOverlappableFlag :: OverlapMode -> Bool
 hasOverlappableFlag mode =
   case mode of
-    Overlappable -> True
-    Overlaps     -> True
-    Incoherent   -> True
-    _            -> False
+    Overlappable -> True
+    Overlaps     -> True
+    Incoherent   -> True
+    _              -> False
 
 hasOverlappingFlag :: OverlapMode -> Bool
 hasOverlappingFlag mode =
   case mode of
-    Overlapping  -> True
-    Overlaps     -> True
-    Incoherent   -> True
-    _            -> False
+    Overlapping  -> True
+    Overlaps     -> True
+    Incoherent   -> True
+    _              -> False
 
 data OverlapMode  -- See Note [Rules for instance lookup] in InstEnv
-  = NoOverlap
+  = NoOverlap SourceText
+                  -- See Note [Pragma source text]
     -- ^ This instance must not overlap another `NoOverlap` instance.
     -- However, it may be overlapped by `Overlapping` instances,
     -- and it may overlap `Overlappable` instances.
 
 
-  | Overlappable
+  | Overlappable SourceText
+                  -- See Note [Pragma source text]
     -- ^ Silently ignore this instance if you find a
     -- more specific one that matches the constraint
     -- you are trying to resolve
@@ -494,7 +506,8 @@ data OverlapMode  -- See Note [Rules for instance lookup] in InstEnv
     -- its ambiguous which to choose)
 
 
-  | Overlapping
+  | Overlapping SourceText
+                  -- See Note [Pragma source text]
     -- ^ Silently ignore any more general instances that may be
     --   used to solve the constraint.
     --
@@ -507,10 +520,12 @@ data OverlapMode  -- See Note [Rules for instance lookup] in InstEnv
     -- it is ambiguous which to choose)
 
 
-  | Overlaps
+  | Overlaps SourceText
+                  -- See Note [Pragma source text]
     -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.
 
-  | Incoherent
+  | Incoherent SourceText
+                  -- See Note [Pragma source text]
     -- ^ Behave like Overlappable and Overlapping, and in addition pick
     -- an an arbitrary one if there are multiple matching candidates, and
     -- don't worry about later instantiation
@@ -529,11 +544,11 @@ instance Outputable OverlapFlag where
    ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)
 
 instance Outputable OverlapMode where
-   ppr NoOverlap    = empty
-   ppr Overlappable = ptext (sLit "[overlappable]")
-   ppr Overlapping  = ptext (sLit "[overlapping]")
-   ppr Overlaps     = ptext (sLit "[overlap ok]")
-   ppr Incoherent   = ptext (sLit "[incoherent]")
+   ppr (NoOverlap    _) = empty
+   ppr (Overlappable _) = ptext (sLit "[overlappable]")
+   ppr (Overlapping  _) = ptext (sLit "[overlapping]")
+   ppr (Overlaps     _) = ptext (sLit "[overlap ok]")
+   ppr (Incoherent   _) = ptext (sLit "[incoherent]")
 
 pprSafeOverlap :: Bool -> SDoc
 pprSafeOverlap True  = ptext $ sLit "[safe]"
@@ -768,6 +783,72 @@ failed Failed    = True
 {-
 ************************************************************************
 *                                                                      *
+\subsection{Source Text}
+*                                                                      *
+************************************************************************
+Keeping Source Text for source to source conversions
+
+Note [Pragma source text]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The lexer does a case-insensitive match for pragmas, as well as
+accepting both UK and US spelling variants.
+
+So
+
+  {-# SPECIALISE #-}
+  {-# SPECIALIZE #-}
+  {-# Specialize #-}
+
+will all generate ITspec_prag token for the start of the pragma.
+
+In order to be able to do source to source conversions, the original
+source text for the token needs to be preserved, hence the
+`SourceText` field.
+
+So the lexer will then generate
+
+  ITspec_prag "{ -# SPECIALISE"
+  ITspec_prag "{ -# SPECIALIZE"
+  ITspec_prag "{ -# Specialize"
+
+for the cases above.
+ [without the space between '{' and '-', otherwise this comment won't parse]
+
+
+Note [literal source text]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The lexer/parser converts literals from their original source text
+versions to an appropriate internal representation. This is a problem
+for tools doing source to source conversions, so the original source
+text is stored in literals where this can occur.
+
+Motivating examples for HsLit
+
+  HsChar          '\n', '\x20`
+  HsCharPrim      '\x41`#
+  HsString        "\x20\x41" == " A"
+  HsStringPrim    "\x20"#
+  HsInt           001
+  HsIntPrim       002#
+  HsWordPrim      003##
+  HsInt64Prim     004##
+  HsWord64Prim    005##
+  HsInteger       006
+
+For OverLitVal
+
+  HsIntegral      003,0x001
+  HsIsString      "\x41nd"
+-}
+
+type SourceText = String -- Note [literal source text],[Pragma source text]
+
+
+{-
+************************************************************************
+*                                                                      *
 \subsection{Activation}
 *                                                                      *
 ************************************************************************
@@ -800,7 +881,8 @@ data RuleMatchInfo = ConLike                    -- See Note [CONLIKE pragma]
 
 data InlinePragma            -- Note [InlinePragma]
   = InlinePragma
-      { inl_inline :: InlineSpec
+      { inl_src    :: SourceText -- Note [Pragma source text]
+      , inl_inline :: InlineSpec
 
       , inl_sat    :: Maybe Arity    -- Just n <=> Inline only when applied to n
                                      --            explicit (non-type, non-dictionary) args
@@ -890,7 +972,8 @@ isEmptyInlineSpec _               = False
 
 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
   :: InlinePragma
-defaultInlinePragma = InlinePragma { inl_act = AlwaysActive
+defaultInlinePragma = InlinePragma { inl_src = "{-# INLINE"
+                                   , inl_act = AlwaysActive
                                    , inl_rule = FunLike
                                    , inl_inline = EmptyInlineSpec
                                    , inl_sat = Nothing }
index 200bf21..cd4fe71 100644 (file)
@@ -453,6 +453,7 @@ data HsBang
   = HsNoBang     -- Equivalent to (HsSrcBang Nothing False)
 
   | HsSrcBang    -- What the user wrote in the source code
+       (Maybe SourceText) -- Note [Pragma source text] in BasicTypes
        (Maybe Bool)       -- Just True    {-# UNPACK #-}
                           -- Just False   {-# NOUNPACK #-}
                           -- Nothing      no pragma
@@ -574,11 +575,11 @@ instance Data.Data DataCon where
     dataTypeOf _ = mkNoRepType "DataCon"
 
 instance Outputable HsBang where
-    ppr HsNoBang              = empty
-    ppr (HsSrcBang prag bang) = pp_unpk prag <+> ppWhen bang (char '!')
-    ppr (HsUnpack Nothing)    = ptext (sLit "Unpk")
-    ppr (HsUnpack (Just co))  = ptext (sLit "Unpk") <> parens (ppr co)
-    ppr HsStrict              = ptext (sLit "SrictNotUnpacked")
+    ppr HsNoBang                = empty
+    ppr (HsSrcBang prag bang) = pp_unpk prag <+> ppWhen bang (char '!')
+    ppr (HsUnpack Nothing)      = ptext (sLit "Unpk")
+    ppr (HsUnpack (Just co))    = ptext (sLit "Unpk") <> parens (ppr co)
+    ppr HsStrict                = ptext (sLit "SrictNotUnpacked")
 
 pp_unpk :: Maybe Bool -> SDoc
 pp_unpk Nothing      = empty
@@ -593,16 +594,16 @@ instance Outputable StrictnessMark where
 eqHsBang :: HsBang -> HsBang -> Bool
 eqHsBang HsNoBang             HsNoBang             = True
 eqHsBang HsStrict             HsStrict             = True
-eqHsBang (HsSrcBang u1 b1)    (HsSrcBang u2 b2)    = u1==u2 && b1==b2
+eqHsBang (HsSrcBang _ u1 b1)  (HsSrcBang _ u2 b2)  = u1==u2 && b1==b2
 eqHsBang (HsUnpack Nothing)   (HsUnpack Nothing)   = True
 eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2)
 eqHsBang _ _ = False
 
 isBanged :: HsBang -> Bool
-isBanged HsNoBang           = False
-isBanged (HsSrcBang _ bang) = bang
-isBanged (HsUnpack {})      = True
-isBanged (HsStrict {})      = True
+isBanged HsNoBang             = False
+isBanged (HsSrcBang _ bang) = bang
+isBanged (HsUnpack {})        = True
+isBanged (HsStrict {})        = True
 
 isMarkedStrict :: StrictnessMark -> Bool
 isMarkedStrict NotMarkedStrict = False
index 7f24faa..34fd0aa 100644 (file)
@@ -595,11 +595,11 @@ dataConArgRep
 dataConArgRep _ _ arg_ty HsNoBang
   = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
 
-dataConArgRep _ _ arg_ty (HsSrcBang _ False)  -- No '!'
+dataConArgRep _ _ arg_ty (HsSrcBang _ False)  -- No '!'
   = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
 
 dataConArgRep dflags fam_envs arg_ty
-    (HsSrcBang unpk_prag True)  -- {-# UNPACK #-} !
+    (HsSrcBang unpk_prag True)  -- {-# UNPACK #-} !
   | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
           -- Don't unpack if we aren't optimising; rather arbitrarily,
           -- we use -fomit-iface-pragmas as the indication
@@ -727,11 +727,11 @@ isUnpackableType fam_envs ty
          -- NB: dataConSrcBangs gives the *user* request;
          -- We'd get a black hole if we used dataConImplBangs
 
-    attempt_unpack (HsUnpack {})                = True
-    attempt_unpack (HsSrcBang (Just unpk) bang) = bang && unpk
-    attempt_unpack (HsSrcBang Nothing bang)     = bang  -- Be conservative
-    attempt_unpack HsStrict                     = False
-    attempt_unpack HsNoBang                     = False
+    attempt_unpack (HsUnpack {})                  = True
+    attempt_unpack (HsSrcBang (Just unpk) bang) = bang && unpk
+    attempt_unpack (HsSrcBang _  Nothing bang)     = bang  -- Be conservative
+    attempt_unpack HsStrict                       = False
+    attempt_unpack HsNoBang                       = False
 
 {-
 Note [Unpack one-wide fields]
index 71135d0..5db0a9d 100644 (file)
@@ -86,6 +86,20 @@ import Data.Data
 
 -- | Do not use the data constructors of RdrName directly: prefer the family
 -- of functions that creates them, such as 'mkRdrUnqual'
+--
+-- - Note: A Located RdrName will only have API Annotations if it is a
+--         compound one,
+--   e.g.
+--
+-- > `bar`
+-- > ( ~ )
+--
+-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
+--           'ApiAnnotation.AnnOpen'  @'('@ or @'['@ or @'[:'@,
+--           'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,,
+--           'ApiAnnotation.AnnBackquote' @'`'@,
+--           'ApiAnnotation.AnnVal','ApiAnnotation.AnnTildehsh',
+--           'ApiAnnotation.AnnTilde',
 data RdrName
   = Unqual OccName
         -- ^ Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@.
index 03e415b..4f6cc1a 100644 (file)
@@ -1,6 +1,11 @@
 -- (c) The University of Glasgow, 1992-2006
 
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveFoldable     #-}
+{-# LANGUAGE DeriveTraversable  #-}
+{-# LANGUAGE FlexibleInstances  #-}
 {-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
    -- Workaround for Trac #5252 crashes the bootstrap compiler without -O
    -- When the earliest compiler we want to boostrap with is
@@ -77,6 +82,10 @@ import Util
 import Outputable
 import FastString
 
+#if __GLASGOW_HASKELL__ < 709
+import Data.Foldable ( Foldable )
+import Data.Traversable ( Traversable )
+#endif
 import Data.Bits
 import Data.Data
 import Data.List
@@ -515,6 +524,8 @@ pprUserRealSpan show_path (SrcSpanPoint src_path line col)
 -- | We attach SrcSpans to lots of things, so let's have a datatype for it.
 data GenLocated l e = L l e
   deriving (Eq, Ord, Typeable, Data)
+deriving instance Foldable    (GenLocated l)
+deriving instance Traversable (GenLocated l)
 
 type Located e = GenLocated SrcSpan e
 type RealLocated e = GenLocated RealSrcSpan e
index 7284db3..3d53e69 100644 (file)
@@ -452,11 +452,11 @@ get_lit :: Pat id -> Maybe HsLit
 -- It doesn't matter which one, because they will only be compared
 -- with other HsLits gotten in the same way
 get_lit (LitPat lit)                                      = Just lit
-get_lit (NPat (OverLit { ol_val = HsIntegral src i})    mb _)
+get_lit (NPat (L _ (OverLit { ol_val = HsIntegral src i}))    mb _)
                         = Just (HsIntPrim src (mb_neg negate              mb i))
-get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _)
+get_lit (NPat (L _ (OverLit { ol_val = HsFractional f })) mb _)
                         = Just (HsFloatPrim (mb_neg negateFractionalLit mb f))
-get_lit (NPat (OverLit { ol_val = HsIsString src s })   _  _)
+get_lit (NPat (L _ (OverLit { ol_val = HsIsString src s }))   _  _)
                         = Just (HsStringPrim src (fastStringToByteString s))
 get_lit _                                                 = Nothing
 
@@ -727,7 +727,7 @@ tidy_pat (TuplePat ps boxity tys)
   where
     arity = length ps
 
-tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq
+tidy_pat (NPat (L _ lit) mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq
 tidy_pat (LitPat lit)         = tidy_lit_pat lit
 
 tidy_pat (ConPatIn {})        = panic "Check.tidy_pat: ConPatIn"
index d81599d..b44e9d8 100644 (file)
@@ -567,7 +567,7 @@ addTickHsExpr (HsTick t e) =
 addTickHsExpr (HsBinTick t0 t1 e) =
         liftM (HsBinTick t0 t1) (addTickLHsExprNever e)
 
-addTickHsExpr (HsTickPragma _ (L pos e0)) = do
+addTickHsExpr (HsTickPragma _ (L pos e0)) = do
     e2 <- allocTickBox (ExpBox False) False False pos $
                 addTickHsExpr e0
     return $ unLoc e2
@@ -575,12 +575,14 @@ addTickHsExpr (PArrSeq   ty arith_seq) =
         liftM2 PArrSeq
                 (return ty)
                 (addTickArithSeqInfo arith_seq)
-addTickHsExpr (HsSCC nm e) =
-        liftM2 HsSCC
+addTickHsExpr (HsSCC src nm e) =
+        liftM3 HsSCC
+                (return src)
                 (return nm)
                 (addTickLHsExpr e)
-addTickHsExpr (HsCoreAnn nm e) =
-        liftM2 HsCoreAnn
+addTickHsExpr (HsCoreAnn src nm e) =
+        liftM3 HsCoreAnn
+                (return src)
                 (return nm)
                 (addTickLHsExpr e)
 addTickHsExpr e@(HsBracket     {})   = return e
@@ -614,10 +616,10 @@ addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do
   return $ mg { mg_alts = matches' }
 
 addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))
-addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) =
+addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) =
   bindLocals (collectPatsBinders pats) $ do
     gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
-    return $ Match pats opSig gRHSs'
+    return $ Match mf pats opSig gRHSs'
 
 addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))
 addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
@@ -829,10 +831,10 @@ addTickCmdMatchGroup mg@(MG { mg_alts = matches }) = do
   return $ mg { mg_alts = matches' }
 
 addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))
-addTickCmdMatch (Match pats opSig gRHSs) =
+addTickCmdMatch (Match mf pats opSig gRHSs) =
   bindLocals (collectPatsBinders pats) $ do
     gRHSs' <- addTickCmdGRHSs gRHSs
-    return $ Match pats opSig gRHSs'
+    return $ Match mf pats opSig gRHSs'
 
 addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))
 addTickCmdGRHSs (GRHSs guarded local_binds) = do
@@ -1204,7 +1206,7 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
 matchesOneOfMany :: [LMatch Id body] -> Bool
 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
   where
-        matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
+        matchCount (L _ (Match _ _pats _ty (GRHSs grhss _binds))) = length grhss
 
 type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
 
index 70fa88e..e4181b9 100644 (file)
@@ -461,12 +461,12 @@ by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
 -}
 
 dsVect :: LVectDecl Id -> DsM CoreVect
-dsVect (L loc (HsVect (L _ v) rhs))
+dsVect (L loc (HsVect (L _ v) rhs))
   = putSrcSpanDs loc $
     do { rhs' <- dsLExpr rhs
        ; return $ Vect v rhs'
        }
-dsVect (L _loc (HsNoVect (L _ v)))
+dsVect (L _loc (HsNoVect (L _ v)))
   = return $ NoVect v
 dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
   = return $ VectType isScalar tycon' rhs_tycon
@@ -474,11 +474,11 @@ dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
     tycon' | Just ty <- coreView $ mkTyConTy tycon
            , (tycon', []) <- splitTyConApp ty      = tycon'
            | otherwise                             = tycon
-dsVect vd@(L _ (HsVectTypeIn _ _ _))
+dsVect vd@(L _ (HsVectTypeIn _ _ _ _))
   = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
 dsVect (L _loc (HsVectClassOut cls))
   = return $ VectClass (classTyCon cls)
-dsVect vc@(L _ (HsVectClassIn _))
+dsVect vc@(L _ (HsVectClassIn _ _))
   = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
 dsVect (L _loc (HsVectInstOut inst))
   = return $ VectInst (instanceDFunId inst)
index 8f5b30e..220ed3c 100644 (file)
@@ -399,7 +399,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
 --              ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
 
 dsCmd ids local_vars stack_ty res_ty
-        (HsCmdLam (MG { mg_alts = [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] }))
+        (HsCmdLam (MG { mg_alts = [L _ (Match _ pats _
+                                       (GRHSs [L _ (GRHS [] body)] _ ))] }))
         env_ids = do
     let
         pat_vars = mkVarSet (collectPatsBinders pats)
@@ -1046,7 +1047,7 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys"
 -- List of leaf expressions, with set of variables bound in each
 
 leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)]
-leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))
+leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))
   = let
         defined_vars = mkVarSet (collectPatsBinders pats)
                         `unionVarSet`
@@ -1065,11 +1066,11 @@ replaceLeavesMatch
         -> LMatch Id (Located (body Id))        -- the matches of a case command
         -> ([Located (body' Id)],               -- remaining leaf expressions
             LMatch Id (Located (body' Id)))     -- updated match
-replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))
+replaceLeavesMatch _res_ty leaves (L loc (Match mf pat mt (GRHSs grhss binds)))
   = let
         (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
     in
-    (leaves', L loc (Match pat mt (GRHSs grhss' binds)))
+    (leaves', L loc (Match mf pat mt (GRHSs grhss' binds)))
 
 replaceLeavesGRHS
         :: [Located (body' Id)]                 -- replacement leaf expressions of that type
index 4bffdbc..3b176a5 100644 (file)
@@ -300,13 +300,18 @@ dsExpr (ExplicitTuple tup_args boxity)
                   mkCoreConApps (tupleCon (boxityNormalTupleSort boxity) (length tup_args))
                                 (map (Type . exprType) args ++ args) }
 
-dsExpr (HsSCC cc expr@(L loc _)) = do
-    mod_name <- getModule
-    count <- goptM Opt_ProfCountEntries
-    uniq <- newUnique
-    Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True) <$> dsLExpr expr
-
-dsExpr (HsCoreAnn _ expr)
+dsExpr (HsSCC _ cc expr@(L loc _)) = do
+    dflags <- getDynFlags
+    if gopt Opt_SccProfilingOn dflags
+      then do
+        mod_name <- getModule
+        count <- goptM Opt_ProfCountEntries
+        uniq <- newUnique
+        Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True)
+               <$> dsLExpr expr
+      else dsLExpr expr
+
+dsExpr (HsCoreAnn _ _ expr)
   = dsLExpr expr
 
 dsExpr (HsCase discrim matches)
@@ -669,13 +674,18 @@ dsExpr (HsBinTick ixT ixF e) = do
        mkBinaryTickBox ixT ixF e2
      }
 
+dsExpr (HsTickPragma _ _ expr) = do
+  dflags <- getDynFlags
+  if gopt Opt_Hpc dflags
+    then panic "dsExpr:HsTickPragma"
+    else dsLExpr expr
+
 -- HsSyn constructs that just shouldn't be here:
 dsExpr (ExprWithTySig {})  = panic "dsExpr:ExprWithTySig"
 dsExpr (HsBracket     {})  = panic "dsExpr:HsBracket"
 dsExpr (HsQuasiQuoteE {})  = panic "dsExpr:HsQuasiQuoteE"
 dsExpr (HsArrApp      {})  = panic "dsExpr:HsArrApp"
 dsExpr (HsArrForm     {})  = panic "dsExpr:HsArrForm"
-dsExpr (HsTickPragma  {})  = panic "dsExpr:HsTickPragma"
 dsExpr (EWildPat      {})  = panic "dsExpr:EWildPat"
 dsExpr (EAsPat        {})  = panic "dsExpr:EAsPat"
 dsExpr (EViewPat      {})  = panic "dsExpr:EViewPat"
@@ -684,6 +694,7 @@ dsExpr (HsType        {})  = panic "dsExpr:HsType"
 dsExpr (HsDo          {})  = panic "dsExpr:HsDo"
 
 
+
 findField :: [LHsRecField Id arg] -> Name -> [arg]
 findField rbinds lbl
   = [rhs | L _ (HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs }) <- rbinds
index 0ae14f8..715e1ce 100644 (file)
@@ -713,7 +713,7 @@ toCType = f False
            -- Note that we aren't looking through type synonyms or
            -- anything, as it may be the synonym that is annotated.
            | TyConApp tycon _ <- t
-           , Just (CType mHeader cType) <- tyConCType_maybe tycon
+           , Just (CType mHeader cType) <- tyConCType_maybe tycon
               = (mHeader, ftext cType)
            -- If we don't know a C type for this type, then try looking
            -- through one layer of type synonym etc.
index b7445a8..63b6539 100644 (file)
@@ -147,9 +147,11 @@ repTopDs group@(HsGroup { hs_valds   = valds
                      ; fix_ds   <- mapM repFixD fixds
                      ; _        <- mapM no_default_decl defds
                      ; for_ds   <- mapM repForD fords
-                     ; _        <- mapM no_warn warnds
+                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)
+                                                           warnds)
                      ; ann_ds   <- mapM repAnnD annds
-                     ; rule_ds  <- mapM repRuleD ruleds
+                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)
+                                                            ruleds)
                      ; _        <- mapM no_vect vects
                      ; _        <- mapM no_doc docs
 
@@ -361,7 +363,7 @@ mk_extra_tvs tc tvs defn
       = do { uniq <- newUnique
            ; let { occ = mkTyVarOccFS (fsLit "t")
                  ; nm = mkInternalName uniq occ loc
-                 ; hs_tv = L loc (KindedTyVar nm kind) }
+                 ; hs_tv = L loc (KindedTyVar (noLoc nm) kind) }
            ; hs_tvs <- go rest
            ; return (hs_tv : hs_tvs) }
 
@@ -374,13 +376,14 @@ mk_extra_tvs tc tvs defn
 -------------------------
 -- represent fundeps
 --
-repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
+repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])
 repLFunDeps fds = repList funDepTyConName repLFunDep fds
 
-repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
-repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs
-                               ys' <- repList nameTyConName lookupBinder ys
-                               repFunDep xs' ys'
+repLFunDep :: Located (FunDep (Located Name)) -> DsM (Core TH.FunDep)
+repLFunDep (L _ (xs, ys))
+   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
+        ys' <- repList nameTyConName (lookupBinder . unLoc) ys
+        repFunDep xs' ys'
 
 -- represent family declaration flavours
 --
@@ -550,17 +553,17 @@ repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty })))
        ; rep2 typedRuleVarName [n', ty'] }
 
 repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
-repAnnD (L loc (HsAnnotation ann_prov (L _ exp)))
+repAnnD (L loc (HsAnnotation ann_prov (L _ exp)))
   = do { target <- repAnnProv ann_prov
        ; exp'   <- repE exp
        ; dec    <- repPragAnn target exp'
        ; return (loc, dec) }
 
 repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
-repAnnProv (ValueAnnProvenance n)
+repAnnProv (ValueAnnProvenance (L _ n))
   = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
        ; rep2 valueAnnotationName [ n' ] }
-repAnnProv (TypeAnnProvenance n)
+repAnnProv (TypeAnnProvenance (L _ n))
   = do { MkC n' <- globalVar n
        ; rep2 typeAnnotationName [ n' ] }
 repAnnProv ModuleAnnProvenance
@@ -619,7 +622,7 @@ mkGadtCtxt :: [Name]            -- Tyvars of the data type
 -- This function is fiddly, but not really hard
 mkGadtCtxt _ ResTyH98
   = return ([], [])
-mkGadtCtxt data_tvs (ResTyGADT res_ty)
+mkGadtCtxt data_tvs (ResTyGADT res_ty)
   | Just (_, tys) <- hsTyGetAppHead_maybe res_ty
   , data_tvs `equalLength` tys
   = return (go [] [] (data_tvs `zip` tys))
@@ -651,9 +654,9 @@ repBangTy ty= do
   rep2 strictTypeName [s, t]
   where
     (str, ty') = case ty of
-                   L _ (HsBangTy (HsSrcBang (Just True) True) ty) -> (unpackedName,  ty)
-                   L _ (HsBangTy (HsSrcBang _     True) ty)       -> (isStrictName,  ty)
-                   _                                              -> (notStrictName, ty)
+         L _ (HsBangTy (HsSrcBang _ (Just True) True) ty) -> (unpackedName,  ty)
+         L _ (HsBangTy (HsSrcBang _ _     True) ty)       -> (isStrictName,  ty)
+         _                                                -> (notStrictName, ty)
 
 -------------------------------------------------------
 --                      Deriving clause
@@ -695,7 +698,7 @@ 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 tys ispec))
    = concatMapM (\t -> rep_specialise nm t ispec loc) tys
-rep_sig (L loc (SpecInstSig ty))      = rep_specialiseInst ty loc
+rep_sig (L loc (SpecInstSig _ ty))    = rep_specialiseInst ty loc
 rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
 
 rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name
@@ -913,11 +916,11 @@ repTy (HsTyLit lit) = do
 repTy ty                      = notHandled "Exotic form of type" (ppr ty)
 
 repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
-repTyLit (HsNumTy i) = do iExpr <- mkIntegerExpr i
-                          rep2 numTyLitName [iExpr]
-repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s
-                         ; rep2 strTyLitName [s']
-                         }
+repTyLit (HsNumTy i) = do iExpr <- mkIntegerExpr i
+                            rep2 numTyLitName [iExpr]
+repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s
+                            ; rep2 strTyLitName [s']
+                            }
 
 -- represent a kind
 --
@@ -1104,7 +1107,7 @@ repE e                     = notHandled "Expression form" (ppr e)
 -- Building representations of auxillary structures like Match, Clause, Stmt,
 
 repMatchTup ::  LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ)
-repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
+repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
   do { ss1 <- mkGenSyms (collectPatBinders p)
      ; addBinds ss1 $ do {
      ; p1 <- repLP p
@@ -1116,7 +1119,7 @@ repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
 
 repClauseTup ::  LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ)
-repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
+repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
   do { ss1 <- mkGenSyms (collectPatsBinders ps)
      ; addBinds ss1 $ do {
        ps1 <- repLPs ps
@@ -1268,8 +1271,10 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
 -- Note GHC treats declarations of a variable (not a pattern)
 -- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match
 -- with an empty list of patterns
-rep_bind (L loc (FunBind { fun_id = fn,
-                           fun_matches = MG { mg_alts = [L _ (Match [] _ (GRHSs guards wheres))] } }))
+rep_bind (L loc (FunBind
+                 { fun_id = fn,
+                   fun_matches = MG { mg_alts = [L _ (Match _ [] _
+                                                   (GRHSs guards wheres))] } }))
  = do { (ss,wherecore) <- repBinds wheres
         ; guardcore <- addBinds ss (repGuards guards)
         ; fn'  <- lookupLBinder fn
@@ -1328,7 +1333,7 @@ rep_bind (L _ dec@(PatSynBind {})) = notHandled "pattern synonyms" (ppr dec)
 -- (\ p1 .. pn -> exp) by causing an error.
 
 repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ)
-repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
+repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
  = do { let bndrs = collectPatsBinders ps ;
       ; ss  <- mkGenSyms bndrs
       ; lam <- addBinds ss (
@@ -1380,7 +1385,7 @@ repP (ConPatIn dc details)
                           ; MkC p <- repLP (hsRecFieldArg fld)
                           ; rep2 fieldPatName [v,p] }
 
-repP (NPat l Nothing _)  = do { a <- repOverloadedLiteral l; repPlit a }
+repP (NPat (L _ l) Nothing _)  = do { a <- repOverloadedLiteral l; repPlit a }
 repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
 repP p@(SigPatIn {})  = notHandled "Type signatures in patterns" (ppr p)
@@ -1848,7 +1853,7 @@ repConstr con (PrefixCon ps)
     = do arg_tys  <- repList strictTypeQTyConName repBangTy ps
          rep2 normalCName [unC con, unC arg_tys]
 
-repConstr con (RecCon ips)
+repConstr con (RecCon (L _ ips))
     = do { args <- concatMapM rep_ip ips
          ; arg_vtys <- coreList varStrictTypeQTyConName args
          ; rep2 recCName [unC con, unC arg_vtys] }
index 5089f86..c8e30f1 100644 (file)
@@ -575,7 +575,7 @@ tidy1 _ (LitPat lit)
   = return (idDsWrapper, tidyLitPat lit)
 
 -- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ (NPat lit mb_neg eq)
+tidy1 _ (NPat (L _ lit) mb_neg eq)
   = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq)
 
 -- Everything else goes through unchanged...
@@ -803,7 +803,7 @@ matchWrapper ctxt (MG { mg_alts = matches
                          matchEquations ctxt new_vars eqns_info rhs_ty
         ; return (new_vars, result_expr) }
   where
-    mk_eqn_info (L _ (Match pats _ grhss))
+    mk_eqn_info (L _ (Match pats _ grhss))
       = do { let upats = map unLoc pats
            ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
            ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }
@@ -1062,8 +1062,9 @@ patGroup _      (ConPatOut { pat_con = con }) = case unLoc con of
     RealDataCon dcon -> PgCon dcon
     PatSynCon psyn -> PgSyn psyn
 patGroup dflags (LitPat lit)                  = PgLit (hsLitKey dflags lit)
-patGroup _      (NPat olit mb_neg _)          = PgN   (hsOverLitKey olit (isJust mb_neg))
-patGroup _      (NPlusKPat _ olit _ _)        = PgNpK (hsOverLitKey olit False)
+patGroup _      (NPat (L _ olit) mb_neg _)
+                                     = PgN   (hsOverLitKey olit (isJust mb_neg))
+patGroup _      (NPlusKPat _ (L _ olit) _ _)  = PgNpK (hsOverLitKey olit False)
 patGroup _      (CoPat _ p _)                 = PgCo  (hsPatType p) -- Type of innelexp pattern
 patGroup _      (ViewPat expr p _)            = PgView expr (hsPatType (unLoc p))
 patGroup _      (ListPat _ _ (Just _))        = PgOverloadedList
index 914b210..25021f5 100644 (file)
@@ -324,7 +324,7 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
                    _ -> Nothing
 
 tidyNPat _ over_lit mb_neg eq
-  = NPat over_lit mb_neg eq
+  = NPat (noLoc over_lit) mb_neg eq
 
 {-
 ************************************************************************
@@ -417,7 +417,7 @@ litValKey (HsIsString _ s) neg   = ASSERT( not neg) MachStr
 
 matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal
-  = do  { let NPat lit mb_neg eq_chk = firstPat eqn1
+  = do  { let NPat (L _ lit) mb_neg eq_chk = firstPat eqn1
         ; lit_expr <- dsOverLit lit
         ; neg_lit <- case mb_neg of
                             Nothing -> return lit_expr
@@ -450,7 +450,7 @@ We generate:
 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 -- All NPlusKPats, for the *same* literal k
 matchNPlusKPats (var:vars) ty (eqn1:eqns)
-  = do  { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
+  = do  { let NPlusKPat (L _ n1) (L _ lit) ge minus = firstPat eqn1
         ; ge_expr     <- dsExpr ge
         ; minus_expr  <- dsExpr minus
         ; lit_expr    <- dsOverLit lit
index 97e64ec..200ec8f 100644 (file)
@@ -493,7 +493,6 @@ compiler_stage2_dll0_MODULES = \
        CoreUnfold \
        CoreUtils \
        CostCentre \
-       Ctype \
        DataCon \
        Demand \
        Digraph \
@@ -532,7 +531,6 @@ compiler_stage2_dll0_MODULES = \
        InstEnv \
        Kind \
        Lexeme \
-       Lexer \
        ListSetOps \
        Literal \
        Maybes \
index 92af651..28742d4 100644 (file)
@@ -41,6 +41,8 @@ import Control.Monad( unless, liftM, ap )
 import Control.Applicative (Applicative(..))
 #endif
 
+import Data.Char ( chr )
+import Data.Word ( Word8 )
 import Data.Maybe( catMaybes )
 import Language.Haskell.TH as TH hiding (sigP)
 import Language.Haskell.TH.Syntax as TH
@@ -418,7 +420,7 @@ cvtConstr (RecC c varstrtys)
         ; cxt'  <- returnL []
         ; args' <- mapM cvt_id_arg varstrtys
         ; returnL $ mkSimpleConDecl c' noExistentials cxt'
-                                   (RecCon args') }
+                                   (RecCon (noLoc args')) }
 
 cvtConstr (InfixC st1 c st2)
   = do  { c' <- cNameL c
@@ -436,8 +438,12 @@ cvtConstr (ForallC tvs ctxt con)
 
 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
 cvt_arg (NotStrict, ty) = cvtType ty
-cvt_arg (IsStrict,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsSrcBang Nothing     True) ty' }
-cvt_arg (Unpacked,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsSrcBang (Just True) True) ty' }
+cvt_arg (IsStrict,  ty)
+  = do { ty' <- cvtType ty
+       ; returnL $ HsBangTy (HsSrcBang Nothing Nothing     True) ty' }
+cvt_arg (Unpacked,  ty)
+  = do { ty' <- cvtType ty
+       ; returnL $ HsBangTy (HsSrcBang Nothing (Just True) True) ty' }
 
 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName)
 cvt_id_arg (i, str, ty)
@@ -455,8 +461,10 @@ cvtDerivs cs = do { cs' <- mapM cvt_one cs
           cvt_one c = do { c' <- tconName c
                          ; returnL $ HsTyVar c' }
 
-cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
-cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }
+cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
+cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs
+                               ; ys' <- mapM tName ys
+                               ; returnL (map noLoc xs', map noLoc ys') }
 
 noExistentials :: [LHsTyVarBndr RdrName]
 noExistentials = []
@@ -469,7 +477,7 @@ cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
 cvtForD (ImportF callconv safety from nm ty)
   | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
                                  (mkFastString (TH.nameBase nm))
-                                 from (noLoc (mkFastString from))
+                                 from (noLoc from)
   = do { nm' <- vNameL nm
        ; ty' <- cvtType ty
        ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
@@ -487,7 +495,7 @@ cvtForD (ExportF callconv as nm ty)
         ; ty' <- cvtType ty
         ; let e = CExport (noLoc (CExportStatic (mkFastString as)
                                                 (cvt_conv callconv)))
-                                                (noLoc (mkFastString as))
+                                                (noLoc as)
         ; return $ ForeignExport nm' ty' noForeignExportCoercionYet e }
 
 cvt_conv :: TH.Callconv -> CCallConv
@@ -505,7 +513,8 @@ cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl RdrName))
 cvtPragmaD (InlineP nm inline rm phases)
   = do { nm' <- vNameL nm
        ; let dflt = dfltActivation inline
-       ; let ip   = InlinePragma { inl_inline = cvtInline inline
+       ; let ip   = InlinePragma { inl_src    = "{-# INLINE"
+                                 , inl_inline = cvtInline inline
                                  , inl_rule   = cvtRuleMatch rm
                                  , inl_act    = cvtPhases phases dflt
                                  , inl_sat    = Nothing }
@@ -517,7 +526,8 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
        ; let (inline', dflt) = case inline of
                Just inline1 -> (cvtInline inline1, dfltActivation inline1)
                Nothing      -> (EmptyInlineSpec,   AlwaysActive)
-       ; let ip = InlinePragma { inl_inline = inline'
+       ; let ip = InlinePragma { inl_src    = "{-# INLINE"
+                               , inl_inline = inline'
                                , inl_rule   = Hs.FunLike
                                , inl_act    = cvtPhases phases dflt
                                , inl_sat    = Nothing }
@@ -525,7 +535,7 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
 
 cvtPragmaD (SpecialiseInstP ty)
   = do { ty' <- cvtType ty
-       ; returnJustL $ Hs.SigD $ SpecInstSig ty' }
+       ; returnJustL $ Hs.SigD $ SpecInstSig "{-# SPECIALISE" ty' }
 
 cvtPragmaD (RuleP nm bndrs lhs rhs phases)
   = do { let nm' = mkFastString nm
@@ -533,9 +543,10 @@ cvtPragmaD (RuleP nm bndrs lhs rhs phases)
        ; bndrs' <- mapM cvtRuleBndr bndrs
        ; lhs'   <- cvtl lhs
        ; rhs'   <- cvtl rhs
-       ; returnJustL $ Hs.RuleD $ HsRule (noLoc nm') act bndrs'
-                                     lhs' placeHolderNames
-                                     rhs' placeHolderNames
+       ; returnJustL $ Hs.RuleD
+            $ HsRules "{-# RULES" [noLoc $ HsRule (noLoc nm') act bndrs'
+                                                  lhs' placeHolderNames
+                                                  rhs' placeHolderNames]
        }
 
 cvtPragmaD (AnnP target exp)
@@ -544,11 +555,11 @@ cvtPragmaD (AnnP target exp)
          ModuleAnnotation  -> return ModuleAnnProvenance
          TypeAnnotation n  -> do
            n' <- tconName n
-           return (TypeAnnProvenance  n')
+           return (TypeAnnProvenance  (noLoc n'))
          ValueAnnotation n -> do
            n' <- vcName n
-           return (ValueAnnProvenance n')
-       ; returnJustL $ Hs.AnnD $ HsAnnotation target' exp'
+           return (ValueAnnProvenance (noLoc n'))
+       ; returnJustL $ Hs.AnnD $ HsAnnotation "{-# ANN" target' exp'
        }
 
 cvtPragmaD (LineP line file)
@@ -603,7 +614,7 @@ cvtClause (Clause ps body wheres)
   = do  { ps' <- cvtPats ps
         ; g'  <- cvtGuard body
         ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres
-        ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
+        ; returnL $ Hs.Match Nothing ps' Nothing (GRHSs g' ds') }
 
 
 -------------------------------------------------------------------
@@ -816,7 +827,7 @@ cvtMatch (TH.Match p body decs)
   = do  { p' <- cvtPat p
         ; g' <- cvtGuard body
         ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
-        ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
+        ; returnL $ Hs.Match Nothing [p'] Nothing (GRHSs g' decs') }
 
 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)]
 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
@@ -831,13 +842,13 @@ cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
 
 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 cvtOverLit (IntegerL i)
-  = do { force i; return $ mkHsIntegral "" i placeHolderType}
+  = do { force i; return $ mkHsIntegral (show i) i placeHolderType}
 cvtOverLit (RationalL r)
   = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
 cvtOverLit (StringL s)
   = do { let { s' = mkFastString s }
        ; force s'
-       ; return $ mkHsIsString "" s' placeHolderType
+       ; return $ mkHsIsString s s' placeHolderType
        }
 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
 -- An Integer is like an (overloaded) '3' in a Haskell source program
@@ -865,22 +876,25 @@ allCharLs xs
     go _  _                     = Nothing
 
 cvtLit :: Lit -> CvtM HsLit
-cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim "" i }
-cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim "" w }
+cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim (show i) i }
+cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim (show w) w }
 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
-cvtLit (CharL c)       = do { force c; return $ HsChar "" c }
+cvtLit (CharL c)       = do { force c; return $ HsChar (show c) c }
 cvtLit (StringL s)     = do { let { s' = mkFastString s }
                             ; force s'
                             ; return $ HsString s s' }
 cvtLit (StringPrimL s) = do { let { s' = BS.pack s }
                             ; force s'
-                            ; return $ HsStringPrim "" s' }
+                            ; return $ HsStringPrim (w8ToString s) s' }
 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
         -- cvtLit should not be called on IntegerL, RationalL
         -- That precondition is established right here in
         -- Convert.lhs, hence panic
 
+w8ToString :: [Word8] -> String
+w8ToString ws = map (\w -> chr (fromIntegral w)) ws
+
 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
 cvtPats pats = mapM cvtPat pats
 
@@ -890,7 +904,7 @@ cvtPat pat = wrapL (cvtp pat)
 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
 cvtp (TH.LitP l)
   | overloadedLit l    = do { l' <- cvtOverLit l
-                            ; return (mkNPat l' Nothing) }
+                            ; return (mkNPat (noLoc l') Nothing) }
                                   -- Not right for negative patterns;
                                   -- need to think about that!
   | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat l' }
@@ -953,7 +967,7 @@ cvt_tv (TH.PlainTV nm)
 cvt_tv (TH.KindedTV nm ki)
   = do { nm' <- tName nm
        ; ki' <- cvtKind ki
-       ; returnL $ KindedTyVar nm' ki' }
+       ; returnL $ KindedTyVar (noLoc nm') ki' }
 
 cvtRole :: TH.Role -> Maybe Coercion.Role
 cvtRole TH.NominalR          = Just Coercion.Nominal
@@ -1064,8 +1078,8 @@ split_ty_app ty = go ty []
     go f as           = return (f,as)
 
 cvtTyLit :: TH.TyLit -> HsTyLit
-cvtTyLit (NumTyLit i) = HsNumTy i
-cvtTyLit (StrTyLit s) = HsStrTy (fsLit s)
+cvtTyLit (NumTyLit i) = HsNumTy (show i) i
+cvtTyLit (StrTyLit s) = HsStrTy s        (fsLit s)
 
 cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)
 cvtKind = cvtTypeKind "kind"
index 5528c3f..b848af1 100644 (file)
@@ -138,7 +138,7 @@ data HsBindLR idL idR
     --    'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
     FunBind {
 
-        fun_id :: Located idL,
+        fun_id :: Located idL, -- Note [fun_id in Match] in HsExpr
 
         fun_infix :: Bool,      -- ^ True => infix declaration
 
@@ -212,8 +212,9 @@ data HsBindLR idL idR
 
   | PatSynBind (PatSynBind idL idR)
         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
-        --           'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnWhere'
-        --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
+        --          'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual',
+        --          'ApiAnnotation.AnnWhere'
+        --          'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@
 
   deriving (Typeable)
 deriving instance (DataId idL, DataId idR)
@@ -239,6 +240,10 @@ data ABExport id
         , abe_prags :: TcSpecPrags  -- ^ SPECIALISE pragmas
   } deriving (Data, Typeable)
 
+-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
+--             'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow'
+--             'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@,
+--             'ApiAnnotation.AnnClose' @'}'@,
 data PatSynBind idL idR
   = PSB { psb_id   :: Located idL,             -- ^ Name of the pattern synonym
           psb_fvs  :: PostRn idR NameSet,      -- ^ See Note [Bind free vars]
@@ -556,13 +561,14 @@ type LIPBind id = Located (IPBind id)
 
 -- | Implicit parameter bindings.
 --
+-- These bindings start off as (Left "x") in the parser and stay
+-- that way until after type-checking when they are replaced with
+-- (Right d), where "d" is the name of the dictionary holding the
+-- evidence for the implicit parameter.
+--
 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
-{- These bindings start off as (Left "x") in the parser and stay
-that way until after type-checking when they are replaced with
-(Right d), where "d" is the name of the dictionary holding the
-evidence for the implicit parameter. -}
 data IPBind id
-  = IPBind (Either HsIPName id) (LHsExpr id)
+  = IPBind (Either (Located HsIPName) id) (LHsExpr id)
   deriving (Typeable)
 deriving instance (DataId name) => Data (IPBind name)
 
@@ -573,8 +579,8 @@ instance (OutputableBndr id) => Outputable (HsIPBinds id) where
 instance (OutputableBndr id) => Outputable (IPBind id) where
   ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
     where name = case lr of
-                   Left ip  -> pprBndr LetBind ip
-                   Right id -> pprBndr LetBind id
+                   Left (L _ ip) -> pprBndr LetBind ip
+                   Right     id  -> pprBndr LetBind id
 
 {-
 ************************************************************************
@@ -650,7 +656,8 @@ data Sig name
         --
         -- > {#- INLINE f #-}
         --
-        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+        --  - 'ApiAnnotation.AnnKeywordId' :
+        --       'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@,
         --       'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen',
         --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde',
         --       'ApiAnnotation.AnnClose'
@@ -662,9 +669,11 @@ data Sig name
         -- > {-# SPECIALISE f :: Int -> Int #-}
         --
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-        --      'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde',
-        --      'ApiAnnotation.AnnVal','ApiAnnotation.AnnClose',
-        --      'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose',
+        --      'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@,
+        --      'ApiAnnotation.AnnTilde',
+        --      'ApiAnnotation.AnnVal',
+        --      'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@,
+        --      'ApiAnnotation.AnnDcolon'
   | SpecSig     (Located name)  -- Specialise a function or datatype  ...
                 [LHsType name]  -- ... to these types
                 InlinePragma    -- The pragma on SPECIALISE_INLINE form.
@@ -680,7 +689,8 @@ data Sig name
         --
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --      'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose'
-  | SpecInstSig (LHsType name)
+  | SpecInstSig SourceText (LHsType name)
+                  -- Note [Pragma source text] in BasicTypes
 
         -- | A minimal complete definition pragma
         --
@@ -689,7 +699,8 @@ data Sig name
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --      'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma',
         --      'ApiAnnotation.AnnClose'
-  | MinimalSig (BooleanFormula (Located name))
+  | MinimalSig SourceText (BooleanFormula (Located name))
+               -- Note [Pragma source text] in BasicTypes
 
   deriving (Typeable)
 deriving instance (DataId name) => Data (Sig name)
@@ -796,8 +807,9 @@ ppr_sig (FixSig fix_sig)          = ppr fix_sig
 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)
+ppr_sig (SpecInstSig _ ty)
+  = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
+ppr_sig (MinimalSig _ bf)         = pragBrackets (pprMinimalSig bf)
 ppr_sig (PatSynSig name (flag, qtvs) (L _ prov) (L _ req) ty)
   = pprPatSynSig (unLoc name) False -- TODO: is_bindir
                  (pprHsForAll flag qtvs (noLoc []))
index 4b54a8d..6fcfa67 100644 (file)
@@ -38,13 +38,15 @@ module HsDecls (
   TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
   DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
   TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
+  HsTyPats,
   LClsInstDecl, ClsInstDecl(..),
 
   -- ** Standalone deriving declarations
   DerivDecl(..), LDerivDecl,
   -- ** @RULE@ declarations
-  RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr,
+  LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr,
   collectRuleBndrSigTys,
+  flattenRuleDecls,
   -- ** @VECTORISE@ declarations
   VectDecl(..), LVectDecl,
   lvectDeclName, lvectInstDecl,
@@ -64,6 +66,7 @@ module HsDecls (
   DocDecl(..), LDocDecl, docDeclDoc,
   -- ** Deprecations
   WarnDecl(..),  LWarnDecl,
+  WarnDecls(..), LWarnDecls,
   -- ** Annotations
   AnnDecl(..), LAnnDecl,
   AnnProvenance(..), annProvenanceName_maybe,
@@ -130,9 +133,9 @@ data HsDecl id
   | SigD        (Sig id)
   | DefD        (DefaultDecl id)
   | ForD        (ForeignDecl id)
-  | WarningD    (WarnDecl id)
+  | WarningD    (WarnDecls id)
   | AnnD        (AnnDecl id)
-  | RuleD       (RuleDecl id)
+  | RuleD       (RuleDecls id)
   | VectD       (VectDecl id)
   | SpliceD     (SpliceDecl id)
   | DocD        (DocDecl)
@@ -179,9 +182,9 @@ data HsGroup id
 
         hs_defds  :: [LDefaultDecl id],
         hs_fords  :: [LForeignDecl id],
-        hs_warnds :: [LWarnDecl id],
+        hs_warnds :: [LWarnDecls id],
         hs_annds  :: [LAnnDecl id],
-        hs_ruleds :: [LRuleDecl id],
+        hs_ruleds :: [LRuleDecls id],
         hs_vects  :: [LVectDecl id],
 
         hs_docs   :: [LDocDecl]
@@ -497,10 +500,11 @@ data TyClDecl name
   | ClassDecl { tcdCtxt    :: LHsContext name,          -- ^ Context...
                 tcdLName   :: Located name,             -- ^ Name of the class
                 tcdTyVars  :: LHsTyVarBndrs name,       -- ^ Class type variables
-                tcdFDs     :: [Located (FunDep name)],  -- ^ Functional deps
+                tcdFDs     :: [Located (FunDep (Located name))],
+                                                        -- ^ Functional deps
                 tcdSigs    :: [LSig name],              -- ^ Methods' signatures
                 tcdMeths   :: LHsBinds name,            -- ^ Default methods
-                tcdATs     :: [LFamilyDecl name],       -- ^ Associated types; ie
+                tcdATs     :: [LFamilyDecl name],       -- ^ Associated types;
                 tcdATDefs  :: [LTyFamDefltEqn name],    -- ^ Associated type defaults
                 tcdDocs    :: [LDocDecl],               -- ^ Haddock docs
                 tcdFVs     :: PostRn name NameSet
@@ -889,23 +893,25 @@ data ConDecl name
     } deriving (Typeable)
 deriving instance (DataId name) => Data (ConDecl name)
 
-type HsConDeclDetails name = HsConDetails (LBangType name) [LConDeclField name]
+type HsConDeclDetails name
+   = HsConDetails (LBangType name) (Located [LConDeclField name])
 
 hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
 hsConDeclArgTys (PrefixCon tys)    = tys
 hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
-hsConDeclArgTys (RecCon flds)      = map (cd_fld_type . unLoc) flds
+hsConDeclArgTys (RecCon flds)      = map (cd_fld_type . unLoc) (unLoc flds)
 
 data ResType ty
-   = ResTyH98           -- Constructor was declared using Haskell 98 syntax
-   | ResTyGADT ty       -- Constructor was declared using GADT-style syntax,
-                        --      and here is its result type
+   = ResTyH98             -- Constructor was declared using Haskell 98 syntax
+   | ResTyGADT SrcSpan ty -- Constructor was declared using GADT-style syntax,
+                          --      and here is its result type, and the SrcSpan
+                          --      of the original sigtype, for API Annotations
    deriving (Data, Typeable)
 
 instance Outputable ty => Outputable (ResType ty) where
          -- Debugging only
-   ppr ResTyH98       = ptext (sLit "ResTyH98")
-   ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> ppr ty
+   ppr ResTyH98         = ptext (sLit "ResTyH98")
+   ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> ppr ty
 
 pp_data_defn :: OutputableBndr name
                   => (HsContext name -> SDoc)   -- Printing the header
@@ -937,7 +943,7 @@ instance Outputable NewOrData where
   ppr DataType = ptext (sLit "data")
 
 pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
-pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
+pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
   = hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
 pp_condecls cs                    -- In H98 syntax
   = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
@@ -955,20 +961,21 @@ pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
     ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc cons
                                    : map (pprParendHsType . unLoc) tys)
     ppr_details (RecCon fields)  = ppr_con_names cons
-                                 <+> pprConDeclFields fields
+                                 <+> pprConDeclFields (unLoc fields)
 
 pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
                     , con_cxt = cxt, con_details = PrefixCon arg_tys
-                    , con_res = ResTyGADT res_ty })
+                    , con_res = ResTyGADT res_ty })
   = 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_names = cons, con_explicit = expl, con_qvars = tvs
-                    , con_cxt = cxt, con_details = RecCon fields, con_res = ResTyGADT res_ty })
+                    , con_cxt = cxt, con_details = RecCon fields
+                    , con_res = ResTyGADT _ res_ty })
   = sep [ppr_con_names cons <+> dcolon <+> pprHsForAll expl tvs cxt,
-         pprConDeclFields fields <+> arrow <+> ppr res_ty]
+         pprConDeclFields (unLoc fields) <+> arrow <+> ppr res_ty]
 
 pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {} })
   = pprConDecl (decl { con_details = PrefixCon [ty1,ty2] })
@@ -1190,11 +1197,11 @@ ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc
 ppOverlapPragma mb =
   case mb of
     Nothing           -> empty
-    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 #-}")
+    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 #-}")
 
 
 
@@ -1333,9 +1340,9 @@ data ForeignImport = -- import of a C entity
                      --
                      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
+                              (Maybe Header)       -- name of C header
+                              CImportSpec          -- details of the C entity
+                              (Located SourceText) -- original source text for
                                                    -- the C entity
   deriving (Data, Typeable)
 
@@ -1352,7 +1359,7 @@ data CImportSpec = CLabel    CLabelString     -- import address of a C label
 --
 data ForeignExport = CExport  (Located CExportSpec) -- contains the calling
                                                     -- convention
-                              (Located FastString)  -- original source text for
+                              (Located SourceText)  -- original source text for
                                                     -- the C entity
   deriving (Data, Typeable)
 
@@ -1399,6 +1406,14 @@ instance Outputable ForeignExport where
 ************************************************************************
 -}
 
+type LRuleDecls name = Located (RuleDecls name)
+
+  -- Note [Pragma source text] in BasicTypes
+data RuleDecls name = HsRules { rds_src   :: SourceText
+                              , rds_rules :: [LRuleDecl name] }
+  deriving (Typeable)
+deriving instance (DataId name) => Data (RuleDecls name)
+
 type LRuleDecl name = Located (RuleDecl name)
 
 data RuleDecl name
@@ -1412,13 +1427,18 @@ data RuleDecl name
         (Located (HsExpr name)) -- RHS
         (PostRn name NameSet)   -- Free-vars from the RHS
         -- ^
-        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
-        --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnVal',
-        --           'ApiAnnotation.AnnClose','ApiAnnotation.AnnTilde',
+        --  - 'ApiAnnotation.AnnKeywordId' :
+        --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde',
+        --           'ApiAnnotation.AnnVal',
+        --           'ApiAnnotation.AnnClose',
         --           'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot',
+        --           'ApiAnnotation.AnnEqual',
   deriving (Typeable)
 deriving instance (DataId name) => Data (RuleDecl name)
 
+flattenRuleDecls :: [LRuleDecls name] -> [LRuleDecl name]
+flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
+
 type LRuleBndr name = Located (RuleBndr name)
 data RuleBndr name
   = RuleBndr (Located name)
@@ -1432,6 +1452,9 @@ deriving instance (DataId name) => Data (RuleBndr name)
 collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs name (LHsType name)]
 collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
 
+instance OutputableBndr name => Outputable (RuleDecls name) where
+  ppr (HsRules _ rules) = ppr rules
+
 instance OutputableBndr name => Outputable (RuleDecl name) where
   ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)
         = sep [text "{-# RULES" <+> doubleQuotes (ftext $ unLoc name)
@@ -1467,15 +1490,18 @@ type LVectDecl name = Located (VectDecl name)
 
 data VectDecl name
   = HsVect
+      SourceText   -- Note [Pragma source text] in BasicTypes
       (Located name)
       (LHsExpr name)
         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --           'ApiAnnotation.AnnEqual','ApiAnnotation.AnnClose'
   | HsNoVect
+      SourceText   -- Note [Pragma source text] in BasicTypes
       (Located name)
         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --                                    'ApiAnnotation.AnnClose'
   | HsVectTypeIn                -- pre type-checking
+      SourceText                -- Note [Pragma source text] in BasicTypes
       Bool                      -- 'TRUE' => SCALAR declaration
       (Located name)
       (Maybe (Located name))    -- 'Nothing' => no right-hand side
@@ -1487,6 +1513,7 @@ data VectDecl name
       TyCon
       (Maybe TyCon)             -- 'Nothing' => no right-hand side
   | HsVectClassIn               -- pre type-checking
+      SourceText                -- Note [Pragma source text] in BasicTypes
       (Located name)
         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --           'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose',
@@ -1500,14 +1527,16 @@ data VectDecl name
 deriving instance (DataId name) => Data (VectDecl name)
 
 lvectDeclName :: NamedThing name => LVectDecl name -> Name
-lvectDeclName (L _ (HsVect         (L _ name) _))   = getName name
-lvectDeclName (L _ (HsNoVect       (L _ name)))     = getName name
-lvectDeclName (L _ (HsVectTypeIn   _ (L _ name) _)) = getName name
-lvectDeclName (L _ (HsVectTypeOut  _ tycon _))      = getName tycon
-lvectDeclName (L _ (HsVectClassIn  (L _ name)))     = getName name
-lvectDeclName (L _ (HsVectClassOut cls))            = getName cls
-lvectDeclName (L _ (HsVectInstIn   _))              = panic "HsDecls.lvectDeclName: HsVectInstIn"
-lvectDeclName (L _ (HsVectInstOut  _))              = panic "HsDecls.lvectDeclName: HsVectInstOut"
+lvectDeclName (L _ (HsVect _       (L _ name) _))    = getName name
+lvectDeclName (L _ (HsNoVect _     (L _ name)))      = getName name
+lvectDeclName (L _ (HsVectTypeIn _  _ (L _ name) _)) = getName name
+lvectDeclName (L _ (HsVectTypeOut  _ tycon _))       = getName tycon
+lvectDeclName (L _ (HsVectClassIn _ (L _ name)))     = getName name
+lvectDeclName (L _ (HsVectClassOut cls))             = getName cls
+lvectDeclName (L _ (HsVectInstIn _))
+  = panic "HsDecls.lvectDeclName: HsVectInstIn"
+lvectDeclName (L _ (HsVectInstOut  _))
+  = panic "HsDecls.lvectDeclName: HsVectInstOut"
 
 lvectInstDecl :: LVectDecl name -> Bool
 lvectInstDecl (L _ (HsVectInstIn _))  = True
@@ -1515,19 +1544,19 @@ lvectInstDecl (L _ (HsVectInstOut _)) = True
 lvectInstDecl _                       = False
 
 instance OutputableBndr name => Outputable (VectDecl name) where
-  ppr (HsVect v rhs)
+  ppr (HsVect v rhs)
     = sep [text "{-# VECTORISE" <+> ppr v,
            nest 4 $
              pprExpr (unLoc rhs) <+> text "#-}" ]
-  ppr (HsNoVect v)
+  ppr (HsNoVect v)
     = sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ]
-  ppr (HsVectTypeIn False t Nothing)
+  ppr (HsVectTypeIn False t Nothing)
     = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ]
-  ppr (HsVectTypeIn False t (Just t'))
+  ppr (HsVectTypeIn False t (Just t'))
     = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ]
-  ppr (HsVectTypeIn True t Nothing)
+  ppr (HsVectTypeIn True t Nothing)
     = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
-  ppr (HsVectTypeIn True t (Just t'))
+  ppr (HsVectTypeIn True t (Just t'))
     = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ]
   ppr (HsVectTypeOut False t Nothing)
     = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ]
@@ -1537,7 +1566,7 @@ instance OutputableBndr name => Outputable (VectDecl name) where
     = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
   ppr (HsVectTypeOut True t (Just t'))
     = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ]
-  ppr (HsVectClassIn c)
+  ppr (HsVectClassIn c)
     = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
   ppr (HsVectClassOut c)
     = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
@@ -1583,11 +1612,24 @@ docDeclDoc (DocGroup _ d) = d
 We use exported entities for things to deprecate.
 -}
 
+
+type LWarnDecls name = Located (WarnDecls name)
+
+ -- Note [Pragma source text] in BasicTypes
+data WarnDecls name = Warnings { wd_src :: SourceText
+                               , wd_warnings :: [LWarnDecl name]
+                               }
+  deriving (Data, Typeable)
+
+
 type LWarnDecl name = Located (WarnDecl name)
 
-data WarnDecl name = Warning name WarningTxt
+data WarnDecl name = Warning [Located name] WarningTxt
   deriving (Data, Typeable)
 
+instance OutputableBndr name => Outputable (WarnDecls name) where
+    ppr (Warnings _ decls) = ppr decls
+
 instance OutputableBndr name => Outputable (WarnDecl name) where
     ppr (Warning thing txt)
       = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
@@ -1602,7 +1644,9 @@ instance OutputableBndr name => Outputable (WarnDecl name) where
 
 type LAnnDecl name = Located (AnnDecl name)
 
-data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name))
+data AnnDecl name = HsAnnotation
+                      SourceText -- Note [Pragma source text] in BasicTypes
+                      (AnnProvenance name) (Located (HsExpr name))
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
       --           'ApiAnnotation.AnnType'
       --           'ApiAnnotation.AnnModule'
@@ -1611,24 +1655,27 @@ data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name))
 deriving instance (DataId name) => Data (AnnDecl name)
 
 instance (OutputableBndr name) => Outputable (AnnDecl name) where
-    ppr (HsAnnotation provenance expr)
+    ppr (HsAnnotation provenance expr)
       = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
 
-
-data AnnProvenance name = ValueAnnProvenance name
-                        | TypeAnnProvenance name
+data AnnProvenance name = ValueAnnProvenance (Located name)
+                        | TypeAnnProvenance (Located name)
                         | ModuleAnnProvenance
-  deriving (Data, Typeable, Functor, Foldable, Traversable)
+  deriving (Data, Typeable, Functor)
+deriving instance Foldable    AnnProvenance
+deriving instance Traversable AnnProvenance
 
 annProvenanceName_maybe :: AnnProvenance name -> Maybe name
-annProvenanceName_maybe (ValueAnnProvenance name) = Just name
-annProvenanceName_maybe (TypeAnnProvenance name)  = Just name
+annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name
+annProvenanceName_maybe (TypeAnnProvenance (L _ name))  = Just name
 annProvenanceName_maybe ModuleAnnProvenance       = Nothing
 
 pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc
 pprAnnProvenance ModuleAnnProvenance       = ptext (sLit "ANN module")
-pprAnnProvenance (ValueAnnProvenance name) = ptext (sLit "ANN") <+> ppr name
-pprAnnProvenance (TypeAnnProvenance name)  = ptext (sLit "ANN type") <+> ppr name
+pprAnnProvenance (ValueAnnProvenance (L _ name))
+  = ptext (sLit "ANN") <+> ppr name
+pprAnnProvenance (TypeAnnProvenance (L _ name))
+  = ptext (sLit "ANN type") <+> ppr name
 
 {-
 ************************************************************************
index 129ed80..e5dbd3c 100644 (file)
@@ -141,6 +141,7 @@ data HsExpr id
        -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
        --           'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen',
        --           'ApiAnnotation.AnnClose'
+
   | HsApp     (LHsExpr id) (LHsExpr id) -- ^ Application
 
   -- | Operator applications:
@@ -161,12 +162,8 @@ data HsExpr id
   | NegApp      (LHsExpr id)
                 (SyntaxExpr id)
 
-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --             'ApiAnnotation.AnnClose'
-  --   - Note: if 'ApiAnnotation.AnnVal' is present this is actually an
-  --           inactive 'HsSCC'
-  --   - Note: if multiple 'ApiAnnotation.AnnVal' are
-  --            present this is actually an inactive 'HsTickPragma'
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
+  --             'ApiAnnotation.AnnClose' @')'@
   | HsPar       (LHsExpr id)    -- ^ Parenthesised expr; see Note [Parens in HsSyn]
 
   | SectionL    (LHsExpr id)    -- operand; see Note [Sections in HsSyn]
@@ -183,14 +180,14 @@ data HsExpr id
         Boxity
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',
-  --       'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen',
-  --       'ApiAnnotation.AnnClose'
+  --       'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,
+  --       'ApiAnnotation.AnnClose' @'}'@
   | HsCase      (LHsExpr id)
                 (MatchGroup id (LHsExpr id))
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf',
   --       'ApiAnnotation.AnnSemi',
-  --       'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi2',
+  --       'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi',
   --       'ApiAnnotation.AnnElse',
   | HsIf        (Maybe (SyntaxExpr id)) -- cond function
                                         -- Nothing => use the built-in 'if'
@@ -208,8 +205,8 @@ data HsExpr id
   -- | let(rec)
   --
   -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',
-  --       'ApiAnnotation.AnnIn','ApiAnnotation.AnnOpen',
-  --       'ApiAnnotation.AnnClose'
+  --       'ApiAnnotation.AnnOpen' @'{'@,
+  --       'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn'
   | HsLet       (HsLocalBinds id)
                 (LHsExpr  id)
 
@@ -225,8 +222,8 @@ data HsExpr id
 
   -- | Syntactic list: [a,b,c,...]
   --
-  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --              'ApiAnnotation.AnnClose'
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
+  --              'ApiAnnotation.AnnClose' @']'@
   | ExplicitList
                 (PostTc id Type)        -- Gives type of components of list
                 (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromListN witness
@@ -234,18 +231,18 @@ data HsExpr id
 
   -- | Syntactic parallel array: [:e1, ..., en:]
   --
-  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
   --              'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnComma',
   --              'ApiAnnotation.AnnVbar'
-  --              'ApiAnnotation.AnnClose'
+  --              'ApiAnnotation.AnnClose' @':]'@
   | ExplicitPArr
                 (PostTc id Type)   -- type of elements of the parallel array
                 [LHsExpr id]
 
   -- | Record construction
   --
-  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --         'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose'
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,
+  --         'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@
   | RecordCon   (Located id)       -- The constructor.  After type checking
                                    -- it's the dataConWrapId of the constructor
                 PostTcExpr         -- Data con Id applied to type args
@@ -253,8 +250,8 @@ data HsExpr id
 
   -- | Record update
   --
-  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --         'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose'
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,
+  --         'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@
   | RecordUpd   (LHsExpr id)
                 (HsRecordBinds id)
 --              (HsMatchGroup Id)  -- Filled in by the type checker to be
@@ -285,27 +282,37 @@ data HsExpr id
 
   -- | Arithmetic sequence
   --
-  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --              'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnComma',
-  --              'ApiAnnotation.AnnClose'
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
+  --              'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot',
+  --              'ApiAnnotation.AnnClose' @']'@
   | ArithSeq
                 PostTcExpr
                 (Maybe (SyntaxExpr id))   -- For OverloadedLists, the fromList witness
                 (ArithSeqInfo id)
 
   -- | Arithmetic sequence for parallel array
+  --
+  -- > [:e1..e2:] or [:e1, e2..e3:]
+  --
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
+  --              'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot',
+  --              'ApiAnnotation.AnnVbar',
+  --              'ApiAnnotation.AnnClose' @':]'@
   | PArrSeq
-                PostTcExpr              -- [:e1..e2:] or [:e1, e2..e3:]
+                PostTcExpr
                 (ArithSeqInfo id)
 
-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --             'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose'
-  | HsSCC       FastString              -- "set cost centre" SCC pragma
-                (LHsExpr id)            -- expr whose cost is to be measured
-
-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --             'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose'
-  | HsCoreAnn   FastString              -- hdaume: core annotation
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# SCC'@,
+  --             'ApiAnnotation.AnnVal' or 'ApiAnnotation.AnnValStr',
+  --              'ApiAnnotation.AnnClose' @'\#-}'@
+  | HsSCC       SourceText            -- Note [Pragma source text] in BasicTypes
+                FastString            -- "set cost centre" SCC pragma
+                (LHsExpr id)          -- expr whose cost is to be measured
+
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@,
+  --             'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@
+  | HsCoreAnn   SourceText            -- Note [Pragma source text] in BasicTypes
+                FastString            -- hdaume: core annotation
                 (LHsExpr id)
 
   -----------------------------------------------------------
@@ -349,6 +356,7 @@ data HsExpr id
 
   ---------------------------------------
   -- static pointers extension
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic',
   | HsStatic    (LHsExpr id)
 
   ---------------------------------------
@@ -368,8 +376,8 @@ data HsExpr id
         Bool             -- True => right-to-left (f -< arg)
                          -- False => left-to-right (arg >- f)
 
-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --         'ApiAnnotation.AnnClose'
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(|'@,
+  --         'ApiAnnotation.AnnClose' @'|)'@
   | HsArrForm            -- Command formation,  (| e cmd1 .. cmdn |)
         (LHsExpr id)     -- the operator
                          -- after type-checking, a type abstraction to be
@@ -391,15 +399,16 @@ data HsExpr id
      (LHsExpr id)                       -- sub-expression
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --       'ApiAnnotation.AnnOpen',
-  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal2',
-  --       'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal3',
+  --       'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@,
+  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal',
+  --       'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal',
   --       'ApiAnnotation.AnnMinus',
-  --       'ApiAnnotation.AnnVal4','ApiAnnotation.AnnColon2',
-  --       'ApiAnnotation.AnnVal5',
-  --       'ApiAnnotation.AnnClose'
-  | HsTickPragma                        -- A pragma introduced tick
-     (FastString,(Int,Int),(Int,Int))   -- external span for this tick
+  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon',
+  --       'ApiAnnotation.AnnVal',
+  --       'ApiAnnotation.AnnClose' @'\#-}'@
+  | HsTickPragma                      -- A pragma introduced tick
+     SourceText                       -- Note [Pragma source text] in BasicTypes
+     (FastString,(Int,Int),(Int,Int)) -- external span for this tick
      (LHsExpr id)
 
   ---------------------------------------
@@ -520,7 +529,7 @@ ppr_expr (HsLit lit)     = ppr lit
 ppr_expr (HsOverLit lit) = ppr lit
 ppr_expr (HsPar e)       = parens (ppr_lexpr e)
 
-ppr_expr (HsCoreAnn s e)
+ppr_expr (HsCoreAnn s e)
   = vcat [ptext (sLit "HsCoreAnn") <+> ftext s, ppr_lexpr e]
 
 ppr_expr (HsApp e1 e2)
@@ -642,7 +651,7 @@ ppr_expr (ELazyPat e)   = char '~' <> pprParendExpr e
 ppr_expr (EAsPat v e)   = ppr v <> char '@' <> pprParendExpr e
 ppr_expr (EViewPat p e) = ppr p <+> ptext (sLit "->") <+> ppr e
 
-ppr_expr (HsSCC lbl expr)
+ppr_expr (HsSCC lbl expr)
   = sep [ ptext (sLit "{-# SCC") <+> doubleQuotes (ftext lbl) <+> ptext (sLit "#-}"),
           pprParendExpr expr ]
 
@@ -674,7 +683,7 @@ ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
           ppr tickIdFalse,
           ptext (sLit ">("),
           ppr exp,ptext (sLit ")")]
-ppr_expr (HsTickPragma externalSrcLoc exp)
+ppr_expr (HsTickPragma externalSrcLoc exp)
   = pprTicks (ppr exp) $
     hcat [ptext (sLit "tickpragma<"),
           ppr externalSrcLoc,
@@ -770,6 +779,9 @@ We re-use HsExpr to represent these.
 type LHsCmd id = Located (HsCmd id)
 
 data HsCmd id
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail',
+  --          'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail',
+  --          'ApiAnnotation.AnnRarrowtail'
   = HsCmdArrApp          -- Arrow tail, or arrow application (f -< arg)
         (LHsExpr id)     -- arrow expression, f
         (LHsExpr id)     -- input expression, arg
@@ -779,6 +791,8 @@ data HsCmd id
         Bool             -- True => right-to-left (f -< arg)
                          -- False => left-to-right (arg >- f)
 
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(|'@,
+  --         'ApiAnnotation.AnnClose' @'|)'@
   | HsCmdArrForm         -- Command formation,  (| e cmd1 .. cmdn |)
         (LHsExpr id)     -- the operator
                          -- after type-checking, a type abstraction to be
@@ -791,22 +805,40 @@ data HsCmd id
                 (LHsExpr id)
 
   | HsCmdLam    (MatchGroup id (LHsCmd id))     -- kappa
+       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
+       --       'ApiAnnotation.AnnRarrow',
 
   | HsCmdPar    (LHsCmd id)                     -- parenthesised command
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
+    --             'ApiAnnotation.AnnClose' @')'@
 
   | HsCmdCase   (LHsExpr id)
                 (MatchGroup id (LHsCmd id))     -- bodies are HsCmd's
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',
+    --       'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,
+    --       'ApiAnnotation.AnnClose' @'}'@
 
   | HsCmdIf     (Maybe (SyntaxExpr id))         -- cond function
                 (LHsExpr id)                    -- predicate
                 (LHsCmd id)                     -- then part
                 (LHsCmd id)                     -- else part
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf',
+    --       'ApiAnnotation.AnnSemi',
+    --       'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi',
+    --       'ApiAnnotation.AnnElse',
 
   | HsCmdLet    (HsLocalBinds id)               -- let(rec)
                 (LHsCmd  id)
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',
+    --       'ApiAnnotation.AnnOpen' @'{'@,
+    --       'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn'
 
   | HsCmdDo     [CmdLStmt id]
                 (PostTc id Type)                -- Type of the whole expression
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',
+    --             'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi',
+    --             'ApiAnnotation.AnnVbar',
+    --             'ApiAnnotation.AnnClose'
 
   | HsCmdCast   TcCoercion     -- A simpler version of HsWrap in HsExpr
                 (HsCmd id)     -- If   cmd :: arg1 --> res
@@ -818,8 +850,8 @@ deriving instance (DataId id) => Data (HsCmd id)
 data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
   deriving (Data, Typeable)
 
-{-
-Top-level command, introducing a new arrow.
+
+{- | Top-level command, introducing a new arrow.
 This may occur inside a proc (where the stack is empty) or as an
 argument of a command-forming operator.
 -}
@@ -968,14 +1000,44 @@ type LMatch id body = Located (Match id body)
 -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a
 --   list
 data Match id body
-  = Match
-        [LPat id]               -- The patterns
-        (Maybe (LHsType id))    -- A type signature for the result of the match
-                                -- Nothing after typechecking
-        (GRHSs id body)
-  deriving (Typeable)
+  = Match {
+        m_fun_id_infix :: (Maybe (Located id,Bool)),
+          -- fun_id and fun_infix for functions with multiple equations
+          -- only present for a RdrName. See note [fun_id in Match]
+        m_pats :: [LPat id], -- The patterns
+        m_type :: (Maybe (LHsType id)),
+                                 -- A type signature for the result of the match
+                                 -- Nothing after typechecking
+        m_grhss :: (GRHSs id body)
+  } deriving (Typeable)
 deriving instance (Data body,DataId id) => Data (Match id body)
 
+{-
+Note [fun_id in Match]
+~~~~~~~~~~~~~~~~~~~~~~
+
+The parser initially creates a FunBind with a single Match in it for
+every function definition it sees.
+
+These are then grouped together by getMonoBind into a single FunBind,
+where all the Matches are combined.
+
+In the process, all the original FunBind fun_id's bar one are
+discarded, including the locations.
+
+This causes a problem for source to source conversions via API
+Annotations, so the original fun_ids and infix flags are preserved in
+the Match, when it originates from a FunBind.
+
+Example infix function definition requiring individual API Annotations
+
+    (&&&  ) [] [] =  []
+    xs    &&&   [] =  xs
+    (  &&&  ) [] ys =  ys
+
+
+-}
+
 isEmptyMatchGroup :: MatchGroup id body -> Bool
 isEmptyMatchGroup (MG { mg_alts = ms }) = null ms
 
@@ -987,7 +1049,7 @@ matchGroupArity (MG { mg_alts = alts })
   | otherwise        = panic "matchGroupArity"
 
 hsLMatchPats :: LMatch id body -> [LPat id]
-hsLMatchPats (L _ (Match pats _ _)) = pats
+hsLMatchPats (L _ (Match pats _ _)) = pats
 
 -- | GRHSs are used both for pattern bindings and for Matches
 --
@@ -1031,7 +1093,7 @@ pprPatBind pat (grhss)
 
 pprMatch :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
          => HsMatchContext idL -> Match idR body -> SDoc
-pprMatch ctxt (Match pats maybe_ty grhss)
+pprMatch ctxt (Match pats maybe_ty grhss)
   = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
         , nest 2 ppr_maybe_ty
         , nest 2 (pprGRHSs ctxt grhss) ]
@@ -1136,6 +1198,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
              (PostTc idR Type) -- Element type of the RHS (used for arrows)
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet'
+  --          'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@,
   | LetStmt  (HsLocalBindsLR idL idR)
 
   -- ParStmts only occur in a list/monad comprehension
index 166dddc..892202f 100644 (file)
@@ -13,6 +13,7 @@ module HsImpExp where
 import Module           ( ModuleName )
 import HsDoc            ( HsDocString )
 import OccName          ( HasOccName(..), isTcOcc, isSymOcc )
+import BasicTypes       ( SourceText )
 
 import Outputable
 import FastString
@@ -39,6 +40,8 @@ type LImportDecl name = Located (ImportDecl name)
 -- | A single Haskell @import@ declaration.
 data ImportDecl name
   = ImportDecl {
+      ideclSourceSrc :: Maybe SourceText,
+                                 -- Note [Pragma source text] in BasicTypes
       ideclName      :: Located ModuleName, -- ^ Module name.
       ideclPkgQual   :: Maybe FastString,  -- ^ Package qualifier.
       ideclSource    :: Bool,              -- ^ True <=> {-\# SOURCE \#-} import
@@ -68,6 +71,7 @@ data ImportDecl name
 
 simpleImportDecl :: ModuleName -> ImportDecl name
 simpleImportDecl mn = ImportDecl {
+      ideclSourceSrc = Nothing,
       ideclName      = noLoc mn,
       ideclPkgQual   = Nothing,
       ideclSource    = False,
@@ -131,7 +135,7 @@ data IE name
   = IEVar       (Located name)
         -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern',
         --             'ApiAnnotation.AnnType'
-  | IEThingAbs           name      -- ^ Class/Type (can't tell)
+  | IEThingAbs  (Located name)     -- ^ Class/Type (can't tell)
         --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern',
         --             'ApiAnnotation.AnnType','ApiAnnotation.AnnVal'
   | IEThingAll  (Located name)     -- ^ Class/Type plus all methods/constructors
@@ -156,14 +160,14 @@ data IE name
 
 ieName :: IE name -> name
 ieName (IEVar (L _ n))         = n
-ieName (IEThingAbs  n)         = n
+ieName (IEThingAbs  (L _ n))   = n
 ieName (IEThingWith (L _ n) _) = n
 ieName (IEThingAll  (L _ n))   = n
 ieName _ = panic "ieName failed pattern match!"
 
 ieNames :: IE a -> [a]
 ieNames (IEVar       (L _ n)   ) = [n]
-ieNames (IEThingAbs       n    ) = [n]
+ieNames (IEThingAbs  (L _ n)   ) = [n]
 ieNames (IEThingAll  (L _ n)   ) = [n]
 ieNames (IEThingWith (L _ n) ns) = n : map unLoc ns
 ieNames (IEModuleContents _    ) = []
@@ -180,7 +184,7 @@ pprImpExp name = type_pref <+> pprPrefixOcc name
 
 instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where
     ppr (IEVar          var)    = pprPrefixOcc (unLoc var)
-    ppr (IEThingAbs     thing)  = pprImpExp thing
+    ppr (IEThingAbs     thing)  = pprImpExp (unLoc thing)
     ppr (IEThingAll      thing) = hcat [pprImpExp (unLoc thing), text "(..)"]
     ppr (IEThingWith thing withs)
         = pprImpExp (unLoc thing) <> parens (fsep (punctuate comma
index 5e673ad..90e79d1 100644 (file)
@@ -19,12 +19,11 @@ module HsLit where
 #include "HsVersions.h"
 
 import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr )
-import BasicTypes ( FractionalLit(..) )
+import BasicTypes ( FractionalLit(..),SourceText )
 import Type       ( Type )
 import Outputable
 import FastString
 import PlaceHolder ( PostTc,PostRn,DataId )
-import Lexer       ( SourceText )
 
 import Data.ByteString (ByteString)
 import Data.Data hiding ( Fixity )
@@ -37,7 +36,8 @@ import Data.Data hiding ( Fixity )
 ************************************************************************
 -}
 
--- Note [literal source text] for SourceText fields in the following
+-- Note [literal source text] in BasicTypes for SourceText fields in
+-- the following
 data HsLit
   = HsChar          SourceText Char        -- Character
   | HsCharPrim      SourceText Char        -- Unboxed character
@@ -84,7 +84,8 @@ data HsOverLit id       -- An overloaded literal
   deriving (Typeable)
 deriving instance (DataId id) => Data (HsOverLit id)
 
--- Note [literal source text] for SourceText fields in the following
+-- Note [literal source text] in BasicTypes for SourceText fields in
+-- the following
 data OverLitVal
   = HsIntegral   !SourceText !Integer    -- Integer-looking literals;
   | HsFractional !FractionalLit          -- Frac-looking literals
@@ -95,36 +96,6 @@ overLitType :: HsOverLit a -> PostTc a Type
 overLitType = ol_type
 
 {-
-Note [literal source text]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The lexer/parser converts literals from their original source text
-versions to an appropriate internal representation. This is a problem
-for tools doing source to source conversions, so the original source
-text is stored in literals where this can occur.
-
-Motivating examples for HsLit
-
-  HsChar          '\n', '\x20`
-  HsCharPrim      '\x41`#
-  HsString        "\x20\x41" == " A"
-  HsStringPrim    "\x20"#
-  HsInt           001
-  HsIntPrim       002#
-  HsWordPrim      003##
-  HsInt64Prim     004##
-  HsWord64Prim    005##
-  HsInteger       006
-
-For OverLitVal
-
-  HsIntegral      003,0x001
-  HsIsString      "\x41nd"
-
-
-
-
-
 Note [ol_rebindable]
 ~~~~~~~~~~~~~~~~~~~~
 The ol_rebindable field is True if this literal is actually
index f38665f..ea8f625 100644 (file)
@@ -67,10 +67,17 @@ data Pat id
 
   | VarPat      id                      -- Variable
   | LazyPat     (LPat id)               -- Lazy pattern
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
+
   | AsPat       (Located id) (LPat id)  -- As pattern
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
+
   | ParPat      (LPat id)               -- Parenthesised pattern
                                         -- See Note [Parens in HsSyn] in HsExpr
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
+    --                                    'ApiAnnotation.AnnClose' @')'@
   | BangPat     (LPat id)               -- Bang pattern
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
 
         ------------ Lists, tuples, arrays ---------------
   | ListPat     [LPat id]                            -- Syntactic list
@@ -79,6 +86,8 @@ data Pat id
                    -- For OverloadedLists a Just (ty,fn) gives
                    -- overall type of the pattern, and the toList
                    -- function to convert the scrutinee to a list value
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
+    --                                    'ApiAnnotation.AnnClose' @']'@
 
   | TuplePat    [LPat id]        -- Tuple sub-patterns
                 Boxity           -- UnitPat is TuplePat []
@@ -99,9 +108,14 @@ data Pat id
         -- of the tuple is of type 'a' not Int.  See selectMatchVar
         -- (June 14: I'm not sure this comment is right; the sub-patterns
         --           will be wrapped in CoPats, no?)
+    -- ^ - 'ApiAnnotation.AnnKeywordId' :
+    --            'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
+    --            'ApiAnnotation.AnnClose' @')'@ or  @'#)'@
 
   | PArrPat     [LPat id]               -- Syntactic parallel array
                 (PostTc id Type)        -- The type of the elements
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
+    --                                    'ApiAnnotation.AnnClose' @':]'@
 
         ------------ Constructor patterns ---------------
   | ConPatIn    (Located id)
@@ -124,6 +138,7 @@ data Pat id
     }
 
         ------------ View patterns ---------------
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
   | ViewPat       (LHsExpr id)
                   (LPat id)
                   (PostTc id Type)  -- The overall type of the pattern
@@ -131,6 +146,8 @@ data Pat id
                                     -- for hsPatType.
 
         ------------ Pattern splices ---------------
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@
+  --        'ApiAnnotation.AnnClose' @')'@
   | SplicePat       (HsSplice id)
 
         ------------ Quasiquoted patterns ---------------
@@ -143,17 +160,19 @@ data Pat id
 
   | NPat                -- Used for all overloaded literals,
                         -- including overloaded strings with -XOverloadedStrings
-                    (HsOverLit id)              -- ALWAYS positive
+                    (Located (HsOverLit id))    -- ALWAYS positive
                     (Maybe (SyntaxExpr id))     -- Just (Name of 'negate') for negative
                                                 -- patterns, Nothing otherwise
                     (SyntaxExpr id)             -- Equality checker, of type t->t->Bool
 
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
   | NPlusKPat       (Located id)        -- n+k pattern
-                    (HsOverLit id)      -- It'll always be an HsIntegral
+                    (Located (HsOverLit id)) -- It'll always be an HsIntegral
                     (SyntaxExpr id)     -- (>=) function, of type t->t->Bool
                     (SyntaxExpr id)     -- Name of '-' (see RnEnv.lookupSyntaxName)
 
         ------------ Pattern type signatures ---------------
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
   | SigPatIn        (LPat id)                  -- Pattern with a type signature
                     (HsWithBndrs id (LHsType id)) -- Signature can bind both
                                                   -- kind and type vars
index 41142bb..ce1d319 100644 (file)
@@ -132,6 +132,7 @@ See also Note [Kind and type-variable binders] in RnTypes
 -}
 
 type LHsContext name = Located (HsContext name)
+      -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnUnit'
 
 type HsContext name = [LHsType name]
 
@@ -216,7 +217,7 @@ data HsTyVarBndr name
          name
 
   | KindedTyVar
-         name
+         (Located name)
          (LHsKind name)  -- The user-supplied kind signature
         -- ^
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
@@ -233,11 +234,6 @@ isHsKindedTyVar (KindedTyVar {}) = True
 hsTvbAllKinded :: LHsTyVarBndrs name -> Bool
 hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvBndrs
 
---------------------------------------------------
--- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon',
---            'ApiAnnotation.AnnTilde','ApiAnnotation.AnnRarrow',
---            'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
---            'ApiAnnotation.AnnComma'
 data HsType name
   = HsForAllTy  HsExplicitFlag          -- Renamer leaves this flag unchanged, to record the way
                                         -- the user wrote it originally, so that the printer can
@@ -253,73 +249,119 @@ data HsType name
                 (LHsType name)
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall',
       --         'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
+
   | HsTyVar             name            -- Type variable, type constructor, or data constructor
                                         -- see Note [Promotions (HsTyVar)]
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
   | HsAppTy             (LHsType name)
                         (LHsType name)
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
   | HsFunTy             (LHsType name)   -- function type
                         (LHsType name)
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow',
 
   | HsListTy            (LHsType name)  -- Element type
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
+      --         'ApiAnnotation.AnnClose' @']'@
 
   | HsPArrTy            (LHsType name)  -- Elem. type of parallel array: [:t:]
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
+      --         'ApiAnnotation.AnnClose' @':]'@
 
   | HsTupleTy           HsTupleSort
                         [LHsType name]  -- Element types (length gives arity)
+    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@,
+    --         'ApiAnnotation.AnnClose' @')' or '#)'@
 
   | HsOpTy              (LHsType name) (LHsTyOp name) (LHsType name)
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
   | HsParTy             (LHsType name)   -- See Note [Parens in HsSyn] in HsExpr
         -- Parenthesis preserved for the precedence re-arrangement in RnTypes
         -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
+      --         'ApiAnnotation.AnnClose' @')'@
 
   | HsIParamTy          HsIPName         -- (?x :: ty)
                         (LHsType name)   -- Implicit parameters as they occur in contexts
+      -- ^
+      -- > (?x :: ty)
+      --
+      -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
 
   | HsEqTy              (LHsType name)   -- ty1 ~ ty2
                         (LHsType name)   -- Always allowed even without TypeOperators, and has special kinding rule
+      -- ^
+      -- > ty1 ~ ty2
+      --
+      -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
 
   | HsKindSig           (LHsType name)  -- (ty :: kind)
                         (LHsKind name)  -- A type with a kind signature
+      -- ^
+      -- > (ty :: kind)
+      --
+      -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
+      --         'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' @')'@
 
   | HsQuasiQuoteTy      (HsQuasiQuote name)
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
   | HsSpliceTy          (HsSplice name)
                         (PostTc name Kind)
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@,
+      --         'ApiAnnotation.AnnClose' @')'@
 
   | HsDocTy             (LHsType name) LHsDocString -- A documented type
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
   | HsBangTy    HsSrcBang (LHsType name)   -- Bang-style type annotations
-  | HsRecTy     [LConDeclField name]       -- Only in data type declarations
+      -- ^ - 'ApiAnnotation.AnnKeywordId' :
+      --         'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@,
+      --         'ApiAnnotation.AnnClose' @'#-}'@
+      --         'ApiAnnotation.AnnBang' @\'!\'@
+
+  | HsRecTy     [LConDeclField name]    -- Only in data type declarations
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,
+      --         'ApiAnnotation.AnnClose' @'}'@
 
   | HsCoreTy Type       -- An escape hatch for tunnelling a *closed*
                         -- Core Type through HsSyn.
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
   | HsExplicitListTy       -- A promoted explicit list
         (PostTc name Kind) -- See Note [Promoted lists and tuples]
         [LHsType name]
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@,
+      --         'ApiAnnotation.AnnClose' @']'@
 
   | HsExplicitTupleTy      -- A promoted explicit tuple
         [PostTc name Kind] -- See Note [Promoted lists and tuples]
         [LHsType name]
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@,
+      --         'ApiAnnotation.AnnClose' @')'@
 
   | HsTyLit HsTyLit      -- A promoted numeric literal.
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
   | HsWrapTy HsTyWrapper (HsType name)  -- only in typechecker output
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
   | HsWildcardTy           -- A type wildcard
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
   | HsNamedWildcardTy name -- A named wildcard
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
   deriving (Typeable)
 deriving instance (DataId name) => Data (HsType name)
 
-
+-- Note [literal source text] in BasicTypes for SourceText fields in
+-- the following
 data HsTyLit
-  = HsNumTy Integer
-  | HsStrTy FastString
+  = HsNumTy SourceText Integer
+  | HsStrTy SourceText FastString
     deriving (Data, Typeable)
 
 data HsTyWrapper
@@ -504,8 +546,8 @@ hsExplicitTvs _                                     = []
 
 ---------------------
 hsTyVarName :: HsTyVarBndr name -> name
-hsTyVarName (UserTyVar n)     = n
-hsTyVarName (KindedTyVar n _) = n
+hsTyVarName (UserTyVar n)           = n
+hsTyVarName (KindedTyVar (L _ n) _) = n
 
 hsLTyVarName :: LHsTyVarBndr name -> name
 hsLTyVarName = hsTyVarName . unLoc
@@ -812,5 +854,5 @@ ppr_fun_ty ctxt_prec ty1 ty2
 
 --------------------------
 ppr_tylit :: HsTyLit -> SDoc
-ppr_tylit (HsNumTy i) = integer i
-ppr_tylit (HsStrTy s) = text (show s)
+ppr_tylit (HsNumTy i) = integer i
+ppr_tylit (HsStrTy s) = text (show s)
index 398aafd..4a80ebd 100644 (file)
@@ -122,7 +122,7 @@ mkHsPar e = L (getLoc e) (HsPar e)
 mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id))
 mkSimpleMatch pats rhs
   = L loc $
-    Match pats Nothing (unguardedGRHSs rhs)
+    Match Nothing pats Nothing (unguardedGRHSs rhs)
   where
     loc = case pats of
                 []      -> getLoc rhs
@@ -202,8 +202,8 @@ mkHsDo         :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName
 mkHsComp       :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName
                -> HsExpr RdrName
 
-mkNPat      :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
-mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
+mkNPat      :: Located (HsOverLit id) -> Maybe (SyntaxExpr id) -> Pat id
+mkNPlusKPat :: Located id -> Located (HsOverLit id) -> Pat id
 
 mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
 mkBodyStmt :: Located (bodyR RdrName)
@@ -460,10 +460,11 @@ toHsType ty
     to_hs_type (FunTy arg res) = ASSERT( not (isConstraintKind (typeKind arg)) )
                                  nlHsFunTy (toHsType arg) (toHsType res)
     to_hs_type t@(ForAllTy {}) = pprPanic "toHsType" (ppr t)
-    to_hs_type (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy n)
-    to_hs_type (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy s)
+    to_hs_type (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n)
+    to_hs_type (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s)
 
-    mk_hs_tvb tv = noLoc $ KindedTyVar (getRdrName tv) (toHsKind (tyVarKind tv))
+    mk_hs_tvb tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
+                                       (toHsKind (tyVarKind tv))
 
 toHsKind :: Kind -> LHsKind RdrName
 toHsKind = toHsType
@@ -564,7 +565,7 @@ mk_easy_FunBind loc fun pats expr
 ------------
 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id)
 mkMatch pats expr binds
-  = noLoc (Match (map paren pats) Nothing
+  = noLoc (Match Nothing (map paren pats) Nothing
                  (GRHSs (unguardedRHS noSrcSpan expr) binds))
   where
     paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
@@ -831,7 +832,8 @@ hsConDeclsBinders cons = go id cons
              -- avoid circumventing detection of duplicate fields (#9156)
              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)
+                  where r' = remSeen (concatMap (cd_fld_names . unLoc)
+                                                (unLoc flds))
                         remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc) v | v <- r']
              L loc (ConDecl { con_names = names }) ->
                 (map (L loc . unLoc) names) ++ go remSeen rs
index 877ae74..a17f3a9 100644 (file)
@@ -245,7 +245,8 @@ module GHC (
 
         -- * API Annotations
         ApiAnns,AnnKeywordId(..),AnnotationComment(..),
-        getAnnotation, getAnnotationComments,
+        getAnnotation, getAndRemoveAnnotation,
+        getAnnotationComments, getAndRemoveAnnotationComments,
 
         -- * Miscellaneous
         --sessionHscEnv,
index d09a43e..3473a4a 100644 (file)
@@ -110,7 +110,8 @@ mkPrelImports this_mod loc implicit_prelude import_decls
 
       preludeImportDecl :: LImportDecl RdrName
       preludeImportDecl
-        = L loc $ ImportDecl { ideclName      = L loc pRELUDE_NAME,
+        = L loc $ ImportDecl { ideclSourceSrc = Nothing,
+                               ideclName      = L loc pRELUDE_NAME,
                                ideclPkgQual   = Nothing,
                                ideclSource    = False,
                                ideclSafe      = False,  -- Not a safe import
index 42acd1a..c1675dd 100644 (file)
@@ -1085,7 +1085,11 @@ markUnsafeInfer tcg_env whyUnsafe = do
                             text str <+> text "is not allowed in Safe Haskell"]
         | otherwise = []
     badInsts insts = concat $ map badInst insts
-    badInst ins | overlapMode (is_flag ins) /= NoOverlap
+
+    checkOverlap (NoOverlap _) = False
+    checkOverlap _             = True
+
+    badInst ins | checkOverlap (overlapMode (is_flag ins))
                 = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $
                       ppr (overlapMode $ is_flag ins) <+>
                       text "overlap mode isn't allowed in Safe Haskell"]
index 4fdfa95..3b28635 100644 (file)
@@ -2386,6 +2386,7 @@ ms_imps ms =
     -- text, such as those induced by the use of plugins (the -plgFoo
     -- flag)
     mk_additional_import mod_nm = noLoc $ ImportDecl {
+      ideclSourceSrc = Nothing,
       ideclName      = noLoc mod_nm,
       ideclPkgQual   = Nothing,
       ideclSource    = False,
index 959b7e8..70c61f2 100644 (file)
@@ -990,6 +990,7 @@ dynCompileExpr :: GhcMonad m => String -> m Dynamic
 dynCompileExpr expr = do
     iis <- getContext
     let importDecl = ImportDecl {
+                         ideclSourceSrc = Nothing,
                          ideclName = noLoc (mkModuleName "Data.Dynamic"),
                          ideclPkgQual = Nothing,
                          ideclSource = False,
index 510f3dc..60f9172 100644 (file)
@@ -1,8 +1,8 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 
 module ApiAnnotation (
-  getAnnotation,
-  getAnnotationComments,
+  getAnnotation, getAndRemoveAnnotation,
+  getAnnotationComments,getAndRemoveAnnotationComments,
   ApiAnns,
   ApiAnnKey,
   AnnKeywordId(..),
@@ -132,28 +132,65 @@ getAnnotation (anns,_) span ann
        Nothing -> []
        Just ss -> ss
 
+-- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan'
+-- of the annotated AST element, and the known type of the annotation.
+-- The list is removed from the annotations.
+getAndRemoveAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId
+                       -> ([SrcSpan],ApiAnns)
+getAndRemoveAnnotation (anns,cs) span ann
+   = case Map.lookup (span,ann) anns of
+       Nothing -> ([],(anns,cs))
+       Just ss -> (ss,(Map.delete (span,ann) anns,cs))
+
 -- |Retrieve the comments allocated to the current 'SrcSpan'
+--
+--  Note: A given 'SrcSpan' may appear in multiple AST elements,
+--  beware of duplicates
 getAnnotationComments :: ApiAnns -> SrcSpan -> [Located AnnotationComment]
 getAnnotationComments (_,anns) span =
   case Map.lookup span anns of
     Just cs -> cs
     Nothing -> []
 
+-- |Retrieve the comments allocated to the current 'SrcSpan', and
+-- remove them from the annotations
+getAndRemoveAnnotationComments :: ApiAnns -> SrcSpan
+                               -> ([Located AnnotationComment],ApiAnns)
+getAndRemoveAnnotationComments (anns,canns) span =
+  case Map.lookup span canns of
+    Just cs -> (cs,(anns,Map.delete span canns))
+    Nothing -> ([],(anns,canns))
+
 -- --------------------------------------------------------------------
 
--- | Note: in general the names of these are taken from the
+-- | API Annotations exist so that tools can perform source to source
+-- conversions of Haskell code. They are used to keep track of the
+-- various syntactic keywords that are not captured in the existing
+-- AST.
+--
+-- The annotations, together with original source comments are made
+-- available in the @'pm_annotations'@ field of @'GHC.ParsedModule'@.
+-- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set in
+-- @'DynFlags.DynFlags'@ before parsing.
+--
+-- Note: in general the names of these are taken from the
 -- corresponding token, unless otherwise noted
 -- See note [Api annotations] above for details of the usage
 data AnnKeywordId
     = AnnAs
     | AnnAt
     | AnnBang  -- ^ '!'
+    | AnnBackquote -- ^ '`'
     | AnnBy
     | AnnCase -- ^ case or lambda case
     | AnnClass
-    | AnnClose -- ^  '}' or ']' or ')' or '#)' etc
+    | AnnClose -- ^  '\#)' or '\#-}'  etc
+    | AnnCloseC -- ^ '}'
+    | AnnCloseP -- ^ ')'
+    | AnnCloseS -- ^ ']'
     | AnnColon
-    | AnnComma
+    | AnnComma -- ^ as a list separator
+    | AnnCommaTuple -- ^ in a RdrName for a tuple
     | AnnDarrow -- ^ '=>'
     | AnnData
     | AnnDcolon -- ^ '::'
@@ -186,7 +223,10 @@ data AnnKeywordId
     | AnnModule
     | AnnNewtype
     | AnnOf
-    | AnnOpen   -- ^ '{' or '[' or '(' or '(#' etc
+    | AnnOpen   -- ^ '(\#' or '{-\# LANGUAGE' etc
+    | AnnOpenC   -- ^ '{'
+    | AnnOpenP   -- ^ '('
+    | AnnOpenS   -- ^ '['
     | AnnPackageName
     | AnnPattern
     | AnnProc
@@ -196,12 +236,15 @@ data AnnKeywordId
     | AnnRole
     | AnnSafe
     | AnnSemi -- ^ ';'
+    | AnnStatic -- ^ 'static'
     | AnnThen
     | AnnTilde -- ^ '~'
     | AnnTildehsh -- ^ '~#'
     | AnnType
+    | AnnUnit -- ^ '()' for types
     | AnnUsing
     | AnnVal  -- ^ e.g. INTEGER
+    | AnnValStr  -- ^ String value, will need quotes when output
     | AnnVbar -- ^ '|'
     | AnnWhere
     | Annlarrowtail -- ^ '-<'
index 596f3bd..495605e 100644 (file)
@@ -56,7 +56,7 @@
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 
 module Lexer (
-   Token(..), SourceText, lexer, pragState, mkPState, PState(..),
+   Token(..), lexer, pragState, mkPState, PState(..),
    P(..), ParseResult(..), getSrcLoc,
    getPState, getDynFlags, withThisPackage,
    failLocMsgP, failSpanMsgP, srcParseFail,
@@ -73,7 +73,7 @@ module Lexer (
    sccProfilingOn, hpcEnabled,
    addWarning,
    lexTokenStream,
-   addAnnotation
+   addAnnotation,AddAnn,mkParensApiAnn
   ) where
 
 -- base
@@ -112,7 +112,8 @@ import DynFlags
 -- compiler/basicTypes
 import SrcLoc
 import Module
-import BasicTypes       ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) )
+import BasicTypes     ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..),
+                        SourceText )
 
 -- compiler/parser
 import Ctype
@@ -507,8 +508,6 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
 
 {
 
-type SourceText = String -- Note [literal source text] in HsLit
-
 -- -----------------------------------------------------------------------------
 -- The token type
 
@@ -560,34 +559,34 @@ data Token
   | ITpattern
   | ITstatic
 
-  -- Pragmas
-  | ITinline_prag InlineSpec RuleMatchInfo
-  | ITspec_prag                 -- SPECIALISE
-  | ITspec_inline_prag Bool     -- SPECIALISE INLINE (or NOINLINE)
-  | ITsource_prag
-  | ITrules_prag
-  | ITwarning_prag
-  | ITdeprecated_prag
+  -- Pragmas, see  note [Pragma source text] in BasicTypes
+  | ITinline_prag       SourceText InlineSpec RuleMatchInfo
+  | ITspec_prag         SourceText                -- SPECIALISE
+  | ITspec_inline_prag  SourceText Bool    -- SPECIALISE INLINE (or NOINLINE)
+  | ITsource_prag       SourceText
+  | ITrules_prag        SourceText
+  | ITwarning_prag      SourceText
+  | ITdeprecated_prag   SourceText
   | ITline_prag
-  | ITscc_prag
-  | ITgenerated_prag
-  | ITcore_prag                 -- hdaume: core annotations
-  | ITunpack_prag
-  | ITnounpack_prag
-  | ITann_prag
+  | ITscc_prag          SourceText
+  | ITgenerated_prag    SourceText
+  | ITcore_prag         SourceText         -- hdaume: core annotations
+  | ITunpack_prag       SourceText
+  | ITnounpack_prag     SourceText
+  | ITann_prag          SourceText
   | ITclose_prag
   | IToptions_prag String
   | ITinclude_prag String
   | ITlanguage_prag
-  | ITvect_prag
-  | ITvect_scalar_prag
-  | ITnovect_prag
-  | ITminimal_prag
-  | IToverlappable_prag         -- instance overlap mode
-  | IToverlapping_prag          -- instance overlap mode
-  | IToverlaps_prag             -- instance overlap mode
-  | ITincoherent_prag           -- instance overlap mode
-  | ITctype
+  | ITvect_prag         SourceText
+  | ITvect_scalar_prag  SourceText
+  | ITnovect_prag       SourceText
+  | ITminimal_prag      SourceText
+  | IToverlappable_prag SourceText  -- instance overlap mode
+  | IToverlapping_prag  SourceText  -- instance overlap mode
+  | IToverlaps_prag     SourceText  -- instance overlap mode
+  | ITincoherent_prag   SourceText  -- instance overlap mode
+  | ITctype             SourceText
 
   | ITdotdot                    -- reserved symbols
   | ITcolon
@@ -640,15 +639,15 @@ data Token
 
   | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x
 
-  | ITchar       SourceText Char        -- Note [literal source text] in HsLit
-  | ITstring     SourceText FastString  -- Note [literal source text] in HsLit
-  | ITinteger    SourceText Integer     -- Note [literal source text] in HsLit
-  | ITrational   FractionalLit
+  | ITchar     SourceText Char       -- Note [literal source text] in BasicTypes
+  | ITstring   SourceText FastString -- Note [literal source text] in BasicTypes
+  | ITinteger  SourceText Integer    -- Note [literal source text] in BasicTypes
+  | ITrational FractionalLit
 
-  | ITprimchar   SourceText Char        -- Note [literal source text] in HsLit
-  | ITprimstring SourceText ByteString  -- Note [literal source text] in HsLit
-  | ITprimint    SourceText Integer     -- Note [literal source text] in HsLit
-  | ITprimword   SourceText Integer     -- Note [literal source text] in HsLit
+  | ITprimchar   SourceText Char     -- Note [literal source text] in BasicTypes
+  | ITprimstring SourceText ByteString -- Note [literal source text] @BasicTypes
+  | ITprimint    SourceText Integer  -- Note [literal source text] in BasicTypes
+  | ITprimword   SourceText Integer  -- Note [literal source text] in BasicTypes
   | ITprimfloat  FractionalLit
   | ITprimdouble FractionalLit
 
@@ -702,6 +701,7 @@ data Token
 instance Outputable Token where
   ppr x = text (show x)
 
+
 -- the bitmap provided as the third component indicates whether the
 -- corresponding extension keyword is valid under the extension options
 -- provided to the compiler; if the extension corresponding to *any* of the
@@ -1029,9 +1029,10 @@ withLexedDocType lexDocComment = do
 -- RULES pragmas turn on the forall and '.' keywords, and we turn them
 -- off again at the end of the pragma.
 rulePrag :: Action
-rulePrag span _buf _len = do
+rulePrag span buf len = do
   setExts (.|. xbit InRulePragBit)
-  return (L span ITrules_prag)
+  let !src = lexemeToString buf len
+  return (L span (ITrules_prag src))
 
 endPrag :: Action
 endPrag span _buf _len = do
@@ -2518,36 +2519,38 @@ ignoredPrags = Map.fromList (map ignored pragmas)
                      -- CFILES is a hugs-only thing.
                      pragmas = options_pragmas ++ ["cfiles", "contract"]
 
-oneWordPrags = Map.fromList([("rules", rulePrag),
-                           ("inline", token (ITinline_prag Inline FunLike)),
-                           ("inlinable", token (ITinline_prag Inlinable FunLike)),
-                           ("inlineable", token (ITinline_prag Inlinable FunLike)),
+oneWordPrags = Map.fromList([
+           ("rules", rulePrag),
+           ("inline", strtoken (\s -> (ITinline_prag s Inline FunLike))),
+           ("inlinable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))),
+           ("inlineable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))),
                                           -- Spelling variant
-                           ("notinline", token (ITinline_prag NoInline FunLike)),
-                           ("specialize", token ITspec_prag),
-                           ("source", token ITsource_prag),
-                           ("warning", token ITwarning_prag),
-                           ("deprecated", token ITdeprecated_prag),
-                           ("scc", token ITscc_prag),
-                           ("generated", token ITgenerated_prag),
-                           ("core", token ITcore_prag),
-                           ("unpack", token ITunpack_prag),
-                           ("nounpack", token ITnounpack_prag),
-                           ("ann", token ITann_prag),
-                           ("vectorize", token ITvect_prag),
-                           ("novectorize", token ITnovect_prag),
-                           ("minimal", token ITminimal_prag),
-                           ("overlaps", token IToverlaps_prag),
-                           ("overlappable", token IToverlappable_prag),
-                           ("overlapping", token IToverlapping_prag),
-                           ("incoherent", token ITincoherent_prag),
-                           ("ctype", token ITctype)])
-
-twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)),
-                             ("notinline conlike", token (ITinline_prag NoInline ConLike)),
-                             ("specialize inline", token (ITspec_inline_prag True)),
-                             ("specialize notinline", token (ITspec_inline_prag False)),
-                             ("vectorize scalar", token ITvect_scalar_prag)])
+           ("notinline", strtoken (\s -> (ITinline_prag s NoInline FunLike))),
+           ("specialize", strtoken (\s -> ITspec_prag s)),
+           ("source", strtoken (\s -> ITsource_prag s)),
+           ("warning", strtoken (\s -> ITwarning_prag s)),
+           ("deprecated", strtoken (\s -> ITdeprecated_prag s)),
+           ("scc", strtoken (\s -> ITscc_prag s)),
+           ("generated", strtoken (\s -> ITgenerated_prag s)),
+           ("core", strtoken (\s -> ITcore_prag s)),
+           ("unpack", strtoken (\s -> ITunpack_prag s)),
+           ("nounpack", strtoken (\s -> ITnounpack_prag s)),
+           ("ann", strtoken (\s -> ITann_prag s)),
+           ("vectorize", strtoken (\s -> ITvect_prag s)),
+           ("novectorize", strtoken (\s -> ITnovect_prag s)),
+           ("minimal", strtoken (\s -> ITminimal_prag s)),
+           ("overlaps", strtoken (\s -> IToverlaps_prag s)),
+           ("overlappable", strtoken (\s -> IToverlappable_prag s)),
+           ("overlapping", strtoken (\s -> IToverlapping_prag s)),
+           ("incoherent", strtoken (\s -> ITincoherent_prag s)),
+           ("ctype", strtoken (\s -> ITctype s))])
+
+twoWordPrags = Map.fromList([
+     ("inline conlike", strtoken (\s -> (ITinline_prag s Inline ConLike))),
+     ("notinline conlike", strtoken (\s -> (ITinline_prag s NoInline ConLike))),
+     ("specialize inline", strtoken (\s -> (ITspec_inline_prag s True))),
+     ("specialize notinline", strtoken (\s -> (ITspec_inline_prag s False))),
+     ("vectorize scalar", strtoken (\s -> ITvect_scalar_prag s))])
 
 dispatch_pragmas :: Map String Action -> Action
 dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
@@ -2585,6 +2588,10 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag))
 %************************************************************************
 -}
 
+-- |Encapsulated call to addAnnotation, requiring only the SrcSpan of
+-- the AST element the annotation belongs to
+type AddAnn = (SrcSpan -> P ())
+
 addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
 addAnnotation l a v = do
   addAnnotationOnly l a v
@@ -2595,6 +2602,22 @@ addAnnotationOnly l a v = P $ \s -> POk s {
   annotations = ((l,a), [v]) : annotations s
   } ()
 
+-- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
+-- 'AddAnn' values for the opening and closing bordering on the start
+-- and end of the span
+mkParensApiAnn :: SrcSpan -> [AddAnn]
+mkParensApiAnn (UnhelpfulSpan _)  = []
+mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc]
+  where
+    mj a l = (\s -> addAnnotation s a l)
+    f = srcSpanFile ss
+    sl = srcSpanStartLine ss
+    sc = srcSpanStartCol ss
+    el = srcSpanEndLine ss
+    ec = srcSpanEndCol ss
+    lo = mkSrcSpan (srcSpanStart s)         (mkSrcLoc f sl (sc+1))
+    lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s)
+
 queueComment :: Located Token -> P()
 queueComment c = P $ \s -> POk s {
   comment_q = commentToAnnotation c : comment_q s
index 36b27cf..9e3d5ff 100644 (file)
@@ -310,29 +310,29 @@ See https://ghc.haskell.org/trac/ghc/wiki/GhcAstAnnotations for some background.
  'pattern'      { L _ ITpattern } -- for pattern synonyms
  'static'       { L _ ITstatic }  -- for static pointers extension
 
- '{-# INLINE'             { L _ (ITinline_prag _ _) }
- '{-# SPECIALISE'         { L _ ITspec_prag }
- '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _) }
- '{-# SOURCE'                                   { L _ ITsource_prag }
- '{-# RULES'                                    { L _ ITrules_prag }
- '{-# CORE'                                     { L _ ITcore_prag }              -- hdaume: annotated core
- '{-# SCC'                { L _ ITscc_prag }
- '{-# GENERATED'          { L _ ITgenerated_prag }
- '{-# DEPRECATED'         { L _ ITdeprecated_prag }
- '{-# WARNING'            { L _ ITwarning_prag }
- '{-# UNPACK'             { L _ ITunpack_prag }
- '{-# NOUNPACK'           { L _ ITnounpack_prag }
- '{-# ANN'                { L _ ITann_prag }
- '{-# VECTORISE'          { L _ ITvect_prag }
- '{-# VECTORISE_SCALAR'   { L _ ITvect_scalar_prag }
- '{-# NOVECTORISE'        { L _ ITnovect_prag }
- '{-# MINIMAL'            { L _ ITminimal_prag }
- '{-# CTYPE'              { L _ ITctype }
- '{-# OVERLAPPING'        { L _ IToverlapping_prag }
- '{-# OVERLAPPABLE'       { L _ IToverlappable_prag }
- '{-# OVERLAPS'           { L _ IToverlaps_prag }
- '{-# INCOHERENT'         { L _ ITincoherent_prag }
- '#-}'                                          { L _ ITclose_prag }
+ '{-# INLINE'             { L _ (ITinline_prag _ _ _) }
+ '{-# SPECIALISE'         { L _ (ITspec_prag _) }
+ '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _ _) }
+ '{-# SOURCE'             { L _ (ITsource_prag _) }
+ '{-# RULES'              { L _ (ITrules_prag _) }
+ '{-# CORE'               { L _ (ITcore_prag _) }      -- hdaume: annotated core
+ '{-# SCC'                { L _ (ITscc_prag _)}
+ '{-# GENERATED'          { L _ (ITgenerated_prag _) }
+ '{-# DEPRECATED'         { L _ (ITdeprecated_prag _) }
+ '{-# WARNING'            { L _ (ITwarning_prag _) }
+ '{-# UNPACK'             { L _ (ITunpack_prag _) }
+ '{-# NOUNPACK'           { L _ (ITnounpack_prag _) }
+ '{-# ANN'                { L _ (ITann_prag _) }
+ '{-# VECTORISE'          { L _ (ITvect_prag _) }
+ '{-# VECTORISE_SCALAR'   { L _ (ITvect_scalar_prag _) }
+ '{-# NOVECTORISE'        { L _ (ITnovect_prag _) }
+ '{-# MINIMAL'            { L _ (ITminimal_prag _) }
+ '{-# CTYPE'              { L _ (ITctype _) }
+ '{-# OVERLAPPING'        { L _ (IToverlapping_prag _) }
+ '{-# OVERLAPPABLE'       { L _ (IToverlappable_prag _) }
+ '{-# OVERLAPS'           { L _ (IToverlaps_prag _) }
+ '{-# INCOHERENT'         { L _ (ITincoherent_prag _) }
+ '#-}'                    { L _ ITclose_prag }
 
  '..'           { L _ ITdotdot }                        -- reserved symbols
  ':'            { L _ ITcolon }
@@ -446,7 +446,8 @@ identifier :: { Located RdrName }
         | qcon                          { $1 }
         | qvarop                        { $1 }
         | qconop                        { $1 }
-    | '(' '->' ')'      { sLL $1 $> $ getRdrName funTyCon }
+    | '(' '->' ')'      {% ams (sLL $1 $> $ getRdrName funTyCon)
+                               [mj AnnOpenP $1,mj AnnRarrow $2,mj AnnCloseP $3] }
 
 -----------------------------------------------------------------------------
 -- Module Header
@@ -480,31 +481,37 @@ missing_module_keyword :: { () }
 
 maybemodwarning :: { Maybe (Located WarningTxt) }
     : '{-# DEPRECATED' strings '#-}'
-                      {% ajs (Just (sLL $1 $> $ DeprecatedTxt $ snd $ unLoc $2))
-                             (mo $1:mc $1: (fst $ unLoc $2)) }
+                      {% ajs (Just (sLL $1 $> $ DeprecatedTxt (sL1 $1 (getDEPRECATED_PRAGs $1)) (snd $ unLoc $2)))
+                             (mo $1:mc $3: (fst $ unLoc $2)) }
     | '{-# WARNING' strings '#-}'
-                         {% ajs (Just (sLL $1 $> $ WarningTxt $ snd $ unLoc $2))
+                         {% ajs (Just (sLL $1 $> $ WarningTxt (sL1 $1 (getWARNING_PRAGs $1)) (snd $ unLoc $2)))
                                 (mo $1:mc $3 : (fst $ unLoc $2)) }
     |  {- empty -}                  { Nothing }
 
 body    :: { ([AddAnn]
              ,([LImportDecl RdrName], [LHsDecl RdrName])) }
-        :  '{'            top '}'      { (mo $1:mc $3:(fst $2)
+        :  '{'            top '}'      { (moc $1:mcc $3:(fst $2)
                                          , snd $2) }
         |      vocurly    top close    { (fst $2, snd $2) }
 
 body2   :: { ([AddAnn]
              ,([LImportDecl RdrName], [LHsDecl RdrName])) }
-        :  '{' top '}'                          { (mo $1:mc $3
+        :  '{' top '}'                          { (moc $1:mcc $3
                                                    :(fst $2), snd $2) }
         |  missing_module_keyword top close     { ([],snd $2) }
 
 top     :: { ([AddAnn]
              ,([LImportDecl RdrName], [LHsDecl RdrName])) }
-        : importdecls                   { ([]
-                                          ,(reverse $1,[]))}
-        | importdecls ';' cvtopdecls    { ([mj AnnSemi $2]
-                                          ,(reverse $1,$3))}
+        : importdecls                   { (fst $1
+                                          ,(reverse $ snd $1,[]))}
+        | importdecls ';' cvtopdecls    {% if null (snd $1)
+                                             then return ((mj AnnSemi $2:(fst $1))
+                                                         ,(reverse $ snd $1,$3))
+                                             else do
+                                              { addAnnotation (gl $ head $ snd $1)
+                                                              AnnSemi (gl $2)
+                                              ; return (fst $1
+                                                       ,(reverse $ snd $1,$3)) }}
         | cvtopdecls                    { ([],([],$1)) }
 
 cvtopdecls :: { [LHsDecl RdrName] }
@@ -524,18 +531,18 @@ header  :: { Located (HsModule RdrName) }
                           Nothing)) }
 
 header_body :: { [LImportDecl RdrName] }
-        :  '{'            importdecls           { $2 }
-        |      vocurly    importdecls           { $2 }
+        :  '{'            importdecls           { snd $2 }
+        |      vocurly    importdecls           { snd $2 }
 
 header_body2 :: { [LImportDecl RdrName] }
-        :  '{' importdecls                      { $2 }
-        |  missing_module_keyword importdecls   { $2 }
+        :  '{' importdecls                      { snd $2 }
+        |  missing_module_keyword importdecls   { snd $2 }
 
 -----------------------------------------------------------------------------
 -- The Export List
 
 maybeexports :: { (Maybe (Located [LIE RdrName])) }
-        :  '(' exportlist ')'       {% ams (sLL $1 $> ()) [mo $1,mc $3] >>
+        :  '(' exportlist ')'       {% ams (sLL $1 $> ()) [mop $1,mcp $3] >>
                                        return (Just (sLL $1 $> (fromOL $2))) }
         |  {- empty -}              { Nothing }
 
@@ -575,10 +582,10 @@ export  :: { OrdList (LIE RdrName) }
 
 export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }
         : {- empty -}             { sL0 ([],ImpExpAbs) }
-        | '(' '..' ')'            { sLL $1 $> ([mo $1,mc $3,mj AnnDotdot $2]
+        | '(' '..' ')'            { sLL $1 $> ([mop $1,mcp $3,mj AnnDotdot $2]
                                        , ImpExpAll) }
-        | '(' ')'                 { sLL $1 $> ([mo $1,mc $2],ImpExpList []) }
-        | '(' qcnames ')'         { sLL $1 $> ([mo $1,mc $3],ImpExpList (reverse $2)) }
+        | '(' ')'                 { sLL $1 $> ([mop $1,mcp $2],ImpExpList []) }
+        | '(' qcnames ')'         { sLL $1 $> ([mop $1,mcp $3],ImpExpList (reverse $2)) }
 
 qcnames :: { [Located RdrName] }     -- A reversed list
         :  qcnames ',' qcname_ext       {% (aa (head $1) (AnnComma, $2)) >>
@@ -587,7 +594,7 @@ qcnames :: { [Located RdrName] }     -- A reversed list
 
 qcname_ext :: { Located RdrName }       -- Variable or data constructor
                                         -- or tagged type constructor
-        :  qcname                   {% ams $1 [mj AnnVal $1] }
+        :  qcname                   { $1 }
         |  'type' qcname            {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2)))
                                             [mj AnnType $1,mj AnnVal $2] }
 
@@ -602,29 +609,39 @@ qcname  :: { Located RdrName }  -- Variable or data constructor
 -- import decls can be *empty*, or even just a string of semicolons
 -- whereas topdecls must contain at least one topdecl.
 
-importdecls :: { [LImportDecl RdrName] }
-        : importdecls ';' importdecl  {% (asl $1 $2 $3) >>
-                                         return ($3 : $1) }
-        | importdecls ';'        {% addAnnotation (gl $ head $1) AnnSemi (gl $2)
-              -- AZ: can $1 above ever be [] due to the {- empty -} production?
-                                    >> return $1 }
-        | importdecl             { [$1] }
-        | {- empty -}            { [] }
+importdecls :: { ([AddAnn],[LImportDecl RdrName]) }
+        : importdecls ';' importdecl
+                                {% if null (snd $1)
+                                     then return (mj AnnSemi $2:fst $1,$3 : snd $1)
+                                     else do
+                                      { addAnnotation (gl $ head $ snd $1)
+                                                      AnnSemi (gl $2)
+                                      ; return (fst $1,$3 : snd $1) } }
+        | importdecls ';'       {% if null (snd $1)
+                                     then return ((mj AnnSemi $2:fst $1),snd $1)
+                                     else do
+                                       { addAnnotation (gl $ head $ snd $1)
+                                                       AnnSemi (gl $2)
+                                       ; return $1} }
+        | importdecl             { ([],[$1]) }
+        | {- empty -}            { ([],[]) }
 
 importdecl :: { LImportDecl RdrName }
         : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec
                 {% ams (L (comb4 $1 $6 (snd $7) $8) $
-                  ImportDecl { ideclName = $6, ideclPkgQual = snd $5
+                  ImportDecl { ideclSourceSrc = snd $ fst $2
+                             , ideclName = $6, ideclPkgQual = snd $5
                              , ideclSource = snd $2, ideclSafe = snd $3
                              , ideclQualified = snd $4, ideclImplicit = False
                              , ideclAs = unLoc (snd $7)
                              , ideclHiding = unLoc $8 })
-                   ((mj AnnImport $1 : fst $2 ++ fst $3 ++ fst $4
+                   ((mj AnnImport $1 : (fst $ fst $2) ++ fst $3 ++ fst $4
                                     ++ fst $5 ++ fst $7)) }
 
-maybe_src :: { ([AddAnn],IsBootInterface) }
-        : '{-# SOURCE' '#-}'           { ([mo $1,mc $2],True) }
-        | {- empty -}                  { ([],False) }
+maybe_src :: { (([AddAnn],Maybe SourceText),IsBootInterface) }
+        : '{-# SOURCE' '#-}'        { (([mo $1,mc $2],Just (getSOURCE_PRAGs $1))
+                                      ,True) }
+        | {- empty -}               { (([],Nothing),False) }
 
 maybe_safe :: { ([AddAnn],Bool) }
         : 'safe'                                { ([mj AnnSafe $1],True) }
@@ -649,12 +666,12 @@ maybeimpspec :: { Located (Maybe (Bool, Located [LIE RdrName])) }
         | {- empty -}              { noLoc Nothing }
 
 impspec :: { Located (Bool, Located [LIE RdrName]) }
-        :  '(' exportlist ')'                 {% ams (sLL $1 $> (False,
-                                                        sLL $1 $> $ fromOL $2))
-                                                      [mo $1,mc $3] }
-        |  'hiding' '(' exportlist ')'        {% ams (sLL $1 $> (True,
-                                                        sLL $1 $> $ fromOL $3))
-                                                 [mj AnnHiding $1,mo $2,mc $4] }
+        :  '(' exportlist ')'               {% ams (sLL $1 $> (False,
+                                                      sLL $1 $> $ fromOL $2))
+                                                   [mop $1,mcp $3] }
+        |  'hiding' '(' exportlist ')'      {% ams (sLL $1 $> (True,
+                                                      sLL $1 $> $ fromOL $3))
+                                               [mj AnnHiding $1,mop $2,mcp $4] }
 
 -----------------------------------------------------------------------------
 -- Fixity Declarations
@@ -670,9 +687,9 @@ infix   :: { Located FixityDirection }
         | 'infixr'                              { sL1 $1 InfixR }
 
 ops     :: { Located (OrdList (Located RdrName)) }
-        : ops ',' op              {% addAnnotation (gl $3) AnnComma (gl $2) >>
-                                     return (sLL $1 $> (unitOL $3 `appOL` (unLoc $1)))}
-        | op                      { sL1 $1 (unitOL $1) }
+        : ops ',' op       {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>
+                              return (sLL $1 $> ((unLoc $1) `appOL` unitOL $3))}
+        | op               { sL1 $1 (unitOL $1) }
 
 -----------------------------------------------------------------------------
 -- Top-Level Declarations
@@ -693,38 +710,41 @@ topdecl :: { OrdList (LHsDecl RdrName) }
         | 'default' '(' comma_types0 ')'    {% do { def <- checkValidDefaults $3
                                                   ; amsu (sLL $1 $> (DefD def))
                                                          [mj AnnDefault $1
-                                                         ,mo $2,mc $4] }}
-        | 'foreign' fdecl                       {% amsu (sLL $1 $> (unLoc $2))
-                                                        [mj AnnForeign $1] }
-        | '{-# DEPRECATED' deprecations '#-}'   { $2 } -- ++AZ++ TODO
-        | '{-# WARNING' warnings '#-}'          { $2 } -- ++AZ++ TODO
-        | '{-# RULES' rules '#-}'               { $2 } -- ++AZ++ TODO
-        | '{-# VECTORISE' qvar '=' exp '#-}' {% amsu (sLL $1 $> $ VectD (HsVect $2 $4))
+                                                         ,mop $2,mcp $4] }}
+        | 'foreign' fdecl          {% amsu (sLL $1 $> (snd $ unLoc $2))
+                                           (mj AnnForeign $1:(fst $ unLoc $2)) }
+        | '{-# DEPRECATED' deprecations '#-}'   {% amsu (sLL $1 $> $ WarningD (Warnings (getDEPRECATED_PRAGs $1) (fromOL $2)))
+                                                       [mo $1,mc $3] }
+        | '{-# WARNING' warnings '#-}'          {% amsu (sLL $1 $> $ WarningD (Warnings (getWARNING_PRAGs $1) (fromOL $2)))
+                                                       [mo $1,mc $3] }
+        | '{-# RULES' rules '#-}'               {% amsu (sLL $1 $> $ RuleD (HsRules (getRULES_PRAGs $1) (fromOL $2)))
+                                                       [mo $1,mc $3] }
+        | '{-# VECTORISE' qvar '=' exp '#-}' {% amsu (sLL $1 $> $ VectD (HsVect (getVECT_PRAGs $1) $2 $4))
                                                     [mo $1,mj AnnEqual $3
                                                     ,mc $5] }
-        | '{-# NOVECTORISE' qvar '#-}'       {% amsu (sLL $1 $> $ VectD (HsNoVect $2))
+        | '{-# NOVECTORISE' qvar '#-}'       {% amsu (sLL $1 $> $ VectD (HsNoVect (getNOVECT_PRAGs $1) $2))
                                                      [mo $1,mc $3] }
         | '{-# VECTORISE' 'type' gtycon '#-}'
                                 {% amsu (sLL $1 $> $
-                                    VectD (HsVectTypeIn False $3 Nothing))
+                                    VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 Nothing))
                                     [mo $1,mj AnnType $2,mc $4] }
 
         | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}'
                                 {% amsu (sLL $1 $> $
-                                    VectD (HsVectTypeIn True $3 Nothing))
+                                    VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 Nothing))
                                     [mo $1,mj AnnType $2,mc $4] }
 
         | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}'
                                 {% amsu (sLL $1 $> $
-                                    VectD (HsVectTypeIn False $3 (Just $5)))
+                                    VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 (Just $5)))
                                     [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] }
         | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}'
                                 {% amsu (sLL $1 $> $
-                                    VectD (HsVectTypeIn True $3 (Just $5)))
+                                    VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 (Just $5)))
                                     [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] }
 
         | '{-# VECTORISE' 'class' gtycon '#-}'
-                                         {% amsu (sLL $1 $>  $ VectD (HsVectClassIn $3))
+                                         {% amsu (sLL $1 $>  $ VectD (HsVectClassIn (getVECT_PRAGs $1) $3))
                                                  [mo $1,mj AnnClass $2,mc $4] }
         | annotation { unitOL $1 }
         | decl_no_th                            { unLoc $1 }
@@ -740,7 +760,7 @@ topdecl :: { OrdList (LHsDecl RdrName) }
 cl_decl :: { LTyClDecl RdrName }
         : 'class' tycl_hdr fds where_cls
                 {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (snd $ unLoc $4))
-                        (mj AnnClass $1: (fst $ unLoc $4)) }
+                        (mj AnnClass $1:(fst $ unLoc $3)++(fst $ unLoc $4)) }
 
 -- Type declarations (toplevel)
 --
@@ -827,13 +847,13 @@ inst_decl :: { LInstDecl RdrName }
                        :(fst $ unLoc $6)) }
 
 overlap_pragma :: { Maybe (Located OverlapMode) }
-  : '{-# OVERLAPPABLE'    '#-}' {% ajs (Just (sLL $1 $> Overlappable))
+  : '{-# OVERLAPPABLE'    '#-}' {% ajs (Just (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1))))
                                        [mo $1,mc $2] }
-  | '{-# OVERLAPPING'     '#-}' {% ajs (Just (sLL $1 $> Overlapping))
+  | '{-# OVERLAPPING'     '#-}' {% ajs (Just (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1))))
                                        [mo $1,mc $2] }
-  | '{-# OVERLAPS'        '#-}' {% ajs (Just (sLL $1 $> Overlaps))
+  | '{-# OVERLAPS'        '#-}' {% ajs (Just (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1))))
                                        [mo $1,mc $2] }
-  | '{-# INCOHERENT'      '#-}' {% ajs (Just (sLL $1 $> Incoherent))
+  | '{-# INCOHERENT'      '#-}' {% ajs (Just (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1))))
                                        [mo $1,mc $2] }
   | {- empty -}                 { Nothing }
 
@@ -847,12 +867,12 @@ where_type_family :: { Located ([AddAnn],FamilyInfo RdrName) }
                     ,ClosedTypeFamily (reverse (snd $ unLoc $2))) }
 
 ty_fam_inst_eqn_list :: { Located ([AddAnn],[LTyFamInstEqn RdrName]) }
-        :     '{' ty_fam_inst_eqns '}'     { sLL $1 $> ([mo $1,mc $3]
+        :     '{' ty_fam_inst_eqns '}'     { sLL $1 $> ([moc $1,mcc $3]
                                                 ,unLoc $2) }
         | vocurly ty_fam_inst_eqns close   { let L loc _ = $2 in
                                              L loc ([],unLoc $2) }
-        |     '{' '..' '}'                 { sLL $1 $> ([mo $1,mj AnnDotdot $2
-                                                 ,mc $3],[]) }
+        |     '{' '..' '}'                 { sLL $1 $> ([moc $1,mj AnnDotdot $2
+                                                 ,mcc $3],[]) }
         | vocurly '..' close               { let L loc _ = $2 in
                                              L loc ([mj AnnDotdot $2],[]) }
 
@@ -868,8 +888,8 @@ ty_fam_inst_eqn :: { LTyFamInstEqn RdrName }
         : type '=' ctype
                 -- Note the use of type for the head; this allows
                 -- infix type constructors and type patterns
-              {% do { eqn <- mkTyFamInstEqn $1 $3
-                    ; aa (sLL $1 $> eqn) (AnnEqual, $2) } }
+              {% do { (eqn,ann) <- mkTyFamInstEqn $1 $3
+                    ; ams (sLL $1 $> eqn) (mj AnnEqual $2:ann) } }
 
 -- Associated type family declarations
 --
@@ -951,21 +971,19 @@ opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) }
 --      T Int [a]                       -- for associated types
 -- Rather a lot of inlining here, else we get reduce/reduce errors
 tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
-        : context '=>' type         {% return (L (comb2 $1 $2) (unLoc $1))
-                                       >>= \c@(L l _) ->
-                                         (addAnnotation l AnnDarrow (gl $2))
-                                       >> (return (sLL $1 $> (Just c, $3)))
+        : context '=>' type         {% addAnnotation (gl $1) AnnDarrow (gl $2)
+                                       >> (return (sLL $1 $> (Just $1, $3)))
                                     }
         | type                      { sL1 $1 (Nothing, $1) }
 
 capi_ctype :: { Maybe (Located CType) }
 capi_ctype : '{-# CTYPE' STRING STRING '#-}'
-                       {% ajs (Just (sLL $1 $> (CType (Just (Header (getSTRING $2)))
+                       {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRING $2)))
                                         (getSTRING $3))))
                               [mo $1,mj AnnHeader $2,mj AnnVal $3,mc $4] }
 
            | '{-# CTYPE'        STRING '#-}'
-                       {% ajs (Just (sLL $1 $> (CType Nothing  (getSTRING $2))))
+                       {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) Nothing  (getSTRING $2))))
                               [mo $1,mj AnnVal $2,mc $3] }
 
            |           { Nothing }
@@ -1037,10 +1055,10 @@ vars0 :: { [Located RdrName] }
 
 where_decls :: { Located ([AddAnn]
                          , Located (OrdList (LHsDecl RdrName))) }
-        : 'where' '{' decls '}'       { sLL $1 $> ([mj AnnWhere $1,mo $2
-                                            ,mc $4],$3) }
-        | 'where' vocurly decls close { L (comb2 $1 $3) ([mj AnnWhere $1]
-                                          ,$3) }
+        : 'where' '{' decls '}'       { sLL $1 $> ((mj AnnWhere $1:moc $2
+                                           :mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) }
+        | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3))
+                                          ,sL1 $3 (snd $ unLoc $3)) }
 pattern_synonym_sig :: { LSig RdrName }
         : 'pattern' con '::' ptype
             {% do { let (flag, qtvs, prov, req, ty) = snd $ unLoc $4
@@ -1084,21 +1102,27 @@ decl_cls  : at_decl_cls                 { sLL $1 $> (unitOL $1) }
                           ; ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (GenericSig l ty)))
                                 [mj AnnDefault $1,mj AnnDcolon $3] } }
 
-decls_cls :: { Located (OrdList (LHsDecl RdrName)) }    -- Reversed
-          : decls_cls ';' decl_cls      {% addAnnotation (oll (unLoc $1)) AnnSemi (gl $2)
-                                           >> return (sLL $1 $> ((unLoc $1) `appOL`
-                                                                    unLoc $3)) }
-          | decls_cls ';'               {% addAnnotation (oll (unLoc $1)) AnnSemi (gl $2)
+decls_cls :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) }  -- Reversed
+          : decls_cls ';' decl_cls      {% if isNilOL (snd $ unLoc $1)
+                                             then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
+                                                                    , unLoc $3))
+                                             else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2]
+                                           >> return (sLL $1 $> (fst $ unLoc $1
+                                                                ,(snd $ unLoc $1) `appOL` unLoc $3)) }
+          | decls_cls ';'               {% if isNilOL (snd $ unLoc $1)
+                                             then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
+                                                                                   ,snd $ unLoc $1))
+                                             else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2]
                                            >> return (sLL $1 $>  (unLoc $1)) }
-          | decl_cls                    { $1 }
-          | {- empty -}                 { noLoc nilOL }
+          | decl_cls                    { sL1 $1 ([],unLoc $1) }
+          | {- empty -}                 { noLoc ([],nilOL) }
 
 decllist_cls
         :: { Located ([AddAnn]
                      , OrdList (LHsDecl RdrName)) }      -- Reversed
-        : '{'         decls_cls '}'     { sLL $1 $>  ([mo $1,mc $3]
-                                             ,unLoc $2) }
-        |     vocurly decls_cls close   { L (gl $2) ([],unLoc $2) }
+        : '{'         decls_cls '}'     { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)
+                                             ,snd $ unLoc $2) }
+        |     vocurly decls_cls close   { $2 }
 
 -- Class body
 --
@@ -1116,20 +1140,27 @@ decl_inst  :: { Located (OrdList (LHsDecl RdrName)) }
 decl_inst  : at_decl_inst               { sLL $1 $> (unitOL (sL1 $1 (InstD (unLoc $1)))) }
            | decl                       { $1 }
 
-decls_inst :: { Located (OrdList (LHsDecl RdrName)) }   -- Reversed
-           : decls_inst ';' decl_inst   {% addAnnotation (oll $ unLoc $1) AnnSemi (gl $2)
+decls_inst :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) }   -- Reversed
+           : decls_inst ';' decl_inst   {% if isNilOL (snd $ unLoc $1)
+                                             then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
+                                                                    , unLoc $3))
+                                             else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2]
                                            >> return
-                                            (sLL $1 $> ((unLoc $1) `appOL` unLoc $3)) }
-           | decls_inst ';'             {% addAnnotation (oll $ unLoc $1) AnnSemi (gl $2)
+                                            (sLL $1 $> (fst $ unLoc $1
+                                                       ,(snd $ unLoc $1) `appOL` unLoc $3)) }
+           | decls_inst ';'             {% if isNilOL (snd $ unLoc $1)
+                                             then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
+                                                                                   ,snd $ unLoc $1))
+                                             else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2]
                                            >> return (sLL $1 $> (unLoc $1)) }
-           | decl_inst                  { $1 }
-           | {- empty -}                { noLoc nilOL }
+           | decl_inst                  { sL1 $1 ([],unLoc $1) }
+           | {- empty -}                { noLoc ([],nilOL) }
 
 decllist_inst
         :: { Located ([AddAnn]
                      , OrdList (LHsDecl RdrName)) }      -- Reversed
-        : '{'         decls_inst '}'    { sLL $1 $> ([mo $1,mc $3],unLoc $2) }
-        |     vocurly decls_inst close  { L (gl $2) ([],unLoc $2) }
+        : '{'         decls_inst '}'    { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) }
+        |     vocurly decls_inst close  { L (gl $2) (unLoc $2) }
 
 -- Instance body
 --
@@ -1143,22 +1174,29 @@ where_inst :: { Located ([AddAnn]
 
 -- Declarations in binding groups other than classes and instances
 --
-decls   :: { Located (OrdList (LHsDecl RdrName)) }
-        : decls ';' decl                {% addAnnotation (oll $ unLoc $1) AnnSemi (gl $2)
+decls   :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) }
+        : decls ';' decl    {% if isNilOL (snd $ unLoc $1)
+                                 then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
+                                                        , unLoc $3))
+                                 else do ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2]
                                            >> return (
                                           let { this = unLoc $3;
-                                    rest = unLoc $1;
-                                    these = rest `appOL` this }
-                              in rest `seq` this `seq` these `seq`
-                                    sLL $1 $> these) }
-        | decls ';'                     {% addAnnotation (oll $ unLoc $1) AnnSemi (gl $2)
+                                                rest = snd $ unLoc $1;
+                                                these = rest `appOL` this }
+                                          in rest `seq` this `seq` these `seq`
+                                             (sLL $1 $> (fst $ unLoc $1,these))) }
+        | decls ';'          {% if isNilOL (snd $ unLoc $1)
+                                  then return (sLL $1 $> ((mj AnnSemi $2:(fst $ unLoc $1)
+                                                          ,snd $ unLoc $1)))
+                                  else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2]
                                            >> return (sLL $1 $> (unLoc $1)) }
-        | decl                          { $1 }
-        | {- empty -}                   { noLoc nilOL }
+        | decl                          { sL1 $1 ([],unLoc $1) }
+        | {- empty -}                   { noLoc ([],nilOL) }
 
 decllist :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) }
-        : '{'            decls '}'      { sLL $1 $> ([mo $1,mc $3],unLoc $2) }
-        |     vocurly    decls close    { L (gl $2) ([],unLoc $2) }
+        : '{'            decls '}'     { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)
+                                                   ,snd $ unLoc $2) }
+        |     vocurly    decls close   { L (gl $2) (fst $ unLoc $2,snd $ unLoc $2) }
 
 -- Binding groups other than those of class and instance declarations
 --
@@ -1169,7 +1207,7 @@ binds   ::  { Located ([AddAnn],HsLocalBinds RdrName) }
                                   ; return (sL1 $1 (fst $ unLoc $1
                                                     ,HsValBinds val_binds)) } }
 
-        | '{'            dbinds '}'     { sLL $1 $> ([mo $1,mc $3]
+        | '{'            dbinds '}'     { sLL $1 $> ([moc $1,mcc $3]
                                              ,HsIPBinds (IPBinds (unLoc $2)
                                                          emptyTcEvBinds)) }
 
@@ -1189,7 +1227,7 @@ wherebinds :: { Located ([AddAnn],HsLocalBinds RdrName) }
 -----------------------------------------------------------------------------
 -- Transformation Rules
 
-rules   :: { OrdList (LHsDecl RdrName) }
+rules   :: { OrdList (LRuleDecl RdrName) }
         :  rules ';' rule              {% addAnnotation (oll $1) AnnSemi (gl $2)
                                           >> return ($1 `snocOL` $3) }
         |  rules ';'                   {% addAnnotation (oll $1) AnnSemi (gl $2)
@@ -1197,9 +1235,9 @@ rules   :: { OrdList (LHsDecl RdrName) }
         |  rule                        { unitOL $1 }
         |  {- empty -}                 { nilOL }
 
-rule    :: { LHsDecl RdrName }
+rule    :: { LRuleDecl RdrName }
         : STRING rule_activation rule_forall infixexp '=' exp
-         {%ams (sLL $1 $> $ RuleD (HsRule (L (gl $1) (getSTRING $1))
+         {%ams (sLL $1 $> $ (HsRule (L (gl $1) (getSTRING $1))
                                   ((snd $2) `orElse` AlwaysActive)
                                   (snd $3) $4 placeHolderNames $6
                                   placeHolderNames))
@@ -1212,11 +1250,11 @@ rule_activation :: { ([AddAnn],Maybe Activation) }
 
 rule_explicit_activation :: { ([AddAnn]
                               ,Activation) }  -- In brackets
-        : '[' INTEGER ']'       { ([mo $1,mj AnnVal $2,mc $3]
+        : '[' INTEGER ']'       { ([mos $1,mj AnnVal $2,mcs $3]
                                   ,ActiveAfter  (fromInteger (getINTEGER $2))) }
-        | '[' '~' INTEGER ']'   { ([mo $1,mj AnnTilde $2,mj AnnVal $3,mc $4]
+        | '[' '~' INTEGER ']'   { ([mos $1,mj AnnTilde $2,mj AnnVal $3,mcs $4]
                                   ,ActiveBefore (fromInteger (getINTEGER $3))) }
-        | '[' '~' ']'           { ([mo $1,mj AnnTilde $2,mc $3]
+        | '[' '~' ']'           { ([mos $1,mj AnnTilde $2,mcs $3]
                                   ,NeverActive) }
 
 rule_forall :: { ([AddAnn],[LRuleBndr RdrName]) }
@@ -1228,15 +1266,15 @@ rule_var_list :: { [LRuleBndr RdrName] }
         | rule_var rule_var_list                { $1 : $2 }
 
 rule_var :: { LRuleBndr RdrName }
-        : varid                           { sLL $1 $> (RuleBndr $1) }
-        | '(' varid '::' ctype ')'        {% ams (sLL $1 $> (RuleBndrSig $2
-                                                         (mkHsWithBndrs $4)))
-                                                 [mo $1,mj AnnDcolon $3,mc $5] }
+        : varid                         { sLL $1 $> (RuleBndr $1) }
+        | '(' varid '::' ctype ')'      {% ams (sLL $1 $> (RuleBndrSig $2
+                                                       (mkHsWithBndrs $4)))
+                                               [mop $1,mj AnnDcolon $3,mcp $5] }
 
 -----------------------------------------------------------------------------
 -- Warnings and deprecations (c.f. rules)
 
-warnings :: { OrdList (LHsDecl RdrName) }
+warnings :: { OrdList (LWarnDecl RdrName) }
         : warnings ';' warning         {% addAnnotation (oll $1) AnnSemi (gl $2)
                                           >> return ($1 `appOL` $3) }
         | warnings ';'                 {% addAnnotation (oll $1) AnnSemi (gl $2)
@@ -1245,12 +1283,12 @@ warnings :: { OrdList (LHsDecl RdrName) }
         | {- empty -}                  { nilOL }
 
 -- SUP: TEMPORARY HACK, not checking for `module Foo'
-warning :: { OrdList (LHsDecl RdrName) }
+warning :: { OrdList (LWarnDecl RdrName) }
         : namelist strings
-                { toOL [ sLL $1 $> $ WarningD (Warning n (WarningTxt $ snd $ unLoc $2))
-                       | n <- unLoc $1 ] }
+                {% amsu (sLL $1 $> (Warning (unLoc $1) (WarningTxt (noLoc "") $ snd $ unLoc $2)))
+                     (fst $ unLoc $2) }
 
-deprecations :: { OrdList (LHsDecl RdrName) }
+deprecations :: { OrdList (LWarnDecl RdrName) }
         : deprecations ';' deprecation
                                        {% addAnnotation (oll $1) AnnSemi (gl $2)
                                           >> return ($1 `appOL` $3) }
@@ -1260,17 +1298,17 @@ deprecations :: { OrdList (LHsDecl RdrName) }
         | {- empty -}                  { nilOL }
 
 -- SUP: TEMPORARY HACK, not checking for `module Foo'
-deprecation :: { OrdList (LHsDecl RdrName) }
+deprecation :: { OrdList (LWarnDecl RdrName) }
         : namelist strings
-             { toOL [ sLL $1 $> $ WarningD (Warning n (DeprecatedTxt $ snd $ unLoc $2))
-                    | n <- unLoc $1 ] }
+             {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc "") $ snd $ unLoc $2)))
+                     (fst $ unLoc $2) }
 
 strings :: { Located ([AddAnn],[Located FastString]) }
     : STRING { sL1 $1 ([],[L (gl $1) (getSTRING $1)]) }
-    | '[' stringlist ']' { sLL $1 $> $ ([mo $1,mc $3],fromOL (unLoc $2)) }
+    | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }
 
 stringlist :: { Located (OrdList (Located FastString)) }
-    : stringlist ',' STRING {% addAnnotation (gl $3) AnnComma (gl $2) >>
+    : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>
                                return (sLL $1 $> (unLoc $1 `snocOL`
                                                   (L (gl $3) (getSTRING $3)))) }
     | STRING                { sLL $1 $> (unitOL (L (gl $1) (getSTRING $1))) }
@@ -1279,14 +1317,17 @@ stringlist :: { Located (OrdList (Located FastString)) }
 -- Annotations
 annotation :: { LHsDecl RdrName }
     : '{-# ANN' name_var aexp '#-}'      {% ams (sLL $1 $> (AnnD $ HsAnnotation
-                                            (ValueAnnProvenance (unLoc $2)) $3))
+                                            (getANN_PRAGs $1)
+                                            (ValueAnnProvenance $2) $3))
                                             [mo $1,mc $4] }
 
     | '{-# ANN' 'type' tycon aexp '#-}'  {% ams (sLL $1 $> (AnnD $ HsAnnotation
-                                            (TypeAnnProvenance (unLoc $3)) $4))
+                                            (getANN_PRAGs $1)
+                                            (TypeAnnProvenance $3) $4))
                                             [mo $1,mj AnnType $2,mc $5] }
 
     | '{-# ANN' 'module' aexp '#-}'      {% ams (sLL $1 $> (AnnD $ HsAnnotation
+                                                (getANN_PRAGs $1)
                                                  ModuleAnnProvenance $3))
                                                 [mo $1,mj AnnModule $2,mc $4] }
 
@@ -1294,16 +1335,16 @@ annotation :: { LHsDecl RdrName }
 -----------------------------------------------------------------------------
 -- Foreign import and export declarations
 
-fdecl :: { LHsDecl RdrName }
+fdecl :: { Located ([AddAnn],HsDecl RdrName) }
 fdecl : 'import' callconv safety fspec
-                {% mkImport $2 $3 (snd $ unLoc $4) >>= \i ->
-                  ams (sLL $1 $> i) (mj AnnImport $1 : (fst $ unLoc $4)) }
+               {% mkImport $2 $3 (snd $ unLoc $4) >>= \i ->
+                 return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i))  }
       | 'import' callconv        fspec
-                {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3);
-                        ams (sLL $1 $> d) (mj AnnImport $1 : (fst $ unLoc $3)) } }
+               {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3);
+                    return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $3),d)) }}
       | 'export' callconv fspec
-                {% mkExport $2 (snd $ unLoc $3) >>= \i ->
-                   ams (sLL $1 $> i) (mj AnnExport $1 : (fst $ unLoc $3)) }
+               {% mkExport $2 (snd $ unLoc $3) >>= \i ->
+                  return (sLL $1 $> (mj AnnExport $1 : (fst $ unLoc $3),i) ) }
 
 callconv :: { Located CCallConv }
           : 'stdcall'                   { sLL $1 $> StdCallConv }
@@ -1349,9 +1390,10 @@ sigtypedoc :: { LHsType RdrName }       -- Always a HsForAllTy
         -- Wrap an Implicit forall if there isn't one there already
 
 sig_vars :: { Located [Located RdrName] }    -- Returned in reversed order
-         : sig_vars ',' var            {% addAnnotation (gl $3) AnnComma (gl $2)
-                                          >> return (sLL $1 $> ($3 : unLoc $1)) }
-         | var                         { sL1 $1 [$1] }
+         : sig_vars ',' var           {% addAnnotation (gl $ head $ unLoc $1)
+                                                       AnnComma (gl $2)
+                                         >> return (sLL $1 $> ($3 : unLoc $1)) }
+         | var                        { sL1 $1 [$1] }
 
 sigtypes1 :: { (OrdList (LHsType RdrName)) }      -- Always HsForAllTys
         : sigtype                      { unitOL $1 }
@@ -1362,11 +1404,16 @@ sigtypes1 :: { (OrdList (LHsType RdrName)) }      -- Always HsForAllTys
 -- Types
 
 strict_mark :: { Located ([AddAnn],HsBang) }
-        : '!'                        { sL1 $1    ([],            HsSrcBang Nothing      True) }
-        | '{-# UNPACK' '#-}'         { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just True)  False) }
-        | '{-# NOUNPACK' '#-}'       { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just False) False) }
-        | '{-# UNPACK' '#-}' '!'     { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just True)  True) }
-        | '{-# NOUNPACK' '#-}' '!'   { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just False) True) }
+        : '!'                        { sL1 $1 ([mj AnnBang $1]
+                                              ,HsSrcBang Nothing                       Nothing      True) }
+        | '{-# UNPACK' '#-}'         { sLL $1 $> ([mo $1,mc $2]
+                                              ,HsSrcBang (Just $ getUNPACK_PRAGs $1)   (Just True)  False) }
+        | '{-# NOUNPACK' '#-}'       { sLL $1 $> ([mo $1,mc $2]
+                                              ,HsSrcBang (Just $ getNOUNPACK_PRAGs $1) (Just False) False) }
+        | '{-# UNPACK' '#-}' '!'     { sLL $1 $> ([mo $1,mc $2,mj AnnBang $3]
+                                              ,HsSrcBang (Just $ getUNPACK_PRAGs $1)   (Just True)  True) }
+        | '{-# NOUNPACK' '#-}' '!'   { sLL $1 $> ([mo $1,mc $2,mj AnnBang $3]
+                                              ,HsSrcBang (Just $ getNOUNPACK_PRAGs $1) (Just False) True) }
         -- Although UNPACK with no '!' is illegal, we get a
         -- better error message if we parse it here
 
@@ -1376,12 +1423,12 @@ ctype   :: { LHsType RdrName }
                                            ams (sLL $1 $> $ mkExplicitHsForAllTy $2
                                                                  (noLoc []) $4)
                                                [mj AnnForall $1,mj AnnDot $3] }
-        | context '=>' ctype            {% ams (sLL $1 $> $ mkQualifiedHsForAllTy
-                                                                         $1 $3)
-                                              [mj AnnDarrow $2] }
-        | ipvar '::' type               {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
-                                               [mj AnnVal $1,mj AnnDcolon $2] }
-        | type                          { $1 }
+        | context '=>' ctype          {% addAnnotation (gl $1) AnnDarrow (gl $2)
+                                         >> return (sLL $1 $> $
+                                               mkQualifiedHsForAllTy $1 $3) }
+        | ipvar '::' type             {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
+                                             [mj AnnVal $1,mj AnnDcolon $2] }
+        | type                        { $1 }
 
 ----------------------
 -- Notes for 'ctypedoc'
@@ -1399,11 +1446,12 @@ ctypedoc :: { LHsType RdrName }
                                             ams (sLL $1 $> $ mkExplicitHsForAllTy $2
                                                                   (noLoc []) $4)
                                                 [mj AnnForall $1,mj AnnDot $3] }
-        | context '=>' ctypedoc        {% ams (sLL $1 $> $ mkQualifiedHsForAllTy $1 $3)
-                                              [mj AnnDarrow $2] }
-        | ipvar '::' type              {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
-                                              [mj AnnDcolon $2] }
-        | typedoc                      { $1 }
+        | context '=>' ctypedoc       {% addAnnotation (gl $1) AnnDarrow (gl $2)
+                                         >> return (sLL $1 $> $
+                                                  mkQualifiedHsForAllTy $1 $3) }
+        | ipvar '::' type             {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
+                                             [mj AnnDcolon $2] }
+        | typedoc                     { $1 }
 
 ----------------------
 -- Notes for 'context'
@@ -1420,7 +1468,12 @@ context :: { LHsContext RdrName }
         : btype '~'      btype          {% amms (checkContext
                                              (sLL $1 $> $ HsEqTy $1 $3))
                                              [mj AnnTilde $2] }
-        | btype                         {% checkContext $1 }
+        | btype                         {% do { ctx <- checkContext $1
+                                              ; if null (unLoc ctx)
+                                                 then addAnnotation (gl $1) AnnUnit (gl $1)
+                                                 else return ()
+                                              ; return ctx
+                                              } }
 
 type :: { LHsType RdrName }
         : btype                         { $1 }
@@ -1469,22 +1522,24 @@ atype :: { LHsType RdrName }
         | '{' fielddecls '}'             {% amms (checkRecordSyntax
                                                     (sLL $1 $> $ HsRecTy $2))
                                                         -- Constructor sigs only
-                                                 [mo $1,mc $3] }
+                                                 [moc $1,mcc $3] }
         | '(' ')'                        {% ams (sLL $1 $> $ HsTupleTy
                                                     HsBoxedOrConstraintTuple [])
-                                                [mo $1,mc $2] }
-        | '(' ctype ',' comma_types1 ')' {% ams (sLL $1 $> $ HsTupleTy
+                                                [mop $1,mcp $2] }
+        | '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma
+                                                          (gl $3) >>
+                                            ams (sLL $1 $> $ HsTupleTy
                                              HsBoxedOrConstraintTuple ($2 : $4))
-                                                [mo $1,mj AnnComma $3,mc $5] }
+                                                [mop $1,mcp $5] }
         | '(#' '#)'                   {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple [])
                                              [mo $1,mc $2] }
         | '(#' comma_types1 '#)'      {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple $2)
                                              [mo $1,mc $3] }
-        | '[' ctype ']'               {% ams (sLL $1 $> $ HsListTy  $2) [mo $1,mc $3] }
+        | '[' ctype ']'               {% ams (sLL $1 $> $ HsListTy  $2) [mos $1,mcs $3] }
         | '[:' ctype ':]'             {% ams (sLL $1 $> $ HsPArrTy  $2) [mo $1,mc $3] }
-        | '(' ctype ')'               {% ams (sLL $1 $> $ HsParTy   $2) [mo $1,mc $3] }
+        | '(' ctype ')'               {% ams (sLL $1 $> $ HsParTy   $2) [mop $1,mcp $3] }
         | '(' ctype '::' kind ')'     {% ams (sLL $1 $> $ HsKindSig $2 $4)
-                                             [mo $1,mj AnnDcolon $3,mc $5] }
+                                             [mop $1,mj AnnDcolon $3,mcp $5] }
         | quasiquote                  { sL1 $1 (HsQuasiQuoteTy (unLoc $1)) }
         | '$(' exp ')'                {% ams (sLL $1 $> $ mkHsSpliceTy $2)
                                              [mo $1,mc $3] }
@@ -1493,23 +1548,28 @@ atype :: { LHsType RdrName }
                                       -- see Note [Promotion] for the followings
         | SIMPLEQUOTE qcon                    { sLL $1 $> $ HsTyVar $ unLoc $2 }
         | SIMPLEQUOTE  '(' ctype ',' comma_types1 ')'
-                                    {% ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5))
-                                           [mo $2,mj AnnComma $4,mc $6] }
+                             {% addAnnotation (gl $3) AnnComma (gl $4) >>
+                                ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5))
+                                    [mop $2,mcp $6] }
         | SIMPLEQUOTE  '[' comma_types0 ']'     {% ams (sLL $1 $> $ HsExplicitListTy
                                                             placeHolderKind $3)
-                                                       [mo $2,mc $4] }
+                                                       [mos $2,mcs $4] }
         | SIMPLEQUOTE var                       { sLL $1 $> $ HsTyVar $ unLoc $2 }
 
         -- Two or more [ty, ty, ty] must be a promoted list type, just as
         -- if you had written '[ty, ty, ty]
         -- (One means a list type, zero means the list type constructor, 
         -- so you have to quote those.)
-        | '[' ctype ',' comma_types1 ']'  {% ams (sLL $1 $> $ HsExplicitListTy
+        | '[' ctype ',' comma_types1 ']'  {% addAnnotation (gl $2) AnnComma
+                                                           (gl $3) >>
+                                             ams (sLL $1 $> $ HsExplicitListTy
                                                      placeHolderKind ($2 : $4))
-                                                 [mo $1, mj AnnComma $3,mc $5] }
-        | INTEGER                     { sLL $1 $> $ HsTyLit $ HsNumTy $ getINTEGER $1 }
-        | STRING                      { sLL $1 $> $ HsTyLit $ HsStrTy $ getSTRING  $1 }
-        | '_'                         { sL1 $1 $ HsWildcardTy }
+                                                 [mos $1,mcs $5] }
+        | INTEGER              { sLL $1 $> $ HsTyLit $ HsNumTy (getINTEGERs $1)
+                                                               (getINTEGER $1) }
+        | STRING               { sLL $1 $> $ HsTyLit $ HsStrTy (getSTRINGs $1)
+                                                               (getSTRING  $1) }
+        | '_'                  { sL1 $1 $ HsWildcardTy }
 
 -- An inst_type is what occurs in the head of an instance decl
 --      e.g.  (Foo a, Gaz b) => Wibble a b
@@ -1539,28 +1599,28 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
 
 tv_bndr :: { LHsTyVarBndr RdrName }
         : tyvar                         { sL1 $1 (UserTyVar (unLoc $1)) }
-        | '(' tyvar '::' kind ')'       {% ams (sLL $1 $>  (KindedTyVar (unLoc $2) $4))
-                                               [mo $1,mj AnnDcolon $3
-                                               ,mc $5] }
+        | '(' tyvar '::' kind ')'       {% ams (sLL $1 $>  (KindedTyVar $2 $4))
+                                               [mop $1,mj AnnDcolon $3
+                                               ,mcp $5] }
 
-fds :: { Located [Located (FunDep RdrName)] }
-        : {- empty -}                   { noLoc [] }
-        | '|' fds1                      {% ams (sLL $1 $> (reverse (unLoc $2)))
-                                                [mj AnnVbar $1] }
+fds :: { Located ([AddAnn],[Located (FunDep (Located RdrName))]) }
+        : {- empty -}                   { noLoc ([],[]) }
+        | '|' fds1                      { (sLL $1 $> ([mj AnnVbar $1]
+                                                 ,reverse (unLoc $2))) }
 
-fds1 :: { Located [Located (FunDep RdrName)] }
-        : fds1 ',' fd                  {% addAnnotation (gl $3) AnnComma (gl $2)
-                                          >> return (sLL $1 $> ($3 : unLoc $1)) }
-        | fd                           { sL1 $1 [$1] }
+fds1 :: { Located [Located (FunDep (Located RdrName))] }
+        : fds1 ',' fd   {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2)
+                           >> return (sLL $1 $> ($3 : unLoc $1)) }
+        | fd            { sL1 $1 [$1] }
 
-fd :: { Located (FunDep RdrName) }
+fd :: { Located (FunDep (Located RdrName)) }
         : varids0 '->' varids0  {% ams (L (comb3 $1 $2 $3)
                                        (reverse (unLoc $1), reverse (unLoc $3)))
                                        [mj AnnRarrow $2] }
 
-varids0 :: { Located [RdrName] }
+varids0 :: { Located [Located RdrName] }
         : {- empty -}                   { noLoc [] }
-        | varids0 tyvar                 { sLL $1 $> (unLoc $2 : unLoc $1) }
+        | varids0 tyvar                 { sLL $1 $> ($2 : unLoc $1) }
 
 -----------------------------------------------------------------------------
 -- Kinds
@@ -1577,19 +1637,20 @@ bkind :: { LHsKind RdrName }
 akind :: { LHsKind RdrName }
         : '*'                    { sL1 $1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) }
         | '(' kind ')'           {% ams (sLL $1 $>  $ HsParTy $2)
-                                        [mo $1,mc $3] }
+                                        [mop $1,mcp $3] }
         | pkind                  { $1 }
         | tyvar                  { sL1 $1 $ HsTyVar (unLoc $1) }
 
 pkind :: { LHsKind RdrName }  -- promoted type, see Note [Promotion]
         : qtycon                          { sL1 $1 $ HsTyVar $ unLoc $1 }
         | '(' ')'                   {% ams (sLL $1 $> $ HsTyVar $ getRdrName unitTyCon)
-                                           [mo $1,mc $2] }
-        | '(' kind ',' comma_kinds1 ')'   {% ams (sLL $1 $> $ HsTupleTy HsBoxedTuple
-                                                                     ( $2 : $4))
-                                                 [mo $1,mj AnnComma $3,mc $5] }
+                                           [mop $1,mcp $2] }
+        | '(' kind ',' comma_kinds1 ')'
+                          {% addAnnotation (gl $2) AnnComma (gl $3) >>
+                             ams (sLL $1 $> $ HsTupleTy HsBoxedTuple ( $2 : $4))
+                                 [mop $1,mcp $5] }
         | '[' kind ']'                    {% ams (sLL $1 $> $ HsListTy $2)
-                                                 [mo $1,mc $3] }
+                                                 [mos $1,mcs $3] }
 
 comma_kinds1 :: { [LHsKind RdrName] }
         : kind                         { [$1] }
@@ -1631,8 +1692,8 @@ gadt_constrlist :: { Located ([AddAnn]
                           ,[LConDecl RdrName]) } -- Returned in order
         : 'where' '{'        gadt_constrs '}'   { L (comb2 $1 $3)
                                                     ([mj AnnWhere $1
-                                                     ,mo $2
-                                                     ,mc $4]
+                                                     ,moc $2
+                                                     ,mcc $4]
                                                     , unLoc $3) }
         | 'where' vocurly    gadt_constrs close  { L (comb2 $1 $3)
                                                      ([mj AnnWhere $1]
@@ -1661,10 +1722,10 @@ gadt_constr :: { LConDecl RdrName }
 
                 -- Deprecated syntax for GADT record declarations
         | oqtycon '{' fielddecls '}' '::' sigtype
-                {% do { cd <- mkDeprecatedGadtRecordDecl (comb2 $1 $6) $1 $3 $6
+                {% do { cd <- mkDeprecatedGadtRecordDecl (comb2 $1 $6) $1 (noLoc $3) $6
                       ; cd' <- checkRecordSyntax cd
                       ; ams (L (comb2 $1 $6) (unLoc cd'))
-                            [mo $2,mc $4,mj AnnDcolon $5] } }
+                            [moc $2,mcc $4,mj AnnDcolon $5] } }
 
 constrs :: { Located ([AddAnn],[LConDecl RdrName]) }
         : maybe_docnext '=' constrs1    { L (comb2 $2 $3) ([mj AnnEqual $2]
@@ -1672,7 +1733,7 @@ constrs :: { Located ([AddAnn],[LConDecl RdrName]) }
 
 constrs1 :: { Located [LConDecl RdrName] }
         : constrs1 maybe_docnext '|' maybe_docprev constr
-            {% addAnnotation (gl $5) AnnVbar (gl $3)
+            {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $3)
                >> return (sLL $1 $> (addConDoc $5 $2 : addConDocFirst (unLoc $1) $4)) }
         | constr                                          { sL1 $1 [$1] }
 
@@ -1733,10 +1794,10 @@ deriving :: { Located (Maybe (Located [LHsType RdrName])) }
                                                        [L loc (HsTyVar tv)]))))
                                           [mj AnnDeriving $1] }
         | 'deriving' '(' ')'      {% aljs (sLL $1 $> (Just (sLL $1 $> [])))
-                                          [mj AnnDeriving $1,mo $2,mc $3] }
+                                          [mj AnnDeriving $1,mop $2,mcp $3] }
 
         | 'deriving' '(' inst_types1 ')'  {% aljs (sLL $1 $> (Just (sLL $1 $> $3)))
-                                                 [mj AnnDeriving $1,mo $2,mc $4] }
+                                                 [mj AnnDeriving $1,mop $2,mcp $4] }
              -- Glasgow extension: allow partial
              -- applications in derivings
 
@@ -1777,7 +1838,7 @@ docdecld :: { LDocDecl }
 decl_no_th :: { Located (OrdList (LHsDecl RdrName)) }
         : sigdecl               { $1 }
 
-        | '!' aexp rhs          {% do { let { e = sLL $1 $> (SectionR (sLL $1 $> (HsVar bang_RDR)) $2) };
+        | '!' aexp rhs          {% do { let { e = sLL $1 $> (SectionR (sL1 $1 (HsVar bang_RDR)) $2) };
                                         pat <- checkPattern empty e;
                                         _ <- ams (sLL $1 $> ())
                                                (mj AnnBang $1:(fst $ unLoc $3));
@@ -1837,8 +1898,9 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
         | var ',' sig_vars '::' sigtypedoc
            {% do { ty <- checkPartialTypeSignature $5
                  ; let sig = TypeSig ($1 : reverse (unLoc $3)) ty PlaceHolder
+                 ; addAnnotation (gl $1) AnnComma (gl $2)
                  ; ams (sLL $1 $> $ toOL [ sLL $1 $> $ SigD sig ])
-                       [mj AnnComma $2,mj AnnDcolon $4] } }
+                       [mj AnnDcolon $4] } }
 
         | infix prec ops
               {% ams (sLL $1 $> $ toOL [ sLL $1 $> $ SigD
@@ -1850,29 +1912,33 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
 
         | '{-# INLINE' activation qvar '#-}'
                 {% ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (InlineSig $3
-                                     (mkInlinePragma (getINLINE $1) (snd $2)))))
-                       (mo $1:mc $4:fst $2) }
+                            (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)
+                                            (snd $2)))))
+                       ((mo $1:fst $2) ++ [mc $4]) }
 
         | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
              {% ams (
-                 let inl_prag = mkInlinePragma (EmptyInlineSpec, FunLike) (snd $2)
+                 let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
+                                             (EmptyInlineSpec, FunLike) (snd $2)
                   in sLL $1 $> $
                             toOL [ sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) inl_prag) ])
                     (mo $1:mj AnnDcolon $4:mc $6:(fst $2)) }
 
         | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
              {% ams (sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 (fromOL $5)
-                               (mkInlinePragma (getSPEC_INLINE $1) (snd $2))) ])
+                               (mkInlinePragma (getSPEC_INLINE_PRAGs $1)
+                                               (getSPEC_INLINE $1) (snd $2))) ])
                        (mo $1:mj AnnDcolon $4:mc $6:(fst $2)) }
 
         | '{-# SPECIALISE' 'instance' inst_type '#-}'
-                {% ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (SpecInstSig $3)))
+                {% ams (sLL $1 $> $ unitOL (sLL $1 $>
+                                  $ SigD (SpecInstSig (getSPEC_PRAGs $1) $3)))
                        [mo $1,mj AnnInstance $2,mc $4] }
 
         -- AZ TODO: Do we need locations in the name_formula_opt?
         -- A minimal complete definition
         | '{-# MINIMAL' name_boolformula_opt '#-}'
-            {% ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (MinimalSig (snd $2))))
+            {% ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (MinimalSig (getMINIMAL_PRAGs $1) (snd $2))))
                    (mo $1:mc $3:fst $2) }
 
 activation :: { ([AddAnn],Maybe Activation) }
@@ -1880,10 +1946,10 @@ activation :: { ([AddAnn],Maybe Activation) }
         | explicit_activation                   { (fst $1,Just (snd $1)) }
 
 explicit_activation :: { ([AddAnn],Activation) }  -- In brackets
-        : '[' INTEGER ']'       { ([mj AnnOpen $1,mj AnnVal $2,mj AnnClose $3]
+        : '[' INTEGER ']'       { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3]
                                   ,ActiveAfter  (fromInteger (getINTEGER $2))) }
-        | '[' '~' INTEGER ']'   { ([mj AnnOpen $1,mj AnnTilde $2,mj AnnVal $3
-                                                 ,mj AnnClose $4]
+        | '[' '~' INTEGER ']'   { ([mj AnnOpenS $1,mj AnnTilde $2,mj AnnVal $3
+                                                 ,mj AnnCloseS $4]
                                   ,ActiveBefore (fromInteger (getINTEGER $3))) }
 
 -----------------------------------------------------------------------------
@@ -1917,14 +1983,18 @@ exp   :: { LHsExpr RdrName }
         | infixexp              { $1 }
 
 infixexp :: { LHsExpr RdrName }
-        : exp10                       { $1 }
-        | infixexp qop exp10          { sLL $1 $> (OpApp $1 $2 placeHolderFixity $3) }
+        : exp10                   { $1 }
+        | infixexp qop exp10      {% ams (sLL $1 $>
+                                             (OpApp $1 $2 placeHolderFixity $3))
+                                         [mj AnnVal $2] }
+                 -- AnnVal annotation for NPlusKPat, which discards the operator
+
 
 exp10 :: { LHsExpr RdrName }
         : '\\' apat apats opt_asig '->' exp
                    {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource
-                            [sLL $1 $> $ Match ($2:$3) (snd $4) (unguardedGRHSs $6)]))
-                          [mj AnnLam $1,mj AnnRarrow $5] }
+                            [sLL $1 $> $ Match Nothing ($2:$3) (snd $4) (unguardedGRHSs $6)]))
+                          (mj AnnLam $1:mj AnnRarrow $5:(fst $4)) }
         | 'let' binds 'in' exp          {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4)
                                                (mj AnnLet $1:mj AnnIn $3
                                                  :(fst $ unLoc $2)) }
@@ -1958,18 +2028,11 @@ exp10 :: { LHsExpr RdrName }
                                               (mkHsDo MDoExpr (snd $ unLoc $2)))
                                            (mj AnnMdo $1:(fst $ unLoc $2)) }
 
-        | scc_annot exp        {% do { on <- extension sccProfilingOn
-                                     ; ams (sLL $1 $> $ if on
-                                                         then HsSCC (snd $ unLoc $1) $2
-                                                         else HsPar $2)
-                                           (fst $ unLoc $1) } }
+        | scc_annot exp        {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
+                                      (fst $ fst $ unLoc $1) }
 
-        | hpc_annot exp        {% do { on <- extension hpcEnabled
-                                       ; ams (sLL $1 $> $ if on
-                                                           then HsTickPragma
-                                                                    (snd $ unLoc $1) $2
-                                                           else HsPar $2)
-                                             (fst $ unLoc $1) } }
+        | hpc_annot exp        {% ams (sLL $1 $> $ HsTickPragma (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
+                                      (fst $ fst $ unLoc $1) }
 
         | 'proc' aexp '->' exp
                        {% checkPattern empty $2 >>= \ p ->
@@ -1979,7 +2042,7 @@ exp10 :: { LHsExpr RdrName }
                                             -- TODO: is LL right here?
                                [mj AnnProc $1,mj AnnRarrow $3] }
 
-        | '{-# CORE' STRING '#-}' exp  {% ams (sLL $1 $> $ HsCoreAnn (getSTRING $2) $4)
+        | '{-# CORE' STRING '#-}' exp  {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getSTRING $2) $4)
                                               [mo $1,mj AnnVal $2
                                               ,mc $3] }
                                           -- hdaume: core annotation
@@ -2020,22 +2083,23 @@ optSemi :: { ([Located a],Bool) }
         : ';'         { ([$1],True) }
         | {- empty -} { ([],False) }
 
-scc_annot :: { Located ([AddAnn],FastString) }
+scc_annot :: { Located (([AddAnn],SourceText),FastString) }
         : '{-# SCC' STRING '#-}'      {% do scc <- getSCC $2
                                             ; return $ sLL $1 $>
-                                               ([mo $1,mj AnnVal $2
-                                                ,mc $3],scc) }
-        | '{-# SCC' VARID  '#-}'      { sLL $1 $> ([mo $1,mj AnnVal $2
-                                         ,mc $3]
+                                               (([mo $1,mj AnnValStr $2
+                                                ,mc $3],getSCC_PRAGs $1),scc) }
+        | '{-# SCC' VARID  '#-}'      { sLL $1 $> (([mo $1,mj AnnVal $2
+                                         ,mc $3],getSCC_PRAGs $1)
                                         ,(getVARID $2)) }
 
-hpc_annot :: { Located ([AddAnn],(FastString,(Int,Int),(Int,Int))) }
+hpc_annot :: { Located (([AddAnn],SourceText),(FastString,(Int,Int),(Int,Int))) }
       : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
-                                      { sLL $1 $> $ ([mo $1,mj AnnVal $2
+                                      { sLL $1 $> $ (([mo $1,mj AnnVal $2
                                               ,mj AnnVal $3,mj AnnColon $4
                                               ,mj AnnVal $5,mj AnnMinus $6
                                               ,mj AnnVal $7,mj AnnColon $8
-                                              ,mj AnnVal $9,mc $10]
+                                              ,mj AnnVal $9,mc $10],
+                                                getGENERATED_PRAGs $1)
                                               ,(getSTRING $2
                                                ,( fromInteger $ getINTEGER $3
                                                 , fromInteger $ getINTEGER $5
@@ -2048,7 +2112,8 @@ hpc_annot :: { Located ([AddAnn],(FastString,(Int,Int),(Int,Int))) }
 
 fexp    :: { LHsExpr RdrName }
         : fexp aexp                             { sLL $1 $> $ HsApp $1 $2 }
-        | 'static' aexp                         { sLL $1 $> $ HsStatic $2 }
+        | 'static' aexp                         {% ams (sLL $1 $> $ HsStatic $2)
+                                                       [mj AnnStatic $1] }
         | aexp                                  { $1 }
 
 aexp    :: { LHsExpr RdrName }
@@ -2059,7 +2124,7 @@ aexp    :: { LHsExpr RdrName }
 aexp1   :: { LHsExpr RdrName }
         : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4)
                                                                    (snd $3)
-                                     ; _ <- ams (sLL $1 $> ()) (mo $2:mc $4:(fst $3))
+                                     ; _ <- ams (sLL $1 $> ()) (moc $2:mcc $4:(fst $3))
                                      ; checkRecordSyntax (sLL $1 $> r) }}
         | aexp2                { $1 }
 
@@ -2080,9 +2145,9 @@ aexp2   :: { LHsExpr RdrName }
         -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't
         -- correct Haskell (you'd have to write '((+ 3), (4 -))')
         -- but the less cluttered version fell out of having texps.
-        | '(' texp ')'                  {% ams (sLL $1 $> (HsPar $2)) [mo $1,mc $3] }
+        | '(' texp ')'                  {% ams (sLL $1 $> (HsPar $2)) [mop $1,mcp $3] }
         | '(' tup_exprs ')'             {% ams (sLL $1 $> (ExplicitTuple $2 Boxed))
-                                               [mo $1,mc $3] }
+                                               [mop $1,mcp $3] }
 
         | '(#' texp '#)'                {% ams (sLL $1 $> (ExplicitTuple [L (gl $2)
                                                          (Present $2)] Unboxed))
@@ -2090,7 +2155,7 @@ aexp2   :: { LHsExpr RdrName }
         | '(#' tup_exprs '#)'           {% ams (sLL $1 $> (ExplicitTuple $2 Unboxed))
                                                [mo $1,mc $3] }
 
-        | '[' list ']'      {% ams (sLL $1 $> (snd $2)) (mo $1:mc $3:(fst $2)) }
+        | '[' list ']'      {% ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) }
         | '[:' parr ':]'    {% ams (sLL $1 $> (snd $2)) (mo $1:mc $3:(fst $2)) }
         | '_'               { sL1 $1 EWildPat }
 
@@ -2139,8 +2204,8 @@ acmd    :: { LHsCmdTop RdrName }
                                            placeHolderType placeHolderType []) }
 
 cvtopbody :: { ([AddAnn],[LHsDecl RdrName]) }
-        :  '{'            cvtopdecls0 '}'      { ([mj AnnOpen $1
-                                                  ,mj AnnClose $3],$2) }
+        :  '{'            cvtopdecls0 '}'      { ([mj AnnOpenC $1
+                                                  ,mj AnnCloseC $3],$2) }
         |      vocurly    cvtopdecls0 close    { ([],$2) }
 
 cvtopdecls0 :: { [LHsDecl RdrName] }
@@ -2265,7 +2330,7 @@ squals :: { Located [LStmt RdrName (LHsExpr RdrName)] }   -- In reverse order, b
              {% addAnnotation (gl $ last $ unLoc $1) AnnComma (gl $2) >>
                 return (sLL $1 $> [L (getLoc $3) ((unLoc $3) (reverse (unLoc $1)))]) }
     | squals ',' qual
-             {% addAnnotation (gl $ last $ unLoc $1) AnnComma (gl $2) >>
+             {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
                 return (sLL $1 $> ($3 : unLoc $1)) }
     | transformqual                       { sLL $1 $> [L (getLoc $1) ((unLoc $1) [])] }
     | qual                                { sL1 $1 [$1] }
@@ -2326,37 +2391,50 @@ guardquals :: { Located [LStmt RdrName (LHsExpr RdrName)] }
     : guardquals1           { L (getLoc $1) (reverse (unLoc $1)) }
 
 guardquals1 :: { Located [LStmt RdrName (LHsExpr RdrName)] }
-    : guardquals1 ',' qual  {% ams (sLL $1 $> ($3 : unLoc $1)) [mj AnnComma $2] }
+    : guardquals1 ',' qual  {% addAnnotation (gl $ last $ unLoc $1) AnnComma
+                                             (gl $2) >>
+                               return (sLL $1 $> ($3 : unLoc $1)) }
     | qual                  { sL1 $1 [$1] }
 
 -----------------------------------------------------------------------------
 -- Case alternatives
 
 altslist :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) }
-        : '{'            alts '}'    { sLL $1 $> ([mo $1,mc $3],(reverse (unLoc $2))) }
-
-        |     vocurly    alts  close { L (getLoc $2) ([],(reverse (unLoc $2))) }
-        | '{'                 '}'    { noLoc ([mo $1,mc $2],[]) }
+        : '{'            alts '}'  { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
+                                               ,(reverse (snd $ unLoc $2))) }
+        |     vocurly    alts  close { L (getLoc $2) (fst $ unLoc $2
+                                        ,(reverse (snd $ unLoc $2))) }
+        | '{'                 '}'    { noLoc ([moc $1,mcc $2],[]) }
         |     vocurly          close { noLoc ([],[]) }
 
-alts    :: { Located [LMatch RdrName (LHsExpr RdrName)] }
-        : alts1                         { sL1 $1 (unLoc $1) }
-        | ';' alts                      {% ams (sLL $1 $> (unLoc $2))
-                                               [mj AnnSemi (head $ unLoc $2)] }
-
-alts1   :: { Located [LMatch RdrName (LHsExpr RdrName)] }
-        : alts1 ';' alt           {% ams (sLL $1 $> ($3 : unLoc $1)) [mj AnnSemi $3] }
-        | alts1 ';'               {% ams (sLL $1 $> (unLoc $1))
-                                         [mj AnnSemi (last $ unLoc $1)] }
-        | alt                     { sL1 $1 [$1] }
+alts    :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) }
+        : alts1                    { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
+        | ';' alts                 { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2))
+                                               ,snd $ unLoc $2) }
+
+alts1   :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) }
+        : alts1 ';' alt         {% if null (snd $ unLoc $1)
+                                     then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
+                                                  ,[$3]))
+                                     else (ams (head $ snd $ unLoc $1)
+                                               (mj AnnSemi $2:(fst $ unLoc $1))
+                                           >> return (sLL $1 $> ([],$3 : (snd $ unLoc $1))) ) }
+        | alts1 ';'             {% if null (snd $ unLoc $1)
+                                     then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
+                                                  ,snd $ unLoc $1))
+                                     else (ams (head $ snd $ unLoc $1)
+                                               (mj AnnSemi $2:(fst $ unLoc $1))
+                                           >> return (sLL $1 $> ([],snd $ unLoc $1))) }
+        | alt                   { sL1 $1 ([],[$1]) }
 
 alt     :: { LMatch RdrName (LHsExpr RdrName) }
-        : pat opt_sig alt_rhs           { sLL $1 $> (Match [$1] (snd $2) (unLoc $3)) }
+        : pat opt_sig alt_rhs      {%ams (sLL $1 $> (Match Nothing [$1] (snd $2)
+                                                              (snd $ unLoc $3)))
+                                         (fst $ unLoc $3)}
 
-alt_rhs :: { Located (GRHSs RdrName (LHsExpr RdrName)) }
-        : ralt wherebinds           {% ams (sLL $1 $> (GRHSs (unLoc $1)
-                                                             (snd $ unLoc $2)))
-                                           (fst $ unLoc $2) }
+alt_rhs :: { Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName)) }
+        : ralt wherebinds           { sLL $1 $> (fst $ unLoc $2,
+                                            GRHSs (unLoc $1) (snd $ unLoc $2)) }
 
 ralt :: { Located [LGRHS RdrName (LHsExpr RdrName)] }
         : '->' exp            {% ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2))
@@ -2379,7 +2457,7 @@ gdpatssemi :: { Located [LGRHS RdrName (LHsExpr RdrName)] }
 -- generate the open brace in addition to the vertical bar in the lexer, and
 -- we don't need it.
 ifgdpats :: { Located ([AddAnn],[LGRHS RdrName (LHsExpr RdrName)]) }
-         : '{' gdpatssemi '}'             { sLL $1 $> ([mo $1,mc $3],unLoc $2)  }
+         : '{' gdpatssemi '}'             { sLL $1 $> ([moc $1,mcc $3],unLoc $2)  }
          |     gdpatssemi close           { sL1 $1 ([],unLoc $1) }
 
 gdpat   :: { LGRHS RdrName (LHsExpr RdrName) }
@@ -2420,10 +2498,10 @@ apats  :: { [LPat RdrName] }
 -- Statement sequences
 
 stmtlist :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) }
-        : '{'           stmts '}'       { sLL $1 $> ((mo $1:mc $3:(fst $ unLoc $2))
-                                             ,(snd $ unLoc $2)) }
+        : '{'           stmts '}'       { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
+                                             ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse?
         |     vocurly   stmts close     { L (gl $2) (fst $ unLoc $2
-                                                    ,snd $ unLoc $2) }
+                                                    ,reverse $ snd $ unLoc $2) }
 
 --      do { ;; s ; s ; ; s ;; }
 -- The last Stmt should be an expression, but that's hard to enforce
@@ -2431,21 +2509,24 @@ stmtlist :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) }
 -- So we use BodyStmts throughout, and switch the last one over
 -- in ParseUtils.checkDo instead
 -- AZ: TODO check that we can retrieve multiple semis.
-stmts :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) }
-        : stmt stmts_help        { sLL $1 $> (fst $ unLoc $2,($1 : (snd $ unLoc $2))) }
-        | ';' stmts     {% if null (snd $ unLoc $2)
-                             then ams (sLL $1 $> ([mj AnnSemi $1],snd $ unLoc $2)) []
-                             else ams (sLL $1 $> ([],snd $ unLoc $2)) [mj AnnSemi $1] }
 
+stmts :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) }
+        : stmts ';' stmt  {% if null (snd $ unLoc $1)
+                              then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
+                                                     ,$3 : (snd $ unLoc $1)))
+                              else do
+                               { ams (head $ snd $ unLoc $1) [mj AnnSemi $2]
+                               ; return $ sLL $1 $> (fst $ unLoc $1,$3 :(snd $ unLoc $1)) }}
+
+        | stmts ';'     {% if null (snd $ unLoc $1)
+                             then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1),snd $ unLoc $1))
+                             else do
+                               { ams (head $ snd $ unLoc $1)
+                                               [mj AnnSemi $2]
+                               ; return $1 } }
+        | stmt                   { sL1 $1 ([],[$1]) }
         | {- empty -}            { noLoc ([],[]) }
 
-stmts_help :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) }
-                                                               -- might be empty
-        : ';' stmts    {% if null (snd $ unLoc $2)
-                             then ams (sLL $1 $> ([mj AnnSemi $1],snd $ unLoc $2)) []
-                             else ams (sLL $1 $> ([],snd $ unLoc $2)) [mj AnnSemi $1] }
-
-        | {- empty -}                   { noLoc ([],[]) }
 
 -- For typing stmts at the GHCi prompt, where
 -- the input may consist of just comments.
@@ -2456,14 +2537,14 @@ maybe_stmt :: { Maybe (LStmt RdrName (LHsExpr RdrName)) }
 stmt  :: { LStmt RdrName (LHsExpr RdrName) }
         : qual                          { $1 }
         | 'rec' stmtlist                {% ams (sLL $1 $> $ mkRecStmt (snd $ unLoc $2))
-                                               [mj AnnRec $1] }
+                                               (mj AnnRec $1:(fst $ unLoc $2)) }
 
 qual  :: { LStmt RdrName (LHsExpr RdrName) }
     : bindpat '<-' exp                  {% ams (sLL $1 $> $ mkBindStmt $1 $3)
                                                [mj AnnLarrow $2] }
     | exp                               { sL1 $1 $ mkBodyStmt $1 }
     | 'let' binds                       {% ams (sLL $1 $>$ LetStmt (snd $ unLoc $2))
-                                               [mj AnnLet $1] }
+                                               (mj AnnLet $1:(fst $ unLoc $2)) }
 
 -----------------------------------------------------------------------------
 -- Record Field Update/Construction
@@ -2504,7 +2585,7 @@ dbinds  :: { Located [LIPBind RdrName] }
 --      | {- empty -}                  { [] }
 
 dbind   :: { LIPBind RdrName }
-dbind   : ipvar '=' exp                {% ams (sLL $1 $> (IPBind (Left (unLoc $1)) $3))
+dbind   : ipvar '=' exp                {% ams (sLL $1 $> (IPBind (Left $1) $3))
                                               [mj AnnEqual $2] }
 
 ipvar   :: { Located HsIPName }
@@ -2529,13 +2610,13 @@ name_boolformula_and :: { ([AddAnn],BooleanFormula (Located RdrName)) }
                   { ((mj AnnComma $2:fst $1)++(fst $3), mkAnd [snd $1,snd $3]) }
 
 name_boolformula_atom :: { ([AddAnn],BooleanFormula (Located RdrName)) }
-        : '(' name_boolformula ')'  { ([mo $1,mc $3],snd $2) }
+        : '(' name_boolformula ')'  { ([mop $1,mcp $3],snd $2) }
         | name_var                  { ([],mkVar $1) }
 
--- AZ TODO: warnings/deprecations are incompletely annotated
-namelist :: { Located [RdrName] }
-namelist : name_var              { sL1 $1 [unLoc $1] }
-         | name_var ',' namelist { sLL $1 $> (unLoc $1 : unLoc $3) }
+namelist :: { Located [Located RdrName] }
+namelist : name_var              { sL1 $1 [$1] }
+         | name_var ',' namelist {% addAnnotation (gl $1) AnnComma (gl $2) >>
+                                    return (sLL $1 $> ($1 : unLoc $3)) }
 
 name_var :: { Located RdrName }
 name_var : var { $1 }
@@ -2545,35 +2626,42 @@ name_var : var { $1 }
 -- Data constructors
 qcon    :: { Located RdrName }
         : qconid                { $1 }
-        | '(' qconsym ')'       {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
+        | '(' qconsym ')'       {% ams (sLL $1 $> (unLoc $2))
+                                       [mop $1,mj AnnVal $2,mcp $3] }
         | sysdcon               { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
 -- The case of '[:' ':]' is part of the production `parr'
 
 con     :: { Located RdrName }
         : conid                 { $1 }
-        | '(' consym ')'        {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
+        | '(' consym ')'        {% ams (sLL $1 $> (unLoc $2))
+                                       [mop $1,mj AnnVal $2,mcp $3] }
         | sysdcon               { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
 
 con_list :: { Located [Located RdrName] }
 con_list : con                  { sL1 $1 [$1] }
-         | con ',' con_list     {% ams (sLL $1 $> ($1 : unLoc $3)) [mj AnnComma $2] }
+         | con ',' con_list     {% addAnnotation (gl $1) AnnComma (gl $2) >>
+                                   return (sLL $1 $> ($1 : unLoc $3)) }
 
 sysdcon :: { Located DataCon }  -- Wired in data constructors
-        : '(' ')'               {% ams (sLL $1 $> unitDataCon) [mo $1,mc $2] }
+        : '(' ')'               {% ams (sLL $1 $> unitDataCon) [mop $1,mcp $2] }
         | '(' commas ')'        {% ams (sLL $1 $> $ tupleCon BoxedTuple (snd $2 + 1))
-                                       (mo $1:mc $3:(mcommas (fst $2))) }
+                                       (mop $1:mcp $3:(mcommas (fst $2))) }
         | '(#' '#)'             {% ams (sLL $1 $> $ unboxedUnitDataCon) [mo $1,mc $2] }
         | '(#' commas '#)'      {% ams (sLL $1 $> $ tupleCon UnboxedTuple (snd $2 + 1))
                                        (mo $1:mc $3:(mcommas (fst $2))) }
-        | '[' ']'               {% ams (sLL $1 $> nilDataCon) [mo $1,mc $2] }
+        | '[' ']'               {% ams (sLL $1 $> nilDataCon) [mos $1,mcs $2] }
 
 conop :: { Located RdrName }
         : consym                { $1 }
-        | '`' conid '`'         {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
+        | '`' conid '`'         {% ams (sLL $1 $> (unLoc $2))
+                                       [mj AnnBackquote $1,mj AnnVal $2
+                                       ,mj AnnBackquote $3] }
 
 qconop :: { Located RdrName }
         : qconsym               { $1 }
-        | '`' qconid '`'        {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
+        | '`' qconid '`'        {% ams (sLL $1 $> (unLoc $2))
+                                       [mj AnnBackquote $1,mj AnnVal $2
+                                       ,mj AnnBackquote $3] }
 
 ----------------------------------------------------------------------------
 -- Type constructors
@@ -2584,7 +2672,7 @@ qconop :: { Located RdrName }
 gtycon :: { Located RdrName }  -- A "general" qualified tycon, including unit tuples
         : ntgtycon                     { $1 }
         | '(' ')'                      {% ams (sLL $1 $> $ getRdrName unitTyCon)
-                                              [mo $1,mc $2] }
+                                              [mop $1,mcp $2] }
         | '(#' '#)'                    {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon)
                                               [mo $1,mc $2] }
 
@@ -2592,48 +2680,51 @@ ntgtycon :: { Located RdrName }  -- A "general" qualified tycon, excluding unit
         : oqtycon               { $1 }
         | '(' commas ')'        {% ams (sLL $1 $> $ getRdrName (tupleTyCon BoxedTuple
                                                         (snd $2 + 1)))
-                                       (mo $1:mc $3:(mcommas (fst $2))) }
+                                       (mop $1:mcp $3:(mcommas (fst $2))) }
         | '(#' commas '#)'      {% ams (sLL $1 $> $ getRdrName (tupleTyCon UnboxedTuple
                                                         (snd $2 + 1)))
                                        (mo $1:mc $3:(mcommas (fst $2))) }
         | '(' '->' ')'          {% ams (sLL $1 $> $ getRdrName funTyCon)
-                                       [mo $1,mj AnnRarrow $2,mc $3] }
-        | '[' ']'               {% ams (sLL $1 $> $ listTyCon_RDR) [mo $1,mc $2] }
+                                       [mop $1,mj AnnRarrow $2,mcp $3] }
+        | '[' ']'               {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] }
         | '[:' ':]'             {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] }
         | '(' '~#' ')'          {% ams (sLL $1 $> $ getRdrName eqPrimTyCon)
-                                        [mo $1,mj AnnTildehsh $2,mc $3] }
+                                        [mop $1,mj AnnTildehsh $2,mcp $3] }
 
 oqtycon :: { Located RdrName }  -- An "ordinary" qualified tycon;
                                 -- These can appear in export lists
         : qtycon                        { $1 }
-        | '(' qtyconsym ')'             {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
+        | '(' qtyconsym ')'             {% ams (sLL $1 $> (unLoc $2))
+                                               [mop $1,mj AnnVal $2,mcp $3] }
         | '(' '~' ')'                   {% ams (sLL $1 $> $ eqTyCon_RDR)
-                                               [mo $1,mj AnnTilde $2,mc $3] }
+                                               [mop $1,mj AnnTilde $2,mcp $3] }
 
 qtyconop :: { Located RdrName } -- Qualified or unqualified
         : qtyconsym                     { $1 }
-        | '`' qtycon '`'                {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
+        | '`' qtycon '`'                {% ams (sLL $1 $> (unLoc $2))
+                                               [mj AnnBackquote $1,mj AnnVal $2
+                                               ,mj AnnBackquote $3] }
 
 qtycon :: { Located RdrName }   -- Qualified or unqualified
-        : QCONID                        { sL1 $1 $! mkQual tcClsName (getQCONID $1) }
-        | PREFIXQCONSYM                 { sL1 $1 $! mkQual tcClsName (getPREFIXQCONSYM $1) }
-        | tycon                         { $1 }
+        : QCONID            { sL1 $1 $! mkQual tcClsName (getQCONID $1) }
+        | PREFIXQCONSYM     { sL1 $1 $! mkQual tcClsName (getPREFIXQCONSYM $1) }
+        | tycon             { $1 }
 
 tycon   :: { Located RdrName }  -- Unqualified
-        : CONID                         { sL1 $1 $! mkUnqual tcClsName (getCONID $1) }
+        : CONID                   { sL1 $1 $! mkUnqual tcClsName (getCONID $1) }
 
 qtyconsym :: { Located RdrName }
-        : QCONSYM                       { sL1 $1 $! mkQual tcClsName (getQCONSYM $1) }
-        | QVARSYM                       { sL1 $1 $! mkQual tcClsName (getQVARSYM $1) }
-        | tyconsym                      { $1 }
+        : QCONSYM            { sL1 $1 $! mkQual tcClsName (getQCONSYM $1) }
+        | QVARSYM            { sL1 $1 $! mkQual tcClsName (getQVARSYM $1) }
+        | tyconsym           { $1 }
 
 -- Does not include "!", because that is used for strictness marks
 --               or ".", because that separates the quantified type vars from the rest
 tyconsym :: { Located RdrName }
-        : CONSYM                        { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) }
-        | VARSYM                        { sL1 $1 $! mkUnqual tcClsName (getVARSYM $1) }
-        | '*'                           { sL1 $1 $! mkUnqual tcClsName (fsLit "*")    }
-        | '-'                           { sL1 $1 $! mkUnqual tcClsName (fsLit "-")    }
+        : CONSYM                { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) }
+        | VARSYM                { sL1 $1 $! mkUnqual tcClsName (getVARSYM $1) }
+        | '*'                   { sL1 $1 $! mkUnqual tcClsName (fsLit "*") }
+        | '-'                   { sL1 $1 $! mkUnqual tcClsName (fsLit "-") }
 
 
 -----------------------------------------------------------------------------
@@ -2645,7 +2736,9 @@ op      :: { Located RdrName }   -- used in infix decls
 
 varop   :: { Located RdrName }
         : varsym                { $1 }
-        | '`' varid '`'         {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
+        | '`' varid '`'         {% ams (sLL $1 $> (unLoc $2))
+                                       [mj AnnBackquote $1,mj AnnVal $2
+                                       ,mj AnnBackquote $3] }
 
 qop     :: { LHsExpr RdrName }   -- used in sections
         : qvarop                { sL1 $1 $ HsVar (unLoc $1) }
@@ -2657,11 +2750,15 @@ qopm    :: { LHsExpr RdrName }   -- used in sections
 
 qvarop :: { Located RdrName }
         : qvarsym               { $1 }
-        | '`' qvarid '`'        {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
+        | '`' qvarid '`'        {% ams (sLL $1 $> (unLoc $2))
+                                       [mj AnnBackquote $1,mj AnnVal $2
+                                       ,mj AnnBackquote $3] }
 
 qvaropm :: { Located RdrName }
         : qvarsym_no_minus      { $1 }
-        | '`' qvarid '`'        {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
+        | '`' qvarid '`'        {% ams (sLL $1 $> (unLoc $2))
+                                       [mj AnnBackquote $1,mj AnnVal $2
+                                       ,mj AnnBackquote $3] }
 
 -----------------------------------------------------------------------------
 -- Type variables
@@ -2670,7 +2767,9 @@ tyvar   :: { Located RdrName }
 tyvar   : tyvarid               { $1 }
 
 tyvarop :: { Located RdrName }
-tyvarop : '`' tyvarid '`'       {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
+tyvarop : '`' tyvarid '`'       {% ams (sLL $1 $> (unLoc $2))
+                                       [mj AnnBackquote $1,mj AnnVal $2
+                                       ,mj AnnBackquote $3] }
         | '.'                   {% parseErrorSDoc (getLoc $1)
                                       (vcat [ptext (sLit "Illegal symbol '.' in type"),
                                              ptext (sLit "Perhaps you intended to use RankNTypes or a similar language"),
@@ -2678,44 +2777,47 @@ tyvarop : '`' tyvarid '`'       {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
                                 }
 
 tyvarid :: { Located RdrName }
-        : VARID                 { sL1 $1 $! mkUnqual tvName (getVARID $1) }
-        | special_id            { sL1 $1 $! mkUnqual tvName (unLoc $1) }
-        | 'unsafe'              { sL1 $1 $! mkUnqual tvName (fsLit "unsafe") }
-        | 'safe'                { sL1 $1 $! mkUnqual tvName (fsLit "safe") }
-        | 'interruptible'       { sL1 $1 $! mkUnqual tvName (fsLit "interruptible") }
+        : VARID            { sL1 $1 $! mkUnqual tvName (getVARID $1) }
+        | special_id       { sL1 $1 $! mkUnqual tvName (unLoc $1) }
+        | 'unsafe'         { sL1 $1 $! mkUnqual tvName (fsLit "unsafe") }
+        | 'safe'           { sL1 $1 $! mkUnqual tvName (fsLit "safe") }
+        | 'interruptible'  { sL1 $1 $! mkUnqual tvName (fsLit "interruptible") }
 
 -----------------------------------------------------------------------------
 -- Variables
 
 var     :: { Located RdrName }
         : varid                 { $1 }
-        | '(' varsym ')'        {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
+        | '(' varsym ')'        {% ams (sLL $1 $> (unLoc $2))
+                                       [mop $1,mj AnnVal $2,mcp $3] }
 
 qvar    :: { Located RdrName }
         : qvarid                { $1 }
-        | '(' varsym ')'        {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
-        | '(' qvarsym1 ')'      {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
+        | '(' varsym ')'        {% ams (sLL $1 $> (unLoc $2))
+                                       [mop $1,mj AnnVal $2,mcp $3] }
+        | '(' qvarsym1 ')'      {% ams (sLL $1 $> (unLoc $2))
+                                       [mop $1,mj AnnVal $2,mcp $3] }
 -- We've inlined qvarsym here so that the decision about
 -- whether it's a qvar or a var can be postponed until
 -- *after* we see the close paren.
 
 qvarid :: { Located RdrName }
-        : varid                 { $1 }
-        | QVARID                { sL1 $1 $! mkQual varName (getQVARID $1) }
-        | PREFIXQVARSYM         { sL1 $1 $! mkQual varName (getPREFIXQVARSYM $1) }
+        : varid               { $1 }
+        | QVARID              { sL1 $1 $! mkQual varName (getQVARID $1) }
+        | PREFIXQVARSYM       { sL1 $1 $! mkQual varName (getPREFIXQVARSYM $1) }
 
 -- Note that 'role' and 'family' get lexed separately regardless of
 -- the use of extensions. However, because they are listed here, this
 -- is OK and they can be used as normal varids.
 varid :: { Located RdrName }
-        : VARID                 { sL1 $1 $! mkUnqual varName (getVARID $1) }
-        | special_id            { sL1 $1 $! mkUnqual varName (unLoc $1) }
-        | 'unsafe'              { sL1 $1 $! mkUnqual varName (fsLit "unsafe") }
-        | 'safe'                { sL1 $1 $! mkUnqual varName (fsLit "safe") }
-        | 'interruptible'       { sL1 $1 $! mkUnqual varName (fsLit "interruptible") }
-        | 'forall'              { sL1 $1 $! mkUnqual varName (fsLit "forall") }
-        | 'family'              { sL1 $1 $! mkUnqual varName (fsLit "family") }
-        | 'role'                { sL1 $1 $! mkUnqual varName (fsLit "role") }
+        : VARID            { sL1 $1 $! mkUnqual varName (getVARID $1) }
+        | special_id       { sL1 $1 $! mkUnqual varName (unLoc $1) }
+        | 'unsafe'         { sL1 $1 $! mkUnqual varName (fsLit "unsafe") }
+        | 'safe'           { sL1 $1 $! mkUnqual varName (fsLit "safe") }
+        | 'interruptible'  { sL1 $1 $! mkUnqual varName (fsLit "interruptible")}
+        | 'forall'         { sL1 $1 $! mkUnqual varName (fsLit "forall") }
+        | 'family'         { sL1 $1 $! mkUnqual varName (fsLit "family") }
+        | 'role'           { sL1 $1 $! mkUnqual varName (fsLit "role") }
 
 qvarsym :: { Located RdrName }
         : varsym                { $1 }
@@ -2733,8 +2835,8 @@ varsym :: { Located RdrName }
         | '-'                   { sL1 $1 $ mkUnqual varName (fsLit "-") }
 
 varsym_no_minus :: { Located RdrName } -- varsym not including '-'
-        : VARSYM                { sL1 $1 $ mkUnqual varName (getVARSYM $1) }
-        | special_sym           { sL1 $1 $ mkUnqual varName (unLoc $1) }
+        : VARSYM               { sL1 $1 $ mkUnqual varName (getVARSYM $1) }
+        | special_sym          { sL1 $1 $ mkUnqual varName (unLoc $1) }
 
 
 -- These special_ids are treated as keywords in various places,
@@ -2757,7 +2859,7 @@ special_id
         | 'group'               { sL1 $1 (fsLit "group") }
 
 special_sym :: { Located FastString }
-special_sym : '!'       { sL1 $1 (fsLit "!") }
+special_sym : '!'       {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] }
             | '.'       { sL1 $1 (fsLit ".") }
             | '*'       { sL1 $1 (fsLit "*") }
 
@@ -2765,22 +2867,22 @@ special_sym : '!'       { sL1 $1 (fsLit "!") }
 -- Data constructors
 
 qconid :: { Located RdrName }   -- Qualified or unqualified
-        : conid                 { $1 }
-        | QCONID                { sL1 $1 $! mkQual dataName (getQCONID $1) }
-        | PREFIXQCONSYM         { sL1 $1 $! mkQual dataName (getPREFIXQCONSYM $1) }
+        : conid              { $1 }
+        | QCONID             { sL1 $1 $! mkQual dataName (getQCONID $1) }
+        | PREFIXQCONSYM      { sL1 $1 $! mkQual dataName (getPREFIXQCONSYM $1) }
 
 conid   :: { Located RdrName }
-        : CONID                 { sL1 $1 $ mkUnqual dataName (getCONID $1) }
+        : CONID                { sL1 $1 $ mkUnqual dataName (getCONID $1) }
 
 qconsym :: { Located RdrName }  -- Qualified or unqualified
-        : consym                { $1 }
-        | QCONSYM               { sL1 $1 $ mkQual dataName (getQCONSYM $1) }
+        : consym               { $1 }
+        | QCONSYM              { sL1 $1 $ mkQual dataName (getQCONSYM $1) }
 
 consym :: { Located RdrName }
-        : CONSYM                { sL1 $1 $ mkUnqual dataName (getCONSYM $1) }
+        : CONSYM              { sL1 $1 $ mkUnqual dataName (getCONSYM $1) }
 
         -- ':' means only list cons
-        | ':'                   { sL1 $1 $ consDataCon_RDR }
+        | ':'                { sL1 $1 $ consDataCon_RDR }
 
 
 -----------------------------------------------------------------------------
@@ -2881,9 +2983,9 @@ getPRIMFLOAT    (L _ (ITprimfloat x)) = x
 getPRIMDOUBLE   (L _ (ITprimdouble x)) = x
 getTH_ID_SPLICE (L _ (ITidEscape x)) = x
 getTH_ID_TY_SPLICE (L _ (ITidTyEscape x)) = x
-getINLINE       (L _ (ITinline_prag inl conl)) = (inl,conl)
-getSPEC_INLINE  (L _ (ITspec_inline_prag True))  = (Inline,  FunLike)
-getSPEC_INLINE  (L _ (ITspec_inline_prag False)) = (NoInline,FunLike)
+getINLINE       (L _ (ITinline_prag inl conl)) = (inl,conl)
+getSPEC_INLINE  (L _ (ITspec_inline_prag True))  = (Inline,  FunLike)
+getSPEC_INLINE  (L _ (ITspec_inline_prag False)) = (NoInline,FunLike)
 
 getDOCNEXT (L _ (ITdocCommentNext x)) = x
 getDOCPREV (L _ (ITdocCommentPrev x)) = x
@@ -2898,6 +3000,29 @@ getPRIMSTRINGs  (L _ (ITprimstring src _)) = src
 getPRIMINTEGERs (L _ (ITprimint    src _)) = src
 getPRIMWORDs    (L _ (ITprimword   src _)) = src
 
+-- See Note [Pragma source text] in BasicTypes for the following
+getINLINE_PRAGs       (L _ (ITinline_prag       src _ _)) = src
+getSPEC_PRAGs         (L _ (ITspec_prag         src))     = src
+getSPEC_INLINE_PRAGs  (L _ (ITspec_inline_prag  src _))   = src
+getSOURCE_PRAGs       (L _ (ITsource_prag       src)) = src
+getRULES_PRAGs        (L _ (ITrules_prag        src)) = src
+getWARNING_PRAGs      (L _ (ITwarning_prag      src)) = src
+getDEPRECATED_PRAGs   (L _ (ITdeprecated_prag   src)) = src
+getSCC_PRAGs          (L _ (ITscc_prag          src)) = src
+getGENERATED_PRAGs    (L _ (ITgenerated_prag    src)) = src
+getCORE_PRAGs         (L _ (ITcore_prag         src)) = src
+getUNPACK_PRAGs       (L _ (ITunpack_prag       src)) = src
+getNOUNPACK_PRAGs     (L _ (ITnounpack_prag     src)) = src
+getANN_PRAGs          (L _ (ITann_prag          src)) = src
+getVECT_PRAGs         (L _ (ITvect_prag         src)) = src
+getVECT_SCALAR_PRAGs  (L _ (ITvect_scalar_prag  src)) = src
+getNOVECT_PRAGs       (L _ (ITnovect_prag       src)) = src
+getMINIMAL_PRAGs      (L _ (ITminimal_prag      src)) = src
+getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src
+getOVERLAPPING_PRAGs  (L _ (IToverlapping_prag  src)) = src
+getOVERLAPS_PRAGs     (L _ (IToverlaps_prag     src)) = src
+getINCOHERENT_PRAGs   (L _ (ITincoherent_prag   src)) = src
+getCTYPEs             (L _ (ITctype             src)) = src
 
 
 getSCC :: Located Token -> P FastString
@@ -2986,10 +3111,6 @@ in ApiAnnotation.hs
 
 -}
 
--- |Encapsulated call to addAnnotation, requiring only the SrcSpan of
--- the AST element the annotation belongs to
-type AddAnn = (SrcSpan -> P ())
-
 -- |Construct an AddAnn from the annotation keyword and the location
 -- of the keyword
 mj :: AnnKeywordId -> Located e -> AddAnn
@@ -3032,10 +3153,22 @@ mo,mc :: Located Token -> SrcSpan -> P ()
 mo ll = mj AnnOpen ll
 mc ll = mj AnnClose ll
 
+moc,mcc :: Located Token -> SrcSpan -> P ()
+moc ll = mj AnnOpenC ll
+mcc ll = mj AnnCloseC ll
+
+mop,mcp :: Located Token -> SrcSpan -> P ()
+mop ll = mj AnnOpenP ll
+mcp ll = mj AnnCloseP ll
+
+mos,mcs :: Located Token -> SrcSpan -> P ()
+mos ll = mj AnnOpenS ll
+mcs ll = mj AnnCloseS ll
+
 -- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma
 --  entry for each SrcSpan
 mcommas :: [SrcSpan] -> [AddAnn]
-mcommas ss = map (\s -> mj AnnComma (L s ())) ss
+mcommas ss = map (\s -> mj AnnCommaTuple (L s ())) ss
 
 -- |Add the annotation to an AST element wrapped in a Just
 ajl :: Located (Maybe (Located a)) -> AnnKeywordId -> SrcSpan
@@ -3050,16 +3183,16 @@ aljs a@(L _ (Just (L l _))) bs = (mapM_ (\a -> a l) bs) >> return a
 -- |Add all [AddAnn] to an AST element wrapped in a Just
 ajs a@(Just (L l _)) bs = (mapM_ (\a -> a l) bs) >> return a
 
--- |Get the location of the last element of a OrdList, or noLoc
+-- |Get the location of the last element of a OrdList, or noSrcSpan
 oll :: OrdList (Located a) -> SrcSpan
-oll l = case fromOL l of
-         [] -> noSrcSpan
-         xs -> getLoc (last xs)
+oll l =
+  if isNilOL l then noSrcSpan
+               else getLoc (lastOL l)
 
 -- |Add a semicolon annotation in the right place in a list. If the
 -- leading list is empty, add it to the tail
 asl :: [Located a] -> Located b -> Located a -> P()
-asl [] (L ls _) (L l _) = addAnnotation l                  AnnSemi ls
+asl [] (L ls _) (L l _) = addAnnotation l          AnnSemi ls
 asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls
 
 }
index 7628227..a1d9885 100644 (file)
@@ -72,7 +72,8 @@ import RdrName          ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
 import OccName          ( tcClsName, isVarNameSpace )
 import Name             ( Name )
 import BasicTypes       ( maxPrecedence, Activation(..), RuleMatchInfo,
-                          InlinePragma(..), InlineSpec(..), Origin(..) )
+                          InlinePragma(..), InlineSpec(..), Origin(..),
+                          SourceText )
 import TcEvidence       ( idHsWrapper )
 import Lexer
 import TysWiredIn       ( unitTyCon, unitDataCon )
@@ -88,6 +89,7 @@ import Outputable
 import FastString
 import Maybes
 import Util
+import ApiAnnotation
 
 import Control.Applicative ((<$>))
 import Control.Monad
@@ -126,20 +128,22 @@ mkInstD (L loc d) = L loc (InstD d)
 
 mkClassDecl :: SrcSpan
             -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-            -> Located [Located (FunDep RdrName)]
+            -> Located (a,[Located (FunDep (Located RdrName))])
             -> OrdList (LHsDecl RdrName)
             -> P (LTyClDecl RdrName)
 
 mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
   = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
        ; let cxt = fromMaybe (noLoc []) mcxt
-       ; (cls, tparams) <- checkTyClHdr tycl_hdr
+       ; (cls, tparams,ann) <- checkTyClHdr tycl_hdr
+       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        -- Partial type signatures are not allowed in a class definition
        ; checkNoPartialSigs sigs cls
        ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams
        ; at_defs <- mapM (eitherToP . mkATDefault) at_insts
        ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
-                                    tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
+                                    tcdFDs = snd (unLoc fds), tcdSigs = sigs,
+                                    tcdMeths = binds,
                                     tcdATs = ats, tcdATDefs = at_defs, tcdDocs  = docs,
                                     tcdFVs = placeHolderNames })) }
 
@@ -188,7 +192,7 @@ checkNoPartialCon con_decls =
                            (hsConDeclArgTys details) ]
   where err con_decl = text "A constructor cannot have a partial type:" $$
                        ppr con_decl
-        containsWildcardRes (ResTyGADT ty) = findWildcards ty
+        containsWildcardRes (ResTyGADT ty) = findWildcards ty
         containsWildcardRes ResTyH98 = notFound
 
 -- | Check that the given type does not contain wildcards, and is thus not a
@@ -265,7 +269,8 @@ mkTyData :: SrcSpan
          -> 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
+  = do { (tc, tparams,ann) <- checkTyClHdr tycl_hdr
+       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
        ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
@@ -299,7 +304,8 @@ mkTySynonym :: SrcSpan
             -> LHsType RdrName  -- RHS
             -> P (LTyClDecl RdrName)
 mkTySynonym loc lhs rhs
-  = do { (tc, tparams) <- checkTyClHdr lhs
+  = do { (tc, tparams,ann) <- checkTyClHdr lhs
+       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; tyvars <- checkTyVarsP (ptext (sLit "type")) equalsDots tc tparams
        ; let err = text "In type synonym" <+> quotes (ppr tc) <>
                    colon <+> ppr rhs
@@ -309,9 +315,9 @@ mkTySynonym loc lhs rhs
 
 mkTyFamInstEqn :: LHsType RdrName
                -> LHsType RdrName
-               -> P (TyFamInstEqn RdrName)
+               -> P (TyFamInstEqn RdrName,[AddAnn])
 mkTyFamInstEqn lhs rhs
-  = do { (tc, tparams) <- checkTyClHdr lhs
+  = do { (tc, tparams,ann) <- checkTyClHdr lhs
        ; let err xhs = hang (text "In type family instance equation of" <+>
                              quotes (ppr tc) <> colon)
                        2 (ppr xhs)
@@ -319,7 +325,8 @@ mkTyFamInstEqn lhs rhs
        ; checkNoPartialType (err rhs) rhs
        ; return (TyFamEqn { tfe_tycon = tc
                           , tfe_pats  = mkHsWithBndrs tparams
-                          , tfe_rhs   = rhs }) }
+                          , tfe_rhs   = rhs },
+                 ann) }
 
 mkDataFamInst :: SrcSpan
          -> NewOrData
@@ -330,7 +337,8 @@ mkDataFamInst :: SrcSpan
          -> 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
+  = do { (tc, tparams,ann) <- checkTyClHdr tycl_hdr
+       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
        ; return (L loc (DataFamInstD (
                   DataFamInstDecl { dfid_tycon = tc, dfid_pats = mkHsWithBndrs tparams
@@ -349,7 +357,8 @@ mkFamDecl :: SrcSpan
           -> Maybe (LHsKind RdrName) -- Optional kind signature
           -> P (LTyClDecl RdrName)
 mkFamDecl loc info lhs ksig
-  = do { (tc, tparams) <- checkTyClHdr lhs
+  = do { (tc, tparams,ann) <- checkTyClHdr lhs
+       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
        ; return (L loc (FamDecl (FamilyDecl { fdInfo = info, fdLName = tc
                                             , fdTyVars = tyvars, fdKindSig = ksig }))) }
@@ -504,7 +513,7 @@ getMonoBind bind binds = (bind, binds)
 
 has_args :: [LMatch RdrName (LHsExpr RdrName)] -> Bool
 has_args []                           = panic "RdrHsSyn:has_args"
-has_args ((L _ (Match args _ _)) : _) = not (null args)
+has_args ((L _ (Match args _ _)) : _) = not (null args)
         -- Don't group together FunBinds if they have
         -- no arguments.  This is necessary now that variable bindings
         -- with no arguments are now treated as FunBinds rather
@@ -540,7 +549,7 @@ splitCon ty
                                          -- See Note [Unit tuples] in HsTypes
    split (L l _) _                 = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty)
 
-   mk_rest [L _ (HsRecTy flds)] = RecCon flds
+   mk_rest [L l (HsRecTy flds)] = RecCon (L l flds)
    mk_rest ts                   = PrefixCon ts
 
 recordPatSynErr :: SrcSpan -> LPat RdrName -> P a
@@ -560,8 +569,9 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
         do { unless (name == patsyn_name) $
                wrongNameBindingErr loc decl
            ; match <- case details of
-               PrefixCon pats -> return $ Match pats Nothing rhs
-               InfixCon pat1 pat2 -> return $ Match [pat1, pat2] Nothing rhs
+               PrefixCon pats -> return $ Match Nothing pats Nothing rhs
+               InfixCon pat1 pat2 ->
+                         return $ Match Nothing [pat1, pat2] Nothing rhs
                RecCon{} -> recordPatSynErr loc pat
            ; return $ L loc match }
     fromDecl (L loc decl) = extraDeclErr loc decl
@@ -578,7 +588,7 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
 
 mkDeprecatedGadtRecordDecl :: SrcSpan
                            -> Located RdrName
-                           -> [LConDeclField RdrName]
+                           -> Located [LConDeclField RdrName]
                            -> LHsType RdrName
                            ->  P (LConDecl  RdrName)
 -- This one uses the deprecated syntax
@@ -592,7 +602,7 @@ mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
                                 , con_qvars    = mkHsQTvs []
                                 , con_cxt      = noLoc []
                                 , con_details  = RecCon flds
-                                , con_res      = ResTyGADT res_ty
+                                , con_res      = ResTyGADT loc res_ty
                                 , con_doc      = Nothing })) }
 
 mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
@@ -620,12 +630,13 @@ mkGadtDecl _ ty@(L _ (HsForAllTy _ (Just l) _ _ _))
   = parseErrorSDoc l $
     text "A constructor cannot have a partial type:" $$
     ppr ty
-mkGadtDecl names (L _ (HsForAllTy imp Nothing qvars cxt tau))
+mkGadtDecl names (L ls (HsForAllTy imp Nothing qvars cxt tau))
   = return $ 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)
+          L _ (HsFunTy (L l (HsRecTy flds)) res_ty)
+                                            -> (RecCon (L l flds), res_ty)
           _other                                    -> (PrefixCon [], tau)
 
     mk_gadt_con names
@@ -635,7 +646,7 @@ mkGadtDecl names (L _ (HsForAllTy imp Nothing qvars cxt tau))
                  , con_qvars    = qvars
                  , con_cxt      = cxt
                  , con_details  = details
-                 , con_res      = ResTyGADT res_ty
+                 , con_res      = ResTyGADT ls res_ty
                  , con_doc      = Nothing }
 mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
 
@@ -689,8 +700,8 @@ checkTyVars pp_what equals_or_where tc tparms
   where
 
         -- Check that the name space is correct!
-    chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
-        | isRdrTyVar tv    = return (L l (KindedTyVar tv k))
+    chk (L l (HsKindSig (L lv (HsTyVar tv)) k))
+        | isRdrTyVar tv    = return (L l (KindedTyVar (L lv tv) k))
     chk (L l (HsTyVar tv))
         | isRdrTyVar tv    = return (L l (UserTyVar tv))
     chk t@(L loc _)
@@ -729,25 +740,28 @@ checkRecordSyntax lr@(L loc r)
 
 checkTyClHdr :: LHsType RdrName
              -> P (Located RdrName,          -- the head symbol (type or class name)
-                   [LHsType RdrName])        -- parameters of head symbol
+                   [LHsType RdrName],        -- parameters of head symbol
+                   [AddAnn]) -- API Annotation for HsParTy when stripping parens
 -- Well-formedness check and decomposition of type and class heads.
 -- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
 --              Int :*: Bool   into    (:*:, [Int, Bool])
 -- returning the pieces
 checkTyClHdr ty
-  = goL ty []
+  = goL ty [] []
   where
-    goL (L l ty) acc = go l ty acc
-
-    go l (HsTyVar tc) acc
-        | isRdrTc tc          = return (L l tc, acc)
-    go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc
-        | isRdrTc tc         = return (ltc, t1:t2:acc)
-    go _ (HsParTy ty)    acc = goL ty acc
-    go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
-    go l (HsTupleTy _ []) [] = return (L l (getRdrName unitTyCon), [])
+    goL (L l ty) acc ann = go l ty acc ann
+
+    go l (HsTyVar tc) acc ann
+        | isRdrTc tc             = return (L l tc, acc, ann)
+    go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc ann
+        | isRdrTc tc             = return (ltc, t1:t2:acc, ann)
+    go l (HsParTy ty)    acc ann = goL ty acc (ann ++ mkParensApiAnn l)
+    go _ (HsAppTy t1 t2) acc ann = goL t1 (t2:acc) ann
+    go l (HsTupleTy _ []) [] ann = return (L l (getRdrName unitTyCon), [],ann)
                                    -- See Note [Unit tuples] in HsTypes
-    go l _               _   = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty)
+    go l _               _   _
+         = parseErrorSDoc l (text "Malformed head of type or class declaration:"
+                             <+> ppr ty)
 
 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 checkContext (L l orig_t)
@@ -808,14 +822,16 @@ checkAPat msg loc e0 = do
    -- Overloaded numeric patterns (e.g. f 0 x = x)
    -- Negation is recorded separately, so that the literal is zero or +ve
    -- NB. Negative *primitive* literals are already handled by the lexer
-   HsOverLit pos_lit          -> return (mkNPat pos_lit Nothing)
-   NegApp (L _ (HsOverLit pos_lit)) _
-                        -> return (mkNPat pos_lit (Just noSyntaxExpr))
+   HsOverLit pos_lit          -> return (mkNPat (L loc pos_lit) Nothing)
+   NegApp (L l (HsOverLit pos_lit)) _
+                        -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))
 
-   SectionR (L _ (HsVar bang)) e        -- (! x)
+   SectionR (L lb (HsVar bang)) e        -- (! x)
         | bang == bang_RDR
         -> do { bang_on <- extension bangPatEnabled
-              ; if bang_on then checkLPat msg e >>= (return . BangPat)
+              ; if bang_on then do { e' <- checkLPat msg e
+                                   ; addAnnotation loc AnnBang lb
+                                   ; return  (BangPat e') }
                 else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) }
 
    ELazyPat e         -> checkLPat msg e >>= (return . LazyPat)
@@ -835,9 +851,9 @@ checkAPat msg loc e0 = do
 
    -- n+k patterns
    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
-         (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
+         (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
                       | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
-                      -> return (mkNPlusKPat (L nloc n) lit)
+                      -> return (mkNPlusKPat (L nloc n) (L lloc lit))
 
    OpApp l op _fix r  -> do l <- checkLPat msg l
                             r <- checkLPat msg r
@@ -919,7 +935,8 @@ checkFunBind :: SDoc
 checkFunBind msg lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
   = do  ps <- checkPatterns msg pats
         let match_span = combineSrcSpans lhs_loc rhs_span
-        return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
+        return (makeFunBind fun is_infix
+                  [L match_span (Match (Just (fun,is_infix)) ps opt_sig grhss)])
         -- The span of the match covers the entire equation.
         -- That isn't quite right, but it'll do for now.
 
@@ -1272,9 +1289,9 @@ checkCmdMatchGroup :: MatchGroup RdrName (LHsExpr RdrName) -> P (MatchGroup RdrN
 checkCmdMatchGroup mg@(MG { mg_alts = ms }) = do
     ms' <- mapM (locMap $ const convert) ms
     return $ mg { mg_alts = ms' }
-    where convert (Match pat mty grhss) = do
+    where convert (Match mf pat mty grhss) = do
             grhss' <- checkCmdGRHSs grhss
-            return $ Match pat mty grhss'
+            return $ Match mf pat mty grhss'
 
 checkCmdGRHSs :: GRHSs RdrName (LHsExpr RdrName) -> P (GRHSs RdrName (LHsCmd RdrName))
 checkCmdGRHSs (GRHSs grhss binds) = do
@@ -1321,11 +1338,13 @@ 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) }
 
-mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma
+mkInlinePragma :: String -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
+               -> InlinePragma
 -- The (Maybe Activation) is because the user can omit
 -- the activation spec (and usually does)
-mkInlinePragma (inl, match_info) mb_act
-  = InlinePragma { inl_inline = inl
+mkInlinePragma src (inl, match_info) mb_act
+  = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes
+                 , inl_inline = inl
                  , inl_sat    = Nothing
                  , inl_act    = act
                  , inl_rule   = match_info }
@@ -1355,16 +1374,16 @@ mkImport (L lc cconv) (L ls safety) (L loc entity, v, ty)
   | cconv == PrimCallConv                      = do
   let funcTarget = CFunction (StaticTarget entity Nothing True)
       importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget
-                           (L loc entity)
+                           (L loc (unpackFS entity))
   return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
   | cconv == JavaScriptCallConv = do
   let funcTarget = CFunction (StaticTarget entity Nothing True)
       importSpec = CImport (L lc JavaScriptCallConv) (L ls safety) Nothing
-                           funcTarget (L loc entity)
+                           funcTarget (L loc (unpackFS entity))
   return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
   | otherwise = do
     case parseCImport (L lc cconv) (L ls safety) (mkExtName (unLoc v))
-                      (unpackFS entity) (L loc entity) of
+                      (unpackFS entity) (L loc (unpackFS entity)) of
       Nothing         -> parseErrorSDoc loc (text "Malformed entity string")
       Just importSpec -> return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
 
@@ -1372,7 +1391,7 @@ mkImport (L lc cconv) (L ls safety) (L loc entity, v, ty)
 -- C identifier case comes first in the alternatives below, so we pick
 -- that one.
 parseCImport :: Located CCallConv -> Located Safety -> FastString -> String
-             -> Located FastString
+             -> Located SourceText
              -> Maybe ForeignImport
 parseCImport cconv safety nm str sourceText =
  listToMaybe $ map fst $ filter (null.snd) $
@@ -1433,7 +1452,8 @@ mkExport (L lc cconv) (L le entity, v, ty) = do
   checkNoPartialType (ptext (sLit "In foreign export declaration") <+>
                       quotes (ppr v) $$ ppr ty) ty
   return $ ForD (ForeignExport v ty noForeignExportCoercionYet
-                 (CExport (L lc (CExportStatic entity' cconv)) (L le entity)))
+                 (CExport (L lc (CExportStatic entity' cconv))
+                          (L le (unpackFS entity))))
   where
     entity' | nullFS entity = mkExtName (unLoc v)
             | otherwise     = entity
@@ -1457,7 +1477,7 @@ mkModuleImpExp n@(L l name) subs =
   case subs of
     ImpExpAbs
       | isVarNameSpace (rdrNameSpace name) -> IEVar       n
-      | otherwise                          -> IEThingAbs  nameT
+      | otherwise                          -> IEThingAbs  (L l nameT)
     ImpExpAll                              -> IEThingAll  (L l nameT)
     ImpExpList xs                          -> IEThingWith (L l nameT) xs
 
index 9afc249..5b05303 100644 (file)
@@ -22,6 +22,7 @@ import FastString
 import Binary
 import Outputable
 import Module
+import BasicTypes ( SourceText )
 
 import Data.Char
 import Data.Data
@@ -224,12 +225,17 @@ instance Outputable Header where
     ppr (Header h) = quotes $ ppr h
 
 -- | A C type, used in CAPI FFI calls
-data CType = CType (Maybe Header) -- header to include for this type
+--
+--  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@,
+--        'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal',
+--        'ApiAnnotation.AnnClose' @'\#-}'@,
+data CType = CType SourceText -- Note [Pragma source text] in BasicTypes
+                   (Maybe Header) -- header to include for this type
                    FastString     -- the type itself
     deriving (Data, Typeable)
 
 instance Outputable CType where
-    ppr (CType mh ct) = hDoc <+> ftext ct
+    ppr (CType mh ct) = hDoc <+> ftext ct
         where hDoc = case mh of
                      Nothing -> empty
                      Just h -> ppr h
@@ -319,11 +325,13 @@ instance Binary CCallConv where
               _ -> do return JavaScriptCallConv
 
 instance Binary CType where
-    put_ bh (CType mh fs) = do put_ bh mh
-                               put_ bh fs
-    get bh = do mh <- get bh
+    put_ bh (CType s mh fs) = do put_ bh s
+                                 put_ bh mh
+                                 put_ bh fs
+    get bh = do s  <- get bh
+                mh <- get bh
                 fs <- get bh
-                return (CType mh fs)
+                return (CType mh fs)
 
 instance Binary Header where
     put_ bh (Header h) = put_ bh h
index ccebe53..6181415 100644 (file)
@@ -536,7 +536,7 @@ charTy = mkTyConTy charTyCon
 
 charTyCon :: TyCon
 charTyCon   = pcNonRecDataTyCon charTyConName
-                                (Just (CType Nothing (fsLit "HsChar")))
+                                (Just (CType "" Nothing (fsLit "HsChar")))
                                 [] [charDataCon]
 charDataCon :: DataCon
 charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon
@@ -548,7 +548,9 @@ intTy :: Type
 intTy = mkTyConTy intTyCon
 
 intTyCon :: TyCon
-intTyCon = pcNonRecDataTyCon intTyConName (Just (CType Nothing (fsLit "HsInt"))) [] [intDataCon]
+intTyCon = pcNonRecDataTyCon intTyConName
+                             (Just (CType "" Nothing (fsLit "HsInt"))) []
+                             [intDataCon]
 intDataCon :: DataCon
 intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon
 
@@ -556,7 +558,9 @@ wordTy :: Type
 wordTy = mkTyConTy wordTyCon
 
 wordTyCon :: TyCon
-wordTyCon = pcNonRecDataTyCon wordTyConName (Just (CType Nothing (fsLit "HsWord"))) [] [wordDataCon]
+wordTyCon = pcNonRecDataTyCon wordTyConName
+                              (Just (CType "" Nothing (fsLit "HsWord"))) []
+                              [wordDataCon]
 wordDataCon :: DataCon
 wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon
 
@@ -564,7 +568,9 @@ floatTy :: Type
 floatTy = mkTyConTy floatTyCon
 
 floatTyCon :: TyCon
-floatTyCon   = pcNonRecDataTyCon floatTyConName   (Just (CType Nothing (fsLit "HsFloat"))) [] [floatDataCon]
+floatTyCon   = pcNonRecDataTyCon floatTyConName
+                                 (Just (CType "" Nothing (fsLit "HsFloat"))) []
+                                 [floatDataCon]
 floatDataCon :: DataCon
 floatDataCon = pcDataCon         floatDataConName [] [floatPrimTy] floatTyCon
 
@@ -572,7 +578,9 @@ doubleTy :: Type
 doubleTy = mkTyConTy doubleTyCon
 
 doubleTyCon :: TyCon
-doubleTyCon = pcNonRecDataTyCon doubleTyConName (Just (CType Nothing (fsLit "HsDouble"))) [] [doubleDataCon]
+doubleTyCon = pcNonRecDataTyCon doubleTyConName
+                                (Just (CType "" Nothing (fsLit "HsDouble"))) []
+                                [doubleDataCon]
 
 doubleDataCon :: DataCon
 doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon
@@ -632,7 +640,7 @@ boolTy = mkTyConTy boolTyCon
 
 boolTyCon :: TyCon
 boolTyCon = pcTyCon True NonRecursive True boolTyConName
-                    (Just (CType Nothing (fsLit "HsBool")))
+                    (Just (CType "" Nothing (fsLit "HsBool")))
                     [] [falseDataCon, trueDataCon]
 
 falseDataCon, trueDataCon :: DataCon
index 46d36a7..7a9dcae 100644 (file)
@@ -826,9 +826,9 @@ renameSig ctxt sig@(GenericSig vs ty)
         ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty
         ; return (GenericSig new_v new_ty, fvs) }
 
-renameSig _ (SpecInstSig ty)
+renameSig _ (SpecInstSig src ty)
   = do  { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty
-        ; return (SpecInstSig new_ty,fvs) }
+        ; return (SpecInstSig src new_ty,fvs) }
 
 -- {-# SPECIALISE #-} pragmas can refer to imported Ids
 -- so, in the top-level case (when mb_names is Nothing)
@@ -854,9 +854,9 @@ 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)
+renameSig ctxt sig@(MinimalSig bf)
   = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
-       return (MinimalSig new_bf, emptyFVs)
+       return (MinimalSig new_bf, emptyFVs)
 
 renameSig ctxt sig@(PatSynSig v (flag, qtvs) prov req ty)
   = do  { v' <- lookupSigOccRn ctxt sig v
@@ -978,7 +978,7 @@ rnMatch' :: Outputable (body RdrName) => HsMatchContext Name
          -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
          -> Match RdrName (Located (body RdrName))
          -> RnM (Match Name (Located (body Name)), FreeVars)
-rnMatch' ctxt rnBody match@(Match pats maybe_rhs_sig grhss)
+rnMatch' ctxt rnBody match@(Match _mf pats maybe_rhs_sig grhss)
   = do  {       -- Result type signatures are no longer supported
           case maybe_rhs_sig of
                 Nothing -> return ()
@@ -989,7 +989,7 @@ rnMatch' ctxt rnBody match@(Match pats maybe_rhs_sig grhss)
         ; rnPats ctxt pats      $ \ pats' -> do
         { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
 
-        ; return (Match pats' Nothing grhss', grhss_fvs) }}
+        ; return (Match Nothing pats' Nothing grhss', grhss_fvs) }}
 
 emptyCaseErr :: HsMatchContext Name -> SDoc
 emptyCaseErr ctxt = hang (ptext (sLit "Empty list of alternatives in") <+> pp_ctxt)
index f210b5a..ced1b43 100644 (file)
@@ -183,16 +183,16 @@ rnExpr expr@(SectionR {})
   = do  { addErr (sectionErr expr); rnSection expr }
 
 ---------------------------------------------
-rnExpr (HsCoreAnn ann expr)
+rnExpr (HsCoreAnn src ann expr)
   = do { (expr', fvs_expr) <- rnLExpr expr
-       ; return (HsCoreAnn ann expr', fvs_expr) }
+       ; return (HsCoreAnn src ann expr', fvs_expr) }
 
-rnExpr (HsSCC lbl expr)
+rnExpr (HsSCC src lbl expr)
   = do { (expr', fvs_expr) <- rnLExpr expr
-       ; return (HsSCC lbl expr', fvs_expr) }
-rnExpr (HsTickPragma info expr)
+       ; return (HsSCC src lbl expr', fvs_expr) }
+rnExpr (HsTickPragma src info expr)
   = do { (expr', fvs_expr) <- rnLExpr expr
-       ; return (HsTickPragma info expr', fvs_expr) }
+       ; return (HsTickPragma src info expr', fvs_expr) }
 
 rnExpr (HsLam matches)
   = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
@@ -559,7 +559,7 @@ methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars
 methodNamesMatch (MG { mg_alts = ms })
   = plusFVs (map do_one ms)
  where
-    do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
+    do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
 
 -------------------------------------------------
 -- gaw 2004
index 84a56f0..102deb0 100644 (file)
@@ -755,7 +755,7 @@ filterImports ifaces decl_spec (Just (want_hiding, L l import_items))
                                        AvailTC parent [name])],
                                      warns)
 
-        IEThingAbs tc
+        IEThingAbs (L l tc)
             | want_hiding   -- hiding ( C )
                        -- Here the 'C' can be a data constructor
                        --  *or* a type/class, or even both
@@ -764,10 +764,10 @@ filterImports ifaces decl_spec (Just (want_hiding, L l import_items))
                in
                case catIELookupM [ tc_name, dc_name ] of
                  []    -> failLookupWith BadImport
-                 names -> return ([mkIEThingAbs name | name <- names], [])
+                 names -> return ([mkIEThingAbs name | name <- names], [])
             | otherwise
             -> do nameAvail <- lookup_name tc
-                  return ([mkIEThingAbs nameAvail], [])
+                  return ([mkIEThingAbs nameAvail], [])
 
         IEThingWith (L l rdr_tc) rdr_ns -> do
            (name, AvailTC _ ns, mb_parent) <- lookup_name rdr_tc
@@ -801,8 +801,10 @@ filterImports ifaces decl_spec (Just (want_hiding, L l import_items))
         -- all errors.
 
       where
-        mkIEThingAbs (n, av, Nothing    ) = (IEThingAbs n, trimAvail av n)
-        mkIEThingAbs (n, _,  Just parent) = (IEThingAbs n, AvailTC parent [n])
+        mkIEThingAbs l (n, av, Nothing    ) = (IEThingAbs (L l n),
+                                               trimAvail av n)
+        mkIEThingAbs l (n, _,  Just parent) = (IEThingAbs (L l n),
+                                               AvailTC parent [n])
 
         handle_bad_import m = catchIELookup m $ \err -> case err of
           BadImport | want_hiding -> return ([], [BadImportW])
@@ -1133,11 +1135,11 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
         = do gre <- lookupGreRn rdr
              return (IEVar (L l (gre_name gre)), greExportAvail gre)
 
-    lookup_ie (IEThingAbs rdr)
+    lookup_ie (IEThingAbs (L l rdr))
         = do gre <- lookupGreRn rdr
              let name = gre_name gre
                  avail = greExportAvail gre
-             return (IEThingAbs name, avail)
+             return (IEThingAbs (L l name), avail)
 
     lookup_ie ie@(IEThingAll (L l rdr))
         = do name <- lookupGlobalOccRn rdr
@@ -1417,7 +1419,7 @@ findImportUsage imports rdr_env rdrs
 
         add_unused :: IE Name -> NameSet -> NameSet
         add_unused (IEVar (L _ n))      acc = add_unused_name n acc
-        add_unused (IEThingAbs n)       acc = add_unused_name n acc
+        add_unused (IEThingAbs (L _ 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
@@ -1568,7 +1570,7 @@ printMinimalImports imports_w_usage
     to_ie _ (Avail n)
        = [IEVar (noLoc n)]
     to_ie _ (AvailTC n [m])
-       | n==m = [IEThingAbs n]
+       | n==m = [IEThingAbs (noLoc n)]
     to_ie ifaces (AvailTC n ns)
       = case [xs | iface <- ifaces
                  , AvailTC x xs <- mi_exports iface
@@ -1771,10 +1773,10 @@ missingImportListItem ie
   = ptext (sLit "The import item") <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list")
 
 moduleWarn :: ModuleName -> WarningTxt -> SDoc
-moduleWarn mod (WarningTxt txt)
+moduleWarn mod (WarningTxt txt)
   = sep [ ptext (sLit "Module") <+> quotes (ppr mod) <> ptext (sLit ":"),
           nest 2 (vcat (map ppr txt)) ]
-moduleWarn mod (DeprecatedTxt txt)
+moduleWarn mod (DeprecatedTxt txt)
   = sep [ ptext (sLit "Module") <+> quotes (ppr mod)
                                 <+> ptext (sLit "is deprecated:"),
           nest 2 (vcat (map ppr txt)) ]
index 7f593f1..cdd180b 100644 (file)
@@ -381,28 +381,30 @@ rnPatAndThen mk (LitPat lit)
   | HsString src s <- lit
   = do { ovlStr <- liftCps (xoptM Opt_OverloadedStrings)
        ; if ovlStr
-         then rnPatAndThen mk (mkNPat (mkHsIsString src s placeHolderType)
+         then rnPatAndThen mk
+                           (mkNPat (noLoc (mkHsIsString src s placeHolderType))
                                       Nothing)
          else normal_lit }
   | otherwise = normal_lit
   where
     normal_lit = do { liftCps (rnLit lit); return (LitPat lit) }
 
-rnPatAndThen _ (NPat lit mb_neg _eq)
+rnPatAndThen _ (NPat (L l lit) mb_neg _eq)
   = do { lit'    <- liftCpsFV $ rnOverLit lit
        ; mb_neg' <- liftCpsFV $ case mb_neg of
                       Nothing -> return (Nothing, emptyFVs)
                       Just _  -> do { (neg, fvs) <- lookupSyntaxName negateName
                                     ; return (Just neg, fvs) }
        ; eq' <- liftCpsFV $ lookupSyntaxName eqName
-       ; return (NPat lit' mb_neg' eq') }
+       ; return (NPat (L l lit') mb_neg' eq') }
 
-rnPatAndThen mk (NPlusKPat rdr lit _ _)
-  = do { new_name <- newPatLName mk rdr
+rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _)
+  = do { new_name <- newPatName mk rdr
        ; lit'  <- liftCpsFV $ rnOverLit lit
        ; minus <- liftCpsFV $ lookupSyntaxName minusName
        ; ge    <- liftCpsFV $ lookupSyntaxName geName
-       ; return (NPlusKPat new_name lit' ge minus) }
+       ; return (NPlusKPat (L (nameSrcSpan new_name) new_name)
+                           (L l lit') ge minus) }
                 -- The Report says that n+k patterns must be in Integral
 
 rnPatAndThen mk (AsPat rdr pat)
index d9536fb..ac86fc3 100644 (file)
@@ -168,7 +168,7 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_decls,
 
    (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
    (rn_rule_decls,    src_fvs3) <- setXOptM Opt_ScopedTypeVariables $
-                                   rnList rnHsRuleDecl    rule_decls ;
+                                   rnList rnHsRuleDecls rule_decls ;
                            -- Inside RULES, scoped type variables are on
    (rn_vect_decls,    src_fvs4) <- rnList rnHsVectDecl    vect_decls ;
    (rn_foreign_decls, src_fvs5) <- rnList rnHsForeignDecl foreign_decls ;
@@ -308,11 +308,11 @@ gather them together.
 -}
 
 -- checks that the deprecations are defined locally, and that there are no duplicates
-rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings
+rnSrcWarnDecls :: NameSet -> [LWarnDecls RdrName] -> RnM Warnings
 rnSrcWarnDecls _ []
   = return NoWarnings
 
-rnSrcWarnDecls bndr_set decls
+rnSrcWarnDecls bndr_set decls'
   = do { -- check for duplicates
        ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups
                           in addErrAt loc (dupWarnDecl lrdr' rdr))
@@ -320,17 +320,21 @@ rnSrcWarnDecls bndr_set decls
        ; pairs_s <- mapM (addLocM rn_deprec) decls
        ; return (WarnSome ((concat pairs_s))) }
  where
+   decls = concatMap (\(L _ d) -> wd_warnings d) decls'
+
    sig_ctxt = TopSigCtxt bndr_set True
       -- True <=> Can give deprecations for class ops and record sels
 
-   rn_deprec (Warning rdr_name txt)
+   rn_deprec (Warning rdr_names txt)
        -- ensures that the names are defined locally
-     = do { names <- lookupLocalTcNames sig_ctxt what rdr_name
+     = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
+                                rdr_names
           ; return [(nameOccName name, txt) | name <- names] }
 
    what = ptext (sLit "deprecation")
 
-   warn_rdr_dups = findDupRdrNames (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)