Add API Annotations
authorAlan Zimmerman <alan.zimm@gmail.com>
Fri, 21 Nov 2014 17:20:13 +0000 (11:20 -0600)
committerAustin Seipp <austin@well-typed.com>
Fri, 21 Nov 2014 17:26:28 +0000 (11:26 -0600)
Summary:
The final design and discussion is captured at
https://ghc.haskell.org/trac/ghc/wiki/GhcAstAnnotations

This is a proof of concept implementation of a completely
separate annotation structure, populated in the parser,and tied to the
AST by means of a virtual "node-key" comprising the surrounding
SrcSpan and a value derived from the specific constructor used for the
node.

The key parts of the design are the following.

== The Annotations ==

In `hsSyn/ApiAnnotation.hs`

```lang=haskell
type ApiAnns = (Map.Map ApiAnnKey SrcSpan, Map.Map SrcSpan [Located Token])

type ApiAnnKey = (SrcSpan,AnnKeywordId)

-- ---------------------------------------------------------------------

-- | Retrieve an annotation based on the @SrcSpan@ of the annotated AST
-- element, and the known type of the annotation.
getAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId -> Maybe SrcSpan
getAnnotation (anns,_) span ann = Map.lookup (span,ann) anns

-- |Retrieve the comments allocated to the current @SrcSpan@
getAnnotationComments :: ApiAnns -> SrcSpan -> [Located Token]
getAnnotationComments (_,anns) span =
  case Map.lookup span anns of
    Just cs -> cs
    Nothing -> []

-- | Note: in general the names of these are taken from the
-- corresponding token, unless otherwise noted
data AnnKeywordId
         = AnnAs
         | AnnBang
         | AnnClass
         | AnnClose -- ^ } or ] or ) or #) etc
         | AnnComma
         | AnnDarrow
         | AnnData
         | AnnDcolon
         ....
```

== Capturing in the lexer/parser ==

The annotations are captured in the lexer / parser by extending PState to include a field

In `parser/Lexer.x`

```lang=haskell
data PState = PState {
        ....
        annotations :: [(ApiAnnKey,SrcSpan)]
        -- Annotations giving the locations of 'noise' tokens in the
        -- source, so that users of the GHC API can do source to
        -- source conversions.
     }
```

The lexer exposes a helper function to add an annotation

```lang=haskell
addAnnotation :: SrcSpan -> Ann -> SrcSpan -> P ()
addAnnotation l a v = P $ \s -> POk s {
  annotations = ((AK l a), v) : annotations s
  } ()

```

The parser also has some helper functions of the form

```lang=haskell
type MaybeAnn = Maybe (SrcSpan -> P ())

gl = getLoc
gj x = Just (gl x)

ams :: Located a -> [MaybeAnn] -> P (Located a)
ams a@(L l _) bs = (mapM_ (\a -> a l) $ catMaybes bs) >> return a
```

This allows annotations to be captured in the parser by means of

```
ctypedoc :: { LHsType RdrName }
        : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >>
                                            ams (LL $ mkExplicitHsForAllTy $2 (noLoc []) $4)
                                                [mj AnnForall $1,mj AnnDot $3] }
        | context '=>' ctypedoc         {% ams (LL $ mkQualifiedHsForAllTy   $1 $3)
                                               [mj AnnDarrow $2] }
        | ipvar '::' type               {% ams (LL (HsIParamTy (unLoc $1) $3))
                                               [mj AnnDcolon $2] }
        | typedoc                       { $1 }
```

== Parse result ==

```lang-haskell
data HsParsedModule = HsParsedModule {
    hpm_module    :: Located (HsModule RdrName),
    hpm_src_files :: [FilePath],
       -- ^ extra source files (e.g. from #includes).  The lexer collects
       -- these from '# <file> <line>' pragmas, which the C preprocessor
       -- leaves behind.  These files and their timestamps are stored in
       -- the .hi file, so that we can force recompilation if any of
       -- them change (#3589)
    hpm_annotations :: ApiAnns
  }

-- | The result of successful parsing.
data ParsedModule =
  ParsedModule { pm_mod_summary   :: ModSummary
               , pm_parsed_source :: ParsedSource
               , pm_extra_src_files :: [FilePath]
               , pm_annotations :: ApiAnns }
```

This diff depends on D426

Test Plan: sh ./validate

Reviewers: austin, simonpj, Mikolaj

Reviewed By: simonpj, Mikolaj

Subscribers: Mikolaj, goldfire, thomie, carter

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

GHC Trac Issues: #9628

