From ee5321325242dcc627459ee08f42d317fb71ca46 Mon Sep 17 00:00:00 2001
From: Robbie Gleichman <rgleichman@gmail.com>
Date: Sat, 8 Dec 2018 16:03:29 -0800
Subject: [PATCH] Remove state from matchesToCase.

---
 app/SimplifySyntax.hs        | 48 +++++++++++++++++++++++++++++++++---
 app/Translate.hs             | 14 +++++------
 test/VisualTranslateTests.hs |  3 ++-
 3 files changed, 52 insertions(+), 13 deletions(-)

diff --git a/app/SimplifySyntax.hs b/app/SimplifySyntax.hs
index 4525a84..7c219a5 100644
--- a/app/SimplifySyntax.hs
+++ b/app/SimplifySyntax.hs
@@ -57,11 +57,51 @@ infixAppToSeApp l e1 op e2 = case op of
 hsPatToSimpPat :: Exts.Pat a -> SimpPat a
 hsPatToSimpPat = undefined
 
-hsBindsToDecls :: Exts.Binds a -> [SimpDecl a]
-hsBindsToDecls = undefined
+whereToLet :: Show a => a -> Exts.Rhs a -> Maybe (Exts.Binds a) -> SimpExp a
+whereToLet l rhs maybeBinds = val
+  where
+    rhsExp = hsRhsToExp rhs
+    val = case maybeBinds of
+      Nothing -> rhsExp
+      Just binds -> SeLet l (hsBindsToDecls binds) rhsExp
 
-hsAltToSimpAlt :: Exts.Alt a -> SimpAlt a
-hsAltToSimpAlt = undefined
+matchesToLambda :: a -> [Exts.Match a] -> SimpDecl a
+matchesToLambda = undefined
+
+hsDeclToSimpDecl :: Show a => Exts.Decl a -> SimpDecl a
+hsDeclToSimpDecl decl = case decl of
+  Exts.FunBind l matches -> matchesToLambda l matches
+  Exts.PatBind l pat rhs maybeBinds -> SdPatBind l (hsPatToSimpPat pat) expr
+    where
+      expr = whereToLet l rhs maybeBinds
+  -- TODO Exts.TypeSig
+  _ -> error $ "Unsupported syntax in hsDeclToSimpDecl: " ++ show decl
+
+hsBindsToDecls :: Show a => Exts.Binds a -> [SimpDecl a]
+hsBindsToDecls binds = case binds of
+  Exts.BDecls _ decls -> fmap hsDeclToSimpDecl decls
+  _ -> error $ "Unsupported syntax in hsBindsToDecls: " ++ show binds
+
+guardedRhsToSelectorAndVal :: Show a => Exts.GuardedRhs a -> SelectorAndVal a
+guardedRhsToSelectorAndVal rhs = case rhs of
+  Exts.GuardedRhs _ [s] valExp -> SelectorAndVal{svSelector=stmtToExp s
+                                                , svVal=hsExpToSimpExp valExp}
+  _ -> error $ "Unsupported syntax in guardedRhsToSelectorAndVal: " ++ show rhs
+  where
+    stmtToExp stmt = case stmt of
+      Exts.Qualifier _ e -> hsExpToSimpExp e
+      _ -> error
+           $ "Unsupported syntax in stmtToExp: " ++ show stmt
+
+hsRhsToExp :: Show a => Exts.Rhs a -> SimpExp a
+hsRhsToExp rhs = case rhs of
+  Exts.UnGuardedRhs _ e -> hsExpToSimpExp e
+  Exts.GuardedRhss l rhss
+    -> SeGuard l (fmap guardedRhsToSelectorAndVal rhss)
+
+hsAltToSimpAlt :: Show a => Exts.Alt a -> SimpAlt a
+hsAltToSimpAlt (Exts.Alt l pat rhs maybeBinds)
+  = SimpAlt{saPat=hsPatToSimpPat pat, saVal=whereToLet l rhs maybeBinds}
 
 ifToGuard :: a -> SimpExp a -> SimpExp a -> SimpExp a -> SimpExp a
 ifToGuard l e1 e2 e3
diff --git a/app/Translate.hs b/app/Translate.hs
index 593e207..b86c2ae 100644
--- a/app/Translate.hs
+++ b/app/Translate.hs
@@ -847,12 +847,12 @@ matchToAlt (Match l _ mtaPats rhs binds) = Alt l altPattern rhs binds where
     _ -> PTuple l Exts.Boxed mtaPats
 matchToAlt match = error $ "Unsupported syntax in matchToAlt: " <> show match
 
-matchesToCase :: Show l => Match l -> [Match l] -> State IDState (Match l)
-matchesToCase match [] = pure match
-matchesToCase firstMatch@(Match srcLoc funName pats _ _) restOfMatches = do
+matchesToCase :: Show l => Match l -> [Match l] -> Match l
+matchesToCase match [] = match
+matchesToCase firstMatch@(Match srcLoc funName pats _ _) restOfMatches = match
+  where
   -- There is a special case in Icons.hs/makeLabelledPort to exclude " tempvar"
-  tempStrings <- replicateM (length pats) (getUniqueString " tempvar")
-  let
+    tempStrings = fmap (\x -> " tempvar" ++ show x) [0..(length pats - 1)]
     tempPats = fmap (PVar srcLoc . Ident srcLoc) tempStrings
     tempVars = fmap (makeVarExp srcLoc) tempStrings
     tuple = Tuple srcLoc Exts.Boxed tempVars
@@ -861,8 +861,6 @@ matchesToCase firstMatch@(Match srcLoc funName pats _ _) restOfMatches = do
       _ -> Case srcLoc tuple alts
     rhs = UnGuardedRhs srcLoc caseExp
     match = Match srcLoc funName tempPats rhs Nothing
-  pure match
-  where
     allMatches = firstMatch:restOfMatches
     alts = fmap matchToAlt allMatches
 matchesToCase firstMatch _
@@ -884,7 +882,7 @@ evalMatch _ match = error $ "Unsupported syntax in evalMatch: " <> show match
 evalMatches :: Show l => EvalContext -> [Match l] -> State IDState SyntaxGraph
 evalMatches _ [] = pure mempty
 evalMatches c (firstMatch:restOfMatches)
-  = matchesToCase firstMatch restOfMatches >>= evalMatch c
+  = evalMatch c $ matchesToCase firstMatch restOfMatches
 
 -- END evalMatches
 
diff --git a/test/VisualTranslateTests.hs b/test/VisualTranslateTests.hs
index 58fcf32..358e9f9 100644
--- a/test/VisualTranslateTests.hs
+++ b/test/VisualTranslateTests.hs
@@ -191,7 +191,8 @@ lambdaTests = [
   "y x = f x1 x2",
   "y (-1) = 2",
   "y 1 = 0",
-  "y x = z 3 where z = f x y"
+  "y x = z 3 where z = f x y",
+  "y (Foo x) = x; y (Bar x) = 3"  -- test multiple matches
   ]
 
 letTests :: [String]