added a bunch of tests

added a bunch of tests

module Test.TypeChecker where

import AST
import TypeChecker as TC
import TypeChecker (Scheme(..), TVarMappings, boolType, charType, intType,
  intToIntType, intToIntToIntType)
import Parser (parseExpr, parseDefs)
import Test.Parser (parsedPrelude)

import Prelude (Unit, bind, map, pure, show, unit, ($), (==), (<>), (>>=), (<$>))
-- import Control.Monad.Writer (Writer, tell)
import Data.Array as Array
import Data.Either (Either(..))
import Data.List (List(..), (:))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..), fst)
import Data.Foldable (intercalate)
import Text.Parsing.Parser (ParseError, parseErrorMessage)

import Control.Semigroupoid ((>>>), (<<<))

import Test.Utils (Test, tell)

toList :: forall a. Array a -> List a
toList = Array.toUnfoldable

tell' :: String -> Test Unit
tell' = tell

-- | Construct a list of type [typCon] given the name of the type constants.
typConList :: String -> Type
typConList name = TList (TypCon name)

-- | Construct a tuple type given a list of type constant names.
typConNTuple:: List String -> Type
typConNTuple names = TTuple (map TypCon names)

-- | Construct a tuple type given a list of type variable names.
typVarTuple :: List TVar -> Type
typVarTuple tvs = TTuple (map TypVar tvs)

-- | Construct a list of type [a] given the type variable name a.
typVarList :: TVar -> Type
typVarList tv = TList (TypVar tv)

-- | Generate an arrow type from two given type variable names.
typVarArrow :: TVar -> TVar -> Type
typVarArrow tv1 tv2 = TypVar tv1 `TypArr` TypVar tv2

-- | The type (Char, Int, Int)
charIntTupleType :: Type
charIntTupleType = typConNTuple ("Char" : "Int" : "Int" : Nil)

-- | The type (Int, Int)
intTupleType :: Type
intTupleType = typConNTuple ("Int" : "Int" : Nil)

-- | The type [Int]
intList :: Type
intList = TList $ TypCon "Int"

-- | Report a parse error.
reportParseError :: String -> ParseError -> Test Unit
reportParseError testName parseError = tell' $ "Parse error for test case "
  <> testName <> ": "
  <> parseErrorMessage parseError
  <> "\nNote that this is not a failing test but rather an error in the test definition."

-- | Report a type error.
reportTypeError :: String -> TypeError -> Test Unit
reportTypeError testName typeError = tell' $ "Type inference failed in test case `"
  <> testName <> "`:\n"
  <> "Encountered type error: "
  <> prettyPrintTypeError typeError

reportTypeErrorWithNote :: String -> TypeError -> String -> Test Unit
reportTypeErrorWithNote testName typeError note =
  tell' $ "Type inference failed in test case `"
    <> testName <> "`:\n"
    <> "Encountered Type error: "
    <> prettyPrintTypeError typeError
    <> "Additional Note: \n"
    <> note

-- | Compare the given two types and report an error if they are not equal.
compareTypes :: String -> Type -> Type -> Test Unit
compareTypes testName expected actual = if expected == actual
  then pure unit
  else tell' $ "Type inference failed in test case `" <> testName <> "`:\n" <>
               "Expected type: " <> prettyPrintType expected <> "\n" <>
               "Actual type: " <> prettyPrintType actual

compareTypesWithNote :: String -> Type -> Type -> String -> Test Unit
compareTypesWithNote testName expected actual note = if expected == actual
  then pure unit
  else tell' $ "Type inference failed in test case `" <> testName <> "`:\n" <>
               "Expected type: " <> prettyPrintType expected <> "\n" <>
               "Actual type: " <> prettyPrintType actual <> "\n" <>
               "Additional note: \n" <> note

-- | Compare the given type errors and report an error if they are not equal.
compareTypeError :: String -> TypeError -> TypeError -> Test Unit
compareTypeError testName expected actual = if expected == actual
  then pure unit
  else tell' $ "Type inference failed in test case `" <> testName <> "`:\n" <>
               "Expected type error: " <> prettyPrintTypeError expected <> "\n" <>
               "Actual type error: " <> prettyPrintTypeError actual <> "\n"

-- | Try to infer the type of a given expression and compare the result with the expected type.
testInferExpr :: String -> String -> Type -> Test Unit
testInferExpr name expressionString expected = case parseExpr expressionString of
  Left parseError -> reportParseError name parseError
  Right expression -> case TC.runInfer true (TC.inferExprToType expression) of
    Left typeError -> reportTypeError name typeError
    Right t -> compareTypes name expected t

-- | Try to infer the type of a given expression and expect a type error to occur.
testInferExprFail :: String -> String -> TypeError -> Test Unit
testInferExprFail name expressionString expected = case parseExpr expressionString of
  Left parseError -> reportParseError name parseError
  Right expression -> case TC.runInfer true (TC.inferExprToType expression) of
    Right t -> tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                       "Expected type error: " <> prettyPrintTypeError expected <> "\n" <>
                       "Found type: " <> prettyPrintType t <> "\n"
    Left typeError -> compareTypeError name expected typeError

testInferDef :: String -> String -> Type -> Test Unit
testInferDef name definitionString expected = case parseDefs definitionString of
  Left parseError -> reportParseError name parseError
  Right (def:_) -> case TC.runInfer true (inferAndConvertToType def) of
    Left typeError -> reportTypeError name typeError
    Right t -> compareTypes name expected t
  _ -> tell' $ "Expected to parse definition in test case `" <> name <> "`\n" <>
               "\nNote that this is not a failing test but rather an error in the test definition."
  where
  inferAndConvertToType def = TC.schemeOfDefinition def >>= TC.schemeToType

testInferDefFail :: String -> String -> TypeError -> Test Unit
testInferDefFail name definitionString expected = case parseDefs definitionString of
  Left parseError -> reportParseError name parseError
  Right (def:_) -> case TC.runInfer true (inferAndConvertToType def) of
    Left typeError -> if typeError == expected
      then pure unit
      else tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                   "Expected type error: " <> prettyPrintTypeError typeError <> "\n" <>
                   "Actual type error: " <> prettyPrintTypeError expected <> "\n"
    Right t -> tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                       "Expected type error: " <> prettyPrintTypeError expected <> "\n" <>
                       "Found type: " <> prettyPrintType t <> "\n"
  _ -> tell' $ "Expected to parse definition in test case `" <> name <> "`\n" <>
               "\nNote that this is not a failing test but rather an error in the test definition."
  where
  inferAndConvertToType def = TC.schemeOfDefinition def >>= TC.schemeToType

testInferDefGroup :: String -> String -> Type -> Test Unit
testInferDefGroup name definitionString expected = case parseDefs definitionString of
  Left parseError -> reportParseError name parseError
  Right definitions -> case TC.runInfer true (inferAndConvertToType definitions) of
    Left typeError -> reportTypeError name typeError
    Right t -> compareTypes name expected t
  where
  inferAndConvertToType defs = TC.schemeOfDefinitionGroup defs >>= TC.schemeToType

-- | Infer the type of the given expression in the context of the prelude.
testInferExprWithPrelude :: String -> String -> Type -> Test Unit
testInferExprWithPrelude name expressionString expected = case parseExpr expressionString of
  Left parseError -> reportParseError name parseError
  Right expression -> case TC.tryInferTypeInContext parsedPrelude expression of
    Left typeError -> reportTypeError name typeError
    Right t -> compareTypes name expected t

-- | Infer the type of the given expression in the context of a custom prelude.
testInferExprWithCustomPrelude :: String -> String -> String -> Type -> Test Unit
testInferExprWithCustomPrelude name prelude expressionString expected =
  case parseDefs prelude of
    Left parseError -> reportParseError name parseError
    Right parsedPrelude ->
      case parseExpr expressionString of
        Left parseError -> reportParseError name parseError
        Right expression -> case TC.tryInferTypeInContext parsedPrelude expression of
          Left typeError -> do
            reportTypeError name typeError
          Right t -> compareTypesWithNote name expected t
            (case TC.ppTypeEnv <$> TC.tryInferEnvironment parsedPrelude of
              Left msg -> show msg
              Right msg -> msg)

-- | Test type inference on expression trees, given an expression string as well as the expected
-- | resulting typed tree.
testInferTT' :: String -> String -> TypeTree -> Test Unit
testInferTT' name unparsedTree expectedTypeTree = case parseExpr unparsedTree of
  Left parseError -> reportParseError name parseError
  Right expression -> testInferTT name expression expectedTypeTree

testInferTTWithCustomPrelude' :: String -> String -> String -> TypeTree -> Test Unit
testInferTTWithCustomPrelude' name prelude unparsedTree expectedTypeTree =
  case parseDefs prelude of
    Left parseError -> reportParseError name parseError
    Right parsedPrelude -> case parseExpr unparsedTree of
      Left parseError -> reportParseError name parseError
      Right expression -> testInferTTWithCustomPrelude name parsedPrelude expression expectedTypeTree

-- | Test type inference on expression trees. Here not only the expected type of the whole
-- | expression is checked, but also the type of every subexpression.
testInferTT :: String -> TypeTree -> TypeTree -> Test Unit
testInferTT name untypedTree expectedTypedTree =
  case TC.tryInferExprInContext parsedPrelude untypedTree of
    Left typeError -> reportTypeError name typeError
    Right typedTree -> if expectedTypedTree == typedTree
      then pure unit
      else tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                   "Expected type tree: " <> show expectedTypedTree <> "\n" <>
                   "Actual type tree: " <> show typedTree <> "\n"

testInferTTWithCustomPrelude :: String -> List Definition -> TypeTree -> TypeTree -> Test Unit
testInferTTWithCustomPrelude name parsedPrelude untypedTree expectedTypedTree =
  case TC.tryInferExprInContext parsedPrelude untypedTree of
    Left typeError -> reportTypeError name typeError
    Right typedTree -> if expectedTypedTree == typedTree
      then pure unit
      else tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                   "Expected type tree: " <> show expectedTypedTree <> "\n" <>
                   "Actual type tree: " <> show typedTree <> "\n"

testInferTTFail :: String -> TypeTree -> TypeError -> Test Unit
testInferTTFail name expr expectedError =
  case TC.tryInferExprInContext parsedPrelude expr of
    Left typeError -> compareTypeError name expectedError typeError
    Right typedExpr ->
      tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
              "Expected type error: " <> prettyPrintTypeError expectedError <> "\n" <>
              "Found type tree: " <> show typedExpr <> "\n"

-- | Test type tree normalization.
testNormalizeTT :: String -> TypeTree -> TypeTree -> Test Unit
testNormalizeTT name tt normalizedTT = if (TC.normalizeTypeTree tt) == normalizedTT
  then pure unit
  else tell' $ "Type tree normalization failed in test case `" <> name <> "`:\n" <>
               "Expected type tree: " <> show normalizedTT <> "\n" <>
               "Actual type tree: " <> show tt <> "\n"

-- | Test the function `mapSchemeOnTVarMappings`.
testMapSchemeOnTVarMappings :: String -> Scheme -> IndexedTypedBinding
                            -> TVarMappings -> Test Unit
testMapSchemeOnTVarMappings name scheme binding expected =
  case TC.runInfer true (fst <$> TC.mapSchemeOnTVarMappings binding scheme) of
    Left typeError -> reportTypeError name typeError
    Right result -> if result == expected
      then pure unit
      else tell' $
        "The function `mapSchemeOnTVarMappings` failed in test case `" <> name <> "`:\n" <>
        "Expected type variable mapping: " <> TC.ppTVarMappings expected <> "\n" <>
        "Actual type variable mapping: " <> TC.ppTVarMappings result <> "\n"

-- | Test the function `mapSchemeOnTVarMappings`.
testMapSchemeOnTVarMappings' :: String -> String -> Scheme -> IndexedTypedBinding
                            -> TVarMappings -> Test Unit
