content: {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE MonoLocalBinds #-}
  module VisualTranslateTests(
    visualTranslateTests
    ) where
  
  import Diagrams.Prelude hiding ((#), (&))
  
  import qualified Data.Graph.Inductive.Graph as ING
  import Data.List(intercalate)
  import GHC.Stack(HasCallStack)
  
  import Types(SpecialQDiagram, SpecialBackend, NodeName(..))
  import Translate(translateStringToCollapsedGraphAndDecl
                  , translateStringToSyntaxGraph)
  import TranslateCore(syntaxGraphToFglGraph, SyntaxGraph(..))
  import Rendering(renderIngSyntaxGraph)
  import Icons(textBox, TransformParams(..))
  
  {-# ANN module "HLint: ignore Unnecessary hiding" #-}
  
  prettyShowList :: Show a => [a] -> String
  prettyShowList ls = intercalate "\n" $ fmap show ls
  
  prettyShowSyntaxGraph :: SyntaxGraph -> String
  prettyShowSyntaxGraph (SyntaxGraph nodes edges sinks sources _) =
    "SyntaxGraph nodes:\n" ++
    prettyShowList nodes ++
    "\nSyntaxGraph edges:\n" ++
    prettyShowList edges ++
    "\nSyntaxGRaph sinks:\n" ++
    prettyShowList sinks ++
    "\nSyntaxGraph sources:\n" ++
    prettyShowList sources
  
  composeTests :: [String]
  composeTests = [
    "y = f (g x)",
    "y = f . g",
    "y = f3 . f2 . f1",
    "y = f3 . f2 . f1 $ x",
    -- TODO The nesting depth could be reduced if the composition is applied to
    -- both f3 and f4 instead of just f3.
    "y = f1 $ f6 (f2 (f3 . f4)) (f5 x)"
    ]
  
  -- | nestedTests / collapseTest
  nestedTests :: [String]
  nestedTests = [
    "y = (\\x -> x) 0",
    "y = f (\\x -> x)",
    "y = f x",
    "y = let x = 1 in f (g x)",
    "y = f []",
    "y = f [1]",
    "y = f [1,2]",
    "y = f [g 3, h 5]",
    "y = f $ g (\\x -> x)",
    "y = f y",
    "y = f (g y)",
    "y = f1 (f2 ( f3 (f4 2))) 1", -- test compose embedded in apply
    "y = f0 $ f1 $ f2 z (f4 $ f5 q) $ x", -- compose embedded in compose
    "fibs = cons 1 (zipWith (+) fibs (tail fibs))",
    "y = foo (3 + bazOf2) bazOf2 where bazOf2 = baz 2",
    "y = foo (3 + bazOf2) (8 * bazOf2) where bazOf2 = baz 2",
    "Foo x = 1",
    "Foo 1 x = 2",
    "Foo (Bar x) = 1",
    "Foo (Bar (Baz x)) = 1",
    "Foo (Bar (Baz (Foot x))) = 1",
    "Foo (Bar x) (Baz y) = 1",
    "Foo (Bar x) = f 2",
    "Foo (Bar x) = f x",
    "y x = case x of {Just w -> (let (z,_) = w in z)}",
    "y = case x of 1 -> f 0",
    "y (Port x) = case x of 0 -> 1",
    "y (x@(Foo y)) = if 0 then x else 1"
    ]
  
  specialTests :: [String]
  specialTests = [
    "lookupTail EndAp1Arg = (arrowTail .~ dart')",
    "y = x .~ y",
    "initialIdState = IDState 0",
    "y = f x",
    "yyy = fff xxx",
    "yyyyy = fffff xxxxx"
    ]
  
  doTests :: [String]
  doTests = [
    "y = do {x1}",
    "y = do {x1; x2}",
    "y = do {x1; x2; x3}",
    "y = do {x1 <- m1; x2}",
    "y = do {(x1, x2) <- m1; x1 + x2}",
    "y = do {x1 <- m1; x2 <- f x1; g x2}",
    "y = do {let {x = 1}; x2 <- x; f x2}"
    ]
  
  tupleTests :: [String]
  tupleTests = [
    "y = ()",
    "y = (1,2)",
    "y = (1,2,3)",
    "y = (,x) 2",
    "y = (x,) 2",
    "y = (,,x) 2",
    "y = (,x,) 2",
    "y = (x,,) 2",
    "y = (x,z,) 2",
    "y = (x,,z) 2",
    "y = (,x,z) 2"
    ]
  
  listTests :: [String]
  listTests = [
    "y = []",
    "y = [1]",
    "y = [1,2]",
    "y = [1,2,3]"
    ]
  
  caseTests :: [String]
  caseTests = [
    "y = case x of {0 -> 1; 2 -> 3}",
    "y = case f x of {0 -> 1; 2 -> 3}",
    "y = case x of {Foo a -> a}",
    "y = case x of {Foo a -> f a; Bar a -> f a}",
    "y = case x of {F x -> x; G x -> x}",
    "y = case x of {F -> 0; G -> 1}",
    "z = case x of {0 -> 1; y -> y}",
    "y x = case f x of {0 -> x; Foo x -> x}"
    ]
  
  guardTests :: [String]
  guardTests = [
    "y x\n\
    \  | x == 0 = 1",
    "y x\n\
    \  | x == 0 = 1\n\
    \  | otherwise = 2"
    ]
  
  patternTests :: [String]
  patternTests = [
    "Foo 3 = 4",
  
    "Foo _ x = 3",
  
    "y (F x) = x",
  
    "y = let {g = 3; F x y = h g} in x y",
  
    "y = let {F x y = 3} in x y",
  
    "y = let F x y = g in x y",
  
    "F x = g x",
    "Foo (Bar x) (Baz y) = f 1 2 x y",
    "Foo x y = f 1 y x",
  
    "t@(Foo x) = 3",
  
    "(x, y) = 3",
    "(x, y, z) = 3",
  
    "[x] = 1",
    "[x, y] = 2",
    "[x, y, z] = 3",
    -- TODO: Add this test "(x:y) = 3"
  
    "y = let {t@(_,_) = (3,4)} in t + 3",
  
    -- TODO There is no bind text box for n2
    "n1@(n2@(x,y)) = f n1 n2 x y",
  
    "n0@(Foo n1@(Bar x) n2@(Baz y)) = f n0 n1 x n2 y",
    "baz = case 0 of {n0@(Foo n1@(Bar x) n2@(Baz y)) -> f n0 n1 x n2 y}",
    "func n0@(Foo n1@(Bar x) n2@(Baz y)) = f n0 n1 x n2 y",
  
    "y = let {(x, y) = (1,2)} in x + y",
    "y = let {(x, y) = (1,2); (z, w) = x; (m, g) = y} in foo x y z w m g",
    "(x:y) = 2",
  
    -- test labelled ports
    "Foo x1 x2 = 4"
    ]
  
  lambdaTests :: [String]
  lambdaTests = [
    "y = (\\x -> if True then 0 else 1) 3",
    "y = (\\x -> 99) x",
    "y = (\\x -> (\\x -> 2) x)",
    "y = (\\x -> (\\x -> f 2) x)",
    "y = (\\x -> (\\x -> x) x)",
    "y = (\\x -> (\\x -> (\\x -> x) x) x)",
    "y = (\\x -> (\\x -> (\\x -> x)))",
    "y = (\\y -> y)",
    "y = (\\x1 -> (\\x2 -> (\\x3 -> x1 x2 x3)))",
    "y x = (\\z -> x)",
    "y x = x",
    "y x = y x",
    "y x = g y y",
    "y f x = f x",
    "y x = x y",
    "y x1 x2 = f x1 x3 x2",
    "y x1 x2 = f x1 x2",
    "y x = f x1 x2",
    "y (-1) = 2",
    "y 1 = 0",
    "y x = z 3 where z = f x y",
    "y (Foo x) = x; y (Bar x) = 3"  -- test multiple matches
    ]
  
  letTests :: [String]
  letTests = [
    -- TODO fix. See UnitTests/letTests
    "y x = f x x",
    "y x1 = let x2 = f x1 in x2 x1",
  
    -- TODO fix. See UnitTests/letTests
    "y = g $ f y",
    "y = let {a = f b; b = g a} in b",
  
    "y = let {a= 1; x = let {a = 27; x = f a 2} in x} in x",
    "y = let {a = b; b = a; d = f a} in d",
    "y = let {a = b; b = a} in a",
    "y = let x = x in x"
    ]
  
  operatorTests :: [String]
  operatorTests = [
    -- right section
    "y = map (++ 1) 3",
    -- left section
    "y = (1 +) 2"
    ]
  
  otherTests :: [String]
  otherTests = [
    "y = f 1 'c' 2.3 \"foobar\"",
    "fact x = if (x == 0) then 1 else (x * fact (x - 1))",
    "fibs = cons 0 (cons 1 (zipWith (+) fibs (tail fibs)))",
    "y x = if x then (if z then q else x) else w",
    "y x1 x2 x3 = if f x1 then g x2 else h x3",
    "y x1 x2 x3 = if x1 then x2 else x3",
    "y = if b then x else n",
    "y2 = f x1 x2 x3 x4",
    "y = x",
    "y x = y x",
    "y = f 3 y",
    "y = f x",
    "y = f (g x1 x2) x3",
    "y = (f x1 x2) (g x1 x2)",
    "y = Foo.bar",
    "y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 = f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10",
    -- test that whitespace is preserved
    "y = \" foo  bar   baz    \""
    ]
  
  simpleTests :: [String]
  simpleTests = [
    "y = x"
    , "y = 1"
    , "f = \\x -> x"
    , "f x = x"
    , "f x = 1"
    , "y = \"foo\""
    , "y = f x"
    -- TODO Fix y = f . g
    , "y = f . g"
    , "y = f . g . h"
    , "y = f . g . h . i"
    , "y = (f . g) x"
    , "y = f (g x)"
    , "y = f $ g x"
    ]
  
  typeSigTests :: [String]
  typeSigTests = [
    "f :: a"
    , "f :: Int -> Bool"
    ]
  
  dataDeclTests :: [String]
  dataDeclTests = [
    "data Foo"
    , "data Foo = Foo Int"
    ]
  
  multiWayIfTests :: [String]
  multiWayIfTests = [
    "y = if | x == 0 -> 1"
    , "y = if\n\
    \  | x == 0 -> 1\n\
    \  | otherwise -> 2"
    , "y = if\n\
    \  | x == 0 -> if {| y > z -> 2; | pizza -> 3} \n\
    \  | otherwise -> 2"
    ]
  
  testDecls :: [String]
  testDecls = mconcat [
    simpleTests
    , composeTests
    , nestedTests
    , doTests
    , caseTests
    , lambdaTests
    , guardTests
    , patternTests
    , specialTests
    , tupleTests
    , listTests
    , letTests
    , operatorTests
    , otherTests
    , typeSigTests
    , dataDeclTests
    , multiWayIfTests
    ]
  
  
  translateStringToDrawing :: SpecialBackend b Double =>
    String
    -> IO (SpecialQDiagram b Double)
  translateStringToDrawing s = do
    putStrLn $ "Translating string: " ++ s
    let
      (collapsedGraph, decl) = translateStringToCollapsedGraphAndDecl s
      syntaxGraph = translateStringToSyntaxGraph s
      fglGraph = syntaxGraphToFglGraph syntaxGraph
    let
      printAction = do
        print decl
        putStr "\nSyntax Graph:\n"
        putStrLn $ prettyShowSyntaxGraph syntaxGraph
        putStr "\nFGL Graph:\n"
        ING.prettyPrint fglGraph
        putStr "\nCollapsed Graph:\n"
        ING.prettyPrint collapsedGraph
        putStr "\n\n"
    if False then printAction else pure ()  -- Supress unused printAction warning
    renderIngSyntaxGraph s collapsedGraph
  
  visualTranslateTests :: (HasCallStack, SpecialBackend b Double)
                       => IO (SpecialQDiagram b Double)
  visualTranslateTests = do
    drawings <- traverse translateStringToDrawing testDecls
    let
      textDrawings
        = fmap
          (\t ->
             alignL $ textBox t (TransformParams (NodeName (-1)) 0 False mempty))
          testDecls
      vCattedDrawings = vsep 1 $ zipWith (===) (fmap alignL drawings) textDrawings
    pure vCattedDrawings
  