Evaluator tests work as well [ci skip]

Evaluator tests work as well [ci skip]

module Test.Evaluator where

import Prelude
import Data.Either (Either(..))
import Data.Tuple (Tuple(..))
import Data.StrMap as M
import Data.List (List(Nil))

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

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

import Test.Utils (Test, tell, padLeft)

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

preludeEnv :: Env
preludeEnv = case runParserIndent definitions prelude of
  Right (Tuple env _) -> defsToEnv env
  Left _    -> defsToEnv Nil

eval1test :: String -> String -> String -> Test Unit
eval1test name input expected = case (Tuple (runParserIndent expression input) (runParserIndent expression expected)) of
  (Tuple (Right (Tuple inExp _)) (Right (Tuple expExp _))) ->
    case runEvalM (eval1 M.empty inExp) of
      (Right eval1Exp) ->
        if eval1Exp `equals` 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 (Tuple inExp _)) (Right (Tuple expExp _))) (Right (Tuple defs _))) ->
    case runEvalM (eval1 (defsToEnv defs) inExp) of
      (Right eval1Exp) ->
        if eval1Exp `equals` 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 (Tuple inExp _)) (Right (Tuple expExp _))) (Right (Tuple defs _))) ->
    let evalExp = eval (defsToEnv defs) inExp in
      if evalExp `equals` 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)

evalTest :: String -> String -> String -> Test Unit
evalTest n = evalEnvTest n ""

evalPreludeTest :: String -> String -> String -> Test Unit
evalPreludeTest name input expected = case (Tuple (runParserIndent expression input) (runParserIndent expression expected)) of
  (Tuple (Right (Tuple inExp _)) (Right (Tuple expExp _))) ->
    let evalExp = eval preludeEnv inExp in
      if evalExp `equals` 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 from Prelude!\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\""
  eval1test "listComp1" "[x | x <-      [1..10]]"      "[x | x <- (1 : [2..10])]"
  eval1test "listComp2" "[x | x <- (1 : [2..10])]" "1 : [x | x <-      [2..10]]"
  eval1test "listComp3" "[x | x <-      [2..10]]"      "[x | x <- (2 : [3..10])]"
  eval1test "listComp4" "[x | x <- (2 : [3..10])]" "2 : [x | x <-      [3..10]]"

  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"
-}

  evalTest "constr-section-1"
    "(:+ 2) 1"
    "1 :+ 2"

  evalTest "constr-section-2"
    "(1 :+) 2"
    "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(Nil))

-- 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

preludeEnv :: Env
preludeEnv = case runParserIndent definitions prelude of
  Right (Tuple env _) -> defsToEnv env
  Left _    -> defsToEnv Nil

