e7430f7 · rowtype-yoga/purescript-native

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

Fix #1185, fix #1369, add everythingWithScope traversal to correct some scoping issues.

commite7430f75a64019910733a3a978a39e28de1b5a6c authorPhil Freeman <paf31@cantab.net> dateSun 22 Nov 2015, 16:16 (11 years ago) parent5241a99

4 files changed+165−47

compare with golang

unifiedsplit

examples/passing/1185.purs+13 src/Language/PureScript/AST/Traversals.hs+107 src/Language/PureScript/Linter.hs+39−35 src/Language/PureScript/Sugar/BindingGroups.hs+6−12

examples/passing/1185.pursnew file+13

@@ -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+107

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

1818import Prelude.Compat

1919

2020import Data.Maybe (mapMaybe)

21+import Data.List (mapAccumL)

22+import Data.Foldable (fold)

23+import qualified Data.Set as S

24+

2125import Control.Monad

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

2327

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

2529import Language.PureScript.AST.Declarations

2630import Language.PureScript.Types

2731import Language.PureScript.Traversals

32+import Language.PureScript.Names

2833

2934everywhereOnValues :: (Declaration -> Declaration) ->

3035 (Expr -> Expr) ->

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

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

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

391396

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+everythingWithScope f g h i j = f''

406+ where

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

408+ (<>) = mappend

409+

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

411+

412+ f' s (DataBindingGroupDeclaration ds) =

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

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

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

416+ let s' = S.insert name s

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

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

419+ let s' = S.insert name s

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

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

422+ f' s (BindingGroupDeclaration ds) =

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

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

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

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

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

428+ f' _ _ = mempty

429+

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

431+

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

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

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

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

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

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

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

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

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

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

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

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

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

445+ let s' = S.insert name s

446+ in g'' s' v1

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

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

449+ in g'' s' v1

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

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

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

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

454+ g' s (Let ds v1) =

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

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

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

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

459+ g' _ _ = mempty

460+

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

462+

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

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

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

466+ h' s (NamedBinder name b1) =

467+ let s' = S.insert name s

468+ in h'' s' b1

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

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

471+ h' _ _ = mempty

472+

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

474+

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

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

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

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

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

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

481+

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

483+

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

485+ j' s (DoNotationBind b v) =

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

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

488+ j' s (DoNotationLet ds) =

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

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

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

492+

493+ getDeclIdent :: Declaration -> Maybe Ident

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

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

496+ getDeclIdent (TypeDeclaration ident _) = Just ident

497+ getDeclIdent _ = Nothing

498+

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

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

394501 where

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

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

1414

1515{-# LANGUAGE FlexibleContexts #-}

1616{-# LANGUAGE ScopedTypeVariables #-}

17+{-# LANGUAGE PatternGuards #-}

1718

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

1920

2021import Prelude ()

2122import Prelude.Compat

2223

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

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

2425import Data.Maybe (mapMaybe)

2526import Data.Monoid

2627

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

5455 getDeclIdent _ = Nothing

5556

5657 lintDeclaration :: Declaration -> m ()

57− lintDeclaration d =

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)

58+ lintDeclaration = tell . f

6759 where

68− def s _ = (s, mempty)

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

61+

62+ f :: Declaration -> MultipleErrors

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

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

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

66+ f dec = warningsInDecl dec <> checkTypeVarsInDecl dec

6967

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

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

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

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'

7293 where

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

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

94+ go d | Just i <- getDeclIdent d

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

96+ | otherwise = mempty

97+ stepDo _ _ = mempty

9498

9599 checkTypeVarsInDecl :: Declaration -> MultipleErrors

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

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

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

102102collapseBindingGroupsForValue other = other

103103

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

105−usedIdents moduleName =

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

107− in nub . f

105+usedIdents moduleName = nub . everythingWithScope def usedNamesE def def def S.empty

108106 where

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

110−

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

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

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

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

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

107+ def _ _ = []

116108

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

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

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

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

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

112+ usedNamesE _ _ = []

119113

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

121115usedImmediateIdents moduleName =