mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 23:17:21 +03:00
Embed literal lambda bodies.
This commit is contained in:
parent
ec6837165a
commit
11fbdfebd8
@ -22,6 +22,7 @@ import Util(sgNamedNodeToSyntaxNode)
|
||||
data ParentType = ApplyParent
|
||||
| CaseParent
|
||||
| MultiIfParent
|
||||
| LambdaParent
|
||||
| NotAParent
|
||||
deriving (Eq, Show)
|
||||
|
||||
@ -48,9 +49,14 @@ syntaxNodeIsEmbeddable parentType syntaxNode mParentPort mChildPort
|
||||
= case (parentType, syntaxNode) of
|
||||
(ApplyParent, ApplyNode _ _ _) -> parentPortNotResult
|
||||
(ApplyParent, LiteralNode _) -> parentPortNotResult
|
||||
(ApplyParent, FunctionDefNode _ _)
|
||||
(ApplyParent, FunctionDefNode _ _ _)
|
||||
-> isInput mParentPort && isResult mChildPort
|
||||
|
||||
-- (LambdaParent, ApplyNode _ _ _) -> parentPortIsInput
|
||||
(LambdaParent, LiteralNode _) -> parentPortIsInput
|
||||
-- (LambdaParent, FunctionDefNode _ _)
|
||||
-- -> parentPortIsInput
|
||||
|
||||
(CaseParent, LiteralNode _) -> parentPortNotResult
|
||||
(CaseParent, ApplyNode _ _ _)
|
||||
-> parentPortNotResult && parentPortNotInput
|
||||
@ -72,6 +78,8 @@ syntaxNodeIsEmbeddable parentType syntaxNode mParentPort mChildPort
|
||||
Just ResultPortConst -> True
|
||||
Just _ -> False
|
||||
|
||||
parentPortIsInput = isInput mParentPort
|
||||
|
||||
parentPortNotInput = not $ isInput mParentPort
|
||||
parentPortNotResult = not $ isResult mParentPort
|
||||
|
||||
@ -80,6 +88,7 @@ parentTypeForNode n = case n of
|
||||
ApplyNode _ _ _ -> ApplyParent
|
||||
CaseOrMultiIfNode CaseTag _ _ -> CaseParent
|
||||
CaseOrMultiIfNode MultiIfTag _ _ -> MultiIfParent
|
||||
FunctionDefNode _ _ _ -> LambdaParent
|
||||
_ -> NotAParent
|
||||
|
||||
lookupSyntaxNode :: ING.Graph gr =>
|
||||
@ -186,6 +195,11 @@ embedChildSyntaxNode parentNode childNode oldGraph = newGraph
|
||||
CaseOrMultiIfNode tag x existingNodes
|
||||
-> CaseOrMultiIfNode tag x
|
||||
(childrenAndEdgesToParent <> existingNodes)
|
||||
FunctionDefNode labels existingNodes innerNodes
|
||||
-> FunctionDefNode
|
||||
labels
|
||||
(childrenAndEdgesToParent <> existingNodes)
|
||||
innerNodes
|
||||
_ -> oldSyntaxNode
|
||||
|
||||
changeEdgeToParent :: ING.Node -> ING.Node -> ING.LEdge b -> ING.LEdge b
|
||||
|
27
app/Icons.hs
27
app/Icons.hs
@ -79,7 +79,7 @@ iconToDiagram icon = case icon of
|
||||
MultiIfIcon n -> nestedMultiIfDia $ replicate (1 + (2 * n)) Nothing
|
||||
CaseIcon n -> nestedCaseDia $ replicate (1 + (2 * n)) Nothing
|
||||
CaseResultIcon -> identDiaFunc caseResult
|
||||
FlatLambdaIcon x _ -> flatLambda x
|
||||
LambdaIcon x bodyExp _ -> nestedLambda x bodyExp
|
||||
NestedApply flavor headIcon args -> nestedApplyDia flavor headIcon args
|
||||
NestedPApp constructor args
|
||||
-> nestedPAppDia (repeat $ patternC colorScheme) constructor args
|
||||
@ -173,7 +173,7 @@ getPortAngles icon port maybeNodeName = case icon of
|
||||
MultiIfIcon _ -> multiIfPortAngles port
|
||||
CaseIcon _ -> multiIfPortAngles port
|
||||
CaseResultIcon -> []
|
||||
FlatLambdaIcon _ _ -> applyPortAngles port
|
||||
LambdaIcon _ _ _ -> applyPortAngles port
|
||||
NestedApply _ headIcon args ->
|
||||
generalNestedPortAngles applyPortAngles headIcon args port maybeNodeName
|
||||
NestedPApp headIcon args ->
|
||||
@ -212,7 +212,7 @@ argumentPorts :: SyntaxNode -> [Port]
|
||||
argumentPorts n = case n of
|
||||
ApplyNode _ _ _ -> defaultPorts
|
||||
PatternApplyNode _ _-> defaultPorts
|
||||
FunctionDefNode _ _ -> defaultPorts
|
||||
FunctionDefNode _ _ _ -> defaultPorts
|
||||
CaseOrMultiIfNode _ _ _-> defaultPorts
|
||||
NameNode _ -> []
|
||||
BindNameNode _ -> []
|
||||
@ -290,9 +290,9 @@ resultIcon = lw none $ fc (lamArgResC colorScheme) unitSquare
|
||||
|
||||
makeAppInnerIcon :: SpecialBackend b n =>
|
||||
TransformParams n ->
|
||||
Bool ->
|
||||
Port ->
|
||||
Labeled (Maybe NamedIcon) ->
|
||||
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
|
||||
(Labeled Nothing str)
|
||||
@ -641,9 +641,12 @@ nestedCaseDia = generalNestedMultiIf (patternC colorScheme) caseC caseResult
|
||||
-- 0: Result icon
|
||||
-- 1: The lambda function value
|
||||
-- 2,3.. : The parameters
|
||||
flatLambda :: SpecialBackend b n => [String] -> TransformableDia b n
|
||||
flatLambda paramNames (TransformParams name _ reflect angle)
|
||||
= centerXY $ named name finalDia
|
||||
nestedLambda :: SpecialBackend b n
|
||||
=> [String]
|
||||
-> Maybe NamedIcon
|
||||
-> TransformableDia b n
|
||||
nestedLambda paramNames mBodyExp (TransformParams name level reflect angle)
|
||||
= centerXY $ bodyExpIcon ||| centerY (named name finalDia)
|
||||
where
|
||||
lambdaCircle
|
||||
= lwG defaultLineWidth
|
||||
@ -654,6 +657,12 @@ flatLambda paramNames (TransformParams name _ reflect angle)
|
||||
:
|
||||
(portIcons
|
||||
++ [makeQualifiedPort name ResultPortConst <> alignR lambdaCircle])
|
||||
bodyExpIcon = case mBodyExp of
|
||||
Nothing -> mempty
|
||||
Just (NamedIcon bodyNodeName bodyIcon)
|
||||
-> iconToDiagram
|
||||
bodyIcon
|
||||
(TransformParams bodyNodeName level reflect angle)
|
||||
|
||||
portIcons
|
||||
= zipWith (makeLabelledPort name reflect angle) paramNames argPortsConst
|
||||
|
@ -367,7 +367,7 @@ drawLambdaRegions placedNodes
|
||||
-- Also draw the region around the icon the lambda is in.
|
||||
drawRegion :: [NodeName] -> NamedIcon -> SpecialQDiagram b Double
|
||||
drawRegion parentNames icon = case icon of
|
||||
NamedIcon _ (FlatLambdaIcon _ enclosedNames)
|
||||
NamedIcon _ (LambdaIcon _ _ enclosedNames)
|
||||
-> regionRect $ fmap findDia (parentNames <> enclosedNames)
|
||||
NamedIcon parentName (NestedApply _ headIcon icons)
|
||||
-> mconcat
|
||||
|
@ -531,7 +531,7 @@ evalLambda _ context patterns expr = do
|
||||
let
|
||||
paramNames = fmap patternName patternValsWithAsNames
|
||||
enclosedNodeNames = snnName <$> sgNodes combinedGraph
|
||||
lambdaNode = FunctionDefNode paramNames enclosedNodeNames
|
||||
lambdaNode = FunctionDefNode paramNames [] enclosedNodeNames
|
||||
lambdaPorts = map (nameAndPort lambdaName) $ argumentPorts lambdaNode
|
||||
patternGraph = mconcat $ fmap graphAndRefToGraph patternVals
|
||||
|
||||
|
@ -285,7 +285,8 @@ nodeToIcon (PatternApplyNode s children)
|
||||
nodeToIcon (NameNode s) = TextBoxIcon s
|
||||
nodeToIcon (BindNameNode s) = BindTextBoxIcon s
|
||||
nodeToIcon (LiteralNode s) = TextBoxIcon s
|
||||
nodeToIcon (FunctionDefNode x names) = FlatLambdaIcon x names
|
||||
nodeToIcon (FunctionDefNode labels embeddedNodes bodyNodes)
|
||||
= nestedLambdaToIcon labels embeddedNodes bodyNodes
|
||||
nodeToIcon CaseResultNode = CaseResultIcon
|
||||
nodeToIcon (CaseOrMultiIfNode tag x edges)
|
||||
= nestedCaseOrMultiIfNodeToIcon tag x edges
|
||||
@ -308,6 +309,16 @@ nestedApplySyntaxNodeToIcon flavor numArgs args =
|
||||
headIcon = makeArg args (inputPort dummyNode)
|
||||
argList = fmap (makeArg args) argPorts
|
||||
|
||||
nestedLambdaToIcon :: [String] -- labels
|
||||
-> [(SgNamedNode, Edge)] -- embedded icons
|
||||
-> [NodeName] -- body nodes
|
||||
-> Icon
|
||||
nestedLambdaToIcon labels embeddedNodes =
|
||||
LambdaIcon labels embeddedBodyNode
|
||||
where
|
||||
dummyNode = FunctionDefNode [] [] []
|
||||
embeddedBodyNode = makeArg embeddedNodes (inputPort dummyNode)
|
||||
|
||||
nestedCaseOrMultiIfNodeToIcon ::
|
||||
CaseOrMultiIfTag
|
||||
-> Int
|
||||
|
@ -54,8 +54,9 @@ instance Applicative Labeled where
|
||||
data Icon = TextBoxIcon String
|
||||
| MultiIfIcon
|
||||
Int -- Number of alternatives
|
||||
| FlatLambdaIcon
|
||||
| LambdaIcon
|
||||
[String] -- Parameter labels
|
||||
(Maybe NamedIcon) -- Function body expression
|
||||
[NodeName] -- Nodes inside the lambda
|
||||
| CaseIcon Int
|
||||
| CaseResultIcon
|
||||
@ -93,6 +94,7 @@ data SyntaxNode =
|
||||
| LiteralNode String -- Literal values like the string "Hello World"
|
||||
| FunctionDefNode -- Function definition (ie. lambda expression)
|
||||
[String] -- Parameter labels
|
||||
[(SgNamedNode, Edge)] -- Embedded nodes
|
||||
[NodeName] -- Nodes inside the lambda
|
||||
| CaseResultNode -- TODO remove caseResultNode
|
||||
| CaseOrMultiIfNode CaseOrMultiIfTag Int [(SgNamedNode, Edge)]
|
||||
|
@ -15,9 +15,9 @@ import Util(iconToPort, tupleToNamedIcon)
|
||||
iconToIntPort :: NodeName -> NodeName -> Int -> Edge
|
||||
iconToIntPort x y p = iconToPort x y (Port p)
|
||||
|
||||
n0, n1, _n2, n3, _n4, n5, _n6, _n7, _n8, _n9, n10 :: NodeName
|
||||
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
|
||||
@ -107,7 +107,19 @@ lambdaDia :: Drawing
|
||||
lambdaDia = Drawing icons []
|
||||
where
|
||||
icons = [
|
||||
ni0 $ FlatLambdaIcon ["foo", "bar"] [n0, n1]
|
||||
ni0 $ LambdaIcon ["foo", "bar"] Nothing [n0, n1]
|
||||
, ni1 CaseResultIcon
|
||||
, 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
|
||||
]
|
||||
@ -128,4 +140,5 @@ renderTests = do
|
||||
, nestedPAppDia
|
||||
, nestedApplyDia
|
||||
, lambdaDia
|
||||
, nestedLambdaDia
|
||||
]
|
||||
|
3
todo.md
3
todo.md
@ -1,7 +1,8 @@
|
||||
# Todo
|
||||
|
||||
## Todo Now
|
||||
* Let lambda icons embed results.
|
||||
* Let lambda icons embed more icons.
|
||||
* Refactor out embedded nodes from SyntaxNodes into a common data structure.
|
||||
* Redesign case to avoid non-locality.
|
||||
* Add command line flags for color style, embedding, and whether to draw arrowheads.
|
||||
* Add wiki pages discussing: Why a visual language?, History of Glance, How to contribute, Code guide [code style, ...], etc..
|
||||
|
Loading…
Reference in New Issue
Block a user