{-# LANGUAGE Strict #-}
module Language.Futhark.Parser.Lexer.Tokens
( Token (..),
Lexeme,
fromRoman,
symbol,
mkQualId,
tokenPosM,
tokenM,
tokenC,
keyword,
tokenS,
indexing,
suffZero,
tryRead,
readIntegral,
readHexRealLit,
)
where
import Data.ByteString.Lazy qualified as BS
import Data.Char (digitToInt, ord)
import Data.Either
import Data.List (find, foldl')
import Data.Loc (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.Parser.Lexer.Wrapper
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 String
| EOF
| HOLE
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)
keyword :: T.Text -> Token
keyword :: Text -> Token
keyword Text
s =
case Text
s of
Text
"true" -> Token
TRUE
Text
"false" -> Token
FALSE
Text
"if" -> Token
IF
Text
"then" -> Token
THEN
Text
"else" -> Token
ELSE
Text
"def" -> Token
DEF
Text
"let" -> Token
LET
Text
"loop" -> Token
LOOP
Text
"in" -> Token
IN
Text
"val" -> Token
VAL
Text
"for" -> Token
FOR
Text
"do" -> Token
DO
Text
"with" -> Token
WITH
Text
"local" -> Token
LOCAL
Text
"open" -> Token
OPEN
Text
"include" -> Token
INCLUDE
Text
"import" -> Token
IMPORT
Text
"type" -> Token
TYPE
Text
"entry" -> Token
ENTRY
Text
"module" -> Token
MODULE
Text
"while" -> Token
WHILE
Text
"assert" -> Token
ASSERT
Text
"match" -> Token
MATCH
Text
"case" -> Token
CASE
Text
_ -> Name -> Token
ID forall a b. (a -> b) -> a -> b
$ Text -> Name
nameFromText Text
s
indexing :: (Loc, T.Text) -> Alex Name
indexing :: (Loc, Text) -> Alex Name
indexing (Loc
loc, Text
s) = case Text -> Token
keyword Text
s of
ID Name
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
v
Token
_ -> forall a. Loc -> Text -> Alex a
alexError Loc
loc forall a b. (a -> b) -> a -> b
$ Text
"Cannot index keyword '" forall a. Semigroup a => a -> a -> a
<> Text
s forall a. Semigroup a => a -> a -> a
<> Text
"'."
mkQualId :: T.Text -> Alex ([Name], Name)
mkQualId :: Text -> Alex ([Name], Name)
mkQualId Text
s = case forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"." Text
s of
[] -> forall a. HasCallStack => String -> a
error String
"mkQualId: no components"
Text
k : [Text]
qs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 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 -> Alex a
tryRead :: forall a. Read a => String -> Text -> Alex a
tryRead String
desc Text
s = case forall a. Read a => ReadS a
reads String
s' of
[(a
x, String
"")] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
readIntegral :: Integral a => T.Text -> a
readIntegral :: forall a. Integral a => Text -> a
readIntegral Text
s
| Text
"0x" Text -> Text -> Bool
`T.isPrefixOf` Text
s Bool -> Bool -> Bool
|| Text
"0X" Text -> Text -> Bool
`T.isPrefixOf` Text
s = forall {a}. Num a => a -> Text -> a
parseBase a
16 (Int -> Text -> Text
T.drop Int
2 Text
s)
| Text
"0b" Text -> Text -> Bool
`T.isPrefixOf` Text
s Bool -> Bool -> Bool
|| Text
"0B" Text -> Text -> Bool
`T.isPrefixOf` Text
s = forall {a}. Num a => a -> Text -> a
parseBase a
2 (Int -> Text -> Text
T.drop Int
2 Text
s)
| Text
"0r" Text -> Text -> Bool
`T.isPrefixOf` Text
s Bool -> Bool -> Bool
|| Text
"0R" Text -> Text -> Bool
`T.isPrefixOf` Text
s = forall a. Integral a => Text -> a
fromRoman (Int -> Text -> Text
T.drop Int
2 Text
s)
| Bool
otherwise = forall {a}. Num a => a -> Text -> a
parseBase a
10 Text
s
where
parseBase :: a -> Text -> a
parseBase a
base = forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl (\a
acc Char
c -> a
acc forall a. Num a => a -> a -> a
* a
base forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
c)) a
0
tokenC :: a -> (Pos, Char, BS.ByteString, Int64) -> Int64 -> Alex (Lexeme a)
tokenC :: forall a.
a -> (Pos, Char, ByteString, Int64) -> Int64 -> Alex (Lexeme a)
tokenC a
v = forall a.
(Text -> a)
-> (Pos, Char, ByteString, Int64) -> Int64 -> Alex (Lexeme a)
tokenS forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const a
v
tokenS :: (T.Text -> a) -> (Pos, Char, BS.ByteString, Int64) -> Int64 -> Alex (Lexeme a)
tokenS :: forall a.
(Text -> a)
-> (Pos, Char, ByteString, Int64) -> Int64 -> Alex (Lexeme a)
tokenS Text -> a
f = forall a.
(Text -> Alex a)
-> (Pos, Char, ByteString, Int64) -> Int64 -> Alex (Lexeme a)
tokenM forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> a
f
type Lexeme a = (Pos, Pos, a)
tokenM ::
(T.Text -> Alex a) ->
(Pos, Char, BS.ByteString, Int64) ->
Int64 ->
Alex (Lexeme a)
tokenM :: forall a.
(Text -> Alex a)
-> (Pos, Char, ByteString, Int64) -> Int64 -> Alex (Lexeme a)
tokenM Text -> Alex a
f = forall a.
((Loc, Text) -> Alex a)
-> (Pos, Char, ByteString, Int64) -> Int64 -> Alex (Lexeme a)
tokenPosM (Text -> Alex a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
tokenPosM ::
((Loc, T.Text) -> Alex a) ->
(Pos, Char, BS.ByteString, Int64) ->
Int64 ->
Alex (Lexeme a)
tokenPosM :: forall a.
((Loc, Text) -> Alex a)
-> (Pos, Char, ByteString, Int64) -> Int64 -> Alex (Lexeme a)
tokenPosM (Loc, Text) -> Alex a
f (Pos
pos, Char
_, ByteString
s, Int64
_) Int64
len = do
a
x <- (Loc, Text) -> Alex a
f (Pos -> Pos -> Loc
Loc Pos
pos Pos
pos', ByteString -> Text
T.decodeUtf8 forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.toStrict ByteString
s')
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pos
pos, Pos
pos', a
x)
where
pos' :: Pos
pos' = Pos -> ByteString -> Pos
advance Pos
pos ByteString
s'
s' :: ByteString
s' = Int64 -> ByteString -> ByteString
BS.take Int64
len ByteString
s
advance :: Pos -> BS.ByteString -> Pos
advance :: Pos -> ByteString -> Pos
advance Pos
orig_pos = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Pos -> Word8 -> Pos
advance' Pos
orig_pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
init forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack
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 -> Alex a
readHexRealLit :: forall a. RealFloat a => Text -> Alex 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 forall (f :: * -> *) a. Applicative f => a -> f a
pure a
totalVal
[Text]
_ -> forall a. HasCallStack => String -> a
error String
"bad hex real literal"