mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-16 18:30:36 +03:00
Update stackage. Replace (NodeName, Icon) with NamedIcon.
This commit is contained in:
Robbie Gleichman
parent
8267305950
commit
4b99c862a7
@ -16,6 +16,7 @@ import Types(SyntaxNode(..), IngSyntaxGraph, Edge(..),
|
||||
CaseOrGuardTag(..), Port(..), NameAndPort(..), SgNamedNode(..))
|
||||
import Util(maybeBoolToBool, sgNamedNodeToSyntaxNode)
|
||||
--import Util(printSelf)
|
||||
{-# ANN module "HLint: ignore Use record patterns" #-}
|
||||
|
||||
-- See graph_algs.txt for pseudocode
|
||||
|
||||
|
||||
63
app/Icons.hs
63
app/Icons.hs
@ -28,10 +28,13 @@ import Data.Either(partitionEithers)
|
||||
import Data.List(find)
|
||||
import Data.Maybe(catMaybes, listToMaybe, isJust, fromJust)
|
||||
|
||||
import Types(Icon(..), SpecialQDiagram, SpecialBackend, SpecialNum, NodeName, Port(..), LikeApplyFlavor(..),
|
||||
SyntaxNode(..))
|
||||
import Types(Icon(..), SpecialQDiagram, SpecialBackend, SpecialNum
|
||||
, NodeName, Port(..), LikeApplyFlavor(..),
|
||||
SyntaxNode(..), NamedIcon(..))
|
||||
import DrawingColors(colorScheme, ColorStyle(..))
|
||||
|
||||
{-# ANN module "HLint: ignore Use record patterns" #-}
|
||||
|
||||
-- TYPES --
|
||||
-- | A TransformableDia is a function that returns a diagram for an icon when given
|
||||
-- the icon's name, its nesting depth, whether it will be reflected, and by what
|
||||
@ -97,21 +100,21 @@ findNestedIcon name icon = case icon of
|
||||
NestedPApp args -> snd <$> findIcon name (fmap fst args)
|
||||
_ -> Nothing
|
||||
|
||||
findIcon :: NodeName -> [Maybe (NodeName, Icon)] -> Maybe (Int, Icon)
|
||||
findIcon :: NodeName -> [Maybe NamedIcon] -> Maybe (Int, Icon)
|
||||
findIcon name args = icon where
|
||||
numberedArgs = zip ([0,1..] :: [Int]) args
|
||||
filteredArgs = Arrow.second fromJust <$> filter (isJust . snd) numberedArgs
|
||||
nameMatches (_, (n, _)) = n == name
|
||||
nameMatches (_, NamedIcon n _) = n == name
|
||||
icon = case find nameMatches filteredArgs of
|
||||
Nothing -> listToMaybe $ catMaybes $ fmap findSubSubIcon filteredArgs
|
||||
Just (argNum, (_, finalIcon)) -> Just (argNum, finalIcon)
|
||||
Just (argNum, NamedIcon _ finalIcon) -> Just (argNum, finalIcon)
|
||||
where
|
||||
findSubSubIcon (argNum, (_, subIcon)) = case findNestedIcon name subIcon of
|
||||
findSubSubIcon (argNum, NamedIcon _ subIcon) = case findNestedIcon name subIcon of
|
||||
Nothing -> Nothing
|
||||
Just x -> Just (argNum, x)
|
||||
|
||||
generalNestedPortAngles :: SpecialNum n =>
|
||||
(Port -> [Angle n]) -> [Maybe (NodeName, Icon)] -> Port -> Maybe NodeName -> [Angle n]
|
||||
(Port -> [Angle n]) -> [Maybe NamedIcon] -> Port -> Maybe NodeName -> [Angle n]
|
||||
generalNestedPortAngles defaultAngles args port maybeNodeName = case maybeNodeName of
|
||||
Nothing -> defaultAngles port
|
||||
Just name -> case findIcon name args of
|
||||
@ -124,7 +127,7 @@ reflectXAngle x = reflectedAngle where
|
||||
reflectedAngle = (-) <$> halfTurn <*> normalizedAngle
|
||||
|
||||
-- TODO reflect the angles for the right side sub-icons
|
||||
nestedGuardPortAngles :: SpecialNum n => [Maybe (NodeName, Icon)] -> Port -> Maybe NodeName -> [Angle n]
|
||||
nestedGuardPortAngles :: SpecialNum n => [Maybe NamedIcon] -> Port -> Maybe NodeName -> [Angle n]
|
||||
nestedGuardPortAngles args port maybeNodeName = case maybeNodeName of
|
||||
Nothing -> guardPortAngles port
|
||||
Just name -> case findIcon name args of
|
||||
@ -290,7 +293,7 @@ generalTextAppDia textCol borderCol numArgs str name _ reflect angle = nameDiagr
|
||||
|
||||
-- TODO Refactor with generalNestedDia
|
||||
nestedPAppDia :: SpecialBackend b n =>
|
||||
[Colour Double] -> [(Maybe (NodeName, Icon), String)] -> TransformableDia b n
|
||||
[Colour Double] -> [(Maybe NamedIcon, String)] -> TransformableDia b n
|
||||
nestedPAppDia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = named name $ case funcNodeNameAndArgs of
|
||||
[] -> mempty
|
||||
(maybeFunText:args) -> centerXY $ centerY finalDia ||| transformedText ||| resultCircleAndPort
|
||||
@ -307,21 +310,21 @@ nestedPAppDia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = n
|
||||
rotate quarterTurn (apply0Triangle borderCol) :
|
||||
zipWith (makeInnerIcon False) argPortsConst args
|
||||
|
||||
|
||||
|
||||
allPorts = makeQualifiedPort name inputPortConst <> alignT triangleAndPorts -- alignL (strutX separation ||| trianglePortsCircle)
|
||||
topAndBottomLineWidth = width allPorts
|
||||
-- boxHeight = height
|
||||
-- boxHeight = height
|
||||
argBox = alignT $ lwG defaultLineWidth $ lc borderCol $ roundedRect topAndBottomLineWidth (height allPorts + verticalSeparation) (circleRadius * 0.5)
|
||||
finalDia = argBox <> allPorts
|
||||
|
||||
makeInnerIcon _ portNum (Nothing, str) = centerX $ makeLabelledPort name reflect angle str portNum
|
||||
makeInnerIcon True _ ((Just (_, TextBoxIcon t)), _) = transformCorrectedTextBox t (textBoxTextC colorScheme) borderCol reflect angle
|
||||
makeInnerIcon func _ ((Just (iconNodeName, icon)), _) = iconToDiagram icon iconNodeName innerLevel reflect angle where
|
||||
makeInnerIcon True _ (Just (NamedIcon _ (TextBoxIcon t)), _) = transformCorrectedTextBox t (textBoxTextC colorScheme) borderCol reflect angle
|
||||
makeInnerIcon func _ (Just (NamedIcon iconNodeName icon), _) = iconToDiagram icon iconNodeName innerLevel reflect angle where
|
||||
innerLevel = if func then nestingLevel else nestingLevel + 1
|
||||
|
||||
|
||||
|
||||
generalNestedDia :: SpecialBackend b n =>
|
||||
(Colour Double -> SpecialQDiagram b n) -> [Colour Double] -> [Maybe (NodeName, Icon)] -> TransformableDia b n
|
||||
(Colour Double -> SpecialQDiagram b n) -> [Colour Double] -> [Maybe NamedIcon] -> TransformableDia b n
|
||||
generalNestedDia dia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = named name $ case funcNodeNameAndArgs of
|
||||
[] -> mempty
|
||||
(maybeFunText:args) -> centerXY $ transformedText ||| centerY finalDia
|
||||
@ -337,19 +340,19 @@ generalNestedDia dia borderCols funcNodeNameAndArgs name nestingLevel reflect an
|
||||
reflectX (dia borderCol) :
|
||||
zipWith (makeInnerIcon False) argPortsConst args ++
|
||||
[makeQualifiedPort name resultPortConst <> alignR (lc borderCol $ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)]
|
||||
|
||||
|
||||
allPorts = makeQualifiedPort name inputPortConst <> alignL trianglePortsCircle
|
||||
topAndBottomLineWidth = width allPorts - circleRadius
|
||||
argBox = alignL $ lwG defaultLineWidth $ lc borderCol $ roundedRect topAndBottomLineWidth (height allPorts + verticalSeperation) (circleRadius * 0.5)
|
||||
finalDia = argBox <> allPorts
|
||||
|
||||
makeInnerIcon _ portNum Nothing = makeQualifiedPort name portNum <> portCircle
|
||||
makeInnerIcon True _ (Just (_, TextBoxIcon t)) = transformCorrectedTextBox t (textBoxTextC colorScheme) borderCol reflect angle
|
||||
makeInnerIcon func _ (Just (iconNodeName, icon)) = iconToDiagram icon iconNodeName innerLevel reflect angle where
|
||||
makeInnerIcon True _ (Just (NamedIcon _ (TextBoxIcon t))) = transformCorrectedTextBox t (textBoxTextC colorScheme) borderCol reflect angle
|
||||
makeInnerIcon func _ (Just (NamedIcon iconNodeName icon)) = iconToDiagram icon iconNodeName innerLevel reflect angle where
|
||||
innerLevel = if func then nestingLevel else nestingLevel + 1
|
||||
|
||||
nestedApplyDia :: SpecialBackend b n =>
|
||||
LikeApplyFlavor -> [Maybe (NodeName, Icon)] -> TransformableDia b n
|
||||
LikeApplyFlavor -> [Maybe NamedIcon] -> TransformableDia b n
|
||||
nestedApplyDia flavor = case flavor of
|
||||
ApplyNodeFlavor -> generalNestedDia apply0Triangle (nestingC colorScheme)
|
||||
ComposeNodeFlavor -> generalNestedDia composeSemiCircle (repeat $ apply1C colorScheme)
|
||||
@ -452,12 +455,20 @@ guardTriangle portDia =
|
||||
-- 1 -> bottom
|
||||
-- odds -> left
|
||||
-- evens -> right
|
||||
generalNestedGuard :: SpecialBackend b n =>
|
||||
Colour Double -> (SpecialQDiagram b n -> SpecialQDiagram b n) -> SpecialQDiagram b n -> [Maybe (NodeName, Icon)] -> TransformableDia b n
|
||||
generalNestedGuard :: SpecialBackend b n
|
||||
=> Colour Double
|
||||
-> (SpecialQDiagram b n -> SpecialQDiagram b n)
|
||||
-> SpecialQDiagram b n
|
||||
-> [Maybe NamedIcon]
|
||||
-> TransformableDia b n
|
||||
generalNestedGuard triangleColor lBracket bottomDia inputAndArgs name nestingLevel reflect angle = named name $ case inputAndArgs of
|
||||
[] -> mempty
|
||||
input : args -> centerXY finalDia where
|
||||
finalDia = alignT (bottomDia <> makeQualifiedPort name resultPortConst) <> alignB (inputIcon === (bigVerticalLine <> guardDia <> makeQualifiedPort name inputPortConst))
|
||||
finalDia = alignT (bottomDia <> makeQualifiedPort name resultPortConst)
|
||||
<> alignB
|
||||
(inputIcon === (bigVerticalLine
|
||||
<> guardDia
|
||||
<> makeQualifiedPort name inputPortConst))
|
||||
|
||||
iconMapper (Port portNum) arg
|
||||
| even portNum = Right $ guardTriangle port ||| makeInnerIcon True arg
|
||||
@ -475,13 +486,13 @@ generalNestedGuard triangleColor lBracket bottomDia inputAndArgs name nestingLev
|
||||
verticalLine = strutY 0.4
|
||||
|
||||
inputIcon = makeInnerIcon False input
|
||||
|
||||
|
||||
guardDia = vcat (alignT trianglesAndBrackets)
|
||||
bigVerticalLine = alignT $ lwG defaultLineWidth $ lc triangleColor $ vrule (height guardDia)
|
||||
|
||||
makeInnerIcon innerReflected mNameAndIcon = case mNameAndIcon of
|
||||
Nothing -> mempty
|
||||
Just (iconNodeName, icon) -> if innerReflected
|
||||
Just (NamedIcon iconNodeName icon) -> if innerReflected
|
||||
then reflectX dia
|
||||
else dia
|
||||
where
|
||||
@ -499,7 +510,7 @@ guardLBracket portDia = alignL (alignT ell) <> portDia
|
||||
-- resultPortConst: Bottom result port
|
||||
-- Ports 3,5...: The left ports for the booleans
|
||||
-- Ports 2,4...: The right ports for the values
|
||||
nestedGuardDia :: SpecialBackend b n => [Maybe (NodeName, Icon)] -> TransformableDia b n
|
||||
nestedGuardDia :: SpecialBackend b n => [Maybe NamedIcon] -> TransformableDia b n
|
||||
nestedGuardDia = generalNestedGuard lineCol guardLBracket mempty
|
||||
|
||||
-- TODO Improve design to be more than a circle.
|
||||
@ -518,7 +529,7 @@ 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 (NodeName, Icon)] -> TransformableDia b n
|
||||
nestedCaseDia :: SpecialBackend b n => [Maybe NamedIcon] -> TransformableDia b n
|
||||
nestedCaseDia = generalNestedGuard (patternC colorScheme) caseC caseResult
|
||||
|
||||
-- END Guard and case icons
|
||||
|
||||
@ -29,8 +29,8 @@ import Icons(colorScheme, iconToDiagram, defaultLineWidth, ColorStyle(..), getPo
|
||||
import TranslateCore(nodeToIcon)
|
||||
import Types(Edge(..), Icon, EdgeOption(..), Drawing(..), EdgeEnd(..),
|
||||
NameAndPort(..), SpecialQDiagram, SpecialBackend, SpecialNum, NodeName(..), Port(..),
|
||||
SgNamedNode)
|
||||
import Util(fromMaybeError, mapNodeInNamedNode)
|
||||
SgNamedNode, NamedIcon(..))
|
||||
import Util(fromMaybeError, mapNodeInNamedNode, namedIconToTuple, tupleToNamedIcon)
|
||||
|
||||
-- If the inferred types for these functions becomes unweildy,
|
||||
-- try using PartialTypeSignitures.
|
||||
@ -55,16 +55,20 @@ drawingToGraphvizScaleFactor = 0.15
|
||||
|
||||
-- TODO Refactor with syntaxGraphToFglGraph in TranslateCore
|
||||
-- TODO Make this work with nested icons now that names are not qualified.
|
||||
drawingToIconGraph :: Drawing -> Gr (NodeName, Icon) Edge
|
||||
drawingToIconGraph :: Drawing -> Gr NamedIcon Edge
|
||||
drawingToIconGraph (Drawing nodes edges) =
|
||||
mkGraph nodes labeledEdges where
|
||||
labeledEdges = fmap makeLabeledEdge edges
|
||||
makeLabeledEdge e@(Edge _ _ (NameAndPort n1 _, NameAndPort n2 _)) =
|
||||
((n1, lookupInNodes n1), (n2, lookupInNodes n2), e) where
|
||||
lookupInNodes name = fromMaybeError errorString (lookup name nodes) where
|
||||
errorString =
|
||||
"syntaxGraphToFglGraph edge connects to non-existent node. Node NodeName ="
|
||||
++ show name ++ " Edge=" ++ show e
|
||||
(NamedIcon n1 (lookupInNodes n1), NamedIcon n2 (lookupInNodes n2), e)
|
||||
where
|
||||
lookupInNodes name = fromMaybeError
|
||||
errorString
|
||||
(lookup name (fmap namedIconToTuple nodes))
|
||||
where
|
||||
errorString =
|
||||
"syntaxGraphToFglGraph edge connects to non-existent node. Node NodeName ="
|
||||
++ show name ++ " Edge=" ++ show e
|
||||
|
||||
|
||||
-- | Custom arrow tail for the arg1 result circle.
|
||||
@ -134,8 +138,8 @@ nameAndPortToName (NameAndPort name mPort) = case mPort of
|
||||
Nothing -> toName name
|
||||
Just port -> name .> port
|
||||
|
||||
findPortAngles :: SpecialNum n => (NodeName, Icon) -> NameAndPort -> [Angle n]
|
||||
findPortAngles (nodeName, nodeIcon) (NameAndPort diaName mPort) = case mPort of
|
||||
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
|
||||
@ -173,13 +177,13 @@ smallestAngleDiff (nodeFlip, nodeAngle) target angles = case angles of
|
||||
(+) <$> angle <*> nodeAngle
|
||||
|
||||
|
||||
lookupNodeAngle :: Show n => [((NodeName, Icon), (Bool, Angle n))] -> (NodeName, Icon) -> (Bool, Angle n)
|
||||
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 (NodeName, Icon) Edge -> SpecialQDiagram b n -> [((NodeName, Icon), (Bool, Angle n))] ->
|
||||
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
|
||||
@ -211,7 +215,7 @@ makeEdge graph dia rotationMap (node0, node1, edge@(Edge _ _ (namePort0, namePor
|
||||
|
||||
-- | addEdges draws the edges underneath the nodes.
|
||||
addEdges :: (SpecialBackend b n, ING.Graph gr) =>
|
||||
gr (NodeName, Icon) Edge -> (SpecialQDiagram b n, [((NodeName, Icon), (Bool, Angle n))]) -> SpecialQDiagram b n
|
||||
gr NamedIcon Edge -> (SpecialQDiagram b n, [(NamedIcon, (Bool, Angle n))]) -> SpecialQDiagram b n
|
||||
addEdges graph (dia, rotationMap) = dia <> applyAll connections dia
|
||||
where
|
||||
connections = makeEdge graph dia rotationMap <$> ING.labEdges graph
|
||||
@ -235,12 +239,12 @@ scoreAngle iconPosition edges reflected angle = sum $ (^(2 :: Int)) <$> fmap edg
|
||||
angleDiff = smallestAngleDiff (reflected, angle) shaftAngle portAngles
|
||||
|
||||
bestAngleForIcon :: (SpecialNum n, ING.Graph gr) =>
|
||||
Map.Map (NodeName, Icon) (Point V2 n)
|
||||
-> gr (NodeName, Icon) Edge
|
||||
-> (NodeName, Icon)
|
||||
Map.Map NamedIcon (Point V2 n)
|
||||
-> gr NamedIcon Edge
|
||||
-> NamedIcon
|
||||
-> Bool
|
||||
-> (Angle n, n)
|
||||
bestAngleForIcon positionMap graph key@(NodeName nodeId, _) reflected =
|
||||
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]
|
||||
@ -261,10 +265,10 @@ bestAngleForIcon positionMap graph key@(NodeName nodeId, _) reflected =
|
||||
(_, nameAndPort) = edgeConnection edge
|
||||
|
||||
findIconRotation :: (SpecialNum n, ING.Graph gr) =>
|
||||
Map.Map (NodeName, Icon) (Point V2 n)
|
||||
-> gr (NodeName, Icon) Edge
|
||||
-> (NodeName, Icon)
|
||||
-> ((NodeName, Icon), (Bool, Angle n))
|
||||
Map.Map NamedIcon (Point V2 n)
|
||||
-> gr NamedIcon Edge
|
||||
-> NamedIcon
|
||||
-> (NamedIcon, (Bool, Angle n))
|
||||
findIconRotation positionMap graph key = (key, (reflected, angle)) where
|
||||
-- Smaller scores are better
|
||||
(reflectedAngle, reflectedScore) = bestAngleForIcon positionMap graph key True
|
||||
@ -273,19 +277,19 @@ findIconRotation positionMap graph key = (key, (reflected, angle)) where
|
||||
angle = if reflected then reflectedAngle else nonReflectedAngle
|
||||
|
||||
rotateNodes :: (SpecialNum n, ING.Graph gr) =>
|
||||
Map.Map (NodeName, Icon) (Point V2 n)
|
||||
-> gr (NodeName, Icon) Edge
|
||||
-> [((NodeName, Icon), (Bool, Angle n))]
|
||||
Map.Map NamedIcon (Point V2 n)
|
||||
-> gr NamedIcon Edge
|
||||
-> [(NamedIcon, (Bool, Angle n))]
|
||||
rotateNodes positionMap graph = findIconRotation positionMap graph <$> Map.keys positionMap
|
||||
|
||||
-- END rotateNodes --
|
||||
|
||||
type LayoutResult a b = Gr (GV.AttributeNode (NodeName, b)) (GV.AttributeNode a)
|
||||
type LayoutResult a = Gr (GV.AttributeNode NamedIcon) (GV.AttributeNode a)
|
||||
|
||||
placeNodes :: forall a b gr. (SpecialBackend b Double, ING.Graph gr) =>
|
||||
LayoutResult a Icon
|
||||
-> gr (NodeName, Icon) Edge
|
||||
-> (SpecialQDiagram b Double, [((NodeName, Icon), (Bool, Angle Double))])
|
||||
LayoutResult a
|
||||
-> gr NamedIcon Edge
|
||||
-> (SpecialQDiagram b Double, [(NamedIcon, (Bool, Angle Double))])
|
||||
placeNodes layoutResult graph = (mconcat placedNodes, rotationMap)
|
||||
where
|
||||
positionMap = fst $ getGraph layoutResult
|
||||
@ -294,7 +298,7 @@ placeNodes layoutResult graph = (mconcat placedNodes, rotationMap)
|
||||
placedNodes = fmap placeNode rotationMap
|
||||
|
||||
-- todo: Not sure if the diagrams should already be centered at this point.
|
||||
placeNode (key@(name, icon), (reflected, angle)) = place transformedDia diaPosition where
|
||||
placeNode (key@(NamedIcon name icon), (reflected, angle)) = place transformedDia diaPosition where
|
||||
origDia = iconToDiagram icon name 0 reflected angle
|
||||
transformedDia = centerXY $ rotate angle $ (if reflected then reflectX else id) origDia
|
||||
diaPosition = graphvizScaleFactor *^ (positionMap Map.! key)
|
||||
@ -320,20 +324,20 @@ customLayoutParams = GV.defaultParams{
|
||||
|
||||
doGraphLayout :: forall b.
|
||||
SpecialBackend b Double =>
|
||||
Gr (NodeName, Icon) Edge
|
||||
Gr NamedIcon Edge
|
||||
-> IO (SpecialQDiagram b Double)
|
||||
doGraphLayout graph = do
|
||||
layoutResult <- layoutGraph' layoutParams GVA.Neato graph
|
||||
-- layoutResult <- layoutGraph' layoutParams GVA.Fdp graph
|
||||
pure $ addEdges graph $ placeNodes layoutResult graph
|
||||
where
|
||||
layoutParams :: GV.GraphvizParams Int (NodeName,Icon) e () (NodeName,Icon)
|
||||
layoutParams :: GV.GraphvizParams Int NamedIcon e () NamedIcon
|
||||
--layoutParams :: GV.GraphvizParams Int l el Int l
|
||||
layoutParams = customLayoutParams{
|
||||
GV.fmtNode = nodeAttribute
|
||||
}
|
||||
nodeAttribute :: (Int, (NodeName, Icon)) -> [GV.Attribute]
|
||||
nodeAttribute (_, (_, nodeIcon)) =
|
||||
nodeAttribute :: (Int, NamedIcon) -> [GV.Attribute]
|
||||
nodeAttribute (_, NamedIcon _ nodeIcon) =
|
||||
-- GVA.Width and GVA.Height have a minimum of 0.01
|
||||
--[GVA.Width diaWidth, GVA.Height diaHeight]
|
||||
[GVA.Width circleDiameter, GVA.Height circleDiameter]
|
||||
@ -359,5 +363,5 @@ renderIngSyntaxGraph ::
|
||||
Gr SgNamedNode Edge -> IO (SpecialQDiagram b Double)
|
||||
renderIngSyntaxGraph = renderIconGraph . ING.nmap (mapNodeInNamedNode nodeToIcon)
|
||||
|
||||
renderIconGraph :: SpecialBackend b Double => Gr (NodeName, Icon) Edge -> IO (SpecialQDiagram b Double)
|
||||
renderIconGraph :: SpecialBackend b Double => Gr NamedIcon Edge -> IO (SpecialQDiagram b Double)
|
||||
renderIconGraph = doGraphLayout
|
||||
|
||||
@ -35,6 +35,8 @@ import Util(makeSimpleEdge, nameAndPort, justName)
|
||||
import Icons(inputPort, resultPort, argumentPorts, caseRhsPorts,
|
||||
casePatternPorts)
|
||||
|
||||
{-# ANN module "HLint: ignore Use record patterns" #-}
|
||||
|
||||
-- OVERVIEW --
|
||||
-- The core functions and data types used in this module are in TranslateCore.
|
||||
-- The TranslateCore also contains most/all of the translation functions that
|
||||
@ -734,7 +736,7 @@ matchesToCase firstMatch@(Match srcLoc funName pats _ _) restOfMatches = do
|
||||
allMatches = firstMatch:restOfMatches
|
||||
alts = fmap matchToAlt allMatches
|
||||
|
||||
evalMatch :: Show l => EvalContext -> (Match l) -> State IDState SyntaxGraph
|
||||
evalMatch :: Show l => EvalContext -> Match l -> State IDState SyntaxGraph
|
||||
evalMatch c (Match _ name patterns rhs maybeWhereBinds) = do
|
||||
let
|
||||
matchFunNameString = nameToString name
|
||||
|
||||
@ -40,10 +40,12 @@ import Data.Semigroup(Semigroup, (<>))
|
||||
|
||||
import Types(Icon, SyntaxNode(..), Edge(..), EdgeOption(..),
|
||||
NameAndPort(..), IDState, SgNamedNode(..), NodeName(..), Port,
|
||||
LikeApplyFlavor(..), CaseOrGuardTag(..), IDState(..))
|
||||
import Util(noEnds, nameAndPort, makeSimpleEdge, justName, maybeBoolToBool, mapNodeInNamedNode, nodeNameToInt)
|
||||
LikeApplyFlavor(..), CaseOrGuardTag(..), IDState(..), NamedIcon(..))
|
||||
import Util(noEnds, nameAndPort, makeSimpleEdge, justName, maybeBoolToBool, mapNodeInNamedNode, nodeNameToInt, tupleToNamedIcon)
|
||||
import Icons(Icon(..), inputPort, resultPort, argumentPorts, guardRhsPorts, guardBoolPorts)
|
||||
|
||||
{-# ANN module "HLint: ignore Use list comprehension" #-}
|
||||
|
||||
-- OVERVIEW --
|
||||
-- This module has the core functions and data types used by Translate.
|
||||
-- This module also contains most/all of the translation functions that
|
||||
@ -258,10 +260,10 @@ nodeToIcon (CaseNode n) = CaseIcon n
|
||||
nodeToIcon CaseResultNode = CaseResultIcon
|
||||
nodeToIcon (NestedCaseOrGuardNode tag x edges) = nestedCaseOrGuardNodeToIcon tag x edges
|
||||
|
||||
makeArg :: [(SgNamedNode, Edge)] -> Port -> Maybe (NodeName, Icon)
|
||||
makeArg :: [(SgNamedNode, Edge)] -> Port -> Maybe NamedIcon
|
||||
makeArg args port = case find (findArg port) args of
|
||||
Nothing -> Nothing
|
||||
Just (SgNamedNode argName argSyntaxNode, _) -> Just (argName, nodeToIcon argSyntaxNode)
|
||||
Just (SgNamedNode argName argSyntaxNode, _) -> Just $ NamedIcon argName (nodeToIcon argSyntaxNode)
|
||||
|
||||
nestedApplySyntaxNodeToIcon :: LikeApplyFlavor -> Int -> [(SgNamedNode, Edge)] -> Icon
|
||||
nestedApplySyntaxNodeToIcon flavor numArgs args = NestedApply flavor argList where
|
||||
@ -281,7 +283,7 @@ nestedCaseOrGuardNodeToIcon tag numArgs args = case tag of
|
||||
|
||||
nestedPatternNodeToIcon :: String -> [(Maybe SgNamedNode, String)] -> Icon
|
||||
nestedPatternNodeToIcon str children = NestedPApp $
|
||||
(Just (NodeName (-1), TextBoxIcon str), "")
|
||||
(Just (NamedIcon (NodeName (-1)) (TextBoxIcon str)), "")
|
||||
:
|
||||
fmap (Arrow.first $ fmap (mapNodeInNamedNode nodeToIcon)) children
|
||||
|
||||
|
||||
18
app/Types.hs
18
app/Types.hs
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, ConstraintKinds #-}
|
||||
|
||||
module Types (
|
||||
NamedIcon(..),
|
||||
Icon(..),
|
||||
SyntaxNode(..),
|
||||
NodeName(..),
|
||||
@ -26,6 +27,9 @@ import Diagrams.TwoD.Text(Text)
|
||||
|
||||
import Data.Typeable(Typeable)
|
||||
|
||||
data NamedIcon = NamedIcon {niName :: NodeName, niIcon :: Icon}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- TYPES --
|
||||
-- | A datatype that represents an icon.
|
||||
-- The TextBoxIcon's data is the text that appears in the text box.
|
||||
@ -35,11 +39,13 @@ data Icon = TextBoxIcon String | GuardIcon Int
|
||||
| FlatLambdaIcon [String] | ApplyAIcon Int | ComposeIcon Int
|
||||
| PAppIcon Int String | CaseIcon Int | CaseResultIcon
|
||||
| BindTextBoxIcon String
|
||||
-- TODO: NestedApply should have the type NestedApply (Maybe (Name, Icon)) [Maybe (Name, Icon)]
|
||||
| NestedApply LikeApplyFlavor [Maybe (NodeName, Icon)]
|
||||
| NestedPApp [(Maybe (NodeName, Icon), String)]
|
||||
| NestedCaseIcon [Maybe (NodeName, Icon)]
|
||||
| NestedGuardIcon [Maybe (NodeName, Icon)]
|
||||
-- TODO: NestedApply should have the type NestedApply (Maybe NamedIcon) [Maybe NamedIcon]
|
||||
| NestedApply
|
||||
LikeApplyFlavor -- apply or compose
|
||||
[Maybe NamedIcon] -- list of arguments or functions
|
||||
| NestedPApp [(Maybe NamedIcon, String)]
|
||||
| NestedCaseIcon [Maybe NamedIcon]
|
||||
| NestedGuardIcon [Maybe NamedIcon]
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data LikeApplyFlavor = ApplyNodeFlavor | ComposeNodeFlavor deriving (Show, Eq, Ord)
|
||||
@ -84,7 +90,7 @@ data EdgeEnd = EndAp1Result | EndAp1Arg | EndNone deriving (Show, Eq, Ord)
|
||||
|
||||
-- | A drawing is a map from names to Icons, a list of edges,
|
||||
-- and a map of names to subDrawings
|
||||
data Drawing = Drawing [(NodeName, Icon)] [Edge] deriving (Show, Eq)
|
||||
data Drawing = Drawing [NamedIcon] [Edge] deriving (Show, Eq)
|
||||
|
||||
data SgNamedNode = SgNamedNode NodeName SyntaxNode deriving (Ord, Eq, Show)
|
||||
|
||||
|
||||
15
app/Util.hs
15
app/Util.hs
@ -19,7 +19,9 @@ module Util (
|
||||
mapNodeInNamedNode,
|
||||
sgNamedNodeToSyntaxNode,
|
||||
nodeNameToInt,
|
||||
customRenderSVG
|
||||
customRenderSVG,
|
||||
namedIconToTuple,
|
||||
tupleToNamedIcon
|
||||
)where
|
||||
|
||||
import Diagrams.Backend.SVG(renderSVG', Options(..), SVG)
|
||||
@ -34,7 +36,7 @@ import Data.Text(pack)
|
||||
import Data.Typeable(Typeable)
|
||||
|
||||
import Types(EdgeEnd(..), Edge(..), NameAndPort(..), Connection, NodeName(..), Port,
|
||||
SyntaxNode, SgNamedNode(..))
|
||||
SyntaxNode, SgNamedNode(..), NamedIcon(..), Icon(..))
|
||||
|
||||
mapFst :: Functor f => (a -> b) -> f (a, c) -> f (b, c)
|
||||
mapFst f = fmap (first f)
|
||||
@ -89,8 +91,8 @@ eitherToMaybes (Right y) = (Nothing, Just y)
|
||||
maybeBoolToBool :: Maybe Bool -> Bool
|
||||
maybeBoolToBool = or
|
||||
|
||||
mapNodeInNamedNode :: (SyntaxNode -> a) -> SgNamedNode -> (NodeName, a)
|
||||
mapNodeInNamedNode f (SgNamedNode name node) = (name, f node)
|
||||
mapNodeInNamedNode :: (SyntaxNode -> Icon) -> SgNamedNode -> NamedIcon
|
||||
mapNodeInNamedNode f (SgNamedNode name node) = NamedIcon name (f node)
|
||||
|
||||
sgNamedNodeToSyntaxNode :: SgNamedNode -> SyntaxNode
|
||||
sgNamedNodeToSyntaxNode (SgNamedNode _ n) = n
|
||||
@ -98,6 +100,11 @@ sgNamedNodeToSyntaxNode (SgNamedNode _ n) = n
|
||||
nodeNameToInt :: NodeName -> Int
|
||||
nodeNameToInt (NodeName x) = x
|
||||
|
||||
namedIconToTuple :: NamedIcon -> (NodeName, Icon)
|
||||
namedIconToTuple (NamedIcon x y) = (x, y)
|
||||
|
||||
tupleToNamedIcon :: (NodeName, Icon) -> NamedIcon
|
||||
tupleToNamedIcon (x, y) = NamedIcon x y
|
||||
|
||||
customRenderSVG :: (Typeable n, Show n, RealFloat n) =>
|
||||
FilePath
|
||||
|
||||
@ -7,7 +7,7 @@ license: GPL-3
|
||||
license-file: LICENSE
|
||||
author: Robbie Gleichman
|
||||
maintainer: rgleichman@gmail.com
|
||||
copyright: 2016 Robbie Gleichman
|
||||
copyright: 2018 Robbie Gleichman
|
||||
category: Visual Programming
|
||||
build-type: Simple
|
||||
-- extra-source-files:
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
|
||||
|
||||
# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
|
||||
resolver: lts-8.23
|
||||
resolver: lts-12.14
|
||||
|
||||
# Local packages, usually specified by relative directory name
|
||||
packages:
|
||||
@ -9,7 +9,7 @@ packages:
|
||||
|
||||
# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
|
||||
extra-deps: [
|
||||
"diagrams-graphviz-1.4"
|
||||
"diagrams-graphviz-1.4.1"
|
||||
]
|
||||
|
||||
# Override default flag values for local packages and extra-deps
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MonoLocalBinds #-}
|
||||
module VisualGraphAlgorithmTests (
|
||||
visualCollapseTests
|
||||
) where
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MonoLocalBinds #-}
|
||||
module VisualRenderingTests (
|
||||
renderTests
|
||||
) where
|
||||
@ -7,9 +8,9 @@ import Diagrams.Prelude hiding ((#), (&))
|
||||
|
||||
import Rendering (renderDrawing)
|
||||
import Types (NodeName(..), Drawing(..), Edge, Icon(..), Port(..), EdgeEnd(..),
|
||||
LikeApplyFlavor(..), SpecialQDiagram, SpecialBackend)
|
||||
LikeApplyFlavor(..), SpecialQDiagram, SpecialBackend, NamedIcon(..))
|
||||
import Util(portToPort, iconToPort,
|
||||
iconToIconEnds, iconTailToPort)
|
||||
iconToIconEnds, iconTailToPort, tupleToNamedIcon)
|
||||
|
||||
iconToIntPort :: NodeName -> NodeName -> Int -> Edge
|
||||
iconToIntPort x y p = iconToPort x y (Port p)
|
||||
@ -20,7 +21,7 @@ intPortToPort x1 port1 x2 port2 = portToPort x1 (Port port1) x2 (Port port2)
|
||||
drawing0 :: Drawing
|
||||
drawing0 = Drawing d0Icons d0Edges where
|
||||
[d0A, d0B, d0Res, d0Foo, d0Bar] = fmap NodeName [0..4] --["A", "B", "res", "foo", "bar"]
|
||||
d0Icons =
|
||||
d0Icons = fmap tupleToNamedIcon
|
||||
[(d0A, ApplyAIcon 1),
|
||||
(d0B, ApplyAIcon 1),
|
||||
(d0Res, CaseResultIcon),
|
||||
@ -45,7 +46,7 @@ fG0, fOne, fEq0, fMinus1, fEq0Ap, fMinus1Ap, fTimes, fRecurAp, fTimesAp, fArg, f
|
||||
|
||||
fact0Drawing :: Drawing
|
||||
fact0Drawing = Drawing fact0Icons fact0Edges where
|
||||
fact0Icons =
|
||||
fact0Icons = fmap tupleToNamedIcon
|
||||
[
|
||||
(fG0, GuardIcon 2),
|
||||
(fOne, TextBoxIcon "1"),
|
||||
@ -75,8 +76,8 @@ fact0Drawing = Drawing fact0Icons fact0Edges where
|
||||
]
|
||||
|
||||
|
||||
fact1Icons :: [(NodeName, Icon)]
|
||||
fact1Icons =
|
||||
fact1Icons :: [NamedIcon]
|
||||
fact1Icons = fmap tupleToNamedIcon
|
||||
[
|
||||
(fG0, GuardIcon 2),
|
||||
(fOne, TextBoxIcon "1"),
|
||||
@ -108,8 +109,8 @@ fact1Drawing = Drawing fact1Icons fact1Edges
|
||||
|
||||
-- fact2 is like fact1, but uses fTimesAp port 2 to distrubute the argument,
|
||||
-- not fArg
|
||||
fact2Icons :: [(NodeName, Icon)]
|
||||
fact2Icons =
|
||||
fact2Icons :: [NamedIcon]
|
||||
fact2Icons = fmap tupleToNamedIcon
|
||||
[
|
||||
(fG0, GuardIcon 2),
|
||||
(fOne, TextBoxIcon "1"),
|
||||
@ -144,7 +145,7 @@ fact2Drawing = Drawing fact2Icons fact2Edges
|
||||
arrowTestDrawing :: Drawing
|
||||
arrowTestDrawing = Drawing arrowTestIcons arrowTestEdges where
|
||||
[arr1, arr2, arr3, arr4] = fmap NodeName [0..3] --["arr1", "arr2", "arr3", "arr4"]
|
||||
arrowTestIcons = [
|
||||
arrowTestIcons = fmap tupleToNamedIcon [
|
||||
(arr1, TextBoxIcon "1"),
|
||||
(arr2, TextBoxIcon "2"),
|
||||
(arr3, TextBoxIcon "3"),
|
||||
@ -160,19 +161,22 @@ arrowTestDrawing = Drawing arrowTestIcons arrowTestEdges where
|
||||
nestedTextDrawing :: Drawing
|
||||
nestedTextDrawing = Drawing nestedTestIcons nestedTestEdges where
|
||||
[n1, t1, t2, inner, t, n2, n3, foo, in1, n4] = fmap NodeName [0..9]
|
||||
nestedTestIcons = [
|
||||
nestedTestIcons = fmap tupleToNamedIcon [
|
||||
(n1, NestedApply ApplyNodeFlavor args),
|
||||
(t1, TextBoxIcon "T1"),
|
||||
(t2, TextBoxIcon "t2")
|
||||
]
|
||||
where
|
||||
innerArgs = [
|
||||
innerArgs = fmap (fmap tupleToNamedIcon) [
|
||||
Just (inner, TextBoxIcon "inner"),
|
||||
Just (t, TextBoxIcon "t"),
|
||||
Nothing,
|
||||
Just (n2, NestedApply ApplyNodeFlavor [Just (n4, TextBoxIcon "N4"), Nothing])
|
||||
Just (n2,
|
||||
NestedApply
|
||||
ApplyNodeFlavor
|
||||
(fmap (fmap tupleToNamedIcon) [Just (n4, TextBoxIcon "N4"), Nothing]))
|
||||
]
|
||||
args = [
|
||||
args = fmap (fmap tupleToNamedIcon) [
|
||||
Just (n3, TextBoxIcon "n3"),
|
||||
Nothing,
|
||||
Just (foo, TextBoxIcon "3"),
|
||||
@ -187,33 +191,34 @@ nestedTextDrawing = Drawing nestedTestIcons nestedTestEdges where
|
||||
iconToIntPort t2 n2 2
|
||||
]
|
||||
|
||||
-- TODO refactor these Drawings
|
||||
nestedCaseDrawing :: Drawing
|
||||
nestedCaseDrawing = Drawing icons [] where
|
||||
[n0, n1, n2, n3, n4, n5, n6, n7, n8, n9] = fmap NodeName [0..9]
|
||||
icons = [
|
||||
icons = fmap tupleToNamedIcon [
|
||||
(n0, NestedCaseIcon [Nothing, Nothing, Nothing]),
|
||||
(n1, NestedCaseIcon [Nothing, Just (n2, TextBoxIcon "n2"), Nothing]),
|
||||
(n3, NestedCaseIcon [Nothing, Nothing, Just (n4, TextBoxIcon "n4")]),
|
||||
(n1, NestedCaseIcon [Nothing, Just $ NamedIcon n2 (TextBoxIcon "n2"), Nothing]),
|
||||
(n3, NestedCaseIcon [Nothing, Nothing, Just $ NamedIcon n4 (TextBoxIcon "n4")]),
|
||||
(n5, NestedCaseIcon [Nothing,
|
||||
Just (n6, TextBoxIcon "n6"),
|
||||
Just (n7, TextBoxIcon "n7"),
|
||||
Just (n8, TextBoxIcon "n8"),
|
||||
Just (n9, TextBoxIcon "n9")])
|
||||
Just $ NamedIcon n6 (TextBoxIcon "n6"),
|
||||
Just $ NamedIcon n7 (TextBoxIcon "n7"),
|
||||
Just $ NamedIcon n8 (TextBoxIcon "n8"),
|
||||
Just $ NamedIcon n9 (TextBoxIcon "n9")])
|
||||
]
|
||||
|
||||
nestedGuardDrawing :: Drawing
|
||||
nestedGuardDrawing = Drawing icons edges where
|
||||
[n0, n1, n2, n3, n4, n5, n6, n7, n8, n9, n10] = fmap NodeName [0..10]
|
||||
icons = [
|
||||
icons = fmap tupleToNamedIcon [
|
||||
(n10, TextBoxIcon "n10"),
|
||||
(n0, NestedGuardIcon [Nothing, Nothing, Nothing]),
|
||||
(n1, NestedGuardIcon [Nothing, Just (n2, TextBoxIcon "n2"), Nothing]),
|
||||
(n3, NestedGuardIcon [Nothing, Nothing, Just (n4, TextBoxIcon "n4")]),
|
||||
(n1, NestedGuardIcon [Nothing, Just $ NamedIcon n2 (TextBoxIcon "n2"), Nothing]),
|
||||
(n3, NestedGuardIcon [Nothing, Nothing, Just $ NamedIcon n4 (TextBoxIcon "n4")]),
|
||||
(n5, NestedGuardIcon [Nothing,
|
||||
Just (n6, TextBoxIcon "n6"),
|
||||
Just (n7, TextBoxIcon "n7"),
|
||||
Just (n8, TextBoxIcon "n8"),
|
||||
Just (n9, TextBoxIcon "n9")])
|
||||
Just $ NamedIcon n6 (TextBoxIcon "n6"),
|
||||
Just $ NamedIcon n7 (TextBoxIcon "n7"),
|
||||
Just $ NamedIcon n8 (TextBoxIcon "n8"),
|
||||
Just $ NamedIcon n9 (TextBoxIcon "n9")])
|
||||
]
|
||||
edges = [
|
||||
iconToIntPort n10 n5 0
|
||||
@ -221,7 +226,7 @@ nestedGuardDrawing = Drawing icons edges where
|
||||
|
||||
flatCaseDrawing :: Drawing
|
||||
flatCaseDrawing = Drawing icons edges where
|
||||
icons = [
|
||||
icons = fmap tupleToNamedIcon [
|
||||
(NodeName 0, CaseIcon 0),
|
||||
(NodeName 1, CaseIcon 1),
|
||||
(NodeName 2, CaseIcon 2)
|
||||
@ -230,7 +235,7 @@ flatCaseDrawing = Drawing icons edges where
|
||||
|
||||
flatGuardDrawing :: Drawing
|
||||
flatGuardDrawing = Drawing icons edges where
|
||||
icons = [
|
||||
icons = fmap tupleToNamedIcon [
|
||||
(NodeName 1, GuardIcon 1),
|
||||
(NodeName 2, GuardIcon 2),
|
||||
(NodeName 3, GuardIcon 3)
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MonoLocalBinds #-}
|
||||
module VisualTranslateTests(
|
||||
visualTranslateTests
|
||||
) where
|
||||
|
||||
Loading…
Reference in New Issue
Block a user