changed int-test, added tests for infix-notation

module Test.Parser where

import Prelude (class Eq, class Show, Unit, (++), ($), bind, show, unit, return, (==), (<<<), negate)
import Data.Either (Either(..))
import Data.List (List(..), toList, singleton)

import Text.Parsing.Parser  (Parser, ParseError(ParseError), runParser)

import Control.Monad.Writer (Writer, tell)

import AST (Atom(..), Binding(..), Definition(Def), Expr(..), Op(..))
import Parser (expression, atom, definitions, definition, binding, variable, bool, int)

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

test :: forall a. (Show a, Eq a) => String -> Parser String a -> String -> a -> Writer (List String) Unit
test name p input expected = case runParser input p of
  Left  (ParseError { position = p, message = m }) -> tell' $ "Parse fail (" ++ name ++ "): " ++ show p ++ " " ++ m
  Right result           ->
    if result == expected
      then return unit --tell $ "Parse success (" ++ name ++ ")"
      else tell' $ "Parse fail (" ++ name ++ "): " ++ show result ++ " /= " ++ show expected

aint :: Int -> Expr
aint i = Atom $ AInt i

abool :: Boolean -> Expr
abool = Atom <<< Bool

aname :: String -> Expr
aname s = Atom $ Name s

runTests :: Writer (List String) Unit
runTests = do
  test "0" int "0" (AInt 0)
  test "1" int "1" (AInt 1)
  test "all" int "0123456789" (AInt 123456789)
  test "high" int "2147483647" (AInt 2147483647)
  test "overflow" int "2147483648" (AInt (negate 2147483648))

  test "bool1" bool "True" (Bool true)
  test "bool2" bool "False" (Bool false)

  test "a" variable "a" (Name "a")
  test "lower" variable "a_bcdefghijklmnopqrstuvwxyz_" (Name "a_bcdefghijklmnopqrstuvwxyz_")
  test "upper" variable "a'BCDEFGHIJKLMNOPQRSTUVWXYZ'" (Name "a'BCDEFGHIJKLMNOPQRSTUVWXYZ'")
  test "special" variable "_____''''" (Name "_____''''")
  test "with_numbers1" variable "a1" (Name "a1")

  test "composition" expression "f . g" (Binary Composition (aname "f") (aname "g"))
  test "power" expression "2 ^ 10" (Binary Power (aint 2) (aint 10))
  test "mul" expression "2 * 2" (Binary Mul (aint 2) (aint 2))
  test "div" expression "13 `div` 3" (Binary Div (aint 13) (aint 3))
  test "mod" expression "13 `mod` 3" (Binary Mod (aint 13) (aint 3))
  test "add1" expression "1 + 1"  (Binary Add (aint 1) (aint 1))
  test "add2" expression "2+2" (Binary Add (aint 2) (aint 2))
  test "sub" expression "5 - 3" (Binary Sub (aint 5) (aint 3))
  test "colon" expression "x:xs" (Binary Colon (aname "x") (aname "xs"))
  test "append1" expression "xs ++ ys" (Binary Append (aname "xs") (aname "ys"))
  test "append2" expression "xs++ys"  (Binary Append (aname "xs") (aname "ys"))
  test "equ" expression "5 == 5" (Binary Equ (aint 5) (aint 5))
  test "neq" expression "1 /= 2" (Binary Neq (aint 1) (aint 2))
  test "lt1" expression "1 < 234" (Binary Lt (aint 1) (aint 234))
  test "lt2" expression "x<y" (Binary Lt (aname "x") (aname "y"))
  test "leq" expression "1 <= 234" (Binary Leq (aint 1) (aint 234))
  test "gt1" expression "567 > 1" (Binary Gt (aint 567) (aint 1))
  test "gt2" expression "x>y" (Binary Gt (aname "x") (aname "y"))
  test "geq" expression "567 >= 1" (Binary Geq (aint 567) (aint 1))
  test "and" expression "hot && cold" (Binary And (aname "hot") (aname "cold"))
  test "or" expression "be || notBe" (Binary Or (aname "be") (aname "notBe"))
  test "dollar" expression "f $ 1 + 2"  (Binary Dollar (aname "f") (Binary Add (aint 1) (aint 2)))

  test "unary_minus1" expression "- 10"  (aint (-10))
  test "unary_minus2" expression "- x"  (Unary Sub (aname "x"))
  test "unary_minus3" expression "-10"  (aint (-10))
  test "unary_minus4" expression "-x"  (Unary Sub (aname "x"))

  test "infix_operator1" expression "1 `max` 3" (App (aname ("max")) (toList [aint 1, aint 3]))
  test "infix_operator2" expression "5 `max` 2 `min` 1" (App (aname ("min")) (toList [App (aname ("max")) (toList [aint 5, aint 2]), aint 1]))
  test "infix_operator3" expression "True`tight`False" (App (aname ("tight")) (toList [abool true, abool false]))

  test "1" expression "1" (aint 1)
  test "add" expression "1 + 2" (Binary Add (aint 1) (aint 2))
  test "precedence" expression "1 * 2 + 3 * 4" (Binary Add
                                    (Binary Mul (aint 1) (aint 2))
                                    (Binary Mul (aint 3) (aint 4)))
  test "whitespaces" expression
    "1   \t   -    \t   ( f   )    \t\t\t\t                                                                \t\t\t\t             `div`     _ignore"
    (Binary Sub (aint 1) (Binary Div (aname "f") (aname "_ignore")))
  test "brackets" expression "(  1  +  2  )  *  3" (Binary Mul (Binary Add (aint 1) (aint 2)) (aint 3))
  test "brackets2" expression "( (  1  +  2  - 3  )  *  4 * 5 * 6)"
    (Binary Mul
      (Binary Mul
        (Binary Mul
          (Binary Sub
            (Binary Add (aint 1) (aint 2))
            (aint 3))
          (aint 4))
        (aint 5))
      (aint 6))
  test "brackets3" expression "( ( ( 1 ) ) )" (aint 1)
  test "many brackets" expression "(   (( ((  f )) *  ( (17   )) ) ))" (Binary Mul (aname "f") (aint 17))

  test "if_then_else" expression "if x then y else z" (IfExpr (aname "x") (aname "y") (aname "z"))
  test "nested if" expression "if(if 1 then 2 else 3)then y else z" (IfExpr (IfExpr (aint 1) (aint 2) (aint 3)) (aname "y") (aname "z"))
  test "iffy1" expression "iffy" (aname "iffy")
  test "iffy2" expression "if 10 + 20 then iffy * iffy else ((7))"
    (IfExpr
      (Binary Add (aint 10) (aint 20))
      (Binary Mul (aname "iffy") (aname "iffy"))
      (aint 7))
  test "iffy3" expression "iffy + if iffy then iffy else iffy"
    (Binary Add (aname "iffy") (IfExpr (aname "iffy") (aname "iffy") (aname "iffy")))
  test "nested if 2" expression "if if x then y else z then if a then b else c else if i then j else k"
    (IfExpr
      (IfExpr (aname "x") (aname "y") (aname "z"))
      (IfExpr (aname "a") (aname "b") (aname "c"))
      (IfExpr (aname "i") (aname "j") (aname "k")))
  test "if2" expression "if bool then False else True" (IfExpr (aname "bool") (Atom (Bool false)) (Atom (Bool true)))

  test "apply1" expression "f 1" (App (aname "f") (singleton (aint 1)))
  test "apply2" expression "f x y z 12 (3 + 7)"
    (App (aname "f") (toList [aname "x", aname "y", aname "z", aint 12, Binary Add (aint 3) (aint 7)]))
  test "fibonacci" expression "fib (n - 1) + fib (n - 2)"
    (Binary Add
      (App (aname "fib") (toList [Binary Sub (aname "n") (aint 1)]))
      (App (aname "fib") (toList [Binary Sub (aname "n") (aint 2)])))
  test "predicate" expression "if p 10 then 10 else 20"
    (IfExpr
      (App (aname "p") (singleton (aint 10)))
      (aint 10)
      (aint 20))
  test "stuff" expression "f a (1 * 2) * 3"
    (Binary Mul
      (App (aname "f") (toList [aname "a", Binary Mul (aint 1) (aint 2)]))
      (aint 3))

  test "tuple" expression "(1, 2)" (NTuple (toList [aint 1, aint 2]))
  test "3tuple" expression "(1, 2, 3)" (NTuple (toList [aint 1, aint 2, aint 3]))
  test "4tuple" expression "(1, 2, 3, 4)" (NTuple (toList [aint 1, aint 2, aint 3, aint 4]))
  test "tuple_spaces" expression "(   1   , 2   )" (NTuple (toList [aint 1, aint 2]))
  test "3tuple_spaces" expression "(  1   , 2    , 3     )" (NTuple (toList [aint 1, aint 2, aint 3]))
  test "tuple_arith" expression "((1 + 2, (3)))" (NTuple (toList [Binary Add (aint 1) (aint 2), aint 3]))
  test "tuple_apply" expression "fmap f (snd (1,2), fst ( 1 , 2 ))"
    (App (aname "fmap") (toList
      [ (aname "f")
      , NTuple (toList
        [ App (aname "snd") (toList [NTuple (toList [aint 1, aint 2])])
        , App (aname "fst") (toList [NTuple (toList [aint 1, aint 2])])
        ])
      ]
    ))
  test "tuple_deep" expression "((((( ((((((1)),((2))),(3,((((4)))))),((5,6),(7,8))),(((9,(10)),(((11,12)))),((((13,14),(14,15)))))) )))))"
    (NTuple (Cons
      (NTuple (Cons
        (NTuple (Cons
          (NTuple (Cons (Atom (AInt 1)) (Cons (Atom (AInt 2)) (Nil))))
          (Cons (NTuple (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))) (Nil))))
        (Cons (NTuple
          (Cons (NTuple (Cons (Atom (AInt 5)) (Cons (Atom (AInt 6)) (Nil))))
            (Cons (NTuple (Cons (Atom (AInt 7)) (Cons (Atom (AInt 8)) (Nil)))) (Nil)))) (Nil))))
      (Cons (NTuple (Cons (NTuple (Cons (NTuple (Cons (Atom (AInt 9)) (Cons (Atom (AInt 10)) (Nil))))
        (Cons (NTuple (Cons (Atom (AInt 11)) (Cons (Atom (AInt 12)) (Nil)))) (Nil))))
      (Cons (NTuple (Cons (NTuple (Cons (Atom (AInt 13)) (Cons (Atom (AInt 14)) (Nil))))
        (Cons (NTuple (Cons (Atom (AInt 14)) (Cons (Atom (AInt 15)) (Nil)))) (Nil)))) (Nil)))) (Nil))))

  test "list_empty" expression "[]" (List Nil)
  test "list1" expression "[1]" (List (toList [aint 1]))
  test "list2" expression "[  1  ]" (List (toList [aint 1]))
  test "list3" expression "[  1  ,2,3,     4    ,  5  ]" (List (toList [aint 1, aint 2, aint 3, aint 4, aint 5]))
  test "list_nested" expression "[ [1,2] , [ 3 , 4 ] ]" (List $ toList [(List $ toList [aint 1, aint 2]), (List $ toList [aint 3, aint 4])])
  test "list_complex" expression "[ 1 + 2 , 3 + 4 ] ++ []"
    (Binary Append
      (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
      (List Nil))

  test "binding_lit1" binding "x" (Lit (Name "x"))
  test "binding_lit2" binding "10" (Lit (AInt 10))
  test "lambda1" expression "(\\x -> x)" (Lambda (toList [Lit (Name "x")]) (aname "x"))
  test "lambda2" expression "( \\ x y z -> ( x , y , z ) )"
    (Lambda (toList [Lit (Name "x"), Lit (Name "y"), Lit (Name "z")])
      (NTuple (toList [aname "x", aname "y", aname "z"])))
  test "lambda3" expression "(  \\  x ->   (   \\    y ->    (   \\    z ->     f   x   y   z )  )  )"
    (Lambda (singleton $ Lit $ Name "x")
      (Lambda (singleton $ Lit $ Name "y")
        (Lambda (singleton $ Lit $ Name "z")
          (App (aname "f") (toList [aname "x", aname "y", aname "z"])))))
  test "lambda4" expression "(\\a b -> a + b) 1 2"
    (App
      (Lambda (toList [Lit (Name "a"), Lit (Name "b")])
        (Binary Add (aname "a") (aname "b")))
      (toList [aint 1, aint 2]))

  test "lambda5" expression "(\\a -> (\\b -> (\\c -> (\\d -> (\\e -> (\\f -> (\\g -> a + b + c + d + e + f + g))))))) 1 2 3 4 5 6 7"
    (App
      (Lambda (Cons (Lit (Name "a")) (Nil))
        (Lambda (Cons (Lit (Name "b")) (Nil))
          (Lambda (Cons (Lit (Name "c")) (Nil))
            (Lambda (Cons (Lit (Name "d")) (Nil))
              (Lambda (Cons (Lit (Name "e")) (Nil))
                (Lambda (Cons (Lit (Name "f")) (Nil))
                  (Lambda (Cons (Lit (Name "g")) (Nil))
                    (Binary Add
                      (Binary Add
                        (Binary Add
                          (Binary Add
                            (Binary Add
                              (Binary Add (Atom (Name "a")) (Atom (Name "b")))
                              (Atom (Name "c")))
                            (Atom (Name "d")))
                          (Atom (Name "e")))
                        (Atom (Name "f")))
                      (Atom (Name "g"))))))))))
      (Cons (Atom (AInt 1)) (Cons (Atom (AInt 2)) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Cons (Atom (AInt 5)) (Cons (Atom (AInt 6)) (Cons (Atom (AInt 7)) (Nil)))))))))

  test "sectR1" expression "(+1)" (SectR Add (aint 1))
  test "sectR2" expression "( ^ 2 )" (SectR Power (aint 2))
  test "sectR3" expression "(++ [1])" (SectR Append (List (toList [aint 1])))
  test "sectR4" expression "(<= (2 + 2))" (SectR Leq (Binary Add (aint 2) (aint 2)))
  test "sectR5" expression "(   >=  (  2 + 2  )  )" (SectR Geq (Binary Add (aint 2) (aint 2)))

  test "prefixOp1" expression "(+)" (PrefixOp Add)
  test "prefixOp2" expression "( ++ )" (PrefixOp Append)
  test "prefixOp3" expression "((^) 2 10)" (App (PrefixOp Power) (toList [aint 2, aint 10]))

  test "sectL1" expression "(1+)" (SectL (aint 1) Add)
  test "sectL2" expression "( n `mod` )" (SectL (aname "n") Mod)
  test "sectL3" expression "([1] ++)" (SectL (List $ toList [aint 1]) Append)
  test "sectL4" expression "(   ( 2 +  2 )  <= )" (SectL (Binary Add (aint 2) (aint 2)) Leq)

  test "let1" expression "let x = 1 in x + x" (LetExpr (Lit (Name "x")) (aint 1) (Binary Add (aname "x") (aname "x")))
  test "let2" expression "letty + let x = 1 in x" (Binary Add (aname "letty") (LetExpr (Lit (Name "x")) (aint 1) (aname "x")))
  test "let3" expression "let x = let y = 1 in y in let z = 2 in x + z"
    (LetExpr
      (Lit (Name "x"))
      (LetExpr
        (Lit (Name "y"))
        (aint 1)
        (aname "y"))
      (LetExpr
        (Lit (Name "z"))
        (aint 2)
        (Binary Add (aname "x") (aname "z"))))

  test "consLit1" binding "(x:xs)" (ConsLit (Lit (Name "x")) (Lit (Name "xs")))
  test "consLit2" binding "(x:(y:zs))" (ConsLit (Lit (Name "x")) (ConsLit (Lit (Name "y")) (Lit (Name "zs"))))
  test "consLit3" binding "(  x  :  (  666  :  zs  )   )" (ConsLit (Lit (Name "x")) (ConsLit (Lit (AInt 666)) (Lit (Name "zs"))))

  test "listLit1" binding "[]" (ListLit Nil)
  test "listLit2" binding "[    ]" (ListLit Nil)
  test "listLit3" binding "[  True ]" (ListLit (Cons (Lit (Bool true)) Nil))
  test "listLit4" binding "[  x   ,  y  ,   1337 ]" (ListLit (toList [Lit (Name "x"), Lit (Name "y"), Lit (AInt 1337)]))

  test "tupleLit1" binding "(a,b)" (NTupleLit (toList [Lit (Name "a"), Lit (Name "b")]))
  test "tupleLit2" binding "(   a   ,  b   ,   c   )" (NTupleLit (toList $ [Lit (Name "a"), Lit (Name "b"), Lit (Name "c")]))
  test "tupleLit3" binding "(  (  x  ,  y  )  , ( a  ,  b  )  , 10 )"
    (NTupleLit (toList
      [ NTupleLit (toList [Lit (Name "x"), Lit (Name "y")])
      , NTupleLit (toList [Lit (Name "a"), Lit (Name "b")])
      , (Lit (AInt 10))
      ]))

  test "binding" binding "( ( x , y ) : [ a , b ] )"
    (ConsLit
      (NTupleLit (toList [Lit (Name "x"), Lit (Name "y")]))
      (ListLit (toList [Lit (Name "a"), Lit (Name "b")])))

  test "def1" definition "x = 10" (Def "x" Nil (aint 10))
  test "def2" definition "double x = x + x" (Def "double" (Cons (Lit (Name "x")) Nil) (Binary Add (aname "x") (aname "x")))
  test "def3" definition "zip (x:xs) (y:ys) = (x,y) : zip xs ys"
    (Def "zip"
      (toList [ConsLit (Lit (Name "x")) (Lit (Name "xs")), ConsLit (Lit (Name "y")) (Lit (Name "ys"))])
      (Binary Colon
        (NTuple (toList  [Atom (Name "x"), Atom (Name "y")]))
        (App (aname "zip") (toList [Atom (Name "xs"), Atom (Name "ys")]))))

  test "defs" definitions "\n\na   =   10 \n  \n \nb    =  20  \n\n  \n"
    (toList [Def "a" Nil (aint 10), Def "b" Nil (aint 20)])

  test "prelude" definitions prelude parsedPrelude
  test "expression" expression "sum (map (^2) [1, 2, 3, 4])"
    (App
      (Atom (Name "sum"))
      (Cons
        (App
          (Atom (Name "map"))
          (Cons (SectR Power (Atom (AInt 2)))
            (Cons (List (Cons (Atom (AInt 1)) (Cons (Atom (AInt 2)) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil))))))
              (Nil))))
        (Nil)))

  test "char_atom1" atom "'a'" (Char "a")
  test "char_atom2" atom "'\\\\'" (Char "\\")
  test "char_atom3" atom "'\\n'" (Char "\n")
  test "char_expr1" expression "'\\r'" (Atom (Char "\r"))
  test "char_expr2" expression "['\\\\', '\\'', '\\\"']" (List $ toList [Atom (Char "\\"), Atom (Char "'"), Atom (Char "\"")])

  test "string1" expression "\"asdf\"" (List $ toList [Atom (Char "a"), Atom (Char "s"), Atom (Char "d"), Atom (Char "f")])
  test "string2" expression "\"\\\\\\n\\\"\\\'\"" (List $ toList [Atom (Char "\\"), Atom (Char "\n"), Atom (Char "\""), Atom (Char "'")])

