mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-17 10:50:24 +03:00
For SyntaxGraph, use a data type (SgSink) for sinks.
This commit is contained in:
parent
771f9a7cc3
commit
5c399b9e50
@ -20,12 +20,12 @@ import Language.Haskell.Exts(Decl(..), parseDecl, Name(..), Pat(..), Rhs(..),
|
||||
Stmt(..), Binds(..), Alt(..), Module(..), SpecialCon(..), prettyPrint)
|
||||
|
||||
import GraphAlgorithms(collapseNodes)
|
||||
import TranslateCore(Reference, SyntaxGraph(..), EvalContext, GraphAndRef, Sink, SgBind(..),
|
||||
import TranslateCore(Reference, SyntaxGraph(..), EvalContext, GraphAndRef, SgSink(..), SgBind(..),
|
||||
syntaxGraphFromNodes, syntaxGraphFromNodesEdges, getUniqueName, combineExpressions,
|
||||
edgesForRefPortList, makeApplyGraph,
|
||||
namesInPattern, lookupReference, deleteBindings, makeEdges,
|
||||
makeBox, nTupleString, nListString,
|
||||
syntaxGraphToFglGraph, getUniqueString)
|
||||
syntaxGraphToFglGraph, getUniqueString, bindsToSyntaxGraph)
|
||||
import Types(NameAndPort(..), IDState,
|
||||
initialIdState, Edge, SyntaxNode(..), IngSyntaxGraph, NodeName, Port(..), SgNamedNode,
|
||||
LikeApplyFlavor(..))
|
||||
@ -48,9 +48,6 @@ qOpToExp :: QOp -> Exp
|
||||
qOpToExp (QVarOp n) = Var 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.
|
||||
makeAsBindGraph :: Reference -> [Maybe String] -> SyntaxGraph
|
||||
makeAsBindGraph ref asNames = bindsToSyntaxGraph $ catMaybes $ fmap makeBind asNames where
|
||||
@ -106,7 +103,7 @@ evalLit (Exts.PrimString x) = makeLiteral x
|
||||
-- BEGIN evalPApp
|
||||
-- TODO Refactor decideIfNested and makePatternGraph
|
||||
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 valAndPort = (Just valAndPort, Nothing, [], [], [])
|
||||
|
||||
@ -561,7 +558,7 @@ generalEvalLambda context patterns rhsEvalFun = do
|
||||
icons = [(lambdaName, FunctionDefNode (length patterns))]
|
||||
returnPort = nameAndPort lambdaName (Port 0)
|
||||
(newEdges, newSinks) = case rhsRef of
|
||||
Left s -> (patternEdges, [(s, returnPort)])
|
||||
Left s -> (patternEdges, [SgSink s returnPort])
|
||||
Right rhsPort -> (makeSimpleEdge (rhsPort, returnPort) : patternEdges, 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])
|
||||
(Right patPort) -> case rhsRef of
|
||||
-- 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)
|
||||
asBindGraph = makeAsBindGraph rhsRef [patAsName]
|
||||
gr = asBindGraph <> SyntaxGraph mempty newEdges newSinks bindings mempty
|
||||
|
@ -3,10 +3,11 @@ module TranslateCore(
|
||||
SyntaxGraph(..),
|
||||
EvalContext,
|
||||
GraphAndRef,
|
||||
Sink,
|
||||
SgSink(..),
|
||||
SgBind(..),
|
||||
syntaxGraphFromNodes,
|
||||
syntaxGraphFromNodesEdges,
|
||||
bindsToSyntaxGraph,
|
||||
getUniqueName,
|
||||
getUniqueString,
|
||||
edgesForRefPortList,
|
||||
@ -48,13 +49,15 @@ type Reference = Either String NameAndPort
|
||||
|
||||
data SgBind = SgBind String Reference deriving (Eq, Show, Ord)
|
||||
|
||||
data SgSink = SgSink String NameAndPort deriving (Eq, Ord, Show)
|
||||
|
||||
-- TODO Replace lists with sets
|
||||
-- | SyntaxGraph is an abstract representation for Haskell syntax. SyntaxGraphs are
|
||||
-- generated from the Haskell syntax tree, and are used to generate Drawings
|
||||
data SyntaxGraph = SyntaxGraph {
|
||||
sgNodes :: [SgNamedNode],
|
||||
sgEdges :: [Edge],
|
||||
sgSinks :: [(String, NameAndPort)],
|
||||
sgSinks :: [SgSink],
|
||||
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 :: [(NodeName, NodeName)]
|
||||
@ -70,7 +73,6 @@ instance Monoid SyntaxGraph where
|
||||
|
||||
type EvalContext = [String]
|
||||
type GraphAndRef = (SyntaxGraph, Reference)
|
||||
type Sink = (String, NameAndPort)
|
||||
|
||||
sgBindToString :: SgBind -> String
|
||||
sgBindToString (SgBind s _) = s
|
||||
@ -84,6 +86,9 @@ syntaxGraphFromNodes icons = SyntaxGraph icons mempty mempty mempty mempty
|
||||
syntaxGraphFromNodesEdges :: [(NodeName, SyntaxNode)] -> [Edge] -> SyntaxGraph
|
||||
syntaxGraphFromNodesEdges icons edges = SyntaxGraph icons edges mempty mempty mempty
|
||||
|
||||
bindsToSyntaxGraph :: [SgBind] -> SyntaxGraph
|
||||
bindsToSyntaxGraph binds = SyntaxGraph mempty mempty mempty binds mempty
|
||||
|
||||
-- TODO Remove string parameter
|
||||
getUniqueName :: String -> State IDState NodeName
|
||||
getUniqueName _ = fmap NodeName getId
|
||||
@ -98,7 +103,7 @@ edgesForRefPortList inPattern portExpPairs = mconcat $ fmap makeGraph portExpPai
|
||||
makeGraph (ref, port) = case ref of
|
||||
Left str -> if inPattern
|
||||
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
|
||||
connection = if inPattern
|
||||
-- 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
|
||||
Left str -> if inPattern
|
||||
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
|
||||
|
||||
-- qualifyNameAndPort :: String -> NameAndPort -> NameAndPort
|
||||
@ -153,14 +158,14 @@ lookupReference bindings ref@(Left originalS) = lookupHelper ref where
|
||||
deleteBindings :: SyntaxGraph -> SyntaxGraph
|
||||
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
|
||||
where
|
||||
renameOrMakeEdge :: (String, NameAndPort) -> Either (String, NameAndPort) Edge
|
||||
renameOrMakeEdge orig@(s, destPort) = case lookup s (fmap sgBindToTuple bindings) of
|
||||
renameOrMakeEdge :: SgSink -> Either SgSink Edge
|
||||
renameOrMakeEdge orig@(SgSink s destPort) = case lookup s (fmap sgBindToTuple bindings) of
|
||||
Just ref -> case lookupReference bindings ref of
|
||||
(Right sourcePort) -> Right $ makeSimpleEdge (sourcePort, destPort)
|
||||
(Left newStr) -> Left (newStr, destPort)
|
||||
(Left newStr) -> Left $ SgSink newStr destPort
|
||||
Nothing -> Left orig
|
||||
|
||||
makeEdges :: SyntaxGraph -> SyntaxGraph
|
||||
|
Loading…
Reference in New Issue
Block a user