From 4b0d32d03472c7ce0f13298d67b4a7ec1c8c9724 Mon Sep 17 00:00:00 2001 From: Robbie Gleichman Date: Mon, 2 Jan 2017 00:37:27 -0800 Subject: [PATCH] Add pattern names to PApp. --- .gitignore | 1 + app/DrawingColors.hs | 3 +- app/Icons.hs | 60 +++++++++++++++++------------------- app/Translate.hs | 48 +++++++++++++++++------------ app/TranslateCore.hs | 7 +++-- app/Types.hs | 4 +-- test/UnitTests.hs | 8 ++--- test/VisualTranslateTests.hs | 5 ++- 8 files changed, 74 insertions(+), 62 deletions(-) diff --git a/.gitignore b/.gitignore index f9bdd4d..35020a1 100644 --- a/.gitignore +++ b/.gitignore @@ -16,6 +16,7 @@ cabal.sandbox.config .stack-work/ *.*~ *~ +*# # You can put SVG images created by Glance in /images /images diff --git a/app/DrawingColors.hs b/app/DrawingColors.hs index ad88e30..a477042 100644 --- a/app/DrawingColors.hs +++ b/app/DrawingColors.hs @@ -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 diff --git a/app/Icons.hs b/app/Icons.hs index a5548e4..7a212bc 100644 --- a/app/Icons.hs +++ b/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 diff --git a/app/Translate.hs b/app/Translate.hs index 642a541..de1cddb 100644 --- a/app/Translate.hs +++ b/app/Translate.hs @@ -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 diff --git a/app/TranslateCore.hs b/app/TranslateCore.hs index 5256439..475fe65 100644 --- a/app/TranslateCore.hs +++ b/app/TranslateCore.hs @@ -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)) diff --git a/app/Types.hs b/app/Types.hs index 27743e6..1cd9798 100644 --- a/app/Types.hs +++ b/app/Types.hs @@ -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" diff --git a/test/UnitTests.hs b/test/UnitTests.hs index d9db72d..6e1e793 100644 --- a/test/UnitTests.hs +++ b/test/UnitTests.hs @@ -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) diff --git a/test/VisualTranslateTests.hs b/test/VisualTranslateTests.hs index 5142c33..2c69bfc 100644 --- a/test/VisualTranslateTests.hs +++ b/test/VisualTranslateTests.hs @@ -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]