prelude :: String
prelude =
  "and (True:xs)  = and xs\n" ++
  "and (False:xs) = False\n" ++
  "and []         = True\n" ++
  "\n" ++
  "or (False:xs) = or xs\n" ++
  "or (True:xs)  = True\n" ++
  "or []         = False\n" ++
  "\n" ++
  "all p = and . map p\n" ++
  "any p = or . map p\n" ++
  "\n" ++
  "head (x:xs) = x\n" ++
  "tail (x:xs) = xs\n" ++
  "\n" ++
  "take 0 xs     = []\n" ++
  "take n (x:xs) = x : take (n - 1) xs\n" ++
  "\n" ++
  "drop 0 xs     = xs\n" ++
  "drop n (x:xs) = drop (n - 1) xs\n" ++
  "\n" ++
  "elem e []     = False\n" ++
  "elem e (x:xs) = if e == x then True else elem e xs\n" ++
  "\n" ++
  "max a b = if a >= b then a else b\n" ++
  "min a b = if b >= a then a else b\n" ++
  "\n" ++
  "maximum (x:xs) = foldr max x xs\n" ++
  "minimum (x:xs) = foldr min x xs\n" ++
  "\n" ++
  "length []     = 0\n" ++
  "length (x:xs) = 1 + length xs\n" ++
  "\n" ++
  "zip (x:xs) (y:ys) = (x, y) : zip xs ys\n" ++
  "zip []      _     = []\n" ++
  "zip _       []    = []\n" ++
  "\n" ++
  "zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\n" ++
  "zipWith _ []     _      = []\n" ++
  "zipWith _ _      []     = []\n" ++
  "\n" ++
  "unzip []          = ([], [])\n" ++
  "unzip ((a, b):xs) = (\\(as, bs) -> (a:as, b:bs)) $ unzip xs\n" ++
  "\n" ++
  "fst (x,_) = x\n" ++
  "snd (_,x) = x\n" ++
  "\n" ++
  "curry f a b = f (a, b)\n" ++
  "uncurry f (a, b) = f a b\n" ++
  "\n" ++
  "repeat x = x : repeat x\n" ++
  "\n" ++
  "replicate 0 _ = []\n" ++
  "replicate n x = x : replicate (n - 1) x\n" ++
  "\n" ++
  "enumFromTo a b = if a <= b then a : enumFromTo (a + 1) b else []\n" ++
  "\n" ++
  "sum (x:xs) = x + sum xs\n" ++
  "sum [] = 0\n" ++
  "\n" ++
  "product (x:xs) = x * product xs\n" ++
  "product [] = 1\n" ++
  "\n" ++
  "reverse []     = []\n" ++
  "reverse (x:xs) = reverse xs ++ [x]\n" ++
  "\n" ++
  "concat = foldr (++) []\n" ++
  "\n" ++
  "map f []     = []\n" ++
  "map f (x:xs) = f x : map f xs\n" ++
  "\n" ++
  "not True  = False\n" ++
  "not False = True\n" ++
  "\n" ++
  "filter p (x:xs) = if p x then x : filter p xs else filter p xs\n" ++
  "filter p []     = []\n" ++
  "\n" ++
  "foldr f ini []     = ini\n" ++
  "foldr f ini (x:xs) = f x (foldr f ini xs)\n" ++
  "\n" ++
  "foldl f acc []     = acc\n" ++
  "foldl f acc (x:xs) = foldl f (f acc x) xs\n" ++
  "\n" ++
  "scanl f b []     = [b]\n" ++
  "scanl f b (x:xs) = b : scanl f (f b x) xs\n" ++
  "\n" ++
  "iterate f x = x : iterate f (f x)\n" ++
  "\n" ++
  "id x = x\n" ++
  "\n" ++
  "const x _ = x\n" ++
  "\n" ++
  "flip f x y = f y x\n" ++
  "\n" ++
  "even n = (n `mod` 2) == 0\n" ++
  "odd n = (n `mod` 2) == 1\n" ++
  "\n" ++
  "fix f = f (fix f)\n"

