801dedb · rowtype-yoga/purescript-native

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

on golang help sign in

Support multiple guard clauses, fix #294.

801dedbPhil Freeman12 years ago

examples/passing/Guards.purs+5−1

compare with golang

unifiedsplit

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

11 z | y > 0 -> z / 2

12 z -> z * 3 + 1

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

15+ min n m | n < m = n

16+ | m <= n = m

17+

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

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

psci/Main.hs+4−4

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

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

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

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

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

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

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

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

196 where

197 isExported = any exports exts

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

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

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

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

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

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

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

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

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

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

267 in

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

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

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

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

94--

95declToJs :: (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

97 js <- valueToJs opts mp e val

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

99declToJs opts mp (BindingGroupDeclaration vals) e = do

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

280bindersToJs opts m e binders vals = do

281 valNames <- replicateM (length vals) freshName

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

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

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

284− ret <- valueToJs opts m e result

284+ ret <- guardsToJs result

285− go valNames [JSReturn ret] bs grd

285+ go valNames ret bs

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

287 []

288 where

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

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

290− go _ done [] Nothing = return done

290+ go _ done [] = 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

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

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

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

296 binderToJs m e v done'' b

293 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

298

302

299-- |

303-- |

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

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

46 filterExport _ _ = Nothing

48 valueExists :: Ident -> Declaration -> Bool

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

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

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

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

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

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

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

66 where

67 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)]

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

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

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

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

88 values _ = []

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

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

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

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

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

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

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

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

23import Control.Applicative

24import Control.Monad

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

26import Language.PureScript.Types

27import Language.PureScript.Types

27import Language.PureScript.Names

28import Language.PureScript.Names

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

154 -- |

155 -- |

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

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

156 --

157 --

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

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

158 -- |

159 -- |

159 -- A minimal mutually recursive set of value declarations

160 -- A minimal mutually recursive set of value declarations

160 --

161 --

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

379 --

380 --

380 caseAlternativeBinders :: [Binder]

381 caseAlternativeBinders :: [Binder]

381 -- |

382 -- |

382− -- An optional guard

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

383 --

384 --

384− , caseAlternativeGuard :: Maybe Guard

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

385− -- |

386− -- The result expression

387− --

388− , caseAlternativeResult :: Expr

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

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

390

387

391-- |

388-- |

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

492 where

489 where

493 f' :: Declaration -> Declaration

490 f' :: Declaration -> Declaration

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

491 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))

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

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

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

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

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

495 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')

530 handleCaseAlternative :: CaseAlternative -> CaseAlternative

527 handleCaseAlternative :: CaseAlternative -> CaseAlternative

531 handleCaseAlternative ca =

528 handleCaseAlternative ca =

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

529 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)

535 }

531 }

536

532

537 handleDoNotationElement :: DoNotationElement -> DoNotationElement

533 handleDoNotationElement :: DoNotationElement -> DoNotationElement

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

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

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

550 where

546 where

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

547 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

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

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

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

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

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

551 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)

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

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

583 h' other = h other

579 h' other = h other

584

580

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

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

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

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

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

588

583

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

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

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

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

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

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

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

600 where

595 where

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

596 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

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

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

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

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

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

600 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)

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

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

633 h' other = h other

628 h' other = h other

634

629

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

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

636− <*> maybeM g' grd

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

637− <*> g' val

638

632

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

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

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

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

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

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

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

652 where

646 where

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

647 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

648+ f' d@(ValueDeclaration _ _ bs (Right 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

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

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

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

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

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

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

652 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')

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

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

686 h' b = h b

680 h' b = h b

687

681

688− i' ca = case caseAlternativeGuard ca of

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

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

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

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

691

684

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

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

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

686 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'

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

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

714

707

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

708 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

709+ f' s (ValueDeclaration _ _ bs (Right 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

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

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

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

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

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

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

713 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'

753

746

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

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

755

748

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

749+ i' s (CaseAlternative bs (Right 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

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

758

751

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

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

760

753

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

780 f'' s = uncurry f' <=< f s

773 f'' s = uncurry f' <=< f s

781

774

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

775 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

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

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

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

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

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

779 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

819

812

820 i'' s = uncurry i' <=< i s

813 i'' s = uncurry i' <=< i s

821

814

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

823

816

824 j'' s = uncurry j' <=< j s

817 j'' s = uncurry j' <=< j s

825

818

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

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

82parseValueDeclaration = do

83 name <- parseIdent

84 binders <- P.many parseBinderNoParens

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

85− guard <- P.optionMaybe parseGuard

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

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

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

