Expose enabled language extensions to TH
[ghc.git] / compiler / parser / Parser.y
index eb528c3..6606e3f 100644 (file)
@@ -8,14 +8,6 @@
 -- ---------------------------------------------------------------------------
 
 {
-{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6
-{-# OPTIONS -Wwarn -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 -- | This module provides the generated Happy parser for Haskell. It exports
 -- a number of parsers which may be used in any library that uses the GHC API.
 -- A common usage pattern is to initialize the parser state with a given string
 --       filename = "\<interactive\>"
 --       location = mkRealSrcLoc (mkFastString filename) 1 1
 --       buffer = stringToStringBuffer str
---       parseState = mkPState flags buffer location in
+--       parseState = mkPState flags buffer location
 -- @
 module Parser (parseModule, parseImport, parseStatement,
-               parseDeclaration, parseExpression, parseTypeSignature,
-               parseFullStmt, parseStmt, parseIdentifier,
+               parseDeclaration, parseExpression, parsePattern,
+               parseTypeSignature,
+               parseStmt, parseIdentifier,
                parseType, parseHeader) where
 
 -- base
@@ -40,6 +33,7 @@ import Control.Monad    ( unless, liftM )
 import GHC.Exts
 import Data.Char
 import Control.Monad    ( mplus )
+import Control.Applicative ((<$))
 
 -- compiler/hsSyn
 import HsSyn
@@ -50,14 +44,14 @@ import DynFlags
 
 -- compiler/utils
 import OrdList
-import BooleanFormula   ( BooleanFormula, mkAnd, mkOr, mkTrue, mkVar )
+import BooleanFormula   ( BooleanFormula(..), LBooleanFormula(..), mkTrue )
 import FastString
 import Maybes           ( orElse )
 import Outputable
 
 -- compiler/basicTypes
 import RdrName
-import OccName          ( varName, dataName, tcClsName, tvName )
+import OccName          ( varName, dataName, tcClsName, tvName, startsWithUnderscore )
 import DataCon          ( DataCon, dataConName )
 import SrcLoc
 import Module
@@ -65,172 +59,261 @@ import BasicTypes
 
 -- compiler/types
 import Type             ( funTyCon )
-import Kind             ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind )
+import Kind             ( Kind )
 import Class            ( FunDep )
 
 -- compiler/parser
 import RdrHsSyn
 import Lexer
 import HaddockUtils
+import ApiAnnotation
 
 -- compiler/typecheck
 import TcEvidence       ( emptyTcEvBinds )
 
 -- compiler/prelude
 import ForeignCall
-import TysPrim          ( liftedTypeKindTyConName, eqPrimTyCon )
-import TysWiredIn       ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
+import TysPrim          ( eqPrimTyCon )
+import PrelNames        ( eqTyCon_RDR )
+import TysWiredIn       ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon,
                           unboxedUnitTyCon, unboxedUnitDataCon,
-                          listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
+                          listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR )
+
+-- compiler/utils
+import Util             ( looksLikePackageName )
+import Prelude
+
+import qualified GHC.LanguageExtensions as LangExt
 }
 
-{-
------------------------------------------------------------------------------
-20 Nov 2014
+{- Last updated: 18 Nov 2015
 
-Conflicts: 60 shift/reduce
-           12 reduce/reduce
+Conflicts: 36 shift/reduce
 
------------------------------------------------------------------------------
-25 June 2014
+If you modify this parser and add a conflict, please update this comment.
+You can learn more about the conflicts by passing 'happy' the -i flag:
 
-Conflicts: 47 shift/reduce
-           1 reduce/reduce
+    happy -agc --strict compiler/parser/Parser.y -idetailed-info
 
------------------------------------------------------------------------------
-12 October 2012
+How is this section formatted? Look up the state the conflict is
+reported at, and copy the list of applicable rules (at the top).  Mark
+*** for the rule that is the conflicting reduction (that is, the
+interpretation which is NOT taken).  NB: Happy doesn't print a rule in a
+state if it is empty, but you should include it in the list (you can
+look these up in the Grammar section of the info file).
 
-Conflicts: 43 shift/reduce
-           1 reduce/reduce
+Obviously the state numbers are not stable across modifications to the parser,
+the idea is to reproduce enough information on each conflict so you can figure
+out what happened if the states were renumbered.  Try not to gratuitously move
+productions around in this file.  It's probably less important to keep
+the rule annotations up-to-date.
 
------------------------------------------------------------------------------
-24 February 2006
+-------------------------------------------------------------------------------
 
-Conflicts: 33 shift/reduce
-           1 reduce/reduce
+state 0 contains 1 shift/reduce conflicts.
 
-The reduce/reduce conflict is weird.  It's between tyconsym and consym, and I
-would think the two should never occur in the same context.
+    Conflicts: DOCNEXT (empty missing_module_keyword reduces)
 
-  -=chak
+Ambiguity when the source file starts with "-- | doc". We need another
+token of lookahead to determine if a top declaration or the 'module' keyword
+follows. Shift parses as if the 'module' keyword follows.
 
------------------------------------------------------------------------------
-31 December 2006
+-------------------------------------------------------------------------------
 
-Conflicts: 34 shift/reduce
-           1 reduce/reduce
+state 46 contains 2 shift/reduce conflicts.
 
-The reduce/reduce conflict is weird.  It's between tyconsym and consym, and I
-would think the two should never occur in the same context.
+    *** strict_mark -> unpackedness .                       (rule 268)
+        strict_mark -> unpackedness . strictness            (rule 269)
 
-  -=chak
+    Conflicts: '~' '!'
 
------------------------------------------------------------------------------
-6 December 2006
+-------------------------------------------------------------------------------
 
-Conflicts: 32 shift/reduce
-           1 reduce/reduce
+state 50 contains 1 shift/reduce conflict.
 
-The reduce/reduce conflict is weird.  It's between tyconsym and consym, and I
-would think the two should never occur in the same context.
+        context -> btype .                                  (rule 295)
+    *** type -> btype .                                     (rule 297)
+        type -> btype . '->' ctype                          (rule 298)
 
-  -=chak
+    Conflicts: '->'
 
------------------------------------------------------------------------------
-26 July 2006
+-------------------------------------------------------------------------------
 
-Conflicts: 37 shift/reduce
-           1 reduce/reduce
+state 51 contains 9 shift/reduce conflicts.
 
-The reduce/reduce conflict is weird.  It's between tyconsym and consym, and I
-would think the two should never occur in the same context.
+    *** btype -> tyapps .                                   (rule 303)
+        tyapps -> tyapps . tyapp                            (rule 307)
 
-  -=chak
+    Conflicts: ':' '-' '!' '.' '`' VARSYM CONSYM QVARSYM QCONSYM
 
------------------------------------------------------------------------------
-Conflicts: 38 shift/reduce (1.25)
-
-10 for abiguity in 'if x then y else z + 1'             [State 178]
-        (shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
-        10 because op might be: : - ! * . `x` VARSYM CONSYM QVARSYM QCONSYM
-
-1 for ambiguity in 'if x then y else z :: T'            [State 178]
-        (shift parses as 'if x then y else (z :: T)', as per longest-parse rule)
-
-4 for ambiguity in 'if x then y else z -< e'            [State 178]
-        (shift parses as 'if x then y else (z -< T)', as per longest-parse rule)
-        There are four such operators: -<, >-, -<<, >>-
-
-
-2 for ambiguity in 'case v of { x :: T -> T ... } '     [States 11, 253]
-        Which of these two is intended?
-          case v of
-            (x::T) -> T         -- Rhs is T
-    or
-          case v of
-            (x::T -> T) -> ..   -- Rhs is ...
-
-10 for ambiguity in 'e :: a `b` c'.  Does this mean     [States 11, 253]
-        (e::a) `b` c, or
-        (e :: (a `b` c))
-    As well as `b` we can have !, VARSYM, QCONSYM, and CONSYM, hence 5 cases
-    Same duplication between states 11 and 253 as the previous case
-
-1 for ambiguity in 'let ?x ...'                         [State 329]
-        the parser can't tell whether the ?x is the lhs of a normal binding or
-        an implicit binding.  Fortunately resolving as shift gives it the only
-        sensible meaning, namely the lhs of an implicit binding.
-
-1 for ambiguity in '{-# RULES "name" [ ... #-}          [State 382]
-        we don't know whether the '[' starts the activation or not: it
-        might be the start of the declaration with the activation being
-        empty.  --SDM 1/4/2002
-
-1 for ambiguity in '{-# RULES "name" forall = ... #-}'  [State 474]
-        since 'forall' is a valid variable name, we don't know whether
-        to treat a forall on the input as the beginning of a quantifier
-        or the beginning of the rule itself.  Resolving to shift means
-        it's always treated as a quantifier, hence the above is disallowed.
-        This saves explicitly defining a grammar for the rule lhs that
-        doesn't include 'forall'.
-
-1 for ambiguity when the source file starts with "-- | doc". We need another
-  token of lookahead to determine if a top declaration or the 'module' keyword
-  follows. Shift parses as if the 'module' keyword follows.
+-------------------------------------------------------------------------------
 
--- ---------------------------------------------------------------------------
--- Adding location info
+state 132 contains 14 shift/reduce conflicts.
 
-This is done using the three functions below, sL0, sL1
-and sLL.  Note that these functions were mechanically
-converted from the three macros that used to exist before,
-namely L0, L1 and LL.
+        exp -> infixexp . '::' sigtype                      (rule 416)
+        exp -> infixexp . '-<' exp                          (rule 417)
+        exp -> infixexp . '>-' exp                          (rule 418)
+        exp -> infixexp . '-<<' exp                         (rule 419)
+        exp -> infixexp . '>>-' exp                         (rule 420)
+    *** exp -> infixexp .                                   (rule 421)
+        infixexp -> infixexp . qop exp10                    (rule 423)
 
-They each add a SrcSpan to their argument.
+    Conflicts: ':' '::' '-' '!' '-<' '>-' '-<<' '>>-'
+               '.' '`' VARSYM CONSYM QVARSYM QCONSYM
 
-   sL0  adds 'noSrcSpan', used for empty productions
-     -- This doesn't seem to work anymore -=chak
+Examples of ambiguity:
+    'if x then y else z -< e'
+    'if x then y else z :: T'
+    'if x then y else z + 1' (NB: '+' is in VARSYM)
 
-   sL1  for a production with a single token on the lhs.  Grabs the SrcSpan
-        from that token.
+Shift parses as (per longest-parse rule):
+    'if x then y else (z -< T)'
+    'if x then y else (z :: T)'
+    'if x then y else (z + 1)'
 
-   sLL  for a production with >1 token on the lhs.  Makes up a SrcSpan from
-        the first and last tokens.
+-------------------------------------------------------------------------------
 
-These suffice for the majority of cases.  However, we must be
-especially careful with empty productions: sLL won't work if the first
-or last token on the lhs can represent an empty span.  In these cases,
-we have to calculate the span using more of the tokens from the lhs, eg.
+state 292 contains 1 shift/reduce conflicts.
 
-        | 'newtype' tycl_hdr '=' newconstr deriving
-                { L (comb3 $1 $4 $5)
-                    (mkTyData NewType (unLoc $2) [$4] (unLoc $5)) }
+        rule -> STRING . rule_activation rule_forall infixexp '=' exp    (rule 215)
 
-We provide comb3 and comb4 functions which are useful in such cases.
+    Conflict: '[' (empty rule_activation reduces)
 
-Be careful: there's no checking that you actually got this right, the
-only symptom will be that the SrcSpans of your syntax will be
-incorrect.
+We don't know whether the '[' starts the activation or not: it
+might be the start of the declaration with the activation being
+empty.  --SDM 1/4/2002
+
+Example ambiguity:
+    '{-# RULE [0] f = ... #-}'
+
+We parse this as having a [0] rule activation for rewriting 'f', rather
+a rule instructing how to rewrite the expression '[0] f'.
+
+-------------------------------------------------------------------------------
+
+state 301 contains 1 shift/reduce conflict.
+
+    *** type -> btype .                                     (rule 297)
+        type -> btype . '->' ctype                          (rule 298)
+
+    Conflict: '->'
+
+Same as state 50 but without contexts.
+
+-------------------------------------------------------------------------------
+
+state 337 contains 1 shift/reduce conflicts.
+
+        tup_exprs -> commas . tup_tail                      (rule 505)
+        sysdcon_nolist -> '(' commas . ')'                  (rule 616)
+        commas -> commas . ','                              (rule 734)
+
+    Conflict: ')' (empty tup_tail reduces)
+
+A tuple section with NO free variables '(,,)' is indistinguishable
+from the Haskell98 data constructor for a tuple.  Shift resolves in
+favor of sysdcon, which is good because a tuple section will get rejected
+if -XTupleSections is not specified.
+
+-------------------------------------------------------------------------------
+
+state 388 contains 1 shift/reduce conflicts.
+
+        tup_exprs -> commas . tup_tail                      (rule 505)
+        sysdcon_nolist -> '(#' commas . '#)'                (rule 618)
+        commas -> commas . ','                              (rule 734)
+
+    Conflict: '#)' (empty tup_tail reduces)
+
+Same as State 324 for unboxed tuples.
+
+-------------------------------------------------------------------------------
+
+state 460 contains 1 shift/reduce conflict.
+
+        oqtycon -> '(' qtyconsym . ')'                      (rule 621)
+    *** qtyconop -> qtyconsym .                             (rule 628)
+
+    Conflict: ')'
+
+TODO: Why?
+
+-------------------------------------------------------------------------------
+
+state 635 contains 1 shift/reduce conflicts.
+
+    *** aexp2 -> ipvar .                                    (rule 466)
+        dbind -> ipvar . '=' exp                            (rule 590)
+
+    Conflict: '='
+
+Example ambiguity: 'let ?x ...'
+
+The parser can't tell whether the ?x is the lhs of a normal binding or
+an implicit binding.  Fortunately, resolving as shift gives it the only
+sensible meaning, namely the lhs of an implicit binding.
+
+-------------------------------------------------------------------------------
+
+state 702 contains 1 shift/reduce conflicts.
+
+        rule -> STRING rule_activation . rule_forall infixexp '=' exp    (rule 215)
+
+    Conflict: 'forall' (empty rule_forall reduces)
+
+Example ambiguity: '{-# RULES "name" forall = ... #-}'
+
+'forall' is a valid variable name---we don't know whether
+to treat a forall on the input as the beginning of a quantifier
+or the beginning of the rule itself.  Resolving to shift means
+it's always treated as a quantifier, hence the above is disallowed.
+This saves explicitly defining a grammar for the rule lhs that
+doesn't include 'forall'.
+
+-------------------------------------------------------------------------------
+
+state 930 contains 1 shift/reduce conflicts.
+
+        transformqual -> 'then' 'group' . 'using' exp       (rule 528)
+        transformqual -> 'then' 'group' . 'by' exp 'using' exp    (rule 529)
+    *** special_id -> 'group' .                             (rule 711)
+
+    Conflict: 'by'
+
+-------------------------------------------------------------------------------
+
+state 1270 contains 1 shift/reduce conflict.
+
+    *** atype -> tyvar .                                    (rule 314)
+        tv_bndr -> '(' tyvar . '::' kind ')'                (rule 346)
+
+    Conflict: '::'
+
+TODO: Why?
+
+-------------------------------------------------------------------------------
+-- API Annotations
+--
+
+A lot of the productions are now cluttered with calls to
+aa,am,ams,amms etc.
+
+These are helper functions to make sure that the locations of the
+various keywords such as do / let / in are captured for use by tools
+that want to do source to source conversions, such as refactorers or
+structured editors.
+
+The helper functions are defined at the bottom of this file.
+
+See
+  https://ghc.haskell.org/trac/ghc/wiki/ApiAnnotations and
+  https://ghc.haskell.org/trac/ghc/wiki/GhcAstAnnotations
+for some background.
+
+If you modify the parser and want to ensure that the API annotations are processed
+correctly, see the README in (REPO)/utils/check-api-annotations for details on
+how to set up a test using the check-api-annotations utility, and interpret the
+output it generates.
 
 -- -----------------------------------------------------------------------------
 
@@ -263,7 +346,7 @@ incorrect.
  'type'         { L _ ITtype }
  'where'        { L _ ITwhere }
 
- 'forall'       { L _ ITforall }                -- GHC extension keywords
+ 'forall'       { L _ (ITforall _) }                -- GHC extension keywords
  'foreign'      { L _ ITforeign }
  'export'       { L _ ITexport }
  'label'        { L _ ITlabel }
@@ -285,51 +368,51 @@ incorrect.
  'by'       { L _ ITby }        -- for list transform extension
  'using'    { L _ ITusing }     -- for list transform extension
  'pattern'      { L _ ITpattern } -- for pattern synonyms
-
- '{-# 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 }
+ '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 }
 
  '..'           { L _ ITdotdot }                        -- reserved symbols
  ':'            { L _ ITcolon }
- '::'           { L _ ITdcolon }
+ '::'           { L _ (ITdcolon _) }
  '='            { L _ ITequal }
  '\\'           { L _ ITlam }
  'lcase'        { L _ ITlcase }
  '|'            { L _ ITvbar }
- '<-'           { L _ ITlarrow }
- '->'           { L _ ITrarrow }
+ '<-'           { L _ (ITlarrow _) }
+ '->'           { L _ (ITrarrow _) }
  '@'            { L _ ITat }
  '~'            { L _ ITtilde }
  '~#'           { L _ ITtildehsh }
- '=>'           { L _ ITdarrow }
+ '=>'           { L _ (ITdarrow _) }
  '-'            { L _ ITminus }
  '!'            { L _ ITbang }
- '*'            { L _ ITstar }
- '-<'           { L _ ITlarrowtail }            -- for arrow notation
- '>-'           { L _ ITrarrowtail }            -- for arrow notation
- '-<<'          { L _ ITLarrowtail }            -- for arrow notation
- '>>-'          { L _ ITRarrowtail }            -- for arrow notation
+ '-<'           { L _ (ITlarrowtail _) }            -- for arrow notation
+ '>-'           { L _ (ITrarrowtail _) }            -- for arrow notation
+ '-<<'          { L _ (ITLarrowtail _) }            -- for arrow notation
+ '>>-'          { L _ (ITRarrowtail _) }            -- for arrow notation
  '.'            { L _ ITdot }
 
  '{'            { L _ ITocurly }                        -- special symbols
@@ -359,20 +442,19 @@ incorrect.
  QCONID         { L _ (ITqconid   _) }
  QVARSYM        { L _ (ITqvarsym  _) }
  QCONSYM        { L _ (ITqconsym  _) }
- PREFIXQVARSYM  { L _ (ITprefixqvarsym  _) }
- PREFIXQCONSYM  { L _ (ITprefixqconsym  _) }
 
  IPDUPVARID     { L _ (ITdupipvarid   _) }              -- GHC extension
+ LABELVARID     { L _ (ITlabelvarid   _) }
 
- CHAR           { L _ (ITchar     _) }
- STRING         { L _ (ITstring   _) }
- INTEGER        { L _ (ITinteger  _) }
+ CHAR           { L _ (ITchar   _ _) }
+ STRING         { L _ (ITstring _ _) }
+ INTEGER        { L _ (ITinteger _ _) }
  RATIONAL       { L _ (ITrational _) }
 
- PRIMCHAR       { L _ (ITprimchar   _) }
- PRIMSTRING     { L _ (ITprimstring _) }
- PRIMINTEGER    { L _ (ITprimint    _) }
- PRIMWORD       { L _ (ITprimword  _) }
+ PRIMCHAR       { L _ (ITprimchar   _ _) }
+ PRIMSTRING     { L _ (ITprimstring _ _) }
+ PRIMINTEGER    { L _ (ITprimint    _ _) }
+ PRIMWORD       { L _ (ITprimword   _ _) }
  PRIMFLOAT      { L _ (ITprimfloat  _) }
  PRIMDOUBLE     { L _ (ITprimdouble _) }
 
@@ -382,12 +464,12 @@ incorrect.
  DOCSECTION     { L _ (ITdocSection _ _) }
 
 -- Template Haskell
-'[|'            { L _ ITopenExpQuote  }
+'[|'            { L _ (ITopenExpQuote _) }
 '[p|'           { L _ ITopenPatQuote  }
 '[t|'           { L _ ITopenTypQuote  }
 '[d|'           { L _ ITopenDecQuote  }
 '|]'            { L _ ITcloseQuote    }
-'[||'           { L _ ITopenTExpQuote   }
+'[||'           { L _ (ITopenTExpQuote _) }
 '||]'           { L _ ITcloseTExpQuote  }
 TH_ID_SPLICE    { L _ (ITidEscape _)  }     -- $x
 '$('            { L _ ITparenEscape   }     -- $( exp )
@@ -398,7 +480,7 @@ TH_QUASIQUOTE   { L _ (ITquasiQuote _) }
 TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }
 
 %monad { P } { >>= } { return }
-%lexer { lexer } { L _ ITeof }
+%lexer { (lexer True) } { L _ ITeof }
 %tokentype { (Located Token) }
 
 -- Exported parsers
@@ -407,8 +489,8 @@ TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }
 %name parseStatement stmt
 %name parseDeclaration topdecl
 %name parseExpression exp
+%name parsePattern pat
 %name parseTypeSignature sigdecl
-%name parseFullStmt   stmt
 %name parseStmt   maybe_stmt
 %name parseIdentifier  identifier
 %name parseType ctype
@@ -422,7 +504,8 @@ identifier :: { Located RdrName }
         | qcon                          { $1 }
         | qvarop                        { $1 }
         | qconop                        { $1 }
-    | '(' '->' ')'      { sLL $1 $> $ getRdrName funTyCon }
+    | '(' '->' ')'      {% ams (sLL $1 $> $ getRdrName funTyCon)
+                               [mj AnnOpenP $1,mu AnnRarrow $2,mj AnnCloseP $3] }
 
 -----------------------------------------------------------------------------
 -- Module Header
@@ -434,16 +517,18 @@ identifier :: { Located RdrName }
 -- either, and DEPRECATED is only expected to be used by people who really
 -- know what they are doing. :-)
 
-module  :: { Located (HsModule RdrName) }
-        : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
-                {% fileSrcSpan >>= \ loc ->
-                   return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4 $1
-                          ) )}
+module :: { Located (HsModule RdrName) }
+       : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
+             {% fileSrcSpan >>= \ loc ->
+                ams (L loc (HsModule (Just $3) $5 (fst $ snd $7)
+                              (snd $ snd $7) $4 $1)
+                    )
+                    ([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) }
         | body2
                 {% fileSrcSpan >>= \ loc ->
-                   return (L loc (HsModule Nothing Nothing
-                          (fst $1) (snd $1) Nothing Nothing
-                          )) }
+                   ams (L loc (HsModule Nothing Nothing
+                               (fst $ snd $1) (snd $ snd $1) Nothing Nothing))
+                       (fst $1) }
 
 maybedocheader :: { Maybe LHsDocString }
         : moduleheader            { $1 }
@@ -452,23 +537,40 @@ maybedocheader :: { Maybe LHsDocString }
 missing_module_keyword :: { () }
         : {- empty -}                           {% pushCurrentContext }
 
-maybemodwarning :: { Maybe WarningTxt }
-    : '{-# DEPRECATED' strings '#-}' { Just (DeprecatedTxt $ unLoc $2) }
-    | '{-# WARNING' strings '#-}'    { Just (WarningTxt $ unLoc $2) }
+maybemodwarning :: { Maybe (Located WarningTxt) }
+    : '{-# DEPRECATED' strings '#-}'
+                      {% 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 (sL1 $1 (getWARNING_PRAGs $1)) (snd $ unLoc $2)))
+                                (mo $1:mc $3 : (fst $ unLoc $2)) }
     |  {- empty -}                  { Nothing }
 