32 files changed:
compiler/basicTypes/DataCon.lhs
compiler/ghc.cabal.in
compiler/ghc.mk
compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsExpr.lhs
compiler/hsSyn/HsImpExp.lhs
compiler/hsSyn/HsPat.lhs
compiler/hsSyn/HsSyn.lhs
compiler/hsSyn/HsTypes.lhs
compiler/hsSyn/HsUtils.lhs
compiler/main/GHC.hs
compiler/main/HeaderInfo.hs
compiler/main/HscMain.hs
compiler/main/HscTypes.lhs
compiler/parser/ApiAnnotation.hs [new file with mode: 0644]
compiler/parser/Lexer.x
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
ghc/InteractiveUI.hs
testsuite/tests/ghc-api/annotations/.gitignore [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/AnnotationLet.hs [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/AnnotationTuple.hs [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/CommentsTest.hs [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/Makefile [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/all.T [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/annotations.hs [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/annotations.stdout [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/comments.hs [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/comments.stdout [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/parseTree.hs [new file with mode: 0644]
testsuite/tests/ghc-api/annotations/parseTree.stdout [new file with mode: 0644]

index 95969df..e57439d 100644 (file)
@@ -246,6 +246,9 @@ Note that (Foo a) might not be an instance of Ord.
 
 \begin{code}
 -- | A data constructor
+--
+-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+--             'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma'
 data DataCon
   = MkData {
         dcName    :: Name,      -- This is the name of the *source data con*
index 4aa2e3a..5c9f17a 100644 (file)
@@ -331,6 +331,7 @@ Library
         OptCoercion
         Parser
         RdrHsSyn
+        ApiAnnotation
         ForeignCall
         PrelInfo
         PrelNames
index 752a607..b0bc1a8 100644 (file)
@@ -537,6 +537,7 @@ compiler_stage2_dll0_MODULES = \
        InstEnv \
        Kind \
        Lexeme \
+       ApiAnnotation \
        ListSetOps \
        Literal \
        LoadIface \
@@ -599,6 +600,7 @@ ifeq "$(GhcWithInterpreter)" "YES"
 # These files are reacheable from DynFlags
 # only by GHCi-enabled code (see #9552)
 compiler_stage2_dll0_MODULES += \
+       ApiAnnotation \
        Bitmap \
        BlockId \
        ByteCodeAsm \
index 28e2343..e0a2193 100644 (file)
@@ -119,6 +119,13 @@ data HsBindLR idL idR
     -- But note that the form                 @f :: a->a = ...@
     -- parses as a pattern binding, just like
     --                                        @(f :: a -> a) = ... @
+    --
+    --  'ApiAnnotation.AnnKeywordId's
+    --
+    --  - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches
+    --
+    --  - 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
+    --    'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
     FunBind {
 
         fun_id :: Located idL,
@@ -129,10 +136,12 @@ data HsBindLR idL idR
 
         fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of
                                 -- the Id.  Example:
+                                --
                                 -- @
                                 --      f :: Int -> forall a. a -> a
                                 --      f x y = y
                                 -- @
+                                --
                                 -- Then the MatchGroup will have type (Int -> a' -> a')
                                 -- (with a free type variable a').  The coercion will take
                                 -- a CoreExpr of this type and convert it to a CoreExpr of
@@ -150,6 +159,10 @@ data HsBindLR idL idR
 
   -- | The pattern is never a simple variable;
   -- That case is done by FunBind
+  --
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang',
+  --       'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
+  --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
   | PatBind {
         pat_lhs    :: LPat idL,
         pat_rhs    :: GRHSs idR (LHsExpr idR),
@@ -183,6 +196,9 @@ data HsBindLR idL idR
     }
 
   | PatSynBind (PatSynBind idL idR)
+        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
+        --           'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnWhere'
+        --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
 
   deriving (Typeable)
 deriving instance (DataId idL, DataId idR)
@@ -525,12 +541,16 @@ isEmptyIPBinds :: HsIPBinds id -> Bool
 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
 
 type LIPBind id = Located (IPBind id)
+-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a
+--   list
 
 -- | Implicit parameter bindings.
+--
+-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
 {- These bindings start off as (Left "x") in the parser and stay
 that way until after type-checking when they are replaced with
 (Right d), where "d" is the name of the dictionary holding the
-evidene for the implicit parameter. -}
+evidence for the implicit parameter. -}
 data IPBind id
   = IPBind (Either HsIPName id) (LHsExpr id)
   deriving (Typeable)
@@ -566,6 +586,9 @@ type LSig name = Located (Sig name)
 data Sig name
   =   -- | An ordinary type signature
       -- @f :: Num a => a -> a@
+      --
+      --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon',
+      --          'ApiAnnotation.AnnComma'
     TypeSig [Located name] (LHsType name)
 
       -- | A pattern synonym type signature
@@ -587,11 +610,15 @@ data Sig name
         -- the desired Id itself, replete with its name, type
         -- and IdDetails.  Otherwise it's just like a type
         -- signature: there should be an accompanying binding
+        --
+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
+        --           'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnDotdot'
+
   | IdSig Id
 
         -- | An ordinary fixity declaration
         --
-        -- >     infixl *** 8
+        -- >     infixl 8 ***
         --
   | FixSig (FixitySig name)
 
@@ -599,6 +626,10 @@ data Sig name
         --
         -- > {#- INLINE f #-}
         --
+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+        --       'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen',
+        --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde',
+        --       'ApiAnnotation.AnnClose'
   | InlineSig   (Located name)  -- Function name
                 InlinePragma    -- Never defaultInlinePragma
 
@@ -606,6 +637,10 @@ data Sig name
         --
         -- > {-# SPECIALISE f :: Int -> Int #-}
         --
+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+        --      'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde',
+        --      'ApiAnnotation.AnnVal','ApiAnnotation.AnnClose',
+        --      'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose',
   | SpecSig     (Located name)  -- Specialise a function or datatype  ...
                 [LHsType name]  -- ... to these types
                 InlinePragma    -- The pragma on SPECIALISE_INLINE form.
@@ -618,11 +653,18 @@ data Sig name
         --
         -- (Class tys); should be a specialisation of the
         -- current instance declaration
+        --
+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+        --      'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose'
   | SpecInstSig (LHsType name)
 
         -- | A minimal complete definition pragma
         --
         -- > {-# MINIMAL a | (b, c | (d | e)) #-}
+        --
+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+        --      'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma',
+        --      'ApiAnnotation.AnnClose'
   | MinimalSig (BooleanFormula (Located name))
 
   deriving (Typeable)
index f8f370c..2cfa959 100644 (file)
@@ -117,6 +117,10 @@ import Data.Maybe
 
 \begin{code}
 type LHsDecl id = Located (HsDecl id)
+        -- ^ When in a list this may have
+        --
+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
+        --
 
 -- | A Haskell Declaration
 data HsDecl id
@@ -459,9 +463,19 @@ type LTyClDecl name = Located (TyClDecl name)
 -- | A type or class declaration.
 data TyClDecl name
   = -- | @type/data family T :: *->*@
+    --
+    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
+    --             'ApiAnnotation.AnnData',
+    --             'ApiAnnotation.AnnFamily','ApiAnnotation.AnnWhere',
+    --             'ApiAnnotation.AnnOpen','ApiAnnotation.AnnDcolon',
+    --             'ApiAnnotation.AnnClose'
+
     FamDecl { tcdFam :: FamilyDecl name }
 
   | -- | @type@ declaration
+    --
+    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
+    --             'ApiAnnotation.AnnEqual',
     SynDecl { tcdLName  :: Located name            -- ^ Type constructor
             , tcdTyVars :: LHsTyVarBndrs name      -- ^ Type variables; for an associated type
                                                   --   these include outer binders
@@ -469,6 +483,11 @@ data TyClDecl name
             , tcdFVs    :: PostRn name NameSet }
 
   | -- | @data@ declaration
+    --
+    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
+    --              'ApiAnnotation.AnnFamily',
+    --              'ApiAnnotation.AnnNewType',
+    --              'ApiAnnotation.AnnNewType','ApiAnnotation.AnnWhere'
     DataDecl { tcdLName    :: Located name        -- ^ Type constructor
              , tcdTyVars   :: LHsTyVarBndrs name  -- ^ Type variables; for an assoicated type
                                                   --   these include outer binders
@@ -491,6 +510,12 @@ data TyClDecl name
                 tcdDocs    :: [LDocDecl],               -- ^ Haddock docs
                 tcdFVs     :: PostRn name NameSet
     }
+        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass',
+        --           'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen',
+        --           'ApiAnnotation.AnnClose'
+        --   - The tcdFDs will have 'ApiAnnotation.AnnVbar',
+        --                          'ApiAnnotation.AnnComma'
+        --                          'ApiAnnotation.AnnRarrow'
 
   deriving (Typeable)
 deriving instance (DataId id) => Data (TyClDecl id)
@@ -799,7 +824,11 @@ data HsDataDefn name   -- The payload of a data type defn
                      -- @
                      -- Typically the foralls and ty args are empty, but they
                      -- are non-empty for the newtype-deriving case
-    }
+                     --
+                     --  - 'ApiAnnotation.AnnKeywordId' :
+                     --       'ApiAnnotation.AnnDeriving',
+                     --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
+   }
     deriving( Typeable )
 deriving instance (DataId id) => Data (HsDataDefn id)
 
@@ -809,19 +838,30 @@ data NewOrData
   deriving( Eq, Data, Typeable )                -- Needed because Demand derives Eq
 
 type LConDecl name = Located (ConDecl name)
+      -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when
+      --   in a GADT constructor list
 
+-- |
+--
+-- @
 -- data T b = forall a. Eq a => MkT a b
 --   MkT :: forall b a. Eq a => MkT a b
-
+--
 -- data T b where
 --      MkT1 :: Int -> T Int
-
+--
 -- data T = Int `MkT` Int
 --        | MkT2
-
+--
 -- data T a where
 --      Int `MkT` Int :: T Int
-
+-- @
+--
+-- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',
+--            'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnCLose',
+--            'ApiAnnotation.AnnEqual','ApiAnnotation.AnnVbar',
+--            'ApiAnnotation.AnnDarrow','ApiAnnotation.AnnDarrow',
+--            'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot'
 data ConDecl name
   = ConDecl
     { con_names     :: [Located name]
@@ -992,6 +1032,8 @@ It is parameterised over its tfe_pats field:
 \begin{code}
 ----------------- Type synonym family instances -------------
 type LTyFamInstEqn  name = Located (TyFamInstEqn  name)
+  -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
+  --   when in a list
 type LTyFamDefltEqn name = Located (TyFamDefltEqn name)
 
 type HsTyPats name = HsWithBndrs name [LHsType name]
@@ -1009,6 +1051,8 @@ data TyFamEqn name pats
        { tfe_tycon :: Located name
        , tfe_pats  :: pats
        , tfe_rhs   :: LHsType name }
+    -- ^
+    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
   deriving( Typeable )
 deriving instance (DataId name, Data pats) => Data (TyFamEqn name pats)
 
@@ -1017,6 +1061,9 @@ data TyFamInstDecl name
   = TyFamInstDecl
        { tfid_eqn  :: LTyFamInstEqn name
        , tfid_fvs  :: PostRn name NameSet }
+    -- ^
+    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
+    --           'ApiAnnotation.AnnInstance',
   deriving( Typeable )
 deriving instance (DataId name) => Data (TyFamInstDecl name)
 
@@ -1028,8 +1075,13 @@ data DataFamInstDecl name
        { dfid_tycon :: Located name
        , dfid_pats  :: HsTyPats name      -- LHS
        , dfid_defn  :: HsDataDefn  name   -- RHS
-       , dfid_fvs   :: PostRn name NameSet } -- Rree vars for
-                                               -- dependency analysis
+       , dfid_fvs   :: PostRn name NameSet } -- Free vars for
+                                             -- dependency analysis
+    -- ^
+    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
+    --           'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance',
+    --           'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen',
+    --           'ApiAnnotation.AnnClose'
   deriving( Typeable )
 deriving instance (DataId name) => Data (DataFamInstDecl name)
 
@@ -1047,7 +1099,15 @@ data ClsInstDecl name
       , cid_tyfam_insts   :: [LTyFamInstDecl name]   -- Type family instances
       , cid_datafam_insts :: [LDataFamInstDecl name] -- Data family instances
       , cid_overlap_mode  :: Maybe (Located OverlapMode)
+         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+         --                                    'ApiAnnotation.AnnClose',
+
       }
+    -- ^
+    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInstance',
+    --           'ApiAnnotation.AnnWhere',
+    --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
+    --
   deriving (Typeable)
 deriving instance (DataId id) => Data (ClsInstDecl id)
 
@@ -1184,6 +1244,10 @@ type LDerivDecl name = Located (DerivDecl name)
 data DerivDecl name = DerivDecl
         { deriv_type :: LHsType name
         , deriv_overlap_mode :: Maybe (Located OverlapMode)
+         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+         --                                    'ApiAnnotation.AnnClose',
+         --                                    'ApiAnnotation.AnnDeriving',
+         --                                    'ApiAnnotation.AnnInstance',
         }
   deriving (Typeable)
 deriving instance (DataId name) => Data (DerivDecl name)
@@ -1208,6 +1272,9 @@ type LDefaultDecl name = Located (DefaultDecl name)
 
 data DefaultDecl name
   = DefaultDecl [LHsType name]
+        -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault',
+        --          'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
+
   deriving (Typeable)
 deriving instance (DataId name) => Data (DefaultDecl name)
 
@@ -1243,6 +1310,10 @@ data ForeignDecl name
                   (LHsType name) -- sig_ty
                   (PostTc name Coercion)  -- sig_ty ~ rep_ty
                   ForeignExport
+        -- ^
+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign',
+        --           'ApiAnnotation.AnnImport','ApiAnnotation.AnnExport',
+        --           'ApiAnnotation.AnnDcolon'
   deriving (Typeable)
 deriving instance (DataId name) => Data (ForeignDecl name)
 {-
@@ -1358,6 +1429,11 @@ data RuleDecl name
         (PostRn name NameSet)   -- Free-vars from the LHS
         (Located (HsExpr name)) -- RHS
         (PostRn name NameSet)   -- Free-vars from the RHS
+        -- ^
+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
+        --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnVal',
+        --           'ApiAnnotation.AnnClose','ApiAnnotation.AnnTilde',
+        --           'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot',
   deriving (Typeable)
 deriving instance (DataId name) => Data (RuleDecl name)
 
@@ -1365,6 +1441,9 @@ type LRuleBndr name = Located (RuleBndr name)
 data RuleBndr name
   = RuleBndr (Located name)
   | RuleBndrSig (Located name) (HsWithBndrs name (LHsType name))
+        -- ^
+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+        --     'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose'
   deriving (Typeable)
 deriving instance (DataId name) => Data (RuleBndr name)
 
@@ -1409,18 +1488,27 @@ data VectDecl name
   = HsVect
       (Located name)
       (LHsExpr name)
+        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+        --           'ApiAnnotation.AnnEqual','ApiAnnotation.AnnClose'
   | HsNoVect
       (Located name)
+        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+        --                                    'ApiAnnotation.AnnClose'
   | HsVectTypeIn                -- pre type-checking
       Bool                      -- 'TRUE' => SCALAR declaration
       (Located name)
       (Maybe (Located name))    -- 'Nothing' => no right-hand side
+        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+        --           'ApiAnnotation.AnnType','ApiAnnotation.AnnClose',
+        --           'ApiAnnotation.AnnEqual'
   | HsVectTypeOut               -- post type-checking
       Bool                      -- 'TRUE' => SCALAR declaration
       TyCon
       (Maybe TyCon)             -- 'Nothing' => no right-hand side
   | HsVectClassIn               -- pre type-checking
       (Located name)
+        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+        --           'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose',
   | HsVectClassOut              -- post type-checking
       Class
   | HsVectInstIn                -- pre type-checking (always SCALAR)  !!!FIXME: should be superfluous now
@@ -1536,6 +1624,10 @@ instance OutputableBndr name => Outputable (WarnDecl name) where
 type LAnnDecl name = Located (AnnDecl name)
 
 data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name))
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+      --           'ApiAnnotation.AnnType'
+      --           'ApiAnnotation.AnnModule'
+      --           'ApiAnnotation.AnnClose'
   deriving (Typeable)
 deriving instance (DataId name) => Data (AnnDecl name)
 
@@ -1574,6 +1666,8 @@ type LRoleAnnotDecl name = Located (RoleAnnotDecl name)
 data RoleAnnotDecl name
   = RoleAnnotDecl (Located name)         -- type constructor
                   [Located (Maybe Role)] -- optional annotations
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
+      --           'ApiAnnotation.AnnRole'
   deriving (Data, Typeable)
 
 instance OutputableBndr name => Outputable (RoleAnnotDecl name) where
index 79c30a0..e7c23eb 100644 (file)
@@ -52,6 +52,8 @@ import Data.Data hiding (Fixity)
 -- * Expressions proper
 
 type LHsExpr id = Located (HsExpr id)
+  -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when
+  --   in a list
 
 -------------------------
 -- | PostTcExpr is an evidence expression attached to the syntax tree by the
@@ -132,9 +134,15 @@ data HsExpr id
   | HsLit     HsLit                     -- ^ Simple (non-overloaded) literals
 
   | HsLam     (MatchGroup id (LHsExpr id)) -- ^ Lambda abstraction. Currently always a single match
+       --
+       -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
+       --       'ApiAnnotation.AnnRarrow',
 
   | HsLamCase (PostTc id Type) (MatchGroup id (LHsExpr id)) -- ^ Lambda-case
-
+       --
+       -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
+       --           'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen',
+       --           'ApiAnnotation.AnnClose'
   | HsApp     (LHsExpr id) (LHsExpr id) -- ^ Application
 
   -- | Operator applications:
@@ -149,10 +157,18 @@ data HsExpr id
                 (LHsExpr id)    -- right operand
 
   -- | Negation operator. Contains the negated expression and the name
-  -- of 'negate'              
-  | NegApp      (LHsExpr id) 
-                (SyntaxExpr id) 
-
+  -- of 'negate'
+  --
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus'
+  | NegApp      (LHsExpr id)
+                (SyntaxExpr id)
+
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+  --             'ApiAnnotation.AnnClose'
+  --   - Note: if 'ApiAnnotation.AnnVal' is present this is actually an
+  --           inactive 'HsSCC'
+  --   - Note: if multiple 'ApiAnnotation.AnnVal' are
+  --            present this is actually an inactive 'HsTickPragma'
   | HsPar       (LHsExpr id)    -- ^ Parenthesised expr; see Note [Parens in HsSyn]
 
   | SectionL    (LHsExpr id)    -- operand; see Note [Sections in HsSyn]
@@ -161,13 +177,23 @@ data HsExpr id
                 (LHsExpr id)    -- operand
 
   -- | Used for explicit tuples and sections thereof
+  --
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+  --         'ApiAnnotation.AnnClose'
   | ExplicitTuple
         [LHsTupArg id]
         Boxity
 
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',
+  --       'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen',
+  --       'ApiAnnotation.AnnClose'
   | HsCase      (LHsExpr id)
                 (MatchGroup id (LHsExpr id))
 
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf',
+  --       'ApiAnnotation.AnnSemi',
+  --       'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi2',
+  --       'ApiAnnotation.AnnElse',
   | HsIf        (Maybe (SyntaxExpr id)) -- cond function
                                         -- Nothing => use the built-in 'if'
                                         -- See Note [Rebindable if]
@@ -176,12 +202,23 @@ data HsExpr id
                 (LHsExpr id)    --  else part
 
   -- | Multi-way if
+  --
+  -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf'
+  --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
   | HsMultiIf   (PostTc id Type) [LGRHS id (LHsExpr id)]
 
   -- | let(rec)
-  | HsLet       (HsLocalBinds id) 
+  --
+  -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',
+  --       'ApiAnnotation.AnnIn','ApiAnnotation.AnnOpen',
+  --       'ApiAnnotation.AnnClose'
+  | HsLet       (HsLocalBinds id)
                 (LHsExpr  id)
 
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',
+  --             'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi',
+  --             'ApiAnnotation.AnnVbar',
+  --             'ApiAnnotation.AnnClose'
   | HsDo        (HsStmtContext Name) -- The parameterisation is unimportant
                                      -- because in this context we never use
                                      -- the PatGuard or ParStmt variant
@@ -189,23 +226,37 @@ data HsExpr id
                 (PostTc id Type)     -- Type of the whole expression
 
   -- | Syntactic list: [a,b,c,...]
+  --
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+  --              'ApiAnnotation.AnnClose'
   | ExplicitList
                 (PostTc id Type)        -- Gives type of components of list
                 (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromListN witness
                 [LHsExpr id]
 
   -- | Syntactic parallel array: [:e1, ..., en:]
+  --
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+  --              'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnComma',
+  --              'ApiAnnotation.AnnVbar'
+  --              'ApiAnnotation.AnnClose'
   | ExplicitPArr
                 (PostTc id Type)   -- type of elements of the parallel array
                 [LHsExpr id]
 
   -- | Record construction
+  --
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+  --         'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose'
   | RecordCon   (Located id)       -- The constructor.  After type checking
                                    -- it's the dataConWrapId of the constructor
                 PostTcExpr         -- Data con Id applied to type args
                 (HsRecordBinds id)
 
   -- | Record update
+  --
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+  --         'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose'
   | RecordUpd   (LHsExpr id)
                 (HsRecordBinds id)
 --              (HsMatchGroup Id)  -- Filled in by the type checker to be
@@ -218,8 +269,10 @@ data HsExpr id
   -- For a type family, the arg types are of the *instance* tycon,
   -- not the family tycon
 
-  -- | Expression with an explicit type signature. @e :: type@  
-  | ExprWithTySig                       
+  -- | Expression with an explicit type signature. @e :: type@
+  --
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
+  | ExprWithTySig
                 (LHsExpr id)
                 (LHsType id)
 
@@ -229,7 +282,11 @@ data HsExpr id
                                         -- round-tripping purposes
 
   -- | Arithmetic sequence
-  | ArithSeq                            
+  --
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+  --              'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnComma',
+  --              'ApiAnnotation.AnnClose'
+  | ArithSeq
                 PostTcExpr
                 (Maybe (SyntaxExpr id))   -- For OverloadedLists, the fromList witness
                 (ArithSeqInfo id)
@@ -239,15 +296,22 @@ data HsExpr id
                 PostTcExpr              -- [:e1..e2:] or [:e1, e2..e3:]
                 (ArithSeqInfo id)
 
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+  --             'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose'
   | HsSCC       FastString              -- "set cost centre" SCC pragma
                 (LHsExpr id)            -- expr whose cost is to be measured
 
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+  --             'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose'
   | HsCoreAnn   FastString              -- hdaume: core annotation
                 (LHsExpr id)
 
   -----------------------------------------------------------
   -- MetaHaskell Extensions
 
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+  --         'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
+  --         'ApiAnnotation.AnnClose'
   | HsBracket    (HsBracket id)
 
     -- See Note [Pending Splices]
@@ -262,6 +326,8 @@ data HsExpr id
       [PendingTcSplice]    -- _typechecked_ splices to be
                            -- pasted back in by the desugarer
 
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+  --         'ApiAnnotation.AnnClose'
   | HsSpliceE    Bool                   -- True <=> typed splice
                  (HsSplice id)          -- False <=> untyped
 
@@ -272,6 +338,9 @@ data HsExpr id
   -- Arrow notation extension
 
   -- | @proc@ notation for Arrows
+  --
+  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnProc',
+  --          'ApiAnnotation.AnnRarrow'
   | HsProc      (LPat id)               -- arrow abstraction, proc
                 (LHsCmdTop id)          -- body of the abstraction
                                         -- always has an empty stack
@@ -280,6 +349,10 @@ data HsExpr id
   -- The following are commands, not expressions proper
   -- They are only used in the parsing stage and are removed
   --    immediately in parser.RdrHsSyn.checkCommand
+
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail',
+  --          'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail',
+  --          'ApiAnnotation.AnnRarrowtail'
   | HsArrApp             -- Arrow tail, or arrow application (f -< arg)
         (LHsExpr id)     -- arrow expression, f
         (LHsExpr id)     -- input expression, arg
@@ -289,6 +362,8 @@ data HsExpr id
         Bool             -- True => right-to-left (f -< arg)
                          -- False => left-to-right (arg >- f)
 
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+  --         'ApiAnnotation.AnnClose'
   | HsArrForm            -- Command formation,  (| e cmd1 .. cmdn |)
         (LHsExpr id)     -- the operator
                          -- after type-checking, a type abstraction to be
@@ -309,6 +384,14 @@ data HsExpr id
      Int                                -- module-local tick number for False
      (LHsExpr id)                       -- sub-expression
 
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+  --       'ApiAnnotation.AnnOpen',
+  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal2',
+  --       'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal3',
+  --       'ApiAnnotation.AnnMinus',
+  --       'ApiAnnotation.AnnVal4','ApiAnnotation.AnnColon2',
+  --       'ApiAnnotation.AnnVal5',
+  --       'ApiAnnotation.AnnClose'
   | HsTickPragma                        -- A pragma introduced tick
      (FastString,(Int,Int),(Int,Int))   -- external span for this tick
      (LHsExpr id)
@@ -319,12 +402,15 @@ data HsExpr id
 
   | EWildPat                 -- wildcard
 
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
   | EAsPat      (Located id) -- as pattern
                 (LHsExpr id)
 
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
   | EViewPat    (LHsExpr id) -- view pattern
                 (LHsExpr id)
 
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
   | ELazyPat    (LHsExpr id) -- ~ pattern
 
   | HsType      (LHsType id) -- Explicit type argument; e.g  f {| Int |} x y
@@ -342,6 +428,7 @@ deriving instance (DataId id) => Data (HsExpr id)
 --  (,a,) is represented by  ExplicitTuple [Missing ty1, Present a, Missing ty3]
 --  Which in turn stands for (\x:ty1 \y:ty2. (x,a,y))
 type LHsTupArg id = Located (HsTupArg id)
+-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma'
 data HsTupArg id
   = Present (LHsExpr id)     -- ^ The argument
   | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type
@@ -878,7 +965,8 @@ data MatchGroup id body
 deriving instance (Data body,DataId id) => Data (MatchGroup id body)
 
 type LMatch id body = Located (Match id body)
-
+-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a
+--   list
 data Match id body
   = Match
         [LPat id]               -- The patterns
@@ -902,6 +990,11 @@ hsLMatchPats :: LMatch id body -> [LPat id]
 hsLMatchPats (L _ (Match pats _ _)) = pats
 
 -- | GRHSs are used both for pattern bindings and for Matches
+--
+--  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar',
+--        'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
+--        'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
+--        'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi'
 data GRHSs id body
   = GRHSs {
       grhssGRHSs :: [LGRHS id body],       -- ^ Guarded RHSs
@@ -1016,6 +1109,11 @@ type GhciStmt   id = Stmt  id (LHsExpr id)
 
 -- The SyntaxExprs in here are used *only* for do-notation and monad
 -- comprehensions, which have rebindable syntax. Otherwise they are unused.
+-- | API Annotations when in qualifier lists or guards
+--  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar',
+--         'ApiAnnotation.AnnComma','ApiAnnotation.AnnThen',
+--         'ApiAnnotation.AnnBy','ApiAnnotation.AnnBy',
+--         'ApiAnnotation.AnnGroup','ApiAnnotation.AnnUsing'
 data StmtLR idL idR body -- body should always be (LHs**** idR)
   = LastStmt  -- Always the last Stmt in ListComp, MonadComp, PArrComp,
               -- and (after the renamer) DoExpr, MDoExpr
@@ -1025,6 +1123,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
                                   -- For ListComp, PArrComp, we use the baked-in 'return'
                                   -- For DoExpr, MDoExpr, we don't appply a 'return' at all
                                   -- See Note [Monad Comprehensions]
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLarrow'
   | BindStmt (LPat idL)
              body
              (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind]
@@ -1038,6 +1137,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
                                -- See notes [Monad Comprehensions]
              (PostTc idR Type) -- Element type of the RHS (used for arrows)
 
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet'
   | LetStmt  (HsLocalBindsLR idL idR)
 
   -- ParStmts only occur in a list/monad comprehension
@@ -1067,6 +1167,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
     }                                 -- See Note [Monad Comprehensions]
 
   -- Recursive statement (see Note [How RecStmt works] below)
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRec'
   | RecStmt
      { recS_stmts :: [LStmtLR idL idR body]
 
index dd23dba..b6ec66a 100644 (file)
@@ -30,6 +30,10 @@ import Data.Data
 One per \tr{import} declaration in a module.
 \begin{code}
 type LImportDecl name = Located (ImportDecl name)
+        -- ^ When in a list this may have
+        --
+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
+        --
 
 -- | A single Haskell @import@ declaration.
 data ImportDecl name
@@ -42,8 +46,23 @@ data ImportDecl name
       ideclImplicit  :: Bool,               -- ^ True => implicit import (of Prelude)
       ideclAs        :: Maybe ModuleName,   -- ^ as Module
       ideclHiding    :: Maybe (Bool, Located [LIE name])
+    }
                                             -- ^ (True => hiding, names)
-    } deriving (Data, Typeable)
+     --
+     --  'ApiAnnotation.AnnKeywordId's
+     --
+     --  - 'ApiAnnotation.AnnImport'
+     --
+     --  - 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnClose' for ideclSource
+     --
+     --  - 'ApiAnnotation.AnnSafe','ApiAnnotation.AnnQualified',
+     --    'ApiAnnotation.AnnPackageName','ApiAnnotation.AnnAs',
+     --
+     --  - 'ApiAnnotation.AnnHiding','ApiAnnotation.AnnOpen',
+     --    'ApiAnnotation.AnnClose' attached
+     --     to location in ideclHiding
+
+       deriving (Data, Typeable)
 
 simpleImportDecl :: ModuleName -> ImportDecl name
 simpleImportDecl mn = ImportDecl {
@@ -102,15 +121,34 @@ instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name)
 
 \begin{code}
 type LIE name = Located (IE name)
+        -- ^ When in a list this may have
+        --
+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma'
+        --
 
 -- | Imported or exported entity.
 data IE name
   = IEVar       (Located name)
+        -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern',
+        --                                     'ApiAnnotation.AnnType'
   | IEThingAbs           name      -- ^ Class/Type (can't tell)
+        --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern',
+        --                                     'ApiAnnotation.AnnType'
   | IEThingAll  (Located name)     -- ^ Class/Type plus all methods/constructors
+        --
+        -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',
+        --       'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose',
+        --                                 'ApiAnnotation.AnnType'
+
   | IEThingWith (Located name) [Located name]
                  -- ^ Class/Type plus some methods/constructors
+        -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',
+        --                                   'ApiAnnotation.AnnClose',
+        --                                   'ApiAnnotation.AnnComma',
+        --                                   'ApiAnnotation.AnnType'
   | IEModuleContents  (Located ModuleName) -- ^ (Export Only)
+        --
+        -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnModule'
   | IEGroup             Int HsDocString  -- ^ Doc section heading
   | IEDoc               HsDocString      -- ^ Some documentation
   | IEDocNamed          String           -- ^ Reference to named doc
index 145a8cd..3f4526c 100644 (file)
@@ -61,6 +61,7 @@ type OutPat id = LPat id        -- No 'In' constructors
 
 type LPat id = Located (Pat id)
 
+-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
 data Pat id
   =     ------------ Simple patterns ---------------
     WildPat     (PostTc id Type)        -- Wild card
@@ -217,6 +218,7 @@ data HsRecFields id arg         -- A bunch of record fields
 --                     and the remainder being 'filled in' implicitly
 
 type LHsRecField id arg = Located (HsRecField id arg)
+-- |  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
 data HsRecField id arg = HsRecField {
         hsRecFieldId  :: Located id,
         hsRecFieldArg :: arg,           -- Filled in by renamer
index bd1b2b2..fe31bd5 100644 (file)
@@ -72,6 +72,10 @@ data HsModule name
         --
         --  - @Just [...]@: as you would expect...
         --
+        --
+        --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen'
+        --                                   ,'ApiAnnotation.AnnClose'
+        --
       hsmodImports :: [LImportDecl name],
         -- ^ We snaffle interesting stuff out of the imported interfaces early
         -- on, adding that info to TyDecls/etc; so this list is often empty,
@@ -80,9 +84,26 @@ data HsModule name
         -- ^ Type, class, value, and interface signature decls
       hsmodDeprecMessage :: Maybe (Located WarningTxt),
         -- ^ reason\/explanation for warning/deprecation of this module
+        --
+        --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen'
+        --                                   ,'ApiAnnotation.AnnClose'
+        --
       hsmodHaddockModHeader :: Maybe LHsDocString
         -- ^ Haddock module info and description, unparsed
-   } deriving (Typeable)
+        --
+        --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen'
+        --                                   ,'ApiAnnotation.AnnClose'
+        --
+   }
+     -- ^ 'ApiAnnotation.AnnKeywordId's
+     --
+     --  - 'ApiAnnotation.AnnModule','ApiAnnotation.AnnWhere'
+     --
+     --  - 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnSemi',
+     --    'ApiAnnotation.AnnClose' for explicit braces and semi around
+     --    hsmodImports,hsmodDecls if this style is used.
+     --
+      deriving (Typeable)
 deriving instance (DataId name) => Data (HsModule name)
 \end{code}
 
index 46cf096..e3d6071 100644 (file)
@@ -136,6 +136,8 @@ type LHsContext name = Located (HsContext name)
 type HsContext name = [LHsType name]
 
 type LHsType name = Located (HsType name)
+      -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when
+      --   in a list
 type HsKind name = HsType name
 type LHsKind name = Located (HsKind name)
 
@@ -199,6 +201,9 @@ data HsTyVarBndr name
   | KindedTyVar
          name
          (LHsKind name)  -- The user-supplied kind signature
+        -- ^
+        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+        --          'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose'
   deriving (Typeable)
 deriving instance (DataId name) => Data (HsTyVarBndr name)
 
@@ -211,6 +216,10 @@ isHsKindedTyVar (KindedTyVar {}) = True
 hsTvbAllKinded :: LHsTyVarBndrs name -> Bool
 hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvBndrs
 
+-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon',
+--            'ApiAnnotation.AnnTilde','ApiAnnotation.AnnRarrow',
+--            'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
+--            'ApiAnnotation.AnnComma'
 data HsType name
   = HsForAllTy  HsExplicitFlag          -- Renamer leaves this flag unchanged, to record the way
                                         -- the user wrote it originally, so that the printer can
@@ -218,7 +227,8 @@ data HsType name
                 (LHsTyVarBndrs name) 
                 (LHsContext name)
                 (LHsType name)
-
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall',
+      --         'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
   | HsTyVar             name            -- Type variable, type constructor, or data constructor
                                         -- see Note [Promotions (HsTyVar)]
 
@@ -399,10 +409,13 @@ data HsTupleSort = HsUnboxedTuple
 data HsExplicitFlag = Qualified | Implicit | Explicit deriving (Data, Typeable)
 
 type LConDeclField name = Located (ConDeclField name)
+      -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when
+      --   in a list
 data ConDeclField name  -- Record fields have Haddoc docs on them
   = ConDeclField { cd_fld_names :: [Located name],
                    cd_fld_type  :: LBangType name,
                    cd_fld_doc   :: Maybe LHsDocString }
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
   deriving (Typeable)
 deriving instance (DataId name) => Data (ConDeclField name)
 
index f64471b..9828c40 100644 (file)
@@ -130,10 +130,10 @@ mkSimpleMatch pats rhs
                 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
 
 unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id))
-unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
+unguardedGRHSs rhs@(L loc _) = GRHSs (unguardedRHS loc rhs) emptyLocalBinds
 
-unguardedRHS :: Located (body id) -> [LGRHS id (Located (body id))]
-unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
+unguardedRHS :: SrcSpan -> Located (body id) -> [LGRHS id (Located (body id))]
+unguardedRHS loc rhs = [L loc (GRHS [] rhs)]
 
 mkMatchGroup :: Origin -> [LMatch RdrName (Located (body RdrName))]
              -> MatchGroup RdrName (Located (body RdrName))
@@ -570,7 +570,7 @@ mk_easy_FunBind loc fun pats expr
 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id)
 mkMatch pats expr binds
   = noLoc (Match (map paren pats) Nothing
-                 (GRHSs (unguardedRHS expr) binds))
+                 (GRHSs (unguardedRHS noSrcSpan expr) binds))
   where
     paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
                      | otherwise          = lp
index 41066a5..0612d6b 100644 (file)
@@ -243,6 +243,10 @@ module GHC (
         -- * Pure interface to the parser
         parser,
 
+        -- * API Annotations
+        ApiAnns,AnnKeywordId(..),AnnotationComment(..),
+        getAnnotation, getAnnotationComments,
+
         -- * Miscellaneous
         --sessionHscEnv,
         cyclicModuleErr,
@@ -313,6 +317,7 @@ import Maybes           ( expectJust )
 import FastString
 import qualified Parser
 import Lexer
+import ApiAnnotation
 
 import System.Directory ( doesFileExist )
 import Data.Maybe
@@ -716,7 +721,9 @@ class TypecheckedMod m => DesugaredMod m where
 data ParsedModule =
   ParsedModule { pm_mod_summary   :: ModSummary
                , pm_parsed_source :: ParsedSource
-               , pm_extra_src_files :: [FilePath] }
+               , pm_extra_src_files :: [FilePath]
+               , pm_annotations :: ApiAnns }
+               -- See Note [Api annotations] in ApiAnnotation.hs
 
 instance ParsedMod ParsedModule where
   modSummary m    = pm_mod_summary m
@@ -805,7 +812,9 @@ parseModule ms = do
    hsc_env <- getSession
    let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
    hpm <- liftIO $ hscParse hsc_env_tmp ms
-   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm))
+   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)
+                           (hpm_annotations hpm))
+               -- See Note [Api annotations] in ApiAnnotation.hs
 
 -- | Typecheck and rename a parsed module.
 --
@@ -818,7 +827,8 @@ typecheckModule pmod = do
  (tc_gbl_env, rn_info)
        <- liftIO $ hscTypecheckRename hsc_env_tmp ms $
                       HsParsedModule { hpm_module = parsedSource pmod,
-                                       hpm_src_files = pm_extra_src_files pmod }
+                                       hpm_src_files = pm_extra_src_files pmod,
+                                       hpm_annotations = pm_annotations pmod }
  details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
  safe    <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env
  return $
index 9ac2243..d09a43e 100644 (file)
@@ -163,7 +163,7 @@ lazyGetToks dflags filename handle = do
 
   lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
   lazyLexBuf handle state eof size = do
-    case unP (lexer return) state of
+    case unP (lexer False return) state of
       POk state' t -> do
         -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
         if atEnd (buffer state') && not eof
@@ -197,7 +197,7 @@ getToks dflags filename buf = lexAll (pragState dflags buf loc)
  where
   loc  = mkRealSrcLoc (mkFastString filename) 1 1
 
-  lexAll state = case unP (lexer return) state of
+  lexAll state = case unP (lexer False return) state of
                    POk _      t@(L _ ITeof) -> [t]
                    POk state' t -> t : lexAll state'
                    _ -> [L (RealSrcSpan (last_loc state)) ITeof]
index 3763e55..fcf0c48 100644 (file)
@@ -164,6 +164,7 @@ import Data.Maybe
 import Data.IORef
 import System.FilePath as FilePath
 import System.Directory
+import qualified Data.Map as Map
 
 #include "HsVersions.h"
 
@@ -372,7 +373,11 @@ hscParse' mod_summary = do
 
             return HsParsedModule {
                       hpm_module    = rdr_module,
-                      hpm_src_files = srcs2
+                      hpm_src_files = srcs2,
+                      hpm_annotations
+                              = (Map.fromListWith (++) $ annotations pst,
+                                 Map.fromList $ ((noSrcSpan,comment_q pst)
+                                                 :(annotations_comments pst)))
                    }
 
 -- XXX: should this really be a Maybe X?  Check under which circumstances this
index 57a5015..502f849 100644 (file)
@@ -145,6 +145,7 @@ import Id
 import IdInfo           ( IdDetails(..) )
 import Type
 
+import ApiAnnotation    ( ApiAnns )
 import Annotations      ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )
 import Class
 import TyCon
@@ -2604,12 +2605,14 @@ instance Binary IfaceTrustInfo where
 \begin{code}
 data HsParsedModule = HsParsedModule {
     hpm_module    :: Located (HsModule RdrName),
-    hpm_src_files :: [FilePath]
+    hpm_src_files :: [FilePath],
        -- ^ extra source files (e.g. from #includes).  The lexer collects
        -- these from '# <file> <line>' pragmas, which the C preprocessor
        -- leaves behind.  These files and their timestamps are stored in
        -- the .hi file, so that we can force recompilation if any of
        -- them change (#3589)
+    hpm_annotations :: ApiAnns
+    -- See note [Api annotations] in ApiAnnotation.hs
   }
 \end{code}
 
diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs
new file mode 100644 (file)
index 0000000..140cd1d
--- /dev/null
@@ -0,0 +1,238 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module ApiAnnotation (
+  getAnnotation,
+  getAnnotationComments,
+  ApiAnns,
+  ApiAnnKey,
+  AnnKeywordId(..),
+  AnnotationComment(..),
+  LRdrName -- Exists for haddocks only
+  ) where
+
+import RdrName
+import Outputable
+import SrcLoc
+import qualified Data.Map as Map
+import Data.Data
+
+
+{- Note [Api annotations]
+   ~~~~~~~~~~~~~~~~~~~~~~
+
+In order to do source to source conversions using the GHC API, the
+locations of all elements of the original source needs to be tracked.
+The includes keywords such as 'let' / 'in' / 'do' etc as well as
+punctuation such as commas and braces, and also comments.
+
+These are captured in a structure separate from the parse tree, and
+returned in the pm_annotations field of the ParsedModule type.
+
+The non-comment annotations are stored indexed to the SrcSpan of the
+AST element containing them, together with a AnnKeywordId value
+identifying the specific keyword being captured.
+
+> type ApiAnnKey = (SrcSpan,AnnKeywordId)
+>
+> Map.Map ApiAnnKey SrcSpan
+
+So
+
+> let X = 1 in 2 *x
+
+would result in the AST element
+
+  L span (HsLet (binds for x = 1) (2 * x))
+
+and the annotations
+
+  (span,AnnLet) having the location of the 'let' keyword
+  (span,AnnIn)  having the location of the 'in' keyword
+
+
+The comments are indexed to the SrcSpan of the lowest AST element
+enclosing them
+
+> Map.Map SrcSpan [Located AnnotationComment]
+
+So the full ApiAnns type is
+
+> type ApiAnns = ( Map.Map ApiAnnKey SrcSpan
+>                , Map.Map SrcSpan [Located AnnotationComment])
+
+
+This is done in the lexer / parser as follows.
+
+
+The PState variable in the lexer has the following variables added
+
+>  annotations :: [(ApiAnnKey,SrcSpan)],
+>  comment_q :: [Located Token],
+>  annotations_comments :: [(SrcSpan,[Located AnnotationComment])]
+
+The first and last store the values that end up in the ApiAnns value
+at the end via Map.fromList
+
+The comment_q captures comments as they are seen in the token stream,
+so that when they are ready to be allocated via the parser they are
+available.
+
+The parser interacts with the lexer using the function
+
+> addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
+
+which takes the AST element SrcSpan, the annotation keyword and the
+target SrcSpan.
+
+This adds the annotation to the `annotations` field of `PState` and
+transfers any comments in `comment_q` to the `annotations_comments`
+field.
+
+Parser
+------
+
+The parser implements a number of helper types and methods for the
+capture of annotations
+
+> type AddAnn = (SrcSpan -> P ())
+>
+> mj :: AnnKeywordId -> Located e -> (SrcSpan -> P ())
+> mj a l = (\s -> addAnnotation s a (gl l))
+
+AddAnn represents the addition of an annotation a to a provided
+SrcSpan, and `mj` constructs an AddAnn value.
+
+> ams :: Located a -> [AddAnn] -> P (Located a)
+> ams a@(L l _) bs = (mapM_ (\a -> a l) bs) >> return a
+
+So the production in Parser.y for the HsLet AST element is
+
+        | 'let' binds 'in' exp    {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4)
+                                         (mj AnnLet $1:mj AnnIn $3
+                                           :(fst $ unLoc $2)) }
+
+This adds an AnnLet annotation for 'let', an AnnIn for 'in', as well
+as any annotations that may arise in the binds. This will include open
+and closing braces if they are used to delimit the let expressions.
+
+-}
+-- ---------------------------------------------------------------------
+
+type ApiAnns = ( Map.Map ApiAnnKey [SrcSpan]
+               , Map.Map SrcSpan [Located AnnotationComment])
+
+type ApiAnnKey = (SrcSpan,AnnKeywordId)
+
+
+-- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan'
+-- of the annotated AST element, and the known type of the annotation.
+getAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId -> [SrcSpan]
+getAnnotation (anns,_) span ann
+   = case Map.lookup (span,ann) anns of
+       Nothing -> []
+       Just ss -> ss
+
+-- |Retrieve the comments allocated to the current 'SrcSpan'
+getAnnotationComments :: ApiAnns -> SrcSpan -> [Located AnnotationComment]
+getAnnotationComments (_,anns) span =
+  case Map.lookup span anns of
+    Just cs -> cs
+    Nothing -> []
+
+-- --------------------------------------------------------------------
+
+-- | Note: in general the names of these are taken from the
+-- corresponding token, unless otherwise noted
+-- See note [Api annotations] above for details of the usage
+data AnnKeywordId
+    = AnnAs
+    | AnnAt
+    | AnnBang  -- ^ '!'
+    | AnnBy
+    | AnnCase -- ^ case or lambda case
+    | AnnClass
+    | AnnClose -- ^  '}' or ']' or ')' or '#)' etc
+    | AnnColon
+    | AnnComma
+    | AnnDarrow -- ^ '=>'
+    | AnnData
+    | AnnDcolon -- ^ '::'
+    | AnnDefault
+    | AnnDeriving
+    | AnnDo
+    | AnnDot    -- ^ '.'
+    | AnnDotdot -- ^ '..'
+    | AnnElse
+    | AnnEqual
+    | AnnExport
+    | AnnFamily
+    | AnnForall
+    | AnnForeign
+    | AnnFunId -- ^ for function name in matches where there are
+               -- multiple equations for the function.
+    | AnnGroup
+    | AnnHeader -- ^ for CType
+    | AnnHiding
+    | AnnIf
+    | AnnImport
+    | AnnIn
+    | AnnInstance
+    | AnnLam
+    | AnnLarrow     -- ^ '<-'
+    | AnnLet
+    | AnnMdo
+    | AnnMinus -- ^ '-'
+    | AnnModule
+    | AnnNewtype
+    | AnnOf
+    | AnnOpen   -- ^ '{' or '[' or '(' or '(#' etc
+    | AnnPackageName
+    | AnnPattern
+    | AnnProc
+    | AnnQualified
+    | AnnRarrow -- ^ '->'
+    | AnnRec
+    | AnnRole
+    | AnnSafe
+    | AnnSemi -- ^ ';'
+    | AnnThen
+    | AnnTilde -- ^ '~'
+    | AnnTildehsh -- ^ '~#'
+    | AnnType
+    | AnnUsing
+    | AnnVal  -- ^ e.g. INTEGER
+    | AnnVbar -- ^ '|'
+    | AnnWhere
+    | Annlarrowtail -- ^ '-<'
+    | Annrarrowtail -- ^ '->'
+    | AnnLarrowtail -- ^ '-<<'
+    | AnnRarrowtail -- ^ '>>-'
+    | AnnEofPos
+    deriving (Eq,Ord,Data,Typeable,Show)
+
+instance Outputable AnnKeywordId where
+  ppr x = text (show x)
+
+-- ---------------------------------------------------------------------
+
+data AnnotationComment =
+  -- Documentation annotations
+    AnnDocCommentNext  String     -- ^ something beginning '-- |'
+  | AnnDocCommentPrev  String     -- ^ something beginning '-- ^'
+  | AnnDocCommentNamed String     -- ^ something beginning '-- $'
+  | AnnDocSection      Int String -- ^ a section heading
+  | AnnDocOptions      String     -- ^ doc options (prune, ignore-exports, etc)
+  | AnnDocOptionsOld   String     -- ^ doc options declared "-- # ..."-style
+  | AnnLineComment     String     -- ^ comment starting by "--"
+  | AnnBlockComment    String     -- ^ comment in {- -}
+    deriving (Eq,Ord,Data,Typeable,Show)
+-- Note: these are based on the Token versions, but the Token type is
+-- defined in Lexer.x and bringing it in here would create a loop
+
+
+-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+--             'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma',
+--             'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnTildehsh',
+--             'ApiAnnotation.AnnTilde'
+--   - May have 'ApiAnnotation.AnnComma' when in a list
+type LRdrName = Located RdrName
index 1e8712b..6669250 100644 (file)
@@ -43,6 +43,7 @@
 {
 -- XXX The above flags turn off warnings in the generated code:
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
@@ -71,7 +72,8 @@ module Lexer (
    patternSynonymsEnabled,
    sccProfilingOn, hpcEnabled,
    addWarning,
-   lexTokenStream
+   lexTokenStream,
+   addAnnotation
   ) where
 
 -- base
@@ -91,6 +93,10 @@ import Data.ByteString (ByteString)
 import Data.Map (Map)
 import qualified Data.Map as Map
 
+-- data/typeable
+import Data.Data
+import Data.Typeable
+
 -- compiler/utils
 import Bag
 import Outputable
@@ -110,6 +116,8 @@ import BasicTypes       ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) )
 
 -- compiler/parser
 import Ctype
+
+import ApiAnnotation
 }
 
 -- -----------------------------------------------------------------------------
@@ -687,6 +695,9 @@ data Token
 
   deriving Show
 
+instance Outputable Token where
+  ppr x = text (show x)
+
 -- the bitmap provided as the third component indicates whether the
 -- corresponding extension keyword is valid under the extension options
 -- provided to the compiler; if the extension corresponding to *any* of the
@@ -952,15 +963,16 @@ lineCommentToken span buf len = do
   using regular expressions.
 -}
 nested_comment :: P (RealLocated Token) -> Action
