aabfac0 · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #1659 from purescript/scope

aabfac0Phil Freeman11 years ago

examples/passing/1185.pursnew file+13

compare with golang

unifiedsplit

@@ -0,0 +1,13 @@

1+module Main where

3+data Person = Person String Boolean

5+getName :: Person -> String

6+getName p = case p of

7+ Person name true -> name

8+ _ -> "Unknown"

10+name :: String

11+name = getName (Person "John Smith" true)

12+

13+main = Control.Monad.Eff.Console.log "Done"

src/Language/PureScript/AST/Traversals.hs+111

@@ -18,6 +18,10 @@ import Prelude ()

18import Prelude.Compat

20import Data.Maybe (mapMaybe)

21+import Data.List (mapAccumL)

22+import Data.Foldable (fold)

23+import qualified Data.Set as S

24+

21import Control.Monad

25import Control.Monad

22import Control.Arrow ((***), (+++), second)

26import Control.Arrow ((***), (+++), second)

@@ -25,6 +29,7 @@ import Language.PureScript.AST.Binders

25import Language.PureScript.AST.Declarations

29import Language.PureScript.AST.Declarations

26import Language.PureScript.Types

30import Language.PureScript.Types

27import Language.PureScript.Traversals

31import Language.PureScript.Traversals

32+import Language.PureScript.Names

29everywhereOnValues :: (Declaration -> Declaration) ->

34everywhereOnValues :: (Declaration -> Declaration) ->

30 (Expr -> Expr) ->

35 (Expr -> Expr) ->

@@ -389,6 +394,112 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

389 j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds

394 j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds

390 j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1

395 j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1

391

396

397+everythingWithScope ::

398+ (Monoid r) =>

399+ (S.Set Ident -> Declaration -> r) ->

400+ (S.Set Ident -> Expr -> r) ->

401+ (S.Set Ident -> Binder -> r) ->

402+ (S.Set Ident -> CaseAlternative -> r) ->

403+ (S.Set Ident -> DoNotationElement -> r) ->

404+ ( S.Set Ident -> Declaration -> r

405+ , S.Set Ident -> Expr -> r

406+ , S.Set Ident -> Binder -> r

407+ , S.Set Ident -> CaseAlternative -> r

408+ , S.Set Ident -> DoNotationElement -> r)

409+everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

410+ where

411+ -- Avoid importing Data.Monoid and getting shadowed names above

412+ (<>) = mappend

413+

414+ f'' s a = f s a <> f' s a

415+

416+ f' s (DataBindingGroupDeclaration ds) =

417+ let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))

