git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fix #1008
f424134Phil Freeman
examples/passing/CaseStatement.pursnew file+19
compare with golang
unifiedsplit
@@ -0,0 +1,19 @@
1+module Main where
2+
3+data A = A | B | C
4+
5+f a _ A = a
6+f _ a B = a
7+f _ _ C = "Done"
8+
9+g a _ A = a
10+g _ b B = b
11+g _ _ C = C
12+
13+data M a = N | J a
14+
15+h f N a = a
16+h f a N = a
17+h f (J a) (J b) = J (f a b)
18+
19+main = Debug.Trace.trace $ f "Done" "Failed" A
src/Language/PureScript/Sugar/CaseDeclarations.hs+27−16
@@ -21,10 +21,11 @@ module Language.PureScript.Sugar.CaseDeclarations (
21 desugarCasesModule
21 desugarCasesModule
22) where
22) where
23
23
24+import Data.Maybe (catMaybes)
24import Data.List (nub, groupBy)
25import Data.List (nub, groupBy)
25
26
26import Control.Applicative
27import Control.Applicative
27−import Control.Monad ((<=<), forM, join, unless)
28+import Control.Monad ((<=<), forM, replicateM, join, unless)
28import Control.Monad.Except (throwError)
29import Control.Monad.Except (throwError)
29import Control.Monad.Error.Class (MonadError)
30import Control.Monad.Error.Class (MonadError)
30import Control.Monad.Supply.Class
31import Control.Monad.Supply.Class
@@ -120,31 +121,41 @@ toTuple _ = error "Not a value declaration"
120makeCaseDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
121makeCaseDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
121makeCaseDeclaration ident alternatives = do
122makeCaseDeclaration ident alternatives = do
122 let namedArgs = map findName . fst <$> alternatives
123 let namedArgs = map findName . fst <$> alternatives
123− args <- mapM argName $ foldl1 resolveNames namedArgs
124+ argNames = map join $ foldl1 resolveNames namedArgs
124− let
125+ args <- if allUnique (catMaybes argNames)
126+ then mapM argName argNames
127+ else replicateM (length argNames) (Ident <$> freshName)
125− vars = map (Var . Qualified Nothing) args
128+ let vars = map (Var . Qualified Nothing) args
126− binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
129+ binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
127− value = foldr (Abs . Left) (Case vars binders) args
130+ value = foldr (Abs . Left) (Case vars binders) args
128 return $ ValueDeclaration ident Value [] (Right value)
131 return $ ValueDeclaration ident Value [] (Right value)
129 where
132 where
130− findName :: Binder -> Maybe Ident
133+ findName :: Binder -> Maybe (Maybe Ident)
134+ findName NullBinder = Just Nothing
131− findName (VarBinder name) = Just name
135+ findName (VarBinder name) = Just (Just name)
132 findName (PositionedBinder _ _ binder) = findName binder
136 findName (PositionedBinder _ _ binder) = findName binder
133 findName _ = Nothing
137 findName _ = Nothing
134
138
139+ allUnique :: (Eq a) => [a] -> Bool
140+ allUnique xs = length xs == length (nub xs)
141+
135 argName :: (MonadSupply m) => Maybe Ident -> m Ident
142 argName :: (MonadSupply m) => Maybe Ident -> m Ident
136 argName (Just name) = return name
143 argName (Just name) = return name
137− argName Nothing = do
144+ argName _ = do
138 name <- freshName
145 name <- freshName
139 return (Ident name)
146 return (Ident name)
140
147
141− resolveNames :: [Maybe Ident] -> [Maybe Ident] -> [Maybe Ident]
148+ resolveNames :: [Maybe (Maybe Ident)] ->
149+ [Maybe (Maybe Ident)] ->
150+ [Maybe (Maybe Ident)]
142 resolveNames = zipWith resolveName
151 resolveNames = zipWith resolveName
143
152
144− resolveName :: Maybe Ident -> Maybe Ident -> Maybe Ident
153+ resolveName :: Maybe (Maybe Ident) ->
154+ Maybe (Maybe Ident) ->
155+ Maybe (Maybe Ident)
145− resolveName (Just a) (Just b)
156+ resolveName (Just (Just a)) (Just (Just b))
146− | a == b = Just a
157+ | a == b = Just (Just a)
147 | otherwise = Nothing
158 | otherwise = Nothing
148− resolveName Nothing Nothing = Nothing
159+ resolveName (Just Nothing) a = a
149− resolveName (Just a) Nothing = Just a
160+ resolveName a (Just Nothing) = a
150− resolveName Nothing (Just b) = Just b
161+ resolveName _ _ = Nothing