TypecheckerTest.hs

{-
  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.
-}

module TypecheckerTest where

import Data.Int
import Data.Text (Text)
import Test.HUnit
import TestRunner
import qualified Data.Map.Strict as Map
import TextShow

import Thrift.Compiler.Options
import Thrift.Compiler.Parser
import Thrift.Compiler.Plugin
import Thrift.Compiler.Plugins.Haskell
import Thrift.Compiler.Plugins.Linter
import Thrift.Compiler.Types as T
import Thrift.Compiler.Typechecker
import Thrift.Compiler.Typechecker.Monad

mkThrift :: [Parsed Decl] -> ModuleMap
mkThrift decls =  Map.singleton "" ThriftFile
                  { thriftName = ""
                  , thriftPath = ""
                  , thriftHeaders = []
                  , thriftDecls = decls
                  , thriftSplice = Nothing
                  , thriftComments = []
                  }

mkModuleMap :: ([Parsed Header], [Parsed Decl]) -> ModuleMap
mkModuleMap (headers, decls) =
  Map.singleton "" ThriftFile
    { thriftName = ""
    , thriftPath = ""
    , thriftHeaders = headers
    , thriftDecls   = decls
    , thriftSplice = Nothing
    , thriftComments = []
    }

parseAndTypecheck
  :: Typecheckable l
  => LangOpts l
  -> String
  -> Either [TypeError l] (Program l Loc, [Program l Loc])
parseAndTypecheck opts input =
  case runParser parseThrift "" input of
    Left err -> error err
    Right tFile -> typecheck (defaultOptions opts) (mkModuleMap tFile)

-- Name Resolution Tests -------------------------------------------------------

resolutionTests :: Test
resolutionTests =
  TestList [ simpleTest, cycleTest, annotationTest, unknownTest ]

simpleTest :: Test
simpleTest = TestLabel "simple test" $ TestCase $ do
  let decls = [ mkTypedef "X" $ AnnotatedType I8 Nothing (Arity0Loc nlc)
              , mkTypedef "Y" $ mkNamedType "X"
              , mkStruct "Foo"
                [ mkField 1 "foo" $
                  AnnotatedType
                  (TMap (mkNamedType "Y") (mkNamedType "Bar"))
                  Nothing
                  (Arity2Loc nlc nlc nlc nlc)
                ]
              , D_Enum Enum
                { enumName = "Bar"
                , enumResolvedName = ()
                , enumConstants = []
                , enumFlavour = ()
                , enumLoc = StructLoc nlc nlc nlc nlc
                , enumAnns = Nothing
                , enumSAnns = []
                }
              ]
  let result = typecheck (defaultOptions NoOpts) (mkThrift decls)
  case fst <$> result of
    Right ( Program
            { progDecls =
              [ D_Typedef Typedef{ tdResolvedType = I8, tdResolvedName = "X" }
              , D_Typedef Typedef
                { tdResolvedType =
                    TTypedef Name {resolvedName=UName "X"} I8 _loc0
                , tdResolvedName = "Y"
                }
              , D_Struct Struct
                { structName = "Foo"
                , structMembers =
                  [ Field
                    { fieldId = 1
                    , fieldName = "foo"
                    , fieldResolvedType =
                      TMap
                      (TTypedef Name {resolvedName=UName "Y"}
                       (TTypedef Name {resolvedName=UName "X"} I8 _loc1)
                       _loc2)
                      (TEnum Name {resolvedName=UName "Bar"} _loc3 False)
                    }
                  ]
                }
              , D_Enum Enum{enumName="Bar"}
              ]
            }
          ) -> return ()
    Right _ -> assertFailure "not equal"
    Left _ -> assertFailure "type error"

annotationTest :: Test
annotationTest = TestLabel "int annotaion" $ TestCase $ do
  let decls = [ mkStruct "Foo"
                [ mkField 1 "foo"
                  (AnnotatedType I64
                   (Just Annotations
                    { annList =
                       [ValueAnn
                        { vaTag = "hs.type"
                        , vaVal = TextAnn "Int" DoubleQuote
                        , vaTagLoc = nlc, vaEqual = nlc, vaValLoc = nlc
                        , vaSep = NoSep
                        }
                       ]
                    , annOpenParen = nlc, annCloseParen = nlc
                    })
                   (Arity0Loc nlc))
                ]
              ]
  case fst <$> typecheck (defaultOptions defaultHsOpts) (mkThrift decls) of
    Right ( Program
            { progDecls =
              [ D_Struct Struct
                { structResolvedName = "Foo"
                , structMembers =
                  [ Field
                    { fieldId = 1
                    , fieldName = "foo"
                    , fieldResolvedType = TSpecial HsInt
                    }
                  ]
                }
              ]
            }
          ) -> return ()
    _ -> assertFailure "not equal"

