Refactor evalLambda to share code with evalMatch.

app/Icons.hs

@@ -189,7 +189,7 @@ apply0NDia n = finalDia # centerXY where
 textBoxFontSize :: (Num a) => a
 textBoxFontSize = 1
 monoLetterWidthToHeightFraction :: (Fractional a) => a
-monoLetterWidthToHeightFraction = 0.6
+monoLetterWidthToHeightFraction = 0.61
 textBoxHeightFactor :: (Fractional a) => a
 textBoxHeightFactor = 1.1
 

app/Main.hs

@@ -4,7 +4,7 @@ module Main where
 import Diagrams.Prelude
 import Diagrams.Backend.SVG.CmdLine
 
-import Icons(apply0NDia, colorScheme, ColorStyle(..))
+import Icons(apply0NDia, textBox, colorScheme, ColorStyle(..))
 import Rendering(renderDrawing)
 import Util(toNames, portToPort, iconToPort, iconToIcon,
   iconToIconEnds, iconTailToPort)
@@ -12,14 +12,9 @@ import Types(Icon(..), Drawing(..), EdgeEnd(..))
 import Translate(translateString)
 
 -- TODO Now --
--- Refactor evalMatch to use a simplified version of makeEdges (makeEdgesCore)
--- - that does not use IconGraph as the data structure.
--- Rewrite and refactor evalLambda to use the new evalMatch
--- Destructuring pattern binds
 
 -- TODO Later --
 -- Eliminate BranchIcon for the identity funciton "y x = x"
--- Refactor evalLabmbda and evalMatch to use makeEdges
 -- otherwise Guard special case
 -- Let lines connect to ports in multiple locations (eg. argument for Apply0Dia)
 -- Add a small black border to lines to help distinguish line crossings.
@@ -264,9 +259,11 @@ main3 = do
       arrowTestDrawing
       ]
 