87− whereClause <- P.optionMaybe $ do

88+ )))

88− C.indented

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

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)

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

101

94parseExternDeclaration :: P.Parsec String ParseState Declaration

102parseExternDeclaration :: P.Parsec String ParseState Declaration

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

103parseExternDeclaration = 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

295

303

296parseCaseAlternative :: P.Parsec String ParseState CaseAlternative

304parseCaseAlternative :: P.Parsec String ParseState CaseAlternative

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

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

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

298− <*> P.optionMaybe parseGuard

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

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

309+ )))

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

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

300 P.<?> "case alternative"

311 P.<?> "case alternative"

301

312

302parseIfThenElse :: P.Parsec String ParseState Expr

313parseIfThenElse :: P.Parsec String ParseState Expr

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

464-- Parse a guard

475-- Parse a guard

465--

476--

466parseGuard :: P.Parsec String ParseState Guard

477parseGuard :: P.Parsec String ParseState Guard

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

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

468

479

469

480

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

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

87prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String

88prettyPrintDeclaration (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

90 [ return $ show ident ++ " = "

91 , prettyPrintValue' val

92 ]

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

94prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"

96prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String

97−prettyPrintCaseAlternative (CaseAlternative binders grd val) =

97+prettyPrintCaseAlternative (CaseAlternative binders result) =

98 fmap concat $ sequence

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

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

100+ , prettyPrintResult result

101− , return " -> "

102− , prettyPrintValue' val

103 ]

101 ]

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

104

114

105prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String

115prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String

106prettyPrintDoNotationElement (DoNotationValue val) =

116prettyPrintDoNotationElement (DoNotationValue val) =

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

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

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

104findDeclIdents = concatMap go

105 where

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

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

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

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

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

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

129-- another in the current scope.

130--

131renameInDecl :: Bool -> Declaration -> Rename Declaration

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

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

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

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

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

135renameInDecl isTopLevel (BindingGroupDeclaration ds) = do

136 ds' <- mapM updateNames ds

137 BindingGroupDeclaration <$> mapM updateValues ds'

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

187-- Renames within case alternatives.

188--

189renameInCaseAlternative :: CaseAlternative -> Rename CaseAlternative

190−renameInCaseAlternative (CaseAlternative bs g v) =

190+renameInCaseAlternative (CaseAlternative bs v) =

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

191+ CaseAlternative <$> mapM renameInBinder bs

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

192

193

193-- |

194-- |

194-- Renames within binders.

195-- Renames within binders.

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

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

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

85 where

86 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

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

89 go other = [other]

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

135 usedNames _ = []

136

137getIdent :: Declaration -> Ident

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

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

139getIdent (PositionedDeclaration _ d) = getIdent d

140getIdent _ = error "Expected ValueDeclaration"

141

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

176

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

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

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

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

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

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

182 cycleError _ _ = error "Expected ValueDeclaration"

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

197isTypeSynonym _ = Nothing

198

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

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

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

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

202fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d

203fromValueDecl _ = error "Expected ValueDeclaration"

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

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

19 desugarCasesModule

20) where

22−import Data.Maybe (isJust)

22+import Data.Either (isLeft)

23import Data.Monoid ((<>))

24import Data.List (nub, groupBy)

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

32import Language.PureScript.Environment

33import Language.PureScript.Errors

34import Language.PureScript.Supply

35+import Language.PureScript.Traversals

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

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

37-- |

38-- |

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

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

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

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

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

52 ident <- Ident <$> freshName

53 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)]

54 replace other = return other

55 replace other = return other

56-- |

57-- |

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

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

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

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

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

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

65 (:) <$> (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) =

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

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

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

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

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

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

68 where

71 where

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

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

70 go other = return other

73 go other = return other

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

75 desugarRest [] = pure []

78 desugarRest [] = pure []

77inSameGroup :: Declaration -> Declaration -> Bool

80inSameGroup :: Declaration -> Declaration -> Bool

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

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

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

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

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

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

81inSameGroup _ _ = False

84inSameGroup _ _ = False

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

86toDecls :: [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

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

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

86 body = foldr (Abs . Left) val args

89 body = foldr (Abs . Left) val args

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

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

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

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

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

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

90 let tuples = map toTuple ds

93 let tuples = map toTuple ds

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

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

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

95 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) $

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

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

95 caseDecl <- makeCaseDeclaration ident tuples

98 caseDecl <- makeCaseDeclaration ident tuples

96 return [caseDecl]

99 return [caseDecl]

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