eval1test :: String -> String -> String -> Test Unit
eval1test name input expected = case (Tuple (runParserIndent expression input) (runParserIndent expression expected)) of
  (Tuple (Right (Tuple inExp _)) (Right (Tuple 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 (Tuple inExp _)) (Right (Tuple expExp _))) (Right (Tuple 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 (Tuple inExp _)) (Right (Tuple expExp _))) (Right (Tuple 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)

evalTest :: String -> String -> String -> Test Unit
evalTest n = evalEnvTest n ""

evalPreludeTest :: String -> String -> String -> Test Unit
evalPreludeTest name input expected = case (Tuple (runParserIndent expression input) (runParserIndent expression expected)) of
  (Tuple (Right (Tuple inExp _)) (Right (Tuple 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"
            <> "Definitions from Prelude!\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\""
  eval1test "listComp1" "[x | x <-      [1..10]]"      "[x | x <- (1 : [2..10])]"
  eval1test "listComp2" "[x | x <- (1 : [2..10])]" "1 : [x | x <-      [2..10]]"
  eval1test "listComp3" "[x | x <-      [2..10]]"      "[x | x <- (2 : [3..10])]"
  eval1test "listComp4" "[x | x <- (2 : [3..10])]" "2 : [x | x <-      [3..10]]"

  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"
-}

  evalTest "constr-section-1"
    "(:+ 2) 1"
    "1 :+ 2"

  evalTest "constr-section-2"
    "(1 :+) 2"
    "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)])
"""


Update documentation - split now takes a Pattern

-- | Wraps the functions of Javascript's `String` object.
-- | A String represents a sequence of characters.
-- | For details of the underlying implementation, see [String Reference at MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String).
module Data.String
  ( Pattern(..)
  , Replacement(..)
  , charAt
  , charCodeAt
  , fromCharArray
  , toChar
  , contains
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , null
  , uncons
  , length
  , singleton
  , localeCompare
  , replace
  , replaceAll
  , take
  , takeWhile
  , drop
  , dropWhile
  , stripPrefix
  , stripSuffix
  , count
  , split
  , splitAt
  , toCharArray
  , toLower
  , toUpper
  , trim
  , joinWith
  ) where

import Prelude

import Data.Maybe (Maybe(..), isJust)
import Data.Newtype (class Newtype)
import Data.String.Unsafe as U

-- | A newtype used in cases where there is a string to be matched.
newtype Pattern = Pattern String

derive instance eqPattern :: Eq Pattern
derive instance ordPattern :: Ord Pattern
derive instance newtypePattern :: Newtype Pattern _

instance showPattern :: Show Pattern where
  show (Pattern s) = "(Pattern " <> s <> ")"

-- | A newtype used in cases to specify a replacement for a pattern.
newtype Replacement = Replacement String

derive instance eqReplacement :: Eq Replacement
derive instance ordReplacement :: Ord Replacement
derive instance newtypeReplacement :: Newtype Replacement _

instance showReplacement :: Show Replacement where
  show (Replacement s) = "(Replacement " <> s <> ")"

-- | Returns the character at the given index, if the index is within bounds.
charAt :: Int -> String -> Maybe Char
charAt = _charAt Just Nothing

foreign import _charAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Char

-- | Returns a string of length `1` containing the given character.
foreign import singleton :: Char -> String

-- | Returns the numeric Unicode value of the character at the given index,
-- | if the index is within bounds.
charCodeAt :: Int -> String -> Maybe Int
charCodeAt = _charCodeAt Just Nothing

foreign import _charCodeAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Int

toChar :: String -> Maybe Char
toChar = _toChar Just Nothing

foreign import _toChar
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> String
  -> Maybe Char

-- | Returns `true` if the given string is empty.
null :: String -> Boolean
null s = s == ""

-- | Returns the first character and the rest of the string,
-- | if the string is not empty.
uncons :: String -> Maybe { head :: Char, tail :: String }
uncons "" = Nothing
uncons s  = Just { head: U.charAt zero s, tail: drop one s }

-- | Returns the longest prefix (possibly empty) of characters that satisfy
-- | the predicate.
takeWhile :: (Char -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Returns the suffix remaining after `takeWhile`.
dropWhile :: (Char -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | If the string starts with the given prefix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripPrefix (Pattern "http:") "http://purescript.org" == Just "//purescript.org"`
-- | * `stripPrefix (Pattern "http:") "https://purescript.org" == Nothing`
stripPrefix :: Pattern -> String -> Maybe String
stripPrefix prefix@(Pattern prefixS) str =
  case indexOf prefix str of
    Just 0 -> Just $ drop (length prefixS) str
    _ -> Nothing

-- | If the string ends with the given suffix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripSuffix (Pattern ".exe") "psc.exe" == Just "psc"`
-- | * `stripSuffix (Pattern ".exe") "psc" == Nothing`
stripSuffix :: Pattern -> String -> Maybe String
stripSuffix suffix@(Pattern suffixS) str =
  case lastIndexOf suffix str of
    Just x | x == length str - length suffixS -> Just $ take x str
    _ -> Nothing

-- | Converts an array of characters into a string.
foreign import fromCharArray :: Array Char -> String

-- | Checks whether the first string exists in the second string.
contains :: Pattern -> String -> Boolean
contains pat = isJust <<< indexOf pat

-- | Returns the index of the first occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
indexOf :: Pattern -> String -> Maybe Int
indexOf = _indexOf Just Nothing

foreign import _indexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the first occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
indexOf' :: Pattern -> Int -> String -> Maybe Int
indexOf' = _indexOf' Just Nothing

foreign import _indexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
lastIndexOf :: Pattern -> String -> Maybe Int
lastIndexOf = _lastIndexOf Just Nothing

foreign import _lastIndexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
lastIndexOf' :: Pattern -> Int -> String -> Maybe Int
lastIndexOf' = _lastIndexOf' Just Nothing

foreign import _lastIndexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the number of characters the string is composed of.
foreign import length :: String -> Int

-- | Locale-aware sort order comparison.
localeCompare :: String -> String -> Ordering
localeCompare = _localeCompare LT EQ GT

foreign import _localeCompare
  :: Ordering
  -> Ordering
  -> Ordering
  -> String
  -> String
  -> Ordering

-- | Replaces the first occurence of the first argument with the second argument.
foreign import replace :: Pattern -> Replacement -> String -> String

-- | Replaces all occurences of the first argument with the second argument.
foreign import replaceAll :: Pattern -> Replacement -> String -> String

-- | Returns the first `n` characters of the string.
foreign import take :: Int -> String -> String

-- | Returns the string without the first `n` characters.
foreign import drop :: Int -> String -> String

-- | Returns the number of contiguous characters at the beginning
-- | of the string for which the predicate holds.
foreign import count :: (Char -> Boolean) -> String -> Int

-- | Returns the substrings of the second string separated along occurences
-- | of the first string.
-- | * `split (Pattern " ") "hello world" == ["hello", "world"]`
foreign import split :: Pattern -> String -> Array String

-- | Returns the substrings of split at the given index, if the index is within bounds.
splitAt :: Int -> String -> Maybe (Array String)
splitAt = _splitAt Just Nothing

foreign import _splitAt :: (forall a. a -> Maybe a)
                        -> (forall a. Maybe a)
                        -> Int
                        -> String
                        -> Maybe (Array String)

-- | Converts the string into an array of characters.
foreign import toCharArray :: String -> Array Char

-- | Returns the argument converted to lowercase.
foreign import toLower :: String -> String

-- | Returns the argument converted to uppercase.
foreign import toUpper :: String -> String

-- | Removes whitespace from the beginning and end of a string, including
-- | [whitespace characters](http://www.ecma-international.org/ecma-262/5.1/#sec-7.2)
-- | and [line terminators](http://www.ecma-international.org/ecma-262/5.1/#sec-7.3).
foreign import trim :: String -> String

-- | Joins the strings in the array together, inserting the first argument
-- | as separator between them.
foreign import joinWith :: String -> Array String -> String

-- | Wraps the functions of Javascript's `String` object.
-- | A String represents a sequence of characters.
-- | For details of the underlying implementation, see [String Reference at MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String).
module Data.String
  ( Pattern(..)
  , Replacement(..)
  , charAt
  , charCodeAt
  , fromCharArray
  , toChar
  , contains
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , null
  , uncons
  , length
  , singleton
  , localeCompare
  , replace
  , replaceAll
  , take
  , takeWhile
  , drop
  , dropWhile
  , stripPrefix
  , stripSuffix
  , count
  , split
  , splitAt
  , toCharArray
  , toLower
  , toUpper
  , trim
  , joinWith
  ) where

import Prelude

import Data.Maybe (Maybe(..), isJust)
import Data.Newtype (class Newtype)
import Data.String.Unsafe as U

-- | A newtype used in cases where there is a string to be matched.
newtype Pattern = Pattern String

derive instance eqPattern :: Eq Pattern
derive instance ordPattern :: Ord Pattern
derive instance newtypePattern :: Newtype Pattern _

instance showPattern :: Show Pattern where
  show (Pattern s) = "(Pattern " <> s <> ")"

-- | A newtype used in cases to specify a replacement for a pattern.
newtype Replacement = Replacement String

derive instance eqReplacement :: Eq Replacement
derive instance ordReplacement :: Ord Replacement
derive instance newtypeReplacement :: Newtype Replacement _

instance showReplacement :: Show Replacement where
  show (Replacement s) = "(Replacement " <> s <> ")"

-- | Returns the character at the given index, if the index is within bounds.
charAt :: Int -> String -> Maybe Char
charAt = _charAt Just Nothing

foreign import _charAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Char

-- | Returns a string of length `1` containing the given character.
foreign import singleton :: Char -> String

-- | Returns the numeric Unicode value of the character at the given index,
-- | if the index is within bounds.
charCodeAt :: Int -> String -> Maybe Int
charCodeAt = _charCodeAt Just Nothing

foreign import _charCodeAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Int

toChar :: String -> Maybe Char
toChar = _toChar Just Nothing

foreign import _toChar
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> String
  -> Maybe Char

-- | Returns `true` if the given string is empty.
null :: String -> Boolean
null s = s == ""

-- | Returns the first character and the rest of the string,
-- | if the string is not empty.
uncons :: String -> Maybe { head :: Char, tail :: String }
uncons "" = Nothing
uncons s  = Just { head: U.charAt zero s, tail: drop one s }

-- | Returns the longest prefix (possibly empty) of characters that satisfy
-- | the predicate.
takeWhile :: (Char -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Returns the suffix remaining after `takeWhile`.
dropWhile :: (Char -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | If the string starts with the given prefix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripPrefix (Pattern "http:") "http://purescript.org" == Just "//purescript.org"`
-- | * `stripPrefix (Pattern "http:") "https://purescript.org" == Nothing`
stripPrefix :: Pattern -> String -> Maybe String
stripPrefix prefix@(Pattern prefixS) str =
  case indexOf prefix str of
    Just 0 -> Just $ drop (length prefixS) str
    _ -> Nothing

-- | If the string ends with the given suffix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripSuffix (Pattern ".exe") "psc.exe" == Just "psc"`
-- | * `stripSuffix (Pattern ".exe") "psc" == Nothing`
stripSuffix :: Pattern -> String -> Maybe String
stripSuffix suffix@(Pattern suffixS) str =
  case lastIndexOf suffix str of
    Just x | x == length str - length suffixS -> Just $ take x str
    _ -> Nothing

-- | Converts an array of characters into a string.
foreign import fromCharArray :: Array Char -> String

-- | Checks whether the first string exists in the second string.
contains :: Pattern -> String -> Boolean
contains pat = isJust <<< indexOf pat

-- | Returns the index of the first occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
indexOf :: Pattern -> String -> Maybe Int
indexOf = _indexOf Just Nothing

foreign import _indexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the first occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
indexOf' :: Pattern -> Int -> String -> Maybe Int
indexOf' = _indexOf' Just Nothing

foreign import _indexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
lastIndexOf :: Pattern -> String -> Maybe Int
lastIndexOf = _lastIndexOf Just Nothing

foreign import _lastIndexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
lastIndexOf' :: Pattern -> Int -> String -> Maybe Int
lastIndexOf' = _lastIndexOf' Just Nothing

foreign import _lastIndexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the number of characters the string is composed of.
foreign import length :: String -> Int

-- | Locale-aware sort order comparison.
localeCompare :: String -> String -> Ordering
localeCompare = _localeCompare LT EQ GT

foreign import _localeCompare
  :: Ordering
  -> Ordering
  -> Ordering
  -> String
  -> String
  -> Ordering

-- | Replaces the first occurence of the first argument with the second argument.
foreign import replace :: Pattern -> Replacement -> String -> String

-- | Replaces all occurences of the first argument with the second argument.
foreign import replaceAll :: Pattern -> Replacement -> String -> String

-- | Returns the first `n` characters of the string.
foreign import take :: Int -> String -> String

-- | Returns the string without the first `n` characters.
foreign import drop :: Int -> String -> String

-- | Returns the number of contiguous characters at the beginning
-- | of the string for which the predicate holds.
foreign import count :: (Char -> Boolean) -> String -> Int

-- | Returns the substrings of the second string separated along occurences
-- | of the first string.
-- | * `split " " "hello world" == ["hello", "world"]`
foreign import split :: Pattern -> String -> Array String

-- | Returns the substrings of split at the given index, if the index is within bounds.
splitAt :: Int -> String -> Maybe (Array String)
splitAt = _splitAt Just Nothing

foreign import _splitAt :: (forall a. a -> Maybe a)
                        -> (forall a. Maybe a)
                        -> Int
                        -> String
                        -> Maybe (Array String)

-- | Converts the string into an array of characters.
foreign import toCharArray :: String -> Array Char

-- | Returns the argument converted to lowercase.
foreign import toLower :: String -> String

-- | Returns the argument converted to uppercase.
foreign import toUpper :: String -> String

-- | Removes whitespace from the beginning and end of a string, including
-- | [whitespace characters](http://www.ecma-international.org/ecma-262/5.1/#sec-7.2)
-- | and [line terminators](http://www.ecma-international.org/ecma-262/5.1/#sec-7.3).
foreign import trim :: String -> String

-- | Joins the strings in the array together, inserting the first argument
-- | as separator between them.
foreign import joinWith :: String -> Array String -> String


letterSpaccing reverted to Number

letterSpaccing reverted to Number

module RNX.Styles where

import Prelude

import RNX.Color (Color)
import React.DOM.Props (Props, unsafeMkProps)
import Unsafe.Coerce (unsafeCoerce)

-- | Proof that row `r` is a subset of row `s`
class Optional (r :: # Type) (s :: # Type)
instance srInstance :: Union r t s => Optional r s

foreign import data Style :: Type

type StyleProps =
  ( alignItems :: AlignItem
  , alignSelf :: AlignSelf
  , backfaceVisibility :: Visibility
  , backgroundColor :: Color
  , backgroundVisibility :: Visibility
  , borderBottomColor :: Color
  , borderBottomLeftRadius :: Int
  , borderBottomRightRadius :: Int
  , borderBottomWidth :: Int
  , borderColor :: Color
  , borderLeftColor :: Color
  , borderLeftWidth :: Int
  , borderRadius :: Int
  , borderRightColor :: Color
  , borderRightWidth :: Int
  , borderStyle :: BorderStyle
  , borderTopColor :: Color
  , borderTopLeftRadius :: Int
  , borderTopRightRadius :: Int
  , borderTopWidth :: Int
  , borderWidth :: Int
  , bottom :: Int
  , color :: Color
  , elevation :: Int
  , flex :: Int
  , flexBasis :: Int
  , flexDirection :: FlexDirection
  , flexGrow :: Int
  , flexShrink :: Int
  , flexWrap :: Wrap
  , fontFamily :: FontFamily
  , fontSize :: Int
  , fontStyle :: FontStyle
  , fontWeight :: FontWeight
  , height :: Int
  , justifyContent :: JustifyContent
  , left :: Int
  , letterSpacing :: Number
  , lineHeight :: Int
  , margin :: Int
  , marginBottom :: Int
  , marginHorizontal :: Int
  , marginLeft :: Int
  , marginRight :: Int
  , marginTop :: Int
  , marginVertical :: Int
  , maxHeight :: Int
  , maxWidth :: Int
  , minHeight :: Int
  , minWidth :: Int
  , opacity :: Int
  , overflow :: Visibility
  , overlayColor :: Color
  , padding :: Int
  , paddingBottom :: Int
  , paddingHorizontal :: Int
  , paddingLeft :: Int
  , paddingRight :: Int
  , paddingTop :: Int
  , paddingVertical :: Int
  , position :: Position
  , right :: Int
  , shadowColor :: Color
  , shadowOffset :: WidthHeight
  , shadowOpacity :: Int
  , shadowRadius :: Int
  , textAlign :: TextAlign
  , textAlignVertical :: TextAlignVertical
  , textDecorationColor :: Color
  , textDecorationLine :: TextDecorationLine
  , textDecorationStyle :: TextDecorationStyle
  , textShadowColor :: Color
  , textShadowOffset :: WidthHeight
  , textShadowRadius :: Int
  , top :: Int
  , width :: Int
  , writingDirection :: WritingDirection
  , zIndex :: Int
  )

foreign import createStyle_ :: forall props. props -> Style

createStyle :: forall o. Optional o StyleProps => { | o } -> Style
createStyle = createStyle_

style :: Style -> Props
style = unsafeMkProps"style"

styles :: Array Style -> Props
styles = unsafeMkProps "style"

--------- Styles ---------------

newtype AlignItem = AlignItem String

alignItems :: { flexStart :: AlignItem
, flexEnd :: AlignItem
, center :: AlignItem
, stretch :: AlignItem
}
alignItems =
  { flexStart : AlignItem "flex-start"
  , flexEnd : AlignItem "flex-end"
  , center : AlignItem "center"
  , stretch : AlignItem "stretch"
  }

newtype AlignSelf = AlignSelf String

alignSelf :: { auto :: AlignSelf
, flexStart :: AlignSelf
, flexEnd :: AlignSelf
, center :: AlignSelf
, stretch :: AlignSelf
}
alignSelf =
  { auto : AlignSelf "auto"
  , flexStart : AlignSelf "flex-start"
  , flexEnd : AlignSelf "flex-end"
  , center : AlignSelf "center"
  , stretch : AlignSelf "stretch"
  }

newtype FontFamily = FontFamily String

newtype Visibility = Visibility String

hidden :: Visibility
hidden = Visibility "hidden"

visible :: Visibility
visible = Visibility "visible"

-- B

newtype BorderStyle = BorderStyle String

borderStyle :: { solid :: BorderStyle
, dotted :: BorderStyle
, dashed :: BorderStyle
}
borderStyle =
  { solid : BorderStyle "solid"
  , dotted : BorderStyle "dotted"
  , dashed : BorderStyle "dashed"
  }

newtype FlexDirection = FlexDirection String

flexDirection :: { row :: FlexDirection
, column :: FlexDirection
, columnReverse :: FlexDirection
, rowReverse :: FlexDirection
}
flexDirection =
  { row : FlexDirection "row"
  , column : FlexDirection "column"
  , columnReverse : FlexDirection "column-reverse"
  , rowReverse : FlexDirection "row-reverse"
  }

newtype Wrap = Wrap String

wrap :: Wrap
wrap = Wrap "wrap"

nowrap :: Wrap
nowrap = Wrap "nowrap"

data FontStyle = FontStyle String

normal :: FontStyle
normal = FontStyle "normal"

italic :: FontStyle
italic = FontStyle "italic"

-- fontVariant :: Array FontVariant -> StyleProp
-- fontVariant ary = unsafeMkStyleProp "fontVariant" (map fontVariantNum ary)

-- fontVariantNum :: FontVariant -> String
-- fontVariantNum SmallCap        = "small-caps"
-- fontVariantNum OldStyleNum     = "oldstyle-nums"
-- fontVariantNum LiningNum       = "lining-nums"
-- fontVariantNum TabularNum      = "tabular-nums"
-- fontVariantNum ProportionalNum = "proportional-nums"

newtype FontWeight = FontWeight String

fontWeight :: { normal :: FontWeight
, bold :: FontWeight
, w100 :: FontWeight
, w200 :: FontWeight
, w300 :: FontWeight
, w400 :: FontWeight
, w500 :: FontWeight
, w600 :: FontWeight
, w700 :: FontWeight
, w800 :: FontWeight
, w900 :: FontWeight
}
fontWeight =
  { normal : FontWeight "normal"
  , bold : FontWeight "bold"
  , w100 : FontWeight "100"
  , w200 : FontWeight "200"
  , w300 : FontWeight "300"
  , w400 : FontWeight "400"
  , w500 : FontWeight "500"
  , w600 : FontWeight "600"
  , w700 : FontWeight "700"
  , w800 : FontWeight "800"
  , w900 : FontWeight "900"
  }

newtype JustifyContent = JustifyContent String

justifyContent :: { flexStart :: JustifyContent
, flexEnd :: JustifyContent
, center :: JustifyContent
, spaceBetween :: JustifyContent
, spaceAround :: JustifyContent
}
justifyContent =
  { flexStart : JustifyContent "flex-start"
  , flexEnd : JustifyContent "flex-end"
  , center : JustifyContent "center"
  , spaceBetween : JustifyContent "space-between"
  , spaceAround : JustifyContent "space-around"
  }

newtype Position = Position String

absolute :: Position
absolute = Position "absolute"

relative :: Position
relative = Position "relative"

newtype WidthHeight = WidthHeight {width :: Int, height :: Int}

-- T
newtype TextAlign = TextAlign String

textAlign :: { auto :: TextAlign
, left :: TextAlign
, right :: TextAlign
, center :: TextAlign
, justify :: TextAlign
}
textAlign =
  { auto : TextAlign "auto"
  , left : TextAlign "left"
  , right : TextAlign "right"
  , center : TextAlign "center"
  , justify : TextAlign "justify"
  }

newtype TextAlignVertical = TextAlignVertical String

textAlignVertical :: { auto :: TextAlignVertical
, top :: TextAlignVertical
, bottom :: TextAlignVertical
, center :: TextAlignVertical
}
textAlignVertical =
  { auto : TextAlignVertical "auto"
  , top : TextAlignVertical "top"
  , bottom : TextAlignVertical "bottom"
  , center : TextAlignVertical "center"
  }

newtype TextDecorationLine = TextDecorationLine String

textDecorationLine :: { none :: TextDecorationLine
, underline :: TextDecorationLine
, lineThrough :: TextDecorationLine
, underlineLineThrough :: TextDecorationLine
}
textDecorationLine =
  { none : TextDecorationLine "none"
  , underline : TextDecorationLine "underline"
  , lineThrough : TextDecorationLine "line-through"
  , underlineLineThrough : TextDecorationLine "underline line-through"
  }

newtype TextDecorationStyle = TextDecorationStyle String

textDecorationStyle :: { solid :: TextDecorationStyle
, double :: TextDecorationStyle
, dotted :: TextDecorationStyle
, dashed :: TextDecorationStyle
}
textDecorationStyle =
  { solid : TextDecorationStyle "solid"
  , double : TextDecorationStyle "double"
  , dotted : TextDecorationStyle "dotted"
  , dashed : TextDecorationStyle "dashed"
  }

newtype WritingDirection = WritingDirection String

writingDirection :: { auto :: WritingDirection
, ltr :: WritingDirection
, rtl :: WritingDirection
}
writingDirection =
  { auto : WritingDirection "auto"
  , ltr : WritingDirection "ltr"
  , rtl : WritingDirection "rtl"

  }

-- TODO: Transform StyleProp
-- TODO: resizeMode

module RNX.Styles where

import Prelude

import RNX.Color (Color)
import React.DOM.Props (Props, unsafeMkProps)
import Unsafe.Coerce (unsafeCoerce)

-- | Proof that row `r` is a subset of row `s`
class Optional (r :: # Type) (s :: # Type)
instance srInstance :: Union r t s => Optional r s

foreign import data Style :: Type
foreign import data LetterSpacing :: Type

type StyleProps =
  ( alignItems :: AlignItem
  , alignSelf :: AlignSelf
  , backfaceVisibility :: Visibility
  , backgroundColor :: Color
  , backgroundVisibility :: Visibility
  , borderBottomColor :: Color
  , borderBottomLeftRadius :: Int
  , borderBottomRightRadius :: Int
  , borderBottomWidth :: Int
  , borderColor :: Color
  , borderLeftColor :: Color
  , borderLeftWidth :: Int
  , borderRadius :: Int
  , borderRightColor :: Color
  , borderRightWidth :: Int
  , borderStyle :: BorderStyle
  , borderTopColor :: Color
  , borderTopLeftRadius :: Int
  , borderTopRightRadius :: Int
  , borderTopWidth :: Int
  , borderWidth :: Int
  , bottom :: Int
  , color :: Color
  , elevation :: Int
  , flex :: Int
  , flexBasis :: Int
  , flexDirection :: FlexDirection
  , flexGrow :: Int
  , flexShrink :: Int
  , flexWrap :: Wrap
  , fontFamily :: FontFamily
  , fontSize :: Int
  , fontStyle :: FontStyle
  , fontWeight :: FontWeight
  , height :: Int
  , justifyContent :: JustifyContent
  , left :: Int
  , letterSpacing :: LetterSpacing
  , lineHeight :: Int
  , margin :: Int
  , marginBottom :: Int
  , marginHorizontal :: Int
  , marginLeft :: Int
  , marginRight :: Int
  , marginTop :: Int
  , marginVertical :: Int
  , maxHeight :: Int
  , maxWidth :: Int
  , minHeight :: Int
  , minWidth :: Int
  , opacity :: Int
  , overflow :: Visibility
  , overlayColor :: Color
  , padding :: Int
  , paddingBottom :: Int
  , paddingHorizontal :: Int
  , paddingLeft :: Int
  , paddingRight :: Int
  , paddingTop :: Int
  , paddingVertical :: Int
  , position :: Position
  , right :: Int
  , shadowColor :: Color
  , shadowOffset :: WidthHeight
  , shadowOpacity :: Int
  , shadowRadius :: Int
  , textAlign :: TextAlign
  , textAlignVertical :: TextAlignVertical
  , textDecorationColor :: Color
  , textDecorationLine :: TextDecorationLine
  , textDecorationStyle :: TextDecorationStyle
  , textShadowColor :: Color
  , textShadowOffset :: WidthHeight
  , textShadowRadius :: Int
  , top :: Int
  , width :: Int
  , writingDirection :: WritingDirection
  , zIndex :: Int
  )

foreign import createStyle_ :: forall props. props -> Style

letterSpacing_ :: Number -> String -> LetterSpacing
letterSpacing_ n s = unsafeCoerce ( show n <> s)

letterSpacing_s :: String -> LetterSpacing
letterSpacing_s = unsafeCoerce

letterSpacing :: { num :: Number -> LetterSpacing
, em :: Number -> LetterSpacing
, px :: Number -> LetterSpacing
, normal :: LetterSpacing
, inherit :: LetterSpacing
, initial :: LetterSpacing
}
letterSpacing =
  { num : \n -> letterSpacing_ n ""
  , em : \n -> letterSpacing_ n "em"
  , px : \n -> letterSpacing_ n "px"
  , normal : letterSpacing_s "normal"
  , inherit : letterSpacing_s "inherit"
  , initial : letterSpacing_s "initial"
  }

createStyle :: forall o. Optional o StyleProps => { | o } -> Style
createStyle = createStyle_

style :: Style -> Props
style = unsafeMkProps"style"

styles :: Array Style -> Props
styles = unsafeMkProps "style"

--------- Styles ---------------

newtype AlignItem = AlignItem String

alignItems :: { flexStart :: AlignItem
, flexEnd :: AlignItem
, center :: AlignItem
, stretch :: AlignItem
}
alignItems =
  { flexStart : AlignItem "flex-start"
  , flexEnd : AlignItem "flex-end"
  , center : AlignItem "center"
  , stretch : AlignItem "stretch"
  }

newtype AlignSelf = AlignSelf String

alignSelf :: { auto :: AlignSelf
, flexStart :: AlignSelf
, flexEnd :: AlignSelf
, center :: AlignSelf
, stretch :: AlignSelf
}
alignSelf =
  { auto : AlignSelf "auto"
  , flexStart : AlignSelf "flex-start"
  , flexEnd : AlignSelf "flex-end"
  , center : AlignSelf "center"
  , stretch : AlignSelf "stretch"
  }

newtype FontFamily = FontFamily String

newtype Visibility = Visibility String

hidden :: Visibility
hidden = Visibility "hidden"

visible :: Visibility
visible = Visibility "visible"

-- B

newtype BorderStyle = BorderStyle String

borderStyle :: { solid :: BorderStyle
, dotted :: BorderStyle
, dashed :: BorderStyle
}
borderStyle =
  { solid : BorderStyle "solid"
  , dotted : BorderStyle "dotted"
  , dashed : BorderStyle "dashed"
  }

newtype FlexDirection = FlexDirection String

flexDirection :: { row :: FlexDirection
, column :: FlexDirection
, columnReverse :: FlexDirection
, rowReverse :: FlexDirection
}
flexDirection =
  { row : FlexDirection "row"
  , column : FlexDirection "column"
  , columnReverse : FlexDirection "column-reverse"
  , rowReverse : FlexDirection "row-reverse"
  }

newtype Wrap = Wrap String

wrap :: Wrap
wrap = Wrap "wrap"

nowrap :: Wrap
nowrap = Wrap "nowrap"

data FontStyle = FontStyle String

normal :: FontStyle
normal = FontStyle "normal"

italic :: FontStyle
italic = FontStyle "italic"

-- fontVariant :: Array FontVariant -> StyleProp
-- fontVariant ary = unsafeMkStyleProp "fontVariant" (map fontVariantNum ary)

-- fontVariantNum :: FontVariant -> String
-- fontVariantNum SmallCap        = "small-caps"
-- fontVariantNum OldStyleNum     = "oldstyle-nums"
-- fontVariantNum LiningNum       = "lining-nums"
-- fontVariantNum TabularNum      = "tabular-nums"
-- fontVariantNum ProportionalNum = "proportional-nums"

newtype FontWeight = FontWeight String

fontWeight :: { normal :: FontWeight
, bold :: FontWeight
, w100 :: FontWeight
, w200 :: FontWeight
, w300 :: FontWeight
, w400 :: FontWeight
, w500 :: FontWeight
, w600 :: FontWeight
, w700 :: FontWeight
, w800 :: FontWeight
, w900 :: FontWeight
}
fontWeight =
  { normal : FontWeight "normal"
  , bold : FontWeight "bold"
  , w100 : FontWeight "100"
  , w200 : FontWeight "200"
  , w300 : FontWeight "300"
  , w400 : FontWeight "400"
  , w500 : FontWeight "500"
  , w600 : FontWeight "600"
  , w700 : FontWeight "700"
  , w800 : FontWeight "800"
  , w900 : FontWeight "900"
  }

newtype JustifyContent = JustifyContent String

justifyContent :: { flexStart :: JustifyContent
, flexEnd :: JustifyContent
, center :: JustifyContent
, spaceBetween :: JustifyContent
, spaceAround :: JustifyContent
}
justifyContent =
  { flexStart : JustifyContent "flex-start"
  , flexEnd : JustifyContent "flex-end"
  , center : JustifyContent "center"
  , spaceBetween : JustifyContent "space-between"
  , spaceAround : JustifyContent "space-around"
  }

newtype Position = Position String

absolute :: Position
absolute = Position "absolute"

relative :: Position
relative = Position "relative"

newtype WidthHeight = WidthHeight {width :: Int, height :: Int}

-- T
newtype TextAlign = TextAlign String

textAlign :: { auto :: TextAlign
, left :: TextAlign
, right :: TextAlign
, center :: TextAlign
, justify :: TextAlign
}
textAlign =
  { auto : TextAlign "auto"
  , left : TextAlign "left"
  , right : TextAlign "right"
  , center : TextAlign "center"
  , justify : TextAlign "justify"
  }

newtype TextAlignVertical = TextAlignVertical String

textAlignVertical :: { auto :: TextAlignVertical
, top :: TextAlignVertical
, bottom :: TextAlignVertical
, center :: TextAlignVertical
}
textAlignVertical =
  { auto : TextAlignVertical "auto"
  , top : TextAlignVertical "top"
  , bottom : TextAlignVertical "bottom"
  , center : TextAlignVertical "center"
  }

newtype TextDecorationLine = TextDecorationLine String

textDecorationLine :: { none :: TextDecorationLine
, underline :: TextDecorationLine
, lineThrough :: TextDecorationLine
, underlineLineThrough :: TextDecorationLine
}
textDecorationLine =
  { none : TextDecorationLine "none"
  , underline : TextDecorationLine "underline"
  , lineThrough : TextDecorationLine "line-through"
  , underlineLineThrough : TextDecorationLine "underline line-through"
  }

newtype TextDecorationStyle = TextDecorationStyle String

textDecorationStyle :: { solid :: TextDecorationStyle
, double :: TextDecorationStyle
, dotted :: TextDecorationStyle
, dashed :: TextDecorationStyle
}
textDecorationStyle =
  { solid : TextDecorationStyle "solid"
  , double : TextDecorationStyle "double"
  , dotted : TextDecorationStyle "dotted"
  , dashed : TextDecorationStyle "dashed"
  }

newtype WritingDirection = WritingDirection String

writingDirection :: { auto :: WritingDirection
, ltr :: WritingDirection
, rtl :: WritingDirection
}
writingDirection =
  { auto : WritingDirection "auto"
  , ltr : WritingDirection "ltr"
  , rtl : WritingDirection "rtl"

  }

-- TODO: Transform StyleProp
-- TODO: resizeMode


Clarify valid range of days

Clarify valid range of days

module Data.Date
  ( Date
  , canonicalDate
  , exactDate
  , year
  , month
  , day
  , weekday
  , diff
  , isLeapYear
  , lastDayOfMonth
  , adjust
  , module Data.Date.Component
  ) where

import Prelude

import Data.Date.Component (Day, Month(..), Weekday(..), Year)
import Data.Enum (class Enum, toEnum, fromEnum, succ, pred)
import Data.Function.Uncurried (Fn3, runFn3, Fn4, runFn4, Fn6, runFn6)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(..), fromJust, fromMaybe, isNothing)
import Data.Time.Duration (class Duration, Days(..), Milliseconds, toDuration)
import Partial.Unsafe (unsafePartial)

-- | A date value in the Gregorian calendar.
data Date = Date Year Month Day

-- | Constructs a date from year, month, and day components. The resulting date
-- | components may not be identical to the input values, as the date will be
-- | canonicalised according to the Gregorian calendar. For example, date
-- | values for the invalid date 2016-02-31 will be corrected to 2016-03-02.
canonicalDate :: Year -> Month -> Day -> Date
canonicalDate y m d = runFn4 canonicalDateImpl mkDate y (fromEnum m) d
  where
  mkDate :: Year -> Int -> Day -> Date
  mkDate = unsafePartial \y' m' d' -> Date y' (fromJust (toEnum m')) d'

-- | Constructs a date from year, month, and day components. The result will be
-- | `Nothing` if the provided values result in an invalid date.
exactDate :: Year -> Month -> Day -> Maybe Date
exactDate y m d =
  let dt = Date y m d
  in if canonicalDate y m d == dt then Just dt else Nothing

derive instance eqDate :: Eq Date
derive instance ordDate :: Ord Date

instance boundedDate :: Bounded Date where
  bottom = Date bottom bottom bottom
  top = Date top top top

instance showDate :: Show Date where
  show (Date y m d) = "(Date " <> show y <> " " <> show m <> " " <> show d <> ")"

instance enumDate :: Enum Date where
  succ (Date y m d) = Date <$> y' <*> pure m' <*> d'
    where
      d' = if isNothing sd then toEnum 1 else sd
      m' = if isNothing sd then fromMaybe January sm else m
      y' = if isNothing sd && isNothing sm then succ y else Just y
      sd = let v = succ d in if v > Just l then Nothing else v
      sm = succ m
      l = lastDayOfMonth y m
  pred (Date y m d) = Date <$> y' <*> pure m' <*> d'
    where
      d' = if isNothing pd then Just l else pd
      m' = if isNothing pd then fromMaybe December pm else m
      y' = if isNothing pd && isNothing pm then pred y else Just y
      pd = pred d
      pm = pred m
      l = lastDayOfMonth y m'

-- | The year component of a date value.
year :: Date -> Year
year (Date y _ _) = y

-- | The month component of a date value.
month :: Date -> Month
month (Date _ m _) = m

-- | The day component of a date value.
day :: Date -> Day
day (Date _ _ d) = d

-- | The weekday for a date value.
weekday :: Date -> Weekday
weekday = unsafePartial \(Date y m d) ->
  let n = runFn3 calcWeekday y (fromEnum m) d
  in if n == 0 then fromJust (toEnum 7) else fromJust (toEnum n)

-- | Adjusts a date with a Duration in days. The number of days must
-- | fall within the valid range for an `Int` type otherwise `Nothing`
-- | is returned.
adjust :: Days -> Date -> Maybe Date
adjust (Days n) date = fromNumber n >>= flip adj date
  where
    adj 0 dt           = Just dt
    adj i (Date y m d) = adj i' =<< dt'
      where
        i'  | low       = j
            | hi        = j - fromEnum l - 1
            | otherwise = 0
        dt' | low       = pred =<< Date y m <$> toEnum 1
            | hi        = succ (Date y m l)
            | otherwise = Date y m <$> toEnum j
        j   = i + fromEnum d
        low = j < 1
        hi  = j > fromEnum l
        l   = lastDayOfMonth y (if low then fromMaybe December (pred m) else m)

-- | Calculates the difference between two dates, returning the result as a
-- | duration.
diff :: forall d. Duration d => Date -> Date -> d
diff (Date y1 m1 d1) (Date y2 m2 d2) =
  toDuration $ runFn6 calcDiff y1 (fromEnum m1) d1 y2 (fromEnum m2) d2

-- | Checks whether a year is a leap year according to the proleptic Gregorian
-- | calendar.
isLeapYear :: Year -> Boolean
isLeapYear y = (mod y' 4 == 0) && ((mod y' 400 == 0) || not (mod y' 100 == 0))
  where
  y' = fromEnum y

-- | Get the final day of a month and year, accounting for leap years.
lastDayOfMonth :: Year -> Month -> Day
lastDayOfMonth y m = case m of
  January -> unsafeDay 31
  February
    | isLeapYear y -> unsafeDay 29
    | otherwise -> unsafeDay 28
  March -> unsafeDay 31
  April -> unsafeDay 30
  May -> unsafeDay 31
  June -> unsafeDay 30
  July -> unsafeDay 31
  August -> unsafeDay 31
  September -> unsafeDay 30
  October -> unsafeDay 31
  November -> unsafeDay 30
  December -> unsafeDay 31
  where
    unsafeDay = unsafePartial fromJust <<< toEnum

-- TODO: these could (and probably should) be implemented in PS
foreign import canonicalDateImpl :: Fn4 (Year -> Int -> Day -> Date) Year Int Day Date
foreign import calcWeekday :: Fn3 Year Int Day Int
foreign import calcDiff :: Fn6 Year Int Day Year Int Day Milliseconds

module Data.Date
  ( Date
  , canonicalDate
  , exactDate
  , year
  , month
  , day
  , weekday
  , diff
  , isLeapYear
  , lastDayOfMonth
  , adjust
  , module Data.Date.Component
  ) where

import Prelude

import Data.Date.Component (Day, Month(..), Weekday(..), Year)
import Data.Enum (class Enum, toEnum, fromEnum, succ, pred)
import Data.Function.Uncurried (Fn3, runFn3, Fn4, runFn4, Fn6, runFn6)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(..), fromJust, fromMaybe, isNothing)
import Data.Time.Duration (class Duration, Days(..), Milliseconds, toDuration)
import Partial.Unsafe (unsafePartial)

-- | A date value in the Gregorian calendar.
data Date = Date Year Month Day

-- | Constructs a date from year, month, and day components. The resulting date
-- | components may not be identical to the input values, as the date will be
-- | canonicalised according to the Gregorian calendar. For example, date
-- | values for the invalid date 2016-02-31 will be corrected to 2016-03-02.
canonicalDate :: Year -> Month -> Day -> Date
canonicalDate y m d = runFn4 canonicalDateImpl mkDate y (fromEnum m) d
  where
  mkDate :: Year -> Int -> Day -> Date
  mkDate = unsafePartial \y' m' d' -> Date y' (fromJust (toEnum m')) d'

-- | Constructs a date from year, month, and day components. The result will be
-- | `Nothing` if the provided values result in an invalid date.
exactDate :: Year -> Month -> Day -> Maybe Date
exactDate y m d =
  let dt = Date y m d
  in if canonicalDate y m d == dt then Just dt else Nothing

derive instance eqDate :: Eq Date
derive instance ordDate :: Ord Date

instance boundedDate :: Bounded Date where
  bottom = Date bottom bottom bottom
  top = Date top top top

instance showDate :: Show Date where
  show (Date y m d) = "(Date " <> show y <> " " <> show m <> " " <> show d <> ")"

instance enumDate :: Enum Date where
  succ (Date y m d) = Date <$> y' <*> pure m' <*> d'
    where
      d' = if isNothing sd then toEnum 1 else sd
      m' = if isNothing sd then fromMaybe January sm else m
      y' = if isNothing sd && isNothing sm then succ y else Just y
      sd = let v = succ d in if v > Just l then Nothing else v
      sm = succ m
      l = lastDayOfMonth y m
  pred (Date y m d) = Date <$> y' <*> pure m' <*> d'
    where
      d' = if isNothing pd then Just l else pd
      m' = if isNothing pd then fromMaybe December pm else m
      y' = if isNothing pd && isNothing pm then pred y else Just y
      pd = pred d
      pm = pred m
      l = lastDayOfMonth y m'

-- | The year component of a date value.
year :: Date -> Year
year (Date y _ _) = y

-- | The month component of a date value.
month :: Date -> Month
month (Date _ m _) = m

-- | The day component of a date value.
day :: Date -> Day
day (Date _ _ d) = d

-- | The weekday for a date value.
weekday :: Date -> Weekday
weekday = unsafePartial \(Date y m d) ->
  let n = runFn3 calcWeekday y (fromEnum m) d
  in if n == 0 then fromJust (toEnum 7) else fromJust (toEnum n)

-- | Adjusts a date with a Duration in days. The day duration is
-- | converted to an Int using fromNumber.
adjust :: Days -> Date -> Maybe Date
adjust (Days n) date = fromNumber n >>= flip adj date
  where
    adj 0 dt           = Just dt
    adj i (Date y m d) = adj i' =<< dt'
      where
        i'  | low       = j
            | hi        = j - fromEnum l - 1
            | otherwise = 0
        dt' | low       = pred =<< Date y m <$> toEnum 1
            | hi        = succ (Date y m l)
            | otherwise = Date y m <$> toEnum j
        j   = i + fromEnum d
        low = j < 1
        hi  = j > fromEnum l
        l   = lastDayOfMonth y (if low then fromMaybe December (pred m) else m)

-- | Calculates the difference between two dates, returning the result as a
-- | duration.
diff :: forall d. Duration d => Date -> Date -> d
diff (Date y1 m1 d1) (Date y2 m2 d2) =
  toDuration $ runFn6 calcDiff y1 (fromEnum m1) d1 y2 (fromEnum m2) d2

-- | Checks whether a year is a leap year according to the proleptic Gregorian
-- | calendar.
isLeapYear :: Year -> Boolean
isLeapYear y = (mod y' 4 == 0) && ((mod y' 400 == 0) || not (mod y' 100 == 0))
  where
  y' = fromEnum y

-- | Get the final day of a month and year, accounting for leap years.
lastDayOfMonth :: Year -> Month -> Day
lastDayOfMonth y m = case m of
  January -> unsafeDay 31
  February
    | isLeapYear y -> unsafeDay 29
    | otherwise -> unsafeDay 28
  March -> unsafeDay 31
  April -> unsafeDay 30
  May -> unsafeDay 31
  June -> unsafeDay 30
  July -> unsafeDay 31
  August -> unsafeDay 31
  September -> unsafeDay 30
  October -> unsafeDay 31
  November -> unsafeDay 30
  December -> unsafeDay 31
  where
    unsafeDay = unsafePartial fromJust <<< toEnum

-- TODO: these could (and probably should) be implemented in PS
foreign import canonicalDateImpl :: Fn4 (Year -> Int -> Day -> Date) Year Int Day Date
foreign import calcWeekday :: Fn3 Year Int Day Int
foreign import calcDiff :: Fn6 Year Int Day Year Int Day Milliseconds