tried to speed up Evaluator tests

tried to speed up Evaluator tests

module Test.Evaluator where

import Prelude
import Data.Either (Either(..))
import Data.Tuple (Tuple(..))
import Data.StrMap as M
-- import Data.List (List, singleton)

-- import Control.Monad.Writer (Writer, tell)

import Parser (definitions, expression, runParserIndent)
import Evaluator (eval, eval1, runEvalM, defsToEnv,Env)
import Test.Parser (prelude, parsedPrelude)

import Test.Utils (Test, tell, padLeft)

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

eval1test :: String -> String -> String -> Test Unit
eval1test name input expected = case (Tuple (runParserIndent expression input) (runParserIndent expression expected)) of
  (Tuple (Right inExp) (Right expExp)) ->
    case runEvalM (eval1 M.empty inExp) of
      (Right eval1Exp) ->
        if eval1Exp == expExp
          then pure unit -- log $ "Eval success (" ++ name ++ ")"
          else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show eval1Exp) <> "\n"
            <> "Expected:\n"
            <> padLeft (show expExp)
      (Left err) -> tell'
        $ "Eval fail (" <> name <> "):\n"
        <> padLeft (show err)
  _ -> tell' $ "Parse fail (" <> name <> ")"

eval1EnvTest :: String -> String -> String -> String -> Test Unit
eval1EnvTest name env input expected = case (Tuple (Tuple (runParserIndent expression input) (runParserIndent expression expected)) (runParserIndent definitions env)) of
  (Tuple (Tuple (Right inExp) (Right expExp)) (Right defs)) ->
    case runEvalM (eval1 (defsToEnv defs) inExp) of
      (Right eval1Exp) ->
        if eval1Exp == expExp
          then pure unit -- log $ "Eval success (" <> name <> ")"
          else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show eval1Exp) <> "\n"
            <> "Expected:\n"
            <> padLeft (show expExp)
      (Left err) -> tell'
        $ "Eval fail (" <> name <> "):\n"
        <> padLeft (show err)
  _ -> tell' $ "Parse fail (" <> name <> ")"

evalEnvTest :: String -> String -> String -> String -> Test Unit
evalEnvTest name env input expected = case (Tuple (Tuple (runParserIndent expression input) (runParserIndent expression expected)) (runParserIndent definitions env)) of
  (Tuple (Tuple (Right inExp) (Right expExp)) (Right defs)) ->
    let evalExp = eval (defsToEnv defs) inExp in
      if evalExp == expExp
        then pure unit -- log $ "Eval success (" ++ name ++ ")"
        else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input String:\n"
            <> padLeft input <> "\n"
            <> "Input Parsed:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show evalExp) <> "\n"
            <> "Expected String:\n"
            <> padLeft expected <> "\n"
            <> "Expected Parsed:\n"
            <> padLeft (show expExp) <> "\n"
            <> "Definitions String:\n"
            <> padLeft env <> "\n"
            <> "Definitions Parsed:\n"
            <> padLeft (show defs)
  (Tuple (Tuple pi pe) pd) -> tell'
     $ "Parse fail (" <> name <> "):\n"
    <> "Input:\n"
    <> padLeft (show pi) <> "\n"
    <> "Expected:\n"
    <> padLeft (show pe) <> "\n"
    <> "Definitions:\n"
    <> padLeft (show pd)

preludeEnv :: Env
preludeEnv = defsToEnv parsedPrelude

evalPreludeTest :: String -> String -> String -> Test Unit
evalPreludeTest name input expected = case (Tuple (runParserIndent expression input) (runParserIndent expression expected)) of
  (Tuple (Right inExp) (Right expExp)) ->
    let evalExp = eval preludeEnv inExp in
      if evalExp == expExp
        then pure unit -- log $ "Eval success (" ++ name ++ ")"
        else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input String:\n"
            <> padLeft input <> "\n"
            <> "Input Parsed:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show evalExp) <> "\n"
            <> "Expected String:\n"
            <> padLeft expected <> "\n"
            <> "Expected Parsed:\n"
            <> padLeft (show expExp) <> "\n"
  (Tuple pi pe) -> tell'
     $ "Parse fail (" <> name <> "):\n"
    <> "Input:\n"
    <> padLeft (show pi) <> "\n"
    <> "Expected:\n"
    <> padLeft (show pe) <> "\n"

runTests :: Test Unit
runTests = do
  eval1test "add" "1+1" "2"
  eval1test "power" "2^10" "1024"
  eval1test "append" "[1] ++ [2]" "[1, 2]"
  eval1test "cons" "True:[]" "[True]"
  eval1test "lambda" "(\\a b -> a + b) 1 2" "1 + 2"
  eval1test "section1" "(*5) 7" "7 * 5"
  eval1test "section2" "(10<) 8" "10 < 8"
  eval1test "prefix" "(&&) True True" "True && True"
  eval1test "if_then_else" "if True then 42 else 0" "42"
  eval1test "pattern_matching1" "(\\(x:xs) -> x) [1, 2, 3]" "1"
  eval1test "pattern_matching2" "(\\[a, b, c] -> c) [1, 2, 3]" "3"
  eval1test "pattern_matching3" "(\\(a, b) (c, d, e) -> d) (1, 2) (3, 2*2, 5)" "2*2"
  eval1test "lambda2" "(\\x y -> [0, x, y, x + y]) 1 2" "[0, 1, 2, 1 + 2]"
  eval1test "string1" "\"as\" ++ \"df\"" "\"asdf\""
  eval1test "string2" "'a' : \"sdf\"" "\"asdf\""

  eval1EnvTest "double_func" "double x = x + x" "double 10" "10 + 10"
  eval1EnvTest "map_func1" "map f [] = []\nmap f (x:xs) = f x : map f xs" "map (^2) []" "[]"
  eval1EnvTest "map_func2" "map f [] = []\nmap f (x:xs) = f x : map f xs" "map (^2) [1, 2, 3]" "(^2) 1 : map (^2) [2, 3]"

  evalEnvTest "evalAll1" "" "1 + 2 + 3" "6"
  evalEnvTest "evalAll2" "" "(2^10) > (10^2)" "True"
  evalEnvTest "evalAll3" "" "3" "3"
  evalEnvTest "evalAll4" "" "x + y" "x + y"
  evalEnvTest "evalAll5" "" "(2 * 5) * x + 2 ^ 3" "10 * x + 8"
  evalEnvTest "evalAll6" "" "1 / 0" "1 / 0"

  evalEnvTest "evalNegNumber1" "" "(-3) - (-4)" "1"
  evalEnvTest "evalNegNumber2" "" "(-2) * (-2)" "4"
  evalEnvTest "evalNegNumber3" "" "-(-(5*5) + 6*6) + 7*7" (show (-(-(5*5) + 6*6) + 7*7)) -- 38
  evalEnvTest "evalNegNumber4" "" "-3 * 7 + 23" "2"

  evalEnvTest "if1" "" "if 10 > 5 then 10 else 5" "10"
  evalEnvTest "if2" "" "if 2 /= 2 then 1 else 0" "0"
  evalEnvTest "if3" "" "if x >= y then 5 * 5 else 6 * 6" "if x >= y then 5 * 5 else 6 * 6"

  evalEnvTest "env1" "x = 10" "x" "10"
  evalEnvTest "env2" "x = 10\ny = 20" "x * y" "200"
  evalEnvTest "env3" "double x = x + x" "double 10" "20"
  evalEnvTest "env4" "double x = x + x" "double (double (double 10))" "80"
  evalEnvTest "env5" "double x = x + x" "double $ double $ double 10" "80"
  evalEnvTest "env6" "double x = x + x" "(double . double . double) 10" "80"
  evalEnvTest "env6" "length (_:xs) = 1 + length xs\nlength [] = 0" "length [1, 2, 3, 4, 5]" "5"

  evalEnvTest "eval_list" "" "[2 + 2, 3 * 3]" "[4, 9]"
  evalEnvTest "eval_tuple" "" "(2+2, 3 * 3)" "(4, 9)"

  -- This test gets stuck in an endless loop,
  -- evalEnvTest "fix" "f x = f x" "f 10" "f 10"

  evalEnvTest "fac" "fac 1 = 1\nfac n = n * fac (n - 1)" "fac 6" "720"
  evalPreludeTest "prelude" "sum (map (^2) [1,2,3,4])" "30"

  evalEnvTest "TAE2a"
    ( prelude <> "\n" <>
      "pair (x:y:rs) = (x, y) : pair (y:rs)\n" <>
      "pair _        = []")
    "pair [1, 2, 3, 4]"
    "[(1, 2), (2, 3), (3, 4)]"
  evalPreludeTest "TAE2b" "foldr (\\a b -> a + b * 10) 0 [3, 2, 1]" "123"
  evalEnvTest "TAE2c"
    (prelude <> "\nsublist f t ls = drop f (take (t + f) ls)\n")
    "sublist 1 3 [0, 1, 2, 3, 4]"
    "[1, 2, 3]"

  evalPreludeTest "TAE3a" "map (>= 2) [1, 2, 3]" "[False, True, True]"
  evalPreludeTest "TAE3b" "foldr (\\a b -> b ++ [a]) [] [1, 2, 3]" "[3, 2, 1]"
  evalPreludeTest "TAE3c" "take 3 (iterate (3*) 1)" "[1, 3, 9]"
  evalPreludeTest "TAE3d" "filter (const True) [1, 3, 5, 7]" "[1, 3, 5, 7]"
  evalPreludeTest "TAE3e" "map (length . snd) [(7, \"sieben\"), (1, \"eins\")]" "[6, 4]"
  evalPreludeTest "TAE3f" "foldr (:) [3, 4] [1, 2]" "[1, 2, 3, 4]"
  evalPreludeTest "TAE3g" "foldl (\\(i, c) s -> (i + 1, c + length s)) (0, 0) [\"a\", \"bc\", \"defg\"]" "(3, 7)"

  evalEnvTest "TAT2a"
    (prelude <> "\nnth ls n = head (drop n ls)\n")
    "nth [0, 1, 2, 3] 2"
    "2"
  evalEnvTest "TAT2b"
    ( prelude <> "\n" <>
      "smallest (x:y:rs) = if x < y then smallest (x:rs) else smallest (y:rs)\n" <>
      "smallest [x]      = x")
    "smallest [5, 3, 7]"
    "3"
  evalPreludeTest "TAT2c" "foldl (\\(s, p) i -> (i + s, i * p)) (0, 1) [2, 3, 4]" "(9, 24)"

  evalPreludeTest "TAT3a" "map (2^) [1, 2, 3]" "[2, 4, 8]"
  evalPreludeTest "TAT3b" "foldl (*) 1 [1, 2, 3, 4]" "24"
  evalPreludeTest "TAT3c" "map (== 3) [1, 2, 3, 4]" "[False, False, True, False]"
  evalPreludeTest "TAT3d" "filter (/= 's') \"asdf\"" "\"adf\""
  evalPreludeTest "TAT3e" "map (fst . head) [[(1, 2)], [(3, 4)]]" "[1, 3]"
  evalPreludeTest "TAT3f" "foldl (-) 10 [1, 2, 3]" "4"
  evalPreludeTest "TAT3g" "zipWith (\\a b -> map (+a) b) [1, 2] [[3, 4], [5, 6]]" "[[4, 5], [7, 8]]"

  evalEnvTest "string_third1" "thrd (_:(_:(x:_))) = x" "thrd \"1234\"" "'3'"
  evalEnvTest "string_third2" "thrd [_,_,x,_] = x" "thrd \"1234\"" "'3'"

  evalEnvTest "pattern_matching4" "f ( x :  y : z : rs  ) = (x + y + z) * length rs\nlength (_:xs) = 1 + length xs\nlength [] = 0" "f [2, 3, 5, 8, 11]" "20"
  evalEnvTest "pattern_matching5" "f ( [ x ] : [ y , z ] : [ ] ) = x + y + z" "f [[1],[2,3]]" "6"
  evalEnvTest "pattern_matching6" "f [  [ x ] , [ y , z ] ] = x + y + z" "f [[1],[2,3]]" "6"
  evalEnvTest "pattern_matching7" "f [(a:b:c:rs1), (x:y:z:rs2)] = a * x + b * y + c * z" "f [[1, 2, 3], [100, 10, 1]]" "123"

  evalEnvTest "eval_names" "nat = [1, 2, 3, 4, 5]" "nat" "[1, 2, 3, 4, 5]"

  evalPreludeTest "infix_functions_1" "3 `take` (2 `drop` [1, 2, 3, 4, 5, 6, 7])" "[3, 4, 5]"
  evalPreludeTest "infix_functions_2" "(\\x -> x `mod` 2 == 0) `filter` [1, 2, 3, 4, 5, 6]" "[2, 4, 6]"
  evalPreludeTest "infix_functions_3" "(*2) `map` [1, 2, 3]" "[2, 4, 6]"

  evalPreludeTest "arithmetic_sequences_1" "sum [1, 3 .. 100]" "2500"
  evalPreludeTest "arithmetic_sequences_3" "length [ 7 * 7, 8 * 8 .. 42 * 42]" "115"
  evalPreludeTest "arithmetic_sequences_5" "sum $ take 100 [500 ..]" "54950"
  evalPreludeTest "arithmetic_sequences_6" "[1, -1 .. 0]" "[1]"
  evalPreludeTest "arithmetic_sequences_7" "sum [10, 9 .. -10]" "0"
  evalPreludeTest "arithmetic_sequences_8" "[True .. False]" "[]"
  evalPreludeTest "arithmetic_sequences_9" "[True, False ..]" "[True, False]"
  evalPreludeTest "arithmetic_sequences_11" "[False, True ..]" "[False, True]"
  evalPreludeTest "arithmetic_sequences_12" "[True, False ..]" "[True, False]"
  evalPreludeTest "arithmetic_sequences_13" "[1 .. 10]" "[1,2,3,4,5,6,7,8,9,10]"
  evalPreludeTest "arithmetic_sequences_14" "[5, 9 .. 20]" "[5, 9, 13, 17]"
  evalPreludeTest "arithmetic_sequences_15" "take 5 [3, -1 ..]" "[3, -1, -5, -9, -13]"
  evalPreludeTest "arithmetic_sequences_16" "take 11 [-5 ..]" "[-5, -4, -3, -2, -1, 0, 1, 2 ,3, 4, 5]"
  evalPreludeTest "arithmetic_sequences_17" "[2147483647 ..]" "[2147483647]"
  evalPreludeTest "arithmetic_sequences_18" "[2147483644, 2147483646 ..]" "[2147483644, 2147483646]"
  evalPreludeTest "arithmetic_sequences_19" "[-2147483648]" "[-2147483648]"
  evalPreludeTest "arithmetic_sequences_20" "[-2147483645, -2147483647 ..]" "[-2147483645, -2147483647]"

  evalPreludeTest "list_comprehension_1" "[ x | x <- [1 .. 10], even x]" "[2, 4, 6, 8, 10]"
  evalPreludeTest "list_comprehension_2" "[ (x, y) | x <- [1 .. 3], y <- [1 .. 3], x + y == 4]" "[(1,3), (2,2), (3,1)]"
  evalPreludeTest "list_comprehension_3" "(\\x -> [ x | let x = 1]) 2"    "[1]"
  evalPreludeTest "list_comprehension_4" "[ x | let x = 1, True, let x = 'a']" "['a']"
  evalPreludeTest "list_comprehension_5" "[ y | y <- [1 .. 10], y < y]"  "[]"
  evalPreludeTest "list_comprehension_6" "[ [ y | y <- reverse x] | x <- [[1 .. 10]]]" "[[10, 9, 8, 7, 6, 5, 4, 3, 2, 1]]"
  evalPreludeTest "list_comprehension_7" "[ x | x <- [1 .. 5], y <- [x .. 5]]" "[1,1,1,1,1, 2,2,2,2, 3,3,3, 4,4, 5]"
  evalPreludeTest "list_comprehension_8" "[x | x <- \"wer misst zu viele gabeln\", elem x \"itzgw\"]" "\"witzig\""
  evalPreludeTest "list_comprehension_9" "[(x, z) | x <- [1 .. 5], z <- [y | y <- [1 .. 5], mod x y == 0] ]" "[(1,1), (2,1), (2,2), (3,1), (3,3), (4,1), (4,2), (4,4), (5,1), (5,5)]"
  evalPreludeTest "list_comprehension_10" "[z | let y = [True, True, False], z <- y, z]" "[True, True]"

  --should fail, due to overlapping defs
  --evalPreludeTest "let_expression_1" "let x = 1; x = 'c' in x" "'c'"
  evalPreludeTest "let_expression_2" "let (x, y) = (\\g -> g, \"Hello\") in x y" "\"Hello\""
  evalPreludeTest "let_expression_3" "let x = 1 ; y = x + 1; z = y + 1 in x + y + z" "6"
  evalPreludeTest "let_expression_4" "let x = 1 in let y = 2 in x + y" "3"
  --                                                                                should be: "True"
  evalPreludeTest "let_expression_5" "(let x = [1,2,3] in x) == (let x = 1; y = 2; z = 3 in [x,y,z])" "[1,2,3] == [1,2,3]"
  evalPreludeTest "let_expression_6" "let sum = \\x -> x ; y = sum [1,2,3] in y" "[1,2,3]"

  testsADT

