{-# LANGUAGE CPP #-}

{-# OPTIONS_GHC -Wunused-imports #-}

{-| This module contains the building blocks used to construct the lexer.
-}
module Agda.Syntax.Parser.LexActions
    ( -- * Main function
      lexToken
      -- * Lex actions
      -- ** General actions
    , token
    , withInterval, withInterval', withInterval_
    , withLayout
    , andThen, skip
    , begin, end, beginWith, endWith
    , begin_, end_
    , lexError
      -- ** Specialized actions
    , keyword, symbol, qualifiedToken, literal, literal', integer
      -- * Lex predicates
    , followedBy, eof, inState
    ) where

import Control.Monad.State (modify)

import Data.Bifunctor
import Data.Char
#if !MIN_VERSION_base(4,20,0)
import Data.Foldable (foldl')
#endif
import Data.Maybe

import Agda.Syntax.Common (pattern Ranged)
import Agda.Syntax.Parser.Lexer
import Agda.Syntax.Parser.Alex
import Agda.Syntax.Parser.Monad
import Agda.Syntax.Parser.Tokens
import Agda.Syntax.Position
import Agda.Syntax.Literal

import Agda.Utils.List
import Agda.Utils.List1 (String1, toList)
import qualified Agda.Utils.List1 as List1

import Agda.Utils.Impossible

{--------------------------------------------------------------------------
    Scan functions
 --------------------------------------------------------------------------}

-- | Called at the end of a file. Returns 'TokEOF'.
returnEOF :: AlexInput -> Parser Token
returnEOF :: AlexInput -> Parser Token
returnEOF AlexInput{ SrcFile
lexSrcFile :: SrcFile
lexSrcFile :: AlexInput -> SrcFile
lexSrcFile, PositionWithoutFile
lexPos :: PositionWithoutFile
lexPos :: AlexInput -> PositionWithoutFile
lexPos } = do
  -- Andreas, 2018-12-30, issue #3480
  -- The following setLastPos leads to parse error reporting
  -- far away from the interesting position, in particular
  -- if there is a long comment before the EOF.
  -- (Such a long comment is frequent in interactive programming, as
  -- commenting out until the end of the file is a common habit.)
  -- -- setLastPos lexPos
  -- Without it, we get much more useful error locations.
  [Char] -> Parser ()
setPrevToken [Char]
"<EOF>"
  Token -> Parser Token
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Parser Token) -> Token -> Parser Token
forall a b. (a -> b) -> a -> b
$ Interval -> Token
TokEOF (Interval -> Token) -> Interval -> Token
forall a b. (a -> b) -> a -> b
$ SrcFile -> PositionWithoutFile -> PositionWithoutFile -> Interval
forall a.
a -> PositionWithoutFile -> PositionWithoutFile -> Interval' a
posToInterval SrcFile
lexSrcFile PositionWithoutFile
lexPos PositionWithoutFile
lexPos

-- | Set the current input and lex a new token (calls 'lexToken').
skipTo :: AlexInput -> Parser Token
skipTo :: AlexInput -> Parser Token
skipTo AlexInput
inp = do
  AlexInput -> Parser ()
setLexInput AlexInput
inp
  Parser Token
lexToken

{-| Scan the input to find the next token. Calls
'Agda.Syntax.Parser.Lexer.alexScanUser'. This is the main lexing function
where all the work happens. The function 'Agda.Syntax.Parser.Lexer.lexer',
used by the parser is the continuation version of this function.
-}
lexToken :: Parser Token
lexToken :: Parser Token
lexToken =
    do  inp <- Parser AlexInput
getLexInput
        lss <- getLexState
        flags <- getParseFlags
        case alexScanUser (lss, flags) inp (headWithDefault __IMPOSSIBLE__ lss) of
            AlexReturn (LexAction Token)
AlexEOF                     -> AlexInput -> Parser Token
returnEOF AlexInput
inp
            AlexSkip AlexInput
inp' Int
len           -> AlexInput -> Parser Token
skipTo AlexInput
inp'
            AlexToken AlexInput
inp' Int
len LexAction Token
action   -> Token -> Token
postToken (Token -> Token) -> Parser Token -> Parser Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LexAction Token -> AlexInput -> AlexInput -> Int -> Parser Token
forall r. LexAction r -> AlexInput -> AlexInput -> Int -> Parser r
runLexAction LexAction Token
action AlexInput
inp AlexInput
inp' Int
len
            AlexError AlexInput
i                 -> [Char] -> Parser Token
forall a. [Char] -> Parser a
parseError ([Char] -> Parser Token) -> [Char] -> Parser Token
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ [Char]
"Lexical error"
              , case [Char] -> Maybe Char
forall a. [a] -> Maybe a
listToMaybe ([Char] -> Maybe Char) -> [Char] -> Maybe Char
forall a b. (a -> b) -> a -> b
$ AlexInput -> [Char]
lexInput AlexInput
i of
                  Just Char
'\t'                -> [Char]
" (you may want to replace tabs with spaces)"
                  Just Char
c | Bool -> Bool
not (Char -> Bool
isPrint Char
c) -> [Char]
" (unprintable character)"
                  Maybe Char
_ -> [Char]
""
              , [Char]
":"
              ]

isSub :: Char -> Bool
isSub :: Char -> Bool
isSub Char
c = Char
'\x2080' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x2089'

readSubscript :: [Char] -> Integer
readSubscript :: [Char] -> Integer
readSubscript = [Char] -> Integer
forall a. Read a => [Char] -> a
read ([Char] -> Integer) -> ([Char] -> [Char]) -> [Char] -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> Int -> Char
forall a. Enum a => Int -> a
toEnum (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0x2080 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'0'))