testMapSchemeOnTVarMappings' name prelude scheme binding expected =
  case parseDefs prelude of
    Left parseError -> reportParseError name parseError
    Right parsedPrelude -> case TC.tryInferEnvironment parsedPrelude of
      Left typeError -> reportTypeError name typeError
      Right env -> case TC.runInferWith env true (fst <$> TC.mapSchemeOnTVarMappings binding scheme) of
        Left typeError -> reportTypeError name typeError
        Right result -> if result == expected
          then pure unit
          else tell' $
            "The function `mapSchemeOnTVarMappings` failed in test case `" <> name <> "`:\n" <>
            "Scheme: " <> TC.ppScheme scheme <> "\n" <>
            "Binding: " <> prettyPrintBinding binding <> "\n" <>
            "Expected type variable mapping: " <> TC.ppTVarMappings expected <> "\n" <>
            "Actual type variable mapping: " <> TC.ppTVarMappings result <> "\n" <>
            "Environment:\n" <> TC.ppTypeEnv env <> "\n"

-- | Typed type tree representing `[1]`.
listOne :: TypeTree
listOne = List (Just $ typConList "Int") (Atom (Just $ TypCon "Int") (AInt 1) : Nil)

-- | Untyped type tree representing `[1]`.
untypedListOne :: TypeTree
untypedListOne = List Nothing (Atom Nothing (AInt 1) : Nil)

partiallyTypedExprTests :: Test Unit
partiallyTypedExprTests = do
  -- Test that ((2 :: Int) + 4) is typed correctly.
  testInferTT "Partially typed"
    (Binary
      Nothing
      (Tuple Add Nothing)
      (Atom (Just intType) (AInt 2))
      (Atom Nothing (AInt 4))
    )
    (Binary
      (Just (TypCon "Int"))
      (Tuple Add (Just (TypCon "Int" `TypArr` (TypCon "Int" `TypArr` TypCon "Int"))))
      (Atom (Just intType) (AInt 2))
      (Atom (Just intType) (AInt 4))
    )

  -- Test that ((2 :: Char) + 4) results in a type error.
  testInferTTFail "Partially typed"
    (Binary
      Nothing
      (Tuple Add Nothing)
      (Atom (Just charType) (AInt 2))
      (Atom Nothing (AInt 4))
    )
    (UnificationFail intType charType)

  -- Test that `let (f :: Int -> Int) = \x -> x in f True` results in a type error.
  testInferTTFail "Partially typed let expression 1"
    (LetExpr
      Nothing
      (
        Tuple (Lit (Just intToIntType) (Name "f"))
          (Lambda Nothing
            ((Lit Nothing (Name "x")) : Nil)
            (Atom Nothing (Name "x"))) :
        Nil
      )
      (App
        Nothing
        (Atom Nothing (Name "f"))
        ((Atom Nothing (Bool true)) : Nil)
      )
    )
    (UnificationFail intType boolType)

  -- Test that `let f = ((\x -> x) :: Int -> Int) in f True` results in a type error.
  testInferTTFail "Partially typed let expression 2"
    (LetExpr
      Nothing
      (
        Tuple (Lit Nothing (Name "f"))
          (Lambda (Just intToIntType)
            ((Lit Nothing (Name "x")) : Nil)
            (Atom Nothing (Name "x"))) :
        Nil
      )
      (App
        Nothing
        (Atom Nothing (Name "f"))
        ((Atom Nothing (Bool true)) : Nil)
      )
    )
    (UnificationFail intType boolType)

  -- Test that `(\(a :: Bool) b -> a)) 'x'` results in a type error.
  testInferTTFail "Partially typed lambda expression 1"
    (App
      Nothing
      (Lambda
        Nothing
        ((Lit (Just boolType) (Name "a")) : (Lit Nothing (Name "b")) : Nil)
        (Atom Nothing (Name "a"))
      )
      ((Atom Nothing (Char "x")) : Nil)
    )
    (UnificationFail boolType charType)

  -- Test that `(\(x:(y :: Char):ys) -> mod x y)` results in a type error.
  testInferTTFail "Partially typed lambda expression 1"
    (Lambda
      Nothing
        (
          (ConsLit
            Nothing
            (Lit Nothing (Name "x"))
            (ConsLit
              Nothing
              (Lit (Just charType) (Name "y"))
              (Lit Nothing (Name "ys"))
            ) : Nil
          )
        )
        (App
          Nothing
          (Atom Nothing (Name "mod"))
          (Atom Nothing (Name "x") : Atom Nothing (Name "y") : Nil)
        )
    )
    (UnificationFail intType charType)

