801dedb · rowtype-yoga/purescript-native

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

Support multiple guard clauses, fix #294.

commit801dedb16977f55d113fc5471b33538212b9c7a9 authorPhil Freeman <paf31@cantab.net> dateFri 14 Nov 2014, 14:56 (12 years ago) parentf8578d1

17 files changed+156−115

compare with golang

unifiedsplit

examples/passing/Guards.purs+5−1

@@ -11,4 +11,8 @@ module Main where

1111 z | y > 0 -> z / 2

1212 z -> z * 3 + 1

1313

14− main = Debug.Trace.trace "Done"

14+ min :: forall a. (Ord a) => a -> a -> a

15+ min n m | n < m = n

16+ | m <= n = m

17+

18+ main = Debug.Trace.trace $ min "Done" "ZZZZ"

psci/Main.hs+4−4

@@ -191,8 +191,8 @@ completion = completeWord Nothing " \t\n\r" findCompletions

191191 let matches = filter (isPrefixOf str) (names ms)

192192 return $ sortBy sorter $ map simpleCompletion matches ++ files

193193 getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident

194− getDeclName Nothing (P.ValueDeclaration ident _ _ _ _) = Just ident

195− getDeclName (Just exts) (P.ValueDeclaration ident _ _ _ _) | isExported = Just ident

194+ getDeclName Nothing (P.ValueDeclaration ident _ _ _) = Just ident

195+ getDeclName (Just exts) (P.ValueDeclaration ident _ _ _) | isExported = Just ident

196196 where

197197 isExported = any exports exts

198198 exports (P.ValueRef ident') = ident == ident'

@@ -261,8 +261,8 @@ createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetB

261261 trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))

262262 itValue = foldl (\x f -> f x) value lets

263263 mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))

264− itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] Nothing itValue

265− mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] Nothing mainValue

264+ itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] $ Right itValue

265+ mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] $ Right mainValue

266266 decls = if exec then [itDecl, mainDecl] else [itDecl]

267267 in

268268 P.Module moduleName ((importDecl `map` imports) ++ decls) Nothing

src/Language/PureScript/CodeGen/JS.hs+16−12

@@ -93,7 +93,7 @@ imports other =

9393-- Generate code in the simplified Javascript intermediate representation for a declaration

9494--

9595declToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])

96−declToJs opts mp (ValueDeclaration ident _ _ _ val) e = do

96+declToJs opts mp (ValueDeclaration ident _ _ (Right val)) e = do

9797 js <- valueToJs opts mp e val

9898 return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]

9999declToJs opts mp (BindingGroupDeclaration vals) e = do

@@ -280,21 +280,25 @@ bindersToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName

280280bindersToJs opts m e binders vals = do

281281 valNames <- replicateM (length vals) freshName

282282 let assignments = zipWith JSVariableIntroduction valNames (map Just vals)

283− jss <- forM binders $ \(CaseAlternative bs grd result) -> do

284− ret <- valueToJs opts m e result

285− go valNames [JSReturn ret] bs grd

283+ jss <- forM binders $ \(CaseAlternative bs result) -> do

284+ ret <- guardsToJs result

285+ go valNames ret bs

286286 return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") $ [JSStringLiteral "Failed pattern match"]])))

287287 []

288288 where

289− go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> Maybe Guard -> SupplyT m [JS]

290− go _ done [] Nothing = return done

291− go _ done [] (Just cond) = do

292− cond' <- valueToJs opts m e cond

293− return [JSIfElse cond' (JSBlock done) Nothing]

294− go (v:vs) done' (b:bs) grd = do

295− done'' <- go vs done' bs grd

289+ go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> SupplyT m [JS]

290+ go _ done [] = return done

291+ go (v:vs) done' (b:bs) = do

292+ done'' <- go vs done' bs

296293 binderToJs m e v done'' b

297− go _ _ _ _ = error "Invalid arguments to bindersToJs"

294+ go _ _ _ = error "Invalid arguments to bindersToJs"

295+

296+ guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard, Expr)] Expr -> SupplyT m [JS]

297+ guardsToJs (Left gs) = forM gs $ \(cond, val) -> do

298+ cond' <- valueToJs opts m e cond

299+ done <- valueToJs opts m e val

300+ return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing

301+ guardsToJs (Right v) = return . JSReturn <$> valueToJs opts m e v

298302

