mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-16 18:30:36 +03:00
Remove (&) and (#), add tests.
This commit is contained in:
parent
3d939f9644
commit
973674054e
@ -3,7 +3,7 @@ module DrawingColors (
|
||||
colorScheme
|
||||
) where
|
||||
|
||||
import Diagrams.Prelude
|
||||
import Diagrams.Prelude hiding ((&), (#))
|
||||
|
||||
-- COLO(U)RS --
|
||||
colorScheme :: ColorStyle Double
|
||||
|
62
app/Icons.hs
62
app/Icons.hs
@ -19,7 +19,7 @@ module Icons
|
||||
nestedApplyDia
|
||||
) where
|
||||
|
||||
import Diagrams.Prelude
|
||||
import Diagrams.Prelude hiding ((&), (#))
|
||||
-- import Diagrams.Backend.SVG(B)
|
||||
import Diagrams.TwoD.Text(Text)
|
||||
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 |||)
|
||||
--- since mempty has no size and will not be placed where you want it.
|
||||
makePort :: Int -> SpecialQDiagram b
|
||||
makePort x = mempty # named x
|
||||
makePort x = named x mempty
|
||||
--makePort x = circle 0.2 # fc green # named x
|
||||
-- Note, the version of makePort below seems to have a different type.
|
||||
--makePort x = textBox (show x) # fc green # named x
|
||||
@ -84,10 +84,10 @@ apply0Triangle ::
|
||||
(Typeable (N b), Transformable b, HasStyle b, TrailLike b,
|
||||
V b ~ V2) =>
|
||||
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 = circle (circleRadius * 0.5) # fc lineCol # lw none
|
||||
portCircle = lw none $ fc lineCol $ circle (circleRadius * 0.5)
|
||||
|
||||
-- applyA Icon--
|
||||
-- | apply0N port locations:
|
||||
@ -97,16 +97,15 @@ portCircle = circle (circleRadius * 0.5) # fc lineCol # lw none
|
||||
coloredApplyADia ::
|
||||
(SpecialBackend b) =>
|
||||
Colour Double -> Int -> SpecialQDiagram b
|
||||
coloredApplyADia appColor n = finalDia # centerXY where
|
||||
seperation = circleRadius * 1.5
|
||||
coloredApplyADia appColor n = centerXY finalDia where
|
||||
trianglePortsCircle = hcat [
|
||||
reflectX (fc appColor apply0Triangle),
|
||||
hcat $ take n $ map (\x -> makePort x <> portCircle <> strutX seperation) [2,3..],
|
||||
makePort 1 <> alignR (circle circleRadius # fc appColor # lwG defaultLineWidth # lc appColor)
|
||||
hcat $ take n $ map (\x -> makePort x <> portCircle <> strutX (circleRadius * 1.5)) [2,3..],
|
||||
makePort 1 <> alignR (lc appColor $ lwG defaultLineWidth $ fc appColor $ circle circleRadius)
|
||||
]
|
||||
allPorts = makePort 0 <> alignL trianglePortsCircle
|
||||
topAndBottomLineWidth = width allPorts - circleRadius
|
||||
topAndBottomLine = hrule topAndBottomLineWidth # lc appColor # lwG defaultLineWidth # alignL
|
||||
topAndBottomLine = alignL $ lwG defaultLineWidth $ lc appColor $ hrule topAndBottomLineWidth
|
||||
finalDia = topAndBottomLine === allPorts === topAndBottomLine
|
||||
|
||||
applyADia :: SpecialBackend b => Int -> SpecialQDiagram b
|
||||
@ -159,11 +158,11 @@ generalNestedDia textCol borderCol funText args reflect angle = centerXY $ tran
|
||||
trianglePortsCircle = hsep seperation $
|
||||
reflectX (fc borderCol apply0Triangle) :
|
||||
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
|
||||
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
|
||||
|
||||
makeInnerIcon portNum Nothing = makePort portNum <> portCircle
|
||||
@ -192,8 +191,8 @@ coloredTextBox :: SpecialBackend b =>
|
||||
Colour Double
|
||||
-> AlphaColour Double -> String -> SpecialQDiagram b
|
||||
coloredTextBox textColor boxColor t =
|
||||
text t # fc textColor # font "freemono" # bold # fontSize (local textBoxFontSize)
|
||||
<> rect rectangleWidth (textBoxFontSize * textBoxHeightFactor) # lcA boxColor # lwG (0.6 * defaultLineWidth)
|
||||
fontSize (local textBoxFontSize) (bold $ font "freemono" $ fc textColor $ text t)
|
||||
<> lwG (0.6 * defaultLineWidth) (lcA boxColor $ rect rectangleWidth (textBoxFontSize * textBoxHeightFactor))
|
||||
where
|
||||
rectangleWidth = textBoxFontSize * monoLetterWidthToHeightFraction
|
||||
* fromIntegral (length t)
|
||||
@ -202,7 +201,7 @@ coloredTextBox textColor boxColor t =
|
||||
-- ENCLOSING REGION --
|
||||
enclosure :: SpecialBackend 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 --
|
||||
-- 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 ::
|
||||
SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b
|
||||
lambdaIcon x = coloredTextBox (lamArgResC colorScheme) transparent "λ" # alignB <> makePort x
|
||||
lambdaIcon x = alignB (coloredTextBox (lamArgResC colorScheme) transparent "λ") <> makePort x
|
||||
|
||||
-- LAMBDA REGION --
|
||||
|
||||
@ -219,16 +218,16 @@ lambdaIcon x = coloredTextBox (lamArgResC colorScheme) transparent "λ" # alignB
|
||||
lambdaRegion :: SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b -> SpecialQDiagram b
|
||||
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..]))
|
||||
|
||||
-- RESULT ICON --
|
||||
resultIcon :: SpecialBackend b => SpecialQDiagram b
|
||||
resultIcon = unitSquare # lw none # fc (lamArgResC colorScheme)
|
||||
resultIcon = lw none $ fc (lamArgResC colorScheme) unitSquare
|
||||
|
||||
-- BRANCH ICON --
|
||||
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 --
|
||||
guardSize :: (Fractional a) => a
|
||||
@ -237,17 +236,17 @@ guardSize = 0.7
|
||||
guardTriangle :: SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b
|
||||
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
|
||||
triangleAndPort = polygon (with & polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize])
|
||||
# rotateBy (1/8) # lwG defaultLineWidth # alignT # alignR
|
||||
triangleAndPort = alignR $ alignT $ lwG defaultLineWidth $ rotateBy (1/8) $
|
||||
polygon (polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize] $ with)
|
||||
|
||||
guardLBracket :: SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b
|
||||
guardLBracket x = ell # alignT # alignL <> makePort x
|
||||
guardLBracket x = alignL (alignT ell) <> makePort x
|
||||
where
|
||||
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 =>
|
||||
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..]
|
||||
trianglesAndBrackets =
|
||||
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
|
||||
verticalLine = strutY 0.4
|
||||
guardDia = vcat (take n trianglesAndBrackets # alignT)
|
||||
bigVerticalLine = vrule (height guardDia) # lc triangleColor # lwG defaultLineWidth # alignT
|
||||
guardDia = vcat (alignT $ take n trianglesAndBrackets)
|
||||
bigVerticalLine = alignT $ lwG defaultLineWidth $ lc triangleColor $ vrule (height guardDia)
|
||||
|
||||
-- | The ports of the guard icon are as follows:
|
||||
-- Port 0: Top result port
|
||||
@ -276,8 +275,9 @@ guardIcon = generalGuardIcon lineCol guardLBracket mempty
|
||||
-- TODO Improve design to be more than a circle.
|
||||
caseResult :: SpecialBackend b =>
|
||||
SpecialQDiagram b
|
||||
caseResult = circle (circleRadius * 0.7) # fc caseCColor # lc caseCColor # lw none where
|
||||
caseCColor = caseRhsC colorScheme
|
||||
caseResult = lw none $ lc caseCColor $ fc caseCColor $ circle (circleRadius * 0.7)
|
||||
where
|
||||
caseCColor = caseRhsC colorScheme
|
||||
|
||||
caseC :: SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b
|
||||
@ -299,10 +299,10 @@ caseIcon = generalGuardIcon (patternC colorScheme) caseC caseResult
|
||||
-- 2,3.. : The parameters
|
||||
flatLambda :: SpecialBackend b => Int -> SpecialQDiagram b
|
||||
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])
|
||||
portIcons = take n $ map (\x -> makePort x <> portCircle) [2,3..]
|
||||
middle = alignL (hsep 0.5 lambdaParts)
|
||||
topAndBottomLineWidth = width middle - circleRadius
|
||||
topAndBottomLine = hrule topAndBottomLineWidth # lc (regionPerimC colorScheme) # lwG defaultLineWidth # alignL
|
||||
finalDia = topAndBottomLine <> alignB (topAndBottomLine <> (middle # alignT))
|
||||
topAndBottomLine = alignL $ lwG defaultLineWidth $ lc (regionPerimC colorScheme) $ hrule topAndBottomLineWidth
|
||||
finalDia = topAndBottomLine <> alignB (topAndBottomLine <> alignT middle)
|
||||
|
110
app/Main.hs
110
app/Main.hs
@ -1,7 +1,9 @@
|
||||
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies #-}
|
||||
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 qualified Language.Haskell.Exts as Exts
|
||||
|
||||
@ -14,6 +16,11 @@ import Translate(translateString, drawingsFromModule)
|
||||
|
||||
|
||||
-- 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.
|
||||
|
||||
-- Refactor Translate
|
||||
@ -23,7 +30,10 @@ import Translate(translateString, drawingsFromModule)
|
||||
-- Move tests out of main.
|
||||
|
||||
-- TODO Later --
|
||||
-- Why is totalLengthOfLines not nesting?
|
||||
|
||||
-- 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 that cross the border of a lambda function a special color.
|
||||
-- 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.
|
||||
-- Improve line routing. Draw curved lines with outgoing lines at fixed angles.
|
||||
-- - 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:
|
||||
-- Make nested version of FlatLambdaIcon
|
||||
-- Fix test case x of {0 -> 1; y -> y}.
|
||||
-- Add proper RecConstr, and RecUpdate support.
|
||||
-- Eliminate BranchIcon in Alts.
|
||||
-- Eliminate BranchIcon for the identity funciton "y x = x"
|
||||
-- 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")
|
||||
d0Icons = toNames
|
||||
[(d0A, ApplyAIcon 1),
|
||||
@ -252,12 +262,33 @@ 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 = do
|
||||
placedNodes <- renderDrawing factLam0Drawing
|
||||
mainWith ((placedNodes # bgFrame 1 (backgroundC colorScheme)) :: Diagram B)
|
||||
placedNodes <- renderDrawing nestedTextDrawing
|
||||
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
|
||||
args = [Nothing, Just (toName "foo", TextBoxIcon "3"), Just (toName "in", NestedApply "inner" [Just (toName "t", TextBoxIcon "t")])]
|
||||
dia = nestedApplyDia "Hello world" args
|
||||
@ -265,8 +296,8 @@ main2 = mainWith ((dia False 0 # bgFrame 0.1 black) :: Diagram B)
|
||||
main3 :: IO ()
|
||||
main3 = do
|
||||
renderedDiagrams <- traverse renderDrawing allDrawings
|
||||
let vCattedDrawings = vcat' (with & sep .~ 0.5) renderedDiagrams
|
||||
mainWith ((vCattedDrawings # bgFrame 1 (backgroundC colorScheme)) :: Diagram B)
|
||||
let vCattedDrawings = vsep 0.5 renderedDiagrams
|
||||
mainWith (bgFrame 1 (backgroundC colorScheme) vCattedDrawings :: Diagram B)
|
||||
where
|
||||
allDrawings = [
|
||||
drawing0,
|
||||
@ -281,8 +312,24 @@ main3 = do
|
||||
factLam2Drawing,
|
||||
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 = [
|
||||
"y = f x $ g y",
|
||||
"lookupTail EndAp1Arg = (arrowTail .~ dart')",
|
||||
"y = x .~ y",
|
||||
"initialIdState = IDState 0",
|
||||
@ -440,19 +487,21 @@ otherTests = [
|
||||
]
|
||||
|
||||
testDecls = mconcat [
|
||||
negateTests
|
||||
,doTests
|
||||
,enumTests
|
||||
,caseTests
|
||||
,lambdaTests
|
||||
,guardTests
|
||||
,patternTests
|
||||
,specialTests
|
||||
,tupleTests
|
||||
,listTests
|
||||
,letTests
|
||||
,operatorTests
|
||||
,otherTests
|
||||
--dollarTests
|
||||
nestedTests
|
||||
-- ,negateTests
|
||||
-- ,doTests
|
||||
-- ,enumTests
|
||||
-- ,caseTests
|
||||
-- ,lambdaTests
|
||||
-- ,guardTests
|
||||
-- ,patternTests
|
||||
-- ,specialTests
|
||||
-- ,tupleTests
|
||||
-- ,listTests
|
||||
-- ,letTests
|
||||
-- ,operatorTests
|
||||
-- ,otherTests
|
||||
]
|
||||
|
||||
translateStringToDrawing :: String -> IO (Diagram B)
|
||||
@ -469,9 +518,9 @@ main4 :: IO ()
|
||||
main4 = do
|
||||
drawings <- traverse translateStringToDrawing testDecls
|
||||
let
|
||||
textDrawings = fmap (alignL . textBox) testDecls
|
||||
vCattedDrawings = vcat' (with & sep .~ 1) $ zipWith (===) (fmap alignL drawings) textDrawings
|
||||
mainWith ((vCattedDrawings # bgFrame 1 (backgroundC colorScheme)) :: Diagram B)
|
||||
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)
|
||||
|
||||
testFiles = [
|
||||
"./app/Main.hs",
|
||||
@ -481,7 +530,8 @@ testFiles = [
|
||||
main5 :: IO ()
|
||||
main5 = do
|
||||
parseResult <- Exts.parseFileWithExts [Exts.EnableExtension Exts.MultiParamTypeClasses, Exts.EnableExtension Exts.FlexibleContexts]
|
||||
"./test/test_translate.hs"
|
||||
--"./app/Icons.hs"
|
||||
"./test/test_nesting.hs"
|
||||
let
|
||||
parsedModule = Exts.fromParseResult parseResult
|
||||
drawings = drawingsFromModule parsedModule
|
||||
@ -491,9 +541,9 @@ main5 = do
|
||||
|
||||
diagrams <- traverse renderDrawing drawings
|
||||
let
|
||||
vCattedDrawings = vcat' (with & sep .~ 1) $ fmap alignL diagrams
|
||||
mainWith ((vCattedDrawings # bgFrame 1 (backgroundC colorScheme)) :: Diagram B)
|
||||
vCattedDrawings = vsep 1 $ fmap alignL diagrams
|
||||
mainWith (bgFrame 1 (backgroundC colorScheme) vCattedDrawings :: Diagram B)
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = main2
|
||||
main = main5
|
||||
|
@ -4,7 +4,7 @@ module Rendering (
|
||||
renderDrawing
|
||||
) where
|
||||
|
||||
import Diagrams.Prelude
|
||||
import Diagrams.Prelude hiding ((#), (&))
|
||||
import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph')
|
||||
import Diagrams.Core.Names(Name(..))
|
||||
--import Diagrams.Backend.SVG(B)
|
||||
@ -74,11 +74,11 @@ edgesToGraph iconNames edges = mkGraph iconNames simpleEdges
|
||||
-- | Custom arrow tail for the arg1 result circle.
|
||||
-- The ArrowHT type does not seem to be documented.
|
||||
arg1ResT :: (RealFloat n) => ArrowHT n
|
||||
arg1ResT len _ = (circle (len / 2) # alignR, mempty)
|
||||
arg1ResT len _ = (alignR $ circle (len / 2), mempty)
|
||||
|
||||
-- | Arrow head version of arg1ResT
|
||||
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 (t, h) opts = arrowOptions
|
||||
@ -99,12 +99,11 @@ getArrowOpts (t, h) opts = arrowOptions
|
||||
lookupHead EndAp1Result = (arrowHead .~ arg1ResH) . (headTexture .~ ap1ResultTexture)
|
||||
|
||||
arrowOptions =
|
||||
with & arrowHead .~ noHead
|
||||
& arrowTail .~ noTail
|
||||
& lengths .~ global 0.75
|
||||
-- this parenthesis "%~ (lwG .. colorScheme))" is necessary for haskell-src-exts to parse the file.
|
||||
& shaftStyle %~ (lwG defaultLineWidth . lc (shaftColor colorScheme))
|
||||
& lookupTail t & lookupHead h
|
||||
arrowHead .~ noHead $
|
||||
arrowTail .~ noTail $
|
||||
lengths .~ global 0.75 $
|
||||
shaftStyle %~ (lwG defaultLineWidth . lc (shaftColor colorScheme)) $
|
||||
lookupHead h $ lookupTail t with
|
||||
|
||||
-- | Given an Edge, return a transformation on Diagrams that will draw a line.
|
||||
connectMaybePorts :: SpecialBackend b =>
|
||||
@ -231,7 +230,7 @@ placeNodes layoutResult nameDiagramMap edges = mconcat placedNodes
|
||||
placedNodes = map placeNode rotatedNameDiagramMap
|
||||
--placedNodes = map placeNode nameDiagramMap
|
||||
-- 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 =>
|
||||
Gr Name e
|
||||
@ -253,9 +252,10 @@ doGraphLayout graph nameDiagramMap edges = do
|
||||
[
|
||||
--GVA.Overlap GVA.KeepOverlaps,
|
||||
--GVA.Overlap GVA.ScaleOverlaps,
|
||||
GVA.Overlap $ GVA.PrismOverlap (Just 1000),
|
||||
GVA.Overlap $ GVA.PrismOverlap (Just 5000),
|
||||
GVA.Splines GVA.LineEdges,
|
||||
GVA.OverlapScaling 4,
|
||||
GVA.OverlapScaling 8,
|
||||
--GVA.OverlapScaling 4,
|
||||
GVA.OverlapShrink True
|
||||
]
|
||||
],
|
||||
|
@ -5,7 +5,7 @@ module Translate(
|
||||
drawingsFromModule
|
||||
) where
|
||||
|
||||
import qualified Diagrams.Prelude as DIA
|
||||
import qualified Diagrams.Prelude as DIA hiding ((#), (&))
|
||||
import Diagrams.Prelude((<>))
|
||||
|
||||
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)
|
||||
pure gr
|
||||
|
||||
|
||||
evalPLit :: Exts.Sign -> Exts.Literal -> State IDState (IconGraph, NameAndPort)
|
||||
evalPLit Exts.Signless l = evalLit 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..]
|
||||
(unnestedArgsAndPort, nestedArgs, nestedSinks, nestedBindings) = unzip4 $ map decideIfNested (zip argVals argumentPorts)
|
||||
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)
|
||||
qualifyBinds (str, ref) = (str, qualifiedRef) where
|
||||
@ -533,8 +532,7 @@ drawingFromDecl d = iconGraphToDrawing $ evalState evaluatedDecl initialIdState
|
||||
-- Profiling: about 1.5% of total time.
|
||||
translateString :: String -> (Drawing, Decl)
|
||||
translateString s = (drawing, decl) where
|
||||
parseResult = parseDecl s -- :: ParseResult Module
|
||||
decl = fromParseResult parseResult
|
||||
decl = fromParseResult (parseDecl s) -- :: ParseResult Module
|
||||
drawing = drawingFromDecl decl
|
||||
|
||||
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)]
|
||||
| NestedApply 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)
|
||||
|
||||
@ -43,13 +43,13 @@ data EdgeOption = EdgeInPattern deriving (Show, Eq)
|
||||
-- | 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.
|
||||
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,
|
||||
-- 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.
|
||||
newtype IDState = IDState Int deriving (Eq, Show)
|
||||
|
18
glance.cabal
18
glance.cabal
@ -41,12 +41,26 @@ executable glance-exe
|
||||
|
||||
test-suite glance-test
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
main-is: Spec.hs
|
||||
hs-source-dirs: test, app
|
||||
main-is: AllTests.hs
|
||||
build-depends: base
|
||||
, 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
|
||||
default-language: Haskell2010
|
||||
Other-modules: Icons, Rendering, Types, Util, Translate, TranslateCore, DrawingColors
|
||||
|
||||
|
||||
source-repository head
|
||||
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