runTests :: Test Unit
runTests = do
  -- +--------------------------------------------------+
  -- | Test the inferred types of arbitrary expressions |
  -- +--------------------------------------------------+

  -- (3^) :: Int -> Int
  testInferExpr "SectL" "(3^)" intToIntType
  -- (^3) :: Int -> Int
  testInferExpr "SectR" "(^3)" intToIntType
  -- (\a b c d -> a b c d) :: (a -> b -> c -> d) -> a -> b -> c -> d
  testInferExpr "Lambda1" "\\a b c d -> a b c d"
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` (TypVar "c" `TypArr` TypVar "d"))) `TypArr`
      (TypVar "a" `TypArr` (TypVar "b" `TypArr` (TypVar "c" `TypArr` (TypVar "d")))))
  testInferExpr "Lambda2" "\\a b -> a b"
    (TypArr (TypArr (TypVar "a") (TypVar "b")) (TypArr (TypVar "a") (TypVar "b")))
  testInferExpr "List1" "[1, 2, 3, 4, 5]" intList
  testInferExpr "List2" "[1 + 2, 3 + 4]" intList
  testInferExpr "Empty list" "[]" (typVarList "a")
  testInferExpr "Append" "[1 + 2, 3 + 4] ++ []" intList
  testInferExpr "NTuple" "(1 + 2, 3)" (typConNTuple ("Int" : "Int" : Nil))
  testInferExpr "SectR colon" "(:[3])" (TypCon "Int" `TypArr` intList)
  testInferExpr "Lambda wildcard" "\\_ _ -> 5" (TypVar "a" `TypArr` (TypVar "b" `TypArr` intType))
  testInferExpr "Lambda cons binding" "\\(x:xs) -> x" (typVarList "a" `TypArr` TypVar "a")
  testInferExpr "Let expression" "let x = 3 in \\_ _ -> x"
    (TypVar "a" `TypArr` (TypVar "b" `TypArr` intType))
  testInferExpr "Binding tuple in let expression" "let (a, b) = (\\f -> f, \"Hello\") in a b"
    (typConList "Char")
  testInferExpr "Lambda application" "(\\f a b -> f a b) (+) 3 4" intType
  -- ((\xs -> [ x | x <- xs ]) [1]) :: [Int]
  testInferExpr "List comprehension inside lambda" "(\\xs -> [ x | x <- xs ]) [1]" intList

  -- Check that let polymorphism works: `let f = \x -> x in (f True, f 42)` :: (Bool, Int).
  testInferExpr "Let polymorphism" "let f = \\x -> x in (f True, f 42)"
    (TTuple (boolType : intType : Nil))

  testInferExprFail "List unification fail" "[(+), 4]" (UnificationFail intToIntToIntType intType)
  testInferExprFail "Cons unification fail"
    "let str = \"Hallo\" in 3 : [1 + 2, 3 + 4, str]"
    (UnificationFail intType (TList charType))

  -- +-----------------------------------------------+
  -- | Test the inferred types of single definitions |
  -- +-----------------------------------------------+

  testInferDef "Define app" "app f xs = app f xs"
    (TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "c"))
  testInferDef "Define single map" "map f (x:xs) = f x : map f xs"
    ((TypVar "a" `TypArr` TypVar "b") `TypArr` (typVarList "a" `TypArr` typVarList "b"))
  testInferDef "Define foldr" "foldr f ini (x:xs) = f x (foldr f ini xs)"
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "b")) `TypArr`
      (TypVar "c" `TypArr` (typVarList "a" `TypArr` TypVar "b")))
  testInferDef "Conslit binding 1" "list (x:xs:xss) = x" (typVarList "a" `TypArr` TypVar "a")
  testInferDef "Conslit binding 2" "list (x:xs:xss) = xs" (typVarList "a" `TypArr` TypVar "a")
  testInferDef "Conslit binding 3" "list (x:xs:xss) = xss" (typVarList "a" `TypArr` typVarList "a")
  testInferDef "Binding tuple 1" "fst (a, b) = a"
    (typVarTuple ("a" : "b" : Nil) `TypArr` TypVar "a")
  testInferDef "Binding tuple 2" "snd (a, b) = b"
    (typVarTuple ("a" : "b" : Nil) `TypArr` TypVar "b")
  testInferDef "Binding tuple 3" "f (a, b, c) = a b c"
    ((TTuple
      (TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "c") : TypVar "a" : TypVar "b" : Nil))
        `TypArr` TypVar "c")

  testInferDefFail "Listlit binding" "list [a, b, c] = a b c"
    (InfiniteType "a" (TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "c")))

  -- +----------------------------------------------+
  -- | Test the inferred types of definition groups |
  -- +----------------------------------------------+

  let zipWithDef = "zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\n" <>
                   "zipWith _ [] _ = []\n" <>
                   "zipWith _ _ [] = []"
  testInferDefGroup "zipWith" zipWithDef
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "c")) `TypArr`
      (typVarList "a" `TypArr` (typVarList "b" `TypArr` typVarList "c")))

  let foldrDef = "foldr f ini [] = ini\n" <>
                 "foldr f ini (x:xs) = f x (foldr f ini xs)"
  testInferDefGroup "foldr" foldrDef
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "b"))
      `TypArr` (TypVar "b" `TypArr` (typVarList "a" `TypArr` TypVar "b")))

  let scanlDef = "scanl f b []     = [b]\n" <>
                 "scanl f b (x:xs) = b : scanl f (f b x) xs"
  testInferDefGroup "scanl" scanlDef
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "a"))
      `TypArr` (TypVar "a" `TypArr` (typVarList "b" `TypArr` typVarList "a")))

  -- +-------------------------------------------------------------------+
  -- | Test the inferred types of expressions in the prelude environment |
  -- +-------------------------------------------------------------------+

  testInferExprWithPrelude "Prelude with exp" "sum (map (^2) [1, 2, 3, 4])" intType

  -- +----------------------------------------+
  -- | Test the type inference on whole trees |
  -- +----------------------------------------+

  -- Check that \f x -> f x and all the subexpressions are typed correctly.
  testInferTT "Apply function"
    (Lambda Nothing
      ((Lit Nothing (Name "f")) : (Lit Nothing (Name "x")) : Nil)
      (App
        Nothing
        (Atom Nothing (Name "f"))
        ((Atom Nothing (Name "x")) : Nil)))
    (Lambda
      (Just (typVarArrow "a" "b" `TypArr` typVarArrow "a" "b"))
      (
        (Lit (Just (typVarArrow "a" "b")) (Name "f")) :
        (Lit (Just (TypVar  "a")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "b"))
        (Atom (Just (typVarArrow "a" "b")) (Name "f"))
        ((Atom (Just (TypVar  "a")) (Name "x")) : Nil)))

  -- Check that [1, 1 + 1, length [1]] and all the subexpressions are typed correctly.
  testInferTT "List"
    (List
      Nothing
      (
        (Atom Nothing (AInt 1)) :
        (Binary
          Nothing
          (Tuple Add Nothing)
          (Atom Nothing (AInt 1))
          (Atom Nothing (AInt 1))) :
        (App
          Nothing
          (Atom
            Nothing
            (Name "length"))
          (untypedListOne : Nil)) :
        Nil
      )
    )
    (List
      (Just (typConList "Int"))
      (
        (Atom (Just (TypCon "Int")) (AInt 1)) :
        (Binary
          (Just (TypCon "Int"))
          (Tuple Add (Just (TypCon "Int" `TypArr` (TypCon "Int" `TypArr` TypCon "Int"))))
          (Atom (Just (TypCon "Int")) (AInt 1))
          (Atom (Just (TypCon "Int")) (AInt 1))) :
        (App
          (Just (TypCon "Int"))
          (Atom
            (Just (typConList "Int" `TypArr` TypCon "Int"))
            (Name "length"))
          (listOne : Nil)) :
        Nil
      )
    )

  -- Check that (\(x:xs) -> x) [1] and all the subexpressions are typed correctly.
  testInferTT "ConsLit"
    (App
      Nothing
      (Lambda
        Nothing
        ((ConsLit
          Nothing
          (Lit Nothing (Name "x"))
          (Lit Nothing (Name "xs"))) : Nil)
        (Atom Nothing (Name "x")))
      (untypedListOne : Nil))
    (App
      (Just $ TypCon "Int")
      (Lambda
        (Just $ typConList "Int" `TypArr` TypCon "Int")
        ((ConsLit
          (Just $ typConList "Int")
          (Lit (Just $ TypCon "Int") (Name "x"))
          (Lit (Just $ typConList "Int") (Name "xs"))) : Nil)
        (Atom (Just $ TypCon "Int") (Name "x")))
      (listOne : Nil))

  -- Check that let x = [1] in [x] :: [[Int]] and all the subexpressions are typed correctly.
  testInferTT "Let"
    (LetExpr
      Nothing
      (Tuple (Lit Nothing (Name "x")) untypedListOne : Nil)
      (List Nothing (Atom Nothing (Name "x") : Nil)))
    (LetExpr
      (Just $ TList $ typConList "Int")
      (Tuple (Lit (Just $ typConList "Int") (Name "x")) listOne : Nil)
      (List
        (Just $ TList $ typConList "Int")
        (Atom (Just $ typConList "Int") (Name "x") : Nil)))

-- lit "a"
-- intLit "a"

  -- Check that (\(a,b) -> ('1',b,a)) (1,2) :: (Char, Int, Int) and all the subexpressions are
  -- typed correctly.
  testInferTT "Tuple and NTupleLit"
    (App
      Nothing
      (Lambda
        Nothing
        ((NTupleLit Nothing (
            Lit Nothing (Name "a") :
            Lit Nothing (Name "b") :
            Nil)) :
          Nil)
        (NTuple Nothing (
          Atom Nothing (Char "1") :
          Atom Nothing (Name "b") :
          Atom Nothing (Name "a") :
          Nil)))
      (NTuple Nothing (
          Atom Nothing (AInt 1) :
          Atom Nothing (AInt 2) :
          Nil) :
        Nil))
    (App
      (Just $ charIntTupleType)
      (Lambda
        (Just $ intTupleType `TypArr` charIntTupleType)
        ((NTupleLit (Just intTupleType) (
            Lit (Just intType) (Name "a") :
            Lit (Just intType) (Name "b") :
            Nil)) :
          Nil)
        (NTuple (Just charIntTupleType) (
          Atom (Just charType) (Char "1") :
          Atom (Just intType) (Name "b") :
          Atom (Just intType) (Name "a") :
          Nil)))
      (NTuple (Just intTupleType) (
          Atom (Just intType) (AInt 1) :
          Atom (Just intType) (AInt 2) :
          Nil) :
        Nil))

  -- +-----------------------------+
  -- | Test the tree normalization |
  -- +-----------------------------+

  -- Check that x :: t_42 == x :: a.
  testNormalizeTT "Atom"
    (Atom (Just $ TypVar "t_42") (Name "x"))
    (Atom (Just $ TypVar "a") (Name "x"))

  -- Check that an untyped atom stays untyped.
  testNormalizeTT "Untyped atom"
    (Atom Nothing (Name "x"))
    (Atom Nothing (Name "x"))

  -- Check that (\x -> x) :: t_2 -> t_2 == (\x -> x) :: a -> a.
  testNormalizeTT "Identity function"
    (Lambda
      (Just $ typVarArrow "t_2" "t_2")
      ((Lit (Just $ TypVar "t_2") (Name "x")) : Nil)
      (Atom (Just $ TypVar "t_2") (Name "x")))
    (Lambda
      (Just $ typVarArrow "a" "a")
      ((Lit (Just $ TypVar "a") (Name "x")) : Nil)
      (Atom (Just $ TypVar "a") (Name "x")))

  -- Check that (\(x, y) -> x) :: (t_10, t_2) -> t_10
  --         == (\(x, y) -> x) :: (a, b) -> a
  testNormalizeTT "Normalization: Tuple binding in lambda"
    (Lambda
      (Just (typVarTuple ("t_10" : "t_2" : Nil) `TypArr` TypVar "t_10"))
      (
        (NTupleLit (Just (typVarTuple ("t_10" : "t_2" : Nil)))
          (
            (Lit (Just (TypVar "t_10")) (Name "x")) :
            (Lit (Just (TypVar "t_2")) (Name "y")) :
            Nil
          )
        ) : Nil
      )
      (Atom (Just (TypVar "t_10")) (Name "x"))
    )
    (Lambda
      (Just (typVarTuple ("a" : "b" : Nil) `TypArr` TypVar "a"))
      (
        (NTupleLit (Just (typVarTuple ("a" : "b" : Nil)))
          (
            (Lit (Just (TypVar "a")) (Name "x")) :
            (Lit (Just (TypVar "b")) (Name "y")) :
            Nil
          )
        ) : Nil
      )
      (Atom (Just (TypVar "a")) (Name "x"))
    )

  -- Check that (\(x:xs) [a,b] (u,v,w) -> x) :: [t_4] -> [t_2] -> (t_1, t_3, t_5) -> t_4
  --         == (\(x:xs) [a,b] (u,v,w) -> x) :: [a] -> [b] -> (c, d, e) -> a
  testNormalizeTT "Normalization: Tuple binding in lambda"
    (Lambda
      -- :: [t_4] -> [t_2] -> (t_1, t_3, t_5) -> t_4
      (Just
        (typVarList "t_4" `TypArr`
          (typVarList "t_2" `TypArr`
            (typVarTuple ("t_1" : "t_3" : "t_5" : Nil)) `TypArr`
              TypVar "t_4")))
      (
        -- (x:xs) [a,b] (u,v,w)
        (ConsLit (Just (typVarList "t_4"))
          (Lit (Just (TypVar "t_4")) (Name "x"))
          (Lit (Just (typVarList "t_4")) (Name "xs"))
        ) :
        (ListLit (Just (typVarList "t_2"))
          (
            (Lit (Just (TypVar "t_2")) (Name "a")) :
            (Lit (Just (TypVar "t_2")) (Name "b")) :
            Nil
          )
        ) :
        (NTupleLit (Just (typVarTuple ("t_1" : "t_3" : "t_5" : Nil)))
          (
            (Lit (Just (TypVar "t_1")) (Name "u")) :
            (Lit (Just (TypVar "t_3")) (Name "v")) :
            (Lit (Just (TypVar "t_5")) (Name "w")) :
            Nil
          )
        ) :
        Nil
      )
      (Atom (Just (TypVar "t_4")) (Name "x"))
    )
    (Lambda
      -- :: [a] -> [b] -> (c, d, e) -> a
      (Just
        (typVarList "a" `TypArr`
          (typVarList "b" `TypArr`
            (typVarTuple ("c" : "d" : "e" : Nil)) `TypArr`
              TypVar "a")))
      (
        -- (x:xs) [a,b] (u,v,w)
        (ConsLit (Just (typVarList "a"))
          (Lit (Just (TypVar "a")) (Name "x"))
          (Lit (Just (typVarList "a")) (Name "xs"))
        ) :
        (ListLit (Just (typVarList "b"))
          (
            (Lit (Just (TypVar "b")) (Name "a")) :
            (Lit (Just (TypVar "b")) (Name "b")) :
            Nil
          )
        ) :
        (NTupleLit (Just (typVarTuple ("c" : "d" : "e" : Nil)))
          (
            (Lit (Just (TypVar "c")) (Name "u")) :
            (Lit (Just (TypVar "d")) (Name "v")) :
            (Lit (Just (TypVar "e")) (Name "w")) :
            Nil
          )
        ) :
        Nil
      )
      (Atom (Just (TypVar "a")) (Name "x"))
    )

  -- Check that (\f x -> f x) :: (t_4 -> t_45) -> t_4 -> t_45
  --         == (\f x -> f x) :: (a -> b) -> a -> b
  testNormalizeTT "Apply function"
    (Lambda
      (Just (typVarArrow "t_4" "t_45" `TypArr` typVarArrow "t_4" "t_45"))
      (
        (Lit (Just (typVarArrow "t_4" "t_45")) (Name "f")) :
        (Lit (Just (TypVar  "t_4")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "t_45"))
        (Atom (Just (typVarArrow "t_4" "t_45")) (Name "f"))
        ((Atom (Just (TypVar  "t_4")) (Name "x")) : Nil)
      )
    )
    (Lambda
      (Just (typVarArrow "a" "b" `TypArr` typVarArrow "a" "b"))
      (
        (Lit (Just (typVarArrow "a" "b")) (Name "f")) :
        (Lit (Just (TypVar  "a")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "b"))
        (Atom (Just (typVarArrow "a" "b")) (Name "f"))
        ((Atom (Just (TypVar  "a")) (Name "x")) : Nil)
      )
    )

  -- Map scheme `Int` on `x`. We expect the type variable mapping { x = Int }.
  testMapSchemeOnTVarMappings
    "Map scheme on literal binding"
    (Forall Nil intType)
    (Lit (Tuple Nothing 0) (Name "x"))
    (Tuple "x" (Forall Nil intType) : Nil)

  -- Map scheme `forall t_4. (t_4 -> t_4, (Int, Bool)) on `(f, (n, b))`. We expect the mapping
  -- { f = forall t_4. t_4 -> t_4, n = Int, b = Bool }.
  testMapSchemeOnTVarMappings
    "Map scheme on tuple"
    -- The scheme: forall t_4. (t_4 -> t_4, (Int, Bool))
    (Forall ("t_4" : Nil)
      (TTuple (typVarArrow "t_4" "t_4" :
        (TTuple (intType : boolType : Nil)) : Nil))
    )
    -- The binding: (f, (n, b))
    (NTupleLit (Tuple Nothing 1)
      (
        (Lit (Tuple Nothing 2) (Name "f")) :
        (NTupleLit (Tuple Nothing 3)
          (
            (Lit (Tuple Nothing 4) (Name "n")) :
            (Lit (Tuple Nothing 5) (Name "b")) :
            Nil
          )
        ) :
        Nil
      )
    )
    -- The expected result: { f = forall t_4. t_4 -> t_4, n = Int, b = Bool }
    (
      (Tuple "f" (Forall ("t_4" : Nil) (typVarArrow "t_4" "t_4"))) :
      (Tuple "n" (Forall Nil intType)) :
      (Tuple "b" (Forall Nil boolType)) :
      Nil
    )

  partiallyTypedExprTests
  adtTests

adtPrelude :: String
adtPrelude = """
data Unit = Unit

data Bool = T | F

useless T = Unit
useless F = Unit

data Tuple a b = Tuple a b

tuple a b = (a,b)

fst (Tuple a b) = a
snd (Tuple a b) = b

data Id a = Id a

id a = a

tuple' a = Tuple a a
"""

