{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Haddock.Backends.Hyperlinker.Parser (parse) where

import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Class
import Control.Applicative ( Alternative(..) )
import Data.List           ( isPrefixOf, isSuffixOf )

import qualified Data.ByteString as BS

import GHC.Platform
import GHC.Types.SourceText
import GHC.Driver.Session
import GHC.Driver.Config.Diagnostic
import GHC.Utils.Error     ( pprLocMsgEnvelopeDefault )
import GHC.Data.FastString ( mkFastString )
import GHC.Parser.Errors.Ppr ()
import qualified GHC.Types.Error as E
import GHC.Parser.Lexer    as Lexer
                           ( P(..), ParseResult(..), PState(..), Token(..)
                           , initParserState, lexer, mkParserOpts, getPsErrorMessages)
import GHC.Data.Bag         ( bagToList )
import GHC.Utils.Outputable ( text, ($$) )
import GHC.Utils.Panic      ( panic )
import GHC.Driver.Ppr       ( showSDoc )
import GHC.Types.SrcLoc
import GHC.Data.StringBuffer ( StringBuffer, atEnd )

import Haddock.Backends.Hyperlinker.Types as T
import Haddock.GhcUtils

-- | Turn source code string into a stream of more descriptive tokens.
--
-- Result should retain original file layout (including comments,
-- whitespace, and CPP).
parse
  :: DynFlags      -- ^ Flags for this module
  -> FilePath      -- ^ Path to the source of this module
  -> BS.ByteString -- ^ Raw UTF-8 encoded source of this module
  -> [T.Token]
parse :: DynFlags -> [Char] -> ByteString -> [Token]
parse DynFlags
dflags [Char]
fpath ByteString
bs = case P [Token] -> PState -> ParseResult [Token]
forall a. P a -> PState -> ParseResult a
unP (Bool -> [Token] -> P [Token]
go Bool
False []) PState
initState of
    POk PState
_ [Token]
toks -> [Token] -> [Token]
forall a. [a] -> [a]
reverse [Token]
toks
    PFailed PState
pst ->
      let MsgEnvelope PsMessage
err:[MsgEnvelope PsMessage]
_ = Bag (MsgEnvelope PsMessage) -> [MsgEnvelope PsMessage]
forall a. Bag a -> [a]
bagToList (Messages PsMessage -> Bag (MsgEnvelope PsMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
E.getMessages (Messages PsMessage -> Bag (MsgEnvelope PsMessage))
-> Messages PsMessage -> Bag (MsgEnvelope PsMessage)
forall a b. (a -> b) -> a -> b
$ PState -> Messages PsMessage
getPsErrorMessages PState
pst) in
      [Char] -> [Token]
forall a. HasCallStack => [Char] -> a
panic ([Char] -> [Token]) -> [Char] -> [Token]
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> [Char]
showSDoc DynFlags
dflags (SDoc -> [Char]) -> SDoc -> [Char]
forall a b. (a -> b) -> a -> b
$
        [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Hyperlinker parse error:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ MsgEnvelope PsMessage -> SDoc
forall e. Diagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelopeDefault MsgEnvelope PsMessage
err
  where

    initState :: PState
initState = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState ParserOpts
pflags StringBuffer
buf RealSrcLoc
start
    buf :: StringBuffer
buf = ByteString -> StringBuffer
stringBufferFromByteString ByteString
bs
    start :: RealSrcLoc
start = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc ([Char] -> FastString
mkFastString [Char]
fpath) Int
1 Int
1
    arch_os :: ArchOS
arch_os = Platform -> ArchOS
platformArchOS (DynFlags -> Platform
targetPlatform DynFlags
dflags)
    pflags :: ParserOpts
pflags = EnumSet Extension
-> DiagOpts
-> [[Char]]
-> Bool
-> Bool
-> Bool
-> Bool
-> ParserOpts
mkParserOpts   (DynFlags -> EnumSet Extension
extensionFlags DynFlags
dflags)
                            (DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags)
                            (ArchOS -> [[Char]]
supportedLanguagesAndExtensions ArchOS
arch_os)
                            (DynFlags -> Bool
safeImportsOn DynFlags
dflags)
                            Bool
False -- lex Haddocks as comment tokens
                            Bool
True  -- produce comment tokens
                            Bool
False -- produce position pragmas tokens

    go :: Bool        -- ^ are we currently in a pragma?
       -> [T.Token]   -- ^ tokens accumulated so far (in reverse)
       -> P [T.Token]
    go :: Bool -> [Token] -> P [Token]
go Bool
inPrag [Token]
toks = do
      (b, _) <- P (StringBuffer, RealSrcLoc)
getInput
      if not (atEnd b)
        then do
          mtok <- runMaybeT (parseCppLine <|> parsePlainTok inPrag)
          (newToks, inPrag') <- case mtok of
            Maybe ([Token], Bool)
Nothing -> P ([Token], Bool)
unknownLine
            Just ([Token], Bool)
a -> ([Token], Bool) -> P ([Token], Bool)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Token], Bool)
a
          go inPrag' (newToks ++ toks)
        else
          pure toks

    -- | Like 'Lexer.lexer', but slower, with a better API, and filtering out empty tokens
    wrappedLexer :: P (RealLocated Lexer.Token)
    wrappedLexer :: P (RealLocated Token)
wrappedLexer = Bool
-> (Located Token -> P (RealLocated Token))
-> P (RealLocated Token)
forall a. Bool -> (Located Token -> P a) -> P a
Lexer.lexer Bool
False Located Token -> P (RealLocated Token)
andThen
      where andThen :: Located Token -> P (RealLocated Token)
andThen (L (RealSrcSpan RealSrcSpan
s Maybe BufSpan
_) Token
t)
              | RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
s Bool -> Bool -> Bool
||
                RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
s
              = RealLocated Token -> P (RealLocated Token)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RealSrcSpan -> Token -> RealLocated Token
forall l e. l -> e -> GenLocated l e
L RealSrcSpan
s Token
t)
            andThen (L (RealSrcSpan RealSrcSpan
s Maybe BufSpan
_) Token
ITeof) = RealLocated Token -> P (RealLocated Token)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RealSrcSpan -> Token -> RealLocated Token
forall l e. l -> e -> GenLocated l e
L RealSrcSpan
s Token
ITeof)
            andThen Located Token
