For SyntaxGraph, use a data type (SgSink) for sinks.

This commit is contained in:
Robbie Gleichman 2016-12-26 16:52:04 -08:00
parent 771f9a7cc3
commit 5c399b9e50
2 changed files with 19 additions and 17 deletions

View File

@ -20,12 +20,12 @@ import Language.Haskell.Exts(Decl(..), parseDecl, Name(..), Pat(..), Rhs(..),
Stmt(..), Binds(..), Alt(..), Module(..), SpecialCon(..), prettyPrint) Stmt(..), Binds(..), Alt(..), Module(..), SpecialCon(..), prettyPrint)
import GraphAlgorithms(collapseNodes) import GraphAlgorithms(collapseNodes)
import TranslateCore(Reference, SyntaxGraph(..), EvalContext, GraphAndRef, Sink, SgBind(..), import TranslateCore(Reference, SyntaxGraph(..), EvalContext, GraphAndRef, SgSink(..), SgBind(..),
syntaxGraphFromNodes, syntaxGraphFromNodesEdges, getUniqueName, combineExpressions, syntaxGraphFromNodes, syntaxGraphFromNodesEdges, getUniqueName, combineExpressions,
edgesForRefPortList, makeApplyGraph, edgesForRefPortList, makeApplyGraph,
namesInPattern, lookupReference, deleteBindings, makeEdges, namesInPattern, lookupReference, deleteBindings, makeEdges,
makeBox, nTupleString, nListString, makeBox, nTupleString, nListString,
syntaxGraphToFglGraph, getUniqueString) syntaxGraphToFglGraph, getUniqueString, bindsToSyntaxGraph)
import Types(NameAndPort(..), IDState, import Types(NameAndPort(..), IDState,
initialIdState, Edge, SyntaxNode(..), IngSyntaxGraph, NodeName, Port(..), SgNamedNode, initialIdState, Edge, SyntaxNode(..), IngSyntaxGraph, NodeName, Port(..), SgNamedNode,
LikeApplyFlavor(..)) LikeApplyFlavor(..))
@ -48,9 +48,6 @@ qOpToExp :: QOp -> Exp
qOpToExp (QVarOp n) = Var n qOpToExp (QVarOp n) = Var n
qOpToExp (QConOp n) = Con n qOpToExp (QConOp n) = Con n
bindsToSyntaxGraph :: [SgBind] -> SyntaxGraph
bindsToSyntaxGraph binds = SyntaxGraph mempty mempty mempty binds mempty
-- | Make a syntax graph that has the bindings for a list of "as pattern" (@) names. -- | Make a syntax graph that has the bindings for a list of "as pattern" (@) names.
makeAsBindGraph :: Reference -> [Maybe String] -> SyntaxGraph makeAsBindGraph :: Reference -> [Maybe String] -> SyntaxGraph
makeAsBindGraph ref asNames = bindsToSyntaxGraph $ catMaybes $ fmap makeBind asNames where makeAsBindGraph ref asNames = bindsToSyntaxGraph $ catMaybes $ fmap makeBind asNames where
@ -106,7 +103,7 @@ evalLit (Exts.PrimString x) = makeLiteral x
-- BEGIN evalPApp -- BEGIN evalPApp
-- TODO Refactor decideIfNested and makePatternGraph -- TODO Refactor decideIfNested and makePatternGraph
decideIfNested :: ((SyntaxGraph, t1), t) -> decideIfNested :: ((SyntaxGraph, t1), t) ->
(Maybe ((SyntaxGraph, t1), t), Maybe SgNamedNode, [Sink], [SgBind], [(NodeName, NodeName)]) (Maybe ((SyntaxGraph, t1), t), Maybe SgNamedNode, [SgSink], [SgBind], [(NodeName, NodeName)])
decideIfNested ((SyntaxGraph [nameAndIcon] [] sinks bindings eMap, _), _) = (Nothing, Just nameAndIcon, sinks, bindings, eMap) decideIfNested ((SyntaxGraph [nameAndIcon] [] sinks bindings eMap, _), _) = (Nothing, Just nameAndIcon, sinks, bindings, eMap)
decideIfNested valAndPort = (Just valAndPort, Nothing, [], [], []) decideIfNested valAndPort = (Just valAndPort, Nothing, [], [], [])
@ -561,7 +558,7 @@ generalEvalLambda context patterns rhsEvalFun = do
icons = [(lambdaName, FunctionDefNode (length patterns))] icons = [(lambdaName, FunctionDefNode (length patterns))]
returnPort = nameAndPort lambdaName (Port 0) returnPort = nameAndPort lambdaName (Port 0)
(newEdges, newSinks) = case rhsRef of (newEdges, newSinks) = case rhsRef of
Left s -> (patternEdges, [(s, returnPort)]) Left s -> (patternEdges, [SgSink s returnPort])
Right rhsPort -> (makeSimpleEdge (rhsPort, returnPort) : patternEdges, mempty) Right rhsPort -> (makeSimpleEdge (rhsPort, returnPort) : patternEdges, mempty)
finalGraph = SyntaxGraph icons newEdges newSinks newBinds mempty finalGraph = SyntaxGraph icons newEdges newSinks newBinds mempty
@ -669,7 +666,7 @@ evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do
(Left s) -> (mempty, mempty, [SgBind s rhsRef]) (Left s) -> (mempty, mempty, [SgBind s rhsRef])
(Right patPort) -> case rhsRef of (Right patPort) -> case rhsRef of
-- TODO This edge/sink should have a special arrow head to indicate an input to a pattern. -- TODO This edge/sink should have a special arrow head to indicate an input to a pattern.
(Left rhsStr) -> (mempty, [(rhsStr, patPort)], mempty) (Left rhsStr) -> (mempty, [SgSink rhsStr patPort], mempty)
(Right rhsPort) -> ([makeSimpleEdge (rhsPort, patPort)], mempty, mempty) (Right rhsPort) -> ([makeSimpleEdge (rhsPort, patPort)], mempty, mempty)
asBindGraph = makeAsBindGraph rhsRef [patAsName] asBindGraph = makeAsBindGraph rhsRef [patAsName]
gr = asBindGraph <> SyntaxGraph mempty newEdges newSinks bindings mempty gr = asBindGraph <> SyntaxGraph mempty newEdges newSinks bindings mempty