299303-- |

300304-- Generate code in the simplified Javascript intermediate representation for a pattern match

src/Language/PureScript/DeadCodeElimination.hs+3−3

@@ -46,7 +46,7 @@ eliminateDeadCode entryPoints ms = map go ms

4646 filterExport _ _ = Nothing

4747

4848 valueExists :: Ident -> Declaration -> Bool

49− valueExists name (ValueDeclaration name' _ _ _ _) = name == name'

49+ valueExists name (ValueDeclaration name' _ _ _) = name == name'

5050 valueExists name (ExternDeclaration _ name' _ _) = name == name'

5151 valueExists name (BindingGroupDeclaration decls) = any (\(name', _, _) -> name == name') decls

5252 valueExists name (PositionedDeclaration _ d) = valueExists name d

@@ -65,7 +65,7 @@ declarationsByModule :: Module -> [(Key, [Key])]

6565declarationsByModule (Module moduleName ds _) = concatMap go ds

6666 where

6767 go :: Declaration -> [(Key, [Key])]

68− go d@(ValueDeclaration name _ _ _ _) = [((moduleName, Left name), dependencies moduleName d)]

68+ go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies moduleName d)]

6969 go (DataDeclaration _ _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors

7070 go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]

7171 go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'

@@ -88,7 +88,7 @@ dependencies moduleName =

8888 values _ = []

8989

9090isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool

91−isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _ _) =

91+isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _) =

9292 let Just v' = vertexFor (moduleName, Left name)

9393 in any (\v -> path graph v v') entryPointVertices

9494isUsed moduleName graph vertexFor entryPointVertices (FixityDeclaration _ name) =

src/Language/PureScript/Declarations.hs+22−29

@@ -22,6 +22,7 @@ import qualified Data.Data as D

2222

2323import Control.Applicative

2424import Control.Monad

25+import Control.Arrow ((***), (+++))

2526

2627import Language.PureScript.Types

2728import Language.PureScript.Names

@@ -154,7 +155,7 @@ data Declaration

154155 -- |

155156 -- A value declaration (name, top-level binders, optional guard, value)

156157 --

157− | ValueDeclaration Ident NameKind [Binder] (Maybe Guard) Expr

158+ | ValueDeclaration Ident NameKind [Binder] (Either [(Guard, Expr)] Expr)

158159 -- |

159160 -- A minimal mutually recursive set of value declarations

160161 --

@@ -379,13 +380,9 @@ data CaseAlternative = CaseAlternative

379380 --

380381 caseAlternativeBinders :: [Binder]

381382 -- |

382− -- An optional guard

383+ -- The result expression or a collect of guarded expressions

383384 --

384− , caseAlternativeGuard :: Maybe Guard

385− -- |

386− -- The result expression

387− --

388− , caseAlternativeResult :: Expr

385+ , caseAlternativeResult :: Either [(Guard, Expr)] Expr

389386 } deriving (Show, D.Data, D.Typeable)

390387

391388-- |

@@ -492,7 +489,7 @@ everywhereOnValues f g h = (f', g', h')

492489 where

493490 f' :: Declaration -> Declaration

494491 f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds))

495− f' (ValueDeclaration name nameKind bs grd val) = f (ValueDeclaration name nameKind (map h' bs) (fmap g' grd) (g' val))

492+ f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val))

496493 f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))

497494 f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))

498495 f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (map f' ds))

@@ -530,8 +527,7 @@ everywhereOnValues f g h = (f', g', h')

530527 handleCaseAlternative :: CaseAlternative -> CaseAlternative

531528 handleCaseAlternative ca =

532529 ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)

533− , caseAlternativeGuard = fmap g' (caseAlternativeGuard ca)

534− , caseAlternativeResult = g' (caseAlternativeResult ca)

530+ , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)

535531 }

536532

537533 handleDoNotationElement :: DoNotationElement -> DoNotationElement

@@ -549,7 +545,7 @@ everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>

549545everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

550546 where

551547 f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds

552− f' (ValueDeclaration name nameKind bs grd val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> maybeM (g' <=< g) grd <*> (g val >>= g')

548+ f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

553549 f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds

554550 f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds

555551 f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f' <=< f) ds

@@ -582,9 +578,8 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

582578 h' (PositionedBinder pos b) = PositionedBinder pos <$> (h b >>= h')