_ = P (RealLocated Token)
wrappedLexer

    -- | Try to parse a CPP line (can fail)
    parseCppLine :: MaybeT P ([T.Token], Bool)
    parseCppLine :: MaybeT P ([Token], Bool)
parseCppLine = P (Maybe ([Token], Bool)) -> MaybeT P ([Token], Bool)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (P (Maybe ([Token], Bool)) -> MaybeT P ([Token], Bool))
-> P (Maybe ([Token], Bool)) -> MaybeT P ([Token], Bool)
forall a b. (a -> b) -> a -> b
$ do
      (b, l) <- P (StringBuffer, RealSrcLoc)
getInput
      case tryCppLine l b of
        Just (ByteString
cppBStr, RealSrcLoc
l', StringBuffer
b')
             -> let cppTok :: Token
cppTok = T.Token { tkType :: TokenType
tkType = TokenType
TkCpp
                                     , tkValue :: ByteString
tkValue = ByteString
cppBStr
                                     , tkSpan :: RealSrcSpan
tkSpan = RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan RealSrcLoc
l RealSrcLoc
l' }
                in (StringBuffer, RealSrcLoc) -> P ()
setInput (StringBuffer
b', RealSrcLoc
l') P () -> P (Maybe ([Token], Bool)) -> P (Maybe ([Token], Bool))
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe ([Token], Bool) -> P (Maybe ([Token], Bool))
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([Token], Bool) -> Maybe ([Token], Bool)
forall a. a -> Maybe a
Just ([Token
cppTok], Bool
False))
        Maybe (ByteString, RealSrcLoc, StringBuffer)
_    -> Maybe ([Token], Bool) -> P (Maybe ([Token], Bool))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([Token], Bool)
forall a. Maybe a
Nothing

    -- | Try to parse a regular old token (can fail)
    parsePlainTok :: Bool -> MaybeT P ([T.Token], Bool)  -- return list is only ever 0-2 elements
    parsePlainTok :: Bool -> MaybeT P ([Token], Bool)
parsePlainTok Bool
inPrag = do
      (bInit, lInit) <- P (StringBuffer, RealSrcLoc) -> MaybeT P (StringBuffer, RealSrcLoc)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift P (StringBuffer, RealSrcLoc)
getInput
      L sp tok <- tryP (Lexer.lexer False return)
      (bEnd, _) <- lift getInput
      case sp of
        UnhelpfulSpan UnhelpfulSpanReason
_ -> ([Token], Bool) -> MaybeT P ([Token], Bool)
forall a. a -> MaybeT P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Bool
False) -- pretend the token never existed
        RealSrcSpan RealSrcSpan
rsp Maybe BufSpan
_ -> do
          let typ :: TokenType
typ = if Bool
inPrag then TokenType
TkPragma else Token -> TokenType
classify Token
tok
              RealSrcLoc RealSrcLoc
lStart Maybe BufPos
_ = SrcSpan -> SrcLoc
srcSpanStart SrcSpan
sp -- safe since @sp@ is real
              (ByteString
spaceBStr, StringBuffer
bStart) = RealSrcLoc
-> RealSrcLoc -> StringBuffer -> (ByteString, StringBuffer)
spanPosition RealSrcLoc
lInit RealSrcLoc
lStart StringBuffer
bInit
              inPragDef :: Bool
inPragDef = Bool -> Token -> Bool
inPragma Bool
inPrag Token
tok

          (bEnd', inPrag') <- case Token
tok of

            -- Update internal line + file position if this is a LINE pragma
            ITline_prag SourceText
_ -> (StringBuffer, Bool)
-> MaybeT P (StringBuffer, Bool) -> MaybeT P (StringBuffer, Bool)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
tryOrElse (StringBuffer
bEnd, Bool
inPragDef) (MaybeT P (StringBuffer, Bool) -> MaybeT P (StringBuffer, Bool))
-> MaybeT P (StringBuffer, Bool) -> MaybeT P (StringBuffer, Bool)
forall a b. (a -> b) -> a -> b
$ do
              L _ (ITinteger (IL { il_value = line })) <- P (RealLocated Token) -> MaybeT P (RealLocated Token)
forall a. P a -> MaybeT P a
tryP P (RealLocated Token)
wrappedLexer
              L _ (ITstring _ file)                    <- tryP wrappedLexer
              L spF ITclose_prag                       <- tryP wrappedLexer

              let newLoc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
file (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
line Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
spF)
              (bEnd'', _) <- lift getInput
              lift $ setInput (bEnd'', newLoc)

              pure (bEnd'', False)

            -- Update internal column position if this is a COLUMN pragma
            ITcolumn_prag SourceText
_ -> (StringBuffer, Bool)
-> MaybeT P (StringBuffer, Bool) -> MaybeT P (StringBuffer, Bool)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
tryOrElse (StringBuffer
bEnd, Bool
inPragDef) (MaybeT P (StringBuffer, Bool) -> MaybeT P (StringBuffer, Bool))
-> MaybeT P (StringBuffer, Bool) -> MaybeT P (StringBuffer, Bool)
forall a b. (a -> b) -> a -> b
$ do
              L _ (ITinteger (IL { il_value = col }))  <- P (RealLocated Token) -> MaybeT P (RealLocated Token)
forall a. P a -> MaybeT P a
tryP P (RealLocated Token)
wrappedLexer
              L spF ITclose_prag                       <- tryP wrappedLexer

              let newLoc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
spF) (RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
spF) (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
col)
              (bEnd'', _) <- lift getInput
              lift $ setInput (bEnd'', newLoc)

              pure (bEnd'', False)

            Token
