{-# 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,
    advance,
    readHexRealLit,
  )
where

import Data.ByteString.Lazy qualified as BS
import Data.Char (ord)
import Data.Either
import Data.List (find)
import Data.Loc (Pos (..))
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

advance :: Pos -> BS.ByteString -> Pos
advance :: Pos -> ByteString -> Pos
advance Pos
orig_pos = (Pos -> Word8 -> Pos) -> Pos -> ByteString -> Pos
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' Pos -> Word8 -> Pos
advance' Pos
orig_pos (ByteString -> Pos)
-> (ByteString -> ByteString) -> ByteString -> Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BS.init
  where
    advance' :: Pos -> Word8 -> Pos
advance' (Pos String
f !Int
line !Int
col !Int
addr) Word8
c
      | Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
nl = String -> Int -> Int -> Int -> Pos
Pos String
f (Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
1 (Int
addr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      | Bool
otherwise = String -> Int -> Int -> Int -> Pos
Pos String
f Int
line (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
addr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    nl :: Word8
nl = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'\n'

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"