-body    :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
-        :  '{'            top '}'               { $2 }
-        |      vocurly    top close             { $2 }
-
-body2   :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
-        :  '{' top '}'                          { $2 }
-        |  missing_module_keyword top close     { $2 }
-
-top     :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
-        : importdecls                           { (reverse $1,[]) }
-        | importdecls ';' cvtopdecls            { (reverse $1,$3) }
-        | cvtopdecls                            { ([],$1) }
+body    :: { ([AddAnn]
+             ,([LImportDecl RdrName], [LHsDecl RdrName])) }
+        :  '{'            top '}'      { (moc $1:mcc $3:(fst $2)
+                                         , snd $2) }
+        |      vocurly    top close    { (fst $2, snd $2) }
+
+body2   :: { ([AddAnn]
+             ,([LImportDecl RdrName], [LHsDecl RdrName])) }
+        :  '{' top '}'                          { (moc $1:mcc $3
+                                                   :(fst $2), snd $2) }
+        |  missing_module_keyword top close     { ([],snd $2) }
+
+top     :: { ([AddAnn]
+             ,([LImportDecl RdrName], [LHsDecl RdrName])) }
+        : 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] }
         : topdecls                              { cvTopDecls $1 }
@@ -479,36 +581,41 @@ cvtopdecls :: { [LHsDecl RdrName] }
 header  :: { Located (HsModule RdrName) }
         : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body
                 {% fileSrcSpan >>= \ loc ->
-                   return (L loc (HsModule (Just $3) $5 $7 [] $4 $1
-                          ))}
+                   ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1
+                          )) [mj AnnModule $2,mj AnnWhere $6] }
         | header_body2
                 {% fileSrcSpan >>= \ loc ->
                    return (L loc (HsModule Nothing Nothing $1 [] Nothing
                           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 [LIE RdrName] }
-        :  '(' exportlist ')'                   { Just (fromOL $2) }
-        |  {- empty -}                          { Nothing }
+maybeexports :: { (Maybe (Located [LIE RdrName])) }
+        :  '(' exportlist ')'       {% ams (sLL $1 $> ()) [mop $1,mcp $3] >>
+                                       return (Just (sLL $1 $> (fromOL $2))) }
+        |  {- empty -}              { Nothing }
 
 exportlist :: { OrdList (LIE RdrName) }
-        : expdoclist ',' expdoclist             { $1 `appOL` $3 }
-        | exportlist1                           { $1 }
+        : expdoclist ',' expdoclist   {% addAnnotation (oll $1) AnnComma (gl $2)
+                                         >> return ($1 `appOL` $3) }
+        | exportlist1                 { $1 }
 
 exportlist1 :: { OrdList (LIE RdrName) }
-        : expdoclist export expdoclist ',' exportlist1 { $1 `appOL` $2 `appOL` $3 `appOL` $5 }
-        | expdoclist export expdoclist                 { $1 `appOL` $2 `appOL` $3 }
-        | expdoclist                                   { $1 }
+        : expdoclist export expdoclist ',' exportlist1
+                          {% (addAnnotation (oll ($1 `appOL` $2 `appOL` $3))
+                                            AnnComma (gl $4) ) >>
+                              return ($1 `appOL` $2 `appOL` $3 `appOL` $5) }
+        | expdoclist export expdoclist             { $1 `appOL` $2 `appOL` $3 }
+        | expdoclist                               { $1 }
 
 expdoclist :: { OrdList (LIE RdrName) }
         : exp_doc expdoclist                           { $1 `appOL` $2 }
@@ -523,30 +630,50 @@ exp_doc :: { OrdList (LIE RdrName) }
    -- No longer allow things like [] and (,,,) to be exported
    -- They are built in syntax, always available
 export  :: { OrdList (LIE RdrName) }
-        : qcname_ext export_subspec     { unitOL (sLL $1 $> (mkModuleImpExp (unLoc $1)
-                                                                     (unLoc $2))) }
-        |  'module' modid               { unitOL (sLL $1 $> (IEModuleContents (unLoc $2))) }
-        |  'pattern' qcon               { unitOL (sLL $1 $> (IEVar (unLoc $2))) }
-
-export_subspec :: { Located ImpExpSubSpec }
-        : {- empty -}                   { sL0 ImpExpAbs }
-        | '(' '..' ')'                  { sLL $1 $> ImpExpAll }
-        | '(' ')'                       { sLL $1 $> (ImpExpList []) }
-        | '(' qcnames ')'               { sLL $1 $> (ImpExpList (reverse $2)) }
-
-qcnames :: { [RdrName] }     -- A reversed list
-        :  qcnames ',' qcname_ext       { unLoc $3 : $1 }
-        |  qcname_ext                   { [unLoc $1]  }
-
-qcname_ext :: { Located RdrName }       -- Variable or data constructor
-                                        -- or tagged type constructor
-        :  qcname                       { $1 }
-        |  'type' qcname                {% mkTypeImpExp (sLL $1 $> (unLoc $2)) }
-
--- Cannot pull into qcname_ext, as qcname is also used in expression.
-qcname  :: { Located RdrName }  -- Variable or data constructor
-        :  qvar                         { $1 }
-        |  qcon                         { $1 }
+        : qcname_ext export_subspec  {% mkModuleImpExp $1 (snd $ unLoc $2)
+                                          >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) }
+        |  'module' modid            {% amsu (sLL $1 $> (IEModuleContents $2))
+                                             [mj AnnModule $1] }
+        |  'pattern' qcon            {% amsu (sLL $1 $> (IEVar $2))
+                                             [mj AnnPattern $1] }
+
+export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }
+        : {- empty -}             { sL0 ([],ImpExpAbs) }
+        | '(' qcnames ')'         {% mkImpExpSubSpec (reverse (snd $2))
+                                      >>= \(as,ie) -> return $ sLL $1 $>
+                                            (as ++ [mop $1,mcp $3] ++ fst $2, ie) }
+
+
+qcnames :: { ([AddAnn], [Located (Maybe RdrName)]) }
+  : {- empty -}                   { ([],[]) }
+  | qcnames1                      { $1 }
+
+qcnames1 :: { ([AddAnn], [Located (Maybe RdrName)]) }     -- A reversed list
+        :  qcnames1 ',' qcname_ext_w_wildcard  {% case (last (snd $1)) of
+                                                    l@(L _ Nothing) ->
+                                                      return ([mj AnnComma $2, mj AnnDotdot l]
+                                                              ,($3  : snd $1))
+                                                    l -> (aa l (AnnComma, $2) >>
+                                                          return (fst $1, $3 : snd $1)) }
+
+
+        -- Annotations readded in mkImpExpSubSpec
+        |  qcname_ext_w_wildcard                   { ([],[$1])  }
+
+-- Variable, data constructor or wildcard
+-- or tagged type constructor
+qcname_ext_w_wildcard :: { Located (Maybe RdrName) }
+        :  qcname_ext               { Just `fmap` $1 }
+        |  '..'                     { Nothing <$ $1 }
+
+qcname_ext :: { Located RdrName }
+        :  qcname                   { $1 }
+        |  'type' oqtycon           {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2)))
+                                            [mj AnnType $1,mj AnnVal $2] }
+
+qcname  :: { Located RdrName }  -- Variable or type constructor
+        :  qvar                 { $1 }
+        |  oqtycon_no_varcon    { $1 } -- see Note [Type constructors in export list]
 
 -----------------------------------------------------------------------------
 -- Import Declarations
@@ -554,111 +681,165 @@ 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            { $3 : $1 }
-        | importdecls ';'                       { $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
-                { L (comb4 $1 $6 $7 $8) $
-                  ImportDecl { ideclName = $6, ideclPkgQual = $5
-                             , ideclSource = $2, ideclSafe = $3
-                             , ideclQualified = $4, ideclImplicit = False
-                             , ideclAs = unLoc $7, ideclHiding = unLoc $8 } }
-
-maybe_src :: { IsBootInterface }
-        : '{-# SOURCE' '#-}'                    { True }
-        | {- empty -}                           { False }
-
-maybe_safe :: { Bool }
-        : 'safe'                                { True }
-        | {- empty -}                           { False }
-
-maybe_pkg :: { Maybe FastString }
-        : STRING                                { Just (getSTRING $1) }
-        | {- empty -}                           { Nothing }
-
-optqualified :: { Bool }
-        : 'qualified'                           { True  }
-        | {- empty -}                           { False }
-
-maybeas :: { Located (Maybe ModuleName) }
-        : 'as' modid                            { sLL $1 $> (Just (unLoc $2)) }
-        | {- empty -}                           { noLoc Nothing }
-
-maybeimpspec :: { Located (Maybe (Bool, [LIE RdrName])) }
-        : impspec                               { sL1 $1 (Just (unLoc $1)) }
-        | {- empty -}                           { noLoc Nothing }
-
-impspec :: { Located (Bool, [LIE RdrName]) }
-        :  '(' exportlist ')'                   { sLL $1 $> (False, fromOL $2) }
-        |  'hiding' '(' exportlist ')'          { sLL $1 $> (True,  fromOL $3) }
+                {% ams (L (comb4 $1 $6 (snd $7) $8) $
+                  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 $ fst $2) ++ fst $3 ++ fst $4
+                                    ++ fst $5 ++ fst $7)) }
+
+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) }
+        | {- empty -}                           { ([],False) }
+
+maybe_pkg :: { ([AddAnn],Maybe StringLiteral) }
+        : STRING  {% let pkgFS = getSTRING $1 in
+                     if looksLikePackageName (unpackFS pkgFS)
+                        then return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS))
+                        else parseErrorSDoc (getLoc $1) $ vcat [
+                             text "parse error" <> colon <+> quotes (ppr pkgFS),
+                             text "Version number or non-alphanumeric" <+>
+                             text "character in package name"] }
+        | {- empty -}                           { ([],Nothing) }
+
+optqualified :: { ([AddAnn],Bool) }
+        : 'qualified'                           { ([mj AnnQualified $1],True)  }
+        | {- empty -}                           { ([],False) }
+
+maybeas :: { ([AddAnn],Located (Maybe ModuleName)) }
+        : 'as' modid                           { ([mj AnnAs $1,mj AnnVal $2]
+                                                 ,sLL $1 $> (Just (unLoc $2))) }
+        | {- empty -}                          { ([],noLoc Nothing) }
+
+maybeimpspec :: { Located (Maybe (Bool, Located [LIE RdrName])) }
+        : impspec                  {% let (b, ie) = unLoc $1 in
+                                       checkImportSpec ie
+                                        >>= \checkedIe ->
+                                          return (L (gl $1) (Just (b, checkedIe)))  }
+        | {- empty -}              { noLoc Nothing }
+
+impspec :: { Located (Bool, Located [LIE RdrName]) }
+        :  '(' 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
 
-prec    :: { Int }
-        : {- empty -}           { 9 }
-        | INTEGER               {% checkPrecP (sL1 $1 (fromInteger (getINTEGER $1))) }
+prec    :: { Located Int }
+        : {- empty -}           { noLoc 9 }
+        | INTEGER
+                 {% checkPrecP (sL1 $1 (fromInteger (getINTEGER $1))) }
 
 infix   :: { Located FixityDirection }
         : 'infix'                               { sL1 $1 InfixN  }
         | 'infixl'                              { sL1 $1 InfixL  }
         | 'infixr'                              { sL1 $1 InfixR }
 
-ops     :: { Located [Located RdrName] }
-        : ops ',' op                            { sLL $1 $> ($3 : unLoc $1) }
-        | op                                    { sL1 $1 [$1] }
+ops     :: { Located (OrdList (Located RdrName)) }
+        : 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
 
 topdecls :: { OrdList (LHsDecl RdrName) }
-        : topdecls ';' topdecl                  { $1 `appOL` $3 }
-        | topdecls ';'                          { $1 }
-        | topdecl                               { $1 }
-
-topdecl :: { OrdList (LHsDecl RdrName) }
-        : cl_decl                               { unitOL (sL1 $1 (TyClD (unLoc $1))) }
-        | ty_decl                               { unitOL (sL1 $1 (TyClD (unLoc $1))) }
-        | inst_decl                             { unitOL (sL1 $1 (InstD (unLoc $1))) }
-        | stand_alone_deriving                  { unitOL (sLL $1 $> (DerivD (unLoc $1))) }
-        | role_annot                            { unitOL (sL1 $1 (RoleAnnotD (unLoc $1))) }
-        | 'default' '(' comma_types0 ')'        { unitOL (sLL $1 $> $ DefD (DefaultDecl $3)) }
-        | 'foreign' fdecl                       { unitOL (sLL $1 $> (unLoc $2)) }
-        | '{-# DEPRECATED' deprecations '#-}'   { $2 }
-        | '{-# WARNING' warnings '#-}'          { $2 }
-        | '{-# RULES' rules '#-}'               { $2 }
-        | '{-# VECTORISE' qvar '=' exp '#-}'    { unitOL $ sLL $1 $> $ VectD (HsVect       $2 $4) }
-        | '{-# NOVECTORISE' qvar '#-}'          { unitOL $ sLL $1 $> $ VectD (HsNoVect     $2) }
+        : topdecls ';' topdecl        {% addAnnotation (oll $1) AnnSemi (gl $2)
+                                         >> return ($1 `appOL` unitOL $3) }
+        | topdecls ';'                {% addAnnotation (oll $1) AnnSemi (gl $2)
+                                         >> return $1 }
+        | topdecl                     { unitOL $1 }
+
+topdecl :: { LHsDecl RdrName }
+        : cl_decl                               { sL1 $1 (TyClD (unLoc $1)) }
+        | ty_decl                               { sL1 $1 (TyClD (unLoc $1)) }
+        | inst_decl                             { sL1 $1 (InstD (unLoc $1)) }
+        | stand_alone_deriving                  { sLL $1 $> (DerivD (unLoc $1)) }
+        | role_annot                            { sL1 $1 (RoleAnnotD (unLoc $1)) }
+        | 'default' '(' comma_types0 ')'    {% ams (sLL $1 $> (DefD (DefaultDecl $3)))
+                                                         [mj AnnDefault $1
+                                                         ,mop $2,mcp $4] }
+        | 'foreign' fdecl          {% ams (sLL $1 $> (snd $ unLoc $2))
+                                           (mj AnnForeign $1:(fst $ unLoc $2)) }
+        | '{-# DEPRECATED' deprecations '#-}'   {% ams (sLL $1 $> $ WarningD (Warnings (getDEPRECATED_PRAGs $1) (fromOL $2)))
+                                                       [mo $1,mc $3] }
+        | '{-# WARNING' warnings '#-}'          {% ams (sLL $1 $> $ WarningD (Warnings (getWARNING_PRAGs $1) (fromOL $2)))
+                                                       [mo $1,mc $3] }
+        | '{-# RULES' rules '#-}'               {% ams (sLL $1 $> $ RuleD (HsRules (getRULES_PRAGs $1) (fromOL $2)))
+                                                       [mo $1,mc $3] }
+        | '{-# VECTORISE' qvar '=' exp '#-}' {% ams (sLL $1 $> $ VectD (HsVect (getVECT_PRAGs $1) $2 $4))
+                                                    [mo $1,mj AnnEqual $3
+                                                    ,mc $5] }
+        | '{-# NOVECTORISE' qvar '#-}'       {% ams (sLL $1 $> $ VectD (HsNoVect (getNOVECT_PRAGs $1) $2))
+                                                     [mo $1,mc $3] }
         | '{-# VECTORISE' 'type' gtycon '#-}'
-                                                { unitOL $ sLL $1 $> $
-                                                    VectD (HsVectTypeIn False $3 Nothing) }
+                                {% ams (sLL $1 $> $
+                                    VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 Nothing))
+                                    [mo $1,mj AnnType $2,mc $4] }
+
         | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}'
-                                                { unitOL $ sLL $1 $> $
-                                                    VectD (HsVectTypeIn True $3 Nothing) }
+                                {% ams (sLL $1 $> $
+                                    VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 Nothing))
+                                    [mo $1,mj AnnType $2,mc $4] }
+
         | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}'
-                                                { unitOL $ sLL $1 $> $
-                                                    VectD (HsVectTypeIn False $3 (Just $5)) }
+                                {% ams (sLL $1 $> $
+                                    VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 (Just $5)))
+                                    [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] }
         | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}'
-                                                { unitOL $ sLL $1 $> $
-                                                    VectD (HsVectTypeIn True $3 (Just $5)) }
-        | '{-# VECTORISE' 'class' gtycon '#-}'  { unitOL $ sLL $1 $> $ VectD (HsVectClassIn $3) }
-        | annotation { unitOL $1 }
-        | decl_no_th                            { unLoc $1 }
+                                {% ams (sLL $1 $> $
+                                    VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 (Just $5)))
+                                    [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] }
+
+        | '{-# VECTORISE' 'class' gtycon '#-}'
+                                         {% ams (sLL $1 $>  $ VectD (HsVectClassIn (getVECT_PRAGs $1) $3))
+                                                 [mo $1,mj AnnClass $2,mc $4] }
+        | annotation { $1 }
+        | decl_no_th                            { $1 }
 
         -- Template Haskell Extension
         -- The $(..) form is one possible form of infixexp
         -- but we treat an arbitrary expression just as if
         -- it had a $(..) wrapped around it
-        | infixexp                              { unitOL (sLL $1 $> $ mkSpliceDecl $1) }
+        | infixexp                              { sLL $1 $> $ mkSpliceDecl $1 }
 
 -- Type classes
 --
 cl_decl :: { LTyClDecl RdrName }
-        : 'class' tycl_hdr fds where_cls        {% mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 $4 }
+        : 'class' tycl_hdr fds where_cls
+                {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (snd $ unLoc $4))
+                        (mj AnnClass $1:(fst $ unLoc $3)++(fst $ unLoc $4)) }
 
 -- Type declarations (toplevel)
 --
@@ -672,91 +853,140 @@ ty_decl :: { LTyClDecl RdrName }
                 --
                 -- Note the use of type for the head; this allows
                 -- infix type constructors to be declared
-                {% mkTySynonym (comb2 $1 $4) $2 $4 }
+                {% amms (mkTySynonym (comb2 $1 $4) $2 $4)
+                        [mj AnnType $1,mj AnnEqual $3] }
 
            -- type family declarations
-        | 'type' 'family' type opt_kind_sig where_type_family
+        | 'type' 'family' type opt_tyfam_kind_sig opt_injective_info
+                          where_type_family
                 -- Note the use of type for the head; this allows
                 -- infix type constructors to be declared
-                {% mkFamDecl (comb4 $1 $3 $4 $5) (unLoc $5) $3 (unLoc $4) }
+                {% amms (mkFamDecl (comb4 $1 $3 $4 $5) (snd $ unLoc $6) $3
+                                   (snd $ unLoc $4) (snd $ unLoc $5))
+                        (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)
+                           ++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) }
 
           -- ordinary data type or newtype declaration
         | data_or_newtype capi_ctype tycl_hdr constrs deriving
-                {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3
-                            Nothing (reverse (unLoc $4)) (unLoc $5) }
+                {% amms (mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3
+                           Nothing (reverse (snd $ unLoc $4))
+                                   (unLoc $5))
                                    -- We need the location on tycl_hdr in case
                                    -- constrs and deriving are both empty
+                        ((fst $ unLoc $1):(fst $ unLoc $4)) }
 
           -- ordinary GADT declaration
         | data_or_newtype capi_ctype tycl_hdr opt_kind_sig
                  gadt_constrlist
                  deriving
-                {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3
-                            (unLoc $4) (unLoc $5) (unLoc $6) }
+            {% amms (mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3
+                            (snd $ unLoc $4) (snd $ unLoc $5) (unLoc $6) )
                                    -- We need the location on tycl_hdr in case
                                    -- constrs and deriving are both empty
+                    ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }
 
           -- data/newtype family
-        | 'data' 'family' type opt_kind_sig
-                {% mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) }
+        | 'data' 'family' type opt_datafam_kind_sig
+                {% amms (mkFamDecl (comb3 $1 $2 $4) DataFamily $3
+                                   (snd $ unLoc $4) Nothing)
+                        (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) }
 
 inst_decl :: { LInstDecl RdrName }
         : 'instance' overlap_pragma inst_type where_inst
-                 { let (binds, sigs, _, ats, adts, _) = cvBindsAndSigs (unLoc $4) in
-                   let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds
-                                         , cid_sigs = sigs, cid_tyfam_insts = ats
-                                         , cid_overlap_mode = $2
-                                         , cid_datafam_insts = adts }
-                   in L (comb3 $1 $3 $4) (ClsInstD { cid_inst = cid }) }
+       {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4)
+             ; let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds
+                                     , cid_sigs = mkClassOpSigs sigs
+                                     , cid_tyfam_insts = ats
+                                     , cid_overlap_mode = $2
+                                     , cid_datafam_insts = adts }
+             ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_inst = cid }))
+                   (mj AnnInstance $1 : (fst $ unLoc $4)) } }
 
            -- type instance declarations
         | 'type' 'instance' ty_fam_inst_eqn
-                {% mkTyFamInst (comb2 $1 $3) $3 }
+                {% ams $3 (fst $ unLoc $3)
+                >> amms (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3))
+                    (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) }
 
           -- data/newtype instance declaration
         | data_or_newtype 'instance' capi_ctype tycl_hdr constrs deriving
-                {% mkDataFamInst (comb4 $1 $4 $5 $6) (unLoc $1) $3 $4
-                                      Nothing (reverse (unLoc $5)) (unLoc $6) }
+            {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 $4
+                                      Nothing (reverse (snd  $ unLoc $5))
+                                              (unLoc $6))
+                    ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }
 
           -- GADT instance declaration
         | data_or_newtype 'instance' capi_ctype tycl_hdr opt_kind_sig
                  gadt_constrlist
                  deriving
-                {% mkDataFamInst (comb4 $1 $4 $6 $7) (unLoc $1) $3 $4
-                                     (unLoc $5) (unLoc $6) (unLoc $7) }
-
-overlap_pragma :: { Maybe OverlapMode }
-  : '{-# OVERLAPPABLE'    '#-}' { Just Overlappable }
-  | '{-# OVERLAPPING'     '#-}' { Just Overlapping }
-  | '{-# OVERLAPS'        '#-}' { Just Overlaps }
-  | '{-# INCOHERENT'      '#-}' { Just Incoherent }
+            {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 $4
+                                   (snd $ unLoc $5) (snd $ unLoc $6) (unLoc $7))
+                    ((fst $ unLoc $1):mj AnnInstance $2
+                       :(fst $ unLoc $5)++(fst $ unLoc $6)) }
+
+overlap_pragma :: { Maybe (Located OverlapMode) }
+  : '{-# OVERLAPPABLE'    '#-}' {% ajs (Just (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1))))
+                                       [mo $1,mc $2] }
+  | '{-# OVERLAPPING'     '#-}' {% ajs (Just (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1))))
+                                       [mo $1,mc $2] }
+  | '{-# OVERLAPS'        '#-}' {% ajs (Just (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1))))
+                                       [mo $1,mc $2] }
+  | '{-# INCOHERENT'      '#-}' {% ajs (Just (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1))))
+                                       [mo $1,mc $2] }
   | {- empty -}                 { Nothing }
 
 
+-- Injective type families
+
+opt_injective_info :: { Located ([AddAnn], Maybe (LInjectivityAnn RdrName)) }
+        : {- empty -}               { noLoc ([], Nothing) }
+        | '|' injectivity_cond      { sLL $1 $> ( mj AnnVbar $1 : fst (unLoc $2)
+                                                , Just (snd (unLoc $2))) }
+
+injectivity_cond :: { Located ([AddAnn], LInjectivityAnn RdrName) }
+        : tyvarid '->' inj_varids
+           { sLL $1 $> ( [mu AnnRarrow $2]
+                       , (sLL $1 $> (InjectivityAnn $1 (reverse (unLoc $3))))) }
+
+inj_varids :: { Located [Located RdrName] }
+        : inj_varids tyvarid  { sLL $1 $> ($2 : unLoc $1) }
+        | tyvarid             { sLL $1 $> [$1]            }
+
 -- Closed type families
 
-where_type_family :: { Located (FamilyInfo RdrName) }
-        : {- empty -}                      { noLoc OpenTypeFamily }
+where_type_family :: { Located ([AddAnn],FamilyInfo RdrName) }
+        : {- empty -}                      { noLoc ([],OpenTypeFamily) }
         | 'where' ty_fam_inst_eqn_list