adtTests :: Test Unit
adtTests = do
  testInferTTWithCustomPrelude' "adt-params-3-1"
    adtPrelude
    "Id"
    (Atom
      (Just
        (TypArr
          (TypVar "a")
          (TTypeCons "Id" (TypVar "a":Nil))))
      (Constr "Id"))

  testInferExprWithCustomPrelude "adt-0-ary-1"
    adtPrelude
    "Unit"
    (TTypeCons "Unit" Nil)

  testInferExprWithCustomPrelude "adt-0-ary-2"
    adtPrelude
    "T"
    (TTypeCons "Bool" Nil)

  testInferExprWithCustomPrelude "adt-0-ary-3"
    adtPrelude
    "F"
    (TTypeCons "Bool" Nil)

  testInferExprWithCustomPrelude "adt-0-ary-4"
    adtPrelude
    "useless"
    (TypArr (TTypeCons "Bool" Nil) (TTypeCons "Unit" Nil))

  testInferExprWithCustomPrelude "adt-params-1-1"
    adtPrelude
    "fst (Tuple T F)"
    (TTypeCons "Bool" Nil)

  testInferExprWithCustomPrelude "adt-params-1-2"
    adtPrelude
    "snd (Tuple T F)"
    (TTypeCons "Bool" Nil)

  testInferExprWithCustomPrelude "adt-params-1-3"
    adtPrelude
    "snd (Tuple 1 2)"
    intType

  testInferExprWithCustomPrelude "adt-params-1-4"
    adtPrelude
    "fst"
    (TypArr
      (TTypeCons "Tuple" (TypVar "a" : TypVar "b" : Nil))
      (TypVar "a"))

  testInferExprWithCustomPrelude "adt-params-1-5"
    adtPrelude
    "snd"
    (TypArr
      (TTypeCons "Tuple" (TypVar "a" : TypVar "b" : Nil))
      (TypVar "b"))

  testInferExprWithCustomPrelude "adt-params-1-6"
    adtPrelude
    "Tuple 1 2"
    (TTypeCons "Tuple" (intType : intType : Nil))

  testInferExprWithCustomPrelude "adt-params-1-7"
    adtPrelude
    "Tuple 1"
    (TypArr
      (TypVar "a")
      (TTypeCons "Tuple" (intType : TypVar "a" : Nil)))

  testInferExprWithCustomPrelude "adt-params-1-8"
    adtPrelude
    "Tuple Unit Unit"
    (TTypeCons "Tuple" (TTypeCons "Unit" Nil:TTypeCons "Unit" Nil:Nil))

  testInferExprWithCustomPrelude "adt-params-2-1"
    adtPrelude
    "Tuple"
    (TypArr
      (TypVar "a")
      (TypArr
        (TypVar "b")
        (TTypeCons "Tuple"
          (Cons (TypVar "a")
            (Cons (TypVar "b") Nil)))))

  testInferExprWithCustomPrelude "adt-params-2-2"
    adtPrelude
    "Id"
    (TypArr (TypVar "a") (TTypeCons "Id" (TypVar "a":Nil)))

  testInferExprWithCustomPrelude "adt-params-2-3"
    adtPrelude
    "Id id"
    (TTypeCons "Id" (TypArr (TypVar "a") (TypVar "a"):Nil))

  testInferExprWithCustomPrelude "adt-params-2-4"
    adtPrelude
    "tuple'"
    (TypArr (TypVar "a") (TTypeCons "Tuple" (TypVar "a":TypVar "a":Nil)))

  testInferExprWithCustomPrelude "adt-params-2-5"
    adtPrelude
    "tuple' 1"
    (TTypeCons "Tuple" (intType:intType:Nil))

  testMapSchemeOnTVarMappings' "adt-map-scheme-1-1"
    adtPrelude
    (Forall ("t_1":Nil)
      (TTypeCons "Id" (TypVar "t_1":Nil)))
    (ConstrLit
      (Tuple Nothing 0)
      (PrefixDataConstr "Id" 1
        (Lit
          (Tuple Nothing 1)
          (Name "x")
        :Nil)))
    (Tuple "x" (Forall ("t_1":Nil) (TypVar "t_1"))
    :Nil)

  testMapSchemeOnTVarMappings' "adt-map-scheme-1-2"
    adtPrelude
    (Forall Nil
      (TTypeCons "Id" (TTypeCons "Unit" Nil:Nil)))
    (ConstrLit
      (Tuple Nothing 0)
      (PrefixDataConstr "Id" 1
        (Lit
          (Tuple Nothing 1)
          (Name "x")
        :Nil)))
    (Tuple "x" (Forall Nil (TTypeCons "Unit" Nil))
    :Nil)

  testMapSchemeOnTVarMappings' "adt-map-scheme-1-3"
    adtPrelude
    (Forall Nil
    (TTypeCons "Id" (intType:Nil)))
    (ConstrLit
      (Tuple Nothing 0)
      (PrefixDataConstr "Id" 1
        (Lit
          (Tuple Nothing 1)
          (Name "x")
        :Nil)))
    (Tuple "x" (Forall Nil intType)
    :Nil)

  testMapSchemeOnTVarMappings' "adt-map-scheme-1-4"
    adtPrelude
    (Forall ("id":Nil)
      (TypArr
        (TypVar "id")
        (TTypeCons "Id" (TypVar "id":Nil))))

    (Lit (Tuple Nothing 0) (Name "id"))

    (Tuple "id"
      (Forall ("id":Nil)
        (TypArr
          (TypVar "id")
          (TTypeCons "Id" (TypVar "id":Nil))))
    :Nil)

module Test.TypeChecker where

import AST
import TypeChecker as TC
import TypeChecker (Scheme(..), TVarMappings, boolType, charType, intType,
  intToIntType, intToIntToIntType)
import Parser (parseExpr, parseDefs)
import Test.Parser (parsedPrelude)

import Prelude (Unit, bind, map, pure, show, unit, ($), (==), (<>), (>>=), (<$>))
-- import Control.Monad.Writer (Writer, tell)
import Data.Array as Array
import Data.Either (Either(..))
import Data.List (List(..), (:))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..), fst)
import Data.Foldable (intercalate)
import Text.Parsing.Parser (ParseError, parseErrorMessage)

import Control.Semigroupoid ((>>>), (<<<))

import Test.Utils (Test, tell)

toList :: forall a. Array a -> List a
toList = Array.toUnfoldable

tell' :: String -> Test Unit
tell' = tell

-- | Construct a list of type [typCon] given the name of the type constants.
typConList :: String -> Type
typConList name = TList (TypCon name)

-- | Construct a tuple type given a list of type constant names.
typConNTuple:: List String -> Type
typConNTuple names = TTuple (map TypCon names)

-- | Construct a tuple type given a list of type variable names.
typVarTuple :: List TVar -> Type
typVarTuple tvs = TTuple (map TypVar tvs)

-- | Construct a list of type [a] given the type variable name a.
typVarList :: TVar -> Type
typVarList tv = TList (TypVar tv)

-- | Generate an arrow type from two given type variable names.
typVarArrow :: TVar -> TVar -> Type
typVarArrow tv1 tv2 = TypVar tv1 `TypArr` TypVar tv2

-- | The type (Char, Int, Int)
charIntTupleType :: Type
charIntTupleType = typConNTuple ("Char" : "Int" : "Int" : Nil)

-- | The type (Int, Int)
intTupleType :: Type
intTupleType = typConNTuple ("Int" : "Int" : Nil)

-- | The type [Int]
intList :: Type
intList = TList $ TypCon "Int"

-- | Report a parse error.
reportParseError :: String -> ParseError -> Test Unit
reportParseError testName parseError = tell' $ "Parse error for test case "
  <> testName <> ": "
  <> parseErrorMessage parseError
  <> "\nNote that this is not a failing test but rather an error in the test definition."

-- | Report a type error.
reportTypeError :: String -> TypeError -> Test Unit
reportTypeError testName typeError = tell' $ "Type inference failed in test case `"
  <> testName <> "`:\n"
  <> "Encountered type error: "
  <> prettyPrintTypeError typeError

reportTypeErrorWithNote :: String -> TypeError -> String -> Test Unit
reportTypeErrorWithNote testName typeError note =
  tell' $ "Type inference failed in test case `"
    <> testName <> "`:\n"
    <> "Encountered Type error: "
    <> prettyPrintTypeError typeError
    <> "Additional Note: \n"
    <> note

-- | Compare the given two types and report an error if they are not equal.
compareTypes :: String -> Type -> Type -> Test Unit
compareTypes testName expected actual = if expected == actual
  then pure unit
  else tell' $ "Type inference failed in test case `" <> testName <> "`:\n" <>
               "Expected type: " <> prettyPrintType expected <> "\n" <>
               "Actual type: " <> prettyPrintType actual

compareTypesWithNote :: String -> Type -> Type -> String -> Test Unit
compareTypesWithNote testName expected actual note = if expected == actual
  then pure unit
  else tell' $ "Type inference failed in test case `" <> testName <> "`:\n" <>
               "Expected type: " <> prettyPrintType expected <> "\n" <>
               "Actual type: " <> prettyPrintType actual <> "\n" <>
               "Additional note: \n" <> note

-- | Compare the given type errors and report an error if they are not equal.
compareTypeError :: String -> TypeError -> TypeError -> Test Unit
compareTypeError testName expected actual = if expected == actual
  then pure unit
  else tell' $ "Type inference failed in test case `" <> testName <> "`:\n" <>
               "Expected type error: " <> prettyPrintTypeError expected <> "\n" <>
               "Actual type error: " <> prettyPrintTypeError actual <> "\n"

-- | Try to infer the type of a given expression and compare the result with the expected type.
testInferExpr :: String -> String -> Type -> Test Unit
testInferExpr name expressionString expected = case parseExpr expressionString of
  Left parseError -> reportParseError name parseError
  Right expression -> case TC.runInfer true (TC.inferExprToType expression) of
    Left typeError -> reportTypeError name typeError
    Right t -> compareTypes name expected t

-- | Try to infer the type of a given expression and expect a type error to occur.
testInferExprFail :: String -> String -> TypeError -> Test Unit
testInferExprFail name expressionString expected = case parseExpr expressionString of
  Left parseError -> reportParseError name parseError
  Right expression -> case TC.runInfer true (TC.inferExprToType expression) of
    Right t -> tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                       "Expected type error: " <> prettyPrintTypeError expected <> "\n" <>
                       "Found type: " <> prettyPrintType t <> "\n"
    Left typeError -> compareTypeError name expected typeError

testInferDef :: String -> String -> Type -> Test Unit
testInferDef name definitionString expected = case parseDefs definitionString of
  Left parseError -> reportParseError name parseError
  Right (def:_) -> case TC.runInfer true (inferAndConvertToType def) of
    Left typeError -> reportTypeError name typeError
    Right t -> compareTypes name expected t
  _ -> tell' $ "Expected to parse definition in test case `" <> name <> "`\n" <>
               "\nNote that this is not a failing test but rather an error in the test definition."
  where
  inferAndConvertToType def = TC.schemeOfDefinition def >>= TC.schemeToType

testInferDefFail :: String -> String -> TypeError -> Test Unit
testInferDefFail name definitionString expected = case parseDefs definitionString of
  Left parseError -> reportParseError name parseError
  Right (def:_) -> case TC.runInfer true (inferAndConvertToType def) of
    Left typeError -> if typeError == expected
      then pure unit
      else tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                   "Expected type error: " <> prettyPrintTypeError typeError <> "\n" <>
                   "Actual type error: " <> prettyPrintTypeError expected <> "\n"
    Right t -> tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                       "Expected type error: " <> prettyPrintTypeError expected <> "\n" <>
                       "Found type: " <> prettyPrintType t <> "\n"
  _ -> tell' $ "Expected to parse definition in test case `" <> name <> "`\n" <>
               "\nNote that this is not a failing test but rather an error in the test definition."
  where
  inferAndConvertToType def = TC.schemeOfDefinition def >>= TC.schemeToType

testInferDefGroup :: String -> String -> Type -> Test Unit
testInferDefGroup name definitionString expected = case parseDefs definitionString of
  Left parseError -> reportParseError name parseError
  Right definitions -> case TC.runInfer true (inferAndConvertToType definitions) of
    Left typeError -> reportTypeError name typeError
    Right t -> compareTypes name expected t
  where
  inferAndConvertToType defs = TC.schemeOfDefinitionGroup defs >>= TC.schemeToType

-- | Infer the type of the given expression in the context of the prelude.
testInferExprWithPrelude :: String -> String -> Type -> Test Unit
testInferExprWithPrelude name expressionString expected = case parseExpr expressionString of
  Left parseError -> reportParseError name parseError
  Right expression -> case TC.tryInferTypeInContext parsedPrelude expression of
    Left typeError -> reportTypeError name typeError
    Right t -> compareTypes name expected t

-- | Infer the type of the given expression in the context of a custom prelude.
testInferExprWithCustomPrelude :: String -> String -> String -> Type -> Test Unit
testInferExprWithCustomPrelude name prelude expressionString expected =
  case parseDefs prelude of
    Left parseError -> reportParseError name parseError
    Right parsedPrelude ->
      case parseExpr expressionString of
        Left parseError -> reportParseError name parseError
        Right expression -> case TC.tryInferTypeInContext parsedPrelude expression of
          Left typeError -> do
            reportTypeError name typeError
          Right t -> compareTypesWithNote name expected t
            (case TC.ppTypeEnv <$> TC.tryInferEnvironment parsedPrelude of
              Left msg -> show msg
              Right msg -> msg)

