From 284a2f44666c88616c9f4426e566014f8685669c Mon Sep 17 00:00:00 2001
From: Vladislav Zavialov <vlad.z.4096@gmail.com>
Date: Mon, 29 Apr 2019 22:36:23 +0300
Subject: Decouple AddAnn from P

---
 compiler/parser/Lexer.x     | 13 +++++++------
 compiler/parser/Parser.y    |  6 +++---
 compiler/parser/RdrHsSyn.hs |  8 +++-----
 3 files changed, 13 insertions(+), 14 deletions(-)

(limited to 'compiler')

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index edad2d90d7..e7e1028c96 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -59,7 +59,8 @@ module Lexer (
    getLexState, popLexState, pushLexState,
    ExtBits(..),
    lexTokenStream,
-   AddAnn,mkParensApiAnn,
+   AddAnn(..),mkParensApiAnn,
+   addAnnsAt,
    commentToAnnotation
   ) where
 
@@ -2503,7 +2504,6 @@ class Monad m => MonadP m where
   -- | Check if a given flag is currently set in the bitmap.
   getBit :: ExtBits -> m Bool
   -- | Given a location and a list of AddAnn, apply them all to the location.
-  addAnnsAt :: SrcSpan -> [AddAnn] -> m ()
   addAnnotation :: SrcSpan          -- SrcSpan of enclosing AST construct
                 -> AnnKeywordId     -- The first two parameters are the key
                 -> SrcSpan          -- The location of the keyword itself
@@ -2533,11 +2533,13 @@ instance MonadP P where
     addError span msg >> P PFailed
   getBit ext = P $ \s -> let b =  ext `xtest` pExtsBitmap (options s)
                          in b `seq` POk s b
-  addAnnsAt loc anns = mapM_ (\a -> a loc) anns
   addAnnotation l a v = do
     addAnnotationOnly l a v
     allocateComments l
 
+addAnnsAt :: MonadP m => SrcSpan -> [AddAnn] -> m ()
+addAnnsAt l = mapM_ (\(AddAnn a v) -> addAnnotation l a v)
+
 addTabWarning :: RealSrcSpan -> P ()
 addTabWarning srcspan
  = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->
@@ -3061,7 +3063,7 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag))
 --
 --   The usual way an 'AddAnn' is created is using the 'mj' ("make jump")
 --   function, and then it can be discharged using the 'ams' function.
-type AddAnn = SrcSpan -> P ()
+data AddAnn = AddAnn AnnKeywordId SrcSpan
 
 addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
 addAnnotationOnly l a v = P $ \s -> POk s {
@@ -3073,9 +3075,8 @@ addAnnotationOnly l a v = P $ \s -> POk s {
 -- and end of the span
 mkParensApiAnn :: SrcSpan -> [AddAnn]
 mkParensApiAnn (UnhelpfulSpan _)  = []
-mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc]
+mkParensApiAnn s@(RealSrcSpan ss) = [AddAnn AnnOpenP lo,AddAnn AnnCloseP lc]
   where
-    mj a l = (\s -> addAnnotation s a l)
     f = srcSpanFile ss
     sl = srcSpanStartLine ss
     sc = srcSpanStartCol ss
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 774b32f0ab..5f79879789 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -3996,10 +3996,10 @@ in ApiAnnotation.hs
 -- |Construct an AddAnn from the annotation keyword and the location
 -- of the keyword itself
 mj :: HasSrcSpan e => AnnKeywordId -> e -> AddAnn
-mj a l s = addAnnotation s a (gl l)
+mj a l = AddAnn a (gl l)
 
 mjL :: AnnKeywordId -> SrcSpan -> AddAnn
-mjL a l s = addAnnotation s a l
+mjL = AddAnn
 
 
 
@@ -4007,7 +4007,7 @@ mjL a l s = addAnnotation s a l
 -- the token has a unicode equivalent and this has been used, provide the
 -- unicode variant of the annotation.
 mu :: AnnKeywordId -> Located Token -> AddAnn
-mu a lt@(dL->L l t) = (\s -> addAnnotation s (toUnicodeAnn a lt) l)
+mu a lt@(dL->L l t) = AddAnn (toUnicodeAnn a lt) l
 
 -- | If the 'Token' is using its unicode variant return the unicode variant of
 --   the annotation
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index b16858de56..b0d493c559 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -266,7 +266,7 @@ mkDataFamInst :: SrcSpan
 mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
               ksig data_cons maybe_deriv
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
-       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
+       ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
        ; return (cL loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs
                   (FamEqn { feqn_ext    = noExtField
@@ -1374,12 +1374,12 @@ pStrictMark ((dL->L l1 x1) : (dL->L l2 x2) : xs)
   | Just (strAnnId, str) <- tyElStrictness x1
   , TyElUnpackedness (unpkAnns, prag, unpk) <- x2
   = Just ( cL (combineSrcSpans l1 l2) (HsSrcBang prag unpk str)
-         , unpkAnns ++ [\s -> addAnnotation s strAnnId l1]
+         , unpkAnns ++ [AddAnn strAnnId l1]
          , xs )
 pStrictMark ((dL->L l x1) : xs)
   | Just (strAnnId, str) <- tyElStrictness x1
   = Just ( cL l (HsSrcBang NoSourceText NoSrcUnpack str)
-         , [\s -> addAnnotation s strAnnId l]
+         , [AddAnn strAnnId l]
          , xs )
 pStrictMark ((dL->L l x1) : xs)
   | TyElUnpackedness (anns, prag, unpk) <- x1
@@ -3025,8 +3025,6 @@ instance MonadP PV where
     PV $ ReaderT $ \ctxMsg -> addFatalError srcspan (msg $$ ctxMsg)
   getBit ext =
     PV $ ReaderT $ \_ -> getBit ext
-  addAnnsAt loc anns =
-    PV $ ReaderT $ \_ -> addAnnsAt loc anns
   addAnnotation l a v =
     PV $ ReaderT $ \_ -> addAnnotation l a v
 
-- 
cgit v1.2.1