mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Replace NamedIcons with NodeNames in some Icon constructors.
This commit is contained in:
parent
c1e1682b1d
commit
b63cdef55e
@ -6,7 +6,6 @@ module GraphAlgorithms(
|
||||
collapseAnnotatedGraph
|
||||
) where
|
||||
|
||||
import qualified Control.Arrow as Arrow
|
||||
import qualified Data.Graph.Inductive as ING
|
||||
import Data.List(foldl', find)
|
||||
import Data.Tuple(swap)
|
||||
@ -15,7 +14,7 @@ import GHC.Stack(HasCallStack)
|
||||
import Constants(pattern ResultPortConst, pattern InputPortConst)
|
||||
import Types(SyntaxNode(..), IngSyntaxGraph, Edge(..),
|
||||
CaseOrMultiIfTag(..), Port(..), NameAndPort(..), SgNamedNode(..)
|
||||
, AnnotatedGraph, EmbedInfo(..), EmbedDirection(..))
|
||||
, AnnotatedGraph, EmbedInfo(..), EmbedDirection(..), NodeInfo(..))
|
||||
import Util(sgNamedNodeToSyntaxNode)
|
||||
|
||||
{-# ANN module "HLint: ignore Use record patterns" #-}
|
||||
@ -55,7 +54,7 @@ syntaxNodeIsEmbeddable parentType syntaxNode mParentPort mChildPort
|
||||
|
||||
-- (LambdaParent, ApplyNode _ _ _) -> parentPortIsInput
|
||||
-- (LambdaParent, LiteralNode _) -> parentPortIsInput
|
||||
-- (LambdaParent, FunctionDefNode _ _)
|
||||
-- (LambdaParent, FunctionDefNode _ _ _)
|
||||
-- -> parentPortIsInput
|
||||
|
||||
(CaseParent, LiteralNode _) -> parentPortNotResult
|
||||
@ -140,7 +139,8 @@ findEmbedDir gr fromNode toNode e = if
|
||||
-> Just EdEmbedFrom
|
||||
| otherwise -> Nothing
|
||||
|
||||
annotateGraph :: ING.DynGraph gr => IngSyntaxGraph gr -> AnnotatedGraph gr
|
||||
|
||||
annotateGraph :: ING.DynGraph gr => IngSyntaxGraph gr -> gr SgNamedNode (EmbedInfo Edge)
|
||||
annotateGraph gr = ING.gmap edgeMapper gr
|
||||
where
|
||||
edgeMapper :: ING.Context SgNamedNode Edge
|
||||
@ -166,12 +166,29 @@ findEdgeLabel graph node1 node2 = fmap fst matchingEdges where
|
||||
matchingEdges = find ((== node2) . snd) labelledEdges
|
||||
|
||||
-- | Replace the a node's label
|
||||
changeNodeLabel :: ING.DynGraph gr => gr a b -> ING.Node -> a -> gr a b
|
||||
changeNodeLabel graph node newLabel = case ING.match node graph of
|
||||
changeNodeLabel :: ING.DynGraph gr => ING.Node -> a -> gr a b -> gr a b
|
||||
changeNodeLabel node newLabel graph = case ING.match node graph of
|
||||
(Just (inEdges, _, _, outEdges), restOfTheGraph)
|
||||
-> (inEdges, node, newLabel, outEdges) ING.& restOfTheGraph
|
||||
(Nothing, _) -> graph
|
||||
|
||||
-- TODO Wrap the SyntaxNodes in an Embedder type so that this function does not
|
||||
-- require pattern matching.
|
||||
addChildrenToNodeLabel :: [(SgNamedNode, Edge)] -> SyntaxNode -> SyntaxNode
|
||||
addChildrenToNodeLabel children oldSyntaxNode = case oldSyntaxNode of
|
||||
ApplyNode flavor x existingNodes
|
||||
-> ApplyNode flavor x
|
||||
(children <> existingNodes)
|
||||
CaseOrMultiIfNode tag x existingNodes
|
||||
-> CaseOrMultiIfNode tag x
|
||||
(children <> existingNodes)
|
||||
FunctionDefNode labels existingNodes innerNodes
|
||||
-> FunctionDefNode
|
||||
labels
|
||||
(children <> existingNodes)
|
||||
innerNodes
|
||||
_ -> oldSyntaxNode
|
||||
|
||||
-- | Change the node label of the parent to be nested.
|
||||
embedChildSyntaxNode :: ING.DynGraph gr =>
|
||||
ING.Node -> ING.Node -> AnnotatedGraph gr -> AnnotatedGraph gr
|
||||
@ -180,29 +197,26 @@ embedChildSyntaxNode parentNode childNode oldGraph = newGraph
|
||||
mChildAndEdge =
|
||||
(,) <$> ING.lab oldGraph childNode
|
||||
<*> findEdgeLabel oldGraph parentNode childNode
|
||||
childrenAndEdgesToParent = case mChildAndEdge of
|
||||
Nothing -> []
|
||||
Just childAndEdge -> [Arrow.second eiVal childAndEdge]
|
||||
newGraph = case ING.lab oldGraph parentNode of
|
||||
Nothing -> oldGraph
|
||||
Just oldNodeLabel -> changeNodeLabel oldGraph parentNode newNodeLabel
|
||||
where
|
||||
SgNamedNode nodeName oldSyntaxNode = oldNodeLabel
|
||||
newNodeLabel = SgNamedNode nodeName newSyntaxNode
|
||||
newSyntaxNode = case oldSyntaxNode of
|
||||
ApplyNode flavor x existingNodes
|
||||
-> ApplyNode flavor x
|
||||
(childrenAndEdgesToParent <> existingNodes)
|
||||
CaseOrMultiIfNode tag x existingNodes
|
||||
-> CaseOrMultiIfNode tag x
|
||||
(childrenAndEdgesToParent <> existingNodes)
|
||||
FunctionDefNode labels existingNodes innerNodes
|
||||
-> FunctionDefNode
|
||||
labels
|
||||
(childrenAndEdgesToParent <> existingNodes)
|
||||
innerNodes
|
||||
_ -> oldSyntaxNode
|
||||
Nothing -> error "embedChildSyntaxNode: parentNode not found"
|
||||
Just (NodeInfo isChild oldNodeLabel) ->
|
||||
-- TODO Refactor with the Maybe Monad?
|
||||
case mChildAndEdge of
|
||||
Nothing -> error "embedChildSyntaxNode: childNode not found."
|
||||
Just (NodeInfo _ childNodeLab, EmbedInfo _ edge)
|
||||
-> changeNodeLabel childNode (NodeInfo True childNodeLab)
|
||||
$ changeNodeLabel parentNode newNodeLabel oldGraph
|
||||
where
|
||||
SgNamedNode nodeName oldSyntaxNode = oldNodeLabel
|
||||
newSyntaxNode
|
||||
= addChildrenToNodeLabel [(childNodeLab, edge)] oldSyntaxNode
|
||||
newNodeLabel = NodeInfo isChild (SgNamedNode nodeName newSyntaxNode)
|
||||
|
||||
-- TODO This is buggy since it needs to transfer edges to the root ancestor, not
|
||||
-- the immediate parent. Otherwise some edges will be between child nodes. Or
|
||||
-- better yet, don't modify the graph edges, and change the bool in NodeInfo
|
||||
-- to a Maybe Node which is the nodes parent. Use this info to find the root
|
||||
-- ancestor when needed.
|
||||
changeEdgeToParent :: ING.Node -> ING.Node -> ING.LEdge b -> ING.LEdge b
|
||||
changeEdgeToParent parentNode childNode (fromNode, toNode, lab)
|
||||
= (toParent fromNode, toParent toNode, lab)
|
||||
@ -216,7 +230,7 @@ collapseEdge :: (HasCallStack, ING.DynGraph gr)
|
||||
collapseEdge oldGraph (fromNode, toNode, e@(EmbedInfo mEmbedDir _))
|
||||
= case mEmbedDir of
|
||||
Nothing -> oldGraph
|
||||
Just embedDir -> childDeletedGraph
|
||||
Just embedDir -> graphWithEdgesTransferred
|
||||
where
|
||||
(parentNode, childNode) = parentAndChild embedDir (fromNode, toNode)
|
||||
childEmbeddedGraph
|
||||
@ -228,13 +242,13 @@ collapseEdge oldGraph (fromNode, toNode, e@(EmbedInfo mEmbedDir _))
|
||||
(ING.inn oldGraph childNode <> ING.out oldGraph childNode)
|
||||
graphWithEdgesTransferred
|
||||
= ING.insEdges childEdgesToTransfer childEmbeddedGraph
|
||||
childDeletedGraph = ING.delNode childNode graphWithEdgesTransferred
|
||||
|
||||
|
||||
collapseAnnotatedGraph :: (HasCallStack, ING.DynGraph gr)
|
||||
=> AnnotatedGraph gr
|
||||
=> gr SgNamedNode (EmbedInfo Edge)
|
||||
-> AnnotatedGraph gr
|
||||
collapseAnnotatedGraph origGraph = newGraph
|
||||
where
|
||||
defaultNodeInfoGraph = ING.nmap (NodeInfo False) origGraph
|
||||
-- TODO Check that there are no embedded edges left.
|
||||
newGraph = foldl' collapseEdge origGraph (ING.labEdges origGraph)
|
||||
newGraph = foldl' collapseEdge defaultNodeInfoGraph (ING.labEdges origGraph)
|
||||
|
216
app/Icons.hs
216
app/Icons.hs
@ -23,22 +23,24 @@ module Icons
|
||||
ColorStyle(..),
|
||||
colorScheme,
|
||||
coloredTextBox,
|
||||
circleRadius
|
||||
circleRadius,
|
||||
findIconFromName
|
||||
) where
|
||||
|
||||
import Diagrams.Prelude hiding ((&), (#), Name)
|
||||
|
||||
import qualified Control.Arrow as Arrow
|
||||
import Data.Either(partitionEithers)
|
||||
import qualified Data.IntMap as IM
|
||||
import Data.List(find)
|
||||
import Data.Maybe(catMaybes, listToMaybe, isJust, fromJust)
|
||||
import Data.Maybe(listToMaybe, isJust, fromJust, mapMaybe)
|
||||
import Data.Typeable(Typeable)
|
||||
|
||||
import Constants(pattern InputPortConst, pattern ResultPortConst)
|
||||
import DrawingColors(colorScheme, ColorStyle(..))
|
||||
import Types(Icon(..), SpecialQDiagram, SpecialBackend, SpecialNum
|
||||
, NodeName, Port(..), LikeApplyFlavor(..),
|
||||
SyntaxNode(..), NamedIcon(..), Labeled(..))
|
||||
, NodeName(..), Port(..), LikeApplyFlavor(..),
|
||||
SyntaxNode(..), NamedIcon(..), Labeled(..), IconInfo)
|
||||
|
||||
{-# ANN module "HLint: ignore Use record patterns" #-}
|
||||
{-# ANN module "HLint: ignore Unnecessary hiding" #-}
|
||||
@ -72,19 +74,38 @@ lineCol = lineC colorScheme
|
||||
|
||||
-- BEGIN Exported icon functions --
|
||||
|
||||
iconToDiagram :: SpecialBackend b n => Icon -> TransformableDia b n
|
||||
iconToDiagram icon = case icon of
|
||||
findIconFromName :: IconInfo -> NodeName -> NamedIcon
|
||||
findIconFromName icons name@(NodeName nameInt)
|
||||
= NamedIcon name $ IM.findWithDefault
|
||||
(error $ "findIconFromName: icon not found.\nicons="
|
||||
<> show icons <> "\nname=" <> show name)
|
||||
nameInt
|
||||
icons
|
||||
|
||||
-- TODO Detect if we are in a loop (have called iconToDiagram on the same node
|
||||
-- before)
|
||||
iconToDiagram :: SpecialBackend b n
|
||||
=> IconInfo
|
||||
-> Icon
|
||||
-> TransformableDia b n
|
||||
iconToDiagram iconInfo icon = case icon of
|
||||
TextBoxIcon s -> textBox s
|
||||
BindTextBoxIcon s -> identDiaFunc $ bindTextBox s
|
||||
MultiIfIcon n -> nestedMultiIfDia $ replicate (1 + (2 * n)) Nothing
|
||||
CaseIcon n -> nestedCaseDia $ replicate (1 + (2 * n)) Nothing
|
||||
MultiIfIcon n -> nestedMultiIfDia iconInfo $ replicate (1 + (2 * n)) Nothing
|
||||
CaseIcon n -> nestedCaseDia iconInfo $ replicate (1 + (2 * n)) Nothing
|
||||
CaseResultIcon -> identDiaFunc caseResult
|
||||
LambdaIcon x bodyExp _ -> nestedLambda x bodyExp
|
||||
NestedApply flavor headIcon args -> nestedApplyDia flavor headIcon args
|
||||
LambdaIcon x bodyExp _
|
||||
-> nestedLambda iconInfo x (findIconFromName iconInfo <$> bodyExp)
|
||||
NestedApply flavor headIcon args
|
||||
-> nestedApplyDia
|
||||
iconInfo
|
||||
flavor
|
||||
(fmap (findIconFromName iconInfo) headIcon)
|
||||
((fmap . fmap) (findIconFromName iconInfo) args)
|
||||
NestedPApp constructor args
|
||||
-> nestedPAppDia (repeat $ patternC colorScheme) constructor args
|
||||
NestedCaseIcon args -> nestedCaseDia args
|
||||
NestedMultiIfIcon args -> nestedMultiIfDia args
|
||||
-> nestedPAppDia iconInfo (repeat $ patternC colorScheme) constructor args
|
||||
NestedCaseIcon args -> nestedCaseDia iconInfo args
|
||||
NestedMultiIfIcon args -> nestedMultiIfDia iconInfo args
|
||||
|
||||
-- BEGIN getPortAngles --
|
||||
|
||||
@ -109,38 +130,44 @@ multiIfPortAngles (Port port) = case port of
|
||||
| even port = [0 @@ turn]
|
||||
| otherwise = [1/2 @@ turn]
|
||||
|
||||
findNestedIcon :: NodeName -> Icon -> Maybe Icon
|
||||
findNestedIcon name icon = case icon of
|
||||
NestedApply _ headIcon args -> snd <$> findIcon name (headIcon : args)
|
||||
findNestedIcon :: IconInfo -> NodeName -> Icon -> Maybe Icon
|
||||
findNestedIcon iconInfo name icon = case icon of
|
||||
NestedApply _ headIcon args
|
||||
-> snd
|
||||
<$> findIcon
|
||||
iconInfo
|
||||
name
|
||||
((fmap . fmap) (findIconFromName iconInfo) (headIcon : args))
|
||||
NestedPApp constructor args ->
|
||||
snd <$> findIcon name (fmap laValue (constructor:args))
|
||||
snd <$> findIcon iconInfo name (fmap laValue (constructor:args))
|
||||
_ -> Nothing
|
||||
|
||||
findIcon :: NodeName -> [Maybe NamedIcon] -> Maybe (Int, Icon)
|
||||
findIcon name args = icon where
|
||||
findIcon :: IconInfo -> NodeName -> [Maybe NamedIcon] -> Maybe (Int, Icon)
|
||||
findIcon iconInfo name args = icon where
|
||||
numberedArgs = zip ([0,1..] :: [Int]) args
|
||||
filteredArgs = Arrow.second fromJust <$> filter (isJust . snd) numberedArgs
|
||||
nameMatches (_, NamedIcon n _) = n == name
|
||||
icon = case find nameMatches filteredArgs of
|
||||
Nothing -> listToMaybe $ catMaybes $ fmap findSubSubIcon filteredArgs
|
||||
Nothing -> listToMaybe $ mapMaybe findSubSubIcon filteredArgs
|
||||
Just (argNum, NamedIcon _ finalIcon) -> Just (argNum, finalIcon)
|
||||
where
|
||||
findSubSubIcon (argNum, NamedIcon _ subIcon)
|
||||
= case findNestedIcon name subIcon of
|
||||
= case findNestedIcon iconInfo name subIcon of
|
||||
Nothing -> Nothing
|
||||
Just x -> Just (argNum, x)
|
||||
|
||||
generalNestedPortAngles :: SpecialNum n
|
||||
=> (Port -> [Angle n])
|
||||
-> Maybe NamedIcon
|
||||
-> [Maybe NamedIcon]
|
||||
-> Port -> Maybe NodeName -> [Angle n]
|
||||
generalNestedPortAngles defaultAngles headIcon args port maybeNodeName =
|
||||
=> IconInfo
|
||||
-> (Port -> [Angle n])
|
||||
-> Maybe NamedIcon
|
||||
-> [Maybe NamedIcon]
|
||||
-> Port -> Maybe NodeName -> [Angle n]
|
||||
generalNestedPortAngles iconInfo defaultAngles headIcon args port maybeNodeName =
|
||||
case maybeNodeName of
|
||||
Nothing -> defaultAngles port
|
||||
Just name -> case findIcon name (headIcon : args) of
|
||||
Just name -> case findIcon iconInfo name (headIcon : args) of
|
||||
Nothing -> []
|
||||
Just (_, icon) -> getPortAngles icon port Nothing
|
||||
Just (_, icon) -> getPortAngles iconInfo icon port Nothing
|
||||
|
||||
reflectXAngle :: SpecialNum n => Angle n -> Angle n
|
||||
reflectXAngle x = reflectedAngle where
|
||||
@ -148,14 +175,15 @@ reflectXAngle x = reflectedAngle where
|
||||
reflectedAngle = (-) <$> halfTurn <*> normalizedAngle
|
||||
|
||||
-- TODO reflect the angles for the right side sub-icons
|
||||
nestedMultiIfPortAngles :: SpecialNum n =>
|
||||
[Maybe NamedIcon]
|
||||
nestedMultiIfPortAngles :: SpecialNum n
|
||||
=> IconInfo
|
||||
-> [Maybe NamedIcon]
|
||||
-> Port
|
||||
-> Maybe NodeName
|
||||
-> [Angle n]
|
||||
nestedMultiIfPortAngles args port maybeNodeName = case maybeNodeName of
|
||||
nestedMultiIfPortAngles iconInfo args port maybeNodeName = case maybeNodeName of
|
||||
Nothing -> multiIfPortAngles port
|
||||
Just name -> case findIcon name args of
|
||||
Just name -> case findIcon iconInfo name args of
|
||||
Nothing -> []
|
||||
-- TODO Don't use hardcoded numbers
|
||||
-- The arguments correspond to ports [0, 2, 3, 4 ...]
|
||||
@ -164,23 +192,37 @@ nestedMultiIfPortAngles args port maybeNodeName = case maybeNodeName of
|
||||
then fmap reflectXAngle subAngles
|
||||
else subAngles
|
||||
where
|
||||
subAngles = getPortAngles icon port Nothing
|
||||
subAngles = getPortAngles iconInfo icon port Nothing
|
||||
|
||||
getPortAngles :: SpecialNum n => Icon -> Port -> Maybe NodeName -> [Angle n]
|
||||
getPortAngles icon port maybeNodeName = case icon of
|
||||
getPortAngles :: SpecialNum n => IconInfo -> Icon -> Port -> Maybe NodeName -> [Angle n]
|
||||
getPortAngles iconInfo icon port maybeNodeName = case icon of
|
||||
TextBoxIcon _ -> []
|
||||
BindTextBoxIcon _ -> []
|
||||
MultiIfIcon _ -> multiIfPortAngles port
|
||||
CaseIcon _ -> multiIfPortAngles port
|
||||
CaseResultIcon -> []
|
||||
LambdaIcon _ _ _ -> applyPortAngles port
|
||||
NestedApply _ headIcon args ->
|
||||
generalNestedPortAngles applyPortAngles headIcon args port maybeNodeName
|
||||
NestedPApp headIcon args ->
|
||||
generalNestedPortAngles
|
||||
pAppPortAngles (laValue headIcon) (fmap laValue args) port maybeNodeName
|
||||
NestedCaseIcon args -> nestedMultiIfPortAngles args port maybeNodeName
|
||||
NestedMultiIfIcon args -> nestedMultiIfPortAngles args port maybeNodeName
|
||||
NestedApply _ headIcon args
|
||||
-> generalNestedPortAngles
|
||||
iconInfo
|
||||
applyPortAngles
|
||||
-- TODO Refactor with iconToDiagram
|
||||
(fmap (findIconFromName iconInfo) headIcon)
|
||||
((fmap . fmap) (findIconFromName iconInfo) args)
|
||||
port
|
||||
maybeNodeName
|
||||
NestedPApp headIcon args
|
||||
-> generalNestedPortAngles
|
||||
iconInfo
|
||||
pAppPortAngles
|
||||
(laValue headIcon)
|
||||
(fmap laValue args)
|
||||
port
|
||||
maybeNodeName
|
||||
NestedCaseIcon args
|
||||
-> nestedMultiIfPortAngles iconInfo args port maybeNodeName
|
||||
NestedMultiIfIcon args
|
||||
-> nestedMultiIfPortAngles iconInfo args port maybeNodeName
|
||||
|
||||
-- END getPortAngles --
|
||||
|
||||
@ -289,29 +331,32 @@ resultIcon = lw none $ fc (lamArgResC colorScheme) unitSquare
|
||||
-- BEGIN Apply like icons
|
||||
|
||||
makeAppInnerIcon :: SpecialBackend b n =>
|
||||
IconInfo ->
|
||||
TransformParams n ->
|
||||
Bool -> -- If False then add one to the nesting level.
|
||||
Port -> -- Port number (if the NamedIcon is Nothing)
|
||||
Labeled (Maybe NamedIcon) -> -- The icon
|
||||
SpecialQDiagram b n
|
||||
makeAppInnerIcon (TransformParams name _ reflect angle) _ portNum
|
||||
makeAppInnerIcon _iconInfo (TransformParams name _ reflect angle) _ portNum
|
||||
(Labeled Nothing str)
|
||||
= centerX $ makeLabelledPort name reflect angle str portNum
|
||||
makeAppInnerIcon (TransformParams _ nestingLevel reflect angle) func _
|
||||
makeAppInnerIcon iconInfo (TransformParams _ nestingLevel reflect angle) func _
|
||||
(Labeled (Just (NamedIcon iconNodeName icon)) _)
|
||||
= iconToDiagram
|
||||
iconInfo
|
||||
icon
|
||||
(TransformParams iconNodeName innerLevel reflect angle)
|
||||
where
|
||||
innerLevel = if func then nestingLevel else nestingLevel + 1
|
||||
|
||||
makeTransformedText :: SpecialBackend b n =>
|
||||
TransformParams n
|
||||
makeTransformedText :: SpecialBackend b n
|
||||
=> IconInfo
|
||||
-> TransformParams n
|
||||
-> Labeled (Maybe NamedIcon)
|
||||
-> SpecialQDiagram b n
|
||||
makeTransformedText tp maybeFunText = case laValue maybeFunText of
|
||||
makeTransformedText iconInfo tp maybeFunText = case laValue maybeFunText of
|
||||
Just _ ->
|
||||
makeAppInnerIcon tp True InputPortConst maybeFunText
|
||||
makeAppInnerIcon iconInfo tp True InputPortConst maybeFunText
|
||||
Nothing -> mempty
|
||||
|
||||
appArgBox :: (HasStyle a, Typeable (N a)
|
||||
@ -326,12 +371,14 @@ appArgBox borderCol topAndBottomLineWidth portHeight
|
||||
where
|
||||
verticalSeparation = circleRadius
|
||||
|
||||
nestedPAppDia :: SpecialBackend b n =>
|
||||
[Colour Double]
|
||||
nestedPAppDia :: SpecialBackend b n
|
||||
=> IconInfo
|
||||
-> [Colour Double]
|
||||
-> Labeled (Maybe NamedIcon)
|
||||
-> [Labeled (Maybe NamedIcon)]
|
||||
-> TransformableDia b n
|
||||
nestedPAppDia
|
||||
iconInfo
|
||||
borderCols
|
||||
maybeFunText
|
||||
args
|
||||
@ -340,7 +387,7 @@ nestedPAppDia
|
||||
$ centerY finalDia ||| beside' unitX transformedText resultCircleAndPort
|
||||
where
|
||||
borderCol = borderCols !! nestingLevel
|
||||
transformedText = makeTransformedText tp maybeFunText
|
||||
transformedText = makeTransformedText iconInfo tp maybeFunText
|
||||
separation = circleRadius * 1.5
|
||||
resultCircleAndPort
|
||||
= makeQualifiedPort name ResultPortConst
|
||||
@ -350,7 +397,7 @@ nestedPAppDia
|
||||
triangleAndPorts
|
||||
= vsep separation $
|
||||
rotate quarterTurn (apply0Triangle borderCol) :
|
||||
zipWith (makeAppInnerIcon tp False) argPortsConst args
|
||||
zipWith (makeAppInnerIcon iconInfo tp False) argPortsConst args
|
||||
allPorts
|
||||
= makeQualifiedPort name InputPortConst <> alignT triangleAndPorts
|
||||
argBox = alignT $ appArgBox
|
||||
@ -369,12 +416,14 @@ beside' dir dia1 dia2 = juxtapose dir dia1 dia2 <> dia1
|
||||
-- ResultPortConst: Result
|
||||
-- Ports 2,3..: Arguments
|
||||
generalNestedDia :: SpecialBackend b n
|
||||
=> (Colour Double -> SpecialQDiagram b n)
|
||||
-> [Colour Double]
|
||||
-> Maybe NamedIcon
|
||||
-> [Maybe NamedIcon]
|
||||
-> TransformableDia b n
|
||||
=> IconInfo
|
||||
-> (Colour Double -> SpecialQDiagram b n)
|
||||
-> [Colour Double]
|
||||
-> Maybe NamedIcon
|
||||
-> [Maybe NamedIcon]
|
||||
-> TransformableDia b n
|
||||
generalNestedDia
|
||||
iconInfo
|
||||
dia
|
||||
borderCols
|
||||
maybeFunText
|
||||
@ -383,11 +432,11 @@ generalNestedDia
|
||||
= named name $ centerXY $ beside' unitX transformedText finalDia
|
||||
where
|
||||
borderCol = borderCols !! nestingLevel
|
||||
transformedText = makeTransformedText tp (pure maybeFunText)
|
||||
transformedText = makeTransformedText iconInfo tp (pure maybeFunText)
|
||||
separation = circleRadius * 1.5
|
||||
trianglePortsCircle = hsep separation $
|
||||
reflectX (dia borderCol) :
|
||||
zipWith (makeAppInnerIcon tp False) argPortsConst (fmap pure args) ++
|
||||
zipWith (makeAppInnerIcon iconInfo tp False) argPortsConst (fmap pure args) ++
|
||||
[makeQualifiedPort name ResultPortConst
|
||||
<> alignR
|
||||
(lc borderCol $ lwG defaultLineWidth $ fc borderCol
|
||||
@ -403,14 +452,16 @@ generalNestedDia
|
||||
|
||||
|
||||
nestedApplyDia :: SpecialBackend b n
|
||||
=> LikeApplyFlavor
|
||||
=> IconInfo
|
||||
-> LikeApplyFlavor
|
||||
-> Maybe NamedIcon
|
||||
-> [Maybe NamedIcon]
|
||||
-> TransformableDia b n
|
||||
nestedApplyDia flavor = case flavor of
|
||||
ApplyNodeFlavor -> generalNestedDia apply0Triangle (nestingC colorScheme)
|
||||
ComposeNodeFlavor ->
|
||||
generalNestedDia composeSemiCircle (repeat $ apply1C colorScheme)
|
||||
nestedApplyDia iconInfo flavor = case flavor of
|
||||
ApplyNodeFlavor
|
||||
-> generalNestedDia iconInfo apply0Triangle (nestingC colorScheme)
|
||||
ComposeNodeFlavor
|
||||
-> generalNestedDia iconInfo composeSemiCircle (repeat $ apply1C colorScheme)
|
||||
|
||||
-- END Apply like diagrams
|
||||
|
||||
@ -542,12 +593,13 @@ multiIfTriangle portDia =
|
||||
-- odds -> left
|
||||
-- evens -> right
|
||||
generalNestedMultiIf :: SpecialBackend b n
|
||||
=> Colour Double
|
||||
=> IconInfo
|
||||
-> Colour Double
|
||||
-> (SpecialQDiagram b n -> SpecialQDiagram b n)
|
||||
-> SpecialQDiagram b n
|
||||
-> [Maybe NamedIcon]
|
||||
-> TransformableDia b n
|
||||
generalNestedMultiIf triangleColor lBracket bottomDia inputAndArgs
|
||||
generalNestedMultiIf iconInfo triangleColor lBracket bottomDia inputAndArgs
|
||||
(TransformParams name nestingLevel reflect angle)
|
||||
= named name $ case inputAndArgs of
|
||||
[] -> mempty
|
||||
@ -591,11 +643,14 @@ generalNestedMultiIf triangleColor lBracket bottomDia inputAndArgs
|
||||
then reflectX dia
|
||||
else dia
|
||||
where
|
||||
dia = iconToDiagram icon (TransformParams
|
||||
iconNodeName
|
||||
nestingLevel
|
||||
(innerReflected /= reflect)
|
||||
angle)
|
||||
dia = iconToDiagram
|
||||
iconInfo
|
||||
icon
|
||||
(TransformParams
|
||||
iconNodeName
|
||||
nestingLevel
|
||||
(innerReflected /= reflect)
|
||||
angle)
|
||||
|
||||
multiIfLBracket :: SpecialBackend b n =>
|
||||
SpecialQDiagram b n -> SpecialQDiagram b n
|
||||
@ -612,9 +667,10 @@ multiIfLBracket portDia = alignL (alignT ell) <> portDia
|
||||
-- Ports 3,5...: The left ports for the booleans
|
||||
-- Ports 2,4...: The right ports for the values
|
||||
nestedMultiIfDia :: SpecialBackend b n =>
|
||||
[Maybe NamedIcon]
|
||||
IconInfo
|
||||
-> [Maybe NamedIcon]
|
||||
-> TransformableDia b n
|
||||
nestedMultiIfDia = generalNestedMultiIf lineCol multiIfLBracket mempty
|
||||
nestedMultiIfDia iconInfo = generalNestedMultiIf iconInfo lineCol multiIfLBracket mempty
|
||||
|
||||
-- TODO Improve design to be more than a circle.
|
||||
caseResult :: SpecialBackend b n =>
|
||||
@ -632,8 +688,12 @@ caseC portDia = caseResult <> portDia
|
||||
-- ResultPortConst: Bottom result port
|
||||
-- Ports 3,5...: The left ports for the results
|
||||
-- Ports 2,4...: The right ports for the patterns
|
||||
nestedCaseDia :: SpecialBackend b n => [Maybe NamedIcon] -> TransformableDia b n
|
||||
nestedCaseDia = generalNestedMultiIf (patternC colorScheme) caseC caseResult
|
||||
nestedCaseDia :: SpecialBackend b n
|
||||
=> IconInfo
|
||||
-> [Maybe NamedIcon]
|
||||
-> TransformableDia b n
|
||||
nestedCaseDia iconInfo
|
||||
= generalNestedMultiIf iconInfo (patternC colorScheme) caseC caseResult
|
||||
|
||||
-- END MultiIf and case icons
|
||||
|
||||
@ -642,10 +702,11 @@ nestedCaseDia = generalNestedMultiIf (patternC colorScheme) caseC caseResult
|
||||
-- 1: The lambda function value
|
||||
-- 2,3.. : The parameters
|
||||
nestedLambda :: SpecialBackend b n
|
||||
=> [String]
|
||||
=> IconInfo
|
||||
-> [String]
|
||||
-> Maybe NamedIcon
|
||||
-> TransformableDia b n
|
||||
nestedLambda paramNames mBodyExp (TransformParams name level reflect angle)
|
||||
nestedLambda iconInfo paramNames mBodyExp (TransformParams name level reflect angle)
|
||||
= centerXY $ bodyExpIcon ||| centerY (named name finalDia)
|
||||
where
|
||||
lambdaCircle
|
||||
@ -661,6 +722,7 @@ nestedLambda paramNames mBodyExp (TransformParams name level reflect angle)
|
||||
Nothing -> mempty
|
||||
Just (NamedIcon bodyNodeName bodyIcon)
|
||||
-> iconToDiagram
|
||||
iconInfo
|
||||
bodyIcon
|
||||
(TransformParams bodyNodeName level reflect angle)
|
||||
|
||||
|
138
app/Rendering.hs
138
app/Rendering.hs
@ -21,13 +21,15 @@ import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph')
|
||||
|
||||
import qualified Data.GraphViz as GV
|
||||
import qualified Data.GraphViz.Attributes.Complete as GVA
|
||||
import qualified Data.IntMap as IM
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Control.Arrow(first)
|
||||
import Data.Function(on)
|
||||
import qualified Data.Graph.Inductive as ING
|
||||
import Data.Graph.Inductive.PatriciaTree (Gr)
|
||||
import Data.List(find, minimumBy)
|
||||
import Data.Maybe(catMaybes, isNothing, fromMaybe)
|
||||
import Data.Maybe(isNothing, fromMaybe, mapMaybe)
|
||||
import Data.Typeable(Typeable)
|
||||
import GHC.Stack(HasCallStack)
|
||||
|
||||
@ -35,14 +37,14 @@ import GHC.Stack(HasCallStack)
|
||||
--import Data.GraphViz.Commands
|
||||
|
||||
import Icons(colorScheme, iconToDiagram, defaultLineWidth, ColorStyle(..)
|
||||
, getPortAngles, TransformParams(..), circleRadius)
|
||||
, getPortAngles, TransformParams(..), circleRadius, findIconFromName)
|
||||
import TranslateCore(nodeToIcon)
|
||||
import Types(EmbedInfo(..), AnnotatedGraph, Edge(..)
|
||||
, Drawing(..), NameAndPort(..)
|
||||
, SpecialQDiagram, SpecialBackend, SpecialNum, NodeName(..)
|
||||
, Port(..), NamedIcon(..), Icon(..))
|
||||
, Port(..), NamedIcon(..), Icon(..), NodeInfo(..), IconInfo)
|
||||
|
||||
import Util(fromMaybeError, mapNodeInNamedNode, namedIconToTuple)
|
||||
import Util(nodeNameToInt, fromMaybeError, mapNodeInNamedNode, namedIconToTuple)
|
||||
|
||||
-- If the inferred types for these functions becomes unweildy,
|
||||
-- try using PartialTypeSignitures.
|
||||
@ -127,14 +129,33 @@ connectMaybePorts :: SpecialBackend b n =>
|
||||
connectMaybePorts portAngles
|
||||
(EmbedInfo embedDir
|
||||
(Edge
|
||||
_
|
||||
(fromNamePort@(NameAndPort name0 mPort1), NameAndPort name1 mPort2)))
|
||||
_
|
||||
(fromNamePort@(NameAndPort name0 mPort1)
|
||||
, NameAndPort name1 mPort2)))
|
||||
origDia
|
||||
-- In order to give arrows a "shadow" effect, draw a thicker semi-transparent
|
||||
-- line shaft the same color as the background underneath the normal line
|
||||
-- shaft.
|
||||
= connectFunc normalOpts qPort0 qPort1
|
||||
. connectFunc arrOptsShadow qPort0 qPort1
|
||||
= -- if DIA.location (DIA.lookupName qPort0 origDia) == DIA.location (DIA.lookupName qPort1 origDia
|
||||
-- if nameToPoint qPort0 == nameToPoint qPort1
|
||||
-- then error "connectMaybePorts: fromNamePort equals toNamePort!"
|
||||
case pointsTheSame of
|
||||
Nothing -> origDia
|
||||
Just True -> origDia
|
||||
_ ->
|
||||
(connectFunc normalOpts qPort0 qPort1
|
||||
. connectFunc arrOptsShadow qPort0 qPort1) origDia
|
||||
where
|
||||
pointsTheSame = do
|
||||
p0 <- nameToPoint qPort0
|
||||
p1 <- nameToPoint qPort1
|
||||
return $ p0 == p1
|
||||
nameToPoint n = case DIA.lookupName n origDia of
|
||||
--Nothing -> DIA.r2 (0, 0)--error "Name does not exist!"
|
||||
Nothing -> Nothing-- error $ "Name does not exist! name=" <> show n <> "\neInfo=" <> show eInfo
|
||||
Just subDia -> Just $ DIA.location subDia
|
||||
|
||||
|
||||
lineWidth = 2 * defaultLineWidth
|
||||
(baseArrOpts, shaftCol) = getArrowOpts portAngles fromNamePort
|
||||
-- TODO Use a color from the color scheme for un-embedded shafts.
|
||||
@ -152,19 +173,21 @@ connectMaybePorts portAngles
|
||||
(Just port0, Nothing) -> (connectOutside', name0 .> port0, toName name1)
|
||||
(_, _) -> (connectOutside', toName name0, toName name1)
|
||||
|
||||
|
||||
-- START addEdges --
|
||||
nameAndPortToName :: NameAndPort -> Name
|
||||
nameAndPortToName (NameAndPort name mPort) = case mPort of
|
||||
Nothing -> toName name
|
||||
Just port -> name .> port
|
||||
|
||||
findPortAngles :: SpecialNum n => NamedIcon -> NameAndPort -> [Angle n]
|
||||
findPortAngles (NamedIcon nodeName nodeIcon) (NameAndPort diaName mPort)
|
||||
findPortAngles :: SpecialNum n
|
||||
=> IconInfo -> NamedIcon -> NameAndPort -> [Angle n]
|
||||
findPortAngles iconInfo (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
|
||||
foundAngles = getPortAngles iconInfo nodeIcon port mName
|
||||
|
||||
-- TODO Clean up the Angle arithmatic
|
||||
pickClosestAngle :: SpecialNum n =>
|
||||
@ -218,13 +241,14 @@ lookupNodeAngle rotationMap key
|
||||
|
||||
makeEdge :: (HasCallStack, SpecialBackend b n, ING.Graph gr) =>
|
||||
String -- ^ Debugging information
|
||||
-> IconInfo
|
||||
-> gr NamedIcon (EmbedInfo Edge)
|
||||
-> SpecialQDiagram b n
|
||||
-> [(NamedIcon, (Bool, Angle n))]
|
||||
-> ING.LEdge (EmbedInfo Edge)
|
||||
-> SpecialQDiagram b n
|
||||
-> SpecialQDiagram b n
|
||||
makeEdge debugInfo graph dia rotationMap
|
||||
makeEdge debugInfo iconInfo graph dia rotationMap
|
||||
(node0, node1, edge@(EmbedInfo _ (Edge _ (namePort0, namePort1))))
|
||||
= connectMaybePorts portAngles edge
|
||||
where
|
||||
@ -241,11 +265,13 @@ makeEdge debugInfo graph dia rotationMap
|
||||
diaNodeNamePointMap = names dia
|
||||
port0Point = getPortPoint $ nameAndPortToName namePort0
|
||||
port1Point = getPortPoint $ nameAndPortToName namePort1
|
||||
shaftVector = port1Point .-. port0Point
|
||||
shaftVector = if port0Point == port1Point
|
||||
then error "makeEdge: points are equal!"
|
||||
else port1Point .-. port0Point
|
||||
shaftAngle = signedAngleBetween shaftVector unitX
|
||||
|
||||
icon0PortAngle = pickClosestAngle node0Angle mempty shaftAngle shaftAngle
|
||||
$ findPortAngles node0label namePort0
|
||||
$ findPortAngles iconInfo node0label namePort0
|
||||
|
||||
shaftAnglePlusOneHalf = (+) <$> shaftAngle <*> (1/2 @@ turn)
|
||||
icon1PortAngle = pickClosestAngle
|
||||
@ -253,10 +279,11 @@ makeEdge debugInfo graph dia rotationMap
|
||||
(1/2 @@ turn)
|
||||
shaftAnglePlusOneHalf
|
||||
shaftAngle
|
||||
(findPortAngles node1label namePort1)
|
||||
(findPortAngles iconInfo node1label namePort1)
|
||||
|
||||
getPortPoint n = case foundPoints of
|
||||
[point] -> point
|
||||
-- (p1:_) -> p1
|
||||
_ -> error $ "Multiple points. Debug info: " <> debugInfo
|
||||
<> "\nn: " <> show n
|
||||
where
|
||||
@ -271,13 +298,15 @@ makeEdge debugInfo graph dia rotationMap
|
||||
-- | addEdges draws the edges underneath the nodes.
|
||||
addEdges :: (HasCallStack, SpecialBackend b n, ING.Graph gr) =>
|
||||
String -- ^ Debugging information
|
||||
-> IconInfo
|
||||
-> gr NamedIcon (EmbedInfo Edge)
|
||||
-> SpecialQDiagram b n
|
||||
-> [(NamedIcon, (Bool, Angle n))]
|
||||
-> SpecialQDiagram b n
|
||||
addEdges debugInfo graph dia rotationMap = applyAll connections dia
|
||||
addEdges debugInfo iconInfo graph dia rotationMap = applyAll connections dia
|
||||
where
|
||||
connections = makeEdge debugInfo graph dia rotationMap <$> ING.labEdges graph
|
||||
connections
|
||||
= makeEdge debugInfo iconInfo graph dia rotationMap <$> ING.labEdges graph
|
||||
|
||||
-- BEGIN rotateNodes --
|
||||
|
||||
@ -298,12 +327,13 @@ scoreAngle iconPosition edges reflected angle
|
||||
angleDiff = smallestAngleDiff (reflected, angle) shaftAngle portAngles
|
||||
|
||||
bestAngleForIcon :: (HasCallStack, SpecialNum n, ING.Graph gr) =>
|
||||
Map.Map NamedIcon (Point V2 n)
|
||||
IconInfo
|
||||
-> Map.Map NamedIcon (Point V2 n)
|
||||
-> gr NamedIcon (EmbedInfo Edge)
|
||||
-> NamedIcon
|
||||
-> Bool
|
||||
-> (Angle n, n)
|
||||
bestAngleForIcon positionMap graph key@(NamedIcon (NodeName nodeId) _) reflected
|
||||
bestAngleForIcon iconInfo positionMap graph key@(NamedIcon (NodeName nodeId) _) reflected
|
||||
= minimumBy (compare `on` snd)
|
||||
( (\angle -> (angle
|
||||
, scoreAngle iconPosition edges reflected angle))
|
||||
@ -322,7 +352,7 @@ bestAngleForIcon positionMap graph key@(NamedIcon (NodeName nodeId) _) reflected
|
||||
nodeLabel = fromMaybeError
|
||||
"getPositionAndAngles: node not found"
|
||||
(ING.lab graph node)
|
||||
portAngles = findPortAngles key nameAndPort
|
||||
portAngles = findPortAngles iconInfo key nameAndPort
|
||||
|
||||
-- Edge points from id to otherNode
|
||||
getSucEdge (otherNode, EmbedInfo _ edge) = (otherNode, nameAndPort) where
|
||||
@ -333,31 +363,34 @@ bestAngleForIcon positionMap graph key@(NamedIcon (NodeName nodeId) _) reflected
|
||||
(_, nameAndPort) = edgeConnection edge
|
||||
|
||||
findIconRotation :: (HasCallStack, SpecialNum n, ING.Graph gr) =>
|
||||
Map.Map NamedIcon (Point V2 n)
|
||||
IconInfo
|
||||
-> Map.Map NamedIcon (Point V2 n)
|
||||
-> gr NamedIcon (EmbedInfo Edge)
|
||||
-> NamedIcon
|
||||
-> (NamedIcon, (Bool, Angle n))
|
||||
findIconRotation positionMap graph key = (key, (reflected, angle)) where
|
||||
findIconRotation iconInfo positionMap graph key = (key, (reflected, angle)) where
|
||||
-- Smaller scores are better
|
||||
(reflectedAngle, reflectedScore) = bestAngleForIcon positionMap graph key True
|
||||
(reflectedAngle, reflectedScore) = bestAngleForIcon iconInfo positionMap graph key True
|
||||
(nonReflectedAngle, nonReflectedScore)
|
||||
= bestAngleForIcon positionMap graph key False
|
||||
= bestAngleForIcon iconInfo positionMap graph key False
|
||||
reflected = reflectedScore < nonReflectedScore
|
||||
angle = if reflected then reflectedAngle else nonReflectedAngle
|
||||
|
||||
rotateNodes :: (HasCallStack, SpecialNum n, ING.Graph gr) =>
|
||||
Map.Map NamedIcon (Point V2 n)
|
||||
IconInfo
|
||||
-> Map.Map NamedIcon (Point V2 n)
|
||||
-> gr NamedIcon (EmbedInfo Edge)
|
||||
-> [(NamedIcon, (Bool, Angle n))]
|
||||
rotateNodes positionMap graph
|
||||
= findIconRotation positionMap graph <$> Map.keys positionMap
|
||||
rotateNodes iconInfo positionMap graph
|
||||
= findIconRotation iconInfo positionMap graph <$> Map.keys positionMap
|
||||
|
||||
-- END rotateNodes --
|
||||
|
||||
drawLambdaRegions :: forall b . SpecialBackend b Double =>
|
||||
[(NamedIcon, SpecialQDiagram b Double)]
|
||||
IconInfo
|
||||
-> [(NamedIcon, SpecialQDiagram b Double)]
|
||||
-> SpecialQDiagram b Double
|
||||
drawLambdaRegions placedNodes
|
||||
drawLambdaRegions iconInfo placedNodes
|
||||
= mconcat $ fmap (drawRegion [] . fst) placedNodes
|
||||
where
|
||||
findDia :: NodeName -> SpecialQDiagram b Double
|
||||
@ -372,7 +405,10 @@ drawLambdaRegions placedNodes
|
||||
-> regionRect $ fmap findDia (parentNames <> enclosedNames)
|
||||
NamedIcon parentName (NestedApply _ headIcon icons)
|
||||
-> mconcat
|
||||
$ drawRegion (parentName:parentNames) <$> catMaybes (headIcon:icons)
|
||||
$ drawRegion (parentName:parentNames)
|
||||
<$> mapMaybe
|
||||
(fmap (findIconFromName iconInfo))
|
||||
(headIcon:icons)
|
||||
_ -> mempty
|
||||
|
||||
-- TODO Use something better than a rectangle
|
||||
@ -389,16 +425,20 @@ drawLambdaRegions placedNodes
|
||||
(3 * circleRadius)
|
||||
|
||||
placeNodes :: SpecialBackend b Double =>
|
||||
Map.Map NamedIcon (P2 Double)
|
||||
IconInfo
|
||||
-> Map.Map NamedIcon (P2 Double)
|
||||
-> [(NamedIcon, (Bool, Angle Double))]
|
||||
-> [(NamedIcon, SpecialQDiagram b Double)]
|
||||
placeNodes positionMap = fmap placeNode
|
||||
placeNodes namedIcons positionMap = fmap placeNode
|
||||
where
|
||||
placeNode (key@(NamedIcon name icon), (reflected, angle))
|
||||
= (key, place transformedDia diaPosition)
|
||||
where
|
||||
origDia = centerXY
|
||||
$ iconToDiagram icon (TransformParams name 0 reflected angle)
|
||||
$ iconToDiagram
|
||||
namedIcons
|
||||
icon
|
||||
(TransformParams name 0 reflected angle)
|
||||
transformedDia = centerXY $ rotate angle
|
||||
$ (if reflected then reflectX else id) origDia
|
||||
diaPosition = graphvizScaleFactor *^ (positionMap Map.! key)
|
||||
@ -426,20 +466,28 @@ customLayoutParams = GV.defaultParams{
|
||||
renderIconGraph :: forall b.
|
||||
SpecialBackend b Double =>
|
||||
String -- ^ Debugging information
|
||||
-> Gr NamedIcon (EmbedInfo Edge)
|
||||
-> Gr (NodeInfo NamedIcon) (EmbedInfo Edge)
|
||||
-> IO (SpecialQDiagram b Double)
|
||||
renderIconGraph debugInfo graph = do
|
||||
layoutResult <- layoutGraph' layoutParams GVA.Neato graph
|
||||
renderIconGraph debugInfo fullGraphWithInfo = do
|
||||
-- graph = ING.nmap niVal fullGraphWithInfo
|
||||
layoutResult <- layoutGraph' layoutParams GVA.Neato parentGraph
|
||||
-- layoutResult <- layoutGraph' layoutParams GVA.Fdp graph
|
||||
let
|
||||
positionMap = fst $ getGraph layoutResult
|
||||
rotationMap = rotateNodes positionMap graph
|
||||
placedNodeList = placeNodes positionMap rotationMap
|
||||
rotationMap = rotateNodes iconInfo positionMap parentGraph
|
||||
placedNodeList = placeNodes iconInfo positionMap rotationMap
|
||||
placedNodes = mconcat $ fmap snd placedNodeList
|
||||
edges = addEdges debugInfo graph placedNodes rotationMap
|
||||
placedRegions = drawLambdaRegions placedNodeList
|
||||
edges = addEdges debugInfo iconInfo parentGraph placedNodes rotationMap
|
||||
placedRegions = drawLambdaRegions iconInfo placedNodeList
|
||||
pure (placedNodes <> edges <> placedRegions)
|
||||
where
|
||||
parentGraph
|
||||
= ING.nmap niVal $ ING.labfilter (not . niIsChild) fullGraphWithInfo
|
||||
fullGraph = ING.nmap niVal fullGraphWithInfo
|
||||
iconInfo = IM.fromList
|
||||
$ first nodeNameToInt . namedIconToTuple . snd
|
||||
<$> ING.labNodes fullGraph
|
||||
|
||||
layoutParams :: GV.GraphvizParams Int NamedIcon e () NamedIcon
|
||||
--layoutParams :: GV.GraphvizParams Int l el Int l
|
||||
layoutParams = customLayoutParams{
|
||||
@ -456,6 +504,7 @@ renderIconGraph debugInfo graph = do
|
||||
-- type signiture has "forall b e."
|
||||
dia :: SpecialQDiagram b Double
|
||||
dia = iconToDiagram
|
||||
iconInfo
|
||||
nodeIcon
|
||||
(TransformParams (NodeName (-1)) 0 False mempty)
|
||||
|
||||
@ -473,9 +522,14 @@ renderDrawing :: SpecialBackend b Double
|
||||
=> String -- ^ Debugging information
|
||||
-> Drawing
|
||||
-> IO (SpecialQDiagram b Double)
|
||||
renderDrawing debugInfo = renderIconGraph debugInfo . drawingToIconGraph
|
||||
renderDrawing debugInfo drawing
|
||||
= renderIconGraph debugInfo graph
|
||||
where
|
||||
graph = ING.nmap (NodeInfo False) . drawingToIconGraph $ drawing
|
||||
|
||||
renderIngSyntaxGraph :: (HasCallStack, SpecialBackend b Double)
|
||||
=> String -> AnnotatedGraph Gr -> IO (SpecialQDiagram b Double)
|
||||
renderIngSyntaxGraph debugInfo gr
|
||||
= renderIconGraph debugInfo $ ING.nmap (mapNodeInNamedNode nodeToIcon) gr
|
||||
= renderIconGraph debugInfo
|
||||
$ ING.nmap (fmap (mapNodeInNamedNode nodeToIcon)) gr
|
||||
-- $ ING.labfilter (not . niIsChild) gr
|
||||
|
@ -297,6 +297,12 @@ makeArg args port = case find (findArg port) args of
|
||||
Just (SgNamedNode argName argSyntaxNode, _)
|
||||
-> Just $ NamedIcon argName (nodeToIcon argSyntaxNode)
|
||||
|
||||
makeArg' :: [(SgNamedNode, Edge)] -> Port -> Maybe NodeName
|
||||
makeArg' args port = case find (findArg port) args of
|
||||
Nothing -> Nothing
|
||||
Just (SgNamedNode argName _, _)
|
||||
-> Just $ argName
|
||||
|
||||
nestedApplySyntaxNodeToIcon :: LikeApplyFlavor
|
||||
-> Int
|
||||
-> [(SgNamedNode, Edge)]
|
||||
@ -306,8 +312,8 @@ nestedApplySyntaxNodeToIcon flavor numArgs args =
|
||||
where
|
||||
dummyNode = ApplyNode flavor numArgs []
|
||||
argPorts = take numArgs (argumentPorts dummyNode)
|
||||
headIcon = makeArg args (inputPort dummyNode)
|
||||
argList = fmap (makeArg args) argPorts
|
||||
headIcon = makeArg' args (inputPort dummyNode)
|
||||
argList = fmap (makeArg' args) argPorts
|
||||
|
||||
nestedLambdaToIcon :: [String] -- labels
|
||||
-> [(SgNamedNode, Edge)] -- embedded icons
|
||||
@ -317,7 +323,7 @@ nestedLambdaToIcon labels embeddedNodes =
|
||||
LambdaIcon labels embeddedBodyNode
|
||||
where
|
||||
dummyNode = FunctionDefNode [] [] []
|
||||
embeddedBodyNode = makeArg embeddedNodes (inputPort dummyNode)
|
||||
embeddedBodyNode = makeArg' embeddedNodes (inputPort dummyNode)
|
||||
|
||||
nestedCaseOrMultiIfNodeToIcon ::
|
||||
CaseOrMultiIfTag
|
||||
|
21
app/Types.hs
21
app/Types.hs
@ -3,6 +3,7 @@
|
||||
|
||||
module Types (
|
||||
NamedIcon(..),
|
||||
IconInfo,
|
||||
Icon(..),
|
||||
SyntaxNode(..),
|
||||
NodeName(..),
|
||||
@ -24,14 +25,17 @@ module Types (
|
||||
EmbedDirection(..),
|
||||
EmbedInfo(..),
|
||||
AnnotatedGraph,
|
||||
NodeInfo(..),
|
||||
) where
|
||||
|
||||
import Diagrams.Prelude(QDiagram, V2, Any, Renderable, Path, IsName)
|
||||
import Diagrams.TwoD.Text(Text)
|
||||
|
||||
import Control.Applicative(Applicative(..))
|
||||
import qualified Data.IntMap as IM
|
||||
import Data.Typeable(Typeable)
|
||||
|
||||
|
||||
newtype NodeName = NodeName Int deriving (Typeable, Eq, Ord, Show)
|
||||
instance IsName NodeName
|
||||
|
||||
@ -48,7 +52,8 @@ instance Applicative Labeled where
|
||||
pure x = Labeled x ""
|
||||
(Labeled f fStr) <*> (Labeled x xStr) = Labeled (f x) (fStr <> xStr)
|
||||
|
||||
-- TYPES --
|
||||
type IconInfo = IM.IntMap Icon
|
||||
|
||||
-- | A datatype that represents an icon.
|
||||
-- The TextBoxIcon's data is the text that appears in the text box.
|
||||
data Icon = TextBoxIcon String
|
||||
@ -56,15 +61,15 @@ data Icon = TextBoxIcon String
|
||||
Int -- Number of alternatives
|
||||
| LambdaIcon
|
||||
[String] -- Parameter labels
|
||||
(Maybe NamedIcon) -- Function body expression
|
||||
(Maybe NodeName) -- Function body expression
|
||||
[NodeName] -- Nodes inside the lambda
|
||||
| CaseIcon Int
|
||||
| CaseResultIcon
|
||||
| BindTextBoxIcon String
|
||||
| NestedApply
|
||||
LikeApplyFlavor -- apply or compose
|
||||
(Maybe NamedIcon) -- The function for apply, or the argument for compose
|
||||
[Maybe NamedIcon] -- list of arguments or functions
|
||||
(Maybe NodeName) -- The function for apply, or the argument for compose
|
||||
[Maybe NodeName] -- list of arguments or functions
|
||||
| NestedPApp
|
||||
(Labeled (Maybe NamedIcon)) -- Data constructor
|
||||
[Labeled (Maybe NamedIcon)] -- Arguments
|
||||
@ -144,4 +149,10 @@ data EmbedDirection =
|
||||
data EmbedInfo a = EmbedInfo {eiEmbedDir :: Maybe EmbedDirection, eiVal :: a}
|
||||
deriving (Show, Eq, Functor)
|
||||
|
||||
type AnnotatedGraph gr = gr SgNamedNode (EmbedInfo Edge)
|
||||
type AnnotatedGraph gr = gr (NodeInfo SgNamedNode) (EmbedInfo Edge)
|
||||
|
||||
data NodeInfo a = NodeInfo {
|
||||
niIsChild :: Bool
|
||||
, niVal :: a
|
||||
}
|
||||
deriving (Show, Eq, Functor, Ord)
|
||||
|
@ -18,10 +18,10 @@ import VisualTranslateTests(visualTranslateTests)
|
||||
{-# ANN module "HLint: ignore Unnecessary hiding" #-}
|
||||
|
||||
drawingsAndNames :: [(String, IO (Diagram B))]
|
||||
drawingsAndNames = [
|
||||
("translate-tests", visualTranslateTests),
|
||||
("render-tests", renderTests),
|
||||
("collapse-tests", visualCollapseTests)
|
||||
drawingsAndNames =
|
||||
[ ("translate-tests", visualTranslateTests)
|
||||
, ("render-tests", renderTests)
|
||||
, ("collapse-tests", visualCollapseTests)
|
||||
]
|
||||
|
||||
renderDrawings :: HasCallStack => [(String, IO (Diagram B))] -> IO ()
|
||||
|
@ -10,10 +10,11 @@ import qualified Data.GraphViz as GV
|
||||
import qualified Diagrams.TwoD.GraphViz as DiaGV
|
||||
import qualified Data.GraphViz.Attributes.Complete as GVA
|
||||
|
||||
import qualified Data.Graph.Inductive as ING
|
||||
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
||||
|
||||
import Types(SpecialQDiagram, SpecialBackend, SyntaxNode(..), NameAndPort(..)
|
||||
, SgNamedNode(..), Edge(..))
|
||||
, SgNamedNode(..), Edge(..), NodeInfo(..))
|
||||
import Translate(translateStringToSyntaxGraph)
|
||||
import TranslateCore(syntaxGraphToFglGraph)
|
||||
import GraphAlgorithms(annotateGraph, collapseAnnotatedGraph)
|
||||
@ -89,7 +90,7 @@ collapseTestStrings = [
|
||||
makeCollapseTest :: SpecialBackend b Double => String -> IO (SpecialQDiagram b Double)
|
||||
makeCollapseTest str = do
|
||||
before <- renderFglGraph fglGraph
|
||||
afterCollapse <- renderFglGraph collapsedGraph
|
||||
afterCollapse <- renderFglGraph (ING.nmap niVal collapsedGraph)
|
||||
pure $ vsep 1 [
|
||||
expressionText,
|
||||
beforeText,
|
||||
|
@ -7,17 +7,20 @@ import qualified Diagrams.Prelude as Dia
|
||||
|
||||
import Rendering (renderDrawing)
|
||||
import Types (Labeled(..), NodeName(..), Drawing(..), Edge, Icon(..), Port(..)
|
||||
, LikeApplyFlavor(..), SpecialQDiagram, SpecialBackend
|
||||
, SpecialQDiagram, SpecialBackend
|
||||
, NamedIcon(..))
|
||||
|
||||
import Util(iconToPort, tupleToNamedIcon)
|
||||
|
||||
-- TODO Fix these tests such that they test nested icons correctly. Will need to
|
||||
-- change the Drawing type.
|
||||
|
||||
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
|
||||
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]
|
||||
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
|
||||
@ -91,17 +94,19 @@ nestedPAppDia = Drawing icons []
|
||||
[Labeled Nothing "bar"])
|
||||
]
|
||||
|
||||
nestedApplyDia :: Drawing
|
||||
nestedApplyDia = Drawing icons []
|
||||
where
|
||||
icons = [
|
||||
NamedIcon
|
||||
(NodeName 1)
|
||||
(NestedApply
|
||||
ApplyNodeFlavor
|
||||
(Just $ NamedIcon (NodeName 1) (TextBoxIcon "foo"))
|
||||
[])
|
||||
]
|
||||
-- nestedApplyDia :: Drawing
|
||||
-- nestedApplyDia = Drawing icons []
|
||||
-- where
|
||||
-- icons = [
|
||||
-- NamedIcon
|
||||
-- (NodeName 1)
|
||||
-- (NestedApply
|
||||
-- ApplyNodeFlavor
|
||||
-- -- TODO Uncomment
|
||||
-- -- (Just $ NamedIcon (NodeName 1) (TextBoxIcon "foo"))
|
||||
-- (Just $ NodeName 2)
|
||||
-- [])
|
||||
-- ]
|
||||
|
||||
lambdaDia :: Drawing
|
||||
lambdaDia = Drawing icons []
|
||||
@ -112,17 +117,18 @@ lambdaDia = Drawing icons []
|
||||
, ni2 $ MultiIfIcon 3
|
||||
]
|
||||
|
||||
nestedLambdaDia :: Drawing
|
||||
nestedLambdaDia = Drawing icons []
|
||||
where
|
||||
icons = [
|
||||
ni0 $ LambdaIcon
|
||||
["baz", "cat"]
|
||||
(Just $ NamedIcon n2 (TextBoxIcon "foobar"))
|
||||
[n0, n1]
|
||||
, ni1 CaseResultIcon
|
||||
, ni2 $ MultiIfIcon 3
|
||||
]
|
||||
-- TODO Uncomment
|
||||
-- nestedLambdaDia :: Drawing
|
||||
-- nestedLambdaDia = Drawing icons []
|
||||
-- where
|
||||
-- icons = [
|
||||
-- ni0 $ LambdaIcon
|
||||
-- ["baz", "cat"]
|
||||
-- (Just $ NamedIcon n2 (TextBoxIcon "foobar"))
|
||||
-- [n0, n1]
|
||||
-- , ni1 CaseResultIcon
|
||||
-- , ni2 $ MultiIfIcon 3
|
||||
-- ]
|
||||
|
||||
|
||||
--renderTests :: IO (Diagram B)
|
||||
@ -132,13 +138,14 @@ renderTests = do
|
||||
let vCattedDrawings = Dia.vsep 0.5 renderedDiagrams
|
||||
pure vCattedDrawings
|
||||
where
|
||||
-- TODO Re-enable tests
|
||||
allDrawings = [
|
||||
nestedCaseDrawing
|
||||
, nestedMultiIfDrawing
|
||||
, flatCaseDrawing
|
||||
, flatMultiIfDrawing
|
||||
, nestedPAppDia
|
||||
, nestedApplyDia
|
||||
-- , nestedApplyDia
|
||||
, lambdaDia
|
||||
, nestedLambdaDia
|
||||
-- , nestedLambdaDia
|
||||
]
|
||||
|
Loading…
Reference in New Issue
Block a user