_ -> (StringBuffer, Bool) -> MaybeT P (StringBuffer, Bool)
forall a. a -> MaybeT P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringBuffer
bEnd, Bool
inPragDef)

          let tokBStr = StringBuffer -> StringBuffer -> ByteString
splitStringBuffer StringBuffer
bStart StringBuffer
bEnd'
              plainTok = T.Token { tkType :: TokenType
tkType = TokenType
typ
                                 , tkValue :: ByteString
tkValue = ByteString
tokBStr
                                 , tkSpan :: RealSrcSpan
tkSpan = RealSrcSpan
rsp }
              spaceTok = T.Token { tkType :: TokenType
tkType = TokenType
TkSpace
                                 , tkValue :: ByteString
tkValue = ByteString
spaceBStr
                                 , tkSpan :: RealSrcSpan
tkSpan = RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan RealSrcLoc
lInit RealSrcLoc
lStart }

          pure (plainTok : [ spaceTok | not (BS.null spaceBStr) ], inPrag')

    -- | Parse whatever remains of the line as an unknown token (can't fail)
    unknownLine :: P ([T.Token], Bool)
    unknownLine :: P ([Token], Bool)
unknownLine = do
      (b, l) <- P (StringBuffer, RealSrcLoc)
getInput
      let (unkBStr, l', b') = spanLine l b
          unkTok = T.Token { tkType :: TokenType
tkType = TokenType
TkUnknown
                           , tkValue :: ByteString
tkValue = ByteString
unkBStr
                           , tkSpan :: RealSrcSpan
tkSpan = RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan RealSrcLoc
l RealSrcLoc
l' }
      setInput (b', l')
      pure ([unkTok], False)


-- | Get the input
getInput :: P (StringBuffer, RealSrcLoc)
getInput :: P (StringBuffer, RealSrcLoc)
getInput = (PState -> ParseResult (StringBuffer, RealSrcLoc))
-> P (StringBuffer, RealSrcLoc)
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult (StringBuffer, RealSrcLoc))
 -> P (StringBuffer, RealSrcLoc))
-> (PState -> ParseResult (StringBuffer, RealSrcLoc))
-> P (StringBuffer, RealSrcLoc)
forall a b. (a -> b) -> a -> b
$ \p :: PState
p@PState { buffer :: PState -> StringBuffer
buffer = StringBuffer
buf, loc :: PState -> PsLoc
loc = PsLoc
srcLoc } -> PState
-> (StringBuffer, RealSrcLoc)
-> ParseResult (StringBuffer, RealSrcLoc)
forall a. PState -> a -> ParseResult a
POk PState
p (StringBuffer
buf, PsLoc -> RealSrcLoc
psRealLoc PsLoc
srcLoc)

-- | Set the input
setInput :: (StringBuffer, RealSrcLoc) -> P ()
setInput :: (StringBuffer, RealSrcLoc) -> P ()
setInput (StringBuffer
buf, RealSrcLoc
srcLoc) =
  (PState -> ParseResult ()) -> P ()
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult ()) -> P ())
-> (PState -> ParseResult ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \p :: PState
p@PState{ loc :: PState -> PsLoc
loc = PsLoc RealSrcLoc
_ BufPos
buf_loc } ->
    PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk (PState
p { buffer = buf, loc = PsLoc srcLoc buf_loc }) ()

tryP :: P a -> MaybeT P a
tryP :: forall a. P a -> MaybeT P a
tryP (P PState -> ParseResult a
f) = P (Maybe a) -> MaybeT P a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (P (Maybe a) -> MaybeT P a) -> P (Maybe a) -> MaybeT P a
forall a b. (a -> b) -> a -> b
$ (PState -> ParseResult (Maybe a)) -> P (Maybe a)
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult (Maybe a)) -> P (Maybe a))
-> (PState -> ParseResult (Maybe a)) -> P (Maybe a)
forall a b. (a -> b) -> a -> b
$ \PState
s -> case PState -> ParseResult a
f PState
s of
  POk PState