postToken :: Token -> Token
postToken :: Token -> Token
postToken (TokId (Interval
r, [Char]
"\x03bb")) = Symbol -> Interval -> Token
TokSymbol Symbol
SymLambda Interval
r
postToken (TokId (Interval
r, [Char]
"\x2026")) = Symbol -> Interval -> Token
TokSymbol Symbol
SymEllipsis Interval
r
postToken (TokId (Interval
r, [Char]
"\x2192")) = Symbol -> Interval -> Token
TokSymbol Symbol
SymArrow Interval
r
postToken (TokId (Interval
r, [Char]
"\x2983")) = Symbol -> Interval -> Token
TokSymbol (Bool -> Symbol
SymDoubleOpenBrace Bool
True) Interval
r
postToken (TokId (Interval
r, [Char]
"\x2984")) = Symbol -> Interval -> Token
TokSymbol (Bool -> Symbol
SymDoubleCloseBrace Bool
True) Interval
r
postToken (TokId (Interval
r, [Char]
"\x2987")) = Symbol -> Interval -> Token
TokSymbol (Bool -> Symbol
SymOpenIdiomBracket Bool
True) Interval
r
postToken (TokId (Interval
r, [Char]
"\x2988")) = Symbol -> Interval -> Token
TokSymbol (Bool -> Symbol
SymCloseIdiomBracket Bool
True) Interval
r
postToken (TokId (Interval
r, [Char]
"\x2987\x2988")) = Symbol -> Interval -> Token
TokSymbol Symbol
SymEmptyIdiomBracket Interval
r
postToken (TokId (Interval
r, [Char]
"\x2200")) = Keyword -> Interval -> Token
TokKeyword Keyword
KwForall Interval
r
postToken Token
t = Token
t

{--------------------------------------------------------------------------
    Lex actions
 --------------------------------------------------------------------------}

-- | The most general way of parsing a token.
token :: (String -> Parser tok) -> LexAction tok
token :: forall tok. ([Char] -> Parser tok) -> LexAction tok
token [Char] -> Parser tok
action = (AlexInput -> AlexInput -> Int -> Parser tok) -> LexAction tok
forall r.
(AlexInput -> AlexInput -> Int -> Parser r) -> LexAction r
LexAction ((AlexInput -> AlexInput -> Int -> Parser tok) -> LexAction tok)
-> (AlexInput -> AlexInput -> Int -> Parser tok) -> LexAction tok
forall a b. (a -> b) -> a -> b
$ \ AlexInput
inp AlexInput
inp' Int
len ->
    do  AlexInput -> Parser ()
