mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Fix app/Translate.hs so FunBind works.
This commit is contained in:
parent
dddb45ebb9
commit
52e34df6b4
@ -353,6 +353,11 @@ evalLambda c patterns e = do
|
||||
drawing = IconGraph icons internalEdges [(rhsDrawingName, rhsDrawing)] unmatchedBoundVars mempty
|
||||
pure (drawing, justName lambdaName)
|
||||
|
||||
makePatternEdges :: String -> GraphAndRef -> NameAndPort -> Either IconGraph (String, Reference)
|
||||
makePatternEdges lambdaName (_, Right patPort) lamPort =
|
||||
Left $ IconGraph mempty [Edge (lamPort, qualifyNameAndPort lambdaName patPort) noEnds] mempty mempty mempty
|
||||
-- TODO case where pattern is a String
|
||||
makePatternEdges _ (_, Left str) lamPort = Right (str, Right lamPort)
|
||||
-- TODO handle inner function definitions.
|
||||
evalMatch :: EvalContext -> Match -> State IDState IconGraph
|
||||
evalMatch c (Match _ name patterns _ rhs _) = do
|
||||
@ -369,17 +374,51 @@ evalMatch c (Match _ name patterns _ rhs _) = do
|
||||
let
|
||||
rhsDrawing = makeRhsDrawing resultIconName rhsVal
|
||||
icons = toNames [
|
||||
(lambdaName, LambdaRegionIcon numParameters rhsDrawingName),
|
||||
(nameString, TextBoxIcon nameString)
|
||||
(lambdaName, LambdaRegionIcon numParameters rhsDrawingName)
|
||||
--(nameString, TextBoxIcon nameString)
|
||||
]
|
||||
externalEdges = [Edge (justName nameString, justName lambdaName) noEnds]
|
||||
--externalEdges = [Edge (justName nameString, justName lambdaName) noEnds]
|
||||
(internalEdges, unmatchedBoundVars) =
|
||||
makeInternalEdges lambdaName rhsGraph patternStrings patternStringMap
|
||||
drawing = IconGraph icons (externalEdges <> internalEdges)
|
||||
[(rhsDrawingName, rhsDrawing)] unmatchedBoundVars mempty
|
||||
drawing = IconGraph icons (internalEdges)
|
||||
[(rhsDrawingName, rhsDrawing)] unmatchedBoundVars [(nameString, Right $ justName lambdaName)]
|
||||
pure drawing
|
||||
|
||||
|
||||
-- -- TODO handle inner function definitions.
|
||||
-- -- TODO: Make sure that any remaining sinks are qualified.
|
||||
-- evalMatch :: EvalContext -> Match -> State IDState IconGraph
|
||||
-- evalMatch c (Match _ name patterns _ rhs _) = do
|
||||
-- lambdaName <- getUniqueName "lam"
|
||||
-- patternVals <- mapM evalPattern patterns
|
||||
-- let
|
||||
-- patternStrings = concatMap namesInPattern patternVals
|
||||
-- rhsContext = nameString : patternStrings <> c
|
||||
-- lambdaPorts = map (nameAndPort lambdaName) [0,1..]
|
||||
-- patternGraph = mconcat $ map fst patternVals
|
||||
-- nameString = nameToString name
|
||||
-- (patternEdgeGraphs, rawNewBinds) = partitionEithers $ zipWith (makePatternEdges lambdaName) patternVals lambdaPorts
|
||||
-- patternEdgeGraph = mconcat patternEdgeGraphs
|
||||
-- newBinds = (nameString, Right $ justName lambdaName): rawNewBinds
|
||||
-- numParameters = length patterns
|
||||
-- -- TODO remove coerceExpressionResult here
|
||||
-- (rhsRawGraph, rhsResult) <- coerceExpressionResult <$> evalRhs rhs rhsContext
|
||||
-- resultIconName <- getUniqueName "res"
|
||||
-- rhsDrawingName <- DIA.toName <$> getUniqueName "rhsDraw"
|
||||
-- let
|
||||
-- rhsAndPatternGraph@(IconGraph _ _ _ sinks _) = makeEdges $ patternGraph <> rhsRawGraph
|
||||
-- qualifiedSinks = fmap (fmap (qualifyNameAndPort lambdaName)) sinks
|
||||
-- (IconGraph _ internalEdges _ newSinks _) = makeEdges (IconGraph mempty mempty mempty qualifiedSinks newBinds)
|
||||
-- rhsDrawing = makeRhsDrawing resultIconName (rhsAndPatternGraph, rhsResult)
|
||||
-- icons = toNames [
|
||||
-- (lambdaName, LambdaRegionIcon numParameters rhsDrawingName),
|
||||
-- (nameString, TextBoxIcon nameString)
|
||||
-- ]
|
||||
-- externalEdges = [Edge (justName nameString, justName lambdaName) noEnds]
|
||||
-- finalGraph = IconGraph icons (internalEdges <> externalEdges) [(rhsDrawingName, rhsDrawing)] newSinks mempty
|
||||
-- pure $ patternEdgeGraph <> finalGraph
|
||||
|
||||
|
||||
evalMatches :: EvalContext -> [Match] -> State IDState IconGraph
|
||||
evalMatches _ [] = pure mempty
|
||||
evalMatches c [match] = evalMatch c match
|
||||
|
Loading…
Reference in New Issue
Block a user