diff --git a/app/Icons.hs b/app/Icons.hs index 07eaca3..d17eae7 100644 --- a/app/Icons.hs +++ b/app/Icons.hs @@ -5,7 +5,13 @@ module Icons TransformableDia, getPortAngles, iconToDiagram, + inputPort, resultPort, + argumentPorts, + caseRhsPorts, + casePatternPorts, + guardRhsPorts, + guardBoolPorts, textBox, multilineComment, defaultLineWidth, @@ -22,7 +28,7 @@ import Data.Either(partitionEithers) import qualified Control.Arrow as Arrow import Types(Icon(..), SpecialQDiagram, SpecialBackend, SpecialNum, NodeName, Port(..), LikeApplyFlavor(..), - SyntaxNode) + SyntaxNode(..)) import DrawingColors(colorScheme, ColorStyle(..)) -- TYPES -- @@ -152,9 +158,40 @@ getPortAngles icon port maybeNodeName = case icon of -- BEGIN Port numbers -- TODO It's a bit strange that the parameter is a SyntaxNode, not an Icon. +inputPort :: SyntaxNode -> Port +inputPort = const (Port 0) + resultPort :: SyntaxNode -> Port resultPort = const (Port 1) +caseRhsPorts :: [Port] +caseRhsPorts = fmap Port [2,4..] + +casePatternPorts :: [Port] +casePatternPorts = fmap Port [3,5..] + +guardRhsPorts :: [Port] +guardRhsPorts = caseRhsPorts + +guardBoolPorts :: [Port] +guardBoolPorts = casePatternPorts + +argumentPorts :: SyntaxNode -> [Port] +argumentPorts n = case n of + LikeApplyNode _ _-> defaultPorts + NestedApplyNode _ _ _ -> defaultPorts + PatternApplyNode _ _-> defaultPorts + NestedPatternApplyNode _ _-> defaultPorts + FunctionDefNode _ -> defaultPorts + NestedCaseOrGuardNode _ _ _-> defaultPorts + GuardNode _ -> defaultPorts + CaseNode _ -> defaultPorts + NameNode _ -> [] + BindNameNode _ -> [] + LiteralNode _ -> [] + CaseResultNode -> [] + where + defaultPorts = fmap Port [2,3..] -- END Port numbers -- END Exported icon functions -- diff --git a/app/Rendering.hs b/app/Rendering.hs index 7bc6688..e21beb9 100644 --- a/app/Rendering.hs +++ b/app/Rendering.hs @@ -13,7 +13,6 @@ import qualified Data.GraphViz as GV import qualified Data.GraphViz.Attributes.Complete as GVA import qualified Data.Map as Map -import Control.Arrow(second) import Data.Function(on) import qualified Data.Graph.Inductive as ING import Data.Graph.Inductive.PatriciaTree (Gr) @@ -29,7 +28,7 @@ import Data.Typeable(Typeable) import Icons(colorScheme, iconToDiagram, defaultLineWidth, ColorStyle(..), getPortAngles) import TranslateCore(nodeToIcon) import Types(Edge(..), Icon, EdgeOption(..), Drawing(..), EdgeEnd(..), - NameAndPort(..), SpecialQDiagram, SpecialBackend, SyntaxNode, SpecialNum, NodeName(..), Port(..), + NameAndPort(..), SpecialQDiagram, SpecialBackend, SpecialNum, NodeName(..), Port(..), SgNamedNode) import Util(fromMaybeError, mapNodeInNamedNode) diff --git a/app/Translate.hs b/app/Translate.hs index 05738fb..059e41d 100644 --- a/app/Translate.hs +++ b/app/Translate.hs @@ -28,10 +28,11 @@ import TranslateCore(Reference, SyntaxGraph(..), EvalContext, GraphAndRef(..), S syntaxGraphToFglGraph, getUniqueString, bindsToSyntaxGraph, graphAndRefToGraph, initialIdState) import Types(NameAndPort(..), IDState, - Edge, SyntaxNode(..), IngSyntaxGraph, NodeName, Port(..), SgNamedNode(..), + Edge, SyntaxNode(..), IngSyntaxGraph, NodeName, SgNamedNode(..), LikeApplyFlavor(..)) import Util(makeSimpleEdge, nameAndPort, justName) -import Icons(resultPort) +import Icons(inputPort, resultPort, argumentPorts, caseRhsPorts, + casePatternPorts, guardRhsPorts, guardBoolPorts) -- OVERVIEW -- -- The core functions and data types used in this module are in TranslateCore. @@ -127,8 +128,8 @@ graphsToComponents graphs = (concat a, concat b, concat c, concat d, concat e) w makeNestedPatternGraph :: NodeName -> String -> [(GraphAndRef, Maybe String)] -> (SyntaxGraph, NameAndPort) makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult where - -- TODO Don't use hardcoded port numbers - argsAndPorts = zip (fmap fst argVals) $ map (nameAndPort applyIconName . Port) [2,3..] + pAppNode = NestedPatternApplyNode funStr argList + argsAndPorts = zip (fmap fst argVals) $ map (nameAndPort applyIconName) $ argumentPorts pAppNode mappedArgs = fmap patternArgumentMapper argsAndPorts (unnestedArgsAndPort, nestedNamedNodesAndGraphs) = partitionEithers mappedArgs @@ -142,7 +143,7 @@ makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult argList = fmap argListMapper mappedArgs combinedGraph = combineExpressions True unnestedArgsAndPort - pAppNode = NestedPatternApplyNode funStr argList + icons = [SgNamedNode applyIconName pAppNode] asNameBinds = catMaybes $ fmap asNameBind argVals @@ -156,10 +157,10 @@ makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult makePatternGraph' :: NodeName -> String -> [GraphAndRef] -> (SyntaxGraph, NameAndPort) makePatternGraph' applyIconName funStr argVals = (newGraph <> combinedGraph, nameAndPort applyIconName (resultPort pAppNode)) where - argumentPorts = map (nameAndPort applyIconName . Port) [2,3..] - combinedGraph = combineExpressions True $ zip argVals argumentPorts - numArgs = length argVals pAppNode = PatternApplyNode funStr numArgs + argumentNamePorts = map (nameAndPort applyIconName) $ argumentPorts pAppNode + combinedGraph = combineExpressions True $ zip argVals argumentNamePorts + numArgs = length argVals icons = [SgNamedNode applyIconName pAppNode] newGraph = syntaxGraphFromNodes icons @@ -378,8 +379,10 @@ evalIf c e1 e2 e3 = do let guardNode = GuardNode 2 icons = [SgNamedNode guardName guardNode] + boolPort = take 1 guardBoolPorts + rhsPorts = take 2 guardRhsPorts combinedGraph = - combineExpressions False $ zip [e1Val, e2Val, e3Val] (map (nameAndPort guardName . Port) [3, 2, 4]) + combineExpressions False $ zip [e1Val, e2Val, e3Val] (map (nameAndPort guardName) (boolPort <> rhsPorts)) newGraph = syntaxGraphFromNodes icons <> combinedGraph pure (newGraph, nameAndPort guardName (resultPort guardNode)) @@ -437,10 +440,10 @@ evalGuardedRhss c rhss = do evaledRhss <- mapM (evalGuaredRhs c) rhss let (bools, exps) = unzip evaledRhss - expsWithPorts = zip exps $ map (nameAndPort guardName . Port) [2,4..] - boolsWithPorts = zip bools $ map (nameAndPort guardName . Port) [3,5..] - combindedGraph = combineExpressions False $ expsWithPorts <> boolsWithPorts guardNode = GuardNode (length rhss) + expsWithPorts = zip exps $ map (nameAndPort guardName) guardRhsPorts + boolsWithPorts = zip bools $ map (nameAndPort guardName) guardBoolPorts + combindedGraph = combineExpressions False $ expsWithPorts <> boolsWithPorts icons = [SgNamedNode guardName guardNode] newGraph = syntaxGraphFromNodes icons <> combindedGraph pure (newGraph, nameAndPort guardName (resultPort guardNode)) @@ -489,12 +492,12 @@ evalCase c e alts = do (patRhsConnected, altGraphs, patRefs, rhsRefs, asNames) = unzip5 evaledAlts combindedAltGraph = mconcat altGraphs numAlts = length alts - caseNode = (CaseNode numAlts) + caseNode = CaseNode numAlts icons = [SgNamedNode caseIconName caseNode] caseGraph = syntaxGraphFromNodes icons - expEdge = (expRef, nameAndPort caseIconName (Port 0)) - patEdges = zip patRefs $ map (nameAndPort caseIconName . Port) [2,4..] - rhsEdges = zip patRhsConnected $ zip rhsRefs $ map (nameAndPort caseIconName . Port) [3,5..] + expEdge = (expRef, nameAndPort caseIconName (inputPort caseNode)) + patEdges = zip patRefs $ map (nameAndPort caseIconName) casePatternPorts + rhsEdges = zip patRhsConnected $ zip rhsRefs $ map (nameAndPort caseIconName) caseRhsPorts (connectedRhss, unConnectedRhss) = partition fst rhsEdges resultIconNames <- replicateM numAlts getUniqueName let @@ -570,7 +573,8 @@ generalEvalLambda context patterns rhsEvalFun = do patternVals = fmap fst patternValsWithAsNames patternStrings = concatMap namesInPattern patternValsWithAsNames rhsContext = patternStrings <> context - lambdaPorts = map (nameAndPort lambdaName . Port) [2,3..] + lambdaNode = FunctionDefNode (length patterns) + lambdaPorts = map (nameAndPort lambdaName) $ argumentPorts lambdaNode patternGraph = mconcat $ fmap graphAndRefToGraph patternVals (patternEdges, newBinds) = @@ -578,9 +582,8 @@ generalEvalLambda context patterns rhsEvalFun = do GraphAndRef rhsRawGraph rhsRef <- rhsEvalFun rhsContext let - lambdaNode = FunctionDefNode (length patterns) icons = [SgNamedNode lambdaName lambdaNode] - returnPort = nameAndPort lambdaName (Port 0) + returnPort = nameAndPort lambdaName (inputPort lambdaNode) (newEdges, newSinks) = case rhsRef of Left s -> (patternEdges, [SgSink s returnPort]) Right rhsPort -> (makeSimpleEdge (rhsPort, returnPort) : patternEdges, mempty) @@ -746,13 +749,12 @@ syntaxGraphToCollapsedGraph = collapseNodes . syntaxGraphToFglGraph translateDeclToCollapsedGraph :: Decl -> IngSyntaxGraph FGR.Gr translateDeclToCollapsedGraph = syntaxGraphToCollapsedGraph . translateDeclToSyntaxGraph --- Profiling: about 1.5% of total time. +-- Profiling: At one point, this was about 1.5% of total time. translateStringToCollapsedGraphAndDecl :: String -> (IngSyntaxGraph FGR.Gr, Decl) translateStringToCollapsedGraphAndDecl s = (drawing, decl) where decl = fromParseResult (parseDecl s) -- :: ParseResult Module drawing = translateDeclToCollapsedGraph decl --- TODO Put the type declarations in a box below the image. translateModuleToCollapsedGraphs :: Module -> [IngSyntaxGraph FGR.Gr] translateModuleToCollapsedGraphs (Module _ _ _ _ _ _ decls) = fmap translateDeclToCollapsedGraph decls diff --git a/app/TranslateCore.hs b/app/TranslateCore.hs index f506634..e2e299a 100644 --- a/app/TranslateCore.hs +++ b/app/TranslateCore.hs @@ -28,7 +28,6 @@ module TranslateCore( initialIdState ) where -import Control.Arrow(second) import Control.Monad.State(State, state) import Data.Either(partitionEithers) import qualified Data.Graph.Inductive.PatriciaTree as FGR diff --git a/app/Types.hs b/app/Types.hs index 413f7c8..836d600 100644 --- a/app/Types.hs +++ b/app/Types.hs @@ -24,7 +24,6 @@ module Types ( import Diagrams.Prelude(QDiagram, V2, Any, Renderable, Path, IsName) import Diagrams.TwoD.Text(Text) -import Control.Monad.State(State, state) import Data.Typeable(Typeable) -- TYPES -- diff --git a/test/UnitTests.hs b/test/UnitTests.hs index 2ac038b..82dc365 100644 --- a/test/UnitTests.hs +++ b/test/UnitTests.hs @@ -10,7 +10,7 @@ import qualified Data.Graph.Inductive.PatriciaTree as FGR import Data.List(foldl', sort, sortOn) import Translate(translateStringToSyntaxGraph) -import TranslateCore(syntaxGraphToFglGraph, SyntaxGraph(..), Reference, SgBind(..)) +import TranslateCore(syntaxGraphToFglGraph, SyntaxGraph(..), SgBind(..)) import Types(SgNamedNode(..), Edge(..), SyntaxNode(..), IngSyntaxGraph, NodeName(..), LikeApplyFlavor(..), NameAndPort(..)) import qualified GraphAlgorithms diff --git a/todo.md b/todo.md index 99a79f6..92ae64e 100644 --- a/todo.md +++ b/todo.md @@ -10,6 +10,8 @@ * Fix the arrowheads being too big for SyntaxGraph drawings. ### Visual todos +* Fix whitspace being stripped in comments. + * Draw bounding boxes for lambdas (use dashed lines) * Use different line styles (e.g. dashed, solid, wavy) in addition to colors