Skip to content

Commit ab1b00d

Browse files
paf31paf31
committed
Merge pull request purescript#1696 from natefaubion/multi-case-expr
Match multiple expressions in case statements
2 parents e6a61b0 + bcb8d32 commit ab1b00d

5 files changed

Lines changed: 69 additions & 9 deletions

File tree

‎examples/failing/CaseBinderLengthsDiffer.purs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
-- @shouldFailWith CaseBinderLengthDiffers
2+
module Main where
3+
4+
test = case 1, 2 of
5+
1, 2, 3 -> 42
6+
_, _ -> 43

‎examples/passing/CaseMultipleExpressions.purs‎

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,19 @@
1+
module Main where
2+
3+
import Prelude
4+
import Control.Monad.Eff.Console
5+
import Control.Monad.Eff
6+
7+
doIt :: forall eff. Eff eff Boolean
8+
doIt = return true
9+
10+
set = do
11+
log "Testing..."
12+
case 42, 10 of
13+
42, 10 -> doIt
14+
_ , _ -> return false
15+
16+
main = do
17+
b <- set
18+
case b of
19+
true -> log "Done"

‎src/Language/PureScript/Errors.hs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -139,6 +139,7 @@ data SimpleErrorMessage
139139
| IntOutOfRange Integer String Integer Integer
140140
| RedundantEmptyHidingImport ModuleName
141141
| ImplicitImport ModuleName [DeclarationRef]
142+
| CaseBinderLengthDiffers Int [Binder]
142143
deriving (Show)
143144

144145
-- | Error message hints, providing more detailed information about failure.
@@ -309,6 +310,7 @@ errorCode em = case unwrapErrorMessage em of
309310
IntOutOfRange{} -> "IntOutOfRange"
310311
RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"
311312
ImplicitImport{} -> "ImplicitImport"
313+
CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"
312314

313315
-- |
314316
-- A stack trace for an error
@@ -860,6 +862,11 @@ prettyPrintSingleError full level e = do
860862
, indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"
861863
]
862864

865+
renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =
866+
paras $ [ line $ "Binder list length differs in case alternative:"
867+
, indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs
868+
, line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "." ]
869+
863870
renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
864871
renderHint (ErrorUnifyingTypes t1 t2) detail =
865872
paras [ detail

‎src/Language/PureScript/Parser/Declarations.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -349,11 +349,11 @@ parseConstructor :: TokenParser Expr
349349
parseConstructor = Constructor <$> C.parseQualified C.properName
350350

351351
parseCase :: TokenParser Expr
352-
parseCase = Case <$> P.between (P.try (reserved "case")) (C.indented *> reserved "of") (return <$> parseValue)
352+
parseCase = Case <$> P.between (P.try (reserved "case")) (C.indented *> reserved "of") (commaSep1 parseValue)
353353
<*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative)))
354354

355355
parseCaseAlternative :: TokenParser CaseAlternative
356-
parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)
356+
parseCaseAlternative = CaseAlternative <$> (commaSep1 parseBinder)
357357
<*> (Left <$> (C.indented *>
358358
P.many1 ((,) <$> parseGuard
359359
<*> (indented *> rarrow *> parseValue)

‎src/Language/PureScript/Sugar/CaseDeclarations.hs‎

Lines changed: 35 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -26,8 +26,8 @@ import Prelude ()
2626
import Prelude.Compat
2727

2828
import Language.PureScript.Crash
29-
import Data.Maybe (catMaybes)
30-
import Data.List (nub, groupBy)
29+
import Data.Maybe (catMaybes, mapMaybe)
30+
import Data.List (nub, groupBy, foldl1')
3131

3232
import Control.Monad ((<=<), forM, replicateM, join, unless)
3333
import Control.Monad.Error.Class (MonadError(..))
@@ -51,14 +51,42 @@ isLeft (Right _) = False
5151
desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
5252
desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->
5353
rethrow (addHint (ErrorInModule name)) $
54-
Module ss coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
54+
Module ss coms name <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) <*> pure exps
5555

56-
desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
56+
-- |
57+
-- Validates that case head and binder lengths match.
58+
--
59+
validateCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
60+
validateCases = flip parU f
61+
where
62+
(f, _, _) = everywhereOnValuesM return validate return
63+
64+
validate :: Expr -> m Expr
65+
validate c@(Case vs alts) = do
66+
let l = length vs
67+
alts' = filter ((l /=) . length . caseAlternativeBinders) alts
68+
unless (null alts') $
69+
throwError . MultipleErrors $ fmap (altError l) (caseAlternativeBinders <$> alts')
70+
return c
71+
validate other = return other
72+
73+
altError :: Int -> [Binder] -> ErrorMessage
74+
altError l bs = withPosition pos $ ErrorMessage [] $ CaseBinderLengthDiffers l bs
75+
where
76+
pos = foldl1' widenSpan (mapMaybe positionedBinder bs)
77+
78+
widenSpan (SourceSpan n start end) (SourceSpan _ start' end') =
79+
SourceSpan n (min start start') (max end end')
80+
81+
positionedBinder (PositionedBinder p _ _) = Just p
82+
positionedBinder _ = Nothing
83+
84+
desugarAbs :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
5785
desugarAbs = flip parU f
5886
where
5987
(f, _, _) = everywhereOnValuesM return replace return
6088

61-
replace :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Expr -> m Expr
89+
replace :: Expr -> m Expr
6290
replace (Abs (Right binder) val) = do
6391
ident <- Ident <$> freshName
6492
return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]
@@ -67,10 +95,10 @@ desugarAbs = flip parU f
6795
-- |
6896
-- Replace all top-level binders with case expressions.
6997
--
70-
desugarCases :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
98+
desugarCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
7199
desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup
72100
where
73-
desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
101+
desugarRest :: [Declaration] -> m [Declaration]
74102
desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
75103
(:) <$> (TypeInstanceDeclaration name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest
76104
desugarRest (ValueDeclaration name nameKind bs result : rest) =

0 commit comments

Comments
 (0)