mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-17 02:40:28 +03:00
Remove hardcoded port numbers from Translate.hs.
This commit is contained in:
parent
6c5663dccf
commit
3ed4c846bb
39
app/Icons.hs
39
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 --
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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 --
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user