beaef52 · rowtype-yoga/purescript-native

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

Write everythingM' by hand.

commitbeaef52dad0fce895e66accba9580b76c1b9abf1 authorPhil Freeman <paf31@cantab.net> dateTue 15 Apr 2014, 19:45 (13 years ago) parent5c2aa36

10 files changed+99−30

compare with golang

unifiedsplit

purescript.cabal+1 src/Data/Generics/Extras.hs−8 src/Language/PureScript/Declarations.hs+55−2 src/Language/PureScript/Sugar/BindingGroups.hs+3−3 src/Language/PureScript/Sugar/CaseDeclarations.hs+3−4 src/Language/PureScript/Sugar/Operators.hs+3−4 src/Language/PureScript/Sugar/TypeDeclarations.hs+2−3 src/Language/PureScript/Traversals.hs+27 src/Language/PureScript/TypeChecker/Types.hs+4−3 src/Language/PureScript/Types.hs+1−3

purescript.cabal+1

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

3737 Language.PureScript.Names

3838 Language.PureScript.Types

3939 Language.PureScript.Scope

40+ Language.PureScript.Traversals

4041 Language.PureScript.TypeClassDictionaries

4142 Language.PureScript.DeadCodeElimination

4243 Language.PureScript.Sugar

src/Data/Generics/Extras.hs−8

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

1919

2020import Data.Data

2121

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−

3022-- |

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

3224--

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

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

1818

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

2020

21+import qualified Data.Data as D

22+

23+import Control.Applicative

24+import Control.Monad

25+

2126import Language.PureScript.Types

2227import Language.PureScript.Names

2328import Language.PureScript.Kinds

2429import Language.PureScript.TypeClassDictionaries

2530import Language.PureScript.CodeGen.JS.AST

2631import Language.PureScript.Environment

27−

28−import qualified Data.Data as D

32+import Language.PureScript.Traversals

2933

3034-- |

3135-- A precedence level for an infix operator

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

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

514518 handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)

515519

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+

516569everythingOnValues :: (r -> r -> r) ->

517570 (Declaration -> r) ->

518571 (Value -> r) ->

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

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

2222) where

2323

2424import Data.Graph

25−import Data.Generics (mkM)

26−import Data.Generics.Extras

2725import Data.List (nub, intersect)

2826import Data.Maybe (isJust, mapMaybe)

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

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

6967 bindingGroupDecls

7068

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

72−createBindingGroupsForValue moduleName = everywhereM' (mkM go)

70+createBindingGroupsForValue moduleName =

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

72+ in f

7373 where

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

7575 go other = return other

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

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

2121

2222import Data.Monoid ((<>))

2323import Data.List (groupBy)

24−import Data.Generics (mkM)

25−import Data.Generics.Extras

2624

2725import Control.Applicative

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

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

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

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

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

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

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

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

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

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

6968 where

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

7170 go other = return other

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

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

3737import Data.Functor.Identity

3838import Data.List (groupBy, sortBy)

3939

40−import qualified Data.Generics as G

41−import qualified Data.Generics.Extras as G

42−

4340import qualified Text.Parsec as P

4441import qualified Text.Parsec.Pos as P

4542import qualified Text.Parsec.Expr as P

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

6764 go other = other

6865

6966rebracketModule :: [[(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

7170

7271removeParens :: Declaration -> Declaration

7372removeParens =

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

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

1919 desugarTypeDeclarationsModule

2020) where

2121

22−import Data.Generics (mkM)

23−import Data.Generics.Extras

2422import Data.Monoid ((<>))

2523

2624import Control.Applicative

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

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

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

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

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

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

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

6362 where

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

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

4747import Data.Ord (comparing)

4848import Data.Monoid

4949import Data.Generics

50− (everythingWithContext, mkM, mkQ)

51−import Data.Generics.Extras

50+ (everythingWithContext, mkQ)

5251

5352import Language.PureScript.Declarations

5453import Language.PureScript.Types

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

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

274273--

275274replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value

276−replaceTypeClassDictionaries mn = everywhereM' (mkM go)

275+replaceTypeClassDictionaries mn =

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

277+ in f

277278 where

278279 go (TypeClassDictionary trySuperclasses constraint dicts) = do

279280 env <- getEnv

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

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

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

2727

2828import Language.PureScript.Names

29+import Language.PureScript.Traversals

2930

3031-- |

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

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

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

233234 go other = f other

234235

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

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

237−

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

239237everywhereOnTypesM f = go

240238 where