Remove (&) and (#), add tests.

app/DrawingColors.hs

@@ -3,7 +3,7 @@ module DrawingColors (
   colorScheme
 ) where
 
-import Diagrams.Prelude
+import Diagrams.Prelude hiding ((&), (#))
 
 -- COLO(U)RS --
 colorScheme :: ColorStyle Double

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
+coloredApplyADia appColor n = centerXY finalDia where
-  seperation = circleRadius * 1.5
   trianglePortsCircle = hcat [
     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
   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)
+  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
     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])
+    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 =>
   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)
+    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:
 -- 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
+caseResult = lw none $ lc caseCColor $ fc caseCColor $ circle (circleRadius * 0.7)
-  caseCColor = caseRhsC colorScheme
+  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
+  topAndBottomLine = alignL $ lwG defaultLineWidth $ lc (regionPerimC colorScheme) $ hrule topAndBottomLineWidth
-  finalDia = topAndBottomLine <> alignB (topAndBottomLine <> (middle # alignT))
+  finalDia = topAndBottomLine <> alignB (topAndBottomLine <> alignT middle)

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
+  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
     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
+  let vCattedDrawings = vsep 0.5 renderedDiagrams
-  mainWith ((vCattedDrawings # bgFrame 1 (backgroundC colorScheme)) :: Diagram B)
+  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
+  --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)
@@ -469,9 +518,9 @@ main4 :: IO ()
 main4 = do
   drawings <- traverse translateStringToDrawing testDecls
   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 = [
   "./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
+    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 = main2
+main = main5

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
+      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.
 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
           ]
         ],

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 (parseDecl s) -- :: ParseResult Module
-  decl = fromParseResult parseResult
   drawing = drawingFromDecl decl
 
 drawingsFromModule :: Module -> [Drawing]

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)

glance.cabal

@@ -41,12 +41,26 @@ executable glance-exe
 
 test-suite glance-test
   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
                      , 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

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

test/Spec.hs

@@ -1,2 +0,0 @@
-main :: IO ()
-main = putStrLn "Test suite not yet implemented"