setLexInput AlexInput
inp'
        let t :: [Char]
t = Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
len ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ AlexInput -> [Char]
lexInput AlexInput
inp
        [Char] -> Parser ()
setPrevToken [Char]
t
        PositionWithoutFile -> Parser ()
setLastPos (PositionWithoutFile -> Parser ())
-> PositionWithoutFile -> Parser ()
forall a b. (a -> b) -> a -> b
$ AlexInput -> PositionWithoutFile
lexPos AlexInput
inp
        [Char] -> Parser tok
action [Char]
t

-- | Parse a token from an 'Interval' and the lexed string.
withInterval :: ((Interval, String) -> tok) -> LexAction tok
withInterval :: forall tok. ((Interval, [Char]) -> tok) -> LexAction tok
withInterval (Interval, [Char]) -> tok
f = ([Char] -> Parser tok) -> LexAction tok
forall tok. ([Char] -> Parser tok) -> LexAction tok
token (([Char] -> Parser tok) -> LexAction tok)
-> ([Char] -> Parser tok) -> LexAction tok
forall a b. (a -> b) -> a -> b
$ \[Char]
s -> do
                   r <- Parser Interval
getParseInterval
                   return $ f (r,s)

-- | Like 'withInterval', but applies a function to the string.
withInterval' :: (String -> a) -> ((Interval, a) -> tok) -> LexAction tok
withInterval' :: forall a tok.
([Char] -> a) -> ((Interval, a) -> tok) -> LexAction tok
withInterval' [Char] -> a
f (Interval, a) -> tok
t = ((Interval, [Char]) -> tok) -> LexAction tok
forall tok. ((Interval, [Char]) -> tok) -> LexAction tok
withInterval ((Interval, a) -> tok
t ((Interval, a) -> tok)
-> ((Interval, [Char]) -> (Interval, a))
-> (Interval, [Char])
-> tok
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> a) -> (Interval, [Char]) -> (Interval, a)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [Char] -> a
f)

-- | Return a token without looking at the lexed string.
withInterval_ :: (Interval -> r) -> LexAction r
withInterval_ :: forall r. (Interval -> r) -> LexAction r
withInterval_ Interval -> r
f = ((Interval, [Char]) -> r) -> LexAction r
forall tok. ((Interval, [Char]) -> tok) -> LexAction tok
withInterval (Interval -> r
f (Interval -> r)
-> ((Interval, [Char]) -> Interval) -> (Interval, [Char]) -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Interval, [Char]) -> Interval
forall a b. (a, b) -> a
fst)

-- | Enter the layout state for the given keyword.
enterLayout :: Keyword -> Parser ()
enterLayout :: Keyword -> Parser ()
enterLayout Keyword
kw = do
  Int -> Parser ()
pushLexState Int
layout
  (ParseState -> ParseState) -> Parser ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify \ParseState
st -> ParseState
st { parseLayKw = kw }

-- | Executed for layout keywords. Enters the 'Agda.Syntax.Parser.Lexer.layout'
--   state and performs the given action.
withLayout :: Keyword -> LexAction r -> LexAction r
withLayout :: forall r. Keyword -> LexAction r -> LexAction r
withLayout Keyword
kw LexAction r
a = Keyword -> Parser ()
enterLayout Keyword
kw Parser () -> LexAction r -> LexAction r
forall r. Parser () -> LexAction r -> LexAction r
`andThen` LexAction r
a

infixr 1 `andThen`

