Permalink
Browse files

Add pattern names to PApp.

  • Loading branch information...
1 parent 9702cab commit 4b0d32d03472c7ce0f13298d67b4a7ec1c8c9724 @rgleichman committed Jan 2, 2017
Showing with 74 additions and 62 deletions.
  1. +1 −0 .gitignore
  2. +2 −1 app/DrawingColors.hs
  3. +29 −31 app/Icons.hs
  4. +28 −20 app/Translate.hs
  5. +4 −3 app/TranslateCore.hs
  6. +2 −2 app/Types.hs
  7. +4 −4 test/UnitTests.hs
  8. +4 −1 test/VisualTranslateTests.hs
View
@@ -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
View
@@ -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,16 +290,16 @@ 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
where
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
View
@@ -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))
View
@@ -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"
View
@@ -38,18 +38,18 @@ 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)
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]

0 comments on commit 4b0d32d

Please sign in to comment.