mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-17 02:40:28 +03:00
Refactor NestedPApp and NestedPatternApplyNode.
This commit is contained in:
parent
17f1679015
commit
484bba5cee
36
app/Icons.hs
36
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)
|
||||
|
@ -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
|
||||
|
||||
|
@ -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))
|
||||
|
23
app/Types.hs
23
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"
|
||||
|
@ -1,3 +1,4 @@
|
||||
module Main (main) where
|
||||
import Prelude hiding (return)
|
||||
|
||||
import Diagrams.Backend.SVG.CmdLine(B)
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user