beaef52 · rowtype-yoga/purescript-native

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

on golang help sign in

Write everythingM' by hand.

beaef52Phil Freeman13 years ago

purescript.cabal+1

compare with golang

unifiedsplit

@@ -37,6 +37,7 @@ library

37 Language.PureScript.Names

38 Language.PureScript.Types

39 Language.PureScript.Scope

40+ Language.PureScript.Traversals

40 Language.PureScript.TypeClassDictionaries

41 Language.PureScript.TypeClassDictionaries

41 Language.PureScript.DeadCodeElimination

42 Language.PureScript.DeadCodeElimination

42 Language.PureScript.Sugar

43 Language.PureScript.Sugar

src/Data/Generics/Extras.hs−8

@@ -19,14 +19,6 @@ module Data.Generics.Extras where

20import Data.Data

22−-- |

23−-- Apply a top-down monadic transformation everywhere

24−--

25−everywhereM' :: (Monad m, Data d) => (forall d1. (Data d1) => d1 -> m d1) -> d -> m d

26−everywhereM' f x = do

27− y <- f x

28− gmapM (everywhereM' f) y

29−

30-- |

22-- |

31-- Apply a top-down transformation, mutating a state when descending from parents to children

23-- Apply a top-down transformation, mutating a state when descending from parents to children

32--

24--

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

@@ -18,14 +18,18 @@ module Language.PureScript.Declarations where

19import Data.Monoid (Monoid(..), mconcat)

21+import qualified Data.Data as D

22+

23+import Control.Applicative

24+import Control.Monad

25+

21import Language.PureScript.Types

26import Language.PureScript.Types

22import Language.PureScript.Names

27import Language.PureScript.Names

23import Language.PureScript.Kinds

28import Language.PureScript.Kinds

24import Language.PureScript.TypeClassDictionaries

29import Language.PureScript.TypeClassDictionaries

25import Language.PureScript.CodeGen.JS.AST

30import Language.PureScript.CodeGen.JS.AST

26import Language.PureScript.Environment

31import Language.PureScript.Environment

27−

32+import Language.PureScript.Traversals

28−import qualified Data.Data as D

30-- |

34-- |

31-- A precedence level for an infix operator

35-- A precedence level for an infix operator

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

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

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

514 handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)

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

515

519

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

521+ (Declaration -> m Declaration) ->

522+ (Value -> m Value) ->

523+ (Binder -> m Binder) ->

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

525+everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

526+ where

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

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

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

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

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

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

533+ f' other = f other

534+

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

550+ g' other = g other

551+

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

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

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

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

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

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

558+ h' other = h other

559+

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