-- | Test type inference on expression trees, given an expression string as well as the expected
-- | resulting typed tree.
testInferTT' :: String -> String -> TypeTree -> Test Unit
testInferTT' name unparsedTree expectedTypeTree = case parseExpr unparsedTree of
  Left parseError -> reportParseError name parseError
  Right expression -> testInferTT name expression expectedTypeTree

testInferTTWithCustomPrelude' :: String -> String -> String -> TypeTree -> Test Unit
testInferTTWithCustomPrelude' name prelude unparsedTree expectedTypeTree =
  case parseDefs prelude of
    Left parseError -> reportParseError name parseError
    Right parsedPrelude -> case parseExpr unparsedTree of
      Left parseError -> reportParseError name parseError
      Right expression -> testInferTTWithCustomPrelude name parsedPrelude expression expectedTypeTree

-- | Test type inference on expression trees. Here not only the expected type of the whole
-- | expression is checked, but also the type of every subexpression.
testInferTT :: String -> TypeTree -> TypeTree -> Test Unit
testInferTT name untypedTree expectedTypedTree =
  case TC.tryInferExprInContext parsedPrelude untypedTree of
    Left typeError -> reportTypeError name typeError
    Right typedTree -> if expectedTypedTree == typedTree
      then pure unit
      else tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                   "Expected type tree: " <> show expectedTypedTree <> "\n" <>
                   "Actual type tree: " <> show typedTree <> "\n"

testInferTTWithCustomPrelude :: String -> List Definition -> TypeTree -> TypeTree -> Test Unit
testInferTTWithCustomPrelude name parsedPrelude untypedTree expectedTypedTree =
  case TC.tryInferExprInContext parsedPrelude untypedTree of
    Left typeError -> reportTypeError name typeError
    Right typedTree -> if expectedTypedTree == typedTree
      then pure unit
      else tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                   "Expected type tree: " <> show expectedTypedTree <> "\n" <>
                   "Actual type tree: " <> show typedTree <> "\n"

testInferTTFail :: String -> TypeTree -> TypeError -> Test Unit
testInferTTFail name expr expectedError =
  case TC.tryInferExprInContext parsedPrelude expr of
    Left typeError -> compareTypeError name expectedError typeError
    Right typedExpr ->
      tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
              "Expected type error: " <> prettyPrintTypeError expectedError <> "\n" <>
              "Found type tree: " <> show typedExpr <> "\n"

-- | Test type tree normalization.
testNormalizeTT :: String -> TypeTree -> TypeTree -> Test Unit
testNormalizeTT name tt normalizedTT = if (TC.normalizeTypeTree tt) == normalizedTT
  then pure unit
  else tell' $ "Type tree normalization failed in test case `" <> name <> "`:\n" <>
               "Expected type tree: " <> show normalizedTT <> "\n" <>
               "Actual type tree: " <> show tt <> "\n"

-- | Test the function `mapSchemeOnTVarMappings`.
testMapSchemeOnTVarMappings :: String -> Scheme -> IndexedTypedBinding
                            -> TVarMappings -> Test Unit
testMapSchemeOnTVarMappings name scheme binding expected =
  case TC.runInfer true (fst <$> TC.mapSchemeOnTVarMappings binding scheme) of
    Left typeError -> reportTypeError name typeError
    Right result -> if result == expected
      then pure unit
      else tell' $
        "The function `mapSchemeOnTVarMappings` failed in test case `" <> name <> "`:\n" <>
        "Expected type variable mapping: " <> TC.ppTVarMappings expected <> "\n" <>
        "Actual type variable mapping: " <> TC.ppTVarMappings result <> "\n"

-- | Typed type tree representing `[1]`.
listOne :: TypeTree
listOne = List (Just $ typConList "Int") (Atom (Just $ TypCon "Int") (AInt 1) : Nil)

-- | Untyped type tree representing `[1]`.
untypedListOne :: TypeTree
untypedListOne = List Nothing (Atom Nothing (AInt 1) : Nil)

partiallyTypedExprTests :: Test Unit
partiallyTypedExprTests = do
  -- Test that ((2 :: Int) + 4) is typed correctly.
  testInferTT "Partially typed"
    (Binary
      Nothing
      (Tuple Add Nothing)
      (Atom (Just intType) (AInt 2))
      (Atom Nothing (AInt 4))
    )
    (Binary
      (Just (TypCon "Int"))
      (Tuple Add (Just (TypCon "Int" `TypArr` (TypCon "Int" `TypArr` TypCon "Int"))))
      (Atom (Just intType) (AInt 2))
      (Atom (Just intType) (AInt 4))
    )

  -- Test that ((2 :: Char) + 4) results in a type error.
  testInferTTFail "Partially typed"
    (Binary
      Nothing
      (Tuple Add Nothing)
      (Atom (Just charType) (AInt 2))
      (Atom Nothing (AInt 4))
    )
    (UnificationFail intType charType)

  -- Test that `let (f :: Int -> Int) = \x -> x in f True` results in a type error.
  testInferTTFail "Partially typed let expression 1"
    (LetExpr
      Nothing
      (
        Tuple (Lit (Just intToIntType) (Name "f"))
          (Lambda Nothing
            ((Lit Nothing (Name "x")) : Nil)
            (Atom Nothing (Name "x"))) :
        Nil
      )
      (App
        Nothing
        (Atom Nothing (Name "f"))
        ((Atom Nothing (Bool true)) : Nil)
      )
    )
    (UnificationFail intType boolType)

  -- Test that `let f = ((\x -> x) :: Int -> Int) in f True` results in a type error.
  testInferTTFail "Partially typed let expression 2"
    (LetExpr
      Nothing
      (
        Tuple (Lit Nothing (Name "f"))
          (Lambda (Just intToIntType)
            ((Lit Nothing (Name "x")) : Nil)
            (Atom Nothing (Name "x"))) :
        Nil
      )
      (App
        Nothing
        (Atom Nothing (Name "f"))
        ((Atom Nothing (Bool true)) : Nil)
      )
    )
    (UnificationFail intType boolType)

  -- Test that `(\(a :: Bool) b -> a)) 'x'` results in a type error.
  testInferTTFail "Partially typed lambda expression 1"
    (App
      Nothing
      (Lambda
        Nothing
        ((Lit (Just boolType) (Name "a")) : (Lit Nothing (Name "b")) : Nil)
        (Atom Nothing (Name "a"))
      )
      ((Atom Nothing (Char "x")) : Nil)
    )
    (UnificationFail boolType charType)

  -- Test that `(\(x:(y :: Char):ys) -> mod x y)` results in a type error.
  testInferTTFail "Partially typed lambda expression 1"
    (Lambda
      Nothing
        (
          (ConsLit
            Nothing
            (Lit Nothing (Name "x"))
            (ConsLit
              Nothing
              (Lit (Just charType) (Name "y"))
              (Lit Nothing (Name "ys"))
            ) : Nil
          )
        )
        (App
          Nothing
          (Atom Nothing (Name "mod"))
          (Atom Nothing (Name "x") : Atom Nothing (Name "y") : Nil)
        )
    )
    (UnificationFail intType charType)