-               { sLL $1 $> (ClosedTypeFamily (reverse (unLoc $2))) }
-
-ty_fam_inst_eqn_list :: { Located [LTyFamInstEqn RdrName] }
-        :     '{' ty_fam_inst_eqns '}'     { sLL $1 $> (unLoc $2) }
-        | vocurly ty_fam_inst_eqns close   { $2 }
-        |     '{' '..' '}'                 { sLL $1 $> [] }
-        | vocurly '..' close               { let L loc _ = $2 in L loc [] }
+               { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)
+                    ,ClosedTypeFamily (fmap reverse $ snd $ unLoc $2)) }
+
+ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn RdrName]) }
+        :     '{' ty_fam_inst_eqns '}'     { sLL $1 $> ([moc $1,mcc $3]
+                                                ,Just (unLoc $2)) }
+        | vocurly ty_fam_inst_eqns close   { let L loc _ = $2 in
+                                             L loc ([],Just (unLoc $2)) }
+        |     '{' '..' '}'                 { sLL $1 $> ([moc $1,mj AnnDotdot $2
+                                                 ,mcc $3],Nothing) }
+        | vocurly '..' close               { let L loc _ = $2 in
+                                             L loc ([mj AnnDotdot $2],Nothing) }
 
 ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] }
-        : ty_fam_inst_eqns ';' ty_fam_inst_eqn   { sLL $1 $> ($3 : unLoc $1) }
-        | ty_fam_inst_eqns ';'                   { sLL $1 $> (unLoc $1) }
-        | ty_fam_inst_eqn                        { sLL $1 $> [$1] }
-
-ty_fam_inst_eqn :: { LTyFamInstEqn RdrName }
+        : ty_fam_inst_eqns ';' ty_fam_inst_eqn
+                                      {% asl (unLoc $1) $2 (snd $ unLoc $3)
+                                         >> ams $3 (fst $ unLoc $3)
+                                         >> return (sLL $1 $> ((snd $ unLoc $3) : unLoc $1)) }
+        | ty_fam_inst_eqns ';'        {% addAnnotation (gl $1) AnnSemi (gl $2)
+                                         >> return (sLL $1 $>  (unLoc $1)) }
+        | ty_fam_inst_eqn             {% ams $1 (fst $ unLoc $1)
+                                         >> return (sLL $1 $> [snd $ unLoc $1]) }
+        | {- empty -}                 { noLoc [] }
+
+ty_fam_inst_eqn :: { Located ([AddAnn],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
-                    ; return (sLL $1 $> eqn) } }
+              {% do { (eqn,ann) <- mkTyFamInstEqn $1 $3
+                    ; return (sLL $1 $> (mj AnnEqual $2:ann, sLL $1 $> eqn))  } }
 
 -- Associated type family declarations
 --
@@ -769,25 +999,39 @@ ty_fam_inst_eqn :: { LTyFamInstEqn RdrName }
 --
 at_decl_cls :: { LHsDecl RdrName }
         :  -- data family declarations, with optional 'family' keyword
-          'data' opt_family type opt_kind_sig
-                {% liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3 (unLoc $4)) }
+          'data' opt_family type opt_datafam_kind_sig
+                {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3
+                                                  (snd $ unLoc $4) Nothing))
+                        (mj AnnData $1:$2++(fst $ unLoc $4)) }
 
            -- type family declarations, with optional 'family' keyword
            -- (can't use opt_instance because you get shift/reduce errors
-        | 'type' type opt_kind_sig
-                {% liftM mkTyClD (mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily $2 (unLoc $3)) }
-        | 'type' 'family' type opt_kind_sig
-                {% liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) OpenTypeFamily $3 (unLoc $4)) }
+        | 'type' type opt_at_kind_inj_sig
+               {% amms (liftM mkTyClD
+                        (mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily $2
+                                   (fst . snd $ unLoc $3)
+                                   (snd . snd $ unLoc $3)))
+                       (mj AnnType $1:(fst $ unLoc $3)) }
+        | 'type' 'family' type opt_at_kind_inj_sig
+               {% amms (liftM mkTyClD
+                        (mkFamDecl (comb3 $1 $3 $4) OpenTypeFamily $3
+                                   (fst . snd $ unLoc $4)
+                                   (snd . snd $ unLoc $4)))
+                       (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)) }
 
            -- default type instances, with optional 'instance' keyword
         | 'type' ty_fam_inst_eqn
-                {% liftM mkInstD (mkTyFamInst (comb2 $1 $2) $2) }
+                {% ams $2 (fst $ unLoc $2) >>
+                   amms (liftM mkInstD (mkTyFamInst (comb2 $1 $2) (snd $ unLoc $2)))
+                        (mj AnnType $1:(fst $ unLoc $2)) }
         | 'type' 'instance' ty_fam_inst_eqn
-                {% liftM mkInstD (mkTyFamInst (comb2 $1 $3) $3) }
+                {% ams $3 (fst $ unLoc $3) >>
+                   amms (liftM mkInstD (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3)))
+                        (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) }
 
-opt_family   :: { () }
-              : {- empty -}   { () }
-              | 'family'      { () }
+opt_family   :: { [AddAnn] }
+              : {- empty -}   { [] }
+              | 'family'      { [mj AnnFamily $1] }
 
 -- Associated type instances
 --
@@ -796,27 +1040,52 @@ at_decl_inst :: { LInstDecl RdrName }
         : 'type' ty_fam_inst_eqn
                 -- Note the use of type for the head; this allows
                 -- infix type constructors and type patterns
-                {% mkTyFamInst (comb2 $1 $2) $2 }
+                {% ams $2 (fst $ unLoc $2) >>
+                   amms (mkTyFamInst (comb2 $1 $2) (snd $ unLoc $2))
+                        (mj AnnType $1:(fst $ unLoc $2)) }
 
         -- data/newtype instance declaration
         | data_or_newtype capi_ctype tycl_hdr constrs deriving
-                {% mkDataFamInst (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3
-                                 Nothing (reverse (unLoc $4)) (unLoc $5) }
+               {% amms (mkDataFamInst (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3
+                                    Nothing (reverse (snd $ unLoc $4))
+                                            (unLoc $5))
+                       ((fst $ unLoc $1):(fst $ unLoc $4)) }
 
         -- GADT instance declaration
         | data_or_newtype capi_ctype tycl_hdr opt_kind_sig
                  gadt_constrlist
                  deriving
-                {% mkDataFamInst (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3
-                                 (unLoc $4) (unLoc $5) (unLoc $6) }
-
-data_or_newtype :: { Located NewOrData }
-        : 'data'        { sL1 $1 DataType }
-        | 'newtype'     { sL1 $1 NewType }
-
-opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) }
-        :                               { noLoc Nothing }
-        | '::' kind                     { sLL $1 $> (Just $2) }
+                {% amms (mkDataFamInst (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2
+                                $3 (snd $ unLoc $4) (snd $ unLoc $5) (unLoc $6))
+                        ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }
+
+data_or_newtype :: { Located (AddAnn, NewOrData) }
+        : 'data'        { sL1 $1 (mj AnnData    $1,DataType) }
+        | 'newtype'     { sL1 $1 (mj AnnNewtype $1,NewType) }
+
+-- Family result/return kind signatures
+
+opt_kind_sig :: { Located ([AddAnn], Maybe (LHsKind RdrName)) }
+        :               { noLoc     ([]               , Nothing) }
+        | '::' kind     { sLL $1 $> ([mu AnnDcolon $1], Just $2) }
+
+opt_datafam_kind_sig :: { Located ([AddAnn], LFamilyResultSig RdrName) }
+        :               { noLoc     ([]               , noLoc NoSig           )}
+        | '::' kind     { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig $2))}
+
+opt_tyfam_kind_sig :: { Located ([AddAnn], LFamilyResultSig RdrName) }
+        :              { noLoc     ([]               , noLoc      NoSig       )}
+        | '::' kind    { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig  $2))}
+        | '='  tv_bndr { sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig $2))}
+
+opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig RdrName
+                                            , Maybe (LInjectivityAnn RdrName)))}
+        :            { noLoc ([], (noLoc NoSig, Nothing)) }
+        | '::' kind  { sLL $1 $> ( [mu AnnDcolon $1]
+                                 , (sLL $2 $> (KindSig $2), Nothing)) }
+        | '='  tv_bndr '|' injectivity_cond
+                { sLL $1 $> ( mj AnnEqual $1 : mj AnnVbar $3 : fst (unLoc $4)
+                            , (sLL $1 $2 (TyVarSig $2), Just (snd (unLoc $4))))}
 
 -- tycl_hdr parses the header of a class or data type decl,
 -- which takes the form
@@ -826,27 +1095,41 @@ 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             { sLL $1 $> (Just $1, $3) }
-        | type                          { sL1 $1 (Nothing, $1) }
+        : context '=>' type         {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (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 (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))
+                                        (getSTRINGs $3,getSTRING $3))))
+                              [mo $1,mj AnnHeader $2,mj AnnVal $3,mc $4] }
+
+           | '{-# CTYPE'        STRING '#-}'
+                       {% ajs (Just (sLL $1 $> (CType (getCTYPEs $1) Nothing  (getSTRINGs $2, getSTRING $2))))
+                              [mo $1,mj AnnVal $2,mc $3] }
 
-capi_ctype :: { Maybe CType }
-capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTRING $2))) (getSTRING $3)) }
-           | '{-# CTYPE'        STRING '#-}' { Just (CType Nothing                        (getSTRING $2)) }
-           |                                 { Nothing }
+           |           { Nothing }
 
 -----------------------------------------------------------------------------
 -- Stand-alone deriving
 
 -- Glasgow extension: stand-alone deriving declarations
 stand_alone_deriving :: { LDerivDecl RdrName }
-  : 'deriving' 'instance' overlap_pragma inst_type { sLL $1 $> (DerivDecl $4 $3) }
+  : 'deriving' 'instance' overlap_pragma inst_type
+                         {% do { let { err = text "in the stand-alone deriving instance"
+                                             <> colon <+> quotes (ppr $4) }
+                               ; ams (sLL $1 (hsSigType $>) (DerivDecl $4 $3))
+                                     [mj AnnDeriving $1, mj AnnInstance $2] } }
 
 -----------------------------------------------------------------------------
 -- Role annotations
 
 role_annot :: { LRoleAnnotDecl RdrName }
 role_annot : 'type' 'role' oqtycon maybe_roles
-              {% mkRoleAnnotDecl (comb3 $1 $3 $4) $3 (reverse (unLoc $4)) }
+          {% amms (mkRoleAnnotDecl (comb3 $1 $3 $4) $3 (reverse (unLoc $4)))
+                  [mj AnnType $1,mj AnnRole $2] }
 
 -- Reversed!
 maybe_roles :: { Located [Located (Maybe FastString)] }
@@ -867,242 +1150,351 @@ role : VARID             { sL1 $1 $ Just $ getVARID $1 }
 -- Glasgow extension: pattern synonyms
 pattern_synonym_decl :: { LHsDecl RdrName }
         : 'pattern' pattern_synonym_lhs '=' pat
-            { let (name, args) = $2
-              in sLL $1 $> . ValD $ mkPatSynBind name args $4 ImplicitBidirectional }
+         {%      let (name, args,as ) = $2 in
+                 ams (sLL $1 $> . ValD $ mkPatSynBind name args $4
+                                                    ImplicitBidirectional)
+               (as ++ [mj AnnPattern $1, mj AnnEqual $3])
+         }
+
         | 'pattern' pattern_synonym_lhs '<-' pat
-            { let (name, args) = $2
-              in sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional }
-        | 'pattern' pattern_synonym_lhs '<-' pat where_decls
-            {% do { let (name, args) = $2
-                  ; mg <- mkPatSynMatchGroup name $5
-                  ; return $ sLL $1 $> . ValD $
-                    mkPatSynBind name args $4 (ExplicitBidirectional mg) }}
+         {%    let (name, args, as) = $2 in
+               ams (sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional)
+               (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) }
 
-pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName)) }
-        : con vars0 { ($1, PrefixPatSyn $2) }
-        | varid consym varid { ($2, InfixPatSyn $1 $3) }
+        | 'pattern' pattern_synonym_lhs '<-' pat where_decls
+            {% do { let (name, args, as) = $2
+                  ; mg <- mkPatSynMatchGroup name (snd $ unLoc $5)
+                  ; ams (sLL $1 $> . ValD $
+                           mkPatSynBind name args $4 (ExplicitBidirectional mg))
+                       (as ++ ((mj AnnPattern $1:mu AnnLarrow $3:(fst $ unLoc $5))) )
+                   }}
+
+pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn]) }
+        : con vars0 { ($1, PrefixPatSyn $2, []) }
+        | varid conop varid { ($2, InfixPatSyn $1 $3, []) }
+        | con '{' cvars1 '}' { ($1, RecordPatSyn $3, [moc $2, mcc $4] ) }
 
 vars0 :: { [Located RdrName] }
         : {- empty -}                 { [] }
         | varid vars0                 { $1 : $2 }
 
-where_decls :: { Located (OrdList (LHsDecl RdrName)) }
-        : 'where' '{' decls '}'       { $3 }
-        | 'where' vocurly decls close { $3 }
+cvars1 :: { [RecordPatSynField (Located RdrName)] }
+       : varid                        { [RecordPatSynField $1 $1] }
+       | varid ',' cvars1             {% addAnnotation (getLoc $1) AnnComma (getLoc $2) >>
+                                         return ((RecordPatSynField $1 $1) : $3 )}
+
+where_decls :: { Located ([AddAnn]
+                         , Located (OrdList (LHsDecl RdrName))) }
+        : '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
-            { let (flag, qtvs, prov, req, ty) = unLoc $4
-              in sLL $1 $> $ PatSynSig $2 (flag, mkHsQTvs qtvs) prov req ty }
+                   {% ams (sLL $1 $> $ PatSynSig $2 (mkLHsSigType $4))
+                          [mj AnnPattern $1, mu AnnDcolon $3] }
 
-ptype :: { Located (HsExplicitFlag, [LHsTyVarBndr RdrName], LHsContext RdrName, LHsContext RdrName, LHsType RdrName) }
+ptype   :: { LHsType RdrName }
         : 'forall' tv_bndrs '.' ptype
-            {% do { hintExplicitForall (getLoc $1)
-                  ; let (_, qtvs', prov, req, ty) = unLoc $4
-                  ; return $ sLL $1 $> (Explicit, $2 ++ qtvs', prov, req ,ty) }}
+                   {% hintExplicitForall (getLoc $1) >>
+                      ams (sLL $1 $> $
+                           HsForAllTy { hst_bndrs = $2
+                                      , hst_body = $4 })
+                          [mu AnnForall $1, mj AnnDot $3] }
+
         | context '=>' context '=>' type
-            { sLL $1 $> (Implicit, [], $1, $3, $5) }
+                   {% ams (sLL $1 $> $
+                           HsQualTy { hst_ctxt = $1, hst_body = sLL $3 $> $
+                           HsQualTy { hst_ctxt = $3, hst_body = $5 } })
+                           [mu AnnDarrow $2, mu AnnDarrow $4] }
         | context '=>' type
-            { sLL $1 $> (Implicit, [], $1, noLoc [], $3) }
-        | type
-            { sL1 $1 (Implicit, [], noLoc [], noLoc [], $1) }
+                   {% ams (sLL $1 $> $
+                           HsQualTy { hst_ctxt = $1, hst_body = $3 })
+                           [mu AnnDarrow $2] }
+        | type     { $1 }
 
 -----------------------------------------------------------------------------
 -- Nested declarations
 
 -- Declaration in class bodies
 --
-decl_cls  :: { Located (OrdList (LHsDecl RdrName)) }
-decl_cls  : at_decl_cls                 { sLL $1 $> (unitOL $1) }
+decl_cls  :: { LHsDecl RdrName }
+decl_cls  : at_decl_cls                 { $1 }
           | decl                        { $1 }
 
           -- A 'default' signature used with the generic-programming extension
           | 'default' infixexp '::' sigtypedoc
-                    {% do { (TypeSig l ty) <- checkValSig $2 $4
-                          ; return (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (GenericSig l ty))) } }
-
-decls_cls :: { Located (OrdList (LHsDecl RdrName)) }    -- Reversed
-          : decls_cls ';' decl_cls      { sLL $1 $> (unLoc $1 `appOL` unLoc $3) }
-          | decls_cls ';'               { sLL $1 $> (unLoc $1) }
-          | decl_cls                    { $1 }
-          | {- empty -}                 { noLoc nilOL }
-
+                    {% do { v <- checkValSigLhs $2
+                          ; let err = text "in default signature" <> colon <+>
+                                      quotes (ppr $2)
+                          ; ams (sLL $1 $> $ SigD $ ClassOpSig True [v] $ mkLHsSigType $4)
+                                [mj AnnDefault $1,mu AnnDcolon $3] } }
+
+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)
+                                                                    , unitOL $3))
+                                             else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2]
+                                           >> return (sLL $1 $> (fst $ unLoc $1
+                                                                ,(snd $ unLoc $1) `appOL` unitOL $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                    { sL1 $1 ([], unitOL $1) }
+          | {- empty -}                 { noLoc ([],nilOL) }
 
 decllist_cls
-        :: { Located (OrdList (LHsDecl RdrName)) }      -- Reversed
-        : '{'         decls_cls '}'     { sLL $1 $> (unLoc $2) }
+        :: { Located ([AddAnn]
+                     , OrdList (LHsDecl RdrName)) }      -- Reversed
+        : '{'         decls_cls '}'     { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)
+                                             ,snd $ unLoc $2) }
         |     vocurly decls_cls close   { $2 }
 
 -- Class body
 --
-where_cls :: { Located (OrdList (LHsDecl RdrName)) }    -- Reversed
+where_cls :: { Located ([AddAnn]
+                       ,(OrdList (LHsDecl RdrName))) }    -- Reversed
                                 -- No implicit parameters
                                 -- May have type declarations
-        : 'where' decllist_cls          { sLL $1 $> (unLoc $2) }
-        | {- empty -}                   { noLoc nilOL }
+        : 'where' decllist_cls          { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)
+                                             ,snd $ unLoc $2) }
+        | {- empty -}                   { noLoc ([],nilOL) }
 
 -- Declarations in instance bodies
 --
 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   { sLL $1 $> (unLoc $1 `appOL` unLoc $3) }
-           | decls_inst ';'             { sLL $1 $> (unLoc $1) }
-           | decl_inst                  { $1 }
-           | {- empty -}                { noLoc nilOL }
+           | decl                       { sLL $1 $> (unitOL $1) }
+
+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 $> (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                  { sL1 $1 ([],unLoc $1) }
+           | {- empty -}                { noLoc ([],nilOL) }
 
 decllist_inst
-        :: { Located (OrdList (LHsDecl RdrName)) }      -- Reversed
-        : '{'         decls_inst '}'    { sLL $1 $> (unLoc $2) }
-        |     vocurly decls_inst close  { $2 }
+        :: { Located ([AddAnn]
+                     , OrdList (LHsDecl RdrName)) }      -- Reversed
+        : '{'         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
 --
-where_inst :: { Located (OrdList (LHsDecl RdrName)) }   -- Reversed
+where_inst :: { Located ([AddAnn]
+                        , OrdList (LHsDecl RdrName)) }   -- Reversed
                                 -- No implicit parameters
                                 -- May have type declarations
-        : 'where' decllist_inst         { sLL $1 $> (unLoc $2) }
-        | {- empty -}                   { noLoc nilOL }
+        : 'where' decllist_inst         { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)
+                                             ,(snd $ unLoc $2)) }
+        | {- empty -}                   { noLoc ([],nilOL) }
 
 -- Declarations in binding groups other than classes and instances
 --
-decls   :: { Located (OrdList (LHsDecl RdrName)) }
-        : decls ';' decl                { let { this = unLoc $3;
-                                    rest = unLoc $1;
-                                    these = rest `appOL` this }
-                              in rest `seq` this `seq` these `seq`
-                                    sLL $1 $> these }
-        | decls ';'                     { sLL $1 $> (unLoc $1) }
-        | decl                          { $1 }
-        | {- empty -}                   { noLoc nilOL }
-
-decllist :: { Located (OrdList (LHsDecl RdrName)) }
-        : '{'            decls '}'      { sLL $1 $> (unLoc $2) }
-        |     vocurly    decls close    { $2 }
+decls   :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) }
+        : decls ';' decl    {% if isNilOL (snd $ unLoc $1)
+                                 then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
+                                                        , unitOL $3))
+                                 else do ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2]
+                                           >> return (
+                                          let { this = unitOL $3;
+                                                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                          { sL1 $1 ([], unitOL $1) }
+        | {- empty -}                   { noLoc ([],nilOL) }
+
+decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl RdrName))) }
+        : '{'            decls '}'     { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)
+                                                   ,sL1 $2 $ snd $ unLoc $2) }
+        |     vocurly    decls close   { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) }
 
 -- Binding groups other than those of class and instance declarations
 --
-binds   ::  { Located (HsLocalBinds RdrName) }          -- May have implicit parameters
+binds   ::  { Located ([AddAnn],Located (HsLocalBinds RdrName)) }
+                                         -- May have implicit parameters
                                                 -- No type declarations
