mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-16 18:30:36 +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 icon = case icon of
|
||||
ApplyAIcon n -> nestedApplyDia ApplyNodeFlavor $ replicate (1 + n) Nothing
|
||||
ComposeIcon n -> nestedApplyDia ComposeNodeFlavor $ replicate (1 + n) Nothing
|
||||
ApplyAIcon n ->
|
||||
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
|
||||
TextBoxIcon s -> textBox s
|
||||
BindTextBoxIcon s -> identDiaFunc $ bindTextBox s
|
||||
@ -66,7 +68,7 @@ iconToDiagram icon = case icon of
|
||||
CaseIcon n -> nestedCaseDia $ replicate (1 + (2 * n)) Nothing
|
||||
CaseResultIcon -> identDiaFunc caseResult
|
||||
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
|
||||
NestedCaseIcon args -> nestedCaseDia args
|
||||
NestedGuardIcon args -> nestedGuardDia args
|
||||
@ -96,7 +98,7 @@ guardPortAngles (Port port) = case port of
|
||||
|
||||
findNestedIcon :: NodeName -> Icon -> Maybe Icon
|
||||
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)
|
||||
_ -> Nothing
|
||||
|
||||
@ -113,13 +115,17 @@ findIcon name args = icon where
|
||||
Nothing -> Nothing
|
||||
Just x -> Just (argNum, x)
|
||||
|
||||
generalNestedPortAngles :: SpecialNum 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
|
||||
Nothing -> []
|
||||
Just (_, icon) -> getPortAngles icon port Nothing
|
||||
generalNestedPortAngles :: SpecialNum n
|
||||
=> (Port -> [Angle n])
|
||||
-> Maybe NamedIcon
|
||||
-> [Maybe NamedIcon]
|
||||
-> Port -> Maybe NodeName -> [Angle n]
|
||||
generalNestedPortAngles defaultAngles headIcon args port maybeNodeName =
|
||||
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 x = reflectedAngle where
|
||||
@ -152,8 +158,11 @@ getPortAngles icon port maybeNodeName = case icon of
|
||||
CaseIcon _ -> guardPortAngles port
|
||||
CaseResultIcon -> []
|
||||
FlatLambdaIcon _ -> applyPortAngles port
|
||||
NestedApply _ args -> generalNestedPortAngles applyPortAngles args port maybeNodeName
|
||||
NestedPApp args -> generalNestedPortAngles pAppPortAngles (fmap fst args) port maybeNodeName
|
||||
NestedApply _ headIcon args ->
|
||||
generalNestedPortAngles applyPortAngles headIcon args port maybeNodeName
|
||||
NestedPApp (headIcon : args) ->
|
||||
generalNestedPortAngles
|
||||
pAppPortAngles (fst headIcon) (fmap fst args) port maybeNodeName
|
||||
NestedCaseIcon 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
|
||||
innerLevel = if func then nestingLevel else nestingLevel + 1
|
||||
|
||||
|
||||
generalNestedDia :: SpecialBackend 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
|
||||
generalNestedDia :: SpecialBackend b n
|
||||
=> (Colour Double -> SpecialQDiagram b n)
|
||||
-> [Colour Double]
|
||||
-> Maybe NamedIcon
|
||||
-> [Maybe NamedIcon]
|
||||
-> TransformableDia b n
|
||||
generalNestedDia dia borderCols maybeFunText funcNodeNameAndArgs name nestingLevel reflect angle = named name $ case funcNodeNameAndArgs of
|
||||
[] -> mempty
|
||||
(maybeFunText:args) -> centerXY $ transformedText ||| centerY finalDia
|
||||
args -> centerXY $ transformedText ||| centerY finalDia
|
||||
where
|
||||
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
|
||||
innerLevel = if func then nestingLevel else nestingLevel + 1
|
||||
|
||||
nestedApplyDia :: SpecialBackend b n =>
|
||||
LikeApplyFlavor -> [Maybe NamedIcon] -> TransformableDia b n
|
||||
nestedApplyDia :: SpecialBackend b n
|
||||
=> LikeApplyFlavor
|
||||
-> Maybe NamedIcon
|
||||
-> [Maybe NamedIcon]
|
||||
-> TransformableDia b n
|
||||
nestedApplyDia flavor = case flavor of
|
||||
ApplyNodeFlavor -> generalNestedDia apply0Triangle (nestingC colorScheme)
|
||||
ComposeNodeFlavor -> generalNestedDia composeSemiCircle (repeat $ apply1C colorScheme)
|
||||
|
@ -265,12 +265,17 @@ makeArg args port = case find (findArg port) args of
|
||||
Nothing -> Nothing
|
||||
Just (SgNamedNode argName argSyntaxNode, _) -> Just $ NamedIcon argName (nodeToIcon argSyntaxNode)
|
||||
|
||||
nestedApplySyntaxNodeToIcon :: LikeApplyFlavor -> Int -> [(SgNamedNode, Edge)] -> Icon
|
||||
nestedApplySyntaxNodeToIcon flavor numArgs args = NestedApply flavor argList where
|
||||
-- argList should be of length numArgs + 1, since argList includes the function expression
|
||||
dummyNode = LikeApplyNode flavor numArgs
|
||||
argPorts = take numArgs (argumentPorts dummyNode)
|
||||
argList = fmap (makeArg args) (inputPort dummyNode : argPorts)
|
||||
nestedApplySyntaxNodeToIcon :: LikeApplyFlavor
|
||||
-> Int
|
||||
-> [(SgNamedNode, Edge)]
|
||||
-> Icon
|
||||
nestedApplySyntaxNodeToIcon flavor numArgs args =
|
||||
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 tag numArgs args = case tag of
|
||||
|
@ -39,9 +39,9 @@ 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 NamedIcon) [Maybe NamedIcon]
|
||||
| NestedApply
|
||||
LikeApplyFlavor -- apply or compose
|
||||
(Maybe NamedIcon) -- The function for apply, or the argument for compose
|
||||
[Maybe NamedIcon] -- list of arguments or functions
|
||||
| NestedPApp [(Maybe NamedIcon, String)]
|
||||
| NestedCaseIcon [Maybe NamedIcon]
|
||||
|
@ -158,39 +158,6 @@ arrowTestDrawing = Drawing arrowTestIcons arrowTestEdges where
|
||||
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
|
||||
nestedCaseDrawing :: Drawing
|
||||
nestedCaseDrawing = Drawing icons [] where
|
||||
@ -255,7 +222,6 @@ renderTests = do
|
||||
fact1Drawing,
|
||||
fact2Drawing,
|
||||
arrowTestDrawing,
|
||||
nestedTextDrawing,
|
||||
nestedCaseDrawing,
|
||||
nestedGuardDrawing,
|
||||
flatCaseDrawing,
|
||||
|
Loading…
Reference in New Issue
Block a user