runTests :: Test Unit
runTests = do
  -- +--------------------------------------------------+
  -- | Test the inferred types of arbitrary expressions |
  -- +--------------------------------------------------+

  -- (3^) :: Int -> Int
  testInferExpr "SectL" "(3^)" intToIntType
  -- (^3) :: Int -> Int
  testInferExpr "SectR" "(^3)" intToIntType
  -- (\a b c d -> a b c d) :: (a -> b -> c -> d) -> a -> b -> c -> d
  testInferExpr "Lambda1" "\\a b c d -> a b c d"
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` (TypVar "c" `TypArr` TypVar "d"))) `TypArr`
      (TypVar "a" `TypArr` (TypVar "b" `TypArr` (TypVar "c" `TypArr` (TypVar "d")))))
  testInferExpr "Lambda2" "\\a b -> a b"
    (TypArr (TypArr (TypVar "a") (TypVar "b")) (TypArr (TypVar "a") (TypVar "b")))
  testInferExpr "List1" "[1, 2, 3, 4, 5]" intList
  testInferExpr "List2" "[1 + 2, 3 + 4]" intList
  testInferExpr "Empty list" "[]" (typVarList "a")
  testInferExpr "Append" "[1 + 2, 3 + 4] ++ []" intList
  testInferExpr "NTuple" "(1 + 2, 3)" (typConNTuple ("Int" : "Int" : Nil))
  testInferExpr "SectR colon" "(:[3])" (TypCon "Int" `TypArr` intList)
  testInferExpr "Lambda wildcard" "\\_ _ -> 5" (TypVar "a" `TypArr` (TypVar "b" `TypArr` intType))
  testInferExpr "Lambda cons binding" "\\(x:xs) -> x" (typVarList "a" `TypArr` TypVar "a")
  testInferExpr "Let expression" "let x = 3 in \\_ _ -> x"
    (TypVar "a" `TypArr` (TypVar "b" `TypArr` intType))
  testInferExpr "Binding tuple in let expression" "let (a, b) = (\\f -> f, \"Hello\") in a b"
    (typConList "Char")
  testInferExpr "Lambda application" "(\\f a b -> f a b) (+) 3 4" intType
  -- ((\xs -> [ x | x <- xs ]) [1]) :: [Int]
  testInferExpr "List comprehension inside lambda" "(\\xs -> [ x | x <- xs ]) [1]" intList

  -- Check that let polymorphism works: `let f = \x -> x in (f True, f 42)` :: (Bool, Int).
  testInferExpr "Let polymorphism" "let f = \\x -> x in (f True, f 42)"
    (TTuple (boolType : intType : Nil))

  testInferExprFail "List unification fail" "[(+), 4]" (UnificationFail intToIntToIntType intType)
  testInferExprFail "Cons unification fail"
    "let str = \"Hallo\" in 3 : [1 + 2, 3 + 4, str]"
    (UnificationFail intType (TList charType))

  -- +-----------------------------------------------+
  -- | Test the inferred types of single definitions |
  -- +-----------------------------------------------+

  testInferDef "Define app" "app f xs = app f xs"
    (TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "c"))
  testInferDef "Define single map" "map f (x:xs) = f x : map f xs"
    ((TypVar "a" `TypArr` TypVar "b") `TypArr` (typVarList "a" `TypArr` typVarList "b"))
  testInferDef "Define foldr" "foldr f ini (x:xs) = f x (foldr f ini xs)"
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "b")) `TypArr`
      (TypVar "c" `TypArr` (typVarList "a" `TypArr` TypVar "b")))
  testInferDef "Conslit binding 1" "list (x:xs:xss) = x" (typVarList "a" `TypArr` TypVar "a")
  testInferDef "Conslit binding 2" "list (x:xs:xss) = xs" (typVarList "a" `TypArr` TypVar "a")
  testInferDef "Conslit binding 3" "list (x:xs:xss) = xss" (typVarList "a" `TypArr` typVarList "a")
  testInferDef "Binding tuple 1" "fst (a, b) = a"
    (typVarTuple ("a" : "b" : Nil) `TypArr` TypVar "a")
  testInferDef "Binding tuple 2" "snd (a, b) = b"
    (typVarTuple ("a" : "b" : Nil) `TypArr` TypVar "b")
  testInferDef "Binding tuple 3" "f (a, b, c) = a b c"
    ((TTuple
      (TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "c") : TypVar "a" : TypVar "b" : Nil))
        `TypArr` TypVar "c")

  testInferDefFail "Listlit binding" "list [a, b, c] = a b c"
    (InfiniteType "a" (TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "c")))

  -- +----------------------------------------------+
  -- | Test the inferred types of definition groups |
  -- +----------------------------------------------+

  let zipWithDef = "zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\n" <>
                   "zipWith _ [] _ = []\n" <>
                   "zipWith _ _ [] = []"
  testInferDefGroup "zipWith" zipWithDef
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "c")) `TypArr`
      (typVarList "a" `TypArr` (typVarList "b" `TypArr` typVarList "c")))

  let foldrDef = "foldr f ini [] = ini\n" <>
                 "foldr f ini (x:xs) = f x (foldr f ini xs)"
  testInferDefGroup "foldr" foldrDef
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "b"))
      `TypArr` (TypVar "b" `TypArr` (typVarList "a" `TypArr` TypVar "b")))

  let scanlDef = "scanl f b []     = [b]\n" <>
                 "scanl f b (x:xs) = b : scanl f (f b x) xs"
  testInferDefGroup "scanl" scanlDef
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "a"))
      `TypArr` (TypVar "a" `TypArr` (typVarList "b" `TypArr` typVarList "a")))

  -- +-------------------------------------------------------------------+
  -- | Test the inferred types of expressions in the prelude environment |
  -- +-------------------------------------------------------------------+

  testInferExprWithPrelude "Prelude with exp" "sum (map (^2) [1, 2, 3, 4])" intType

  -- +----------------------------------------+
  -- | Test the type inference on whole trees |
  -- +----------------------------------------+

  -- Check that \f x -> f x and all the subexpressions are typed correctly.
  testInferTT "Apply function"
    (Lambda Nothing
      ((Lit Nothing (Name "f")) : (Lit Nothing (Name "x")) : Nil)
      (App
        Nothing
        (Atom Nothing (Name "f"))
        ((Atom Nothing (Name "x")) : Nil)))
    (Lambda
      (Just (typVarArrow "a" "b" `TypArr` typVarArrow "a" "b"))
      (
        (Lit (Just (typVarArrow "a" "b")) (Name "f")) :
        (Lit (Just (TypVar  "a")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "b"))
        (Atom (Just (typVarArrow "a" "b")) (Name "f"))
        ((Atom (Just (TypVar  "a")) (Name "x")) : Nil)))

  -- Check that [1, 1 + 1, length [1]] and all the subexpressions are typed correctly.
  testInferTT "List"
    (List
      Nothing
      (
        (Atom Nothing (AInt 1)) :
        (Binary
          Nothing
          (Tuple Add Nothing)
          (Atom Nothing (AInt 1))
          (Atom Nothing (AInt 1))) :
        (App
          Nothing
          (Atom
            Nothing
            (Name "length"))
          (untypedListOne : Nil)) :
        Nil
      )
    )
    (List
      (Just (typConList "Int"))
      (
        (Atom (Just (TypCon "Int")) (AInt 1)) :
        (Binary
          (Just (TypCon "Int"))
          (Tuple Add (Just (TypCon "Int" `TypArr` (TypCon "Int" `TypArr` TypCon "Int"))))
          (Atom (Just (TypCon "Int")) (AInt 1))
          (Atom (Just (TypCon "Int")) (AInt 1))) :
        (App
          (Just (TypCon "Int"))
          (Atom
            (Just (typConList "Int" `TypArr` TypCon "Int"))
            (Name "length"))
          (listOne : Nil)) :
        Nil
      )
    )

  -- Check that (\(x:xs) -> x) [1] and all the subexpressions are typed correctly.
  testInferTT "ConsLit"
    (App
      Nothing
      (Lambda
        Nothing
        ((ConsLit
          Nothing
          (Lit Nothing (Name "x"))
          (Lit Nothing (Name "xs"))) : Nil)
        (Atom Nothing (Name "x")))
      (untypedListOne : Nil))
    (App
      (Just $ TypCon "Int")
      (Lambda
        (Just $ typConList "Int" `TypArr` TypCon "Int")
        ((ConsLit
          (Just $ typConList "Int")
          (Lit (Just $ TypCon "Int") (Name "x"))
          (Lit (Just $ typConList "Int") (Name "xs"))) : Nil)
        (Atom (Just $ TypCon "Int") (Name "x")))
      (listOne : Nil))

  -- Check that let x = [1] in [x] :: [[Int]] and all the subexpressions are typed correctly.
  testInferTT "Let"
    (LetExpr
      Nothing
      (Tuple (Lit Nothing (Name "x")) untypedListOne : Nil)
      (List Nothing (Atom Nothing (Name "x") : Nil)))
    (LetExpr
      (Just $ TList $ typConList "Int")
      (Tuple (Lit (Just $ typConList "Int") (Name "x")) listOne : Nil)
      (List
        (Just $ TList $ typConList "Int")
        (Atom (Just $ typConList "Int") (Name "x") : Nil)))

-- lit "a"
-- intLit "a"

  -- Check that (\(a,b) -> ('1',b,a)) (1,2) :: (Char, Int, Int) and all the subexpressions are
  -- typed correctly.
  testInferTT "Tuple and NTupleLit"
    (App
      Nothing
      (Lambda
        Nothing
        ((NTupleLit Nothing (
            Lit Nothing (Name "a") :
            Lit Nothing (Name "b") :
            Nil)) :
          Nil)
        (NTuple Nothing (
          Atom Nothing (Char "1") :
          Atom Nothing (Name "b") :
          Atom Nothing (Name "a") :
          Nil)))
      (NTuple Nothing (
          Atom Nothing (AInt 1) :
          Atom Nothing (AInt 2) :
          Nil) :
        Nil))
    (App
      (Just $ charIntTupleType)
      (Lambda
        (Just $ intTupleType `TypArr` charIntTupleType)
        ((NTupleLit (Just intTupleType) (
            Lit (Just intType) (Name "a") :
            Lit (Just intType) (Name "b") :
            Nil)) :
          Nil)
        (NTuple (Just charIntTupleType) (
          Atom (Just charType) (Char "1") :
          Atom (Just intType) (Name "b") :
          Atom (Just intType) (Name "a") :
          Nil)))
      (NTuple (Just intTupleType) (
          Atom (Just intType) (AInt 1) :
          Atom (Just intType) (AInt 2) :
          Nil) :
        Nil))

  -- +-----------------------------+
  -- | Test the tree normalization |
  -- +-----------------------------+

  -- Check that x :: t_42 == x :: a.
  testNormalizeTT "Atom"
    (Atom (Just $ TypVar "t_42") (Name "x"))
    (Atom (Just $ TypVar "a") (Name "x"))

  -- Check that an untyped atom stays untyped.
  testNormalizeTT "Untyped atom"
    (Atom Nothing (Name "x"))
    (Atom Nothing (Name "x"))

  -- Check that (\x -> x) :: t_2 -> t_2 == (\x -> x) :: a -> a.
  testNormalizeTT "Identity function"
    (Lambda
      (Just $ typVarArrow "t_2" "t_2")
      ((Lit (Just $ TypVar "t_2") (Name "x")) : Nil)
      (Atom (Just $ TypVar "t_2") (Name "x")))
    (Lambda
      (Just $ typVarArrow "a" "a")
      ((Lit (Just $ TypVar "a") (Name "x")) : Nil)
      (Atom (Just $ TypVar "a") (Name "x")))

  -- Check that (\(x, y) -> x) :: (t_10, t_2) -> t_10
  --         == (\(x, y) -> x) :: (a, b) -> a
  testNormalizeTT "Normalization: Tuple binding in lambda"
    (Lambda
      (Just (typVarTuple ("t_10" : "t_2" : Nil) `TypArr` TypVar "t_10"))
      (
        (NTupleLit (Just (typVarTuple ("t_10" : "t_2" : Nil)))
          (
            (Lit (Just (TypVar "t_10")) (Name "x")) :
            (Lit (Just (TypVar "t_2")) (Name "y")) :
            Nil
          )
        ) : Nil
      )
      (Atom (Just (TypVar "t_10")) (Name "x"))
    )
    (Lambda
      (Just (typVarTuple ("a" : "b" : Nil) `TypArr` TypVar "a"))
      (
        (NTupleLit (Just (typVarTuple ("a" : "b" : Nil)))
          (
            (Lit (Just (TypVar "a")) (Name "x")) :
            (Lit (Just (TypVar "b")) (Name "y")) :
            Nil
          )
        ) : Nil
      )
      (Atom (Just (TypVar "a")) (Name "x"))
    )

  -- Check that (\(x:xs) [a,b] (u,v,w) -> x) :: [t_4] -> [t_2] -> (t_1, t_3, t_5) -> t_4
  --         == (\(x:xs) [a,b] (u,v,w) -> x) :: [a] -> [b] -> (c, d, e) -> a
  testNormalizeTT "Normalization: Tuple binding in lambda"
    (Lambda
      -- :: [t_4] -> [t_2] -> (t_1, t_3, t_5) -> t_4
      (Just
        (typVarList "t_4" `TypArr`
          (typVarList "t_2" `TypArr`
            (typVarTuple ("t_1" : "t_3" : "t_5" : Nil)) `TypArr`
              TypVar "t_4")))
      (
        -- (x:xs) [a,b] (u,v,w)
        (ConsLit (Just (typVarList "t_4"))
          (Lit (Just (TypVar "t_4")) (Name "x"))
          (Lit (Just (typVarList "t_4")) (Name "xs"))
        ) :
        (ListLit (Just (typVarList "t_2"))
          (
            (Lit (Just (TypVar "t_2")) (Name "a")) :
            (Lit (Just (TypVar "t_2")) (Name "b")) :
            Nil
          )
        ) :
        (NTupleLit (Just (typVarTuple ("t_1" : "t_3" : "t_5" : Nil)))
          (
            (Lit (Just (TypVar "t_1")) (Name "u")) :
            (Lit (Just (TypVar "t_3")) (Name "v")) :
            (Lit (Just (TypVar "t_5")) (Name "w")) :
            Nil
          )
        ) :
        Nil
      )
      (Atom (Just (TypVar "t_4")) (Name "x"))
    )
    (Lambda
      -- :: [a] -> [b] -> (c, d, e) -> a
      (Just
        (typVarList "a" `TypArr`
          (typVarList "b" `TypArr`
            (typVarTuple ("c" : "d" : "e" : Nil)) `TypArr`
              TypVar "a")))
      (
        -- (x:xs) [a,b] (u,v,w)
        (ConsLit (Just (typVarList "a"))
          (Lit (Just (TypVar "a")) (Name "x"))
          (Lit (Just (typVarList "a")) (Name "xs"))
        ) :
        (ListLit (Just (typVarList "b"))
          (
            (Lit (Just (TypVar "b")) (Name "a")) :
            (Lit (Just (TypVar "b")) (Name "b")) :
            Nil
          )
        ) :
        (NTupleLit (Just (typVarTuple ("c" : "d" : "e" : Nil)))
          (
            (Lit (Just (TypVar "c")) (Name "u")) :
            (Lit (Just (TypVar "d")) (Name "v")) :
            (Lit (Just (TypVar "e")) (Name "w")) :
            Nil
          )
        ) :
        Nil
      )
      (Atom (Just (TypVar "a")) (Name "x"))
    )

  -- Check that (\f x -> f x) :: (t_4 -> t_45) -> t_4 -> t_45
  --         == (\f x -> f x) :: (a -> b) -> a -> b
  testNormalizeTT "Apply function"
    (Lambda
      (Just (typVarArrow "t_4" "t_45" `TypArr` typVarArrow "t_4" "t_45"))
      (
        (Lit (Just (typVarArrow "t_4" "t_45")) (Name "f")) :
        (Lit (Just (TypVar  "t_4")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "t_45"))
        (Atom (Just (typVarArrow "t_4" "t_45")) (Name "f"))
        ((Atom (Just (TypVar  "t_4")) (Name "x")) : Nil)
      )
    )
    (Lambda
      (Just (typVarArrow "a" "b" `TypArr` typVarArrow "a" "b"))
      (
        (Lit (Just (typVarArrow "a" "b")) (Name "f")) :
        (Lit (Just (TypVar  "a")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "b"))
        (Atom (Just (typVarArrow "a" "b")) (Name "f"))
        ((Atom (Just (TypVar  "a")) (Name "x")) : Nil)
      )
    )

  -- Map scheme `Int` on `x`. We expect the type variable mapping { x = Int }.
  testMapSchemeOnTVarMappings
    "Map scheme on literal binding"
    (Forall Nil intType)
    (Lit (Tuple Nothing 0) (Name "x"))
    (Tuple "x" (Forall Nil intType) : Nil)

  -- Map scheme `(forall t_4. t_4 -> t_4, (Int, Bool)) on `(f, (n, b))`. We expect the mapping
  -- { f = forall t_4. t_4 -> t_4, n = Int, b = Bool }.
  testMapSchemeOnTVarMappings
    "Map scheme on tuple"
    -- The scheme: (forall t_4. t_4 -> t_4, (Int, Bool))
    (Forall ("t_4" : Nil)
      (TTuple (typVarArrow "t_4" "t_4" :
        (TTuple (intType : boolType : Nil)) : Nil))
    )
    -- The binding: (f, (n, b))
    (NTupleLit (Tuple Nothing 1)
      (
        (Lit (Tuple Nothing 2) (Name "f")) :
        (NTupleLit (Tuple Nothing 3)
          (
            (Lit (Tuple Nothing 4) (Name "n")) :
            (Lit (Tuple Nothing 5) (Name "b")) :
            Nil
          )
        ) :
        Nil
      )
    )
    -- The expected result: { f = forall t_4. t_4 -> t_4, n = Int, b = Bool }
    (
      (Tuple "f" (Forall ("t_4" : Nil) (typVarArrow "t_4" "t_4"))) :
      (Tuple "n" (Forall Nil intType)) :
      (Tuple "b" (Forall Nil boolType)) :
      Nil
    )

  partiallyTypedExprTests
  adtTests