-        : decllist                      { sL1 $1 (HsValBinds (cvBindGroup (unLoc $1))) }
-        | '{'            dbinds '}'     { sLL $1 $> (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
-        |     vocurly    dbinds close   { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
+        : decllist          {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1)
+                                  ; return (sL1 $1 (fst $ unLoc $1
+                                                    ,sL1 $1 $ HsValBinds val_binds)) } }
+
+        | '{'            dbinds '}'     { sLL $1 $> ([moc $1,mcc $3]
+                                             ,sL1 $2 $ HsIPBinds (IPBinds (unLoc $2)
+                                                         emptyTcEvBinds)) }
+
+        |     vocurly    dbinds close   { L (getLoc $2) ([]
+                                            ,sL1 $2 $ HsIPBinds (IPBinds (unLoc $2)
+                                                        emptyTcEvBinds)) }
+
 
-wherebinds :: { Located (HsLocalBinds RdrName) }        -- May have implicit parameters
+wherebinds :: { Located ([AddAnn],Located (HsLocalBinds RdrName)) }
+                                                -- May have implicit parameters
                                                 -- No type declarations
-        : 'where' binds                 { sLL $1 $> (unLoc $2) }
-        | {- empty -}                   { noLoc emptyLocalBinds }
+        : 'where' binds                 { sLL $1 $> (mj AnnWhere $1 : (fst $ unLoc $2)
+                                             ,snd $ unLoc $2) }
+        | {- empty -}                   { noLoc ([],noLoc emptyLocalBinds) }
 
 
 -----------------------------------------------------------------------------
 -- Transformation Rules
 
-rules   :: { OrdList (LHsDecl RdrName) }
-        :  rules ';' rule                       { $1 `snocOL` $3 }
-        |  rules ';'                            { $1 }
-        |  rule                                 { unitOL $1 }
-        |  {- empty -}                          { nilOL }
+rules   :: { OrdList (LRuleDecl RdrName) }
+        :  rules ';' rule              {% addAnnotation (oll $1) AnnSemi (gl $2)
+                                          >> return ($1 `snocOL` $3) }
+        |  rules ';'                   {% addAnnotation (oll $1) AnnSemi (gl $2)
+                                          >> return $1 }
+        |  rule                        { unitOL $1 }
+        |  {- empty -}                 { nilOL }
 
-rule    :: { LHsDecl RdrName }
+rule    :: { LRuleDecl RdrName }
         : STRING rule_activation rule_forall infixexp '=' exp
-             { sLL $1 $> $ RuleD (HsRule (getSTRING $1)
-                                  ($2 `orElse` AlwaysActive)
-                                  $3 $4 placeHolderNames $6 placeHolderNames) }
+         {%ams (sLL $1 $> $ (HsRule (L (gl $1) (getSTRINGs $1,getSTRING $1))
+                                  ((snd $2) `orElse` AlwaysActive)
+                                  (snd $3) $4 placeHolderNames $6
+                                  placeHolderNames))
+               (mj AnnEqual $5 : (fst $2) ++ (fst $3)) }
 
 -- Rules can be specified to be NeverActive, unlike inline/specialize pragmas
-rule_activation :: { Maybe Activation }
-        : {- empty -}                           { Nothing }
-        | rule_explicit_activation              { Just $1 }
-
-rule_explicit_activation :: { Activation }  -- In brackets
-        : '[' INTEGER ']'               { ActiveAfter  (fromInteger (getINTEGER $2)) }
-        | '[' '~' INTEGER ']'           { ActiveBefore (fromInteger (getINTEGER $3)) }
-        | '[' '~' ']'                   { NeverActive }
-
-rule_forall :: { [RuleBndr RdrName] }
-        : 'forall' rule_var_list '.'            { $2 }
-        | {- empty -}                           { [] }
-
-rule_var_list :: { [RuleBndr RdrName] }
+rule_activation :: { ([AddAnn],Maybe Activation) }
+        : {- empty -}                           { ([],Nothing) }
+        | rule_explicit_activation              { (fst $1,Just (snd $1)) }
+
+rule_explicit_activation :: { ([AddAnn]
+                              ,Activation) }  -- In brackets
+        : '[' INTEGER ']'       { ([mos $1,mj AnnVal $2,mcs $3]
+                                  ,ActiveAfter  (fromInteger (getINTEGER $2))) }
+        | '[' '~' INTEGER ']'   { ([mos $1,mj AnnTilde $2,mj AnnVal $3,mcs $4]
+                                  ,ActiveBefore (fromInteger (getINTEGER $3))) }
+        | '[' '~' ']'           { ([mos $1,mj AnnTilde $2,mcs $3]
+                                  ,NeverActive) }
+
+rule_forall :: { ([AddAnn],[LRuleBndr RdrName]) }
+        : 'forall' rule_var_list '.'     { ([mu AnnForall $1,mj AnnDot $3],$2) }
+        | {- empty -}                    { ([],[]) }
+
+rule_var_list :: { [LRuleBndr RdrName] }
         : rule_var                              { [$1] }
         | rule_var rule_var_list                { $1 : $2 }
 
-rule_var :: { RuleBndr RdrName }
-        : varid                                 { RuleBndr $1 }
-        | '(' varid '::' ctype ')'              { RuleBndrSig $2 (mkHsWithBndrs $4) }
+rule_var :: { LRuleBndr RdrName }
+        : varid                         { sLL $1 $> (RuleBndr $1) }
+        | '(' varid '::' ctype ')'      {% ams (sLL $1 $> (RuleBndrSig $2
+                                                       (mkLHsSigWcType $4)))
+                                               [mop $1,mu AnnDcolon $3,mcp $5] }
 
 -----------------------------------------------------------------------------
 -- Warnings and deprecations (c.f. rules)
 
-warnings :: { OrdList (LHsDecl RdrName) }
-        : warnings ';' warning          { $1 `appOL` $3 }
-        | warnings ';'                  { $1 }
-        | warning                               { $1 }
-        | {- empty -}                           { nilOL }
+warnings :: { OrdList (LWarnDecl RdrName) }
+        : warnings ';' warning         {% addAnnotation (oll $1) AnnSemi (gl $2)
+                                          >> return ($1 `appOL` $3) }
+        | warnings ';'                 {% addAnnotation (oll $1) AnnSemi (gl $2)
+                                          >> return $1 }
+        | warning                      { $1 }
+        | {- 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 $ unLoc $2))
-                       | n <- unLoc $1 ] }
-
-deprecations :: { OrdList (LHsDecl RdrName) }
-        : deprecations ';' deprecation          { $1 `appOL` $3 }
-        | deprecations ';'                      { $1 }
-        | deprecation                           { $1 }
-        | {- empty -}                           { nilOL }
+                {% amsu (sLL $1 $> (Warning (unLoc $1) (WarningTxt (noLoc "") $ snd $ unLoc $2)))
+                     (fst $ unLoc $2) }
+
+deprecations :: { OrdList (LWarnDecl RdrName) }
+        : deprecations ';' deprecation
+                                       {% addAnnotation (oll $1) AnnSemi (gl $2)
+                                          >> return ($1 `appOL` $3) }
+        | deprecations ';'             {% addAnnotation (oll $1) AnnSemi (gl $2)
+                                          >> return $1 }
+        | deprecation                  { $1 }
+        | {- 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 $ unLoc $2))
-                       | n <- unLoc $1 ] }
+             {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc "") $ snd $ unLoc $2)))
+                     (fst $ unLoc $2) }
 
-strings :: { Located [FastString] }
-    : STRING { sL1 $1 [getSTRING $1] }
-    | '[' stringlist ']' { sLL $1 $> $ fromOL (unLoc $2) }
+strings :: { Located ([AddAnn],[Located StringLiteral]) }
+    : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }
+    | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }
 
-stringlist :: { Located (OrdList FastString) }
-    : stringlist ',' STRING { sLL $1 $> (unLoc $1 `snocOL` getSTRING $3) }
-    | STRING                { sLL $1 $> (unitOL (getSTRING $1)) }
+stringlist :: { Located (OrdList (Located StringLiteral)) }
+    : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>
+                               return (sLL $1 $> (unLoc $1 `snocOL`
+                                                  (L (gl $3) (getStringLiteral $3)))) }
+    | STRING                { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }
+    | {- empty -}           { noLoc nilOL }
 
 -----------------------------------------------------------------------------
 -- Annotations
 annotation :: { LHsDecl RdrName }
-    : '{-# ANN' name_var aexp '#-}'      { sLL $1 $> (AnnD $ HsAnnotation (ValueAnnProvenance (unLoc $2)) $3) }
-    | '{-# ANN' 'type' tycon aexp '#-}'  { sLL $1 $> (AnnD $ HsAnnotation (TypeAnnProvenance (unLoc $3)) $4) }
-    | '{-# ANN' 'module' aexp '#-}'      { sLL $1 $> (AnnD $ HsAnnotation ModuleAnnProvenance $3) }
+    : '{-# ANN' name_var aexp '#-}'      {% ams (sLL $1 $> (AnnD $ HsAnnotation
+                                            (getANN_PRAGs $1)
+                                            (ValueAnnProvenance $2) $3))
+                                            [mo $1,mc $4] }
+
+    | '{-# ANN' 'type' tycon aexp '#-}'  {% ams (sLL $1 $> (AnnD $ HsAnnotation
+                                            (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] }
 
 
 -----------------------------------------------------------------------------
 -- Foreign import and export declarations
 
-fdecl :: { LHsDecl RdrName }
+fdecl :: { Located ([AddAnn],HsDecl RdrName) }
 fdecl : 'import' callconv safety fspec
-                {% mkImport $2 $3 (unLoc $4) >>= return.sLL $1 $> }
+               {% mkImport $2 $3 (snd $ unLoc $4) >>= \i ->
+                 return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i))  }
       | 'import' callconv        fspec
-                {% do { d <- mkImport $2 PlaySafe (unLoc $3);
-                        return (sLL $1 $> d) } }
+               {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3);
+                    return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $3),d)) }}
       | 'export' callconv fspec
-                {% mkExport $2 (unLoc $3) >>= return.sLL $1 $> }
-
-callconv :: { CCallConv }
-          : 'stdcall'                   { StdCallConv }
-          | 'ccall'                     { CCallConv   }
-          | 'capi'                      { CApiConv    }
-          | 'prim'                      { PrimCallConv}
-          | 'javascript'                { JavaScriptCallConv }
-
-safety :: { Safety }
-        : 'unsafe'                      { PlayRisky }
-        | 'safe'                        { PlaySafe }
-        | 'interruptible'               { PlayInterruptible }
-
-fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
-       : STRING var '::' sigtypedoc     { sLL $1 $> (L (getLoc $1) (getSTRING $1), $2, $4) }
-       |        var '::' sigtypedoc     { sLL $1 $> (noLoc nilFS, $1, $3) }
+               {% mkExport $2 (snd $ unLoc $3) >>= \i ->
+                  return (sLL $1 $> (mj AnnExport $1 : (fst $ unLoc $3),i) ) }
+
+callconv :: { Located CCallConv }
+          : 'stdcall'                   { sLL $1 $> StdCallConv }
+          | 'ccall'                     { sLL $1 $> CCallConv   }
+          | 'capi'                      { sLL $1 $> CApiConv    }
+          | 'prim'                      { sLL $1 $> PrimCallConv}
+          | 'javascript'                { sLL $1 $> JavaScriptCallConv }
+
+safety :: { Located Safety }
+        : 'unsafe'                      { sLL $1 $> PlayRisky }
+        | 'safe'                        { sLL $1 $> PlaySafe }
+        | 'interruptible'               { sLL $1 $> PlayInterruptible }
+
+fspec :: { Located ([AddAnn]
+                    ,(Located StringLiteral, Located RdrName, LHsSigType RdrName)) }
+       : STRING var '::' sigtypedoc     { sLL $1 $> ([mu AnnDcolon $3]
+                                             ,(L (getLoc $1)
+                                                    (getStringLiteral $1), $2, mkLHsSigType $4)) }
+       |        var '::' sigtypedoc     { sLL $1 $> ([mu AnnDcolon $2]
+                                             ,(noLoc (StringLiteral "" nilFS), $1, mkLHsSigType $3)) }
          -- if the entity string is missing, it defaults to the empty string;
          -- the meaning of an empty entity string depends on the calling
          -- convention
@@ -1110,50 +1502,66 @@ fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
 -----------------------------------------------------------------------------
 -- Type signatures
 
-opt_sig :: { Maybe (LHsType RdrName) }
-        : {- empty -}                   { Nothing }
-        | '::' sigtype                  { Just $2 }
+opt_sig :: { ([AddAnn], Maybe (LHsType RdrName)) }
+        : {- empty -}                   { ([],Nothing) }
+        | '::' sigtype                  { ([mu AnnDcolon $1],Just $2) }
 
-opt_asig :: { Maybe (LHsType RdrName) }
-        : {- empty -}                   { Nothing }
-        | '::' atype                    { Just $2 }
+opt_asig :: { ([AddAnn],Maybe (LHsType RdrName)) }
+        : {- empty -}                   { ([],Nothing) }
+        | '::' atype                    { ([mu AnnDcolon $1],Just $2) }
 
-sigtype :: { LHsType RdrName }          -- Always a HsForAllTy,
-                                        -- to tell the renamer where to generalise
-        : ctype                         { sL1 $1 (mkImplicitHsForAllTy (noLoc []) $1) }
-        -- Wrap an Implicit forall if there isn't one there already
+sigtype :: { LHsType RdrName }
+        : ctype                            { $1 }
 
-sigtypedoc :: { LHsType RdrName }       -- Always a HsForAllTy
-        : ctypedoc                      { sL1 $1 (mkImplicitHsForAllTy (noLoc []) $1) }
-        -- Wrap an Implicit forall if there isn't one there already
+sigtypedoc :: { LHsType RdrName }
+        : ctypedoc                         { $1 }
 
-sig_vars :: { Located [Located RdrName] }  -- Returned in reversed order
-         : sig_vars ',' var             { sLL $1 $> ($3 : unLoc $1) }
-         | var                          { sL1 $1 [$1] }
 
-sigtypes1 :: { [LHsType RdrName] }      -- Always HsForAllTys
-        : sigtype                       { [ $1 ] }
-        | sigtype ',' sigtypes1         { $1 : $3 }
+sig_vars :: { Located [Located RdrName] }    -- Returned in reversed order
+         : sig_vars ',' var           {% addAnnotation (gl $ head $ unLoc $1)
+                                                       AnnComma (gl $2)
+                                         >> return (sLL $1 $> ($3 : unLoc $1)) }
+         | var                        { sL1 $1 [$1] }
+
+sigtypes1 :: { (OrdList (LHsSigType RdrName)) }
+   : sigtype                 { unitOL (mkLHsSigType $1) }
+   | sigtype ',' sigtypes1   {% addAnnotation (gl $1) AnnComma (gl $2)
+                                >> return (unitOL (mkLHsSigType $1) `appOL` $3) }
 
 -----------------------------------------------------------------------------
 -- Types
 
-strict_mark :: { Located HsBang }
-        : '!'                           { sL1 $1 (HsUserBang Nothing      True) }
-        | '{-# UNPACK' '#-}'            { sLL $1 $> (HsUserBang (Just True)  False) }
-        | '{-# NOUNPACK' '#-}'          { sLL $1 $> (HsUserBang (Just False) True) }
-        | '{-# UNPACK' '#-}' '!'        { sLL $1 $> (HsUserBang (Just True)  True) }
-        | '{-# NOUNPACK' '#-}' '!'      { sLL $1 $> (HsUserBang (Just False) True) }
-        -- Although UNPACK with no '!' is illegal, we get a
-        -- better error message if we parse it here
+strict_mark :: { Located ([AddAnn],HsSrcBang) }
+        : strictness { sL1 $1 (let (a, str) = unLoc $1 in (a, HsSrcBang Nothing NoSrcUnpack str)) }
+        | unpackedness { sL1 $1 (let (a, prag, unpk) = unLoc $1 in (a, HsSrcBang prag unpk NoSrcStrict)) }
+        | unpackedness strictness { sLL $1 $> (let { (a, prag, unpk) = unLoc $1
+                                                   ; (a', str) = unLoc $2 }
+                                                in (a ++ a', HsSrcBang prag unpk str)) }
+        -- Although UNPACK with no '!' without StrictData and UNPACK with '~' are illegal,
+        -- we get a better error message if we parse them here
+
+strictness :: { Located ([AddAnn], SrcStrictness) }
+        : '!' { sL1 $1 ([mj AnnBang $1], SrcStrict) }
+        | '~' { sL1 $1 ([mj AnnTilde $1], SrcLazy) }
+
+unpackedness :: { Located ([AddAnn], Maybe SourceText, SrcUnpackedness) }
+        : '{-# UNPACK' '#-}'   { sLL $1 $> ([mo $1, mc $2], Just $ getUNPACK_PRAGs $1, SrcUnpack) }
+        | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], Just $ getNOUNPACK_PRAGs $1, SrcNoUnpack) }
 
 -- A ctype is a for-all type
 ctype   :: { LHsType RdrName }
         : 'forall' tv_bndrs '.' ctype   {% hintExplicitForall (getLoc $1) >>
-                                            return (sLL $1 $> $ mkExplicitHsForAllTy $2 (noLoc []) $4) }
-        | context '=>' ctype            { sLL $1 $> $ mkQualifiedHsForAllTy   $1 $3 }
-        | ipvar '::' type               { sLL $1 $> (HsIParamTy (unLoc $1) $3) }
-        | type                          { $1 }
+                                           ams (sLL $1 $> $
+                                                HsForAllTy { hst_bndrs = $2
+                                                           , hst_body = $4 })
+                                               [mu AnnForall $1, mj AnnDot $3] }
+        | context '=>' ctype          {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
+                                         >> return (sLL $1 $> $
+                                            HsQualTy { hst_ctxt = $1
+                                                     , hst_body = $3 }) }
+        | ipvar '::' type             {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
+                                             [mj AnnVal $1,mu AnnDcolon $2] }
+        | type                        { $1 }
 
 ----------------------
 -- Notes for 'ctypedoc'
@@ -1168,10 +1576,17 @@ ctype   :: { LHsType RdrName }
 
 ctypedoc :: { LHsType RdrName }
         : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >>
-                                            return (sLL $1 $> $ mkExplicitHsForAllTy $2 (noLoc []) $4) }
-        | context '=>' ctypedoc         { sLL $1 $> $ mkQualifiedHsForAllTy   $1 $3 }
-        | ipvar '::' type               { sLL $1 $> (HsIParamTy (unLoc $1) $3) }
-        | typedoc                       { $1 }
+                                            ams (sLL $1 $> $
+                                                 HsForAllTy { hst_bndrs = $2
+                                                            , hst_body = $4 })
+                                                [mu AnnForall $1,mj AnnDot $3] }
+        | context '=>' ctypedoc       {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
+                                         >> return (sLL $1 $> $
+                                            HsQualTy { hst_ctxt = $1
+                                                     , hst_body = $3 }) }
+        | ipvar '::' type             {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
+                                             [mj AnnVal $1,mu AnnDcolon $2] }
+        | typedoc                     { $1 }
 
 ----------------------
 -- Notes for 'context'
@@ -1184,137 +1599,219 @@ ctypedoc :: { LHsType RdrName }
 -- to permit an individual equational constraint without parenthesis.
 -- Thus for some reason we allow    f :: a~b => blah
 -- but not                          f :: ?x::Int => blah
+-- See Note [Parsing ~]
 context :: { LHsContext RdrName }
-        : btype '~'      btype          {% checkContext
-                                             (sLL $1 $> $ HsEqTy $1 $3) }
-        | btype                         {% checkContext $1 }
+        :  btype                        {% do { (anns,ctx) <- checkContext $1
+                                                ; if null (unLoc ctx)
+                                                   then addAnnotation (gl $1) AnnUnit (gl $1)
+                                                   else return ()
+                                                ; ams ctx anns
+                                                } }
+
+context_no_ops :: { LHsContext RdrName }
+        : btype_no_ops                 {% do { let { ty = splitTilde $1 }
+                                             ; (anns,ctx) <- checkContext ty
+                                             ; if null (unLoc ctx)
+                                                   then addAnnotation (gl ty) AnnUnit (gl ty)
+                                                   else return ()
+                                             ; ams ctx anns
+                                             } }
+
+{- Note [GADT decl discards annotations]
+~~~~~~~~~~~~~~~~~~~~~
+The type production for
+
+    btype `->` btype
+
+adds the AnnRarrow annotation twice, in different places.
+
+This is because if the type is processed as usual, it belongs on the annotations
+for the type as a whole.
+
+But if the type is passed to mkGadtDecl, it discards the top level SrcSpan, and
+the top-level annotation will be disconnected. Hence for this specific case it
+is connected to the first type too.
+-}
 
 type :: { LHsType RdrName }
