    {-# LANGUAGE Strict #-}

    -- | Definition of the tokens used in the lexer.
    --
    -- Also defines other useful building blocks for constructing tokens.
    module Language.Futhark.Parser.Lexer.Tokens
      ( Token (..),
        fromRoman,
        symbol,
        mkQualId,
        tokenC,
        tokenS,
        suffZero,
        tryRead,
        decToken,
        binToken,
        hexToken,
        romToken,
        readHexRealLit,
      )
    where

    import Data.ByteString.Lazy qualified as BS
    import Data.Either
    import Data.List (find)
    import Data.Text qualified as T
    import Data.Text.Encoding qualified as T
    import Data.Text.Read qualified as T
    import Language.Futhark.Core
      ( Int16,
        Int32,
        Int64,
        Int8,
        Name,
        Word16,
        Word32,
        Word64,
        Word8,
      )
    import Language.Futhark.Prop (leadingOperator)
    import Language.Futhark.Syntax (BinOp, nameFromText, nameToText)
    import Numeric.Half
    import Prelude hiding (exponent)

    -- | A lexical token.  It does not itself contain position
    -- information, so in practice the parser will consume tokens tagged
    -- with a source position.
    data Token
      = ID Name
      | COMMENT T.Text
      | INDEXING -- A left bracket immediately following an identifier.
      | SYMBOL BinOp [Name] Name
      | CONSTRUCTOR Name
      | NATLIT Name Integer
      | INTLIT Integer
      | STRINGLIT T.Text
      | I8LIT Int8
      | I16LIT Int16
      | I32LIT Int32
      | I64LIT Int64
      | U8LIT Word8
      | U16LIT Word16
      | U32LIT Word32
      | U64LIT Word64
      | FLOATLIT Double
      | F16LIT Half
      | F32LIT Float
      | F64LIT Double
      | CHARLIT Char
      | COLON
      | COLON_GT
      | BACKSLASH
      | APOSTROPHE
      | APOSTROPHE_THEN_HAT
      | APOSTROPHE_THEN_TILDE
      | BACKTICK
      | HASH_LBRACKET
      | DOT
      | TWO_DOTS
      | TWO_DOTS_LT
      | TWO_DOTS_GT
      | THREE_DOTS
      | LPAR
      | RPAR
      | LBRACKET
      | RBRACKET
      | LCURLY
      | RCURLY
      | COMMA
      | UNDERSCORE
      | RIGHT_ARROW
      | QUESTION_MARK
      | EQU
      | ASTERISK
      | NEGATE
      | BANG
      | DOLLAR
      | LTH
      | HAT
      | TILDE
      | PIPE
      | IF
      | THEN
      | ELSE
      | DEF
      | LET
      | LOOP
      | IN
      | FOR
      | DO
      | WITH
      | ASSERT
      | TRUE
      | FALSE
      | WHILE
      | INCLUDE
      | IMPORT
      | ENTRY
      | TYPE
      | MODULE
      | VAL
      | OPEN
      | LOCAL
      | MATCH
      | CASE
      | DOC T.Text
      | EOF
      | HOLE
      | ERROR T.Text
      deriving (Int -> Token -> ShowS
    [Token] -> ShowS
    Token -> String
    (Int -> Token -> ShowS)
    -> (Token -> String) -> ([Token] -> ShowS) -> Show Token
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Token -> ShowS
    showsPrec :: Int -> Token -> ShowS
    $cshow :: Token -> String
    show :: Token -> String
    $cshowList :: [Token] -> ShowS
    showList :: [Token] -> ShowS
    Show, Token -> Token -> Bool
    (Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Token -> Token -> Bool
    == :: Token -> Token -> Bool
    $c/= :: Token -> Token -> Bool
    /= :: Token -> Token -> Bool
    Eq, Eq Token
    Eq Token =>
    (Token -> Token -> Ordering)
    -> (Token -> Token -> Bool)
    -> (Token -> Token -> Bool)
    -> (Token -> Token -> Bool)
    -> (Token -> Token -> Bool)
    -> (Token -> Token -> Token)
    -> (Token -> Token -> Token)
    -> Ord Token
    Token -> Token -> Bool
    Token -> Token -> Ordering
    Token -> Token -> Token
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: Token -> Token -> Ordering
    compare :: Token -> Token -> Ordering
    $c< :: Token -> Token -> Bool
    < :: Token -> Token -> Bool
    $c<= :: Token -> Token -> Bool
    <= :: Token -> Token -> Bool
    $c> :: Token -> Token -> Bool
    > :: Token -> Token -> Bool
    $c>= :: Token -> Token -> Bool
    >= :: Token -> Token -> Bool
    $cmax :: Token -> Token -> Token
    max :: Token -> Token -> Token
    $cmin :: Token -> Token -> Token
    min :: Token -> Token -> Token
    Ord)

    mkQualId :: T.Text -> ([Name], Name)
    mkQualId :: Text -> ([Name], Name)
    mkQualId Text
    s = case [Text] -> [Text]
    forall a. [a] -> [a]
    reverse ([Text] -> [Text]) -> [Text] -> [Text]
    forall a b. (a -> b) -> a -> b
    $ HasCallStack => Text -> Text -> [Text]
    Text -> Text -> [Text]
    T.splitOn Text
    "." Text
    s of
      [] -> String -> ([Name], Name)
    forall a. HasCallStack => String -> a
    error String
    "mkQualId: no components"
      Text
    k : [Text]
    qs -> ((Text -> Name) -> [Text] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map Text -> Name
    nameFromText ([Text] -> [Text]
    forall a. [a] -> [a]
    reverse [Text]
    qs), Text -> Name
    nameFromText Text
    k)

    -- | Suffix a zero if the last character is dot.
    suffZero :: T.Text -> T.Text
    suffZero :: Text -> Text
    suffZero Text
    s = if HasCallStack => Text -> Char
    Text -> Char
    T.last Text
    s Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '.' then Text
    s Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "0" else Text
    s

    tryRead :: (Read a) => String -> T.Text -> a
    tryRead :: forall a. Read a => String -> Text -> a
    tryRead String
    desc Text
    s = case ReadS a
    forall a. Read a => ReadS a
    reads String
    s' of
      [(a
    x, String
    "")] -> a
    x
      [(a, String)]
    _ -> String -> a
    forall a. HasCallStack => String -> a
    error (String -> a) -> String -> a
    forall a b. (a -> b) -> a -> b
    $ String
    "Invalid " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    desc String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    " literal: `" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Text -> String
    T.unpack Text
    s String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "'."
      where
        s' :: String
    s' = Text -> String
    T.unpack Text
    s

    {-# INLINE tokenC #-}
    tokenC :: a -> BS.ByteString -> a
    tokenC :: forall a. a -> ByteString -> a
    tokenC a
    v ByteString
    _ = a
    v

    {-# INLINE decToken #-}
    decToken :: (Integral a) => (a -> Token) -> BS.ByteString -> Token
    decToken :: forall a. Integral a => (a -> Token) -> ByteString -> Token
    decToken a -> Token
    f = a -> Token
    f (a -> Token) -> (ByteString -> a) -> ByteString -> Token
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (a -> Word8 -> a) -> a -> ByteString -> a
    forall a. (a -> Word8 -> a) -> a -> ByteString -> a
    BS.foldl' a -> Word8 -> a
    forall {a} {a}. (Num a, Integral a) => a -> a -> a
    digit a
    0
      where
        digit :: a -> a -> a
    digit a
    x a
    c =
          if a
    c a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    >= a
    48 Bool -> Bool -> Bool
    && a
    c a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    <= a
    57
            then a
    x a -> a -> a
    forall a. Num a => a -> a -> a
    * a
    10 a -> a -> a
    forall a. Num a => a -> a -> a
    + a -> a
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (a
    c a -> a -> a
    forall a. Num a => a -> a -> a
    - a
    48)
            else a
    x

    {-# INLINE binToken #-}
    binToken :: (Integral a) => (a -> Token) -> BS.ByteString -> Token
    binToken :: forall a. Integral a => (a -> Token) -> ByteString -> Token
    binToken a -> Token
    f = a -> Token
    f (a -> Token) -> (ByteString -> a) -> ByteString -> Token
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (a -> Word8 -> a) -> a -> ByteString -> a
    forall a. (a -> Word8 -> a) -> a -> ByteString -> a
    BS.foldl' a -> Word8 -> a
    forall {a} {a}. (Num a, Integral a) => a -> a -> a
    digit a
    0
      where
        digit :: a -> a -> a
    digit a
    x a
    c =
          if a
    c a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    >= a
    48 Bool -> Bool -> Bool
    && a
    c a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    <= a
    49
            then a
    x a -> a -> a
    forall a. Num a => a -> a -> a
    * a
    2 a -> a -> a
    forall a. Num a => a -> a -> a
    + a -> a
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (a
    c a -> a -> a
    forall a. Num a => a -> a -> a
    - a
    48)
            else a
    x

    {-# INLINE hexToken #-}
    hexToken :: (Integral a) => (a -> Token) -> BS.ByteString -> Token
    hexToken :: forall a. Integral a => (a -> Token) -> ByteString -> Token
    hexToken a -> Token
    f = a -> Token
    f (a -> Token) -> (ByteString -> a) -> ByteString -> Token
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (a -> Word8 -> a) -> a -> ByteString -> a
    forall a. (a -> Word8 -> a) -> a -> ByteString -> a
    BS.foldl' a -> Word8 -> a
    forall {a} {a}. (Num a, Integral a) => a -> a -> a
    digit a
    0
      where
        digit :: a -> a -> a
    digit a
    x a
    c
          | a
    c a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    >= a
    48 Bool -> Bool -> Bool
    && a
    c a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    <= a
    57 =
              a
    x a -> a -> a
    forall a. Num a => a -> a -> a
    * a
    16 a -> a -> a
    forall a. Num a => a -> a -> a
    + a -> a
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (a
    c a -> a -> a
    forall a. Num a => a -> a -> a
    - a
    48)
          | a
    c a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    >= a
    65 Bool -> Bool -> Bool
    && a
    c a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    <= a
    70 =
              a
    x a -> a -> a
    forall a. Num a => a -> a -> a
    * a
    16 a -> a -> a
    forall a. Num a => a -> a -> a
    + a -> a
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (a
    10 a -> a -> a
    forall a. Num a => a -> a -> a
    + a
    c a -> a -> a
    forall a. Num a => a -> a -> a
    - a
    65)
          | a
    c a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    >= a
    97 Bool -> Bool -> Bool
    && a
    c a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    <= a
    102 =
              a
    x a -> a -> a
    forall a. Num a => a -> a -> a
    * a
    16 a -> a -> a
    forall a. Num a => a -> a -> a
    + a -> a
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (a
    10 a -> a -> a
    forall a. Num a => a -> a -> a
    + a
    c a -> a -> a
    forall a. Num a => a -> a -> a
    - a
    97)
          | Bool
    otherwise =
              a
    x

    {-# INLINE romToken #-}
    romToken :: (Integral a) => (a -> Token) -> BS.ByteString -> Token
    romToken :: forall a. Integral a => (a -> Token) -> ByteString -> Token
    romToken a -> Token
    f = (Text -> Token) -> ByteString -> Token
    forall a. (Text -> a) -> ByteString -> a
    tokenS ((Text -> Token) -> ByteString -> Token)
    -> (Text -> Token) -> ByteString -> Token
    forall a b. (a -> b) -> a -> b
    $ a -> Token
    f (a -> Token) -> (Text -> a) -> Text -> Token
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> a
    forall a. Integral a => Text -> a
    fromRoman

    {-# INLINE tokenS #-}
    tokenS :: (T.Text -> a) -> BS.ByteString -> a
    tokenS :: forall a. (Text -> a) -> ByteString -> a
    tokenS Text -> a
    f = Text -> a
    f (Text -> a) -> (ByteString -> Text) -> ByteString -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> Text
    T.decodeUtf8 (ByteString -> Text)
    -> (ByteString -> ByteString) -> ByteString -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> ByteString
    BS.toStrict

    symbol :: [Name] -> Name -> Token
    symbol :: [Name] -> Name -> Token
    symbol [] Name
    q
      | Name -> Text
    nameToText Name
    q Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "*" = Token
    ASTERISK
      | Name -> Text
    nameToText Name
    q Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "-" = Token
    NEGATE
      | Name -> Text
    nameToText Name
    q Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "<" = Token
    LTH
      | Name -> Text
    nameToText Name
    q Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "^" = Token
    HAT
      | Name -> Text
    nameToText Name
    q Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "|" = Token
    PIPE
      | Bool
    otherwise = BinOp -> [Name] -> Name -> Token
    SYMBOL (Name -> BinOp
    leadingOperator Name
    q) [] Name
    q
    symbol [Name]
    qs Name
    q = BinOp -> [Name] -> Name -> Token
    SYMBOL (Name -> BinOp
    leadingOperator Name
    q) [Name]
    qs Name
    q

    romanNumerals :: (Integral a) => [(T.Text, a)]
    romanNumerals :: forall a. Integral a => [(Text, a)]
    romanNumerals =
      [(Text, a)] -> [(Text, a)]
    forall a. [a] -> [a]
    reverse
        [ (Text
    "I", a
    1),
          (Text
    "IV", a
    4),
          (Text
    "V", a
    5),
          (Text
    "IX", a
    9),
          (Text
    "X", a
    10),
          (Text
    "XL", a
    40),
          (Text
    "L", a
    50),
          (Text
    "XC", a
    90),
          (Text
    "C", a
    100),
          (Text
    "CD", a
    400),
          (Text
    "D", a
    500),
          (Text
    "CM", a
    900),
          (Text
    "M", a
    1000)
        ]

    fromRoman :: (Integral a) => T.Text -> a
    fromRoman :: forall a. Integral a => Text -> a
    fromRoman Text
    s =
      case ((Text, a) -> Bool) -> [(Text, a)] -> Maybe (Text, a)
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
    find ((Text -> Text -> Bool
    `T.isPrefixOf` Text
    s) (Text -> Bool) -> ((Text, a) -> Text) -> (Text, a) -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Text, a) -> Text
    forall a b. (a, b) -> a
    fst) [(Text, a)]
    forall a. Integral a => [(Text, a)]
    romanNumerals of
        Maybe (Text, a)
    Nothing -> a
    0
        Just (Text
    d, a
    n) -> a
    n a -> a -> a
    forall a. Num a => a -> a -> a
    + Text -> a
    forall a. Integral a => Text -> a
    fromRoman (Int -> Text -> Text
    T.drop (Text -> Int
    T.length Text
    d) Text
    s)

    readHexRealLit :: (RealFloat a) => T.Text -> a
    readHexRealLit :: forall a. RealFloat a => Text -> a
    readHexRealLit Text
    s =
      let num :: Text
    num = Int -> Text -> Text
    T.drop Int
    2 Text
    s
       in -- extract number into integer, fractional and (optional) exponent
          let comps :: [Text]
    comps = (Char -> Bool) -> Text -> [Text]
    T.split (Char -> String -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Char
    '.', Char
    'p', Char
    'P']) Text
    num
           in case [Text]
    comps of
                [Text
    i, Text
    f, Text
    p] ->
                  let runTextReader :: (a -> Either a (Integer, b)) -> a -> c
    runTextReader a -> Either a (Integer, b)
    r = Integer -> c
    forall a. Num a => Integer -> a
    fromInteger (Integer -> c) -> (a -> Integer) -> a -> c
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Integer, b) -> Integer
    forall a b. (a, b) -> a
    fst ((Integer, b) -> Integer) -> (a -> (Integer, b)) -> a -> Integer
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Integer, b) -> Either a (Integer, b) -> (Integer, b)
    forall b a. b -> Either a b -> b
    fromRight (String -> (Integer, b)
    forall a. HasCallStack => String -> a
    error String
    "internal error") (Either a (Integer, b) -> (Integer, b))
    -> (a -> Either a (Integer, b)) -> a -> (Integer, b)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> Either a (Integer, b)
    r
                      intPart :: a
    intPart = (Text -> Either String (Integer, Text)) -> Text -> a
    forall {c} {a} {a} {b}.
    Num c =>
    (a -> Either a (Integer, b)) -> a -> c
    runTextReader Text -> Either String (Integer, Text)
    forall a. Integral a => Reader a
    T.hexadecimal Text
    i
                      fracPart :: a
    fracPart = (Text -> Either String (Integer, Text)) -> Text -> a
    forall {c} {a} {a} {b}.
    Num c =>
    (a -> Either a (Integer, b)) -> a -> c
    runTextReader Text -> Either String (Integer, Text)
    forall a. Integral a => Reader a
    T.hexadecimal Text
    f
                      exponent :: a
    exponent = (Text -> Either String (Integer, Text)) -> Text -> a
    forall {c} {a} {a} {b}.
    Num c =>
    (a -> Either a (Integer, b)) -> a -> c
    runTextReader ((Text -> Either String (Integer, Text))
    -> Text -> Either String (Integer, Text)
    forall a. Num a => Reader a -> Reader a
    T.signed Text -> Either String (Integer, Text)
    forall a. Integral a => Reader a
    T.decimal) Text
    p

                      fracLen :: a
    fracLen = Int -> a
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int -> a) -> Int -> a
    forall a b. (a -> b) -> a -> b
    $ Text -> Int
    T.length Text
    f
                      fracVal :: a
    fracVal = a
    fracPart a -> a -> a
    forall a. Fractional a => a -> a -> a
    / (a
    16.0 a -> a -> a
    forall a. Floating a => a -> a -> a
    ** a
    fracLen)
                      totalVal :: a
    totalVal = (a
    intPart a -> a -> a
    forall a. Num a => a -> a -> a
    + a
    fracVal) a -> a -> a
    forall a. Num a => a -> a -> a
    * (a
    2.0 a -> a -> a
    forall a. Floating a => a -> a -> a
    ** a
    exponent)
                   in a
    totalVal
                [Text]
    _ -> String -> a
    forall a. HasCallStack => String -> a
    error String
    "bad hex real literal"