diff --git a/app/Translate.hs b/app/Translate.hs index f89ef1d..c04bec8 100644 --- a/app/Translate.hs +++ b/app/Translate.hs @@ -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 diff --git a/app/TranslateCore.hs b/app/TranslateCore.hs index 73e3735..8522f39 100644 --- a/app/TranslateCore.hs +++ b/app/TranslateCore.hs @@ -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