-        : btype                         { $1 }
-        | btype qtyconop type           { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
-        | btype tyvarop  type           { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
-        | btype '->'     ctype          { sLL $1 $> $ HsFunTy $1 $3 }
-        | btype '~'      btype          { sLL $1 $> $ HsEqTy $1 $3 }
-                                        -- see Note [Promotion]
-        | btype SIMPLEQUOTE qconop type     { sLL $1 $> $ mkHsOpTy $1 $3 $4 }
-        | btype SIMPLEQUOTE varop  type     { sLL $1 $> $ mkHsOpTy $1 $3 $4 }
+        : btype                        { $1 }
+        | btype '->' ctype             {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations]
+                                       >> ams (sLL $1 $> $ HsFunTy $1 $3)
+                                              [mu AnnRarrow $2] }
+
 
 typedoc :: { LHsType RdrName }
         : btype                          { $1 }
         | btype docprev                  { sLL $1 $> $ HsDocTy $1 $2 }
-        | btype qtyconop type            { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
-        | btype qtyconop type docprev    { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
-        | btype tyvarop  type            { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
-        | btype tyvarop  type docprev    { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
-        | btype '->'     ctypedoc        { sLL $1 $> $ HsFunTy $1 $3 }
-        | btype docprev '->' ctypedoc    { sLL $1 $> $ HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) $4 }
-        | btype '~'      btype           { sLL $1 $> $ HsEqTy $1 $3 }
-                                        -- see Note [Promotion]
-        | btype SIMPLEQUOTE qconop type     { sLL $1 $> $ mkHsOpTy $1 $3 $4 }
-        | btype SIMPLEQUOTE varop  type     { sLL $1 $> $ mkHsOpTy $1 $3 $4 }
-
+        | btype '->'     ctypedoc        {% ams (sLL $1 $> $ HsFunTy $1 $3)
+                                                [mu AnnRarrow $2] }
+        | btype docprev '->' ctypedoc    {% ams (sLL $1 $> $
+                                                 HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2))
+                                                         $4)
+                                                [mu AnnRarrow $3] }
+
+-- See Note [Parsing ~]
 btype :: { LHsType RdrName }
-        : btype atype                   { sLL $1 $> $ HsAppTy $1 $2 }
+        : tyapps                      { sL1 $1 $ HsAppsTy (splitTildeApps (reverse (unLoc $1))) }
+
+-- Used for parsing Haskell98-style data constructors,
+-- in order to forbid the blasphemous
+-- > data Foo = Int :+ Char :* Bool
+-- See also Note [Parsing data constructors is hard].
+btype_no_ops :: { LHsType RdrName }
+        : btype_no_ops atype            { sLL $1 $> $ HsAppTy $1 $2 }
         | atype                         { $1 }
 
+tyapps :: { Located [HsAppType RdrName] }   -- NB: This list is reversed
+        : tyapp                         { sL1 $1 [unLoc $1] }
+        | tyapps tyapp                  { sLL $1 $> $ (unLoc $2) : (unLoc $1) }
+
+-- See Note [HsAppsTy] in HsTypes
+tyapp :: { Located (HsAppType RdrName) }
+        : atype                         { sL1 $1 $ HsAppPrefix $1 }
+        | qtyconop                      { sL1 $1 $ HsAppInfix $1 }
+        | tyvarop                       { sL1 $1 $ HsAppInfix $1 }
+        | SIMPLEQUOTE qconop            {% ams (sLL $1 $> $ HsAppInfix $2)
+                                               [mj AnnSimpleQuote $1] }
+        | SIMPLEQUOTE varop             {% ams (sLL $1 $> $ HsAppInfix $2)
+                                               [mj AnnSimpleQuote $1] }
+
 atype :: { LHsType RdrName }
-        : ntgtycon                       { sL1 $1 (HsTyVar (unLoc $1)) }      -- Not including unit tuples
-        | tyvar                          { sL1 $1 (HsTyVar (unLoc $1)) }      -- (See Note [Unit tuples])
-        | strict_mark atype              { sLL $1 $> (HsBangTy (unLoc $1) $2) }  -- Constructor sigs only
-        | '{' fielddecls '}'             {% checkRecordSyntax (sLL $1 $> $ HsRecTy $2) } -- Constructor sigs only
-        | '(' ')'                        { sLL $1 $> $ HsTupleTy HsBoxedOrConstraintTuple []      }
-        | '(' ctype ',' comma_types1 ')' { sLL $1 $> $ HsTupleTy HsBoxedOrConstraintTuple ($2:$4) }
-        | '(#' '#)'                      { sLL $1 $> $ HsTupleTy HsUnboxedTuple           []      }
-        | '(#' comma_types1 '#)'         { sLL $1 $> $ HsTupleTy HsUnboxedTuple           $2      }
-        | '[' ctype ']'                  { sLL $1 $> $ HsListTy  $2 }
-        | '[:' ctype ':]'                { sLL $1 $> $ HsPArrTy  $2 }
-        | '(' ctype ')'                  { sLL $1 $> $ HsParTy   $2 }
-        | '(' ctype '::' kind ')'        { sLL $1 $> $ HsKindSig $2 $4 }
-        | quasiquote                     { sL1 $1 (HsQuasiQuoteTy (unLoc $1)) }
-        | '$(' exp ')'                   { sLL $1 $> $ mkHsSpliceTy $2 }
-        | TH_ID_SPLICE                   { sLL $1 $> $ mkHsSpliceTy $ sL1 $1 $ HsVar $
-                                           mkUnqual varName (getTH_ID_SPLICE $1) }
-                                                      -- see Note [Promotion] for the followings
-        | SIMPLEQUOTE qcon                            { sLL $1 $> $ HsTyVar $ unLoc $2 }
-        | SIMPLEQUOTE  '(' ctype ',' comma_types1 ')' { sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5) }
-        | SIMPLEQUOTE  '[' comma_types0 ']'     { sLL $1 $> $ HsExplicitListTy
-                                                       placeHolderKind $3 }
-        | SIMPLEQUOTE var                       { sLL $1 $> $ HsTyVar $ unLoc $2 }
-
-        | '[' ctype ',' comma_types1 ']'  { sLL $1 $> $ HsExplicitListTy
-                                                 placeHolderKind ($2 : $4) }
-        | INTEGER                         { sLL $1 $> $ HsTyLit $ HsNumTy $ getINTEGER $1 }
-        | STRING                          { sLL $1 $> $ HsTyLit $ HsStrTy $ getSTRING  $1 }
+        : ntgtycon                       { sL1 $1 (HsTyVar $1) }      -- Not including unit tuples
+        | tyvar                          {% do { nwc <- namedWildCardsEnabled -- (See Note [Unit tuples])
+                                               ; let tv@(L _ (Unqual name)) = $1
+                                               ; return $ if (startsWithUnderscore name && nwc)
+                                                          then (sL1 $1 (mkNamedWildCardTy tv))
+                                                          else (sL1 $1 (HsTyVar tv)) } }
+
+        | strict_mark atype              {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2))
+                                                (fst $ unLoc $1) }  -- Constructor sigs only
+        | '{' fielddecls '}'             {% amms (checkRecordSyntax
+                                                    (sLL $1 $> $ HsRecTy $2))
+                                                        -- Constructor sigs only
+                                                 [moc $1,mcc $3] }
+        | '(' ')'                        {% ams (sLL $1 $> $ HsTupleTy
+                                                    HsBoxedOrConstraintTuple [])
+                                                [mop $1,mcp $2] }
+        | '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma
+                                                          (gl $3) >>
+                                            ams (sLL $1 $> $ HsTupleTy
+                                             HsBoxedOrConstraintTuple ($2 : $4))
+                                                [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) [mos $1,mcs $3] }
+        | '[:' ctype ':]'             {% ams (sLL $1 $> $ HsPArrTy  $2) [mo $1,mc $3] }
+        | '(' ctype ')'               {% ams (sLL $1 $> $ HsParTy   $2) [mop $1,mcp $3] }
+        | '(' ctype '::' kind ')'     {% ams (sLL $1 $> $ HsKindSig $2 $4)
+                                             [mop $1,mu AnnDcolon $3,mcp $5] }
+        | quasiquote                  { sL1 $1 (HsSpliceTy (unLoc $1) placeHolderKind) }
+        | '$(' exp ')'                {% ams (sLL $1 $> $ mkHsSpliceTy $2)
+                                             [mj AnnOpenPE $1,mj AnnCloseP $3] }
+        | TH_ID_SPLICE                {%ams (sLL $1 $> $ mkHsSpliceTy $ sL1 $1 $ HsVar $
+                                             (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))
+                                             [mj AnnThIdSplice $1] }
+                                      -- see Note [Promotion] for the followings
+        | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
+        | SIMPLEQUOTE  '(' ctype ',' comma_types1 ')'
+                             {% addAnnotation (gl $3) AnnComma (gl $4) >>
+                                ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5))
+                                    [mj AnnSimpleQuote $1,mop $2,mcp $6] }
+        | SIMPLEQUOTE  '[' comma_types0 ']'     {% ams (sLL $1 $> $ HsExplicitListTy
+                                                            placeHolderKind $3)
+                                                       [mj AnnSimpleQuote $1,mos $2,mcs $4] }
+        | SIMPLEQUOTE var                       {% ams (sLL $1 $> $ HsTyVar $2)
+                                                       [mj AnnSimpleQuote $1,mj AnnName $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 ']'  {% addAnnotation (gl $2) AnnComma
+                                                           (gl $3) >>
+                                             ams (sLL $1 $> $ HsExplicitListTy
+                                                     placeHolderKind ($2 : $4))
+                                                 [mos $1,mcs $5] }
+        | INTEGER              { sLL $1 $> $ HsTyLit $ HsNumTy (getINTEGERs $1)
+                                                               (getINTEGER $1) }
+        | STRING               { sLL $1 $> $ HsTyLit $ HsStrTy (getSTRINGs $1)
+                                                               (getSTRING  $1) }
+        | '_'                  { sL1 $1 $ mkAnonWildCardTy }
 
 -- An inst_type is what occurs in the head of an instance decl
 --      e.g.  (Foo a, Gaz b) => Wibble a b
--- It's kept as a single type, with a MonoDictTy at the right
--- hand corner, for convenience.
-inst_type :: { LHsType RdrName }
-        : sigtype                       { $1 }
+-- It's kept as a single type for convenience.
+inst_type :: { LHsSigType RdrName }
+        : sigtype                       { mkLHsSigType $1 }
+
+deriv_types :: { [LHsSigType RdrName] }
+        : type                          { [mkLHsSigType $1] }
 
-inst_types1 :: { [LHsType RdrName] }
-        : inst_type                     { [$1] }
-        | inst_type ',' inst_types1     { $1 : $3 }
+        | type ',' deriv_types          {% addAnnotation (gl $1) AnnComma (gl $2)
+                                           >> return (mkLHsSigType $1 : $3) }
 
-comma_types0  :: { [LHsType RdrName] }
+comma_types0  :: { [LHsType RdrName] }  -- Zero or more:  ty,ty,ty
         : comma_types1                  { $1 }
         | {- empty -}                   { [] }
 
-comma_types1    :: { [LHsType RdrName] }
-        : ctype                         { [$1] }
-        | ctype  ',' comma_types1       { $1 : $3 }
+comma_types1    :: { [LHsType RdrName] }  -- One or more:  ty,ty,ty
+        : ctype                        { [$1] }
+        | ctype  ',' comma_types1      {% addAnnotation (gl $1) AnnComma (gl $2)
+                                          >> return ($1 : $3) }
 
 tv_bndrs :: { [LHsTyVarBndr RdrName] }
          : tv_bndr tv_bndrs             { $1 : $2 }
          | {- empty -}                  { [] }
 
 tv_bndr :: { LHsTyVarBndr RdrName }
-        : tyvar                         { sL1 $1 (UserTyVar (unLoc $1)) }
-        | '(' tyvar '::' kind ')'       { sLL $1 $> (KindedTyVar (unLoc $2) $4) }
-
-fds :: { Located [Located (FunDep RdrName)] }
+        : tyvar                         { sL1 $1 (UserTyVar $1) }
+        | '(' tyvar '::' kind ')'       {% ams (sLL $1 $>  (KindedTyVar $2 $4))
+                                               [mop $1,mu AnnDcolon $3
+                                               ,mcp $5] }
+
+fds :: { Located ([AddAnn],[Located (FunDep (Located RdrName))]) }
+        : {- empty -}                   { noLoc ([],[]) }
+        | '|' fds1                      { (sLL $1 $> ([mj AnnVbar $1]
+                                                 ,reverse (unLoc $2))) }
+
+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 (Located RdrName)) }
+        : varids0 '->' varids0  {% ams (L (comb3 $1 $2 $3)
+                                       (reverse (unLoc $1), reverse (unLoc $3)))
+                                       [mu AnnRarrow $2] }
+
+varids0 :: { Located [Located RdrName] }
         : {- empty -}                   { noLoc [] }
-        | '|' fds1                      { sLL $1 $> (reverse (unLoc $2)) }
+        | varids0 tyvar                 { sLL $1 $> ($2 : unLoc $1) }
 
-fds1 :: { Located [Located (FunDep RdrName)] }
-        : fds1 ',' fd                   { sLL $1 $> ($3 : unLoc $1) }
-        | fd                            { sL1 $1 [$1] }
+{-
+Note [Parsing ~]
+~~~~~~~~~~~~~~~~
 
-fd :: { Located (FunDep RdrName) }
-        : varids0 '->' varids0          { L (comb3 $1 $2 $3)
-                                           (reverse (unLoc $1), reverse (unLoc $3)) }
+Due to parsing conflicts between lazyness annotations in data type
+declarations (see strict_mark) and equality types ~'s are always
+parsed as lazyness annotations, and turned into HsEqTy's in the
+correct places using RdrHsSyn.splitTilde.
+
+Since strict_mark is parsed as part of atype which is part of type,
+typedoc and context (where HsEqTy previously appeared) it made most
+sense and was simplest to parse ~ as part of strict_mark and later
+turn them into HsEqTy's.
+
+-}
 
-varids0 :: { Located [RdrName] }
-        : {- empty -}                   { noLoc [] }
-        | varids0 tyvar                 { sLL $1 $> (unLoc $2 : unLoc $1) }
 
 -----------------------------------------------------------------------------
 -- Kinds
 
 kind :: { LHsKind RdrName }
-        : bkind                  { $1 }
-        | bkind '->' kind        { sLL $1 $> $ HsFunTy $1 $3 }
-
-bkind :: { LHsKind RdrName }
-        : akind                  { $1 }
-        | bkind akind            { sLL $1 $> $ HsAppTy $1 $2 }
-
-akind :: { LHsKind RdrName }
-        : '*'                    { sL1 $1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) }
-        | '(' kind ')'           { sLL $1 $> $ HsParTy $2 }
-        | pkind                  { $1 }
-        | tyvar                  { sL1 $1 $ HsTyVar (unLoc $1) }
-
-pkind :: { LHsKind RdrName }  -- promoted type, see Note [Promotion]
-        : qtycon                          { sL1 $1 $ HsTyVar $ unLoc $1 }
-        | '(' ')'                         { sLL $1 $> $ HsTyVar $ getRdrName unitTyCon }
-        | '(' kind ',' comma_kinds1 ')'   { sLL $1 $> $ HsTupleTy HsBoxedTuple ($2 : $4) }
-        | '[' kind ']'                    { sLL $1 $> $ HsListTy $2 }
-
-comma_kinds1 :: { [LHsKind RdrName] }
-        : kind                          { [$1] }
-        | kind  ',' comma_kinds1        { $1 : $3 }
+        : ctype                  { $1 }
 
 {- Note [Promotion]
    ~~~~~~~~~~~~~~~~
@@ -1327,12 +1824,6 @@ few reasons:
   2. if one day we merge types and kinds, tick would mean look in DataName
   3. we don't have a kind namespace anyway
 
-- Syntax of explicit kind polymorphism  (IA0_TODO: not yet implemented)
-Kind abstraction is implicit. We write
-> data SList (s :: k -> *) (as :: [k]) where ...
-because it looks like what we do in terms
-> id (x :: a) = x
-
 - Name resolution
 When the user write Zero instead of 'Zero in types, we parse it a
 HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We
@@ -1347,14 +1838,23 @@ both become a HsTyVar ("Zero", DataName) after the renamer.
 -----------------------------------------------------------------------------
 -- Datatype declarations
 
-gadt_constrlist :: { Located [LConDecl RdrName] }       -- Returned in order
-        : 'where' '{'        gadt_constrs '}'      { L (comb2 $1 $3) (unLoc $3) }
-        | 'where' vocurly    gadt_constrs close    { L (comb2 $1 $3) (unLoc $3) }
-        | {- empty -}                              { noLoc [] }
+gadt_constrlist :: { Located ([AddAnn]
+                          ,[LConDecl RdrName]) } -- Returned in order
+        : 'where' '{'        gadt_constrs '}'   { L (comb2 $1 $3)
+                                                    ([mj AnnWhere $1
+                                                     ,moc $2
+                                                     ,mcc $4]
+                                                    , unLoc $3) }
+        | 'where' vocurly    gadt_constrs close  { L (comb2 $1 $3)
+                                                     ([mj AnnWhere $1]
+                                                     , unLoc $3) }
+        | {- empty -}                            { noLoc ([],[]) }
 
 gadt_constrs :: { Located [LConDecl RdrName] }
-        : gadt_constr ';' gadt_constrs  { L (comb2 (head $1) $3) ($1 ++ unLoc $3) }
-        | gadt_constr                   { L (getLoc (head $1)) $1 }
+        : gadt_constr_with_doc ';' gadt_constrs
+                  {% addAnnotation (gl $1) AnnSemi (gl $2)
+                     >> return (L (comb2 $1 $3) ($1 : unLoc $3)) }
+        | gadt_constr_with_doc          { L (gl $1) [$1] }
         | {- empty -}                   { noLoc [] }
 
 -- We allow the following forms:
@@ -1363,72 +1863,111 @@ gadt_constrs :: { Located [LConDecl RdrName] }
 --      D { x,y :: a } :: T a
 --      forall a. Eq a => D { x,y :: a } :: T a
 
-gadt_constr :: { [LConDecl RdrName] }   -- Returns a list because of:   C,D :: ty
+gadt_constr_with_doc :: { LConDecl RdrName }
+gadt_constr_with_doc
+        : maybe_docnext ';' gadt_constr
+                {% return $ addConDoc $3 $1 }
+        | gadt_constr
+                {% return $1 }
+
+gadt_constr :: { LConDecl RdrName }
+    -- see Note [Difference in parsing GADT and data constructors]
+    -- Returns a list because of:   C,D :: ty
         : con_list '::' sigtype
-                { map (sL (comb2 $1 $3)) (mkGadtDecl (unLoc $1) $3) }
+                {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) (mkLHsSigType $3)))
+                       [mu AnnDcolon $2] }
 
-                -- Deprecated syntax for GADT record declarations
-        | oqtycon '{' fielddecls '}' '::' sigtype
-                {% do { cd <- mkDeprecatedGadtRecordDecl (comb2 $1 $6) $1 $3 $6
-                      ; cd' <- checkRecordSyntax cd
-                      ; return [cd'] } }
+{- Note [Difference in parsing GADT and data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+GADT constructors have simpler syntax than usual data constructors:
+in GADTs, types cannot occur to the left of '::', so they cannot be mixed
+with constructor names (see Note [Parsing data constructors is hard]).
+
+Due to simplified syntax, GADT constructor names (left-hand side of '::')
+use simpler grammar production than usual data constructor names. As a
+consequence, GADT constructor names are resticted (names like '(*)' are
+allowed in usual data constructors, but not in GADTs).
+-}
 
-constrs :: { Located [LConDecl RdrName] }
-        : maybe_docnext '=' constrs1    { L (comb2 $2 $3) (addConDocs (unLoc $3) $1) }
+constrs :: { Located ([AddAnn],[LConDecl RdrName]) }
+        : maybe_docnext '=' constrs1    { L (comb2 $2 $3) ([mj AnnEqual $2]
+                                                     ,addConDocs (unLoc $3) $1)}
 
 constrs1 :: { Located [LConDecl RdrName] }
-        : constrs1 maybe_docnext '|' maybe_docprev constr { sLL $1 $> (addConDoc $5 $2 : addConDocFirst (unLoc $1) $4) }
+        : constrs1 maybe_docnext '|' maybe_docprev constr
+            {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $3)
+               >> return (sLL $1 $> (addConDoc $5 $2 : addConDocFirst (unLoc $1) $4)) }
         | constr                                          { sL1 $1 [$1] }
 
 constr :: { LConDecl RdrName }
-        : maybe_docnext forall context '=>' constr_stuff maybe_docprev
-                { let (con,details) = unLoc $5 in
-                  addConDoc (L (comb4 $2 $3 $4 $5) (mkSimpleConDecl con (unLoc $2) $3 details))
-                            ($1 `mplus` $6) }
+        : maybe_docnext forall context_no_ops '=>' constr_stuff maybe_docprev
+                {% ams (let (con,details) = unLoc $5 in
+                  addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con
+                                                   (snd $ unLoc $2) $3 details))
+                            ($1 `mplus` $6))
+                        (mu AnnDarrow $4:(fst $ unLoc $2)) }
         | maybe_docnext forall constr_stuff maybe_docprev
-                { let (con,details) = unLoc $3 in
-                  addConDoc (L (comb2 $2 $3) (mkSimpleConDecl con (unLoc $2) (noLoc []) details))
-                            ($1 `mplus` $4) }
+                {% ams ( let (con,details) = unLoc $3 in
+                  addConDoc (L (comb2 $2 $3) (mkConDeclH98 con
+                                           (snd $ unLoc $2) (noLoc []) details))
+                            ($1 `mplus` $4))
+                       (fst $ unLoc $2) }
 
-forall :: { Located [LHsTyVarBndr RdrName] }
-        : 'forall' tv_bndrs '.'         { sLL $1 $> $2 }
-        | {- empty -}                   { noLoc [] }
+forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr RdrName]) }
+        : 'forall' tv_bndrs '.'       { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }
+        | {- empty -}                 { noLoc ([], Nothing) }
 
 constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) }
--- We parse the constructor declaration
---      C t1 t2
--- as a btype (treating C as a type constructor) and then convert C to be
--- a data constructor.  Reason: it might continue like this:
---      C t1 t2 %: D Int
--- in which case C really would be a type constructor.  We can't resolve this
--- ambiguity till we come across the constructor oprerator :% (or not, more usually)
-        : btype                         {% splitCon $1 >>= return.sLL $1 $> }
-        | btype conop btype             {  sLL $1 $> ($2, InfixCon $1 $3) }
-
-fielddecls :: { [ConDeclField RdrName] }
+    -- see Note [Parsing data constructors is hard]
+        : btype_no_ops                         {% do { c <- splitCon $1
+                                                     ; return $ sLL $1 $> c } }
+        | btype_no_ops conop btype_no_ops      {  sLL $1 $> ($2, InfixCon (splitTilde $1) $3) }
+
+{- Note [Parsing data constructors is hard]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We parse the constructor declaration
+     C t1 t2
+as a btype_no_ops (treating C as a type constructor) and then convert C to be
+a data constructor.  Reason: it might continue like this:
+     C t1 t2 :% D Int
+in which case C really would be a type constructor.  We can't resolve this
+ambiguity till we come across the constructor oprerator :% (or not, more usually)
+-}
+
+fielddecls :: { [LConDeclField RdrName] }
         : {- empty -}     { [] }
         | fielddecls1     { $1 }
 
-fielddecls1 :: { [ConDeclField RdrName] }
+fielddecls1 :: { [LConDeclField RdrName] }
         : fielddecl maybe_docnext ',' maybe_docprev fielddecls1
-                      { [ addFieldDoc f $4 | f <- $1 ] ++ addFieldDocs $5 $2 }
-                             -- This adds the doc $4 to each field separately
-        | fielddecl   { $1 }
-
-fielddecl :: { [ConDeclField RdrName] }    -- A list because of   f,g :: Int
-        : maybe_docnext sig_vars '::' ctype maybe_docprev      { [ ConDeclField fld $4 ($1 `mplus` $5)
-                                                                 | fld <- reverse (unLoc $2) ] }
-
--- We allow the odd-looking 'inst_type' in a deriving clause, so that
--- we can do deriving( forall a. C [a] ) in a newtype (GHC extension).
--- The 'C [a]' part is converted to an HsPredTy by checkInstType
--- We don't allow a context, but that's sorted out by the type checker.
-deriving :: { Located (Maybe [LHsType RdrName]) }
-        : {- empty -}                           { noLoc Nothing }
-        | 'deriving' qtycon                     { let { L loc tv = $2 }
-                                                  in sLL $1 $> (Just [L loc (HsTyVar tv)]) }
-        | 'deriving' '(' ')'                    { sLL $1 $> (Just []) }
-        | 'deriving' '(' inst_types1 ')'        { sLL $1 $> (Just $3) }
+            {% addAnnotation (gl $1) AnnComma (gl $3) >>
+               return ((addFieldDoc $1 $4) : addFieldDocs $5 $2) }
+        | fielddecl   { [$1] }
+
+fielddecl :: { LConDeclField RdrName }
+                                              -- A list because of   f,g :: Int
+        : maybe_docnext sig_vars '::' ctype maybe_docprev
+            {% ams (L (comb2 $2 $4)
+                      (ConDeclField (reverse (map (fmap (flip FieldOcc PlaceHolder)) (unLoc $2))) $4 ($1 `mplus` $5)))
+                   [mu AnnDcolon $3] }
+
+-- The outer Located is just to allow the caller to
+-- know the rightmost extremity of the 'deriving' clause
+deriving :: { Located (HsDeriving RdrName) }
+        : {- empty -}             { noLoc Nothing }
+        | 'deriving' qtycon       {% let { L tv_loc tv = $2
+                                         ; full_loc = comb2 $1 $> }
+                                      in ams (L full_loc $ Just $ L full_loc $
+                                                 [mkLHsSigType (L tv_loc (HsTyVar $2))])
+                                             [mj AnnDeriving $1] }
+
+        | 'deriving' '(' ')'      {% let { full_loc = comb2 $1 $> }
+                                     in ams (L full_loc $ Just $ L full_loc [])
+                                            [mj AnnDeriving $1,mop $2,mcp $3] }
+
+        | 'deriving' '(' deriv_types ')'  {% let { full_loc = comb2 $1 $> }
+                                             in ams (L full_loc $ Just $ L full_loc $3)
+                                                    [mj AnnDeriving $1,mop $2,mcp $4] }
              -- Glasgow extension: allow partial
              -- applications in derivings
 
@@ -1466,82 +2005,126 @@ docdecld :: { LDocDecl }
         | docnamed                              { sL1 $1 (case (unLoc $1) of (n, doc) -> DocCommentNamed n doc) }
         | docsection                            { sL1 $1 (case (unLoc $1) of (n, doc) -> DocGroup n doc) }
 
-decl_no_th :: { Located (OrdList (LHsDecl RdrName)) }
+decl_no_th :: { 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 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2) };
                                         pat <- checkPattern empty e;
-                                        return $ sLL $1 $> $ unitOL $ sLL $1 $> $ ValD $
-                                               PatBind pat (unLoc $3)
-                                                       placeHolderType
-                                                       placeHolderNames
-                                                       (Nothing,[]) } }
+                                        _ <- ams (sLL $1 $> ())
+                                               (fst $ unLoc $3);
+                                        return $ sLL $1 $> $ ValD $
+                                            PatBind pat (snd $ unLoc $3)
+                                                    placeHolderType
+                                                    placeHolderNames
+                                                    ([],[]) } }
                                 -- Turn it all into an expression so that
                                 -- checkPattern can check that bangs are enabled
 
-        | infixexp opt_sig rhs  {% do { r <- checkValDef empty $1 $2 $3;
+        | infixexp opt_sig rhs  {% do { (ann,r) <- checkValDef empty $1 (snd $2) $3;
                                         let { l = comb2 $1 $> };
-                                        return $! (sL l (unitOL $! (sL l $ ValD r))) } }
-        | pattern_synonym_decl  { sLL $1 $> $ unitOL $1 }
-        | docdecl               { sLL $1 $> $ unitOL $1 }
-
-decl    :: { Located (OrdList (LHsDecl RdrName)) }
+                                        case r of {
+                                          (FunBind n _ _ _ _) ->
+                                                ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ;
+                                          (PatBind (L lh _lhs) _rhs _ _ _) ->
+                                                ams (L lh ()) (fst $2) >> return () } ;
+                                        _ <- ams (L l ()) (ann ++ (fst $ unLoc $3));
+                                        return $! (sL l $ ValD r) } }
+        | pattern_synonym_decl  { $1 }
+        | docdecl               { $1 }
+
+decl    :: { LHsDecl RdrName }
         : decl_no_th            { $1 }
 
         -- Why do we only allow naked declaration splices in top-level
         -- declarations and not here? Short answer: because readFail009
         -- fails terribly with a panic in cvBindsAndSigs otherwise.
-        | splice_exp            { sLL $1 $> $ unitOL (sLL $1 $> $ mkSpliceDecl $1) }
+        | splice_exp            { sLL $1 $> $ mkSpliceDecl $1 }
 
-rhs     :: { Located (GRHSs RdrName (LHsExpr RdrName)) }
-        : '=' exp wherebinds    { sL (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) }
-        | gdrhs wherebinds      { sLL $1 $> $ GRHSs (reverse (unLoc $1)) (unLoc $2) }
+rhs     :: { Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName)) }
+        : '=' exp wherebinds    { sL (comb3 $1 $2 $3)
+                                    ((mj AnnEqual $1 : (fst $ unLoc $3))
+                                    ,GRHSs (unguardedRHS (comb3 $1 $2 $3) $2)
+                                   (snd $ unLoc $3)) }
+        | gdrhs wherebinds      { sLL $1 $>  (fst $ unLoc $2
+                                    ,GRHSs (reverse (unLoc $1))
+                                                    (snd $ unLoc $2)) }
 
 gdrhs :: { Located [LGRHS RdrName (LHsExpr RdrName)] }
         : gdrhs gdrh            { sLL $1 $> ($2 : unLoc $1) }
         | gdrh                  { sL1 $1 [$1] }
 
 gdrh :: { LGRHS RdrName (LHsExpr RdrName) }
