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.
  -}
  
  {-# LANGUAGE NamedFieldPuns #-}
  module TypecheckerTestLenient where
  
  import Data.Text ( Text )
  import qualified Data.Text as Text
  
  import Test.HUnit
  import TestRunner
  import qualified Data.Map.Strict as Map
  
  import Thrift.Compiler.Options
  import Thrift.Compiler.Parser
  import Thrift.Compiler.Plugin
  import Thrift.Compiler.Plugins.Linter
  import Thrift.Compiler.Pretty ( renderTypeError )
  import Thrift.Compiler.Types as T
  import Thrift.Compiler.Typechecker
  import Thrift.Compiler.Typechecker.Monad
  
  mkModuleMap :: Text -> ([Parsed Header], [Parsed Decl]) -> ModuleMap
  mkModuleMap name (headers, decls) =
    let path = Text.unpack name ++ ".thrift"
    in Map.singleton path ThriftFile
        { thriftName = name
        , thriftPath = path
        , thriftHeaders = headers
        , thriftDecls   = decls
        , thriftSplice = Nothing
        , thriftComments = []
        }
  
  lenientOptions :: LangOpts l -> Bool -> Options l
  lenientOptions opts optsLenient = (defaultOptions opts){ optsLenient }
  
  typecheckIncludes
    :: Typecheckable l
    => LangOpts l
    -> Bool
    -> [(Text, String)]
    -> Either String (Either [TypeError l] (Program l Loc, [Program l Loc]))
  typecheckIncludes opts lenient files =
      case parseIncludes files of
        Left err -> Left ("parse error: " ++ err)
        Right moduleMap -> Right $
          typecheck (lenientOptions opts lenient) moduleMap
    where
      parseInclude :: (Text, String) -> Either String ModuleMap
      parseInclude (name, input) =
        let path = Text.unpack name ++ ".thrift"
        in case runParser parseThrift path input of
            Left err -> Left ("parse error: " ++ path ++ " : " ++ err)
            Right hsds -> Right (mkModuleMap name hsds)
  
      parseIncludes :: [(Text, String)] -> Either String ModuleMap
      parseIncludes = fmap mconcat . traverse parseInclude
  
  typecheckIncludesTest :: String -> [(Text, String)] -> Test
  typecheckIncludesTest label files =
    TestLabel (label ++ " should pass") $ TestCase $
      case typecheckIncludes NoOpts True files of
        Right (Right _) -> return ()
        Right (Left errors) -> assertFailure $
          "should have typechecked: " <> show (map renderTypeError errors)
        Left err -> assertFailure err
  
  typecheckIncludesErrorTest :: String -> [(Text, String)] -> Test
  typecheckIncludesErrorTest label files =
    TestLabel (label ++ " should fail") $ TestCase $
      case typecheckIncludes NoOpts False files of
        Right (Left errors)
          | any isTypeError errors -> return ()
          | otherwise -> assertFailure $
              "wrong errors: " <> show (map renderTypeError errors)
        Right (Right _) -> assertFailure "should be a type error but typechecked"
        Left err -> assertFailure err
  
  parseAndTypecheck
    :: Typecheckable l
    => LangOpts l
    -> Bool
    -> String
    -> Either String (Either [TypeError l] (Program l Loc, [Program l Loc]))
  parseAndTypecheck opts lenient input =
    case runParser parseThrift "ttl.thrift" input of
      Left err -> Left ("parse error: " ++ err)
      Right hsds -> Right $
        typecheck (lenientOptions opts lenient) (mkModuleMap "ttl" hsds)
  
  typecheckTest :: String -> String -> Test
  typecheckTest label input = TestLabel (label ++ " should pass") $ TestCase $
    case parseAndTypecheck NoOpts True input of
      Right (Right _) -> return ()
      Right (Left errors) -> assertFailure $
        "should have typechecked: " <> show (map renderTypeError errors)
      Left err -> assertFailure err
  
  typeErrorTest :: String -> String -> Test
  typeErrorTest label input = TestLabel (label ++ " should fail") $ TestCase $
    case parseAndTypecheck NoOpts False input of
      Right (Left errors)
        | any isTypeError errors -> return ()
        | otherwise -> assertFailure $
            "wrong errors: " <> show (map renderTypeError errors)
      Right (Right _) -> assertFailure "should be a type error but typechecked"
      Left err -> assertFailure err
  
  isTypeError :: TypeError l -> Bool
  isTypeError TypeError{} = True
  isTypeError EmptyInput = False
  isTypeError CyclicModules{} = False
  
  --------------------------------------------------------------------------------
  
  emptySet1 :: String
  emptySet1 = unlines
    [ "struct Foo {"
    , "  2: set<i32> emptySet = {},"
    , "}"
    ]
  
  emptySet2 :: String
  emptySet2 = unlines [ "const set<i32> EmptySet = {}" ]
  
  enumToIntDefaults :: String
  enumToIntDefaults = unlines
    [ "enum Bar {"
    , "  A = 1,"
    , "  B = 2,"
    , "  C = 3,"
    , "}"
    , ""
    , "struct Foo {"
    , "  1: i32 enumToInt = A,"
    , "  2: list<i16> enumToIntList = [A, B, C],"
    , "  3: set<byte> enumToIntSet = [A, B, C],"
    , "  4: map<i64, bool> enumToIntMapKey = { A : true, B : false, C : true },"
    , "  5: map<string, i16> enumToMapValue = "
    , "    { \"7\" : A, \"8\" : B, \"9\": C },"
    , "}"
    ]
  
  enumToIntConst :: String
  enumToIntConst = unlines
    [ "enum Bar {"
    , "  A = 1,"
    , "  B = 2,"
    , "  C = 3,"
    , "}"
    , ""
    , "const i32 enumToInt = A"
    , "const list<i32> qualifiedEnumToIntList = [Bar.A, Bar.B, Bar.C]"
    , "const list<i16> enumToIntList = [A, B, C]"
    , "const set<byte> enumToIntSet = [A, B, C]"
    , "const map<i64, bool> enumToIntMapKey = { A : true, B : false, C : true }"
    , "const map<string, i16> enumToMapValue = "
    , "    { \"7\" : A, \"8\" : B, \"9\": C }"
    ]
  
  enumConstToIntConst :: String
  enumConstToIntConst = unlines
    [ "enum Bar {"
    , "  A = 1,"
    , "  B = 2,"
    , "  C = 3,"
    , "}"
    , ""
    , "const Bar iAmB = B"
    , "typedef i16 Foo"
    , "const Foo fooIs2 = iAmB"
    ]
  
  selfQualification :: String
  selfQualification = unlines
    [ "enum Bar {"
    , "  A = 1,"
    , "  B = 2,"
    , "  C = 3,"
    , "}"
    , ""
    , "const ttl.Bar iAmB = ttl.Bar.B"
    ]
  
  ignoreWrongEnumKeys :: String
  ignoreWrongEnumKeys = unlines
    [ "enum Bar {"
    , "  A = 1,"
    , "  B = 2,"
    , "  C = 3,"
    , "}"
    , "enum Wrong {"
    , "  WrongA = 1"
    , "  WrongB = 10"
    , "  WrongC = 100"
    , "}"
    , "const map<Bar, i16> barMap = {"
    , "  A : 1,"
    , "  B : 2,"
    , "  C : 3,"
    , "  WrongA : 11,"
    , "  WrongB : 12,"
    , "  WrongC : 13,"
    , "}"
    ]
  
  noAltUnion :: String
  noAltUnion = unlines
    [ "union Zero {"
    , "}"
    ]
  
  emptyListMap :: String
  emptyListMap = unlines
    [ "const list<i32> EmptyList = {}"
    , "const map<i32,i32> EmptyMap = []"
    ]
  
  selfQualType :: String
  selfQualType = unlines
    [ "struct Foo {"
    , "  1: string name,"
    , "}"
    , "service S {"
    , "  ttl.Foo fun("
    , "    1: ttl.Foo param1,"
    , "  )"
    , "}"
    ]
  
  lenientInputs :: [(String, String)]
  lenientInputs =
    [ ( "T43181705 empty set1", emptySet1 )
    , ( "T43181705 empty set2", emptySet2 )
    , ( "T43181363 enum to Int Defaults", enumToIntDefaults )
    , ( "T43181363 enum to Int Constants", enumToIntConst )
    , ( "T43181363 enum Const to Int Constant", enumConstToIntConst )
    , ( "T43181635 self qualification", selfQualification )
    , ( "T45688659 ignore wrong enum keys", ignoreWrongEnumKeys )
    , ( "T46325195 allow unions without alts", noAltUnion )
    , ( "T43181705 empty list/map", emptyListMap )
    , ( "T43181635 self qualified type", selfQualType )
    ]
  
  lenientTests :: Test
  lenientTests = TestList $
    map (uncurry typecheckTest) lenientInputs
    ++
    map (uncurry typeErrorTest) lenientInputs
  --------------------------------------------------------------------------------
  
  includeA :: (Text, String)
  includeA = ("file_a", "typedef i64 A")
  
  includeB :: (Text, String)
  includeB = ("file_b", "include \"file_a.thrift\"")
  
  transitiveC :: (Text, String)
  transitiveC = (,) "file_c" $ unlines
    [ "include \"file_b.thrift\""
    , "const file_a.A deep = 17"
    ]
  
  transitiveInputs :: (String, [(Text, String)])
  transitiveInputs =
    ("T43181464 transitive import", [ transitiveC, includeB, includeA ])
  
  lenientTransitiveInclude :: Test
  lenientTransitiveInclude = TestList
    [ uncurry typecheckIncludesTest transitiveInputs
    , uncurry typecheckIncludesErrorTest transitiveInputs
    ]
  
  --------------------------------------------------------------------------------
  
  main :: IO ()
  main = testRunner $ TestList [ lenientTests, lenientTransitiveInclude ]
  