{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Haddock.Backends.Hyperlinker.Parser (parse) where

import Control.Applicative (Alternative (..))
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import qualified Data.ByteString as BS
import Data.List (isPrefixOf, isSuffixOf)
import GHC.Data.Bag (bagToList)
import GHC.Data.FastString (mkFastString)
import GHC.Data.StringBuffer (StringBuffer, atEnd)
import GHC.Parser.Errors.Ppr ()
import GHC.Parser.Lexer as Lexer
  ( P (..)
  , PState (..)
  , ParseResult (..)
  , ParserOpts
  , Token (..)
  , getPsErrorMessages
  , initParserState
  , lexer
  )
import qualified GHC.Types.Error as E
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import GHC.Utils.Error (pprLocMsgEnvelopeDefault)
import GHC.Utils.Outputable (SDocContext, text, ($$))
import qualified GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic (panic)

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
  :: ParserOpts
  -> SDocContext
  -> FilePath
  -- ^ Path to the source of this module
  -> BS.ByteString
  -- ^ Raw UTF-8 encoded source of this module
  -> [T.Token]
parse :: ParserOpts -> SDocContext -> [Char] -> ByteString -> [Token]
parse ParserOpts
parserOpts SDocContext
sDocContext [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
$
          SDocContext -> SDoc -> [Char]
Outputable.renderWithContext SDocContext
sDocContext (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
parserOpts 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
    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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> Maybe ([Token], Bool) -> P (Maybe ([Token], Bool))
forall a. a -> P a
forall (f :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) a. Monad m => m a -> MaybeT m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> a -> f a
forall a. a -> f a
forall (f :: Type -> Type) 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
    ITstringMulti{} -> 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