diff options
Diffstat (limited to 'compiler/parser/Lexer.x')
| -rw-r--r-- | compiler/parser/Lexer.x | 157 |
1 files changed, 90 insertions, 67 deletions
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 596f3bd1cf..495605e70c 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -56,7 +56,7 @@ {-# OPTIONS_GHC -funbox-strict-fields #-} module Lexer ( - Token(..), SourceText, lexer, pragState, mkPState, PState(..), + Token(..), lexer, pragState, mkPState, PState(..), P(..), ParseResult(..), getSrcLoc, getPState, getDynFlags, withThisPackage, failLocMsgP, failSpanMsgP, srcParseFail, @@ -73,7 +73,7 @@ module Lexer ( sccProfilingOn, hpcEnabled, addWarning, lexTokenStream, - addAnnotation + addAnnotation,AddAnn,mkParensApiAnn ) where -- base @@ -112,7 +112,8 @@ import DynFlags -- compiler/basicTypes import SrcLoc import Module -import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) ) +import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..), + SourceText ) -- compiler/parser import Ctype @@ -507,8 +508,6 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } { -type SourceText = String -- Note [literal source text] in HsLit - -- ----------------------------------------------------------------------------- -- The token type @@ -560,34 +559,34 @@ data Token | ITpattern | ITstatic - -- Pragmas - | ITinline_prag InlineSpec RuleMatchInfo - | ITspec_prag -- SPECIALISE - | ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE) - | ITsource_prag - | ITrules_prag - | ITwarning_prag - | ITdeprecated_prag + -- Pragmas, see note [Pragma source text] in BasicTypes + | ITinline_prag SourceText InlineSpec RuleMatchInfo + | ITspec_prag SourceText -- SPECIALISE + | ITspec_inline_prag SourceText Bool -- SPECIALISE INLINE (or NOINLINE) + | ITsource_prag SourceText + | ITrules_prag SourceText + | ITwarning_prag SourceText + | ITdeprecated_prag SourceText | ITline_prag - | ITscc_prag - | ITgenerated_prag - | ITcore_prag -- hdaume: core annotations - | ITunpack_prag - | ITnounpack_prag - | ITann_prag + | ITscc_prag SourceText + | ITgenerated_prag SourceText + | ITcore_prag SourceText -- hdaume: core annotations + | ITunpack_prag SourceText + | ITnounpack_prag SourceText + | ITann_prag SourceText | ITclose_prag | IToptions_prag String | ITinclude_prag String | ITlanguage_prag - | ITvect_prag - | ITvect_scalar_prag - | ITnovect_prag - | ITminimal_prag - | IToverlappable_prag -- instance overlap mode - | IToverlapping_prag -- instance overlap mode - | IToverlaps_prag -- instance overlap mode - | ITincoherent_prag -- instance overlap mode - | ITctype + | ITvect_prag SourceText + | ITvect_scalar_prag SourceText + | ITnovect_prag SourceText + | ITminimal_prag SourceText + | IToverlappable_prag SourceText -- instance overlap mode + | IToverlapping_prag SourceText -- instance overlap mode + | IToverlaps_prag SourceText -- instance overlap mode + | ITincoherent_prag SourceText -- instance overlap mode + | ITctype SourceText | ITdotdot -- reserved symbols | ITcolon @@ -640,15 +639,15 @@ data Token | ITdupipvarid FastString -- GHC extension: implicit param: ?x - | ITchar SourceText Char -- Note [literal source text] in HsLit - | ITstring SourceText FastString -- Note [literal source text] in HsLit - | ITinteger SourceText Integer -- Note [literal source text] in HsLit - | ITrational FractionalLit + | ITchar SourceText Char -- Note [literal source text] in BasicTypes + | ITstring SourceText FastString -- Note [literal source text] in BasicTypes + | ITinteger SourceText Integer -- Note [literal source text] in BasicTypes + | ITrational FractionalLit - | ITprimchar SourceText Char -- Note [literal source text] in HsLit - | ITprimstring SourceText ByteString -- Note [literal source text] in HsLit - | ITprimint SourceText Integer -- Note [literal source text] in HsLit - | ITprimword SourceText Integer -- Note [literal source text] in HsLit + | ITprimchar SourceText Char -- Note [literal source text] in BasicTypes + | ITprimstring SourceText ByteString -- Note [literal source text] @BasicTypes + | ITprimint SourceText Integer -- Note [literal source text] in BasicTypes + | ITprimword SourceText Integer -- Note [literal source text] in BasicTypes | ITprimfloat FractionalLit | ITprimdouble FractionalLit @@ -702,6 +701,7 @@ data Token instance Outputable Token where ppr x = text (show x) + -- the bitmap provided as the third component indicates whether the -- corresponding extension keyword is valid under the extension options -- provided to the compiler; if the extension corresponding to *any* of the @@ -1029,9 +1029,10 @@ withLexedDocType lexDocComment = do -- RULES pragmas turn on the forall and '.' keywords, and we turn them -- off again at the end of the pragma. rulePrag :: Action -rulePrag span _buf _len = do +rulePrag span buf len = do setExts (.|. xbit InRulePragBit) - return (L span ITrules_prag) + let !src = lexemeToString buf len + return (L span (ITrules_prag src)) endPrag :: Action endPrag span _buf _len = do @@ -2518,36 +2519,38 @@ ignoredPrags = Map.fromList (map ignored pragmas) -- CFILES is a hugs-only thing. pragmas = options_pragmas ++ ["cfiles", "contract"] -oneWordPrags = Map.fromList([("rules", rulePrag), - ("inline", token (ITinline_prag Inline FunLike)), - ("inlinable", token (ITinline_prag Inlinable FunLike)), - ("inlineable", token (ITinline_prag Inlinable FunLike)), +oneWordPrags = Map.fromList([ + ("rules", rulePrag), + ("inline", strtoken (\s -> (ITinline_prag s Inline FunLike))), + ("inlinable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))), + ("inlineable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))), -- Spelling variant - ("notinline", token (ITinline_prag NoInline FunLike)), - ("specialize", token ITspec_prag), - ("source", token ITsource_prag), - ("warning", token ITwarning_prag), - ("deprecated", token ITdeprecated_prag), - ("scc", token ITscc_prag), - ("generated", token ITgenerated_prag), - ("core", token ITcore_prag), - ("unpack", token ITunpack_prag), - ("nounpack", token ITnounpack_prag), - ("ann", token ITann_prag), - ("vectorize", token ITvect_prag), - ("novectorize", token ITnovect_prag), - ("minimal", token ITminimal_prag), - ("overlaps", token IToverlaps_prag), - ("overlappable", token IToverlappable_prag), - ("overlapping", token IToverlapping_prag), - ("incoherent", token ITincoherent_prag), - ("ctype", token ITctype)]) - -twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)), - ("notinline conlike", token (ITinline_prag NoInline ConLike)), - ("specialize inline", token (ITspec_inline_prag True)), - ("specialize notinline", token (ITspec_inline_prag False)), - ("vectorize scalar", token ITvect_scalar_prag)]) + ("notinline", strtoken (\s -> (ITinline_prag s NoInline FunLike))), + ("specialize", strtoken (\s -> ITspec_prag s)), + ("source", strtoken (\s -> ITsource_prag s)), + ("warning", strtoken (\s -> ITwarning_prag s)), + ("deprecated", strtoken (\s -> ITdeprecated_prag s)), + ("scc", strtoken (\s -> ITscc_prag s)), + ("generated", strtoken (\s -> ITgenerated_prag s)), + ("core", strtoken (\s -> ITcore_prag s)), + ("unpack", strtoken (\s -> ITunpack_prag s)), + ("nounpack", strtoken (\s -> ITnounpack_prag s)), + ("ann", strtoken (\s -> ITann_prag s)), + ("vectorize", strtoken (\s -> ITvect_prag s)), + ("novectorize", strtoken (\s -> ITnovect_prag s)), + ("minimal", strtoken (\s -> ITminimal_prag s)), + ("overlaps", strtoken (\s -> IToverlaps_prag s)), + ("overlappable", strtoken (\s -> IToverlappable_prag s)), + ("overlapping", strtoken (\s -> IToverlapping_prag s)), + ("incoherent", strtoken (\s -> ITincoherent_prag s)), + ("ctype", strtoken (\s -> ITctype s))]) + +twoWordPrags = Map.fromList([ + ("inline conlike", strtoken (\s -> (ITinline_prag s Inline ConLike))), + ("notinline conlike", strtoken (\s -> (ITinline_prag s NoInline ConLike))), + ("specialize inline", strtoken (\s -> (ITspec_inline_prag s True))), + ("specialize notinline", strtoken (\s -> (ITspec_inline_prag s False))), + ("vectorize scalar", strtoken (\s -> ITvect_scalar_prag s))]) dispatch_pragmas :: Map String Action -> Action dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of @@ -2585,6 +2588,10 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag)) %************************************************************************ -} +-- |Encapsulated call to addAnnotation, requiring only the SrcSpan of +-- the AST element the annotation belongs to +type AddAnn = (SrcSpan -> P ()) + addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () addAnnotation l a v = do addAnnotationOnly l a v @@ -2595,6 +2602,22 @@ addAnnotationOnly l a v = P $ \s -> POk s { annotations = ((l,a), [v]) : annotations s } () +-- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate +-- 'AddAnn' values for the opening and closing bordering on the start +-- and end of the span +mkParensApiAnn :: SrcSpan -> [AddAnn] +mkParensApiAnn (UnhelpfulSpan _) = [] +mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc] + where + mj a l = (\s -> addAnnotation s a l) + f = srcSpanFile ss + sl = srcSpanStartLine ss + sc = srcSpanStartCol ss + el = srcSpanEndLine ss + ec = srcSpanEndCol ss + lo = mkSrcSpan (srcSpanStart s) (mkSrcLoc f sl (sc+1)) + lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s) + queueComment :: Located Token -> P() queueComment c = P $ \s -> POk s { comment_q = commentToAnnotation c : comment_q s |