mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 23:17:21 +03:00
Embed lambda nodes in apply parents.
This commit is contained in:
parent
96aaaa2319
commit
2d74cb2fd1
@ -41,13 +41,12 @@ syntaxNodeIsEmbeddable :: ParentType
|
|||||||
-> Maybe Port
|
-> Maybe Port
|
||||||
-> Maybe Port
|
-> Maybe Port
|
||||||
-> Bool
|
-> Bool
|
||||||
syntaxNodeIsEmbeddable parentType n mParentPort _mChildPort
|
syntaxNodeIsEmbeddable parentType syntaxNode mParentPort mChildPort
|
||||||
= case (parentType, n) of
|
= case (parentType, syntaxNode) of
|
||||||
(ApplyParent, ApplyNode _ _ _) -> parentPortNotResult
|
(ApplyParent, ApplyNode _ _ _) -> parentPortNotResult
|
||||||
(ApplyParent, LiteralNode _) -> parentPortNotResult
|
(ApplyParent, LiteralNode _) -> parentPortNotResult
|
||||||
-- TODO Embedded FunctionDefNodes are missing their enclosures.
|
(ApplyParent, FunctionDefNode _ _)
|
||||||
-- (ApplyParent, FunctionDefNode _ _)
|
-> isInput mParentPort && isResult mChildPort
|
||||||
-- -> isInput mParentPort && isResult mChildPort
|
|
||||||
|
|
||||||
(CaseParent, LiteralNode _) -> parentPortNotResult
|
(CaseParent, LiteralNode _) -> parentPortNotResult
|
||||||
(CaseParent, ApplyNode _ _ _)
|
(CaseParent, ApplyNode _ _ _)
|
||||||
|
@ -6,6 +6,7 @@ module Rendering (
|
|||||||
renderIngSyntaxGraph
|
renderIngSyntaxGraph
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import qualified Diagrams.Prelude as DIA
|
||||||
import Diagrams.Prelude(toName, shaftStyle, global, arrowShaft, noTail
|
import Diagrams.Prelude(toName, shaftStyle, global, arrowShaft, noTail
|
||||||
, arrowTail, arrowHead, scale, r2, bezier3
|
, arrowTail, arrowHead, scale, r2, bezier3
|
||||||
, fromSegments, Angle, P2, V2, Point, Name, ArrowOpts, N
|
, fromSegments, Angle, P2, V2, Point, Name, ArrowOpts, N
|
||||||
@ -17,7 +18,6 @@ import Diagrams.Prelude(toName, shaftStyle, global, arrowShaft, noTail
|
|||||||
, connectOutside', connect', with, (%~), lengths, (^+^)
|
, connectOutside', connect', with, (%~), lengths, (^+^)
|
||||||
, (.~))
|
, (.~))
|
||||||
import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph')
|
import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph')
|
||||||
import qualified Diagrams.Prelude as DIA
|
|
||||||
|
|
||||||
import qualified Data.GraphViz as GV
|
import qualified Data.GraphViz as GV
|
||||||
import qualified Data.GraphViz.Attributes.Complete as GVA
|
import qualified Data.GraphViz.Attributes.Complete as GVA
|
||||||
@ -27,7 +27,7 @@ import Data.Function(on)
|
|||||||
import qualified Data.Graph.Inductive as ING
|
import qualified Data.Graph.Inductive as ING
|
||||||
import Data.Graph.Inductive.PatriciaTree (Gr)
|
import Data.Graph.Inductive.PatriciaTree (Gr)
|
||||||
import Data.List(find, minimumBy)
|
import Data.List(find, minimumBy)
|
||||||
import Data.Maybe(isNothing, fromMaybe)
|
import Data.Maybe(catMaybes, isNothing, fromMaybe)
|
||||||
import Data.Typeable(Typeable)
|
import Data.Typeable(Typeable)
|
||||||
|
|
||||||
--import qualified Data.GraphViz.Types
|
--import qualified Data.GraphViz.Types
|
||||||
@ -353,20 +353,26 @@ rotateNodes positionMap graph
|
|||||||
|
|
||||||
-- END rotateNodes --
|
-- END rotateNodes --
|
||||||
|
|
||||||
drawLambdaRegions :: SpecialBackend b Double =>
|
drawLambdaRegions :: forall b . SpecialBackend b Double =>
|
||||||
[(NamedIcon, SpecialQDiagram b Double)]
|
[(NamedIcon, SpecialQDiagram b Double)]
|
||||||
-> SpecialQDiagram b Double
|
-> SpecialQDiagram b Double
|
||||||
drawLambdaRegions placedNodes
|
drawLambdaRegions placedNodes
|
||||||
= mconcat $ fmap (drawRegion . niIcon . fst) placedNodes
|
= mconcat $ fmap (drawRegion [] . fst) placedNodes
|
||||||
where
|
where
|
||||||
drawRegion (FlatLambdaIcon _ enclosedNames)
|
findDia :: NodeName -> SpecialQDiagram b Double
|
||||||
= regionRect enclosedDias
|
findDia n1
|
||||||
where
|
= maybe mempty snd
|
||||||
enclosedDias = fmap findDia enclosedNames
|
(find (\(NamedIcon n2 _, _) -> n1 == n2) placedNodes)
|
||||||
findDia n1
|
|
||||||
= maybe mempty snd
|
-- Also draw the region around the icon the lambda is in.
|
||||||
(find (\(NamedIcon n2 _, _) -> n1 == n2) placedNodes)
|
drawRegion :: [NodeName] -> NamedIcon -> SpecialQDiagram b Double
|
||||||
drawRegion _ = mempty
|
drawRegion parentNames icon = case icon of
|
||||||
|
NamedIcon _ (FlatLambdaIcon _ enclosedNames)
|
||||||
|
-> regionRect $ fmap findDia (parentNames <> enclosedNames)
|
||||||
|
NamedIcon parentName (NestedApply _ headIcon icons)
|
||||||
|
-> mconcat
|
||||||
|
$ drawRegion (parentName:parentNames) <$> catMaybes (headIcon:icons)
|
||||||
|
_ -> mempty
|
||||||
|
|
||||||
-- TODO Use something better than a rectangle
|
-- TODO Use something better than a rectangle
|
||||||
regionRect dias
|
regionRect dias
|
||||||
|
1
todo.md
1
todo.md
@ -2,7 +2,6 @@
|
|||||||
|
|
||||||
## Todo Now
|
## Todo Now
|
||||||
* Remove port number magic numbers in GraphAlgorithms.hs.
|
* Remove port number magic numbers in GraphAlgorithms.hs.
|
||||||
* Fix embedded lambdas missing their enclosures.
|
|
||||||
* Add command line flags for color style, embedding, and whether to draw arrowheads.
|
* 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..
|
* 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