cycleTest :: Test
cycleTest = TestLabel "cyclic types" $ TestCase $ do
  let decls = [ mkTypedef "X" $ mkNamedType "Y"
              , mkTypedef "Y" $ mkNamedType "Z"
              , mkTypedef "Z" $ mkNamedType "X"
              ]
  let result = typecheck (defaultOptions NoOpts) (mkThrift decls)
  case fst <$> result of
    Left [TypeError _ (CyclicTypes _)] -> return ()
    _ -> assertFailure "Should have been a type error"

mkNamedType :: Text -> AnnotatedType Loc ()
mkNamedType name = AnnotatedType (TNamed name) Nothing (Arity0Loc nlc)

mkTypedef :: Text -> AnnotatedType Loc t -> Parsed Decl
mkTypedef name ty = D_Typedef Typedef
  { tdName = name
  , tdTag  = IsTypedef
  , tdType = ty
  , tdResolvedName = ()
  , tdResolvedType = ()
  , tdLoc = TypedefLoc nlc nlc
  , tdAnns = Nothing
  , tdSAnns = []
  }

unknownTest :: Test
unknownTest = TestLabel "unknown type" $ TestCase $ do
  let
    decls = [ mkStruct "Foo"
              [ mkField 1 "foo" $ mkNamedType "X"
              ]
            ]
    result = typecheck (defaultOptions NoOpts) (mkThrift decls)
  case result of
    Left [TypeError _ (UnknownType _)] -> return ()
    _ -> assertFailure "Should have been a type error"