adtPrelude :: String
adtPrelude = """
data Unit = Unit

data Bool = T | F

useless T = Unit
useless F = Unit

data Tuple a b = Tuple a b

tuple a b = (a,b)

fst (Tuple a b) = a
snd (Tuple a b) = b

data Id a = Id a

id a = a
"""

adtTests :: Test Unit
adtTests = do
  testInferTTWithCustomPrelude' "adt-params-3-1"
    adtPrelude
    "Id"
    (Atom
      (Just
        (TypArr
          (TypVar "a")
          (TTypeCons "Id" (TypVar "a":Nil))))
      (Constr "Id"))

  testInferExprWithCustomPrelude "adt-0-ary-1"
    adtPrelude
    "Unit"
    (TTypeCons "Unit" Nil)

  testInferExprWithCustomPrelude "adt-0-ary-2"
    adtPrelude
    "T"
    (TTypeCons "Bool" Nil)

  testInferExprWithCustomPrelude "adt-0-ary-3"
    adtPrelude
    "F"
    (TTypeCons "Bool" Nil)

  testInferExprWithCustomPrelude "adt-0-ary-4"
    adtPrelude
    "useless"
    (TypArr (TTypeCons "Bool" Nil) (TTypeCons "Unit" Nil))

  testInferExprWithCustomPrelude "adt-params-1-1"
    adtPrelude
    "fst (Tuple T F)"
    (TTypeCons "Bool" Nil)

  testInferExprWithCustomPrelude "adt-params-1-2"
    adtPrelude
    "snd (Tuple T F)"
    (TTypeCons "Bool" Nil)

  testInferExprWithCustomPrelude "adt-params-1-3"
    adtPrelude
    "snd (Tuple 1 2)"
    intType

  testInferExprWithCustomPrelude "adt-params-1-4"
    adtPrelude
    "fst"
    (TypArr
      (TTypeCons "Tuple" (TypVar "a" : TypVar "b" : Nil))
      (TypVar "a"))

  testInferExprWithCustomPrelude "adt-params-1-5"
    adtPrelude
    "snd"
    (TypArr
      (TTypeCons "Tuple" (TypVar "a" : TypVar "b" : Nil))
      (TypVar "b"))

  testInferExprWithCustomPrelude "adt-params-1-6"
    adtPrelude
    "Tuple 1 2"
    (TTypeCons "Tuple" (intType : intType : Nil))

  testInferExprWithCustomPrelude "adt-params-1-7"
    adtPrelude
    "Tuple 1"
    (TypArr
      (TypVar "a")
      (TTypeCons "Tuple" (intType : TypVar "a" : Nil)))

  testInferExprWithCustomPrelude "adt-params-1-8"
    adtPrelude
    "Tuple Unit Unit"
    (TTypeCons "Tuple" (TTypeCons "Unit" Nil:TTypeCons "Unit" Nil:Nil))

  testInferExprWithCustomPrelude "adt-params-2-1"
    adtPrelude
    "Tuple"
    (TypArr
      (TypVar "a")
      (TypArr
        (TypVar "b")
        (TTypeCons "Tuple"
          (Cons (TypVar "a")
            (Cons (TypVar "b") Nil)))))

  testInferExprWithCustomPrelude "adt-params-2-2"
    adtPrelude
    "Id"
    (TypArr (TypVar "a") (TTypeCons "Id" (TypVar "a":Nil)))

  testInferExprWithCustomPrelude "adt-params-2-2"
    adtPrelude
    "Id id"
    (TTypeCons "Id" (TypArr (TypVar "a") (TypVar "a"):Nil))


Newtyped browser view scale

Newtyped browser view scale

module Genetics.Browser.Types.Coordinates where

import Prelude

import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Foldable (any, foldMap)
import Data.Generic.Rep (class Generic)
import Data.Lens (Getter', Lens, _2, findOf, folded, to, view, (^.))
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (class Newtype, alaF, unwrap)
import Data.Pair (Pair(..))
import Data.Tuple (Tuple(Tuple))
import Genetics.Browser.Types (Point)

-- | The global coordinate system works by taking the sum of the chromosome sizes,
-- | for now mainly represented as a BigInt, as an Int representation may overflow.
-- | Subsets of the global coordinate system are defined by some interval, namely a Pair of Ints

-- | Helper function to calculate the size of the stretch covered by a pair.
pairSize :: forall c.
            Ring c
         => Pair c
         -> c
pairSize (Pair l r) = r - l

-- | Helper function for defining predicates on pairs that contain a given point.
inPair :: forall c.
          Ord c
       => c
       -> Pair c
       -> Boolean
inPair p (Pair l r) = l <= p && p <= r

-- TODO test this one

-- | Helper function for defining predicates on pairs that overlap with a given pair.
pairsOverlap :: forall c.
                Ord c
             => Pair c
             -> Pair c
             -> Boolean
pairsOverlap (Pair l1 r1) (Pair l2 r2) =
  let (Pair l1' r1') = Pair (min l1 l2) (min r1 r2)
      (Pair l2' r2') = Pair (max l1 l2) (max r1 r2)
  in r1' >= l2'

-- | Newtype for representing values normalized to fit in some range
newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (Normalized a) _

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint s {x, y} = Normalized { x: x', y: y' }
  where x' = x / s.width
        y' = y / s.height

rescalePoint :: { width :: Number, height :: Number }
             -> Normalized Point
             -> Point
rescalePoint s (Normalized p) = {x: p.x * s.width, y: p.y * s.height}

-- this should be in the UI, actually.
-- the padding for the view is calculated from the current scale & is in [minPixels, maxPixels]
type SegmentPadding = { minPixels :: Number
                      , maxPixels :: Number }

-- | A coordinate system is defined by a set of segments,
-- | which are defined by (mutually exclusive and contiguous) intervals
-- | over the browser coordinates (BigInt in most cases)
newtype CoordSys i c =
  CoordSys (Segments i c)

-- | A single segment is the segment identifier together with the range it covers.
type Segment i c  = Tuple i (Pair c)

-- TODO the `Map i (Pair c)` definition of `Segments i c` makes it
--      tricky to work with `Segments` using lenses; having problems
--      working with whole `Tuple i (Pair c)` from `Map i (Pair c)`
--      without using Map.toUnfoldable, which requires an annotation...

-- | Several segments are indexed by their identifiers.
type Segments i c = Map i (Pair c)

-- | The `Functor` instance maps over the segment borders.
instance functorCoordSys :: Functor (CoordSys i) where
  map f (CoordSys cs) = CoordSys $ (map <<< map) f cs

derive instance newtypeCoordSys :: Newtype (CoordSys i c) _
derive instance genericCoordSys :: Generic (CoordSys i c) _

-- | Lens to the segments in a coordinate system.
_Segments :: forall i c j d.
             Lens
             (CoordSys i c) (CoordSys j d)
             (Segments i c) (Segments j d)
_Segments = _Newtype

-- | A Getter' to retrieve the total size of the coordinate system by summing its parts.
_TotalSize :: forall i c.
              Ring c
           => Getter' (CoordSys i c) c
_TotalSize = _Segments
             <<< (to $ alaF Additive foldMap pairSize)

-- | A Getter' into the size of a segment.
_SegmentSize :: forall i c.
                Ring c
             => Getter' (Segment i c) c
_SegmentSize = _2 <<< to pairSize

-- | A coordinate system is created by providing an array of pairs of
-- | chromosome/segment name (often in the ChrId newtype) and their
-- | respective sizes.
coordSys :: forall i c.
            Ord i
         => Semiring c
         => Array (Tuple i c)
         -> CoordSys i c
coordSys segs = CoordSys $ Map.fromFoldable
                $ Array.zip ids (offsets sizes)
  where (Tuple ids sizes) = Array.unzip segs

        -- Given an array of sizes, produce an array of contiguous intervals.
        offsets :: Array c -> Array (Pair c)
        offsets xs = let os = Array.scanl (\x y -> x + y) zero xs
                     in Array.zipWith Pair (zero `Array.cons` os) os

-- | Given a coordinate system and a point, find the segment that contains the point, if any.
lookupSegment :: forall i c.
                 Ord c
              => CoordSys i c
              -> c
              -> Maybe (Segment i c)
lookupSegment cs x = findOf folded pred array
  where pred :: Segment i c -> Boolean
        pred = view (_2 <<< to (inPair x))
        array :: Array (Segment i c)
        array = cs ^. _Segments <<< to Map.toUnfoldable

-- | Given a coordinate system and a range, find the segments that overlap, even partially, with the range.
segmentsInPair :: forall i c.
                  Ord i
               => Ord c
               => CoordSys i c
               -> Pair c
               -> Segments i c
segmentsInPair cs x = Map.filter (any (_ `inPair` x)) $ cs ^. _Segments

newtype ViewScale = ViewScale { pixelWidth :: Number, coordWidth :: BigInt }

derive instance eqViewScale :: Eq ViewScale

newtype CoordSysView = CoordSysView (Pair BigInt)

derive instance coordsysviewNewtype :: Newtype CoordSysView _

setViewWidth :: BigInt
             -> Pair BigInt
             -> Pair BigInt
setViewWidth w p@(Pair l r) =
  let width = pairSize p
      rad = width / BigInt.fromInt 2
      mid = l + rad
  in Pair (mid - w) (mid + r)

normalizeView :: forall i.
                 CoordSys i BigInt
              -> BigInt
              -> CoordSysView
              -> CoordSysView
normalizeView cs minWidth csv =
  let limL = zero
      limR = cs ^. _TotalSize
      p = unwrap csv
      len = max minWidth (pairSize p)
      (Pair l r) = setViewWidth len p
      vr' = case l < limL, r > limR of
              true, false  -> Pair limL len
              false, true  -> Pair (limR - len) limR
              true, true   -> Pair limL limR
              false, false -> Pair l r
  in CoordSysView vr'

viewScale :: forall r.
             { width :: Number | r } -> CoordSysView -> ViewScale
viewScale {width} (CoordSysView csView) =
  let coordWidth = pairSize csView
  in ViewScale { pixelWidth: width, coordWidth }

-- | The scale of the browser view is defined by how much of the coordinate system is visible,
-- | and how big the screen it must fit into.
type Scale = { screenWidth :: Number, viewWidth :: BigInt }

-- | Given the width of the display in pixels, and how much of the coordinate system
-- | that is currently visible, scale a point in the coordinate system
-- | to the screen.
-- | Always uses zero as the origin -- points scaled with this must still be translated!
scaleToScreen :: Scale
              -> BigInt
              -> Number
scaleToScreen {screenWidth, viewWidth} x =
  BigInt.toNumber x * (screenWidth / (BigInt.toNumber viewWidth))

scaleToScreen' :: ViewScale
               -> BigInt
               -> Number
scaleToScreen' (ViewScale {pixelWidth, coordWidth}) x =
  BigInt.toNumber x * (pixelWidth / (BigInt.toNumber coordWidth))

-- | Given the width of the display in pixels, and how much of the coordinate system
-- | that is currently visible, scale a point given in pixels from the left-hand edge
-- | to browser units from the beginning of the browser.
-- | Always uses zero as the origin -- points scaled with this must still be translated!
scaleToGlobal :: Scale
              -> Number
              -> BigInt
scaleToGlobal {screenWidth, viewWidth} x =
  BigInt.fromNumber $ x * ((BigInt.toNumber viewWidth) / screenWidth)

scaleToGlobal' :: ViewScale
              -> Number
              -> BigInt
scaleToGlobal' (ViewScale {pixelWidth, coordWidth}) x =
  BigInt.fromNumber $ x * ((BigInt.toNumber coordWidth) / pixelWidth)

pixelsView :: ViewScale -> CoordSysView -> Pair Number
pixelsView vs (CoordSysView (Pair l r)) =
  let f = scaleToScreen' vs
  in Pair (f l) (f r)

-- | Given a coordinate system and browser scale,
-- | return the browser segments scaled to canvas coordinates.
scaledSegments :: forall i.
                  CoordSys i BigInt
               -> Scale
               -> Segments i Number
scaledSegments cs scale = (map <<< map) (scaleToScreen scale) $ cs ^. _Segments

scaledSegments' :: forall i.
                  CoordSys i BigInt
               -> ViewScale
               -> Segments i Number
scaledSegments' cs scale = (map <<< map) (scaleToScreen' scale) $ cs ^. _Segments

