mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
359 lines
8.2 KiB
Haskell
359 lines
8.2 KiB
Haskell
{-# 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
|