purescript-0.14.2: tests/TestCst.hs

module TestCst where

import Prelude

import Control.Monad (when, forM_)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.IO as Text
import Test.Hspec
import Test.QuickCheck
import TestUtils
import Text.Read (readMaybe)
import Language.PureScript.CST.Errors as CST
import Language.PureScript.CST.Lexer as CST
import Language.PureScript.CST.Print as CST
import Language.PureScript.CST.Types
import System.FilePath (takeBaseName, replaceExtension)

spec :: Spec
spec = do
  layoutSpec
  literalsSpec

layoutSpec :: Spec
layoutSpec = do
  pursFiles <- runIO $ concat <$> getTestFiles "layout"
  describe "Layout golden tests" $ do
    forM_ pursFiles $ \file ->
      it (takeBaseName file) $
        goldenVsString
          (replaceExtension file ".out")
          (Text.encodeUtf8 <$> runLexer file)
  where
  runLexer file = do
    src <- Text.readFile file
    case sequence $ CST.lex src of
      Left (_, err) ->
        pure $ Text.pack $ CST.prettyPrintError err
      Right toks -> do
        pure $ CST.printTokens toks

literalsSpec :: Spec
literalsSpec = describe "Literals" $ do
  testProperty "Integer" $
    checkTok checkReadNum (\case TokInt _ a -> Just a; _ -> Nothing) . unInt
  testProperty "Hex" $
    checkTok checkReadNum (\case TokInt _ a -> Just a; _ -> Nothing) . unHex
  testProperty "Number" $
    checkTok checkReadNum (\case TokNumber _ a -> Just a; _ -> Nothing) . unFloat
  testProperty "Exponent" $
    checkTok checkReadNum (\case TokNumber _ a -> Just a; _ -> Nothing) . unExponent

  testProperty "Integer (round trip)" $ roundTripTok . unInt
  testProperty "Hex (round trip)" $ roundTripTok . unHex
  testProperty "Number (round trip)" $ roundTripTok . unFloat
  testProperty "Exponent (round trip)" $ roundTripTok . unExponent
  testProperty "Char (round trip)" $ roundTripTok . unChar
  testProperty "String (round trip)" $ roundTripTok . unString
  testProperty "Raw String (round trip)" $ roundTripTok . unRawString

  where
  testProperty name test = specify name (property test)

readTok' :: String -> Text -> Gen SourceToken
readTok' failMsg t = case CST.lex t of
  Right tok : _ ->
    pure tok
  Left (_, err) : _ ->
    error $ failMsg <> ": " <> CST.prettyPrintError err
  [] ->
    error "Empty token stream"

readTok :: Text -> Gen SourceToken
readTok = readTok' "Failed to parse"

checkTok
  :: (Text -> a -> Gen Bool)
  -> (Token -> Maybe a)
  -> Text
  -> Gen Bool
checkTok p f t = do
  SourceToken _ tok <- readTok t
  case f tok of
    Just a  -> p t a
    Nothing -> error $ "Failed to lex correctly: " <> show tok

roundTripTok :: Text -> Gen Bool
roundTripTok t = do
  tok <- readTok t
  let t' = CST.printTokens [tok]
  tok' <- readTok' "Failed to re-parse" t'
  pure $ tok == tok'

checkReadNum :: (Eq a, Read a) => Text -> a -> Gen Bool
checkReadNum t a = do
  let
    chs = case Text.unpack $ Text.replace ".e" ".0e" $ Text.replace "_" "" t of
      chs' | last chs' == '.' -> chs' <> "0"
      chs' -> chs'
  case (== a) <$> readMaybe chs of
    Just a' -> pure a'
    Nothing -> error "Failed to `read`"

newtype PSSourceInt = PSSourceInt { unInt :: Text }
  deriving (Show, Eq)

instance Arbitrary PSSourceInt where
  arbitrary = resize 16 genInt

