rgleichman/glance
1
1
Fork 0
mirror of https://github.com/rgleichman/glance.git synced 2024-09-11 15:05:41 +03:00
Code Issues Projects Releases Wiki Activity

Fix app/Translate.hs so FunBind works.

Browse Source
This commit is contained in:
Robbie Gleichman 2016-02-22 15:45:53 -08:00
parent dddb45ebb9
commit 52e34df6b4
1 changed files with 44 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
app/Translate.hs
View File

@ -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