Handle where bindings in function definitions.

src/Language/Fay.hs

@@ -631,15 +631,8 @@ constructorName = fromString . ("$_" ++) . qname
 compileFunCase :: Bool -> [Match] -> Compile [JsStmt]
 compileFunCase _toplevel [] = return []
 compileFunCase toplevel matches@(Match _ name argslen _ _ _:_) = do
-  tco <- config configTCO
-  pats <- fmap optimizePatConditions $ forM matches $ \match@(Match _ _ pats _ rhs wheres) -> do
-    unless (noBinds wheres) $ do _ <- throwError (UnsupportedWhereInMatch match) -- TODO: Support `where'.
-                                 return ()
-    exp <- compileRhs rhs
-    foldM (\inner (arg,pat) ->
-            compilePat (JsName arg) pat inner)
-          [JsEarlyReturn exp]
-          (zip args pats)
+  tco  <- config configTCO
+  pats <- fmap optimizePatConditions (mapM compileCase matches)
   bind <- bindToplevel toplevel
                        (UnQual name)
                        (foldr (\arg inner -> JsFun [arg] [] (Just inner))
@@ -650,14 +643,32 @@ compileFunCase toplevel matches@(Match _ name argslen _ _ _:_) = do
                               args)
   return [bind]
   where args = zipWith const uniqueNames argslen
+
+        isWildCardMatch (Match _ _ pats _ _ _) = all isWildCardPat pats
+
+        compileCase :: Match -> Compile [JsStmt]
+        compileCase match@(Match _ _ pats _ rhs _) = do
+          whereDecls' <- whereDecls match
+          exp  <- compileRhs rhs
+          body <- if null whereDecls'
+                    then return exp
+                    else do
+                        binds <- mapM compileLetDecl whereDecls'
+                        return (JsApp (JsFun [] (concat binds) (Just exp)) [])
+          foldM (\inner (arg,pat) ->
+                  compilePat (JsName arg) pat inner)
+                [JsEarlyReturn body]
+                (zip args pats)
+
+        whereDecls :: Match -> Compile [Decl]
+        whereDecls (Match _ _ _ _ _ (BDecls decls)) = return decls
+        whereDecls match = throwError (UnsupportedWhereInMatch match)
+
+        basecase :: [JsStmt]
         basecase = if any isWildCardMatch matches
                       then []
                       else [throw ("unhandled case in " ++ show name)
                                   (JsList (map JsName args))]
-        isWildCardMatch (Match _ _ pats _ _ _) = all isWildCardPat pats
-        noBinds (BDecls []) = True
-        noBinds (IPBinds []) = True
-        noBinds _ = False
 
 -- | Optimize functions in tail-call form.
 optimizeTailCalls :: [JsParam] -- ^ The function parameters.

tests/whereBind

@@ -0,0 +1 @@
+30

tests/whereBind.hs

@@ -0,0 +1,10 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+main :: IO ()
+main =
+    let x = 10
+    in print $ show (x + y)
+  where y = 20
+
+print :: String -> Fay ()
+print = ffi "console.log(%1)"

tests/whereBind2

@@ -0,0 +1,2 @@
+ok
+nop

tests/whereBind2.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+someFun x = fun x
+  where fun x | x < 50 = "ok"
+              | otherwise = "nop"
+
+main :: IO ()
+main = do
+    print (someFun 30)
+    print (someFun 100)
+
+print :: String -> Fay ()
+print = ffi "console.log(%1)"

tests/whereBind3

@@ -0,0 +1 @@
+my friends and family

tests/whereBind3.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+f :: String -> String
+f x = friends ++ family
+  where friends = x
+        family = " and family"
+
+main = print (f "my friends")
+
+print :: String -> Fay ()
+print = ffi "console.log(%1)"