-nested_comment cont span _str _len = do
+nested_comment cont span buf len = do
   input <- getInput
-  go "" (1::Int) input
+  go (reverse $ drop 2 $ lexemeToString buf len) (1::Int) input
   where
-    go commentAcc 0 input = do setInput input
-                               b <- extension rawTokenStreamEnabled
-                               if b
-                                 then docCommentEnd input commentAcc ITblockComment _str span
-                                 else cont
+    go commentAcc 0 input = do
+      setInput input
+      b <- extension rawTokenStreamEnabled
+      if b
+        then docCommentEnd input commentAcc ITblockComment buf span
+        else cont
     go commentAcc n input = case alexGetChar' input of
       Nothing -> errBrace input span
       Just ('-',input) -> case alexGetChar' input of
@@ -1675,7 +1687,15 @@ data PState = PState {
         alr_expecting_ocurly :: Maybe ALRLayout,
         -- Have we just had the '}' for a let block? If so, than an 'in'
         -- token doesn't need to close anything:
-        alr_justClosedExplicitLetBlock :: Bool
+        alr_justClosedExplicitLetBlock :: Bool,
+
+        -- The next three are used to implement Annotations giving the
+        -- locations of 'noise' tokens in the source, so that users of
+        -- the GHC API can do source to source conversions.
+        -- See note [Api annotations] in ApiAnnotation.hs
+        annotations :: [(ApiAnnKey,[SrcSpan])],
+        comment_q :: [Located AnnotationComment],
+        annotations_comments :: [(SrcSpan,[Located AnnotationComment])]
      }
         -- last_loc and last_len are used when generating error messages,
         -- and in pushCurrentContext only.  Sigh, if only Happy passed the
@@ -2057,7 +2077,10 @@ mkPState flags buf loc =
       alr_last_loc = alrInitialLoc (fsLit "<no file>"),
       alr_context = [],
       alr_expecting_ocurly = Nothing,
-      alr_justClosedExplicitLetBlock = False
+      alr_justClosedExplicitLetBlock = False,
+      annotations = [],
+      comment_q = [],
+      annotations_comments = []
     }
     where
       bitmap =     FfiBit                      `setBitIf` xopt Opt_ForeignFunctionInterface flags
@@ -2175,13 +2198,24 @@ lexError str = do
 -- This is the top-level function: called from the parser each time a
 -- new token is to be read from the input.
 
-lexer :: (Located Token -> P a) -> P a
-lexer cont = do
+lexer :: Bool -> (Located Token -> P a) -> P a
+lexer queueComments cont = do
   alr <- extension alternativeLayoutRule
   let lexTokenFun = if alr then lexTokenAlr else lexToken
   (L span tok) <- lexTokenFun
   --trace ("token: " ++ show tok) $ do
-  cont (L (RealSrcSpan span) tok)
+
+  case tok of
+    ITeof -> addAnnotationOnly noSrcSpan AnnEofPos (RealSrcSpan span)
+    _ -> return ()
+
+  if (queueComments && isDocComment tok)
+    then queueComment (L (RealSrcSpan span) tok)
+    else return ()
+
+  if (queueComments && isComment tok)
+    then queueComment (L (RealSrcSpan span) tok) >> lexer queueComments cont
+    else cont (L (RealSrcSpan span) tok)
 
 lexTokenAlr :: P (RealLocated Token)
 lexTokenAlr = do mPending <- popPendingImplicitToken
@@ -2446,7 +2480,7 @@ lexTokenStream buf loc dflags = unP go initState
     where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
           initState = mkPState dflags' buf loc
           go = do
-            ltok <- lexer return
+            ltok <- lexer False return
             case ltok of
               L _ ITeof -> return []
               _ -> liftM (ltok:) go
@@ -2522,4 +2556,71 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag))
                                               "constructorlike" -> "conlike"
                                               _ -> prag'
                           canon_ws s = unwords (map canonical (words s))
+
+
+
+{-
+%************************************************************************
+%*                                                                      *
+        Helper functions for generating annotations in the parser
+%*                                                                      *
+%************************************************************************
+-}
+
+addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
+addAnnotation l a v = do
+  addAnnotationOnly l a v
+  allocateComments l
+
+addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
+addAnnotationOnly l a v = P $ \s -> POk s {
+  annotations = ((l,a), [v]) : annotations s
+  } ()
+
+queueComment :: Located Token -> P()
+queueComment c = P $ \s -> POk s {
+  comment_q = commentToAnnotation c : comment_q s
+  } ()
+
+-- | Go through the @comment_q@ in @PState@ and remove all comments
+-- that belong within the given span
+allocateComments :: SrcSpan -> P ()
+allocateComments ss = P $ \s ->
+  let
+    (before,rest)  = break (\(L l _) -> isSubspanOf l ss) (comment_q s)
+    (middle,after) = break (\(L l _) -> not (isSubspanOf l ss)) rest
+    comment_q' = before ++ after
+    newAnns = if null middle then []
+                             else [(ss,middle)]
+  in
+    POk s {
+       comment_q = comment_q'
+     , annotations_comments = newAnns ++ (annotations_comments s)
+     } ()
+
+commentToAnnotation :: Located Token -> Located AnnotationComment
+commentToAnnotation (L l (ITdocCommentNext s))  = L l (AnnDocCommentNext s)
+commentToAnnotation (L l (ITdocCommentPrev s))  = L l (AnnDocCommentPrev s)
+commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s)
+commentToAnnotation (L l (ITdocSection n s))    = L l (AnnDocSection n s)
+commentToAnnotation (L l (ITdocOptions s))      = L l (AnnDocOptions s)
+commentToAnnotation (L l (ITdocOptionsOld s))   = L l (AnnDocOptionsOld s)
+commentToAnnotation (L l (ITlineComment s))     = L l (AnnLineComment s)
+commentToAnnotation (L l (ITblockComment s))    = L l (AnnBlockComment s)
+
+-- ---------------------------------------------------------------------
+
+isComment :: Token -> Bool
+isComment (ITlineComment     _)   = True
+isComment (ITblockComment    _)   = True
+isComment _ = False
+
+isDocComment :: Token -> Bool
+isDocComment (ITdocCommentNext  _)   = True
+isDocComment (ITdocCommentPrev  _)   = True
+isDocComment (ITdocCommentNamed _)   = True
+isDocComment (ITdocSection      _ _) = True
+isDocComment (ITdocOptions      _)   = True
+isDocComment (ITdocOptionsOld   _)   = True
+isDocComment _ = False
 }
index 30cd552..36baf1d 100644 (file)
@@ -72,6 +72,7 @@ import Class            ( FunDep )
 import RdrHsSyn
 import Lexer
 import HaddockUtils
+import ApiAnnotation
 
 -- compiler/typecheck
 import TcEvidence       ( emptyTcEvBinds )
@@ -82,6 +83,7 @@ import TysPrim          ( liftedTypeKindTyConName, eqPrimTyCon )
 import TysWiredIn       ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
                           unboxedUnitTyCon, unboxedUnitDataCon,
                           listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
+
 }
 
 {-
@@ -119,7 +121,7 @@ would think the two should never occur in the same context.
 
 Conflicts: 34 shift/reduce
            1 reduce/reduce
-
+q
 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.
 
@@ -224,7 +226,7 @@ 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)) }
+                    (mkTyData NewType (unLoc $2) $4 (unLoc $5)) }
 
 We provide comb3 and comb4 functions which are useful in such cases.
 
@@ -398,7 +400,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
@@ -434,16 +436,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 }
@@ -453,24 +457,33 @@ missing_module_keyword :: { () }
         : {- empty -}                           {% pushCurrentContext }
 
 maybemodwarning :: { Maybe (Located WarningTxt) }