parsedPrelude :: List Definition
parsedPrelude = toList [
  (Def "and" (Cons (ConsLit (Lit (Bool true)) (Lit (Name "xs"))) (Nil)) (App (Atom (Name "and")) (Cons (Atom (Name "xs")) (Nil)))),
  (Def "and" (Cons (ConsLit (Lit (Bool false)) (Lit (Name "xs"))) (Nil)) (Atom (Bool false))),
  (Def "and" (Cons (ListLit (Nil)) (Nil)) (Atom (Bool true))),
  (Def "or" (Cons (ConsLit (Lit (Bool false)) (Lit (Name "xs"))) (Nil)) (App (Atom (Name "or")) (Cons (Atom (Name "xs")) (Nil)))),
  (Def "or" (Cons (ConsLit (Lit (Bool true)) (Lit (Name "xs"))) (Nil)) (Atom (Bool true))),
  (Def "or" (Cons (ListLit (Nil)) (Nil)) (Atom (Bool false))),
  (Def "all" (Cons (Lit (Name "p")) (Nil)) (Binary Composition (Atom (Name "and")) (App (Atom (Name "map")) (Cons (Atom (Name "p")) (Nil))))),
  (Def "any" (Cons (Lit (Name "p")) (Nil)) (Binary Composition (Atom (Name "or")) (App (Atom (Name "map")) (Cons (Atom (Name "p")) (Nil))))),
  (Def "head" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)) (Atom (Name "x"))),
  (Def "tail" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)) (Atom (Name "xs"))),
  (Def "take" (Cons (Lit (AInt 0)) (Cons (Lit (Name "xs")) (Nil))) (List (Nil))),
  (Def "take" (Cons (Lit (Name "n")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil))) (Binary Colon (Atom (Name "x")) (App (Atom (Name "take")) (Cons (Binary Sub (Atom (Name "n")) (Atom (AInt 1))) (Cons (Atom (Name "xs")) (Nil)))))),
  (Def "drop" (Cons (Lit (AInt 0)) (Cons (Lit (Name "xs")) (Nil))) (Atom (Name "xs"))),
  (Def "drop" (Cons (Lit (Name "n")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil))) (App (Atom (Name "drop")) (Cons (Binary Sub (Atom (Name "n")) (Atom (AInt 1))) (Cons (Atom (Name "xs")) (Nil))))),
  (Def "elem" (Cons (Lit (Name "e")) (Cons (ListLit (Nil)) (Nil))) (Atom (Bool false))),
  (Def "elem" (Cons (Lit (Name "e")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil))) (IfExpr (Binary Equ (Atom (Name "e")) (Atom (Name "x"))) (Atom (Bool true)) (App (Atom (Name "elem")) (Cons (Atom (Name "e")) (Cons (Atom (Name "xs")) (Nil)))))),
  (Def "max" (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil))) (IfExpr (Binary Geq (Atom (Name "a")) (Atom (Name "b"))) (Atom (Name "a")) (Atom (Name "b")))),
  (Def "min" (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil))) (IfExpr (Binary Geq (Atom (Name "b")) (Atom (Name "a"))) (Atom (Name "a")) (Atom (Name "b")))),
  (Def "maximum" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)) (App (Atom (Name "foldr")) (Cons (Atom (Name "max")) (Cons (Atom (Name "x")) (Cons (Atom (Name "xs")) (Nil)))))),
  (Def "minimum" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)) (App (Atom (Name "foldr")) (Cons (Atom (Name "min")) (Cons (Atom (Name "x")) (Cons (Atom (Name "xs")) (Nil)))))),
  (Def "length" (Cons (ListLit (Nil)) (Nil)) (Atom (AInt 0))),
  (Def "length" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)) (Binary Add (Atom (AInt 1)) (App (Atom (Name "length")) (Cons (Atom (Name "xs")) (Nil))))),
  (Def "zip" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Cons (ConsLit (Lit (Name "y")) (Lit (Name "ys"))) (Nil))) (Binary Colon (NTuple (Cons (Atom (Name "x")) (Cons (Atom (Name "y")) (Nil)))) (App (Atom (Name "zip")) (Cons (Atom (Name "xs")) (Cons (Atom (Name "ys")) (Nil)))))),
  (Def "zip" (Cons (ListLit (Nil)) (Cons (Lit (Name "_")) (Nil))) (List (Nil))),
  (Def "zip" (Cons (Lit (Name "_")) (Cons (ListLit (Nil)) (Nil))) (List (Nil))),
  (Def "zipWith" (Cons (Lit (Name "f")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Cons (ConsLit (Lit (Name "y")) (Lit (Name "ys"))) (Nil)))) (Binary Colon (App (Atom (Name "f")) (Cons (Atom (Name "x")) (Cons (Atom (Name "y")) (Nil)))) (App (Atom (Name "zipWith")) (Cons (Atom (Name "f")) (Cons (Atom (Name "xs")) (Cons (Atom (Name "ys")) (Nil))))))),
  (Def "zipWith" (Cons (Lit (Name "_")) (Cons (ListLit (Nil)) (Cons (Lit (Name "_")) (Nil)))) (List (Nil))),
  (Def "zipWith" (Cons (Lit (Name "_")) (Cons (Lit (Name "_")) (Cons (ListLit (Nil)) (Nil)))) (List (Nil))),
  (Def "unzip" (Cons (ListLit (Nil)) (Nil)) (NTuple (Cons (List (Nil)) (Cons (List (Nil)) (Nil))))),
  (Def "unzip" (Cons (ConsLit (NTupleLit (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil)))) (Lit (Name "xs"))) (Nil)) (Binary Dollar (Lambda (Cons (NTupleLit (Cons (Lit (Name "as")) (Cons (Lit (Name "bs")) (Nil)))) (Nil)) (NTuple (Cons (Binary Colon (Atom (Name "a")) (Atom (Name "as"))) (Cons (Binary Colon (Atom (Name "b")) (Atom (Name "bs"))) (Nil))))) (App (aname "unzip") (Cons (aname "xs") Nil)))),
  (Def "fst" (Cons (NTupleLit (Cons (Lit (Name "x")) (Cons (Lit (Name "_")) (Nil)))) Nil) (Atom (Name "x"))),
  (Def "snd" (Cons (NTupleLit (Cons (Lit (Name "_")) (Cons (Lit (Name "x")) (Nil)))) Nil) (Atom (Name "x"))),
  (Def "curry" (Cons (Lit (Name "f")) (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil)))) (App (Atom (Name "f")) (Cons (NTuple (Cons (Atom (Name "a")) (Cons (Atom (Name "b")) (Nil)))) (Nil)))),
  (Def "uncurry" (Cons (Lit (Name "f")) (Cons (NTupleLit (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil)))) (Nil))) (App (Atom (Name "f")) (Cons (Atom (Name "a")) (Cons (Atom (Name "b")) (Nil))))),
  (Def "repeat" (Cons (Lit (Name "x")) (Nil)) (Binary Colon (Atom (Name "x")) (App (Atom (Name "repeat")) (Cons (Atom (Name "x")) (Nil))))),
  (Def "replicate" (Cons (Lit (AInt 0)) (Cons (Lit (Name "_")) (Nil))) (List (Nil))),
  (Def "replicate" (Cons (Lit (Name "n")) (Cons (Lit (Name "x")) (Nil))) (Binary Colon (Atom (Name "x")) (App (Atom (Name "replicate")) (Cons (Binary Sub (Atom (Name "n")) (Atom (AInt 1))) (Cons (Atom (Name "x")) (Nil)))))),
  (Def "enumFromTo" (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil))) (IfExpr (Binary Leq (Atom (Name "a")) (Atom (Name "b"))) (Binary Colon (Atom (Name "a")) (App (Atom (Name "enumFromTo")) (Cons (Binary Add (Atom (Name "a")) (Atom (AInt 1))) (Cons (Atom (Name "b")) (Nil))))) (List (Nil)))),
  (Def "sum" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)) (Binary Add (Atom (Name "x")) (App (Atom (Name "sum")) (Cons (Atom (Name "xs")) (Nil))))),
  (Def "sum" (Cons (ListLit (Nil)) (Nil)) (Atom (AInt 0))),
  (Def "product" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)) (Binary Mul (Atom (Name "x")) (App (Atom (Name "product")) (Cons (Atom (Name "xs")) (Nil))))),
  (Def "product" (Cons (ListLit (Nil)) (Nil)) (Atom (AInt 1))),
  (Def "reverse" (Cons (ListLit (Nil)) (Nil)) (List (Nil))),
  (Def "reverse" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)) (Binary Append (App (Atom (Name "reverse")) (Cons (Atom (Name "xs")) (Nil))) (List (Cons (Atom (Name "x")) (Nil))))),
  (Def "concat" (Nil) (App (Atom (Name "foldr")) (Cons (PrefixOp Append) (Cons (List (Nil)) (Nil))))),
  (Def "map" (Cons (Lit (Name "f")) (Cons (ListLit (Nil)) (Nil))) (List (Nil))),
  (Def "map" (Cons (Lit (Name "f")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil))) (Binary Colon (App (Atom (Name "f")) (Cons (Atom (Name "x")) (Nil))) (App (Atom (Name "map")) (Cons (Atom (Name "f")) (Cons (Atom (Name "xs")) (Nil)))))),
  (Def "not" (Cons (Lit (Bool true)) (Nil)) (Atom (Bool false))),
  (Def "not" (Cons (Lit (Bool false)) (Nil)) (Atom (Bool true))),
  (Def "filter" (Cons (Lit (Name "p")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil))) (IfExpr (App (Atom (Name "p")) (Cons (Atom (Name "x")) (Nil))) (Binary Colon (Atom (Name "x")) (App (Atom (Name "filter")) (Cons (Atom (Name "p")) (Cons (Atom (Name "xs")) (Nil))))) (App (Atom (Name "filter")) (Cons (Atom (Name "p")) (Cons (Atom (Name "xs")) (Nil)))))),
  (Def "filter" (Cons (Lit (Name "p")) (Cons (ListLit (Nil)) (Nil))) (List (Nil))),
  (Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ListLit (Nil)) (Nil)))) (Atom (Name "ini"))),
  (Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "x")) (Cons (App (Atom (Name "foldr")) (Cons (Atom (Name "f")) (Cons (Atom (Name "ini")) (Cons (Atom (Name "xs")) (Nil))))) (Nil))))),
  (Def "foldl" (Cons (Lit (Name "f")) (Cons (Lit (Name "acc")) (Cons (ListLit (Nil)) (Nil)))) (Atom (Name "acc"))),
  (Def "foldl" (Cons (Lit (Name "f")) (Cons (Lit (Name "acc")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (App (Atom (Name "foldl")) (Cons (Atom (Name "f")) (Cons (App (Atom (Name "f")) (Cons (Atom (Name "acc")) (Cons (Atom (Name "x")) (Nil)))) (Cons (Atom (Name "xs")) (Nil)))))),
  (Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ListLit (Nil)) (Nil)))) (List (Cons (Atom (Name "b")) (Nil)))),
  (Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (Binary Colon (Atom (Name "b")) (App (Atom (Name "scanl")) (Cons (Atom (Name "f")) (Cons (App (Atom (Name "f")) (Cons (Atom (Name "b")) (Cons (Atom (Name "x")) (Nil)))) (Cons (Atom (Name "xs")) (Nil))))))),
  (Def "iterate" (Cons (Lit (Name "f")) (Cons (Lit (Name "x")) (Nil))) (Binary Colon (Atom (Name "x")) (App (Atom (Name "iterate")) (Cons (Atom (Name "f")) (Cons (App (Atom (Name "f")) (Cons (Atom (Name "x")) (Nil))) (Nil)))))),
  (Def "id" (Cons (Lit (Name "x")) (Nil)) (Atom (Name "x"))),
  (Def "const" (Cons (Lit (Name "x")) (Cons (Lit (Name "_")) (Nil))) (Atom (Name "x"))),
  (Def "flip" (Cons (Lit (Name "f")) (Cons (Lit (Name "x")) (Cons (Lit (Name "y")) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "y")) (Cons (Atom (Name "x")) (Nil))))),
  (Def "even" (Cons (Lit (Name "n")) (Nil)) (Binary Equ (Binary Mod (Atom (Name "n")) (Atom (AInt 2))) (Atom (AInt 0)))),
  (Def "odd" (Cons (Lit (Name "n")) (Nil)) (Binary Equ (Binary Mod (Atom (Name "n")) (Atom (AInt 2))) (Atom (AInt 1)))),
  (Def "fix" (Cons (Lit (Name "f")) (Nil)) (App (Atom (Name "f")) (Cons (App (Atom (Name "fix")) (Cons (Atom (Name "f")) (Nil))) (Nil))))
  ]

module Test.Parser where

import Prelude (class Eq, class Show, Unit, (++), ($), bind, show, unit, return, (==), (<<<), negate)
import Data.Either (Either(..))
import Data.List (List(..), toList, singleton)

import Text.Parsing.Parser  (Parser, ParseError(ParseError), runParser)

import Control.Monad.Writer (Writer, tell)

import AST (Atom(..), Binding(..), Definition(Def), Expr(..), Op(..))
import Parser (expression, atom, definitions, definition, binding, variable, bool, int)

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

test :: forall a. (Show a, Eq a) => String -> Parser String a -> String -> a -> Writer (List String) Unit
test name p input expected = case runParser input p of
  Left  (ParseError { position = p, message = m }) -> tell' $ "Parse fail (" ++ name ++ "): " ++ show p ++ " " ++ m
  Right result           ->
    if result == expected
      then return unit --tell $ "Parse success (" ++ name ++ ")"
      else tell' $ "Parse fail (" ++ name ++ "): " ++ show result ++ " /= " ++ show expected

aint :: Int -> Expr
aint i = Atom $ AInt i

aname :: String -> Expr
aname s = Atom $ Name s

