Add test for let polymorphism

Add test for let polymorphism

module Test.TypeChecker where

import AST
import TypeChecker as TC
import TypeChecker (Scheme(..), TVarMappings, boolType, charType, emptyTypeEnv, 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(..), (:), singleton)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..), fst)
import Text.Parsing.Parser (ParseError, parseErrorMessage)

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

tell' :: forall a. a -> Writer (List a) Unit
tell' = tell <<< singleton

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

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

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

-- | Construct a list of type [a] given the type variable name a.
typVarList :: TVar -> Type
typVarList tv = AD $ 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 = AD $ TList $ TypCon "Int"

-- | Report a parse error.
reportParseError :: String -> ParseError -> Writer (List String) 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 -> Writer (List String) Unit
reportTypeError testName typeError = tell' $ "Type inference failed in test case `"
  <> testName <> "`:\n"
  <> "Encountered type error: "
  <> prettyPrintTypeError typeError

-- | Compare the given two types and report an error if they are not equal.
compareTypes :: String -> Type -> Type -> Writer (List String) 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

-- | Compare the given type errors and report an error if they are not equal.
compareTypeError :: String -> TypeError -> TypeError -> Writer (List String) 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 -> Writer (List String) 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 -> Writer (List String) 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 -> Writer (List String) 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 -> Writer (List String) 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 -> Writer (List String) 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 -> Writer (List String) 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

-- | Test type inference on expression trees, given an expression string as well as the expected
-- | resulting typed tree.
testInferTT' :: String -> String -> TypeTree -> Writer (List String) Unit
testInferTT' name unparsedTree expectedTypeTree = case parseExpr unparsedTree of
  Left parseError -> reportParseError name parseError
  Right expression -> testInferTT name 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 -> Writer (List String) 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"