-- | Prepend some parser manipulation to an action.
andThen :: Parser () -> LexAction r -> LexAction r
andThen :: forall r. Parser () -> LexAction r -> LexAction r
andThen Parser ()
cmd LexAction r
a = (AlexInput -> AlexInput -> Int -> Parser r) -> LexAction r
forall r.
(AlexInput -> AlexInput -> Int -> Parser r) -> LexAction r
LexAction ((AlexInput -> AlexInput -> Int -> Parser r) -> LexAction r)
-> (AlexInput -> AlexInput -> Int -> Parser r) -> LexAction r
forall a b. (a -> b) -> a -> b
$ \ AlexInput
inp AlexInput
inp' Int
n -> do
  Parser ()
cmd
  LexAction r -> AlexInput -> AlexInput -> Int -> Parser r
forall r. LexAction r -> AlexInput -> AlexInput -> Int -> Parser r
runLexAction LexAction r
a AlexInput
inp AlexInput
inp' Int
n

-- | Visit the current lexeme again.
revisit :: LexAction Token
revisit :: LexAction Token
revisit = (AlexInput -> AlexInput -> Int -> Parser Token) -> LexAction Token
forall r.
(AlexInput -> AlexInput -> Int -> Parser r) -> LexAction r
LexAction ((AlexInput -> AlexInput -> Int -> Parser Token)
 -> LexAction Token)
-> (AlexInput -> AlexInput -> Int -> Parser Token)
-> LexAction Token
forall a b. (a -> b) -> a -> b
$ \ AlexInput
_ AlexInput
_ Int
_ -> Parser Token
lexToken

-- | Throw away the current lexeme.
skip :: LexAction Token
skip :: LexAction Token
skip = (AlexInput -> AlexInput -> Int -> Parser Token) -> LexAction Token
forall r.
(AlexInput -> AlexInput -> Int -> Parser r) -> LexAction r
LexAction ((AlexInput -> AlexInput -> Int -> Parser Token)
 -> LexAction Token)
-> (AlexInput -> AlexInput -> Int -> Parser Token)
-> LexAction Token
forall a b. (a -> b) -> a -> b
$ \ AlexInput
_ AlexInput
inp' Int
_ -> AlexInput -> Parser Token
skipTo AlexInput
inp'

-- | Enter a new state without consuming any input.
begin :: LexState -> LexAction Token
begin :: Int -> LexAction Token
begin Int
code = Int -> LexAction Token -> LexAction Token
forall a. Int -> LexAction a -> LexAction a
beginWith Int
code LexAction Token
revisit

-- | Exit the current state without consuming any input.
end :: LexAction Token
end :: LexAction Token
end = LexAction Token -> LexAction Token
forall a. LexAction a -> LexAction a
endWith LexAction Token
revisit

-- | Enter a new state throwing away the current lexeme.
begin_ :: LexState -> LexAction Token
begin_ :: Int -> LexAction Token
begin_ Int
code = Int -> LexAction Token -> LexAction Token
forall a. Int -> LexAction a -> LexAction a
beginWith Int
code LexAction Token
skip

-- | Exit the current state throwing away the current lexeme.
end_ :: LexAction Token
end_ :: LexAction Token
end_ = LexAction Token -> LexAction Token
forall a. LexAction a -> LexAction a
endWith LexAction Token
skip

-- | Enter a new state and perform the given action.
beginWith :: LexState -> LexAction a -> LexAction a
beginWith :: forall a. Int -> LexAction a -> LexAction a
beginWith Int
code LexAction a
a = Int -> Parser ()
pushLexState Int
code Parser () -> LexAction a -> LexAction a
forall r. Parser () -> LexAction r -> LexAction r
`andThen` LexAction a
a

-- | Exit the current state and perform the given action.
endWith :: LexAction a -> LexAction a
endWith :: forall a. LexAction a -> LexAction a
endWith LexAction a
a = Parser ()
popLexState Parser () -> LexAction a -> LexAction a
forall r. Parser () -> LexAction r -> LexAction r
`andThen` LexAction a
a


-- | Parse a 'Keyword' token, triggers layout for 'layoutKeywords'.
keyword :: Keyword -> LexAction Token
keyword :: Keyword -> LexAction Token
keyword Keyword
k =
    case Keyword