-        : '|' guardquals '=' exp        { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 }
+        : '|' guardquals '=' exp  {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4)
+                                         [mj AnnVbar $1,mj AnnEqual $3] }
 
-sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
+sigdecl :: { LHsDecl RdrName }
         :
         -- See Note [Declaration/signature overlap] for why we need infixexp here
           infixexp '::' sigtypedoc
-                        {% do s <- checkValSig $1 $3
-                        ; return (sLL $1 $> $ unitOL (sLL $1 $> $ SigD s)) }
+                        {% do v <- checkValSigLhs $1
+                        ; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2]
+                        ; return (sLL $1 $> $ SigD $
+                                  TypeSig [v] (mkLHsSigWcType $3)) }
+
         | var ',' sig_vars '::' sigtypedoc
-                                { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (TypeSig ($1 : reverse (unLoc $3)) $5) ] }
-        | infix prec ops        { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
-                                             | n <- unLoc $3 ] }
-        | pattern_synonym_sig   { sLL $1 $> $ unitOL $ sLL $1 $> . SigD . unLoc $ $1 }
+           {% do { let sig = TypeSig ($1 : reverse (unLoc $3))
+                                     (mkLHsSigWcType $5)
+                 ; addAnnotation (gl $1) AnnComma (gl $2)
+                 ; ams ( sLL $1 $> $ SigD sig )
+                       [mu AnnDcolon $4] } }
+
+        | infix prec ops
+              {% ams (sLL $1 $> $ SigD
+                        (FixSig (FixitySig (fromOL $ unLoc $3)
+                                (Fixity (unLoc $2) (unLoc $1)))))
+                     [mj AnnInfix $1,mj AnnVal $2] }
+
+        | pattern_synonym_sig   { sLL $1 $> . SigD . unLoc $ $1 }
+
         | '{-# INLINE' activation qvar '#-}'
-                { sLL $1 $> $ unitOL (sLL $1 $> $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) }
+                {% ams ((sLL $1 $> $ SigD (InlineSig $3
+                            (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)
+                                            (snd $2)))))
+                       ((mo $1:fst $2) ++ [mc $4]) }
+
         | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
-                { let inl_prag = mkInlinePragma (EmptyInlineSpec, FunLike) $2
-                  in sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 t inl_prag)
-                               | t <- $5] }
+             {% ams (
+                 let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
+                                             (EmptyInlineSpec, FunLike) (snd $2)
+                  in sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) inl_prag))
+                    (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) }
+
         | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
-                { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 t (mkInlinePragma (getSPEC_INLINE $1) $2))
-                            | t <- $5] }
+             {% ams (sLL $1 $> $ SigD (SpecSig $3 (fromOL $5)
+                               (mkInlinePragma (getSPEC_INLINE_PRAGs $1)
+                                               (getSPEC_INLINE $1) (snd $2))))
+                       (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) }
+
         | '{-# SPECIALISE' 'instance' inst_type '#-}'
-                { sLL $1 $> $ unitOL (sLL $1 $> $ SigD (SpecInstSig $3)) }
+                {% ams (sLL $1 $>
+                                  $ SigD (SpecInstSig (getSPEC_PRAGs $1) $3))
+                       [mo $1,mj AnnInstance $2,mc $4] }
+
         -- A minimal complete definition
         | '{-# MINIMAL' name_boolformula_opt '#-}'
-                { sLL $1 $> $ unitOL (sLL $1 $> $ SigD (MinimalSig $2)) }
+            {% ams (sLL $1 $> $ SigD (MinimalSig (getMINIMAL_PRAGs $1) $2))
+                   [mo $1,mc $3] }
 
-activation :: { Maybe Activation }
-        : {- empty -}                           { Nothing }
-        | explicit_activation                   { Just $1 }
+activation :: { ([AddAnn],Maybe Activation) }
+        : {- empty -}                           { ([],Nothing) }
+        | explicit_activation                   { (fst $1,Just (snd $1)) }
 
-explicit_activation :: { Activation }  -- In brackets
-        : '[' INTEGER ']'               { ActiveAfter  (fromInteger (getINTEGER $2)) }
-        | '[' '~' INTEGER ']'           { ActiveBefore (fromInteger (getINTEGER $3)) }
+explicit_activation :: { ([AddAnn],Activation) }  -- In brackets
+        : '[' INTEGER ']'       { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3]
+                                  ,ActiveAfter  (fromInteger (getINTEGER $2))) }
+        | '[' '~' INTEGER ']'   { ([mj AnnOpenS $1,mj AnnTilde $2,mj AnnVal $3
+                                                 ,mj AnnCloseS $4]
+                                  ,ActiveBefore (fromInteger (getINTEGER $3))) }
 
 -----------------------------------------------------------------------------
 -- Expressions
 
-quasiquote :: { Located (HsQuasiQuote RdrName) }
+quasiquote :: { Located (HsSplice RdrName) }
         : TH_QUASIQUOTE   { let { loc = getLoc $1
                                 ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1
                                 ; quoterId = mkUnqual varName quoter }
@@ -1552,181 +2135,211 @@ quasiquote :: { Located (HsQuasiQuote RdrName) }
                             in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
 
 exp   :: { LHsExpr RdrName }
-        : infixexp '::' sigtype { sLL $1 $> $ ExprWithTySig $1 $3 }
-        | infixexp '-<' exp     { sLL $1 $> $ HsArrApp $1 $3 placeHolderType
-                                                      HsFirstOrderApp True }
-        | infixexp '>-' exp     { sLL $1 $> $ HsArrApp $3 $1 placeHolderType
-                                                      HsFirstOrderApp False }
-        | infixexp '-<<' exp    { sLL $1 $> $ HsArrApp $1 $3 placeHolderType
-                                                      HsHigherOrderApp True }
-        | infixexp '>>-' exp    { sLL $1 $> $ HsArrApp $3 $1 placeHolderType
-                                                      HsHigherOrderApp False}
+        : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 (mkLHsSigWcType $3))
+                                       [mu AnnDcolon $2] }
+        | infixexp '-<' exp     {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType
+                                                        HsFirstOrderApp True)
+                                       [mu Annlarrowtail $2] }
+        | infixexp '>-' exp     {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType
+                                                      HsFirstOrderApp False)
+                                       [mu Annrarrowtail $2] }
+        | infixexp '-<<' exp    {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType
+                                                      HsHigherOrderApp True)
+                                       [mu AnnLarrowtail $2] }
+        | infixexp '>>-' exp    {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType
+                                                      HsHigherOrderApp False)
+                                       [mu AnnRarrowtail $2] }
         | 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
-                        { sLL $1 $> $ HsLam (mkMatchGroup FromSource [sLL $1 $> $ Match ($2:$3) $4
-                                                                (unguardedGRHSs $6)
-                                                              ]) }
-        | 'let' binds 'in' exp                  { sLL $1 $> $ HsLet (unLoc $2) $4 }
+                   {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource
+                            [sLL $1 $> $ Match { m_fixity = NonFunBindMatch
+                                               , m_pats = $2:$3
+                                               , m_type = snd $4
+                                               , m_grhss = unguardedGRHSs $6 }]))
+                          (mj AnnLam $1:mu 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)) }
         | '\\' 'lcase' altslist
-            { sLL $1 $> $ HsLamCase placeHolderType (mkMatchGroup FromSource (unLoc $3)) }
+            {% ams (sLL $1 $> $ HsLamCase placeHolderType
+                                   (mkMatchGroup FromSource (snd $ unLoc $3)))
+                   (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) }
         | 'if' exp optSemi 'then' exp optSemi 'else' exp
-                                        {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
-                                           return (sLL $1 $> $ mkHsIf $2 $5 $8) }
+                           {% checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >>
+                              ams (sLL $1 $> $ mkHsIf $2 $5 $8)
+                                  (mj AnnIf $1:mj AnnThen $4
+                                     :mj AnnElse $7
+                                     :(map (\l -> mj AnnSemi l) (fst $3))
+                                    ++(map (\l -> mj AnnSemi l) (fst $6))) }
         | 'if' ifgdpats                 {% hintMultiWayIf (getLoc $1) >>
-                                           return (sLL $1 $> $ HsMultiIf
-                                                      placeHolderType
-                                                      (reverse $ unLoc $2)) }
-        | 'case' exp 'of' altslist              { sLL $1 $> $ HsCase $2 (mkMatchGroup FromSource (unLoc $4)) }
-        | '-' fexp                              { sLL $1 $> $ NegApp $2 noSyntaxExpr }
-
-        | 'do' stmtlist                 { L (comb2 $1 $2) (mkHsDo DoExpr  (unLoc $2)) }
-        | 'mdo' stmtlist                { L (comb2 $1 $2) (mkHsDo MDoExpr (unLoc $2)) }
-
-        | scc_annot exp             {% do { on <- extension sccProfilingOn
-                                          ; return $ sLL $1 $> $ if on
-                                                          then HsSCC (unLoc $1) $2
-                                                          else HsPar $2 } }
-        | hpc_annot exp                         {% do { on <- extension hpcEnabled
-                                                      ; return $ sLL $1 $> $ if on
-                                                                      then HsTickPragma (unLoc $1) $2
-                                                                      else HsPar $2 } }
+                                           ams (sLL $1 $> $ HsMultiIf
+                                                     placeHolderType
+                                                     (reverse $ snd $ unLoc $2))
+                                               (mj AnnIf $1:(fst $ unLoc $2)) }
+        | 'case' exp 'of' altslist      {% ams (sLL $1 $> $ HsCase $2 (mkMatchGroup
+                                                   FromSource (snd $ unLoc $4)))
+                                               (mj AnnCase $1:mj AnnOf $3
+                                                  :(fst $ unLoc $4)) }
+        | '-' fexp                      {% ams (sLL $1 $> $ NegApp $2 noSyntaxExpr)
+                                               [mj AnnMinus $1] }
+
+        | 'do' stmtlist              {% ams (L (comb2 $1 $2)
+                                               (mkHsDo DoExpr (snd $ unLoc $2)))
+                                               (mj AnnDo $1:(fst $ unLoc $2)) }
+        | 'mdo' stmtlist            {% ams (L (comb2 $1 $2)
+                                              (mkHsDo MDoExpr (snd $ unLoc $2)))
+                                           (mj AnnMdo $1:(fst $ unLoc $2)) }
+
+        | scc_annot exp        {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
+                                      (fst $ 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 ->
-                            checkCommand $4 >>= \ cmd ->
-                            return (sLL $1 $> $ HsProc p (sLL $1 $> $ HsCmdTop cmd placeHolderType
-                                                    placeHolderType [])) }
-                                                -- TODO: is sLL $1 $> right here?
-
-        | '{-# CORE' STRING '#-}' exp           { sLL $1 $> $ HsCoreAnn (getSTRING $2) $4 }
-                                                    -- hdaume: core annotation
-        | fexp                                  { $1 }
-
-        -- parsing error messages go below here
-        | '\\' apat apats opt_asig '->'              {% parseErrorSDoc (combineLocs $1 $5) $ text
-                                                        "parse error in lambda: no expression after '->'"
-                                                     }
-        | '\\'                                       {% parseErrorSDoc (getLoc $1) $ text
-                                                        "parse error: naked lambda expression '\'"
-                                                     }
-        | 'let' binds 'in'                           {% parseErrorSDoc (combineLocs $1 $2) $ text
-                                                        "parse error in let binding: missing expression after 'in'"
-                                                     }
-        | 'let' binds                                {% parseErrorSDoc (combineLocs $1 $2) $ text
-                                                        "parse error in let binding: missing required 'in'"
-                                                     }
-        | 'let'                                      {% parseErrorSDoc (getLoc $1) $ text
-                                                        "parse error: naked let binding"
-                                                     }
-        | 'if' exp optSemi 'then' exp optSemi 'else' {% hintIf (combineLocs $1 $5) "else clause empty" }
-        | 'if' exp optSemi 'then' exp optSemi        {% hintIf (combineLocs $1 $5) "missing required else clause" }
-        | 'if' exp optSemi 'then'                    {% hintIf (combineLocs $1 $2) "then clause empty" }
-        | 'if' exp optSemi                           {% hintIf (combineLocs $1 $2) "missing required then and else clauses" }
-        | 'if'                                       {% hintIf (getLoc $1) "naked if statement" }
-        | 'case' exp 'of'                            {% parseErrorSDoc (combineLocs $1 $2) $ text
-                                                        "parse error in case statement: missing list after '->'"
-                                                     }
-        | 'case' exp                                 {% parseErrorSDoc (combineLocs $1 $2) $ text
-                                                        "parse error in case statement: missing required 'of'"
-                                                     }
-        | 'case'                                     {% parseErrorSDoc (getLoc $1) $ text
-                                                        "parse error: naked case statement"
-                                                     }
-
-optSemi :: { Bool }
-        : ';'         { True }
-        | {- empty -} { False }
-
-scc_annot :: { Located FastString }
-        : '{-# SCC' STRING '#-}'                {% do scc <- getSCC $2; return $ sLL $1 $> scc }
-        | '{-# SCC' VARID  '#-}'                { sLL $1 $> (getVARID $2) }
-
-hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) }
-        : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
-                                                { sLL $1 $> $ (getSTRING $2
-                                                       ,( fromInteger $ getINTEGER $3
-                                                        , fromInteger $ getINTEGER $5
-                                                        )
-                                                       ,( fromInteger $ getINTEGER $7
-                                                        , fromInteger $ getINTEGER $9
-                                                        )
-                                                       )
-                                                 }
+                       {% checkPattern empty $2 >>= \ p ->
+                           checkCommand $4 >>= \ cmd ->
+                           ams (sLL $1 $> $ HsProc p (sLL $1 $> $ HsCmdTop cmd placeHolderType
+                                                placeHolderType []))
+                                            -- TODO: is LL right here?
+                               [mj AnnProc $1,mu AnnRarrow $3] }
+
+        | '{-# CORE' STRING '#-}' exp  {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getStringLiteral $2) $4)
+                                              [mo $1,mj AnnVal $2
+                                              ,mc $3] }
+                                          -- hdaume: core annotation
+        | fexp                         { $1 }
+
+optSemi :: { ([Located a],Bool) }
+        : ';'         { ([$1],True) }
+        | {- empty -} { ([],False) }
+
+scc_annot :: { Located (([AddAnn],SourceText),StringLiteral) }
+        : '{-# SCC' STRING '#-}'      {% do scc <- getSCC $2
+                                            ; return $ sLL $1 $>
+                                               (([mo $1,mj AnnValStr $2
+                                                ,mc $3],getSCC_PRAGs $1),(StringLiteral (getSTRINGs $2) scc)) }
+        | '{-# SCC' VARID  '#-}'      { sLL $1 $> (([mo $1,mj AnnVal $2
+                                         ,mc $3],getSCC_PRAGs $1)
+                                        ,(StringLiteral (unpackFS $ getVARID $2) (getVARID $2))) }
+
+hpc_annot :: { Located (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))) }
+      : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
+                                      { 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],
+                                                getGENERATED_PRAGs $1)
+                                              ,((getStringLiteral $2)
+                                               ,( fromInteger $ getINTEGER $3
+                                                , fromInteger $ getINTEGER $5
+                                                )
+                                               ,( fromInteger $ getINTEGER $7
+                                                , fromInteger $ getINTEGER $9
+                                                )
+                                               ))
+                                         }
 
 fexp    :: { LHsExpr RdrName }
         : fexp aexp                             { sLL $1 $> $ HsApp $1 $2 }
+        | 'static' aexp                         {% ams (sLL $1 $> $ HsStatic $2)
+                                                       [mj AnnStatic $1] }
         | aexp                                  { $1 }
 
 aexp    :: { LHsExpr RdrName }
-        : qvar '@' aexp                 { sLL $1 $> $ EAsPat $1 $3 }
-        | '~' aexp                      { sLL $1 $> $ ELazyPat $2 }
+        : qvar '@' aexp         {% ams (sLL $1 $> $ EAsPat $1 $3) [mj AnnAt $2] }
+        | '~' aexp              {% ams (sLL $1 $> $ ELazyPat $2) [mj AnnTilde $1] }
         | aexp1                 { $1 }
 
 aexp1   :: { LHsExpr RdrName }
-        : aexp1 '{' fbinds '}'  {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) $3
-                                      ; checkRecordSyntax (sLL $1 $> r) }}
-        | aexp2                 { $1 }
+        : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4)
+                                                                   (snd $3)
+                                     ; _ <- ams (sLL $1 $> ()) (moc $2:mcc $4:(fst $3))
+                                     ; checkRecordSyntax (sLL $1 $> r) }}
+        | aexp2                { $1 }
 
 aexp2   :: { LHsExpr RdrName }
-        : ipvar                         { sL1 $1 (HsIPVar $! unLoc $1) }
-        | qcname                        { sL1 $1 (HsVar   $! unLoc $1) }
+        : qvar                          { sL1 $1 (HsVar   $! $1) }
+        | qcon                          { sL1 $1 (HsVar   $! $1) }
+        | ipvar                         { sL1 $1 (HsIPVar $! unLoc $1) }
+        | overloaded_label              { sL1 $1 (HsOverLabel $! unLoc $1) }
         | literal                       { sL1 $1 (HsLit   $! unLoc $1) }
 -- This will enable overloaded strings permanently.  Normally the renamer turns HsString
 -- into HsOverLit when -foverloaded-strings is on.
---      | STRING     { sL (getLoc $1) (HsOverLit $! mkHsIsString
---                                        (getSTRING $1) placeHolderType) }
-        | INTEGER    { sL (getLoc $1) (HsOverLit $! mkHsIntegral
-                                          (getINTEGER $1) placeHolderType) }
-        | RATIONAL   { sL (getLoc $1) (HsOverLit $! mkHsFractional
+--      | STRING    { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1)
+--                                       (getSTRING $1) placeHolderType) }
+        | INTEGER   { sL (getLoc $1) (HsOverLit $! mkHsIntegral (getINTEGERs $1)
+                                         (getINTEGER $1) placeHolderType) }
+        | RATIONAL  { sL (getLoc $1) (HsOverLit $! mkHsFractional
                                           (getRATIONAL $1) placeHolderType) }
 
         -- N.B.: sections get parsed by these next two productions.
         -- 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 ')'                  { sLL $1 $> (HsPar $2) }
-        | '(' tup_exprs ')'             { sLL $1 $> (ExplicitTuple $2 Boxed) }
+        | '(' texp ')'                  {% ams (sLL $1 $> (HsPar $2)) [mop $1,mcp $3] }
+        | '(' tup_exprs ')'             {% ams (sLL $1 $> (ExplicitTuple $2 Boxed))
+                                               [mop $1,mcp $3] }
 
-        | '(#' texp '#)'                { sLL $1 $> (ExplicitTuple [Present $2] Unboxed) }
-        | '(#' tup_exprs '#)'           { sLL $1 $> (ExplicitTuple $2 Unboxed) }
+        | '(#' texp '#)'                {% ams (sLL $1 $> (ExplicitTuple [L (gl $2)
+                                                         (Present $2)] Unboxed))
+                                               [mo $1,mc $3] }
+        | '(#' tup_exprs '#)'           {% ams (sLL $1 $> (ExplicitTuple $2 Unboxed))
+                                               [mo $1,mc $3] }
 
-        | '[' list ']'                  { sLL $1 $> (unLoc $2) }
-        | '[:' parr ':]'                { sLL $1 $> (unLoc $2) }
-        | '_'                           { sL1 $1 EWildPat }
+        | '[' 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 }
 
         -- Template Haskell Extension
         | splice_exp            { $1 }
 
-        | SIMPLEQUOTE  qvar     { sLL $1 $> $ HsBracket (VarBr True  (unLoc $2)) }
-        | SIMPLEQUOTE  qcon     { sLL $1 $> $ HsBracket (VarBr True  (unLoc $2)) }
-        | TH_TY_QUOTE tyvar     { sLL $1 $> $ HsBracket (VarBr False (unLoc $2)) }
-        | TH_TY_QUOTE gtycon    { sLL $1 $> $ HsBracket (VarBr False (unLoc $2)) }
-        | '[|' exp '|]'         { sLL $1 $> $ HsBracket (ExpBr $2) }
-        | '[||' exp '||]'       { sLL $1 $> $ HsBracket (TExpBr $2) }
-        | '[t|' ctype '|]'      { sLL $1 $> $ HsBracket (TypBr $2) }
-        | '[p|' infixexp '|]'   {% checkPattern empty $2 >>= \p ->
-                                        return (sLL $1 $> $ HsBracket (PatBr p)) }
-        | '[d|' cvtopbody '|]'  { sLL $1 $> $ HsBracket (DecBrL $2) }
-        | quasiquote            { sL1 $1 (HsQuasiQuoteE (unLoc $1)) }
+        | SIMPLEQUOTE  qvar     {% ams (sLL $1 $> $ HsBracket (VarBr True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
+        | SIMPLEQUOTE  qcon     {% ams (sLL $1 $> $ HsBracket (VarBr True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
+        | TH_TY_QUOTE tyvar     {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
+        | TH_TY_QUOTE gtycon    {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
+        | '[|' exp '|]'       {% ams (sLL $1 $> $ HsBracket (ExpBr $2))
+                                      (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }
+        | '[||' exp '||]'     {% ams (sLL $1 $> $ HsBracket (TExpBr $2))
+                                      (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }
+        | '[t|' ctype '|]'    {% ams (sLL $1 $> $ HsBracket (TypBr $2)) [mo $1,mc $3] }
+        | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p ->
+                                      ams (sLL $1 $> $ HsBracket (PatBr p))
+                                          [mo $1,mc $3] }
+        | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket (DecBrL (snd $2)))
+                                      (mo $1:mc $3:fst $2) }
+        | quasiquote          { sL1 $1 (HsSpliceE (unLoc $1)) }
 
         -- arrow notation extension
-        | '(|' aexp2 cmdargs '|)'       { sLL $1 $> $ HsArrForm $2 Nothing (reverse $3) }
+        | '(|' aexp2 cmdargs '|)'  {% ams (sLL $1 $> $ HsArrForm $2
+                                                           Nothing (reverse $3))
+                                          [mo $1,mc $4] }
 
 splice_exp :: { LHsExpr RdrName }
-        : TH_ID_SPLICE          { sL1 $1 $ mkHsSpliceE
-                                        (sL1 $1 $ HsVar (mkUnqual varName
-                                                        (getTH_ID_SPLICE $1))) }
-        | '$(' exp ')'          { sLL $1 $> $ mkHsSpliceE $2 }
-        | TH_ID_TY_SPLICE       { sL1 $1 $ mkHsSpliceTE
-                                        (sL1 $1 $ HsVar (mkUnqual varName
-                                                        (getTH_ID_TY_SPLICE $1))) }
-        | '$$(' exp ')'         { sLL $1 $> $ mkHsSpliceTE $2 }
+        : TH_ID_SPLICE          {% ams (sL1 $1 $ mkHsSpliceE
+                                        (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName
+                                                           (getTH_ID_SPLICE $1)))))
+                                       [mj AnnThIdSplice $1] }
+        | '$(' exp ')'          {% ams (sLL $1 $> $ mkHsSpliceE $2)
+                                       [mj AnnOpenPE $1,mj AnnCloseP $3] }
+        | TH_ID_TY_SPLICE       {% ams (sL1 $1 $ mkHsSpliceTE
+                                        (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName
+                                                        (getTH_ID_TY_SPLICE $1)))))
+                                       [mj AnnThIdTySplice $1] }
+        | '$$(' exp ')'         {% ams (sLL $1 $> $ mkHsSpliceTE $2)
+                                       [mj AnnOpenPTE $1,mj AnnCloseP $3] }
 
 cmdargs :: { [LHsCmdTop RdrName] }
         : cmdargs acmd                  { $2 : $1 }
@@ -1737,9 +2350,10 @@ acmd    :: { LHsCmdTop RdrName }
                                     return (sL1 $1 $ HsCmdTop cmd
                                            placeHolderType placeHolderType []) }
 
-cvtopbody :: { [LHsDecl RdrName] }
-        :  '{'            cvtopdecls0 '}'               { $2 }
-        |      vocurly    cvtopdecls0 close             { $2 }
+cvtopbody :: { ([AddAnn],[LHsDecl RdrName]) }
+        :  '{'            cvtopdecls0 '}'      { ([mj AnnOpenC $1
+                                                  ,mj AnnCloseC $3],$2) }
+        |      vocurly    cvtopdecls0 close    { ([],$2) }
 
 cvtopdecls0 :: { [LHsDecl RdrName] }
         : {- empty -}           { [] }
@@ -1769,45 +2383,65 @@ texp :: { LHsExpr RdrName }
         | qopm infixexp       { sLL $1 $> $ SectionR $1 $2 }
 
        -- View patterns get parenthesized above
-        | exp '->' texp   { sLL $1 $> $ EViewPat $1 $3 }
+        | exp '->' texp   {% ams (sLL $1 $> $ EViewPat $1 $3) [mu AnnRarrow $2] }
 
 -- Always at least one comma
-tup_exprs :: { [HsTupArg RdrName] }
-           : texp commas_tup_tail  { Present $1 : $2 }
-           | commas tup_tail       { replicate $1 missingTupArg ++ $2 }
+tup_exprs :: { [LHsTupArg RdrName] }
+           : texp commas_tup_tail
+                          {% do { addAnnotation (gl $1) AnnComma (fst $2)
+                                ; return ((sL1 $1 (Present $1)) : snd $2) } }
+
+           | commas tup_tail
+                {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1)
+                      ; return
+                           (map (\l -> L l missingTupArg) (fst $1) ++ $2) } }
 
 -- Always starts with commas; always follows an expr
