git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #2020 from purescript/1558-case-wildcards
1fe80a5Gary Burgess
examples/passing/CaseInputWildcard.pursnew file+18
compare with golang
unifiedsplit
@@ -0,0 +1,18 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff (Eff)
5+import Control.Monad.Eff.Console (log, CONSOLE)
6+
7+data Foo = X | Y
8+
9+what ∷ Foo → Int → Boolean → Foo
10+what x = case _, x, _ of
11+ 0, X, true → X
12+ 0, Y, true → X
13+ _, _, _ → Y
14+
15+main :: forall e. Eff (console :: CONSOLE | e) Unit
16+main = do
17+ let tmp = what Y 0 true
18+ log "Done"
examples/passing/IfWildcard.pursnew file+19
@@ -0,0 +1,19 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff (Eff)
5+import Control.Monad.Eff.Console (log, CONSOLE)
6+
7+data Foo = X | Y
8+
9+cond ∷ ∀ a. Boolean → a → a → a
10+cond = if _ then _ else _
11+
12+what ∷ Boolean → Foo
13+what = if _ then X else Y
14+
15+main :: forall e. Eff (console :: CONSOLE | e) Unit
16+main = do
17+ let tmp1 = what true
18+ tmp2 = cond true 0 1
19+ log "Done"
src/Language/PureScript/Sugar/ObjectWildcards.hs+24−7
@@ -9,6 +9,7 @@ module Language.PureScript.Sugar.ObjectWildcards (
9import Prelude ()
9import Prelude ()
10import Prelude.Compat
10import Prelude.Compat
11
11
12+import Control.Monad (forM)
12import Control.Monad.Error.Class (MonadError(..))
13import Control.Monad.Error.Class (MonadError(..))
13import Control.Monad.Supply.Class
14import Control.Monad.Supply.Class
14
15
@@ -45,11 +46,21 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma
45 desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (Literal . ObjectLiteral) ps
46 desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (Literal . ObjectLiteral) ps
46 desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do
47 desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do
47 obj <- freshIdent'
48 obj <- freshIdent'
48− Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps
49+ Abs (Left obj) <$> wrapLambda (ObjectUpdate (argToExpr obj)) ps
49 desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps
50 desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps
50 desugarExpr (Accessor prop u) | isAnonymousArgument u = do
51 desugarExpr (Accessor prop u) | isAnonymousArgument u = do
51 arg <- freshIdent'
52 arg <- freshIdent'
52− return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))
53+ return $ Abs (Left arg) (Accessor prop (argToExpr arg))
54+ desugarExpr (Case args cas) | any isAnonymousArgument args = do
55+ argIdents <- forM args freshIfAnon
56+ let args' = zipWith (\p -> maybe p argToExpr) args argIdents
57+ return $ foldr (Abs . Left) (Case args' cas) (catMaybes argIdents)
58+ desugarExpr (IfThenElse u t f) | any isAnonymousArgument [u, t, f] = do
59+ u' <- freshIfAnon u
60+ t' <- freshIfAnon t
61+ f' <- freshIfAnon f
62+ let if_ = IfThenElse (maybe u argToExpr u') (maybe t argToExpr t') (maybe f argToExpr f')
63+ return $ foldr (Abs . Left) if_ (catMaybes [u', t', f'])
53 desugarExpr e = return e
64 desugarExpr e = return e
54
65
55 wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Expr)] -> m Expr
66 wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Expr)] -> m Expr
@@ -71,8 +82,14 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma
71 isAnonymousArgument _ = False
82 isAnonymousArgument _ = False
72
83
73 mkProp :: (String, Expr) -> m (Maybe Ident, (String, Expr))
84 mkProp :: (String, Expr) -> m (Maybe Ident, (String, Expr))
74− mkProp (name, e)
85+ mkProp (name, e) = do
75− | isAnonymousArgument e = do
86+ arg <- freshIfAnon e
87+ return (arg, (name, maybe e argToExpr arg))
88+
89+ freshIfAnon :: Expr -> m (Maybe Ident)
90+ freshIfAnon u
76− arg <- freshIdent'
91+ | isAnonymousArgument u = Just <$> freshIdent'
92+ | otherwise = return Nothing
93+
94+ argToExpr :: Ident -> Expr
77− return (Just arg, (name, Var (Qualified Nothing arg)))
95+ argToExpr = Var . Qualified Nothing
78− | otherwise = return (Nothing, (name, e))