583579 h' other = h other

584580

585− handleCaseAlternative (CaseAlternative bs grd val) = CaseAlternative <$> mapM (h' <=< h) bs

586− <*> maybeM (g' <=< g) grd

587− <*> (g' <=< g) val

581+ handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM (h' <=< h) bs

582+ <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

588583

589584 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v

590585 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v

@@ -599,7 +594,7 @@ everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>

599594everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)

600595 where

601596 f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f

602− f' (ValueDeclaration name nameKind bs grd val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> maybeM g' grd <*> g' val) >>= f

597+ f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> eitherM (mapM (pairM g' g')) g' val) >>= f

603598 f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f

604599 f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f

605600 f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> mapM f' ds) >>= f

@@ -632,9 +627,8 @@ everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)

632627 h' (PositionedBinder pos b) = (PositionedBinder pos <$> h' b) >>= h

633628 h' other = h other

634629

635− handleCaseAlternative (CaseAlternative bs grd val) = CaseAlternative <$> mapM h' bs

636− <*> maybeM g' grd

637− <*> g' val

630+ handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM h' bs

631+ <*> eitherM (mapM (pairM g' g')) g' val

638632

639633 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v

640634 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v

@@ -651,8 +645,8 @@ everythingOnValues :: (r -> r -> r) ->

651645everythingOnValues (<>) f g h i j = (f', g', h', i', j')

652646 where

653647 f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)

654− f' d@(ValueDeclaration _ _ bs Nothing val) = foldl (<>) (f d) (map h' bs) <> g' val

655− f' d@(ValueDeclaration _ _ bs (Just grd) val) = foldl (<>) (f d) (map h' bs) <> g' grd <> g' val

648+ f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val

649+ f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

656650 f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)

657651 f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)

658652 f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)

@@ -685,9 +679,8 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

685679 h' b@(PositionedBinder _ b1) = h b <> h' b1

686680 h' b = h b

687681

688− i' ca = case caseAlternativeGuard ca of

689− Nothing -> foldl (<>) (i ca) (map h' (caseAlternativeBinders ca)) <> g' (caseAlternativeResult ca)

690− Just grd -> foldl (<>) (i ca) (map h' (caseAlternativeBinders ca)) <> g' grd <> g' (caseAlternativeResult ca)

682+ i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val

683+ i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

691684

692685 j' e@(DoNotationValue v) = j e <> g' v

693686 j' e@(DoNotationBind b v) = j e <> h' b <> g' v

@@ -713,8 +706,8 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

713706 f'' s d = let (s', r) = f s d in r <> f' s' d

714707

715708 f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)

716− f' s (ValueDeclaration _ _ bs Nothing val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) val

717− f' s (ValueDeclaration _ _ bs (Just grd) val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) grd <> (g'' s) val

709+ f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) val

710+ f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

718711 f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> (g'' s) val) ds)

719712 f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)

720713 f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)

@@ -753,8 +746,8 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

753746

754747 i'' s ca = let (s', r) = i s ca in r <> i' s' ca

755748

756− i' s (CaseAlternative bs Nothing val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) val

757− i' s (CaseAlternative bs (Just grd) val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) grd <> (g'' s) val

749+ i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val

750+ i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

758751

759752 j'' s e = let (s', r) = j s e in r <> j' s' e

760753

@@ -780,7 +773,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

780773 f'' s = uncurry f' <=< f s

781774

782775 f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f'' s) ds

783− f' s (ValueDeclaration name nameKind bs grd val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> maybeM (g'' s) grd <*> g'' s val

776+ f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val

784777 f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds

785778 f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds

786779 f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f'' s) ds

@@ -819,7 +812,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

819812

820813 i'' s = uncurry i' <=< i s

821814

822− i' s (CaseAlternative bs grd val) = CaseAlternative <$> mapM (h'' s) bs <*> maybeM (g'' s) grd <*> g'' s val

815+ i' s (CaseAlternative bs val) = CaseAlternative <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val

823816

824817 j'' s = uncurry j' <=< j s

825818

src/Language/PureScript/Parser/Declarations.hs+22−11

@@ -82,14 +82,22 @@ parseValueDeclaration :: P.Parsec String ParseState Declaration

8282parseValueDeclaration = do

8383 name <- parseIdent

8484 binders <- P.many parseBinderNoParens

85− guard <- P.optionMaybe parseGuard

86− value <- lexeme (indented *> P.char '=') *> parseValue

87− whereClause <- P.optionMaybe $ do

88− C.indented

89− reserved "where"

90− C.indented

91− C.mark $ P.many1 (C.same *> parseLocalDeclaration)

92− return $ ValueDeclaration name Value binders guard (maybe value (`Let` value) whereClause)

85+ value <- Left <$> (C.indented *>

86+ C.mark (P.many1 ((,) <$> (C.same *> parseGuard)

87+ <*> (lexeme (indented *> P.char '=') *> parseValueWithWhereClause)

88+ )))

89+ <|> Right <$> (lexeme (indented *> P.char '=') *> parseValueWithWhereClause)

90+ return $ ValueDeclaration name Value binders value

91+ where

92+ parseValueWithWhereClause :: P.Parsec String ParseState Expr

93+ parseValueWithWhereClause = do

94+ value <- parseValue

95+ whereClause <- P.optionMaybe $ do

96+ C.indented

97+ reserved "where"

98+ C.indented

99+ C.mark $ P.many1 (C.same *> parseLocalDeclaration)

100+ return $ maybe value (`Let` value) whereClause

93101

94102parseExternDeclaration :: P.Parsec String ParseState Declaration

95103parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>

@@ -295,8 +303,11 @@ parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.rese

295303

296304parseCaseAlternative :: P.Parsec String ParseState CaseAlternative

297305parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)

298− <*> P.optionMaybe parseGuard

299− <*> (C.indented *> C.reservedOp "->" *> parseValue)

306+ <*> (Left <$> (C.indented *>

307+ C.mark (P.many1 ((,) <$> (C.same *> parseGuard)

308+ <*> (lexeme (indented *> C.reservedOp "->") *> parseValue)

309+ )))

310+ <|> Right <$> (lexeme (indented *> C.reservedOp "->") *> parseValue))

300311 P.<?> "case alternative"

301312

302313parseIfThenElse :: P.Parsec String ParseState Expr

@@ -464,6 +475,6 @@ parseBinderNoParens = P.choice (map P.try

464475-- Parse a guard

465476--

466477parseGuard :: P.Parsec String ParseState Guard

467−parseGuard = C.indented *> C.pipe *> C.indented *> parseValue

478+parseGuard = C.pipe *> C.indented *> parseValue

468479

469480

src/Language/PureScript/Pretty/Values.hs+15−5

@@ -86,7 +86,7 @@ literals = mkPattern' match

8686

8787prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String

8888prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty

89−prettyPrintDeclaration (ValueDeclaration ident _ [] Nothing val) = fmap concat $ sequence

89+prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = fmap concat $ sequence

9090 [ return $ show ident ++ " = "

9191 , prettyPrintValue' val

9292 ]

@@ -94,13 +94,23 @@ prettyPrintDeclaration (PositionedDeclaration _ d) = prettyPrintDeclaration d

9494prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"

9595

9696prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String

97−prettyPrintCaseAlternative (CaseAlternative binders grd val) =

97+prettyPrintCaseAlternative (CaseAlternative binders result) =

9898 fmap concat $ sequence

9999 [ intercalate ", " <$> forM binders prettyPrintBinder'

100− , maybe (return "") (fmap ("| " ++) . prettyPrintValue') grd

101− , return " -> "

102− , prettyPrintValue' val

100+ , prettyPrintResult result

103101 ]

102+ where

103+ prettyPrintResult (Left gs) = concat <$> mapM prettyPrintGuardedValue gs

104+ prettyPrintResult (Right v) = (" -> " ++) <$> prettyPrintValue' v

105+

106+ prettyPrintGuardedValue (grd, val) =

107+ fmap concat $ sequence

108+ [ return "| "

109+ , prettyPrintValue' grd

110+ , return " -> "

111+ , prettyPrintValue' val

112+ , return "\n"

113+ ]

104114

105115prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String

106116prettyPrintDoNotationElement (DoNotationValue val) =

src/Language/PureScript/Renamer.hs+6−5

@@ -103,7 +103,7 @@ lookupIdent name = do

103103findDeclIdents :: [Declaration] -> [Ident]

104104findDeclIdents = concatMap go

105105 where

106− go (ValueDeclaration ident _ _ _ _) = [ident]

106+ go (ValueDeclaration ident _ _ _) = [ident]

107107 go (BindingGroupDeclaration ds) = map (\(name, _, _) -> name) ds

108108 go (ExternDeclaration _ ident _ _) = [ident]

109109 go (TypeClassDeclaration _ _ _ ds) = findDeclIdents ds

@@ -129,9 +129,9 @@ renameInModules = map go

129129-- another in the current scope.

130130--

131131renameInDecl :: Bool -> Declaration -> Rename Declaration

132−renameInDecl isTopLevel (ValueDeclaration name nameKind [] Nothing val) = do

132+renameInDecl isTopLevel (ValueDeclaration name nameKind [] (Right val)) = do

133133 name' <- if isTopLevel then return name else updateScope name

134− ValueDeclaration name' nameKind [] Nothing <$> renameInValue val

134+ ValueDeclaration name' nameKind [] . Right <$> renameInValue val

135135renameInDecl isTopLevel (BindingGroupDeclaration ds) = do

136136 ds' <- mapM updateNames ds

137137 BindingGroupDeclaration <$> mapM updateValues ds'

@@ -187,8 +187,9 @@ renameInValue v = return v

187187-- Renames within case alternatives.

188188--

189189renameInCaseAlternative :: CaseAlternative -> Rename CaseAlternative

190−renameInCaseAlternative (CaseAlternative bs g v) =

191− CaseAlternative <$> mapM renameInBinder bs <*> maybeM renameInValue g <*> renameInValue v

190+renameInCaseAlternative (CaseAlternative bs v) =

191+ CaseAlternative <$> mapM renameInBinder bs

192+ <*> eitherM (mapM (pairM renameInValue renameInValue)) renameInValue v

192193

193194-- |

194195-- Renames within binders.

src/Language/PureScript/Sugar/BindingGroups.hs+4−4

@@ -84,7 +84,7 @@ collapseBindingGroups :: [Declaration] -> [Declaration]

8484collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id in map f . concatMap go

8585 where

8686 go (DataBindingGroupDeclaration ds) = ds

87− go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] Nothing val) ds

87+ go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds

8888 go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d

8989 go other = [other]

9090

@@ -135,7 +135,7 @@ usedProperNames moduleName =

135135 usedNames _ = []

136136

137137getIdent :: Declaration -> Ident

138−getIdent (ValueDeclaration ident _ _ _ _) = ident

138+getIdent (ValueDeclaration ident _ _ _) = ident

139139getIdent (PositionedDeclaration _ d) = getIdent d

140140getIdent _ = error "Expected ValueDeclaration"

141141

@@ -176,7 +176,7 @@ toBindingGroup moduleName (CyclicSCC ds') =

176176

177177 cycleError :: Declaration -> [Declaration] -> Either ErrorStack a

178178 cycleError (PositionedDeclaration p d) ds = rethrowWithPosition p $ cycleError d ds

179− cycleError (ValueDeclaration n _ _ _ e) [] = Left $

179+ cycleError (ValueDeclaration n _ _ (Right e)) [] = Left $

180180 mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))

181181 cycleError d ds@(_:_) = rethrow (<> mkErrorStack ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing) $ cycleError d []

182182 cycleError _ _ = error "Expected ValueDeclaration"

@@ -197,7 +197,7 @@ isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d

197197isTypeSynonym _ = Nothing

198198

199199fromValueDecl :: Declaration -> (Ident, NameKind, Expr)

200−fromValueDecl (ValueDeclaration ident nameKind [] Nothing val) = (ident, nameKind, val)

200+fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val)

201201fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"

202202fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d

203203fromValueDecl _ = error "Expected ValueDeclaration"

src/Language/PureScript/Sugar/CaseDeclarations.hs+17−14

@@ -19,7 +19,7 @@ module Language.PureScript.Sugar.CaseDeclarations (

1919 desugarCasesModule

2020) where

2121

22−import Data.Maybe (isJust)

22+import Data.Either (isLeft)

2323import Data.Monoid ((<>))

2424import Data.List (nub, groupBy)

2525

@@ -32,6 +32,7 @@ import Language.PureScript.Declarations

3232import Language.PureScript.Environment

3333import Language.PureScript.Errors

3434import Language.PureScript.Supply

35+import Language.PureScript.Traversals

3536import Language.PureScript.TypeChecker.Monad (guardWith)

3637

3738-- |

@@ -50,7 +51,7 @@ desugarAbs = flip parU f

5051 replace :: Expr -> SupplyT (Either ErrorStack) Expr

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

5253 ident <- Ident <$> freshName

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

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

5455 replace other = return other

5556

5657-- |

@@ -62,9 +63,11 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro

6263 desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]

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

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

65− desugarRest (ValueDeclaration name nameKind bs g val : rest) =

66+ desugarRest (ValueDeclaration name nameKind bs result : rest) =

6667 let (_, f, _) = everywhereOnValuesTopDownM return go return

67− in (:) <$> (ValueDeclaration name nameKind bs g <$> f val) <*> desugarRest rest

68+ f' (Left gs) = Left <$> mapM (pairM return f) gs

69+ f' (Right v) = Right <$> f v

70+ in (:) <$> (ValueDeclaration name nameKind bs <$> f' result) <*> desugarRest rest

6871 where

6972 go (Let ds val') = Let <$> desugarCases ds <*> pure val'

7073 go other = return other

@@ -75,22 +78,22 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro

7578 desugarRest [] = pure []

7679

7780inSameGroup :: Declaration -> Declaration -> Bool

78−inSameGroup (ValueDeclaration ident1 _ _ _ _) (ValueDeclaration ident2 _ _ _ _) = ident1 == ident2

81+inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2

7982inSameGroup (PositionedDeclaration _ d1) d2 = inSameGroup d1 d2

8083inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2

8184inSameGroup _ _ = False

8285

8386toDecls :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]

84−toDecls [ValueDeclaration ident nameKind bs Nothing val] | all isVarBinder bs = do

87+toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do

8588 let args = map (\(VarBinder arg) -> arg) bs

8689 body = foldr (Abs . Left) val args

8790 guardWith (strMsg "Overlapping function argument names") $ length (nub args) == length args

88− return [ValueDeclaration ident nameKind [] Nothing body]

89−toDecls ds@(ValueDeclaration ident _ bs g _ : _) = do

91+ return [ValueDeclaration ident nameKind [] (Right body)]

92+toDecls ds@(ValueDeclaration ident _ bs result : _) = do

9093 let tuples = map toTuple ds

9194 unless (all ((== length bs) . length . fst) tuples) $

9295 throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing

93− unless (not (null bs) || isJust g) $

96+ unless (not (null bs) || isLeft result) $

9497 throwError $ mkErrorStack ("Duplicate value declaration '" ++ show ident ++ "'") Nothing

9598 caseDecl <- makeCaseDeclaration ident tuples

9699 return [caseDecl]

@@ -103,18 +106,18 @@ isVarBinder :: Binder -> Bool

103106isVarBinder (VarBinder _) = True

104107isVarBinder _ = False

105108

106−toTuple :: Declaration -> ([Binder], (Maybe Guard, Expr))

107−toTuple (ValueDeclaration _ _ bs g val) = (bs, (g, val))

109+toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr)

110+toTuple (ValueDeclaration _ _ bs result) = (bs, result)

108111toTuple (PositionedDeclaration _ d) = toTuple d

109112toTuple _ = error "Not a value declaration"

110113

111−makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Expr))] -> SupplyT (Either ErrorStack) Declaration

114+makeCaseDeclaration :: Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> SupplyT (Either ErrorStack) Declaration

112115makeCaseDeclaration ident alternatives = do

113116 let argPattern = length . fst . head $ alternatives

114117 args <- map Ident <$> replicateM argPattern freshName

115118 let

116119 vars = map (Var . Qualified Nothing) args

117− binders = [ CaseAlternative bs g val | (bs, (g, val)) <- alternatives ]

120+ binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]

118121 value = foldr (Abs . Left) (Case vars binders) args

119− return $ ValueDeclaration ident Value [] Nothing value

122+ return $ ValueDeclaration ident Value [] (Right value)

120123

src/Language/PureScript/Sugar/DoNotation.hs+1−1

@@ -66,7 +66,7 @@ desugarDo d =

6666 go (DoNotationBind binder val : rest) = do

6767 rest' <- go rest

6868 ident <- Ident <$> freshName

69− return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing rest']))

69+ return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))

7070 go [DoNotationLet _] = lift $ Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing

7171 go (DoNotationLet ds : rest) = do

7272 rest' <- go rest

src/Language/PureScript/Sugar/Names.hs+3−3