k of

        -- Unconditional layout keyword.
        Keyword
_ | Keyword
k Keyword -> [Keyword] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Keyword]
layoutKeywords ->
            Keyword -> LexAction Token -> LexAction Token
forall r. Keyword -> LexAction r -> LexAction r
withLayout Keyword
k LexAction Token
cont

        -- Andreas, 2021-05-06, issue #5356:
        -- @constructor@ is not a layout keyword after all, replaced by @data _ where@.
        -- -- @constructor@ is not a layout keyword in @record ... where@ blocks,
        -- -- only in @interleaved mutual@ blocks.
        -- KwConstructor -> do
        --     cxt <- getContext
        --     if inMutualAndNotInWhereBlock cxt
        --       then withLayout k cont
        --       else cont

        Keyword
_ -> LexAction Token
cont
    where
    cont :: LexAction Token
cont = (Interval -> Token) -> LexAction Token
forall r. (Interval -> r) -> LexAction r
withInterval_ (Keyword -> Interval -> Token
TokKeyword Keyword
k)

    -- Andreas, 2021-05-06, issue #5356:
    -- @constructor@ is not a layout keyword after all, replaced by @data _ where@.
    -- -- Most recent block decides ...
    -- inMutualAndNotInWhereBlock = \case
    --   Layout KwMutual _ _ : _ -> True
    --   Layout KwWhere  _ _ : _ -> False
    --   _ : bs                  -> inMutualAndNotInWhereBlock bs
    --   []                      -> True  -- For better errors on stray @constructor@ decls.


-- | Parse a 'Symbol' token.
symbol :: Symbol -> LexAction Token
symbol :: Symbol -> LexAction Token
symbol Symbol
s = (Interval -> Token) -> LexAction Token
forall r. (Interval -> r) -> LexAction r
withInterval_ (Symbol -> Interval -> Token
TokSymbol Symbol
s)


-- | Parse a number.

number :: String -> Integer
number :: [Char] -> Integer
number [Char]
str = case [Char]
str of
    Char
'0' : Char
'x' : [Char]
num -> Integer -> [Char] -> Integer
parseNumber Integer
16 [Char]
num
    Char
'0' : Char
'b' : [Char]
num -> Integer -> [Char] -> Integer
parseNumber Integer
2  [Char]
num
    [Char]
num             -> Integer -> [Char] -> Integer
parseNumber Integer
10 [Char]
num
    where
        parseNumber :: Integer -> String -> Integer
        parseNumber :: Integer -> [Char] -> Integer
parseNumber Integer
radix = (Integer -> Char -> Integer) -> Integer -> [Char] -> Integer
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Integer -> Integer -> Char -> Integer
addDigit Integer
radix) Integer
0

        -- We rely on Agda.Syntax.Parser.Lexer to enforce that the digits are
        -- in the correct range (so e.g. the digit 'E' cannot appear in a
        -- binary number).
        addDigit :: Integer -> Integer -> Char -> Integer
        addDigit :: Integer -> Integer -> Char -> Integer
addDigit Integer
radix Integer
n Char
'_' = Integer
n
        addDigit Integer
radix Integer
n Char
c   = Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
radix Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
c)

integer :: String -> Integer
integer :: [Char] -> Integer
integer = \case
  Char
'-' : [Char]
str -> - ([Char] -> Integer
number [Char]
str)
  [Char]
str       -> [Char] -> Integer
number [Char]
str

-- | Parse a literal.
literal' :: (String -> a) -> (a -> Literal) -> LexAction Token
literal' :: forall a. ([Char] -> a) -> (a -> Literal) -> LexAction Token
literal' [Char] -> a
read a -> Literal
lit = ([Char] -> a) -> ((Interval, a) -> Token) -> LexAction Token
forall a tok.
([Char] -> a) -> ((Interval, a) -> tok) -> LexAction tok
withInterval' [Char] -> a
read (((Interval, a) -> Token) -> LexAction Token)
-> ((Interval, a) -> Token) -> LexAction Token
forall a b. (a -> b) -> a -> b
$ \ (Interval
r, a
a) ->
  RLiteral -> Token