-commas_tup_tail :: { [HsTupArg RdrName] }
-commas_tup_tail : commas tup_tail  { replicate ($1-1) missingTupArg ++ $2 }
+commas_tup_tail :: { (SrcSpan,[LHsTupArg RdrName]) }
+commas_tup_tail : commas tup_tail
+       {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1)
+             ; return (
+            (head $ fst $1
+            ,(map (\l -> L l missingTupArg) (tail $ fst $1)) ++ $2)) } }
 
 -- Always follows a comma
-tup_tail :: { [HsTupArg RdrName] }
-          : texp commas_tup_tail        { Present $1 : $2 }
-          | texp                        { [Present $1] }
-          | {- empty -}                 { [missingTupArg] }
+tup_tail :: { [LHsTupArg RdrName] }
+          : texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >>
+                                    return ((L (gl $1) (Present $1)) : snd $2) }
+          | texp                 { [L (gl $1) (Present $1)] }
+          | {- empty -}          { [noLoc missingTupArg] }
 
 -----------------------------------------------------------------------------
 -- List expressions
 
 -- The rules below are little bit contorted to keep lexps left-recursive while
 -- avoiding another shift/reduce-conflict.
-
-list :: { LHsExpr RdrName }
-        : texp    { sL1 $1 $ ExplicitList placeHolderType Nothing [$1] }
-        | lexps   { sL1 $1 $ ExplicitList placeHolderType Nothing
-                                                   (reverse (unLoc $1)) }
-        | texp '..'             { sLL $1 $> $ ArithSeq noPostTcExpr Nothing (From $1) }
-        | texp ',' exp '..'     { sLL $1 $> $ ArithSeq noPostTcExpr Nothing (FromThen $1 $3) }
-        | texp '..' exp         { sLL $1 $> $ ArithSeq noPostTcExpr Nothing (FromTo $1 $3) }
-        | texp ',' exp '..' exp { sLL $1 $> $ ArithSeq noPostTcExpr Nothing (FromThenTo $1 $3 $5) }
+list :: { ([AddAnn],HsExpr RdrName) }
+        : texp    { ([],ExplicitList placeHolderType Nothing [$1]) }
+        | lexps   { ([],ExplicitList placeHolderType Nothing
+                                                   (reverse (unLoc $1))) }
+        | texp '..'             { ([mj AnnDotdot $2],
+                                      ArithSeq noPostTcExpr Nothing (From $1)) }
+        | texp ',' exp '..'     { ([mj AnnComma $2,mj AnnDotdot $4],
+                                  ArithSeq noPostTcExpr Nothing
+                                                             (FromThen $1 $3)) }
+        | texp '..' exp         { ([mj AnnDotdot $2],
+                                   ArithSeq noPostTcExpr Nothing
+                                                               (FromTo $1 $3)) }
+        | texp ',' exp '..' exp { ([mj AnnComma $2,mj AnnDotdot $4],
+                                    ArithSeq noPostTcExpr Nothing
+                                                (FromThenTo $1 $3 $5)) }
         | texp '|' flattenedpquals
              {% checkMonadComp >>= \ ctxt ->
-                return (sL (comb2 $1 $>) $
+                return ([mj AnnVbar $2],
                         mkHsComp ctxt (unLoc $3) $1) }
 
 lexps :: { Located [LHsExpr RdrName] }
-        : lexps ',' texp                { sLL $1 $> (((:) $! $3) $! unLoc $1) }
-        | texp ',' texp                 { sLL $1 $> [$3,$1] }
+        : lexps ',' texp          {% addAnnotation (gl $ head $ unLoc $1)
+                                                            AnnComma (gl $2) >>
+                                      return (sLL $1 $> (((:) $! $3) $! unLoc $1)) }
+        | texp ',' texp            {% addAnnotation (gl $1) AnnComma (gl $2) >>
+                                      return (sLL $1 $> [$3,$1]) }
 
 -----------------------------------------------------------------------------
 -- List Comprehensions
@@ -1826,30 +2460,40 @@ flattenedpquals :: { Located [LStmt RdrName (LHsExpr RdrName)] }
                 }
 
 pquals :: { Located [[LStmt RdrName (LHsExpr RdrName)]] }
-    : squals '|' pquals     { L (getLoc $2) (reverse (unLoc $1) : unLoc $3) }
-    | squals                { L (getLoc $1) [reverse (unLoc $1)] }
+    : squals '|' pquals
+                     {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) >>
+                        return (sLL $1 $> (reverse (unLoc $1) : unLoc $3)) }
+    | squals         { L (getLoc $1) [reverse (unLoc $1)] }
 
 squals :: { Located [LStmt RdrName (LHsExpr RdrName)] }   -- In reverse order, because the last
                                         -- one can "grab" the earlier ones
-    : squals ',' transformqual               { sLL $1 $> [L (getLoc $3) ((unLoc $3) (reverse (unLoc $1)))] }
-    | squals ',' qual                        { sLL $1 $> ($3 : unLoc $1) }
-    | transformqual                          { sLL $1 $> [L (getLoc $1) ((unLoc $1) [])] }
-    | qual                                   { sL1 $1 [$1] }
+    : squals ',' transformqual
+             {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
+                ams (sLL $1 $> ()) (fst $ unLoc $3) >>
+                return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) }
+    | squals ',' qual
+             {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
+                return (sLL $1 $> ($3 : unLoc $1)) }
+    | transformqual        {% ams $1 (fst $ unLoc $1) >>
+                              return (sLL $1 $> [L (getLoc $1) ((snd $ unLoc $1) [])]) }
+    | qual                                { sL1 $1 [$1] }
 --  | transformquals1 ',' '{|' pquals '|}'   { sLL $1 $> ($4 : unLoc $1) }
 --  | '{|' pquals '|}'                       { sL1 $1 [$2] }
 
-
 -- It is possible to enable bracketing (associating) qualifier lists
 -- by uncommenting the lines with {| |} above. Due to a lack of
 -- consensus on the syntax, this feature is not being used until we
 -- get user demand.
 
-transformqual :: { Located ([LStmt RdrName (LHsExpr RdrName)] -> Stmt RdrName (LHsExpr RdrName)) }
+transformqual :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)] -> Stmt RdrName (LHsExpr RdrName)) }
                         -- Function is applied to a list of stmts *in order*
-    : 'then' exp                           { sLL $1 $> $ \ss -> (mkTransformStmt    ss $2)    }
-    | 'then' exp 'by' exp                  { sLL $1 $> $ \ss -> (mkTransformByStmt  ss $2 $4) }
-    | 'then' 'group' 'using' exp           { sLL $1 $> $ \ss -> (mkGroupUsingStmt   ss $4)    }
-    | 'then' 'group' 'by' exp 'using' exp  { sLL $1 $> $ \ss -> (mkGroupByUsingStmt ss $4 $6) }
+    : 'then' exp               { sLL $1 $> ([mj AnnThen $1], \ss -> (mkTransformStmt ss $2)) }
+    | 'then' exp 'by' exp      { sLL $1 $> ([mj AnnThen $1,mj AnnBy  $3],\ss -> (mkTransformByStmt ss $2 $4)) }
+    | 'then' 'group' 'using' exp
+             { sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3], \ss -> (mkGroupUsingStmt ss $4)) }
+
+    | 'then' 'group' 'by' exp 'using' exp
+             { sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5], \ss -> (mkGroupByUsingStmt ss $4 $6)) }
 
 -- Note that 'group' is a special_id, which means that you can enable
 -- TransformListComp while still using Data.List.group. However, this
@@ -1864,14 +2508,18 @@ transformqual :: { Located ([LStmt RdrName (LHsExpr RdrName)] -> Stmt RdrName (L
 -- Moreover, we allow explicit arrays with no element (represented by the nil
 -- constructor in the list case).
 
-parr :: { LHsExpr RdrName }
-        :                               { noLoc (ExplicitPArr placeHolderType []) }
-        | texp                          { sL1 $1 $ ExplicitPArr placeHolderType [$1] }
-        | lexps                         { sL1 $1 $ ExplicitPArr placeHolderType
-                                                       (reverse (unLoc $1)) }
-        | texp '..' exp                 { sLL $1 $> $ PArrSeq noPostTcExpr (FromTo $1 $3) }
-        | texp ',' exp '..' exp         { sLL $1 $> $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
-        | texp '|' flattenedpquals      { sLL $1 $> $ mkHsComp PArrComp (unLoc $3) $1 }
+parr :: { ([AddAnn],HsExpr RdrName) }
+        :                      { ([],ExplicitPArr placeHolderType []) }
+        | texp                 { ([],ExplicitPArr placeHolderType [$1]) }
+        | lexps                { ([],ExplicitPArr placeHolderType
+                                                          (reverse (unLoc $1))) }
+        | texp '..' exp        { ([mj AnnDotdot $2]
+                                 ,PArrSeq noPostTcExpr (FromTo $1 $3)) }
+        | texp ',' exp '..' exp
+                        { ([mj AnnComma $2,mj AnnDotdot $4]
+                          ,PArrSeq noPostTcExpr (FromThenTo $1 $3 $5)) }
+        | texp '|' flattenedpquals
+                        { ([mj AnnVbar $2],mkHsComp PArrComp (unLoc $3) $1) }
 
 -- We are reusing `lexps' and `flattenedpquals' from the list case.
 
@@ -1882,36 +2530,57 @@ guardquals :: { Located [LStmt RdrName (LHsExpr RdrName)] }
     : guardquals1           { L (getLoc $1) (reverse (unLoc $1)) }
 
 guardquals1 :: { Located [LStmt RdrName (LHsExpr RdrName)] }
-    : guardquals1 ',' qual  { sLL $1 $> ($3 : unLoc $1) }
+    : guardquals1 ',' qual  {% addAnnotation (gl $ head $ unLoc $1) AnnComma
+                                             (gl $2) >>
+                               return (sLL $1 $> ($3 : unLoc $1)) }
     | qual                  { sL1 $1 [$1] }
 
 -----------------------------------------------------------------------------
 -- Case alternatives
 
-altslist :: { Located [LMatch RdrName (LHsExpr RdrName)] }
-        : '{'            alts '}'       { sLL $1 $> (reverse (unLoc $2)) }
-        |     vocurly    alts  close    { L (getLoc $2) (reverse (unLoc $2)) }
-        | '{'                 '}'       { noLoc [] }
-        |     vocurly          close    { noLoc [] }
-
-alts    :: { Located [LMatch RdrName (LHsExpr RdrName)] }
-        : alts1                         { sL1 $1 (unLoc $1) }
-        | ';' alts                      { sLL $1 $> (unLoc $2) }
-
-alts1   :: { Located [LMatch RdrName (LHsExpr RdrName)] }
-        : alts1 ';' alt                 { sLL $1 $> ($3 : unLoc $1) }
-        | alts1 ';'                     { sLL $1 $> (unLoc $1) }
-        | alt                           { sL1 $1 [$1] }
+altslist :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) }
+        : '{'            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 ([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] $2 (unLoc $3)) }
+        : pat opt_asig alt_rhs  {%ams (sLL $1 $> (Match { m_fixity = NonFunBindMatch
+                                                        , m_pats = [$1]
+                                                        , m_type = snd $2
+                                                        , m_grhss = snd $ unLoc $3 }))
+                                      (fst $2 ++ (fst $ unLoc $3))}
 
-alt_rhs :: { Located (GRHSs RdrName (LHsExpr RdrName)) }
-        : ralt wherebinds               { sLL $1 $> (GRHSs (unLoc $1) (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                      { sLL $1 $> (unguardedRHS $2) }
-        | gdpats                        { sL1 $1 (reverse (unLoc $1)) }
+        : '->' exp            {% ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2))
+                                     [mu AnnRarrow $1] }
+        | gdpats              { sL1 $1 (reverse (unLoc $1)) }
 
 gdpats :: { Located [LGRHS RdrName (LHsExpr RdrName)] }
         : gdpats gdpat                  { sLL $1 $> ($2 : unLoc $1) }
@@ -1920,34 +2589,47 @@ gdpats :: { Located [LGRHS RdrName (LHsExpr RdrName)] }
 -- optional semi-colons between the guards of a MultiWayIf, because we use
 -- layout here, but we don't need (or want) the semicolon as a separator (#7783).
 gdpatssemi :: { Located [LGRHS RdrName (LHsExpr RdrName)] }
-        : gdpatssemi gdpat optSemi      { sL (comb2 $1 $2) ($2 : unLoc $1) }
-        | gdpat optSemi                 { sL1 $1 [$1] }
+        : gdpatssemi gdpat optSemi  {% ams (sL (comb2 $1 $2) ($2 : unLoc $1))
+                                           (map (\l -> mj AnnSemi l) $ fst $3) }
+        | gdpat optSemi             {% ams (sL1 $1 [$1])
+                                           (map (\l -> mj AnnSemi l) $ fst $2) }
 
 -- layout for MultiWayIf doesn't begin with an open brace, because it's hard to
 -- generate the open brace in addition to the vertical bar in the lexer, and
 -- we don't need it.
-ifgdpats :: { Located [LGRHS RdrName (LHsExpr RdrName)] }
-         : '{' gdpatssemi '}'              { sLL $1 $> (unLoc $2) }
-         |     gdpatssemi close            { $1 }
+ifgdpats :: { Located ([AddAnn],[LGRHS RdrName (LHsExpr RdrName)]) }
+         : '{' gdpatssemi '}'             { sLL $1 $> ([moc $1,mcc $3],unLoc $2)  }
+         |     gdpatssemi close           { sL1 $1 ([],unLoc $1) }
 
 gdpat   :: { LGRHS RdrName (LHsExpr RdrName) }
-        : '|' guardquals '->' exp               { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 }
+        : '|' guardquals '->' exp
+                                  {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4)
+                                         [mj AnnVbar $1,mu AnnRarrow $3] }
 
 -- 'pat' recognises a pattern, including one with a bang at the top
 --      e.g.  "!x" or "!(x,y)" or "C a b" etc
 -- Bangs inside are parsed as infix operator applications, so that
 -- we parse them right when bang-patterns are off
 pat     :: { LPat RdrName }
-pat     :  exp                  {% checkPattern empty $1 }
-        | '!' aexp              {% checkPattern empty (sLL $1 $> (SectionR (sL1 $1 (HsVar bang_RDR)) $2)) }
+pat     :  exp          {% checkPattern empty $1 }
+        | '!' aexp      {% amms (checkPattern empty (sLL $1 $> (SectionR
+                                                     (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))
+                                [mj AnnBang $1] }
 
 bindpat :: { LPat RdrName }
-bindpat :  exp                  {% checkPattern (text "Possibly caused by a missing 'do'?") $1 }
-        | '!' aexp              {% checkPattern (text "Possibly caused by a missing 'do'?") (sLL $1 $> (SectionR (sL1 $1 (HsVar bang_RDR)) $2)) }
+bindpat :  exp            {% checkPattern
+                                (text "Possibly caused by a missing 'do'?") $1 }
+        | '!' aexp        {% amms (checkPattern
+                                     (text "Possibly caused by a missing 'do'?")
+                                     (sLL $1 $> (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))
+                                  [mj AnnBang $1] }
 
 apat   :: { LPat RdrName }
 apat    : aexp                  {% checkPattern empty $1 }
-        | '!' aexp              {% checkPattern empty (sLL $1 $> (SectionR (sL1 $1 (HsVar bang_RDR)) $2)) }
+        | '!' aexp              {% amms (checkPattern empty
+                                            (sLL $1 $> (SectionR
+                                                (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))
+                                        [mj AnnBang $1] }
 
 apats  :: { [LPat RdrName] }
         : apat apats            { $1 : $2 }
@@ -1956,23 +2638,35 @@ apats  :: { [LPat RdrName] }
 -----------------------------------------------------------------------------
 -- Statement sequences
 
-stmtlist :: { Located [LStmt RdrName (LHsExpr RdrName)] }
-        : '{'           stmts '}'       { sLL $1 $> (unLoc $2) }
-        |     vocurly   stmts close     { $2 }
+stmtlist :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) }
+        : '{'           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
+                                                    ,reverse $ snd $ unLoc $2) }
 
 --      do { ;; s ; s ; ; s ;; }
 -- The last Stmt should be an expression, but that's hard to enforce
 -- here, because we need too much lookahead if we see do { e ; }
 -- So we use BodyStmts throughout, and switch the last one over
 -- in ParseUtils.checkDo instead
-stmts :: { Located [LStmt RdrName (LHsExpr RdrName)] }
-        : stmt stmts_help               { sLL $1 $> ($1 : unLoc $2) }
-        | ';' stmts                     { sLL $1 $> (unLoc $2) }
-        | {- empty -}                   { noLoc [] }
 
-stmts_help :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- might be empty
-        : ';' stmts                     { sLL $1 $> (unLoc $2) }
-        | {- empty -}                   { noLoc [] }
+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 ([],[]) }
+
 
 -- For typing stmts at the GHCi prompt, where
 -- the input may consist of just comments.
@@ -1982,32 +2676,38 @@ maybe_stmt :: { Maybe (LStmt RdrName (LHsExpr RdrName)) }
 
 stmt  :: { LStmt RdrName (LHsExpr RdrName) }
         : qual                          { $1 }
-        | 'rec' stmtlist                { sLL $1 $> $ mkRecStmt (unLoc $2) }
+        | 'rec' stmtlist                {% ams (sLL $1 $> $ mkRecStmt (snd $ unLoc $2))
+                                               (mj AnnRec $1:(fst $ unLoc $2)) }
 
 qual  :: { LStmt RdrName (LHsExpr RdrName) }
-    : bindpat '<-' exp                  { sLL $1 $> $ mkBindStmt $1 $3 }
+    : bindpat '<-' exp                  {% ams (sLL $1 $> $ mkBindStmt $1 $3)
+                                               [mu AnnLarrow $2] }
     | exp                               { sL1 $1 $ mkBodyStmt $1 }
-    | 'let' binds                       { sLL $1 $> $ LetStmt (unLoc $2) }
+    | 'let' binds                       {% ams (sLL $1 $>$ LetStmt (snd $ unLoc $2))
+                                               (mj AnnLet $1:(fst $ unLoc $2)) }
 
 -----------------------------------------------------------------------------
 -- Record Field Update/Construction
 
-fbinds  :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) }
+fbinds  :: { ([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool)) }
         : fbinds1                       { $1 }
-        | {- empty -}                   { ([], False) }
-
-fbinds1 :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) }
-        : fbind ',' fbinds1             { case $3 of (flds, dd) -> ($1 : flds, dd) }
-        | fbind                         { ([$1], False) }
-        | '..'                          { ([],   True) }
-
-fbind   :: { HsRecField RdrName (LHsExpr RdrName) }
-        : qvar '=' texp { HsRecField $1 $3                False }
+        | {- empty -}                   { ([],([], False)) }
+
+fbinds1 :: { ([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool)) }
+        : fbind ',' fbinds1
+                {% addAnnotation (gl $1) AnnComma (gl $2) >>
+                   return (case $3 of (ma,(flds, dd)) -> (ma,($1 : flds, dd))) }
+        | fbind                         { ([],([$1], False)) }
+        | '..'                          { ([mj AnnDotdot $1],([],   True)) }
+
+fbind   :: { LHsRecField RdrName (LHsExpr RdrName) }
+        : qvar '=' texp {% ams  (sLL $1 $> $ HsRecField (fmap mkFieldOcc $1) $3 False)
+                                [mj AnnEqual $2] }
                         -- RHS is a 'texp', allowing view patterns (Trac #6038)
                         -- and, incidentaly, sections.  Eg
                         -- f (R { x = show -> s }) = ...
 
-        | qvar          { HsRecField $1 placeHolderPunRhs True }
+        | qvar          { sLL $1 $> $ HsRecField (fmap mkFieldOcc $1) placeHolderPunRhs True }
                         -- In the punning case, use a place-holder
                         -- The renamer fills in the final value
 
@@ -2015,40 +2715,54 @@ fbind   :: { HsRecField RdrName (LHsExpr RdrName) }
 -- Implicit Parameter Bindings
 
 dbinds  :: { Located [LIPBind RdrName] }
-        : dbinds ';' dbind              { let { this = $3; rest = unLoc $1 }
-                              in rest `seq` this `seq` sLL $1 $> (this : rest) }
-        | dbinds ';'                    { sLL $1 $> (unLoc $1) }
-        | dbind                         { let this = $1 in this `seq` sL1 $1 [this] }
---      | {- empty -}                   { [] }
+        : dbinds ';' dbind
+                      {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >>
+                         return (let { this = $3; rest = unLoc $1 }
+                              in rest `seq` this `seq` sLL $1 $> (this : rest)) }
+        | dbinds ';'  {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >>
+                         return (sLL $1 $> (unLoc $1)) }
+        | dbind                        { let this = $1 in this `seq` sL1 $1 [this] }
+--      | {- empty -}                  { [] }
 
 dbind   :: { LIPBind RdrName }
-dbind   : ipvar '=' exp                 { sLL $1 $> (IPBind (Left (unLoc $1)) $3) }
+dbind   : ipvar '=' exp                {% ams (sLL $1 $> (IPBind (Left $1) $3))
+                                              [mj AnnEqual $2] }
 
 ipvar   :: { Located HsIPName }
         : IPDUPVARID            { sL1 $1 (HsIPName (getIPDUPVARID $1)) }
 
 -----------------------------------------------------------------------------
+-- Overloaded labels
+
+overloaded_label :: { Located FastString }
+        : LABELVARID          { sL1 $1 (getLABELVARID $1) }
+
+-----------------------------------------------------------------------------
 -- Warnings and deprecations
 
-name_boolformula_opt :: { BooleanFormula (Located RdrName) }
+name_boolformula_opt :: { LBooleanFormula (Located RdrName) }
         : name_boolformula          { $1 }
-        | {- empty -}               { mkTrue }
+        | {- empty -}               { noLoc mkTrue }
 
-name_boolformula :: { BooleanFormula (Located RdrName) }
+name_boolformula :: { LBooleanFormula (Located RdrName) }
         : name_boolformula_and                      { $1 }
-        | name_boolformula_and '|' name_boolformula { mkOr [$1,$3] }
+        | name_boolformula_and '|' name_boolformula
+                           {% aa $1 (AnnVbar, $2)
+                              >> return (sLL $1 $> (Or [$1,$3])) }
 
-name_boolformula_and :: { BooleanFormula (Located RdrName) }
+name_boolformula_and :: { LBooleanFormula (Located RdrName) }
         : name_boolformula_atom                             { $1 }
-        | name_boolformula_atom ',' name_boolformula_and    { mkAnd [$1,$3] }
+        | name_boolformula_atom ',' name_boolformula_and
+                  {% aa $1 (AnnComma,$2) >> return (sLL $1 $> (And [$1,$3])) }
 
-name_boolformula_atom :: { BooleanFormula (Located RdrName) }
-        : '(' name_boolformula ')'  { $2 }
-        | name_var                  { mkVar $1 }
+name_boolformula_atom :: { LBooleanFormula (Located RdrName) }
+        : '(' name_boolformula ')'  {% ams (sLL $1 $> (Parens $2)) [mop $1,mcp $3] }
+        | name_var                  { sL1 $1 (Var $1) }
 
-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 }
@@ -2056,35 +2770,58 @@ name_var : var { $1 }
 
 -----------------------------------------
 -- Data constructors