-- | Helper functions for translating and scaling pairs.
-- | They're concretized to `BigInt` for convenience; in truth they would
-- | probably fit better in the UI module.

-- | Translate an BigInt pair to the right by `x` times its size.
translatePairBy :: Pair BigInt
                -> Number
                -> Pair BigInt
translatePairBy p x = (_ + delta) <$> p
  where delta = BigInt.fromNumber $ x * (BigInt.toNumber $ pairSize p)

translateViewBy :: CoordSysView
                -> Number
                -> CoordSysView
translateViewBy (CoordSysView p) x = CoordSysView $ translatePairBy p x

-- | Scale an Int pair by changing its length to be `x` times the pair size.
scalePairBy :: Pair BigInt
            -> Number
            -> Pair BigInt
scalePairBy p x = result
  where x' = max zero x
        p'@(Pair l' r') = BigInt.toNumber <$> p
        delta = ((pairSize p' * x') - (pairSize p')) / 2.0
        result = BigInt.fromNumber <$> Pair (l' - delta) (r' + delta)

scaleViewBy :: CoordSysView
            -> Number
            -> CoordSysView
scaleViewBy (CoordSysView p) x = CoordSysView $ scalePairBy p x

module Genetics.Browser.Types.Coordinates where

import Prelude

import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Foldable (any, foldMap)
import Data.Generic.Rep (class Generic)
import Data.Lens (Getter', Lens, _2, findOf, folded, to, view, (^.))
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (class Newtype, alaF)
import Data.Pair (Pair(..))
import Data.Tuple (Tuple(Tuple))
import Genetics.Browser.Types (Point)

-- | The global coordinate system works by taking the sum of the chromosome sizes,
-- | for now mainly represented as a BigInt, as an Int representation may overflow.
-- | Subsets of the global coordinate system are defined by some interval, namely a Pair of Ints

-- | Helper function to calculate the size of the stretch covered by a pair.
pairSize :: forall c.
            Ring c
         => Pair c
         -> c
pairSize (Pair l r) = r - l

-- | Helper function for defining predicates on pairs that contain a given point.
inPair :: forall c.
          Ord c
       => c
       -> Pair c
       -> Boolean
inPair p (Pair l r) = l <= p && p <= r

-- TODO test this one

-- | Helper function for defining predicates on pairs that overlap with a given pair.
pairsOverlap :: forall c.
                Ord c
             => Pair c
             -> Pair c
             -> Boolean
pairsOverlap (Pair l1 r1) (Pair l2 r2) =
  let (Pair l1' r1') = Pair (min l1 l2) (min r1 r2)
      (Pair l2' r2') = Pair (max l1 l2) (max r1 r2)
  in r1' >= l2'

-- | Newtype for representing values normalized to fit in some range
newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (Normalized a) _

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint s {x, y} = Normalized { x: x', y: y' }
  where x' = x / s.width
        y' = y / s.height

rescalePoint :: { width :: Number, height :: Number }
             -> Normalized Point
             -> Point
rescalePoint s (Normalized p) = {x: p.x * s.width, y: p.y * s.height}

-- this should be in the UI, actually.
-- the padding for the view is calculated from the current scale & is in [minPixels, maxPixels]
type SegmentPadding = { minPixels :: Number
                      , maxPixels :: Number }

-- | A coordinate system is defined by a set of segments,
-- | which are defined by (mutually exclusive and contiguous) intervals
-- | over the browser coordinates (BigInt in most cases)
newtype CoordSys i c =
  CoordSys (Segments i c)

-- | A single segment is the segment identifier together with the range it covers.
type Segment i c  = Tuple i (Pair c)

-- TODO the `Map i (Pair c)` definition of `Segments i c` makes it
--      tricky to work with `Segments` using lenses; having problems
--      working with whole `Tuple i (Pair c)` from `Map i (Pair c)`
--      without using Map.toUnfoldable, which requires an annotation...

-- | Several segments are indexed by their identifiers.
type Segments i c = Map i (Pair c)

-- | The `Functor` instance maps over the segment borders.
instance functorCoordSys :: Functor (CoordSys i) where
  map f (CoordSys cs) = CoordSys $ (map <<< map) f cs

derive instance newtypeCoordSys :: Newtype (CoordSys i c) _
derive instance genericCoordSys :: Generic (CoordSys i c) _

-- | Lens to the segments in a coordinate system.
_Segments :: forall i c j d.
             Lens
             (CoordSys i c) (CoordSys j d)
             (Segments i c) (Segments j d)
_Segments = _Newtype

-- | A Getter' to retrieve the total size of the coordinate system by summing its parts.
_TotalSize :: forall i c.
              Ring c
           => Getter' (CoordSys i c) c
_TotalSize = _Segments
             <<< (to $ alaF Additive foldMap pairSize)

-- | A Getter' into the size of a segment.
_SegmentSize :: forall i c.
                Ring c
             => Getter' (Segment i c) c
_SegmentSize = _2 <<< to pairSize

-- | A coordinate system is created by providing an array of pairs of
-- | chromosome/segment name (often in the ChrId newtype) and their
-- | respective sizes.
coordSys :: forall i c.
            Ord i
         => Semiring c
         => Array (Tuple i c)
         -> CoordSys i c
coordSys segs = CoordSys $ Map.fromFoldable
                $ Array.zip ids (offsets sizes)
  where (Tuple ids sizes) = Array.unzip segs

        -- Given an array of sizes, produce an array of contiguous intervals.
        offsets :: Array c -> Array (Pair c)
        offsets xs = let os = Array.scanl (\x y -> x + y) zero xs
                     in Array.zipWith Pair (zero `Array.cons` os) os

-- | Given a coordinate system and a point, find the segment that contains the point, if any.
lookupSegment :: forall i c.
                 Ord c
              => CoordSys i c
              -> c
              -> Maybe (Segment i c)
lookupSegment cs x = findOf folded pred array
  where pred :: Segment i c -> Boolean
        pred = view (_2 <<< to (inPair x))
        array :: Array (Segment i c)
        array = cs ^. _Segments <<< to Map.toUnfoldable

-- | Given a coordinate system and a range, find the segments that overlap, even partially, with the range.
segmentsInPair :: forall i c.
                  Ord i
               => Ord c
               => CoordSys i c
               -> Pair c
               -> Segments i c
segmentsInPair cs x = Map.filter (any (_ `inPair` x)) $ cs ^. _Segments

-- | The scale of the browser view is defined by how much of the coordinate system is visible,
-- | and how big the screen it must fit into.
type Scale = { screenWidth :: Number, viewWidth :: BigInt }

-- | Given the width of the display in pixels, and how much of the coordinate system
-- | that is currently visible, scale a point in the coordinate system
-- | to the screen.
-- | Always uses zero as the origin -- points scaled with this must still be translated!
scaleToScreen :: Scale
              -> BigInt
              -> Number
scaleToScreen {screenWidth, viewWidth} x =
  BigInt.toNumber x * (screenWidth / (BigInt.toNumber viewWidth))

-- | Given the width of the display in pixels, and how much of the coordinate system
-- | that is currently visible, scale a point given in pixels from the left-hand edge
-- | to browser units from the beginning of the browser.
-- | Always uses zero as the origin -- points scaled with this must still be translated!
scaleToGlobal :: Scale
              -> Number
              -> BigInt
scaleToGlobal {screenWidth, viewWidth} x =
  BigInt.fromNumber $ x * ((BigInt.toNumber viewWidth) / screenWidth)

-- | Given a coordinate system and browser scale,
-- | return the browser segments scaled to canvas coordinates.
scaledSegments :: forall i.
                  CoordSys i BigInt
               -> Scale
               -> Segments i Number
scaledSegments cs scale = (map <<< map) (scaleToScreen scale) $ cs ^. _Segments

-- | Helper functions for translating and scaling pairs.
-- | They're concretized to `BigInt` for convenience; in truth they would
-- | probably fit better in the UI module.

-- | Translate an BigInt pair to the right by `x` times its size.
translatePairBy :: Pair BigInt
                -> Number
                -> Pair BigInt
translatePairBy p x = (_ + delta) <$> p
  where delta = BigInt.fromNumber $ x * (BigInt.toNumber $ pairSize p)

-- | Scale an Int pair by changing its length to be `x` times the pair size.
scalePairBy :: Pair BigInt
            -> Number
            -> Pair BigInt
scalePairBy p x = result
  where x' = max zero x
        p'@(Pair l' r') = BigInt.toNumber <$> p
        delta = ((pairSize p' * x') - (pairSize p')) / 2.0
        result = BigInt.fromNumber <$> Pair (l' - delta) (r' + delta)


Update UnknownName quickfix check

Update UnknownName quickfix check

module IdePurescript.QuickFix where

-- | Get a title which explains what applying a compiler suggestion will do
getTitle :: String -> String
getTitle code = case code of
  "UnusedImport"                -> "Remove import"
  "RedundantEmptyHidingImport"  -> "Remove import"
  "DuplicateImport"             -> "Remove import"
  "RedundantUnqualifiedImport"  -> "Remove import"
  "DeprecatedQualifiedSyntax"   -> "Remove qualified keyword"
  "ImplicitImport"              -> "Make import explicit"
  "UnusedExplicitImport"        -> "Remove unused references"
  _                             -> "Apply Suggestion"

-- | Determine whether an error code represents an unknown token (unknown identifier or missing import)
isUnknownToken :: String -> Boolean
isUnknownToken code = case code of
  "UnknownValue" -> true
  "UnknownType" -> true
  "UnknownDataConstructor" -> true
  "UnknownTypeConstructor" -> true
    -- In later compiler versions UnknownName covers all of the above
  "UnknownName" -> true
  _ -> false

module IdePurescript.QuickFix where

-- | Get a title which explains what applying a compiler suggestion will do
getTitle :: String -> String
getTitle code = case code of
  "UnusedImport"                -> "Remove import"
  "RedundantEmptyHidingImport"  -> "Remove import"
  "DuplicateImport"             -> "Remove import"
  "RedundantUnqualifiedImport"  -> "Remove import"
  "DeprecatedQualifiedSyntax"   -> "Remove qualified keyword"
  "ImplicitImport"              -> "Make import explicit"
  "UnusedExplicitImport"        -> "Remove unused references"
  _                             -> "Apply Suggestion"

-- | Determine whether an error code represents an unknown token (unknown identifier or missing import)
isUnknownToken :: String -> Boolean
isUnknownToken code = case code of
  "UnknownValue" -> true
  "UnknownType" -> true
  "UnknownDataConstructor" -> true
  "UnknownTypeConstructor" -> true
  _ -> false