Literals.hs

module Compiler.Lexer.Literals where

import Control.Applicative
import Control.Monad
import qualified Data.ByteString as BS
import Data.Char
import Data.Text as T
import Data.Decimal
import Text.Read hiding (choice)
import Text.Hex (decodeHex, encodeHex)

import Parser.Lib
import Parser.Parser
import Test.Common
import Common

data Literal
  = LitString Text
  | LitNumber IntType
  | LitFloat Decimal -- This needs to be a decimal so that string round tripping can work.
  | LitBool Bool
  | LitBytes BS.ByteString
  deriving (Eq, Show)

instance HasGen Literal where
  getGen = choice
    [ LitString <$> (text (linear 0 50) (enum 'a' 'z'))
    , LitFloat <$> realFrac_ (linearFrac 0 999.00)
    , (LitNumber . fromIntegral) <$> int (linear 0 999)
    , LitBool <$> bool
    ]

instance ToSource Literal where
  toSource = \case
    LitBytes t -> "0x" <> (encodeHex t) <> ""
    LitString t -> "\"" <> t <> "\""
    LitNumber n -> (T.pack $ show n)
    LitFloat n  -> let o = T.pack $ show n in
      if T.isInfixOf "." o then o else o <> ".0"
    LitBool n   -> (T.toLower $ T.pack $ show n)

instance HasParser Literal where
  parser
    = strLiteralParser
    <|> floatLiteralParser
    <|> hexLiteralParser
    <|> intLiteralParser
    <|> boolLiteralParser

strLiteralParser :: Parser Literal
strLiteralParser = do
  void $ pChar '"'
  c <- many (pAny (\c -> c /= '"'))
  void $ pChar '"'
  pure $ LitString (pack c)

hexLiteralParser :: Parser Literal
hexLiteralParser = do
  void $ pText "0x"
  c <- many (pAny isHexDigit)
  case decodeHex $ T.pack c of
    Just b -> pure $ LitBytes b
    Nothing -> cantHandle

intLiteralParser :: Parser Literal
intLiteralParser = do
  c <- many (pAny isDigit)
  case c of
    ['0'] -> pure $ LitNumber 0
    ('0':_) -> cantHandle
    _ -> case readEither c of
      Right n -> pure $ LitNumber n
      Left _  -> cantHandle

floatLiteralParser :: Parser Literal
floatLiteralParser = do
  c <- many (pAny (\c -> isDigit c))
  _ <- pChar '.'
  m <- many (pAny isDigit)
  case readEither (c <> "." <> m) of
    Right a -> pure $ LitFloat a
    Left _  -> cantHandle

boolLiteralParser :: Parser Literal
boolLiteralParser =
  (do void $ pText "true"; pure $ LitBool True) <|>
  (do void $ pText "false"; pure $ LitBool False)