+caseTests = [
+
+  ]
+
 patternTests = [
-  "y = let {z = (\\x -> y x)} in z",
-  "y = let {z x = y x} in z ",
   "y (F x) = x",
   "y = (\\(F x) -> x)",
   "y = let {g = 3; F x y = h g} in x y",
@@ -277,7 +274,18 @@ patternTests = [
   "Foo x y = f 1 y x"
   ]
 
+lambdaTests = [
+  "{y 0 = 1; y 1= 0}",
+  "y (-1) = 2",
+  "y 1 = 0",
+  "{y (F x) = x; y (G x) = x}",
+  "y x = z 3 where z = f x y",
+  "y x = z where z = f x y"
+  ]
+
 letTests = [
+  "y = let {z = (\\x -> y x)} in z",
+  "y = let {z x = y x} in z ",
   "y = x where x = f 3 y",
   "y x1 = let {x2 = x1; x3 = x2; x4 = f x3} in x4",
   "y x1 = let x2 = f x1 in x2 x1",
@@ -336,7 +344,9 @@ otherTests = [
   ]
 
 testDecls = mconcat [
-  patternTests
+  caseTests
+  lambdaTests
+  ,patternTests
   ,letTests
   ,otherTests
   ]
@@ -354,7 +364,9 @@ translateStringToDrawing s = do
 main4 :: IO ()
 main4 = do
   drawings <- mapM translateStringToDrawing testDecls
-  let vCattedDrawings = vcat' (with & sep .~ 0.5) $ fmap alignL drawings
+  let
+    textDrawings = fmap (alignL . textBox) testDecls
+    vCattedDrawings = vcat' (with & sep .~ 1) $ zipWith (===) (fmap alignL drawings) textDrawings
   mainWith ((vCattedDrawings # bgFrame 1 (backgroundC colorScheme)) :: Diagram B)
 
 main :: IO ()

app/Translate.hs

@@ -11,14 +11,12 @@ import Language.Haskell.Exts(Decl(..), parseDecl, Name(..), Pat(..), Rhs(..),
   Stmt(..), Binds(..))
 import qualified Language.Haskell.Exts as Exts
 import Control.Monad.State(State, evalState)
-import Data.List(partition)
-import qualified Control.Arrow
 import Debug.Trace
 import Data.Either(partitionEithers)
 
 import Types(Icon, Edge(..), Drawing(..), NameAndPort(..), IDState,
   initialIdState, getId)
-import Util(toNames, noEnds, nameAndPort, justName, fromMaybeError)
+import Util(toNames, noEnds, nameAndPort, justName)
 import Icons(Icon(..))
 
 type Reference = Either String NameAndPort
@@ -29,6 +27,7 @@ data IconGraph = IconGraph [(DIA.Name, Icon)] [Edge] [(DIA.Name, Drawing)] [(Str
 
 type EvalContext = [String]
 type GraphAndRef = (IconGraph, Reference)
+type Sink = (String, NameAndPort)
 
 instance DIA.Semigroup IconGraph where
   (IconGraph icons1 edges1 subDrawings1 sinks1 sources1) <> (IconGraph icons2 edges2 subDrawings2 sinks2 sources2) =
@@ -63,9 +62,14 @@ evalPApp name patterns = do
   pure gr
 
 
+evalPLit :: Exts.Sign -> Exts.Literal -> State IDState (IconGraph, NameAndPort)
+evalPLit Exts.Signless l = evalLit l
+evalPLit Exts.Negative l = makeBox ('-' : showLiteral l)
+
 evalPattern :: Pat -> State IDState GraphAndRef
 evalPattern p = case p of
   PVar n -> pure (mempty, Left $ nameToString n)
+  PLit s l -> fmap Right <$> evalPLit s l
   PApp name patterns -> fmap Right <$> evalPApp name patterns
   PParen pat -> evalPattern pat
 
@@ -157,13 +161,15 @@ evalGuardedRhss c rhss = do
     newGraph = iconGraphFromIcons icons <> combindedGraph
   pure (newGraph, NameAndPort guardName (Just 0))
 
-makeLiteral :: (Show x) => x -> State IDState (IconGraph, NameAndPort)
-makeLiteral x = do
-  let str = show x
+makeBox :: String -> State IDState (IconGraph, NameAndPort)
+makeBox str = do
   name <- DIA.toName <$> getUniqueName str
   let graph = iconGraphFromIcons [(DIA.toName name, TextBoxIcon str)]
   pure (graph, justName name)
 
+makeLiteral :: (Show x) => x -> State IDState (IconGraph, NameAndPort)
+makeLiteral = makeBox. show
+
 evalLit :: Exts.Literal -> State IDState (IconGraph, NameAndPort)
 evalLit (Exts.Int x) = makeLiteral x
 evalLit (Exts.Char x) = makeLiteral x
@@ -178,6 +184,21 @@ evalLit (Exts.PrimDouble x) = makeLiteral x
 evalLit (Exts.PrimChar x) = makeLiteral x
 evalLit (Exts.PrimString x) = makeLiteral x
 
+showLiteral :: Exts.Literal -> String
+showLiteral (Exts.Int x) = show x
+showLiteral (Exts.Char x) = show x
+showLiteral (Exts.String x) = show x
+-- TODO: Print the Rational as a floating point.
+showLiteral (Exts.Frac x) = show x
+-- TODO: Test the unboxed literals
+showLiteral (Exts.PrimInt x) = show x
+showLiteral (Exts.PrimWord x) = show x
+showLiteral (Exts.PrimFloat x) = show x
+showLiteral (Exts.PrimDouble x) = show x
+showLiteral (Exts.PrimChar x) = show x
+showLiteral (Exts.PrimString x) = show x
+
+
 namesInPattern :: GraphAndRef -> [String]
 namesInPattern (_, Left str) = [str]
 namesInPattern (IconGraph _ _ _ _ bindings, Right _) = fmap fst bindings
@@ -215,18 +236,21 @@ lookupReference bindings ref@(Left originalS) = lookupHelper ref where
 deleteBindings :: IconGraph -> IconGraph
 deleteBindings (IconGraph a b c d _) = IconGraph a b c d mempty
 
+makeEdgesCore :: [Sink] -> [(String, Reference)] -> ([Sink], [Edge])
+makeEdgesCore sinks bindings = partitionEithers $ fmap renameOrMakeEdge sinks
+  where
+    renameOrMakeEdge :: (String, NameAndPort) -> Either (String, NameAndPort) Edge
+    renameOrMakeEdge orig@(s, destPort) = case lookup s bindings of
+      Just ref -> case lookupReference bindings ref of
+        (Right sourcePort) -> Right $ Edge (sourcePort, destPort) noEnds
+        (Left newStr) -> Left (newStr, destPort)
+      Nothing -> Left orig
+
 makeEdges :: IconGraph -> IconGraph
 makeEdges (IconGraph icons edges c sinks bindings) = newGraph where
-  (newSinks, newEdges) = partitionEithers $ fmap renameOrMakeEdge sinks
+  (newSinks, newEdges) = makeEdgesCore sinks bindings
   newGraph = IconGraph icons (newEdges <> edges) c newSinks bindings
 
-  renameOrMakeEdge :: (String, NameAndPort) -> Either (String, NameAndPort) Edge
-  renameOrMakeEdge orig@(s, destPort) = case lookup s bindings of
-    Just ref -> case lookupReference bindings ref of
-      (Right sourcePort) -> Right $ Edge (sourcePort, destPort) noEnds
-      (Left newStr) -> Left (newStr, destPort)
-    Nothing -> Left orig
-
 evalGeneralLet :: (EvalContext -> State IDState (IconGraph, Reference)) -> EvalContext -> Binds -> State IDState (IconGraph, Reference)
 evalGeneralLet expOrRhsEvaler c bs = do
   (bindGraph, bindContext) <- evalBinds c bs
@@ -235,7 +259,7 @@ evalGeneralLet expOrRhsEvaler c bs = do
     (expGraph, expResult) = expVal
     newGraph = deleteBindings . makeEdges $ expGraph <> bindGraph
     (IconGraph _ _ _ _ bindings) = bindGraph
-  pure $ printSelf (newGraph, lookupReference bindings expResult)
+  pure (newGraph, lookupReference bindings expResult)
 
 evalLet :: EvalContext -> Binds -> Exp -> State IDState (IconGraph, Reference)
 evalLet context binds e = evalGeneralLet (`evalExp` e) context binds
@@ -265,19 +289,20 @@ coerceExpressionResult (g, Right x) = (g, x)
 
 -- | First argument is the right hand side.
 -- The second arugement is a list of strings that are bound in the environment.
-evalRhs :: Rhs -> EvalContext -> State IDState (IconGraph, Reference)
-evalRhs (UnGuardedRhs e) c = evalExp c e
-evalRhs (GuardedRhss rhss) c = fmap Right <$> evalGuardedRhss c rhss
+evalRhs :: EvalContext -> Rhs -> State IDState (IconGraph, Reference)
+evalRhs c (UnGuardedRhs e) = evalExp c e
+evalRhs c (GuardedRhss rhss) = fmap Right <$> evalGuardedRhss c rhss
+
+rhsWithBinds :: Maybe Binds -> Rhs -> EvalContext -> State IDState (IconGraph, Reference)
+rhsWithBinds maybeWhereBinds rhs rhsContext = case maybeWhereBinds of
+  Nothing -> evalRhs rhsContext rhs
+  Just b -> evalGeneralLet (`evalRhs` rhs) rhsContext b
 
 evalPatBind :: EvalContext -> Decl -> State IDState IconGraph
 evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do
-  patternNames <- printSelf . namesInPattern <$> evalPattern pat
-  let
-    rhsContext = patternNames <> c
-  (rhsGraph, rhsRef) <- case maybeWhereBinds of
-    Nothing -> evalRhs rhs rhsContext
-    Just b -> evalGeneralLet (evalRhs rhs) rhsContext b
-
+  patternNames <- namesInPattern <$> evalPattern pat
+  let rhsContext = patternNames <> c
+  (rhsGraph, rhsRef) <- rhsWithBinds maybeWhereBinds rhs rhsContext
   (patGraph, patRef) <- evalPattern pat
   let
     (newEdges, newSinks, bindings) = case patRef of
@@ -287,22 +312,11 @@ evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do
         -- TODO: This edge should be special to indicate that one side is a pattern.
         (Right rhsPort) -> ([Edge (rhsPort, patPort) noEnds], mempty, mempty)
     gr = IconGraph mempty newEdges mempty newSinks bindings
-  pure .printSelf. makeEdges $ (gr <> rhsGraph <> patGraph)
+  pure . makeEdges $ (gr <> rhsGraph <> patGraph)
 
 iconGraphToDrawing :: IconGraph -> Drawing
 iconGraphToDrawing (IconGraph icons edges subDrawings _ _) = Drawing icons edges subDrawings
 
---processPatterns :: DIA.IsName a => a -> [Pat] -> ([(String, NameAndPort)], [String], Int)
-processPatterns :: DIA.IsName a  => a -> [Pat] -> [(String, NameAndPort)] -> ([(String, NameAndPort)], [String], Int)
-processPatterns lambdaName patterns extraVars =
-  (patternStringMap, patternStrings, numParameters)
-    where
-      lambdaPorts = map (nameAndPort lambdaName) [0,1..]
-      -- TODO this is wrong and must be rewritten for more complex patterns. (perhaps use makeEdges)
-      patternStringMap = extraVars <> zip (map (head . namesInPattern. (`evalState` initialIdState) .evalPattern) patterns) lambdaPorts
-      patternStrings = map fst patternStringMap
-      numParameters = length patterns
-
 makeRhsDrawing :: DIA.IsName a => a -> (IconGraph, NameAndPort) -> Drawing
 makeRhsDrawing resultIconName (rhsGraph, rhsResult)= rhsDrawing where
   rhsNewIcons = toNames [(resultIconName, ResultIcon)]
@@ -313,89 +327,19 @@ makeRhsDrawing resultIconName (rhsGraph, rhsResult)= rhsDrawing where
 qualifyNameAndPort :: String -> NameAndPort -> NameAndPort
 qualifyNameAndPort s (NameAndPort n p) = NameAndPort (s DIA..> n) p
 
-boundVarsToEdge :: Eq a => [(a, NameAndPort)] -> (a, NameAndPort) -> Edge
-boundVarsToEdge patternStringMap (s, np) = Edge (source, np) noEnds where
-  source = fromMaybeError "boundVarsToEdge: bound var not found" $ lookup s patternStringMap
-
---TODO: I think this will loop on recursive references (eg. ("a", Left "a"))
--- simplifyReferences :: [(String, Reference)] -> [(String, Reference)] -> [(String, NameAndPort)]
--- simplifyReferences extraBounds ls = map lookupReference ls where
---   augmentedLs = extraBounds <> ls
---   lookupReference (str, Right n@(NameAndPort _ _)) = (str, n)
---   lookupReference v@(str, Left n) = case lookup n augmentedLs of
---     Just x -> lookupReference (str, x)
---     Nothing -> error $ "Could not find reference. ls =" ++ show ls ++ "\nv=" ++ show v
-
-makeInternalEdges :: Foldable t => String -> IconGraph -> t String -> [(String, NameAndPort)] -> ([Edge], [(String, NameAndPort)])
-makeInternalEdges lambdaName rhsGraph patternStrings patternStringMap = (internalEdges, unmatchedBoundVars) where
-  (IconGraph _ _ _ boundVars _) = rhsGraph
-  qualifiedBoundVars =
-    fmap (Control.Arrow.second (qualifyNameAndPort lambdaName)) boundVars
-  (matchedBoundVars, unmatchedBoundVars) = partition (\(s, _) -> s `elem` patternStrings) qualifiedBoundVars
-  internalEdges = fmap (boundVarsToEdge patternStringMap) matchedBoundVars
-
-evalLambda :: EvalContext -> [Pat] -> Exp -> State IDState (IconGraph, NameAndPort)
-evalLambda c patterns e = do
-  lambdaName <- getUniqueName "lam"
-  let
-    (patternStringMap, patternStrings, numParameters) = processPatterns lambdaName patterns []
-    augmentedContext = patternStrings <> c
-  rhsVal <- evalExp augmentedContext e
-  resultIconName <- getUniqueName "res"
-  rhsDrawingName <- DIA.toName <$> getUniqueName "rhsDraw"
-  let
-    -- TODO remove coerceExpressionResult here
-    rhsCoercedVal@(rhsGraph, _) = coerceExpressionResult rhsVal
-    rhsDrawing = makeRhsDrawing resultIconName rhsCoercedVal
-    icons = toNames [(lambdaName, LambdaRegionIcon numParameters rhsDrawingName)]
-    (internalEdges, unmatchedBoundVars) =
-      makeInternalEdges lambdaName rhsGraph patternStrings patternStringMap
-    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 $ iconGraphFromIconsEdges mempty
     [Edge (lamPort, qualifyNameAndPort lambdaName patPort) noEnds]
 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
-  lambdaName <- getUniqueName "lam"
-  let
-    nameString = nameToString name
-    extraVars = [(nameString, justName lambdaName)]
-    (patternStringMap, patternStrings, numParameters) =
-      processPatterns lambdaName patterns extraVars
-  -- TODO remove coerceExpressionResult here
-  rhsVal@(rhsGraph, _) <- coerceExpressionResult <$> evalRhs rhs (patternStrings <> c)
-  resultIconName <- getUniqueName "res"
-  rhsDrawingName <- DIA.toName <$> getUniqueName "rhsDraw"
-  let
-    rhsDrawing = makeRhsDrawing resultIconName rhsVal
-    icons = toNames [
-      (lambdaName, LambdaRegionIcon numParameters rhsDrawingName)
-      --(nameString, TextBoxIcon nameString)
-      ]
-    --externalEdges = [Edge (justName nameString, justName lambdaName) noEnds]
-    (internalEdges, unmatchedBoundVars) =
-      makeInternalEdges lambdaName rhsGraph patternStrings patternStringMap
-    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
+generalEvalLambda :: EvalContext -> [Pat] -> (EvalContext -> State IDState GraphAndRef) -> State IDState (IconGraph, NameAndPort)
+generalEvalLambda context patterns rhsEvalFun = do
   lambdaName <- getUniqueName "lam"
   patternVals <- mapM evalPattern patterns
   let
-    matchFunNameString = nameToString name
     patternStrings = concatMap namesInPattern patternVals
-    rhsContext = matchFunNameString : patternStrings <> c
+    rhsContext = patternStrings <> context
     lambdaPorts = map (nameAndPort lambdaName) [0,1..]
     patternGraph = mconcat $ map fst patternVals
 
@@ -403,27 +347,39 @@ evalMatch c (Match _ name patterns _ rhs _) = do
       partitionEithers $ zipWith (makePatternEdges lambdaName) patternVals lambdaPorts
     patternEdgeGraph = mconcat patternEdgeGraphs
 
-    lambdaNameRef = Right $ justName lambdaName
-    newBinds = (matchFunNameString, lambdaNameRef): rawNewBinds
+    newBinds = rawNewBinds
     numParameters = length patterns
   -- TODO remove coerceExpressionResult here
-  (rhsRawGraph, rhsResult) <- coerceExpressionResult <$> evalRhs rhs rhsContext
+  (rhsRawGraph, rhsResult) <- coerceExpressionResult <$> rhsEvalFun 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)
+    (newSinks, internalEdges) = makeEdgesCore qualifiedSinks newBinds
     rhsDrawing = makeRhsDrawing resultIconName (rhsAndPatternGraph, rhsResult)
     icons = toNames [(lambdaName, LambdaRegionIcon numParameters rhsDrawingName)]
     finalGraph = IconGraph icons internalEdges [(rhsDrawingName, rhsDrawing)]
-      newSinks [(matchFunNameString, lambdaNameRef)]
-  pure $ patternEdgeGraph <> finalGraph
+      newSinks mempty
+  pure (patternEdgeGraph <> finalGraph, justName lambdaName)
 
+evalLambda :: EvalContext -> [Pat] -> Exp -> State IDState (IconGraph, NameAndPort)
+evalLambda c patterns e = generalEvalLambda c patterns (`evalExp` e)
+
+evalMatch :: EvalContext -> Match -> State IDState IconGraph
+evalMatch c (Match _ name patterns _ rhs maybeWhereBinds) = do
+  let
+    matchFunNameString = nameToString name
+    newContext = matchFunNameString : c
+  (lambdaGraph, lambdaPort) <-
+    generalEvalLambda newContext patterns (rhsWithBinds maybeWhereBinds rhs)
+  let
+    newBinding = IconGraph mempty mempty mempty mempty [(matchFunNameString, Right lambdaPort)]
+  pure $ makeEdges (newBinding <> lambdaGraph)
 
 evalMatches :: EvalContext -> [Match] -> State IDState IconGraph
 evalMatches _ [] = pure mempty
-evalMatches c [match] = evalMatch c match
+evalMatches c matches = mconcat <$> mapM (evalMatch c) matches
 -- TODO turn more than one match into a case expression.
 
 -- TODO: Use the context in evalPatBind and evalMatches