-    : '{-# DEPRECATED' strings '#-}' { Just (sLL $1 $> $
-                                                    DeprecatedTxt $ unLoc $2) }
-    | '{-# WARNING' strings '#-}'    { Just (sLL $1 $> $
-                                                    WarningTxt $ unLoc $2) }
+    : '{-# DEPRECATED' strings '#-}'
+                      {% ajs (Just (sLL $1 $> $ DeprecatedTxt $ snd $ unLoc $2))
+                             (mo $1:mc $1: (fst $ unLoc $2)) }
+    | '{-# WARNING' strings '#-}'
+                         {% ajs (Just (sLL $1 $> $ WarningTxt $ 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 '}'      { (mo $1:mc $3:(fst $2)
+                                         , snd $2) }
+        |      vocurly    top close    { (fst $2, snd $2) }
+
+body2   :: { ([AddAnn]
+             ,([LImportDecl RdrName], [LHsDecl RdrName])) }
+        :  '{' top '}'                          { (mo $1:mc $3
+                                                   :(fst $2), snd $2) }
+        |  missing_module_keyword top close     { ([],snd $2) }
+
+top     :: { ([AddAnn]
+             ,([LImportDecl RdrName], [LHsDecl RdrName])) }
+        : importdecls                   { ([]
+                                          ,(reverse $1,[]))}
+        | importdecls ';' cvtopdecls    { ([mj AnnSemi $2]
+                                          ,(reverse $1,$3))}
+        | cvtopdecls                    { ([],([],$1)) }
 
 cvtopdecls :: { [LHsDecl RdrName] }
         : topdecls                              { cvTopDecls $1 }
@@ -481,8 +494,8 @@ 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
@@ -499,18 +512,23 @@ header_body2 :: { [LImportDecl RdrName] }
 -----------------------------------------------------------------------------
 -- The Export List
 
-maybeexports :: { Maybe (Located [LIE RdrName]) }
-        :  '(' exportlist ')'                   { Just (sLL $1 $> (fromOL $2)) }
-        |  {- empty -}                          { Nothing }
+maybeexports :: { (Maybe (Located [LIE RdrName])) }
+        :  '(' exportlist ')'       {% ams (sLL $1 $> ()) [mo $1,mc $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 }
@@ -525,25 +543,31 @@ 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 $1
-                                                                     (unLoc $2))) }
-        |  'module' modid               { unitOL (sLL $1 $> (IEModuleContents $2)) }
-        |  'pattern' qcon               { unitOL (sLL $1 $> (IEVar $2)) }
-
-export_subspec :: { Located ImpExpSubSpec }
-        : {- empty -}                   { sL0 ImpExpAbs }
-        | '(' '..' ')'                  { sLL $1 $> ImpExpAll }
-        | '(' ')'                       { sLL $1 $> (ImpExpList []) }
-        | '(' qcnames ')'               { sLL $1 $> (ImpExpList (reverse $2)) }
+        : qcname_ext export_subspec  {% amsu (sLL $1 $> (mkModuleImpExp $1
+                                                           (snd $ unLoc $2)))
+                                             (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) }
+        | '(' '..' ')'            { sLL $1 $> ([mo $1,mc $3,mj AnnDotdot $2]
+                                       , ImpExpAll) }
+        | '(' ')'                 { sLL $1 $> ([mo $1,mc $2],ImpExpList []) }
+        | '(' qcnames ')'         { sLL $1 $> ([mo $1,mc $3],ImpExpList (reverse $2)) }
 
 qcnames :: { [Located RdrName] }     -- A reversed list
-        :  qcnames ',' qcname_ext       { $3 : $1 }
+        :  qcnames ',' qcname_ext       {% (aa (head $1) (AnnComma, $2)) >>
+                                           return ($3  : $1) }
         |  qcname_ext                   { [$1]  }
 
 qcname_ext :: { Located RdrName }       -- Variable or data constructor
                                         -- or tagged type constructor
         :  qcname                       { $1 }
-        |  'type' qcname                {% mkTypeImpExp (sLL $1 $> (unLoc $2)) }
+        |  'type' qcname                {% am (mkTypeImpExp (sLL $1 $> (unLoc $2)))
+                                              (AnnType, $1) }
 
 -- Cannot pull into qcname_ext, as qcname is also used in expression.
 qcname  :: { Located RdrName }  -- Variable or data constructor
@@ -557,48 +581,58 @@ qcname  :: { Located RdrName }  -- Variable or data constructor
 -- whereas topdecls must contain at least one topdecl.
 
 importdecls :: { [LImportDecl RdrName] }
-        : importdecls ';' importdecl            { ($3 : $1) }
-        | importdecls ';'                       { $1 }
-        | importdecl                            { [ $1 ] }
-        | {- empty -}                           { [] }
+        : importdecls ';' importdecl  {% (aa $3 (AnnSemi, $2)) >>
+                                         return ($3 : $1) }
+        | importdecls ';'        {% addAnnotation (gl $ head $1) AnnSemi (gl $2)
+              -- AZ: can $1 above ever be [] due to the {- empty -} production?
+                                    >> return $1 }
+        | importdecl             { [$1] }
+        | {- empty -}            { [] }
 
 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 }
+                {% ams (L (comb4 $1 $6 (snd $7) $8) $
+                  ImportDecl { ideclName = $6, ideclPkgQual = snd $5
+                             , ideclSource = snd $2, ideclSafe = snd $3
+                             , ideclQualified = snd $4, ideclImplicit = False
+                             , ideclAs = unLoc (snd $7)
+                             , ideclHiding = unLoc $8 })
+                   ((mj AnnImport $1 : fst $2 ++ fst $3 ++ fst $4
+                                    ++ fst $7) ++ (fst $5)) }
+
+maybe_src :: { ([AddAnn],IsBootInterface) }
+        : '{-# SOURCE' '#-}'           { ([mo $1,mc $2],True) }
+        | {- empty -}                  { ([],False) }
+
+maybe_safe :: { ([AddAnn],Bool) }
+        : 'safe'                                { ([mj AnnSafe $1],True) }
+        | {- empty -}                           { ([],False) }
+
+maybe_pkg :: { ([AddAnn],Maybe FastString) }
+        : STRING                                { ([mj AnnPackageName $1]
+                                                  ,Just (getSTRING $1)) }
+        | {- empty -}                           { ([],Nothing) }
+
+optqualified :: { ([AddAnn],Bool) }
+        : 'qualified'                           { ([mj AnnQualified $1],True)  }
+        | {- empty -}                           { ([],False) }
+
+maybeas :: { ([AddAnn],Located (Maybe ModuleName)) }
+        : 'as' modid                            { ([mj AnnAs $1]
+                                                  ,sLL $1 $> (Just (unLoc $2))) }
+        | {- empty -}                           { ([],noLoc Nothing) }
 
 maybeimpspec :: { Located (Maybe (Bool, Located [LIE RdrName])) }
-        : impspec                               { sL1 $1 (Just (unLoc $1)) }
-        | {- empty -}                           { noLoc Nothing }
+        : impspec                  { L (gl $1) (Just (unLoc $1)) }
+        | {- empty -}              { noLoc Nothing }
 
 impspec :: { Located (Bool, Located [LIE RdrName]) }
-        :  '(' exportlist ')'                   { sLL $1 $> (False,
-                                                      (sLL $1 $> $ fromOL $2)) }
-        |  'hiding' '(' exportlist ')'          { sLL $1 $> (True,
-                                                      (sLL $2 $> $ fromOL $3)) }
+        :  '(' exportlist ')'                 {% ams (sLL $1 $> (False,
+                                                        sLL $1 $> $ fromOL $2))
+                                                      [mo $1,mc $3] }
+        |  'hiding' '(' exportlist ')'        {% ams (sLL $1 $> (True,
+                                                        sLL $1 $> $ fromOL $3))
+                                                 [mj AnnHiding $1,mo $2,mc $4] }
 
 -----------------------------------------------------------------------------
 -- Fixity Declarations
@@ -612,17 +646,20 @@ infix   :: { Located FixityDirection }
         | '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 (gl $3) AnnComma (gl $2) >>
+                                     return (sLL $1 $> (unitOL $3 `appOL` (unLoc $1)))}
+        | op                      { sL1 $1 (unitOL $1) }
 
 -----------------------------------------------------------------------------
 -- Top-Level Declarations
 
 topdecls :: { OrdList (LHsDecl RdrName) }
-        : topdecls ';' topdecl                  { $1 `appOL` $3 }
-        | topdecls ';'                          { $1 }
-        | topdecl                               { $1 }
+        : topdecls ';' topdecl        {% addAnnotation (oll $3) AnnSemi (gl $2)
+                                         >> return ($1 `appOL` $3) }
+        | topdecls ';'                {% addAnnotation (oll $1) AnnSemi (gl $2)
+                                         >> return $1 }
+        | topdecl                     { $1 }
 
 topdecl :: { OrdList (LHsDecl RdrName) }
         : cl_decl                               { unitOL (sL1 $1 (TyClD (unLoc $1))) }
@@ -630,26 +667,41 @@ topdecl :: { OrdList (LHsDecl RdrName) }
         | 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) }
+        | 'default' '(' comma_types0 ')'    {% amsu (sLL $1 $> $ DefD (DefaultDecl $3))
+                                                    [mj AnnDefault $1
+                                                    ,mo $2,mc $4] }
+        | 'foreign' fdecl                       {% amsu (sLL $1 $> (unLoc $2))
+                                                        [mj AnnForeign $1] }
+        | '{-# DEPRECATED' deprecations '#-}'   { $2 } -- ++AZ++ TODO
+        | '{-# WARNING' warnings '#-}'          { $2 } -- ++AZ++ TODO
+        | '{-# RULES' rules '#-}'               { $2 } -- ++AZ++ TODO
+        | '{-# VECTORISE' qvar '=' exp '#-}' {% amsu (sLL $1 $> $ VectD (HsVect $2 $4))
+                                                    [mo $1,mj AnnEqual $3
+                                                    ,mc $5] }
+        | '{-# NOVECTORISE' qvar '#-}'       {% amsu (sLL $1 $> $ VectD (HsNoVect $2))
+                                                     [mo $1,mc $3] }
         | '{-# VECTORISE' 'type' gtycon '#-}'
-                                                { unitOL $ sLL $1 $> $
-                                                    VectD (HsVectTypeIn False $3 Nothing) }
+                                {% amsu (sLL $1 $> $
+                                    VectD (HsVectTypeIn False $3 Nothing))
+                                    [mo $1,mj AnnType $2,mc $4] }
+
         | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}'
-                                                { unitOL $ sLL $1 $> $
-                                                    VectD (HsVectTypeIn True $3 Nothing) }
+                                {% amsu (sLL $1 $> $
+                                    VectD (HsVectTypeIn True $3 Nothing))
+                                    [mo $1,mj AnnType $2,mc $4] }
+
         | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}'
-                                                { unitOL $ sLL $1 $> $
-                                                    VectD (HsVectTypeIn False $3 (Just $5)) }
+                                {% amsu (sLL $1 $> $
+                                    VectD (HsVectTypeIn 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) }
+                                {% amsu (sLL $1 $> $
+                                    VectD (HsVectTypeIn True $3 (Just $5)))
+                                    [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] }
+
+        | '{-# VECTORISE' 'class' gtycon '#-}'
+                                         {% amsu (sLL $1 $>  $ VectD (HsVectClassIn $3))
+                                                 [mo $1,mj AnnClass $2,mc $4] }
         | annotation { unitOL $1 }
         | decl_no_th                            { unLoc $1 }
 
@@ -663,7 +715,8 @@ topdecl :: { OrdList (LHsDecl RdrName) }
 --
 cl_decl :: { LTyClDecl RdrName }
         : 'class' tycl_hdr fds where_cls
-                           {% mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (unLoc $4) }
+                {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (snd $ unLoc $4))
+                        (mj AnnClass $1: (fst $ unLoc $4)) }
 
 -- Type declarations (toplevel)
 --
@@ -677,91 +730,116 @@ 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
                 -- 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 $5) $3
+                                   (unLoc $4))
+                        (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $5)) }
 
           -- 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
+                            (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 $5)) }
 
           -- data/newtype family
         | 'data' 'family' type opt_kind_sig
-                {% mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) }
+                {% amms (mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (unLoc $4))
+                        [mj AnnData $1,mj AnnFamily $2] }
 
 inst_decl :: { LInstDecl RdrName }
         : 'instance' overlap_pragma inst_type where_inst
-            {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (unLoc $4)
-                  ; 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 }
-                  ; return (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 = sigs, cid_tyfam_insts = ats
+                                     , cid_overlap_mode = $2
+                                     , cid_datafam_insts = adts }
+             ; ams (L (comb3 $1 $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 }
+                {% amms (mkTyFamInst (comb2 $1 $3) $3)
+                    [mj AnnType $1,mj AnnInstance $2] }
 
           -- 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) }
+            {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 $4
+                                   (unLoc $5) (snd $ unLoc $6) (unLoc $7))
+                    ((fst $ unLoc $1):mj AnnInstance $2
+                       :(fst $ unLoc $6)) }
 
 overlap_pragma :: { Maybe (Located OverlapMode) }
-  : '{-# OVERLAPPABLE'    '#-}' { Just (sLL $1 $> Overlappable) }
-  | '{-# OVERLAPPING'     '#-}' { Just (sLL $1 $> Overlapping) }
-  | '{-# OVERLAPS'        '#-}' { Just (sLL $1 $> Overlaps) }
-  | '{-# INCOHERENT'      '#-}' { Just (sLL $1 $> Incoherent) }
+  : '{-# OVERLAPPABLE'    '#-}' {% ajs (Just (sLL $1 $> Overlappable))
+                                       [mo $1,mc $2] }
+  | '{-# OVERLAPPING'     '#-}' {% ajs (Just (sLL $1 $> Overlapping))
+                                       [mo $1,mc $2] }
+  | '{-# OVERLAPS'        '#-}' {% ajs (Just (sLL $1 $> Overlaps))
+                                       [mo $1,mc $2] }
+  | '{-# INCOHERENT'      '#-}' {% ajs (Just (sLL $1 $> Incoherent))
+                                       [mo $1,mc $2] }
   | {- empty -}                 { Nothing }
 
 
 -- 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 (reverse (snd $ unLoc $2))) }
+
+ty_fam_inst_eqn_list :: { Located ([AddAnn],[LTyFamInstEqn RdrName]) }
+        :     '{' ty_fam_inst_eqns '}'     { sLL $1 $> ([mo $1,mc $3]
+                                                ,unLoc $2) }
+        | vocurly ty_fam_inst_eqns close   { let L loc _ = $2 in
+                                             L loc ([],unLoc $2) }
+        |     '{' '..' '}'                 { sLL $1 $> ([mo $1,mj AnnDotdot $2
+                                                 ,mc $3],[]) }
+        | vocurly '..' close               { let L loc _ = $2 in
+                                             L loc ([mj AnnDotdot $2],[]) }
 
 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_eqns ';' ty_fam_inst_eqn
+                                      {% addAnnotation (gl $3) AnnSemi (gl $2)
+                                         >> return (sLL $1 $> ($3 : unLoc $1)) }
+        | ty_fam_inst_eqns ';'        {% addAnnotation (gl $1) AnnSemi (gl $2)
+                                         >> return (sLL $1 $>  (unLoc $1)) }
+        | ty_fam_inst_eqn             { sLL $1 $> [$1] }
 
 ty_fam_inst_eqn :: { LTyFamInstEqn RdrName }
         : type '=' ctype
                 -- Note the use of type for the head; this allows
                 -- infix type constructors and type patterns
               {% do { eqn <- mkTyFamInstEqn $1 $3
-                    ; return (sLL $1 $> eqn) } }
+                    ; aa (sLL $1 $> eqn) (AnnEqual, $2) } }
 
 -- Associated type family declarations
 --
@@ -775,24 +853,32 @@ 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)) }
+                {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3
+                                                  (unLoc $4)))
+                        (mj AnnData $1:$2) }
 
            -- 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)) }
+               {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $2 $3)
+                                                  OpenTypeFamily $2 (unLoc $3)))
+                       [mj AnnType $1] }
         | 'type' 'family' type opt_kind_sig
-                {% liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) OpenTypeFamily $3 (unLoc $4)) }
+               {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4)
+                                                  OpenTypeFamily $3 (unLoc $4)))
+                       [mj AnnType $1,mj AnnFamily $2] }
 
            -- default type instances, with optional 'instance' keyword
         | 'type' ty_fam_inst_eqn
-                {% liftM mkInstD (mkTyFamInst (comb2 $1 $2) $2) }
+                {% amms (liftM mkInstD (mkTyFamInst (comb2 $1 $2) $2))
+                        [mj AnnType $1] }
         | 'type' 'instance' ty_fam_inst_eqn
-                {% liftM mkInstD (mkTyFamInst (comb2 $1 $3) $3) }
+                {% amms (liftM mkInstD (mkTyFamInst (comb2 $1 $3) $3))
+                        [mj AnnType $1,mj AnnInstance $2] }
 
-opt_family   :: { () }
-              : {- empty -}   { () }
-              | 'family'      { () }
+opt_family   :: { [AddAnn] }
+              : {- empty -}   { [] }
+              | 'family'      { [mj AnnFamily $1] }
 
 -- Associated type instances
 --
@@ -801,27 +887,31 @@ 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 }
+                {% amms (mkTyFamInst (comb2 $1 $2) $2)
+                        [mj AnnType $1] }
 
         -- 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) }
+                {% amms (mkDataFamInst (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2
+                                $3 (unLoc $4) (snd $ unLoc $5) (unLoc $6))
+                        ((fst $ unLoc $1):(fst $ unLoc $5)) }
 
-data_or_newtype :: { Located NewOrData }
-        : 'data'        { sL1 $1 DataType }
-        | 'newtype'     { sL1 $1 NewType }
+data_or_newtype :: { Located (AddAnn,NewOrData) }
+        : 'data'        { sL1 $1 (mj AnnData    $1,DataType) }
+        | 'newtype'     { sL1 $1 (mj AnnNewtype $1,NewType) }
 
 opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) }
-        :                               { noLoc Nothing }
-        | '::' kind                     { sLL $1 $> (Just $2) }
+        :                             { noLoc Nothing }
+        | '::' kind                   {% ajl (sLL $1 $> (Just $2)) AnnDcolon (gl $1) }
 
 -- tycl_hdr parses the header of a class or data type decl,
 -- which takes the form
@@ -831,31 +921,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         {% return (L (comb2 $1 $2) (unLoc $1))
+                                       >>= \c@(L l _) ->
+                                         (addAnnotation l AnnDarrow (gl $2))
+                                       >> (return (sLL $1 $> (Just c, $3)))
+                                    }
+        | type                      { sL1 $1 (Nothing, $1) }
 
 capi_ctype :: { Maybe (Located CType) }
 capi_ctype : '{-# CTYPE' STRING STRING '#-}'
-                           { Just $ sLL $1 $> (CType
-                                    (Just (Header (getSTRING $2)))
-                                                  (getSTRING $3)) }
+                       {% ajs (Just (sLL $1 $> (CType (Just (Header (getSTRING $2)))
+                                        (getSTRING $3))))
+                              [mo $1,mj AnnHeader $2,mj AnnVal $3,mc $4] }
+
            | '{-# CTYPE'        STRING '#-}'
-                           { Just $ sLL $1 $> (CType Nothing (getSTRING $2)) }
-           |               { Nothing }
+                       {% ajs (Just (sLL $1 $> (CType Nothing  (getSTRING $2))))
+                              [mo $1,mj AnnVal $2,mc $3] }
+
+           |           { 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
+                         {% ams (sLL $1 $> (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)] }
@@ -876,16 +976,22 @@ 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 }
+         {%ams ( let (name, args) = $2
+                 in sLL $1 $> . ValD $ mkPatSynBind name args $4
+                                                    ImplicitBidirectional)
+               [mj AnnPattern $1,mj AnnEqual $3]
+         }
         | 'pattern' pattern_synonym_lhs '<-' pat
-            { let (name, args) = $2
-              in sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional }
+         {%ams (let (name, args) = $2
+                in sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional)
+               [mj AnnPattern $1,mj AnnLarrow $3] }
         | '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) }}
+                  ; mg <- mkPatSynMatchGroup name (snd $ unLoc $5)
+                  ; ams (sLL $1 $> . ValD $
+                           mkPatSynBind name args $4 (ExplicitBidirectional mg))
+                        (mj AnnPattern $1:mj AnnLarrow $3:(fst $ unLoc $5))
+                   }}
 
 pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName)) }
         : con vars0 { ($1, PrefixPatSyn $2) }
@@ -895,10 +1001,12 @@ vars0 :: { [Located RdrName] }
         : {- empty -}                 { [] }
         | varid vars0                 { $1 : $2 }
 
-where_decls :: { Located (OrdList (LHsDecl RdrName)) }
-        : 'where' '{' decls '}'       { $3 }
-        | 'where' vocurly decls close { $3 }
-
+where_decls :: { Located ([AddAnn]
+                         , Located (OrdList (LHsDecl RdrName))) }
+        : 'where' '{' decls '}'       { sLL $1 $> ([mj AnnWhere $1,mo $2
+                                            ,mc $4],$3) }
+        | 'where' vocurly decls close { L (comb2 $1 $3) ([mj AnnWhere $1]
+                                          ,$3) }
 pattern_synonym_sig :: { LSig RdrName }
         : 'pattern' con '::' ptype
             { let (flag, qtvs, prov, req, ty) = unLoc $4
@@ -928,27 +1036,40 @@ decl_cls  : at_decl_cls                 { sLL $1 $> (unitOL $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))) } }
+                          ; ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (GenericSig l ty)))
+                                [mj AnnDefault $1,mj AnnDcolon $3] } }
+
+          -- A 'default' signature used with the generic-programming extension
+          | 'default' infixexp '::' sigtypedoc
+                    {% do { (TypeSig l ty) <- checkValSig $2 $4
+                          ; ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (GenericSig l ty)))
+                                [mj AnnDefault $1,mj AnnDcolon $3] } }
 
 decls_cls :: { Located (OrdList (LHsDecl RdrName)) }    -- Reversed
-          : decls_cls ';' decl_cls      { sLL $1 $> (unLoc $1 `appOL` unLoc $3) }
-          | decls_cls ';'               { sLL $1 $> (unLoc $1) }
+          : decls_cls ';' decl_cls      {% addAnnotation (gl $3) AnnSemi (gl $2)
+                                           >> return (sLL $1 $> ((unLoc $1) `appOL`
+                                                                    unLoc $3)) }
+          | decls_cls ';'               {% addAnnotation (gl $1) AnnSemi (gl $2)
+                                           >> return (sLL $1 $>  (unLoc $1)) }
           | decl_cls                    { $1 }
           | {- empty -}                 { noLoc nilOL }
 