561+ <*> maybeM (g' <=< g) grd

562+ <*> (g' <=< g) val

563+

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

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

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

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

568+

516everythingOnValues :: (r -> r -> r) ->

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

517 (Declaration -> r) ->

570 (Declaration -> r) ->

518 (Value -> r) ->

571 (Value -> r) ->

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

@@ -22,8 +22,6 @@ module Language.PureScript.Sugar.BindingGroups (

22) where

24import Data.Graph

25−import Data.Generics (mkM)

26−import Data.Generics.Extras

27import Data.List (nub, intersect)

25import Data.List (nub, intersect)

28import Data.Maybe (isJust, mapMaybe)

26import Data.Maybe (isJust, mapMaybe)

29import Control.Applicative ((<$>), (<*>), pure)

27import Control.Applicative ((<$>), (<*>), pure)

@@ -69,7 +67,9 @@ createBindingGroups moduleName ds = do

69 bindingGroupDecls

67 bindingGroupDecls

71createBindingGroupsForValue :: ModuleName -> Declaration -> Either ErrorStack Declaration

69createBindingGroupsForValue :: ModuleName -> Declaration -> Either ErrorStack Declaration

72−createBindingGroupsForValue moduleName = everywhereM' (mkM go)

70+createBindingGroupsForValue moduleName =

71+ let (f, _, _) = everywhereOnValuesTopDownM return go return

72+ in f

73 where

74 go (Let ds val) = Let <$> createBindingGroups moduleName ds <*> pure val

75 go other = return other

src/Language/PureScript/Sugar/CaseDeclarations.hs+3−4

@@ -21,8 +21,6 @@ module Language.PureScript.Sugar.CaseDeclarations (

22import Data.Monoid ((<>))

23import Data.List (groupBy)

24−import Data.Generics (mkM)

25−import Data.Generics.Extras

27import Control.Applicative

25import Control.Applicative

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

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

@@ -64,8 +62,9 @@ desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup

64 desugarRest :: [Declaration] -> Either ErrorStack [Declaration]

62 desugarRest :: [Declaration] -> Either ErrorStack [Declaration]

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

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

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

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

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

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

68− (:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarRest rest

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

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

69 where

68 where

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

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

71 go other = return other

70 go other = return other

src/Language/PureScript/Sugar/Operators.hs+3−4

@@ -37,9 +37,6 @@ import Data.Function (on)

37import Data.Functor.Identity

38import Data.List (groupBy, sortBy)

40−import qualified Data.Generics as G

41−import qualified Data.Generics.Extras as G

42−

43import qualified Text.Parsec as P

40import qualified Text.Parsec as P

44import qualified Text.Parsec.Pos as P

41import qualified Text.Parsec.Pos as P

45import qualified Text.Parsec.Expr as P

42import qualified Text.Parsec.Expr as P

@@ -67,7 +64,9 @@ removeSignedLiterals (Module mn ds exts) = Module mn (map f' ds) exts

67 go other = other

64 go other = other

69rebracketModule :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Module -> Either ErrorStack Module

66rebracketModule :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Module -> Either ErrorStack Module

70−rebracketModule opTable (Module mn ds exts) = Module mn <$> (map removeParens <$> G.everywhereM' (G.mkM (matchOperators opTable)) ds) <*> pure exts

67+rebracketModule opTable (Module mn ds exts) =

68+ let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return

69+ in Module mn <$> (map removeParens <$> mapM f ds) <*> pure exts

72removeParens :: Declaration -> Declaration

71removeParens :: Declaration -> Declaration

73removeParens =

72removeParens =

src/Language/PureScript/Sugar/TypeDeclarations.hs+2−3

@@ -19,8 +19,6 @@ module Language.PureScript.Sugar.TypeDeclarations (

19 desugarTypeDeclarationsModule

20) where

22−import Data.Generics (mkM)

23−import Data.Generics.Extras

24import Data.Monoid ((<>))

22import Data.Monoid ((<>))

26import Control.Applicative

24import Control.Applicative

@@ -59,7 +57,8 @@ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

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

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

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

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

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

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

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

62− (:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarTypeDeclarations rest

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

63 where

62 where

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

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

65 go other = return other

64 go other = return other

src/Language/PureScript/Traversals.hsnew file+27

@@ -0,0 +1,27 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Traversals

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | Common functions for implementing generic traversals

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.Traversals where

16+

17+import Control.Applicative

18+

19+fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b)

20+fstM f (a, b) = flip (,) b <$> f a

21+

22+sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c)

23+sndM f (a, b) = (,) a <$> f b

24+

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

26+maybeM _ Nothing = pure Nothing

27+maybeM f (Just a) = Just <$> f a

src/Language/PureScript/TypeChecker/Types.hs+4−3

@@ -47,8 +47,7 @@ import Data.Function (on)

47import Data.Ord (comparing)

48import Data.Monoid

49import Data.Generics

50− (everythingWithContext, mkM, mkQ)

50+ (everythingWithContext, mkQ)

51−import Data.Generics.Extras

53import Language.PureScript.Declarations

52import Language.PureScript.Declarations

54import Language.PureScript.Types

53import Language.PureScript.Types

@@ -273,7 +272,9 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'

273-- Replace type class dictionary placeholders with inferred type class dictionaries

272-- Replace type class dictionary placeholders with inferred type class dictionaries

274--

273--

275replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value

274replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value

276−replaceTypeClassDictionaries mn = everywhereM' (mkM go)

275+replaceTypeClassDictionaries mn =

276+ let (_, f, _) = everywhereOnValuesTopDownM return go return

277+ in f

277 where

278 where

278 go (TypeClassDictionary trySuperclasses constraint dicts) = do

279 go (TypeClassDictionary trySuperclasses constraint dicts) = do

279 env <- getEnv

280 env <- getEnv

src/Language/PureScript/Types.hs+1−3

@@ -26,6 +26,7 @@ import Control.Applicative

26import Control.Monad ((<=<))

28import Language.PureScript.Names

29+import Language.PureScript.Traversals

30-- |

31-- |

31-- An identifier for the scope of a skolem variable

32-- An identifier for the scope of a skolem variable

@@ -232,9 +233,6 @@ everywhereOnTypesTopDown f = go . f

232 go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))

233 go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))

233 go other = f other

234 go other = f other

234

235

235−sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c)

236−sndM f (a, b) = (,) a <$> f b

237−

238everywhereOnTypesM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type

236everywhereOnTypesM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type

239everywhereOnTypesM f = go

237everywhereOnTypesM f = go

240 where

238 where