037f361 · rowtype-yoga/purescript-native

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

on golang help sign in

Implement everythingWithContext by hand.

037f361Phil Freeman13 years ago

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

compare with golang

unifiedsplit

@@ -12,7 +12,7 @@

12--

13-----------------------------------------------------------------------------

15−{-# LANGUAGE DeriveDataTypeable #-}

15+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}

17module Language.PureScript.Declarations where

@@ -668,6 +668,74 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

668 j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)

669 j' e@(PositionedDoNotationElement _ e1) = j e <> j' e1

670

671+everythingWithContextOnValues ::

672+ s ->

673+ r ->

674+ (r -> r -> r) ->

675+ (s -> Declaration -> (s, r)) ->

676+ (s -> Value -> (s, r)) ->

677+ (s -> Binder -> (s, r)) ->

678+ (s -> CaseAlternative -> (s, r)) ->

679+ (s -> DoNotationElement -> (s, r)) ->

680+ ( Declaration -> r

681+ , Value -> r

682+ , Binder -> r

683+ , CaseAlternative -> r

684+ , DoNotationElement -> r)

685+everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)

686+ where

687+ f'' s d = let (s', r) = f s d in r <> f' s' d

688+

689+ f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)

690+ f' s (ValueDeclaration _ _ bs Nothing val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) val

691+ f' s (ValueDeclaration _ _ bs (Just grd) val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) grd <> (g'' s) val

692+ f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> (g'' s) val) ds)

693+ f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)

694+ f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)

695+ f' s (PositionedDeclaration _ d1) = (f'' s) d1

696+ f' _ _ = r0

697+

698+ g'' s v = let (s', r) = g s v in r <> g' s' v

699+

700+ g' s (UnaryMinus v1) = (g'' s) v1

701+ g' s (BinaryNoParens _ v1 v2) = (g'' s) v1 <> (g'' s) v2

702+ g' s (Parens v1) = (g'' s) v1

703+ g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)

704+ g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)

705+ g' s (Accessor _ v1) = (g'' s) v1

706+ g' s (ObjectUpdate obj vs) = foldl (<>) ((g'' s) obj) (map (g'' s . snd) vs)

707+ g' s (Abs _ v1) = (g'' s) v1

708+ g' s (App v1 v2) = (g'' s) v1 <> (g'' s) v2

709+ g' s (IfThenElse v1 v2 v3) = (g'' s) v1 <> (g'' s) v2 <> (g'' s) v3

710+ g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (map (g'' s) vs)) (map (i'' s) alts)

711+ g' s (TypedValue _ v1 _) = (g'' s) v1

712+ g' s (Let ds v1) = (foldl (<>) r0 (map (f'' s) ds)) <> (g'' s) v1

713+ g' s (Do es) = foldl (<>) r0 (map (j'' s) es)

714+ g' s (PositionedValue _ v1) = (g'' s) v1

715+ g' _ _ = r0

716+

717+ h'' s b = let (s', r) = h s b in r <> h' s' b

718+

719+ h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)

720+ h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)

721+ h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)

722+ h' s (ConsBinder b1 b2) = (h'' s) b1 <> (h'' s) b2

723+ h' s (NamedBinder _ b1) = (h'' s) b1

724+ h' s (PositionedBinder _ b1) = (h'' s) b1

725+ h' _ _ = r0

726+

727+ i'' s ca = let (s', r) = i s ca in r <> i' s' ca

728+

729+ i' s (CaseAlternative bs Nothing val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) val

730+ i' s (CaseAlternative bs (Just grd) val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) grd <> (g'' s) val

731+

732+ j'' s e = let (s', r) = j s e in r <> j' s' e

733+

734+ j' s (DoNotationValue v) = (g'' s) v

735+ j' s (DoNotationBind b v) = (h'' s) b <> (g'' s) v

736+ j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)

737+ j' s (PositionedDoNotationElement _ e1) = (j'' s) e1

738+

671accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Value -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

739accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Value -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

672accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)

740accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)

673 where

741 where

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

686 forValues _ = mempty

754 forValues _ = mempty

687

755

688

756

689−

src/Language/PureScript/TypeChecker/Types.hs+12−11

@@ -46,8 +46,6 @@ import Data.Maybe (maybeToList, isNothing, isJust, fromMaybe)

46import Data.Function (on)

47import Data.Ord (comparing)

48import Data.Monoid

49−import Data.Generics

50− (everythingWithContext, mkQ)

52import Language.PureScript.Declarations

50import Language.PureScript.Declarations

53import Language.PureScript.Types

51import Language.PureScript.Types

@@ -462,22 +460,25 @@ skolemEscapeCheck root@TypedValue{} =

462 -- We traverse the tree top-down, and collect any SkolemScopes introduced by ForAlls.

460 -- We traverse the tree top-down, and collect any SkolemScopes introduced by ForAlls.

463 -- If a Skolem is encountered whose SkolemScope is not in the current list, we have found

461 -- If a Skolem is encountered whose SkolemScope is not in the current list, we have found

464 -- an escaped skolem variable.

462 -- an escaped skolem variable.

463+ let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def

465− case everythingWithContext [] (++) (mkQ ((,) []) go) root of

464+ in case f root of

466− [] -> return ()

465+ [] -> return ()

467− ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ValueError val))

466+ ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ValueError val))

468 where

467 where

468+ def s _ = (s, [])

469+

469− go :: Value -> [(SkolemScope, Value)] -> ([(Maybe Value, Value)], [(SkolemScope, Value)])

470+ go :: [(SkolemScope, Value)] -> Value -> ([(SkolemScope, Value)], [(Maybe Value, Value)])

470− go val@(TypedValue _ _ (ForAll _ _ (Just sco))) scos = ([], (sco, val) : scos)

471+ go scos val@(TypedValue _ _ (ForAll _ _ (Just sco))) = ((sco, val) : scos, [])

471− go val@(TypedValue _ _ ty) scos = case collectSkolems ty \\ map fst scos of

472+ go scos val@(TypedValue _ _ ty) = case collectSkolems ty \\ map fst scos of

472− (sco : _) -> ([(findBindingScope sco, val)], scos)

473+ (sco : _) -> (scos, [(findBindingScope sco, val)])

473− _ -> ([], scos)

474+ _ -> (scos, [])

474 where

475 where

475 collectSkolems :: Type -> [SkolemScope]

476 collectSkolems :: Type -> [SkolemScope]

476 collectSkolems = nub . everythingOnTypes (++) collect

477 collectSkolems = nub . everythingOnTypes (++) collect

477 where

478 where

478 collect (Skolem _ _ scope) = [scope]

479 collect (Skolem _ _ scope) = [scope]

479 collect _ = []

480 collect _ = []

480− go _ scos = ([], scos)

481+ go scos _ = (scos, [])

481 findBindingScope :: SkolemScope -> Maybe Value

482 findBindingScope :: SkolemScope -> Maybe Value

482 findBindingScope sco =

483 findBindingScope sco =

483 let (_, f, _, _, _) = everythingOnValues mappend (const mempty) go' (const mempty) (const mempty) (const mempty)

484 let (_, f, _, _, _) = everythingOnValues mappend (const mempty) go' (const mempty) (const mempty) (const mempty)