From 973674054e99f67f34d1509264368b296e9f6216 Mon Sep 17 00:00:00 2001 From: Robbie Gleichman Date: Mon, 9 May 2016 23:45:37 -0700 Subject: [PATCH] Remove (&) and (#), add tests. --- app/DrawingColors.hs | 2 +- app/Icons.hs | 62 ++++++------ app/Main.hs | 110 +++++++++++++++------ app/Rendering.hs | 24 ++--- app/Translate.hs | 8 +- app/Types.hs | 10 +- glance.cabal | 18 +++- test/AllTests.hs | 222 +++++++++++++++++++++++++++++++++++++++++++ test/Spec.hs | 2 - 9 files changed, 370 insertions(+), 88 deletions(-) create mode 100644 test/AllTests.hs delete mode 100644 test/Spec.hs diff --git a/app/DrawingColors.hs b/app/DrawingColors.hs index da6be54..df44c24 100644 --- a/app/DrawingColors.hs +++ b/app/DrawingColors.hs @@ -3,7 +3,7 @@ module DrawingColors ( colorScheme ) where -import Diagrams.Prelude +import Diagrams.Prelude hiding ((&), (#)) -- COLO(U)RS -- colorScheme :: ColorStyle Double diff --git a/app/Icons.hs b/app/Icons.hs index f3014d0..2329ddc 100644 --- a/app/Icons.hs +++ b/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) diff --git a/app/Main.hs b/app/Main.hs index a02f3d6..9d56a61 100644 --- a/app/Main.hs +++ b/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 diff --git a/app/Rendering.hs b/app/Rendering.hs index ac1d33e..52baa28 100644 --- a/app/Rendering.hs +++ b/app/Rendering.hs @@ -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 ] ], diff --git a/app/Translate.hs b/app/Translate.hs index 8590b6d..b30de15 100644 --- a/app/Translate.hs +++ b/app/Translate.hs @@ -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] diff --git a/app/Types.hs b/app/Types.hs index 10d93bc..e0598f4 100644 --- a/app/Types.hs +++ b/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) diff --git a/glance.cabal b/glance.cabal index 54612be..7187308 100644 --- a/glance.cabal +++ b/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 diff --git a/test/AllTests.hs b/test/AllTests.hs new file mode 100644 index 0000000..16f6df0 --- /dev/null +++ b/test/AllTests.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 index cd4753f..0000000 --- a/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented"