bcb8d32 · rowtype-yoga/purescript-native

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

Match multiple expressions in case statements

commitbcb8d326a4be60a8d2829ae85f30ccb3641e8569 authorNathan Faubion <nathan@n-son.com> dateMon 7 Dec 2015, 20:14 (11 years ago) parente6a61b0

5 files changed+69−9

compare with golang

unifiedsplit

examples/failing/CaseBinderLengthsDiffer.purs+6 examples/passing/CaseMultipleExpressions.purs+19 src/Language/PureScript/Errors.hs+7 src/Language/PureScript/Parser/Declarations.hs+2−2 src/Language/PureScript/Sugar/CaseDeclarations.hs+35−7

examples/failing/CaseBinderLengthsDiffer.pursnew file+6

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

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

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

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

350350

351351parseCase :: 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

355355parseCaseAlternative :: 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+35−7

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

2626import Prelude.Compat

2727

2828import 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

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

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

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

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

5252desugarCasesModule 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]

5785desugarAbs = 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]

7199desugarCases = 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) =