eded2bd · rowtype-yoga/purescript-native

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

on golang help sign in

Write everythingM by hand.

eded2bdPhil Freeman13 years ago

src/Language/PureScript/Declarations.hs+51

compare with golang

unifiedsplit

@@ -517,6 +517,7 @@ everywhereOnValues f g h = (f', g', h')

517 handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)

518 handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)

519

520+

520everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>

521everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>

521 (Declaration -> m Declaration) ->

522 (Declaration -> m Declaration) ->

522 (Value -> m Value) ->

523 (Value -> m Value) ->

@@ -566,6 +567,55 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

566 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds

567 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds

567 handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e

568 handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e

568

569

570+everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>

571+ (Declaration -> m Declaration) ->

572+ (Value -> m Value) ->

573+ (Binder -> m Binder) ->

574+ (Declaration -> m Declaration, Value -> m Value, Binder -> m Binder)

575+everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)

576+ where

577+ f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f

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

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

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

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

582+ f' (PositionedDeclaration pos d) = (PositionedDeclaration pos <$> f' d) >>= f

583+ f' other = f other

584+

585+ g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g

586+ g' (BinaryNoParens op v1 v2) = (BinaryNoParens op <$> (g' v1) <*> (g' v2)) >>= g

587+ g' (Parens v) = (Parens <$> g' v) >>= g

588+ g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g

589+ g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g

590+ g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g

591+ g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g

592+ g' (Abs name v) = (Abs name <$> g' v) >>= g

593+ g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g

594+ g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g

595+ g' (Case vs alts) = (Case <$> mapM g' vs <*> mapM handleCaseAlternative alts) >>= g

596+ g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g

597+ g' (Let ds v) = (Let <$> mapM f' ds <*> g' v) >>= g

598+ g' (Do es) = (Do <$> mapM handleDoNotationElement es) >>= g

599+ g' (PositionedValue pos v) = (PositionedValue pos <$> g' v) >>= g

600+ g' other = g other

601+

602+ h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM h' bs

603+ h' (ObjectBinder bs) = (ObjectBinder <$> mapM (sndM h') bs) >>= h

604+ h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h

605+ h' (ConsBinder b1 b2) = (ConsBinder <$> h' b1 <*> h' b2) >>= h

606+ h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h

607+ h' (PositionedBinder pos b) = (PositionedBinder pos <$> h' b) >>= h

608+ h' other = h other

609+

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

611+ <*> maybeM g' grd

612+ <*> g' val

613+

614+ handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v

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

616+ handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM f' ds

617+ handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e

618+

569everythingOnValues :: (r -> r -> r) ->

619everythingOnValues :: (r -> r -> r) ->

570 (Declaration -> r) ->

620 (Declaration -> r) ->

571 (Value -> r) ->

621 (Value -> r) ->

@@ -636,3 +686,4 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con

636 forValues _ = mempty

686 forValues _ = mempty

637

687

638

688

689+

src/Language/PureScript/Sugar/DoNotation.hs+6−3

@@ -18,8 +18,6 @@ module Language.PureScript.Sugar.DoNotation (

18 desugarDoModule

19) where

21−import Data.Generics

22−

23import Language.PureScript.Names

21import Language.PureScript.Names

24import Language.PureScript.Scope

22import Language.PureScript.Scope

25import Language.PureScript.Declarations

23import Language.PureScript.Declarations

@@ -37,15 +35,20 @@ desugarDoModule :: Module -> Either ErrorStack Module

37desugarDoModule (Module mn ds exts) = Module mn <$> mapM desugarDo ds <*> pure exts

35desugarDoModule (Module mn ds exts) = Module mn <$> mapM desugarDo ds <*> pure exts

39desugarDo :: Declaration -> Either ErrorStack Declaration

37desugarDo :: Declaration -> Either ErrorStack Declaration

40−desugarDo = everywhereM (mkM replace)

38+desugarDo =

39+ let (f, _, _) = everywhereOnValuesM return replace return

40+ in f

41 where

42 prelude :: ModuleName

43 prelude = ModuleName [ProperName C.prelude]

44+

44 bind :: Value

45 bind :: Value

45 bind = Var (Qualified (Just prelude) (Op (C.>>=)))

46 bind = Var (Qualified (Just prelude) (Op (C.>>=)))

47+

46 replace :: Value -> Either ErrorStack Value

48 replace :: Value -> Either ErrorStack Value

47 replace (Do els) = go els

49 replace (Do els) = go els

48 replace other = return other

50 replace other = return other

51+

49 go :: [DoNotationElement] -> Either ErrorStack Value

52 go :: [DoNotationElement] -> Either ErrorStack Value

50 go [] = error "The impossible happened in desugarDo"

53 go [] = error "The impossible happened in desugarDo"

51 go [DoNotationValue val] = return val

54 go [DoNotationValue val] = return val