mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Refactor the NestedApply Icon.
This commit is contained in:
parent
4b99c862a7
commit
ccee42c23e
55
app/Icons.hs
55
app/Icons.hs
@ -57,8 +57,10 @@ lineCol = lineC colorScheme
|
|||||||
|
|
||||||
iconToDiagram :: SpecialBackend b n => Icon -> TransformableDia b n
|
iconToDiagram :: SpecialBackend b n => Icon -> TransformableDia b n
|
||||||
iconToDiagram icon = case icon of
|
iconToDiagram icon = case icon of
|
||||||
ApplyAIcon n -> nestedApplyDia ApplyNodeFlavor $ replicate (1 + n) Nothing
|
ApplyAIcon n ->
|
||||||
ComposeIcon n -> nestedApplyDia ComposeNodeFlavor $ replicate (1 + n) Nothing
|
nestedApplyDia ApplyNodeFlavor Nothing $ replicate (1 + n) Nothing
|
||||||
|
ComposeIcon n ->
|
||||||
|
nestedApplyDia ComposeNodeFlavor Nothing $ replicate (1 + n) Nothing
|
||||||
PAppIcon n str -> generalTextAppDia (patternTextC colorScheme) (patternC colorScheme) n str
|
PAppIcon n str -> generalTextAppDia (patternTextC colorScheme) (patternC colorScheme) n str
|
||||||
TextBoxIcon s -> textBox s
|
TextBoxIcon s -> textBox s
|
||||||
BindTextBoxIcon s -> identDiaFunc $ bindTextBox s
|
BindTextBoxIcon s -> identDiaFunc $ bindTextBox s
|
||||||
@ -66,7 +68,7 @@ iconToDiagram icon = case icon of
|
|||||||
CaseIcon n -> nestedCaseDia $ replicate (1 + (2 * n)) Nothing
|
CaseIcon n -> nestedCaseDia $ replicate (1 + (2 * n)) Nothing
|
||||||
CaseResultIcon -> identDiaFunc caseResult
|
CaseResultIcon -> identDiaFunc caseResult
|
||||||
FlatLambdaIcon x -> flatLambda x
|
FlatLambdaIcon x -> flatLambda x
|
||||||
NestedApply flavor args -> nestedApplyDia flavor args
|
NestedApply flavor headIcon args -> nestedApplyDia flavor headIcon args
|
||||||
NestedPApp args -> nestedPAppDia (repeat $ patternC colorScheme) args
|
NestedPApp args -> nestedPAppDia (repeat $ patternC colorScheme) args
|
||||||
NestedCaseIcon args -> nestedCaseDia args
|
NestedCaseIcon args -> nestedCaseDia args
|
||||||
NestedGuardIcon args -> nestedGuardDia args
|
NestedGuardIcon args -> nestedGuardDia args
|
||||||
@ -96,7 +98,7 @@ guardPortAngles (Port port) = case port of
|
|||||||
|
|
||||||
findNestedIcon :: NodeName -> Icon -> Maybe Icon
|
findNestedIcon :: NodeName -> Icon -> Maybe Icon
|
||||||
findNestedIcon name icon = case icon of
|
findNestedIcon name icon = case icon of
|
||||||
NestedApply _ args -> snd <$> findIcon name args
|
NestedApply _ headIcon args -> snd <$> findIcon name (headIcon : args)
|
||||||
NestedPApp args -> snd <$> findIcon name (fmap fst args)
|
NestedPApp args -> snd <$> findIcon name (fmap fst args)
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
@ -113,13 +115,17 @@ findIcon name args = icon where
|
|||||||
Nothing -> Nothing
|
Nothing -> Nothing
|
||||||
Just x -> Just (argNum, x)
|
Just x -> Just (argNum, x)
|
||||||
|
|
||||||
generalNestedPortAngles :: SpecialNum n =>
|
generalNestedPortAngles :: SpecialNum n
|
||||||
(Port -> [Angle n]) -> [Maybe NamedIcon] -> Port -> Maybe NodeName -> [Angle n]
|
=> (Port -> [Angle n])
|
||||||
generalNestedPortAngles defaultAngles args port maybeNodeName = case maybeNodeName of
|
-> Maybe NamedIcon
|
||||||
Nothing -> defaultAngles port
|
-> [Maybe NamedIcon]
|
||||||
Just name -> case findIcon name args of
|
-> Port -> Maybe NodeName -> [Angle n]
|
||||||
Nothing -> []
|
generalNestedPortAngles defaultAngles headIcon args port maybeNodeName =
|
||||||
Just (_, icon) -> getPortAngles icon port Nothing
|
case maybeNodeName of
|
||||||
|
Nothing -> defaultAngles port
|
||||||
|
Just name -> case findIcon name (headIcon : args) of
|
||||||
|
Nothing -> []
|
||||||
|
Just (_, icon) -> getPortAngles icon port Nothing
|
||||||
|
|
||||||
reflectXAngle :: SpecialNum n => Angle n -> Angle n
|
reflectXAngle :: SpecialNum n => Angle n -> Angle n
|
||||||
reflectXAngle x = reflectedAngle where
|
reflectXAngle x = reflectedAngle where
|
||||||
@ -152,8 +158,11 @@ getPortAngles icon port maybeNodeName = case icon of
|
|||||||
CaseIcon _ -> guardPortAngles port
|
CaseIcon _ -> guardPortAngles port
|
||||||
CaseResultIcon -> []
|
CaseResultIcon -> []
|
||||||
FlatLambdaIcon _ -> applyPortAngles port
|
FlatLambdaIcon _ -> applyPortAngles port
|
||||||
NestedApply _ args -> generalNestedPortAngles applyPortAngles args port maybeNodeName
|
NestedApply _ headIcon args ->
|
||||||
NestedPApp args -> generalNestedPortAngles pAppPortAngles (fmap fst args) port maybeNodeName
|
generalNestedPortAngles applyPortAngles headIcon args port maybeNodeName
|
||||||
|
NestedPApp (headIcon : args) ->
|
||||||
|
generalNestedPortAngles
|
||||||
|
pAppPortAngles (fst headIcon) (fmap fst args) port maybeNodeName
|
||||||
NestedCaseIcon args -> nestedGuardPortAngles args port maybeNodeName
|
NestedCaseIcon args -> nestedGuardPortAngles args port maybeNodeName
|
||||||
NestedGuardIcon args -> nestedGuardPortAngles args port maybeNodeName
|
NestedGuardIcon args -> nestedGuardPortAngles args port maybeNodeName
|
||||||
|
|
||||||
@ -322,12 +331,15 @@ nestedPAppDia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = n
|
|||||||
makeInnerIcon func _ (Just (NamedIcon iconNodeName icon), _) = iconToDiagram icon iconNodeName innerLevel reflect angle where
|
makeInnerIcon func _ (Just (NamedIcon iconNodeName icon), _) = iconToDiagram icon iconNodeName innerLevel reflect angle where
|
||||||
innerLevel = if func then nestingLevel else nestingLevel + 1
|
innerLevel = if func then nestingLevel else nestingLevel + 1
|
||||||
|
|
||||||
|
generalNestedDia :: SpecialBackend b n
|
||||||
generalNestedDia :: SpecialBackend b n =>
|
=> (Colour Double -> SpecialQDiagram b n)
|
||||||
(Colour Double -> SpecialQDiagram b n) -> [Colour Double] -> [Maybe NamedIcon] -> TransformableDia b n
|
-> [Colour Double]
|
||||||
generalNestedDia dia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = named name $ case funcNodeNameAndArgs of
|
-> Maybe NamedIcon
|
||||||
|
-> [Maybe NamedIcon]
|
||||||
|
-> TransformableDia b n
|
||||||
|
generalNestedDia dia borderCols maybeFunText funcNodeNameAndArgs name nestingLevel reflect angle = named name $ case funcNodeNameAndArgs of
|
||||||
[] -> mempty
|
[] -> mempty
|
||||||
(maybeFunText:args) -> centerXY $ transformedText ||| centerY finalDia
|
args -> centerXY $ transformedText ||| centerY finalDia
|
||||||
where
|
where
|
||||||
borderCol = borderCols !! nestingLevel
|
borderCol = borderCols !! nestingLevel
|
||||||
|
|
||||||
@ -351,8 +363,11 @@ generalNestedDia dia borderCols funcNodeNameAndArgs name nestingLevel reflect an
|
|||||||
makeInnerIcon func _ (Just (NamedIcon iconNodeName icon)) = iconToDiagram icon iconNodeName innerLevel reflect angle where
|
makeInnerIcon func _ (Just (NamedIcon iconNodeName icon)) = iconToDiagram icon iconNodeName innerLevel reflect angle where
|
||||||
innerLevel = if func then nestingLevel else nestingLevel + 1
|
innerLevel = if func then nestingLevel else nestingLevel + 1
|
||||||
|
|
||||||
nestedApplyDia :: SpecialBackend b n =>
|
nestedApplyDia :: SpecialBackend b n
|
||||||
LikeApplyFlavor -> [Maybe NamedIcon] -> TransformableDia b n
|
=> LikeApplyFlavor
|
||||||
|
-> Maybe NamedIcon
|
||||||
|
-> [Maybe NamedIcon]
|
||||||
|
-> TransformableDia b n
|
||||||
nestedApplyDia flavor = case flavor of
|
nestedApplyDia flavor = case flavor of
|
||||||
ApplyNodeFlavor -> generalNestedDia apply0Triangle (nestingC colorScheme)
|
ApplyNodeFlavor -> generalNestedDia apply0Triangle (nestingC colorScheme)
|
||||||
ComposeNodeFlavor -> generalNestedDia composeSemiCircle (repeat $ apply1C colorScheme)
|
ComposeNodeFlavor -> generalNestedDia composeSemiCircle (repeat $ apply1C colorScheme)
|
||||||
|
@ -265,12 +265,17 @@ makeArg args port = case find (findArg port) args of
|
|||||||
Nothing -> Nothing
|
Nothing -> Nothing
|
||||||
Just (SgNamedNode argName argSyntaxNode, _) -> Just $ NamedIcon argName (nodeToIcon argSyntaxNode)
|
Just (SgNamedNode argName argSyntaxNode, _) -> Just $ NamedIcon argName (nodeToIcon argSyntaxNode)
|
||||||
|
|
||||||
nestedApplySyntaxNodeToIcon :: LikeApplyFlavor -> Int -> [(SgNamedNode, Edge)] -> Icon
|
nestedApplySyntaxNodeToIcon :: LikeApplyFlavor
|
||||||
nestedApplySyntaxNodeToIcon flavor numArgs args = NestedApply flavor argList where
|
-> Int
|
||||||
-- argList should be of length numArgs + 1, since argList includes the function expression
|
-> [(SgNamedNode, Edge)]
|
||||||
dummyNode = LikeApplyNode flavor numArgs
|
-> Icon
|
||||||
argPorts = take numArgs (argumentPorts dummyNode)
|
nestedApplySyntaxNodeToIcon flavor numArgs args =
|
||||||
argList = fmap (makeArg args) (inputPort dummyNode : argPorts)
|
NestedApply flavor headIcon argList
|
||||||
|
where
|
||||||
|
dummyNode = LikeApplyNode flavor numArgs
|
||||||
|
argPorts = take numArgs (argumentPorts dummyNode)
|
||||||
|
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
|
nestedCaseOrGuardNodeToIcon tag numArgs args = case tag of
|
||||||
|
@ -39,9 +39,9 @@ data Icon = TextBoxIcon String | GuardIcon Int
|
|||||||
| FlatLambdaIcon [String] | ApplyAIcon Int | ComposeIcon Int
|
| FlatLambdaIcon [String] | ApplyAIcon Int | ComposeIcon Int
|
||||||
| PAppIcon Int String | CaseIcon Int | CaseResultIcon
|
| PAppIcon Int String | CaseIcon Int | CaseResultIcon
|
||||||
| BindTextBoxIcon String
|
| BindTextBoxIcon String
|
||||||
-- TODO: NestedApply should have the type NestedApply (Maybe NamedIcon) [Maybe NamedIcon]
|
|
||||||
| NestedApply
|
| NestedApply
|
||||||
LikeApplyFlavor -- apply or compose
|
LikeApplyFlavor -- apply or compose
|
||||||
|
(Maybe NamedIcon) -- The function for apply, or the argument for compose
|
||||||
[Maybe NamedIcon] -- list of arguments or functions
|
[Maybe NamedIcon] -- list of arguments or functions
|
||||||
| NestedPApp [(Maybe NamedIcon, String)]
|
| NestedPApp [(Maybe NamedIcon, String)]
|
||||||
| NestedCaseIcon [Maybe NamedIcon]
|
| NestedCaseIcon [Maybe NamedIcon]
|
||||||
|
@ -158,39 +158,6 @@ arrowTestDrawing = Drawing arrowTestIcons arrowTestEdges where
|
|||||||
iconToIconEnds arr1 EndAp1Arg arr4 EndAp1Arg
|
iconToIconEnds arr1 EndAp1Arg arr4 EndAp1Arg
|
||||||
]
|
]
|
||||||
|
|
||||||
nestedTextDrawing :: Drawing
|
|
||||||
nestedTextDrawing = Drawing nestedTestIcons nestedTestEdges where
|
|
||||||
[n1, t1, t2, inner, t, n2, n3, foo, in1, n4] = fmap NodeName [0..9]
|
|
||||||
nestedTestIcons = fmap tupleToNamedIcon [
|
|
||||||
(n1, NestedApply ApplyNodeFlavor args),
|
|
||||||
(t1, TextBoxIcon "T1"),
|
|
||||||
(t2, TextBoxIcon "t2")
|
|
||||||
]
|
|
||||||
where
|
|
||||||
innerArgs = fmap (fmap tupleToNamedIcon) [
|
|
||||||
Just (inner, TextBoxIcon "inner"),
|
|
||||||
Just (t, TextBoxIcon "t"),
|
|
||||||
Nothing,
|
|
||||||
Just (n2,
|
|
||||||
NestedApply
|
|
||||||
ApplyNodeFlavor
|
|
||||||
(fmap (fmap tupleToNamedIcon) [Just (n4, TextBoxIcon "N4"), Nothing]))
|
|
||||||
]
|
|
||||||
args = fmap (fmap tupleToNamedIcon) [
|
|
||||||
Just (n3, TextBoxIcon "n3"),
|
|
||||||
Nothing,
|
|
||||||
Just (foo, TextBoxIcon "3"),
|
|
||||||
Just (in1, NestedApply ApplyNodeFlavor innerArgs)
|
|
||||||
]
|
|
||||||
nestedTestEdges = [
|
|
||||||
iconToIntPort t1 n1 2,
|
|
||||||
--iconToIntPort "t1" "in" 1,
|
|
||||||
--iconToIntPort "t2" ("n1" .> "in") 3,
|
|
||||||
--iconToIntPort "t2" ("n1" .> "in" .> "n2") 2
|
|
||||||
-- TODO This edge is not drawn currently. See todo in drawingToIconGraph in Rendering.
|
|
||||||
iconToIntPort t2 n2 2
|
|
||||||
]
|
|
||||||
|
|
||||||
-- TODO refactor these Drawings
|
-- TODO refactor these Drawings
|
||||||
nestedCaseDrawing :: Drawing
|
nestedCaseDrawing :: Drawing
|
||||||
nestedCaseDrawing = Drawing icons [] where
|
nestedCaseDrawing = Drawing icons [] where
|
||||||
@ -255,7 +222,6 @@ renderTests = do
|
|||||||
fact1Drawing,
|
fact1Drawing,
|
||||||
fact2Drawing,
|
fact2Drawing,
|
||||||
arrowTestDrawing,
|
arrowTestDrawing,
|
||||||
nestedTextDrawing,
|
|
||||||
nestedCaseDrawing,
|
nestedCaseDrawing,
|
||||||
nestedGuardDrawing,
|
nestedGuardDrawing,
|
||||||
flatCaseDrawing,
|
flatCaseDrawing,
|
||||||
|
Loading…
Reference in New Issue
Block a user