-
 decllist_cls
-        :: { Located (OrdList (LHsDecl RdrName)) }      -- Reversed
-        : '{'         decls_cls '}'     { sLL $1 $> (unLoc $2) }
-        |     vocurly decls_cls close   { $2 }
+        :: { Located ([AddAnn]
+                     , OrdList (LHsDecl RdrName)) }      -- Reversed
+        : '{'         decls_cls '}'     { sLL $1 $>  ([mo $1,mc $3]
+                                             ,unLoc $2) }
+        |     vocurly decls_cls close   { L (gl $2) ([],unLoc $2) }
 
 -- 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
 --
@@ -957,134 +1078,178 @@ decl_inst  : at_decl_inst               { sLL $1 $> (unitOL (sL1 $1 (InstD (unLo
            | 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) }
+           : decls_inst ';' decl_inst   {% addAnnotation (gl $3) AnnSemi (gl $2)
+                                           >> return
+                                            (sLL $1 $> ((unLoc $1) `appOL` unLoc $3)) }
+           | decls_inst ';'             {% addAnnotation (gl $1) AnnSemi (gl $2)
+                                           >> return (sLL $1 $> (unLoc $1)) }
            | decl_inst                  { $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 $> ([mo $1,mc $3],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;
+        : decls ';' decl                {% addAnnotation (gl $3) AnnSemi (gl $2)
+                                           >> return (
+                                          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) }
+                                    sLL $1 $> these) }
+        | decls ';'                     {% addAnnotation (gl $1) AnnSemi (gl $2)
+                                           >> return (sLL $1 $> (unLoc $1)) }
         | decl                          { $1 }
         | {- empty -}                   { noLoc nilOL }
 
-decllist :: { Located (OrdList (LHsDecl RdrName)) }
-        : '{'            decls '}'      { sLL $1 $> (unLoc $2) }
-        |     vocurly    decls close    { $2 }
+decllist :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) }
+        : '{'            decls '}'      { sLL $1 $> ([mo $1,mc $3],unLoc $2) }
+        |     vocurly    decls close    { L (gl $2) ([],unLoc $2) }
 
 -- Binding groups other than those of class and instance declarations
 --
-binds   ::  { Located (HsLocalBinds RdrName) }          -- May have implicit parameters
+binds   ::  { Located ([AddAnn],HsLocalBinds RdrName) }
+                                         -- May have implicit parameters
                                                 -- No type declarations
-        : decllist                      {% do { val_binds <- cvBindGroup (unLoc $1)
-                                              ; return (sL1 $1 (HsValBinds val_binds)) } }
-        | '{'            dbinds '}'     { sLL $1 $> (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
-        |     vocurly    dbinds close   { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
+        : decllist          {% do { val_binds <- cvBindGroup (snd $ unLoc $1)
+                                  ; return (sL1 $1 (fst $ unLoc $1
+                                                    ,HsValBinds val_binds)) } }
+
+        | '{'            dbinds '}'     { sLL $1 $> ([mo $1,mc $3]
+                                             ,HsIPBinds (IPBinds (unLoc $2)
+                                                         emptyTcEvBinds)) }
+
+        |     vocurly    dbinds close   { L (getLoc $2) ([]
+                                            ,HsIPBinds (IPBinds (unLoc $2)
+                                                        emptyTcEvBinds)) }
 
-wherebinds :: { Located (HsLocalBinds RdrName) }        -- May have implicit parameters
+
+wherebinds :: { Located ([AddAnn],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 ([],emptyLocalBinds) }
 
 
 -----------------------------------------------------------------------------
 -- Transformation Rules
 
 rules   :: { OrdList (LHsDecl RdrName) }
-        :  rules ';' rule                       { $1 `snocOL` $3 }
-        |  rules ';'                            { $1 }
-        |  rule                                 { unitOL $1 }
-        |  {- empty -}                          { nilOL }
+        :  rules ';' rule              {% addAnnotation (gl $3) AnnSemi (gl $2)
+                                          >> return ($1 `snocOL` $3) }
+        |  rules ';'                   {% addAnnotation (oll $1) AnnSemi (gl $2)
+                                          >> return $1 }
+        |  rule                        { unitOL $1 }
+        |  {- empty -}                 { nilOL }
 
 rule    :: { LHsDecl RdrName }
         : STRING rule_activation rule_forall infixexp '=' exp
-             { sLL $1 $> $ RuleD (HsRule (sL1 $1 (getSTRING $1))
-                                  ($2 `orElse` AlwaysActive)
-                                  $3 $4 placeHolderNames $6 placeHolderNames) }
+         {%ams (sLL $1 $> $ RuleD (HsRule (L (gl $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 :: { [LRuleBndr RdrName] }
-        : 'forall' rule_var_list '.'            { $2 }
-        | {- empty -}                           { [] }
+rule_activation :: { ([AddAnn],Maybe Activation) }
+        : {- empty -}                           { ([],Nothing) }
+        | rule_explicit_activation              { (fst $1,Just (snd $1)) }
+
+rule_explicit_activation :: { ([AddAnn]
+                              ,Activation) }  -- In brackets
+        : '[' INTEGER ']'       { ([mo $1,mj AnnVal $2,mc $3]
+                                  ,ActiveAfter  (fromInteger (getINTEGER $2))) }
+        | '[' '~' INTEGER ']'   { ([mo $1,mj AnnTilde $2,mj AnnVal $3,mc $4]
+                                  ,ActiveBefore (fromInteger (getINTEGER $3))) }
+        | '[' '~' ']'           { ([mo $1,mj AnnTilde $2,mc $3]
+                                  ,NeverActive) }
+
+rule_forall :: { ([AddAnn],[LRuleBndr RdrName]) }
+        : 'forall' rule_var_list '.'     { ([mj AnnForall $1,mj AnnDot $3],$2) }
+        | {- empty -}                    { ([],[]) }
 
 rule_var_list :: { [LRuleBndr RdrName] }
         : rule_var                              { [$1] }
         | rule_var rule_var_list                { $1 : $2 }
 
 rule_var :: { LRuleBndr RdrName }
-        : varid                       { sLL $1 $> $ RuleBndr $1 }
-        | '(' varid '::' ctype ')'    { sLL $1 $> $ RuleBndrSig $2 (mkHsWithBndrs $4) }
+        : varid                           { sLL $1 $> (RuleBndr $1) }
+        | '(' varid '::' ctype ')'        {% ams (sLL $1 $> (RuleBndrSig $2
+                                                         (mkHsWithBndrs $4)))
+                                                 [mo $1,mj AnnDcolon $3,mc $5] }
 
 -----------------------------------------------------------------------------
 -- Warnings and deprecations (c.f. rules)
 
 warnings :: { OrdList (LHsDecl RdrName) }
-        : warnings ';' warning          { $1 `appOL` $3 }
-        | warnings ';'                  { $1 }
-        | warning                               { $1 }
-        | {- empty -}                           { nilOL }
+        : warnings ';' warning         {% addAnnotation (oll $3) 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) }
         : namelist strings
-                { toOL [ sLL $1 $> $ WarningD (Warning n (WarningTxt $ unLoc $2))
+                { toOL [ sLL $1 $> $ WarningD (Warning n (WarningTxt $ snd $ unLoc $2))
                        | n <- unLoc $1 ] }
 
 deprecations :: { OrdList (LHsDecl RdrName) }
-        : deprecations ';' deprecation          { $1 `appOL` $3 }
-        | deprecations ';'                      { $1 }
-        | deprecation                           { $1 }
-        | {- empty -}                           { nilOL }
+        : deprecations ';' deprecation
+                                       {% addAnnotation (oll $3) 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) }
         : namelist strings
-                { toOL [ sLL $1 $> $ WarningD (Warning n (DeprecatedTxt $ unLoc $2))
-                       | n <- unLoc $1 ] }
+             { toOL [ sLL $1 $> $ WarningD (Warning n (DeprecatedTxt $ snd $ unLoc $2))
+                    | n <- unLoc $1 ] }
 
-strings :: { Located [Located FastString] }
-    : STRING { sL1 $1 [sL1 $1 (getSTRING $1)] }
-    | '[' stringlist ']' { sLL $1 $> $ fromOL (unLoc $2) }
+strings :: { Located ([AddAnn],[Located FastString]) }
+    : STRING { sL1 $1 ([],[L (gl $1) (getSTRING $1)]) }
+    | '[' stringlist ']' { sLL $1 $> $ ([mo $1,mc $3],fromOL (unLoc $2)) }
 
 stringlist :: { Located (OrdList (Located FastString)) }
-    : stringlist ',' STRING { sLL $1 $> (unLoc $1 `snocOL`
-                                               (L (getLoc $3) (getSTRING $3))) }
-    | STRING                { sLL $1 $> (unitOL (sLL $1 $> (getSTRING $1))) }
+    : stringlist ',' STRING {% addAnnotation (gl $3) AnnComma (gl $2) >>
+                               return (sLL $1 $> (unLoc $1 `snocOL`
+                                                  (L (gl $3) (getSTRING $3)))) }
+    | STRING                { sLL $1 $> (unitOL (L (gl $1) (getSTRING $1))) }
 
 -----------------------------------------------------------------------------
 -- 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
+                                            (ValueAnnProvenance (unLoc $2)) $3))
+                                            [mo $1,mc $4] }
+
+    | '{-# ANN' 'type' tycon aexp '#-}'  {% ams (sLL $1 $> (AnnD $ HsAnnotation
+                                            (TypeAnnProvenance (unLoc $3)) $4))
+                                            [mo $1,mj AnnType $2,mc $5] }
+
+    | '{-# ANN' 'module' aexp '#-}'      {% ams (sLL $1 $> (AnnD $ HsAnnotation
+                                                 ModuleAnnProvenance $3))
+                                                [mo $1,mj AnnModule $2,mc $4] }
 
 
 -----------------------------------------------------------------------------
@@ -1092,18 +1257,20 @@ annotation :: { LHsDecl RdrName }
 
 fdecl :: { LHsDecl RdrName }
 fdecl : 'import' callconv safety fspec
-                {% mkImport $2 $3 (unLoc $4) >>= return.sLL $1 $> }
+                {% mkImport $2 $3 (snd $ unLoc $4) >>= \i ->
+                  ams (sLL $1 $> i) (mj AnnImport $1 : (fst $ unLoc $4)) }
       | 'import' callconv        fspec
-                {% do { d <- mkImport $2 (noLoc PlaySafe) (unLoc $3);
-                        return (sLL $1 $> d) } }
+                {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3);
+                        ams (sLL $1 $> d) (mj AnnImport $1 : (fst $ unLoc $3)) } }
       | 'export' callconv fspec
-                {% mkExport $2 (unLoc $3) >>= return.sLL $1 $> }
+                {% mkExport $2 (snd $ unLoc $3) >>= \i ->
+                   ams (sLL $1 $> i) (mj AnnExport $1 : (fst $ unLoc $3)) }
 
 callconv :: { Located CCallConv }
-          : 'stdcall'                   { sLL $1 $> StdCallConv  }
-          | 'ccall'                     { sLL $1 $> CCallConv    }
-          | 'capi'                      { sLL $1 $> CApiConv     }
-          | 'prim'                      { sLL $1 $> PrimCallConv }
+          : 'stdcall'                   { sLL $1 $> StdCallConv }
+          | 'ccall'                     { sLL $1 $> CCallConv   }
+          | 'capi'                      { sLL $1 $> CApiConv    }
+          | 'prim'                      { sLL $1 $> PrimCallConv}
           | 'javascript'                { sLL $1 $> JavaScriptCallConv }
 
 safety :: { Located Safety }
@@ -1111,9 +1278,13 @@ safety :: { Located Safety }
         | 'safe'                        { sLL $1 $> PlaySafe }
         | 'interruptible'               { sLL $1 $> PlayInterruptible }
 
-fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
-       : STRING var '::' sigtypedoc     { sLL $1 $> (L (getLoc $1) (getSTRING $1), $2, $4) }
-       |        var '::' sigtypedoc     { sLL $1 $> (noLoc nilFS, $1, $3) }
+fspec :: { Located ([AddAnn]
+                    ,(Located FastString, Located RdrName, LHsType RdrName)) }
+       : STRING var '::' sigtypedoc     { sLL $1 $> ([mj AnnDcolon $3]
+                                             ,(L (getLoc $1)
+                                                    (getSTRING $1), $2, $4)) }
+       |        var '::' sigtypedoc     { sLL $1 $> ([mj AnnDcolon $2]
+                                             ,(noLoc nilFS, $1, $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
@@ -1121,13 +1292,13 @@ 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                  { ([mj AnnDcolon $1],Just $2) }
 
-opt_asig :: { Maybe (LHsType RdrName) }
-        : {- empty -}                   { Nothing }
-        | '::' atype                    { Just $2 }
+opt_asig :: { ([AddAnn],Maybe (LHsType RdrName)) }
+        : {- empty -}                   { ([],Nothing) }
+        | '::' atype                    { ([mj AnnDcolon $1],Just $2) }
 
 sigtype :: { LHsType RdrName }          -- Always a HsForAllTy,
                                         -- to tell the renamer where to generalise
@@ -1138,32 +1309,39 @@ sigtypedoc :: { LHsType RdrName }       -- Always a HsForAllTy
         : ctypedoc                      { sL1 $1 (mkImplicitHsForAllTy (noLoc []) $1) }
         -- Wrap an Implicit forall if there isn't one there already
 
-sig_vars :: { Located [Located RdrName] }  -- Returned in reversed order
-         : sig_vars ',' var             { sLL $1 $> ($3 : unLoc $1) }
-         | var                          { sL1 $1 [$1] }
+sig_vars :: { Located [Located RdrName] }    -- Returned in reversed order
+         : sig_vars ',' var            {% addAnnotation (gl $3) AnnComma (gl $2)
+                                          >> return (sLL $1 $> ($3 : unLoc $1)) }
+         | var                         { sL1 $1 [$1] }
 
-sigtypes1 :: { [LHsType RdrName] }      -- Always HsForAllTys
-        : sigtype                       { [ $1 ] }
-        | sigtype ',' sigtypes1         { $1 : $3 }
+sigtypes1 :: { (OrdList (LHsType RdrName)) }      -- Always HsForAllTys
+        : sigtype                      { unitOL $1 }
+        | sigtype ',' sigtypes1        {% addAnnotation (gl $1) AnnComma (gl $2)
+                                          >> return ((unitOL $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) }
+strict_mark :: { Located ([AddAnn],HsBang) }
+        : '!'                        { sL1 $1 ([],HsUserBang Nothing      True) }
+        | '{-# UNPACK' '#-}'         { sLL $1 $> ([mo $1,mc $2],HsUserBang (Just True)  False) }
+        | '{-# NOUNPACK' '#-}'       { sLL $1 $> ([mo $1,mc $2],HsUserBang (Just False) True) }
+        | '{-# UNPACK' '#-}' '!'     { sLL $1 $> ([mo $1,mc $2],HsUserBang (Just True)  True) }
+        | '{-# NOUNPACK' '#-}' '!'   { sLL $1 $> ([mo $1,mc $2],HsUserBang (Just False) True) }
         -- Although UNPACK with no '!' is illegal, we get a
         -- better error message if we parse it here
 
 -- 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) }
+                                           ams (sLL $1 $> $ mkExplicitHsForAllTy $2
+                                                                 (noLoc []) $4)
+                                               [mj AnnForall $1,mj AnnDot $3] }
+        | context '=>' ctype            {% ams (sLL $1 $> $ mkQualifiedHsForAllTy
+                                                                         $1 $3)
+                                              [mj AnnDarrow $2] }
+        | ipvar '::' type               {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
+                                               [mj AnnDcolon $2] }
         | type                          { $1 }
 
 ----------------------
@@ -1179,10 +1357,14 @@ 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 $> $ mkExplicitHsForAllTy $2
+                                                                  (noLoc []) $4)
+                                                [mj AnnForall $1,mj AnnDot $3] }
+        | context '=>' ctypedoc        {% ams (sLL $1 $> $ mkQualifiedHsForAllTy $1 $3)
+                                              [mj AnnDarrow $2] }
+        | ipvar '::' type              {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3))
+                                              [mj AnnDcolon $2] }
+        | typedoc                      { $1 }
 
 ----------------------
 -- Notes for 'context'
@@ -1196,16 +1378,19 @@ ctypedoc :: { LHsType RdrName }
 -- Thus for some reason we allow    f :: a~b => blah
 -- but not                          f :: ?x::Int => blah
 context :: { LHsContext RdrName }
-        : btype '~'      btype          {% checkContext
-                                             (sLL $1 $> $ HsEqTy $1 $3) }
+        : btype '~'      btype          {% amms (checkContext
+                                             (sLL $1 $> $ HsEqTy $1 $3))
+                                             [mj AnnTilde $2] }
         | btype                         {% checkContext $1 }
 
 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 }
+        | btype '->'     ctype          {% ams (sLL $1 $> $ HsFunTy $1 $3)
+                                               [mj AnnRarrow $2] }
+        | btype '~'      btype          {% ams (sLL $1 $> $ HsEqTy $1 $3)
+                                               [mj AnnTilde $2] }
                                         -- see Note [Promotion]
         | btype SIMPLEQUOTE qconop type     { sLL $1 $> $ mkHsOpTy $1 $3 $4 }
         | btype SIMPLEQUOTE varop  type     { sLL $1 $> $ mkHsOpTy $1 $3 $4 }
@@ -1217,9 +1402,13 @@ typedoc :: { LHsType RdrName }
         | 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 }
+        | btype '->'     ctypedoc        {% ams (sLL $1 $> $ HsFunTy $1 $3)
+                                                [mj AnnRarrow $2] }
+        | btype docprev '->' ctypedoc    {% ams (sLL $1 $> $ HsFunTy (L (comb2 $1 $2)
+                                                            (HsDocTy $1 $2)) $4)
+                                                [mj AnnRarrow $3] }
+        | btype '~'      btype           {% ams (sLL $1 $> $ HsEqTy $1 $3)
+                                                [mj AnnTilde $2] }
                                         -- see Note [Promotion]
         | btype SIMPLEQUOTE qconop type     { sLL $1 $> $ mkHsOpTy $1 $3 $4 }
         | btype SIMPLEQUOTE varop  type     { sLL $1 $> $ mkHsOpTy $1 $3 $4 }
@@ -1231,31 +1420,47 @@ btype :: { LHsType RdrName }
 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 }
+        | 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
+                                                 [mo $1,mc $3] }
+        | '(' ')'                        {% ams (sLL $1 $> $ HsTupleTy
+                                                    HsBoxedOrConstraintTuple [])
+                                                [mo $1,mc $2] }
+        | '(' ctype ',' comma_types1 ')' {% ams (sLL $1 $> $ HsTupleTy
+                                             HsBoxedOrConstraintTuple ($2 : $4))
+                                                [mo $1,mj AnnComma $3,mc $5] }
+        | '(#' '#)'                   {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple [])
+                                             [mo $1,mc $2] }
+        | '(#' comma_types1 '#)'      {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple $2)
+                                             [mo $1,mc $3] }
+        | '[' ctype ']'               {% ams (sLL $1 $> $ HsListTy  $2) [mo $1,mc $3] }
+        | '[:' ctype ':]'             {% ams (sLL $1 $> $ HsPArrTy  $2) [mo $1,mc $3] }
+        | '(' ctype ')'               {% ams (sLL $1 $> $ HsParTy   $2) [mo $1,mc $3] }
+        | '(' ctype '::' kind ')'     {% ams (sLL $1 $> $ HsKindSig $2 $4)
+                                             [mo $1,mj AnnDcolon $3,mc $5] }
+        | quasiquote                  { sL1 $1 (HsQuasiQuoteTy (unLoc $1)) }
+        | '$(' exp ')'                {% ams (sLL $1 $> $ mkHsSpliceTy $2)
+                                             [mo $1,mc $3] }
+        | 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 ')'
+                                    {% ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5))
+                                           [mo $2,mj AnnComma $4,mc $6] }
+        | SIMPLEQUOTE  '[' comma_types0 ']'     {% ams (sLL $1 $> $ HsExplicitListTy
+                                                            placeHolderKind $3)
+                                                       [mo $2,mc $4] }
         | 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 }
+        | '[' ctype ',' comma_types1 ']'  {% ams (sLL $1 $> $ HsExplicitListTy
+                                                     placeHolderKind ($2 : $4))
+                                                 [mo $1, mj AnnComma $3,mc $5] }
+        | INTEGER                     { sLL $1 $> $ HsTyLit $ HsNumTy $ getINTEGER $1 }
+        | STRING                      { sLL $1 $> $ HsTyLit $ HsStrTy $ getSTRING  $1 }
 
 -- An inst_type is what occurs in the head of an instance decl
 --      e.g.  (Foo a, Gaz b) => Wibble a b
@@ -1266,15 +1471,18 @@ inst_type :: { LHsType RdrName }
 
 inst_types1 :: { [LHsType RdrName] }
         : inst_type                     { [$1] }
