bcb8d32 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Match multiple expressions in case statements

bcb8d32Nathan Faubion11 years ago

examples/failing/CaseBinderLengthsDiffer.pursnew file+6

compare with golang

unifiedsplit

@@ -0,0 +1,6 @@

1+-- @shouldFailWith CaseBinderLengthDiffers

2+module Main where

4+test = case 1, 2 of

5+ 1, 2, 3 -> 42

6+ _, _ -> 43

examples/passing/CaseMultipleExpressions.pursnew file+19

@@ -0,0 +1,19 @@

1+module Main where

3+import Prelude

4+import Control.Monad.Eff.Console

5+import Control.Monad.Eff

7+doIt :: forall eff. Eff eff Boolean

8+doIt = return true

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+7

@@ -139,6 +139,7 @@ data SimpleErrorMessage

139 | IntOutOfRange Integer String Integer Integer

140 | RedundantEmptyHidingImport ModuleName

141 | ImplicitImport ModuleName [DeclarationRef]

142+ | CaseBinderLengthDiffers Int [Binder]

142 deriving (Show)

143 deriving (Show)

143

144

144-- | Error message hints, providing more detailed information about failure.

145-- | Error message hints, providing more detailed information about failure.

@@ -309,6 +310,7 @@ errorCode em = case unwrapErrorMessage em of

309 IntOutOfRange{} -> "IntOutOfRange"

310 IntOutOfRange{} -> "IntOutOfRange"

310 RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"

311 RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"

311 ImplicitImport{} -> "ImplicitImport"

312 ImplicitImport{} -> "ImplicitImport"

313+ CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

312

314

313-- |

315-- |

314-- A stack trace for an error

316-- A stack trace for an error

@@ -860,6 +862,11 @@ prettyPrintSingleError full level e = do

860 , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"

862 , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"

861 ]

863 ]

862

864

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+

863 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

870 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

864 renderHint (ErrorUnifyingTypes t1 t2) detail =

871 renderHint (ErrorUnifyingTypes t1 t2) detail =

865 paras [ detail

872 paras [ detail

src/Language/PureScript/Parser/Declarations.hs+2−2

@@ -349,11 +349,11 @@ parseConstructor :: TokenParser Expr

349parseConstructor = Constructor <$> C.parseQualified C.properName

350

351parseCase :: 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)

353 <*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative)))

354

355parseCaseAlternative :: TokenParser CaseAlternative

356−parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)

356+parseCaseAlternative = CaseAlternative <$> (commaSep1 parseBinder)

357 <*> (Left <$> (C.indented *>

358 P.many1 ((,) <$> parseGuard

359 <*> (indented *> rarrow *> parseValue)

src/Language/PureScript/Sugar/CaseDeclarations.hs+35−7

@@ -26,8 +26,8 @@ import Prelude ()

26import Prelude.Compat

28import Language.PureScript.Crash

29−import Data.Maybe (catMaybes)

29+import Data.Maybe (catMaybes, mapMaybe)

30−import Data.List (nub, groupBy)

30+import Data.List (nub, groupBy, foldl1')

32import Control.Monad ((<=<), forM, replicateM, join, unless)

33import Control.Monad.Error.Class (MonadError(..))

@@ -51,14 +51,42 @@ isLeft (Right _) = False

51desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]

52desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->

53 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

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+

56−desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

84+desugarAbs :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

57desugarAbs = flip parU f

85desugarAbs = flip parU f

58 where

86 where

59 (f, _, _) = everywhereOnValuesM return replace return

87 (f, _, _) = everywhereOnValuesM return replace return

61− replace :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Expr -> m Expr

89+ replace :: Expr -> m Expr

62 replace (Abs (Right binder) val) = do

90 replace (Abs (Right binder) val) = do

63 ident <- Ident <$> freshName

91 ident <- Ident <$> freshName

64 return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]

92 return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]

@@ -67,10 +95,10 @@ desugarAbs = flip parU f

67-- |

95-- |

68-- Replace all top-level binders with case expressions.

96-- Replace all top-level binders with case expressions.

69--

97--

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]

71desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup

99desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup

72 where

100 where

73− desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

101+ desugarRest :: [Declaration] -> m [Declaration]

74 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =

102 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =

75 (:) <$> (TypeInstanceDeclaration name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest

103 (:) <$> (TypeInstanceDeclaration name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest

76 desugarRest (ValueDeclaration name nameKind bs result : rest) =

104 desugarRest (ValueDeclaration name nameKind bs result : rest) =