git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fix #1185, fix #1369, add everythingWithScope traversal to correct some scoping issues.
e7430f7Phil Freeman
examples/passing/1185.pursnew file+13
compare with golang
unifiedsplit
@@ -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+107
@@ -18,6 +18,10 @@ import Prelude ()
18import Prelude.Compat
18import Prelude.Compat
19
19
20import Data.Maybe (mapMaybe)
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)
23
27
@@ -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
28
33
29everywhereOnValues :: (Declaration -> Declaration) ->
34everywhereOnValues :: (Declaration -> Declaration) ->
30 (Expr -> Expr) ->
35 (Expr -> Expr) ->
@@ -389,6 +394,108 @@ 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+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+
392accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
499accumTypes :: (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)
500accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
394 where
501 where
src/Language/PureScript/Linter.hs+39−35
@@ -14,13 +14,14 @@
14
14
15{-# LANGUAGE FlexibleContexts #-}
15{-# LANGUAGE FlexibleContexts #-}
16{-# LANGUAGE ScopedTypeVariables #-}
16{-# LANGUAGE ScopedTypeVariables #-}
17+{-# LANGUAGE PatternGuards #-}
17
18
18module Language.PureScript.Linter (lint, module L) where
19module Language.PureScript.Linter (lint, module L) where
19
20
20import Prelude ()
21import Prelude ()
21import Prelude.Compat
22import Prelude.Compat
22
23
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
26
27
@@ -54,43 +55,46 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
54 getDeclIdent _ = Nothing
55 getDeclIdent _ = Nothing
55
56
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 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
69
67
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
94
98
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+6−12
@@ -102,20 +102,14 @@ collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
102collapseBindingGroupsForValue other = other
102collapseBindingGroupsForValue other = other
103
103
104usedIdents :: ModuleName -> Declaration -> [Ident]
104usedIdents :: ModuleName -> Declaration -> [Ident]
105−usedIdents moduleName =
105+usedIdents moduleName = nub . everythingWithScope def usedNamesE def def def S.empty
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−
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, [])
116
108
117− usedNamesB :: S.Set Ident -> Binder -> (S.Set Ident, [Ident])
109+ usedNamesE :: S.Set Ident -> Expr -> [Ident]
118− usedNamesB scope binder = (scope `S.union` S.fromList (binderNames binder), [])
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 _ _ = []
119
113
120usedImmediateIdents :: ModuleName -> Declaration -> [Ident]
114usedImmediateIdents :: ModuleName -> Declaration -> [Ident]
121usedImmediateIdents moduleName =
115usedImmediateIdents moduleName =