-        | inst_type ',' inst_types1     { $1 : $3 }
+
+        | inst_type ',' inst_types1    {% addAnnotation (gl $1) AnnComma (gl $2)
+                                          >> return ($1 : $3) }
 
 comma_types0  :: { [LHsType RdrName] }
         : comma_types1                  { $1 }
         | {- empty -}                   { [] }
 
 comma_types1    :: { [LHsType RdrName] }
-        : ctype                         { [$1] }
-        | ctype  ',' comma_types1       { $1 : $3 }
+        : ctype                        { [$1] }
+        | ctype  ',' comma_types1      {% addAnnotation (gl $1) AnnComma (gl $2)
+                                          >> return ($1 : $3) }
 
 tv_bndrs :: { [LHsTyVarBndr RdrName] }
          : tv_bndr tv_bndrs             { $1 : $2 }
@@ -1282,19 +1490,24 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
 
 tv_bndr :: { LHsTyVarBndr RdrName }
         : tyvar                         { sL1 $1 (UserTyVar (unLoc $1)) }
-        | '(' tyvar '::' kind ')'       { sLL $1 $> (KindedTyVar (unLoc $2) $4) }
+        | '(' tyvar '::' kind ')'       {% ams (sLL $1 $>  (KindedTyVar (unLoc $2) $4))
+                                               [mo $1,mj AnnDcolon $3
+                                               ,mc $5] }
 
 fds :: { Located [Located (FunDep RdrName)] }
         : {- empty -}                   { noLoc [] }
-        | '|' fds1                      { sLL $1 $> (reverse (unLoc $2)) }
+        | '|' fds1                      {% ams (sLL $1 $> (reverse (unLoc $2)))
+                                                [mj AnnVbar $1] }
 
 fds1 :: { Located [Located (FunDep RdrName)] }
-        : fds1 ',' fd                   { sLL $1 $> ($3 : unLoc $1) }
-        | fd                            { sL1 $1 [$1] }
+        : fds1 ',' fd                  {% addAnnotation (gl $3) AnnComma (gl $2)
+                                          >> return (sLL $1 $> ($3 : unLoc $1)) }
+        | fd                           { sL1 $1 [$1] }
 
 fd :: { Located (FunDep RdrName) }
-        : varids0 '->' varids0          { L (comb3 $1 $2 $3)
-                                           (reverse (unLoc $1), reverse (unLoc $3)) }
+        : varids0 '->' varids0  {% ams (L (comb3 $1 $2 $3)
+                                       (reverse (unLoc $1), reverse (unLoc $3)))
+                                       [mj AnnRarrow $2] }
 
 varids0 :: { Located [RdrName] }
         : {- empty -}                   { noLoc [] }
@@ -1305,7 +1518,8 @@ varids0 :: { Located [RdrName] }
 
 kind :: { LHsKind RdrName }
         : bkind                  { $1 }
-        | bkind '->' kind        { sLL $1 $> $ HsFunTy $1 $3 }
+        | bkind '->' kind        {% ams (sLL $1 $> $ HsFunTy $1 $3)
+                                        [mj AnnRarrow $2] }
 
 bkind :: { LHsKind RdrName }
         : akind                  { $1 }
@@ -1313,19 +1527,25 @@ bkind :: { LHsKind RdrName }
 
 akind :: { LHsKind RdrName }
         : '*'                    { sL1 $1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) }
-        | '(' kind ')'           { sLL $1 $> $ HsParTy $2 }
+        | '(' kind ')'           {% ams (sLL $1 $>  $ HsParTy $2)
+                                        [mo $1,mc $3] }
         | 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 }
+        | '(' ')'                   {% ams (sLL $1 $> $ HsTyVar $ getRdrName unitTyCon)
+                                           [mo $1,mc $2] }
+        | '(' kind ',' comma_kinds1 ')'   {% ams (sLL $1 $> $ HsTupleTy HsBoxedTuple
+                                                                     ( $2 : $4))
+                                                 [mo $1,mj AnnComma $3,mc $5] }
+        | '[' kind ']'                    {% ams (sLL $1 $> $ HsListTy $2)
+                                                 [mo $1,mc $3] }
 
 comma_kinds1 :: { [LHsKind RdrName] }
-        : kind                          { [$1] }
-        | kind  ',' comma_kinds1        { $1 : $3 }
+        : kind                         { [$1] }
+        | kind  ',' comma_kinds1       {% addAnnotation (gl $1) AnnComma (gl $2)
+                                          >> return ($1 : $3) }
 
 {- Note [Promotion]
    ~~~~~~~~~~~~~~~~
@@ -1358,14 +1578,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
+                                                     ,mo $2
+                                                     ,mc $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  { sLL $1 $> ($1 : unLoc $3) }
-        | gadt_constr                   { sLL $1 $> [$1] }
+        : gadt_constr ';' gadt_constrs
+                  {% addAnnotation (gl $1) AnnSemi (gl $2)
+                     >> return (L (comb2 $1 $3) ($1 : unLoc $3)) }
+        | gadt_constr                   { L (gl $1) [$1] }
         | {- empty -}                   { noLoc [] }
 
 -- We allow the following forms:
@@ -1375,36 +1604,45 @@ gadt_constrs :: { Located [LConDecl RdrName] }
 --      forall a. Eq a => D { x,y :: a } :: T a
 
 gadt_constr :: { LConDecl RdrName }
-                                   -- Returns a list because of:   C,D :: ty
+                   -- Returns a list because of:   C,D :: ty
         : con_list '::' sigtype
-                { sLL $1 $> $ mkGadtDecl (unLoc $1) $3 }
+                {%ams (sLL $1 $> $ mkGadtDecl (unLoc $1) $3)
+                      [mj 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' } }
+                      ; ams (L (comb2 $1 $6) (unLoc cd'))
+                            [mo $2,mc $4,mj AnnDcolon $5] } }
 
-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 $5) 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) }
+                {% ams (let (con,details) = unLoc $5 in
+                  addConDoc (L (comb4 $2 $3 $4 $5) (mkSimpleConDecl con
+                                                   (snd $ unLoc $2) $3 details))
+                            ($1 `mplus` $6))
+                        (mj 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) (mkSimpleConDecl 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],[LHsTyVarBndr RdrName]) }
+        : 'forall' tv_bndrs '.'       { sLL $1 $> ([mj AnnForall $1,mj AnnDot $3],$2) }
+        | {- empty -}                 { noLoc ([],[]) }
 
 constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) }
 -- We parse the constructor declaration
@@ -1423,26 +1661,32 @@ fielddecls :: { [LConDeclField RdrName] }
 
 fielddecls1 :: { [LConDeclField RdrName] }
         : fielddecl maybe_docnext ',' maybe_docprev fielddecls1
-            { (addFieldDoc $1 $4) : addFieldDocs $5 $2 }
+            {% 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
-                  { L (comb2 $2 $4)
-                      (ConDeclField (reverse (unLoc $2)) $4 ($1 `mplus` $5)) }
+            {% ams (L (comb2 $2 $4)
+                      (ConDeclField (reverse (unLoc $2)) $4 ($1 `mplus` $5)))
+                   [mj AnnDcolon $3] }
 
 -- 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 (Located [LHsType RdrName])) }
-        : {- empty -}                       { noLoc Nothing }
-        | 'deriving' qtycon
-                       { let { L loc tv = $2 }
-                         in sLL $1 $>  (Just (sLL $1 $> [L loc (HsTyVar tv)])) }
-        | 'deriving' '(' ')'                { sLL $1 $> (Just (noLoc [])) }
-        | 'deriving' '(' inst_types1 ')'    { sLL $1 $> (Just (sLL $1 $> $3)) }
+        : {- empty -}             { noLoc Nothing }
+        | 'deriving' qtycon       {% aljs ( let { L loc tv = $2 }
+                                            in (sLL $1 $> (Just (sLL $1 $>
+                                                       [L loc (HsTyVar tv)]))))
+                                          [mj AnnDeriving $1] }
+        | 'deriving' '(' ')'      {% aljs (sLL $1 $> (Just (sLL $1 $> [])))
+                                          [mj AnnDeriving $1,mo $2,mc $3] }
+
+        | 'deriving' '(' inst_types1 ')'  {% aljs (sLL $1 $> (Just (sLL $1 $> $3)))
+                                                 [mj AnnDeriving $1,mo $2,mc $4] }
              -- Glasgow extension: allow partial
              -- applications in derivings
 
@@ -1485,16 +1729,23 @@ decl_no_th :: { Located (OrdList (LHsDecl RdrName)) }
 
         | '!' aexp rhs          {% do { let { e = sLL $1 $> (SectionR (sLL $1 $> (HsVar bang_RDR)) $2) };
                                         pat <- checkPattern empty e;
+                                        _ <- ams (sLL $1 $> ())
+                                               (mj AnnBang $1:(fst $ unLoc $3));
                                         return $ sLL $1 $> $ unitOL $ sLL $1 $> $ ValD $
-                                               PatBind pat (unLoc $3)
-                                                       placeHolderType
-                                                       placeHolderNames
-                                                       (Nothing,[]) } }
+                                            PatBind pat (snd $ unLoc $3)
+                                                    placeHolderType
+                                                    placeHolderNames
+                                                    (Nothing,[]) } }
                                 -- 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 { r <- checkValDef empty $1 (snd $2) $3;
                                         let { l = comb2 $1 $> };
+                                        case r of {
+                                          (FunBind n _ _ _ _ _) ->
+                                                ams (L l ()) [mj AnnFunId n] >> return () ;
+                                          _ -> return () } ;
+                                        _ <- ams (L l ()) (fst $ unLoc $3);
                                         return $! (sL l (unitOL $! (sL l $ ValD r))) } }
         | pattern_synonym_decl  { sLL $1 $> $ unitOL $1 }
         | docdecl               { sLL $1 $> $ unitOL $1 }
@@ -1507,55 +1758,80 @@ decl    :: { Located (OrdList (LHsDecl RdrName)) }
         -- fails terribly with a panic in cvBindsAndSigs otherwise.
         | splice_exp            { sLL $1 $> $ unitOL (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 (comb2 $1 $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)) }
         :
         -- See Note [Declaration/signature overlap] for why we need infixexp here
           infixexp '::' sigtypedoc
                         {% do s <- checkValSig $1 $3
+                        ; _ <- ams (sLL $1 $> ()) [mj AnnDcolon $2]
                         ; return (sLL $1 $> $ unitOL (sLL $1 $> $ SigD s)) }
+
         | var ',' sig_vars '::' sigtypedoc
-                { sLL $1 $> $ toOL [ sLL $1 $> $ SigD
-                              (TypeSig ($1 : reverse (unLoc $3)) $5) ] }
+           {% ams (sLL $1 $> $ toOL [ sLL $1 $> $ SigD (TypeSig ($1:reverse (unLoc $3)) $5) ])
+                  [mj AnnComma $2,mj AnnDcolon $4] }
+
         | infix prec ops
-                { sLL $1 $> $ toOL [ sLL $1 $> $ SigD
-                      (FixSig (FixitySig (unLoc $3) (Fixity $2 (unLoc $1)))) ] }
+              { sLL $1 $> $ toOL [ sLL $1 $> $ SigD
+                     (FixSig (FixitySig (fromOL $ unLoc $3) (Fixity $2 (unLoc $1)))) ] }
 
         | pattern_synonym_sig   { sLL $1 $> $ unitOL $ sLL $1 $> . SigD . unLoc $ $1 }
 
         | '{-# INLINE' activation qvar '#-}'
-                { sLL $1 $> $ unitOL (sLL $1 $> $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) }
+                {% ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (InlineSig $3
+                                     (mkInlinePragma (getINLINE $1) (snd $2)))))
+                       (mo $1:mc $4:fst $2) }
+
+        -- AZ TODO: adjust hsSyn so all the SpecSig from a single SPECIALISE
+        --          pragma is kept together
         | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
-                { let inl_prag = mkInlinePragma (EmptyInlineSpec, FunLike) $2
+             {% ams (
+                 let inl_prag = mkInlinePragma (EmptyInlineSpec, FunLike) (snd $2)
                   in sLL $1 $> $
-                            toOL [ sLL $1 $> $ SigD (SpecSig $3 $5 inl_prag) ] }
+                            toOL [ sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) inl_prag) ])
+                    (mo $1:mj AnnDcolon $4:mc $6:(fst $2)) }
 
         | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
-                { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 $5
-                                    (mkInlinePragma (getSPEC_INLINE $1) $2)) ] }
+             {% ams (sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 (fromOL $5)
+                               (mkInlinePragma (getSPEC_INLINE $1) (snd $2))) ])
+                       (mo $1:mj AnnDcolon $4:mc $6:(fst $2)) }
+
         | '{-# SPECIALISE' 'instance' inst_type '#-}'
-                { sLL $1 $> $ unitOL (sLL $1 $> $ SigD (SpecInstSig $3)) }
+                {% ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (SpecInstSig $3)))
+                       [mo $1,mj AnnInstance $2,mc $4] }
+
+        -- AZ TODO: Do we need locations in the name_formula_opt?
         -- A minimal complete definition
         | '{-# MINIMAL' name_boolformula_opt '#-}'
-                { sLL $1 $> $ unitOL (sLL $1 $> $ SigD (MinimalSig $2)) }
+            {% ams (sLL $1 $> $ unitOL (sLL $1 $> $ SigD (MinimalSig (snd $2))))
+                   (mo $1:mc $3:fst $2) }
 
-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 AnnOpen $1,mj AnnVal $2,mj AnnClose $3]
+                                  ,ActiveAfter  (fromInteger (getINTEGER $2))) }
+        | '[' '~' INTEGER ']'   { ([mj AnnOpen $1,mj AnnTilde $2,mj AnnVal $3
+                                                 ,mj AnnClose $4]
+                                  ,ActiveBefore (fromInteger (getINTEGER $3))) }
 
 -----------------------------------------------------------------------------
 -- Expressions
@@ -1571,15 +1847,20 @@ 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 $3)
+                                       [mj AnnDcolon $2] }
+        | infixexp '-<' exp     {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType
+                                                        HsFirstOrderApp True)
+                                       [mj Annlarrowtail $2] }
+        | infixexp '>-' exp     {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType
+                                                      HsFirstOrderApp False)
+                                       [mj Annrarrowtail $2] }
+        | infixexp '-<<' exp    {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType
+                                                      HsHigherOrderApp True)
+                                       [mj AnnLarrowtail $2] }
+        | infixexp '>>-' exp    {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType
+                                                      HsHigherOrderApp False)
+                                       [mj AnnRarrowtail $2] }
         | infixexp              { $1 }
 
 infixexp :: { LHsExpr RdrName }
@@ -1588,44 +1869,68 @@ infixexp :: { LHsExpr RdrName }
 
 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 ($2:$3) (snd $4) (unguardedGRHSs $6)]))
+                          [mj AnnLam $1,mj AnnRarrow $5] }
+        | '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        {% do { on <- extension sccProfilingOn
+                                     ; ams (sLL $1 $> $ if on
+                                                         then HsSCC (snd $ unLoc $1) $2
+                                                         else HsPar $2)
+                                           (fst $ unLoc $1) } }
+
+        | hpc_annot exp        {% do { on <- extension hpcEnabled
+                                       ; ams (sLL $1 $> $ if on
+                                                           then HsTickPragma
+                                                                    (snd $ unLoc $1) $2
+                                                           else HsPar $2)
+                                             (fst $ unLoc $1) } }
 
         | '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 }
+                       {% 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,mj AnnRarrow $3] }
+
+        | '{-# CORE' STRING '#-}' exp  {% ams (sLL $1 $> $ HsCoreAnn (getSTRING $2) $4)
+                                              [mo $1,mj AnnVal $2
+                                              ,mc $3] }
+                                          -- hdaume: core annotation
+        | fexp                         { $1 }
 
         -- parsing error messages go below here
         | '\\' apat apats opt_asig '->'              {% parseErrorSDoc (combineLocs $1 $5) $ text
@@ -1657,40 +1962,51 @@ exp10 :: { LHsExpr RdrName }
         | '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
-                                                        )
-                                                       )
-                                                 }
+optSemi :: { ([Located a],Bool) }
+        : ';'         { ([$1],True) }
+        | {- empty -} { ([],False) }
+
+scc_annot :: { Located ([AddAnn],FastString) }
+        : '{-# SCC' STRING '#-}'      {% do scc <- getSCC $2
+                                            ; return $ sLL $1 $>
+                                               ([mo $1,mj AnnVal $2
+                                                ,mc $3],scc) }
+        | '{-# SCC' VARID  '#-}'      { sLL $1 $> ([mo $1,mj AnnVal $2
+                                         ,mc $3]
+                                        ,(getVARID $2)) }
+
+hpc_annot :: { Located ([AddAnn],(FastString,(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]
+                                              ,(getSTRING $2
+                                               ,( fromInteger $ getINTEGER $3
+                                                , fromInteger $ getINTEGER $5
+                                                )
+                                               ,( fromInteger $ getINTEGER $7
+                                                , fromInteger $ getINTEGER $9
+                                                )
+                                               ))
+                                         }
 
 fexp    :: { LHsExpr RdrName }
         : fexp aexp                             { sLL $1 $> $ HsApp $1 $2 }
         | 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 $> ()) (mo $2:mc $4:(fst $3))
+                                     ; checkRecordSyntax (sLL $1 $> r) }}
+        | aexp2                { $1 }
 
 aexp2   :: { LHsExpr RdrName }
         : ipvar                         { sL1 $1 (HsIPVar $! unLoc $1) }
@@ -1709,16 +2025,19 @@ aexp2   :: { LHsExpr RdrName }
         -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't
         -- correct Haskell (you'd have to write '((+ 3), (4 -))')
         -- but the less cluttered version fell out of having texps.
-        | '(' texp ')'                  { sLL $1 $> (HsPar $2) }
-        | '(' tup_exprs ')'             { sLL $1 $> (ExplicitTuple $2 Boxed) }
+        | '(' texp ')'                  {% ams (sLL $1 $> (HsPar $2)) [mo $1,mc $3] }
+        | '(' tup_exprs ')'             {% ams (sLL $1 $> (ExplicitTuple $2 Boxed))
+                                               [mo $1,mc $3] }
 
-        | '(#' texp '#)'                { sLL $1 $> (ExplicitTuple [L (getLoc $2)
-                                                       (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)) (mo $1:mc $3:(fst $2)) }
+        | '[:' parr ':]'    {% ams (sLL $1 $> (snd $2)) (mo $1:mc $3:(fst $2)) }
+        | '_'               { sL1 $1 EWildPat }
 
         -- Template Haskell Extension
         | splice_exp            { $1 }
@@ -1727,26 +2046,30 @@ aexp2   :: { LHsExpr RdrName }
         | 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)) }
+        | '[|' exp '|]'       {% ams (sLL $1 $> $ HsBracket (ExpBr $2)) [mo $1,mc $3] }
+        | '[||' exp '||]'     {% ams (sLL $1 $> $ HsBracket (TExpBr $2)) [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 (HsQuasiQuoteE (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 }
+        | '$(' exp ')'          {% ams (sLL $1 $> $ mkHsSpliceE $2) [mo $1,mc $3] }
         | TH_ID_TY_SPLICE       { sL1 $1 $ mkHsSpliceTE
                                         (sL1 $1 $ HsVar (mkUnqual varName
-                                                        (getTH_ID_TY_SPLICE $1))) }
-        | '$$(' exp ')'         { sLL $1 $> $ mkHsSpliceTE $2 }
+                                                     (getTH_ID_TY_SPLICE $1))) }
+        | '$$(' exp ')'         {% ams (sLL $1 $> $ mkHsSpliceTE $2) [mo $1,mc $3] }
 
 cmdargs :: { [LHsCmdTop RdrName] }
         : cmdargs acmd                  { $2 : $1 }
@@ -1757,9 +2080,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 AnnOpen $1
+                                                  ,mj AnnClose $3],$2) }
+        |      vocurly    cvtopdecls0 close    { ([],$2) }
 
 cvtopdecls0 :: { [LHsDecl RdrName] }
         : {- empty -}           { [] }
@@ -1789,46 +2113,71 @@ 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) [mj AnnRarrow $2] }
 
 -- Always at least one comma
 tup_exprs :: { [LHsTupArg RdrName] }
-           : texp commas_tup_tail  { sL1 $1 (Present $1) : $2 }
-           | commas tup_tail       { replicate $1 (noLoc missingTupArg) ++ $2 }
+           : texp commas_tup_tail
+                          {% do { addAnnotation (gl $1) AnnComma (fst $2)
+                                ; return ((L (gl $1) (Present $1)) : snd $2) } }
+
+           | commas tup_tail
+                {% do { mapM_ (\ll -> addAnnotation (gl ll) AnnComma (gl ll)) $2
+                      ; return
+                           (let tt = if null $2
+                                       then [noLoc missingTupArg]
+                                       else $2
+                            in map (\l -> L l missingTupArg) (fst $1) ++ tt) } }
 
 -- Always starts with commas; always follows an expr
-commas_tup_tail :: { [LHsTupArg RdrName] }
+commas_tup_tail :: { (SrcSpan,[LHsTupArg RdrName]) }
 commas_tup_tail : commas tup_tail
