Permalink
Browse files

Handle where bindings in function definitions.

  • Loading branch information...
osa1 authored and chrisdone committed Sep 6, 2012
1 parent 0a3798b commit f827a14e4aa0ca244c2fa57843987a2ad04b5c45
Showing with 62 additions and 13 deletions.
  1. +24 −13 src/Language/Fay.hs
  2. +1 −0 tests/whereBind
  3. +10 −0 tests/whereBind.hs
  4. +2 −0 tests/whereBind2
  5. +13 −0 tests/whereBind2.hs
  6. +1 −0 tests/whereBind3
  7. +11 −0 tests/whereBind3.hs
View
@@ -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.
View
@@ -0,0 +1 @@
+30
View
@@ -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)"
View
@@ -0,0 +1,2 @@
+ok
+nop
View
@@ -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)"
View
@@ -0,0 +1 @@
+my friends and family
View
@@ -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)"

0 comments on commit f827a14

Please sign in to comment.