From 484bba5cee7308bfe95a8cc266661163f401805f Mon Sep 17 00:00:00 2001 From: Robbie Gleichman Date: Tue, 6 Nov 2018 01:52:39 -0800 Subject: [PATCH] Refactor NestedPApp and NestedPatternApplyNode. --- app/Icons.hs | 36 +++++++++++++++++++----------------- app/Translate.hs | 6 +++--- app/TranslateCore.hs | 14 +++++++------- app/Types.hs | 23 +++++++++++++++++++---- test/AllTests.hs | 1 + test/UnitTests.hs | 21 +++++++++++++++------ test/VisualRenderingTests.hs | 15 +++++++-------- 7 files changed, 71 insertions(+), 45 deletions(-) diff --git a/app/Icons.hs b/app/Icons.hs index 2ffbe7d..cc8439d 100644 --- a/app/Icons.hs +++ b/app/Icons.hs @@ -31,7 +31,7 @@ import Data.Maybe(catMaybes, listToMaybe, isJust, fromJust) import Types(Icon(..), SpecialQDiagram, SpecialBackend, SpecialNum , NodeName, Port(..), LikeApplyFlavor(..), - SyntaxNode(..), NamedIcon(..)) + SyntaxNode(..), NamedIcon(..), Labeled(..)) import DrawingColors(colorScheme, ColorStyle(..)) {-# ANN module "HLint: ignore Use record patterns" #-} @@ -74,7 +74,8 @@ iconToDiagram icon = case icon of CaseResultIcon -> identDiaFunc caseResult FlatLambdaIcon x -> flatLambda x NestedApply flavor headIcon args -> nestedApplyDia flavor headIcon args - NestedPApp args -> nestedPAppDia (repeat $ patternC colorScheme) args + NestedPApp constructor args + -> nestedPAppDia (repeat $ patternC colorScheme) constructor args NestedCaseIcon args -> nestedCaseDia args NestedGuardIcon args -> nestedGuardDia args @@ -104,7 +105,8 @@ guardPortAngles (Port port) = case port of findNestedIcon :: NodeName -> Icon -> Maybe Icon findNestedIcon name icon = case icon of NestedApply _ headIcon args -> snd <$> findIcon name (headIcon : args) - NestedPApp args -> snd <$> findIcon name (fmap fst args) + NestedPApp constructor args -> + snd <$> findIcon name (fmap laValue (constructor:args)) _ -> Nothing findIcon :: NodeName -> [Maybe NamedIcon] -> Maybe (Int, Icon) @@ -167,11 +169,9 @@ getPortAngles icon port maybeNodeName = case icon of FlatLambdaIcon _ -> applyPortAngles port NestedApply _ headIcon args -> generalNestedPortAngles applyPortAngles headIcon args port maybeNodeName - NestedPApp (headIcon : args) -> + NestedPApp headIcon args -> generalNestedPortAngles - pAppPortAngles (fst headIcon) (fmap fst args) port maybeNodeName - NestedPApp _ -> - error "getPortAngles called on a NestedPApp with not enough arguments." + pAppPortAngles (laValue headIcon) (fmap laValue args) port maybeNodeName NestedCaseIcon args -> nestedGuardPortAngles args port maybeNodeName NestedGuardIcon args -> nestedGuardPortAngles args port maybeNodeName @@ -292,23 +292,25 @@ resultIcon = lw none $ fc (lamArgResC colorScheme) unitSquare -- TODO Refactor with generalNestedDia nestedPAppDia :: SpecialBackend b n => - [Colour Double] -> [(Maybe NamedIcon, String)] -> TransformableDia b n + [Colour Double] + -> Labeled (Maybe NamedIcon) + -> [Labeled (Maybe NamedIcon)] + -> TransformableDia b n nestedPAppDia borderCols - funcNodeNameAndArgs + maybeFunText + args (TransformParams name nestingLevel reflect angle) = named name $ - case funcNodeNameAndArgs of - [] -> mempty - (maybeFunText:args) -> centerXY $ centerY finalDia ||| beside' unitX transformedText resultCircleAndPort where borderCol = borderCols !! nestingLevel - transformedText = case maybeFunText of - (Just _, _) -> makeInnerIcon True inputPortConst maybeFunText - (Nothing, _) -> mempty + transformedText = case laValue maybeFunText of + (Just _) -> + makeInnerIcon True inputPortConst maybeFunText + Nothing -> mempty separation = circleRadius * 1.5 verticalSeparation = circleRadius resultCircleAndPort @@ -333,9 +335,9 @@ nestedPAppDia (circleRadius * 0.5) finalDia = argBox <> allPorts - makeInnerIcon _ portNum (Nothing, str) + makeInnerIcon _ portNum (Labeled Nothing str) = centerX $ makeLabelledPort name reflect angle str portNum - makeInnerIcon func _ (Just (NamedIcon iconNodeName icon), _) + makeInnerIcon func _ (Labeled (Just (NamedIcon iconNodeName icon)) _) = iconToDiagram icon (TransformParams iconNodeName innerLevel reflect angle) diff --git a/app/Translate.hs b/app/Translate.hs index e3b468f..77d012f 100644 --- a/app/Translate.hs +++ b/app/Translate.hs @@ -28,7 +28,7 @@ import TranslateCore(Reference, SyntaxGraph(..), EvalContext, GraphAndRef(..), S makeBox, nTupleString, nTupleSectionString, nListString, syntaxGraphToFglGraph, getUniqueString, bindsToSyntaxGraph, graphAndRefToGraph, initialIdState) -import Types(NameAndPort(..), IDState, +import Types(Labeled(..), NameAndPort(..), IDState, Edge, SyntaxNode(..), IngSyntaxGraph, NodeName, SgNamedNode(..), LikeApplyFlavor(..)) import Util(makeSimpleEdge, nameAndPort, justName) @@ -164,8 +164,8 @@ makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult (nestedArgs, _, nestedSinks, nestedBinds, nestedEMaps) = graphsToComponents $ fmap snd nestedNamedNodesAndGraphs argListMapper (str, arg) = case arg of - Left _ -> (Nothing, str) - Right (namedNode, _) -> (Just namedNode, str) + Left _ -> Labeled Nothing str + Right (namedNode, _) -> Labeled (Just namedNode) str argList = fmap argListMapper mappedArgs diff --git a/app/TranslateCore.hs b/app/TranslateCore.hs index 00b284f..76c2b18 100644 --- a/app/TranslateCore.hs +++ b/app/TranslateCore.hs @@ -31,14 +31,13 @@ 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 import Data.List(find) import Data.Semigroup(Semigroup, (<>)) -import Types(Icon, SyntaxNode(..), Edge(..), EdgeOption(..), +import Types(Labeled(..), Icon, SyntaxNode(..), Edge(..), EdgeOption(..), NameAndPort(..), IDState, SgNamedNode(..), NodeName(..), Port, LikeApplyFlavor(..), CaseOrGuardTag(..), IDState(..), NamedIcon(..)) import Util(noEnds, nameAndPort, makeSimpleEdge, justName, maybeBoolToBool @@ -289,11 +288,12 @@ nestedCaseOrGuardNodeToIcon tag numArgs args = case tag of argPorts = take (2 * numArgs) $ argumentPorts dummyNode argList = fmap (makeArg args) (inputPort dummyNode : argPorts) -nestedPatternNodeToIcon :: String -> [(Maybe SgNamedNode, String)] -> Icon -nestedPatternNodeToIcon str children = NestedPApp $ - (Just (NamedIcon (NodeName (-1)) (TextBoxIcon str)), "") - : - fmap (Arrow.first $ fmap (mapNodeInNamedNode nodeToIcon)) children +nestedPatternNodeToIcon :: String -> [Labeled (Maybe SgNamedNode)] -> Icon +nestedPatternNodeToIcon str children = NestedPApp + (pure (Just (NamedIcon (NodeName (-1)) (TextBoxIcon str)))) + (fmap + (fmap (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 bbb1a7a..e068293 100644 --- a/app/Types.hs +++ b/app/Types.hs @@ -19,17 +19,29 @@ module Types ( SgNamedNode(..), IngSyntaxGraph, LikeApplyFlavor(..), - CaseOrGuardTag(..) + CaseOrGuardTag(..), + Labeled(..) ) where import Diagrams.Prelude(QDiagram, V2, Any, Renderable, Path, IsName) import Diagrams.TwoD.Text(Text) +import Control.Applicative(Applicative(..)) import Data.Typeable(Typeable) data NamedIcon = NamedIcon {niName :: NodeName, niIcon :: Icon} deriving (Show, Eq, Ord) +data Labeled a = Labeled {laValue :: a, laLabel :: String} + deriving (Show, Eq, Ord) + +instance Functor Labeled where + fmap f (Labeled value str) = Labeled (f value) str + +instance Applicative Labeled where + pure x = Labeled x "" + (Labeled f fStr) <*> (Labeled x xStr) = Labeled (f x) (fStr <> xStr) + -- TYPES -- -- | A datatype that represents an icon. -- The TextBoxIcon's data is the text that appears in the text box. @@ -44,12 +56,15 @@ data Icon = TextBoxIcon String LikeApplyFlavor -- apply or compose (Maybe NamedIcon) -- The function for apply, or the argument for compose [Maybe NamedIcon] -- list of arguments or functions - | NestedPApp [(Maybe NamedIcon, String)] + | NestedPApp + (Labeled (Maybe NamedIcon)) -- Data constructor + [Labeled (Maybe NamedIcon)] -- Arguments | NestedCaseIcon [Maybe NamedIcon] | NestedGuardIcon [Maybe NamedIcon] 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) @@ -58,7 +73,7 @@ data SyntaxNode = LikeApplyNode LikeApplyFlavor Int -- Function application, composition, and applying to a composition -- NestedApplyNode is only created in GraphAlgorithms, not during translation. | NestedApplyNode LikeApplyFlavor Int [(SgNamedNode, Edge)] - | NestedPatternApplyNode String [(Maybe SgNamedNode, String)] + | NestedPatternApplyNode String [Labeled (Maybe SgNamedNode)] | NameNode String -- Identifiers or symbols | BindNameNode String | LiteralNode String -- Literal values like the string "Hello World" diff --git a/test/AllTests.hs b/test/AllTests.hs index 2a34508..1ee92a9 100644 --- a/test/AllTests.hs +++ b/test/AllTests.hs @@ -1,3 +1,4 @@ +module Main (main) where import Prelude hiding (return) import Diagrams.Backend.SVG.CmdLine(B) diff --git a/test/UnitTests.hs b/test/UnitTests.hs index 18132ac..bf4ee48 100644 --- a/test/UnitTests.hs +++ b/test/UnitTests.hs @@ -11,7 +11,7 @@ import Data.List(foldl', sort, sortOn) import Translate(translateStringToSyntaxGraph) import TranslateCore(syntaxGraphToFglGraph, SyntaxGraph(..), SgBind(..)) -import Types(SgNamedNode(..), Edge(..), SyntaxNode(..), +import Types(Labeled(..), SgNamedNode(..), Edge(..), SyntaxNode(..), IngSyntaxGraph, NodeName(..), LikeApplyFlavor(..), NameAndPort(..)) import qualified GraphAlgorithms import Util(fromMaybeError) @@ -38,18 +38,27 @@ renameNode nameMap counter (SgNamedNode nodeName syntaxNode) = (newNamedNode, na newNamedNode = SgNamedNode newNodeName newSyntaxNode maybeRenameNodeFolder :: - ([(Maybe SgNamedNode, String)], NameMap, Int) -> Maybe SgNamedNode -> ([(Maybe SgNamedNode, String)], NameMap, Int) + ([Labeled (Maybe SgNamedNode)], NameMap, Int) + -> Maybe SgNamedNode + -> ([Labeled (Maybe SgNamedNode)], NameMap, Int) maybeRenameNodeFolder (renamedNodes, nameMap, counter) mNode = case mNode of - Nothing -> ((Nothing, ""):renamedNodes, nameMap, counter) - Just node -> ((Just newNamedNode, ""):renamedNodes, newNameMap, newCounter) where + Nothing -> ((pure Nothing) : renamedNodes, nameMap, counter) + Just node -> ((pure $ 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) + NestedPatternApplyNode s subNodes + -> (NestedPatternApplyNode s (reverse renamedSubNodes) + , newNameMap + , counter2) where - (renamedSubNodes, newNameMap, counter2) = foldl' maybeRenameNodeFolder ([], nameMap, counter) (fmap fst subNodes) + (renamedSubNodes, newNameMap, counter2) + = foldl' + maybeRenameNodeFolder + ([], nameMap, counter) + (fmap laValue subNodes) _ -> (node, nameMap, counter) renameNodeFolder :: ([SgNamedNode], NameMap, Int) -> SgNamedNode -> ([SgNamedNode], NameMap, Int) diff --git a/test/VisualRenderingTests.hs b/test/VisualRenderingTests.hs index 5b849cc..8c461e1 100644 --- a/test/VisualRenderingTests.hs +++ b/test/VisualRenderingTests.hs @@ -7,7 +7,7 @@ module VisualRenderingTests ( import Diagrams.Prelude hiding ((#), (&)) import Rendering (renderDrawing) -import Types (NodeName(..), Drawing(..), Edge, Icon(..), Port(..), LikeApplyFlavor(..), SpecialQDiagram, SpecialBackend, NamedIcon(..)) +import Types (Labeled(..), NodeName(..), Drawing(..), Edge, Icon(..), Port(..), LikeApplyFlavor(..), SpecialQDiagram, SpecialBackend, NamedIcon(..)) import Util(iconToPort, tupleToNamedIcon) @@ -70,19 +70,18 @@ nestedPAppDia :: Drawing nestedPAppDia = Drawing icons [] where icons = [ - NamedIcon (NodeName 1) (NestedPApp [(Nothing, "baz")]) + NamedIcon (NodeName 1) (NestedPApp (Labeled Nothing "baz") []) , NamedIcon (NodeName 2) (NestedPApp - [ (Nothing, "") - , (Just (NamedIcon (NodeName 1) (TextBoxIcon "foo")), "bar") - , (Nothing, "bar")]) + (Labeled Nothing "") + [ Labeled (Just (NamedIcon (NodeName 1) (TextBoxIcon "foo"))) "bar" + , Labeled Nothing "bar"]) , NamedIcon (NodeName 3) (NestedPApp - [ - (Just (NamedIcon (NodeName 4) (TextBoxIcon "foo")), "bar") - , (Nothing, "bar")]) + (Labeled (Just (NamedIcon (NodeName 4) (TextBoxIcon "foo"))) "bar") + [Labeled Nothing "bar"]) ] nestedApplyDia :: Drawing