-qcon    :: { Located RdrName }
-        : qconid                { $1 }
-        | '(' qconsym ')'       { sLL $1 $> (unLoc $2) }
-        | sysdcon               { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
+-- There are two different productions here as lifted list constructors
+-- are parsed differently.
+
+qcon_nowiredlist :: { Located RdrName }
+        : gen_qcon                     { $1 }
+        | sysdcon_nolist               { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
+
+qcon :: { Located RdrName }
+  : gen_qcon              { $1}
+  | sysdcon               { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
+
+gen_qcon :: { Located RdrName }
+  : qconid                { $1 }
+  | '(' qconsym ')'       {% ams (sLL $1 $> (unLoc $2))
+                                   [mop $1,mj AnnVal $2,mcp $3] }
+
 -- The case of '[:' ':]' is part of the production `parr'
 
 con     :: { Located RdrName }
         : conid                 { $1 }
-        | '(' consym ')'        { sLL $1 $> (unLoc $2) }
+        | '(' 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     { sLL $1 $> ($1 : unLoc $3) }
+         | con ',' con_list     {% addAnnotation (gl $1) AnnComma (gl $2) >>
+                                   return (sLL $1 $> ($1 : unLoc $3)) }
+
+sysdcon_nolist :: { Located DataCon }  -- Wired in data constructors
+        : '(' ')'               {% ams (sLL $1 $> unitDataCon) [mop $1,mcp $2] }
+        | '(' commas ')'        {% ams (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1))
+                                       (mop $1:mcp $3:(mcommas (fst $2))) }
+        | '(#' '#)'             {% ams (sLL $1 $> $ unboxedUnitDataCon) [mo $1,mc $2] }
+        | '(#' commas '#)'      {% ams (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1))
+                                       (mo $1:mc $3:(mcommas (fst $2))) }
 
-sysdcon :: { Located DataCon }  -- Wired in data constructors
-        : '(' ')'               { sLL $1 $> unitDataCon }
-        | '(' commas ')'        { sLL $1 $> $ tupleCon BoxedTuple ($2 + 1) }
-        | '(#' '#)'             { sLL $1 $> $ unboxedUnitDataCon }
-        | '(#' commas '#)'      { sLL $1 $> $ tupleCon UnboxedTuple ($2 + 1) }
-        | '[' ']'               { sLL $1 $> nilDataCon }
+sysdcon :: { Located DataCon }
+        : sysdcon_nolist                 { $1 }
+        | '[' ']'               {% ams (sLL $1 $> nilDataCon) [mos $1,mcs $2] }
 
 conop :: { Located RdrName }
         : consym                { $1 }
-        | '`' conid '`'         { sLL $1 $> (unLoc $2) }
+        | '`' conid '`'         {% ams (sLL $1 $> (unLoc $2))
+                                       [mj AnnBackquote $1,mj AnnVal $2
+                                       ,mj AnnBackquote $3] }
 
 qconop :: { Located RdrName }
         : qconsym               { $1 }
-        | '`' qconid '`'        { sLL $1 $> (unLoc $2) }
+        | '`' qconid '`'        {% ams (sLL $1 $> (unLoc $2))
+                                       [mj AnnBackquote $1,mj AnnVal $2
+                                       ,mj AnnBackquote $3] }
 
 ----------------------------------------------------------------------------
 -- Type constructors
@@ -2093,49 +2830,87 @@ qconop :: { Located RdrName }
 -- See Note [Unit tuples] in HsTypes for the distinction
 -- between gtycon and ntgtycon
 gtycon :: { Located RdrName }  -- A "general" qualified tycon, including unit tuples
-        : ntgtycon                      { $1 }
-        | '(' ')'                       { sLL $1 $> $ getRdrName unitTyCon }
-        | '(#' '#)'                     { sLL $1 $> $ getRdrName unboxedUnitTyCon }
+        : ntgtycon                     { $1 }
+        | '(' ')'                      {% ams (sLL $1 $> $ getRdrName unitTyCon)
+                                              [mop $1,mcp $2] }
+        | '(#' '#)'                    {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon)
+                                              [mo $1,mc $2] }
 
 ntgtycon :: { Located RdrName }  -- A "general" qualified tycon, excluding unit tuples
-        : oqtycon                       { $1 }
-        | '(' commas ')'                { sLL $1 $> $ getRdrName (tupleTyCon BoxedTuple ($2 + 1)) }
-        | '(#' commas '#)'              { sLL $1 $> $ getRdrName (tupleTyCon UnboxedTuple ($2 + 1)) }
-        | '(' '->' ')'                  { sLL $1 $> $ getRdrName funTyCon }
-        | '[' ']'                       { sLL $1 $> $ listTyCon_RDR }
-        | '[:' ':]'                     { sLL $1 $> $ parrTyCon_RDR }
-        | '(' '~#' ')'                  { sLL $1 $> $ getRdrName eqPrimTyCon }
+        : oqtycon               { $1 }
+        | '(' commas ')'        {% ams (sLL $1 $> $ getRdrName (tupleTyCon Boxed
+                                                        (snd $2 + 1)))
+                                       (mop $1:mcp $3:(mcommas (fst $2))) }
+        | '(#' commas '#)'      {% ams (sLL $1 $> $ getRdrName (tupleTyCon Unboxed
+                                                        (snd $2 + 1)))
+                                       (mo $1:mc $3:(mcommas (fst $2))) }
+        | '(' '->' ')'          {% ams (sLL $1 $> $ getRdrName funTyCon)
+                                       [mop $1,mu 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)
+                                        [mop $1,mj AnnTildehsh $2,mcp $3] }
 
 oqtycon :: { Located RdrName }  -- An "ordinary" qualified tycon;
                                 -- These can appear in export lists
         : qtycon                        { $1 }
-        | '(' qtyconsym ')'             { sLL $1 $> (unLoc $2) }
-        | '(' '~' ')'                   { sLL $1 $> $ eqTyCon_RDR }
+        | '(' qtyconsym ')'             {% ams (sLL $1 $> (unLoc $2))
+                                               [mop $1,mj AnnVal $2,mcp $3] }
+        | '(' '~' ')'                   {% ams (sLL $1 $> $ eqTyCon_RDR)
+                                               [mop $1,mj AnnTilde $2,mcp $3] }
+
+oqtycon_no_varcon :: { Located RdrName }  -- Type constructor which cannot be mistaken
+                                          -- for variable constructor in export lists
+                                          -- see Note [Type constructors in export list]
+        :  qtycon            { $1 }
+        | '(' QCONSYM ')'    {% let name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2)
+                                in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }
+        | '(' CONSYM ')'     {% let name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2)
+                                in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }
+        | '(' ':' ')'        {% let name = sL1 $2 $! consDataCon_RDR
+                                in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }
+        | '(' '~' ')'        {% ams (sLL $1 $> $ eqTyCon_RDR) [mop $1,mj AnnTilde $2,mcp $3] }
+
+{- Note [Type constructors in export list]
+~~~~~~~~~~~~~~~~~~~~~
+Mixing type constructors and variable constructors in export lists introduces
+ambiguity in grammar: e.g. (*) may be both a type constructor and a function.
+
+-XExplicitNamespaces allows to disambiguate by explicitly prefixing type
+constructors with 'type' keyword.
+
+This ambiguity causes reduce/reduce conflicts in parser, which are always
+resolved in favour of variable constructors. To get rid of conflicts we demand
+that ambigous type constructors (those, which are formed by the same
+productions as variable constructors) are always prefixed with 'type' keyword.
+Unambigous type constructors may occur both with or without 'type' keyword.
+-}
 
 qtyconop :: { Located RdrName } -- Qualified or unqualified
         : qtyconsym                     { $1 }
-        | '`' qtycon '`'                { sLL $1 $> (unLoc $2) }
+        | '`' 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) }
+        | 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 $! consDataCon_RDR }
+        | '-'                   { sL1 $1 $! mkUnqual tcClsName (fsLit "-") }
 
 
 -----------------------------------------------------------------------------
@@ -2147,23 +2922,29 @@ op      :: { Located RdrName }   -- used in infix decls
 
 varop   :: { Located RdrName }
         : varsym                { $1 }
-        | '`' varid '`'         { sLL $1 $> (unLoc $2) }
+        | '`' 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) }
-        | qconop                { sL1 $1 $ HsVar (unLoc $1) }
+        : qvarop                { sL1 $1 $ HsVar $1 }
+        | qconop                { sL1 $1 $ HsVar $1 }
 
 qopm    :: { LHsExpr RdrName }   -- used in sections
-        : qvaropm               { sL1 $1 $ HsVar (unLoc $1) }
-        | qconop                { sL1 $1 $ HsVar (unLoc $1) }
+        : qvaropm               { sL1 $1 $ HsVar $1 }
+        | qconop                { sL1 $1 $ HsVar $1 }
 
 qvarop :: { Located RdrName }
         : qvarsym               { $1 }
-        | '`' qvarid '`'        { sLL $1 $> (unLoc $2) }
+        | '`' qvarid '`'        {% ams (sLL $1 $> (unLoc $2))
+                                       [mj AnnBackquote $1,mj AnnVal $2
+                                       ,mj AnnBackquote $3] }
 
 qvaropm :: { Located RdrName }
         : qvarsym_no_minus      { $1 }
-        | '`' qvarid '`'        { sLL $1 $> (unLoc $2) }
+        | '`' qvarid '`'        {% ams (sLL $1 $> (unLoc $2))
+                                       [mj AnnBackquote $1,mj AnnVal $2
+                                       ,mj AnnBackquote $3] }
 
 -----------------------------------------------------------------------------
 -- Type variables
@@ -2172,7 +2953,9 @@ tyvar   :: { Located RdrName }
 tyvar   : tyvarid               { $1 }
 
 tyvarop :: { Located RdrName }
-tyvarop : '`' tyvarid '`'       { sLL $1 $> (unLoc $2) }
+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"),
@@ -2180,44 +2963,47 @@ tyvarop : '`' tyvarid '`'       { sLL $1 $> (unLoc $2) }
                                 }
 
 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 ')'        { sLL $1 $> (unLoc $2) }
+        | '(' varsym ')'        {% ams (sLL $1 $> (unLoc $2))
+                                       [mop $1,mj AnnVal $2,mcp $3] }
 
 qvar    :: { Located RdrName }
         : qvarid                { $1 }
-        | '(' varsym ')'        { sLL $1 $> (unLoc $2) }
-        | '(' qvarsym1 ')'      { sLL $1 $> (unLoc $2) }
+        | '(' 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) }
 
 -- 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.
+-- See Note [Lexing type pseudo-keywords] in Lexer.x
 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 }
@@ -2235,8 +3021,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,
@@ -2259,44 +3045,47 @@ 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 "*") }
 
 -----------------------------------------------------------------------------
 -- 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) }
 
 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 }
 
 
 -----------------------------------------------------------------------------
 -- Literals
 
 literal :: { Located HsLit }
-        : CHAR                  { sL1 $1 $ HsChar       $ getCHAR $1 }
-        | STRING                { sL1 $1 $ HsString     $ getSTRING $1 }
-        | PRIMINTEGER           { sL1 $1 $ HsIntPrim    $ getPRIMINTEGER $1 }
-        | PRIMWORD              { sL1 $1 $ HsWordPrim    $ getPRIMWORD $1 }
-        | PRIMCHAR              { sL1 $1 $ HsCharPrim   $ getPRIMCHAR $1 }
-        | PRIMSTRING            { sL1 $1 $ HsStringPrim $ getPRIMSTRING $1 }
-        | PRIMFLOAT             { sL1 $1 $ HsFloatPrim  $ getPRIMFLOAT $1 }
-        | PRIMDOUBLE            { sL1 $1 $ HsDoublePrim $ getPRIMDOUBLE $1 }
+        : CHAR              { sL1 $1 $ HsChar       (getCHARs $1) $ getCHAR $1 }
+        | STRING            { sL1 $1 $ HsString     (getSTRINGs $1)
+                                                   $ getSTRING $1 }
+        | PRIMINTEGER       { sL1 $1 $ HsIntPrim    (getPRIMINTEGERs $1)
+                                                   $ getPRIMINTEGER $1 }
+        | PRIMWORD          { sL1 $1 $ HsWordPrim   (getPRIMWORDs $1)
+                                                   $ getPRIMWORD $1 }
+        | PRIMCHAR          { sL1 $1 $ HsCharPrim   (getPRIMCHARs $1)
+                                                   $ getPRIMCHAR $1 }
+        | PRIMSTRING        { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1)
+                                                   $ getPRIMSTRING $1 }
+        | PRIMFLOAT         { sL1 $1 $ HsFloatPrim  $ getPRIMFLOAT $1 }
+        | PRIMDOUBLE        { sL1 $1 $ HsDoublePrim $ getPRIMDOUBLE $1 }
 
 -----------------------------------------------------------------------------
 -- Layout
@@ -2316,9 +3105,9 @@ modid   :: { Located ModuleName }
                                      (unpackFS mod ++ '.':unpackFS c))
                                 }
 
-commas :: { Int }   -- One or more commas
-        : commas ','                    { $1 + 1 }
-        | ','                           { 1 }
+commas :: { ([SrcSpan],Int) }   -- One or more commas
+        : commas ','             { ((fst $1)++[gl $2],snd $1 + 1) }
+        | ','                    { ([gl $1],1) }
 
 -----------------------------------------------------------------------------
 -- Documentation comments
@@ -2363,30 +3152,81 @@ getQVARID       (L _ (ITqvarid   x)) = x
 getQCONID       (L _ (ITqconid   x)) = x
 getQVARSYM      (L _ (ITqvarsym  x)) = x
 getQCONSYM      (L _ (ITqconsym  x)) = x
-getPREFIXQVARSYM (L _ (ITprefixqvarsym  x)) = x
-getPREFIXQCONSYM (L _ (ITprefixqconsym  x)) = x
 getIPDUPVARID   (L _ (ITdupipvarid   x)) = x
-getCHAR         (L _ (ITchar     x)) = x
-getSTRING       (L _ (ITstring   x)) = x
-getINTEGER      (L _ (ITinteger  x)) = x
+getLABELVARID   (L _ (ITlabelvarid   x)) = x
+getCHAR         (L _ (ITchar   _ x)) = x
+getSTRING       (L _ (ITstring _ x)) = x
+getINTEGER      (L _ (ITinteger _ x)) = x
 getRATIONAL     (L _ (ITrational x)) = x
-getPRIMCHAR     (L _ (ITprimchar   x)) = x
-getPRIMSTRING   (L _ (ITprimstring x)) = x
-getPRIMINTEGER  (L _ (ITprimint    x)) = x
-getPRIMWORD     (L _ (ITprimword x)) = x
-getPRIMFLOAT    (L _ (ITprimfloat  x)) = x
+getPRIMCHAR     (L _ (ITprimchar _ x)) = x
+getPRIMSTRING   (L _ (ITprimstring x)) = x
+getPRIMINTEGER  (L _ (ITprimint  _ x)) = x
+getPRIMWORD     (L _ (ITprimword x)) = x
+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
 getDOCNAMED (L _ (ITdocCommentNamed x)) = x
 getDOCSECTION (L _ (ITdocSection n x)) = (n, x)
 
+getCHARs        (L _ (ITchar       src _)) = src
+getSTRINGs      (L _ (ITstring     src _)) = src
+getINTEGERs     (L _ (ITinteger    src _)) = src
+getPRIMCHARs    (L _ (ITprimchar   src _)) = src
+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
+
+getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l)
+
+isUnicode :: Located Token -> Bool
+isUnicode (L _ (ITforall     iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITdarrow     iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITdcolon     iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITlarrow     iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITrarrow     iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITrarrow     iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITlarrowtail iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITrarrowtail iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITRarrowtail iu)) = iu == UnicodeSyntax
+isUnicode _                       = False
+
+hasE :: Located Token -> Bool
+hasE (L _ (ITopenExpQuote HasE))  = True
+hasE (L _ (ITopenTExpQuote HasE)) = True
+hasE _                            = False
+
 getSCC :: Located Token -> P FastString
 getSCC lt = do let s = getSTRING lt
                    err = "Spaces are not allowed in SCCs"
@@ -2413,16 +3253,57 @@ comb4 a b c d = a `seq` b `seq` c `seq` d `seq`
 sL :: SrcSpan -> a -> Located a
 sL span a = span `seq` a `seq` L span a
 
+-- See Note [Adding location info] for how these utility functions are used
+
 -- replaced last 3 CPP macros in this file
 {-# INLINE sL0 #-}
+sL0 :: a -> Located a
 sL0 = L noSrcSpan       -- #define L0   L noSrcSpan
 
 {-# INLINE sL1 #-}
-sL1 x = sL (getLoc x)   -- #define L1   sL (getLoc $1)
+sL1 :: Located a -> b -> Located b
+sL1 x = sL (getLoc x)   -- #define sL1   sL (getLoc $1)
 
 {-# INLINE sLL #-}
+sLL :: Located a -> Located b -> c -> Located c
 sLL x y = sL (comb2 x y) -- #define LL   sL (comb2 $1 $>)
 
+{- Note [Adding location info]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+This is done using the three functions below, sL0, sL1
+and sLL.  Note that these functions were mechanically
+converted from the three macros that used to exist before,
+namely L0, L1 and LL.
+
+They each add a SrcSpan to their argument.
+
+   sL0  adds 'noSrcSpan', used for empty productions
+     -- This doesn't seem to work anymore -=chak
+
+   sL1  for a production with a single token on the lhs.  Grabs the SrcSpan
+        from that token.
+
+   sLL  for a production with >1 token on the lhs.  Makes up a SrcSpan from
+        the first and last tokens.
+
+These suffice for the majority of cases.  However, we must be
+especially careful with empty productions: sLL won't work if the first
+or last token on the lhs can represent an empty span.  In these cases,
+we have to calculate the span using more of the tokens from the lhs, eg.
+
+        | 'newtype' tycl_hdr '=' newconstr deriving
+                { L (comb3 $1 $4 $5)
+                    (mkTyData NewType (unLoc $2) $4 (unLoc $5)) }
+
+We provide comb3 and comb4 functions which are useful in such cases.
+
+Be careful: there's no checking that you actually got this right, the
+only symptom will be that the SrcSpans of your syntax will be
+incorrect.
+
+-}
+
 -- Make a source location for the file.  We're a bit lazy here and just
 -- make a point SrcSpan at line 1, column 0.  Strictly speaking we should
 -- try to find the span of the whole file (ToDo).
@@ -2435,14 +3316,14 @@ fileSrcSpan = do
 -- Hint about the MultiWayIf extension
 hintMultiWayIf :: SrcSpan -> P ()
 hintMultiWayIf span = do
-  mwiEnabled <- liftM ((Opt_MultiWayIf `xopt`) . dflags) getPState
+  mwiEnabled <- liftM ((LangExt.MultiWayIf `xopt`) . dflags) getPState
   unless mwiEnabled $ parseErrorSDoc span $
     text "Multi-way if-expressions need MultiWayIf turned on"
 
 -- Hint about if usage for beginners
 hintIf :: SrcSpan -> String -> P (LHsExpr RdrName)
 hintIf span msg = do
-  mwiEnabled <- liftM ((Opt_MultiWayIf `xopt`) . dflags) getPState
+  mwiEnabled <- liftM ((LangExt.MultiWayIf `xopt`) . dflags) getPState
   if mwiEnabled
     then parseErrorSDoc span $ text $ "parse error in if statement"
     else parseErrorSDoc span $ text $ "parse error in if statement: "++msg
@@ -2457,4 +3338,109 @@ hintExplicitForall span = do
       , text "Perhaps you intended to use RankNTypes or a similar language"
       , text "extension to enable explicit-forall syntax: \x2200 <tvs>. <type>"
       ]
+
+namedWildCardsEnabled :: P Bool
+namedWildCardsEnabled = liftM ((LangExt.NamedWildCards `xopt`) . dflags) getPState
+
+{-
+%************************************************************************
+%*                                                                      *
+        Helper functions for generating annotations in the parser
+%*                                                                      *
+%************************************************************************
+
+For the general principles of the following routines, see Note [Api annotations]
+in ApiAnnotation.hs
+
+-}
+
+addAnnsAt :: SrcSpan -> [AddAnn] -> P ()
+addAnnsAt loc anns = mapM_ (\a -> a loc) anns
+
+-- |Construct an AddAnn from the annotation keyword and the location
+-- of the keyword itself
+mj :: AnnKeywordId -> Located e -> AddAnn
+mj a l s = addAnnotation s a (gl l)
+
+-- |Construct an AddAnn from the annotation keyword and the Located Token. If
+-- the token has a unicode equivalent and this has been used, provide the
+-- unicode variant of the annotation.
+mu :: AnnKeywordId -> Located Token -> AddAnn
+mu a lt@(L l t) = (\s -> addAnnotation s (toUnicodeAnn a lt) l)
+
+-- | If the 'Token' is using its unicode variant return the unicode variant of
+--   the annotation
+toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId
+toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a
+
+gl = getLoc
+
+-- |Add an annotation to the located element, and return the located
+-- element as a pass through
+aa :: Located a -> (AnnKeywordId,Located c) -> P (Located a)
+aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a
+
+-- |Add an annotation to a located element resulting from a monadic action
+am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a)
+am a (b,s) = do
+  av@(L l _) <- a
+  addAnnotation l b (gl s)
+  return av
+
+-- |Add a list of AddAnns to the given AST element
+ams :: Located a -> [AddAnn] -> P (Located a)
+ams a@(L l _) bs = addAnnsAt l bs >> return a
+
+-- |Add all [AddAnn] to an AST element wrapped in a Just
+aljs :: Located (Maybe a) -> [AddAnn] -> P (Located (Maybe a))
+aljs a@(L l _) bs = addAnnsAt l bs >> return a
+
+-- |Add all [AddAnn] to an AST element wrapped in a Just
+ajs a@(Just (L l _)) bs = addAnnsAt l bs >> return a
+
+-- |Add a list of AddAnns to the given AST element, where the AST element is the
+--  result of a monadic action
+amms :: P (Located a) -> [AddAnn] -> P (Located a)
+amms a bs = do { av@(L l _) <- a
+               ; addAnnsAt l bs
+               ; return av }
+
+-- |Add a list of AddAnns to the AST element, and return the element as a
+--  OrdList
+amsu :: Located a -> [AddAnn] -> P (OrdList (Located a))
+amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a)
+
+-- |Synonyms for AddAnn versions of AnnOpen and AnnClose
+mo,mc :: Located Token -> AddAnn
+mo ll = mj AnnOpen ll
+mc ll = mj AnnClose ll
+
+moc,mcc :: Located Token -> AddAnn
+moc ll = mj AnnOpenC ll
+mcc ll = mj AnnCloseC ll
+
+mop,mcp :: Located Token -> AddAnn
+mop ll = mj AnnOpenP ll
+mcp ll = mj AnnCloseP ll
+
+mos,mcs :: Located Token -> AddAnn
+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 AnnCommaTuple (L s ())) ss
+
+-- |Get the location of the last element of a OrdList, or noSrcSpan
+oll :: OrdList (Located a) -> SrcSpan
+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 (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls
 }