runTests :: Writer (List String) Unit
runTests = do
  test "0" int "0" (AInt 0)
  test "1" int "1" (AInt 1)
  test "all" int "0123456789" (AInt 123456789)
  test "high" int "999999999999999999" (AInt 2147483647)

  test "bool1" bool "True" (Bool true)
  test "bool2" bool "False" (Bool false)

  test "a" variable "a" (Name "a")
  test "lower" variable "a_bcdefghijklmnopqrstuvwxyz_" (Name "a_bcdefghijklmnopqrstuvwxyz_")
  test "upper" variable "a'BCDEFGHIJKLMNOPQRSTUVWXYZ'" (Name "a'BCDEFGHIJKLMNOPQRSTUVWXYZ'")
  test "special" variable "_____''''" (Name "_____''''")
  test "with_numbers1" variable "a1" (Name "a1")

  test "composition" expression "f . g" (Binary Composition (aname "f") (aname "g"))
  test "power" expression "2 ^ 10" (Binary Power (aint 2) (aint 10))
  test "mul" expression "2 * 2" (Binary Mul (aint 2) (aint 2))
  test "div" expression "13 `div` 3" (Binary Div (aint 13) (aint 3))
  test "mod" expression "13 `mod` 3" (Binary Mod (aint 13) (aint 3))
  test "add1" expression "1 + 1"  (Binary Add (aint 1) (aint 1))
  test "add2" expression "2+2" (Binary Add (aint 2) (aint 2))
  test "sub" expression "5 - 3" (Binary Sub (aint 5) (aint 3))
  test "colon" expression "x:xs" (Binary Colon (aname "x") (aname "xs"))
  test "append1" expression "xs ++ ys" (Binary Append (aname "xs") (aname "ys"))
  test "append2" expression "xs++ys"  (Binary Append (aname "xs") (aname "ys"))
  test "equ" expression "5 == 5" (Binary Equ (aint 5) (aint 5))
  test "neq" expression "1 /= 2" (Binary Neq (aint 1) (aint 2))
  test "lt1" expression "1 < 234" (Binary Lt (aint 1) (aint 234))
  test "lt2" expression "x<y" (Binary Lt (aname "x") (aname "y"))
  test "leq" expression "1 <= 234" (Binary Leq (aint 1) (aint 234))
  test "gt1" expression "567 > 1" (Binary Gt (aint 567) (aint 1))
  test "gt2" expression "x>y" (Binary Gt (aname "x") (aname "y"))
  test "geq" expression "567 >= 1" (Binary Geq (aint 567) (aint 1))
  test "and" expression "hot && cold" (Binary And (aname "hot") (aname "cold"))
  test "or" expression "be || notBe" (Binary Or (aname "be") (aname "notBe"))
  test "dollar" expression "f $ 1 + 2"  (Binary Dollar (aname "f") (Binary Add (aint 1) (aint 2)))

  test "unary_minus1" expression "- 10"  (aint (-10))
  test "unary_minus2" expression "- x"  (Unary Sub (aname "x"))
  test "unary_minus3" expression "-10"  (aint (-10))
  test "unary_minus4" expression "-x"  (Unary Sub (aname "x"))

  test "1" expression "1" (aint 1)
  test "add" expression "1 + 2" (Binary Add (aint 1) (aint 2))
  test "precedence" expression "1 * 2 + 3 * 4" (Binary Add
                                    (Binary Mul (aint 1) (aint 2))
                                    (Binary Mul (aint 3) (aint 4)))
  test "whitespaces" expression
    "1   \t   -    \t   ( f   )    \t\t\t\t                                                                \t\t\t\t             `div`     _ignore"
    (Binary Sub (aint 1) (Binary Div (aname "f") (aname "_ignore")))
  test "brackets" expression "(  1  +  2  )  *  3" (Binary Mul (Binary Add (aint 1) (aint 2)) (aint 3))
  test "brackets2" expression "( (  1  +  2  - 3  )  *  4 * 5 * 6)"
    (Binary Mul
      (Binary Mul
        (Binary Mul
          (Binary Sub
            (Binary Add (aint 1) (aint 2))
            (aint 3))
          (aint 4))
        (aint 5))
      (aint 6))
  test "brackets3" expression "( ( ( 1 ) ) )" (aint 1)
  test "many brackets" expression "(   (( ((  f )) *  ( (17   )) ) ))" (Binary Mul (aname "f") (aint 17))

  test "if_then_else" expression "if x then y else z" (IfExpr (aname "x") (aname "y") (aname "z"))
  test "nested if" expression "if(if 1 then 2 else 3)then y else z" (IfExpr (IfExpr (aint 1) (aint 2) (aint 3)) (aname "y") (aname "z"))
  test "iffy1" expression "iffy" (aname "iffy")
  test "iffy2" expression "if 10 + 20 then iffy * iffy else ((7))"
    (IfExpr
      (Binary Add (aint 10) (aint 20))
      (Binary Mul (aname "iffy") (aname "iffy"))
      (aint 7))
  test "iffy3" expression "iffy + if iffy then iffy else iffy"
    (Binary Add (aname "iffy") (IfExpr (aname "iffy") (aname "iffy") (aname "iffy")))
  test "nested if 2" expression "if if x then y else z then if a then b else c else if i then j else k"
    (IfExpr
      (IfExpr (aname "x") (aname "y") (aname "z"))
      (IfExpr (aname "a") (aname "b") (aname "c"))
      (IfExpr (aname "i") (aname "j") (aname "k")))
  test "if2" expression "if bool then False else True" (IfExpr (aname "bool") (Atom (Bool false)) (Atom (Bool true)))

  test "apply1" expression "f 1" (App (aname "f") (singleton (aint 1)))
  test "apply2" expression "f x y z 12 (3 + 7)"
    (App (aname "f") (toList [aname "x", aname "y", aname "z", aint 12, Binary Add (aint 3) (aint 7)]))
  test "fibonacci" expression "fib (n - 1) + fib (n - 2)"
    (Binary Add
      (App (aname "fib") (toList [Binary Sub (aname "n") (aint 1)]))
      (App (aname "fib") (toList [Binary Sub (aname "n") (aint 2)])))
  test "predicate" expression "if p 10 then 10 else 20"
    (IfExpr
      (App (aname "p") (singleton (aint 10)))
      (aint 10)
      (aint 20))
  test "stuff" expression "f a (1 * 2) * 3"
    (Binary Mul
      (App (aname "f") (toList [aname "a", Binary Mul (aint 1) (aint 2)]))
      (aint 3))

  test "tuple" expression "(1, 2)" (NTuple (toList [aint 1, aint 2]))
  test "3tuple" expression "(1, 2, 3)" (NTuple (toList [aint 1, aint 2, aint 3]))
  test "4tuple" expression "(1, 2, 3, 4)" (NTuple (toList [aint 1, aint 2, aint 3, aint 4]))
  test "tuple_spaces" expression "(   1   , 2   )" (NTuple (toList [aint 1, aint 2]))
  test "3tuple_spaces" expression "(  1   , 2    , 3     )" (NTuple (toList [aint 1, aint 2, aint 3]))
  test "tuple_arith" expression "((1 + 2, (3)))" (NTuple (toList [Binary Add (aint 1) (aint 2), aint 3]))
  test "tuple_apply" expression "fmap f (snd (1,2), fst ( 1 , 2 ))"
    (App (aname "fmap") (toList
      [ (aname "f")
      , NTuple (toList
        [ App (aname "snd") (toList [NTuple (toList [aint 1, aint 2])])
        , App (aname "fst") (toList [NTuple (toList [aint 1, aint 2])])
        ])
      ]
    ))
  test "tuple_deep" expression "((((( ((((((1)),((2))),(3,((((4)))))),((5,6),(7,8))),(((9,(10)),(((11,12)))),((((13,14),(14,15)))))) )))))"
    (NTuple (Cons
      (NTuple (Cons
        (NTuple (Cons
          (NTuple (Cons (Atom (AInt 1)) (Cons (Atom (AInt 2)) (Nil))))
          (Cons (NTuple (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))) (Nil))))
        (Cons (NTuple
          (Cons (NTuple (Cons (Atom (AInt 5)) (Cons (Atom (AInt 6)) (Nil))))
            (Cons (NTuple (Cons (Atom (AInt 7)) (Cons (Atom (AInt 8)) (Nil)))) (Nil)))) (Nil))))
      (Cons (NTuple (Cons (NTuple (Cons (NTuple (Cons (Atom (AInt 9)) (Cons (Atom (AInt 10)) (Nil))))
        (Cons (NTuple (Cons (Atom (AInt 11)) (Cons (Atom (AInt 12)) (Nil)))) (Nil))))
      (Cons (NTuple (Cons (NTuple (Cons (Atom (AInt 13)) (Cons (Atom (AInt 14)) (Nil))))
        (Cons (NTuple (Cons (Atom (AInt 14)) (Cons (Atom (AInt 15)) (Nil)))) (Nil)))) (Nil)))) (Nil))))

  test "list_empty" expression "[]" (List Nil)
  test "list1" expression "[1]" (List (toList [aint 1]))
  test "list2" expression "[  1  ]" (List (toList [aint 1]))
  test "list3" expression "[  1  ,2,3,     4    ,  5  ]" (List (toList [aint 1, aint 2, aint 3, aint 4, aint 5]))
  test "list_nested" expression "[ [1,2] , [ 3 , 4 ] ]" (List $ toList [(List $ toList [aint 1, aint 2]), (List $ toList [aint 3, aint 4])])
  test "list_complex" expression "[ 1 + 2 , 3 + 4 ] ++ []"
    (Binary Append
      (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
      (List Nil))

  test "binding_lit1" binding "x" (Lit (Name "x"))
  test "binding_lit2" binding "10" (Lit (AInt 10))
  test "lambda1" expression "(\\x -> x)" (Lambda (toList [Lit (Name "x")]) (aname "x"))
  test "lambda2" expression "( \\ x y z -> ( x , y , z ) )"
    (Lambda (toList [Lit (Name "x"), Lit (Name "y"), Lit (Name "z")])
      (NTuple (toList [aname "x", aname "y", aname "z"])))
  test "lambda3" expression "(  \\  x ->   (   \\    y ->    (   \\    z ->     f   x   y   z )  )  )"
    (Lambda (singleton $ Lit $ Name "x")
      (Lambda (singleton $ Lit $ Name "y")
        (Lambda (singleton $ Lit $ Name "z")
          (App (aname "f") (toList [aname "x", aname "y", aname "z"])))))
  test "lambda4" expression "(\\a b -> a + b) 1 2"
    (App
      (Lambda (toList [Lit (Name "a"), Lit (Name "b")])
        (Binary Add (aname "a") (aname "b")))
      (toList [aint 1, aint 2]))

  test "lambda5" expression "(\\a -> (\\b -> (\\c -> (\\d -> (\\e -> (\\f -> (\\g -> a + b + c + d + e + f + g))))))) 1 2 3 4 5 6 7"
    (App
      (Lambda (Cons (Lit (Name "a")) (Nil))
        (Lambda (Cons (Lit (Name "b")) (Nil))
          (Lambda (Cons (Lit (Name "c")) (Nil))
            (Lambda (Cons (Lit (Name "d")) (Nil))
              (Lambda (Cons (Lit (Name "e")) (Nil))
                (Lambda (Cons (Lit (Name "f")) (Nil))
                  (Lambda (Cons (Lit (Name "g")) (Nil))
                    (Binary Add
                      (Binary Add
                        (Binary Add
                          (Binary Add
                            (Binary Add
                              (Binary Add (Atom (Name "a")) (Atom (Name "b")))
                              (Atom (Name "c")))
                            (Atom (Name "d")))
                          (Atom (Name "e")))
                        (Atom (Name "f")))
                      (Atom (Name "g"))))))))))
      (Cons (Atom (AInt 1)) (Cons (Atom (AInt 2)) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Cons (Atom (AInt 5)) (Cons (Atom (AInt 6)) (Cons (Atom (AInt 7)) (Nil)))))))))

  test "sectR1" expression "(+1)" (SectR Add (aint 1))
  test "sectR2" expression "( ^ 2 )" (SectR Power (aint 2))
  test "sectR3" expression "(++ [1])" (SectR Append (List (toList [aint 1])))
  test "sectR4" expression "(<= (2 + 2))" (SectR Leq (Binary Add (aint 2) (aint 2)))
  test "sectR5" expression "(   >=  (  2 + 2  )  )" (SectR Geq (Binary Add (aint 2) (aint 2)))

  test "prefixOp1" expression "(+)" (PrefixOp Add)
  test "prefixOp2" expression "( ++ )" (PrefixOp Append)
  test "prefixOp3" expression "((^) 2 10)" (App (PrefixOp Power) (toList [aint 2, aint 10]))

  test "sectL1" expression "(1+)" (SectL (aint 1) Add)
  test "sectL2" expression "( n `mod` )" (SectL (aname "n") Mod)
  test "sectL3" expression "([1] ++)" (SectL (List $ toList [aint 1]) Append)
  test "sectL4" expression "(   ( 2 +  2 )  <= )" (SectL (Binary Add (aint 2) (aint 2)) Leq)

  test "let1" expression "let x = 1 in x + x" (LetExpr (Lit (Name "x")) (aint 1) (Binary Add (aname "x") (aname "x")))
  test "let2" expression "letty + let x = 1 in x" (Binary Add (aname "letty") (LetExpr (Lit (Name "x")) (aint 1) (aname "x")))
  test "let3" expression "let x = let y = 1 in y in let z = 2 in x + z"
    (LetExpr
      (Lit (Name "x"))
      (LetExpr
        (Lit (Name "y"))
        (aint 1)
        (aname "y"))
      (LetExpr
        (Lit (Name "z"))
        (aint 2)
        (Binary Add (aname "x") (aname "z"))))

  test "consLit1" binding "(x:xs)" (ConsLit (Lit (Name "x")) (Lit (Name "xs")))
  test "consLit2" binding "(x:(y:zs))" (ConsLit (Lit (Name "x")) (ConsLit (Lit (Name "y")) (Lit (Name "zs"))))
  test "consLit3" binding "(  x  :  (  666  :  zs  )   )" (ConsLit (Lit (Name "x")) (ConsLit (Lit (AInt 666)) (Lit (Name "zs"))))

  test "listLit1" binding "[]" (ListLit Nil)
  test "listLit2" binding "[    ]" (ListLit Nil)
  test "listLit3" binding "[  True ]" (ListLit (Cons (Lit (Bool true)) Nil))
  test "listLit4" binding "[  x   ,  y  ,   1337 ]" (ListLit (toList [Lit (Name "x"), Lit (Name "y"), Lit (AInt 1337)]))

  test "tupleLit1" binding "(a,b)" (NTupleLit (toList [Lit (Name "a"), Lit (Name "b")]))
  test "tupleLit2" binding "(   a   ,  b   ,   c   )" (NTupleLit (toList $ [Lit (Name "a"), Lit (Name "b"), Lit (Name "c")]))
  test "tupleLit3" binding "(  (  x  ,  y  )  , ( a  ,  b  )  , 10 )"
    (NTupleLit (toList
      [ NTupleLit (toList [Lit (Name "x"), Lit (Name "y")])
      , NTupleLit (toList [Lit (Name "a"), Lit (Name "b")])
      , (Lit (AInt 10))
      ]))

  test "binding" binding "( ( x , y ) : [ a , b ] )"
    (ConsLit
      (NTupleLit (toList [Lit (Name "x"), Lit (Name "y")]))
      (ListLit (toList [Lit (Name "a"), Lit (Name "b")])))

  test "def1" definition "x = 10" (Def "x" Nil (aint 10))
  test "def2" definition "double x = x + x" (Def "double" (Cons (Lit (Name "x")) Nil) (Binary Add (aname "x") (aname "x")))
  test "def3" definition "zip (x:xs) (y:ys) = (x,y) : zip xs ys"
    (Def "zip"
      (toList [ConsLit (Lit (Name "x")) (Lit (Name "xs")), ConsLit (Lit (Name "y")) (Lit (Name "ys"))])
      (Binary Colon
        (NTuple (toList  [Atom (Name "x"), Atom (Name "y")]))
        (App (aname "zip") (toList [Atom (Name "xs"), Atom (Name "ys")]))))

  test "defs" definitions "\n\na   =   10 \n  \n \nb    =  20  \n\n  \n"
    (toList [Def "a" Nil (aint 10), Def "b" Nil (aint 20)])

  test "prelude" definitions prelude parsedPrelude
  test "expression" expression "sum (map (^2) [1, 2, 3, 4])"
    (App
      (Atom (Name "sum"))
      (Cons
        (App
          (Atom (Name "map"))
          (Cons (SectR Power (Atom (AInt 2)))
            (Cons (List (Cons (Atom (AInt 1)) (Cons (Atom (AInt 2)) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil))))))
              (Nil))))
        (Nil)))

  test "char_atom1" atom "'a'" (Char "a")
  test "char_atom2" atom "'\\\\'" (Char "\\")
  test "char_atom3" atom "'\\n'" (Char "\n")
  test "char_expr1" expression "'\\r'" (Atom (Char "\r"))
  test "char_expr2" expression "['\\\\', '\\'', '\\\"']" (List $ toList [Atom (Char "\\"), Atom (Char "'"), Atom (Char "\"")])

  test "string1" expression "\"asdf\"" (List $ toList [Atom (Char "a"), Atom (Char "s"), Atom (Char "d"), Atom (Char "f")])
  test "string2" expression "\"\\\\\\n\\\"\\\'\"" (List $ toList [Atom (Char "\\"), Atom (Char "\n"), Atom (Char "\""), Atom (Char "'")])