TokLiteral (RLiteral -> Token) -> RLiteral -> Token
forall a b. (a -> b) -> a -> b
$ Range -> Literal -> RLiteral
forall a. Range -> a -> Ranged a
Ranged (Interval -> Range
forall a. HasRange a => a -> Range
getRange Interval
r) (Literal -> RLiteral) -> Literal -> RLiteral
forall a b. (a -> b) -> a -> b
$ a -> Literal
lit a
a

literal :: Read a => (a -> Literal) -> LexAction Token
literal :: forall a. Read a => (a -> Literal) -> LexAction Token
literal = ([Char] -> a) -> (a -> Literal) -> LexAction Token
forall a. ([Char] -> a) -> (a -> Literal) -> LexAction Token
literal' [Char] -> a
forall a. Read a => [Char] -> a
read

-- | Parse a potentially-qualified token. This action is responsible for
-- lexing both identifiers (which do not always have a qualifier, in
-- which case a 'TokId' is returned) *and* "qualified keywords", like
-- qualified @do@.
--
-- This action may thus modify the layout state of the parser, since
-- qualified @do@ is a layout "keyword".
--
-- Examples: @Foo.Bar.f@, @Foo.do@.
qualifiedToken :: LexAction Token
qualifiedToken :: LexAction Token
qualifiedToken = (Either (Interval, NonEmpty Char) [(Interval, NonEmpty Char)]
 -> Parser Token)
-> LexAction Token
forall a.
(Either (Interval, NonEmpty Char) [(Interval, NonEmpty Char)]
 -> Parser a)
-> LexAction a
qualified ((Either (Interval, NonEmpty Char) [(Interval, NonEmpty Char)]
  -> Parser Token)
 -> LexAction Token)
-> (Either (Interval, NonEmpty Char) [(Interval, NonEmpty Char)]
    -> Parser Token)
-> LexAction Token
forall a b. (a -> b) -> a -> b
$ ((Interval, NonEmpty Char) -> Parser Token)
-> ([(Interval, NonEmpty Char)] -> Parser Token)
-> Either (Interval, NonEmpty Char) [(Interval, NonEmpty Char)]
-> Parser Token
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Token -> Parser Token
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token -> Parser Token)
-> ((Interval, NonEmpty Char) -> Token)
-> (Interval, NonEmpty Char)
-> Parser Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Interval, [Char]) -> Token
TokId ((Interval, [Char]) -> Token)
-> ((Interval, NonEmpty Char) -> (Interval, [Char]))
-> (Interval, NonEmpty Char)
-> Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty Char -> [Char])
-> (Interval, NonEmpty Char) -> (Interval, [Char])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second NonEmpty Char -> [Char]
NonEmpty Char -> [Item (NonEmpty Char)]
forall l. IsList l => l -> [Item l]
toList) ([(Interval, [Char])] -> Parser Token
qid ([(Interval, [Char])] -> Parser Token)
-> ([(Interval, NonEmpty Char)] -> [(Interval, [Char])])
-> [(Interval, NonEmpty Char)]
-> Parser Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Interval, NonEmpty Char) -> (Interval, [Char]))
-> [(Interval, NonEmpty Char)] -> [(Interval, [Char])]
forall a b. (a -> b) -> [a] -> [b]
map ((NonEmpty Char -> [Char])
-> (Interval, NonEmpty Char) -> (Interval, [Char])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second NonEmpty Char -> [Char]
NonEmpty Char -> [Item (NonEmpty Char)]
forall l. IsList l => l -> [Item l]
toList)) where
  qid :: [(Interval, String)] -> Parser Token
  qid :: [(Interval, [Char])] -> Parser Token