testsADT :: Test Unit
testsADT = do
{-
  eval1test "constr-1"
    "1 :+ 1"
    "1 :+ 1"
  eval1test "constr-2"
    "Foo"
    "Foo"
  eval1test "constr-3"
    "Foo 1"
    "Foo 1"
  eval1test "constr-4"
    "Foo 1 2"
    "Foo 1 2"
-}
  eval1test "constr-5"
    "if True then Foo else Bar"
    "Foo"

  eval1test "constr-6"
    "if False then Foo else Bar"
    "Bar"

  eval1EnvTest "func-1"
    "foo (Foo x) = x"
    "foo (Foo 1)"
    "1"

  eval1EnvTest "func-2"
    "foo (Foo x y) = x + y"
    "foo (Foo 1 2)"
    "1 + 2"

  eval1EnvTest "map-func-3"
    "map f Nil = Nil\nmap f (Cons x xs) = Cons (f x) (map f xs)"
    "map (1 +) (Cons 1 (Cons 2 (Cons 3 Nil)))"
    "Cons ((1 +) 1) (map (1 +) (Cons 2 (Cons 3 Nil)))"

  eval1EnvTest "map-func-4"
    "map f Nil = Nil\nmap f (x::xs) = f x :: map f xs"
    "map (^2) Nil"
    "Nil"

  eval1EnvTest "map-func-5"
    "map f Nil = Nil\nmap f (x::xs) = f x :: map f xs"
    "map (^2) (1 :: (2 :: (3 :: Nil)))"
    "(^2) 1 :: map (^2) (2 :: (3 :: Nil))"

  eval1EnvTest "tuple-1"
    "fst (Tuple a _) = a\n"
    "fst (Tuple (Tuple 1 2) 3)"
    "Tuple 1 2"

  eval1EnvTest "tuple-2"
    "snd (Tuple _ a) = a\n"
    "snd (Tuple (Tuple 1 2) 3)"
    "3"

  eval1EnvTest "infix-1"
    "fst (a ::: _) = a"
    "fst (1 ::: 3)"
    "1"

  eval1EnvTest "infix-2"
    "snd (_ ::: a) = a"
    "snd (1 ::: 3)"
    "3"

  evalEnvTest "infix-3"
    "map f g (a :-: b) = f a :-: g b\ndouble = map (*2) (*2)"
    "double (2 :-: 3)"
    "4 :-: 6"

  evalEnvTest "prefix-1"
    "map f g (Tuple x y) = Tuple (f x) (g y)\ndouble = map (*2) (*2)"
    "double (Tuple 2 3)"
    "Tuple 4 6"

  evalEnvTest "constr-nested-1"
    "foo (Bar (Bar a) Foo) = Foo a a"
    "foo (Bar (Bar Foo) Foo)"
    "Foo Foo Foo"

  evalEnvTest "pdp1-a" envPdP1
    ("numParts " <> bspPdP1)
    "13"

  evalEnvTest "pdp1-b" envPdP1
    ("foldBauwerk Rechteck Spitze Split " <> bspPdP1)
    bspPdP1

  evalEnvTest "pdp1-c" envPdP1
    ("maxHoehe " <> bspPdP1)
    "87"

  evalEnvTest "pdp1-d" envPdP1
    ("numPeaks " <> bspPdP1)
    "5"

  evalEnvTest "pdp1-e" envPdP1
    ("wellformed " <> bspPdP1)
    "True"

  evalEnvTest "fp-a" envPdP2
    ("foldMixTree QuadSplit Split Color " <> bspPdP2)
    bspPdP2

  evalEnvTest "fp-b" envPdP2
    ("areas " <> bspPdP2)
    "22"

  evalEnvTest "fp-c" envPdP2
    ("wellformedTree " <> bspPdP2)
    "True"

  evalEnvTest "rose-fold" envRoseFold
    ("foldRoseTree Node Leaf " <> bspRoseFold)
    bspRoseFold

  evalEnvTest "bin-tree-fold-1" envBinTree
    ("foldBinTree Nil (:::) " <> bspBinTree)
    bspBinTree

  evalEnvTest "bin-tree-fold-2" envBinTree
    ("nils " <> bspBinTree)
    "6"

  evalEnvTest "bin-tree-fold-1" envBinTree
    ("foldBinTree Nil (:::) " <> bspBinTree2)
    bspBinTree2

  evalEnvTest "bin-tree-fold-2" envBinTree
    ("nils (" <> bspBinTree2 <> ")")
    "2"

envRoseFold :: String
envRoseFold = """
map _ [] = []
map f (x:xs) = f x : map f xs

foldRoseTree fN fL (Leaf a) = fL a
foldRoseTree fN fL (Node ts) = fN (map (foldRoseTree fN fL) ts)
"""

bspRoseFold :: String
bspRoseFold = """(Node
  [ Leaf 1
  , Leaf 2
  , Leaf 3
  , Node
    [ Leaf 4
    , Leaf 5
    , Leaf 6 ]])
"""

envBinTree :: String
envBinTree = """
foldBinTree fNil fNode Nil = fNil
foldBinTree fNil fNode (l ::: r) = fNode
  (foldBinTree fNil fNode l)
  (foldBinTree fNil fNode r)

nils = foldBinTree 1 (+)
"""

bspBinTree :: String
bspBinTree = "(((Nil ::: Nil) ::: Nil) ::: (Nil ::: (Nil ::: Nil)))"

bspBinTree2 :: String
bspBinTree2 = "Nil ::: Nil"

envPdP1 :: String
envPdP1 = """
foldBauwerk fRechteck fSpitze fSplit (Rechteck br ho bw)
  = fRechteck br ho (foldBauwerk fRechteck fSpitze fSplit bw)
foldBauwerk fRechteck fSpitze fSplit (Spitze br ho)
  = fSpitze br ho
foldBauwerk fRechteck fSpitze fSplit (Split l r)
  = fSplit (foldBauwerk fRechteck fSpitze fSplit l) (foldBauwerk fRechteck fSpitze fSplit r)

numParts (Rechteck _ _ bw) = 1 + numParts bw
numParts (Spitze _ _) = 1
numParts (Split l r)  = numParts l + numParts r

max a b = if a < b then b else a

maxHoehe = foldBauwerk
  (\_ ho hor -> ho + hor)
  (\_ h -> h)
  max

numPeaks = foldBauwerk (\_ _ ps -> ps) (\_ _ -> 1) (+)

wellformed
  = (> 0)
  . foldBauwerk
    (\br _ br' -> if br' < 0 || br' > br then -1 else br)
    (\br _ -> br)
    (\l r -> l + r)
"""

bspPdP1 :: String
bspPdP1 = """(Rechteck 50 20
  (Split
    (Rechteck 20 15
      (Split
        (Rechteck 10 20
          (Rechteck 8 18
            (Spitze 8 14)))
        (Rechteck 8 17
          (Spitze 8 14))))
    (Rechteck 20 15
      (Split
        (Rechteck 8 17
          (Spitze 8 14))
        (Rechteck 10 20
          (Split
            (Spitze 5 17)
            (Spitze 5 17)))))))
"""

envPdP2 :: String
envPdP2 = """
foldMixTree fQ fS fC (QuadSplit ro ru lu lo) = fQ
  (foldMixTree fQ fS fC ro)
  (foldMixTree fQ fS fC ru)
  (foldMixTree fQ fS fC lu)
  (foldMixTree fQ fS fC lo)
foldMixTree fQ fS fC (Split a ts)
  = fS a (map (\(d, t) -> (d, foldMixTree fQ fS fC t)) ts)
foldMixTree fQ fS fC (Color c) = fC c

wellformed xs = all (\(x,_) -> x > 0) xs && (10 == sum (map fst xs))

all _ [] = True
all p (x:xs) = if p x then all p xs else False

sum [] = 0
sum (x:xs) = x + sum xs

map f [] = []
map f (x:xs) = f x : map f xs

fst (x,_) = x
snd (_,x) = x

areas = foldMixTree
  (\ro ru lu lo -> ro + ru + lu + lo)
  (\_ -> sum . map snd)
  (\_ -> 1)

wellformedTree = foldMixTree
  (\ro ru lu lo -> ro && ru && lu && lo)
  (\_ -> wellformed)
  (\_ -> True)
"""

bspPdP2 :: String
bspPdP2 = """(Split H
  [ (2, Color White)
  , (2, Split V
      [ (3, Color White)
      , (2, QuadSplit
          (Color White)
          (Color DarkGrey)
          (Color White)
          (Color DarkGrey))
      , (2, Split H
          [ (5, Color White)
          , (5, Color LightGrey)])
      , (3, Color White)])
  , (1, Split V
      [ (4, Color Black)
      , (4, Color LightGrey)
      , (2, Color White) ])
  , (2, Split V
      [ (2, Color White)
      , (2, QuadSplit
          (Color DarkGrey)
          (Color White)
          (Color DarkGrey)
          (Color White))
      , (1, Color White)
      , (2, Split H
          [ (5, Color LightGrey)
          , (5, Color White) ])
      , (3, Color White)])
  , (3, Color White)])
"""

module Test.Evaluator where

import Prelude
import Data.Either (Either(..))
import Data.Tuple (Tuple(..))
import Data.StrMap as M
-- import Data.List (List, singleton)

-- import Control.Monad.Writer (Writer, tell)

import Parser (definitions, expression, runParserIndent)
import Evaluator (eval, eval1, runEvalM, defsToEnv)
import Test.Parser (prelude)

import Test.Utils (Test, tell, padLeft)

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

eval1test :: String -> String -> String -> Test Unit
eval1test name input expected = case (Tuple (runParserIndent expression input) (runParserIndent expression expected)) of
  (Tuple (Right inExp) (Right expExp)) ->
    case runEvalM (eval1 M.empty inExp) of
      (Right eval1Exp) ->
        if eval1Exp == expExp
          then pure unit -- log $ "Eval success (" ++ name ++ ")"
          else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show eval1Exp) <> "\n"
            <> "Expected:\n"
            <> padLeft (show expExp)
      (Left err) -> tell'
        $ "Eval fail (" <> name <> "):\n"
        <> padLeft (show err)
  _ -> tell' $ "Parse fail (" <> name <> ")"

eval1EnvTest :: String -> String -> String -> String -> Test Unit
eval1EnvTest name env input expected = case (Tuple (Tuple (runParserIndent expression input) (runParserIndent expression expected)) (runParserIndent definitions env)) of
  (Tuple (Tuple (Right inExp) (Right expExp)) (Right defs)) ->
    case runEvalM (eval1 (defsToEnv defs) inExp) of
      (Right eval1Exp) ->
        if eval1Exp == expExp
          then pure unit -- log $ "Eval success (" <> name <> ")"
          else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show eval1Exp) <> "\n"
            <> "Expected:\n"
            <> padLeft (show expExp)
      (Left err) -> tell'
        $ "Eval fail (" <> name <> "):\n"
        <> padLeft (show err)
  _ -> tell' $ "Parse fail (" <> name <> ")"