103isVarBinder (VarBinder _) = True

106isVarBinder (VarBinder _) = True

104isVarBinder _ = False

107isVarBinder _ = False

105

108

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

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

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

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

108toTuple (PositionedDeclaration _ d) = toTuple d

111toTuple (PositionedDeclaration _ d) = toTuple d

109toTuple _ = error "Not a value declaration"

112toTuple _ = error "Not a value declaration"

110

113

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

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

112makeCaseDeclaration ident alternatives = do

115makeCaseDeclaration ident alternatives = do

113 let argPattern = length . fst . head $ alternatives

116 let argPattern = length . fst . head $ alternatives

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

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

115 let

118 let

116 vars = map (Var . Qualified Nothing) args

119 vars = map (Var . Qualified Nothing) args

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

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

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

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

119− return $ ValueDeclaration ident Value [] Nothing value

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

120

123

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

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

66 go (DoNotationBind binder val : rest) = do

67 rest' <- go rest

68 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')]))

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

71 go (DoNotationLet ds : rest) = do

72 rest' <- go rest

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

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

240 updateBinder s v = return (s, v)

241

242 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)

244

245 letBoundVariable :: Declaration -> Maybe Ident

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

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

247 letBoundVariable (PositionedDeclaration _ d) = letBoundVariable d

248 letBoundVariable _ = Nothing

249

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

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

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

324 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

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

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

328 addDecl _ env _ = return env

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

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

211

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

213typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

214− ValueDeclaration ident TypeClassAccessorImport [] Nothing $

214+ ValueDeclaration ident TypeClassAccessorImport [] $ Right $

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

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

217typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =

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

258 dictTy = foldl TypeApp (TypeConstructor className) tys

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

260 dict = TypeClassDictionaryConstructorApp className memberNames'

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

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

262 return result

263

264 where

265

266 declName :: Declaration -> Maybe Ident

267 declName (PositionedDeclaration _ d) = declName d

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

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

269 declName (TypeDeclaration ident _) = Just ident

270 declName _ = Nothing

271

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

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

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

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

275 let memberValue = typeInstanceDictionaryEntryValue d

276 return (ident, memberValue)

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

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

281

282 typeInstanceDictionaryEntryValue :: Declaration -> Expr

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

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

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

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

286

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

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

29import Language.PureScript.Names

30import Language.PureScript.Environment

31import Language.PureScript.Errors

32+import Language.PureScript.Traversals

33-- |

34-- |

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

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

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

47 return (PositionedDeclaration pos d' : ds')

48 return (PositionedDeclaration pos d' : ds')

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

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

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

50 (_, 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)

51 where

52 where

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

53 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)

54 fromValueDeclaration (PositionedDeclaration pos d') = do

55 fromValueDeclaration (PositionedDeclaration pos d') = do

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

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

56 return (ident, nameKind, PositionedValue pos val)

57 return (ident, nameKind, PositionedValue pos val)

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

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

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

59desugarTypeDeclarations (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

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

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

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

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

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

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

62 where

65 where

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

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

64 go other = return other

67 go other = return other

src/Language/PureScript/Traversals.hs+7

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

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

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

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+

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

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

29maybeM _ Nothing = pure Nothing

32maybeM _ Nothing = pure Nothing

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

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

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+

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

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

33defS s val = return (s, val)

40defS s val = return (s, val)

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

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

169 ds <- go rest

170 return $ TypeSynonymDeclaration name args ty : ds

171 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

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

174 valueIsNotDefined moduleName name

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

176 addValue moduleName name ty nameKind

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

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

178 ds <- go rest

179 return $ d : ds

180 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"

743

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

745inferLetBinding 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

747 Just moduleName <- checkCurrentModule <$> get

748 kind <- liftCheck $ kindOf moduleName ty

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

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

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

752 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

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 [] Nothing val : rest) ret j = do

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

755 valTy <- fresh

756 Just moduleName <- checkCurrentModule <$> get

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

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

759 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

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

762 Just moduleName <- checkCurrentModule <$> get

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

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

845--

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

847checkBinders _ _ [] = return []

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

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

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

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

851 Just moduleName <- checkCurrentModule <$> get

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

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

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

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

854+ CaseAlternative binders <$>

855− case grd of

855+ case result of

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

856+ Left gs -> do

857− Just g -> do

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

858− g' <- check g tyBoolean

858+ grd' <- check grd tyBoolean

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

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'

860 rs <- checkBinders nvals ret bs

865 rs <- checkBinders nvals ret bs

861 return $ r : rs

866 return $ r : rs

862

867