54116df · rowtype-yoga/purescript-native

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

More work on replacing syb

commit54116df92f80b67793514077719184bac7626755 authorPhil Freeman <paf31@cantab.net> dateMon 14 Apr 2014, 20:32 (13 years ago) parent7d1bbfe

6 files changed+73−9

compare with golang

unifiedsplit

src/Language/PureScript/Declarations.hs+59 src/Language/PureScript/Sugar.hs+1−1 src/Language/PureScript/Sugar/BindingGroups.hs+1−1 src/Language/PureScript/Sugar/CaseDeclarations.hs+4−2 src/Language/PureScript/Sugar/Operators.hs+5−2 src/Language/PureScript/TypeChecker/Types.hs+3−3

src/Language/PureScript/Declarations.hs+59

@@ -447,3 +447,62 @@ binderNames = everything (++) (mkQ [] go)

447447 go (VarBinder ident) = [ident]

448448 go (NamedBinder ident _) = [ident]

449449 go _ = []

450+

451+--

452+-- Traversals

453+--

454+

455+everywhereOnValues :: (Declaration -> Declaration) ->

456+ (Value -> Value) ->

457+ (Binder -> Binder) ->

458+ (Declaration -> Declaration, Value -> Value, Binder -> Binder)

459+everywhereOnValues f g h = (f', g', h')

460+ where

461+ f' :: Declaration -> Declaration

462+ f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds))

463+ f' (ValueDeclaration name nameKind bs grd val) = f (ValueDeclaration name nameKind (map h' bs) (fmap g' grd) (g' val))

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

465+ f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))

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

467+ f' (PositionedDeclaration pos d) = f (PositionedDeclaration pos (f' d))

468+ f' other = f other

469+

470+ g' :: Value -> Value

471+ g' (UnaryMinus v) = g (UnaryMinus (g' v))

472+ g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2))

473+ g' (Parens v) = g (Parens (g' v))

474+ g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))

475+ g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))

476+ g' (Accessor prop v) = g (Accessor prop (g' v))

477+ g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))

478+ g' (Abs name v) = g (Abs name (g' v))

479+ g' (App v1 v2) = g (App (g' v1) (g' v2))

480+ g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))

481+ g' (Case vs alts) = g (Case (map g' vs) (map handleCaseAlternative alts))

482+ g' (TypedValue check v ty) = g (TypedValue check (g' v) ty)

483+ g' (Let ds v) = g (Let (map f' ds) (g' v))

484+ g' (Do es) = g (Do (map handleDoNotationElement es))

485+ g' (PositionedValue pos v) = g (PositionedValue pos (g' v))

486+ g' other = g other

487+

488+ h' :: Binder -> Binder

489+ h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))

490+ h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))

491+ h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))

492+ h' (ConsBinder b1 b2) = h (ConsBinder (h' b1) (h' b2))

493+ h' (NamedBinder name b) = h (NamedBinder name (h' b))

494+ h' (PositionedBinder pos b) = h (PositionedBinder pos (h' b))

495+ h' other = h other

496+

497+ handleCaseAlternative :: CaseAlternative -> CaseAlternative

498+ handleCaseAlternative ca =

499+ ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)

500+ , caseAlternativeGuard = fmap g' (caseAlternativeGuard ca)

501+ , caseAlternativeResult = g' (caseAlternativeResult ca)

502+ }

503+

504+ handleDoNotationElement :: DoNotationElement -> DoNotationElement

505+ handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v)

506+ handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v)

507+ handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)

508+ handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)

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

@@ -48,7 +48,7 @@ import Control.Category ((>>>))

4848-- * Qualify any unqualified names and types

4949--

5050desugar :: [Module] -> Either ErrorStack [Module]

51−desugar = removeSignedLiterals

51+desugar = map removeSignedLiterals

5252 >>> desugarDo

5353 >=> desugarCasesModule

5454 >=> desugarTypeDeclarationsModule

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

@@ -79,7 +79,7 @@ createBindingGroupsForValue moduleName = everywhereM' (mkM go)

7979-- Collapse all binding groups to individual declarations

8080--

8181collapseBindingGroups :: [Declaration] -> [Declaration]

82−collapseBindingGroups = everywhere (mkT collapseBindingGroupsForValue) . concatMap go

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

8383 where

8484 go (DataBindingGroupDeclaration ds) = ds

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

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

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

2121

2222import Data.Monoid ((<>))

2323import Data.List (groupBy)

24−import Data.Generics (mkM, mkT, everywhere)

24+import Data.Generics (mkM)

2525import Data.Generics.Extras

2626

2727import Control.Applicative

@@ -43,8 +43,10 @@ desugarCasesModule ms = forM ms $ \(Module name ds exps) ->

4343 Module name <$> (desugarCases . desugarAbs $ ds) <*> pure exps

4444

4545desugarAbs :: [Declaration] -> [Declaration]

46−desugarAbs = everywhere (mkT replace)

46+desugarAbs = map f

4747 where

48+ (f, _, _) = everywhereOnValues id replace id

49+

4850 replace (Abs (Right binder) val) =

4951 let

5052 ident = head $ unusedNames (binder, val)

src/Language/PureScript/Sugar/Operators.hs+5−2

@@ -57,9 +57,12 @@ rebracket ms = do

5757 let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities

5858 mapM (rebracketModule opTable) ms

5959

60−removeSignedLiterals :: (D.Data d) => d -> d

61−removeSignedLiterals = G.everywhere (G.mkT go)

60+

61+removeSignedLiterals :: Module -> Module

62+removeSignedLiterals (Module mn ds exts) = Module mn (map f' ds) exts

6263 where

64+ (f', _, _) = everywhereOnValues id go id

65+

6366 go (UnaryMinus (NumericLiteral (Left n))) = NumericLiteral (Left $ negate n)

6467 go (UnaryMinus (NumericLiteral (Right n))) = NumericLiteral (Right $ negate n)

6568 go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val

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

@@ -44,7 +44,7 @@ module Language.PureScript.TypeChecker.Types (

4444import Data.List

4545import Data.Maybe (maybeToList, isNothing, isJust, fromMaybe)

4646import Data.Generics

47− (everythingWithContext, mkM, mkT, something, everywhere, mkQ)

47+ (everythingWithContext, mkM, something, mkQ)

4848import Data.Generics.Extras

4949

5050import Language.PureScript.Declarations

@@ -251,7 +251,7 @@ isTyped (name, value) = (name, (value, Nothing))

251251-- Map a function over type annotations appearing inside a value

252252--

253253overTypes :: (Type -> Type) -> Value -> Value

254−overTypes f = everywhere (mkT g)

254+overTypes f = let (_, f', _) = everywhereOnValues id g id in f'

255255 where

256256 g :: Value -> Value

257257 g (TypedValue checkTy val t) = TypedValue checkTy val (f t)

@@ -811,7 +811,7 @@ skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope)

811811-- only example of scoped type variables.

812812--

813813skolemizeTypesInValue :: String -> Int -> SkolemScope -> Value -> Value

814−skolemizeTypesInValue ident sko scope = everywhere (mkT go)

814+skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id go id in f

815815 where

816816 go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)

817817 go other = other