s' a
a -> PState -> Maybe a -> ParseResult (Maybe a)
forall a. PState -> a -> ParseResult a
POk PState
s' (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
  PFailed PState
_ -> PState -> Maybe a -> ParseResult (Maybe a)
forall a. PState -> a -> ParseResult a
POk PState
s Maybe a
forall a. Maybe a
Nothing

tryOrElse :: Alternative f => a -> f a -> f a
tryOrElse :: forall (f :: * -> *) a. Alternative f => a -> f a -> f a
tryOrElse a
x f a
p = f a
p f a -> f a -> f a
forall a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

-- | Classify given tokens as appropriate Haskell token type.
classify :: Lexer.Token -> TokenType
classify :: Token -> TokenType
classify Token
tok =
  case Token
tok of
    Token
ITas                   -> TokenType
TkKeyword
    Token
ITcase                 -> TokenType
TkKeyword
    Token
ITclass                -> TokenType
TkKeyword
    Token
ITdata                 -> TokenType
TkKeyword
    Token
ITdefault              -> TokenType
TkKeyword
    Token
ITderiving             -> TokenType
TkKeyword
    ITdo                {} -> TokenType
TkKeyword
    Token
ITelse                 -> TokenType
TkKeyword
    Token
IThiding               -> TokenType
TkKeyword
    Token