qid [(Interval, [Char])]
parts = case [(Interval, [Char])]
-> Maybe ([(Interval, [Char])], (Interval, [Char]))
forall a. [a] -> Maybe ([a], a)
initLast [(Interval, [Char])]
parts of
    -- For qualified 'do', we have to pretend to be a layout keyword
    Just ([(Interval, [Char])]
initp, (Interval
i, [Char]
"do")) ->
      QualifiableToken -> [(Interval, [Char])] -> Interval -> Token
TokQual QualifiableToken
QualDo [(Interval, [Char])]
initp Interval
i Token -> Parser () -> Parser Token
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Keyword -> Parser ()
enterLayout Keyword
KwDo

    Just ([(Interval, [Char])]
initp, (Interval
i, [Char]
"(|)"))          -> Token -> Parser Token
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token -> Parser Token) -> Token -> Parser Token
forall a b. (a -> b) -> a -> b
$ QualifiableToken -> [(Interval, [Char])] -> Interval -> Token
TokQual QualifiableToken
QualEmptyIdiom [(Interval, [Char])]
initp Interval
i
    Just ([(Interval, [Char])]
initp, (Interval
i, [Char]
"\x2987\x2988")) -> Token -> Parser Token
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token -> Parser Token) -> Token -> Parser Token
forall a b. (a -> b) -> a -> b
$ QualifiableToken -> [(Interval, [Char])] -> Interval -> Token
TokQual QualifiableToken
QualEmptyIdiom [(Interval, [Char])]
initp Interval
i

    Just ([(Interval, [Char])]
initp, (Interval
i, [Char]
"(|"))           -> Token -> Parser Token
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token -> Parser Token) -> Token -> Parser Token
forall a b. (a -> b) -> a -> b
$ QualifiableToken -> [(Interval, [Char])] -> Interval -> Token
TokQual (Bool -> QualifiableToken
QualOpenIdiom Bool
False) [(Interval, [Char])]
initp Interval
i
    Just ([(Interval, [Char])]
initp, (Interval
i, [Char]
"\x2987"))       -> Token -> Parser Token
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token -> Parser Token) -> Token -> Parser Token
forall a b. (a -> b) -> a -> b
$ QualifiableToken -> [(Interval, [Char])] -> Interval -> Token
TokQual (Bool -> QualifiableToken
QualOpenIdiom Bool
True) [(Interval, [Char])]
initp Interval
i

    Maybe ([(Interval, [Char])], (Interval, [Char]))
_                                 -> Token -> Parser Token
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token -> Parser Token) -> Token -> Parser Token
forall a b. (a -> b) -> a -> b
$ [(Interval, [Char])] -> Token
TokQId [(Interval, [Char])]
parts

-- | Parse a possibly qualified name.
qualified :: (Either (Interval, String1) [(Interval, String1)] -> Parser a) -> LexAction a
qualified :: forall a.
(Either (Interval, NonEmpty Char) [(Interval, NonEmpty Char)]
 -> Parser a)
-> LexAction a
qualified Either (Interval, NonEmpty Char) [(Interval, NonEmpty Char)]
-> Parser a
tok =
    ([Char] -> Parser a) -> LexAction a
forall tok. ([Char] -> Parser tok) -> LexAction tok
token (([Char] -> Parser a) -> LexAction a)
-> ([Char] -> Parser a) -> LexAction a
forall a b. (a -> b) -> a -> b
$ \[Char]
s ->
    do  i <- Parser Interval
getParseInterval
        case mkName i $ List1.wordsBy (== '.') s of
            []  -> [Char] -> Parser a
forall a. [Char] -> Parser a
lexError [Char]
"lex error on .."
            [(Interval, NonEmpty Char)
x] -> Either (Interval, NonEmpty Char) [(Interval, NonEmpty Char)]
-> Parser a
tok (Either (Interval, NonEmpty Char) [(Interval, NonEmpty Char)]
 -> Parser a)
