From 9e7d01ab82822829bad59942e096694093c2c1b8 Mon Sep 17 00:00:00 2001 From: Robbie Gleichman Date: Sun, 11 Nov 2018 23:13:19 -0800 Subject: [PATCH] Cleanup and improve formatting. --- app/Icons.hs | 1 - app/Main.hs | 29 ++- app/Rendering.hs | 193 ++++++++++++------- app/Translate.hs | 355 +++++++++++++++++++++++------------ app/TranslateCore.hs | 144 +++++++++----- app/Util.hs | 49 +---- test/VisualRenderingTests.hs | 13 +- 7 files changed, 493 insertions(+), 291 deletions(-) diff --git a/app/Icons.hs b/app/Icons.hs index b9b3b2d..b5e80f9 100644 --- a/app/Icons.hs +++ b/app/Icons.hs @@ -2,7 +2,6 @@ {-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies, ScopedTypeVariables #-} module Icons ( - Icon(..), TransformParams(..), TransformableDia, getPortAngles, diff --git a/app/Main.hs b/app/Main.hs index 98c13a8..a98f655 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -5,14 +5,18 @@ module Main import Prelude hiding (return) --- 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. +-- Note: (#) and (&) are hidden in all Glance source files, since they would +-- require a special case when translating when Glance is run on its own source +-- code. import qualified Diagrams.Prelude as Dia hiding ((#), (&)) import qualified Language.Haskell.Exts as Exts -- Options.Applicative does not seem to work qualified -import Options.Applicative +import Options.Applicative(header, progDesc, fullDesc, helper, info + , defaultPrefs, customExecParser, help, short, switch + , metavar, auto, argument, str, prefShowHelpOnError + , Parser) import Icons(ColorStyle(..), colorScheme, multilineComment) import Rendering(renderIngSyntaxGraph) @@ -31,16 +35,23 @@ optionParser = CmdLineOptions <$> argument str (metavar "INPUT_FILE" Dia.<> help "Input .hs filename") <*> argument str (metavar "OUTPUT_FILE" Dia.<> help "Output .svg filename") <*> argument auto (metavar "IMAGE_WIDTH" Dia.<> help "Output image width") - <*> switch (short 'c' Dia.<> help "Include comments between top level declarations.") + <*> switch + (short 'c' Dia.<> help "Include comments between top level declarations.") renderFile :: CmdLineOptions -> IO () -renderFile (CmdLineOptions inputFilename outputFilename imageWidth includeComments) = do +renderFile (CmdLineOptions + inputFilename + outputFilename + imageWidth + includeComments) + = do putStrLn $ "Translating file " ++ inputFilename ++ " into a Glance image." parseResult <- Exts.parseFileWithComments - (Exts.defaultParseMode - {Exts.extensions = [Exts.EnableExtension Exts.MultiParamTypeClasses, Exts.EnableExtension Exts.FlexibleContexts], - Exts.parseFilename = inputFilename - }) + (Exts.defaultParseMode { + Exts.extensions = [Exts.EnableExtension Exts.MultiParamTypeClasses + , Exts.EnableExtension Exts.FlexibleContexts] + , Exts.parseFilename = inputFilename + }) inputFilename let (parsedModule, comments) = Exts.fromParseResult parseResult diff --git a/app/Rendering.hs b/app/Rendering.hs index 068f3c6..4f43ca2 100644 --- a/app/Rendering.hs +++ b/app/Rendering.hs @@ -6,7 +6,16 @@ module Rendering ( renderIngSyntaxGraph ) where -import Diagrams.Prelude hiding ((#), (&)) +import Diagrams.Prelude(toName, shaftStyle, global, arrowShaft, noTail + , arrowTail, noHead, arrowHead, scale, r2, bezier3 + , fromSegments, Angle, P2, V2, Point, Name, ArrowOpts, N + , TrailLike, V, height, width, (*^), reflectX, rotate + , centerXY, place + , roundedRect, dashingG, lwG, lightgreen, lc, centerPoint + , moveTo, turn, (@@), unitX, signedAngleBetween, (.-.) + , applyAll, names, angleV, rad, (^.), angleBetween, (.>) + , connectOutside', connect', with, (%~), lengths, (^+^) + , (.~)) import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph') import qualified Data.GraphViz as GV @@ -74,17 +83,29 @@ drawingToIconGraph (Drawing nodes edges) = ++ show name ++ " Edge=" ++ show e -bezierShaft :: (V t ~ V2, TrailLike t) => Angle (N t) -> Angle (N t) -> t +bezierShaft :: (V t ~ V2, TrailLike t) => + Angle (N t) -> Angle (N t) -> t bezierShaft angle1 angle2 = fromSegments [bezier3 c1 c2 x] where scaleFactor = 0.5 x = r2 (1,0) c1 = rotate angle1 (scale scaleFactor unitX) c2 = rotate angle2 (scale scaleFactor unitX) ^+^ x -getArrowOpts :: (RealFloat n, Typeable n) => (EdgeEnd, EdgeEnd) -> [EdgeOption] -> (Angle n, Angle n) -> NameAndPort -> ArrowOpts n -getArrowOpts (t, h) _ (fromAngle, toAngle) (NameAndPort (NodeName nodeNum) mPort)= arrowOptions +getArrowOpts :: (RealFloat n, Typeable n) => + (EdgeEnd, EdgeEnd) + -> [EdgeOption] + -> (Angle n, Angle n) + -> NameAndPort + -> ArrowOpts n +getArrowOpts (t, h) + _ + (fromAngle, toAngle) + (NameAndPort (NodeName nodeNum) mPort) + = arrowOptions where - --shaftColor = if EdgeInPattern `elem` opts then patternC colorScheme else hashedColor + -- shaftColor = if EdgeInPattern `elem` opts + -- then patternC colorScheme + -- else hashedColor shaftColor = hashedColor edgeColors = edgeListC colorScheme @@ -108,13 +129,18 @@ getArrowOpts (t, h) _ (fromAngle, toAngle) (NameAndPort (NodeName nodeNum) mPort -- | Given an Edge, return a transformation on Diagrams that will draw a line. connectMaybePorts :: SpecialBackend b n => (Angle n, Angle n)-> Edge -> SpecialQDiagram b n -> SpecialQDiagram b n -connectMaybePorts portAngles (Edge opts ends (fromNamePort@(NameAndPort name0 mPort1), NameAndPort name1 mPort2)) = - connectFunc (getArrowOpts ends opts portAngles fromNamePort) qPort0 qPort1 where - (connectFunc, qPort0, qPort1) = case (mPort1, mPort2) of - (Just port0, Just port1) -> (connect', name0 .> port0, name1 .> port1) - (Nothing, Just port1) -> (connectOutside', toName name0, name1 .> port1) - (Just port0, Nothing) -> (connectOutside', name0 .> port0, toName name1) - (_, _) -> (connectOutside', toName name0, toName name1) +connectMaybePorts portAngles + (Edge + opts + ends + (fromNamePort@(NameAndPort name0 mPort1), NameAndPort name1 mPort2)) + = connectFunc (getArrowOpts ends opts portAngles fromNamePort) qPort0 qPort1 + where + (connectFunc, qPort0, qPort1) = case (mPort1, mPort2) of + (Just port0, Just port1) -> (connect', name0 .> port0, name1 .> port1) + (Nothing, Just port1) -> (connectOutside', toName name0, name1 .> port1) + (Just port0, Nothing) -> (connectOutside', name0 .> port0, toName name1) + (_, _) -> (connectOutside', toName name0, toName name1) -- START addEdges -- nameAndPortToName :: NameAndPort -> Name @@ -123,31 +149,42 @@ nameAndPortToName (NameAndPort name mPort) = case mPort of Just port -> name .> port findPortAngles :: SpecialNum n => NamedIcon -> NameAndPort -> [Angle n] -findPortAngles (NamedIcon nodeName nodeIcon) (NameAndPort diaName mPort) = case mPort of - Nothing -> [] - Just port -> foundAngles where - mName = if nodeName == diaName then Nothing else Just diaName - foundAngles = getPortAngles nodeIcon port mName +findPortAngles (NamedIcon nodeName nodeIcon) (NameAndPort diaName mPort) + = case mPort of + Nothing -> [] + Just port -> foundAngles where + mName = if nodeName == diaName then Nothing else Just diaName + foundAngles = getPortAngles nodeIcon port mName -- TODO Clean up the Angle arithmatic -pickClosestAngle :: SpecialNum n => (Bool, Angle n) -> Angle n -> Angle n -> Angle n -> [Angle n] -> Angle n -pickClosestAngle (nodeFlip, nodeAngle) emptyCase target shaftAngle angles = case angles of - [] -> emptyCase - _ -> (-) <$> - fst (minimumBy (compare `on` snd) $ fmap angleDiff adjustedAngles) - <*> - shaftAngle - where - adjustedAngles = fmap adjustAngle angles - angleDiff angle = (angle, angleBetween (angleV target) (angleV angle)) +pickClosestAngle :: SpecialNum n => + (Bool, Angle n) + -> Angle n + -> Angle n + -> Angle n + -> [Angle n] + -> Angle n +pickClosestAngle (nodeFlip, nodeAngle) emptyCase target shaftAngle angles + = case angles of + [] -> emptyCase + _ -> (-) <$> + fst (minimumBy (compare `on` snd) $ fmap angleDiff adjustedAngles) + <*> + shaftAngle + where + adjustedAngles = fmap adjustAngle angles + angleDiff angle = (angle, angleBetween (angleV target) (angleV angle)) + + adjustAngle angle = if nodeFlip + then signedAngleBetween + (rotate nodeAngle $ reflectX (angleV angle)) + unitX + else (+) <$> angle <*> nodeAngle - adjustAngle angle = if nodeFlip then - signedAngleBetween (rotate nodeAngle $ reflectX (angleV angle)) unitX - else - (+) <$> angle <*> nodeAngle -- TODO Refactor with pickClosestAngle -smallestAngleDiff :: SpecialNum n => (Bool, Angle n) -> Angle n -> [Angle n] -> n +smallestAngleDiff :: SpecialNum n => + (Bool, Angle n) -> Angle n -> [Angle n] -> n smallestAngleDiff (nodeFlip, nodeAngle) target angles = case angles of [] -> 0 _ -> minimum $ fmap angleDiff adjustedAngles @@ -161,21 +198,31 @@ smallestAngleDiff (nodeFlip, nodeAngle) target angles = case angles of (+) <$> angle <*> nodeAngle -lookupNodeAngle :: Show n => [(NamedIcon, (Bool, Angle n))] -> NamedIcon -> (Bool, Angle n) -lookupNodeAngle rotationMap key = - fromMaybeError ("nodeVector: key not in rotaionMap. key = " ++ show key ++ "\n\n rotationMap = " ++ show rotationMap) +lookupNodeAngle :: Show n => + [(NamedIcon, (Bool, Angle n))] -> NamedIcon -> (Bool, Angle n) +lookupNodeAngle rotationMap key + = fromMaybeError + ("nodeVector: key not in rotaionMap. key = " ++ show key + ++ "\n\n rotationMap = " ++ show rotationMap) $ lookup key rotationMap makeEdge :: (SpecialBackend b n, ING.Graph gr) => - gr NamedIcon Edge -> SpecialQDiagram b n -> [(NamedIcon, (Bool, Angle n))] -> - ING.LEdge Edge -> SpecialQDiagram b n -> SpecialQDiagram b n -makeEdge graph dia rotationMap (node0, node1, edge@(Edge _ _ (namePort0, namePort1))) = - connectMaybePorts portAngles edge + gr NamedIcon Edge + -> SpecialQDiagram b n + -> [(NamedIcon, (Bool, Angle n))] + -> ING.LEdge Edge + -> SpecialQDiagram b n + -> SpecialQDiagram b n +makeEdge graph dia rotationMap + (node0, node1, edge@(Edge _ _ (namePort0, namePort1))) + = connectMaybePorts portAngles edge where - node0label = fromMaybeError ("makeEdge: node0 is not in graph. node0: " ++ show node0) $ - ING.lab graph node0 - node1label = fromMaybeError ("makeEdge: node1 is not in graph. node1: " ++ show node1) $ - ING.lab graph node1 + node0label = fromMaybeError + ("makeEdge: node0 is not in graph. node0: " ++ show node0) + $ ING.lab graph node0 + node1label = fromMaybeError + ("makeEdge: node1 is not in graph. node1: " ++ show node1) + $ ING.lab graph node1 node0Angle = lookupNodeAngle rotationMap node0label node1Angle = lookupNodeAngle rotationMap node1label @@ -186,13 +233,20 @@ makeEdge graph dia rotationMap (node0, node1, edge@(Edge _ _ (namePort0, namePor shaftVector = port1Point .-. port0Point shaftAngle = signedAngleBetween shaftVector unitX - icon0PortAngle = pickClosestAngle node0Angle mempty shaftAngle shaftAngle $ findPortAngles node0label namePort0 + icon0PortAngle = pickClosestAngle node0Angle mempty shaftAngle shaftAngle + $ findPortAngles node0label namePort0 shaftAnglePlusOneHalf = (+) <$> shaftAngle <*> (1/2 @@ turn) - icon1PortAngle = pickClosestAngle node1Angle (1/2 @@ turn) shaftAnglePlusOneHalf shaftAngle $ findPortAngles node1label namePort1 + icon1PortAngle = pickClosestAngle + node1Angle + (1/2 @@ turn) + shaftAnglePlusOneHalf + shaftAngle + (findPortAngles node1label namePort1) getPortPoint n = head $ fromMaybeError - ("makeEdge: port not found. Port: " ++ show n ++ ". Valid ports: " ++ show diaNodeNamePointMap) + ("makeEdge: port not found. Port: " ++ show n ++ ". Valid ports: " + ++ show diaNodeNamePointMap) (lookup n diaNodeNamePointMap) portAngles = (icon0PortAngle, icon1PortAngle) @@ -207,9 +261,6 @@ addEdges graph dia rotationMap = applyAll connections dia where connections = makeEdge graph dia rotationMap <$> ING.labEdges graph ---printSelf :: (Show a) => a -> a ---printSelf a = Debug.Trace.trace (show a ++ "/n") a - -- BEGIN rotateNodes -- -- TODO May want to use a power other than 2 for the edgeAngleDiffs @@ -219,11 +270,14 @@ scoreAngle :: SpecialNum n => -> Bool -> Angle n -> n -scoreAngle iconPosition edges reflected angle = sum $ (^(2 :: Int)) <$> fmap edgeAngleDiff edges where - edgeAngleDiff (otherNodePosition, portAngles) = angleDiff where - shaftVector = otherNodePosition .-. iconPosition - shaftAngle = signedAngleBetween shaftVector unitX - angleDiff = smallestAngleDiff (reflected, angle) shaftAngle portAngles +scoreAngle iconPosition edges reflected angle + = sum $ (^(2 :: Int)) <$> fmap edgeAngleDiff edges + where + edgeAngleDiff (otherNodePosition, portAngles) = angleDiff + where + shaftVector = otherNodePosition .-. iconPosition + shaftAngle = signedAngleBetween shaftVector unitX + angleDiff = smallestAngleDiff (reflected, angle) shaftAngle portAngles bestAngleForIcon :: (SpecialNum n, ING.Graph gr) => Map.Map NamedIcon (Point V2 n) @@ -231,17 +285,27 @@ bestAngleForIcon :: (SpecialNum n, ING.Graph gr) => -> NamedIcon -> Bool -> (Angle n, n) -bestAngleForIcon positionMap graph key@(NamedIcon (NodeName nodeId) _) reflected = - minimumBy (compare `on` snd) $ (\angle -> (angle, scoreAngle iconPosition edges reflected angle)) <$> fmap (@@ turn) possibleAngles +bestAngleForIcon positionMap graph key@(NamedIcon (NodeName nodeId) _) reflected + = minimumBy (compare `on` snd) + ( (\angle -> (angle + , scoreAngle iconPosition edges reflected angle)) + <$> fmap (@@ turn) possibleAngles) where possibleAngles = [0,(1/24)..1] -- possibleAngles = [0, 1/2] -- (uncomment this line and comment out the line above to disable rotation) iconPosition = positionMap Map.! key - edges = getPositionAndAngles <$> fmap getSucEdge (ING.lsuc graph nodeId) <> fmap getPreEdge (ING.lpre graph nodeId) + edges = getPositionAndAngles + <$> ( fmap getSucEdge (ING.lsuc graph nodeId) + <> fmap getPreEdge (ING.lpre graph nodeId)) - getPositionAndAngles (node, nameAndPort) = (positionMap Map.! nodeLabel, portAngles) where - nodeLabel = fromMaybeError "getPositionAndAngles: node not found" $ ING.lab graph node - portAngles = findPortAngles key nameAndPort + + getPositionAndAngles (node, nameAndPort) + = (positionMap Map.! nodeLabel, portAngles) + where + nodeLabel = fromMaybeError + "getPositionAndAngles: node not found" + (ING.lab graph node) + portAngles = findPortAngles key nameAndPort -- Edge points from id to otherNode getSucEdge (otherNode, edge) = (otherNode, nameAndPort) where @@ -259,7 +323,8 @@ findIconRotation :: (SpecialNum n, ING.Graph gr) => findIconRotation positionMap graph key = (key, (reflected, angle)) where -- Smaller scores are better (reflectedAngle, reflectedScore) = bestAngleForIcon positionMap graph key True - (nonReflectedAngle, nonReflectedScore) = bestAngleForIcon positionMap graph key False + (nonReflectedAngle, nonReflectedScore) + = bestAngleForIcon positionMap graph key False reflected = reflectedScore < nonReflectedScore angle = if reflected then reflectedAngle else nonReflectedAngle @@ -267,7 +332,8 @@ rotateNodes :: (SpecialNum n, ING.Graph gr) => Map.Map NamedIcon (Point V2 n) -> gr NamedIcon Edge -> [(NamedIcon, (Bool, Angle n))] -rotateNodes positionMap graph = findIconRotation positionMap graph <$> Map.keys positionMap +rotateNodes positionMap graph + = findIconRotation positionMap graph <$> Map.keys positionMap -- END rotateNodes -- @@ -387,7 +453,8 @@ renderDrawing = renderIconGraph . drawingToIconGraph renderIngSyntaxGraph :: SpecialBackend b Double => Gr SgNamedNode Edge -> IO (SpecialQDiagram b Double) -renderIngSyntaxGraph = renderIconGraph . ING.nmap (mapNodeInNamedNode nodeToIcon) +renderIngSyntaxGraph + = renderIconGraph . ING.nmap (mapNodeInNamedNode nodeToIcon) renderIconGraph :: SpecialBackend b Double => Gr NamedIcon Edge -> IO (SpecialQDiagram b Double) diff --git a/app/Translate.hs b/app/Translate.hs index bce7288..9b5a9db 100644 --- a/app/Translate.hs +++ b/app/Translate.hs @@ -16,17 +16,20 @@ import Data.Maybe(catMaybes, isJust, fromMaybe) import qualified Language.Haskell.Exts as Exts -import Language.Haskell.Exts(Decl(..), parseDeclWithMode, Name(..), Pat(..), Rhs(..), +import Language.Haskell.Exts( + Decl(..), parseDeclWithMode, Name(..), Pat(..), Rhs(..), Exp(..), QName(..), fromParseResult, Match(..), QOp(..), GuardedRhs(..), Stmt(..), Binds(..), Alt(..), Module(..), SpecialCon(..), prettyPrint) import GraphAlgorithms(collapseNodes) -import TranslateCore(Reference, SyntaxGraph(..), EvalContext, GraphAndRef(..), SgSink(..), SgBind(..), - syntaxGraphFromNodes, syntaxGraphFromNodesEdges, getUniqueName, combineExpressions, - edgesForRefPortList, makeApplyGraph, makeGuardGraph, +import TranslateCore( + Reference, SyntaxGraph(..), EvalContext, GraphAndRef(..), SgSink(..), + syntaxGraphFromNodes, syntaxGraphFromNodesEdges, getUniqueName, + edgesForRefPortList, makeApplyGraph, makeGuardGraph, combineExpressions, namesInPattern, lookupReference, deleteBindings, makeEdges, makeBox, nTupleString, nTupleSectionString, nListString, - syntaxGraphToFglGraph, getUniqueString, bindsToSyntaxGraph, graphAndRefToGraph, + syntaxGraphToFglGraph, getUniqueString, bindsToSyntaxGraph, + SgBind(..), graphAndRefToGraph, initialIdState) import Types(Labeled(..), NameAndPort(..), IDState, Edge, SyntaxNode(..), IngSyntaxGraph, NodeName, SgNamedNode(..), @@ -54,18 +57,25 @@ qOpToExp :: QOp l -> Exp l qOpToExp (QVarOp l n) = Var l n qOpToExp (QConOp l n) = Con l n --- | Make a syntax graph that has the bindings for a list of "as pattern" (@) names. +-- | Make a syntax graph that has the bindings for a list of "as pattern" (@) +-- names. makeAsBindGraph :: Reference -> [Maybe String] -> SyntaxGraph -makeAsBindGraph ref asNames = bindsToSyntaxGraph $ catMaybes $ fmap makeBind asNames where - makeBind mName = case mName of - Nothing -> Nothing - Just asName -> Just $ SgBind asName ref +makeAsBindGraph ref asNames + = bindsToSyntaxGraph $ catMaybes $ fmap makeBind asNames + where + makeBind mName = case mName of + Nothing -> Nothing + Just asName -> Just $ SgBind asName ref grNamePortToGrRef :: (SyntaxGraph, NameAndPort) -> GraphAndRef grNamePortToGrRef (graph, np) = GraphAndRef graph (Right np) -bindOrAltHelper :: - Show l => EvalContext -> Pat l -> Rhs l -> Maybe (Binds l) -> State IDState ((GraphAndRef, Maybe String), GraphAndRef) +bindOrAltHelper :: Show l => + EvalContext + -> Pat l + -> Rhs l + -> Maybe (Binds l) + -> State IDState ((GraphAndRef, Maybe String), GraphAndRef) bindOrAltHelper c pat rhs maybeWhereBinds = do patGraphAndRef <- evalPattern pat let @@ -90,7 +100,8 @@ nameToString (Ident _ s) = s nameToString (Symbol _ s) = s qNameToString :: Show l => QName l -> String -qNameToString (Qual _ (Exts.ModuleName _ modName) name) = modName ++ "." ++ nameToString name +qNameToString (Qual _ (Exts.ModuleName _ modName) name) + = modName ++ "." ++ nameToString name qNameToString (UnQual _ name) = nameToString name qNameToString (Special _ (UnitCon _)) = "()" qNameToString (Special _ (ListCon _)) = "[]" @@ -105,7 +116,8 @@ qNameToString q = error $ "Unsupported syntax in qNameToSrting: " <> show q -- BEGIN evalLit --- This is in Translate and not Translate core since currently it is only used by evalLit. +-- This is in Translate and not Translate core since currently it is only used +-- by evalLit. makeLiteral :: (Show x) => x -> State IDState (SyntaxGraph, NameAndPort) makeLiteral = makeBox . show @@ -133,8 +145,11 @@ asNameBind (GraphAndRef _ ref, mAsName) = case mAsName of Nothing -> Nothing Just asName -> Just $ SgBind asName ref -patternArgumentMapper :: ((GraphAndRef, Maybe String), t) -> (String, Either (GraphAndRef, t) (SgNamedNode, SyntaxGraph)) -patternArgumentMapper (asGraphAndRef@(graphAndRef, _), port) = (patName, eitherVal) +patternArgumentMapper :: + ((GraphAndRef, Maybe String), t) + -> (String, Either (GraphAndRef, t) (SgNamedNode, SyntaxGraph)) +patternArgumentMapper (asGraphAndRef@(graphAndRef, _), port) + = (patName, eitherVal) where graph = graphAndRefToGraph graphAndRef patName = patternName asGraphAndRef @@ -144,24 +159,36 @@ patternArgumentMapper (asGraphAndRef@(graphAndRef, _), port) = (patName, eitherV _ -> Left (graphAndRef, port) -graphToTuple :: SyntaxGraph -> ([SgNamedNode], [Edge], [SgSink], [SgBind], [(NodeName, NodeName)]) +graphToTuple :: + SyntaxGraph + -> ([SgNamedNode], [Edge], [SgSink], [SgBind], [(NodeName, NodeName)]) graphToTuple (SyntaxGraph a b c d e) = (a, b, c, d, e) -graphsToComponents :: [SyntaxGraph] -> ([SgNamedNode], [Edge], [SgSink], [SgBind], [(NodeName, NodeName)]) -graphsToComponents graphs = (concat a, concat b, concat c, concat d, concat e) where - (a, b, c, d, e) = unzip5 $ fmap graphToTuple graphs +graphsToComponents :: + [SyntaxGraph] + -> ([SgNamedNode], [Edge], [SgSink], [SgBind], [(NodeName, NodeName)]) +graphsToComponents graphs = (concat a, concat b, concat c, concat d, concat e) + where + (a, b, c, d, e) = unzip5 $ fmap graphToTuple graphs -makeNestedPatternGraph :: NodeName -> String -> [(GraphAndRef, Maybe String)] -> (SyntaxGraph, NameAndPort) +makeNestedPatternGraph :: + NodeName + -> String + -> [(GraphAndRef, Maybe String)] + -> (SyntaxGraph, NameAndPort) makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult where dummyNode = NestedPatternApplyNode "" [] - argsAndPorts = zip argVals $ map (nameAndPort applyIconName) $ argumentPorts dummyNode + argsAndPorts + = zip argVals $ map (nameAndPort applyIconName) $ argumentPorts dummyNode mappedArgs = fmap patternArgumentMapper argsAndPorts - (unnestedArgsAndPort, nestedNamedNodesAndGraphs) = partitionEithers (fmap snd mappedArgs) + (unnestedArgsAndPort, nestedNamedNodesAndGraphs) + = partitionEithers (fmap snd mappedArgs) - (nestedArgs, _, nestedSinks, nestedBinds, nestedEMaps) = graphsToComponents $ fmap snd nestedNamedNodesAndGraphs + (nestedArgs, _, nestedSinks, nestedBinds, nestedEMaps) + = graphsToComponents $ fmap snd nestedNamedNodesAndGraphs argListMapper (str, arg) = case arg of Left _ -> Labeled Nothing str @@ -177,23 +204,18 @@ makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult asNameBinds = catMaybes $ fmap asNameBind argVals allBinds = nestedBinds <> asNameBinds - newEMap = ((\(SgNamedNode n _) -> (n, applyIconName)) <$> nestedArgs) <> nestedEMaps + newEMap = ((\(SgNamedNode n _) -> (n, applyIconName)) <$> nestedArgs) + <> nestedEMaps newGraph = SyntaxGraph icons [] nestedSinks allBinds newEMap - nestedApplyResult = (newGraph <> combinedGraph, nameAndPort applyIconName (resultPort pAppNode)) + nestedApplyResult = (newGraph <> combinedGraph + , nameAndPort applyIconName (resultPort pAppNode)) --- TODO Delete makePatternGraph' --- makePatternGraph' :: NodeName -> String -> [GraphAndRef] -> (SyntaxGraph, NameAndPort) --- makePatternGraph' applyIconName funStr argVals = (newGraph <> combinedGraph, nameAndPort applyIconName (resultPort pAppNode)) --- where --- pAppNode = PatternApplyNode funStr numArgs --- argumentNamePorts = map (nameAndPort applyIconName) $ argumentPorts pAppNode --- combinedGraph = combineExpressions True $ zip argVals argumentNamePorts --- numArgs = length argVals --- icons = [SgNamedNode applyIconName pAppNode] --- newGraph = syntaxGraphFromNodes icons -evalPApp :: Show l => QName l -> [Pat l] -> State IDState (SyntaxGraph, NameAndPort) +evalPApp :: Show l => + QName l + -> [Pat l] + -> State IDState (SyntaxGraph, NameAndPort) evalPApp name patterns = case patterns of [] -> makeBox constructorName _ -> do @@ -219,22 +241,27 @@ showLiteral (Exts.PrimDouble _ x _) = show x showLiteral (Exts.PrimChar _ x _) = show x showLiteral (Exts.PrimString _ x _) = show x -evalPLit :: Exts.Sign l -> Exts.Literal l -> State IDState (SyntaxGraph, NameAndPort) +evalPLit :: + Exts.Sign l -> Exts.Literal l -> State IDState (SyntaxGraph, NameAndPort) evalPLit sign l = case sign of Exts.Signless _ -> evalLit l Exts.Negative _ -> makeBox ('-' : showLiteral l) -- END evalPLit -evalPAsPat :: Show l => Name l -> Pat l -> State IDState (GraphAndRef, Maybe String) +evalPAsPat :: Show l => + Name l -> Pat l -> State IDState (GraphAndRef, Maybe String) evalPAsPat n p = do (GraphAndRef evaledPatGraph evaledPatRef, mInnerName) <- evalPattern p let outerName = nameToString n asBindGraph = makeAsBindGraph (Left outerName) [mInnerName] - pure (GraphAndRef (asBindGraph <> evaledPatGraph) evaledPatRef, Just outerName) + pure (GraphAndRef (asBindGraph <> evaledPatGraph) evaledPatRef + , Just outerName) -makePatternResult :: Functor f => f (SyntaxGraph, NameAndPort) -> f (GraphAndRef, Maybe String) -makePatternResult = fmap (\(graph, namePort) -> (GraphAndRef graph (Right namePort), Nothing)) +makePatternResult :: Functor f => + f (SyntaxGraph, NameAndPort) -> f (GraphAndRef, Maybe String) +makePatternResult + = fmap (\(graph, namePort) -> (GraphAndRef graph (Right namePort), Nothing)) evalPattern :: Show l => Pat l -> State IDState (GraphAndRef, Maybe String) evalPattern p = case p of @@ -244,9 +271,13 @@ evalPattern p = case p of PApp _ name patterns -> makePatternResult $ evalPApp name patterns -- TODO special tuple handling. PTuple l _ patterns -> - makePatternResult $ evalPApp (Exts.UnQual l . Ident l . nTupleString . length $ patterns) patterns + makePatternResult $ evalPApp + (Exts.UnQual l . Ident l . nTupleString . length $ patterns) + patterns PList l patterns -> - makePatternResult $ evalPApp (Exts.UnQual l . Ident l . nListString . length $ patterns) patterns + makePatternResult $ evalPApp + (Exts.UnQual l . Ident l . nListString . length $ patterns) + patterns PParen _ pat -> evalPattern pat PAsPat _ n subPat -> evalPAsPat n subPat PWildCard _ -> makePatternResult $ makeBox "_" @@ -275,7 +306,7 @@ evalQName qName c = case qName of -- END evalQName - +-- TODO Delete these commented out functions. -- evalQOp :: QOp l -> EvalContext -> State IDState GraphAndRef -- evalQOp (QVarOp n) = evalQName n -- evalQOp (QConOp n) = evalQName n @@ -297,41 +328,55 @@ removeParen e = case e of Paren _ x -> removeParen x _ -> e -evalFunExpAndArgs :: Show l => EvalContext -> LikeApplyFlavor -> (Exp l, [Exp l]) -> State IDState (SyntaxGraph, NameAndPort) +evalFunExpAndArgs :: Show l => + EvalContext + -> LikeApplyFlavor + -> (Exp l, [Exp l]) + -> State IDState (SyntaxGraph, NameAndPort) evalFunExpAndArgs c flavor (funExp, argExps) = do funVal <- evalExp c funExp argVals <- mapM (evalExp c) argExps applyIconName <- getUniqueName - pure $ makeApplyGraph (length argExps) flavor False applyIconName funVal argVals + pure + $ makeApplyGraph (length argExps) flavor False applyIconName funVal argVals -- END apply and compose helper functions -- BEGIN evalInfixApp -evalFunctionComposition :: Show l => EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort) +evalFunctionComposition :: Show l => + EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort) evalFunctionComposition c functions = do let reversedFunctios = reverse functions evaluatedFunctions <- mapM (evalExp c) reversedFunctios neverUsedPort <- Left <$> getUniqueString "unusedArgument" applyIconName <- getUniqueName - pure $ makeApplyGraph (length evaluatedFunctions) ComposeNodeFlavor False applyIconName - (GraphAndRef mempty neverUsedPort) evaluatedFunctions + pure $ makeApplyGraph + (length evaluatedFunctions) + ComposeNodeFlavor + False + applyIconName + (GraphAndRef mempty neverUsedPort) + evaluatedFunctions -- | Turn (a . b . c) into [a, b, c] compositionToList :: Exp l -> [Exp l] compositionToList e = case removeParen e of - (InfixApp _ exp1 (QVarOp _ (UnQual _ (Symbol _ "."))) exp2) -> exp1 : compositionToList exp2 + (InfixApp _ exp1 (QVarOp _ (UnQual _ (Symbol _ "."))) exp2) + -> exp1 : compositionToList exp2 x -> [x] -- | In the general case, infix is converted to prefix. -- Special cases: -- a $ b is converted to (a b) -- (a . b . c) uses the compose apply icon with no argument -evalInfixApp :: Show l => l -> EvalContext -> Exp l -> QOp l -> Exp l -> State IDState GraphAndRef +evalInfixApp :: Show l => + l -> EvalContext -> Exp l -> QOp l -> Exp l -> State IDState GraphAndRef evalInfixApp l c e1 op e2 = case op of QVarOp _ (UnQual _ (Symbol _ sym)) -> case sym of "$" -> evalExp c (App l e1 e2) - "." -> grNamePortToGrRef <$> evalFunctionComposition c (e1 : compositionToList e2) + "." -> grNamePortToGrRef + <$> evalFunctionComposition c (e1 : compositionToList e2) _ -> defaultCase _ -> defaultCase where @@ -346,7 +391,8 @@ simplifyExp e = case removeParen e of InfixApp l exp1 (QVarOp _ (UnQual _ (Symbol _ "$"))) exp2 -> App l exp1 exp2 -- Don't convert compose to apply InfixApp _ _ (QVarOp _ (UnQual _ (Symbol _ "."))) _ -> e - App l (Var _ (UnQual _ (Symbol _ "<$>"))) arg -> App l (makeVarExp l "fmap") arg + App l (Var _ (UnQual _ (Symbol _ "<$>"))) arg + -> App l (makeVarExp l "fmap") arg InfixApp l exp1 op exp2 -> App l (App l (qOpToExp op) exp1) exp2 LeftSection l exp1 op -> App l (qOpToExp op) exp1 x -> x @@ -370,7 +416,8 @@ applyComposeScoreHelper exp1 exp2 = (appScore, compScore) where compScore = max leftComp rightComp -- TODO Consider putting this logic in a separate "simplifyExpression" function. --- | Returns the amount of nesting if the App is converted to (applyNode, composeNode) +-- | Returns the amount of nesting if the App is converted to +-- (applyNode, composeNode) applyComposeScore :: Exp l -> (Int, Int) applyComposeScore e = case simplifyExp e of App _ exp1 exp2 -> applyComposeScoreHelper exp1 exp2 @@ -397,11 +444,13 @@ appExpToArgFuncs e = case simplifyExp e of removeCompose :: l -> Exp l -> Exp l -> Exp l removeCompose l f x = case removeParen f of - (InfixApp _ f1 (QVarOp _ (UnQual _ (Symbol _ "."))) f2) -> App l f1 $ removeCompose l f2 x + (InfixApp _ f1 (QVarOp _ (UnQual _ (Symbol _ "."))) f2) + -> App l f1 $ removeCompose l f2 x _ -> App l f x -- TODO Refactor this and all sub-expressions -evalApp :: Show l => l -> EvalContext -> Exp l -> Exp l -> State IDState (SyntaxGraph, NameAndPort) +evalApp :: Show l => + l -> EvalContext -> Exp l -> Exp l -> State IDState (SyntaxGraph, NameAndPort) evalApp l c f e = if appScore <= compScore then evalFunExpAndArgs c ApplyNodeFlavor (appExpToFuncArgs noComposeExp) else evalFunExpAndArgs c ComposeNodeFlavor (appExpToArgFuncs noComposeExp) @@ -411,7 +460,12 @@ evalApp l c f e = if appScore <= compScore -- END evaluateAppExpression -evalIf :: Show l => EvalContext -> Exp l -> Exp l -> Exp l -> State IDState (SyntaxGraph, NameAndPort) +evalIf :: Show l => + EvalContext + -> Exp l + -> Exp l + -> Exp l + -> State IDState (SyntaxGraph, NameAndPort) evalIf c boolExp trueExp falseExp = makeGuardGraph 2 <$> getUniqueName @@ -425,13 +479,16 @@ evalIf c boolExp trueExp falseExp = makeGuardGraph 2 getBoundVarName :: Show l => Decl l -> [String] -- TODO Should evalState be used here? -getBoundVarName (PatBind _ pat _ _) = namesInPattern $ evalState (evalPattern pat) initialIdState +getBoundVarName (PatBind _ pat _ _) + = namesInPattern $ evalState (evalPattern pat) initialIdState getBoundVarName (FunBind _ (Match _ name _ _ _:_)) = [nameToString name] -- TODO: Other cases getBoundVarName (TypeSig _ _ _) = [] -getBoundVarName decl = error $ "getBoundVarName: No pattern in case for " ++ show decl +getBoundVarName decl + = error $ "getBoundVarName: No pattern in case for " ++ show decl -evalBinds :: Show l => EvalContext -> Binds l -> State IDState (SyntaxGraph, EvalContext) +evalBinds :: Show l => + EvalContext -> Binds l -> State IDState (SyntaxGraph, EvalContext) evalBinds c (BDecls _ decls) = let boundNames = concatMap getBoundVarName decls @@ -440,7 +497,11 @@ evalBinds c (BDecls _ decls) = ((,augmentedContext) . mconcat) <$> mapM (evalDecl augmentedContext) decls evalBinds _ binds = error $ "Unsupported syntax in evalBinds: " <> show binds -evalGeneralLet :: Show l => (EvalContext -> State IDState GraphAndRef) -> EvalContext -> Binds l-> State IDState GraphAndRef +evalGeneralLet :: Show l => + (EvalContext -> State IDState GraphAndRef) + -> EvalContext + -> Binds l + -> State IDState GraphAndRef evalGeneralLet expOrRhsEvaler c bs = do (bindGraph, bindContext) <- evalBinds c bs expVal <- expOrRhsEvaler bindContext @@ -465,10 +526,13 @@ evalStmts :: Show l => EvalContext -> [Stmt l] -> State IDState GraphAndRef evalStmts c [stmt] = evalStmt c stmt evalStmts _ stmts = error $ "Unsupported syntax in evalStmts: " <> show stmts -evalGuardedRhs :: Show l => EvalContext -> GuardedRhs l -> State IDState (GraphAndRef, GraphAndRef) -evalGuardedRhs c (GuardedRhs _ stmts e) = (,) <$> evalStmts c stmts <*> evalExp c e +evalGuardedRhs :: Show l => + EvalContext -> GuardedRhs l -> State IDState (GraphAndRef, GraphAndRef) +evalGuardedRhs c (GuardedRhs _ stmts e) + = (,) <$> evalStmts c stmts <*> evalExp c e -evalGuardedRhss :: Show l => EvalContext -> [GuardedRhs l] -> State IDState (SyntaxGraph, NameAndPort) +evalGuardedRhss :: Show l => + EvalContext -> [GuardedRhs l] -> State IDState (SyntaxGraph, NameAndPort) evalGuardedRhss c rhss = let evaledRhss = unzip <$> mapM (evalGuardedRhs c) rhss in @@ -486,7 +550,8 @@ evalRhs :: Show l => EvalContext -> Rhs l -> State IDState GraphAndRef evalRhs c (UnGuardedRhs _ e) = evalExp c e evalRhs c (GuardedRhss _ rhss) = grNamePortToGrRef <$> evalGuardedRhss c rhss -rhsWithBinds :: Show l => Maybe (Binds l) -> Rhs l -> EvalContext -> State IDState GraphAndRef +rhsWithBinds :: Show l => + Maybe (Binds l) -> Rhs l -> EvalContext -> State IDState GraphAndRef rhsWithBinds maybeWhereBinds rhs rhsContext = case maybeWhereBinds of Nothing -> evalRhs rhsContext rhs Just b -> evalGeneralLet (`evalRhs` rhs) rhsContext b @@ -495,22 +560,38 @@ rhsWithBinds maybeWhereBinds rhs rhsContext = case maybeWhereBinds of -- BEGIN evalCase --- TODO patRhsAreConnected is sometimes incorrectly true if the pat is just a name -evalPatAndRhs :: Show l => EvalContext -> Pat l-> Rhs l -> Maybe (Binds l) -> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String) +-- TODO patRhsAreConnected is sometimes incorrectly true if the pat is just a +-- name +evalPatAndRhs :: Show l => + EvalContext + -> Pat l + -> Rhs l + -> Maybe (Binds l) + -> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String) evalPatAndRhs c pat rhs maybeWhereBinds = do ((GraphAndRef patGraph patRef, mPatAsName), GraphAndRef rhsGraph rhsRef) <- bindOrAltHelper c pat rhs maybeWhereBinds let grWithEdges = makeEdges (rhsGraph <> patGraph) lookedUpRhsRef = lookupReference (sgBinds grWithEdges) rhsRef - -- The pattern and rhs are conneted if makeEdges added extra edges, or if the rhsRef refers to a source - -- in the pattern - patRhsAreConnected = (rhsRef /= lookedUpRhsRef) || - length (sgEdges grWithEdges) > (length (sgEdges rhsGraph) + length (sgEdges patGraph)) - pure (patRhsAreConnected, deleteBindings grWithEdges, patRef, lookedUpRhsRef, mPatAsName) + -- The pattern and rhs are conneted if makeEdges added extra edges, or if + -- the rhsRef refers to a source in the pattern. + patRhsAreConnected + = (rhsRef /= lookedUpRhsRef) + || ( length (sgEdges grWithEdges) + > + (length (sgEdges rhsGraph) + length (sgEdges patGraph))) + pure (patRhsAreConnected + , deleteBindings grWithEdges + , patRef + , lookedUpRhsRef + , mPatAsName) -- returns (combined graph, pattern reference, rhs reference) -evalAlt :: Show l => EvalContext -> Exts.Alt l -> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String) +evalAlt :: Show l => + EvalContext + -> Exts.Alt l + -> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String) evalAlt c (Exts.Alt _ pat rhs maybeBinds) = evalPatAndRhs c pat rhs maybeBinds evalCaseHelper :: @@ -520,37 +601,50 @@ evalCaseHelper :: -> GraphAndRef -> [(Bool, SyntaxGraph, Reference, Reference, Maybe String)] -> (SyntaxGraph, NameAndPort) -evalCaseHelper numAlts caseIconName resultIconNames (GraphAndRef expGraph expRef) evaledAlts = result where - (patRhsConnected, altGraphs, patRefs, rhsRefs, asNames) = unzip5 evaledAlts - combindedAltGraph = mconcat altGraphs - caseNode = CaseNode numAlts - icons = [SgNamedNode caseIconName caseNode] - caseGraph = syntaxGraphFromNodes icons - expEdge = (expRef, nameAndPort caseIconName (inputPort caseNode)) - patEdges = zip patRefs $ map (nameAndPort caseIconName) casePatternPorts - rhsEdges = zip patRhsConnected $ zip rhsRefs $ map (nameAndPort caseIconName) caseRhsPorts - (connectedRhss, unConnectedRhss) = partition fst rhsEdges +evalCaseHelper numAlts caseIconName resultIconNames + (GraphAndRef expGraph expRef) evaledAlts + = result + where + (patRhsConnected, altGraphs, patRefs, rhsRefs, asNames) = unzip5 evaledAlts + combindedAltGraph = mconcat altGraphs + caseNode = CaseNode numAlts + icons = [SgNamedNode caseIconName caseNode] + caseGraph = syntaxGraphFromNodes icons + expEdge = (expRef, nameAndPort caseIconName (inputPort caseNode)) + patEdges = zip patRefs $ map (nameAndPort caseIconName) casePatternPorts + rhsEdges = zip patRhsConnected $ zip rhsRefs + $ map (nameAndPort caseIconName) caseRhsPorts + (connectedRhss, unConnectedRhss) = partition fst rhsEdges - makeCaseResult :: NodeName -> Reference -> SyntaxGraph - makeCaseResult resultIconName rhsRef = case rhsRef of - Left _ -> mempty - Right rhsPort -> syntaxGraphFromNodesEdges rhsNewIcons rhsNewEdges - where - rhsNewIcons = [SgNamedNode resultIconName CaseResultNode] - rhsNewEdges = [makeSimpleEdge (rhsPort, justName resultIconName)] + makeCaseResult :: NodeName -> Reference -> SyntaxGraph + makeCaseResult resultIconName rhsRef = case rhsRef of + Left _ -> mempty + Right rhsPort -> syntaxGraphFromNodesEdges rhsNewIcons rhsNewEdges + where + rhsNewIcons = [SgNamedNode resultIconName CaseResultNode] + rhsNewEdges = [makeSimpleEdge (rhsPort, justName resultIconName)] - caseResultGraphs = mconcat $ zipWith makeCaseResult resultIconNames (fmap (fst . snd) connectedRhss) - filteredRhsEdges = fmap snd unConnectedRhss - patternEdgesGraph = edgesForRefPortList True patEdges - caseEdgeGraph = edgesForRefPortList False (expEdge : filteredRhsEdges) + caseResultGraphs = + mconcat + $ zipWith makeCaseResult resultIconNames (fmap (fst . snd) connectedRhss) + filteredRhsEdges = fmap snd unConnectedRhss + patternEdgesGraph = edgesForRefPortList True patEdges + caseEdgeGraph = edgesForRefPortList False (expEdge : filteredRhsEdges) - bindGraph = makeAsBindGraph expRef asNames + bindGraph = makeAsBindGraph expRef asNames - finalGraph = deleteBindings $ makeEdges $ mconcat [bindGraph, patternEdgesGraph, caseResultGraphs, expGraph, caseEdgeGraph, caseGraph, combindedAltGraph] - result = (finalGraph, nameAndPort caseIconName (resultPort caseNode)) + finalGraph = deleteBindings $ makeEdges $ mconcat [bindGraph + , patternEdgesGraph + , caseResultGraphs + , expGraph + , caseEdgeGraph + , caseGraph + , combindedAltGraph] + result = (finalGraph, nameAndPort caseIconName (resultPort caseNode)) -evalCase :: Show l => EvalContext -> Exp l -> [Alt l] -> State IDState (SyntaxGraph, NameAndPort) +evalCase :: Show l => + EvalContext -> Exp l -> [Alt l] -> State IDState (SyntaxGraph, NameAndPort) evalCase c e alts = let numAlts = length alts @@ -567,7 +661,8 @@ evalCase c e alts = -- END evalCase -evalTuple :: Show l => EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort) +evalTuple :: Show l => + EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort) evalTuple c exps = let numExps = length exps @@ -580,7 +675,8 @@ evalTuple c exps = <*> mapM (evalExp c) exps -evalTupleSection :: Show l => EvalContext -> [Maybe (Exp l)] -> State IDState (SyntaxGraph, NameAndPort) +evalTupleSection :: Show l => + EvalContext -> [Maybe (Exp l)] -> State IDState (SyntaxGraph, NameAndPort) evalTupleSection c mExps = let exps = catMaybes mExps @@ -594,14 +690,20 @@ evalTupleSection c mExps = <*> mapM (evalExp c) exps -evalListExp :: Show l => l -> EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort) +evalListExp :: Show l => + l -> EvalContext -> [Exp l] -> State IDState (SyntaxGraph, NameAndPort) evalListExp _ _ [] = makeBox "[]" -evalListExp l c exps = evalFunExpAndArgs c ApplyNodeFlavor (makeVarExp l . nListString . length $ exps, exps) +evalListExp l c exps = evalFunExpAndArgs + c + ApplyNodeFlavor + (makeVarExp l . nListString . length $ exps, exps) -evalLeftSection :: Show l => l -> EvalContext -> Exp l -> QOp l -> State IDState GraphAndRef +evalLeftSection :: Show l => + l -> EvalContext -> Exp l -> QOp l -> State IDState GraphAndRef evalLeftSection l c e op = evalExp c $ App l (qOpToExp op) e -evalRightSection :: Show l => EvalContext -> QOp l -> Exp l -> State IDState (SyntaxGraph, NameAndPort) +evalRightSection :: Show l => + EvalContext -> QOp l -> Exp l -> State IDState (SyntaxGraph, NameAndPort) evalRightSection c op e = makeApplyGraph 2 ApplyNodeFlavor False <$> @@ -610,15 +712,19 @@ evalRightSection c op e = evalExp c (qOpToExp op) <*> ((\x y -> [x, y]) <$> - -- TODO: A better option would be for makeApplyGraph to take the list of expressions as Maybes. + -- TODO: A better option would be for makeApplyGraph to take the list of + -- expressions as Maybes. fmap (GraphAndRef mempty . Left) (getUniqueString "unusedArgument") <*> evalExp c e ) -- evalEnums is only used by evalExp -evalEnums :: Show l => l -> EvalContext -> String -> [Exp l] -> State IDState GraphAndRef -evalEnums l c s exps = grNamePortToGrRef <$> evalFunExpAndArgs c ApplyNodeFlavor (makeVarExp l s, exps) +evalEnums :: Show l => + l -> EvalContext -> String -> [Exp l] -> State IDState GraphAndRef +evalEnums l c s exps + = grNamePortToGrRef + <$> evalFunExpAndArgs c ApplyNodeFlavor (makeVarExp l s, exps) desugarDo :: Show l => [Stmt l] -> Exp l desugarDo [Qualifier _ e] = e @@ -630,7 +736,8 @@ desugarDo (LetStmt l binds : stmts) = Let l binds (desugarDo stmts) desugarDo stmts = error $ "Unsupported syntax in degugarDo: " <> show stmts -- TODO: Finish evalRecConstr -evalRecConstr :: Show l => EvalContext -> QName l -> [Exts.FieldUpdate l] -> State IDState GraphAndRef +evalRecConstr :: Show l => + EvalContext -> QName l -> [Exts.FieldUpdate l] -> State IDState GraphAndRef evalRecConstr c qName _ = evalQName qName c -- BEGIN generalEvalLambda @@ -679,8 +786,10 @@ generalEvalLambda context patterns rhsEvalFun = do pure (combinedGraph, nameAndPort lambdaName (resultPort lambdaNode)) where - -- TODO Like evalPatBind, this edge should have an indicator that it is the input to a pattern. - -- makePatternEdges creates the edges between the patterns and the parameter ports. + -- TODO Like evalPatBind, this edge should have an indicator that it is the + -- input to a pattern. + -- makePatternEdges creates the edges between the patterns and the parameter + -- ports. makePatternEdges :: GraphAndRef -> NameAndPort -> Either Edge SgBind makePatternEdges (GraphAndRef _ ref) lamPort = case ref of Right patPort -> Left $ makeSimpleEdge (lamPort, patPort) @@ -688,7 +797,8 @@ generalEvalLambda context patterns rhsEvalFun = do -- END generalEvalLambda -evalLambda :: Show l => EvalContext -> [Pat l] -> Exp l -> State IDState (SyntaxGraph, NameAndPort) +evalLambda :: Show l => + EvalContext -> [Pat l] -> Exp l -> State IDState (SyntaxGraph, NameAndPort) evalLambda c patterns e = generalEvalLambda c patterns (`evalExp` e) evalExp :: Show l => EvalContext -> Exp l -> State IDState GraphAndRef @@ -764,13 +874,15 @@ evalMatch c (Match _ name patterns rhs maybeWhereBinds) = do (lambdaGraph, lambdaPort) <- generalEvalLambda newContext patterns (rhsWithBinds maybeWhereBinds rhs) let - newBinding = bindsToSyntaxGraph [SgBind matchFunNameString (Right lambdaPort)] + newBinding + = bindsToSyntaxGraph [SgBind matchFunNameString (Right lambdaPort)] pure $ makeEdges (newBinding <> lambdaGraph) evalMatch _ match = error $ "Unsupported syntax in evalMatch: " <> show match evalMatches :: Show l => EvalContext -> [Match l] -> State IDState SyntaxGraph evalMatches _ [] = pure mempty -evalMatches c (firstMatch:restOfMatches) = matchesToCase firstMatch restOfMatches >>= evalMatch c +evalMatches c (firstMatch:restOfMatches) + = matchesToCase firstMatch restOfMatches >>= evalMatch c -- END evalMatches @@ -798,7 +910,8 @@ evalTypeSig (TypeSig _ names typeForNames) = makeBox ++ prettyPrintWithoutNewlines typeForNames) where -- TODO Make custom version of prettyPrint for type signitures. - -- Use (unwords . words) to convert consecutive whitspace characters to one space + -- Use (unwords . words) to convert consecutive whitspace characters to one + -- space. prettyPrintWithoutNewlines = unwords . words . prettyPrint evalTypeSig decl = error $ "Unsupported syntax in evalTypeSig: " <> show decl @@ -855,16 +968,20 @@ syntaxGraphToCollapsedGraph :: SyntaxGraph -> IngSyntaxGraph FGR.Gr syntaxGraphToCollapsedGraph = collapseNodes . syntaxGraphToFglGraph translateDeclToCollapsedGraph :: Show l => Decl l -> IngSyntaxGraph FGR.Gr -translateDeclToCollapsedGraph = syntaxGraphToCollapsedGraph . translateDeclToSyntaxGraph +translateDeclToCollapsedGraph + = syntaxGraphToCollapsedGraph . translateDeclToSyntaxGraph -- Profiling: At one point, this was about 1.5% of total time. -translateStringToCollapsedGraphAndDecl :: String -> (IngSyntaxGraph FGR.Gr, Decl Exts.SrcSpanInfo) +translateStringToCollapsedGraphAndDecl :: + String -> (IngSyntaxGraph FGR.Gr, Decl Exts.SrcSpanInfo) translateStringToCollapsedGraphAndDecl s = (drawing, decl) where decl = customParseDecl s -- :: ParseResult Module drawing = translateDeclToCollapsedGraph decl -translateModuleToCollapsedGraphs :: Show l => Module l -> [IngSyntaxGraph FGR.Gr] -translateModuleToCollapsedGraphs (Module _ _ _ _ decls) = fmap translateDeclToCollapsedGraph decls +translateModuleToCollapsedGraphs :: Show l => + Module l -> [IngSyntaxGraph FGR.Gr] +translateModuleToCollapsedGraphs (Module _ _ _ _ decls) + = fmap translateDeclToCollapsedGraph decls translateModuleToCollapsedGraphs moduleSyntax = error $ "Unsupported syntax in translateModuleToCollapsedGraphs: " <> show moduleSyntax diff --git a/app/TranslateCore.hs b/app/TranslateCore.hs index 0aaba45..a94e509 100644 --- a/app/TranslateCore.hs +++ b/app/TranslateCore.hs @@ -13,14 +13,12 @@ module TranslateCore( getUniqueString, edgesForRefPortList, combineExpressions, - --qualifyNameAndPort, makeApplyGraph, makeGuardGraph, namesInPattern, lookupReference, deleteBindings, makeEdges, - --makeEdgesCore, makeBox, nTupleString, nTupleSectionString, @@ -32,17 +30,19 @@ module TranslateCore( import Control.Monad.State(State, state) import Data.Either(partitionEithers) -import qualified Data.Graph.Inductive.PatriciaTree as FGR import qualified Data.Graph.Inductive.Graph as ING +import qualified Data.Graph.Inductive.PatriciaTree as FGR import Data.List(find) import Data.Semigroup(Semigroup, (<>)) -import Types(Labeled(..), Icon, SyntaxNode(..), Edge(..), EdgeOption(..), - NameAndPort(..), IDState, SgNamedNode(..), NodeName(..), Port, - LikeApplyFlavor(..), CaseOrGuardTag(..), IDState(..), NamedIcon(..)) +import Icons(inputPort, resultPort, argumentPorts, guardRhsPorts + , guardBoolPorts) +import Types(Labeled(..), Icon(..), SyntaxNode(..), Edge(..), EdgeOption(..) + , NameAndPort(..), IDState, SgNamedNode(..), NodeName(..), Port + , LikeApplyFlavor(..), CaseOrGuardTag(..), IDState(..) + , NamedIcon(..)) import Util(noEnds, nameAndPort, makeSimpleEdge, justName, maybeBoolToBool , mapNodeInNamedNode, nodeNameToInt) -import Icons(Icon(..), inputPort, resultPort, argumentPorts, guardRhsPorts, guardBoolPorts) {-# ANN module "HLint: ignore Use list comprehension" #-} @@ -73,8 +73,15 @@ data SyntaxGraph = SyntaxGraph { } deriving (Show, Eq) instance Semigroup SyntaxGraph where - (SyntaxGraph icons1 edges1 sinks1 sources1 map1) <> (SyntaxGraph icons2 edges2 sinks2 sources2 map2) = - SyntaxGraph (icons1 <> icons2) (edges1 <> edges2) (sinks1 <> sinks2) (sources1 <> sources2) (map1 <> map2) + (<>) + (SyntaxGraph icons1 edges1 sinks1 sources1 map1) + (SyntaxGraph icons2 edges2 sinks2 sources2 map2) + = SyntaxGraph + (icons1 <> icons2) + (edges1 <> edges2) + (sinks1 <> sinks2) + (sources1 <> sources2) + (map1 <> map2) instance Monoid SyntaxGraph where mempty = SyntaxGraph mempty mempty mempty mempty mempty @@ -94,7 +101,8 @@ syntaxGraphFromNodes :: [SgNamedNode] -> SyntaxGraph syntaxGraphFromNodes icons = SyntaxGraph icons mempty mempty mempty mempty syntaxGraphFromNodesEdges :: [SgNamedNode] -> [Edge] -> SyntaxGraph -syntaxGraphFromNodesEdges icons edges = SyntaxGraph icons edges mempty mempty mempty +syntaxGraphFromNodesEdges icons edges + = SyntaxGraph icons edges mempty mempty mempty bindsToSyntaxGraph :: [SgBind] -> SyntaxGraph bindsToSyntaxGraph binds = SyntaxGraph mempty mempty mempty binds mempty @@ -134,46 +142,70 @@ getUniqueString base = fmap ((base ++). show) getId -- TODO: Refactor with combineExpressions edgesForRefPortList :: Bool -> [(Reference, NameAndPort)] -> SyntaxGraph -edgesForRefPortList inPattern portExpPairs = mconcat $ fmap makeGraph portExpPairs where - edgeOpts = if inPattern then [EdgeInPattern] else [] - makeGraph (ref, port) = case ref of - Left str -> if inPattern - then bindsToSyntaxGraph [SgBind str (Right port)] - else sinksToSyntaxGraph [SgSink str port] - Right resPort -> edgesToSyntaxGraph [Edge edgeOpts noEnds connection] where - connection = if inPattern - -- If in a pattern, then the port on the case icon is the data source. - then (port, resPort) - else (resPort, port) +edgesForRefPortList inPattern portExpPairs + = mconcat $ fmap makeGraph portExpPairs + where + edgeOpts = if inPattern then [EdgeInPattern] else [] + makeGraph (ref, port) = case ref of + Left str -> if inPattern + then bindsToSyntaxGraph [SgBind str (Right port)] + else sinksToSyntaxGraph [SgSink str port] + Right resPort -> edgesToSyntaxGraph [Edge edgeOpts noEnds connection] + where + connection = if inPattern + -- If in a pattern, then the port on the case icon is + -- the data source. + then (port, resPort) + else (resPort, port) combineExpressions :: Bool -> [(GraphAndRef, NameAndPort)] -> SyntaxGraph -combineExpressions inPattern portExpPairs = mconcat $ fmap makeGraph portExpPairs where - edgeOpts = if inPattern then [EdgeInPattern] else [] - makeGraph (GraphAndRef graph ref, port) = graph <> case ref of - Left str -> if inPattern - then bindsToSyntaxGraph [SgBind str (Right port)] - else sinksToSyntaxGraph [SgSink str port] - Right resPort -> edgesToSyntaxGraph [Edge edgeOpts noEnds (resPort, port)] +combineExpressions inPattern portExpPairs + = mconcat $ fmap makeGraph portExpPairs + where + edgeOpts = if inPattern then [EdgeInPattern] else [] + makeGraph (GraphAndRef graph ref, port) = graph <> case ref of + Left str -> if inPattern + then bindsToSyntaxGraph [SgBind str (Right port)] + else sinksToSyntaxGraph [SgSink str port] + Right resPort -> edgesToSyntaxGraph [Edge edgeOpts noEnds (resPort, port)] -makeApplyGraph :: Int -> LikeApplyFlavor -> Bool -> NodeName -> GraphAndRef -> [GraphAndRef] -> (SyntaxGraph, NameAndPort) -makeApplyGraph numArgs applyFlavor inPattern applyIconName funVal argVals = (newGraph <> combinedGraph, nameAndPort applyIconName (resultPort applyNode)) +makeApplyGraph :: + Int + -> LikeApplyFlavor + -> Bool + -> NodeName + -> GraphAndRef + -> [GraphAndRef] + -> (SyntaxGraph, NameAndPort) +makeApplyGraph numArgs applyFlavor inPattern applyIconName funVal argVals + = (newGraph <> combinedGraph + , nameAndPort applyIconName (resultPort applyNode) + ) where applyNode = LikeApplyNode applyFlavor numArgs - argumentNamePorts = map (nameAndPort applyIconName) (argumentPorts applyNode) + argumentNamePorts + = map (nameAndPort applyIconName) (argumentPorts applyNode) functionPort = nameAndPort applyIconName (inputPort applyNode) - combinedGraph = combineExpressions inPattern $ zip (funVal:argVals) (functionPort:argumentNamePorts) + combinedGraph = combineExpressions inPattern + $ zip (funVal:argVals) (functionPort:argumentNamePorts) icons = [SgNamedNode applyIconName applyNode] newGraph = syntaxGraphFromNodes icons makeGuardGraph :: - Int -> NodeName -> [GraphAndRef] -> [GraphAndRef] -> (SyntaxGraph, NameAndPort) -makeGuardGraph numPairs guardName bools exps = (newGraph, nameAndPort guardName (resultPort guardNode)) where - guardNode = GuardNode numPairs - expsWithPorts = zip exps $ map (nameAndPort guardName) guardRhsPorts - boolsWithPorts = zip bools $ map (nameAndPort guardName) guardBoolPorts - combindedGraph = combineExpressions False $ expsWithPorts <> boolsWithPorts - icons = [SgNamedNode guardName guardNode] - newGraph = syntaxGraphFromNodes icons <> combindedGraph + Int + -> NodeName + -> [GraphAndRef] + -> [GraphAndRef] + -> (SyntaxGraph, NameAndPort) +makeGuardGraph numPairs guardName bools exps + = (newGraph, nameAndPort guardName (resultPort guardNode)) + where + guardNode = GuardNode numPairs + expsWithPorts = zip exps $ map (nameAndPort guardName) guardRhsPorts + boolsWithPorts = zip bools $ map (nameAndPort guardName) guardBoolPorts + combindedGraph = combineExpressions False $ expsWithPorts <> boolsWithPorts + icons = [SgNamedNode guardName guardNode] + newGraph = syntaxGraphFromNodes icons <> combindedGraph namesInPatternHelper :: GraphAndRef -> [String] namesInPatternHelper (GraphAndRef graph ref) = case ref of @@ -207,18 +239,18 @@ makeEdgesCore :: [SgSink] -> [SgBind] -> ([SgSink], [Edge]) makeEdgesCore sinks bindings = partitionEithers $ fmap renameOrMakeEdge sinks where renameOrMakeEdge :: SgSink -> Either SgSink Edge - renameOrMakeEdge orig@(SgSink s destPort) = case lookup s (fmap sgBindToTuple bindings) of - Just ref -> case lookupReference bindings ref of - (Right sourcePort) -> Right $ makeSimpleEdge (sourcePort, destPort) - (Left newStr) -> Left $ SgSink newStr destPort - Nothing -> Left orig + renameOrMakeEdge orig@(SgSink s destPort) + = case lookup s (fmap sgBindToTuple bindings) of + Just ref -> case lookupReference bindings ref of + Right sourcePort -> Right $ makeSimpleEdge (sourcePort, destPort) + Left newStr -> Left $ SgSink newStr destPort + Nothing -> Left orig makeEdges :: SyntaxGraph -> SyntaxGraph makeEdges (SyntaxGraph icons edges sinks bindings eMap) = newGraph where (newSinks, newEdges) = makeEdgesCore sinks bindings newGraph = SyntaxGraph icons (newEdges <> edges) newSinks bindings eMap --- TODO: remove / change due toSyntaxGraph makeBox :: String -> State IDState (SyntaxGraph, NameAndPort) makeBox str = do name <- getUniqueName @@ -265,7 +297,8 @@ nodeToIcon (NestedCaseOrGuardNode tag x edges) makeArg :: [(SgNamedNode, Edge)] -> Port -> Maybe NamedIcon makeArg args port = case find (findArg port) args of Nothing -> Nothing - Just (SgNamedNode argName argSyntaxNode, _) -> Just $ NamedIcon argName (nodeToIcon argSyntaxNode) + Just (SgNamedNode argName argSyntaxNode, _) + -> Just $ NamedIcon argName (nodeToIcon argSyntaxNode) nestedApplySyntaxNodeToIcon :: LikeApplyFlavor -> Int @@ -279,7 +312,11 @@ nestedApplySyntaxNodeToIcon flavor numArgs args = headIcon = makeArg args (inputPort dummyNode) argList = fmap (makeArg args) argPorts -nestedCaseOrGuardNodeToIcon :: CaseOrGuardTag -> Int -> [(SgNamedNode, Edge)] -> Icon +nestedCaseOrGuardNodeToIcon :: + CaseOrGuardTag + -> Int + -> [(SgNamedNode, Edge)] + -> Icon nestedCaseOrGuardNodeToIcon tag numArgs args = case tag of CaseTag -> NestedCaseIcon argList GuardTag -> NestedGuardIcon argList @@ -296,7 +333,9 @@ nestedPatternNodeToIcon str children = NestedPApp children) findArg :: Port -> (SgNamedNode, Edge) -> Bool -findArg currentPort (SgNamedNode argName _, Edge _ _ (NameAndPort fromName fromPort, NameAndPort toName toPort)) +findArg currentPort + (SgNamedNode argName _ + , Edge _ _ (NameAndPort fromName fromPort, NameAndPort toName toPort)) | argName == fromName = maybeBoolToBool $ fmap (== currentPort) toPort | argName == toName = maybeBoolToBool $ fmap (== currentPort) fromPort | otherwise = False -- This case should never happen @@ -309,7 +348,8 @@ lookupInEmbeddingMap origName eMap = lookupHelper origName where lookupHelper name = case lookup name eMap of Nothing -> name Just parent -> if parent == origName - then error $ "lookupInEmbeddingMap: Found cycle. Node = " ++ show origName ++ "\nEmbedding Map = " ++ show eMap + then error $ "lookupInEmbeddingMap: Found cycle. Node = " + ++ show origName ++ "\nEmbedding Map = " ++ show eMap else lookupHelper parent syntaxGraphToFglGraph :: SyntaxGraph -> FGR.Gr SgNamedNode Edge @@ -318,4 +358,6 @@ syntaxGraphToFglGraph (SyntaxGraph nodes edges _ _ eMap) = labeledEdges = fmap makeLabeledEdge edges makeLabeledEdge e@(Edge _ _ (NameAndPort name1 _, NameAndPort name2 _)) = - (nodeNameToInt $ lookupInEmbeddingMap name1 eMap, nodeNameToInt $ lookupInEmbeddingMap name2 eMap, e) + (nodeNameToInt $ lookupInEmbeddingMap name1 eMap + , nodeNameToInt $ lookupInEmbeddingMap name2 eMap + , e) diff --git a/app/Util.hs b/app/Util.hs index 036193e..737939f 100644 --- a/app/Util.hs +++ b/app/Util.hs @@ -1,20 +1,13 @@ {-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies #-} module Util ( - portToPort, + printSelf, iconToPort, - iconToIcon, - iconToIconEnds, - --iconHeadToPort, - iconTailToPort, makeSimpleEdge, noEnds, nameAndPort, justName, fromMaybeError, - mapFst, - printSelf, - eitherToMaybes, maybeBoolToBool, mapNodeInNamedNode, sgNamedNodeToSyntaxNode, @@ -22,24 +15,19 @@ module Util ( customRenderSVG, namedIconToTuple, tupleToNamedIcon -)where + ) where import Diagrams.Backend.SVG(renderSVG', Options(..), SVG) -import Graphics.Svg.Attributes(bindAttr, AttrTag(..)) import qualified Diagrams.Prelude as Dia +import Graphics.Svg.Attributes(bindAttr, AttrTag(..)) -import Control.Arrow(first) --- import Diagrams.Prelude(IsName, toName, Name) import Data.Maybe(fromMaybe) -import qualified Debug.Trace import Data.Text(pack) import Data.Typeable(Typeable) +import qualified Debug.Trace -import Types(EdgeEnd(..), Edge(..), NameAndPort(..), Connection, NodeName(..), Port, - SyntaxNode, SgNamedNode(..), NamedIcon(..), Icon(..)) - -mapFst :: Functor f => (a -> b) -> f (a, c) -> f (b, c) -mapFst f = fmap (first f) +import Types(EdgeEnd(..), Edge(..), NameAndPort(..), Connection, NodeName(..) + , Port, SyntaxNode, SgNamedNode(..), NamedIcon(..), Icon(..)) noEnds :: (EdgeEnd, EdgeEnd) noEnds = (EndNone, EndNone) @@ -54,27 +42,9 @@ justName :: NodeName -> NameAndPort justName n = NameAndPort n Nothing -- BEGIN Edge constructors -- -portToPort :: NodeName -> Port -> NodeName -> Port -> Edge -portToPort a b c d = makeSimpleEdge (nameAndPort a b, nameAndPort c d) - iconToPort :: NodeName -> NodeName -> Port -> Edge iconToPort a c d = makeSimpleEdge (justName a, nameAndPort c d) -iconToIcon :: NodeName -> NodeName -> Edge -iconToIcon a c = makeSimpleEdge (justName a, justName c) - - --- If there are gaps between the arrow and the icon, try switching the first two arguments --- with the last two arguments -iconToIconEnds :: NodeName -> EdgeEnd -> NodeName -> EdgeEnd -> Edge -iconToIconEnds a b c d = Edge [] (b, d) (justName a, justName c) - --- iconHeadToPort :: (IsName a, IsName b) => a -> EdgeEnd -> b -> Int -> Edge --- iconHeadToPort a endHead c d = Edge (justName a, nameAndPort c d) (EndNone, endHead) - -iconTailToPort :: NodeName -> EdgeEnd -> NodeName -> Port -> Edge -iconTailToPort a endTail c d = Edge [] (endTail, EndNone) (justName a, nameAndPort c d) - -- END Edge constructors -- fromMaybeError :: String -> Maybe a -> a @@ -83,10 +53,6 @@ fromMaybeError s = fromMaybe (error s) printSelf :: (Show a) => a -> a printSelf a = Debug.Trace.trace (show a ++ "\n\n") a -eitherToMaybes :: Either a b -> (Maybe a, Maybe b) -eitherToMaybes (Left x) = (Just x, Nothing) -eitherToMaybes (Right y) = (Nothing, Just y) - -- | (Just True) = True, Nothing = False maybeBoolToBool :: Maybe Bool -> Bool maybeBoolToBool = or @@ -114,5 +80,6 @@ customRenderSVG :: (Typeable n, Show n, RealFloat n) => customRenderSVG outputFilename size = renderSVG' outputFilename svgOptions where -- This xml:space attribute preserves the whitespace in the svg text. attributes = [bindAttr XmlSpace_ (pack "preserve")] - -- TODO Look at the source of renderSVG to see what the 3rd argument to SVGOptions should be + -- TODO Look at the source of renderSVG to see what the 3rd argument to + -- SVGOptions should be svgOptions = SVGOptions size Nothing (pack "") attributes True diff --git a/test/VisualRenderingTests.hs b/test/VisualRenderingTests.hs index 9559e72..441ed4d 100644 --- a/test/VisualRenderingTests.hs +++ b/test/VisualRenderingTests.hs @@ -3,8 +3,7 @@ module VisualRenderingTests ( renderTests ) where - -import Diagrams.Prelude hiding ((#), (&)) +import qualified Diagrams.Prelude as Dia import Rendering (renderDrawing) import Types (Labeled(..), NodeName(..), Drawing(..), Edge, Icon(..), Port(..) @@ -13,16 +12,17 @@ import Types (Labeled(..), NodeName(..), Drawing(..), Edge, Icon(..), Port(..) import Util(iconToPort, tupleToNamedIcon) - iconToIntPort :: NodeName -> NodeName -> Int -> Edge iconToIntPort x y p = iconToPort x y (Port p) n0, n1, _n2, n3, _n4, n5, _n6, _n7, _n8, _n9, n10 :: NodeName nodeNames :: [NodeName] -nodeNames@[n0, n1, _n2, n3, _n4, n5, _n6, _n7, _n8, _n9, n10] = fmap NodeName [0..10] +nodeNames@[n0, n1, _n2, n3, _n4, n5, _n6, _n7, _n8, _n9, n10] + = fmap NodeName [0..10] ni0, ni1, ni2, ni3, ni4, ni5, ni6, ni7, ni8, ni9, ni10 :: Icon -> NamedIcon -[ni0, ni1, ni2, ni3, ni4, ni5, ni6, ni7, ni8, ni9, ni10] = fmap NamedIcon nodeNames +[ni0, ni1, ni2, ni3, ni4, ni5, ni6, ni7, ni8, ni9, ni10] + = fmap NamedIcon nodeNames -- TODO refactor these Drawings nestedCaseDrawing :: Drawing @@ -101,7 +101,6 @@ nestedApplyDia = Drawing icons [] ApplyNodeFlavor (Just $ NamedIcon (NodeName 1) (TextBoxIcon "foo")) []) - --[Just $ NamedIcon (NodeName 1) (TextBoxIcon "bar")]) ] lambdaDia :: Drawing @@ -118,7 +117,7 @@ lambdaDia = Drawing icons [] renderTests :: SpecialBackend b Double => IO (SpecialQDiagram b Double) renderTests = do renderedDiagrams <- traverse renderDrawing allDrawings - let vCattedDrawings = vsep 0.5 renderedDiagrams + let vCattedDrawings = Dia.vsep 0.5 renderedDiagrams pure vCattedDrawings where allDrawings = [