git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #1659 from purescript/scope

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

commitaabfac00ebf436a44c86edef6c35d1098d47923a authorPhil Freeman <paf31@cantab.net> dateMon 23 Nov 2015, 07:39 (11 years ago) parentf8fff2db88c063
4 files changed+175−46
compare with golang
unifiedsplit
examples/passing/1185.purs+13 src/Language/PureScript/AST/Traversals.hs+111 src/Language/PureScript/Linter.hs+39−35 src/Language/PureScript/Sugar/BindingGroups.hs+12−11
examples/passing/1185.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+data Person = Person String Boolean
4+
5+getName :: Person -> String
6+getName p = case p of
7+ Person name true -> name
8+ _ -> "Unknown"
9+
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 ()
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,112 @@ 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+ , 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+
392503accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
393504accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
394505 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
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
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+12−11
@@ -102,20 +102,21 @@ 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 . usedIdents' S.empty . getValue
108106 where
109− def s _ = (s, [])
107+ def _ _ = []
110108
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, [])
109+ getValue (ValueDeclaration _ _ [] (Right val)) = val
110+ getValue ValueDeclaration{} = internalError "Binders should have been desugared"
111+ getValue (PositionedDeclaration _ _ d) = getValue d
112+ getValue _ = internalError "Expected ValueDeclaration"
113+
114+ (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def
116115
117− usedNamesB :: S.Set Ident -> Binder -> (S.Set Ident, [Ident])
118− usedNamesB scope binder = (scope `S.union` S.fromList (binderNames binder), [])
116+ usedNamesE :: S.Set Ident -> Expr -> [Ident]
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 _ _ = []
119120
120121usedImmediateIdents :: ModuleName -> Declaration -> [Ident]
121122usedImmediateIdents moduleName =