ITforeign              -> TokenType
TkKeyword
    Token
ITif                   -> TokenType
TkKeyword
    Token
ITimport               -> TokenType
TkKeyword
    Token
ITin                   -> TokenType
TkKeyword
    Token
ITinfix                -> TokenType
TkKeyword
    Token
ITinfixl               -> TokenType
TkKeyword
    Token
ITinfixr               -> TokenType
TkKeyword
    Token
ITinstance             -> TokenType
TkKeyword
    Token
ITlet                  -> TokenType
TkKeyword
    Token
ITmodule               -> TokenType
TkKeyword
    Token
ITnewtype              -> TokenType
TkKeyword
    Token
ITof                   -> TokenType
TkKeyword
    Token
ITqualified            -> TokenType
TkKeyword
    Token
ITthen                 -> TokenType
TkKeyword
    Token
ITtype                 -> TokenType
TkKeyword
    Token
ITvia                  -> TokenType
TkKeyword
    Token
ITwhere                -> TokenType
TkKeyword

    ITforall            {} -> TokenType
TkKeyword
    Token
ITexport               -> TokenType
TkKeyword
    Token
ITlabel                -> TokenType
TkKeyword
    Token
ITdynamic              -> TokenType
TkKeyword
    Token
ITsafe                 -> TokenType
TkKeyword
    Token
ITinterruptible        -> TokenType
TkKeyword
    Token
ITunsafe               -> TokenType
TkKeyword
    Token
ITstdcallconv          -> TokenType
TkKeyword
    Token
ITccallconv            -> TokenType
TkKeyword
    Token
ITcapiconv             -> TokenType
TkKeyword
    Token
ITprimcallconv         -> TokenType
TkKeyword
    Token
ITjavascriptcallconv   -> TokenType
TkKeyword
    ITmdo               {} -> TokenType
TkKeyword
    Token
ITfamily               -> TokenType
TkKeyword
    Token
ITrole                 -> TokenType
TkKeyword
    Token
ITgroup                -> TokenType
TkKeyword
    Token
ITby                   -> TokenType
TkKeyword
    Token
ITusing                -> TokenType
TkKeyword
    Token
ITpattern              -> TokenType
TkKeyword
    Token
ITstatic               -> TokenType
TkKeyword
    Token
ITstock                -> TokenType
TkKeyword
    Token
ITanyclass             -> TokenType
TkKeyword

    Token
ITunit                 -> TokenType
TkKeyword
    Token
ITsignature            -> TokenType
TkKeyword
    Token
ITdependency           -> TokenType
TkKeyword
    Token
ITrequires             -> TokenType
TkKeyword

    ITinline_prag       {} -> TokenType
TkPragma
    ITopaque_prag       {} -> TokenType
TkPragma
    ITspec_prag         {} -> TokenType
TkPragma
    ITspec_inline_prag  {} -> TokenType
TkPragma
    ITsource_prag       {} -> TokenType
TkPragma
    ITrules_prag        {} -> TokenType
TkPragma
    ITwarning_prag      {} -> TokenType
TkPragma
    ITdeprecated_prag   {} -> TokenType
TkPragma
    ITline_prag         {} -> TokenType
TkPragma
    ITcolumn_prag       {} -> TokenType
TkPragma
    ITscc_prag          {} -> TokenType
TkPragma
    ITunpack_prag       {} -> TokenType
TkPragma
    ITnounpack_prag     {} -> TokenType
TkPragma
    ITann_prag          {} -> TokenType
TkPragma
    ITcomplete_prag     {} -> TokenType
TkPragma
    Token
ITclose_prag           -> TokenType
TkPragma
    IToptions_prag      {} -> TokenType