evalEnvTest :: String -> String -> String -> String -> Test Unit
evalEnvTest name env input expected = case (Tuple (Tuple (runParserIndent expression input) (runParserIndent expression expected)) (runParserIndent definitions env)) of
  (Tuple (Tuple (Right inExp) (Right expExp)) (Right defs)) ->
    let evalExp = eval (defsToEnv defs) inExp in
      if evalExp == expExp
        then pure unit -- log $ "Eval success (" ++ name ++ ")"
        else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input String:\n"
            <> padLeft input <> "\n"
            <> "Input Parsed:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show evalExp) <> "\n"
            <> "Expected String:\n"
            <> padLeft expected <> "\n"
            <> "Expected Parsed:\n"
            <> padLeft (show expExp) <> "\n"
            <> "Definitions String:\n"
            <> padLeft env <> "\n"
            <> "Definitions Parsed:\n"
            <> padLeft (show defs)
  (Tuple (Tuple pi pe) pd) -> tell'
     $ "Parse fail (" <> name <> "):\n"
    <> "Input:\n"
    <> padLeft (show pi) <> "\n"
    <> "Expected:\n"
    <> padLeft (show pe) <> "\n"
    <> "Definitions:\n"
    <> padLeft (show pd)

runTests :: Test Unit
runTests = do
  eval1test "add" "1+1" "2"
  eval1test "power" "2^10" "1024"
  eval1test "append" "[1] ++ [2]" "[1, 2]"
  eval1test "cons" "True:[]" "[True]"
  eval1test "lambda" "(\\a b -> a + b) 1 2" "1 + 2"
  eval1test "section1" "(*5) 7" "7 * 5"
  eval1test "section2" "(10<) 8" "10 < 8"
  eval1test "prefix" "(&&) True True" "True && True"
  eval1test "if_then_else" "if True then 42 else 0" "42"
  eval1test "pattern_matching1" "(\\(x:xs) -> x) [1, 2, 3]" "1"
  eval1test "pattern_matching2" "(\\[a, b, c] -> c) [1, 2, 3]" "3"
  eval1test "pattern_matching3" "(\\(a, b) (c, d, e) -> d) (1, 2) (3, 2*2, 5)" "2*2"
  eval1test "lambda2" "(\\x y -> [0, x, y, x + y]) 1 2" "[0, 1, 2, 1 + 2]"
  eval1test "string1" "\"as\" ++ \"df\"" "\"asdf\""
  eval1test "string2" "'a' : \"sdf\"" "\"asdf\""

  eval1EnvTest "double_func" "double x = x + x" "double 10" "10 + 10"
  eval1EnvTest "map_func1" "map f [] = []\nmap f (x:xs) = f x : map f xs" "map (^2) []" "[]"
  eval1EnvTest "map_func2" "map f [] = []\nmap f (x:xs) = f x : map f xs" "map (^2) [1, 2, 3]" "(^2) 1 : map (^2) [2, 3]"

  evalEnvTest "evalAll1" "" "1 + 2 + 3" "6"
  evalEnvTest "evalAll2" "" "(2^10) > (10^2)" "True"
  evalEnvTest "evalAll3" "" "3" "3"
  evalEnvTest "evalAll4" "" "x + y" "x + y"
  evalEnvTest "evalAll5" "" "(2 * 5) * x + 2 ^ 3" "10 * x + 8"
  evalEnvTest "evalAll6" "" "1 / 0" "1 / 0"

  evalEnvTest "evalNegNumber1" "" "(-3) - (-4)" "1"
  evalEnvTest "evalNegNumber2" "" "(-2) * (-2)" "4"
  evalEnvTest "evalNegNumber3" "" "-(-(5*5) + 6*6) + 7*7" (show (-(-(5*5) + 6*6) + 7*7)) -- 38
  evalEnvTest "evalNegNumber4" "" "-3 * 7 + 23" "2"

  evalEnvTest "if1" "" "if 10 > 5 then 10 else 5" "10"
  evalEnvTest "if2" "" "if 2 /= 2 then 1 else 0" "0"
  evalEnvTest "if3" "" "if x >= y then 5 * 5 else 6 * 6" "if x >= y then 5 * 5 else 6 * 6"

  evalEnvTest "env1" "x = 10" "x" "10"
  evalEnvTest "env2" "x = 10\ny = 20" "x * y" "200"
  evalEnvTest "env3" "double x = x + x" "double 10" "20"
  evalEnvTest "env4" "double x = x + x" "double (double (double 10))" "80"
  evalEnvTest "env5" "double x = x + x" "double $ double $ double 10" "80"
  evalEnvTest "env6" "double x = x + x" "(double . double . double) 10" "80"
  evalEnvTest "env6" "length (_:xs) = 1 + length xs\nlength [] = 0" "length [1, 2, 3, 4, 5]" "5"

  evalEnvTest "eval_list" "" "[2 + 2, 3 * 3]" "[4, 9]"
  evalEnvTest "eval_tuple" "" "(2+2, 3 * 3)" "(4, 9)"

  -- This test gets stuck in an endless loop,
  -- evalEnvTest "fix" "f x = f x" "f 10" "f 10"

  evalEnvTest "fac" "fac 1 = 1\nfac n = n * fac (n - 1)" "fac 6" "720"
  evalEnvTest "prelude" prelude "sum (map (^2) [1,2,3,4])" "30"

  evalEnvTest "TAE2a"
    ( prelude <> "\n" <>
      "pair (x:y:rs) = (x, y) : pair (y:rs)\n" <>
      "pair _        = []")
    "pair [1, 2, 3, 4]"
    "[(1, 2), (2, 3), (3, 4)]"
  evalEnvTest "TAE2b" prelude "foldr (\\a b -> a + b * 10) 0 [3, 2, 1]" "123"
  evalEnvTest "TAE2c"
    (prelude <> "\nsublist f t ls = drop f (take (t + f) ls)\n")
    "sublist 1 3 [0, 1, 2, 3, 4]"
    "[1, 2, 3]"

  evalEnvTest "TAE3a" prelude "map (>= 2) [1, 2, 3]" "[False, True, True]"
  evalEnvTest "TAE3b" prelude "foldr (\\a b -> b ++ [a]) [] [1, 2, 3]" "[3, 2, 1]"
  evalEnvTest "TAE3c" prelude "take 3 (iterate (3*) 1)" "[1, 3, 9]"
  evalEnvTest "TAE3d" prelude "filter (const True) [1, 3, 5, 7]" "[1, 3, 5, 7]"
  evalEnvTest "TAE3e" prelude "map (length . snd) [(7, \"sieben\"), (1, \"eins\")]" "[6, 4]"
  evalEnvTest "TAE3f" prelude "foldr (:) [3, 4] [1, 2]" "[1, 2, 3, 4]"
  evalEnvTest "TAE3g" prelude "foldl (\\(i, c) s -> (i + 1, c + length s)) (0, 0) [\"a\", \"bc\", \"defg\"]" "(3, 7)"

  evalEnvTest "TAT2a"
    (prelude <> "\nnth ls n = head (drop n ls)\n")
    "nth [0, 1, 2, 3] 2"
    "2"
  evalEnvTest "TAT2b"
    ( prelude <> "\n" <>
      "smallest (x:y:rs) = if x < y then smallest (x:rs) else smallest (y:rs)\n" <>
      "smallest [x]      = x")
    "smallest [5, 3, 7]"
    "3"
  evalEnvTest "TAT2c" prelude "foldl (\\(s, p) i -> (i + s, i * p)) (0, 1) [2, 3, 4]" "(9, 24)"

  evalEnvTest "TAT3a" prelude "map (2^) [1, 2, 3]" "[2, 4, 8]"
  evalEnvTest "TAT3b" prelude "foldl (*) 1 [1, 2, 3, 4]" "24"
  evalEnvTest "TAT3c" prelude "map (== 3) [1, 2, 3, 4]" "[False, False, True, False]"
  evalEnvTest "TAT3d" prelude "filter (/= 's') \"asdf\"" "\"adf\""
  evalEnvTest "TAT3e" prelude "map (fst . head) [[(1, 2)], [(3, 4)]]" "[1, 3]"
  evalEnvTest "TAT3f" prelude "foldl (-) 10 [1, 2, 3]" "4"
  evalEnvTest "TAT3g" prelude "zipWith (\\a b -> map (+a) b) [1, 2] [[3, 4], [5, 6]]" "[[4, 5], [7, 8]]"

  evalEnvTest "string_third1" "thrd (_:(_:(x:_))) = x" "thrd \"1234\"" "'3'"
  evalEnvTest "string_third2" "thrd [_,_,x,_] = x" "thrd \"1234\"" "'3'"

  evalEnvTest "pattern_matching4" "f ( x :  y : z : rs  ) = (x + y + z) * length rs\nlength (_:xs) = 1 + length xs\nlength [] = 0" "f [2, 3, 5, 8, 11]" "20"
  evalEnvTest "pattern_matching5" "f ( [ x ] : [ y , z ] : [ ] ) = x + y + z" "f [[1],[2,3]]" "6"
  evalEnvTest "pattern_matching6" "f [  [ x ] , [ y , z ] ] = x + y + z" "f [[1],[2,3]]" "6"
  evalEnvTest "pattern_matching7" "f [(a:b:c:rs1), (x:y:z:rs2)] = a * x + b * y + c * z" "f [[1, 2, 3], [100, 10, 1]]" "123"

  evalEnvTest "eval_names" "nat = [1, 2, 3, 4, 5]" "nat" "[1, 2, 3, 4, 5]"

  evalEnvTest "infix_functions_1" prelude "3 `take` (2 `drop` [1, 2, 3, 4, 5, 6, 7])" "[3, 4, 5]"
  evalEnvTest "infix_functions_2" prelude "(\\x -> x `mod` 2 == 0) `filter` [1, 2, 3, 4, 5, 6]" "[2, 4, 6]"
  evalEnvTest "infix_functions_3" prelude "(*2) `map` [1, 2, 3]" "[2, 4, 6]"

  evalEnvTest "arithmetic_sequences_1" prelude "sum [1, 3 .. 100]" "2500"
  evalEnvTest "arithmetic_sequences_3" prelude "length [ 7 * 7, 8 * 8 .. 42 * 42]" "115"
  evalEnvTest "arithmetic_sequences_5" prelude "sum $ take 100 [500 ..]" "54950"
  evalEnvTest "arithmetic_sequences_6" prelude "[1, -1 .. 0]" "[1]"
  evalEnvTest "arithmetic_sequences_7" prelude "sum [10, 9 .. -10]" "0"
  evalEnvTest "arithmetic_sequences_8" prelude "[True .. False]" "[]"
  evalEnvTest "arithmetic_sequences_9" prelude "[True, False ..]" "[True, False]"
  evalEnvTest "arithmetic_sequences_11" prelude "[False, True ..]" "[False, True]"
  evalEnvTest "arithmetic_sequences_12" prelude "[True, False ..]" "[True, False]"
  evalEnvTest "arithmetic_sequences_13" prelude "[1 .. 10]" "[1,2,3,4,5,6,7,8,9,10]"
  evalEnvTest "arithmetic_sequences_14" prelude "[5, 9 .. 20]" "[5, 9, 13, 17]"
  evalEnvTest "arithmetic_sequences_15" prelude "take 5 [3, -1 ..]" "[3, -1, -5, -9, -13]"
  evalEnvTest "arithmetic_sequences_16" prelude "take 11 [-5 ..]" "[-5, -4, -3, -2, -1, 0, 1, 2 ,3, 4, 5]"
  evalEnvTest "arithmetic_sequences_17" prelude "[2147483647 ..]" "[2147483647]"
  evalEnvTest "arithmetic_sequences_18" prelude "[2147483644, 2147483646 ..]" "[2147483644, 2147483646]"
  evalEnvTest "arithmetic_sequences_19" prelude "[-2147483648]" "[-2147483648]"
  evalEnvTest "arithmetic_sequences_20" prelude "[-2147483645, -2147483647 ..]" "[-2147483645, -2147483647]"

  evalEnvTest "list_comprehension_1" prelude "[ x | x <- [1 .. 10], even x]" "[2, 4, 6, 8, 10]"
  evalEnvTest "list_comprehension_2" prelude "[ (x, y) | x <- [1 .. 3], y <- [1 .. 3], x + y == 4]" "[(1,3), (2,2), (3,1)]"
  evalEnvTest "list_comprehension_3" prelude "(\\x -> [ x | let x = 1]) 2"    "[1]"
  evalEnvTest "list_comprehension_4" prelude "[ x | let x = 1, True, let x = 'a']" "['a']"
  evalEnvTest "list_comprehension_5" prelude "[ y | y <- [1 .. 10], y < y]"  "[]"
  evalEnvTest "list_comprehension_6" prelude "[ [ y | y <- reverse x] | x <- [[1 .. 10]]]" "[[10, 9, 8, 7, 6, 5, 4, 3, 2, 1]]"
  evalEnvTest "list_comprehension_7" prelude "[ x | x <- [1 .. 5], y <- [x .. 5]]" "[1,1,1,1,1, 2,2,2,2, 3,3,3, 4,4, 5]"
  evalEnvTest "list_comprehension_8" prelude "[x | x <- \"wer misst zu viele gabeln\", elem x \"itzgw\"]" "\"witzig\""
  evalEnvTest "list_comprehension_9" prelude "[(x, z) | x <- [1 .. 5], z <- [y | y <- [1 .. 5], mod x y == 0] ]" "[(1,1), (2,1), (2,2), (3,1), (3,3), (4,1), (4,2), (4,4), (5,1), (5,5)]"
  evalEnvTest "list_comprehension_10" prelude "[z | let y = [True, True, False], z <- y, z]" "[True, True]"

  --should fail, due to overlapping defs
  --evalEnvTest "let_expression_1" prelude "let x = 1; x = 'c' in x" "'c'"
  evalEnvTest "let_expression_2" prelude "let (x, y) = (\\g -> g, \"Hello\") in x y" "\"Hello\""
  evalEnvTest "let_expression_3" prelude "let x = 1 ; y = x + 1; z = y + 1 in x + y + z" "6"
  evalEnvTest "let_expression_4" prelude "let x = 1 in let y = 2 in x + y" "3"
  --                                                                                should be: "True"
  evalEnvTest "let_expression_5" prelude "(let x = [1,2,3] in x) == (let x = 1; y = 2; z = 3 in [x,y,z])" "[1,2,3] == [1,2,3]"
  evalEnvTest "let_expression_6" prelude "let sum = \\x -> x ; y = sum [1,2,3] in y" "[1,2,3]"

  testsADT