prelude :: String
prelude =
  "and (True:xs)  = and xs\n" ++
  "and (False:xs) = False\n" ++
  "and []         = True\n" ++
  "\n" ++
  "or (False:xs) = or xs\n" ++
  "or (True:xs)  = True\n" ++
  "or []         = False\n" ++
  "\n" ++
  "all p = and . map p\n" ++
  "any p = or . map p\n" ++
  "\n" ++
  "head (x:xs) = x\n" ++
  "tail (x:xs) = xs\n" ++
  "\n" ++
  "take 0 xs     = []\n" ++
  "take n (x:xs) = x : take (n - 1) xs\n" ++
  "\n" ++
  "drop 0 xs     = xs\n" ++
  "drop n (x:xs) = drop (n - 1) xs\n" ++
  "\n" ++
  "elem e []     = False\n" ++
  "elem e (x:xs) = if e == x then True else elem e xs\n" ++
  "\n" ++
  "max a b = if a >= b then a else b\n" ++
  "min a b = if b >= a then a else b\n" ++
  "\n" ++
  "maximum (x:xs) = foldr max x xs\n" ++
  "minimum (x:xs) = foldr min x xs\n" ++
  "\n" ++
  "length []     = 0\n" ++
  "length (x:xs) = 1 + length xs\n" ++
  "\n" ++
  "zip (x:xs) (y:ys) = (x, y) : zip xs ys\n" ++
  "zip []      _     = []\n" ++
  "zip _       []    = []\n" ++
  "\n" ++
  "zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\n" ++
  "zipWith _ []     _      = []\n" ++
  "zipWith _ _      []     = []\n" ++
  "\n" ++
  "unzip []          = ([], [])\n" ++
  "unzip ((a, b):xs) = (\\(as, bs) -> (a:as, b:bs)) $ unzip xs\n" ++
  "\n" ++
  "fst (x,_) = x\n" ++
  "snd (_,x) = x\n" ++
  "\n" ++
  "curry f a b = f (a, b)\n" ++
  "uncurry f (a, b) = f a b\n" ++
  "\n" ++
  "repeat x = x : repeat x\n" ++
  "\n" ++
  "replicate 0 _ = []\n" ++
  "replicate n x = x : replicate (n - 1) x\n" ++
  "\n" ++
  "enumFromTo a b = if a <= b then a : enumFromTo (a + 1) b else []\n" ++
  "\n" ++
  "sum (x:xs) = x + sum xs\n" ++
  "sum [] = 0\n" ++
  "\n" ++
  "product (x:xs) = x * product xs\n" ++
  "product [] = 1\n" ++
  "\n" ++
  "reverse []     = []\n" ++
  "reverse (x:xs) = reverse xs ++ [x]\n" ++
  "\n" ++
  "concat = foldr (++) []\n" ++
  "\n" ++
  "map f []     = []\n" ++
  "map f (x:xs) = f x : map f xs\n" ++
  "\n" ++
  "not True  = False\n" ++
  "not False = True\n" ++
  "\n" ++
  "filter p (x:xs) = if p x then x : filter p xs else filter p xs\n" ++
  "filter p []     = []\n" ++
  "\n" ++
  "foldr f ini []     = ini\n" ++
  "foldr f ini (x:xs) = f x (foldr f ini xs)\n" ++
  "\n" ++
  "foldl f acc []     = acc\n" ++
  "foldl f acc (x:xs) = foldl f (f acc x) xs\n" ++
  "\n" ++
  "scanl f b []     = [b]\n" ++
  "scanl f b (x:xs) = b : scanl f (f b x) xs\n" ++
  "\n" ++
  "iterate f x = x : iterate f (f x)\n" ++
  "\n" ++
  "id x = x\n" ++
  "\n" ++
  "const x _ = x\n" ++
  "\n" ++
  "flip f x y = f y x\n" ++
  "\n" ++
  "even n = (n `mod` 2) == 0\n" ++
  "odd n = (n `mod` 2) == 1\n" ++
  "\n" ++
  "fix f = f (fix f)\n"

parsedPrelude :: List Definition
parsedPrelude = toList [
  (Def "and" (Cons (ConsLit (Lit (Bool true)) (Lit (Name "xs"))) (Nil)) (App (Atom (Name "and")) (Cons (Atom (Name "xs")) (Nil)))),
  (Def "and" (Cons (ConsLit (Lit (Bool false)) (Lit (Name "xs"))) (Nil)) (Atom (Bool false))),
  (Def "and" (Cons (ListLit (Nil)) (Nil)) (Atom (Bool true))),
  (Def "or" (Cons (ConsLit (Lit (Bool false)) (Lit (Name "xs"))) (Nil)) (App (Atom (Name "or")) (Cons (Atom (Name "xs")) (Nil)))),
  (Def "or" (Cons (ConsLit (Lit (Bool true)) (Lit (Name "xs"))) (Nil)) (Atom (Bool true))),
  (Def "or" (Cons (ListLit (Nil)) (Nil)) (Atom (Bool false))),
  (Def "all" (Cons (Lit (Name "p")) (Nil)) (Binary Composition (Atom (Name "and")) (App (Atom (Name "map")) (Cons (Atom (Name "p")) (Nil))))),
  (Def "any" (Cons (Lit (Name "p")) (Nil)) (Binary Composition (Atom (Name "or")) (App (Atom (Name "map")) (Cons (Atom (Name "p")) (Nil))))),
  (Def "head" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)) (Atom (Name "x"))),
  (Def "tail" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)) (Atom (Name "xs"))),
  (Def "take" (Cons (Lit (AInt 0)) (Cons (Lit (Name "xs")) (Nil))) (List (Nil))),
  (Def "take" (Cons (Lit (Name "n")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil))) (Binary Colon (Atom (Name "x")) (App (Atom (Name "take")) (Cons (Binary Sub (Atom (Name "n")) (Atom (AInt 1))) (Cons (Atom (Name "xs")) (Nil)))))),
  (Def "drop" (Cons (Lit (AInt 0)) (Cons (Lit (Name "xs")) (Nil))) (Atom (Name "xs"))),
  (Def "drop" (Cons (Lit (Name "n")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil))) (App (Atom (Name "drop")) (Cons (Binary Sub (Atom (Name "n")) (Atom (AInt 1))) (Cons (Atom (Name "xs")) (Nil))))),
  (Def "elem" (Cons (Lit (Name "e")) (Cons (ListLit (Nil)) (Nil))) (Atom (Bool false))),
  (Def "elem" (Cons (Lit (Name "e")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil))) (IfExpr (Binary Equ (Atom (Name "e")) (Atom (Name "x"))) (Atom (Bool true)) (App (Atom (Name "elem")) (Cons (Atom (Name "e")) (Cons (Atom (Name "xs")) (Nil)))))),
  (Def "max" (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil))) (IfExpr (Binary Geq (Atom (Name "a")) (Atom (Name "b"))) (Atom (Name "a")) (Atom (Name "b")))),
  (Def "min" (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil))) (IfExpr (Binary Geq (Atom (Name "b")) (Atom (Name "a"))) (Atom (Name "a")) (Atom (Name "b")))),
  (Def "maximum" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)) (App (Atom (Name "foldr")) (Cons (Atom (Name "max")) (Cons (Atom (Name "x")) (Cons (Atom (Name "xs")) (Nil)))))),
  (Def "minimum" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)) (App (Atom (Name "foldr")) (Cons (Atom (Name "min")) (Cons (Atom (Name "x")) (Cons (Atom (Name "xs")) (Nil)))))),
  (Def "length" (Cons (ListLit (Nil)) (Nil)) (Atom (AInt 0))),
  (Def "length" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)) (Binary Add (Atom (AInt 1)) (App (Atom (Name "length")) (Cons (Atom (Name "xs")) (Nil))))),
  (Def "zip" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Cons (ConsLit (Lit (Name "y")) (Lit (Name "ys"))) (Nil))) (Binary Colon (NTuple (Cons (Atom (Name "x")) (Cons (Atom (Name "y")) (Nil)))) (App (Atom (Name "zip")) (Cons (Atom (Name "xs")) (Cons (Atom (Name "ys")) (Nil)))))),
  (Def "zip" (Cons (ListLit (Nil)) (Cons (Lit (Name "_")) (Nil))) (List (Nil))),
  (Def "zip" (Cons (Lit (Name "_")) (Cons (ListLit (Nil)) (Nil))) (List (Nil))),
  (Def "zipWith" (Cons (Lit (Name "f")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Cons (ConsLit (Lit (Name "y")) (Lit (Name "ys"))) (Nil)))) (Binary Colon (App (Atom (Name "f")) (Cons (Atom (Name "x")) (Cons (Atom (Name "y")) (Nil)))) (App (Atom (Name "zipWith")) (Cons (Atom (Name "f")) (Cons (Atom (Name "xs")) (Cons (Atom (Name "ys")) (Nil))))))),
  (Def "zipWith" (Cons (Lit (Name "_")) (Cons (ListLit (Nil)) (Cons (Lit (Name "_")) (Nil)))) (List (Nil))),
  (Def "zipWith" (Cons (Lit (Name "_")) (Cons (Lit (Name "_")) (Cons (ListLit (Nil)) (Nil)))) (List (Nil))),
  (Def "unzip" (Cons (ListLit (Nil)) (Nil)) (NTuple (Cons (List (Nil)) (Cons (List (Nil)) (Nil))))),
  (Def "unzip" (Cons (ConsLit (NTupleLit (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil)))) (Lit (Name "xs"))) (Nil)) (Binary Dollar (Lambda (Cons (NTupleLit (Cons (Lit (Name "as")) (Cons (Lit (Name "bs")) (Nil)))) (Nil)) (NTuple (Cons (Binary Colon (Atom (Name "a")) (Atom (Name "as"))) (Cons (Binary Colon (Atom (Name "b")) (Atom (Name "bs"))) (Nil))))) (App (aname "unzip") (Cons (aname "xs") Nil)))),
  (Def "fst" (Cons (NTupleLit (Cons (Lit (Name "x")) (Cons (Lit (Name "_")) (Nil)))) Nil) (Atom (Name "x"))),
  (Def "snd" (Cons (NTupleLit (Cons (Lit (Name "_")) (Cons (Lit (Name "x")) (Nil)))) Nil) (Atom (Name "x"))),
  (Def "curry" (Cons (Lit (Name "f")) (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil)))) (App (Atom (Name "f")) (Cons (NTuple (Cons (Atom (Name "a")) (Cons (Atom (Name "b")) (Nil)))) (Nil)))),
  (Def "uncurry" (Cons (Lit (Name "f")) (Cons (NTupleLit (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil)))) (Nil))) (App (Atom (Name "f")) (Cons (Atom (Name "a")) (Cons (Atom (Name "b")) (Nil))))),
  (Def "repeat" (Cons (Lit (Name "x")) (Nil)) (Binary Colon (Atom (Name "x")) (App (Atom (Name "repeat")) (Cons (Atom (Name "x")) (Nil))))),
  (Def "replicate" (Cons (Lit (AInt 0)) (Cons (Lit (Name "_")) (Nil))) (List (Nil))),
  (Def "replicate" (Cons (Lit (Name "n")) (Cons (Lit (Name "x")) (Nil))) (Binary Colon (Atom (Name "x")) (App (Atom (Name "replicate")) (Cons (Binary Sub (Atom (Name "n")) (Atom (AInt 1))) (Cons (Atom (Name "x")) (Nil)))))),
  (Def "enumFromTo" (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil))) (IfExpr (Binary Leq (Atom (Name "a")) (Atom (Name "b"))) (Binary Colon (Atom (Name "a")) (App (Atom (Name "enumFromTo")) (Cons (Binary Add (Atom (Name "a")) (Atom (AInt 1))) (Cons (Atom (Name "b")) (Nil))))) (List (Nil)))),
  (Def "sum" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)) (Binary Add (Atom (Name "x")) (App (Atom (Name "sum")) (Cons (Atom (Name "xs")) (Nil))))),
  (Def "sum" (Cons (ListLit (Nil)) (Nil)) (Atom (AInt 0))),
  (Def "product" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)) (Binary Mul (Atom (Name "x")) (App (Atom (Name "product")) (Cons (Atom (Name "xs")) (Nil))))),
  (Def "product" (Cons (ListLit (Nil)) (Nil)) (Atom (AInt 1))),
  (Def "reverse" (Cons (ListLit (Nil)) (Nil)) (List (Nil))),
  (Def "reverse" (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)) (Binary Append (App (Atom (Name "reverse")) (Cons (Atom (Name "xs")) (Nil))) (List (Cons (Atom (Name "x")) (Nil))))),
  (Def "concat" (Nil) (App (Atom (Name "foldr")) (Cons (PrefixOp Append) (Cons (List (Nil)) (Nil))))),
  (Def "map" (Cons (Lit (Name "f")) (Cons (ListLit (Nil)) (Nil))) (List (Nil))),
  (Def "map" (Cons (Lit (Name "f")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil))) (Binary Colon (App (Atom (Name "f")) (Cons (Atom (Name "x")) (Nil))) (App (Atom (Name "map")) (Cons (Atom (Name "f")) (Cons (Atom (Name "xs")) (Nil)))))),
  (Def "not" (Cons (Lit (Bool true)) (Nil)) (Atom (Bool false))),
  (Def "not" (Cons (Lit (Bool false)) (Nil)) (Atom (Bool true))),
  (Def "filter" (Cons (Lit (Name "p")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil))) (IfExpr (App (Atom (Name "p")) (Cons (Atom (Name "x")) (Nil))) (Binary Colon (Atom (Name "x")) (App (Atom (Name "filter")) (Cons (Atom (Name "p")) (Cons (Atom (Name "xs")) (Nil))))) (App (Atom (Name "filter")) (Cons (Atom (Name "p")) (Cons (Atom (Name "xs")) (Nil)))))),
  (Def "filter" (Cons (Lit (Name "p")) (Cons (ListLit (Nil)) (Nil))) (List (Nil))),
  (Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ListLit (Nil)) (Nil)))) (Atom (Name "ini"))),
  (Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "x")) (Cons (App (Atom (Name "foldr")) (Cons (Atom (Name "f")) (Cons (Atom (Name "ini")) (Cons (Atom (Name "xs")) (Nil))))) (Nil))))),
  (Def "foldl" (Cons (Lit (Name "f")) (Cons (Lit (Name "acc")) (Cons (ListLit (Nil)) (Nil)))) (Atom (Name "acc"))),
  (Def "foldl" (Cons (Lit (Name "f")) (Cons (Lit (Name "acc")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (App (Atom (Name "foldl")) (Cons (Atom (Name "f")) (Cons (App (Atom (Name "f")) (Cons (Atom (Name "acc")) (Cons (Atom (Name "x")) (Nil)))) (Cons (Atom (Name "xs")) (Nil)))))),
  (Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ListLit (Nil)) (Nil)))) (List (Cons (Atom (Name "b")) (Nil)))),
  (Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (Binary Colon (Atom (Name "b")) (App (Atom (Name "scanl")) (Cons (Atom (Name "f")) (Cons (App (Atom (Name "f")) (Cons (Atom (Name "b")) (Cons (Atom (Name "x")) (Nil)))) (Cons (Atom (Name "xs")) (Nil))))))),
  (Def "iterate" (Cons (Lit (Name "f")) (Cons (Lit (Name "x")) (Nil))) (Binary Colon (Atom (Name "x")) (App (Atom (Name "iterate")) (Cons (Atom (Name "f")) (Cons (App (Atom (Name "f")) (Cons (Atom (Name "x")) (Nil))) (Nil)))))),
  (Def "id" (Cons (Lit (Name "x")) (Nil)) (Atom (Name "x"))),
  (Def "const" (Cons (Lit (Name "x")) (Cons (Lit (Name "_")) (Nil))) (Atom (Name "x"))),
  (Def "flip" (Cons (Lit (Name "f")) (Cons (Lit (Name "x")) (Cons (Lit (Name "y")) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "y")) (Cons (Atom (Name "x")) (Nil))))),
  (Def "even" (Cons (Lit (Name "n")) (Nil)) (Binary Equ (Binary Mod (Atom (Name "n")) (Atom (AInt 2))) (Atom (AInt 0)))),
  (Def "odd" (Cons (Lit (Name "n")) (Nil)) (Binary Equ (Binary Mod (Atom (Name "n")) (Atom (AInt 2))) (Atom (AInt 1)))),
  (Def "fix" (Cons (Lit (Name "f")) (Nil)) (App (Atom (Name "f")) (Cons (App (Atom (Name "fix")) (Cons (Atom (Name "f")) (Nil))) (Nil))))
  ]