418+ in foldMap (f'' s') ds

419+ f' s (ValueDeclaration name _ bs (Right val)) =

420+ let s' = S.insert name s

421+ in foldMap (h'' s') bs <> g'' s' val

422+ f' s (ValueDeclaration name _ bs (Left gs)) =

423+ let s' = S.insert name s

424+ s'' = S.union s' (S.fromList (concatMap binderNames bs))

425+ in foldMap (h'' s') bs <> foldMap (\(grd, val) -> g'' s'' grd <> g'' s'' val) gs

426+ f' s (BindingGroupDeclaration ds) =

427+ let s' = S.union s (S.fromList (map (\(name, _, _) -> name) ds))

428+ in foldMap (\(_, _, val) -> g'' s' val) ds

429+ f' s (TypeClassDeclaration _ _ _ ds) = foldMap (f'' s) ds

430+ f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds

431+ f' s (PositionedDeclaration _ _ d) = f'' s d

432+ f' _ _ = mempty

433+

434+ g'' s a = g s a <> g' s a

435+

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

437+ g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2

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

439+ g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v

440+ g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

441+ g' s (ArrayLiteral vs) = foldMap (g'' s) vs

442+ g' s (ObjectLiteral vs) = foldMap (g'' s . snd) vs

443+ g' s (ObjectConstructor vs) = foldMap (g'' s) (mapMaybe snd vs)

444+ g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

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

446+ g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs

447+ g' s (ObjectUpdater obj vs) = foldMap (g'' s) obj <> foldMap (g'' s) (mapMaybe snd vs)

448+ g' s (Abs (Left name) v1) =

449+ let s' = S.insert name s

450+ in g'' s' v1

451+ g' s (Abs (Right b) v1) =

452+ let s' = S.union (S.fromList (binderNames b)) s

453+ in g'' s' v1

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

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

456+ g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts

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

458+ g' s (Let ds v1) =

459+ let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))

460+ in foldMap (f'' s') ds <> g'' s' v1

461+ g' s (Do es) = fold . snd . mapAccumL j'' s $ es

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

463+ g' _ _ = mempty

464+

465+ h'' s a = h s a <> h' s a

466+

467+ h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs

468+ h' s (ObjectBinder bs) = foldMap (h'' s . snd) bs

469+ h' s (ArrayBinder bs) = foldMap (h'' s) bs

470+ h' s (NamedBinder name b1) =

471+ let s' = S.insert name s

472+ in h'' s' b1

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

474+ h' s (TypedBinder _ b1) = h'' s b1

475+ h' _ _ = mempty

476+

477+ i'' s a = i s a <> i' s a

478+

479+ i' s (CaseAlternative bs (Right val)) =

480+ let s' = S.union s (S.fromList (concatMap binderNames bs))

481+ in foldMap (h'' s) bs <> g'' s' val

482+ i' s (CaseAlternative bs (Left gs)) =

483+ let s' = S.union s (S.fromList (concatMap binderNames bs))

484+ in foldMap (h'' s) bs <> foldMap (\(grd, val) -> g'' s' grd <> g'' s' val) gs

485+

486+ j'' s a = let (s', r) = j' s a in (s', j s a <> r)

487+

488+ j' s (DoNotationValue v) = (s, g'' s v)

489+ j' s (DoNotationBind b v) =

490+ let s' = S.union (S.fromList (binderNames b)) s

491+ in (s', h'' s b <> g'' s' v)

492+ j' s (DoNotationLet ds) =

493+ let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))

494+ in (s', foldMap (f'' s') ds)

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

496+

497+ getDeclIdent :: Declaration -> Maybe Ident

498+ getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d

499+ getDeclIdent (ValueDeclaration ident _ _ _) = Just ident

500+ getDeclIdent (TypeDeclaration ident _) = Just ident

501+ getDeclIdent _ = Nothing

502+

392accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

503accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

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

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

394 where

505 where

src/Language/PureScript/Linter.hs+39−35

@@ -14,13 +14,14 @@

15{-# LANGUAGE FlexibleContexts #-}

16{-# LANGUAGE ScopedTypeVariables #-}

17+{-# LANGUAGE PatternGuards #-}

18module Language.PureScript.Linter (lint, module L) where

19module Language.PureScript.Linter (lint, module L) where

20import Prelude ()

21import Prelude ()

21import Prelude.Compat

22import Prelude.Compat

23−import Data.List (mapAccumL, nub, (\\))

24+import Data.List (nub, (\\))

24import Data.Maybe (mapMaybe)

25import Data.Maybe (mapMaybe)

25import Data.Monoid

26import Data.Monoid

@@ -54,43 +55,46 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

54 getDeclIdent _ = Nothing

55 getDeclIdent _ = Nothing

56 lintDeclaration :: Declaration -> m ()

57 lintDeclaration :: Declaration -> m ()

57− lintDeclaration d =

58+ lintDeclaration = tell . f

58− let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend stepD stepE stepB def def

59−

60− f' :: Declaration -> MultipleErrors

61− f' (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' dec)

62− f' dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (f dec <> checkTypeVarsInDecl dec)

63− f' (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)

64− f' dec = f dec <> checkTypeVarsInDecl dec

65−

66− in tell (f' d)

67 where

59 where

68− def s _ = (s, mempty)

60+ (warningsInDecl, _, _, _, _) = everythingWithScope stepD stepE stepB (\_ _ -> mempty) stepDo

61+

62+ f :: Declaration -> MultipleErrors

63+ f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec)

64+ f dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec)

65+ f (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)

66+ f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec

70− stepD :: S.Set Ident -> Declaration -> (S.Set Ident, MultipleErrors)

68+ stepD :: S.Set Ident -> Declaration -> MultipleErrors

71− stepD s (TypeClassDeclaration name _ _ decls) = (s, foldr go mempty decls)

69+ stepD _ (TypeClassDeclaration name _ _ decls) = foldMap go decls

70+ where

71+ go :: Declaration -> MultipleErrors

72+ go (PositionedDeclaration _ _ d') = go d'

73+ go (TypeDeclaration op@(Op _) _) = errorMessage (ClassOperator name op)

74+ go _ = mempty

75+ stepD _ _ = mempty

76+

77+ stepE :: S.Set Ident -> Expr -> MultipleErrors

78+ stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name)

79+ stepE s (Let ds' _) = foldMap go ds'

80+ where

81+ go d | Just i <- getDeclIdent d

82+ , i `S.member` s = errorMessage (ShadowedName i)

83+ | otherwise = mempty

84+ stepE _ _ = mempty

85+

86+ stepB :: S.Set Ident -> Binder -> MultipleErrors

87+ stepB s (VarBinder name) | name `S.member` s = errorMessage (ShadowedName name)

88+ stepB s (NamedBinder name _) | name `S.member` s = errorMessage (ShadowedName name)

89+ stepB _ _ = mempty

90+

91+ stepDo :: S.Set Ident -> DoNotationElement -> MultipleErrors

92+ stepDo s (DoNotationLet ds') = foldMap go ds'

72 where

93 where

73− go :: Declaration -> MultipleErrors -> MultipleErrors

94+ go d | Just i <- getDeclIdent d

74− go (PositionedDeclaration _ _ d') errs = go d' errs

75− go (TypeDeclaration op@(Op _) _) errs = errorMessage (ClassOperator name op) <> errs

76− go _ errs = errs

77− stepD s _ = (s, mempty)

78−

79− stepE :: S.Set Ident -> Expr -> (S.Set Ident, MultipleErrors)

80− stepE s (Abs (Left name) _) = bindName s name

81− stepE s (Let ds' _) =

82− case mapAccumL bindName s (nub (mapMaybe getDeclIdent ds')) of

83− (s', es) -> (s', mconcat es)

84− stepE s _ = (s, mempty)

85−

86− stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors)

87− stepB s (VarBinder name) = bindName s name

88− stepB s (NamedBinder name _) = bindName s name

89− stepB s (TypedBinder _ b) = stepB s b

90− stepB s _ = (s, mempty)

91−

92− bindName :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)

93− bindName = bind ShadowedName

95+ , i `S.member` s = errorMessage (ShadowedName i)

96+ | otherwise = mempty

97+ stepDo _ _ = mempty

95 checkTypeVarsInDecl :: Declaration -> MultipleErrors

99 checkTypeVarsInDecl :: Declaration -> MultipleErrors

96 checkTypeVarsInDecl d = let (f, _, _, _, _) = accumTypes checkTypeVars in f d

100 checkTypeVarsInDecl d = let (f, _, _, _, _) = accumTypes checkTypeVars in f d

src/Language/PureScript/Sugar/BindingGroups.hs+12−11

@@ -102,20 +102,21 @@ collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val

102collapseBindingGroupsForValue other = other

103

104usedIdents :: ModuleName -> Declaration -> [Ident]

105−usedIdents moduleName =

105+usedIdents moduleName = nub . usedIdents' S.empty . getValue

106− let (f, _, _, _, _) = everythingWithContextOnValues S.empty [] (++) def usedNamesE usedNamesB def def

107− in nub . f

108 where

106 where

109− def s _ = (s, [])

107+ def _ _ = []

110

108

111− usedNamesE :: S.Set Ident -> Expr -> (S.Set Ident, [Ident])

109+ getValue (ValueDeclaration _ _ [] (Right val)) = val

112− usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = (scope, [name])

110+ getValue ValueDeclaration{} = internalError "Binders should have been desugared"

113− usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = (scope, [name])

111+ getValue (PositionedDeclaration _ _ d) = getValue d

114− usedNamesE scope (Abs (Left name) _) = (name `S.insert` scope, [])

112+ getValue _ = internalError "Expected ValueDeclaration"

115− usedNamesE scope _ = (scope, [])

113+

114+ (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def

116

115

117− usedNamesB :: S.Set Ident -> Binder -> (S.Set Ident, [Ident])

116+ usedNamesE :: S.Set Ident -> Expr -> [Ident]

118− usedNamesB scope binder = (scope `S.union` S.fromList (binderNames binder), [])

117+ usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = [name]

118+ usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = [name]

119+ usedNamesE _ _ = []

119

120

120usedImmediateIdents :: ModuleName -> Declaration -> [Ident]

121usedImmediateIdents :: ModuleName -> Declaration -> [Ident]

121usedImmediateIdents moduleName =

122usedImmediateIdents moduleName =