@@ -21,10 +21,11 @@ module Language.PureScript.Sugar.CaseDeclarations (
2121 desugarCasesModule
2222) where
2323
24+import Data.Maybe (catMaybes)
2425import Data.List (nub, groupBy)
2526
2627import Control.Applicative
27−import Control.Monad ((<=<), forM, join, unless)
28+import Control.Monad ((<=<), forM, replicateM, join, unless)
2829import Control.Monad.Except (throwError)
2930import Control.Monad.Error.Class (MonadError)
3031import Control.Monad.Supply.Class
@@ -120,31 +121,41 @@ toTuple _ = error "Not a value declaration"
120121makeCaseDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
121122makeCaseDeclaration ident alternatives = do
122123 let namedArgs = map findName . fst <$> alternatives
123− args <- mapM argName $ foldl1 resolveNames namedArgs
124− let
125− vars = map (Var . Qualified Nothing) args
126− binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
127− value = foldr (Abs . Left) (Case vars binders) args
124+ argNames = map join $ foldl1 resolveNames namedArgs
125+ args <- if allUnique (catMaybes argNames)
126+ then mapM argName argNames
127+ else replicateM (length argNames) (Ident <$> freshName)
128+ let vars = map (Var . Qualified Nothing) args
129+ binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
130+ value = foldr (Abs . Left) (Case vars binders) args
128131 return $ ValueDeclaration ident Value [] (Right value)
129132 where
130− findName :: Binder -> Maybe Ident
131− findName (VarBinder name) = Just name
133+ findName :: Binder -> Maybe (Maybe Ident)
134+ findName NullBinder = Just Nothing
135+ findName (VarBinder name) = Just (Just name)
132136 findName (PositionedBinder _ _ binder) = findName binder
133137 findName _ = Nothing
134138
139+ allUnique :: (Eq a) => [a] -> Bool
140+ allUnique xs = length xs == length (nub xs)
141+
135142 argName :: (MonadSupply m) => Maybe Ident -> m Ident
136143 argName (Just name) = return name
137− argName Nothing = do
144+ argName _ = do
138145 name <- freshName
139146 return (Ident name)
140147
141− resolveNames :: [Maybe Ident] -> [Maybe Ident] -> [Maybe Ident]
148+ resolveNames :: [Maybe (Maybe Ident)] ->
149+ [Maybe (Maybe Ident)] ->
150+ [Maybe (Maybe Ident)]
142151 resolveNames = zipWith resolveName
143152
144− resolveName :: Maybe Ident -> Maybe Ident -> Maybe Ident
145− resolveName (Just a) (Just b)
146− | a == b = Just a
153+ resolveName :: Maybe (Maybe Ident) ->
154+ Maybe (Maybe Ident) ->
155+ Maybe (Maybe Ident)
156+ resolveName (Just (Just a)) (Just (Just b))
157+ | a == b = Just (Just a)
147158 | otherwise = Nothing
148− resolveName Nothing Nothing = Nothing
149− resolveName (Just a) Nothing = Just a
150− resolveName Nothing (Just b) = Just b
159+ resolveName (Just Nothing) a = a
160+ resolveName a (Just Nothing) = a
161+ resolveName _ _ = Nothing