testsADT :: Test Unit
testsADT = do
{-
  eval1test "constr-1"
    "1 :+ 1"
    "1 :+ 1"
  eval1test "constr-2"
    "Foo"
    "Foo"
  eval1test "constr-3"
    "Foo 1"
    "Foo 1"
  eval1test "constr-4"
    "Foo 1 2"
    "Foo 1 2"
-}
  eval1test "constr-5"
    "if True then Foo else Bar"
    "Foo"

  eval1test "constr-6"
    "if False then Foo else Bar"
    "Bar"

  eval1EnvTest "func-1"
    "foo (Foo x) = x"
    "foo (Foo 1)"
    "1"

  eval1EnvTest "func-2"
    "foo (Foo x y) = x + y"
    "foo (Foo 1 2)"
    "1 + 2"

  eval1EnvTest "map-func-3"
    "map f Nil = Nil\nmap f (Cons x xs) = Cons (f x) (map f xs)"
    "map (1 +) (Cons 1 (Cons 2 (Cons 3 Nil)))"
    "Cons ((1 +) 1) (map (1 +) (Cons 2 (Cons 3 Nil)))"

  eval1EnvTest "map-func-4"
    "map f Nil = Nil\nmap f (x::xs) = f x :: map f xs"
    "map (^2) Nil"
    "Nil"

  eval1EnvTest "map-func-5"
    "map f Nil = Nil\nmap f (x::xs) = f x :: map f xs"
    "map (^2) (1 :: (2 :: (3 :: Nil)))"
    "(^2) 1 :: map (^2) (2 :: (3 :: Nil))"

  eval1EnvTest "tuple-1"
    "fst (Tuple a _) = a\n"
    "fst (Tuple (Tuple 1 2) 3)"
    "Tuple 1 2"

  eval1EnvTest "tuple-2"
    "snd (Tuple _ a) = a\n"
    "snd (Tuple (Tuple 1 2) 3)"
    "3"

  eval1EnvTest "infix-1"
    "fst (a ::: _) = a"
    "fst (1 ::: 3)"
    "1"

  eval1EnvTest "infix-2"
    "snd (_ ::: a) = a"
    "snd (1 ::: 3)"
    "3"

  evalEnvTest "infix-3"
    "map f g (a :-: b) = f a :-: g b\ndouble = map (*2) (*2)"
    "double (2 :-: 3)"
    "4 :-: 6"

  evalEnvTest "prefix-1"
    "map f g (Tuple x y) = Tuple (f x) (g y)\ndouble = map (*2) (*2)"
    "double (Tuple 2 3)"
    "Tuple 4 6"

  evalEnvTest "constr-nested-1"
    "foo (Bar (Bar a) Foo) = Foo a a"
    "foo (Bar (Bar Foo) Foo)"
    "Foo Foo Foo"

  evalEnvTest "pdp1-a" envPdP1
    ("numParts " <> bspPdP1)
    "13"

  evalEnvTest "pdp1-b" envPdP1
    ("foldBauwerk Rechteck Spitze Split " <> bspPdP1)
    bspPdP1

  evalEnvTest "pdp1-c" envPdP1
    ("maxHoehe " <> bspPdP1)
    "87"

  evalEnvTest "pdp1-d" envPdP1
    ("numPeaks " <> bspPdP1)
    "5"

  evalEnvTest "pdp1-e" envPdP1
    ("wellformed " <> bspPdP1)
    "True"

  evalEnvTest "fp-a" envPdP2
    ("foldMixTree QuadSplit Split Color " <> bspPdP2)
    bspPdP2

  evalEnvTest "fp-b" envPdP2
    ("areas " <> bspPdP2)
    "22"

  evalEnvTest "fp-c" envPdP2
    ("wellformedTree " <> bspPdP2)
    "True"

  evalEnvTest "rose-fold" envRoseFold
    ("foldRoseTree Node Leaf " <> bspRoseFold)
    bspRoseFold

  evalEnvTest "bin-tree-fold-1" envBinTree
    ("foldBinTree Nil (:::) " <> bspBinTree)
    bspBinTree

  evalEnvTest "bin-tree-fold-2" envBinTree
    ("nils " <> bspBinTree)
    "6"

  evalEnvTest "bin-tree-fold-1" envBinTree
    ("foldBinTree Nil (:::) " <> bspBinTree2)
    bspBinTree2

  evalEnvTest "bin-tree-fold-2" envBinTree
    ("nils (" <> bspBinTree2 <> ")")
    "2"

envRoseFold :: String
envRoseFold = """
map _ [] = []
map f (x:xs) = f x : map f xs

foldRoseTree fN fL (Leaf a) = fL a
foldRoseTree fN fL (Node ts) = fN (map (foldRoseTree fN fL) ts)
"""

bspRoseFold :: String
bspRoseFold = """(Node
  [ Leaf 1
  , Leaf 2
  , Leaf 3
  , Node
    [ Leaf 4
    , Leaf 5
    , Leaf 6 ]])
"""

envBinTree :: String
envBinTree = """
foldBinTree fNil fNode Nil = fNil
foldBinTree fNil fNode (l ::: r) = fNode
  (foldBinTree fNil fNode l)
  (foldBinTree fNil fNode r)

nils = foldBinTree 1 (+)
"""

bspBinTree :: String
bspBinTree = "(((Nil ::: Nil) ::: Nil) ::: (Nil ::: (Nil ::: Nil)))"

bspBinTree2 :: String
bspBinTree2 = "Nil ::: Nil"

envPdP1 :: String
envPdP1 = """
foldBauwerk fRechteck fSpitze fSplit (Rechteck br ho bw)
  = fRechteck br ho (foldBauwerk fRechteck fSpitze fSplit bw)
foldBauwerk fRechteck fSpitze fSplit (Spitze br ho)
  = fSpitze br ho
foldBauwerk fRechteck fSpitze fSplit (Split l r)
  = fSplit (foldBauwerk fRechteck fSpitze fSplit l) (foldBauwerk fRechteck fSpitze fSplit r)

numParts (Rechteck _ _ bw) = 1 + numParts bw
numParts (Spitze _ _) = 1
numParts (Split l r)  = numParts l + numParts r

max a b = if a < b then b else a

maxHoehe = foldBauwerk
  (\_ ho hor -> ho + hor)
  (\_ h -> h)
  max

numPeaks = foldBauwerk (\_ _ ps -> ps) (\_ _ -> 1) (+)

wellformed
  = (> 0)
  . foldBauwerk
    (\br _ br' -> if br' < 0 || br' > br then -1 else br)
    (\br _ -> br)
    (\l r -> l + r)
"""

bspPdP1 :: String
bspPdP1 = """(Rechteck 50 20
  (Split
    (Rechteck 20 15
      (Split
        (Rechteck 10 20
          (Rechteck 8 18
            (Spitze 8 14)))
        (Rechteck 8 17
          (Spitze 8 14))))
    (Rechteck 20 15
      (Split
        (Rechteck 8 17
          (Spitze 8 14))
        (Rechteck 10 20
          (Split
            (Spitze 5 17)
            (Spitze 5 17)))))))
"""

envPdP2 :: String
envPdP2 = """
foldMixTree fQ fS fC (QuadSplit ro ru lu lo) = fQ
  (foldMixTree fQ fS fC ro)
  (foldMixTree fQ fS fC ru)
  (foldMixTree fQ fS fC lu)
  (foldMixTree fQ fS fC lo)
foldMixTree fQ fS fC (Split a ts)
  = fS a (map (\(d, t) -> (d, foldMixTree fQ fS fC t)) ts)
foldMixTree fQ fS fC (Color c) = fC c

wellformed xs = all (\(x,_) -> x > 0) xs && (10 == sum (map fst xs))

all _ [] = True
all p (x:xs) = if p x then all p xs else False

sum [] = 0
sum (x:xs) = x + sum xs

map f [] = []
map f (x:xs) = f x : map f xs

fst (x,_) = x
snd (_,x) = x

areas = foldMixTree
  (\ro ru lu lo -> ro + ru + lu + lo)
  (\_ -> sum . map snd)
  (\_ -> 1)

wellformedTree = foldMixTree
  (\ro ru lu lo -> ro && ru && lu && lo)
  (\_ -> wellformed)
  (\_ -> True)
"""

bspPdP2 :: String
bspPdP2 = """(Split H
  [ (2, Color White)
  , (2, Split V
      [ (3, Color White)
      , (2, QuadSplit
          (Color White)
          (Color DarkGrey)
          (Color White)
          (Color DarkGrey))
      , (2, Split H
          [ (5, Color White)
          , (5, Color LightGrey)])
      , (3, Color White)])
  , (1, Split V
      [ (4, Color Black)
      , (4, Color LightGrey)
      , (2, Color White) ])
  , (2, Split V
      [ (2, Color White)
      , (2, QuadSplit
          (Color DarkGrey)
          (Color White)
          (Color DarkGrey)
          (Color White))
      , (1, Color White)
      , (2, Split H
          [ (5, Color LightGrey)
          , (5, Color White) ])
      , (3, Color White)])
  , (3, Color White)])
"""


Fork to prevent deadlock

Fork to prevent deadlock

