content: {-
    Copyright (c) Meta Platforms, Inc. and affiliates.
    All rights reserved.
  
    This source code is licensed under the BSD-style license found in the
    LICENSE file in the root directory of this source tree.
  -}
  
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  module LexerTest where
  
  import Control.Applicative
  import qualified Data.Text as Text
  import System.Exit
  import Test.QuickCheck
  import TextShow
  
  import Thrift.Compiler.Lexer
  import Thrift.Compiler.Types
  
  instance Arbitrary Token where
    arbitrary = (\tok -> Tok tok nlc) <$> arbitrary
  
  string :: Gen String
  string = listOf $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']
  
  symbol :: Gen String
  symbol = (:) <$> elements (['a'..'z'] ++ ['A'..'Z'])
               <*> listOf (elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'])
  
  instance Arbitrary TokenType where
      arbitrary = oneof [ pure L_CURLY_BRACE, pure R_CURLY_BRACE
                        , pure L_ANGLE_BRACE, pure R_ANGLE_BRACE
                        , pure L_SQUARE_BRACE, pure R_SQUARE_BRACE
                        , pure L_PAREN, pure R_PAREN
                        , pure COMMA, pure SEMICOLON, pure COLON, pure EQUALS
                        , pure INCLUDE, pure HS_INCLUDE
                        , pure STRUCT, pure ENUM, pure TYPEDEF, pure CONST
                        , pure REQUIRED, pure OPTIONAL
                        , pure MAP, pure LIST, pure SET
                        , pure INT8, pure INT16, pure INT32, pure INT64
                        , pure DOUBLE, pure FLOAT
                        , pure BOOL, pure STRING, pure VOID
                        , (\i -> INTEGRAL i $ showt i) <$> arbitrary
                        , (\f -> FLOATING f $ showt f) <$> arbitrary
                        , STRING_LIT <$> string <*> arbitrary
                        , SYMBOL <$> symbol
                        , pure TRUE, pure FALSE
                        ]
  
  instance Arbitrary QuoteType where
    arbitrary = elements [SingleQuote, DoubleQuote]
  
  ppT :: TokenType -> String
  ppT L_CURLY_BRACE = "{"
  ppT R_CURLY_BRACE = "}"
  ppT L_ANGLE_BRACE = "<"
  ppT R_ANGLE_BRACE = ">"
  ppT L_SQUARE_BRACE = "["
  ppT R_SQUARE_BRACE = "]"
  ppT L_PAREN = "("
  ppT R_PAREN = ")"
  ppT COMMA = ","
  ppT SEMICOLON = ";"
  ppT COLON = ":"
  ppT EQUALS = "="
  ppT AT = "@"
  ppT STRUCT = "struct"
  ppT ENUM = "enum"
  ppT TYPEDEF = "typedef"
  ppT CONST = "const"
  ppT REQUIRED = "required"
  ppT OPTIONAL = "optional"
  ppT MAP = "map"
  ppT LIST = "list"
  ppT SET = "set"
  ppT INT8 = "byte"
  ppT INT16 = "i16"
  ppT INT32 = "i32"
  ppT INT64 = "i64"
  ppT DOUBLE = "double"
  ppT FLOAT  = "float"
  ppT BOOL = "bool"
  ppT STRING = "string"
  ppT (INTEGRAL _ r) = Text.unpack r
  ppT (FLOATING _ r) = Text.unpack r
  ppT (STRING_LIT s qt) = q ++ s ++ q
    where q = case qt of { SingleQuote -> "'" ; DoubleQuote -> "\"" }
  ppT (SYMBOL s) = s
  ppT NAMESPACE = "namespace"
  ppT PACKAGE = "package"
  ppT INCLUDE = "include"
  ppT HS_INCLUDE = "hs_include"
  ppT HASH_MAP = "hash_map"
  ppT HASH_SET = "hash_set"
  ppT BINARY = "binary"
  ppT VOID = "void"
  ppT UNION = "union"
  ppT VIEW = "view"
  ppT EXCEPTION = "exception"
  ppT SERVICE = "service"
  ppT ONEWAY = "oneway"
  ppT EXTENDS = "extends"
  ppT THROWS = "throws"
  ppT ASYNC = "async"
  ppT CPP_INCLUDE = "cpp_include"
  ppT SAFE = "safe"
  ppT TRANSIENT = "transient"
  ppT STATEFUL = "stateful"
  ppT PERMANENT = "permanent"
  ppT SERVER = "server"
  ppT CLIENT = "client"
  ppT READONLY = "readonly"
  ppT IDEMPOTENT = "idempotent"
  ppT SENUM = "senum"
  ppT STREAM = "stream"
  ppT TRUE = "true"
  ppT FALSE = "false"
  ppT INTERACTION = "interaction"
  ppT PERFORMS = "performs"
  
  pp :: [Token] -> String
  pp tokens = unwords [ ppT tok | Tok tok _ <- tokens ]
  
  prop_roundTrip :: [Token] -> Bool
  prop_roundTrip =
    liftA2 (==) (Right . getTokens) (fmap getTokens . lexThrift . pp)
    where
      getTokens ts = [ t | Tok t _ <- ts ]
  
  main :: IO ()
  main = do
    result <- quickCheckResult prop_roundTrip
    case result of
      Success{} -> exitSuccess
      _         -> exitFailure
  