TkPragma
    ITinclude_prag      {} -> TokenType
TkPragma
    Token
ITlanguage_prag        -> TokenType
TkPragma
    ITminimal_prag      {} -> TokenType
TkPragma
    IToverlappable_prag {} -> TokenType
TkPragma
    IToverlapping_prag  {} -> TokenType
TkPragma
    IToverlaps_prag     {} -> TokenType
TkPragma
    ITincoherent_prag   {} -> TokenType
TkPragma
    ITctype             {} -> TokenType
TkPragma

    Token
ITdotdot               -> TokenType
TkGlyph
    Token
ITcolon                -> TokenType
TkGlyph
    ITdcolon            {} -> TokenType
TkGlyph
    Token
ITequal                -> TokenType
TkGlyph
    Token
ITlam                  -> TokenType
TkGlyph
    Token
ITlcase                -> TokenType
TkGlyph
    Token
ITlcases               -> TokenType
TkGlyph
    Token
ITvbar                 -> TokenType
TkGlyph
    ITlarrow            {} -> TokenType
TkGlyph
    ITrarrow            {} -> TokenType
TkGlyph
    ITlolly             {} -> TokenType
TkGlyph
    Token
ITat                   -> TokenType
TkGlyph
    Token
ITtilde                -> TokenType
TkGlyph
    ITdarrow            {} -> TokenType
TkGlyph
    Token
ITminus                -> TokenType
TkGlyph
    Token
ITprefixminus          -> TokenType
TkGlyph
    Token
ITbang                 -> TokenType
TkGlyph
    Token
ITdot                  -> TokenType
TkOperator
    ITproj              {} -> TokenType
TkOperator
    ITstar              {} -> TokenType
TkOperator
    Token
ITtypeApp              -> TokenType
TkGlyph
    Token
ITpercent              -> TokenType
TkGlyph

    Token
ITbiglam               -> TokenType
TkGlyph

    Token
ITocurly               -> TokenType
TkSpecial
    Token
ITccurly               -> TokenType
TkSpecial
    Token
ITvocurly              -> TokenType
TkSpecial
    Token
ITvccurly              -> TokenType
TkSpecial
    Token
ITobrack               -> TokenType
TkSpecial
    Token
ITopabrack             -> TokenType
TkSpecial
    Token
ITcpabrack             -> TokenType
TkSpecial
    Token
ITcbrack               -> TokenType
TkSpecial
    Token
IToparen               -> TokenType
TkSpecial
    Token
ITcparen               -> TokenType
TkSpecial
    Token
IToubxparen            -> TokenType
TkSpecial
    Token
ITcubxparen            -> TokenType
TkSpecial
    Token
ITsemi                 -> TokenType
TkSpecial
    Token
ITcomma                -> TokenType
TkSpecial
    Token
ITunderscore           -> TokenType
TkIdentifier
    Token
ITbackquote            -> TokenType
TkSpecial
    Token
ITsimpleQuote          -> TokenType
TkSpecial

    ITvarid             {} -> TokenType
TkIdentifier
    ITconid             {} -> TokenType
TkIdentifier
    ITvarsym            {} -> TokenType
TkOperator
    ITconsym            {} -> TokenType
TkOperator
    ITqvarid            {} -> TokenType
TkIdentifier
    ITqconid            {} -> TokenType
TkIdentifier
    ITqvarsym           {} -> TokenType
TkOperator
    ITqconsym           {} -> TokenType
TkOperator

    ITdupipvarid        {} -> TokenType
TkUnknown
    ITlabelvarid        {} -> TokenType
TkUnknown

    ITchar              {} -> TokenType
TkChar
    ITstring            {} -> TokenType
TkString
    ITinteger           {} -> TokenType
TkNumber
    ITrational          {} -> TokenType
TkNumber

    ITprimchar          {} -> TokenType
TkChar
    ITprimstring        {} -> TokenType
TkString
    ITprimint           {} -> TokenType
TkNumber
    ITprimword          {} -> TokenType
TkNumber
    ITprimint8          {} -> TokenType
TkNumber
    ITprimint16         {} -> TokenType
TkNumber
    ITprimint32         {} -> TokenType
TkNumber
    ITprimint64         {} -> TokenType
