mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Case and guard icons can now embed literals.
This commit is contained in:
parent
0185257444
commit
9523dcd609
@ -11,13 +11,14 @@ import Data.List(foldl', find)
|
|||||||
import Data.Maybe(catMaybes, isJust, fromMaybe)
|
import Data.Maybe(catMaybes, isJust, fromMaybe)
|
||||||
--import qualified Debug.Trace
|
--import qualified Debug.Trace
|
||||||
|
|
||||||
import Types(SyntaxNode(..), sgNamedNodeToSyntaxNode, IngSyntaxGraph, Edge(..))
|
import Types(SyntaxNode(..), sgNamedNodeToSyntaxNode, IngSyntaxGraph, Edge(..),
|
||||||
|
CaseOrGuardTag(..))
|
||||||
import Util(maybeBoolToBool)
|
import Util(maybeBoolToBool)
|
||||||
--import Util(printSelf)
|
--import Util(printSelf)
|
||||||
|
|
||||||
-- See graph_algs.txt for pseudocode
|
-- See graph_algs.txt for pseudocode
|
||||||
|
|
||||||
data ParentType = ApplyParent | NotAParent
|
data ParentType = ApplyParent | CaseOrGuardParent | NotAParent deriving (Eq, Show)
|
||||||
|
|
||||||
-- START HELPER functions --
|
-- START HELPER functions --
|
||||||
|
|
||||||
@ -26,19 +27,20 @@ syntaxNodeIsEmbeddable :: ParentType -> SyntaxNode -> Bool
|
|||||||
syntaxNodeIsEmbeddable parentType n = case (parentType, n) of
|
syntaxNodeIsEmbeddable parentType n = case (parentType, n) of
|
||||||
(ApplyParent, LikeApplyNode _ _) -> True
|
(ApplyParent, LikeApplyNode _ _) -> True
|
||||||
(ApplyParent, LiteralNode _) -> True
|
(ApplyParent, LiteralNode _) -> True
|
||||||
|
(CaseOrGuardParent, LiteralNode _) -> True
|
||||||
_ -> False
|
_ -> False
|
||||||
|
|
||||||
-- | A syntaxNodeCanEmbed if it can contain other nodes
|
-- | A syntaxNodeCanEmbed if it can contain other nodes
|
||||||
syntaxNodeCanEmbed :: SyntaxNode -> Bool
|
syntaxNodeCanEmbed :: SyntaxNode -> Bool
|
||||||
syntaxNodeCanEmbed n = case n of
|
syntaxNodeCanEmbed = (NotAParent /=) . parentTypeForNode
|
||||||
LikeApplyNode _ _ -> True
|
|
||||||
NestedApplyNode _ _ _ -> True -- This case should not happen
|
|
||||||
_ -> False
|
|
||||||
|
|
||||||
parentTypeForNode :: SyntaxNode -> ParentType
|
parentTypeForNode :: SyntaxNode -> ParentType
|
||||||
parentTypeForNode n = case n of
|
parentTypeForNode n = case n of
|
||||||
LikeApplyNode _ _ -> ApplyParent
|
LikeApplyNode _ _ -> ApplyParent
|
||||||
NestedApplyNode _ _ _ -> ApplyParent
|
NestedApplyNode _ _ _ -> ApplyParent
|
||||||
|
CaseNode _ -> CaseOrGuardParent
|
||||||
|
GuardNode _ -> CaseOrGuardParent
|
||||||
|
NestedCaseOrGuardNode _ _ _ -> CaseOrGuardParent
|
||||||
-- The NotAParent case should never occur.
|
-- The NotAParent case should never occur.
|
||||||
_ -> NotAParent
|
_ -> NotAParent
|
||||||
|
|
||||||
@ -205,6 +207,8 @@ embedChildSyntaxNodes parentNode childrenNodes oldGraph = case childrenNodes of
|
|||||||
newNodeLabel = (nodeName, newSyntaxNode)
|
newNodeLabel = (nodeName, newSyntaxNode)
|
||||||
newSyntaxNode = case oldSyntaxNode of
|
newSyntaxNode = case oldSyntaxNode of
|
||||||
LikeApplyNode flavor x -> NestedApplyNode flavor x childrenAndEdgesToParent
|
LikeApplyNode flavor x -> NestedApplyNode flavor x childrenAndEdgesToParent
|
||||||
|
CaseNode x -> NestedCaseOrGuardNode CaseTag x childrenAndEdgesToParent
|
||||||
|
GuardNode x -> NestedCaseOrGuardNode GuardTag x childrenAndEdgesToParent
|
||||||
_ -> oldSyntaxNode
|
_ -> oldSyntaxNode
|
||||||
childrenAndEdgesToParent = catMaybes $ fmap findChildAndEdge childrenNodes
|
childrenAndEdgesToParent = catMaybes $ fmap findChildAndEdge childrenNodes
|
||||||
findChildAndEdge childNode =
|
findChildAndEdge childNode =
|
||||||
|
77
app/Icons.hs
77
app/Icons.hs
@ -25,6 +25,7 @@ import Diagrams.Prelude hiding ((&), (#), Name)
|
|||||||
|
|
||||||
import Data.List(find)
|
import Data.List(find)
|
||||||
import Data.Maybe(catMaybes, listToMaybe)
|
import Data.Maybe(catMaybes, listToMaybe)
|
||||||
|
import Data.Either(partitionEithers)
|
||||||
|
|
||||||
-- import Diagrams.Backend.SVG(B)
|
-- import Diagrams.Backend.SVG(B)
|
||||||
--import Diagrams.TwoD.Text(Text)
|
--import Diagrams.TwoD.Text(Text)
|
||||||
@ -54,6 +55,8 @@ iconToDiagram CaseResultIcon = identDiaFunc caseResult
|
|||||||
iconToDiagram (FlatLambdaIcon n) = identDiaFunc $ flatLambda n
|
iconToDiagram (FlatLambdaIcon n) = identDiaFunc $ flatLambda n
|
||||||
iconToDiagram (NestedApply flavor args) = nestedApplyDia flavor args
|
iconToDiagram (NestedApply flavor args) = nestedApplyDia flavor args
|
||||||
iconToDiagram (NestedPApp args) = nestedPAppDia args
|
iconToDiagram (NestedPApp args) = nestedPAppDia args
|
||||||
|
iconToDiagram (NestedCaseIcon args) = nestedCaseDia args
|
||||||
|
iconToDiagram (NestedGuardIcon args) = nestedGuardDia args
|
||||||
|
|
||||||
applyPortAngles :: Floating n => Port -> [Angle n]
|
applyPortAngles :: Floating n => Port -> [Angle n]
|
||||||
applyPortAngles (Port x) = fmap (@@ turn) $ case x of
|
applyPortAngles (Port x) = fmap (@@ turn) $ case x of
|
||||||
@ -107,6 +110,8 @@ getPortAngles icon port maybeNodeName = case icon of
|
|||||||
FlatLambdaIcon _ -> applyPortAngles port
|
FlatLambdaIcon _ -> applyPortAngles port
|
||||||
NestedApply _ args -> nestedApplyPortAngles args port maybeNodeName
|
NestedApply _ args -> nestedApplyPortAngles args port maybeNodeName
|
||||||
NestedPApp args -> nestedApplyPortAngles args port maybeNodeName
|
NestedPApp args -> nestedApplyPortAngles args port maybeNodeName
|
||||||
|
NestedCaseIcon _ -> guardPortAngles port
|
||||||
|
NestedGuardIcon _ -> guardPortAngles port
|
||||||
|
|
||||||
-- END FUNCTIONS --
|
-- END FUNCTIONS --
|
||||||
|
|
||||||
@ -208,6 +213,9 @@ nestedPAppDia :: SpecialBackend b n =>
|
|||||||
[Maybe (NodeName, Icon)] -> TransformableDia b n
|
[Maybe (NodeName, Icon)] -> TransformableDia b n
|
||||||
nestedPAppDia = generalNestedDia apply0Triangle (repeat $ patternC colorScheme)
|
nestedPAppDia = generalNestedDia apply0Triangle (repeat $ patternC colorScheme)
|
||||||
|
|
||||||
|
makeQualifiedPort :: SpecialNum n => NodeName -> Port -> SpecialQDiagram b n
|
||||||
|
makeQualifiedPort n x = n .>> makePort x
|
||||||
|
|
||||||
generalNestedDia :: SpecialBackend b n =>
|
generalNestedDia :: SpecialBackend b n =>
|
||||||
(Colour Double -> SpecialQDiagram b n) -> [Colour Double] -> [Maybe (NodeName, Icon)] -> TransformableDia b n
|
(Colour Double -> SpecialQDiagram b n) -> [Colour Double] -> [Maybe (NodeName, Icon)] -> TransformableDia b n
|
||||||
generalNestedDia dia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = named name $ case funcNodeNameAndArgs of
|
generalNestedDia dia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = named name $ case funcNodeNameAndArgs of
|
||||||
@ -215,7 +223,7 @@ generalNestedDia dia borderCols funcNodeNameAndArgs name nestingLevel reflect an
|
|||||||
(maybeFunText:args) -> centerXY $ transformedText ||| centerY finalDia
|
(maybeFunText:args) -> centerXY $ transformedText ||| centerY finalDia
|
||||||
where
|
where
|
||||||
borderCol = borderCols !! nestingLevel
|
borderCol = borderCols !! nestingLevel
|
||||||
makeQualifiedPort x = name .>> makePort x
|
|
||||||
transformedText = case maybeFunText of
|
transformedText = case maybeFunText of
|
||||||
Just _ -> makeInnerIcon True 0 maybeFunText
|
Just _ -> makeInnerIcon True 0 maybeFunText
|
||||||
Nothing -> mempty
|
Nothing -> mempty
|
||||||
@ -224,14 +232,14 @@ generalNestedDia dia borderCols funcNodeNameAndArgs name nestingLevel reflect an
|
|||||||
trianglePortsCircle = hsep seperation $
|
trianglePortsCircle = hsep seperation $
|
||||||
reflectX (dia borderCol) :
|
reflectX (dia borderCol) :
|
||||||
zipWith (makeInnerIcon False) [2,3..] args ++
|
zipWith (makeInnerIcon False) [2,3..] args ++
|
||||||
[makeQualifiedPort (Port 1) <> alignR (lc borderCol $ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)]
|
[makeQualifiedPort name (Port 1) <> alignR (lc borderCol $ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)]
|
||||||
|
|
||||||
allPorts = makeQualifiedPort (Port 0) <> alignL trianglePortsCircle
|
allPorts = makeQualifiedPort name (Port 0) <> alignL trianglePortsCircle
|
||||||
topAndBottomLineWidth = width allPorts - circleRadius
|
topAndBottomLineWidth = width allPorts - circleRadius
|
||||||
argBox = alignL $ lwG defaultLineWidth $ lc borderCol $ roundedRect topAndBottomLineWidth (height allPorts + verticalSeperation) (circleRadius * 0.5)
|
argBox = alignL $ lwG defaultLineWidth $ lc borderCol $ roundedRect topAndBottomLineWidth (height allPorts + verticalSeperation) (circleRadius * 0.5)
|
||||||
finalDia = argBox <> allPorts
|
finalDia = argBox <> allPorts
|
||||||
|
|
||||||
makeInnerIcon _ portNum Nothing = makeQualifiedPort (Port portNum) <> portCircle
|
makeInnerIcon _ portNum Nothing = makeQualifiedPort name (Port portNum) <> portCircle
|
||||||
makeInnerIcon True _ (Just (_, TextBoxIcon t)) = transformCorrectedTextBox t (textBoxTextC colorScheme) borderCol reflect angle
|
makeInnerIcon True _ (Just (_, TextBoxIcon t)) = transformCorrectedTextBox t (textBoxTextC colorScheme) borderCol reflect angle
|
||||||
makeInnerIcon func _ (Just (iconNodeName, icon)) = iconToDiagram icon iconNodeName innerLevel reflect angle where
|
makeInnerIcon func _ (Just (iconNodeName, icon)) = iconToDiagram icon iconNodeName innerLevel reflect angle where
|
||||||
innerLevel = if func then nestingLevel else nestingLevel + 1
|
innerLevel = if func then nestingLevel else nestingLevel + 1
|
||||||
@ -322,16 +330,16 @@ guardSize :: (Fractional a) => a
|
|||||||
guardSize = 0.7
|
guardSize = 0.7
|
||||||
|
|
||||||
guardTriangle :: SpecialBackend b n =>
|
guardTriangle :: SpecialBackend b n =>
|
||||||
Int -> SpecialQDiagram b n
|
SpecialQDiagram b n -> SpecialQDiagram b n
|
||||||
guardTriangle x =
|
guardTriangle portDia =
|
||||||
alignL $ alignR (triangleAndPort ||| lwG defaultLineWidth (hrule (guardSize * 0.8))) <> makePort (Port x)
|
alignL $ alignR (triangleAndPort ||| lwG defaultLineWidth (hrule (guardSize * 0.8))) <> portDia
|
||||||
where
|
where
|
||||||
triangleAndPort = alignR $ alignT $ lwG defaultLineWidth $ rotateBy (1/8) $
|
triangleAndPort = alignR $ alignT $ lwG defaultLineWidth $ rotateBy (1/8) $
|
||||||
polygon (polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize] $ with)
|
polygon (polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize] $ with)
|
||||||
|
|
||||||
guardLBracket :: SpecialBackend b n =>
|
guardLBracket :: SpecialBackend b n =>
|
||||||
Int -> SpecialQDiagram b n
|
SpecialQDiagram b n -> SpecialQDiagram b n
|
||||||
guardLBracket x = alignL (alignT ell) <> makePort (Port x)
|
guardLBracket portDia = alignL (alignT ell) <> portDia
|
||||||
where
|
where
|
||||||
ellShape = fromOffsets $ map r2 [(0, guardSize), (-guardSize,0)]
|
ellShape = fromOffsets $ map r2 [(0, guardSize), (-guardSize,0)]
|
||||||
ell = lineJoin LineJoinRound $ lwG defaultLineWidth $ lc (boolC colorScheme) (strokeLine ellShape)
|
ell = lineJoin LineJoinRound $ lwG defaultLineWidth $ lc (boolC colorScheme) (strokeLine ellShape)
|
||||||
@ -342,12 +350,12 @@ guardLBracket x = alignL (alignT ell) <> makePort (Port x)
|
|||||||
-- odds -> left
|
-- odds -> left
|
||||||
-- evens -> right
|
-- evens -> right
|
||||||
generalGuardIcon :: SpecialBackend b n =>
|
generalGuardIcon :: SpecialBackend b n =>
|
||||||
Colour Double -> (Int -> SpecialQDiagram b n) -> SpecialQDiagram b n -> Int -> SpecialQDiagram b n
|
Colour Double -> (SpecialQDiagram b n -> SpecialQDiagram b n) -> SpecialQDiagram b n -> Int -> SpecialQDiagram b n
|
||||||
generalGuardIcon triangleColor lBracket bottomDia n = centerXY $ alignT (bottomDia <> makePort (Port 1)) <> alignB (bigVerticalLine <> guardDia <> makePort (Port 0))
|
generalGuardIcon triangleColor lBracket bottomDia n = centerXY $ alignT (bottomDia <> makePort (Port 1)) <> alignB (bigVerticalLine <> guardDia <> makePort (Port 0))
|
||||||
where
|
where
|
||||||
--guardTriangles = vsep 0.4 (take n (map guardTriangle [0,1..]))
|
--guardTriangles = vsep 0.4 (take n (map guardTriangle [0,1..]))
|
||||||
trianglesWithPorts = map guardTriangle [2,4..]
|
trianglesWithPorts = map (guardTriangle . makePort . Port) [2,4..]
|
||||||
lBrackets = map lBracket [3, 5..]
|
lBrackets = map (lBracket . makePort . Port) [3, 5..]
|
||||||
trianglesAndBrackets =
|
trianglesAndBrackets =
|
||||||
zipWith zipper trianglesWithPorts lBrackets
|
zipWith zipper trianglesWithPorts lBrackets
|
||||||
zipper thisTriangle lBrack = verticalLine === (alignR (extrudeRight guardSize lBrack) <> lc triangleColor (alignL thisTriangle))
|
zipper thisTriangle lBrack = verticalLine === (alignR (extrudeRight guardSize lBrack) <> lc triangleColor (alignL thisTriangle))
|
||||||
@ -356,6 +364,41 @@ generalGuardIcon triangleColor lBracket bottomDia n = centerXY $ alignT (bottomD
|
|||||||
guardDia = vcat (alignT $ take n trianglesAndBrackets)
|
guardDia = vcat (alignT $ take n trianglesAndBrackets)
|
||||||
bigVerticalLine = alignT $ lwG defaultLineWidth $ lc triangleColor $ vrule (height guardDia)
|
bigVerticalLine = alignT $ lwG defaultLineWidth $ lc triangleColor $ vrule (height guardDia)
|
||||||
|
|
||||||
|
generalNestedGuard :: SpecialBackend b n =>
|
||||||
|
Colour Double -> (SpecialQDiagram b n -> SpecialQDiagram b n) -> SpecialQDiagram b n -> [Maybe (NodeName, Icon)] -> TransformableDia b n
|
||||||
|
generalNestedGuard triangleColor lBracket bottomDia inputAndArgs name nestingLevel reflect angle = named name $ case inputAndArgs of
|
||||||
|
[] -> mempty
|
||||||
|
(input : args) -> centerXY finalDia where
|
||||||
|
finalDia = alignT (bottomDia <> makeQualifiedPort name (Port 1)) <> alignB (inputIcon === (bigVerticalLine <> guardDia <> makeQualifiedPort name (Port 0)))
|
||||||
|
|
||||||
|
argPortNums = [2..]
|
||||||
|
innerIcons = fmap makeInnerIcon args
|
||||||
|
|
||||||
|
iconMapper portNum innerIcon
|
||||||
|
| even portNum = Right $ guardTriangle port ||| innerIcon
|
||||||
|
| otherwise = Left $ innerIcon ||| lBracket port
|
||||||
|
where
|
||||||
|
port = (makeQualifiedPort name (Port portNum))
|
||||||
|
|
||||||
|
-- TODO argPortNums is duplicated
|
||||||
|
(lBrackets, trianglesWithPorts) = partitionEithers $ zipWith iconMapper argPortNums innerIcons
|
||||||
|
|
||||||
|
trianglesAndBrackets =
|
||||||
|
zipWith zipper trianglesWithPorts lBrackets
|
||||||
|
|
||||||
|
zipper thisTriangle lBrack = verticalLine === (alignR (extrudeRight guardSize lBrack) <> lc triangleColor (alignL thisTriangle))
|
||||||
|
where
|
||||||
|
verticalLine = strutY 0.4
|
||||||
|
|
||||||
|
inputIcon = makeInnerIcon input
|
||||||
|
|
||||||
|
guardDia = vcat (alignT $ trianglesAndBrackets)
|
||||||
|
bigVerticalLine = alignT $ lwG defaultLineWidth $ lc triangleColor $ vrule (height guardDia)
|
||||||
|
|
||||||
|
makeInnerIcon mNameAndIcon = case mNameAndIcon of
|
||||||
|
Nothing -> mempty
|
||||||
|
Just (iconNodeName, icon) -> iconToDiagram icon iconNodeName nestingLevel reflect angle
|
||||||
|
|
||||||
-- | The ports of the guard icon are as follows:
|
-- | The ports of the guard icon are as follows:
|
||||||
-- Port 0: Top result port
|
-- Port 0: Top result port
|
||||||
-- Port 1: Bottom result port
|
-- Port 1: Bottom result port
|
||||||
@ -365,6 +408,9 @@ guardIcon :: SpecialBackend b n =>
|
|||||||
Int -> SpecialQDiagram b n
|
Int -> SpecialQDiagram b n
|
||||||
guardIcon = generalGuardIcon lineCol guardLBracket mempty
|
guardIcon = generalGuardIcon lineCol guardLBracket mempty
|
||||||
|
|
||||||
|
nestedGuardDia :: SpecialBackend b n => [Maybe (NodeName, Icon)] -> TransformableDia b n
|
||||||
|
nestedGuardDia = generalNestedGuard lineCol guardLBracket mempty
|
||||||
|
|
||||||
-- TODO Improve design to be more than a circle.
|
-- TODO Improve design to be more than a circle.
|
||||||
caseResult :: SpecialBackend b n =>
|
caseResult :: SpecialBackend b n =>
|
||||||
SpecialQDiagram b n
|
SpecialQDiagram b n
|
||||||
@ -373,8 +419,8 @@ caseResult = lw none $ lc caseCColor $ fc caseCColor $ circle (circleRadius * 0.
|
|||||||
caseCColor = caseRhsC colorScheme
|
caseCColor = caseRhsC colorScheme
|
||||||
|
|
||||||
caseC :: SpecialBackend b n =>
|
caseC :: SpecialBackend b n =>
|
||||||
Int -> SpecialQDiagram b n
|
SpecialQDiagram b n -> SpecialQDiagram b n
|
||||||
caseC n = caseResult <> makePort (Port n)
|
caseC portDia = caseResult <> portDia
|
||||||
|
|
||||||
|
|
||||||
-- | The ports of the case icon are as follows:
|
-- | The ports of the case icon are as follows:
|
||||||
@ -386,6 +432,9 @@ caseIcon :: SpecialBackend b n =>
|
|||||||
Int -> SpecialQDiagram b n
|
Int -> SpecialQDiagram b n
|
||||||
caseIcon = generalGuardIcon (patternC colorScheme) caseC caseResult
|
caseIcon = generalGuardIcon (patternC colorScheme) caseC caseResult
|
||||||
|
|
||||||
|
nestedCaseDia :: SpecialBackend b n => [Maybe (NodeName, Icon)] -> TransformableDia b n
|
||||||
|
nestedCaseDia = generalNestedGuard (patternC colorScheme) caseC caseResult
|
||||||
|
|
||||||
-- | The ports of flatLambdaIcon are:
|
-- | The ports of flatLambdaIcon are:
|
||||||
-- 0: Result icon
|
-- 0: Result icon
|
||||||
-- 1: The lambda function value
|
-- 1: The lambda function value
|
||||||
|
@ -92,7 +92,7 @@ getArrowOpts (t, h) _ (fromAngle, toAngle) (NameAndPort (NodeName nodeNum) mPort
|
|||||||
edgeColors = edgeListC colorScheme
|
edgeColors = edgeListC colorScheme
|
||||||
numEdgeColors = length edgeColors
|
numEdgeColors = length edgeColors
|
||||||
hashedColor = edgeColors !! namePortHash
|
hashedColor = edgeColors !! namePortHash
|
||||||
namePortHash = mod (nodeNum + (503 * portNum)) numEdgeColors
|
namePortHash = mod (portNum + (503 * nodeNum)) numEdgeColors
|
||||||
Port portNum = fromMaybe (Port 0) mPort
|
Port portNum = fromMaybe (Port 0) mPort
|
||||||
|
|
||||||
ap1ArgTexture = solid (backgroundC colorScheme)
|
ap1ArgTexture = solid (backgroundC colorScheme)
|
||||||
|
@ -274,7 +274,7 @@ evalIf c e1 e2 e3 = do
|
|||||||
combinedGraph =
|
combinedGraph =
|
||||||
combineExpressions False $ zip [e1Val, e2Val, e3Val] (map (nameAndPort guardName . Port) [3, 2, 4])
|
combineExpressions False $ zip [e1Val, e2Val, e3Val] (map (nameAndPort guardName . Port) [3, 2, 4])
|
||||||
newGraph = syntaxGraphFromNodes icons <> combinedGraph
|
newGraph = syntaxGraphFromNodes icons <> combinedGraph
|
||||||
pure (newGraph, nameAndPort guardName (Port 0))
|
pure (newGraph, nameAndPort guardName (Port 1))
|
||||||
|
|
||||||
evalStmt :: EvalContext -> Stmt -> State IDState GraphAndRef
|
evalStmt :: EvalContext -> Stmt -> State IDState GraphAndRef
|
||||||
evalStmt c (Qualifier e) = evalExp c e
|
evalStmt c (Qualifier e) = evalExp c e
|
||||||
|
@ -34,7 +34,7 @@ import Data.Semigroup(Semigroup, (<>))
|
|||||||
|
|
||||||
import Types(Icon, SyntaxNode(..), Edge(..), EdgeOption(..),
|
import Types(Icon, SyntaxNode(..), Edge(..), EdgeOption(..),
|
||||||
NameAndPort(..), IDState, getId, SgNamedNode, NodeName(..), Port(..), nodeNameToInt,
|
NameAndPort(..), IDState, getId, SgNamedNode, NodeName(..), Port(..), nodeNameToInt,
|
||||||
LikeApplyFlavor(..))
|
LikeApplyFlavor(..), CaseOrGuardTag(..))
|
||||||
import Util(noEnds, nameAndPort, makeSimpleEdge, justName, maybeBoolToBool)
|
import Util(noEnds, nameAndPort, makeSimpleEdge, justName, maybeBoolToBool)
|
||||||
import Icons(Icon(..))
|
import Icons(Icon(..))
|
||||||
|
|
||||||
@ -177,6 +177,7 @@ nodeToIcon (FunctionDefNode n) = FlatLambdaIcon n
|
|||||||
nodeToIcon (GuardNode n) = GuardIcon n
|
nodeToIcon (GuardNode n) = GuardIcon n
|
||||||
nodeToIcon (CaseNode n) = CaseIcon n
|
nodeToIcon (CaseNode n) = CaseIcon n
|
||||||
nodeToIcon CaseResultNode = CaseResultIcon
|
nodeToIcon CaseResultNode = CaseResultIcon
|
||||||
|
nodeToIcon (NestedCaseOrGuardNode tag x edges) = nestedCaseOrGuardNodeToIcon tag x edges
|
||||||
|
|
||||||
makeArg :: [(SgNamedNode, Edge)] -> Int -> Maybe (NodeName, Icon)
|
makeArg :: [(SgNamedNode, Edge)] -> Int -> Maybe (NodeName, Icon)
|
||||||
makeArg args port = case find (findArg (Port port)) args of
|
makeArg args port = case find (findArg (Port port)) args of
|
||||||
@ -190,6 +191,13 @@ nestedApplySyntaxNodeToIcon flavor numArgs args = NestedApply flavor argList whe
|
|||||||
-- TODO Don't use hardcoded port numbers
|
-- TODO Don't use hardcoded port numbers
|
||||||
argList = fmap (makeArg args) (0:[2..numArgs + 1])
|
argList = fmap (makeArg args) (0:[2..numArgs + 1])
|
||||||
|
|
||||||
|
nestedCaseOrGuardNodeToIcon :: CaseOrGuardTag -> Int -> [(SgNamedNode, Edge)] -> Icon
|
||||||
|
nestedCaseOrGuardNodeToIcon tag numArgs args = case tag of
|
||||||
|
CaseTag -> NestedCaseIcon argList
|
||||||
|
GuardTag -> NestedGuardIcon argList
|
||||||
|
where
|
||||||
|
argList = fmap (makeArg args) (0:[2..( 1 + (2 * numArgs))])
|
||||||
|
|
||||||
nestedPatternNodeToIcon :: String -> [Maybe SgNamedNode] -> Icon
|
nestedPatternNodeToIcon :: String -> [Maybe SgNamedNode] -> Icon
|
||||||
nestedPatternNodeToIcon str children = NestedPApp $
|
nestedPatternNodeToIcon str children = NestedPApp $
|
||||||
Just (NodeName (-1), TextBoxIcon str)
|
Just (NodeName (-1), TextBoxIcon str)
|
||||||
|
@ -18,6 +18,7 @@ module Types (
|
|||||||
SgNamedNode,
|
SgNamedNode,
|
||||||
IngSyntaxGraph,
|
IngSyntaxGraph,
|
||||||
LikeApplyFlavor(..),
|
LikeApplyFlavor(..),
|
||||||
|
CaseOrGuardTag(..),
|
||||||
initialIdState,
|
initialIdState,
|
||||||
getId,
|
getId,
|
||||||
sgNamedNodeToSyntaxNode,
|
sgNamedNodeToSyntaxNode,
|
||||||
@ -42,10 +43,14 @@ data Icon = ResultIcon | TextBoxIcon String | GuardIcon Int
|
|||||||
-- TODO: NestedApply should have the type NestedApply (Maybe (Name, Icon)) [Maybe (Name, Icon)]
|
-- TODO: NestedApply should have the type NestedApply (Maybe (Name, Icon)) [Maybe (Name, Icon)]
|
||||||
| NestedApply LikeApplyFlavor [Maybe (NodeName, Icon)]
|
| NestedApply LikeApplyFlavor [Maybe (NodeName, Icon)]
|
||||||
| NestedPApp [Maybe (NodeName, Icon)]
|
| NestedPApp [Maybe (NodeName, Icon)]
|
||||||
|
| NestedCaseIcon [Maybe (NodeName, Icon)]
|
||||||
|
| NestedGuardIcon [Maybe (NodeName, Icon)]
|
||||||
deriving (Show, Eq, Ord)
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
data LikeApplyFlavor = ApplyNodeFlavor | ComposeNodeFlavor deriving (Show, Eq, Ord)
|
data LikeApplyFlavor = ApplyNodeFlavor | ComposeNodeFlavor deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
|
data CaseOrGuardTag = CaseTag | GuardTag deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
-- TODO remove Ints from SyntaxNode data constructors.
|
-- TODO remove Ints from SyntaxNode data constructors.
|
||||||
data SyntaxNode =
|
data SyntaxNode =
|
||||||
LikeApplyNode LikeApplyFlavor Int -- Function application, composition, and applying to a composition
|
LikeApplyNode LikeApplyFlavor Int -- Function application, composition, and applying to a composition
|
||||||
@ -60,6 +65,7 @@ data SyntaxNode =
|
|||||||
| GuardNode Int
|
| GuardNode Int
|
||||||
| CaseNode Int
|
| CaseNode Int
|
||||||
| CaseResultNode -- TODO remove caseResultNode
|
| CaseResultNode -- TODO remove caseResultNode
|
||||||
|
| NestedCaseOrGuardNode CaseOrGuardTag Int [(SgNamedNode, Edge)]
|
||||||
deriving (Show, Eq, Ord)
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
newtype NodeName = NodeName Int deriving (Typeable, Eq, Ord, Show)
|
newtype NodeName = NodeName Int deriving (Typeable, Eq, Ord, Show)
|
||||||
|
@ -187,6 +187,38 @@ nestedTextDrawing = Drawing nestedTestIcons nestedTestEdges where
|
|||||||
iconToIntPort t2 n2 2
|
iconToIntPort t2 n2 2
|
||||||
]
|
]
|
||||||
|
|
||||||
|
nestedCaseDrawing :: Drawing
|
||||||
|
nestedCaseDrawing = Drawing icons [] where
|
||||||
|
[n0, n1, n2, n3, n4, n5, n6, n7, n8, n9] = fmap NodeName [0..9]
|
||||||
|
icons = [
|
||||||
|
(n0, NestedCaseIcon [Nothing, Nothing, Nothing]),
|
||||||
|
(n1, NestedCaseIcon [Nothing, Just (n2, TextBoxIcon "n2"), Nothing]),
|
||||||
|
(n3, NestedCaseIcon [Nothing, Nothing, Just (n4, TextBoxIcon "n4")]),
|
||||||
|
(n5, NestedCaseIcon [Nothing,
|
||||||
|
Just (n6, TextBoxIcon "n6"),
|
||||||
|
Just (n7, TextBoxIcon "n7"),
|
||||||
|
Just (n8, TextBoxIcon "n8"),
|
||||||
|
Just (n9, TextBoxIcon "n9")])
|
||||||
|
]
|
||||||
|
|
||||||
|
nestedGuardDrawing :: Drawing
|
||||||
|
nestedGuardDrawing = Drawing icons edges where
|
||||||
|
[n0, n1, n2, n3, n4, n5, n6, n7, n8, n9, n10] = fmap NodeName [0..10]
|
||||||
|
icons = [
|
||||||
|
(n10, TextBoxIcon "n10"),
|
||||||
|
(n0, NestedGuardIcon [Nothing, Nothing, Nothing]),
|
||||||
|
(n1, NestedGuardIcon [Nothing, Just (n2, TextBoxIcon "n2"), Nothing]),
|
||||||
|
(n3, NestedGuardIcon [Nothing, Nothing, Just (n4, TextBoxIcon "n4")]),
|
||||||
|
(n5, NestedGuardIcon [Nothing,
|
||||||
|
Just (n6, TextBoxIcon "n6"),
|
||||||
|
Just (n7, TextBoxIcon "n7"),
|
||||||
|
Just (n8, TextBoxIcon "n8"),
|
||||||
|
Just (n9, TextBoxIcon "n9")])
|
||||||
|
]
|
||||||
|
edges = [
|
||||||
|
iconToIntPort n10 n5 0
|
||||||
|
]
|
||||||
|
|
||||||
--renderTests :: IO (Diagram B)
|
--renderTests :: IO (Diagram B)
|
||||||
renderTests :: SpecialBackend b Double => IO (SpecialQDiagram b Double)
|
renderTests :: SpecialBackend b Double => IO (SpecialQDiagram b Double)
|
||||||
renderTests = do
|
renderTests = do
|
||||||
@ -200,6 +232,8 @@ renderTests = do
|
|||||||
fact1Drawing,
|
fact1Drawing,
|
||||||
fact2Drawing,
|
fact2Drawing,
|
||||||
arrowTestDrawing,
|
arrowTestDrawing,
|
||||||
nestedTextDrawing
|
nestedTextDrawing,
|
||||||
|
nestedCaseDrawing,
|
||||||
|
nestedGuardDrawing
|
||||||
-- TODO Add a nested test where the function expression is nested.
|
-- TODO Add a nested test where the function expression is nested.
|
||||||
]
|
]
|
||||||
|
@ -209,7 +209,8 @@ otherTests = [
|
|||||||
"y = f x",
|
"y = f x",
|
||||||
"y = f (g x1 x2) x3",
|
"y = f (g x1 x2) x3",
|
||||||
"y = (f x1 x2) (g x1 x2)",
|
"y = (f x1 x2) (g x1 x2)",
|
||||||
"y = Foo.bar"
|
"y = Foo.bar",
|
||||||
|
"y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 = f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10"
|
||||||
]
|
]
|
||||||
|
|
||||||
testDecls :: [String]
|
testDecls :: [String]
|
||||||
|
5
todo.txt
5
todo.txt
@ -1,6 +1,4 @@
|
|||||||
-- TODO Now --
|
-- TODO Now --
|
||||||
Case icon that can embed literals
|
|
||||||
|
|
||||||
Consider adding binding variable names to the lambda icon and match icon. Don't display the name if it is only one character.
|
Consider adding binding variable names to the lambda icon and match icon. Don't display the name if it is only one character.
|
||||||
|
|
||||||
-- TODO Later --
|
-- TODO Later --
|
||||||
@ -15,11 +13,12 @@ Draw bounding boxes for lambdas (use dashed lines)
|
|||||||
-- Make an icon font/library with labeled ports. E.g. the apply icon would have text labels "function", "result", "arg 0", "arg 1", etc.
|
-- Make an icon font/library with labeled ports. E.g. the apply icon would have text labels "function", "result", "arg 0", "arg 1", etc.
|
||||||
-- Don't rotate text and nested icons, give them rectangular bounding boxes in GraphViz. (Perhaps use a typeclass for isRotateAble)
|
-- Don't rotate text and nested icons, give them rectangular bounding boxes in GraphViz. (Perhaps use a typeclass for isRotateAble)
|
||||||
-- Give lines a black border to make line crossings easier to see.
|
-- Give lines a black border to make line crossings easier to see.
|
||||||
-- Let lines connect to ports in multiple locations (e.g. guard result)
|
-- Let lines connect to ports other than the original source
|
||||||
-- Use different line styles (e.g. dashed, solid, wavy) in addition to colors
|
-- Use different line styles (e.g. dashed, solid, wavy) in addition to colors
|
||||||
Use diagrams to shrink the drawing until icons start overlapping.
|
Use diagrams to shrink the drawing until icons start overlapping.
|
||||||
|
|
||||||
-- Translate todos:
|
-- Translate todos:
|
||||||
|
Allow case and guard nodes to embed simple patterns and expressions.
|
||||||
|
|
||||||
Fix this test so that the line colors are correct. Consider connecting the t line to the origial rhs (3,4), not the pattern result.
|
Fix this test so that the line colors are correct. Consider connecting the t line to the origial rhs (3,4), not the pattern result.
|
||||||
y = let {t@(_,_) = (3,4)} in t + 3
|
y = let {t@(_,_) = (3,4)} in t + 3
|
||||||
|
Loading…
Reference in New Issue
Block a user