Cleanup and improve formatting.

This commit is contained in:
Robbie Gleichman 2018-11-11 23:13:19 -08:00
parent 5b8d4d598c
commit 9e7d01ab82
7 changed files with 493 additions and 291 deletions

View File

@ -2,7 +2,6 @@
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies, ScopedTypeVariables #-}
module Icons
(
Icon(..),
TransformParams(..),
TransformableDia,
getPortAngles,

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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 = [