{-
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.Eval.Persistence where

import SlamData.Prelude

import Control.Monad.Aff.AVar (AVar, takeVar, putVar, modifyVar, killVar)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.Free (class Affable, fromAff)
import Control.Monad.Aff.Promise (wait, defer)
import Control.Monad.Eff.Exception as Exn
import Control.Monad.Fork (class MonadFork, fork)
import Control.Parallel (parSequence)

import Data.Array as Array
import Data.List (List(..), (:))
import Data.List as List
import Data.Map as Map
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as Pathy
import Data.Rational ((%))

import SlamData.Effects (SlamDataEffects)
import SlamData.Quasar.Data as Quasar
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Workspace.AccessType (isEditable)
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Card.Port (Port)
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Draftboard.Layout as Layout
import SlamData.Workspace.Card.Draftboard.Pane as Pane
import SlamData.Workspace.Card.Draftboard.Orientation as Orn
import SlamData.Workspace.Deck.DeckId as DID
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Eval as Eval
import SlamData.Workspace.Eval.Card as Card
import SlamData.Workspace.Eval.Deck as Deck
import SlamData.Workspace.Eval.Graph (unfoldGraph, EvalGraph)
import SlamData.Workspace.Model as WM
import SlamData.Wiring (Wiring)
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache

import Utils (censor)
import Utils.Aff (laterVar)

defaultSaveDebounce ∷ Int
defaultSaveDebounce = 500

defaultEvalDebounce ∷ Int
defaultEvalDebounce = 500

type Persist f m a =
  ( Affable SlamDataEffects m
  , MonadAsk Wiring m
  , MonadFork Exn.Error m
  , Parallel f m
  , QuasarDSL m
  ) ⇒ a

putDeck ∷ ∀ f m. Persist f m (Deck.Id → Deck.Model → m (Either QE.QError Unit))
putDeck deckId deck = do
  { path, eval, accessType } ← Wiring.expose
  ref ← defer do
    res ←
      if isEditable accessType
        then Quasar.save (Deck.deckIndex path deckId) $ Deck.encode deck
        else pure (Right unit)
    pure $ res $> deck
  Cache.alter deckId (updateOrFork ref) eval.decks
  rmap (const unit) <$> wait ref

  where
    updateOrFork ref = case _ of
      Just cell →
        pure $ Just cell
          { value = ref
          , model = deck
          }
      Nothing → do
        cell ← { value: ref, model: deck, bus: _ } <$> fromAff Bus.make
        fork do
          populateCards deckId deck
          forkDeckProcess deckId cell.bus
        pure (Just cell)

saveDeck ∷ ∀ f m. Persist f m (Deck.Id → m Unit)
saveDeck deckId = do
  { eval } ← Wiring.expose
  newDeck ← runMaybeT do
    cell ← MaybeT $ Cache.get deckId eval.decks
    deck ← MaybeT $ censor <$> wait cell.value
    cards ← MaybeT $ sequence <$> traverse getCard (Tuple deckId ∘ _.cardId <$> deck.cards)
    pure deck { cards = (\c → c.value.model) <$> cards }
  for_ newDeck (void ∘ putDeck deckId)

-- | Loads a deck from a DeckId. Returns the model.
getDeck ∷ ∀ f m. Persist f m (Deck.Id → m (Either QE.QError Deck.Model))
getDeck =
  getDeck' >=> _.value >>> wait

-- | Loads a deck from a DeckId. This has the effect of loading decks from
-- | which it extends (for mirroring) and populating the card graph. Returns
-- | the "cell" (model promise paired with its message bus).
getDeck' ∷ ∀ f m. Persist f m (Deck.Id → m Deck.Cell)
getDeck' deckId = do
  { path, eval } ← Wiring.expose
  let
    cacheVar = Cache.unCache eval.decks
  decks ← fromAff (takeVar cacheVar)
  case Map.lookup deckId decks of
    Just cell → do
      fromAff $ putVar cacheVar decks
      pure cell
    Nothing → do
      value ← defer do
        let
          deckPath = Deck.deckIndex path deckId
        -- FIXME: Notify on failure
        result ← runExceptT do
          deck ← ExceptT $ (_ >>= Deck.decode >>> lmap QE.msgToQError) <$> Quasar.load deckPath
          _    ← ExceptT $ populateCards deckId deck
          pure deck
        case result of
          Left _ →
            fromAff $ modifyVar (Map.delete deckId) cacheVar
          Right model →
            Cache.alter deckId (pure ∘ map (_ { model = model })) eval.decks
        pure result
      cell ← { value, model: Deck.emptyDeck, bus: _ } <$> fromAff Bus.make
      fromAff do
        putVar cacheVar (Map.insert deckId cell decks)
      forkDeckProcess deckId cell.bus
      pure cell

-- | Populates the card eval graph based on a deck model. This may fail as it
-- | also attempts to load/hydrate foreign cards (mirrors) as well.
populateCards ∷ ∀ f m. Persist f m (Deck.Id → Deck.Model → m (Either QE.QError Unit))
populateCards deckId deck = runExceptT do
  { eval } ← Wiring.expose
  decks ←
    ExceptT $ sequence <$>
      parTraverse getDeck (Array.nub (fst <$> deck.mirror))
  let
    cards = List.fromFoldable deck.cards
  case Array.last deck.mirror of
    Nothing → lift $ threadCards eval.cards cards
    Just coord → do
      cell ← do
        mb ← Cache.get coord eval.cards
        case mb of
          Nothing → QE.throw ("Card not found in eval cache: " <> show coord)
          Just a  → pure a
      let
        next = case List.head cards of
          Nothing → Left deckId
          Just c  → Right (deckId × c.cardId)
        cell' = cell { next = next : cell.next }
      Cache.put coord cell' eval.cards
      lift $ threadCards eval.cards cards

  where
    threadCards cache = case _ of
      Nil         → pure unit
      c : Nil     → makeCell c Nil cache
      c : c' : cs → do
        makeCell c (pure c'.cardId) cache
        threadCards cache (c' : cs)

    makeCell card next cache = do
      let
        coord = deckId × card.cardId
      cell ← makeCardCell card Nothing (Right ∘ Tuple deckId <$> next)
      Cache.put coord cell cache
      forkCardProcess coord cell.bus

forkDeckProcess ∷ ∀ f m . Persist f m (Deck.Id → Bus.BusRW Deck.EvalMessage → m Unit)
forkDeckProcess deckId = forkLoop case _ of
  Deck.Force source →
    queueEval' 0 source
  Deck.AddCard cty →
    addCard deckId cty >>= traverse_ \coord → do
      queueSave defaultSaveDebounce deckId
      queueEval' 0 (mempty × coord)
  Deck.RemoveCard coord → do
    removeCard deckId coord >>= traverse_ \_ → do
      queueSave defaultSaveDebounce deckId
  Deck.UpdateParent parent → do
    { eval } ← Wiring.expose
    deckCell ← getDeck' deckId
    mbDeck ← wait deckCell.value
    for_ mbDeck \deck → do
      let
        deck' = deck { parent = parent }
      value' ← defer (pure (Right deck'))
      Cache.put deckId (deckCell { value = value' }) eval.decks
      queueSave defaultSaveDebounce deckId
  _ →
    pure unit

forkCardProcess ∷ ∀ f m. Persist f m (Card.Coord → Bus.BusRW Card.EvalMessage → m Unit)
forkCardProcess coord@(deckId × cardId) = forkLoop case _ of
  Card.ModelChange source model → do
    { eval } ← Wiring.expose
    Cache.alter coord (pure ∘ map (updateCellModel model)) eval.cards
    mbGraph ← snapshotGraph coord
    for_ mbGraph \graph → do
      queueSave defaultSaveDebounce deckId
      queueEval defaultEvalDebounce source graph
  _ →
    pure unit

snapshotGraph ∷ ∀ f m. Persist f m (Card.Coord → m (Maybe EvalGraph))
snapshotGraph coord = do
  { eval } ← Wiring.expose
  unfoldGraph
    <$> Cache.snapshot eval.cards
    <*> Cache.snapshot eval.decks
    <*> pure coord

queueSave ∷ ∀ f m. Persist f m (Int → Deck.Id → m Unit)
queueSave ms deckId = do
  { eval } ← Wiring.expose
  debounce ms deckId { avar: _ } eval.pendingSaves do
    saveDeck deckId

queueEval ∷ ∀ f m. Persist f m (Int → Card.DisplayCoord → EvalGraph → m Unit)
queueEval ms source@(_ × coord) graph = do
  { eval } ← Wiring.expose
  let
    pending =
      { source
      , graph
      , avar: _
      }
  -- TODO: Notify pending immediately
  debounce ms coord pending eval.pendingEvals do
    Eval.evalGraph source graph

queueEval' ∷ ∀ f m. Persist f m (Int → Card.DisplayCoord → m Unit)
queueEval' ms source@(_ × coord) =
  traverse_ (queueEval ms source) =<< snapshotGraph coord

freshWorkspace ∷ ∀ f m. Persist f m (m (Deck.Id × Deck.Cell))
freshWorkspace = do
  { eval } ← Wiring.expose
  rootId ← fromAff DID.make
  bus ← fromAff Bus.make
  value ← defer (pure (Right Deck.emptyDeck))
  let
    cell = { bus, value, model: Deck.emptyDeck }
  Cache.put rootId cell eval.decks
  forkDeckProcess rootId bus
  pure (rootId × cell)

wrapDeck ∷ ∀ f m. Persist f m (Deck.Id → m (Either QE.QError Deck.Id))
wrapDeck deckId = runExceptT do
  cell ← lift $ getDeck' deckId
  deck ← ExceptT $ wait cell.value
  parentCoord ← Tuple <$> fromAff DID.make <*> fromAff CID.make
  let
    parentDeck = DM.wrappedDeck deck.parent (snd parentCoord) deckId
  ExceptT $ putDeck (fst parentCoord) parentDeck
  updateParentPointer deckId (fst parentCoord) deck.parent
  fromAff $ Bus.write (Deck.UpdateParent (Just parentCoord)) cell.bus
  pure (fst parentCoord)

wrapAndMirrorDeck ∷ ∀ f m. Persist f m (Deck.Id → m (Either QE.QError Deck.Id))
wrapAndMirrorDeck deckId = runExceptT do
  cell ← lift $ getDeck' deckId
  deck ← ExceptT $ wait cell.value
  newSharedId ← fromAff DID.make
  newMirrorId ← fromAff DID.make
  parentCoord ← Tuple <$> fromAff DID.make <*> fromAff CID.make
  let
    wrappedDeck =
      DM.splitDeck deck.parent (snd parentCoord) Orn.Vertical
        (List.fromFoldable [ deckId, newMirrorId ])
  ExceptT $ map sequence
    if Array.null deck.cards
      then do
        let
          mirrored = deck { parent = Just parentCoord }
        parSequence
          [ putDeck deckId mirrored
          , putDeck newMirrorId (mirrored { name = "" })
          , putDeck (fst parentCoord) wrappedDeck
          ]
      else do
        let
          oldCardIds = Tuple deckId ∘ _.cardId <$> deck.cards
          newCardIds = Tuple newSharedId ∘ snd <$> oldCardIds
          mirrored = deck
            { parent = Just parentCoord
            , mirror = deck.mirror <> newCardIds
            , cards = []
            , name = deck.name
            }
        traverse_ (relocateCardTo newSharedId) oldCardIds
        parSequence
          [ putDeck deckId mirrored
          , putDeck newMirrorId (mirrored { name = "" })
          , putDeck newSharedId (deck { name = "" })
          , putDeck (fst parentCoord) wrappedDeck
          ]
  updateParentPointer deckId (fst parentCoord) deck.parent
  pure (fst parentCoord)

mirrorDeck ∷ ∀ f m. Persist f m (Deck.Id → Card.Coord → m (Either QE.QError Deck.Id))
mirrorDeck childId coord = runExceptT do
  { eval } ← Wiring.expose
  deck ← ExceptT $ getDeck childId
  parent ← liftWithErr "Parent not found." $ getCard coord
  newSharedId ← fromAff DID.make
  newMirrorId ← fromAff DID.make
  ExceptT $ map sequence
    if Array.null deck.cards
      then do
        let
          mirrored = deck { name = "" }
        parSequence
          [ putDeck newMirrorId mirrored
          ]
      else do
        let
          oldCardIds = Tuple childId ∘ _.cardId <$> deck.cards
          newCardIds = Tuple newSharedId ∘ snd <$> oldCardIds
          mirrored = deck
            { parent = Just coord
            , mirror = deck.mirror <> newCardIds
            , cards = []
            , name = deck.name
            }
        traverse_ (relocateCardTo newSharedId) oldCardIds
        parSequence
          [ putDeck childId mirrored
          , putDeck newMirrorId (mirrored { name = "" })
          , putDeck newSharedId (deck { name = "" })
          ]
  parent'' ← liftWithErr "Cannot mirror deck." $ pure $ mirrorInLayout newMirrorId parent.value.model.model
  fromAff $ Bus.write (Card.ModelChange (Card.toAll coord) parent'') parent.bus
  pure newMirrorId
  where
  mirrorInLayout newId = case _ of
    CM.Draftboard { layout } → do
      cursor ← List.tail =<< Pane.getCursorFor (Just childId) layout
      let
        orn =
          case Pane.getAt cursor layout of
            Just (Pane.Split o _) → o
            _ → Orn.Vertical
      layout' ←
        Layout.insertSplit
          (Pane.Cell (Just newId)) orn (1%2) Layout.SideB cursor layout
      pure (CM.Draftboard { layout: layout' })
    _ →
      Nothing

unwrapDeck ∷ ∀ f m. Persist f m (Deck.Id → m (Either QE.QError Deck.Id))
unwrapDeck deckId = runExceptT do
  deck ← ExceptT $ getDeck deckId
  cards ← liftWithErr "Cards not found." $ getCards (Deck.cardCoords deckId deck)
  childId ← liftWithErr "Cannot unwrap deck." $ pure $ immediateChild (_.value.model.model ∘ snd <$> cards)
  cell ← lift $ getDeck' childId
  updateParentPointer deckId childId deck.parent
  fromAff $ Bus.write (Deck.UpdateParent deck.parent) cell.bus
  pure childId

  where
    immediateChild = case _ of
      [ model ] →
        case CM.childDeckIds model of
          childId : Nil → Just childId
          _ → Nothing
      _ → Nothing

collapseDeck ∷ ∀ f m. Persist f m (Deck.Id → Card.Coord → m (Either QE.QError Unit))
collapseDeck childId coord = runExceptT do
  { eval } ← Wiring.expose
  deck ← ExceptT $ getDeck childId
  cards ← liftWithErr "Cards not found." $ getCards (Deck.cardCoords childId deck)
  parent ← liftWithErr "Parent not found." $ getCard coord
  let
    parent' = parent.value.model.model
    cards' = _.value.model.model ∘ snd <$> cards
  childIds × parent'' ← liftWithErr "Cannot collapse deck." $ pure $ collapsed parent' cards'
  childDecks ← lift $ traverse getDeck' childIds
  fromAff do
    for_ childDecks \{ bus } →
      Bus.write (Deck.UpdateParent (Just coord)) bus
    Bus.write (Card.ModelChange (Card.toAll coord) parent'') parent.bus

  where
    collapsed parent child = case parent, child of
      CM.Draftboard { layout }, [ cm@CM.Draftboard { layout: subLayout } ] → do
        cursor ← Pane.getCursorFor (Just childId) layout
        layout' ← Pane.modifyAt (const subLayout) cursor layout
        let
          childIds = CM.childDeckIds cm
          parent' = CM.Draftboard { layout: layout' }
        pure (childIds × parent')
      _, _ →
        Nothing

addCard ∷ ∀ f m. Persist f m (Deck.Id → CT.CardType → m (Either QE.QError Card.Coord))
addCard deckId cty = runExceptT do
  { eval } ← Wiring.expose
  deckCell ← lift $ getDeck' deckId
  deck ← ExceptT $ wait deckCell.value
  cardId ← fromAff CID.make
  let
    coord = deckId × cardId
  lift do
    input ← runMaybeT do
      last ← MaybeT $ pure $ Array.last (Deck.cardCoords deckId deck)
      cell ← MaybeT $ Cache.get last eval.cards
      let
        next' = List.filter (not ∘ eq (Left deckId)) cell.next
        cell' = cell { next = Right coord : next' }
      lift $ Cache.put last cell' eval.cards
      MaybeT $ pure $ cell.value.output
    let
      card = { cardId, model: Card.cardModelOfType (fromMaybe Port.Initial input) cty }
      deck' = deck { cards = Array.snoc deck.cards card }
    cell ← makeCardCell card input mempty
    value' ← defer (pure (Right deck'))
    Cache.put (deckId × cardId) cell eval.cards
    Cache.put deckId (deckCell { value = value' }) eval.decks
    forkCardProcess coord cell.bus
    pure coord

removeCard ∷ ∀ f m. Persist f m (Deck.Id → Card.Coord → m (Either QE.QError Unit))
removeCard deckId coord@(deckId' × cardId) = runExceptT do
  { eval } ← Wiring.expose
  deckCell ← lift $ getDeck' deckId
  deck ← ExceptT $ wait deckCell.value
  lift do
    let
      coords = Array.span (not ∘ eq coord) (Deck.cardCoords deckId deck)
      deck' =
        if deckId ≡ deckId'
          then deck { cards = Array.takeWhile (not ∘ eq cardId ∘ _.cardId) deck.cards }
          else deck { cards = [], mirror = Array.takeWhile (not ∘ eq coord) deck.mirror }
    output ← runMaybeT do
      last ← MaybeT $ pure $ Array.last coords.init
      cell ← MaybeT $ Cache.get last eval.cards
      let
        leaf = if Array.null deck'.cards then pure (Left deckId) else mempty
        next' = List.delete (Right coord) cell.next
        cell' = cell { next = leaf <> next' }
      lift $ Cache.put last cell' eval.cards
      MaybeT $ pure $ cell.value.output
    value' ← defer (pure (Right deck'))
    Cache.put deckId (deckCell { value = value' }) eval.decks
    fromAff $ Bus.write (Deck.Complete coords.init (fromMaybe Port.Initial output)) deckCell.bus

updateParentPointer
  ∷ ∀ f m
  . Persist f m
  ( Deck.Id
  → Deck.Id
  → Maybe Card.Coord
  → ExceptT QE.QError m Unit )
updateParentPointer oldId newId parent =
  case parent of
    Just coord@(deckId × cardId) → do
      -- We need to guard on the parentDeck because it may not be loaded if we
      -- are viewing the child at the root of the UI.
      parentDeck ← ExceptT $ getDeck deckId
      cell ← getCard coord
      for_ cell \{ bus, value } → do
        let
          model' = CM.updatePointer oldId (Just newId) value.model.model
          message = Card.ModelChange (Card.toAll coord) model'
        fromAff $ Bus.write message bus
    Nothing → do
      { path } ← Wiring.expose
      ExceptT $ WM.setRoot (path </> Pathy.file "index") newId

forkLoop
  ∷ ∀ m r a
  . ( Affable SlamDataEffects m
    , MonadFork Exn.Error m
    )
  ⇒ (a → m Unit)
  → Bus.Bus (Bus.R' r) a
  → m Unit
forkLoop handler bus = void (fork loop)
  where
    loop = do
      msg ← fromAff (Bus.read bus)
      fork (handler msg)
      loop

makeCardCell
  ∷ ∀ m
  . ( Affable SlamDataEffects m
    , Monad m
    )
  ⇒ Card.Model
  → Maybe Port
  → List (Either Deck.Id Card.Coord)
  → m Card.Cell
makeCardCell model input next = do
  let
    value =
      { model
      , input
      , output: Nothing
      , state: Nothing
      , tick: Nothing
      }
  bus ← fromAff Bus.make
  pure { bus, next, value }

getCard
  ∷ ∀ m
  . ( Affable SlamDataEffects m
    , MonadAsk Wiring m
    )
  ⇒ Card.Coord
  → m (Maybe Card.Cell)
getCard coord = do
  { eval } ← Wiring.expose
  Cache.get coord eval.cards

getCards
  ∷ ∀ m
  . ( Affable SlamDataEffects m
    , MonadAsk Wiring m
    )
  ⇒ Array Card.Coord
  → m (Maybe (Array (Deck.Id × Card.Cell)))
getCards = map sequence ∘ traverse go
  where
    go coord = map (fst coord × _) <$> getCard coord

relocateCardTo
  ∷ ∀ m
  . ( Affable SlamDataEffects m
    , MonadAsk Wiring m
    )
  ⇒ Deck.Id
  → Card.Coord
  → m Unit
relocateCardTo deckId coord@(_ × cardId) = do
  -- FIXME: This is so broken
  { eval } ← Wiring.expose
  Cache.get coord eval.cards >>= traverse_ \cell → do
    Cache.remove coord eval.cards
    Cache.put (deckId × cardId) cell eval.cards

debounce
  ∷ ∀ k m r
  . ( Affable SlamDataEffects m
    , MonadFork Exn.Error m
    , Ord k
    )
  ⇒ Int
  → k
  → (AVar Unit → { avar ∷ AVar Unit | r })
  → Cache.Cache k { avar ∷ AVar Unit | r }
  → m Unit
  → m Unit
debounce ms key make cache run = do
  avar ← laterVar ms $ void $ run *> Cache.remove key cache
  Cache.alter key (alterFn (make avar)) cache
  where
    alterFn a b = fromAff do
      traverse_ (flip killVar (Exn.error "debounce") ∘ _.avar) b
        $> Just a

liftWithErr
  ∷ ∀ m a
  . Monad m
  ⇒ String
  → m (Maybe a)
  → ExceptT QE.QError m a
liftWithErr err =
  maybe (QE.throw err) pure <=< lift

updateCellModel ∷ CM.AnyCardModel → Card.Cell → Card.Cell
updateCellModel model cell = cell
  { value = cell.value
      { model = cell.value.model
          { model = model
          }
      }
  }

{-
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.Eval.Persistence where

import SlamData.Prelude

import Control.Monad.Aff.AVar (AVar, takeVar, putVar, modifyVar, killVar)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.Free (class Affable, fromAff)
import Control.Monad.Aff.Promise (wait, defer)
import Control.Monad.Eff.Exception as Exn
import Control.Monad.Fork (class MonadFork, fork)
import Control.Parallel (parSequence)

import Data.Array as Array
import Data.List (List(..), (:))
import Data.List as List
import Data.Map as Map
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as Pathy
import Data.Rational ((%))

import SlamData.Effects (SlamDataEffects)
import SlamData.Quasar.Data as Quasar
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Workspace.AccessType (isEditable)
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Card.Port (Port)
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Draftboard.Layout as Layout
import SlamData.Workspace.Card.Draftboard.Pane as Pane
import SlamData.Workspace.Card.Draftboard.Orientation as Orn
import SlamData.Workspace.Deck.DeckId as DID
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Eval as Eval
import SlamData.Workspace.Eval.Card as Card
import SlamData.Workspace.Eval.Deck as Deck
import SlamData.Workspace.Eval.Graph (unfoldGraph, EvalGraph)
import SlamData.Workspace.Model as WM
import SlamData.Wiring (Wiring)
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache

import Utils (censor)
import Utils.Aff (laterVar)

defaultSaveDebounce ∷ Int
defaultSaveDebounce = 500

defaultEvalDebounce ∷ Int
defaultEvalDebounce = 500

type Persist f m a =
  ( Affable SlamDataEffects m
  , MonadAsk Wiring m
  , MonadFork Exn.Error m
  , Parallel f m
  , QuasarDSL m
  ) ⇒ a

putDeck ∷ ∀ f m. Persist f m (Deck.Id → Deck.Model → m (Either QE.QError Unit))
putDeck deckId deck = do
  { path, eval, accessType } ← Wiring.expose
  ref ← defer do
    res ←
      if isEditable accessType
        then Quasar.save (Deck.deckIndex path deckId) $ Deck.encode deck
        else pure (Right unit)
    pure $ res $> deck
  Cache.alter deckId (updateOrFork ref) eval.decks
  rmap (const unit) <$> wait ref

  where
    updateOrFork ref = case _ of
      Just cell →
        pure $ Just cell
          { value = ref
          , model = deck
          }
      Nothing → do
        cell ← { value: ref, model: deck, bus: _ } <$> fromAff Bus.make
        populateCards deckId deck
        forkDeckProcess deckId cell.bus
        pure (Just cell)

saveDeck ∷ ∀ f m. Persist f m (Deck.Id → m Unit)
saveDeck deckId = do
  { eval } ← Wiring.expose
  newDeck ← runMaybeT do
    cell ← MaybeT $ Cache.get deckId eval.decks
    deck ← MaybeT $ censor <$> wait cell.value
    cards ← MaybeT $ sequence <$> traverse getCard (Tuple deckId ∘ _.cardId <$> deck.cards)
    pure deck { cards = (\c → c.value.model) <$> cards }
  for_ newDeck (void ∘ putDeck deckId)

-- | Loads a deck from a DeckId. Returns the model.
getDeck ∷ ∀ f m. Persist f m (Deck.Id → m (Either QE.QError Deck.Model))
getDeck =
  getDeck' >=> _.value >>> wait

-- | Loads a deck from a DeckId. This has the effect of loading decks from
-- | which it extends (for mirroring) and populating the card graph. Returns
-- | the "cell" (model promise paired with its message bus).
getDeck' ∷ ∀ f m. Persist f m (Deck.Id → m Deck.Cell)
getDeck' deckId = do
  { path, eval } ← Wiring.expose
  let
    cacheVar = Cache.unCache eval.decks
  decks ← fromAff (takeVar cacheVar)
  case Map.lookup deckId decks of
    Just cell → do
      fromAff $ putVar cacheVar decks
      pure cell
    Nothing → do
      value ← defer do
        let
          deckPath = Deck.deckIndex path deckId
        -- FIXME: Notify on failure
        result ← runExceptT do
          deck ← ExceptT $ (_ >>= Deck.decode >>> lmap QE.msgToQError) <$> Quasar.load deckPath
          _    ← ExceptT $ populateCards deckId deck
          pure deck
        case result of
          Left _ →
            fromAff $ modifyVar (Map.delete deckId) cacheVar
          Right model →
            Cache.alter deckId (pure ∘ map (_ { model = model })) eval.decks
        pure result
      cell ← { value, model: Deck.emptyDeck, bus: _ } <$> fromAff Bus.make
      fromAff do
        putVar cacheVar (Map.insert deckId cell decks)
      forkDeckProcess deckId cell.bus
      pure cell

-- | Populates the card eval graph based on a deck model. This may fail as it
-- | also attempts to load/hydrate foreign cards (mirrors) as well.
populateCards ∷ ∀ f m. Persist f m (Deck.Id → Deck.Model → m (Either QE.QError Unit))
populateCards deckId deck = runExceptT do
  { eval } ← Wiring.expose
  decks ←
    ExceptT $ sequence <$>
      parTraverse getDeck (Array.nub (fst <$> deck.mirror))
  let
    cards = List.fromFoldable deck.cards
  case Array.last deck.mirror of
    Nothing → lift $ threadCards eval.cards cards
    Just coord → do
      cell ← do
        mb ← Cache.get coord eval.cards
        case mb of
          Nothing → QE.throw ("Card not found in eval cache: " <> show coord)
          Just a  → pure a
      let
        next = case List.head cards of
          Nothing → Left deckId
          Just c  → Right (deckId × c.cardId)
        cell' = cell { next = next : cell.next }
      Cache.put coord cell' eval.cards
      lift $ threadCards eval.cards cards

  where
    threadCards cache = case _ of
      Nil         → pure unit
      c : Nil     → makeCell c Nil cache
      c : c' : cs → do
        makeCell c (pure c'.cardId) cache
        threadCards cache (c' : cs)

    makeCell card next cache = do
      let
        coord = deckId × card.cardId
      cell ← makeCardCell card Nothing (Right ∘ Tuple deckId <$> next)
      Cache.put coord cell cache
      forkCardProcess coord cell.bus

forkDeckProcess ∷ ∀ f m . Persist f m (Deck.Id → Bus.BusRW Deck.EvalMessage → m Unit)
forkDeckProcess deckId = forkLoop case _ of
  Deck.Force source →
    queueEval' 0 source
  Deck.AddCard cty →
    addCard deckId cty >>= traverse_ \coord → do
      queueSave defaultSaveDebounce deckId
      queueEval' 0 (mempty × coord)
  Deck.RemoveCard coord → do
    removeCard deckId coord >>= traverse_ \_ → do
      queueSave defaultSaveDebounce deckId
  Deck.UpdateParent parent → do
    { eval } ← Wiring.expose
    deckCell ← getDeck' deckId
    mbDeck ← wait deckCell.value
    for_ mbDeck \deck → do
      let
        deck' = deck { parent = parent }
      value' ← defer (pure (Right deck'))
      Cache.put deckId (deckCell { value = value' }) eval.decks
      queueSave defaultSaveDebounce deckId
  _ →
    pure unit

forkCardProcess ∷ ∀ f m. Persist f m (Card.Coord → Bus.BusRW Card.EvalMessage → m Unit)
forkCardProcess coord@(deckId × cardId) = forkLoop case _ of
  Card.ModelChange source model → do
    { eval } ← Wiring.expose
    Cache.alter coord (pure ∘ map (updateCellModel model)) eval.cards
    mbGraph ← snapshotGraph coord
    for_ mbGraph \graph → do
      queueSave defaultSaveDebounce deckId
      queueEval defaultEvalDebounce source graph
  _ →
    pure unit

snapshotGraph ∷ ∀ f m. Persist f m (Card.Coord → m (Maybe EvalGraph))
snapshotGraph coord = do
  { eval } ← Wiring.expose
  unfoldGraph
    <$> Cache.snapshot eval.cards
    <*> Cache.snapshot eval.decks
    <*> pure coord

queueSave ∷ ∀ f m. Persist f m (Int → Deck.Id → m Unit)
queueSave ms deckId = do
  { eval } ← Wiring.expose
  debounce ms deckId { avar: _ } eval.pendingSaves do
    saveDeck deckId

queueEval ∷ ∀ f m. Persist f m (Int → Card.DisplayCoord → EvalGraph → m Unit)
queueEval ms source@(_ × coord) graph = do
  { eval } ← Wiring.expose
  let
    pending =
      { source
      , graph
      , avar: _
      }
  -- TODO: Notify pending immediately
  debounce ms coord pending eval.pendingEvals do
    Eval.evalGraph source graph

queueEval' ∷ ∀ f m. Persist f m (Int → Card.DisplayCoord → m Unit)
queueEval' ms source@(_ × coord) =
  traverse_ (queueEval ms source) =<< snapshotGraph coord

freshWorkspace ∷ ∀ f m. Persist f m (m (Deck.Id × Deck.Cell))
freshWorkspace = do
  { eval } ← Wiring.expose
  rootId ← fromAff DID.make
  bus ← fromAff Bus.make
  value ← defer (pure (Right Deck.emptyDeck))
  let
    cell = { bus, value, model: Deck.emptyDeck }
  Cache.put rootId cell eval.decks
  forkDeckProcess rootId bus
  pure (rootId × cell)

wrapDeck ∷ ∀ f m. Persist f m (Deck.Id → m (Either QE.QError Deck.Id))
wrapDeck deckId = runExceptT do
  cell ← lift $ getDeck' deckId
  deck ← ExceptT $ wait cell.value
  parentCoord ← Tuple <$> fromAff DID.make <*> fromAff CID.make
  let
    parentDeck = DM.wrappedDeck deck.parent (snd parentCoord) deckId
  ExceptT $ putDeck (fst parentCoord) parentDeck
  updateParentPointer deckId (fst parentCoord) deck.parent
  fromAff $ Bus.write (Deck.UpdateParent (Just parentCoord)) cell.bus
  pure (fst parentCoord)

wrapAndMirrorDeck ∷ ∀ f m. Persist f m (Deck.Id → m (Either QE.QError Deck.Id))
wrapAndMirrorDeck deckId = runExceptT do
  cell ← lift $ getDeck' deckId
  deck ← ExceptT $ wait cell.value
  newSharedId ← fromAff DID.make
  newMirrorId ← fromAff DID.make
  parentCoord ← Tuple <$> fromAff DID.make <*> fromAff CID.make
  let
    wrappedDeck =
      DM.splitDeck deck.parent (snd parentCoord) Orn.Vertical
        (List.fromFoldable [ deckId, newMirrorId ])
  ExceptT $ map sequence
    if Array.null deck.cards
      then do
        let
          mirrored = deck { parent = Just parentCoord }
        parSequence
          [ putDeck deckId mirrored
          , putDeck newMirrorId (mirrored { name = "" })
          , putDeck (fst parentCoord) wrappedDeck
          ]
      else do
        let
          oldCardIds = Tuple deckId ∘ _.cardId <$> deck.cards
          newCardIds = Tuple newSharedId ∘ snd <$> oldCardIds
          mirrored = deck
            { parent = Just parentCoord
            , mirror = deck.mirror <> newCardIds
            , cards = []
            , name = deck.name
            }
        traverse_ (relocateCardTo newSharedId) oldCardIds
        parSequence
          [ putDeck deckId mirrored
          , putDeck newMirrorId (mirrored { name = "" })
          , putDeck newSharedId (deck { name = "" })
          , putDeck (fst parentCoord) wrappedDeck
          ]
  updateParentPointer deckId (fst parentCoord) deck.parent
  pure (fst parentCoord)

mirrorDeck ∷ ∀ f m. Persist f m (Deck.Id → Card.Coord → m (Either QE.QError Deck.Id))
mirrorDeck childId coord = runExceptT do
  { eval } ← Wiring.expose
  deck ← ExceptT $ getDeck childId
  parent ← liftWithErr "Parent not found." $ getCard coord
  newSharedId ← fromAff DID.make
  newMirrorId ← fromAff DID.make
  ExceptT $ map sequence
    if Array.null deck.cards
      then do
        let
          mirrored = deck { name = "" }
        parSequence
          [ putDeck newMirrorId mirrored
          ]
      else do
        let
          oldCardIds = Tuple childId ∘ _.cardId <$> deck.cards
          newCardIds = Tuple newSharedId ∘ snd <$> oldCardIds
          mirrored = deck
            { parent = Just coord
            , mirror = deck.mirror <> newCardIds
            , cards = []
            , name = deck.name
            }
        traverse_ (relocateCardTo newSharedId) oldCardIds
        parSequence
          [ putDeck childId mirrored
          , putDeck newMirrorId (mirrored { name = "" })
          , putDeck newSharedId (deck { name = "" })
          ]
  parent'' ← liftWithErr "Cannot mirror deck." $ pure $ mirrorInLayout newMirrorId parent.value.model.model
  fromAff $ Bus.write (Card.ModelChange (Card.toAll coord) parent'') parent.bus
  pure newMirrorId
  where
  mirrorInLayout newId = case _ of
    CM.Draftboard { layout } → do
      cursor ← List.tail =<< Pane.getCursorFor (Just childId) layout
      let
        orn =
          case Pane.getAt cursor layout of
            Just (Pane.Split o _) → o
            _ → Orn.Vertical
      layout' ←
        Layout.insertSplit
          (Pane.Cell (Just newId)) orn (1%2) Layout.SideB cursor layout
      pure (CM.Draftboard { layout: layout' })
    _ →
      Nothing

unwrapDeck ∷ ∀ f m. Persist f m (Deck.Id → m (Either QE.QError Deck.Id))
unwrapDeck deckId = runExceptT do
  deck ← ExceptT $ getDeck deckId
  cards ← liftWithErr "Cards not found." $ getCards (Deck.cardCoords deckId deck)
  childId ← liftWithErr "Cannot unwrap deck." $ pure $ immediateChild (_.value.model.model ∘ snd <$> cards)
  cell ← lift $ getDeck' childId
  updateParentPointer deckId childId deck.parent
  fromAff $ Bus.write (Deck.UpdateParent deck.parent) cell.bus
  pure childId

  where
    immediateChild = case _ of
      [ model ] →
        case CM.childDeckIds model of
          childId : Nil → Just childId
          _ → Nothing
      _ → Nothing

collapseDeck ∷ ∀ f m. Persist f m (Deck.Id → Card.Coord → m (Either QE.QError Unit))
collapseDeck childId coord = runExceptT do
  { eval } ← Wiring.expose
  deck ← ExceptT $ getDeck childId
  cards ← liftWithErr "Cards not found." $ getCards (Deck.cardCoords childId deck)
  parent ← liftWithErr "Parent not found." $ getCard coord
  let
    parent' = parent.value.model.model
    cards' = _.value.model.model ∘ snd <$> cards
  childIds × parent'' ← liftWithErr "Cannot collapse deck." $ pure $ collapsed parent' cards'
  childDecks ← lift $ traverse getDeck' childIds
  fromAff do
    for_ childDecks \{ bus } →
      Bus.write (Deck.UpdateParent (Just coord)) bus
    Bus.write (Card.ModelChange (Card.toAll coord) parent'') parent.bus

  where
    collapsed parent child = case parent, child of
      CM.Draftboard { layout }, [ cm@CM.Draftboard { layout: subLayout } ] → do
        cursor ← Pane.getCursorFor (Just childId) layout
        layout' ← Pane.modifyAt (const subLayout) cursor layout
        let
          childIds = CM.childDeckIds cm
          parent' = CM.Draftboard { layout: layout' }
        pure (childIds × parent')
      _, _ →
        Nothing

addCard ∷ ∀ f m. Persist f m (Deck.Id → CT.CardType → m (Either QE.QError Card.Coord))
addCard deckId cty = runExceptT do
  { eval } ← Wiring.expose
  deckCell ← lift $ getDeck' deckId
  deck ← ExceptT $ wait deckCell.value
  cardId ← fromAff CID.make
  let
    coord = deckId × cardId
  lift do
    input ← runMaybeT do
      last ← MaybeT $ pure $ Array.last (Deck.cardCoords deckId deck)
      cell ← MaybeT $ Cache.get last eval.cards
      let
        next' = List.filter (not ∘ eq (Left deckId)) cell.next
        cell' = cell { next = Right coord : next' }
      lift $ Cache.put last cell' eval.cards
      MaybeT $ pure $ cell.value.output
    let
      card = { cardId, model: Card.cardModelOfType (fromMaybe Port.Initial input) cty }
      deck' = deck { cards = Array.snoc deck.cards card }
    cell ← makeCardCell card input mempty
    value' ← defer (pure (Right deck'))
    Cache.put (deckId × cardId) cell eval.cards
    Cache.put deckId (deckCell { value = value' }) eval.decks
    forkCardProcess coord cell.bus
    pure coord

removeCard ∷ ∀ f m. Persist f m (Deck.Id → Card.Coord → m (Either QE.QError Unit))
removeCard deckId coord@(deckId' × cardId) = runExceptT do
  { eval } ← Wiring.expose
  deckCell ← lift $ getDeck' deckId
  deck ← ExceptT $ wait deckCell.value
  lift do
    let
      coords = Array.span (not ∘ eq coord) (Deck.cardCoords deckId deck)
      deck' =
        if deckId ≡ deckId'
          then deck { cards = Array.takeWhile (not ∘ eq cardId ∘ _.cardId) deck.cards }
          else deck { cards = [], mirror = Array.takeWhile (not ∘ eq coord) deck.mirror }
    output ← runMaybeT do
      last ← MaybeT $ pure $ Array.last coords.init
      cell ← MaybeT $ Cache.get last eval.cards
      let
        leaf = if Array.null deck'.cards then pure (Left deckId) else mempty
        next' = List.delete (Right coord) cell.next
        cell' = cell { next = leaf <> next' }
      lift $ Cache.put last cell' eval.cards
      MaybeT $ pure $ cell.value.output
    value' ← defer (pure (Right deck'))
    Cache.put deckId (deckCell { value = value' }) eval.decks
    fromAff $ Bus.write (Deck.Complete coords.init (fromMaybe Port.Initial output)) deckCell.bus

updateParentPointer
  ∷ ∀ f m
  . Persist f m
  ( Deck.Id
  → Deck.Id
  → Maybe Card.Coord
  → ExceptT QE.QError m Unit )
updateParentPointer oldId newId parent =
  case parent of
    Just coord@(deckId × cardId) → do
      -- We need to guard on the parentDeck because it may not be loaded if we
      -- are viewing the child at the root of the UI.
      parentDeck ← ExceptT $ getDeck deckId
      cell ← getCard coord
      for_ cell \{ bus, value } → do
        let
          model' = CM.updatePointer oldId (Just newId) value.model.model
          message = Card.ModelChange (Card.toAll coord) model'
        fromAff $ Bus.write message bus
    Nothing → do
      { path } ← Wiring.expose
      ExceptT $ WM.setRoot (path </> Pathy.file "index") newId

forkLoop
  ∷ ∀ m r a
  . ( Affable SlamDataEffects m
    , MonadFork Exn.Error m
    )
  ⇒ (a → m Unit)
  → Bus.Bus (Bus.R' r) a
  → m Unit
forkLoop handler bus = void (fork loop)
  where
    loop = do
      msg ← fromAff (Bus.read bus)
      fork (handler msg)
      loop

makeCardCell
  ∷ ∀ m
  . ( Affable SlamDataEffects m
    , Monad m
    )
  ⇒ Card.Model
  → Maybe Port
  → List (Either Deck.Id Card.Coord)
  → m Card.Cell
makeCardCell model input next = do
  let
    value =
      { model
      , input
      , output: Nothing
      , state: Nothing
      , tick: Nothing
      }
  bus ← fromAff Bus.make
  pure { bus, next, value }

getCard
  ∷ ∀ m
  . ( Affable SlamDataEffects m
    , MonadAsk Wiring m
    )
  ⇒ Card.Coord
  → m (Maybe Card.Cell)
getCard coord = do
  { eval } ← Wiring.expose
  Cache.get coord eval.cards

getCards
  ∷ ∀ m
  . ( Affable SlamDataEffects m
    , MonadAsk Wiring m
    )
  ⇒ Array Card.Coord
  → m (Maybe (Array (Deck.Id × Card.Cell)))
getCards = map sequence ∘ traverse go
  where
    go coord = map (fst coord × _) <$> getCard coord

relocateCardTo
  ∷ ∀ m
  . ( Affable SlamDataEffects m
    , MonadAsk Wiring m
    )
  ⇒ Deck.Id
  → Card.Coord
  → m Unit
relocateCardTo deckId coord@(_ × cardId) = do
  -- FIXME: This is so broken
  { eval } ← Wiring.expose
  Cache.get coord eval.cards >>= traverse_ \cell → do
    Cache.remove coord eval.cards
    Cache.put (deckId × cardId) cell eval.cards

debounce
  ∷ ∀ k m r
  . ( Affable SlamDataEffects m
    , MonadFork Exn.Error m
    , Ord k
    )
  ⇒ Int
  → k
  → (AVar Unit → { avar ∷ AVar Unit | r })
  → Cache.Cache k { avar ∷ AVar Unit | r }
  → m Unit
  → m Unit
debounce ms key make cache run = do
  avar ← laterVar ms $ void $ run *> Cache.remove key cache
  Cache.alter key (alterFn (make avar)) cache
  where
    alterFn a b = fromAff do
      traverse_ (flip killVar (Exn.error "debounce") ∘ _.avar) b
        $> Just a

liftWithErr
  ∷ ∀ m a
  . Monad m
  ⇒ String
  → m (Maybe a)
  → ExceptT QE.QError m a
liftWithErr err =
  maybe (QE.throw err) pure <=< lift

updateCellModel ∷ CM.AnyCardModel → Card.Cell → Card.Cell
updateCellModel model cell = cell
  { value = cell.value
      { model = cell.value.model
          { model = model
          }
      }
  }


Enforce at least 12 words with every mnemonic

module Daedalus.Types
       ( module CT
       , module C
       , module E
       , module BP
       , module DT
       , _address
       , _coin
       , mkCoin
       , mkCAddress
       , mkCWalletMeta
       , mkCWalletInit
       , mkCWalletInitIgnoreChecksum
       , mkCTxMeta
       , mkCTxId
       , mkCCurrency
       , mkCProfile
       , _ctxIdValue
       , showCCurrency
       , mkBackupPhrase
       , mkCWalletRedeem
       ) where

import Prelude

import Pos.Wallet.Web.ClientTypes (CAddress (..), CHash (..))
import Pos.Types.Core (Coin (..))

import Pos.Wallet.Web.ClientTypes as CT
import Pos.Types.Core as C
import Pos.Wallet.Web.Error as E
import Pos.Util.BackupPhrase (BackupPhrase (..))
import Pos.Util.BackupPhrase as BP

import Control.Monad.Eff.Exception (error, Error)
import Control.Apply ((<$>))
import Data.Either (either, Either (..))
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Argonaut.Core (fromString)
import Data.Generic (gShow)
import Data.Array.Partial (last)
import Data.Array (length, filter)
import Partial.Unsafe (unsafePartial)
import Data.String (split, null, trim, joinWith)

import Daedalus.Crypto (isValidMnemonic)
import Data.Types (mkTime)
import Data.Types as DT

mkBackupPhrase :: String -> Either Error BackupPhrase
mkBackupPhrase mnemonic = mkBackupPhraseIgnoreChecksum mnemonic >>= const do
    if not $ isValidMnemonic mnemonicCleaned
        then Left $ error "Invalid mnemonic: checksum missmatch"
        else Right $ BackupPhrase { bpToList: split " " mnemonicCleaned }
  where
    mnemonicCleaned = cleanMnemonic mnemonic

cleanMnemonic :: String -> String
cleanMnemonic = joinWith " " <<< filter (not <<< null) <<< split " " <<< trim

mkBackupPhraseIgnoreChecksum :: String -> Either Error BackupPhrase
mkBackupPhraseIgnoreChecksum mnemonic =
    if not $ hasAtLeast12words mnemonicCleaned
        then Left $ error "Invalid mnemonic: mnemonic should have at least 12 words"
        else Right $ BackupPhrase { bpToList: split " " mnemonicCleaned }
  where
    hasAtLeast12words = (<=) 12 <<< length <<< split " "
    mnemonicCleaned = cleanMnemonic mnemonic

showCCurrency :: CT.CCurrency -> String
showCCurrency = dropModuleName <<< gShow
  where
    -- TODO: this is again stupid. We should derive Show for this type instead of doing this
    dropModuleName = unsafePartial last <<< split "."

-- TODO: it would be useful to extend purescript-bridge
-- and generate lenses

_hash :: CHash -> String
_hash (CHash h) = h

_address :: CAddress -> String
_address (CAddress a) = _hash a

mkCAddress :: String -> CAddress
mkCAddress = CAddress <<< CHash

_coin :: Coin -> Int
_coin (Coin c) = c.getCoin

mkCoin :: Int -> Coin
mkCoin amount = Coin { getCoin: amount }

-- NOTE: use genericRead maybe https://github.com/paluh/purescript-generic-read-example
mkCWalletType :: String -> CT.CWalletType
mkCWalletType = either (const CT.CWTPersonal) id <<< decodeJson <<< fromString

mkCCurrency :: String -> CT.CCurrency
mkCCurrency = either (const CT.ADA) id <<< decodeJson <<< fromString

mkCWalletMeta :: String -> String -> String -> CT.CWalletMeta
mkCWalletMeta wType wCurrency wName =
    CT.CWalletMeta { cwType: mkCWalletType wType
                   , cwCurrency: mkCCurrency wCurrency
                   , cwName: wName
                   }

mkCWalletInit :: String -> String -> String -> String -> Either Error CT.CWalletInit
mkCWalletInit wType wCurrency wName mnemonic =
    mkCWalletInit' wType wCurrency wName <$> mkBackupPhrase mnemonic

mkCWalletInitIgnoreChecksum :: String -> String -> String -> String -> Either Error CT.CWalletInit
mkCWalletInitIgnoreChecksum wType wCurrency wName mnemonic= do
    mkCWalletInit' wType wCurrency wName <$> mkBackupPhraseIgnoreChecksum mnemonic

mkCWalletInit' :: String -> String -> String -> BackupPhrase -> CT.CWalletInit
mkCWalletInit' wType wCurrency wName bp =
    CT.CWalletInit { cwBackupPhrase: bp
                   , cwInitMeta: mkCWalletMeta wType wCurrency wName
                   }

mkCWalletRedeem :: String -> String -> CT.CWalletRedeem
mkCWalletRedeem seed wId = do
    CT.CWalletRedeem { crWalletId: mkCAddress wId
                     , crSeed: seed
                     }

_ctxIdValue :: CT.CTxId -> String
_ctxIdValue (CT.CTxId tx) = _hash tx

mkCTxId :: String -> CT.CTxId
mkCTxId = CT.CTxId <<< CHash

mkCTxMeta :: String -> String -> String -> Number -> CT.CTxMeta
mkCTxMeta currency title description date =
    CT.CTxMeta { ctmCurrency: mkCCurrency currency
               , ctmTitle: title
               , ctmDescription: description
               , ctmDate: mkTime date
               }

mkCProfile :: String -> String -> String -> String -> Number -> String -> String -> CT.CProfile
mkCProfile name email phone pass date locale picture =
    CT.CProfile { cpName: name
                , cpEmail: email
                , cpPhoneNumber: phone
                , cpPwHash: pass
                , cpPwCreated: mkTime date
                , cpLocale: locale
                , cpPicture: picture
                }

module Daedalus.Types
       ( module CT
       , module C
       , module E
       , module BP
       , module DT
       , _address
       , _coin
       , mkCoin
       , mkCAddress
       , mkCWalletMeta
       , mkCWalletInit
       , mkCWalletInitIgnoreChecksum
       , mkCTxMeta
       , mkCTxId
       , mkCCurrency
       , mkCProfile
       , _ctxIdValue
       , showCCurrency
       , mkBackupPhrase
       , mkCWalletRedeem
       ) where

import Prelude

import Pos.Wallet.Web.ClientTypes (CAddress (..), CHash (..))
import Pos.Types.Core (Coin (..))

import Pos.Wallet.Web.ClientTypes as CT
import Pos.Types.Core as C
import Pos.Wallet.Web.Error as E
import Pos.Util.BackupPhrase (BackupPhrase (..))
import Pos.Util.BackupPhrase as BP

import Control.Monad.Eff.Exception (error, Error)
import Control.Apply ((<$>))
import Data.Either (either, Either (..))
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Argonaut.Core (fromString)
import Data.Generic (gShow)
import Data.Array.Partial (last)
import Data.Array (length, filter)
import Partial.Unsafe (unsafePartial)
import Data.String (split, null, trim, joinWith)

import Daedalus.Crypto (isValidMnemonic)
import Data.Types (mkTime)
import Data.Types as DT

mkBackupPhrase :: String -> Either Error BackupPhrase
mkBackupPhrase mnemonic =
    if not $ isValidMnemonic mnemonicCleaned
        then Left $ error "Invalid mnemonic: checksum missmatch"
        else Right $ BackupPhrase { bpToList: split " " mnemonicCleaned }
  where
    mnemonicCleaned = cleanMnemonic mnemonic

cleanMnemonic :: String -> String
cleanMnemonic = joinWith " " <<< filter (not <<< null) <<< split " " <<< trim

mkBackupPhraseIgnoreChecksum :: String -> Either Error BackupPhrase
mkBackupPhraseIgnoreChecksum mnemonic =
    if not $ hasAtLeast12words mnemonicCleaned
        then Left $ error "Invalid mnemonic: mnemonic should have at least 12 words"
        else Right $ BackupPhrase { bpToList: split " " mnemonicCleaned }
  where
    hasAtLeast12words = (<=) 12 <<< length <<< split " "
    mnemonicCleaned = cleanMnemonic mnemonic

showCCurrency :: CT.CCurrency -> String
showCCurrency = dropModuleName <<< gShow
  where
    -- TODO: this is again stupid. We should derive Show for this type instead of doing this
    dropModuleName = unsafePartial last <<< split "."

-- TODO: it would be useful to extend purescript-bridge
-- and generate lenses

_hash :: CHash -> String
_hash (CHash h) = h

_address :: CAddress -> String
_address (CAddress a) = _hash a

mkCAddress :: String -> CAddress
mkCAddress = CAddress <<< CHash

_coin :: Coin -> Int
_coin (Coin c) = c.getCoin

mkCoin :: Int -> Coin
mkCoin amount = Coin { getCoin: amount }

-- NOTE: use genericRead maybe https://github.com/paluh/purescript-generic-read-example
mkCWalletType :: String -> CT.CWalletType
mkCWalletType = either (const CT.CWTPersonal) id <<< decodeJson <<< fromString

mkCCurrency :: String -> CT.CCurrency
mkCCurrency = either (const CT.ADA) id <<< decodeJson <<< fromString

mkCWalletMeta :: String -> String -> String -> CT.CWalletMeta
mkCWalletMeta wType wCurrency wName =
    CT.CWalletMeta { cwType: mkCWalletType wType
                   , cwCurrency: mkCCurrency wCurrency
                   , cwName: wName
                   }

mkCWalletInit :: String -> String -> String -> String -> Either Error CT.CWalletInit
mkCWalletInit wType wCurrency wName mnemonic =
    mkCWalletInit' wType wCurrency wName <$> mkBackupPhrase mnemonic

mkCWalletInitIgnoreChecksum :: String -> String -> String -> String -> Either Error CT.CWalletInit
mkCWalletInitIgnoreChecksum wType wCurrency wName mnemonic= do
    mkCWalletInit' wType wCurrency wName <$> mkBackupPhraseIgnoreChecksum mnemonic

mkCWalletInit' :: String -> String -> String -> BackupPhrase -> CT.CWalletInit
mkCWalletInit' wType wCurrency wName bp =
    CT.CWalletInit { cwBackupPhrase: bp
                   , cwInitMeta: mkCWalletMeta wType wCurrency wName
                   }

mkCWalletRedeem :: String -> String -> CT.CWalletRedeem
mkCWalletRedeem seed wId = do
    CT.CWalletRedeem { crWalletId: mkCAddress wId
                     , crSeed: seed
                     }

_ctxIdValue :: CT.CTxId -> String
_ctxIdValue (CT.CTxId tx) = _hash tx

mkCTxId :: String -> CT.CTxId
mkCTxId = CT.CTxId <<< CHash

mkCTxMeta :: String -> String -> String -> Number -> CT.CTxMeta
mkCTxMeta currency title description date =
    CT.CTxMeta { ctmCurrency: mkCCurrency currency
               , ctmTitle: title
               , ctmDescription: description
               , ctmDate: mkTime date
               }

mkCProfile :: String -> String -> String -> String -> Number -> String -> String -> CT.CProfile
mkCProfile name email phone pass date locale picture =
    CT.CProfile { cpName: name
                , cpEmail: email
                , cpPhoneNumber: phone
                , cpPwHash: pass
                , cpPwCreated: mkTime date
                , cpLocale: locale
                , cpPicture: picture
                }


Add example of `f <$> arg1 <*> arg2 <*> ... <*> argN` to Apply docs

module Control.Apply
  ( class Apply, apply, (<*>)
  , applyFirst, (<*)
  , applySecond, (*>)
  , lift2, lift3, lift4, lift5
  , module Data.Functor
  ) where

import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Function (const)
import Control.Category (identity)

-- | The `Apply` class provides the `(<*>)` which is used to apply a function
-- | to an argument under a type constructor.
-- |
-- | `Apply` can be used to lift functions of two or more arguments to work on
-- | values wrapped with the type constructor `f`. It might also be understood
-- | in terms of the `lift2` function:
-- |
-- | ```purescript
-- | lift2 :: forall f a b c. Apply f => (a -> b -> c) -> f a -> f b -> f c
-- | lift2 f a b = f <$> a <*> b
-- | ```
-- |
-- | `(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts
-- | the function application operator `($)` to arguments wrapped with the
-- | type constructor `f`.
-- |
-- | Put differently...
-- | ```
-- | foo =
-- |   functionTakingNArguments <$> computationProducingArg1
-- |                            <*> computationProducingArg2
-- |                            <*> ...
-- |                            <*> computationProducingArgN
-- | ```
-- |
-- | Instances must satisfy the following law in addition to the `Functor`
-- | laws:
-- |
-- | - Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`
-- |
-- | Formally, `Apply` represents a strong lax semi-monoidal endofunctor.
class Functor f <= Apply f where
  apply :: forall a b. f (a -> b) -> f a -> f b

infixl 4 apply as <*>

instance applyFn :: Apply ((->) r) where
  apply f g x = f x (g x)

instance applyArray :: Apply Array where
  apply = arrayApply

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

-- | Combine two effectful actions, keeping only the result of the first.
applyFirst :: forall a b f. Apply f => f a -> f b -> f a
applyFirst a b = const <$> a <*> b

infixl 4 applyFirst as <*

-- | Combine two effectful actions, keeping only the result of the second.
applySecond :: forall a b f. Apply f => f a -> f b -> f b
applySecond a b = const identity <$> a <*> b

infixl 4 applySecond as *>

-- | Lift a function of two arguments to a function which accepts and returns
-- | values wrapped with the type constructor `f`.
lift2 :: forall a b c f. Apply f => (a -> b -> c) -> f a -> f b -> f c
lift2 f a b = f <$> a <*> b

-- | Lift a function of three arguments to a function which accepts and returns
-- | values wrapped with the type constructor `f`.
lift3 :: forall a b c d f. Apply f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
lift3 f a b c = f <$> a <*> b <*> c

-- | Lift a function of four arguments to a function which accepts and returns
-- | values wrapped with the type constructor `f`.
lift4 :: forall a b c d e f. Apply f => (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e
lift4 f a b c d = f <$> a <*> b <*> c <*> d

-- | Lift a function of five arguments to a function which accepts and returns
-- | values wrapped with the type constructor `f`.
lift5 :: forall a b c d e f g. Apply f => (a -> b -> c -> d -> e -> g) -> f a -> f b -> f c -> f d -> f e -> f g
lift5 f a b c d e = f <$> a <*> b <*> c <*> d <*> e

module Control.Apply
  ( class Apply, apply, (<*>)
  , applyFirst, (<*)
  , applySecond, (*>)
  , lift2, lift3, lift4, lift5
  , module Data.Functor
  ) where

import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Function (const)
import Control.Category (identity)

-- | The `Apply` class provides the `(<*>)` which is used to apply a function
-- | to an argument under a type constructor.
-- |
-- | `Apply` can be used to lift functions of two or more arguments to work on
-- | values wrapped with the type constructor `f`. It might also be understood
-- | in terms of the `lift2` function:
-- |
-- | ```purescript
-- | lift2 :: forall f a b c. Apply f => (a -> b -> c) -> f a -> f b -> f c
-- | lift2 f a b = f <$> a <*> b
-- | ```
-- |
-- | `(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts
-- | the function application operator `($)` to arguments wrapped with the
-- | type constructor `f`.
-- |
-- | Instances must satisfy the following law in addition to the `Functor`
-- | laws:
-- |
-- | - Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`
-- |
-- | Formally, `Apply` represents a strong lax semi-monoidal endofunctor.
class Functor f <= Apply f where
  apply :: forall a b. f (a -> b) -> f a -> f b

infixl 4 apply as <*>

instance applyFn :: Apply ((->) r) where
  apply f g x = f x (g x)

instance applyArray :: Apply Array where
  apply = arrayApply

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

-- | Combine two effectful actions, keeping only the result of the first.
applyFirst :: forall a b f. Apply f => f a -> f b -> f a
applyFirst a b = const <$> a <*> b

infixl 4 applyFirst as <*

-- | Combine two effectful actions, keeping only the result of the second.
applySecond :: forall a b f. Apply f => f a -> f b -> f b
applySecond a b = const identity <$> a <*> b

infixl 4 applySecond as *>

-- | Lift a function of two arguments to a function which accepts and returns
-- | values wrapped with the type constructor `f`.
lift2 :: forall a b c f. Apply f => (a -> b -> c) -> f a -> f b -> f c
lift2 f a b = f <$> a <*> b

-- | Lift a function of three arguments to a function which accepts and returns
-- | values wrapped with the type constructor `f`.
lift3 :: forall a b c d f. Apply f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
lift3 f a b c = f <$> a <*> b <*> c

-- | Lift a function of four arguments to a function which accepts and returns
-- | values wrapped with the type constructor `f`.
lift4 :: forall a b c d e f. Apply f => (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e
lift4 f a b c d = f <$> a <*> b <*> c <*> d

-- | Lift a function of five arguments to a function which accepts and returns
-- | values wrapped with the type constructor `f`.
lift5 :: forall a b c d e f g. Apply f => (a -> b -> c -> d -> e -> g) -> f a -> f b -> f c -> f d -> f e -> f g
lift5 f a b c d e = f <$> a <*> b <*> c <*> d <*> e