Literals.hs

module Compiler.Lexer.Literals where

import Control.Applicative
import GHC.Generics
import Control.DeepSeq
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, Generic)

instance NFData Literal

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 -> "\"" <> (escapeQuotes 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

escapeQuotes :: Text -> Text
escapeQuotes = T.replace "\n" "\\n" . T.replace "\"" "\\\""

strLiteralParser :: Parser Literal
strLiteralParser = do
  void $ pChar '"'
  c <- many parseEscapedChar
  void $ pChar '"'
  pure $ LitString (pack c)
  where
    parseEscapedChar :: Parser Char
    parseEscapedChar = ParserM "Escaped Char" (\s ->
      case T.uncons (twText s) of
        Just ('\\', rst) ->  case T.uncons rst of
          Just ('n', rst') -> pure (Right '\n', TextWithOffset rst' (moveCols (twLocation s) 2))
          Just (h, rst') -> pure (Right h, TextWithOffset rst' (moveCols (twLocation s) 2))
          _ -> pure (Left CantHandle, s)
        Just ('"', _) -> pure (Left CantHandle, s)
        Just (c, rst') -> pure (Right c, TextWithOffset rst' (moveCols (twLocation s) 1))
        _ -> pure (Left CantHandle, s)
      )

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)