-> Either (Interval, NonEmpty Char) [(Interval, NonEmpty Char)]
-> Parser a
forall a b. (a -> b) -> a -> b
$ (Interval, NonEmpty Char)
-> Either (Interval, NonEmpty Char) [(Interval, NonEmpty Char)]
forall a b. a -> Either a b
Left  (Interval, NonEmpty Char)
x
            [(Interval, NonEmpty Char)]
xs  -> Either (Interval, NonEmpty Char) [(Interval, NonEmpty Char)]
-> Parser a
tok (Either (Interval, NonEmpty Char) [(Interval, NonEmpty Char)]
 -> Parser a)
-> Either (Interval, NonEmpty Char) [(Interval, NonEmpty Char)]
-> Parser a
forall a b. (a -> b) -> a -> b
$ [(Interval, NonEmpty Char)]
-> Either (Interval, NonEmpty Char) [(Interval, NonEmpty Char)]
forall a b. b -> Either a b
Right [(Interval, NonEmpty Char)]
xs
    where
        -- Compute the ranges for the substrings (separated by '.') of
        -- a name. Dots are included: the intervals generated for
        -- "A.B.x" correspond to "A.", "B." and "x".
        mkName :: Interval -> [String1] -> [(Interval, String1)]
        mkName :: Interval -> [NonEmpty Char] -> [(Interval, NonEmpty Char)]
mkName Interval
_ []     = []
        mkName Interval
i [NonEmpty Char
x]    = [(Interval
i, NonEmpty Char
x)]
        mkName (Interval SrcFile
f PositionWithoutFile
p0 PositionWithoutFile
p1) (NonEmpty Char
x:[NonEmpty Char]
xs) = (Interval
i0, NonEmpty Char
x) (Interval, NonEmpty Char)
-> [(Interval, NonEmpty Char)] -> [(Interval, NonEmpty Char)]
forall a. a -> [a] -> [a]
: Interval -> [NonEmpty Char] -> [(Interval, NonEmpty Char)]
mkName Interval
i1 [NonEmpty Char]
xs
            where
                p' :: PositionWithoutFile
p' = PositionWithoutFile -> Char -> PositionWithoutFile
forall a. Position' a -> Char -> Position' a
movePos (PositionWithoutFile -> NonEmpty Char -> PositionWithoutFile
forall (t :: * -> *) a.
Foldable t =>
Position' a -> t Char -> Position' a
movePosByString PositionWithoutFile
p0 NonEmpty Char
x) Char
'.'
                i0 :: Interval
i0 = SrcFile -> PositionWithoutFile -> PositionWithoutFile -> Interval
forall a.
a -> PositionWithoutFile -> PositionWithoutFile -> Interval' a
Interval SrcFile
f PositionWithoutFile
p0 PositionWithoutFile
p'
                i1 :: Interval
i1 = SrcFile -> PositionWithoutFile -> PositionWithoutFile -> Interval
forall a.
a -> PositionWithoutFile -> PositionWithoutFile -> Interval' a
Interval SrcFile
f PositionWithoutFile
p' PositionWithoutFile
p1


{--------------------------------------------------------------------------
    Predicates
 --------------------------------------------------------------------------}

-- | True when the given character is the next character of the input string.
followedBy :: Char -> LexPredicate
followedBy :: Char -> LexPredicate
followedBy Char
c' ([Int], ParseFlags)
_ AlexInput
_ Int
_ AlexInput
inp =
    case AlexInput -> [Char]
lexInput AlexInput
inp of
        []  -> Bool
False
        Char
c:[Char]
_ -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c'

-- | True if we are at the end of the file.
eof :: LexPredicate
eof :: LexPredicate
eof ([Int], ParseFlags)
_ AlexInput
_ Int
_ AlexInput
inp = [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ AlexInput -> [Char]
lexInput AlexInput
inp

-- | True if the given state appears somewhere on the state stack
inState :: LexState -> LexPredicate
inState :: Int -> LexPredicate
inState Int
s ([Int]
ls, ParseFlags
_) AlexInput
_ Int
_ AlexInput
_ = Int
s Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
ls