{-# LANGUAGE Strict #-}
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)
data Token
= ID Name
| T.Text
| INDEXING
| 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show, Token -> Token -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq, Eq 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
min :: Token -> Token -> Token
$cmin :: Token -> Token -> Token
max :: Token -> Token -> Token
$cmax :: Token -> Token -> Token
>= :: Token -> Token -> Bool
$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
compare :: Token -> Token -> Ordering
$ccompare :: Token -> Token -> Ordering
Ord)
mkQualId :: T.Text -> ([Name], Name)
mkQualId :: Text -> ([Name], Name)
mkQualId Text
s = case forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
T.splitOn Text
"." Text
s of
[] -> forall a. HasCallStack => String -> a
error String
"mkQualId: no components"
Text
k : [Text]
qs -> (forall a b. (a -> b) -> [a] -> [b]
map Text -> Name
nameFromText (forall a. [a] -> [a]
reverse [Text]
qs), Text -> Name
nameFromText Text
k)
suffZero :: T.Text -> T.Text
suffZero :: Text -> Text
suffZero Text
s = if HasCallStack => Text -> Char
T.last Text
s forall a. Eq a => a -> a -> Bool
== Char
'.' then Text
s 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 forall a. Read a => ReadS a
reads String
s' of
[(a
x, String
"")] -> a
x
[(a, String)]
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Invalid " forall a. [a] -> [a] -> [a]
++ String
desc forall a. [a] -> [a] -> [a]
++ String
" literal: `" forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
s 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' 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 forall a. Ord a => a -> a -> Bool
>= a
48 Bool -> Bool -> Bool
&& a
c forall a. Ord a => a -> a -> Bool
<= a
57
then a
x forall a. Num a => a -> a -> a
* a
10 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
c 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' 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 forall a. Ord a => a -> a -> Bool
>= a
48 Bool -> Bool -> Bool
&& a
c forall a. Ord a => a -> a -> Bool
<= a
49
then a
x forall a. Num a => a -> a -> a
* a
2 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
c 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' 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 forall a. Ord a => a -> a -> Bool
>= a
48 Bool -> Bool -> Bool
&& a
c forall a. Ord a => a -> a -> Bool
<= a
57 =
a
x forall a. Num a => a -> a -> a
* a
16 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
c forall a. Num a => a -> a -> a
- a
48)
| a
c forall a. Ord a => a -> a -> Bool
>= a
65 Bool -> Bool -> Bool
&& a
c forall a. Ord a => a -> a -> Bool
<= a
70 =
a
x forall a. Num a => a -> a -> a
* a
16 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
10 forall a. Num a => a -> a -> a
+ a
c forall a. Num a => a -> a -> a
- a
65)
| a
c forall a. Ord a => a -> a -> Bool
>= a
97 Bool -> Bool -> Bool
&& a
c forall a. Ord a => a -> a -> Bool
<= a
102 =
a
x forall a. Num a => a -> a -> a
* a
16 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
10 forall a. Num a => a -> a -> a
+ a
c 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 = forall a. (Text -> a) -> ByteString -> a
tokenS forall a b. (a -> b) -> a -> b
$ a -> Token
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 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 = forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' Pos -> Word8 -> Pos
advance' Pos
orig_pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => ByteString -> ByteString
BS.init
where
advance' :: Pos -> Word8 -> Pos
advance' (Pos String
f !Int
line !Int
col !Int
addr) Word8
c
| Word8
c forall a. Eq a => a -> a -> Bool
== Word8
nl = String -> Int -> Int -> Int -> Pos
Pos String
f (Int
line forall a. Num a => a -> a -> a
+ Int
1) Int
1 (Int
addr forall a. Num a => a -> a -> a
+ Int
1)
| Bool
otherwise = String -> Int -> Int -> Int -> Pos
Pos String
f Int
line (Int
col forall a. Num a => a -> a -> a
+ Int
1) (Int
addr forall a. Num a => a -> a -> a
+ Int
1)
nl :: Word8
nl = forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 forall a. Eq a => a -> a -> Bool
== Text
"*" = Token
ASTERISK
| Name -> Text
nameToText Name
q forall a. Eq a => a -> a -> Bool
== Text
"-" = Token
NEGATE
| Name -> Text
nameToText Name
q forall a. Eq a => a -> a -> Bool
== Text
"<" = Token
LTH
| Name -> Text
nameToText Name
q forall a. Eq a => a -> a -> Bool
== Text
"^" = Token
HAT
| Name -> Text
nameToText Name
q 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 =
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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
`T.isPrefixOf` Text
s) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a. Integral a => [(Text, a)]
romanNumerals of
Maybe (Text, a)
Nothing -> a
0
Just (Text
d, a
n) -> a
n forall a. Num a => a -> a -> 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
let comps :: [Text]
comps = (Char -> Bool) -> Text -> [Text]
T.split (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 = forall a. Num a => Integer -> a
fromInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> Either a b -> b
fromRight (forall a. HasCallStack => String -> a
error String
"internal error") forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a (Integer, b)
r
intPart :: a
intPart = forall {c} {a} {a} {b}.
Num c =>
(a -> Either a (Integer, b)) -> a -> c
runTextReader forall a. Integral a => Reader a
T.hexadecimal Text
i
fracPart :: a
fracPart = forall {c} {a} {a} {b}.
Num c =>
(a -> Either a (Integer, b)) -> a -> c
runTextReader forall a. Integral a => Reader a
T.hexadecimal Text
f
exponent :: a
exponent = forall {c} {a} {a} {b}.
Num c =>
(a -> Either a (Integer, b)) -> a -> c
runTextReader (forall a. Num a => Reader a -> Reader a
T.signed forall a. Integral a => Reader a
T.decimal) Text
p
fracLen :: a
fracLen = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Text -> Int
T.length Text
f
fracVal :: a
fracVal = a
fracPart forall a. Fractional a => a -> a -> a
/ (a
16.0 forall a. Floating a => a -> a -> a
** a
fracLen)
totalVal :: a
totalVal = (a
intPart forall a. Num a => a -> a -> a
+ a
fracVal) forall a. Num a => a -> a -> a
* (a
2.0 forall a. Floating a => a -> a -> a
** a
exponent)
in a
totalVal
[Text]
_ -> forall a. HasCallStack => String -> a
error String
"bad hex real literal"