54116df · rowtype-yoga/purescript-native

src/Language/PureScript/Declarations.hs+59

compare with golang

unifiedsplit

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

447 go (VarBinder ident) = [ident]

448 go (NamedBinder ident _) = [ident]

449 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 ((>>>))

48-- * Qualify any unqualified names and types

49--

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

51−desugar = removeSignedLiterals

51+desugar = map removeSignedLiterals

52 >>> desugarDo

53 >=> desugarCasesModule

54 >=> desugarTypeDeclarationsModule

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

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

79-- Collapse all binding groups to individual declarations

80--

81collapseBindingGroups :: [Declaration] -> [Declaration]

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

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

83 where

84 go (DataBindingGroupDeclaration ds) = ds

85 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 (

21

22import Data.Monoid ((<>))

23import Data.List (groupBy)

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

24+import Data.Generics (mkM)

25import Data.Generics.Extras

26

27import Control.Applicative

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

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

44

45desugarAbs :: [Declaration] -> [Declaration]

46−desugarAbs = everywhere (mkT replace)

46+desugarAbs = map f

47 where

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

49+

48 replace (Abs (Right binder) val) =

50 replace (Abs (Right binder) val) =

49 let

51 let

50 ident = head $ unusedNames (binder, val)

52 ident = head $ unusedNames (binder, val)

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

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

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

58 mapM (rebracketModule opTable) ms

59

60+

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

61+removeSignedLiterals :: Module -> Module

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

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

62 where

63 where

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

65+

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

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

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

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

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

68 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 (

44import Data.List

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

46import Data.Generics

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

47+ (everythingWithContext, mkM, something, mkQ)

48import Data.Generics.Extras

49

50import Language.PureScript.Declarations

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

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

252--

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

254−overTypes f = everywhere (mkT g)

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

255 where

256 g :: Value -> Value

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

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

811-- only example of scoped type variables.

812--

813skolemizeTypesInValue :: 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

815 where

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

817 go other = other