mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-16 18:30:36 +03:00
Translate nested icons. Fix nested icons missing edges in GraphViz graph.
This commit is contained in:
parent
5f958e07f2
commit
dd758a38ad
26
app/Icons.hs
26
app/Icons.hs
@ -43,13 +43,14 @@ iconToDiagram (PAppIcon n str) _ = pAppDia n str
|
||||
iconToDiagram (TextApplyAIcon n str) _ = textApplyADia n str
|
||||
iconToDiagram ResultIcon _ = identDiaFunc resultIcon
|
||||
iconToDiagram BranchIcon _ = identDiaFunc branchIcon
|
||||
iconToDiagram (TextBoxIcon s) _ = identDiaFunc $ textBox s
|
||||
iconToDiagram (TextBoxIcon s) _ = textBox s
|
||||
iconToDiagram (BindTextBoxIcon s) _ = identDiaFunc $ bindTextBox s
|
||||
iconToDiagram (GuardIcon n) _ = identDiaFunc $ guardIcon n
|
||||
iconToDiagram (CaseIcon n) _ = identDiaFunc $ caseIcon n
|
||||
iconToDiagram CaseResultIcon _ = identDiaFunc caseResult
|
||||
iconToDiagram (FlatLambdaIcon n) _ = identDiaFunc $ flatLambda n
|
||||
iconToDiagram (NestedApply s args) _ = nestedApplyDia s args
|
||||
iconToDiagram (NestedPApp s args) _ = nestedPAppDia s args
|
||||
iconToDiagram (LambdaRegionIcon n diagramName) nameToSubdiagramMap =
|
||||
identDiaFunc $ lambdaRegion n dia
|
||||
where
|
||||
@ -138,24 +139,31 @@ transformCorrectedTextBox str textCol borderCol reflect angle =
|
||||
textBoxRotation = if (reducedAngle > (1/4)) && (reducedAngle < (3/4)) then 1 / 2 else 0
|
||||
reflectIfTrue shouldReflect dia = if shouldReflect then reflectX dia else dia
|
||||
|
||||
|
||||
nestedApplyDia :: SpecialBackend b =>
|
||||
String -> [Maybe (Name, Icon)] -> TransformableDia b
|
||||
nestedApplyDia funText args reflect angle = transformedText ||| centerY finalDia
|
||||
nestedApplyDia = generalNestedDia (textBoxC colorScheme) (apply0C colorScheme)
|
||||
|
||||
nestedPAppDia :: SpecialBackend b =>
|
||||
String -> [Maybe (Name, Icon)] -> TransformableDia b
|
||||
nestedPAppDia = generalNestedDia (patternTextC colorScheme) (patternC colorScheme)
|
||||
|
||||
generalNestedDia :: SpecialBackend b =>
|
||||
Colour Double -> Colour Double-> String -> [Maybe (Name, Icon)] -> TransformableDia b
|
||||
generalNestedDia textCol borderCol funText args reflect angle = centerXY $ transformedText ||| centerY finalDia
|
||||
where
|
||||
transformedText = transformCorrectedTextBox funText (textBoxTextC colorScheme) (apply0C colorScheme) reflect angle
|
||||
transformedText = transformCorrectedTextBox funText textCol borderCol reflect angle
|
||||
seperation = circleRadius * 1.5
|
||||
verticalSeperation = circleRadius
|
||||
appColor = apply0C colorScheme
|
||||
n = length args
|
||||
trianglePortsCircle = hsep seperation $
|
||||
reflectX (fc appColor apply0Triangle) :
|
||||
reflectX (fc borderCol apply0Triangle) :
|
||||
zipWith makeInnerIcon [2,3..] args ++
|
||||
[makePort 1 <> alignR (circle circleRadius # fc appColor # lwG defaultLineWidth # lc appColor)]
|
||||
[makePort 1 <> alignR (circle circleRadius # fc borderCol # lwG defaultLineWidth # lc borderCol)]
|
||||
|
||||
allPorts = makePort 0 <> alignL trianglePortsCircle
|
||||
topAndBottomLineWidth = width allPorts - circleRadius
|
||||
argBox = rect topAndBottomLineWidth (height allPorts + verticalSeperation)# lc appColor # lwG defaultLineWidth # alignL
|
||||
argBox = rect topAndBottomLineWidth (height allPorts + verticalSeperation)# lc borderCol # lwG defaultLineWidth # alignL
|
||||
finalDia = argBox <> allPorts
|
||||
|
||||
makeInnerIcon portNum Nothing = makePort portNum <> portCircle
|
||||
@ -171,8 +179,8 @@ textBoxHeightFactor :: (Fractional a) => a
|
||||
textBoxHeightFactor = 1.1
|
||||
|
||||
textBox :: SpecialBackend b =>
|
||||
String -> SpecialQDiagram b
|
||||
textBox = coloredTextBox (textBoxTextC colorScheme) $ opaque (textBoxC colorScheme)
|
||||
String -> TransformableDia b
|
||||
textBox t = transformCorrectedTextBox t (textBoxTextC colorScheme) $ textBoxC colorScheme
|
||||
|
||||
bindTextBox :: SpecialBackend b =>
|
||||
String -> SpecialQDiagram b
|
||||
|
@ -6,6 +6,7 @@ module Rendering (
|
||||
|
||||
import Diagrams.Prelude
|
||||
import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph')
|
||||
import Diagrams.Core.Names(Name(..))
|
||||
--import Diagrams.Backend.SVG(B)
|
||||
|
||||
import qualified Data.GraphViz as GV
|
||||
@ -57,11 +58,18 @@ makeNamedMap :: SpecialBackend b =>
|
||||
makeNamedMap subDiagramMap =
|
||||
map (\(name, icon) -> (name, iconToDiagram icon subDiagramMap))
|
||||
|
||||
-- Note that the name type alias is different from the Name constructor.
|
||||
getTopLevelName :: Name -> Name
|
||||
getTopLevelName (Name []) = Name []
|
||||
getTopLevelName (Name (x:_)) = Name [x]
|
||||
|
||||
|
||||
-- TODO: Not sure if using getTopLevelName here will break the old nested lambda icon.
|
||||
-- | Make an inductive Graph from a list of node names, and a list of Connections.
|
||||
edgesToGraph :: [Name] -> [(NameAndPort, NameAndPort)] -> Gr Name ()
|
||||
edgesToGraph iconNames edges = mkGraph iconNames simpleEdges
|
||||
where
|
||||
simpleEdges = map (\(NameAndPort a _, NameAndPort c _) -> (a, c, ())) edges
|
||||
simpleEdges = map (\(NameAndPort a _, NameAndPort c _) -> (getTopLevelName a, getTopLevelName c, ())) edges
|
||||
|
||||
-- | Custom arrow tail for the arg1 result circle.
|
||||
-- The ArrowHT type does not seem to be documented.
|
||||
|
@ -16,6 +16,7 @@ import Control.Monad.State(State, evalState)
|
||||
import Data.Either(partitionEithers)
|
||||
import Data.List(unzip4, partition)
|
||||
import Control.Monad(replicateM)
|
||||
import Data.Maybe(catMaybes)
|
||||
|
||||
import Types(Drawing(..), NameAndPort(..), IDState,
|
||||
initialIdState, Edge)
|
||||
@ -108,8 +109,34 @@ qOpToString :: QOp -> String
|
||||
qOpToString (QVarOp n) = qNameToString n
|
||||
qOpToString (QConOp n) = qNameToString n
|
||||
|
||||
--decideIfNested :: ((IconGraph, r), p) -> (Maybe ((IconGraph, r), p), Maybe (DIA.Name, Icon))
|
||||
decideIfNested valAndPort@((IconGraph [nameAndIcon] [] [] sinks bindings, _), _) = (Nothing, Just nameAndIcon, sinks, bindings)
|
||||
decideIfNested valAndPort = (Just valAndPort, Nothing, [], [])
|
||||
|
||||
makeTextApplyGraph :: Bool -> DIA.Name -> String -> [(IconGraph, Reference)] -> Int -> (IconGraph, NameAndPort)
|
||||
makeTextApplyGraph inPattern applyIconName funStr argVals numArgs = (newGraph <> combinedGraph, nameAndPort applyIconName 1)
|
||||
makeTextApplyGraph inPattern applyIconName funStr argVals numArgs = result
|
||||
where
|
||||
result = nestedApplyResult
|
||||
argumentPorts = map (nameAndPort applyIconName) [2,3..]
|
||||
(unnestedArgsAndPort, nestedArgs, nestedSinks, nestedBindings) = unzip4 $ map decideIfNested (zip argVals argumentPorts)
|
||||
qualifiedSinks = map qualifySink (mconcat nestedSinks)
|
||||
qualifySink (str, (NameAndPort n p)) = (str, NameAndPort (applyIconName DIA..> n) p)
|
||||
|
||||
qualifiedBinds = map qualifyBinds (mconcat nestedBindings)
|
||||
qualifyBinds (str, ref) = (str, qualifiedRef) where
|
||||
qualifiedRef = case ref of
|
||||
Left _ -> ref
|
||||
Right (NameAndPort n p) -> Right $ NameAndPort (applyIconName DIA..> n) p
|
||||
|
||||
combinedGraph = combineExpressions inPattern $ catMaybes unnestedArgsAndPort
|
||||
icon = if inPattern then NestedPApp else NestedApply
|
||||
icons = [(applyIconName, icon funStr nestedArgs)]
|
||||
newGraph = IconGraph icons [] [] qualifiedSinks qualifiedBinds
|
||||
nestedApplyResult = (newGraph <> combinedGraph, nameAndPort applyIconName 1)
|
||||
|
||||
|
||||
makeTextApplyGraph' :: Bool -> DIA.Name -> String -> [(IconGraph, Reference)] -> Int -> (IconGraph, NameAndPort)
|
||||
makeTextApplyGraph' inPattern applyIconName funStr argVals numArgs = (newGraph <> combinedGraph, nameAndPort applyIconName 1)
|
||||
where
|
||||
argumentPorts = map (nameAndPort applyIconName) [2,3..]
|
||||
combinedGraph = combineExpressions inPattern $ zip argVals argumentPorts
|
||||
|
@ -31,6 +31,7 @@ data Icon = ResultIcon | BranchIcon | TextBoxIcon String | GuardIcon Int
|
||||
| BindTextBoxIcon String
|
||||
-- TODO: NestedApply should have the type NestedApply (Maybe (Name, Icon)) [Maybe (Name, Icon)]
|
||||
| NestedApply String [Maybe (Name, Icon)]
|
||||
| NestedPApp String [Maybe (Name, Icon)]
|
||||
deriving (Show)
|
||||
|
||||
data NameAndPort = NameAndPort Name (Maybe Int) deriving (Show)
|
||||
|
@ -26,6 +26,7 @@ executable glance-exe
|
||||
build-depends: base
|
||||
, glance
|
||||
, diagrams
|
||||
, diagrams-core
|
||||
, diagrams-lib
|
||||
, diagrams-svg
|
||||
, diagrams-graphviz
|
||||
|
Loading…
Reference in New Issue
Block a user