mirror of
https://github.com/rgleichman/glance.git
synced 2024-07-07 03:46:33 +03:00
Add pattern names to PApp.
This commit is contained in:
Robbie Gleichman
parent
9702cabc29
commit
4b0d32d034
1
.gitignore
vendored
1
.gitignore
vendored
|
|
@ -16,6 +16,7 @@ cabal.sandbox.config
|
|||
.stack-work/
|
||||
*.*~
|
||||
*~
|
||||
*#
|
||||
|
||||
# You can put SVG images created by Glance in /images
|
||||
/images
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ colorOnBlackScheme = ColorStyle {
|
|||
patternC = lightMagenta,
|
||||
patternTextC = cyan,
|
||||
bindTextBoxC = reddishOrange,
|
||||
bindTextBoxTextC = lime,
|
||||
bindTextBoxTextC = lightGreen,
|
||||
edgeListC = [white, lime, reddishOrange, lightPurple, yellow, lightBlue],
|
||||
nestingC = cycle [red, reddishOrange, yellow]
|
||||
}
|
||||
|
|
@ -56,6 +56,7 @@ colorOnBlackScheme = ColorStyle {
|
|||
--lightBlue = sRGB24 126 127 255
|
||||
lightBlue = sRGB24 35 156 255
|
||||
lightPurple = sRGB24 208 137 255
|
||||
lightGreen = sRGB24 180 255 145
|
||||
|
||||
|
||||
whiteOnBlackScheme :: (Floating a, Ord a) => ColorStyle a
|
||||
|
|
|
|||
60
app/Icons.hs
60
app/Icons.hs
|
|
@ -23,10 +23,10 @@ module Icons
|
|||
|
||||
import Diagrams.Prelude hiding ((&), (#), Name)
|
||||
|
||||
import qualified Control.Arrow as Arrow
|
||||
import Data.Either(partitionEithers)
|
||||
import Data.List(find)
|
||||
import Data.Maybe(catMaybes, listToMaybe, isJust, fromJust)
|
||||
import Data.Either(partitionEithers)
|
||||
import qualified Control.Arrow as Arrow
|
||||
|
||||
import Types(Icon(..), SpecialQDiagram, SpecialBackend, SpecialNum, NodeName, Port(..), LikeApplyFlavor(..),
|
||||
SyntaxNode(..))
|
||||
|
|
@ -94,7 +94,7 @@ guardPortAngles (Port port) = case port of
|
|||
findNestedIcon :: NodeName -> Icon -> Maybe Icon
|
||||
findNestedIcon name icon = case icon of
|
||||
NestedApply _ args -> snd <$> findIcon name args
|
||||
NestedPApp args -> snd <$> findIcon name args
|
||||
NestedPApp args -> snd <$> findIcon name (fmap fst args)
|
||||
_ -> Nothing
|
||||
|
||||
findIcon :: NodeName -> [Maybe (NodeName, Icon)] -> Maybe (Int, Icon)
|
||||
|
|
@ -150,7 +150,7 @@ getPortAngles icon port maybeNodeName = case icon of
|
|||
CaseResultIcon -> []
|
||||
FlatLambdaIcon _ -> applyPortAngles port
|
||||
NestedApply _ args -> generalNestedPortAngles applyPortAngles args port maybeNodeName
|
||||
NestedPApp args -> generalNestedPortAngles pAppPortAngles args port maybeNodeName
|
||||
NestedPApp args -> generalNestedPortAngles pAppPortAngles (fmap fst args) port maybeNodeName
|
||||
NestedCaseIcon args -> nestedGuardPortAngles args port maybeNodeName
|
||||
NestedGuardIcon args -> nestedGuardPortAngles args port maybeNodeName
|
||||
|
||||
|
|
@ -228,6 +228,17 @@ makePort x = named x mempty
|
|||
makeQualifiedPort :: SpecialNum n => NodeName -> Port -> SpecialQDiagram b n
|
||||
makeQualifiedPort n x = n .>> makePort x
|
||||
|
||||
makeLabelledPort :: SpecialBackend b n =>
|
||||
NodeName -> Bool -> Angle n -> String -> Port -> SpecialQDiagram b n
|
||||
makeLabelledPort name reflect angle str portNum = case str of
|
||||
-- Don't display " tempvar" from Translate.hs/matchesToCase
|
||||
(' ':_) -> portAndCircle
|
||||
(_:_:_) -> portAndCircle ||| label
|
||||
_ -> portAndCircle
|
||||
where
|
||||
portAndCircle = makeQualifiedPort name portNum <> portCircle
|
||||
label = transformableBindTextBox str reflect angle
|
||||
|
||||
-- END Diagram helper functions
|
||||
|
||||
|
||||
|
|
@ -279,7 +290,7 @@ generalTextAppDia textCol borderCol numArgs str name _ reflect angle = nameDiagr
|
|||
|
||||
-- TODO Refactor with generalNestedDia
|
||||
nestedPAppDia :: SpecialBackend b n =>
|
||||
[Colour Double] -> [Maybe (NodeName, Icon)] -> TransformableDia b n
|
||||
[Colour Double] -> [(Maybe (NodeName, Icon), String)] -> TransformableDia b n
|
||||
nestedPAppDia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = named name $ case funcNodeNameAndArgs of
|
||||
[] -> mempty
|
||||
(maybeFunText:args) -> centerXY $ centerY finalDia ||| transformedText ||| resultCircleAndPort
|
||||
|
|
@ -287,8 +298,8 @@ nestedPAppDia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = n
|
|||
borderCol = borderCols !! nestingLevel
|
||||
|
||||
transformedText = case maybeFunText of
|
||||
Just _ -> makeInnerIcon True inputPortConst maybeFunText
|
||||
Nothing -> mempty
|
||||
(Just _, _) -> makeInnerIcon True inputPortConst maybeFunText
|
||||
(Nothing, _) -> mempty
|
||||
separation = circleRadius * 1.5
|
||||
verticalSeparation = circleRadius
|
||||
resultCircleAndPort = makeQualifiedPort name resultPortConst <> alignR (lc borderCol $ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)
|
||||
|
|
@ -303,9 +314,9 @@ nestedPAppDia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = n
|
|||
argBox = alignT $ lwG defaultLineWidth $ lc borderCol $ roundedRect topAndBottomLineWidth (height allPorts + verticalSeparation) (circleRadius * 0.5)
|
||||
finalDia = argBox <> allPorts
|
||||
|
||||
makeInnerIcon _ portNum Nothing = makeQualifiedPort name portNum <> portCircle
|
||||
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 _ portNum (Nothing, str) = centerX $ makeLabelledPort name reflect angle str portNum
|
||||
makeInnerIcon True _ ((Just (_, TextBoxIcon t)), _) = transformCorrectedTextBox t (textBoxTextC colorScheme) borderCol reflect angle
|
||||
makeInnerIcon func _ ((Just (iconNodeName, icon)), _) = iconToDiagram icon iconNodeName innerLevel reflect angle where
|
||||
innerLevel = if func then nestingLevel else nestingLevel + 1
|
||||
|
||||
|
||||
|
|
@ -395,10 +406,6 @@ coloredTextBox textColor boxColor t =
|
|||
fontSize (local textBoxFontSize) (bold $ font "freemono" $ fc textColor $ text t)
|
||||
<> lwG (0.6 * defaultLineWidth) (lcA boxColor $ fcA (withOpacity (backgroundC colorScheme) 0.5) $ rectForText (length t))
|
||||
|
||||
bindTextBox :: SpecialBackend b n =>
|
||||
String -> SpecialQDiagram b n
|
||||
bindTextBox = coloredTextBox (bindTextBoxTextC colorScheme) $ opaque (bindTextBoxC colorScheme)
|
||||
|
||||
transformCorrectedTextBox :: SpecialBackend b n =>
|
||||
String -> Colour Double -> Colour Double -> Bool -> Angle n -> SpecialQDiagram b n
|
||||
transformCorrectedTextBox str textCol borderCol reflect angle =
|
||||
|
|
@ -409,13 +416,17 @@ 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
|
||||
|
||||
defaultColoredTextBox :: SpecialBackend b n =>
|
||||
transformableBindTextBox :: SpecialBackend b n =>
|
||||
String -> Bool -> Angle n -> SpecialQDiagram b n
|
||||
defaultColoredTextBox str = transformCorrectedTextBox str (textBoxTextC colorScheme) (textBoxC colorScheme)
|
||||
transformableBindTextBox str = transformCorrectedTextBox str (bindTextBoxTextC colorScheme) (bindTextBoxC colorScheme)
|
||||
|
||||
bindTextBox :: SpecialBackend b n =>
|
||||
String -> SpecialQDiagram b n
|
||||
bindTextBox = coloredTextBox (bindTextBoxTextC colorScheme) $ opaque (bindTextBoxC colorScheme)
|
||||
|
||||
textBox :: SpecialBackend b n =>
|
||||
String -> TransformableDia b n
|
||||
textBox t name _ reflect angle = nameDiagram name $ defaultColoredTextBox t reflect angle
|
||||
textBox t name _ reflect angle = nameDiagram name $ transformCorrectedTextBox t (textBoxTextC colorScheme) (textBoxC colorScheme) reflect angle
|
||||
|
||||
-- END Text boxes and icons
|
||||
|
||||
|
|
@ -507,25 +518,13 @@ nestedCaseDia = generalNestedGuard (patternC colorScheme) caseC caseResult
|
|||
|
||||
-- END Guard and case icons
|
||||
|
||||
-- BEGIN Lambda icon --
|
||||
makeLabelledPort :: SpecialBackend b n =>
|
||||
NodeName -> Bool -> Angle n -> String -> Port -> SpecialQDiagram b n
|
||||
makeLabelledPort name reflect angle str portNum = case str of
|
||||
-- Don't display " tempvar" from Translate.hs/matchesToCase
|
||||
(' ':_) -> portAndCircle
|
||||
(_:_:_) -> portAndCircle ||| label
|
||||
_ -> portAndCircle
|
||||
where
|
||||
portAndCircle = makeQualifiedPort name portNum <> portCircle
|
||||
label = defaultColoredTextBox str reflect angle
|
||||
|
||||
-- | The ports of flatLambdaIcon are:
|
||||
-- 0: Result icon
|
||||
-- 1: The lambda function value
|
||||
-- 2,3.. : The parameters
|
||||
flatLambda :: SpecialBackend b n => [String] -> TransformableDia b n
|
||||
flatLambda paramNames name _ reflect angle = named name finalDia where
|
||||
lambdaCircle = lwG defaultLineWidth $ lc (regionPerimC colorScheme) $ fc (regionPerimC colorScheme) $ circle circleRadius
|
||||
lambdaCircle = lwG defaultLineWidth $ lc (regionPerimC colorScheme) $ fc (regionPerimC colorScheme) $ circle (1.5 * circleRadius)
|
||||
lambdaParts = (makeQualifiedPort name inputPortConst <> resultIcon) : (portIcons ++ [makeQualifiedPort name resultPortConst <> alignR lambdaCircle])
|
||||
|
||||
portIcons = zipWith (makeLabelledPort name reflect angle) paramNames argPortsConst
|
||||
|
|
@ -534,6 +533,5 @@ flatLambda paramNames name _ reflect angle = named name finalDia where
|
|||
topAndBottomLine = alignL $ lwG defaultLineWidth $ lc (regionPerimC colorScheme) $ hrule topAndBottomLineWidth
|
||||
finalDia = topAndBottomLine <> alignB (topAndBottomLine <> alignT middle)
|
||||
|
||||
-- END Lambda icon --
|
||||
-- END Main icons
|
||||
-- END Icons
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@ import Data.Either(partitionEithers)
|
|||
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
||||
import Data.List(unzip5, partition, intercalate)
|
||||
import Data.Maybe(catMaybes, isJust, fromMaybe)
|
||||
|
||||
import qualified Language.Haskell.Exts as Exts
|
||||
|
||||
import Language.Haskell.Exts(Decl(..), parseDeclWithMode, Name(..), Pat(..), Rhs(..),
|
||||
|
|
@ -70,6 +71,14 @@ bindOrAltHelper c pat rhs maybeWhereBinds = do
|
|||
rhsGraphAndRef <- rhsWithBinds maybeWhereBinds rhs rhsContext
|
||||
pure (patGraphAndRef, rhsGraphAndRef)
|
||||
|
||||
patternName :: (GraphAndRef, Maybe String) -> String
|
||||
patternName (GraphAndRef _ ref, mStr) = fromMaybe
|
||||
(case ref of
|
||||
Left str -> str
|
||||
Right _ -> ""
|
||||
)
|
||||
mStr
|
||||
|
||||
-- END Helper Functions --
|
||||
|
||||
-- BEGIN Names helper functions --
|
||||
|
|
@ -121,11 +130,16 @@ asNameBind (GraphAndRef _ ref, mAsName) = case mAsName of
|
|||
Nothing -> Nothing
|
||||
Just asName -> Just $ SgBind asName ref
|
||||
|
||||
patternArgumentMapper :: (GraphAndRef, t) -> Either (GraphAndRef, t) (SgNamedNode, SyntaxGraph)
|
||||
patternArgumentMapper argAndPort = case graph of
|
||||
(SyntaxGraph [namedNode] [] _ _ _) -> Right (namedNode, graph)
|
||||
_ -> Left argAndPort
|
||||
where graph = graphAndRefToGraph $ fst argAndPort
|
||||
patternArgumentMapper :: ((GraphAndRef, Maybe String), t) -> (String, Either (GraphAndRef, t) (SgNamedNode, SyntaxGraph))
|
||||
patternArgumentMapper (asGraphAndRef@(graphAndRef, _), port) = (patName, eitherVal)
|
||||
where
|
||||
graph = graphAndRefToGraph graphAndRef
|
||||
patName = patternName asGraphAndRef
|
||||
|
||||
eitherVal = case graph of
|
||||
(SyntaxGraph [namedNode] [] _ _ _) -> Right (namedNode, graph)
|
||||
_ -> Left (graphAndRef, port)
|
||||
|
||||
|
||||
graphToTuple :: SyntaxGraph -> ([SgNamedNode], [Edge], [SgSink], [SgBind], [(NodeName, NodeName)])
|
||||
graphToTuple (SyntaxGraph a b c d e) = (a, b, c, d, e)
|
||||
|
|
@ -137,22 +151,24 @@ graphsToComponents graphs = (concat a, concat b, concat c, concat d, concat e) w
|
|||
makeNestedPatternGraph :: NodeName -> String -> [(GraphAndRef, Maybe String)] -> (SyntaxGraph, NameAndPort)
|
||||
makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult
|
||||
where
|
||||
pAppNode = NestedPatternApplyNode funStr argList
|
||||
argsAndPorts = zip (fmap fst argVals) $ map (nameAndPort applyIconName) $ argumentPorts pAppNode
|
||||
dummyNode = NestedPatternApplyNode "" []
|
||||
|
||||
argsAndPorts = zip argVals $ map (nameAndPort applyIconName) $ argumentPorts dummyNode
|
||||
mappedArgs = fmap patternArgumentMapper argsAndPorts
|
||||
|
||||
(unnestedArgsAndPort, nestedNamedNodesAndGraphs) = partitionEithers mappedArgs
|
||||
(unnestedArgsAndPort, nestedNamedNodesAndGraphs) = partitionEithers (fmap snd mappedArgs)
|
||||
|
||||
(nestedArgs, _, nestedSinks, nestedBinds, nestedEMaps) = graphsToComponents $ fmap snd nestedNamedNodesAndGraphs
|
||||
|
||||
argListMapper arg = case arg of
|
||||
Left _ -> Nothing
|
||||
Right (namedNode, _) -> Just namedNode
|
||||
argListMapper (str, arg) = case arg of
|
||||
Left _ -> (Nothing, str)
|
||||
Right (namedNode, _) -> (Just namedNode, str)
|
||||
|
||||
argList = fmap argListMapper mappedArgs
|
||||
|
||||
combinedGraph = combineExpressions True unnestedArgsAndPort
|
||||
|
||||
pAppNode = NestedPatternApplyNode funStr argList
|
||||
icons = [SgNamedNode applyIconName pAppNode]
|
||||
|
||||
asNameBinds = catMaybes $ fmap asNameBind argVals
|
||||
|
|
@ -615,14 +631,6 @@ evalRecConstr c qName _ = evalQName qName c
|
|||
asBindGraphZipper :: Maybe String -> NameAndPort -> SyntaxGraph
|
||||
asBindGraphZipper asName nameNPort = makeAsBindGraph (Right nameNPort) [asName]
|
||||
|
||||
paramName :: (GraphAndRef, Maybe String) -> String
|
||||
paramName (GraphAndRef _ ref, mStr) = fromMaybe
|
||||
(case ref of
|
||||
Left str -> str
|
||||
Right _ -> ""
|
||||
)
|
||||
mStr
|
||||
|
||||
generalEvalLambda :: EvalContext -> [Pat] -> (EvalContext -> State IDState GraphAndRef) -> State IDState (SyntaxGraph, NameAndPort)
|
||||
generalEvalLambda context patterns rhsEvalFun = do
|
||||
lambdaName <- getUniqueName
|
||||
|
|
@ -631,7 +639,7 @@ generalEvalLambda context patterns rhsEvalFun = do
|
|||
patternVals = fmap fst patternValsWithAsNames
|
||||
patternStrings = concatMap namesInPattern patternValsWithAsNames
|
||||
rhsContext = patternStrings <> context
|
||||
paramNames = fmap paramName patternValsWithAsNames
|
||||
paramNames = fmap patternName patternValsWithAsNames
|
||||
lambdaNode = FunctionDefNode paramNames
|
||||
lambdaPorts = map (nameAndPort lambdaName) $ argumentPorts lambdaNode
|
||||
patternGraph = mconcat $ fmap graphAndRefToGraph patternVals
|
||||
|
|
|
|||
|
|
@ -31,6 +31,7 @@ module TranslateCore(
|
|||
) where
|
||||
|
||||
import Control.Monad.State(State, state)
|
||||
import qualified Control.Arrow as Arrow
|
||||
import Data.Either(partitionEithers)
|
||||
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
||||
import qualified Data.Graph.Inductive.Graph as ING
|
||||
|
|
@ -278,11 +279,11 @@ nestedCaseOrGuardNodeToIcon tag numArgs args = case tag of
|
|||
argPorts = take (2 * numArgs) $ argumentPorts dummyNode
|
||||
argList = fmap (makeArg args) (inputPort dummyNode : argPorts)
|
||||
|
||||
nestedPatternNodeToIcon :: String -> [Maybe SgNamedNode] -> Icon
|
||||
nestedPatternNodeToIcon :: String -> [(Maybe SgNamedNode, String)] -> Icon
|
||||
nestedPatternNodeToIcon str children = NestedPApp $
|
||||
Just (NodeName (-1), TextBoxIcon str)
|
||||
(Just (NodeName (-1), TextBoxIcon str), "")
|
||||
:
|
||||
(fmap (mapNodeInNamedNode nodeToIcon) <$> children)
|
||||
fmap (Arrow.first $ fmap (mapNodeInNamedNode nodeToIcon)) children
|
||||
|
||||
findArg :: Port -> (SgNamedNode, Edge) -> Bool
|
||||
findArg currentPort (SgNamedNode argName _, Edge _ _ (NameAndPort fromName fromPort, NameAndPort toName toPort))
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ data Icon = TextBoxIcon String | GuardIcon Int
|
|||
| BindTextBoxIcon String
|
||||
-- TODO: NestedApply should have the type NestedApply (Maybe (Name, Icon)) [Maybe (Name, Icon)]
|
||||
| NestedApply LikeApplyFlavor [Maybe (NodeName, Icon)]
|
||||
| NestedPApp [Maybe (NodeName, Icon)]
|
||||
| NestedPApp [(Maybe (NodeName, Icon), String)]
|
||||
| NestedCaseIcon [Maybe (NodeName, Icon)]
|
||||
| NestedGuardIcon [Maybe (NodeName, Icon)]
|
||||
deriving (Show, Eq, Ord)
|
||||
|
|
@ -52,7 +52,7 @@ data SyntaxNode =
|
|||
| NestedApplyNode LikeApplyFlavor Int [(SgNamedNode, Edge)]
|
||||
| PatternApplyNode String Int -- Destructors as used in patterns
|
||||
-- | NestedPatternApplyNode String Int [(SgNamedNode, Edge)]
|
||||
| NestedPatternApplyNode String [Maybe SgNamedNode]
|
||||
| NestedPatternApplyNode String [(Maybe SgNamedNode, String)]
|
||||
| NameNode String -- Identifiers or symbols
|
||||
| BindNameNode String
|
||||
| LiteralNode String -- Literal values like the string "Hello World"
|
||||
|
|
|
|||
|
|
@ -38,10 +38,10 @@ renameNode nameMap counter (SgNamedNode nodeName syntaxNode) = (newNamedNode, na
|
|||
newNamedNode = SgNamedNode newNodeName newSyntaxNode
|
||||
|
||||
maybeRenameNodeFolder ::
|
||||
([Maybe SgNamedNode], NameMap, Int) -> Maybe SgNamedNode -> ([Maybe SgNamedNode], NameMap, Int)
|
||||
([(Maybe SgNamedNode, String)], NameMap, Int) -> Maybe SgNamedNode -> ([(Maybe SgNamedNode, String)], NameMap, Int)
|
||||
maybeRenameNodeFolder (renamedNodes, nameMap, counter) mNode = case mNode of
|
||||
Nothing -> (Nothing:renamedNodes, nameMap, counter)
|
||||
Just node -> (Just newNamedNode:renamedNodes, newNameMap, newCounter) where
|
||||
Nothing -> ((Nothing, ""):renamedNodes, nameMap, counter)
|
||||
Just node -> ((Just newNamedNode, ""):renamedNodes, newNameMap, newCounter) where
|
||||
(newNamedNode, newNameMap, newCounter) = renameNode nameMap counter node
|
||||
|
||||
renameSyntaxNode :: NameMap -> SyntaxNode -> Int -> (SyntaxNode, NameMap, Int)
|
||||
|
|
@ -49,7 +49,7 @@ renameSyntaxNode nameMap node counter = case node of
|
|||
-- TODO Keep the Nothing subNodes
|
||||
NestedPatternApplyNode s subNodes -> (NestedPatternApplyNode s (reverse renamedSubNodes), newNameMap, counter2)
|
||||
where
|
||||
(renamedSubNodes, newNameMap, counter2) = foldl' maybeRenameNodeFolder ([], nameMap, counter) subNodes
|
||||
(renamedSubNodes, newNameMap, counter2) = foldl' maybeRenameNodeFolder ([], nameMap, counter) (fmap fst subNodes)
|
||||
_ -> (node, nameMap, counter)
|
||||
|
||||
renameNodeFolder :: ([SgNamedNode], NameMap, Int) -> SgNamedNode -> ([SgNamedNode], NameMap, Int)
|
||||
|
|
|
|||
|
|
@ -166,7 +166,10 @@ patternTests = [
|
|||
|
||||
"y = let {(x, y) = (1,2)} in x + y",
|
||||
"y = let {(x, y) = (1,2); (z, w) = x; (m, g) = y} in foo x y z w m g",
|
||||
"(x:y) = 2"
|
||||
"(x:y) = 2",
|
||||
|
||||
-- test labelled ports
|
||||
"Foo x1 x2 = 4"
|
||||
]
|
||||
|
||||
lambdaTests :: [String]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user