testInferTTFail :: String -> TypeTree -> TypeError -> Writer (List String) 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 -> Writer (List String) 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 -> Writer (List String) 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 :: Writer (List String) 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 :: Writer (List String) 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)"
    (AD $ 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 (AD $ 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"
    ((AD $ 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 $ AD $ TList $ typConList "Int")
      (Tuple (Lit (Just $ typConList "Int") (Name "x")) listOne : Nil)
      (List
        (Just $ AD $ 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)
      (AD (TTuple (typVarArrow "t_4" "t_4" :
        (AD (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

module Test.TypeChecker where

import AST
import TypeChecker as TC
import TypeChecker (Scheme(..), TVarMappings, boolType, charType, emptyTypeEnv, 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(..), (:), singleton)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..), fst)
import Text.Parsing.Parser (ParseError, parseErrorMessage)

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

tell' :: forall a. a -> Writer (List a) Unit
tell' = tell <<< singleton

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

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

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

-- | Construct a list of type [a] given the type variable name a.
typVarList :: TVar -> Type
typVarList tv = AD $ 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 = AD $ TList $ TypCon "Int"

-- | Report a parse error.
reportParseError :: String -> ParseError -> Writer (List String) 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 -> Writer (List String) Unit
reportTypeError testName typeError = tell' $ "Type inference failed in test case `"
  <> testName <> "`:\n"
  <> "Encountered type error: "
  <> prettyPrintTypeError typeError

-- | Compare the given two types and report an error if they are not equal.
compareTypes :: String -> Type -> Type -> Writer (List String) 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

-- | Compare the given type errors and report an error if they are not equal.
compareTypeError :: String -> TypeError -> TypeError -> Writer (List String) 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 -> Writer (List String) 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 -> Writer (List String) 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 -> Writer (List String) 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 -> Writer (List String) 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 -> Writer (List String) 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 -> Writer (List String) 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

-- | Test type inference on expression trees, given an expression string as well as the expected
-- | resulting typed tree.
testInferTT' :: String -> String -> TypeTree -> Writer (List String) Unit
testInferTT' name unparsedTree expectedTypeTree = case parseExpr unparsedTree of
  Left parseError -> reportParseError name parseError
  Right expression -> testInferTT name 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 -> Writer (List String) 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"

testInferTTFail :: String -> TypeTree -> TypeError -> Writer (List String) 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 -> Writer (List String) 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 -> Writer (List String) 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 :: Writer (List String) 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 :: Writer (List String) 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

  testInferExprFail "List unification fail" "[(+), 4]" (UnificationFail intToIntToIntType intType)
  testInferExprFail "Cons unification fail"
    "let str = \"Hallo\" in 3 : [1 + 2, 3 + 4, str]"
    (UnificationFail intType (AD $ 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"
    ((AD $ 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 $ AD $ TList $ typConList "Int")
      (Tuple (Lit (Just $ typConList "Int") (Name "x")) listOne : Nil)
      (List
        (Just $ AD $ 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)
      (AD (TTuple (typVarArrow "t_4" "t_4" :
        (AD (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


Pass qualifier down to the identImport command

module IdePurescript.VSCode.Imports where

import Prelude

import Control.Monad.Except (runExcept)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Nullable (toNullable)
import Data.Traversable (traverse)
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Foreign (readArray, readString, unsafeToForeign)
import IdePurescript.VSCode.Assist (getActivePosInfo)
import IdePurescript.VSCode.Editor (identifierAtCursor)
import IdePurescript.VSCode.Types (launchAffAndRaise)
import LanguageServer.IdePurescript.Commands (addCompletionImport, addModuleImportCmd, cmdName, getAvailableModulesCmd)
import LanguageServer.Types (Command(..), DocumentUri)
import LanguageServer.Uri (filenameToUri)
import VSCode.Input (showQuickPick, defaultInputOptions, getInput)
import VSCode.LanguageClient (LanguageClient, sendCommand)
import VSCode.TextDocument (getPath)
import VSCode.TextEditor (getDocument)
import VSCode.Window (getActiveTextEditor)

addIdentImport :: LanguageClient -> Effect Unit
addIdentImport client = launchAffAndRaise $ void $ do
  liftEffect getActivePosInfo >>= maybe (pure unit) \{ pos, uri, ed } -> do
    atCursor <- liftEffect $ identifierAtCursor ed
    let defaultIdent = maybe "" _.word atCursor
        qual = _.qualifier =<< atCursor
    ident <- getInput (defaultInputOptions { prompt = toNullable $ Just "Identifier", value = toNullable $ Just defaultIdent })
    addIdentImportMod ident qual uri Nothing
  where
    addIdentImportMod :: String -> Maybe String -> DocumentUri -> Maybe String -> Aff Unit
    addIdentImportMod ident qual uri mod = do
      let Command { command, arguments } = addCompletionImport ident mod qual uri
      res <- sendCommand client command arguments
      case runExcept $ readArray res of
        Right forArr
          | Right arr <- runExcept $ traverse readString forArr
          -> showQuickPick arr >>= maybe (pure unit) (addIdentImportMod ident qual uri <<< Just)
        _ -> pure unit

addModuleImport :: LanguageClient -> Effect Unit
addModuleImport client = launchAffAndRaise $ void $ do
  modulesForeign <- sendCommand client (cmdName getAvailableModulesCmd) (toNullable Nothing)
  ed' <- liftEffect $ getActiveTextEditor
  case runExcept $ readArray modulesForeign, ed' of
    Right arr1, Just ed
      | Right modules <- runExcept $ traverse readString arr1
      -> do
        pick <- showQuickPick modules
        uri <- liftEffect $ filenameToUri =<< (getPath $ getDocument ed)
        atCursor <- liftEffect $ identifierAtCursor ed
        qual <- pure $ toNullable $ _.qualifier =<< atCursor
        case pick of
          Just modName -> void $ sendCommand client (cmdName addModuleImportCmd)
            (toNullable $ Just [ unsafeToForeign modName, unsafeToForeign qual, unsafeToForeign uri ])
          _ -> pure unit
    _, _ -> pure unit

module IdePurescript.VSCode.Imports where

import Prelude

import Control.Monad.Except (runExcept)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Nullable (toNullable)
import Data.Traversable (traverse)
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Foreign (readArray, readString, unsafeToForeign)
import IdePurescript.VSCode.Assist (getActivePosInfo)
import IdePurescript.VSCode.Editor (identifierAtCursor)
import IdePurescript.VSCode.Types (launchAffAndRaise)
import LanguageServer.IdePurescript.Commands (addCompletionImport, addModuleImportCmd, cmdName, getAvailableModulesCmd)
import LanguageServer.Types (Command(..), DocumentUri)
import LanguageServer.Uri (filenameToUri)
import VSCode.Input (showQuickPick, defaultInputOptions, getInput)
import VSCode.LanguageClient (LanguageClient, sendCommand)
import VSCode.TextDocument (getPath)
import VSCode.TextEditor (getDocument)
import VSCode.Window (getActiveTextEditor)

addIdentImport :: LanguageClient -> Effect Unit
addIdentImport client = launchAffAndRaise $ void $ do
  liftEffect getActivePosInfo >>= maybe (pure unit) \{ pos, uri, ed } -> do
    atCursor <- liftEffect $ identifierAtCursor ed
    let defaultIdent = maybe "" _.word atCursor
    ident <- getInput (defaultInputOptions { prompt = toNullable $ Just "Identifier", value = toNullable $ Just defaultIdent })
    addIdentImportMod ident uri Nothing
  where
    addIdentImportMod :: String -> DocumentUri -> Maybe String -> Aff Unit
    addIdentImportMod ident uri mod = do
      let Command { command, arguments } = addCompletionImport ident mod Nothing uri
      res <- sendCommand client command arguments
      case runExcept $ readArray res of
        Right forArr
          | Right arr <- runExcept $ traverse readString forArr
          -> showQuickPick arr >>= maybe (pure unit) (addIdentImportMod ident uri <<< Just)
        _ -> pure unit

addModuleImport :: LanguageClient -> Effect Unit
addModuleImport client = launchAffAndRaise $ void $ do
  modulesForeign <- sendCommand client (cmdName getAvailableModulesCmd) (toNullable Nothing)
  ed' <- liftEffect $ getActiveTextEditor
  case runExcept $ readArray modulesForeign, ed' of
    Right arr1, Just ed
      | Right modules <- runExcept $ traverse readString arr1
      -> do
        pick <- showQuickPick modules
        uri <- liftEffect $ filenameToUri =<< (getPath $ getDocument ed)
        atCursor <- liftEffect $ identifierAtCursor ed
        qual <- pure $ toNullable $ _.qualifier =<< atCursor
        case pick of
          Just modName -> void $ sendCommand client (cmdName addModuleImportCmd)
            (toNullable $ Just [ unsafeToForeign modName, unsafeToForeign qual, unsafeToForeign uri ])
          _ -> pure unit
    _, _ -> pure unit


Add comments

Add comments

module Docopt.Parser.Lexer where

import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Token as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import qualified Data.List as L
import qualified Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray)
import Data.List (List(..), (:))
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Docopt.Parser.Base

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | LAngle
  | RAngle
  | TripleDot
  | Dash
  | Name String

prettyPrintToken :: Token -> String
prettyPrintToken LParen      = show '('
prettyPrintToken RParen      = show ')'
prettyPrintToken LSquare     = show '['
prettyPrintToken RSquare     = show ']'
prettyPrintToken LAngle      = show '<'
prettyPrintToken RAngle      = show '>'
prettyPrintToken Dash        = show '-'
prettyPrintToken TripleDot   = show "..."
prettyPrintToken (Name name) = show name

data PositionedToken = PositionedToken
  { sourcePos :: P.Position
  , token     :: Token
  }

instance showToken :: Show Token where
  show = show <<< prettyPrintToken

instance eqToken :: Eq Token where
  eq LParen      LParen       = true
  eq RParen      RParen       = true
  eq LSquare     LSquare      = true
  eq RSquare     RSquare      = true
  eq LAngle      LAngle       = true
  eq RAngle      RAngle       = true
  eq Dash        Dash         = true
  eq TripleDot   TripleDot    = true
  eq (Name name) (Name name') = name == name'
  eq _ _                      = false

instance showPositionedToken :: Show PositionedToken where
  show (PositionedToken { sourcePos=pos, token=tok }) =
    (show tok) ++ " at " ++ (show pos)

parseTokens :: P.Parser String (L.List PositionedToken)
parseTokens = do
  P.skipSpaces
  L.many parsePositionedToken
  <* P.eof

parsePositionedToken :: P.Parser String PositionedToken
parsePositionedToken = P.try $ do
  pos <- getPosition
  tok <- parseToken
  return $ PositionedToken { sourcePos: pos, token: tok }

parseToken :: P.Parser String Token
parseToken = P.choice
  [ P.try $ P.char   '('   *> pure LParen
  , P.try $ P.char   ')'   *> pure RParen
  , P.try $ P.char   '['   *> pure LSquare
  , P.try $ P.char   ']'   *> pure RSquare
  , P.try $ P.char   '<'   *> pure LAngle
  , P.try $ P.char   '>'   *> pure RAngle
  , P.try $ P.char   '-'   *> pure Dash
  , P.try $ P.string "..." *> pure TripleDot
  , Name <$> parseName
  ] <* P.skipSpaces

 where
  parseName :: P.Parser String String
  parseName = fromCharArray <$> do
    A.cons
      <$> identStart
      <*> A.many identLetter

  identStart :: P.Parser String Char
  identStart = alpha

  identLetter :: P.Parser String Char
  identLetter = alphaNum <|> P.oneOf ['_', '-']

-- | Parser that  parses a stream of tokens
type TokenParser a = P.Parser (List PositionedToken) a

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> TokenParser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      case test tok of
        Just a ->
          let nextpos =
              case xs of
                Cons (PositionedToken { sourcePos: npos }) _ -> npos
                Nil -> ppos
          in
            { consumed: true
            , input: xs
            , result: Right a
            , position: nextpos }
        Nothing -> P.parseFailed toks pos "expected token, met EOF"
    _ -> P.parseFailed toks pos "expected token, met EOF"

-- | Match the token at the head of the stream
match :: forall a. Token -> TokenParser Unit
match tok = token (\tok' -> if (tok' == tok) then Just unit else Nothing)
            P.<?> prettyPrintToken tok

module Docopt.Parser.Lexer where

import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Token as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import qualified Data.List as L
import qualified Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray)
import Data.List (List(..), (:))
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Docopt.Parser.Base

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | LAngle
  | RAngle
  | TripleDot
  | Dash
  | Name String

prettyPrintToken :: Token -> String
prettyPrintToken LParen      = show '('
prettyPrintToken RParen      = show ')'
prettyPrintToken LSquare     = show '['
prettyPrintToken RSquare     = show ']'
prettyPrintToken LAngle      = show '<'
prettyPrintToken RAngle      = show '>'
prettyPrintToken Dash        = show '-'
prettyPrintToken TripleDot   = show "..."
prettyPrintToken (Name name) = show name

data PositionedToken = PositionedToken
  { sourcePos :: P.Position
  , token     :: Token
  }

instance showToken :: Show Token where
  show = show <<< prettyPrintToken

instance eqToken :: Eq Token where
  eq LParen      LParen       = true
  eq RParen      RParen       = true
  eq LSquare     LSquare      = true
  eq RSquare     RSquare      = true
  eq LAngle      LAngle       = true
  eq RAngle      RAngle       = true
  eq Dash        Dash         = true
  eq TripleDot   TripleDot    = true
  eq (Name name) (Name name') = name == name'
  eq _ _                      = false

instance showPositionedToken :: Show PositionedToken where
  show (PositionedToken { sourcePos=pos, token=tok }) =
    (show tok) ++ " at " ++ (show pos)

parseTokens :: P.Parser String (L.List PositionedToken)
parseTokens = do
  P.skipSpaces
  L.many parsePositionedToken
  <* P.eof

parsePositionedToken :: P.Parser String PositionedToken
parsePositionedToken = P.try $ do
  pos <- getPosition
  tok <- parseToken
  return $ PositionedToken { sourcePos: pos, token: tok }

parseToken :: P.Parser String Token
parseToken = P.choice
  [ P.try $ P.char   '('   *> pure LParen
  , P.try $ P.char   ')'   *> pure RParen
  , P.try $ P.char   '['   *> pure LSquare
  , P.try $ P.char   ']'   *> pure RSquare
  , P.try $ P.char   '<'   *> pure LAngle
  , P.try $ P.char   '>'   *> pure RAngle
  , P.try $ P.char   '-'   *> pure Dash
  , P.try $ P.string "..." *> pure TripleDot
  , Name <$> parseName
  ] <* P.skipSpaces

 where
  parseName :: P.Parser String String
  parseName = fromCharArray <$> do
    A.cons
      <$> identStart
      <*> A.many identLetter

  identStart :: P.Parser String Char
  identStart = alpha

  identLetter :: P.Parser String Char
  identLetter = alphaNum <|> P.oneOf ['_', '-']

type TokenParser a = P.Parser (List PositionedToken) a

token :: forall a. (Token -> Maybe a) -> TokenParser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      case test tok of
        Just a ->
          let nextpos =
              case xs of
                Cons (PositionedToken { sourcePos: npos }) _ -> npos
                Nil -> ppos
          in
            { consumed: true
            , input: xs
            , result: Right a
            , position: nextpos }
        Nothing -> P.parseFailed toks pos "expected token, met EOF"
    _ -> P.parseFailed toks pos "expected token, met EOF"

match :: forall a. Token -> TokenParser Unit
match tok = token (\tok' -> if (tok' == tok) then Just unit else Nothing)
            P.<?> prettyPrintToken tok


[SD-1340] show error dialog when file upload fails

{-
Copyright 2015 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module FileSystem
       ( module FileSystem.State
       , module FileSystem.Query
       , module FileSystem.Install
       , comp
       ) where

import Prelude

import Control.Alt ((<|>))
import Control.Bind (join)
import Control.Monad.Aff (attempt)
import Control.Monad.Eff.Exception (error, message)
import Control.Monad.Error.Class (throwError)
import Control.UI.Browser (setLocation, locationString, clearValue)
import Control.UI.Browser.Event as Be
import Control.UI.File as Cf

import Data.Array (head, last, mapMaybe, filter)
import Data.Either (Either(..), either)
import Data.Foldable (traverse_)
import Data.Functor.Aff (liftAff)
import Data.Functor.Coproduct (left, right)
import Data.Functor.Eff (liftEff)
import Data.Inject (prj)
import Data.Lens ((^.), (.~), preview)
import Data.Lens.Prism.Coproduct (_Left, _Right)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Path.Pathy (rootDir, (</>), dir, file)
import Data.String as S
import Data.URI (runParseAbsoluteURI)

import Halogen.Component
import Halogen.Component.ChildPath (injSlot, prjSlot, prjQuery, injQuery)
import Halogen.Component.Utils (applyCF)
import Halogen.HTML as H
import Halogen.HTML.Properties as P
import Halogen.Query (action, request, get, modify, gets)
import Halogen.Themes.Bootstrap3 as B

import Dialog.Download as Download
import Dialog.Mount as Mount
import Dialog.Rename as Rename

import FileSystem.Breadcrumbs as Breadcrumbs
import FileSystem.Common (Slam(), forceRerender')
import FileSystem.Dialog as Dialog
import FileSystem.Install
import FileSystem.Item as Item
import FileSystem.Items as Items
import FileSystem.Query
import FileSystem.Render
import FileSystem.Search as Search
import FileSystem.State

import Model.Notebook.Action (Action(..), AccessType(..))
import Model.Common (browseURL, mkNotebookURL)
import Model.Item (Item(..), itemResource, itemURL, openItem, sortItem)
import Model.Resource as R
import Model.Salt (newSalt)
import Model.Sort (notSort)

import Network.HTTP.MimeType.Common (textCSV)
import Quasar.Aff as API
import Render.Common
import Render.CssClasses as Rc
import Utils.DOM as D
import Utils.Path (DirPath())

comp :: Component StateP QueryP Slam
comp = parentComponent' render eval peek

render :: RenderParent State ChildState Query ChildQuery Slam ChildSlot
render state@(State r) =
  H.div [P.classes [ Rc.filesystem ] ]
         [ navbar
           [  H.div [ P.classes [ Rc.header, B.clearfix ] ]
              [ icon B.glyphiconFolderOpen Config.homeHash
              , logo (state ^. _version)
              , H.slot' cpSearch SearchSlot
                \_ -> { component: Search.comp
                      , initialState: Search.initialState r.sort  r.salt
                      }
              ]
           ]
         , content
           [ H.div [ P.class_ B.clearfix ]
             [ H.slot' cpBreadcrumbs (BreadcrumbsSlot r.path)
               \_ -> { component: Breadcrumbs.comp
                     , initialState: Breadcrumbs.mkBreadcrumbs r.path r.sort r.salt
                     }
             , toolbar state
             ]
           , row [ sorting state ]
           , H.slot' cpItems ItemsSlot
             \_ -> { component: Items.comp
                   , initialState: installedState $ Items.initialState
                   }
           ]
         , H.slot' cpDialog DialogSlot
           \_ -> { component: Dialog.comp
                 , initialState: installedState $ Dialog.initialState
                 }
         ]

eval :: EvalParent Query State ChildState Query ChildQuery Slam ChildSlot
eval (Resort next) = do
  searchValue <- query' cpSearch SearchSlot (request Search.GetValue)
  state <- get
  liftEff $ setLocation $ browseURL (searchValue >>= id)
    (notSort (state ^. _sort)) (state ^. _salt) (state ^. _path)
  pure next
eval (SetPath path next) = do
  modify (_path .~ path)
  pure next
eval (SetSort sort next) = do
  modify (_sort .~ sort)
  resort
  pure next
eval (SetSalt salt next) = do
  modify (_salt .~ salt)
  pure next
eval (SetIsMount isMount next) = do
  modify (_isMount .~ isMount)
  pure next
eval (ShowHiddenFiles next) = do
  modify (_showHiddenFiles .~ true)
  query' cpItems ItemsSlot $ left $ action $ Items.SetIsHidden false
  pure next
eval (HideHiddenFiles next) = do
  modify (_showHiddenFiles .~ false)
  query' cpItems ItemsSlot $ left $ action $ Items.SetIsHidden true
  pure next
eval (Configure next) = do
  state <- get
  let res = R.Database $ state ^. _path
  eiURI <- liftAff $ attempt (API.mountInfo res)
  configure (either (const Nothing) Just eiURI) res
  pure next
eval (MakeMount next) = do
  state <- get
  query' cpDialog DialogSlot $ left $ action
    $ Dialog.Show (Dialog.Mount (state ^. _path))
  pure next
eval (MakeFolder next) = do
  state <- get
  let path = state ^. _path
  dirName <- liftAff $ API.getNewName path Config.newFolderName
  let dirPath = path </> dir dirName
      dirRes = R.Directory dirPath
      dirItem = PhantomItem dirRes
      hiddenFile = dirPath </> file (Config.folderMark)
  query' cpItems ItemsSlot $ left $ action $ Items.Add dirItem
  added <- liftAff do
    attempt $ API.makeFile hiddenFile API.ldJSON "{}"
  query' cpItems ItemsSlot $ left $ action
    $ Items.Filter (/= dirItem)
  case added of
    Left err ->
      query' cpDialog DialogSlot $ left $ action
      $ Dialog.Show (Dialog.Error $ "There was a problem creating the directory: "
              <> message err)
    Right _ -> do
      query' cpItems ItemsSlot $ left $ action $ Items.Add $ Item dirRes
  pure next

eval (MakeNotebook next) = do
  path <- gets (^. _path)
  let newNotebookName = Config.newNotebookName <> "." <> Config.notebookExtension
  name <- liftAff $ API.getNewName path newNotebookName
  let uri = mkNotebookURL (path </> dir name) New
  liftEff $ setLocation uri
  pure next

eval (UploadFile el next) = do
  mbInput <- liftEff $ D.querySelector "input" el
  case mbInput of
    Nothing -> pure unit
    Just input -> void $ liftEff $ Be.raiseEvent "click" input
  pure next

eval (FileListChanged el next) = do
  fileArr <- map Cf.fileListToArray $ (liftAff $ Cf.files el)
  liftEff $ clearValue el
  case head fileArr of
    Nothing ->
      let err :: Slam Unit
          err = throwError $ error "empty filelist"
      in liftAff err
    Just f -> do
      state <- get
      let path = state ^. _path
      name <- liftAff $ liftEff (Cf.name f)
                >>= API.getNewName (state ^. _path)

      let fileName = path </> file name
          fileItem = PhantomItem $ R.File fileName
          ext = last (S.split "." name)
          mime = if ext == Just "csv"
                 then textCSV
                 else API.ldJSON
      reader <- liftEff Cf.newReaderEff
      content <- liftAff $ Cf.readAsBinaryString f reader
      query' cpItems ItemsSlot $ left $ action $ Items.Add fileItem
      f <- liftAff $ attempt $ API.makeFile fileName mime content
      case f of
        Left err -> do
          query' cpItems ItemsSlot $ left $ action
            $ Items.Filter (not <<< eq (R.File fileName) <<< itemResource)
          query' cpDialog DialogSlot $ left $ action
            $ Dialog.Show (Dialog.Error $ message err)
          pure unit
        Right _ ->
          liftEff $ setLocation
            $ itemURL (state ^. _sort) (state ^. _salt) Editable fileItem

  pure next

eval (Download next) = do
  state <- get
  download (R.Directory (state ^. _path))
  pure next

eval (SetVersion version next) = do
  modify (_version .~ Just version)
  pure next

peek :: forall a. ChildF ChildSlot ChildQuery a -> Algebra Unit
peek (ChildF p q) =
  fromMaybe (pure unit)
  $   (itemsPeek <$> prjSlot cpItems p <*> prjQuery cpItems q)
  <|> (searchPeek <$> prjSlot cpSearch p <*> prjQuery cpSearch q)
  <|> (dialogPeek <$> prjSlot cpDialog p <*> prjQuery cpDialog q)

dialogPeek :: forall a. DialogSlot -> Dialog.QueryP a -> Algebra Unit
dialogPeek s q =
  fromMaybe (pure unit)
  $   (applyCF dialogChildrenPeek <$> prj q)

dialogChildrenPeek ::
  forall a. Dialog.ChildSlot -> Dialog.ChildQuery a -> Algebra Unit
dialogChildrenPeek p q =
  fromMaybe (pure unit)
  $   (mountPeek <$> prjSlot Dialog.cpMount p <*> prjQuery Dialog.cpMount q)

mountPeek :: forall a. Dialog.MountSlot -> Mount.Query a -> Algebra Unit
mountPeek slot (Mount.Save _) = do
  saved <- query' cpDialog DialogSlot $ right
           $ ChildF (injSlot Dialog.cpMount slot)
           $ injQuery Dialog.cpMount (request Mount.GetSaved)
  case join saved of
    Nothing -> pure unit
    Just res ->
      void $ query' cpItems ItemsSlot $ left $ action $ Items.Add $ Item res
mountPeek _ _ = pure unit

itemsPeek :: forall a. ItemsSlot -> Items.QueryP a -> Algebra Unit
itemsPeek s q =
  fromMaybe (pure unit)
  $   (itemsPeek' s <$> preview _Left q)
  <|> (applyCF itemPeek <$> preview _Right q)

itemsPeek' :: forall a. ItemsSlot -> Items.Query a -> Algebra Unit
itemsPeek' _ (Items.Add _ _) = resort
itemsPeek' _ (Items.Adds _ _) = resort
itemsPeek' _ _ = pure unit

itemPeek :: forall a. Items.ItemSlot -> Item.Query a -> Algebra Unit
itemPeek slot (Item.Open _) = do
  mbit <- query' cpItems ItemsSlot $ right $ ChildF slot $ request Item.GetItem
  case mbit of
    Nothing -> pure unit
    Just it -> do
      state <- get
      liftEff $ openItem it (state ^. _sort) (state ^. _salt)
itemPeek slot (Item.Configure _) = do
  mbit <- query' cpItems ItemsSlot $ right $ ChildF slot $ request Item.GetItem
  case mbit of
    Nothing -> pure unit
    Just (PhantomItem _) -> pure unit
    Just item -> do
      mbURI <- map join
               $ query' cpItems ItemsSlot $ right $ ChildF slot $ request Item.GetURI
      configure mbURI (itemResource item)

itemPeek _ (Item.Move _) = do
  mbit <- query' cpItems ItemsSlot $ right $ ChildF slot $ request Item.GetItem
  case mbit of
    Nothing -> pure unit
    Just it -> void do
      query' cpDialog DialogSlot $ left $ action
        $ Dialog.Show (Dialog.Rename $ itemResource it)
      forceRerender'
      flip getDirectories rootDir \x ->
        void $ query' cpDialog DialogSlot $ right
        $ ChildF (injSlot Dialog.cpRename (itemResource it))
        $ injQuery Dialog.cpRename (action $ Rename.AddDirs x)

itemPeek _ (Item.Remove _) = do
  mbit <- query' cpItems ItemsSlot $ right $ ChildF slot $ request Item.GetItem
  case mbit of
    Nothing -> pure unit
    Just item -> void do
      let r = itemResource item
      mbTrashFolder <- liftAff $ API.delete r
      query' cpItems ItemsSlot $ left $ action
        $ Items.Filter (not <<< eq r <<< itemResource)
      maybe (pure unit) (\x -> void $ query' cpItems ItemsSlot $ left $ action
                               $ Items.Add $ Item x) mbTrashFolder
itemPeek _ (Item.Share _) = do
  mbit <- query' cpItems ItemsSlot $ right $ ChildF slot $ request Item.GetItem
  case mbit of
    Nothing -> pure unit
    Just item -> void do
      loc <- liftEff locationString
      state <- get
      let url = loc <> "/"
                <> itemURL (state ^. _sort) (state ^. _salt) ReadOnly item
      query' cpDialog DialogSlot $ left $ action
        $ Dialog.Show (Dialog.Share url)
itemPeek _ (Item.Download _) = do
  mbit <- query' cpItems ItemsSlot $ right $ ChildF slot $ request Item.GetItem
  case mbit of
    Nothing -> pure unit
    Just it -> download $ itemResource it
itemPeek _ _ = pure unit

searchPeek :: forall a. SearchSlot -> Search.Query a -> Algebra Unit
searchPeek _ (Search.Clear _) = do
  salt <- liftEff newSalt
  (State state) <- get
  liftEff $ setLocation
    $ browseURL Nothing state.sort salt state.path
searchPeek _ _ = pure unit

resort :: Algebra Unit
resort = do
  sort <- gets (^. _sort)
  mbIsSearching <- query' cpSearch SearchSlot (request Search.IsSearching)
  case mbIsSearching of
    Nothing -> pure unit
    Just isSearching ->
      void $ query' cpItems ItemsSlot $ left
      $ action (Items.SortBy $ sortItem isSearching sort)

configure :: Maybe String -> R.Resource -> Algebra Unit
configure Nothing _ = pure unit
configure (Just info) res@(R.Database _) = do
  void case runParseAbsoluteURI info of
    Left err -> do
      query' cpDialog DialogSlot $ left $ action
        $ Dialog.Show (Dialog.Error
                       $ "There was a problem reading the mount settings: "
                       <>  show err)
    Right uri -> do
      let parent = R.resourceDir res
          r = Mount.mountDialogFromURI res uri
      b <- query' cpDialog DialogSlot $ left $ action
        $ Dialog.Show (Dialog.Mount parent)
      forceRerender'
      a <- query' cpDialog DialogSlot $ right
        $ ChildF (injSlot Dialog.cpMount $ Dialog.MountSlot parent)
        $ injQuery Dialog.cpMount (action $ Mount.ModifyState (const r))
      pure $ pure unit
configure _ _ = pure unit

download :: R.Resource -> Algebra Unit
download res = do
  query' cpDialog DialogSlot $ left $ action
    $ Dialog.Show (Dialog.Download res)
  forceRerender'
  getChildren (const true)
    (\x -> void $ query' cpDialog DialogSlot $ right
           $ ChildF (injSlot Dialog.cpDownload res)
           $ injQuery Dialog.cpDownload (action $ Download.AddSources x))
    rootDir
  pure unit

getChildren :: (R.Resource -> Boolean)
               -> (Array R.Resource -> Algebra Unit)
               -> DirPath -> Algebra Unit
getChildren pred cont start = do
  forceRerender'
  ei <- liftAff $ attempt $ API.children start
  case ei of
    Right items -> do
      let items' = filter pred items
          parents = mapMaybe (either (const Nothing) Just <<< R.getPath) items
      cont items'
      traverse_ (getChildren pred cont) parents
    _ -> pure unit

getDirectories :: (Array R.Resource -> Algebra Unit) -> DirPath -> Algebra Unit
getDirectories = getChildren (\x -> R.isDirectory x || R.isDatabase x)

{-
Copyright 2015 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module FileSystem
       ( module FileSystem.State
       , module FileSystem.Query
       , module FileSystem.Install
       , comp
       ) where

import Prelude

import Control.Alt ((<|>))
import Control.Bind (join)
import Control.Monad.Aff (attempt)
import Control.Monad.Eff.Exception (error, message)
import Control.Monad.Error.Class (throwError)
import Control.UI.Browser (setLocation, locationString, clearValue)
import Control.UI.Browser.Event as Be
import Control.UI.File as Cf

import Data.Array (head, last, mapMaybe, filter)
import Data.Either (Either(..), either)
import Data.Foldable (traverse_)
import Data.Functor.Aff (liftAff)
import Data.Functor.Coproduct (left, right)
import Data.Functor.Eff (liftEff)
import Data.Inject (prj)
import Data.Lens ((^.), (.~), preview)
import Data.Lens.Prism.Coproduct (_Left, _Right)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Path.Pathy (rootDir, (</>), dir, file)
import Data.String as S
import Data.URI (runParseAbsoluteURI)

import Halogen.Component
import Halogen.Component.ChildPath (injSlot, prjSlot, prjQuery, injQuery)
import Halogen.Component.Utils (applyCF)
import Halogen.HTML as H
import Halogen.HTML.Properties as P
import Halogen.Query (action, request, get, modify, gets)
import Halogen.Themes.Bootstrap3 as B

import Dialog.Download as Download
import Dialog.Mount as Mount
import Dialog.Rename as Rename

import FileSystem.Breadcrumbs as Breadcrumbs
import FileSystem.Common (Slam(), forceRerender')
import FileSystem.Dialog as Dialog
import FileSystem.Install
import FileSystem.Item as Item
import FileSystem.Items as Items
import FileSystem.Query
import FileSystem.Render
import FileSystem.Search as Search
import FileSystem.State

import Model.Notebook.Action (Action(..), AccessType(..))
import Model.Common (browseURL, mkNotebookURL)
import Model.Item (Item(..), itemResource, itemURL, openItem, sortItem)
import Model.Resource as R
import Model.Salt (newSalt)
import Model.Sort (notSort)

import Network.HTTP.MimeType.Common (textCSV)
import Quasar.Aff as API
import Render.Common
import Render.CssClasses as Rc
import Utils.DOM as D
import Utils.Path (DirPath())

comp :: Component StateP QueryP Slam
comp = parentComponent' render eval peek

render :: RenderParent State ChildState Query ChildQuery Slam ChildSlot
render state@(State r) =
  H.div [P.classes [ Rc.filesystem ] ]
         [ navbar
           [  H.div [ P.classes [ Rc.header, B.clearfix ] ]
              [ icon B.glyphiconFolderOpen Config.homeHash
              , logo (state ^. _version)
              , H.slot' cpSearch SearchSlot
                \_ -> { component: Search.comp
                      , initialState: Search.initialState r.sort  r.salt
                      }
              ]
           ]
         , content
           [ H.div [ P.class_ B.clearfix ]
             [ H.slot' cpBreadcrumbs (BreadcrumbsSlot r.path)
               \_ -> { component: Breadcrumbs.comp
                     , initialState: Breadcrumbs.mkBreadcrumbs r.path r.sort r.salt
                     }
             , toolbar state
             ]
           , row [ sorting state ]
           , H.slot' cpItems ItemsSlot
             \_ -> { component: Items.comp
                   , initialState: installedState $ Items.initialState
                   }
           ]
         , H.slot' cpDialog DialogSlot
           \_ -> { component: Dialog.comp
                 , initialState: installedState $ Dialog.initialState
                 }
         ]

eval :: EvalParent Query State ChildState Query ChildQuery Slam ChildSlot
eval (Resort next) = do
  searchValue <- query' cpSearch SearchSlot (request Search.GetValue)
  state <- get
  liftEff $ setLocation $ browseURL (searchValue >>= id)
    (notSort (state ^. _sort)) (state ^. _salt) (state ^. _path)
  pure next
eval (SetPath path next) = do
  modify (_path .~ path)
  pure next
eval (SetSort sort next) = do
  modify (_sort .~ sort)
  resort
  pure next
eval (SetSalt salt next) = do
  modify (_salt .~ salt)
  pure next
eval (SetIsMount isMount next) = do
  modify (_isMount .~ isMount)
  pure next
eval (ShowHiddenFiles next) = do
  modify (_showHiddenFiles .~ true)
  query' cpItems ItemsSlot $ left $ action $ Items.SetIsHidden false
  pure next
eval (HideHiddenFiles next) = do
  modify (_showHiddenFiles .~ false)
  query' cpItems ItemsSlot $ left $ action $ Items.SetIsHidden true
  pure next
eval (Configure next) = do
  state <- get
  let res = R.Database $ state ^. _path
  eiURI <- liftAff $ attempt (API.mountInfo res)
  configure (either (const Nothing) Just eiURI) res
  pure next
eval (MakeMount next) = do
  state <- get
  query' cpDialog DialogSlot $ left $ action
    $ Dialog.Show (Dialog.Mount (state ^. _path))
  pure next
eval (MakeFolder next) = do
  state <- get
  let path = state ^. _path
  dirName <- liftAff $ API.getNewName path Config.newFolderName
  let dirPath = path </> dir dirName
      dirRes = R.Directory dirPath
      dirItem = PhantomItem dirRes
      hiddenFile = dirPath </> file (Config.folderMark)
  query' cpItems ItemsSlot $ left $ action $ Items.Add dirItem
  added <- liftAff do
    attempt $ API.makeFile hiddenFile API.ldJSON "{}"
  query' cpItems ItemsSlot $ left $ action
    $ Items.Filter (/= dirItem)
  case added of
    Left err ->
      query' cpDialog DialogSlot $ left $ action
      $ Dialog.Show (Dialog.Error $ "There was a problem creating the directory: "
              <> message err)
    Right _ -> do
      query' cpItems ItemsSlot $ left $ action $ Items.Add $ Item dirRes
  pure next

eval (MakeNotebook next) = do
  path <- gets (^. _path)
  let newNotebookName = Config.newNotebookName <> "." <> Config.notebookExtension
  name <- liftAff $ API.getNewName path newNotebookName
  let uri = mkNotebookURL (path </> dir name) New
  liftEff $ setLocation uri
  pure next

eval (UploadFile el next) = do
  mbInput <- liftEff $ D.querySelector "input" el
  case mbInput of
    Nothing -> pure unit
    Just input -> void $ liftEff $ Be.raiseEvent "click" input
  pure next

eval (FileListChanged el next) = do
  fileArr <- map Cf.fileListToArray $ (liftAff $ Cf.files el)
  liftEff $ clearValue el
  case head fileArr of
    Nothing ->
      let err :: Slam Unit
          err = throwError $ error "empty filelist"
      in liftAff err
    Just f -> do
      state <- get
      let path = state ^. _path
      name <- liftAff $ liftEff (Cf.name f)
                >>= API.getNewName (state ^. _path)

      let fileName = path </> file name
          fileItem = PhantomItem $ R.File fileName
          ext = last (S.split "." name)
          mime = if ext == Just "csv"
                 then textCSV
                 else API.ldJSON
      reader <- liftEff Cf.newReaderEff
      content <- liftAff $ Cf.readAsBinaryString f reader
      query' cpItems ItemsSlot $ left $ action $ Items.Add fileItem
      f <- liftAff $ attempt $ API.makeFile fileName mime content
      case f of
        Left err -> do
          query' cpItems ItemsSlot $ left $ action
            $ Items.Filter (not <<< eq (R.File fileName) <<< itemResource)
          pure unit
        Right _ ->
          liftEff $ setLocation
            $ itemURL (state ^. _sort) (state ^. _salt) Editable fileItem

  pure next
eval (Download next) = do
  state <- get
  download (R.Directory (state ^. _path))
  pure next

eval (SetVersion version next) = do
  modify (_version .~ Just version)
  pure next

peek :: forall a. ChildF ChildSlot ChildQuery a -> Algebra Unit
peek (ChildF p q) =
  fromMaybe (pure unit)
  $   (itemsPeek <$> prjSlot cpItems p <*> prjQuery cpItems q)
  <|> (searchPeek <$> prjSlot cpSearch p <*> prjQuery cpSearch q)
  <|> (dialogPeek <$> prjSlot cpDialog p <*> prjQuery cpDialog q)

dialogPeek :: forall a. DialogSlot -> Dialog.QueryP a -> Algebra Unit
dialogPeek s q =
  fromMaybe (pure unit)
  $   (applyCF dialogChildrenPeek <$> prj q)

dialogChildrenPeek ::
  forall a. Dialog.ChildSlot -> Dialog.ChildQuery a -> Algebra Unit
dialogChildrenPeek p q =
  fromMaybe (pure unit)
  $   (mountPeek <$> prjSlot Dialog.cpMount p <*> prjQuery Dialog.cpMount q)

mountPeek :: forall a. Dialog.MountSlot -> Mount.Query a -> Algebra Unit
mountPeek slot (Mount.Save _) = do
  saved <- query' cpDialog DialogSlot $ right
           $ ChildF (injSlot Dialog.cpMount slot)
           $ injQuery Dialog.cpMount (request Mount.GetSaved)
  case join saved of
    Nothing -> pure unit
    Just res ->
      void $ query' cpItems ItemsSlot $ left $ action $ Items.Add $ Item res
mountPeek _ _ = pure unit

itemsPeek :: forall a. ItemsSlot -> Items.QueryP a -> Algebra Unit
itemsPeek s q =
  fromMaybe (pure unit)
  $   (itemsPeek' s <$> preview _Left q)
  <|> (applyCF itemPeek <$> preview _Right q)

itemsPeek' :: forall a. ItemsSlot -> Items.Query a -> Algebra Unit
itemsPeek' _ (Items.Add _ _) = resort
itemsPeek' _ (Items.Adds _ _) = resort
itemsPeek' _ _ = pure unit

itemPeek :: forall a. Items.ItemSlot -> Item.Query a -> Algebra Unit
itemPeek slot (Item.Open _) = do
  mbit <- query' cpItems ItemsSlot $ right $ ChildF slot $ request Item.GetItem
  case mbit of
    Nothing -> pure unit
    Just it -> do
      state <- get
      liftEff $ openItem it (state ^. _sort) (state ^. _salt)
itemPeek slot (Item.Configure _) = do
  mbit <- query' cpItems ItemsSlot $ right $ ChildF slot $ request Item.GetItem
  case mbit of
    Nothing -> pure unit
    Just (PhantomItem _) -> pure unit
    Just item -> do
      mbURI <- map join
               $ query' cpItems ItemsSlot $ right $ ChildF slot $ request Item.GetURI
      configure mbURI (itemResource item)

itemPeek _ (Item.Move _) = do
  mbit <- query' cpItems ItemsSlot $ right $ ChildF slot $ request Item.GetItem
  case mbit of
    Nothing -> pure unit
    Just it -> void do
      query' cpDialog DialogSlot $ left $ action
        $ Dialog.Show (Dialog.Rename $ itemResource it)
      forceRerender'
      flip getDirectories rootDir \x ->
        void $ query' cpDialog DialogSlot $ right
        $ ChildF (injSlot Dialog.cpRename (itemResource it))
        $ injQuery Dialog.cpRename (action $ Rename.AddDirs x)

itemPeek _ (Item.Remove _) = do
  mbit <- query' cpItems ItemsSlot $ right $ ChildF slot $ request Item.GetItem
  case mbit of
    Nothing -> pure unit
    Just item -> void do
      let r = itemResource item
      mbTrashFolder <- liftAff $ API.delete r
      query' cpItems ItemsSlot $ left $ action
        $ Items.Filter (not <<< eq r <<< itemResource)
      maybe (pure unit) (\x -> void $ query' cpItems ItemsSlot $ left $ action
                               $ Items.Add $ Item x) mbTrashFolder
itemPeek _ (Item.Share _) = do
  mbit <- query' cpItems ItemsSlot $ right $ ChildF slot $ request Item.GetItem
  case mbit of
    Nothing -> pure unit
    Just item -> void do
      loc <- liftEff locationString
      state <- get
      let url = loc <> "/"
                <> itemURL (state ^. _sort) (state ^. _salt) ReadOnly item
      query' cpDialog DialogSlot $ left $ action
        $ Dialog.Show (Dialog.Share url)
itemPeek _ (Item.Download _) = do
  mbit <- query' cpItems ItemsSlot $ right $ ChildF slot $ request Item.GetItem
  case mbit of
    Nothing -> pure unit
    Just it -> download $ itemResource it
itemPeek _ _ = pure unit

searchPeek :: forall a. SearchSlot -> Search.Query a -> Algebra Unit
searchPeek _ (Search.Clear _) = do
  salt <- liftEff newSalt
  (State state) <- get
  liftEff $ setLocation
    $ browseURL Nothing state.sort salt state.path
searchPeek _ _ = pure unit

resort :: Algebra Unit
resort = do
  sort <- gets (^. _sort)
  mbIsSearching <- query' cpSearch SearchSlot (request Search.IsSearching)
  case mbIsSearching of
    Nothing -> pure unit
    Just isSearching ->
      void $ query' cpItems ItemsSlot $ left
      $ action (Items.SortBy $ sortItem isSearching sort)

configure :: Maybe String -> R.Resource -> Algebra Unit
configure Nothing _ = pure unit
configure (Just info) res@(R.Database _) = do
  void case runParseAbsoluteURI info of
    Left err -> do
      query' cpDialog DialogSlot $ left $ action
        $ Dialog.Show (Dialog.Error
                       $ "There was a problem reading the mount settings: "
                       <>  show err)
    Right uri -> do
      let parent = R.resourceDir res
          r = Mount.mountDialogFromURI res uri
      b <- query' cpDialog DialogSlot $ left $ action
        $ Dialog.Show (Dialog.Mount parent)
      forceRerender'
      a <- query' cpDialog DialogSlot $ right
        $ ChildF (injSlot Dialog.cpMount $ Dialog.MountSlot parent)
        $ injQuery Dialog.cpMount (action $ Mount.ModifyState (const r))
      pure $ pure unit
configure _ _ = pure unit

download :: R.Resource -> Algebra Unit
download res = do
  query' cpDialog DialogSlot $ left $ action
    $ Dialog.Show (Dialog.Download res)
  forceRerender'
  getChildren (const true)
    (\x -> void $ query' cpDialog DialogSlot $ right
           $ ChildF (injSlot Dialog.cpDownload res)
           $ injQuery Dialog.cpDownload (action $ Download.AddSources x))
    rootDir
  pure unit

getChildren :: (R.Resource -> Boolean)
               -> (Array R.Resource -> Algebra Unit)
               -> DirPath -> Algebra Unit
getChildren pred cont start = do
  forceRerender'
  ei <- liftAff $ attempt $ API.children start
  case ei of
    Right items -> do
      let items' = filter pred items
          parents = mapMaybe (either (const Nothing) Just <<< R.getPath) items
      cont items'
      traverse_ (getChildren pred cont) parents
    _ -> pure unit

getDirectories :: (Array R.Resource -> Algebra Unit) -> DirPath -> Algebra Unit
getDirectories = getChildren (\x -> R.isDirectory x || R.isDatabase x)