@@ -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,53 @@ 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+ -- 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.
139+ findName :: Binder -> Maybe (Maybe Ident)
140+ findName NullBinder = Just Nothing
141+ findName (VarBinder name) = Just (Just name)
132142 findName (PositionedBinder _ _ binder) = findName binder
133143 findName _ = Nothing
134144
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)
149+
135150 argName :: (MonadSupply m) => Maybe Ident -> m Ident
136151 argName (Just name) = return name
137− argName Nothing = do
152+ argName _ = do
138153 name <- freshName
139154 return (Ident name)
140155
141− resolveNames :: [Maybe Ident] -> [Maybe Ident] -> [Maybe Ident]
156+ -- Combine two lists of potential names from two case alternatives
157+ -- by zipping correspoding columns.
158+ resolveNames :: [Maybe (Maybe Ident)] ->
159+ [Maybe (Maybe Ident)] ->
160+ [Maybe (Maybe Ident)]
142161 resolveNames = zipWith resolveName
143162
144− resolveName :: Maybe Ident -> Maybe Ident -> Maybe Ident
145− resolveName (Just a) (Just b)
146− | a == b = Just a
163+ -- Resolve a pair of names. VarBinder beats NullBinder, and everything
164+ -- else results in Nothing.
165+ resolveName :: Maybe (Maybe Ident) ->
166+ Maybe (Maybe Ident) ->
167+ Maybe (Maybe Ident)
168+ resolveName (Just (Just a)) (Just (Just b))
169+ | a == b = Just (Just a)
147170 | otherwise = Nothing
148− resolveName Nothing Nothing = Nothing
149− resolveName (Just a) Nothing = Just a
150− resolveName Nothing (Just b) = Just b
171+ resolveName (Just Nothing) a = a
172+ resolveName a (Just Nothing) = a
173+ resolveName _ _ = Nothing