@@ -240,10 +240,10 @@ renameInModule imports exports (Module mn decls exps) =

240240 updateBinder s v = return (s, v)

241241

242242 updateCase :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)

243− updateCase (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, concatMap binderNames bs ++ bound), c)

243+ updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c)

244244

245245 letBoundVariable :: Declaration -> Maybe Ident

246− letBoundVariable (ValueDeclaration ident _ _ _ _) = Just ident

246+ letBoundVariable (ValueDeclaration ident _ _ _) = Just ident

247247 letBoundVariable (PositionedDeclaration _ d) = letBoundVariable d

248248 letBoundVariable _ = Nothing

249249

@@ -322,7 +322,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri

322322 addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)

323323 addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []

324324 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []

325− addDecl mn env (ValueDeclaration name _ _ _ _) = addValue env mn name

325+ addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name

326326 addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name

327327 addDecl mn env (PositionedDeclaration _ d) = addDecl mn env d

328328 addDecl _ env _ = return env

src/Language/PureScript/Sugar/TypeClasses.hs+5−5

@@ -211,7 +211,7 @@ typeClassDictionaryDeclaration name args implies members =

211211

212212typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration

213213typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

214− ValueDeclaration ident TypeClassAccessorImport [] Nothing $

214+ ValueDeclaration ident TypeClassAccessorImport [] $ Right $

215215 TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $

216216 moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map (TypeVar . fst) args)] ty))

217217typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =

@@ -258,19 +258,19 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

258258 dictTy = foldl TypeApp (TypeConstructor className) tys

259259 constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)

260260 dict = TypeClassDictionaryConstructorApp className memberNames'

261− result = ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)

261+ result = ValueDeclaration name TypeInstanceDictionaryValue [] (Right (TypedValue True dict constrainedTy))

262262 return result

263263

264264 where

265265

266266 declName :: Declaration -> Maybe Ident

267267 declName (PositionedDeclaration _ d) = declName d

268− declName (ValueDeclaration ident _ _ _ _) = Just ident

268+ declName (ValueDeclaration ident _ _ _) = Just ident

269269 declName (TypeDeclaration ident _) = Just ident

270270 declName _ = Nothing

271271

272272 memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Expr)

273− memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do

273+ memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _) = do

274274 _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'

275275 let memberValue = typeInstanceDictionaryEntryValue d

276276 return (ident, memberValue)

@@ -280,7 +280,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

280280 memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"

281281

282282 typeInstanceDictionaryEntryValue :: Declaration -> Expr

283− typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val

283+ typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] (Right val)) = val

284284 typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)

285285 typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"

286286

src/Language/PureScript/Sugar/TypeDeclarations.hs+7−4

@@ -29,6 +29,7 @@ import Language.PureScript.Declarations

2929import Language.PureScript.Names

3030import Language.PureScript.Environment

3131import Language.PureScript.Errors

32+import Language.PureScript.Traversals

3233

3334-- |

3435-- Replace all top level type declarations in a module with type annotations

@@ -47,18 +48,20 @@ desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do

4748 return (PositionedDeclaration pos d' : ds')

4849desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

4950 (_, nameKind, val) <- fromValueDeclaration d

50− desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue True val ty) : rest)

51+ desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)

5152 where

5253 fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Expr)