-                                { replicate ($1-1) (noLoc missingTupArg) ++ $2 }
+       {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1)
+             ; return (
+         let tt = if null $2
+                    then [L (last $ fst $1) missingTupArg]
+                    else $2
+         in (head $ fst $1
+            ,(map (\l -> L l missingTupArg) (init $ fst $1)) ++ tt)) } }
 
 -- Always follows a comma
 tup_tail :: { [LHsTupArg RdrName] }
-          : texp commas_tup_tail        { sL1 $1 (Present $1) : $2 }
-          | texp                        { [sL1 $1 $ Present $1] }
-          | {- empty -}                 { [noLoc missingTupArg] }
+          : 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
@@ -1847,19 +2196,24 @@ 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 $ last $ unLoc $1) AnnVbar (gl $2) >>
+                        return (L (getLoc $2) (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 $ last $ unLoc $1) AnnComma (gl $2) >>
+                return (sLL $1 $> [L (getLoc $3) ((unLoc $3) (reverse (unLoc $1)))]) }
+    | squals ',' qual
+             {% addAnnotation (gl $ last $ unLoc $1) AnnComma (gl $2) >>
+                return (sLL $1 $> ($3 : unLoc $1)) }
+    | transformqual                       { sLL $1 $> [L (getLoc $1) ((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
@@ -1867,10 +2221,17 @@ squals :: { Located [LStmt RdrName (LHsExpr RdrName)] }   -- In reverse order, b
 
 transformqual :: { Located ([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               {% ams (sLL $1 $> $ \ss -> (mkTransformStmt ss $2))
+                                      [mj AnnThen $1] }
+    | 'then' exp 'by' exp      {% ams (sLL $1 $> $ \ss -> (mkTransformByStmt ss $2 $4))
+                                      [mj AnnThen $1,mj AnnBy  $3] }
+    | 'then' 'group' 'using' exp
+             {% ams (sLL $1 $> $ \ss -> (mkGroupUsingStmt ss $4))
+                    [mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3] }
+
+    | 'then' 'group' 'by' exp 'using' exp
+             {% ams (sLL $1 $> $ \ss -> (mkGroupByUsingStmt ss $4 $6))
+                     [mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5] }
 
 -- Note that 'group' is a special_id, which means that you can enable
 -- TransformListComp while still using Data.List.group. However, this
@@ -1885,14 +2246,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.
 
@@ -1903,36 +2268,42 @@ 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  {% ams (sLL $1 $> ($3 : unLoc $1)) [mj AnnComma $2] }
     | 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 [] }
+altslist :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) }
+        : '{'            alts '}'    { sLL $1 $> ([mo $1,mc $3],(reverse (unLoc $2))) }
+
+        |     vocurly    alts  close { L (getLoc $2) ([],(reverse (unLoc $2))) }
+        | '{'                 '}'    { noLoc ([mo $1,mc $2],[]) }
+        |     vocurly          close { noLoc ([],[]) }
 
 alts    :: { Located [LMatch RdrName (LHsExpr RdrName)] }
         : alts1                         { sL1 $1 (unLoc $1) }
-        | ';' alts                      { sLL $1 $> (unLoc $2) }
+        | ';' alts                      {% ams (sLL $1 $> (unLoc $2))
+                                               [mj AnnSemi (head $ unLoc $2)] }
 
 alts1   :: { Located [LMatch RdrName (LHsExpr RdrName)] }
-        : alts1 ';' alt                 { sLL $1 $> ($3 : unLoc $1) }
-        | alts1 ';'                     { sLL $1 $> (unLoc $1) }
-        | alt                           { sL1 $1 [$1] }
+        : alts1 ';' alt           {% ams (sLL $1 $> ($3 : unLoc $1)) [mj AnnSemi $3] }
+        | alts1 ';'               {% ams (sLL $1 $> (unLoc $1))
+                                         [mj AnnSemi (last $ unLoc $1)] }
+        | alt                     { sL1 $1 [$1] }
 
 alt     :: { LMatch RdrName (LHsExpr RdrName) }
-        : pat opt_sig alt_rhs           { sLL $1 $> (Match [$1] $2 (unLoc $3)) }
+        : pat opt_sig alt_rhs           { sLL $1 $> (Match [$1] (snd $2) (unLoc $3)) }
 
 alt_rhs :: { Located (GRHSs RdrName (LHsExpr RdrName)) }
-        : ralt wherebinds               { sLL $1 $> (GRHSs (unLoc $1) (unLoc $2)) }
+        : ralt wherebinds           {% ams (sLL $1 $> (GRHSs (unLoc $1)
+                                                             (snd $ unLoc $2)))
+                                           (fst $ 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))
+                                     [mj AnnRarrow $1] }
+        | gdpats              { sL1 $1 (reverse (unLoc $1)) }
 
 gdpats :: { Located [LGRHS RdrName (LHsExpr RdrName)] }
         : gdpats gdpat                  { sLL $1 $> ($2 : unLoc $1) }
@@ -1941,34 +2312,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 $> ([mo $1,mc $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,mj 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 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 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 bang_RDR)) $2)))
+                                        [mj AnnBang $1] }
 
 apats  :: { [LPat RdrName] }
         : apat apats            { $1 : $2 }
@@ -1977,23 +2361,33 @@ 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 $> ((mo $1:mc $3:(fst $ unLoc $2))
+                                             ,(snd $ unLoc $2)) }
+        |     vocurly   stmts close     { L (gl $2) (fst $ unLoc $2
+                                                    ,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 [] }
+-- AZ: TODO check that we can retrieve multiple semis.
+stmts :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) }
+        : stmt stmts_help        { sLL $1 $> (fst $ unLoc $2,($1 : (snd $ unLoc $2))) }
+        | ';' stmts     {% if null (snd $ unLoc $2)
+                             then ams (sLL $1 $> ([mj AnnSemi $1],snd $ unLoc $2)) []
+                             else ams (sLL $1 $> ([],snd $ unLoc $2)) [mj AnnSemi $1] }
 
-stmts_help :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- might be empty
-        : ';' stmts                     { sLL $1 $> (unLoc $2) }
-        | {- empty -}                   { noLoc [] }
+        | {- empty -}            { noLoc ([],[]) }
+
+stmts_help :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) }
+                                                               -- might be empty
+        : ';' stmts    {% if null (snd $ unLoc $2)
+                             then ams (sLL $1 $> ([mj AnnSemi $1],snd $ unLoc $2)) []
+                             else ams (sLL $1 $> ([],snd $ unLoc $2)) [mj AnnSemi $1] }
+
+        | {- empty -}                   { noLoc ([],[]) }
 
 -- For typing stmts at the GHCi prompt, where
 -- the input may consist of just comments.
@@ -2003,27 +2397,33 @@ 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] }
 
 qual  :: { LStmt RdrName (LHsExpr RdrName) }
-    : bindpat '<-' exp                  { sLL $1 $> $ mkBindStmt $1 $3 }
+    : bindpat '<-' exp                  {% ams (sLL $1 $> $ mkBindStmt $1 $3)
+                                               [mj 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] }
 
 -----------------------------------------------------------------------------
 -- Record Field Update/Construction
 
-fbinds  :: { ([LHsRecField RdrName (LHsExpr RdrName)], Bool) }
+fbinds  :: { ([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool)) }
         : fbinds1                       { $1 }
-        | {- empty -}                   { ([], False) }
+        | {- empty -}                   { ([],([], False)) }
 
-fbinds1 :: { ([LHsRecField RdrName (LHsExpr RdrName)], Bool) }
-        : fbind ',' fbinds1             { case $3 of (flds, dd) -> ($1 : flds, dd) }
-        | fbind                         { ([$1], False) }
-        | '..'                          { ([],   True) }
+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 { sLL $1 $> $ HsRecField $1 $3                False }
+        : qvar '=' texp {% ams  (sLL $1 $> $ HsRecField $1 $3             False)
+                                [mj AnnEqual $2] }
                         -- RHS is a 'texp', allowing view patterns (Trac #6038)
                         -- and, incidentaly, sections.  Eg
                         -- f (R { x = show -> s }) = ...
@@ -2036,14 +2436,18 @@ fbind   :: { LHsRecField 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 (unLoc $1)) $3))
+                                              [mj AnnEqual $2] }
 
 ipvar   :: { Located HsIPName }
         : IPDUPVARID            { sL1 $1 (HsIPName (getIPDUPVARID $1)) }
@@ -2051,22 +2455,26 @@ ipvar   :: { Located HsIPName }
 -----------------------------------------------------------------------------
 -- Warnings and deprecations
 
-name_boolformula_opt :: { BooleanFormula (Located RdrName) }
+name_boolformula_opt :: { ([AddAnn],BooleanFormula (Located RdrName)) }
         : name_boolformula          { $1 }
-        | {- empty -}               { mkTrue }
+        | {- empty -}               { ([],mkTrue) }
 
-name_boolformula :: { BooleanFormula (Located RdrName) }
+name_boolformula :: { ([AddAnn],BooleanFormula (Located RdrName)) }
         : name_boolformula_and                      { $1 }
-        | name_boolformula_and '|' name_boolformula { mkOr [$1,$3] }
+        | name_boolformula_and '|' name_boolformula
+                                             { ((mj AnnVbar $2:fst $1)++(fst $3)
+                                                ,mkOr [snd $1,snd $3]) }
 
-name_boolformula_and :: { BooleanFormula (Located RdrName) }
+name_boolformula_and :: { ([AddAnn],BooleanFormula (Located RdrName)) }
         : name_boolformula_atom                             { $1 }
-        | name_boolformula_atom ',' name_boolformula_and    { mkAnd [$1,$3] }
+        | name_boolformula_atom ',' name_boolformula_and
+                  { ((mj AnnComma $2:fst $1)++(fst $3), mkAnd [snd $1,snd $3]) }
 
-name_boolformula_atom :: { BooleanFormula (Located RdrName) }
-        : '(' name_boolformula ')'  { $2 }
-        | name_var                  { mkVar $1 }
+name_boolformula_atom :: { ([AddAnn],BooleanFormula (Located RdrName)) }
+        : '(' name_boolformula ')'  { ([mo $1,mc $3],snd $2) }
+        | name_var                  { ([],mkVar $1) }
 
+-- AZ TODO: warnings/deprecations are incompletely annotated
 namelist :: { Located [RdrName] }
 namelist : name_var              { sL1 $1 [unLoc $1] }
          | name_var ',' namelist { sLL $1 $> (unLoc $1 : unLoc $3) }
@@ -2079,33 +2487,35 @@ name_var : var { $1 }
 -- Data constructors
 qcon    :: { Located RdrName }
         : qconid                { $1 }
-        | '(' qconsym ')'       { sLL $1 $> (unLoc $2) }
+        | '(' qconsym ')'       {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
         | sysdcon               { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
 -- 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)) [mo $1,mc $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     {% ams (sLL $1 $> ($1 : unLoc $3)) [mj AnnComma $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 }
+        : '(' ')'               {% ams (sLL $1 $> unitDataCon) [mo $1,mc $2] }
+        | '(' commas ')'        {% ams (sLL $1 $> $ tupleCon BoxedTuple (snd $2 + 1))
+                                       (mo $1:mc $3:(mcommas (fst $2))) }
+        | '(#' '#)'             {% ams (sLL $1 $> $ unboxedUnitDataCon) [mo $1,mc $2] }
+        | '(#' commas '#)'      {% ams (sLL $1 $> $ tupleCon UnboxedTuple (snd $2 + 1))
+                                       (mo $1:mc $3:(mcommas (fst $2))) }
+        | '[' ']'               {% ams (sLL $1 $> nilDataCon) [mo $1,mc $2] }
 
 conop :: { Located RdrName }
         : consym                { $1 }
-        | '`' conid '`'         { sLL $1 $> (unLoc $2) }
+        | '`' conid '`'         {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
 
 qconop :: { Located RdrName }
         : qconsym               { $1 }
-        | '`' qconid '`'        { sLL $1 $> (unLoc $2) }
+        | '`' qconid '`'        {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
 
 ----------------------------------------------------------------------------
 -- Type constructors
@@ -2114,28 +2524,37 @@ 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)
+                                              [mo $1,mc $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 BoxedTuple
+                                                        (snd $2 + 1)))
+                                       (mo $1:mc $3:(mcommas (fst $2))) }
+        | '(#' commas '#)'      {% ams (sLL $1 $> $ getRdrName (tupleTyCon UnboxedTuple
+                                                        (snd $2 + 1)))
+                                       (mo $1:mc $3:(mcommas (fst $2))) }
+        | '(' '->' ')'          {% ams (sLL $1 $> $ getRdrName funTyCon)
+                                       [mo $1,mj AnnRarrow $2,mc $3] }
+        | '[' ']'               {% ams (sLL $1 $> $ listTyCon_RDR) [mo $1,mc $2] }
+        | '[:' ':]'             {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] }
+        | '(' '~#' ')'          {% ams (sLL $1 $> $ getRdrName eqPrimTyCon)
+                                        [mo $1,mj AnnTildehsh $2,mc $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)) [mo $1,mc $3] }
+        | '(' '~' ')'                   {% ams (sLL $1 $> $ eqTyCon_RDR)
+                                               [mo $1,mj AnnTilde $2,mc $3] }
 
 qtyconop :: { Located RdrName } -- Qualified or unqualified
         : qtyconsym                     { $1 }