mkStruct :: Text -> [Parsed (Field 'StructField)] -> Parsed Decl
mkStruct name fields = D_Struct Struct
  { structName = name
  , structType = StructTy
  , structMembers = fields
  , structResolvedName = ()
  , structLoc = StructLoc nlc nlc nlc nlc
  , structAnns = Nothing
  , structSAnns = []
  , errorClassifications = []
  }

mkField
  :: Int32
  -> Text
  -> AnnotatedType Loc t
  -> Parsed (Field 'StructField)
mkField fid name ty = Field
  { fieldId = fid
  , fieldName = name
  , fieldResolvedName = ()
  , fieldRequiredness = Default
  , fieldType = ty
  , fieldResolvedType = ()
  , fieldVal = Nothing
  , fieldResolvedVal = ()
  , fieldLaziness = Lazy
  , fieldTag = STRUCT_FIELD
  , fieldLoc = FieldLoc nlc (showt fid) nlc nlc Nothing NoSep
  , fieldAnns = Nothing
  , fieldSAnns = []
  }

-- Constant Typechecking Tests -------------------------------------------------

simpleStruct :: String
simpleStruct = unlines
  [ "struct Foo {"
  , "  1: i32 x = 1,"
  , "  2: bool y = 0,"
  , "  3: string z = 'hello'"
  , "}"
  ]

complexTypes :: String
complexTypes = unlines
  [ "struct Foo {"
  , "  1: list<i32> x = [ 1, 2, 3],"
  , "  2: set<i32> y = [0],"
  , "  3: map<byte, i64> z = { 1 : 2, 2 : 3 }"
  , "}"
  ]

structConstant :: String
structConstant = unlines
  [ "struct Foo {"
  , "  1: Bar bar = { 'y' : 0, 'z' : '>>=' }"
  , "}"
  , ""
  , "struct Bar {"
  , "  1: optional i64 x,"
  , "  2: bool y,"
  , "  3: optional string z"
  , "}"
  ]

unionConsts :: String
unionConsts = unlines
  [ "# Lambda calculus in thrift"
  , ""
  , "union Exp {"
  , "  1: string EVar"
  , "  2: Lambda ELambda"
  , "  3: App EApp"
  , "}"
  , ""
  , "struct Lambda {"
  , "  1: string bind"
  , "  2: Exp body"
  , "} (hs.prefix = \"\")"
  , ""
  , "struct App {"
  , "  1: Exp e1"
  , "  2: Exp e2"
  , "} (hs.prefix = \"\")"
  , ""
  , "# identity function in thrift"
  , "const Exp identity = {"
  , "  \"ELambda\" : { \"bind\" : \"x\", \"body\" : { \"EVar\" : \"x\" } }"
  , "}"
  , ""
  , "# apply identity function to itelf"
  , "const Exp id_id = { \"EApp\" : { \"e1\" : identity, \"e2\" : identity } }"
  ]

typedefException :: String
typedefException = unlines
  [ "exception MyException { 1: string err }"
  , "typedef MyException MyTypedef"
  ]

typecheckTests :: Test
typecheckTests = TestList $ map (uncurry typecheckTest)
                 [ ( "simple struct", simpleStruct )
                 , ( "complex types", complexTypes )
                 , ( "struct consts", structConstant )
                 , ( "union consts", unionConsts )
                 , ( "typedef exception", typedefException )
                 ]

typecheckTest :: String -> String -> Test
typecheckTest label input = TestLabel label $ TestCase $
  case parseAndTypecheck NoOpts input of
    Right _ -> return ()
    Left _ -> assertFailure "should have typechecked"

simpleError :: String
simpleError = unlines
  [ "struct Foo {"
  , "  1: list<i32> foo = [ 1.5 ]"
  , "}"
  ]

i64IntError :: String
i64IntError = unlines
  [ "const i64 (hs.type = 'Int') intThing = 1"
  , "const i64 i64Thing = intThing"
  ]

newtypeError :: String
newtypeError = unlines
  [ "typedef i64 X (hs.newtype)"
  , "const i64 i = 0"
  , "const X x = i"
  ]

nestedNewtypeError :: String
nestedNewtypeError = unlines
  [ "typedef i64 X (hs.newtype)"
  , "const X x = 100"
  , "const list<i64> listThing = [x]"
  ]

vectorError :: String
vectorError = unlines
  [ "const list<i64> listThing = [1, 2, 3]"
  , "const list<i64> (hs.type = 'Vector') vectorThing = listThing"
  ]

zeroFieldError :: String
zeroFieldError = unlines
  [ "struct X {"
  , "  0: i64 x"
  , "}"
  ]

duplicateFieldError :: String
duplicateFieldError = unlines
  [ "struct X {"
  , "  1: i64 x"
  , "  1: i64 y"
  , "}"
  ]

throwsError :: String
throwsError = unlines
  [ "service X {"
  , "  void foo() throws (1: i64 x)"
  , "}"
  ]

emptyUnionError :: String
emptyUnionError = "union X {}"

duplicateEnumError :: String
duplicateEnumError = unlines
  [ "enum X {"
  , "  A = 1"
  , "  B = 1"
  , "}"
  ]

typeErrorTests :: Test
typeErrorTests = TestList $
  map (uncurry $ typeErrorTest NoOpts)
    [ ( "simple error", simpleError )
    , ( "FieldId = 0", zeroFieldError )
    , ( "duplicate FieldId", duplicateFieldError )
    , ( "throws error", throwsError )
    , ( "empty union", emptyUnionError )
    , ( "duplicate enum", duplicateEnumError )
    ] ++
  map (uncurry $ typeErrorTest defaultHsOpts)
    [ ( "i64 int error", i64IntError )
    , ( "Newtype Error", newtypeError )
    , ( "Nested Newtype Error", nestedNewtypeError )
    , ( "Vector Error", vectorError )
    ]

typeErrorTest :: Typecheckable l => LangOpts l -> String -> String -> Test
typeErrorTest opts label input = TestLabel label $ TestCase $
  case parseAndTypecheck opts input of
    Left errors | any isTypeError errors -> return ()
    _ -> assertFailure "should be a type mismatch"

isTypeError :: TypeError l -> Bool
isTypeError TypeError{} = True
isTypeError EmptyInput = False
isTypeError CyclicModules{} = False

-- Name Collision Tests --------------------------------------------------------

nameCollision :: String
nameCollision = unlines
  [ "struct X {"
  , "  1: i32 x"
  , "}"
  , "const i32 x_x = 100"
  ]

typeCollision :: String
typeCollision = unlines
  [ "struct X {"
  , "  1: i32 x"
  , "}"
  , "typedef i32 X"
  ]

enumHSNameCollision :: String
enumHSNameCollision = unlines
  [ "enum A { A = 0}"
  , "enum Y { A = 0} (hs.prefix = \"A_\")"
  ]

unionHSNameCollition :: String
unionHSNameCollition = unlines
  [ "union A {"
  , "  1: i64 Alt"
  , "}"
  , "union B {"
  , "  1: i64 t"
  , "} (hs.prefix = \"A_Al\")"
  ]

collisionTests :: Test
collisionTests = TestList $ map (uncurry collisionTest)
                 [ ( "name collision", nameCollision )
                 , ( "type collision", typeCollision )
                 , ( "enum haskell name collision", enumHSNameCollision)
                 , ( "union haskell name collision", unionHSNameCollition)
                 ]

collisionTest :: String -> String -> Test
collisionTest label input = TestLabel label $ TestCase $
  case parseAndTypecheck defaultHsOpts input of
    Left [TypeError _ DuplicateName{}] -> return ()
    _ -> assertFailure "should be a duplicate name error"

-- Multiple Errors -------------------------------------------------------------

multipleErrors :: String
multipleErrors = unlines
  [ "const i32 x = 'foo'"
  , "const i32 y = 'bar'"
  , "const i32 z = 'baz'"
  ]

multiErrorTest :: Test
multiErrorTest = TestLabel "multi error" $ TestCase $
  case parseAndTypecheck NoOpts multipleErrors of
    Left es -> assertEqual "3 errors" (length es) 3
    _ -> assertFailure "should have been a type error"

--------------------------------------------------------------------------------

main :: IO ()
main = testRunner $ TestList
  [ resolutionTests, typecheckTests, typeErrorTests
  , collisionTests, multiErrorTest ]