mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
163 lines
4.4 KiB
Haskell
163 lines
4.4 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE MonoLocalBinds #-}
|
|
module VisualRenderingTests (
|
|
renderTests
|
|
) where
|
|
import qualified Diagrams.Prelude as Dia
|
|
import qualified Data.Set as Set
|
|
|
|
import Rendering (renderDrawing)
|
|
import Types (Labeled(..), NodeName(..), Drawing(..), Edge, Icon(..), Port(..)
|
|
, SpecialQDiagram, SpecialBackend
|
|
, Named(..), NamedIcon)
|
|
|
|
import Util(iconToPort, tupleToNamed)
|
|
|
|
-- TODO Fix these tests such that they test nested icons correctly. Will need to
|
|
-- change the Drawing type.
|
|
|
|
iconToIntPort :: NodeName -> NodeName -> Int -> Edge
|
|
iconToIntPort x y p = iconToPort x y (Port p)
|
|
|
|
n0, n1, n2, n3, n4, n5, n6, n7, n8, n9, n10 :: NodeName
|
|
nodeNames :: [NodeName]
|
|
nodeNames@[n0, n1, n2, n3, n4, n5, n6, n7, n8, n9, n10]
|
|
= fmap NodeName [0..10]
|
|
|
|
ni0, ni1, ni2, ni3, ni4, ni5, ni6, ni7, ni8, ni9, ni10 :: Icon -> NamedIcon
|
|
[ni0, ni1, ni2, ni3, ni4, ni5, ni6, ni7, ni8, ni9, ni10]
|
|
= fmap Named nodeNames
|
|
|
|
textBoxIcons :: [NamedIcon]
|
|
textBoxIcons =
|
|
[ ni2 (TextBoxIcon "n2")
|
|
, ni4 (TextBoxIcon "n4")
|
|
, ni10 $ TextBoxIcon "n10"
|
|
, ni6 (TextBoxIcon "n6")
|
|
, ni7 (TextBoxIcon "n7")
|
|
, ni8 (TextBoxIcon "n8")
|
|
, ni9 (TextBoxIcon "n9")]
|
|
|
|
-- TODO refactor these Drawings
|
|
nestedCaseDrawing :: Drawing
|
|
nestedCaseDrawing = Drawing icons [] where
|
|
icons = textBoxIcons <> fmap tupleToNamed [
|
|
(n0, NestedCaseIcon [Nothing, Nothing, Nothing]),
|
|
(n1, NestedCaseIcon [Nothing, Just n2, Nothing]),
|
|
(n3, NestedCaseIcon [Nothing, Nothing, Just n4]),
|
|
(n5, NestedCaseIcon [Nothing,
|
|
Just n6,
|
|
Just n7,
|
|
Just n8,
|
|
Just n9])
|
|
]
|
|
|
|
nestedMultiIfDrawing :: Drawing
|
|
nestedMultiIfDrawing = Drawing icons edges where
|
|
icons = textBoxIcons <>
|
|
[ ni0 $ NestedMultiIfIcon [Nothing, Nothing, Nothing]
|
|
, ni1 $ NestedMultiIfIcon [Nothing, Just n2, Nothing]
|
|
, ni3 $ NestedMultiIfIcon [Nothing, Nothing, Just n4]
|
|
, ni5 $ NestedMultiIfIcon [Nothing,
|
|
Just n6,
|
|
Just n7,
|
|
Just n8,
|
|
Just n9]
|
|
]
|
|
edges = [
|
|
iconToIntPort n10 n5 0
|
|
]
|
|
|
|
flatCaseDrawing :: Drawing
|
|
flatCaseDrawing = Drawing icons edges where
|
|
icons = fmap tupleToNamed [
|
|
(NodeName 0, CaseIcon 0),
|
|
(NodeName 1, CaseIcon 1),
|
|
(NodeName 2, CaseIcon 2)
|
|
]
|
|
edges = []
|
|
|
|
flatMultiIfDrawing :: Drawing
|
|
flatMultiIfDrawing = Drawing icons edges where
|
|
icons = fmap tupleToNamed [
|
|
(NodeName 1, MultiIfIcon 1),
|
|
(NodeName 2, MultiIfIcon 2),
|
|
(NodeName 3, MultiIfIcon 3)
|
|
]
|
|
edges = []
|
|
|
|
nestedPAppDia :: Drawing
|
|
nestedPAppDia = Drawing icons []
|
|
where
|
|
icons = [
|
|
Named n0 (NestedPApp (Labeled Nothing "baz") [])
|
|
, Named
|
|
(NodeName 2)
|
|
(NestedPApp
|
|
(Labeled Nothing "")
|
|
[ Labeled (Just (Named (NodeName 1) (TextBoxIcon "foo"))) "bar"
|
|
, Labeled Nothing "bar"])
|
|
, Named
|
|
(NodeName 3)
|
|
(NestedPApp
|
|
(Labeled (Just (Named (NodeName 4) (TextBoxIcon "foo"))) "bar")
|
|
[Labeled Nothing "bar"])
|
|
]
|
|
|
|
-- TODO Uncomment
|
|
-- nestedApplyDia :: Drawing
|
|
-- nestedApplyDia = Drawing icons []
|
|
-- where
|
|
-- icons = [
|
|
-- Named
|
|
-- (NodeName 1)
|
|
-- (NestedApply
|
|
-- ApplyNodeFlavor
|
|
-- -- TODO Uncomment
|
|
-- -- (Just $ Named (NodeName 1) (TextBoxIcon "foo"))
|
|
-- (Just $ NodeName 2)
|
|
-- [])
|
|
-- ]
|
|
|
|
lambdaDia :: Drawing
|
|
lambdaDia = Drawing icons []
|
|
where
|
|
icons = [
|
|
ni0 $ LambdaIcon ["foo", "bar"] Nothing (Set.fromList [n0, n1])
|
|
, ni1 CaseResultIcon
|
|
, ni2 $ MultiIfIcon 3
|
|
]
|
|
|
|
-- TODO Uncomment
|
|
-- nestedLambdaDia :: Drawing
|
|
-- nestedLambdaDia = Drawing icons []
|
|
-- where
|
|
-- icons = [
|
|
-- ni0 $ LambdaIcon
|
|
-- ["baz", "cat"]
|
|
-- (Just $ Named n2 (TextBoxIcon "foobar"))
|
|
-- [n0, n1]
|
|
-- , ni1 CaseResultIcon
|
|
-- , ni2 $ MultiIfIcon 3
|
|
-- ]
|
|
|
|
|
|
--renderTests :: IO (Diagram B)
|
|
renderTests :: SpecialBackend b Double => IO (SpecialQDiagram b Double)
|
|
renderTests = do
|
|
renderedDiagrams <- traverse (renderDrawing "") allDrawings
|
|
let vCattedDrawings = Dia.vsep 0.5 renderedDiagrams
|
|
pure vCattedDrawings
|
|
where
|
|
-- TODO Re-enable tests
|
|
allDrawings = [
|
|
nestedCaseDrawing
|
|
, nestedMultiIfDrawing
|
|
, flatCaseDrawing
|
|
, flatMultiIfDrawing
|
|
, nestedPAppDia
|
|
-- , nestedApplyDia
|
|
, lambdaDia
|
|
-- , nestedLambdaDia
|
|
]
|