newtype PSSourceFloat = PSSourceFloat { unFloat :: Text }
  deriving (Show, Eq)

instance Arbitrary PSSourceFloat where
  arbitrary = resize 16 genFloat

newtype PSSourceExponent = PSSourceExponent { unExponent :: Text }
  deriving (Show, Eq)

instance Arbitrary PSSourceExponent where
  arbitrary = PSSourceExponent <$> do
    floatPart <- unFloat <$> resize 5 genFloat
    signPart <- fromMaybe "" <$> elements [ Just "+", Just "-", Nothing ]
    expPart <- unInt <$> resize 1 genInt
    pure $ floatPart <> "e" <> signPart <> expPart

newtype PSSourceHex = PSSourceHex { unHex :: Text }
  deriving (Show, Eq)

instance Arbitrary PSSourceHex where
  arbitrary = resize 16 genHex

newtype PSSourceChar = PSSourceChar { unChar :: Text }
  deriving (Show, Eq)

instance Arbitrary PSSourceChar where
  arbitrary = genChar

newtype PSSourceString = PSSourceString { unString :: Text }
  deriving (Show, Eq)

instance Arbitrary PSSourceString where
  arbitrary = resize 256 genString

newtype PSSourceRawString = PSSourceRawString { unRawString :: Text }
  deriving (Show, Eq)

instance Arbitrary PSSourceRawString where
  arbitrary = resize 256 genRawString

genInt :: Gen PSSourceInt
genInt = PSSourceInt . Text.pack <$> do
  (:) <$> nonZeroChar
      <*> listOf numChar

genFloat :: Gen PSSourceFloat
genFloat = PSSourceFloat <$> do
  intPart <- unInt <$> genInt
  floatPart <- Text.pack <$> listOf1 numChar
  pure $ intPart <> "." <> floatPart

genHex :: Gen PSSourceHex
genHex = PSSourceHex <$> do
  nums <- listOf1 hexDigit
  pure $ "0x" <> Text.pack nums

genChar :: Gen PSSourceChar
genChar = PSSourceChar <$> do
  ch <- resize 0xFFFF arbitrarySizedNatural >>= (genStringChar '\'' . toEnum)
  pure $ "'" <> ch <> "'"

genString :: Gen PSSourceString
genString = PSSourceString <$> do
  chs <- listOf $ arbitraryUnicodeChar >>= genStringChar '"'
  pure $ "\"" <> Text.concat chs <> "\""

genStringChar :: Char -> Char -> Gen Text
genStringChar delimiter ch = frequency
  [ (1, genCharEscape)
  , (10, if ch `elem` [delimiter, '\n', '\r', '\\']
           then discard
           else pure $ Text.singleton ch
    )
  ]

genRawString :: Gen PSSourceRawString
genRawString = PSSourceRawString <$> do
  chs <- listOf arbitraryUnicodeChar
  let
    k1 acc qs cs = do
      let (cs', q) = span (/= '"') cs
      k2 (acc <> cs') qs q
    k2 acc qs [] = acc <> qs
    k2 acc qs cs = do
      let (q, cs') = span (== '"') cs
      k1 (acc <> take 2 q) (qs <> drop 2 q) cs'
    chs' = k1 [] [] chs
  when (all (== '"') chs') discard
  pure $ "\"\"\"" <> Text.pack chs' <> "\"\"\""

genCharEscape :: Gen Text
genCharEscape = oneof
  [ pure "\\t"
  , pure "\\r"
  , pure "\\n"
  , pure "\\\""
  , pure "\\'"
  , pure "\\\\"
  , do
      chs <- resize 4 $ listOf1 hexDigit
      pure $ "\\x" <> Text.pack chs
  ]

numChar :: Gen Char
numChar = elements "0123456789_"

nonZeroChar :: Gen Char
nonZeroChar = elements "123456789"

hexDigit :: Gen Char
hexDigit = elements $ ['a'..'f'] <> ['A'..'F'] <> ['0'..'9']