53− fromValueDeclaration (ValueDeclaration name' nameKind [] Nothing val) | name == name' = return (name', nameKind, val)

54+ fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)

5455 fromValueDeclaration (PositionedDeclaration pos d') = do

5556 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'

5657 return (ident, nameKind, PositionedValue pos val)

5758 fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing

5859desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing

59−desugarTypeDeclarations (ValueDeclaration name nameKind bs g val : rest) = do

60+desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do

6061 let (_, f, _) = everywhereOnValuesTopDownM return go return

61− (:) <$> (ValueDeclaration name nameKind bs g <$> f val) <*> desugarTypeDeclarations rest

62+ f' (Left gs) = Left <$> mapM (pairM return f) gs

63+ f' (Right v) = Right <$> f v

64+ (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest

6265 where

6366 go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'

6467 go other = return other

src/Language/PureScript/Traversals.hs+7

@@ -25,10 +25,17 @@ sndM f (a, b) = (,) a <$> f b

2525thirdM :: (Functor f) => (c -> f d) -> (a, b, c) -> f (a, b, d)

2626thirdM f (a, b, c) = (,,) a b <$> f c

2727

28+pairM :: (Applicative f) => (a -> f c) -> (b -> f d) -> (a, b) -> f (c, d)

29+pairM f g (a, b) = (,) <$> f a <*> g b

30+

2831maybeM :: (Applicative f) => (a -> f b) -> Maybe a -> f (Maybe b)

2932maybeM _ Nothing = pure Nothing

3033maybeM f (Just a) = Just <$> f a

3134

35+eitherM :: (Applicative f) => (a -> f c) -> (b -> f d) -> Either a b -> f (Either c d)

36+eitherM f _ (Left a) = Left <$> f a

37+eitherM _ g (Right b) = Right <$> g b

38+

3239defS :: (Monad m) => st -> val -> m (st, val)

3340defS s val = return (s, val)

3441

src/Language/PureScript/TypeChecker.hs+2−2

@@ -169,12 +169,12 @@ typeCheckAll mainModuleName moduleName exps = go

169169 ds <- go rest

170170 return $ TypeSynonymDeclaration name args ty : ds

171171 go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

172− go (ValueDeclaration name nameKind [] Nothing val : rest) = do

172+ go (ValueDeclaration name nameKind [] (Right val) : rest) = do

173173 d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do

174174 valueIsNotDefined moduleName name

175175 [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]

176176 addValue moduleName name ty nameKind

177− return $ ValueDeclaration name nameKind [] Nothing val'

177+ return $ ValueDeclaration name nameKind [] $ Right val'

178178 ds <- go rest

179179 return $ d : ds

180180 go (ValueDeclaration{} : _) = error "Binders were not desugared"

src/Language/PureScript/TypeChecker/Types.hs+17−12

@@ -743,21 +743,21 @@ infer' _ = error "Invalid argument to infer"

743743

744744inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)

745745inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret)

746−inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing tv@(TypedValue checkType val ty) : rest) ret j = do

746+inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do

747747 Just moduleName <- checkCurrentModule <$> get

748748 kind <- liftCheck $ kindOf moduleName ty

749749 guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

750750 let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)

751751 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

752752 TypedValue _ val' ty'' <- if checkType then bindNames dict (check val ty') else return tv

753− bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing (TypedValue checkType val' ty'')]) rest ret j

754−inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing val : rest) ret j = do

753+ bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j

754+inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do

755755 valTy <- fresh

756756 Just moduleName <- checkCurrentModule <$> get

757757 let dict = M.singleton (moduleName, ident) (valTy, nameKind, Undefined)

758758 TypedValue _ val' valTy' <- bindNames dict $ infer val

759759 valTy =?= valTy'

760− bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j

760+ bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j

761761inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

762762 Just moduleName <- checkCurrentModule <$> get

763763 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)

@@ -845,18 +845,23 @@ inferBinder val (PositionedBinder pos binder) =

845845--

846846checkBinders :: [Type] -> Type -> [CaseAlternative] -> UnifyT Type Check [CaseAlternative]

847847checkBinders _ _ [] = return []

848−checkBinders nvals ret (CaseAlternative binders grd val : bs) = do

848+checkBinders nvals ret (CaseAlternative binders result : bs) = do

849849 guardWith (strMsg "Overlapping binders in case statement") $

850850 let ns = concatMap binderNames binders in length (nub ns) == length ns

851851 Just moduleName <- checkCurrentModule <$> get

852852 m1 <- M.unions <$> zipWithM inferBinder nvals binders

853− r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $ do

854− val' <- TypedValue True <$> check val ret <*> pure ret

855− case grd of

856− Nothing -> return $ CaseAlternative binders Nothing val'

857− Just g -> do

858− g' <- check g tyBoolean

859− return $ CaseAlternative binders (Just g') val'

853+ r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $

854+ CaseAlternative binders <$>

855+ case result of

856+ Left gs -> do

857+ gs' <- forM gs $ \(grd, val) -> do

858+ grd' <- check grd tyBoolean

859+ val' <- TypedValue True <$> check val ret <*> pure ret

860+ return (grd', val')

861+ return $ Left gs'

862+ Right val -> do

863+ val' <- TypedValue True <$> check val ret <*> pure ret

864+ return $ Right val'

860865 rs <- checkBinders nvals ret bs

861866 return $ r : rs

862867