-        | '`' qtycon '`'                { sLL $1 $> (unLoc $2) }
+        | '`' qtycon '`'                {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
 
 qtycon :: { Located RdrName }   -- Qualified or unqualified
         : QCONID                        { sL1 $1 $! mkQual tcClsName (getQCONID $1) }
@@ -2168,7 +2587,7 @@ op      :: { Located RdrName }   -- used in infix decls
 
 varop   :: { Located RdrName }
         : varsym                { $1 }
-        | '`' varid '`'         { sLL $1 $> (unLoc $2) }
+        | '`' varid '`'         {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
 
 qop     :: { LHsExpr RdrName }   -- used in sections
         : qvarop                { sL1 $1 $ HsVar (unLoc $1) }
@@ -2180,11 +2599,11 @@ qopm    :: { LHsExpr RdrName }   -- used in sections
 
 qvarop :: { Located RdrName }
         : qvarsym               { $1 }
-        | '`' qvarid '`'        { sLL $1 $> (unLoc $2) }
+        | '`' qvarid '`'        {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
 
 qvaropm :: { Located RdrName }
         : qvarsym_no_minus      { $1 }
-        | '`' qvarid '`'        { sLL $1 $> (unLoc $2) }
+        | '`' qvarid '`'        {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
 
 -----------------------------------------------------------------------------
 -- Type variables
@@ -2193,7 +2612,7 @@ tyvar   :: { Located RdrName }
 tyvar   : tyvarid               { $1 }
 
 tyvarop :: { Located RdrName }
-tyvarop : '`' tyvarid '`'       { sLL $1 $> (unLoc $2) }
+tyvarop : '`' tyvarid '`'       {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
         | '.'                   {% parseErrorSDoc (getLoc $1)
                                       (vcat [ptext (sLit "Illegal symbol '.' in type"),
                                              ptext (sLit "Perhaps you intended to use RankNTypes or a similar language"),
@@ -2212,12 +2631,12 @@ tyvarid :: { Located RdrName }
 
 var     :: { Located RdrName }
         : varid                 { $1 }
-        | '(' varsym ')'        { sLL $1 $> (unLoc $2) }
+        | '(' varsym ')'        {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
 
 qvar    :: { Located RdrName }
         : qvarid                { $1 }
-        | '(' varsym ')'        { sLL $1 $> (unLoc $2) }
-        | '(' qvarsym1 ')'      { sLL $1 $> (unLoc $2) }
+        | '(' varsym ')'        {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $3] }
+        | '(' qvarsym1 ')'      {% ams (sLL $1 $> (unLoc $2)) [mo $1,mc $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.
@@ -2337,9 +2756,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
@@ -2478,4 +2897,80 @@ hintExplicitForall span = do
       , text "Perhaps you intended to use RankNTypes or a similar language"
       , text "extension to enable explicit-forall syntax: \x2200 <tvs>. <type>"
       ]
+
+{-
+%************************************************************************
+%*                                                                      *
+        Helper functions for generating annotations in the parser
+%*                                                                      *
+%************************************************************************
+
+For the general principles of the following routines, see Note [Api annotations]
+in ApiAnnotation.hs
+
+-}
+
+-- |Encapsulated call to addAnnotation, requiring only the SrcSpan of
+-- the AST element the annotation belongs to
+type AddAnn = (SrcSpan -> P ())
+
+-- |Construct an AddAnn from the annotation keyword and the location
+-- of the keyword
+mj :: AnnKeywordId -> Located e -> AddAnn
+mj a l = (\s -> addAnnotation s a (gl l))
+
+
+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 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 = mapM_ (\a -> a 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
+  (mapM_ (\a -> a 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 = (mapM_ (\a -> a l) bs) >> return (unitOL a)
+
+-- |Synonyms for AddAnn versions of AnnOpen and AnnClose
+mo ll = mj AnnOpen ll
+mc ll = mj AnnClose ll
+
+-- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma
+--  entry for each SrcSpan
+mcommas :: [SrcSpan] -> [AddAnn]
+mcommas ss = map (\s -> mj AnnComma (L s ())) ss
+
+-- |Add the annotation to an AST element wrapped in a Just
+ajl a@(L _ (Just (L l _))) b s = addAnnotation l b s >> return a
+
+-- |Add all [AddAnn] to an AST element wrapped in a Just
+aljs a@(L _ (Just (L l _))) bs = (mapM_ (\a -> a l) bs) >> return a
+
+-- |Add all [AddAnn] to an AST element wrapped in a Just
+ajs a@(Just (L l _)) bs = (mapM_ (\a -> a l) bs) >> return a
+
+-- |Get the location of the last element of a OrdList, or noLoc
+oll :: OrdList (Located a) -> SrcSpan
+oll l = case fromOL l of
+         [] -> noSrcSpan
+         xs -> getLoc (last xs)
 }
index eb15b81..1b30b71 100644 (file)
@@ -766,14 +766,14 @@ patFail msg loc e = parseErrorSDoc loc err
 checkValDef :: SDoc
             -> LHsExpr RdrName
             -> Maybe (LHsType RdrName)
-            -> Located (GRHSs RdrName (LHsExpr RdrName))
+            -> Located (a,GRHSs RdrName (LHsExpr RdrName))
             -> P (HsBind RdrName)
 
 checkValDef msg lhs (Just sig) grhss
         -- x :: ty = rhs  parses as a *pattern* binding
   = checkPatBind msg (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
 
-checkValDef msg lhs opt_sig g@(L l grhss)
+checkValDef msg lhs opt_sig g@(L l (_,grhss))
   = do  { mb_fun <- isFunLhs lhs
         ; case mb_fun of
             Just (fun, is_infix, pats) -> checkFunBind msg (getLoc lhs)
@@ -804,9 +804,9 @@ makeFunBind fn is_infix ms
 
 checkPatBind :: SDoc
              -> LHsExpr RdrName
-             -> Located (GRHSs RdrName (LHsExpr RdrName))
+             -> Located (a,GRHSs RdrName (LHsExpr RdrName))
              -> P (HsBind RdrName)
-checkPatBind msg lhs (L _ grhss)
+checkPatBind msg lhs (L _ (_,grhss))
   = do  { lhs <- checkPattern msg lhs
         ; return (PatBind lhs grhss placeHolderType placeHolderNames
                     (Nothing,[])) }
index 03a6790..f5a1bbe 100644 (file)
@@ -864,7 +864,7 @@ checkInputForLayout stmt getStmt = do
              eof <- Lexer.nextIsEOF
              if eof
                then Lexer.activeContext
-               else Lexer.lexer return >> goToEnd
+               else Lexer.lexer False return >> goToEnd
 
 enqueueCommands :: [String] -> GHCi ()
 enqueueCommands cmds = do
diff --git a/testsuite/tests/ghc-api/annotations/.gitignore b/testsuite/tests/ghc-api/annotations/.gitignore
new file mode 100644 (file)
index 0000000..61d9b24
--- /dev/null
@@ -0,0 +1,7 @@
+annotations
+parseTree
+comments
+*.hi
+*.o
+*.run.*
+*.normalised
diff --git a/testsuite/tests/ghc-api/annotations/AnnotationLet.hs b/testsuite/tests/ghc-api/annotations/AnnotationLet.hs
new file mode 100644 (file)
index 0000000..de30f8b
--- /dev/null
@@ -0,0 +1,12 @@
+module AnnotationLet (foo) where
+
+{
+import qualified Data.List as DL
+;
+foo = let
+        a 0 = 1
+        a _ = 2
+        b = 2
+      in a b
+
+}
diff --git a/testsuite/tests/ghc-api/annotations/AnnotationTuple.hs b/testsuite/tests/ghc-api/annotations/AnnotationTuple.hs
new file mode 100644 (file)
index 0000000..1eced4d
--- /dev/null
@@ -0,0 +1,20 @@
+{-# LANGUAGE TupleSections #-}
+module AnnotationTuple (foo) where
+
+{
+import qualified Data.List as DL
+;
+foo = let
+        a = 1
+        b = 2
+      in a + b
+
+;
+bar = print $ map (1, "hello"   , 6.5,, [5, 5, 6, 7]) [Just (), Nothing]
+;
+baz = (1, "hello", 6.5,,,,) 'a' (Just ())
+}
+-- Note: the trailing whitespace in this file is used to check that we
+-- have an annotation for it.
+
+
diff --git a/testsuite/tests/ghc-api/annotations/CommentsTest.hs b/testsuite/tests/ghc-api/annotations/CommentsTest.hs
new file mode 100644 (file)
index 0000000..ce0f336
--- /dev/null
@@ -0,0 +1,13 @@
+{-# LANGUAGE DeriveFoldable #-}
+module CommentsTest (foo) where
+{-
+An opening comment
+-}
+
+import qualified Data.List as DL
+
+-- | The function @foo@ does blah
+foo = let
+        a = 1
+        b = 2 -- value 2
+      in a + b
diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile
new file mode 100644 (file)
index 0000000..d5c7bd4
--- /dev/null
@@ -0,0 +1,21 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+clean:
+       rm -f *.o *.hi
+
+annotations: clean
+       '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc annotations
+       ./annotations "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
+
+parseTree: clean
+       '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc parseTree
+       ./parseTree "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
+
+comments: clean
+       '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc comments
+       ./comments "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
+
+
+.PHONY: clean
diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T
new file mode 100644 (file)
index 0000000..54da2ef
--- /dev/null
@@ -0,0 +1,4 @@
+test('annotations', normal, run_command, ['$MAKE -s --no-print-directory annotations'])
+test('parseTree',   normal, run_command, ['$MAKE -s --no-print-directory parseTree'])
+test('comments',    normal, run_command, ['$MAKE -s --no-print-directory comments'])
+
diff --git a/testsuite/tests/ghc-api/annotations/annotations.hs b/testsuite/tests/ghc-api/annotations/annotations.hs
new file mode 100644 (file)
index 0000000..fe95260
--- /dev/null
@@ -0,0 +1,58 @@
+{-# LANGUAGE RankNTypes #-}
+
+-- This program must be called with GHC's libdir as the single command line
+-- argument.
+module Main where
+
+-- import Data.Generics
+import Data.Data
+import Data.List
+import System.IO
+import GHC
+import DynFlags
+import MonadUtils
+import Outputable
+import Bag (filterBag,isEmptyBag)
+import System.Directory (removeFile)
+import System.Environment( getArgs )
+import qualified Data.Map as Map
+import Data.Dynamic ( fromDynamic,Dynamic )
+
+main::IO()
+main = do
+        [libdir] <- getArgs
+        testOneFile libdir "AnnotationLet"
+
+testOneFile libdir fileName = do
+        p <- runGhc (Just libdir) $ do
+                        dflags <- getSessionDynFlags
+                        setSessionDynFlags dflags
+                        let mn =mkModuleName fileName
+                        addTarget Target { targetId = TargetModule mn
+                                         , targetAllowObjCode = True
+                                         , targetContents = Nothing }
+                        load LoadAllTargets
+                        modSum <- getModSummary mn
+                        p <- parseModule modSum
+                        t <- typecheckModule p
+                        d <- desugarModule t
+                        l <- loadModule d
+                        let ts=typecheckedSource l
+                            r =renamedSource l
+                        -- liftIO (putStr (showSDocDebug (ppr ts)))
+                        return (pm_annotations p)
+
+        let anns = p
+            (l,_) = fst $ head $ Map.toList (fst anns)
+            annModule = (getAnnotation anns l AnnModule)
+            annLet    = (getAnnotation anns l AnnLet)
+
+        putStrLn (intercalate "\n" [showAnns anns,pp annModule,pp annLet,pp l])
+
+showAnns (anns,_) = "[\n" ++ (intercalate "\n"
+   $ map (\((s,k),v)
+              -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
+   $ Map.toList anns)
+    ++ "]\n"
+
+pp a = showPpr unsafeGlobalDynFlags a
diff --git a/testsuite/tests/ghc-api/annotations/annotations.stdout b/testsuite/tests/ghc-api/annotations/annotations.stdout
new file mode 100644 (file)
index 0000000..e0c311e
--- /dev/null
@@ -0,0 +1,51 @@
+[
+(AK AnnotationLet.hs:1:1 AnnClose = [AnnotationLet.hs:12:1])
+
+(AK AnnotationLet.hs:1:1 AnnModule = [AnnotationLet.hs:1:1-6])
+
+(AK AnnotationLet.hs:1:1 AnnOpen = [AnnotationLet.hs:3:1])
+
+(AK AnnotationLet.hs:1:1 AnnSemi = [AnnotationLet.hs:5:1])
+
+(AK AnnotationLet.hs:1:1 AnnWhere = [AnnotationLet.hs:1:28-32])
+
+(AK AnnotationLet.hs:1:22-26 AnnClose = [AnnotationLet.hs:1:26])
+
+(AK AnnotationLet.hs:1:22-26 AnnOpen = [AnnotationLet.hs:1:22])
+
+(AK AnnotationLet.hs:4:1-32 AnnAs = [AnnotationLet.hs:4:28-29])
+
+(AK AnnotationLet.hs:4:1-32 AnnImport = [AnnotationLet.hs:4:1-6])
+
+(AK AnnotationLet.hs:4:1-32 AnnQualified = [AnnotationLet.hs:4:8-16])
+
+(AK AnnotationLet.hs:(6,1)-(10,12) AnnEqual = [AnnotationLet.hs:6:5])
+
+(AK AnnotationLet.hs:(6,1)-(10,12) AnnFunId = [AnnotationLet.hs:6:1-3])
+
+(AK AnnotationLet.hs:(6,7)-(10,12) AnnIn = [AnnotationLet.hs:10:7-8])
+
+(AK AnnotationLet.hs:(6,7)-(10,12) AnnLet = [AnnotationLet.hs:6:7-9])
+
+(AK AnnotationLet.hs:7:9-15 AnnEqual = [AnnotationLet.hs:7:13])
+
+(AK AnnotationLet.hs:7:9-15 AnnFunId = [AnnotationLet.hs:7:9])
+
+(AK AnnotationLet.hs:8:9-15 AnnEqual = [AnnotationLet.hs:8:13])
+
+(AK AnnotationLet.hs:8:9-15 AnnFunId = [AnnotationLet.hs:8:9])
+
+(AK AnnotationLet.hs:8:9-15 AnnSemi = [AnnotationLet.hs:8:9])
+
+(AK AnnotationLet.hs:9:9-13 AnnEqual = [AnnotationLet.hs:9:11])
+
+(AK AnnotationLet.hs:9:9-13 AnnFunId = [AnnotationLet.hs:9:9])
+
+(AK AnnotationLet.hs:9:9-13 AnnSemi = [AnnotationLet.hs:9:9])
+
+(AK <no location info> AnnEofPos = [AnnotationLet.hs:13:1])
+]
+
+[AnnotationLet.hs:1:1-6]
+[]
+AnnotationLet.hs:1:1
diff --git a/testsuite/tests/ghc-api/annotations/comments.hs b/testsuite/tests/ghc-api/annotations/comments.hs
new file mode 100644 (file)
index 0000000..1fb1d41
--- /dev/null
@@ -0,0 +1,64 @@
+{-# LANGUAGE RankNTypes #-}
+
+-- This program must be called with GHC's libdir as the single command line
+-- argument.
+module Main where
+
+-- import Data.Generics
+import Data.Data
+import Data.List
+import System.IO
+import GHC
+import DynFlags
+import MonadUtils
+import Outputable
+import Bag (filterBag,isEmptyBag)
+import System.Directory (removeFile)
+import System.Environment( getArgs )
+import qualified Data.Map as Map
+import Data.Dynamic ( fromDynamic,Dynamic )
+
+main::IO()
+main = do
+        [libdir] <- getArgs
+        testOneFile libdir "CommentsTest" True
+        testOneFile libdir "CommentsTest" False
+
+testOneFile libdir fileName useHaddock = do
+    p <- runGhc (Just libdir) $ do
+        dflags <- getSessionDynFlags
+        let dflags' = if useHaddock
+                        then gopt_set (gopt_set dflags Opt_Haddock)
+                                       Opt_KeepRawTokenStream
+                        else gopt_set (gopt_unset dflags Opt_Haddock)
+                                       Opt_KeepRawTokenStream
+        setSessionDynFlags dflags'
+        let mn =mkModuleName fileName
+        addTarget Target { targetId = TargetModule mn
+                         , targetAllowObjCode = True
+                         , targetContents = Nothing }
+        load LoadAllTargets
+        modSum <- getModSummary mn
+        p <- parseModule modSum
+        t <- typecheckModule p
+        d <- desugarModule t
+        l <- loadModule d
+        let ts=typecheckedSource l
+            r =renamedSource l
+        -- liftIO (putStr (showSDocDebug (ppr ts)))
+        return (pm_annotations p)
+
+    let anns = p
+
+    putStrLn (intercalate "\n" [showAnns anns])
+
+showAnns (_,anns) = "[\n" ++ (intercalate "\n"
+   $ map (\(s,v)
+              -> ("( " ++ pp s ++" =\n[" ++ showToks v ++ "])\n"))
+   $ Map.toList anns)
+    ++ "]\n"
+
+showToks ts = intercalate ",\n\n"
+            $ map (\(L p t) -> "(" ++ pp p ++ "," ++ show t ++ ")") ts
+
+pp a = showPpr unsafeGlobalDynFlags a
diff --git a/testsuite/tests/ghc-api/annotations/comments.stdout b/testsuite/tests/ghc-api/annotations/comments.stdout
new file mode 100644 (file)
index 0000000..82ae6e1
--- /dev/null
@@ -0,0 +1,24 @@
+[
+( CommentsTest.hs:(10,7)-(13,14) =
+[(CommentsTest.hs:12:15-24,AnnLineComment "-- value 2")])
+
+( <no location info> =
+[(CommentsTest.hs:9:1-33,AnnDocCommentNext " The function @foo@ does blah"),
+
+(CommentsTest.hs:(3,1)-(5,2),AnnBlockComment "\nAn opening comment\n"),
+
+(CommentsTest.hs:1:1-31,AnnBlockComment "# LANGUAGE DeriveFoldable #")])
+]
+
+[
+( CommentsTest.hs:(10,7)-(13,14) =
+[(CommentsTest.hs:12:15-24,AnnLineComment "-- value 2")])
+
+( <no location info> =
+[(CommentsTest.hs:9:1-33,AnnLineComment "-- | The function @foo@ does blah"),
+
+(CommentsTest.hs:(3,1)-(5,2),AnnBlockComment "\nAn opening comment\n"),
+
+(CommentsTest.hs:1:1-31,AnnBlockComment "# LANGUAGE DeriveFoldable #")])
+]
+
diff --git a/testsuite/tests/ghc-api/annotations/parseTree.hs b/testsuite/tests/ghc-api/annotations/parseTree.hs
new file mode 100644 (file)
index 0000000..2794f22
--- /dev/null
@@ -0,0 +1,102 @@
+{-# LANGUAGE RankNTypes #-}
+
+-- This program must be called with GHC's libdir as the single command line
+-- argument.
+module Main where
+
+-- import Data.Generics
+import Data.Data
+import Data.List
+import System.IO
+import GHC
+import BasicTypes
+import DynFlags
+import MonadUtils
+import Outputable
+import Bag (filterBag,isEmptyBag)
+import System.Directory (removeFile)
+import System.Environment( getArgs )
+import qualified Data.Map as Map
+import Data.Dynamic ( fromDynamic,Dynamic )
+
+main::IO()
+main = do
+        [libdir] <- getArgs
+        testOneFile libdir "AnnotationTuple"
+
+testOneFile libdir fileName = do
+       ((anns,cs),p) <- runGhc (Just libdir) $ do
+                        dflags <- getSessionDynFlags
+                        setSessionDynFlags dflags
+                        let mn =mkModuleName fileName
+                        addTarget Target { targetId = TargetModule mn
+                                         , targetAllowObjCode = True
+                                         , targetContents = Nothing }
+                        load LoadAllTargets
+                        modSum <- getModSummary mn
+                        p <- parseModule modSum
+                        t <- typecheckModule p
+                        d <- desugarModule t
+                        l <- loadModule d
+                        let ts=typecheckedSource l
+                            r =renamedSource l
+                        return (pm_annotations p,p)
+
+       let tupArgs = gq (pm_parsed_source p)
+
+       putStrLn (pp tupArgs)
+       putStrLn (intercalate "\n" [showAnns anns])
+
+    where
+     gq ast = everything (++) ([] `mkQ` doLHsTupArg) ast
+
+     doLHsTupArg :: LHsTupArg RdrName -> [(SrcSpan,String,HsExpr RdrName)]
+     doLHsTupArg (L l arg@(Present _)) = [(l,"p",ExplicitTuple [L l arg] Boxed)]
+     doLHsTupArg (L l arg@(Missing _)) = [(l,"m",ExplicitTuple [L l arg] Boxed)]
+
+
+showAnns anns = "[\n" ++ (intercalate "\n"
+   $ map (\((s,k),v)
+              -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
+   $ Map.toList anns)
+    ++ "]\n"
+
+pp a = showPpr unsafeGlobalDynFlags a
+
+
+-- ---------------------------------------------------------------------
+
+-- Copied from syb for the test
+
+
+-- | Generic queries of type \"r\",
+--   i.e., take any \"a\" and return an \"r\"
+--
+type GenericQ r = forall a. Data a => a -> r
+
+
+-- | Make a generic query;
+--   start from a type-specific case;
+--   return a constant otherwise
+--
+mkQ :: ( Typeable a
+       , Typeable b
+       )
+    => r
+    -> (b -> r)
+    -> a
+    -> r
+(r `mkQ` br) a = case cast a of
+                        Just b  -> br b
+                        Nothing -> r
+
+
+
+-- | Summarise all nodes in top-down, left-to-right order
+everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
+
+-- Apply f to x to summarise top-level node;
+-- use gmapQ to recurse into immediate subterms;
+-- use ordinary foldl to reduce list of intermediate results
+
+everything k f x = foldl k (f x) (gmapQ (everything k f) x)
diff --git a/testsuite/tests/ghc-api/annotations/parseTree.stdout b/testsuite/tests/ghc-api/annotations/parseTree.stdout
new file mode 100644 (file)
index 0000000..b8b9aa6
--- /dev/null
@@ -0,0 +1,122 @@
+[(AnnotationTuple.hs:13:20, [p], (1)),
+ (AnnotationTuple.hs:13:23-29, [p], ("hello")),
+ (AnnotationTuple.hs:13:35-37, [p], (6.5)),
+ (AnnotationTuple.hs:13:38, [m], ()),
+ (AnnotationTuple.hs:13:41-52, [p], ([5, 5, 6, 7])),
+ (AnnotationTuple.hs:15:8, [p], (1)),
+ (AnnotationTuple.hs:15:11-17, [p], ("hello")),
+ (AnnotationTuple.hs:15:20-22, [p], (6.5)),
+ (AnnotationTuple.hs:15:23, [m], ()),
+ (AnnotationTuple.hs:15:24, [m], ()),
+ (AnnotationTuple.hs:15:25, [m], ()),
+ (AnnotationTuple.hs:15:26, [m], ())]
+[
+(AK AnnotationTuple.hs:1:1 AnnClose = [AnnotationTuple.hs:16:1])
+
+(AK AnnotationTuple.hs:1:1 AnnModule = [AnnotationTuple.hs:2:1-6])
+
+(AK AnnotationTuple.hs:1:1 AnnOpen = [AnnotationTuple.hs:4:1])
+
+(AK AnnotationTuple.hs:1:1 AnnSemi = [AnnotationTuple.hs:6:1])
+
+(AK AnnotationTuple.hs:1:1 AnnWhere = [AnnotationTuple.hs:2:30-34])
+
+(AK AnnotationTuple.hs:2:24-28 AnnClose = [AnnotationTuple.hs:2:28])
+
+(AK AnnotationTuple.hs:2:24-28 AnnOpen = [AnnotationTuple.hs:2:24])
+
+(AK AnnotationTuple.hs:5:1-32 AnnAs = [AnnotationTuple.hs:5:28-29])
+
+(AK AnnotationTuple.hs:5:1-32 AnnImport = [AnnotationTuple.hs:5:1-6])
+
+(AK AnnotationTuple.hs:5:1-32 AnnQualified = [AnnotationTuple.hs:5:8-16])
+
+(AK AnnotationTuple.hs:(7,1)-(10,14) AnnEqual = [AnnotationTuple.hs:7:5])
+
+(AK AnnotationTuple.hs:(7,1)-(10,14) AnnFunId = [AnnotationTuple.hs:7:1-3])
+
+(AK AnnotationTuple.hs:(7,7)-(10,14) AnnIn = [AnnotationTuple.hs:10:7-8])
+
+(AK AnnotationTuple.hs:(7,7)-(10,14) AnnLet = [AnnotationTuple.hs:7:7-9])
+
+(AK AnnotationTuple.hs:8:9-13 AnnEqual = [AnnotationTuple.hs:8:11])
+
+(AK AnnotationTuple.hs:8:9-13 AnnFunId = [AnnotationTuple.hs:8:9])
+
+(AK AnnotationTuple.hs:9:9-13 AnnEqual = [AnnotationTuple.hs:9:11])
+
+(AK AnnotationTuple.hs:9:9-13 AnnFunId = [AnnotationTuple.hs:9:9])
+
+(AK AnnotationTuple.hs:9:9-13 AnnSemi = [AnnotationTuple.hs:9:9])
+
+(AK AnnotationTuple.hs:13:1-72 AnnEqual = [AnnotationTuple.hs:13:5])
+
+(AK AnnotationTuple.hs:13:1-72 AnnFunId = [AnnotationTuple.hs:13:1-3])
+
+(AK AnnotationTuple.hs:13:1-72 AnnSemi = [AnnotationTuple.hs:12:1])
+
+(AK AnnotationTuple.hs:13:19-53 AnnClose = [AnnotationTuple.hs:13:53])
+
+(AK AnnotationTuple.hs:13:19-53 AnnOpen = [AnnotationTuple.hs:13:19])
+
+(AK AnnotationTuple.hs:13:20 AnnComma = [AnnotationTuple.hs:13:21])
+
+(AK AnnotationTuple.hs:13:23-29 AnnComma = [AnnotationTuple.hs:13:33])
+
+(AK AnnotationTuple.hs:13:35-37 AnnComma = [AnnotationTuple.hs:13:38])
+
+(AK AnnotationTuple.hs:13:39 AnnComma = [AnnotationTuple.hs:13:39])
+
+(AK AnnotationTuple.hs:13:41-52 AnnClose = [AnnotationTuple.hs:13:52])
+
+(AK AnnotationTuple.hs:13:41-52 AnnOpen = [AnnotationTuple.hs:13:41])
+
+(AK AnnotationTuple.hs:13:42 AnnComma = [AnnotationTuple.hs:13:43])
+
+(AK AnnotationTuple.hs:13:45 AnnComma = [AnnotationTuple.hs:13:46])
+
+(AK AnnotationTuple.hs:13:48 AnnComma = [AnnotationTuple.hs:13:49])
+
+(AK AnnotationTuple.hs:13:55-72 AnnClose = [AnnotationTuple.hs:13:72])
+
+(AK AnnotationTuple.hs:13:55-72 AnnOpen = [AnnotationTuple.hs:13:55])
+
+(AK AnnotationTuple.hs:13:56-62 AnnComma = [AnnotationTuple.hs:13:63])
+
+(AK AnnotationTuple.hs:13:61-62 AnnClose = [AnnotationTuple.hs:13:62])
+
+(AK AnnotationTuple.hs:13:61-62 AnnOpen = [AnnotationTuple.hs:13:61])
+
+(AK AnnotationTuple.hs:15:1-41 AnnEqual = [AnnotationTuple.hs:15:5])
+
+(AK AnnotationTuple.hs:15:1-41 AnnFunId = [AnnotationTuple.hs:15:1-3])
+
+(AK AnnotationTuple.hs:15:1-41 AnnSemi = [AnnotationTuple.hs:14:1])
+
+(AK AnnotationTuple.hs:15:7-27 AnnClose = [AnnotationTuple.hs:15:27])
+
+(AK AnnotationTuple.hs:15:7-27 AnnOpen = [AnnotationTuple.hs:15:7])
+
+(AK AnnotationTuple.hs:15:8 AnnComma = [AnnotationTuple.hs:15:9])
+
+(AK AnnotationTuple.hs:15:11-17 AnnComma = [AnnotationTuple.hs:15:18])
+
+(AK AnnotationTuple.hs:15:20-22 AnnComma = [AnnotationTuple.hs:15:23])
+
+(AK AnnotationTuple.hs:15:24 AnnComma = [AnnotationTuple.hs:15:24])
+
+(AK AnnotationTuple.hs:15:25 AnnComma = [AnnotationTuple.hs:15:25])
+
+(AK AnnotationTuple.hs:15:26 AnnComma = [AnnotationTuple.hs:15:26])
+
+(AK AnnotationTuple.hs:15:33-41 AnnClose = [AnnotationTuple.hs:15:41])
+
+(AK AnnotationTuple.hs:15:33-41 AnnOpen = [AnnotationTuple.hs:15:33])
+
+(AK AnnotationTuple.hs:15:39-40 AnnClose = [AnnotationTuple.hs:15:40])
+
+(AK AnnotationTuple.hs:15:39-40 AnnOpen = [AnnotationTuple.hs:15:39])
+
+(AK <no location info> AnnEofPos = [AnnotationTuple.hs:21:1])
+]
+