@@ -21,10 +21,11 @@ module Language.PureScript.Sugar.CaseDeclarations (
21 desugarCasesModule
21 desugarCasesModule
24+import Data.Maybe (catMaybes)
24import Data.List (nub, groupBy)
25import Data.List (nub, groupBy)
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,53 @@ 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)
133+ -- We will construct a table of potential names.
134+ -- VarBinders will become Just (Just _) which is a potential name.
135+ -- NullBinder will become Just Nothing, which indicates that we may
136+ -- have to generate a name.
137+ -- Everything else becomes Nothing, which indicates that we definitely
138+ --have to generate a name.
130− findName :: Binder -> Maybe Ident
139+ findName :: Binder -> Maybe (Maybe Ident)
140+ findName NullBinder = Just Nothing
131− findName (VarBinder name) = Just name
141+ findName (VarBinder name) = Just (Just name)
132 findName (PositionedBinder _ _ binder) = findName binder
142 findName (PositionedBinder _ _ binder) = findName binder
133 findName _ = Nothing
143 findName _ = Nothing
145+ -- We still have to make sure the generated names are unique, or else
146+ -- we will end up constructing an invalid function.
147+ allUnique :: (Eq a) => [a] -> Bool
148+ allUnique xs = length xs == length (nub xs)
135 argName :: (MonadSupply m) => Maybe Ident -> m Ident
150 argName :: (MonadSupply m) => Maybe Ident -> m Ident
136 argName (Just name) = return name
151 argName (Just name) = return name
137− argName Nothing = do
152+ argName _ = do
138 name <- freshName
153 name <- freshName
139 return (Ident name)
154 return (Ident name)
156+ -- Combine two lists of potential names from two case alternatives
157+ -- by zipping correspoding columns.
141− resolveNames :: [Maybe Ident] -> [Maybe Ident] -> [Maybe Ident]
158+ resolveNames :: [Maybe (Maybe Ident)] ->
159+ [Maybe (Maybe Ident)] ->
160+ [Maybe (Maybe Ident)]
142 resolveNames = zipWith resolveName
161 resolveNames = zipWith resolveName
163+ -- Resolve a pair of names. VarBinder beats NullBinder, and everything
164+ -- else results in Nothing.
144− resolveName :: Maybe Ident -> Maybe Ident -> Maybe Ident
165+ resolveName :: Maybe (Maybe Ident) ->
166+ Maybe (Maybe Ident) ->
145− resolveName (Just a) (Just b)
168+ resolveName (Just (Just a)) (Just (Just b))
146− | a == b = Just a
169+ | a == b = Just (Just a)
147 | otherwise = Nothing
170 | otherwise = Nothing
148− resolveName Nothing Nothing = Nothing
171+ resolveName (Just Nothing) a = a
149− resolveName (Just a) Nothing = Just a
172+ resolveName a (Just Nothing) = a
150− resolveName Nothing (Just b) = Just b
173+ resolveName _ _ = Nothing