View File

@ -3,10 +3,11 @@ module TranslateCore(
SyntaxGraph(..), SyntaxGraph(..),
EvalContext, EvalContext,
GraphAndRef, GraphAndRef,
Sink, SgSink(..),
SgBind(..), SgBind(..),
syntaxGraphFromNodes, syntaxGraphFromNodes,
syntaxGraphFromNodesEdges, syntaxGraphFromNodesEdges,
bindsToSyntaxGraph,
getUniqueName, getUniqueName,
getUniqueString, getUniqueString,
edgesForRefPortList, edgesForRefPortList,
@ -48,13 +49,15 @@ type Reference = Either String NameAndPort
data SgBind = SgBind String Reference deriving (Eq, Show, Ord) data SgBind = SgBind String Reference deriving (Eq, Show, Ord)
data SgSink = SgSink String NameAndPort deriving (Eq, Ord, Show)
-- TODO Replace lists with sets -- TODO Replace lists with sets
-- | SyntaxGraph is an abstract representation for Haskell syntax. SyntaxGraphs are -- | SyntaxGraph is an abstract representation for Haskell syntax. SyntaxGraphs are
-- generated from the Haskell syntax tree, and are used to generate Drawings -- generated from the Haskell syntax tree, and are used to generate Drawings
data SyntaxGraph = SyntaxGraph { data SyntaxGraph = SyntaxGraph {
sgNodes :: [SgNamedNode], sgNodes :: [SgNamedNode],
sgEdges :: [Edge], sgEdges :: [Edge],
sgSinks :: [(String, NameAndPort)], sgSinks :: [SgSink],
sgBinds :: [SgBind], sgBinds :: [SgBind],
-- sgEmbedMap keeps track of nodes embedded in other nodes. If (child, parent) is in the Map, then child is embedded inside parent. -- sgEmbedMap keeps track of nodes embedded in other nodes. If (child, parent) is in the Map, then child is embedded inside parent.
sgEmbedMap :: [(NodeName, NodeName)] sgEmbedMap :: [(NodeName, NodeName)]
@ -70,7 +73,6 @@ instance Monoid SyntaxGraph where
type EvalContext = [String] type EvalContext = [String]
type GraphAndRef = (SyntaxGraph, Reference) type GraphAndRef = (SyntaxGraph, Reference)
type Sink = (String, NameAndPort)
sgBindToString :: SgBind -> String sgBindToString :: SgBind -> String
sgBindToString (SgBind s _) = s sgBindToString (SgBind s _) = s
@ -84,6 +86,9 @@ syntaxGraphFromNodes icons = SyntaxGraph icons mempty mempty mempty mempty
syntaxGraphFromNodesEdges :: [(NodeName, SyntaxNode)] -> [Edge] -> SyntaxGraph syntaxGraphFromNodesEdges :: [(NodeName, SyntaxNode)] -> [Edge] -> SyntaxGraph
syntaxGraphFromNodesEdges icons edges = SyntaxGraph icons edges mempty mempty mempty syntaxGraphFromNodesEdges icons edges = SyntaxGraph icons edges mempty mempty mempty
bindsToSyntaxGraph :: [SgBind] -> SyntaxGraph
bindsToSyntaxGraph binds = SyntaxGraph mempty mempty mempty binds mempty
-- TODO Remove string parameter -- TODO Remove string parameter
getUniqueName :: String -> State IDState NodeName getUniqueName :: String -> State IDState NodeName
getUniqueName _ = fmap NodeName getId getUniqueName _ = fmap NodeName getId
@ -98,7 +103,7 @@ edgesForRefPortList inPattern portExpPairs = mconcat $ fmap makeGraph portExpPai
makeGraph (ref, port) = case ref of makeGraph (ref, port) = case ref of
Left str -> if inPattern Left str -> if inPattern
then SyntaxGraph mempty mempty mempty [SgBind str (Right port)] mempty then SyntaxGraph mempty mempty mempty [SgBind str (Right port)] mempty
else SyntaxGraph mempty mempty [(str, port)] mempty mempty else SyntaxGraph mempty mempty [SgSink str port] mempty mempty
Right resultPort -> SyntaxGraph mempty [Edge edgeOpts noEnds connection] mempty mempty mempty where Right resultPort -> SyntaxGraph mempty [Edge edgeOpts noEnds connection] mempty mempty mempty where
connection = if inPattern connection = if inPattern
-- If in a pattern, then the port on the case icon is the data source. -- If in a pattern, then the port on the case icon is the data source.
@ -111,7 +116,7 @@ combineExpressions inPattern portExpPairs = mconcat $ fmap makeGraph portExpPair
makeGraph ((graph, ref), port) = graph <> case ref of makeGraph ((graph, ref), port) = graph <> case ref of
Left str -> if inPattern Left str -> if inPattern
then SyntaxGraph mempty mempty mempty [SgBind str (Right port)] mempty then SyntaxGraph mempty mempty mempty [SgBind str (Right port)] mempty
else SyntaxGraph mempty mempty [(str, port)] mempty mempty else SyntaxGraph mempty mempty [SgSink str port] mempty mempty
Right resultPort -> SyntaxGraph mempty [Edge edgeOpts noEnds (resultPort, port)] mempty mempty mempty Right resultPort -> SyntaxGraph mempty [Edge edgeOpts noEnds (resultPort, port)] mempty mempty mempty
-- qualifyNameAndPort :: String -> NameAndPort -> NameAndPort -- qualifyNameAndPort :: String -> NameAndPort -> NameAndPort
@ -153,14 +158,14 @@ lookupReference bindings ref@(Left originalS) = lookupHelper ref where
deleteBindings :: SyntaxGraph -> SyntaxGraph deleteBindings :: SyntaxGraph -> SyntaxGraph
deleteBindings (SyntaxGraph a b c _ e) = SyntaxGraph a b c mempty e deleteBindings (SyntaxGraph a b c _ e) = SyntaxGraph a b c mempty e
makeEdgesCore :: [Sink] -> [SgBind] -> ([Sink], [Edge]) makeEdgesCore :: [SgSink] -> [SgBind] -> ([SgSink], [Edge])
makeEdgesCore sinks bindings = partitionEithers $ fmap renameOrMakeEdge sinks makeEdgesCore sinks bindings = partitionEithers $ fmap renameOrMakeEdge sinks
where where
renameOrMakeEdge :: (String, NameAndPort) -> Either (String, NameAndPort) Edge renameOrMakeEdge :: SgSink -> Either SgSink Edge
renameOrMakeEdge orig@(s, destPort) = case lookup s (fmap sgBindToTuple bindings) of renameOrMakeEdge orig@(SgSink s destPort) = case lookup s (fmap sgBindToTuple bindings) of
Just ref -> case lookupReference bindings ref of Just ref -> case lookupReference bindings ref of
(Right sourcePort) -> Right $ makeSimpleEdge (sourcePort, destPort) (Right sourcePort) -> Right $ makeSimpleEdge (sourcePort, destPort)
(Left newStr) -> Left (newStr, destPort) (Left newStr) -> Left $ SgSink newStr destPort
Nothing -> Left orig Nothing -> Left orig
makeEdges :: SyntaxGraph -> SyntaxGraph makeEdges :: SyntaxGraph -> SyntaxGraph