TkNumber
    ITprimword8         {} -> TokenType
TkNumber
    ITprimword16        {} -> TokenType
TkNumber
    ITprimword32        {} -> TokenType
TkNumber
    ITprimword64        {} -> TokenType
TkNumber
    ITprimfloat         {} -> TokenType
TkNumber
    ITprimdouble        {} -> TokenType
TkNumber

    ITopenExpQuote      {} -> TokenType
TkSpecial
    Token
ITopenPatQuote         -> TokenType
TkSpecial
    Token
ITopenDecQuote         -> TokenType
TkSpecial
    Token
ITopenTypQuote         -> TokenType
TkSpecial
    ITcloseQuote        {} -> TokenType
TkSpecial
    ITopenTExpQuote     {} -> TokenType
TkSpecial
    Token
ITcloseTExpQuote       -> TokenType
TkSpecial
    Token
ITdollar               -> TokenType
TkSpecial
    Token
ITdollardollar         -> TokenType
TkSpecial
    Token
ITtyQuote              -> TokenType
TkSpecial
    ITquasiQuote        {} -> TokenType
TkUnknown
    ITqQuasiQuote       {} -> TokenType
TkUnknown

    Token
ITproc                 -> TokenType
TkKeyword
    Token
ITrec                  -> TokenType
TkKeyword
    IToparenbar         {} -> TokenType
TkGlyph
    ITcparenbar         {} -> TokenType
TkGlyph
    ITlarrowtail        {} -> TokenType
TkGlyph
    ITrarrowtail        {} -> TokenType
TkGlyph
    ITLarrowtail        {} -> TokenType
TkGlyph
    ITRarrowtail        {} -> TokenType
TkGlyph

    Token
ITcomment_line_prag    -> TokenType
TkUnknown
    ITunknown           {} -> TokenType
TkUnknown
    Token
ITeof                  -> TokenType
TkUnknown

    ITlineComment       {} -> TokenType
TkComment
    ITdocComment        {} -> TokenType
TkComment
    ITdocOptions        {} -> TokenType
TkComment

    -- The lexer considers top-level pragmas as comments (see `pragState` in
    -- the GHC lexer for more), so we have to manually reverse this. The
    -- following is a hammer: it smashes _all_ pragma-like block comments into
    -- pragmas.
    ITblockComment [Char]
c PsSpan
_
      | [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
"{-#" [Char]
c
      , [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf [Char]
"#-}" [Char]
c -> TokenType
TkPragma
      | Bool
otherwise          -> TokenType
TkComment

-- | Classify given tokens as beginning pragmas (or not).
inPragma :: Bool           -- ^ currently in pragma
         -> Lexer.Token    -- ^ current token
         -> Bool           -- ^ new information about whether we are in a pragma
inPragma :: Bool -> Token -> Bool
inPragma Bool
_ Token
ITclose_prag = Bool
False
inPragma Bool
True Token
_ = Bool
True
inPragma Bool
False Token
tok =
  case Token
tok of
    ITinline_prag       {} -> Bool
True
    ITopaque_prag       {} -> Bool
True
    ITspec_prag         {} -> Bool
True
    ITspec_inline_prag  {} -> Bool
True
    ITsource_prag       {} -> Bool
True
    ITrules_prag        {} -> Bool
True
    ITwarning_prag      {} -> Bool
True
    ITdeprecated_prag   {} -> Bool
True
    ITline_prag         {} -> Bool
True
    ITcolumn_prag       {} -> Bool
True
    ITscc_prag          {} -> Bool
True
    ITunpack_prag       {} -> Bool
True
    ITnounpack_prag     {} -> Bool
True
    ITann_prag          {} -> Bool
True
    ITcomplete_prag     {} -> Bool
True
    IToptions_prag      {} -> Bool
True
    ITinclude_prag      {} -> Bool
True
    Token
ITlanguage_prag        -> Bool
True
    ITminimal_prag      {} -> Bool
True
    IToverlappable_prag {} -> Bool
True
    IToverlapping_prag  {} -> Bool
True
    IToverlaps_prag     {} -> Bool
True
    ITincoherent_prag   {} -> Bool
True
    ITctype             {} -> Bool
True

    Token
_                      -> Bool
False