mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Remove (&) and (#), add tests.
This commit is contained in:
parent
3d939f9644
commit
973674054e
@ -3,7 +3,7 @@ module DrawingColors (
|
|||||||
colorScheme
|
colorScheme
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Diagrams.Prelude
|
import Diagrams.Prelude hiding ((&), (#))
|
||||||
|
|
||||||
-- COLO(U)RS --
|
-- COLO(U)RS --
|
||||||
colorScheme :: ColorStyle Double
|
colorScheme :: ColorStyle Double
|
||||||
|
62
app/Icons.hs
62
app/Icons.hs
@ -19,7 +19,7 @@ module Icons
|
|||||||
nestedApplyDia
|
nestedApplyDia
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Diagrams.Prelude
|
import Diagrams.Prelude hiding ((&), (#))
|
||||||
-- import Diagrams.Backend.SVG(B)
|
-- import Diagrams.Backend.SVG(B)
|
||||||
import Diagrams.TwoD.Text(Text)
|
import Diagrams.TwoD.Text(Text)
|
||||||
import Data.Typeable(Typeable)
|
import Data.Typeable(Typeable)
|
||||||
@ -67,7 +67,7 @@ nameDiagram name dia = named name (name .>> dia)
|
|||||||
-- | Make an port with an integer name. Always use <> to add a ports (not === or |||)
|
-- | Make an port with an integer name. Always use <> to add a ports (not === or |||)
|
||||||
--- since mempty has no size and will not be placed where you want it.
|
--- since mempty has no size and will not be placed where you want it.
|
||||||
makePort :: Int -> SpecialQDiagram b
|
makePort :: Int -> SpecialQDiagram b
|
||||||
makePort x = mempty # named x
|
makePort x = named x mempty
|
||||||
--makePort x = circle 0.2 # fc green # named x
|
--makePort x = circle 0.2 # fc green # named x
|
||||||
-- Note, the version of makePort below seems to have a different type.
|
-- Note, the version of makePort below seems to have a different type.
|
||||||
--makePort x = textBox (show x) # fc green # named x
|
--makePort x = textBox (show x) # fc green # named x
|
||||||
@ -84,10 +84,10 @@ apply0Triangle ::
|
|||||||
(Typeable (N b), Transformable b, HasStyle b, TrailLike b,
|
(Typeable (N b), Transformable b, HasStyle b, TrailLike b,
|
||||||
V b ~ V2) =>
|
V b ~ V2) =>
|
||||||
b
|
b
|
||||||
apply0Triangle = eqTriangle (2 * circleRadius) # rotateBy (-1/12) # lw none
|
apply0Triangle = lw none $ rotateBy (-1/12) $ eqTriangle (2 * circleRadius)
|
||||||
|
|
||||||
portCircle :: (SpecialBackend b) => SpecialQDiagram b
|
portCircle :: (SpecialBackend b) => SpecialQDiagram b
|
||||||
portCircle = circle (circleRadius * 0.5) # fc lineCol # lw none
|
portCircle = lw none $ fc lineCol $ circle (circleRadius * 0.5)
|
||||||
|
|
||||||
-- applyA Icon--
|
-- applyA Icon--
|
||||||
-- | apply0N port locations:
|
-- | apply0N port locations:
|
||||||
@ -97,16 +97,15 @@ portCircle = circle (circleRadius * 0.5) # fc lineCol # lw none
|
|||||||
coloredApplyADia ::
|
coloredApplyADia ::
|
||||||
(SpecialBackend b) =>
|
(SpecialBackend b) =>
|
||||||
Colour Double -> Int -> SpecialQDiagram b
|
Colour Double -> Int -> SpecialQDiagram b
|
||||||
coloredApplyADia appColor n = finalDia # centerXY where
|
coloredApplyADia appColor n = centerXY finalDia where
|
||||||
seperation = circleRadius * 1.5
|
|
||||||
trianglePortsCircle = hcat [
|
trianglePortsCircle = hcat [
|
||||||
reflectX (fc appColor apply0Triangle),
|
reflectX (fc appColor apply0Triangle),
|
||||||
hcat $ take n $ map (\x -> makePort x <> portCircle <> strutX seperation) [2,3..],
|
hcat $ take n $ map (\x -> makePort x <> portCircle <> strutX (circleRadius * 1.5)) [2,3..],
|
||||||
makePort 1 <> alignR (circle circleRadius # fc appColor # lwG defaultLineWidth # lc appColor)
|
makePort 1 <> alignR (lc appColor $ lwG defaultLineWidth $ fc appColor $ circle circleRadius)
|
||||||
]
|
]
|
||||||
allPorts = makePort 0 <> alignL trianglePortsCircle
|
allPorts = makePort 0 <> alignL trianglePortsCircle
|
||||||
topAndBottomLineWidth = width allPorts - circleRadius
|
topAndBottomLineWidth = width allPorts - circleRadius
|
||||||
topAndBottomLine = hrule topAndBottomLineWidth # lc appColor # lwG defaultLineWidth # alignL
|
topAndBottomLine = alignL $ lwG defaultLineWidth $ lc appColor $ hrule topAndBottomLineWidth
|
||||||
finalDia = topAndBottomLine === allPorts === topAndBottomLine
|
finalDia = topAndBottomLine === allPorts === topAndBottomLine
|
||||||
|
|
||||||
applyADia :: SpecialBackend b => Int -> SpecialQDiagram b
|
applyADia :: SpecialBackend b => Int -> SpecialQDiagram b
|
||||||
@ -159,11 +158,11 @@ generalNestedDia textCol borderCol funText args reflect angle = centerXY $ tran
|
|||||||
trianglePortsCircle = hsep seperation $
|
trianglePortsCircle = hsep seperation $
|
||||||
reflectX (fc borderCol apply0Triangle) :
|
reflectX (fc borderCol apply0Triangle) :
|
||||||
zipWith makeInnerIcon [2,3..] args ++
|
zipWith makeInnerIcon [2,3..] args ++
|
||||||
[makePort 1 <> alignR (circle circleRadius # fc borderCol # lwG defaultLineWidth # lc borderCol)]
|
[makePort 1 <> alignR (lc borderCol $ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)]
|
||||||
|
|
||||||
allPorts = makePort 0 <> alignL trianglePortsCircle
|
allPorts = makePort 0 <> alignL trianglePortsCircle
|
||||||
topAndBottomLineWidth = width allPorts - circleRadius
|
topAndBottomLineWidth = width allPorts - circleRadius
|
||||||
argBox = rect topAndBottomLineWidth (height allPorts + verticalSeperation)# lc borderCol # lwG defaultLineWidth # alignL
|
argBox = alignL $ lwG defaultLineWidth $ lc borderCol $ rect topAndBottomLineWidth (height allPorts + verticalSeperation)
|
||||||
finalDia = argBox <> allPorts
|
finalDia = argBox <> allPorts
|
||||||
|
|
||||||
makeInnerIcon portNum Nothing = makePort portNum <> portCircle
|
makeInnerIcon portNum Nothing = makePort portNum <> portCircle
|
||||||
@ -192,8 +191,8 @@ coloredTextBox :: SpecialBackend b =>
|
|||||||
Colour Double
|
Colour Double
|
||||||
-> AlphaColour Double -> String -> SpecialQDiagram b
|
-> AlphaColour Double -> String -> SpecialQDiagram b
|
||||||
coloredTextBox textColor boxColor t =
|
coloredTextBox textColor boxColor t =
|
||||||
text t # fc textColor # font "freemono" # bold # fontSize (local textBoxFontSize)
|
fontSize (local textBoxFontSize) (bold $ font "freemono" $ fc textColor $ text t)
|
||||||
<> rect rectangleWidth (textBoxFontSize * textBoxHeightFactor) # lcA boxColor # lwG (0.6 * defaultLineWidth)
|
<> lwG (0.6 * defaultLineWidth) (lcA boxColor $ rect rectangleWidth (textBoxFontSize * textBoxHeightFactor))
|
||||||
where
|
where
|
||||||
rectangleWidth = textBoxFontSize * monoLetterWidthToHeightFraction
|
rectangleWidth = textBoxFontSize * monoLetterWidthToHeightFraction
|
||||||
* fromIntegral (length t)
|
* fromIntegral (length t)
|
||||||
@ -202,7 +201,7 @@ coloredTextBox textColor boxColor t =
|
|||||||
-- ENCLOSING REGION --
|
-- ENCLOSING REGION --
|
||||||
enclosure :: SpecialBackend b =>
|
enclosure :: SpecialBackend b =>
|
||||||
SpecialQDiagram b -> SpecialQDiagram b
|
SpecialQDiagram b -> SpecialQDiagram b
|
||||||
enclosure dia = dia <> boundingRect (dia # frame 0.5) # lc (regionPerimC colorScheme) # lwG defaultLineWidth
|
enclosure dia = dia <> lwG defaultLineWidth (lc (regionPerimC colorScheme) $ boundingRect (frame 0.5 dia))
|
||||||
|
|
||||||
-- LAMBDA ICON --
|
-- LAMBDA ICON --
|
||||||
-- Don't use === here to put the port under the text box since mempty will stay
|
-- Don't use === here to put the port under the text box since mempty will stay
|
||||||
@ -210,7 +209,7 @@ enclosure dia = dia <> boundingRect (dia # frame 0.5) # lc (regionPerimC colorSc
|
|||||||
lambdaIcon ::
|
lambdaIcon ::
|
||||||
SpecialBackend b =>
|
SpecialBackend b =>
|
||||||
Int -> SpecialQDiagram b
|
Int -> SpecialQDiagram b
|
||||||
lambdaIcon x = coloredTextBox (lamArgResC colorScheme) transparent "λ" # alignB <> makePort x
|
lambdaIcon x = alignB (coloredTextBox (lamArgResC colorScheme) transparent "λ") <> makePort x
|
||||||
|
|
||||||
-- LAMBDA REGION --
|
-- LAMBDA REGION --
|
||||||
|
|
||||||
@ -219,16 +218,16 @@ lambdaIcon x = coloredTextBox (lamArgResC colorScheme) transparent "λ" # alignB
|
|||||||
lambdaRegion :: SpecialBackend b =>
|
lambdaRegion :: SpecialBackend b =>
|
||||||
Int -> SpecialQDiagram b -> SpecialQDiagram b
|
Int -> SpecialQDiagram b -> SpecialQDiagram b
|
||||||
lambdaRegion n dia =
|
lambdaRegion n dia =
|
||||||
centerXY $ lambdaIcons # centerX === (enclosure dia # centerX)
|
centerXY $ centerX lambdaIcons === centerX (enclosure dia)
|
||||||
where lambdaIcons = hsep 0.4 (take n (map lambdaIcon [0,1..]))
|
where lambdaIcons = hsep 0.4 (take n (map lambdaIcon [0,1..]))
|
||||||
|
|
||||||
-- RESULT ICON --
|
-- RESULT ICON --
|
||||||
resultIcon :: SpecialBackend b => SpecialQDiagram b
|
resultIcon :: SpecialBackend b => SpecialQDiagram b
|
||||||
resultIcon = unitSquare # lw none # fc (lamArgResC colorScheme)
|
resultIcon = lw none $ fc (lamArgResC colorScheme) unitSquare
|
||||||
|
|
||||||
-- BRANCH ICON --
|
-- BRANCH ICON --
|
||||||
branchIcon :: SpecialBackend b => SpecialQDiagram b
|
branchIcon :: SpecialBackend b => SpecialQDiagram b
|
||||||
branchIcon = circle circleRadius # fc lineCol # lc lineCol # lw none
|
branchIcon = lw none $ lc lineCol $ fc lineCol $ circle circleRadius
|
||||||
|
|
||||||
-- GUARD ICON --
|
-- GUARD ICON --
|
||||||
guardSize :: (Fractional a) => a
|
guardSize :: (Fractional a) => a
|
||||||
@ -237,17 +236,17 @@ guardSize = 0.7
|
|||||||
guardTriangle :: SpecialBackend b =>
|
guardTriangle :: SpecialBackend b =>
|
||||||
Int -> SpecialQDiagram b
|
Int -> SpecialQDiagram b
|
||||||
guardTriangle x =
|
guardTriangle x =
|
||||||
((triangleAndPort ||| (hrule (guardSize * 0.8) # lwG defaultLineWidth)) # alignR) <> makePort x # alignL
|
alignL $ alignR (triangleAndPort ||| lwG defaultLineWidth (hrule (guardSize * 0.8))) <> makePort x
|
||||||
where
|
where
|
||||||
triangleAndPort = polygon (with & polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize])
|
triangleAndPort = alignR $ alignT $ lwG defaultLineWidth $ rotateBy (1/8) $
|
||||||
# rotateBy (1/8) # lwG defaultLineWidth # alignT # alignR
|
polygon (polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize] $ with)
|
||||||
|
|
||||||
guardLBracket :: SpecialBackend b =>
|
guardLBracket :: SpecialBackend b =>
|
||||||
Int -> SpecialQDiagram b
|
Int -> SpecialQDiagram b
|
||||||
guardLBracket x = ell # alignT # alignL <> makePort x
|
guardLBracket x = alignL (alignT ell) <> makePort x
|
||||||
where
|
where
|
||||||
ellShape = fromOffsets $ map r2 [(0, guardSize), (-guardSize,0)]
|
ellShape = fromOffsets $ map r2 [(0, guardSize), (-guardSize,0)]
|
||||||
ell = ellShape # strokeLine # lc (boolC colorScheme) # lwG defaultLineWidth # lineJoin LineJoinRound
|
ell = lineJoin LineJoinRound $ lwG defaultLineWidth $ lc (boolC colorScheme) (strokeLine ellShape)
|
||||||
|
|
||||||
generalGuardIcon :: SpecialBackend b =>
|
generalGuardIcon :: SpecialBackend b =>
|
||||||
Colour Double -> (Int -> SpecialQDiagram b) -> SpecialQDiagram b -> Int -> SpecialQDiagram b
|
Colour Double -> (Int -> SpecialQDiagram b) -> SpecialQDiagram b -> Int -> SpecialQDiagram b
|
||||||
@ -258,11 +257,11 @@ generalGuardIcon triangleColor lBracket bottomDia n = centerXY $ alignT (bottomD
|
|||||||
lBrackets = map lBracket [3, 5..]
|
lBrackets = map lBracket [3, 5..]
|
||||||
trianglesAndBrackets =
|
trianglesAndBrackets =
|
||||||
zipWith zipper trianglesWithPorts lBrackets
|
zipWith zipper trianglesWithPorts lBrackets
|
||||||
zipper thisTriangle lBrack = verticalLine === ((lBrack # extrudeRight guardSize) # alignR <> (thisTriangle # alignL # lc triangleColor))
|
zipper thisTriangle lBrack = verticalLine === (alignR (extrudeRight guardSize lBrack) <> lc triangleColor (alignL thisTriangle))
|
||||||
where
|
where
|
||||||
verticalLine = strutY 0.4
|
verticalLine = strutY 0.4
|
||||||
guardDia = vcat (take n trianglesAndBrackets # alignT)
|
guardDia = vcat (alignT $ take n trianglesAndBrackets)
|
||||||
bigVerticalLine = vrule (height guardDia) # lc triangleColor # lwG defaultLineWidth # alignT
|
bigVerticalLine = alignT $ lwG defaultLineWidth $ lc triangleColor $ vrule (height guardDia)
|
||||||
|
|
||||||
-- | The ports of the guard icon are as follows:
|
-- | The ports of the guard icon are as follows:
|
||||||
-- Port 0: Top result port
|
-- Port 0: Top result port
|
||||||
@ -276,8 +275,9 @@ guardIcon = generalGuardIcon lineCol guardLBracket mempty
|
|||||||
-- TODO Improve design to be more than a circle.
|
-- TODO Improve design to be more than a circle.
|
||||||
caseResult :: SpecialBackend b =>
|
caseResult :: SpecialBackend b =>
|
||||||
SpecialQDiagram b
|
SpecialQDiagram b
|
||||||
caseResult = circle (circleRadius * 0.7) # fc caseCColor # lc caseCColor # lw none where
|
caseResult = lw none $ lc caseCColor $ fc caseCColor $ circle (circleRadius * 0.7)
|
||||||
caseCColor = caseRhsC colorScheme
|
where
|
||||||
|
caseCColor = caseRhsC colorScheme
|
||||||
|
|
||||||
caseC :: SpecialBackend b =>
|
caseC :: SpecialBackend b =>
|
||||||
Int -> SpecialQDiagram b
|
Int -> SpecialQDiagram b
|
||||||
@ -299,10 +299,10 @@ caseIcon = generalGuardIcon (patternC colorScheme) caseC caseResult
|
|||||||
-- 2,3.. : The parameters
|
-- 2,3.. : The parameters
|
||||||
flatLambda :: SpecialBackend b => Int -> SpecialQDiagram b
|
flatLambda :: SpecialBackend b => Int -> SpecialQDiagram b
|
||||||
flatLambda n = finalDia where
|
flatLambda n = finalDia where
|
||||||
lambdaCircle = circle circleRadius # fc (regionPerimC colorScheme) # lc (regionPerimC colorScheme) # lwG defaultLineWidth
|
lambdaCircle = lwG defaultLineWidth $ lc (regionPerimC colorScheme) $ fc (regionPerimC colorScheme) $ circle circleRadius
|
||||||
lambdaParts = (makePort 0 <> resultIcon) : (portIcons ++ [makePort 1 <> alignR lambdaCircle])
|
lambdaParts = (makePort 0 <> resultIcon) : (portIcons ++ [makePort 1 <> alignR lambdaCircle])
|
||||||
portIcons = take n $ map (\x -> makePort x <> portCircle) [2,3..]
|
portIcons = take n $ map (\x -> makePort x <> portCircle) [2,3..]
|
||||||
middle = alignL (hsep 0.5 lambdaParts)
|
middle = alignL (hsep 0.5 lambdaParts)
|
||||||
topAndBottomLineWidth = width middle - circleRadius
|
topAndBottomLineWidth = width middle - circleRadius
|
||||||
topAndBottomLine = hrule topAndBottomLineWidth # lc (regionPerimC colorScheme) # lwG defaultLineWidth # alignL
|
topAndBottomLine = alignL $ lwG defaultLineWidth $ lc (regionPerimC colorScheme) $ hrule topAndBottomLineWidth
|
||||||
finalDia = topAndBottomLine <> alignB (topAndBottomLine <> (middle # alignT))
|
finalDia = topAndBottomLine <> alignB (topAndBottomLine <> alignT middle)
|
||||||
|
110
app/Main.hs
110
app/Main.hs
@ -1,7 +1,9 @@
|
|||||||
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies #-}
|
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies #-}
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Diagrams.Prelude
|
-- Note: (#) and (&) are hidden in all Glance source files, since they would require
|
||||||
|
-- - an special case when translating when Glance is run on its own source code.
|
||||||
|
import Diagrams.Prelude hiding ((#), (&))
|
||||||
import Diagrams.Backend.SVG.CmdLine
|
import Diagrams.Backend.SVG.CmdLine
|
||||||
import qualified Language.Haskell.Exts as Exts
|
import qualified Language.Haskell.Exts as Exts
|
||||||
|
|
||||||
@ -14,6 +16,11 @@ import Translate(translateString, drawingsFromModule)
|
|||||||
|
|
||||||
|
|
||||||
-- TODO Now --
|
-- TODO Now --
|
||||||
|
-- Fix icon nesting if a non-nestable icon (eg. flatLambdaIcon) is part of the expression.
|
||||||
|
-- - eg. y = f $ g (\x -> x)
|
||||||
|
-- Fix rotation missing edges to nested diagrams.
|
||||||
|
|
||||||
|
-- Add a maximum nesting depth.
|
||||||
-- Clean up Rendering and Icons.
|
-- Clean up Rendering and Icons.
|
||||||
|
|
||||||
-- Refactor Translate
|
-- Refactor Translate
|
||||||
@ -23,7 +30,10 @@ import Translate(translateString, drawingsFromModule)
|
|||||||
-- Move tests out of main.
|
-- Move tests out of main.
|
||||||
|
|
||||||
-- TODO Later --
|
-- TODO Later --
|
||||||
|
-- Why is totalLengthOfLines not nesting?
|
||||||
|
|
||||||
-- Visual todos:
|
-- Visual todos:
|
||||||
|
-- Don't rotate text and nested icons, give them rectangualar bounding boxes in GraphViz. (Perhaps use a typeclass for isRotateAble)
|
||||||
-- Give lines a black border to make line crossings easier to see.
|
-- Give lines a black border to make line crossings easier to see.
|
||||||
-- Give lines that cross the border of a lambda function a special color.
|
-- Give lines that cross the border of a lambda function a special color.
|
||||||
-- Line intersections should have a small circle. This could probably be done with
|
-- Line intersections should have a small circle. This could probably be done with
|
||||||
@ -33,17 +43,17 @@ import Translate(translateString, drawingsFromModule)
|
|||||||
-- Rotate icons based on the outgoing line's difference from ideal angle, not line distance.
|
-- Rotate icons based on the outgoing line's difference from ideal angle, not line distance.
|
||||||
-- Improve line routing. Draw curved lines with outgoing lines at fixed angles.
|
-- Improve line routing. Draw curved lines with outgoing lines at fixed angles.
|
||||||
-- - connectPerim might be useful for this.
|
-- - connectPerim might be useful for this.
|
||||||
|
-- For nested apply, cycle through different colors and line styles (eg. dashed, solid, wavy)
|
||||||
|
-- - for each nesting level. This will help distinguish what is an argument to which funciton.
|
||||||
|
|
||||||
-- Translate todos:
|
-- Translate todos:
|
||||||
|
-- Make nested version of FlatLambdaIcon
|
||||||
-- Fix test case x of {0 -> 1; y -> y}.
|
-- Fix test case x of {0 -> 1; y -> y}.
|
||||||
-- Add proper RecConstr, and RecUpdate support.
|
-- Add proper RecConstr, and RecUpdate support.
|
||||||
-- Eliminate BranchIcon in Alts.
|
-- Eliminate BranchIcon in Alts.
|
||||||
-- Eliminate BranchIcon for the identity funciton "y x = x"
|
-- Eliminate BranchIcon for the identity funciton "y x = x"
|
||||||
-- otherwise Guard special case
|
-- otherwise Guard special case
|
||||||
|
|
||||||
--Other todos:
|
|
||||||
-- Use a nested tree layout. A graph can take an optional (name, Icon) instead of a port.
|
|
||||||
|
|
||||||
(d0A, d0B, d0Res, d0Foo, d0Bar) = ("A", "B", "res", "foo", "bar")
|
(d0A, d0B, d0Res, d0Foo, d0Bar) = ("A", "B", "res", "foo", "bar")
|
||||||
d0Icons = toNames
|
d0Icons = toNames
|
||||||
[(d0A, ApplyAIcon 1),
|
[(d0A, ApplyAIcon 1),
|
||||||
@ -252,12 +262,33 @@ arrowTestEdges = [
|
|||||||
|
|
||||||
arrowTestDrawing = Drawing arrowTestIcons arrowTestEdges []
|
arrowTestDrawing = Drawing arrowTestIcons arrowTestEdges []
|
||||||
|
|
||||||
|
nestedTestIcons = toNames [
|
||||||
|
("n1", NestedApply "N1" args),
|
||||||
|
("t1", TextBoxIcon "T1"),
|
||||||
|
("t2", TextBoxIcon "t2")
|
||||||
|
]
|
||||||
|
where
|
||||||
|
innerArgs = [Just (toName "t", TextBoxIcon "t"), Nothing, Just (toName "n2", NestedApply "n2" [Nothing])]
|
||||||
|
args = [
|
||||||
|
Nothing, Just (toName "foo", TextBoxIcon "3"),
|
||||||
|
Just (toName "in", NestedApply "inner" innerArgs)
|
||||||
|
]
|
||||||
|
|
||||||
|
nestedTestEdges = [
|
||||||
|
iconToPort "t1" "n1" 2,
|
||||||
|
--iconToPort "t1" "in" 1,
|
||||||
|
--iconToPort "t2" ("n1" .> "in") 3,
|
||||||
|
iconToPort "t2" ("n1" .> "in" .> "n2") 2
|
||||||
|
]
|
||||||
|
|
||||||
|
nestedTextDrawing = Drawing nestedTestIcons nestedTestEdges []
|
||||||
|
|
||||||
main1 :: IO ()
|
main1 :: IO ()
|
||||||
main1 = do
|
main1 = do
|
||||||
placedNodes <- renderDrawing factLam0Drawing
|
placedNodes <- renderDrawing nestedTextDrawing
|
||||||
mainWith ((placedNodes # bgFrame 1 (backgroundC colorScheme)) :: Diagram B)
|
mainWith (bgFrame 1 (backgroundC colorScheme) placedNodes :: Diagram B)
|
||||||
|
|
||||||
main2 = mainWith ((dia False 0 # bgFrame 0.1 black) :: Diagram B)
|
main2 = mainWith ((bgFrame 0.1 black $ dia False 0) :: Diagram B)
|
||||||
where
|
where
|
||||||
args = [Nothing, Just (toName "foo", TextBoxIcon "3"), Just (toName "in", NestedApply "inner" [Just (toName "t", TextBoxIcon "t")])]
|
args = [Nothing, Just (toName "foo", TextBoxIcon "3"), Just (toName "in", NestedApply "inner" [Just (toName "t", TextBoxIcon "t")])]
|
||||||
dia = nestedApplyDia "Hello world" args
|
dia = nestedApplyDia "Hello world" args
|
||||||
@ -265,8 +296,8 @@ main2 = mainWith ((dia False 0 # bgFrame 0.1 black) :: Diagram B)
|
|||||||
main3 :: IO ()
|
main3 :: IO ()
|
||||||
main3 = do
|
main3 = do
|
||||||
renderedDiagrams <- traverse renderDrawing allDrawings
|
renderedDiagrams <- traverse renderDrawing allDrawings
|
||||||
let vCattedDrawings = vcat' (with & sep .~ 0.5) renderedDiagrams
|
let vCattedDrawings = vsep 0.5 renderedDiagrams
|
||||||
mainWith ((vCattedDrawings # bgFrame 1 (backgroundC colorScheme)) :: Diagram B)
|
mainWith (bgFrame 1 (backgroundC colorScheme) vCattedDrawings :: Diagram B)
|
||||||
where
|
where
|
||||||
allDrawings = [
|
allDrawings = [
|
||||||
drawing0,
|
drawing0,
|
||||||
@ -281,8 +312,24 @@ main3 = do
|
|||||||
factLam2Drawing,
|
factLam2Drawing,
|
||||||
arrowTestDrawing
|
arrowTestDrawing
|
||||||
]
|
]
|
||||||
|
|
||||||
|
nestedTests = [
|
||||||
|
"y = f x",
|
||||||
|
"y = f (g x)",
|
||||||
|
"y = let x = 1 in 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]"
|
||||||
|
]
|
||||||
|
|
||||||
|
dollarTests = [
|
||||||
|
"y = f $ g 3",
|
||||||
|
" y = f 1 $ g 2 "
|
||||||
|
]
|
||||||
|
|
||||||
specialTests = [
|
specialTests = [
|
||||||
"y = f x $ g y",
|
|
||||||
"lookupTail EndAp1Arg = (arrowTail .~ dart')",
|
"lookupTail EndAp1Arg = (arrowTail .~ dart')",
|
||||||
"y = x .~ y",
|
"y = x .~ y",
|
||||||
"initialIdState = IDState 0",
|
"initialIdState = IDState 0",
|
||||||
@ -440,19 +487,21 @@ otherTests = [
|
|||||||
]
|
]
|
||||||
|
|
||||||
testDecls = mconcat [
|
testDecls = mconcat [
|
||||||
negateTests
|
--dollarTests
|
||||||
,doTests
|
nestedTests
|
||||||
,enumTests
|
-- ,negateTests
|
||||||
,caseTests
|
-- ,doTests
|
||||||
,lambdaTests
|
-- ,enumTests
|
||||||
,guardTests
|
-- ,caseTests
|
||||||
,patternTests
|
-- ,lambdaTests
|
||||||
,specialTests
|
-- ,guardTests
|
||||||
,tupleTests
|
-- ,patternTests
|
||||||
,listTests
|
-- ,specialTests
|
||||||
,letTests
|
-- ,tupleTests
|
||||||
,operatorTests
|
-- ,listTests
|
||||||
,otherTests
|
-- ,letTests
|
||||||
|
-- ,operatorTests
|
||||||
|
-- ,otherTests
|
||||||
]
|
]
|
||||||
|
|
||||||
translateStringToDrawing :: String -> IO (Diagram B)
|
translateStringToDrawing :: String -> IO (Diagram B)
|
||||||
@ -469,9 +518,9 @@ main4 :: IO ()
|
|||||||
main4 = do
|
main4 = do
|
||||||
drawings <- traverse translateStringToDrawing testDecls
|
drawings <- traverse translateStringToDrawing testDecls
|
||||||
let
|
let
|
||||||
textDrawings = fmap (alignL . textBox) testDecls
|
textDrawings = fmap (\t -> alignL $ textBox t False 0) testDecls
|
||||||
vCattedDrawings = vcat' (with & sep .~ 1) $ zipWith (===) (fmap alignL drawings) textDrawings
|
vCattedDrawings = vsep 1 $ zipWith (===) (fmap alignL drawings) textDrawings
|
||||||
mainWith ((vCattedDrawings # bgFrame 1 (backgroundC colorScheme)) :: Diagram B)
|
mainWith (bgFrame 1 (backgroundC colorScheme) vCattedDrawings :: Diagram B)
|
||||||
|
|
||||||
testFiles = [
|
testFiles = [
|
||||||
"./app/Main.hs",
|
"./app/Main.hs",
|
||||||
@ -481,7 +530,8 @@ testFiles = [
|
|||||||
main5 :: IO ()
|
main5 :: IO ()
|
||||||
main5 = do
|
main5 = do
|
||||||
parseResult <- Exts.parseFileWithExts [Exts.EnableExtension Exts.MultiParamTypeClasses, Exts.EnableExtension Exts.FlexibleContexts]
|
parseResult <- Exts.parseFileWithExts [Exts.EnableExtension Exts.MultiParamTypeClasses, Exts.EnableExtension Exts.FlexibleContexts]
|
||||||
"./test/test_translate.hs"
|
--"./app/Icons.hs"
|
||||||
|
"./test/test_nesting.hs"
|
||||||
let
|
let
|
||||||
parsedModule = Exts.fromParseResult parseResult
|
parsedModule = Exts.fromParseResult parseResult
|
||||||
drawings = drawingsFromModule parsedModule
|
drawings = drawingsFromModule parsedModule
|
||||||
@ -491,9 +541,9 @@ main5 = do
|
|||||||
|
|
||||||
diagrams <- traverse renderDrawing drawings
|
diagrams <- traverse renderDrawing drawings
|
||||||
let
|
let
|
||||||
vCattedDrawings = vcat' (with & sep .~ 1) $ fmap alignL diagrams
|
vCattedDrawings = vsep 1 $ fmap alignL diagrams
|
||||||
mainWith ((vCattedDrawings # bgFrame 1 (backgroundC colorScheme)) :: Diagram B)
|
mainWith (bgFrame 1 (backgroundC colorScheme) vCattedDrawings :: Diagram B)
|
||||||
|
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = main2
|
main = main5
|
||||||
|
@ -4,7 +4,7 @@ module Rendering (
|
|||||||
renderDrawing
|
renderDrawing
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Diagrams.Prelude
|
import Diagrams.Prelude hiding ((#), (&))
|
||||||
import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph')
|
import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph')
|
||||||
import Diagrams.Core.Names(Name(..))
|
import Diagrams.Core.Names(Name(..))
|
||||||
--import Diagrams.Backend.SVG(B)
|
--import Diagrams.Backend.SVG(B)
|
||||||
@ -74,11 +74,11 @@ edgesToGraph iconNames edges = mkGraph iconNames simpleEdges
|
|||||||
-- | Custom arrow tail for the arg1 result circle.
|
-- | Custom arrow tail for the arg1 result circle.
|
||||||
-- The ArrowHT type does not seem to be documented.
|
-- The ArrowHT type does not seem to be documented.
|
||||||
arg1ResT :: (RealFloat n) => ArrowHT n
|
arg1ResT :: (RealFloat n) => ArrowHT n
|
||||||
arg1ResT len _ = (circle (len / 2) # alignR, mempty)
|
arg1ResT len _ = (alignR $ circle (len / 2), mempty)
|
||||||
|
|
||||||
-- | Arrow head version of arg1ResT
|
-- | Arrow head version of arg1ResT
|
||||||
arg1ResH :: (RealFloat n) => ArrowHT n
|
arg1ResH :: (RealFloat n) => ArrowHT n
|
||||||
arg1ResH len _ = (circle (len / 2) # alignL, mempty)
|
arg1ResH len _ = (alignL $ circle (len / 2), mempty)
|
||||||
|
|
||||||
getArrowOpts :: (RealFloat n, Typeable n) => (EdgeEnd, EdgeEnd) -> [EdgeOption]-> ArrowOpts n
|
getArrowOpts :: (RealFloat n, Typeable n) => (EdgeEnd, EdgeEnd) -> [EdgeOption]-> ArrowOpts n
|
||||||
getArrowOpts (t, h) opts = arrowOptions
|
getArrowOpts (t, h) opts = arrowOptions
|
||||||
@ -99,12 +99,11 @@ getArrowOpts (t, h) opts = arrowOptions
|
|||||||
lookupHead EndAp1Result = (arrowHead .~ arg1ResH) . (headTexture .~ ap1ResultTexture)
|
lookupHead EndAp1Result = (arrowHead .~ arg1ResH) . (headTexture .~ ap1ResultTexture)
|
||||||
|
|
||||||
arrowOptions =
|
arrowOptions =
|
||||||
with & arrowHead .~ noHead
|
arrowHead .~ noHead $
|
||||||
& arrowTail .~ noTail
|
arrowTail .~ noTail $
|
||||||
& lengths .~ global 0.75
|
lengths .~ global 0.75 $
|
||||||
-- this parenthesis "%~ (lwG .. colorScheme))" is necessary for haskell-src-exts to parse the file.
|
shaftStyle %~ (lwG defaultLineWidth . lc (shaftColor colorScheme)) $
|
||||||
& shaftStyle %~ (lwG defaultLineWidth . lc (shaftColor colorScheme))
|
lookupHead h $ lookupTail t with
|
||||||
& lookupTail t & lookupHead h
|
|
||||||
|
|
||||||
-- | Given an Edge, return a transformation on Diagrams that will draw a line.
|
-- | Given an Edge, return a transformation on Diagrams that will draw a line.
|
||||||
connectMaybePorts :: SpecialBackend b =>
|
connectMaybePorts :: SpecialBackend b =>
|
||||||
@ -231,7 +230,7 @@ placeNodes layoutResult nameDiagramMap edges = mconcat placedNodes
|
|||||||
placedNodes = map placeNode rotatedNameDiagramMap
|
placedNodes = map placeNode rotatedNameDiagramMap
|
||||||
--placedNodes = map placeNode nameDiagramMap
|
--placedNodes = map placeNode nameDiagramMap
|
||||||
-- todo: Not sure if the diagrams should already be centered at this point.
|
-- todo: Not sure if the diagrams should already be centered at this point.
|
||||||
placeNode (name, diagram) = place (diagram # centerXY) (scaleFactor *^ (positionMap Map.! name))
|
placeNode (name, diagram) = place (centerXY diagram) (scaleFactor *^ (positionMap Map.! name))
|
||||||
|
|
||||||
doGraphLayout :: SpecialBackend b =>
|
doGraphLayout :: SpecialBackend b =>
|
||||||
Gr Name e
|
Gr Name e
|
||||||
@ -253,9 +252,10 @@ doGraphLayout graph nameDiagramMap edges = do
|
|||||||
[
|
[
|
||||||
--GVA.Overlap GVA.KeepOverlaps,
|
--GVA.Overlap GVA.KeepOverlaps,
|
||||||
--GVA.Overlap GVA.ScaleOverlaps,
|
--GVA.Overlap GVA.ScaleOverlaps,
|
||||||
GVA.Overlap $ GVA.PrismOverlap (Just 1000),
|
GVA.Overlap $ GVA.PrismOverlap (Just 5000),
|
||||||
GVA.Splines GVA.LineEdges,
|
GVA.Splines GVA.LineEdges,
|
||||||
GVA.OverlapScaling 4,
|
GVA.OverlapScaling 8,
|
||||||
|
--GVA.OverlapScaling 4,
|
||||||
GVA.OverlapShrink True
|
GVA.OverlapShrink True
|
||||||
]
|
]
|
||||||
],
|
],
|
||||||
|
@ -5,7 +5,7 @@ module Translate(
|
|||||||
drawingsFromModule
|
drawingsFromModule
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import qualified Diagrams.Prelude as DIA
|
import qualified Diagrams.Prelude as DIA hiding ((#), (&))
|
||||||
import Diagrams.Prelude((<>))
|
import Diagrams.Prelude((<>))
|
||||||
|
|
||||||
import Language.Haskell.Exts(Decl(..), parseDecl, Name(..), Pat(..), Rhs(..),
|
import Language.Haskell.Exts(Decl(..), parseDecl, Name(..), Pat(..), Rhs(..),
|
||||||
@ -59,7 +59,6 @@ evalPApp name patterns = do
|
|||||||
gr = makeTextApplyGraph True patName constructorName evaledPatterns (length evaledPatterns)
|
gr = makeTextApplyGraph True patName constructorName evaledPatterns (length evaledPatterns)
|
||||||
pure gr
|
pure gr
|
||||||
|
|
||||||
|
|
||||||
evalPLit :: Exts.Sign -> Exts.Literal -> State IDState (IconGraph, NameAndPort)
|
evalPLit :: Exts.Sign -> Exts.Literal -> State IDState (IconGraph, NameAndPort)
|
||||||
evalPLit Exts.Signless l = evalLit l
|
evalPLit Exts.Signless l = evalLit l
|
||||||
evalPLit Exts.Negative l = makeBox ('-' : showLiteral l)
|
evalPLit Exts.Negative l = makeBox ('-' : showLiteral l)
|
||||||
@ -120,7 +119,7 @@ makeTextApplyGraph inPattern applyIconName funStr argVals numArgs = result
|
|||||||
argumentPorts = map (nameAndPort applyIconName) [2,3..]
|
argumentPorts = map (nameAndPort applyIconName) [2,3..]
|
||||||
(unnestedArgsAndPort, nestedArgs, nestedSinks, nestedBindings) = unzip4 $ map decideIfNested (zip argVals argumentPorts)
|
(unnestedArgsAndPort, nestedArgs, nestedSinks, nestedBindings) = unzip4 $ map decideIfNested (zip argVals argumentPorts)
|
||||||
qualifiedSinks = map qualifySink (mconcat nestedSinks)
|
qualifiedSinks = map qualifySink (mconcat nestedSinks)
|
||||||
qualifySink (str, (NameAndPort n p)) = (str, NameAndPort (applyIconName DIA..> n) p)
|
qualifySink (str, NameAndPort n p) = (str, NameAndPort (applyIconName DIA..> n) p)
|
||||||
|
|
||||||
qualifiedBinds = map qualifyBinds (mconcat nestedBindings)
|
qualifiedBinds = map qualifyBinds (mconcat nestedBindings)
|
||||||
qualifyBinds (str, ref) = (str, qualifiedRef) where
|
qualifyBinds (str, ref) = (str, qualifiedRef) where
|
||||||
@ -533,8 +532,7 @@ drawingFromDecl d = iconGraphToDrawing $ evalState evaluatedDecl initialIdState
|
|||||||
-- Profiling: about 1.5% of total time.
|
-- Profiling: about 1.5% of total time.
|
||||||
translateString :: String -> (Drawing, Decl)
|
translateString :: String -> (Drawing, Decl)
|
||||||
translateString s = (drawing, decl) where
|
translateString s = (drawing, decl) where
|
||||||
parseResult = parseDecl s -- :: ParseResult Module
|
decl = fromParseResult (parseDecl s) -- :: ParseResult Module
|
||||||
decl = fromParseResult parseResult
|
|
||||||
drawing = drawingFromDecl decl
|
drawing = drawingFromDecl decl
|
||||||
|
|
||||||
drawingsFromModule :: Module -> [Drawing]
|
drawingsFromModule :: Module -> [Drawing]
|
||||||
|
10
app/Types.hs
10
app/Types.hs
@ -32,9 +32,9 @@ data Icon = ResultIcon | BranchIcon | TextBoxIcon String | GuardIcon Int
|
|||||||
-- TODO: NestedApply should have the type NestedApply (Maybe (Name, Icon)) [Maybe (Name, Icon)]
|
-- TODO: NestedApply should have the type NestedApply (Maybe (Name, Icon)) [Maybe (Name, Icon)]
|
||||||
| NestedApply String [Maybe (Name, Icon)]
|
| NestedApply String [Maybe (Name, Icon)]
|
||||||
| NestedPApp String [Maybe (Name, Icon)]
|
| NestedPApp String [Maybe (Name, Icon)]
|
||||||
deriving (Show)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
data NameAndPort = NameAndPort Name (Maybe Int) deriving (Show)
|
data NameAndPort = NameAndPort Name (Maybe Int) deriving (Show, Eq)
|
||||||
|
|
||||||
type Connection = (NameAndPort, NameAndPort)
|
type Connection = (NameAndPort, NameAndPort)
|
||||||
|
|
||||||
@ -43,13 +43,13 @@ data EdgeOption = EdgeInPattern deriving (Show, Eq)
|
|||||||
-- | An Edge has an name of the source icon, and its optional port number,
|
-- | An Edge has an name of the source icon, and its optional port number,
|
||||||
-- and the name of the destination icon, and its optional port number.
|
-- and the name of the destination icon, and its optional port number.
|
||||||
data Edge = Edge {edgeOptions::[EdgeOption], edgeEnds :: (EdgeEnd, EdgeEnd), edgeConnection :: Connection}
|
data Edge = Edge {edgeOptions::[EdgeOption], edgeEnds :: (EdgeEnd, EdgeEnd), edgeConnection :: Connection}
|
||||||
deriving (Show)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
data EdgeEnd = EndAp1Result | EndAp1Arg | EndNone deriving (Show)
|
data EdgeEnd = EndAp1Result | EndAp1Arg | EndNone deriving (Show, Eq)
|
||||||
|
|
||||||
-- | A drawing is a map from names to Icons, a list of edges,
|
-- | A drawing is a map from names to Icons, a list of edges,
|
||||||
-- and a map of names to subDrawings
|
-- and a map of names to subDrawings
|
||||||
data Drawing = Drawing [(Name, Icon)] [Edge] [(Name, Drawing)] deriving (Show)
|
data Drawing = Drawing [(Name, Icon)] [Edge] [(Name, Drawing)] deriving (Show, Eq)
|
||||||
|
|
||||||
-- | IDState is an Abstract Data Type that is used as a state whose value is a unique id.
|
-- | IDState is an Abstract Data Type that is used as a state whose value is a unique id.
|
||||||
newtype IDState = IDState Int deriving (Eq, Show)
|
newtype IDState = IDState Int deriving (Eq, Show)
|
||||||
|
18
glance.cabal
18
glance.cabal
@ -41,12 +41,26 @@ executable glance-exe
|
|||||||
|
|
||||||
test-suite glance-test
|
test-suite glance-test
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
hs-source-dirs: test
|
hs-source-dirs: test, app
|
||||||
main-is: Spec.hs
|
main-is: AllTests.hs
|
||||||
build-depends: base
|
build-depends: base
|
||||||
, glance
|
, glance
|
||||||
|
, HUnit
|
||||||
|
, diagrams
|
||||||
|
, diagrams-core
|
||||||
|
, diagrams-lib
|
||||||
|
, diagrams-svg
|
||||||
|
, diagrams-graphviz
|
||||||
|
, graphviz
|
||||||
|
, containers
|
||||||
|
, fgl
|
||||||
|
, haskell-src-exts
|
||||||
|
, mtl
|
||||||
|
, semigroups
|
||||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
Other-modules: Icons, Rendering, Types, Util, Translate, TranslateCore, DrawingColors
|
||||||
|
|
||||||
|
|
||||||
source-repository head
|
source-repository head
|
||||||
type: git
|
type: git
|
||||||
|
222
test/AllTests.hs
Normal file
222
test/AllTests.hs
Normal file
@ -0,0 +1,222 @@
|
|||||||
|
module AllTests where
|
||||||
|
import Diagrams.Prelude hiding ((#), (&))
|
||||||
|
import Diagrams.Backend.SVG.CmdLine
|
||||||
|
import Diagrams.Backend.SVG (renderSVG)
|
||||||
|
|
||||||
|
import Rendering(renderDrawing)
|
||||||
|
import Translate(translateString)
|
||||||
|
import Icons(textBox, colorScheme, ColorStyle(..))
|
||||||
|
|
||||||
|
nestedTests = [
|
||||||
|
"y = f x",
|
||||||
|
"y = f (g x)",
|
||||||
|
"y = let x = 1 in 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]"
|
||||||
|
]
|
||||||
|
|
||||||
|
dollarTests = [
|
||||||
|
"y = f $ g 3",
|
||||||
|
" y = f 1 $ g 2 "
|
||||||
|
]
|
||||||
|
|
||||||
|
specialTests = [
|
||||||
|
"lookupTail EndAp1Arg = (arrowTail .~ dart')",
|
||||||
|
"y = x .~ y",
|
||||||
|
"initialIdState = IDState 0",
|
||||||
|
"y = f x",
|
||||||
|
"yyy = fff xxx",
|
||||||
|
"yyyyy = fffff xxxxx"
|
||||||
|
]
|
||||||
|
|
||||||
|
negateTests = [
|
||||||
|
"y = -1",
|
||||||
|
"y = -1/2",
|
||||||
|
"y = -x"
|
||||||
|
]
|
||||||
|
|
||||||
|
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}"
|
||||||
|
]
|
||||||
|
|
||||||
|
enumTests = [
|
||||||
|
"y = [1..]",
|
||||||
|
"y = [1,2..]",
|
||||||
|
"y = [0..10]",
|
||||||
|
"y = [0,1..10]"
|
||||||
|
]
|
||||||
|
|
||||||
|
tupleTests = [
|
||||||
|
"y = ()",
|
||||||
|
"(x, y) = (1,2)",
|
||||||
|
"(x, y, z) = (1,2,3)"
|
||||||
|
]
|
||||||
|
|
||||||
|
listTests = [
|
||||||
|
"y = []",
|
||||||
|
"y = [1]",
|
||||||
|
"y = [1,2]",
|
||||||
|
"y = [1,2,3]",
|
||||||
|
"[x] = 1",
|
||||||
|
"[x, y] = 2",
|
||||||
|
"[x, y, z] = 3"
|
||||||
|
-- TODO: Add this test "(x:y) = 3"
|
||||||
|
]
|
||||||
|
|
||||||
|
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}"
|
||||||
|
]
|
||||||
|
|
||||||
|
guardTests = [
|
||||||
|
"y x\n\
|
||||||
|
\ | x == 0 = 1",
|
||||||
|
"y x\n\
|
||||||
|
\ | x == 0 = 1\n\
|
||||||
|
\ | otherwise = 2"
|
||||||
|
]
|
||||||
|
|
||||||
|
patternTests = [
|
||||||
|
"Foo _ x = 3",
|
||||||
|
"y (F x) = x",
|
||||||
|
"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 {g = 3; F x y = g} 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@(x,y) = (x,y)",
|
||||||
|
"y = let {t@(_,_) = (3,4)} in t + 3",
|
||||||
|
"y = let {(x, y) = (1,2)} in x + y",
|
||||||
|
-- TODO: Fix so that lines between patterns are Pattern Color.
|
||||||
|
"y = let {(x, y) = (1,2); (z, w) = x; (m, g) = y} in foo x y z w m g",
|
||||||
|
"(x:y) = 2"
|
||||||
|
]
|
||||||
|
|
||||||
|
lambdaTests = [
|
||||||
|
"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 -> (\\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 0 = 1; y 1= 0}",
|
||||||
|
"y (-1) = 2",
|
||||||
|
"y 1 = 0",
|
||||||
|
"{y (F x) = x; y (G x) = x}",
|
||||||
|
"{y (F x) z = x z; y (G x) z = z x}",
|
||||||
|
"y x = z 3 where z = f x y",
|
||||||
|
"y x = z where z = f x y"
|
||||||
|
]
|
||||||
|
|
||||||
|
letTests = [
|
||||||
|
"y = let {z = (\\x -> y x)} in z",
|
||||||
|
"y = let {z x = y x} in z ",
|
||||||
|
"y = x where x = f 3 y",
|
||||||
|
"y x1 = let {x2 = x1; x3 = x2; x4 = f x3} in x4",
|
||||||
|
"y x1 = let x2 = f x1 in x2 x1",
|
||||||
|
"y x = let x = 3 in x",
|
||||||
|
"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",
|
||||||
|
"y = let {fibs = cons 0 (cons 1 (zipWith (+) fibs (tail fibs)))} in fibs",
|
||||||
|
"fibs = cons 0 (cons 1 (zipWith (+) fibs (tail fibs)))",
|
||||||
|
"y = let x = f x in x",
|
||||||
|
"y = f y",
|
||||||
|
"y = let {a = f b; b = g a} in b",
|
||||||
|
"y = let {a = 48; b = a + 3} in b",
|
||||||
|
"y = let {b = a; a = 84} in f b",
|
||||||
|
"y = let {x = 1} in f x",
|
||||||
|
"y = let z = 2 in z",
|
||||||
|
"y = let {z = 3; z2 = z} in z2",
|
||||||
|
"y x = let z = x in z"
|
||||||
|
]
|
||||||
|
|
||||||
|
operatorTests = [
|
||||||
|
"y = 1 + 2",
|
||||||
|
"y = map (1 ++) 3",
|
||||||
|
"y = map (++ 1) 3"
|
||||||
|
]
|
||||||
|
|
||||||
|
otherTests = [
|
||||||
|
"y = f 1 'c' 2.3 \"foobar\"",
|
||||||
|
"fact x = if (x == 0) then 1 else (fact x (x - 1))",
|
||||||
|
"fact x = if ((==) 0 x) then 1 else (fact x ((-) x 1))",
|
||||||
|
"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 = f x",
|
||||||
|
"y = f (g x)",
|
||||||
|
"y = f (g x1 x2) x3",
|
||||||
|
"y = (f x1 x2) (g x1 x2)",
|
||||||
|
"y = Foo.bar"
|
||||||
|
]
|
||||||
|
|
||||||
|
testDecls = mconcat [
|
||||||
|
dollarTests
|
||||||
|
,nestedTests
|
||||||
|
,negateTests
|
||||||
|
,doTests
|
||||||
|
,enumTests
|
||||||
|
,caseTests
|
||||||
|
,lambdaTests
|
||||||
|
,guardTests
|
||||||
|
,patternTests
|
||||||
|
,specialTests
|
||||||
|
,tupleTests
|
||||||
|
,listTests
|
||||||
|
,letTests
|
||||||
|
,operatorTests
|
||||||
|
,otherTests
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
translateStringToDrawing :: String -> IO (Diagram B)
|
||||||
|
translateStringToDrawing s = do
|
||||||
|
let
|
||||||
|
(drawing, decl) = translateString s
|
||||||
|
print decl
|
||||||
|
putStr "\n"
|
||||||
|
print drawing
|
||||||
|
putStr "\n\n"
|
||||||
|
renderDrawing drawing
|
||||||
|
|
||||||
|
renderAllTests :: IO ()
|
||||||
|
renderAllTests = do
|
||||||
|
drawings <- traverse translateStringToDrawing testDecls
|
||||||
|
let
|
||||||
|
textDrawings = fmap (\t -> alignL $ textBox t False 0) testDecls
|
||||||
|
vCattedDrawings = vsep 1 $ zipWith (===) (fmap alignL drawings) textDrawings
|
||||||
|
--mainWith (bgFrame 1 (backgroundC colorScheme) vCattedDrawings :: Diagram B)
|
||||||
|
renderSVG "test/tests.svg" (mkWidth 700) (bgFrame 1 (backgroundC colorScheme) vCattedDrawings :: Diagram B)
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = renderAllTests
|
@ -1,2 +0,0 @@
|
|||||||
main :: IO ()
|
|
||||||
main = putStrLn "Test suite not yet implemented"
|
|
Loading…
Reference in New Issue
Block a user