mirror of
https://github.com/rgleichman/glance.git
synced 2024-11-25 21:43:03 +03:00
Change emEmbedded in Embedder from a list to a Set.
This commit is contained in:
parent
91b4a6545a
commit
164d837a10
@ -8,6 +8,7 @@ module GraphAlgorithms(
|
|||||||
|
|
||||||
import qualified Data.Graph.Inductive as ING
|
import qualified Data.Graph.Inductive as ING
|
||||||
import Data.List(foldl', find)
|
import Data.List(foldl', find)
|
||||||
|
import qualified Data.Set as Set
|
||||||
import Data.Tuple(swap)
|
import Data.Tuple(swap)
|
||||||
import GHC.Stack(HasCallStack)
|
import GHC.Stack(HasCallStack)
|
||||||
|
|
||||||
@ -179,7 +180,7 @@ changeNodeLabel node newLabel graph = case ING.match node graph of
|
|||||||
addChildToNodeLabel ::
|
addChildToNodeLabel ::
|
||||||
(NodeName, Edge) -> EmbedderSyntaxNode -> EmbedderSyntaxNode
|
(NodeName, Edge) -> EmbedderSyntaxNode -> EmbedderSyntaxNode
|
||||||
addChildToNodeLabel child (Embedder existingNodes oldSyntaxNode)
|
addChildToNodeLabel child (Embedder existingNodes oldSyntaxNode)
|
||||||
= Embedder (child : existingNodes) oldSyntaxNode
|
= Embedder (Set.insert child existingNodes) oldSyntaxNode
|
||||||
|
|
||||||
-- | Change the node label of the parent to be nested.
|
-- | Change the node label of the parent to be nested.
|
||||||
embedChildSyntaxNode :: ING.DynGraph gr =>
|
embedChildSyntaxNode :: ING.DynGraph gr =>
|
||||||
|
@ -34,6 +34,7 @@ import qualified Data.Graph.Inductive.Graph as ING
|
|||||||
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
||||||
import Data.List(find)
|
import Data.List(find)
|
||||||
import Data.Semigroup(Semigroup, (<>))
|
import Data.Semigroup(Semigroup, (<>))
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
import Icons(inputPort, resultPort, argumentPorts, multiIfRhsPorts
|
import Icons(inputPort, resultPort, argumentPorts, multiIfRhsPorts
|
||||||
, multiIfBoolPorts)
|
, multiIfBoolPorts)
|
||||||
@ -303,12 +304,12 @@ findArg currentPort
|
|||||||
| argName == toName = maybeBoolToBool $ fmap (== currentPort) fromPort
|
| argName == toName = maybeBoolToBool $ fmap (== currentPort) fromPort
|
||||||
| otherwise = False -- This case should never happen
|
| otherwise = False -- This case should never happen
|
||||||
|
|
||||||
makeArg :: [(NodeName, Edge)] -> Port -> Maybe NodeName
|
makeArg :: Set.Set (NodeName, Edge) -> Port -> Maybe NodeName
|
||||||
makeArg args port = fst <$> find (findArg port) args
|
makeArg args port = fst <$> find (findArg port) args
|
||||||
|
|
||||||
nestedApplySyntaxNodeToIcon :: LikeApplyFlavor
|
nestedApplySyntaxNodeToIcon :: LikeApplyFlavor
|
||||||
-> Int
|
-> Int
|
||||||
-> [(NodeName, Edge)]
|
-> Set.Set (NodeName, Edge)
|
||||||
-> Icon
|
-> Icon
|
||||||
nestedApplySyntaxNodeToIcon flavor numArgs args =
|
nestedApplySyntaxNodeToIcon flavor numArgs args =
|
||||||
NestedApply flavor headIcon argList
|
NestedApply flavor headIcon argList
|
||||||
@ -319,7 +320,7 @@ nestedApplySyntaxNodeToIcon flavor numArgs args =
|
|||||||
argList = fmap (makeArg args) argPorts
|
argList = fmap (makeArg args) argPorts
|
||||||
|
|
||||||
nestedLambdaToIcon :: [String] -- labels
|
nestedLambdaToIcon :: [String] -- labels
|
||||||
-> [(NodeName, Edge)] -- embedded icons
|
-> Set.Set (NodeName, Edge) -- embedded icons
|
||||||
-> [NodeName] -- body nodes
|
-> [NodeName] -- body nodes
|
||||||
-> Icon
|
-> Icon
|
||||||
nestedLambdaToIcon labels embeddedNodes =
|
nestedLambdaToIcon labels embeddedNodes =
|
||||||
@ -331,7 +332,7 @@ nestedLambdaToIcon labels embeddedNodes =
|
|||||||
nestedCaseOrMultiIfNodeToIcon ::
|
nestedCaseOrMultiIfNodeToIcon ::
|
||||||
CaseOrMultiIfTag
|
CaseOrMultiIfTag
|
||||||
-> Int
|
-> Int
|
||||||
-> [(NodeName, Edge)]
|
-> Set.Set (NodeName, Edge)
|
||||||
-> Icon
|
-> Icon
|
||||||
nestedCaseOrMultiIfNodeToIcon tag numArgs args = case tag of
|
nestedCaseOrMultiIfNodeToIcon tag numArgs args = case tag of
|
||||||
CaseTag -> NestedCaseIcon argList
|
CaseTag -> NestedCaseIcon argList
|
||||||
|
@ -38,9 +38,9 @@ import Diagrams.TwoD.Text(Text)
|
|||||||
import Control.Applicative(Applicative(..))
|
import Control.Applicative(Applicative(..))
|
||||||
import qualified Data.Graph.Inductive as ING
|
import qualified Data.Graph.Inductive as ING
|
||||||
import qualified Data.IntMap as IM
|
import qualified Data.IntMap as IM
|
||||||
|
import Data.Set(Set, empty)
|
||||||
import Data.Typeable(Typeable)
|
import Data.Typeable(Typeable)
|
||||||
|
|
||||||
|
|
||||||
newtype NodeName = NodeName Int deriving (Typeable, Eq, Ord, Show)
|
newtype NodeName = NodeName Int deriving (Typeable, Eq, Ord, Show)
|
||||||
instance IsName NodeName
|
instance IsName NodeName
|
||||||
|
|
||||||
@ -91,13 +91,13 @@ data CaseOrMultiIfTag = CaseTag | MultiIfTag deriving (Show, Eq, Ord)
|
|||||||
|
|
||||||
-- TODO The full edge does not need to be included, just the port.
|
-- TODO The full edge does not need to be included, just the port.
|
||||||
data Embedder a = Embedder {
|
data Embedder a = Embedder {
|
||||||
emEmbedded :: [(NodeName, Edge)] -- ^ Set of embedded nodes
|
emEmbedded :: Set (NodeName, Edge) -- ^ Set of embedded nodes
|
||||||
, emNode :: a
|
, emNode :: a
|
||||||
}
|
}
|
||||||
deriving (Show, Eq, Ord, Functor)
|
deriving (Show, Eq, Ord, Functor)
|
||||||
|
|
||||||
mkEmbedder :: a -> Embedder a
|
mkEmbedder :: a -> Embedder a
|
||||||
mkEmbedder = Embedder []
|
mkEmbedder = Embedder empty
|
||||||
|
|
||||||
type EmbedderSyntaxNode = Embedder SyntaxNode
|
type EmbedderSyntaxNode = Embedder SyntaxNode
|
||||||
|
|
||||||
|
@ -9,7 +9,7 @@ import Data.List(foldl', sort, sortOn)
|
|||||||
import Translate(translateStringToSyntaxGraph)
|
import Translate(translateStringToSyntaxGraph)
|
||||||
import TranslateCore(SyntaxGraph(..), SgBind(..))
|
import TranslateCore(SyntaxGraph(..), SgBind(..))
|
||||||
import Types(Embedder(..), Labeled(..), SgNamedNode, Edge(..), SyntaxNode(..),
|
import Types(Embedder(..), Labeled(..), SgNamedNode, Edge(..), SyntaxNode(..),
|
||||||
NodeName(..), NameAndPort(..), Named(..))
|
NodeName(..), NameAndPort(..), Named(..), mkEmbedder)
|
||||||
import Util(fromMaybeError)
|
import Util(fromMaybeError)
|
||||||
|
|
||||||
-- Unit Test Helpers --
|
-- Unit Test Helpers --
|
||||||
@ -30,7 +30,7 @@ type NameMap = [(NodeName, NodeName)]
|
|||||||
renameNode
|
renameNode
|
||||||
:: NameMap -> Int -> SgNamedNode -> (SgNamedNode, NameMap, Int)
|
:: NameMap -> Int -> SgNamedNode -> (SgNamedNode, NameMap, Int)
|
||||||
renameNode nameMap counter (Named nodeName syntaxNode)
|
renameNode nameMap counter (Named nodeName syntaxNode)
|
||||||
= (fmap (Embedder []) newNamedNode, nameMap3, newCounter) where
|
= (fmap mkEmbedder newNamedNode, nameMap3, newCounter) where
|
||||||
newNodeName = NodeName counter
|
newNodeName = NodeName counter
|
||||||
nameMap2 = (nodeName, newNodeName) : nameMap
|
nameMap2 = (nodeName, newNodeName) : nameMap
|
||||||
(newSyntaxNode, nameMap3, newCounter) = renameSyntaxNode nameMap2 (emNode syntaxNode) (counter + 1)
|
(newSyntaxNode, nameMap3, newCounter) = renameSyntaxNode nameMap2 (emNode syntaxNode) (counter + 1)
|
||||||
|
Loading…
Reference in New Issue
Block a user