futhark-0.25.18: src/Language/Futhark/Parser/Lexer/Tokens.hs

{-# 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 (Show, Eq, Ord)

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

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

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

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

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

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

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

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

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

symbol :: [Name] -> Name -> Token
symbol [] q
  | nameToText q == "*" = ASTERISK
  | nameToText q == "-" = NEGATE
  | nameToText q == "<" = LTH
  | nameToText q == "^" = HAT
  | nameToText q == "|" = PIPE
  | otherwise = SYMBOL (leadingOperator q) [] q
symbol qs q = SYMBOL (leadingOperator q) qs q

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

fromRoman :: (Integral a) => T.Text -> a
fromRoman s =
  case find ((`T.isPrefixOf` s) . fst) romanNumerals of
    Nothing -> 0
    Just (d, n) -> n + fromRoman (T.drop (T.length d) s)

readHexRealLit :: (RealFloat a) => T.Text -> a
readHexRealLit s =
  let num = T.drop 2 s
   in -- extract number into integer, fractional and (optional) exponent
      let comps = T.split (`elem` ['.', 'p', 'P']) num
       in case comps of
            [i, f, p] ->
              let runTextReader r = fromInteger . fst . fromRight (error "internal error") . r
                  intPart = runTextReader T.hexadecimal i
                  fracPart = runTextReader T.hexadecimal f
                  exponent = runTextReader (T.signed T.decimal) p

                  fracLen = fromIntegral $ T.length f
                  fracVal = fracPart / (16.0 ** fracLen)
                  totalVal = (intPart + fracVal) * (2.0 ** exponent)
               in totalVal
            _ -> error "bad hex real literal"