mirror of
https://github.com/rgleichman/glance.git
synced 2024-11-27 03:02:44 +03:00
Give edges in patterns a special color.
This commit is contained in:
Robbie Gleichman
parent
ce31dfa29a
commit
b2a9427e57
@ -54,10 +54,11 @@ colorOnBlackScheme = ColorStyle {
|
||||
lamArgResC = lime,
|
||||
regionPerimC = white,
|
||||
caseRhsC = slightlyGreenYellow,
|
||||
patternC = magenta
|
||||
patternC = lightMagenta
|
||||
}
|
||||
where
|
||||
slightlyGreenYellow = sRGB24 212 255 0
|
||||
lightMagenta = sRGB24 255 94 255
|
||||
|
||||
whiteOnBlackScheme :: (Floating a, Ord a) => ColorStyle a
|
||||
whiteOnBlackScheme = ColorStyle {
|
||||
|
||||
@ -14,12 +14,14 @@ import Translate(translateString, drawingFromDecl, drawingsFromModule)
|
||||
|
||||
|
||||
-- TODO Now --
|
||||
-- Use special colors for lines/boxes/text in patterns.
|
||||
|
||||
-- Refactor Translate
|
||||
-- Test reference lookup in case rhs.
|
||||
-- Use special colors for lines/boxes/text in patterns.
|
||||
-- Convert match to a PatBind with a lambda and a let.
|
||||
-- Have the file be a command line argument to main.
|
||||
-- In matchesToCase, don't tuple and untuple for a single argument.
|
||||
-- In evalPatBind, give the edge from the rhs to the pattern a special arrowhead.
|
||||
|
||||
-- TODO Later --
|
||||
-- Let each bool, value pair in Guard icon be flipped to reduce line crossings. Do the same for case.
|
||||
@ -304,6 +306,7 @@ patternTests = [
|
||||
"y (F x) = x",
|
||||
"y = (\\(F x) -> x)",
|
||||
"y = let {g = 3; F x y = h g} in x y",
|
||||
"y = let {F x y = 3} in x y",
|
||||
"y = let {g = 3; F x y = g} in x y",
|
||||
"y = let F x y = g in x y",
|
||||
"F x = g x",
|
||||
|
||||
@ -21,7 +21,7 @@ import Data.Graph.Inductive.PatriciaTree (Gr)
|
||||
import Data.Typeable(Typeable)
|
||||
|
||||
import Icons(colorScheme, Icon(..), iconToDiagram, nameDiagram, defaultLineWidth, ColorStyle(..))
|
||||
import Types(Edge(..), Connection, Drawing(..), EdgeEnd(..), NameAndPort(..))
|
||||
import Types(Edge(..), EdgeOption(..), Connection, Drawing(..), EdgeEnd(..), NameAndPort(..))
|
||||
import Util(fromMaybeError)
|
||||
|
||||
-- If the inferred types for these functions becomes unweildy,
|
||||
@ -69,9 +69,10 @@ arg1ResT len _ = (circle (len / 2) # alignR, mempty)
|
||||
arg1ResH :: (RealFloat n) => ArrowHT n
|
||||
arg1ResH len _ = (circle (len / 2) # alignL, mempty)
|
||||
|
||||
getArrowOpts :: (RealFloat n, Typeable n) => (EdgeEnd, EdgeEnd) -> ArrowOpts n
|
||||
getArrowOpts (t, h) = arrowOptions
|
||||
getArrowOpts :: (RealFloat n, Typeable n) => (EdgeEnd, EdgeEnd) -> [EdgeOption]-> ArrowOpts n
|
||||
getArrowOpts (t, h) opts = arrowOptions
|
||||
where
|
||||
shaftColor = if EdgeInPattern `elem` opts then patternC else lineC
|
||||
ap1ArgTexture = solid (backgroundC colorScheme)
|
||||
ap1ArgStyle = lwG defaultLineWidth . lc (apply1C colorScheme)
|
||||
ap1ResultTexture = solid (apply1C colorScheme)
|
||||
@ -90,24 +91,24 @@ getArrowOpts (t, h) = arrowOptions
|
||||
with & arrowHead .~ noHead
|
||||
& arrowTail .~ noTail
|
||||
& lengths .~ global 0.75
|
||||
& shaftStyle %~ lwG defaultLineWidth . lc (lineC colorScheme)
|
||||
& shaftStyle %~ lwG defaultLineWidth . lc (shaftColor colorScheme)
|
||||
& lookupTail t & lookupHead h
|
||||
|
||||
-- | Given an Edge, return a transformation on Diagrams that will draw a line.
|
||||
connectMaybePorts ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b) =>
|
||||
Edge -> QDiagram b V2 n Any -> QDiagram b V2 n Any
|
||||
connectMaybePorts (Edge (NameAndPort icon0 (Just port0), NameAndPort icon1 (Just port1)) ends) =
|
||||
connectMaybePorts (Edge opts ends (NameAndPort icon0 (Just port0), NameAndPort icon1 (Just port1))) =
|
||||
connect'
|
||||
(getArrowOpts ends)
|
||||
(getArrowOpts ends opts)
|
||||
(icon0 .> port0)
|
||||
(icon1 .> port1)
|
||||
connectMaybePorts (Edge (NameAndPort icon0 Nothing, NameAndPort icon1 (Just port1)) ends) =
|
||||
connectOutside' (getArrowOpts ends) icon0 (icon1 .> port1)
|
||||
connectMaybePorts (Edge (NameAndPort icon0 (Just port0), NameAndPort icon1 Nothing) ends) =
|
||||
connectOutside' (getArrowOpts ends) (icon0 .> port0) icon1
|
||||
connectMaybePorts (Edge (NameAndPort icon0 Nothing, NameAndPort icon1 Nothing) ends) =
|
||||
connectOutside' (getArrowOpts ends) icon0 icon1
|
||||
connectMaybePorts (Edge opts ends (NameAndPort icon0 Nothing, NameAndPort icon1 (Just port1))) =
|
||||
connectOutside' (getArrowOpts ends opts) icon0 (icon1 .> port1)
|
||||
connectMaybePorts (Edge opts ends (NameAndPort icon0 (Just port0), NameAndPort icon1 Nothing)) =
|
||||
connectOutside' (getArrowOpts ends opts) (icon0 .> port0) icon1
|
||||
connectMaybePorts (Edge opts ends (NameAndPort icon0 Nothing, NameAndPort icon1 Nothing)) =
|
||||
connectOutside' (getArrowOpts ends opts) icon0 icon1
|
||||
|
||||
makeConnections ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b) =>
|
||||
|
||||
@ -18,9 +18,9 @@ import Data.Either(partitionEithers, rights)
|
||||
import Data.List(unzip4, partition)
|
||||
import Control.Monad(replicateM)
|
||||
|
||||
import Types(Icon, Edge(..), Drawing(..), NameAndPort(..), IDState,
|
||||
import Types(Icon, Edge(..), EdgeOption(..), Drawing(..), NameAndPort(..), IDState,
|
||||
initialIdState, getId)
|
||||
import Util(toNames, noEnds, nameAndPort, justName, mapFst)
|
||||
import Util(toNames, makeSimpleEdge, noEnds, nameAndPort, justName, mapFst)
|
||||
import Icons(Icon(..))
|
||||
|
||||
type Reference = Either String NameAndPort
|
||||
@ -107,19 +107,21 @@ evalQOp (QConOp n) = evalQName n
|
||||
-- TODO: Refactor with combineExpressions
|
||||
edgesForRefPortList :: Bool -> [(Reference, NameAndPort)] -> IconGraph
|
||||
edgesForRefPortList inPattern portExpPairs = mconcat $ fmap mkGraph portExpPairs where
|
||||
edgeOptions = if inPattern then [EdgeInPattern] else []
|
||||
mkGraph (ref, port) = case ref of
|
||||
Left str -> if inPattern
|
||||
then IconGraph mempty mempty mempty mempty [(str, Right port)]
|
||||
else IconGraph mempty mempty mempty [(str, port)] mempty
|
||||
Right resultPort -> IconGraph mempty [Edge (resultPort, port) noEnds] mempty mempty mempty
|
||||
Right resultPort -> IconGraph mempty [Edge edgeOptions noEnds (resultPort, port)] mempty mempty mempty
|
||||
|
||||
combineExpressions :: Bool -> [(GraphAndRef, NameAndPort)] -> IconGraph
|
||||
combineExpressions inPattern portExpPairs = mconcat $ fmap mkGraph portExpPairs where
|
||||
edgeOptions = if inPattern then [EdgeInPattern] else []
|
||||
mkGraph ((graph, ref), port) = graph <> case ref of
|
||||
Left str -> if inPattern
|
||||
then IconGraph mempty mempty mempty mempty [(str, Right port)]
|
||||
else IconGraph mempty mempty mempty [(str, port)] mempty
|
||||
Right resultPort -> IconGraph mempty [Edge (resultPort, port) noEnds] mempty mempty mempty
|
||||
Right resultPort -> IconGraph mempty [Edge edgeOptions noEnds (resultPort, port)] mempty mempty mempty
|
||||
|
||||
makeApplyGraph :: Bool -> DIA.Name -> (IconGraph, Reference) -> [(IconGraph, Reference)] -> Int -> (IconGraph, NameAndPort)
|
||||
makeApplyGraph inPattern applyIconName funVal argVals numArgs = (newGraph <> combinedGraph, nameAndPort applyIconName 1)
|
||||
@ -271,7 +273,7 @@ makeEdgesCore sinks bindings = partitionEithers $ fmap renameOrMakeEdge sinks
|
||||
renameOrMakeEdge :: (String, NameAndPort) -> Either (String, NameAndPort) Edge
|
||||
renameOrMakeEdge orig@(s, destPort) = case lookup s bindings of
|
||||
Just ref -> case lookupReference bindings ref of
|
||||
(Right sourcePort) -> Right $ Edge (sourcePort, destPort) noEnds
|
||||
(Right sourcePort) -> Right $ makeSimpleEdge (sourcePort, destPort)
|
||||
(Left newStr) -> Left (newStr, destPort)
|
||||
Nothing -> Left orig
|
||||
|
||||
@ -333,11 +335,12 @@ evalCase c e alts = do
|
||||
makeCaseResult resultIconName rhsPort = iconGraphFromIconsEdges rhsNewIcons rhsNewEdges
|
||||
where
|
||||
rhsNewIcons = toNames [(resultIconName, CaseResultIcon)]
|
||||
rhsNewEdges = [Edge (rhsPort, justName resultIconName) noEnds]
|
||||
rhsNewEdges = [makeSimpleEdge (rhsPort, justName resultIconName)]
|
||||
caseResultGraphs = mconcat $ zipWith makeCaseResult resultIconNames (fmap (fst . snd) connectedRhss)
|
||||
filteredRhsEdges = mapFst Right $ fmap snd unConnectedRhss
|
||||
caseEdgeGraph = edgesForRefPortList False $ expEdge : (patEdges <> filteredRhsEdges)
|
||||
finalGraph = caseResultGraphs <> expGraph <> caseEdgeGraph <> caseGraph <> combindedAltGraph
|
||||
patternEdgesGraph = edgesForRefPortList True patEdges
|
||||
caseEdgeGraph = edgesForRefPortList False (expEdge : filteredRhsEdges)
|
||||
finalGraph = mconcat [patternEdgesGraph, caseResultGraphs, expGraph, caseEdgeGraph, caseGraph, combindedAltGraph]
|
||||
pure (finalGraph, nameAndPort caseIconName 1)
|
||||
|
||||
evalTuple :: EvalContext -> [Exp] -> State IDState (IconGraph, NameAndPort)
|
||||
@ -397,9 +400,9 @@ evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do
|
||||
(newEdges, newSinks, bindings) = case patRef of
|
||||
(Left s) -> (mempty, mempty, [(s, rhsRef)])
|
||||
(Right patPort) -> case rhsRef of
|
||||
-- TODO This edge/sink should have a special arrow head to indicate an input to a pattern.
|
||||
(Left rhsStr) -> (mempty, [(rhsStr, patPort)], mempty)
|
||||
-- TODO: This edge should be special to indicate that one side is a pattern.
|
||||
(Right rhsPort) -> ([Edge (rhsPort, patPort) noEnds], mempty, mempty)
|
||||
(Right rhsPort) -> ([makeSimpleEdge (rhsPort, patPort)], mempty, mempty)
|
||||
gr = IconGraph mempty newEdges mempty newSinks bindings
|
||||
pure . makeEdges $ (gr <> rhsGraph <> patGraph)
|
||||
|
||||
@ -409,17 +412,18 @@ iconGraphToDrawing (IconGraph icons edges subDrawings _ _) = Drawing icons edges
|
||||
makeRhsDrawing :: DIA.IsName a => a -> (IconGraph, NameAndPort) -> Drawing
|
||||
makeRhsDrawing resultIconName (rhsGraph, rhsResult)= rhsDrawing where
|
||||
rhsNewIcons = toNames [(resultIconName, ResultIcon)]
|
||||
rhsNewEdges = [Edge (rhsResult, justName resultIconName) noEnds]
|
||||
rhsNewEdges = [makeSimpleEdge (rhsResult, justName resultIconName)]
|
||||
rhsGraphWithResult = rhsGraph <> iconGraphFromIconsEdges rhsNewIcons rhsNewEdges
|
||||
rhsDrawing = iconGraphToDrawing rhsGraphWithResult
|
||||
|
||||
qualifyNameAndPort :: String -> NameAndPort -> NameAndPort
|
||||
qualifyNameAndPort s (NameAndPort n p) = NameAndPort (s DIA..> n) p
|
||||
|
||||
-- TODO Like evalPatBind, this edge should have an indicator that it is the input to a pattern.
|
||||
makePatternEdges :: String -> GraphAndRef -> NameAndPort -> Either IconGraph (String, Reference)
|
||||
makePatternEdges lambdaName (_, Right patPort) lamPort =
|
||||
Left $ iconGraphFromIconsEdges mempty
|
||||
[Edge (lamPort, qualifyNameAndPort lambdaName patPort) noEnds]
|
||||
[makeSimpleEdge (lamPort, qualifyNameAndPort lambdaName patPort)]
|
||||
makePatternEdges _ (_, Left str) lamPort = Right (str, Right lamPort)
|
||||
|
||||
generalEvalLambda :: EvalContext -> [Pat] -> (EvalContext -> State IDState GraphAndRef) -> State IDState (IconGraph, NameAndPort)
|
||||
@ -511,7 +515,7 @@ showTopLevelBinds gr@(IconGraph _ _ _ _ binds) = do
|
||||
uniquePatName <- getUniqueName patName
|
||||
let
|
||||
icons = toNames [(uniquePatName, TextBoxIcon patName)]
|
||||
edges = [Edge (justName uniquePatName, port) noEnds]
|
||||
edges = [makeSimpleEdge (justName uniquePatName, port)]
|
||||
edgeGraph = iconGraphFromIconsEdges icons edges
|
||||
pure edgeGraph
|
||||
newGraph <- mconcat <$> mapM addBind binds
|
||||
|
||||
@ -5,6 +5,7 @@ module Types (
|
||||
NameAndPort(..),
|
||||
Connection(..),
|
||||
Edge(..),
|
||||
EdgeOption(..),
|
||||
EdgeEnd(..),
|
||||
Drawing(..),
|
||||
IDState,
|
||||
@ -29,9 +30,11 @@ data NameAndPort = NameAndPort Name (Maybe Int) deriving (Show)
|
||||
|
||||
type Connection = (NameAndPort, NameAndPort)
|
||||
|
||||
data EdgeOption = EdgeInPattern deriving (Show, Eq)
|
||||
|
||||
-- | An Edge has an name of the source icon, and its optional port number,
|
||||
-- and the name of the destination icon, and its optional port number.
|
||||
data Edge = Edge {edgeConnection :: Connection, edgeEnds :: (EdgeEnd, EdgeEnd)}
|
||||
data Edge = Edge {edgeOptions::[EdgeOption], edgeEnds :: (EdgeEnd, EdgeEnd), edgeConnection :: Connection}
|
||||
deriving (Show)
|
||||
|
||||
data EdgeEnd = EndAp1Result | EndAp1Arg | EndNone deriving (Show)
|
||||
|
||||
16
app/Util.hs
16
app/Util.hs
@ -8,6 +8,7 @@ module Util (
|
||||
--iconHeadToPort,
|
||||
iconTailToPort,
|
||||
toNames,
|
||||
makeSimpleEdge,
|
||||
noEnds,
|
||||
nameAndPort,
|
||||
justName,
|
||||
@ -19,7 +20,7 @@ import Control.Arrow(first)
|
||||
import Diagrams.Prelude(IsName, toName, Name)
|
||||
import Data.Maybe(fromMaybe)
|
||||
|
||||
import Types(EdgeEnd(..), Edge(..), NameAndPort(..))
|
||||
import Types(EdgeEnd(..), Edge(..), NameAndPort(..), Connection)
|
||||
|
||||
mapFst :: Functor f => (a -> b) -> f (a, c) -> f (b, c)
|
||||
mapFst f = fmap (first f)
|
||||
@ -30,6 +31,9 @@ toNames = mapFst toName
|
||||
noEnds :: (EdgeEnd, EdgeEnd)
|
||||
noEnds = (EndNone, EndNone)
|
||||
|
||||
makeSimpleEdge :: Connection -> Edge
|
||||
makeSimpleEdge = Edge [] noEnds
|
||||
|
||||
nameAndPort :: IsName a => a -> Int -> NameAndPort
|
||||
nameAndPort n p = NameAndPort (toName n) (Just p)
|
||||
|
||||
@ -38,25 +42,25 @@ justName n = NameAndPort (toName n) Nothing
|
||||
|
||||
-- Edge constructors --
|
||||
portToPort :: (IsName a, IsName b) => a -> Int -> b -> Int -> Edge
|
||||
portToPort a b c d = Edge (nameAndPort a b, nameAndPort c d) noEnds
|
||||
portToPort a b c d = makeSimpleEdge (nameAndPort a b, nameAndPort c d)
|
||||
|
||||
iconToPort :: (IsName a, IsName b) => a -> b -> Int -> Edge
|
||||
iconToPort a c d = Edge (justName a, nameAndPort c d) noEnds
|
||||
iconToPort a c d = makeSimpleEdge (justName a, nameAndPort c d)
|
||||
|
||||
iconToIcon :: (IsName a, IsName b) => a -> b -> Edge
|
||||
iconToIcon a c = Edge (justName a, justName c) noEnds
|
||||
iconToIcon a c = makeSimpleEdge (justName a, justName c)
|
||||
|
||||
|
||||
-- If there are gaps between the arrow and the icon, try switching the first two arguments
|
||||
-- with the last two arguments
|
||||
iconToIconEnds :: (IsName a, IsName b) => a -> EdgeEnd -> b -> EdgeEnd -> Edge
|
||||
iconToIconEnds a b c d = Edge (justName a, justName c) (b, d)
|
||||
iconToIconEnds a b c d = Edge [] (b, d) (justName a, justName c)
|
||||
|
||||
-- iconHeadToPort :: (IsName a, IsName b) => a -> EdgeEnd -> b -> Int -> Edge
|
||||
-- iconHeadToPort a endHead c d = Edge (justName a, nameAndPort c d) (EndNone, endHead)
|
||||
|
||||
iconTailToPort :: (IsName a, IsName b) => a -> EdgeEnd -> b -> Int -> Edge
|
||||
iconTailToPort a endTail c d = Edge (justName a, nameAndPort c d) (endTail, EndNone)
|
||||
iconTailToPort a endTail c d = Edge [] (endTail, EndNone) (justName a, nameAndPort c d)
|
||||
|
||||
fromMaybeError :: String -> Maybe a -> a
|
||||
fromMaybeError s = fromMaybe (error s)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user