PunchCard gen

PunchCard gen

{-
Copyright 2016 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 SlamData.Workspace.Card.Setups.Chart.PunchCard.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Chart.PunchCard.Model
  ) where

import SlamData.Prelude

import Color as C

import Data.Argonaut (Json, decodeJson, (.?))
import Data.Array as A
import Data.Foldable as F
import Data.Foreign (readNumber)
import Data.Int as Int
import Data.Lens ((^?))
import Data.List as L
import Data.Map as M
import Data.Set as Set

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import Global (infinity)

import SlamData.Workspace.Card.CardType.ChartType (ChartType(PunchCard))
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis as Ax
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors)
import SlamData.Workspace.Card.Setups.Chart.Common as SCC
import SlamData.Workspace.Card.Setups.Chart.Common.Tooltip as CCT
import SlamData.Workspace.Card.Setups.Chart.PunchCard.Model (ModelR, Model)
import SlamData.Workspace.Card.Setups.Common.Eval (type (>>))
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics as Sem

import SqlSquare as Sql

import Utils (hush')
import Utils.Array (enumerate)

eval ∷ ∀ m. BCE.ChartSetupEval ModelR m
eval = BCE.chartSetupEval (SCC.buildBasicSql buildProjections buildGroupBy) buildPort

type PunchCardData = (String × String) >> (Int × Number)

type Item =
  { abscissa ∷ String
  , ordinate ∷ String
  , measure ∷ Number
  }

decodeItem ∷ Json → Either String Item
decodeItem = decodeJson >=> \obj → do
  abscissa ← Sem.requiredString "" <$> obj .? "abscissa"
  ordinate ← Sem.requiredString "" <$> obj .? "ordinate"
  measure ← Sem.requiredNumber zero <$> obj .? "measure"
  pure { abscissa, ordinate, measure }

buildProjections ∷ ModelR → L.List (Sql.Projection Sql.Sql)
buildProjections r = L.fromFoldable
  [ r.abscissa # SCC.jcursorPrj # Sql.as "abscissa"
  , r.ordinate # SCC.jcursorPrj # Sql.as "ordinate"
  , r.value # SCC.jcursorPrj # Sql.as "measure" # SCC.applyTransform r.value
  ]

buildGroupBy ∷ ModelR → Maybe (Sql.GroupBy Sql.Sql)
buildGroupBy r =
  SCC.groupBy $ L.fromFoldable
    [ r.abscissa # SCC.jcursorSql
    , r.ordinate # SCC.jcursorSql
    ]

buildPort ∷ ModelR → Ax.Axes → Array Json → Port.Port
buildPort m axes jarr =
  Port.ChartInstructions
    { options: buildOptions axes m $ buildData m jarr
    , chartType: PunchCard
    }

buildData ∷ ModelR → Array Json → PunchCardData
buildData r records = M.fromFoldable $ map addSymbolSize <$> items

  where
  items ∷ Array ((String × String) × Number)
  items =
    records
      # foldMap (foldMap A.singleton ∘ decodeItem)
      # map toPoint

  toPoint ∷ Item → (String × String) × Number
  toPoint item = (item.abscissa × item.ordinate) × item.measure

  aggregated ∷ Array Number
  aggregated = snd <$> items

  minValue ∷ Number
  minValue = fromMaybe (-1.0 * infinity) $ F.minimum aggregated

  maxValue ∷ Number
  maxValue = fromMaybe infinity $ F.maximum aggregated

  distance ∷ Number
  distance = maxValue - minValue

  sizeDistance ∷ Number
  sizeDistance = r.maxSize - r.minSize

  addSymbolSize ∷ Number → Int × Number
  addSymbolSize val
    | distance ≡ zero = (Int.ceil val) × val
    | otherwise =
        (Int.ceil (r.maxSize - sizeDistance / distance * (maxValue - val))) × val

buildOptions ∷ Ax.Axes → ModelR → PunchCardData → DSL OptionI
buildOptions axes r punchCardData = do
  E.tooltip do
    E.triggerItem
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12
    E.formatterItemArrayValue \{value} →
      let
        xIx = (map Int.ceil ∘ hush' ∘ readNumber) =<< value A.!! 0
        yIx = (map Int.ceil ∘ hush' ∘ readNumber) =<< value A.!! 1
        val = CCT.formatForeign <$> value A.!! 2
      in
        CCT.tableRows $ A.catMaybes
          [ map (D.jcursorLabel r.abscissa × _) $ xIx >>= A.index abscissaValues
          , map (D.jcursorLabel r.ordinate × _) $ yIx >>= A.index ordinateValues
          , map (D.jcursorLabel r.value × _) val
          ]

  E.colors colors

  when r.circular do
    E.polar $ pure unit
    E.angleAxis abscissaAxis
    E.radiusAxis ordinateAxis

  when (not r.circular) do
    E.xAxis abscissaAxis
    E.yAxis ordinateAxis

    E.grid $ E.containLabel true

  E.series series

  where
  abscissaAxis ∷ ∀ i. DSL (ETP.AxisI i)
  abscissaAxis = do
    E.axisType $ ET.Category
    E.disabledBoundaryGap
    E.splitLine do
      E.shown
      E.lineStyle do
        E.dashedLine
        E.color $ C.rgba 9 9 9 1.0
    E.axisLine E.hidden
    E.items $ map ET.strItem abscissaValues

  ordinateAxis ∷ ∀ i. DSL (ETP.AxisI i)
  ordinateAxis = do
    E.axisType $ ET.Category
    E.axisLine E.hidden
    E.axisLabel $ E.margin $ margin + 2
    E.items $ map ET.strItem ordinateValues

  xAxisType ∷ Ax.AxisType
  xAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType
    <$> (r.abscissa ^? D._value ∘ D._projection)
    <*> pure axes

  yAxisType ∷ Ax.AxisType
  yAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType
    <$> (r.ordinate ^? D._value ∘ D._projection)
    <*> pure axes

  abscissaValues ∷ Array String
  abscissaValues =
    A.sortBy (Ax.compareWithAxisType xAxisType)
      $ A.fromFoldable
      $ Set.fromFoldable
      $ map fst
      $ M.keys punchCardData

  ordinateValues ∷ Array String
  ordinateValues =
    A.sortBy (Ax.compareWithAxisType yAxisType)
      $ A.fromFoldable
      $ Set.fromFoldable
      $ map snd
      $ M.keys punchCardData

  margin ∷ Int
  margin =
    fromMaybe 6
      $ F.maximum
      $ foldMap (\((a × o) × (v × _)) → if Just a ≡ A.head abscissaValues then [v / 2] else [])
      $ M.toList punchCardData

  series = E.scatter do
    if r.circular
      then E.polarCoordinateSystem
      else E.cartesianCoordinateSystem
    E.buildItems
      $ for_ (enumerate abscissaValues) \(xIx × abscissa) →
          for_ (enumerate ordinateValues) \(yIx × ordinate) →
            for_ (M.lookup (abscissa × ordinate) punchCardData) \(symbolSize × val) → E.addItem do
              E.symbolSize symbolSize
              E.buildValues do
                E.addValue $ Int.toNumber xIx
                E.addValue $ Int.toNumber yIx
                E.addValue val

{-
Copyright 2016 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 SlamData.Workspace.Card.Setups.Chart.PunchCard.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Chart.PunchCard.Model
  ) where

import SlamData.Prelude

import Color as C

import Control.Monad.State (class MonadState)
import Control.Monad.Throw (class MonadThrow)

import Data.Argonaut (JArray, Json)
import Data.Array as A
import Data.Foldable as F
import Data.Foreign (readNumber)
import Data.Int as Int
import Data.Lens ((^?), _Just)
import Data.Map as M
import Data.Set as Set

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import Global (infinity)

import SlamData.Quasar.Class (class QuasarDSL )
import SlamData.Workspace.Card.CardType.ChartType (ChartType(PunchCard))
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis as Ax
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors)
import SlamData.Workspace.Card.Setups.Chart.Common.Tooltip as CCT
import SlamData.Workspace.Card.Setups.Chart.PunchCard.Model (ModelR, Model)
import SlamData.Workspace.Card.Setups.Common.Eval (type (>>))
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics (getMaybeString, getValues)
import SlamData.Workspace.Card.Setups.Transform as T
import SlamData.Workspace.Card.Setups.Transform.Aggregation as Ag

import Utils (hush')
import Utils.Array (enumerate)

eval
  ∷ ∀ m
  . ( MonadState CEM.CardState m
    , MonadThrow CEM.CardError m
    , QuasarDSL m
    )
  ⇒ Model
  → Port.Resource
  → m Port.Port
eval m = BCE.buildChartEval PunchCard buildPunchCard m \axes → m

type PunchCardData = (String × String) >> (Int × Number)

buildPunchCardData ∷ ModelR → JArray → PunchCardData
buildPunchCardData r records = map addSymbolSize aggregated
  where
  dataMap ∷ (String × String) >> Array Number
  dataMap =
    foldl dataMapFoldFn M.empty records

  dataMapFoldFn
    ∷ (String × String) >> Array Number
    → Json
    → (String × String) >> Array Number
  dataMapFoldFn acc js =
    let
      getValuesFromJson = getValues js
      getMaybeStringFromJson = getMaybeString js

      mbAbscissa =
        getMaybeStringFromJson =<< r.abscissa ^? D._value ∘ D._projection
      mbOrdinate =
        getMaybeStringFromJson =<< r.ordinate ^? D._value ∘ D._projection
      values =
        getValuesFromJson $ r.value ^? D._value ∘ D._projection

    in case mbAbscissa × mbOrdinate of
      (Just abscissa) × (Just ordinate) →
        let
          alterFn
            ∷ Maybe (Array Number)
            → Maybe (Array Number)
          alterFn Nothing =
            Just values
          alterFn (Just vs) =
            Just $ values ⊕ vs
        in M.alter alterFn (abscissa × ordinate) acc
      _ → acc

  aggregated ∷ (String × String) >> Number
  aggregated =
    flip map dataMap
    $ Ag.runAggregation
    $ fromMaybe Ag.Sum
    $ r.value ^? D._value ∘ D._transform ∘ _Just ∘ T._Aggregation

  minValue ∷ Number
  minValue = fromMaybe (-1.0 * infinity) $ F.minimum aggregated

  maxValue ∷ Number
  maxValue = fromMaybe infinity $ F.maximum aggregated

  distance ∷ Number
  distance = maxValue - minValue

  sizeDistance ∷ Number
  sizeDistance = r.maxSize - r.minSize

  addSymbolSize
    ∷ Number
    → Int × Number
  addSymbolSize val
    | distance ≡ zero = (Int.ceil val) × val
    | otherwise =
        (Int.ceil (r.maxSize - sizeDistance / distance * (maxValue - val))) × val

buildPunchCard ∷ Ax.Axes → ModelR → JArray → DSL OptionI
buildPunchCard axes r records = do
  E.tooltip do
    E.triggerItem
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12
    E.formatterItemArrayValue \{value} →
      let
        xIx = (map Int.ceil ∘ hush' ∘ readNumber) =<< value A.!! 0
        yIx = (map Int.ceil ∘ hush' ∘ readNumber) =<< value A.!! 1
        val = CCT.formatForeign <$> value A.!! 2
      in
        CCT.tableRows $ A.catMaybes
          [ map (D.jcursorLabel r.abscissa × _) $ xIx >>= A.index abscissaValues
          , map (D.jcursorLabel r.ordinate × _) $ yIx >>= A.index ordinateValues
          , map (D.jcursorLabel r.value × _) val
          ]

  E.colors colors

  when r.circular do
    E.polar $ pure unit
    E.angleAxis abscissaAxis
    E.radiusAxis ordinateAxis

  when (not r.circular) do
    E.xAxis abscissaAxis
    E.yAxis ordinateAxis

    E.grid $ E.containLabel true

  E.series series

  where
  punchCardData ∷ PunchCardData
  punchCardData = buildPunchCardData r records

  abscissaAxis ∷ ∀ i. DSL (ETP.AxisI i)
  abscissaAxis = do
    E.axisType $ ET.Category
    E.disabledBoundaryGap
    E.splitLine do
      E.shown
      E.lineStyle do
        E.dashedLine
        E.color $ C.rgba 9 9 9 1.0
    E.axisLine E.hidden
    E.items $ map ET.strItem abscissaValues

  ordinateAxis ∷ ∀ i. DSL (ETP.AxisI i)
  ordinateAxis = do
    E.axisType $ ET.Category
    E.axisLine E.hidden
    E.axisLabel $ E.margin $ margin + 2
    E.items $ map ET.strItem ordinateValues

  xAxisType ∷ Ax.AxisType
  xAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType
    <$> (r.abscissa ^? D._value ∘ D._projection)
    <*> pure axes

  yAxisType ∷ Ax.AxisType
  yAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType
    <$> (r.ordinate ^? D._value ∘ D._projection)
    <*> pure axes

  abscissaValues ∷ Array String
  abscissaValues =
    A.sortBy (Ax.compareWithAxisType xAxisType)
      $ A.fromFoldable
      $ Set.fromFoldable
      $ map fst
      $ M.keys punchCardData

  ordinateValues ∷ Array String
  ordinateValues =
    A.sortBy (Ax.compareWithAxisType yAxisType)
      $ A.fromFoldable
      $ Set.fromFoldable
      $ map snd
      $ M.keys punchCardData

  margin ∷ Int
  margin =
    fromMaybe 6
      $ F.maximum
      $ foldMap (\((a × o) × (v × _)) → if Just a ≡ A.head abscissaValues then [v / 2] else [])
      $ M.toList punchCardData

  series = E.scatter do
    if r.circular
      then E.polarCoordinateSystem
      else E.cartesianCoordinateSystem
    E.buildItems
      $ for_ (enumerate abscissaValues) \(xIx × abscissa) →
          for_ (enumerate ordinateValues) \(yIx × ordinate) →
            for_ (M.lookup (abscissa × ordinate) punchCardData) \(symbolSize × val) → E.addItem do
              E.symbolSize symbolSize
              E.buildValues do
                E.addValue $ Int.toNumber xIx
                E.addValue $ Int.toNumber yIx
                E.addValue val


before optimizing save

before optimizing save

{-
Copyright 2016 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 SlamData.Quasar.FS
  ( children
  , transitiveChildren
  , getNewName
  , move
  , listing
  , delete
  , messageIfFileNotFound
  , dirNotAccessible
  , fileNotAccessible
  , module Quasar.Error
  ) where

import SlamData.Prelude

import Control.Monad.Eff.Exception (error)

import Data.Argonaut as J
import Data.Array as Arr
import Data.Foldable as F
import Data.Lens ((.~), (^.), (^?), _Left)
import Data.List as List
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.String as S

import Quasar.Advanced.QuasarAF as QF
import Quasar.Data.JSONMode as QDJ
import Quasar.Error (QError(..))
import Quasar.FS as QFS
import Quasar.FS.Mount as QFSM
import Quasar.FS.Resource as QR
import Quasar.Types (AnyPath, DirPath, FilePath)

import SlamData.Config as Config
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Class (class QuasarDSL, liftQuasar)
import SlamData.Quasar.Data as QD

import SlamData.Workspace.Model as WM
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Deck.DeckId as DID
import SlamData.Workspace.Card.Draftboard.Pane as Pane

children
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
children dir = runExceptT do
  cs ← ExceptT $ listing dir
  let result = (R._root .~ dir) <$> cs
  -- TODO: do this somewhere more appropriate
  -- lift $ fromAff $ memoizeCompletionStrs dir result
  pure result

transitiveChildren
  ∷ ∀ f m
  . (Parallel f m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
transitiveChildren start = runExceptT do
  rs ← ExceptT $ children start
  cs ← parTraverse go rs
  pure $ rs <> join cs
  where
  go :: R.Resource → ExceptT QError m (Array R.Resource)
  go r = case R.getPath r of
    Left dir → do
      crs ← ExceptT $ transitiveChildren dir
      pure $ [r] <> crs
    Right _ → pure [r]

listing
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
listing p =
  map (map toResource) <$> liftQuasar (QF.dirMetadata p)
  where
  toResource ∷ QFS.Resource → R.Resource
  toResource res = case res of
    QFS.File path → R.File path
    QFS.Directory path →
      let workspaceName
            = S.stripSuffix (S.Pattern $ "." <> Config.workspaceExtension)
            ∘ P.runDirName =<< P.dirName path
      in case workspaceName of
        Just name → R.Workspace (p </> P.dir name)
        Nothing → R.Directory path
    QFS.Mount m → R.Mount $ either R.Database R.View $ QFSM.getPath m

-- | Generates a new resource name based on a directory path and a name for the
-- | resource. If the name already exists in the path a number is appended to
-- | the end of the name.
getNewName
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ DirPath
  → String
  → m (Either QError String)
getNewName parent name = do
  result ← liftQuasar (QF.dirMetadata parent)
  pure case result of
    Right items
      | exists name items → Right (getNewName' items 1)
      | otherwise → Right name
    Left QF.NotFound → Right name
    Left err → Left err
  where

  getNewName' ∷ Array QFS.Resource → Int → String
  getNewName' items i =
    let arr = S.split (S.Pattern ".") name
    in fromMaybe "" do
      body ← Arr.head arr
      suffixes ← Arr.tail arr
      let newName = S.joinWith "." $ Arr.cons (body <> " " <> show i) suffixes
      pure if exists newName items
           then getNewName' items (i + one)
           else newName

  exists ∷ String → Array QFS.Resource → Boolean
  exists n = F.any ((_ == n) ∘ printName ∘ QR.getName)

  printName ∷ Either (Maybe P.DirName) P.FileName → String
  printName = either (fromMaybe "" ∘ map P.runDirName) P.runFileName

-- | Will return `Just` in case the resource was successfully moved, and
-- | `Nothing` in case no resource existed at the requested source path.
move
  ∷ ∀ f m
  . (Monad m, QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → AnyPath
  → m (Either QError (Maybe AnyPath))
move src tgt = do
  let srcPath = R.getPath src
  runExceptT ∘ traverse cleanViewMounts $ srcPath ^? _Left

  case src of
    R.Workspace wsDir → void $ prepareWorkspaceForMoving wsDir
    _ → pure unit

  result ←
    case src of
      R.Mount _ → liftQuasar $ QF.moveMount srcPath tgt
      _ → liftQuasar $ QF.moveData srcPath tgt

  pure
    case result of
      Right _ → Right (Just tgt)
      Left QF.NotFound → Right Nothing
      Left err → Left err

  where
  prepareWorkspaceForMoving ∷ DirPath → m (QError ⊹ Unit)
  prepareWorkspaceForMoving wsDir = do
    eitherDid ← getWorkspaceRoot wsDir
    case eitherDid of
      Left e → pure $ Left e
      Right Nothing → pure $ Right unit
      Right (Just did) → do
        deck ← getDeck wsDir did
        case deck of
          Left e → pure $ Left e
          Right deck' → do
            newDeck ← oneDeck wsDir deck'
            case newDeck of
              Left e → pure $ Left e
              Right d → putDeck wsDir did d

  getWorkspaceRoot ∷ DirPath → m (QError ⊹ Maybe DID.DeckId)
  getWorkspaceRoot wsDir = do
    wsIndexArr ←
      liftQuasar $ QF.readFile QDJ.Readable (wsDir </> P.file "index") Nothing
    pure case wsIndexArr of
      Left e → Left e
      Right wsIArr → case Arr.head wsIArr of
        Nothing → Left $ Error $ error "incorrect workspace model"
        Just wmJS → case WM.decode wmJS of
          Left e → Left $ Error $ error e
          Right ok → Right ok.root

  getDeck ∷ DirPath → DID.DeckId → m (QError ⊹ DM.Deck)
  getDeck wsDir did = do
    deckJArr ←
      liftQuasar
        $ QF.readFile
          QDJ.Readable
          (wsDir </> P.dir (DID.deckIdToString did) </> P.file "index")
          Nothing
    pure case deckJArr of
      Left e → Left e
      Right arr → case Arr.head arr of
        Nothing → Left $ Error $ error "incorrect deck model"
        Just deckJS →
          case DM.decode deckJS of
            Left e → Left $ Error $ error e
            Right ok → Right ok

  putDeck ∷ DirPath → DID.DeckId → DM.Deck → m (QError ⊹ Unit)
  putDeck wsDir did deck =
    QD.save
      (wsDir </> P.dir (DID.deckIdToString did) </> P.file "index")
      (J.encodeJson $ Arr.singleton $ DM.encode deck)

  oneDeck ∷ DirPath → DM.Deck → m (QError ⊹ DM.Deck)
  oneDeck wsDir deck =
    let
      foldFn d = case _ of
        {model: CM.Draftboard m} → do
          for_ (List.catMaybes $ Pane.toList m.layout) \did → do
            d' ← getDeck wsDir  did
            for_ d' \deck' → do
              newDeck ← oneDeck wsDir deck'
              for_ newDeck $ putDeck wsDir did
          pure d
        {cardId, model: CM.Cache m} →
          let newM =
                S.replace
                  (S.Pattern $ P.printPath wsDir)
                  (S.Replacement $ either P.printPath P.printPath tgt)
                  <$> m
          in
           pure d{cards =
                     Arr.sortBy (\{cardId: a} {cardId: b} → compare a b)
                       $ Arr.cons {cardId, model: CM.Cache newM}
                       $ Arr.filter (_.cardId ⋙ eq cardId ⋙ not) d.cards
                 }

        _ → pure d
    in Right <$> Arr.foldM foldFn deck deck.cards

delete
  ∷ ∀ f m
  . (Monad m, QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → m (Either QError (Maybe R.Resource))
delete resource =
  runExceptT $
    if R.isMount resource || alreadyInTrash resource
    then
      forceDelete resource $> Nothing
    else
      moveToTrash resource `catchError` \(err ∷ QError) →
        forceDelete resource $> Nothing

  where
  msg ∷ String
  msg = "cannot delete"

  moveToTrash
    ∷ R.Resource
    → ExceptT QError m (Maybe R.Resource)
  moveToTrash res = do
    let
      d = (res ^. R._root) </> P.dir Config.trashFolder
      path = (res # R._root .~ d) ^. R._path
    name ← ExceptT $ getNewName d (res ^. R._name)
    ExceptT $ move res (path # R._nameAnyPath .~ name)
    pure ∘ Just $ R.Directory d

  alreadyInTrash ∷ R.Resource → Boolean
  alreadyInTrash res =
    case res ^. R._path of
      Left path → alreadyInTrash' path
      Right _ → alreadyInTrash' (res ^. R._root)

  alreadyInTrash' ∷ DirPath → Boolean
  alreadyInTrash' d =
    if d == P.rootDir
    then false
    else maybe false go $ P.peel d

    where
    go ∷ Tuple DirPath (Either P.DirName P.FileName) → Boolean
    go (Tuple d' name) =
      case name of
        Right _ → false
        Left n →
          if n == P.DirName Config.trashFolder
          then true
          else alreadyInTrash' d'

forceDelete
  ∷ ∀ f m
  . (QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → ExceptT QError m Unit
forceDelete res =
  case res of
    R.Mount _ →
      ExceptT ∘ liftQuasar $ QF.deleteMount (R.getPath res)
    _ → do
      let path = R.getPath res
      traverse cleanViewMounts $ path ^? _Left
      ExceptT ∘ liftQuasar $ QF.deleteData path

cleanViewMounts
  ∷ ∀ f m
  . (Parallel f m, QuasarDSL m)
  ⇒ DirPath
  → ExceptT QError m Unit
cleanViewMounts =
  parTraverse_ deleteViewMount <=< ExceptT ∘ transitiveChildren
  where
  deleteViewMount ∷ R.Resource → ExceptT QError m Unit
  deleteViewMount =
    case _ of
      R.Mount (R.View vp) →
        ExceptT ∘ liftQuasar $ QF.deleteMount (Right vp)
      _ → pure unit

messageIfFileNotFound
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ FilePath
  → String
  → m (Either QError (Maybe String))
messageIfFileNotFound path defaultMsg =
  handleResult <$> liftQuasar (QF.fileMetadata path)
  where
  handleResult ∷ ∀ a. Either QF.QError a → Either QError (Maybe String)
  handleResult (Left QF.NotFound) = Right (Just defaultMsg)
  handleResult (Left err) = Left err
  handleResult (Right _) = Right Nothing

dirNotAccessible
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ DirPath
  → m (Maybe QF.QError)
dirNotAccessible path =
  either Just (const Nothing) <$> liftQuasar (QF.dirMetadata path)

fileNotAccessible
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ FilePath
  → m (Maybe QF.QError)
fileNotAccessible path =
  either Just (const Nothing) <$> liftQuasar (QF.fileMetadata path)

{-
Copyright 2016 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 SlamData.Quasar.FS
  ( children
  , transitiveChildren
  , getNewName
  , move
  , listing
  , delete
  , messageIfFileNotFound
  , dirNotAccessible
  , fileNotAccessible
  , module Quasar.Error
  ) where

import SlamData.Prelude

import Data.Array as Arr
import Data.Foldable as F
import Data.Lens ((.~), (^.), (^?), _Left)
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.String as S

import Quasar.Advanced.QuasarAF as QF
import Quasar.Data.JSONMode as QDJ
import Quasar.Error (QError)
import Quasar.FS as QFS
import Quasar.FS.Mount as QFSM
import Quasar.FS.Resource as QR
import Quasar.Types (AnyPath, DirPath, FilePath)

import SlamData.Config as Config
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Class (class QuasarDSL, liftQuasar)

import SlamData.Workspace.Model as WM
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Deck.DeckId as DID
import SlamData.Workspace.Card.Draftboard.Pane as Pane

children
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
children dir = runExceptT do
  cs ← ExceptT $ listing dir
  let result = (R._root .~ dir) <$> cs
  -- TODO: do this somewhere more appropriate
  -- lift $ fromAff $ memoizeCompletionStrs dir result
  pure result

transitiveChildren
  ∷ ∀ f m
  . (Parallel f m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
transitiveChildren start = runExceptT do
  rs ← ExceptT $ children start
  cs ← parTraverse go rs
  pure $ rs <> join cs
  where
  go :: R.Resource → ExceptT QError m (Array R.Resource)
  go r = case R.getPath r of
    Left dir → do
      crs ← ExceptT $ transitiveChildren dir
      pure $ [r] <> crs
    Right _ → pure [r]

listing
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
listing p =
  map (map toResource) <$> liftQuasar (QF.dirMetadata p)
  where
  toResource ∷ QFS.Resource → R.Resource
  toResource res = case res of
    QFS.File path → R.File path
    QFS.Directory path →
      let workspaceName
            = S.stripSuffix (S.Pattern $ "." <> Config.workspaceExtension)
            ∘ P.runDirName =<< P.dirName path
      in case workspaceName of
        Just name → R.Workspace (p </> P.dir name)
        Nothing → R.Directory path
    QFS.Mount m → R.Mount $ either R.Database R.View $ QFSM.getPath m

-- | Generates a new resource name based on a directory path and a name for the
-- | resource. If the name already exists in the path a number is appended to
-- | the end of the name.
getNewName
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ DirPath
  → String
  → m (Either QError String)
getNewName parent name = do
  result ← liftQuasar (QF.dirMetadata parent)
  pure case result of
    Right items
      | exists name items → Right (getNewName' items 1)
      | otherwise → Right name
    Left QF.NotFound → Right name
    Left err → Left err
  where

  getNewName' ∷ Array QFS.Resource → Int → String
  getNewName' items i =
    let arr = S.split (S.Pattern ".") name
    in fromMaybe "" do
      body ← Arr.head arr
      suffixes ← Arr.tail arr
      let newName = S.joinWith "." $ Arr.cons (body <> " " <> show i) suffixes
      pure if exists newName items
           then getNewName' items (i + one)
           else newName

  exists ∷ String → Array QFS.Resource → Boolean
  exists n = F.any ((_ == n) ∘ printName ∘ QR.getName)

  printName ∷ Either (Maybe P.DirName) P.FileName → String
  printName = either (fromMaybe "" ∘ map P.runDirName) P.runFileName

-- | Will return `Just` in case the resource was successfully moved, and
-- | `Nothing` in case no resource existed at the requested source path.
move
  ∷ ∀ f m
  . (Monad m, QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → AnyPath
  → m (Either QError (Maybe AnyPath))
move src tgt = do
  let srcPath = R.getPath src
  runExceptT ∘ traverse cleanViewMounts $ srcPath ^? _Left
  result ←
    case src of
      R.Workspace wsDir → moveWorkspace wsDir
      R.Mount _ → liftQuasar $ QF.moveMount srcPath tgt
      _ → liftQuasar $ QF.moveData srcPath tgt
  pure
    case result of
      Right _ → Right (Just tgt)
      Left QF.NotFound → Right Nothing
      Left err → Left err
  where
  moveWorkspace ∷ DirPath → m (QError ⊹ Unit)
  moveWorkspace wsDir = do
    wsIndexArr ←
      liftQuasar $ QF.readFile QDJ.Readable (wsDir </> P.file "index") Nothing
    for_ wsIndexArr
      (Arr.head ⋙ traverse_
       (WM.decode ⋙ traverse_
        (_.root ⋙ traverse_ \did → do
            deckJArr ←
              liftQuasar
              $ QF.readFile
                  QDJ.Readable
                  (wsDir </> P.dir (DID.deckIdToString did) </> P.file "index")
                  Nothing
            for_ deckJArr
              (Arr.head ⋙ traverse_
               (DM.decode ⋙ traverse_ \deck → do
                   for_ (map _.model $ deck.cards) case _ of
                     CM.Draftboard m → for_ (Pane.toList m.layout) traceAnyA
                     CM.Cache m → do
                       traceAnyA "Cache"
                       traceAnyA m
                       traceAnyA "\n"
                     _ → pure unit
               ))
            traceAnyA did
        )))
    pure $ pure unit

  oneDeck ∷ DirPath → DM.Model → m (QError ⊹ Deck)
  oneDeck wsDir deck = for_ (deck.cards) case _ of
    CM.Draftboard m → for_ (Pane.toList m.layout) oneDeck
    CM.Cache m → do

delete
  ∷ ∀ f m
  . (Monad m, QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → m (Either QError (Maybe R.Resource))
delete resource =
  runExceptT $
    if R.isMount resource || alreadyInTrash resource
    then
      forceDelete resource $> Nothing
    else
      moveToTrash resource `catchError` \(err ∷ QError) →
        forceDelete resource $> Nothing

  where
  msg ∷ String
  msg = "cannot delete"

  moveToTrash
    ∷ R.Resource
    → ExceptT QError m (Maybe R.Resource)
  moveToTrash res = do
    let
      d = (res ^. R._root) </> P.dir Config.trashFolder
      path = (res # R._root .~ d) ^. R._path
    name ← ExceptT $ getNewName d (res ^. R._name)
    ExceptT $ move res (path # R._nameAnyPath .~ name)
    pure ∘ Just $ R.Directory d

  alreadyInTrash ∷ R.Resource → Boolean
  alreadyInTrash res =
    case res ^. R._path of
      Left path → alreadyInTrash' path
      Right _ → alreadyInTrash' (res ^. R._root)

  alreadyInTrash' ∷ DirPath → Boolean
  alreadyInTrash' d =
    if d == P.rootDir
    then false
    else maybe false go $ P.peel d

    where
    go ∷ Tuple DirPath (Either P.DirName P.FileName) → Boolean
    go (Tuple d' name) =
      case name of
        Right _ → false
        Left n →
          if n == P.DirName Config.trashFolder
          then true
          else alreadyInTrash' d'

forceDelete
  ∷ ∀ f m
  . (QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → ExceptT QError m Unit
forceDelete res =
  case res of
    R.Mount _ →
      ExceptT ∘ liftQuasar $ QF.deleteMount (R.getPath res)
    _ → do
      let path = R.getPath res
      traverse cleanViewMounts $ path ^? _Left
      ExceptT ∘ liftQuasar $ QF.deleteData path

cleanViewMounts
  ∷ ∀ f m
  . (Parallel f m, QuasarDSL m)
  ⇒ DirPath
  → ExceptT QError m Unit
cleanViewMounts =
  parTraverse_ deleteViewMount <=< ExceptT ∘ transitiveChildren
  where
  deleteViewMount ∷ R.Resource → ExceptT QError m Unit
  deleteViewMount =
    case _ of
      R.Mount (R.View vp) →
        ExceptT ∘ liftQuasar $ QF.deleteMount (Right vp)
      _ → pure unit

messageIfFileNotFound
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ FilePath
  → String
  → m (Either QError (Maybe String))
messageIfFileNotFound path defaultMsg =
  handleResult <$> liftQuasar (QF.fileMetadata path)
  where
  handleResult ∷ ∀ a. Either QF.QError a → Either QError (Maybe String)
  handleResult (Left QF.NotFound) = Right (Just defaultMsg)
  handleResult (Left err) = Left err
  handleResult (Right _) = Right Nothing

dirNotAccessible
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ DirPath
  → m (Maybe QF.QError)
dirNotAccessible path =
  either Just (const Nothing) <$> liftQuasar (QF.dirMetadata path)

fileNotAccessible
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ FilePath
  → m (Maybe QF.QError)
fileNotAccessible path =
  either Just (const Nothing) <$> liftQuasar (QF.fileMetadata path)


Change Array's element type to String to match example

module Control.Bind
  ( class Bind, bind, (>>=)
  , bindFlipped, (=<<)
  , class Discard, discard
  , join
  , composeKleisli, (>=>)
  , composeKleisliFlipped, (<=<)
  , ifM
  , module Data.Functor
  , module Control.Apply
  , module Control.Applicative
  ) where

import Control.Applicative (class Applicative, liftA1, pure, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Category (identity)

import Data.Function (flip)
import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit)

-- | The `Bind` type class extends the [`Apply`](#apply) type class with a
-- | "bind" operation `(>>=)` which composes computations in sequence, using
-- | the return value of one computation to determine the next computation.
-- |
-- | The `>>=` operator can also be expressed using `do` notation, as follows:
-- |
-- | ```purescript
-- | x >>= f = do y <- x
-- |              f y
-- | ```
-- |
-- | where the function argument of `f` is given the name `y`.
-- |
-- | Instances must satisfy the following law in addition to the `Apply`
-- | laws:
-- |
-- | - Associativity: `(x >>= f) >>= g = x >>= (\k -> f k >>= g)`
-- |
-- | Associativity tells us that we can regroup operations which use `do`
-- | notation so that we can unambiguously write, for example:
-- |
-- | ```purescript
-- | do x <- m1
-- |    y <- m2 x
-- |    m3 x y
-- | ```
class Apply m <= Bind m where
  bind :: forall a b. m a -> (a -> m b) -> m b

infixl 1 bind as >>=

-- | `bindFlipped` is `bind` with its arguments reversed. For example:
-- |
-- | ```purescript
-- | print =<< random
-- | ```
bindFlipped :: forall m a b. Bind m => (a -> m b) -> m a -> m b
bindFlipped = flip bind

infixr 1 bindFlipped as =<<

instance bindFn :: Bind ((->) r) where
  bind m f x = f (m x) x

-- | The `bind`/`>>=` function for `Array` works by applying a function to
-- | each element in the array, and flattening the results into a single,
-- | new array.
-- |
-- | Array's `bind`/`>>=` works like a nested for loop. Each `bind` adds
-- | another level of nesting in the loop. For example:
-- | ```
-- | foo :: Array String
-- | foo =
-- |   ["a", "b"] >>= \eachElementInArray1 ->
-- |     ["c", "d"] >>= \eachElementInArray2
-- |       pure (eachElementInArray1 <> eachElementInArray2)
-- |
-- | -- In other words...
-- | foo
-- | -- ... is the same as...
-- | [ ("a" <> "c"), ("a" <> "d"), ("b" <> "c"), ("b" <> "d") ]
-- | -- which simplifies to...
-- | [ "ac", "ad", "bc", "bd" ]
-- | ```
instance bindArray :: Bind Array where
  bind = arrayBind

foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b

-- | A class for types whose values can safely be discarded
-- | in a `do` notation block.
-- |
-- | An example is the `Unit` type, since there is only one
-- | possible value which can be returned.
class Discard a where
  discard :: forall f b. Bind f => f a -> (a -> f b) -> f b

instance discardUnit :: Discard Unit where
  discard = bind

-- | Collapse two applications of a monadic type constructor into one.
join :: forall a m. Bind m => m (m a) -> m a
join m = m >>= identity

-- | Forwards Kleisli composition.
-- |
-- | For example:
-- |
-- | ```purescript
-- | import Data.Array (head, tail)
-- |
-- | third = tail >=> tail >=> head
-- | ```
composeKleisli :: forall a b c m. Bind m => (a -> m b) -> (b -> m c) -> a -> m c
composeKleisli f g a = f a >>= g

infixr 1 composeKleisli as >=>

-- | Backwards Kleisli composition.
composeKleisliFlipped :: forall a b c m. Bind m => (b -> m c) -> (a -> m b) -> a -> m c
composeKleisliFlipped f g a = f =<< g a

infixr 1 composeKleisliFlipped as <=<

-- | Execute a monadic action if a condition holds.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = ifM ((< 0.5) <$> random)
-- |          (trace "Heads")
-- |          (trace "Tails")
-- | ```
ifM :: forall a m. Bind m => m Boolean -> m a -> m a -> m a
ifM cond t f = cond >>= \cond' -> if cond' then t else f

module Control.Bind
  ( class Bind, bind, (>>=)
  , bindFlipped, (=<<)
  , class Discard, discard
  , join
  , composeKleisli, (>=>)
  , composeKleisliFlipped, (<=<)
  , ifM
  , module Data.Functor
  , module Control.Apply
  , module Control.Applicative
  ) where

import Control.Applicative (class Applicative, liftA1, pure, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Category (identity)

import Data.Function (flip)
import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit)

-- | The `Bind` type class extends the [`Apply`](#apply) type class with a
-- | "bind" operation `(>>=)` which composes computations in sequence, using
-- | the return value of one computation to determine the next computation.
-- |
-- | The `>>=` operator can also be expressed using `do` notation, as follows:
-- |
-- | ```purescript
-- | x >>= f = do y <- x
-- |              f y
-- | ```
-- |
-- | where the function argument of `f` is given the name `y`.
-- |
-- | Instances must satisfy the following law in addition to the `Apply`
-- | laws:
-- |
-- | - Associativity: `(x >>= f) >>= g = x >>= (\k -> f k >>= g)`
-- |
-- | Associativity tells us that we can regroup operations which use `do`
-- | notation so that we can unambiguously write, for example:
-- |
-- | ```purescript
-- | do x <- m1
-- |    y <- m2 x
-- |    m3 x y
-- | ```
class Apply m <= Bind m where
  bind :: forall a b. m a -> (a -> m b) -> m b

infixl 1 bind as >>=

-- | `bindFlipped` is `bind` with its arguments reversed. For example:
-- |
-- | ```purescript
-- | print =<< random
-- | ```
bindFlipped :: forall m a b. Bind m => (a -> m b) -> m a -> m b
bindFlipped = flip bind

infixr 1 bindFlipped as =<<

instance bindFn :: Bind ((->) r) where
  bind m f x = f (m x) x

-- | The `bind`/`>>=` function for `Array` works by applying a function to
-- | each element in the array, and flattening the results into a single,
-- | new array.
-- |
-- | Array's `bind`/`>>=` works like a nested for loop. Each `bind` adds
-- | another level of nesting in the loop. For example:
-- | ```
-- | foo :: Array Int
-- | foo =
-- |   ["a", "b"] >>= \eachElementInArray1 ->
-- |     ["c", "d"] >>= \eachElementInArray2
-- |       pure (eachElementInArray1 <> eachElementInArray2)
-- |
-- | -- In other words...
-- | foo
-- | -- ... is the same as...
-- | [ ("a" <> "c"), ("a" <> "d"), ("b" <> "c"), ("b" <> "d") ]
-- | -- which simplifies to...
-- | [ "ac", "ad", "bc", "bd" ]
-- | ```
instance bindArray :: Bind Array where
  bind = arrayBind

foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b

-- | A class for types whose values can safely be discarded
-- | in a `do` notation block.
-- |
-- | An example is the `Unit` type, since there is only one
-- | possible value which can be returned.
class Discard a where
  discard :: forall f b. Bind f => f a -> (a -> f b) -> f b

instance discardUnit :: Discard Unit where
  discard = bind

-- | Collapse two applications of a monadic type constructor into one.
join :: forall a m. Bind m => m (m a) -> m a
join m = m >>= identity

-- | Forwards Kleisli composition.
-- |
-- | For example:
-- |
-- | ```purescript
-- | import Data.Array (head, tail)
-- |
-- | third = tail >=> tail >=> head
-- | ```
composeKleisli :: forall a b c m. Bind m => (a -> m b) -> (b -> m c) -> a -> m c
composeKleisli f g a = f a >>= g

infixr 1 composeKleisli as >=>

-- | Backwards Kleisli composition.
composeKleisliFlipped :: forall a b c m. Bind m => (b -> m c) -> (a -> m b) -> a -> m c
composeKleisliFlipped f g a = f =<< g a

infixr 1 composeKleisliFlipped as <=<

-- | Execute a monadic action if a condition holds.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = ifM ((< 0.5) <$> random)
-- |          (trace "Heads")
-- |          (trace "Tails")
-- | ```
ifM :: forall a m. Bind m => m Boolean -> m a -> m a -> m a
ifM cond t f = cond >>= \cond' -> if cond' then t else f