Fix tests.

purescript · Nov 23, 2015 · b88c063 · b88c063
1 parent e7430f7
commit b88c063
Show file tree

Hide file tree

Showing 3 changed files with 17 additions and 6 deletions.
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
@@ -401,8 +401,12 @@ everythingWithScope ::
   (S.Set Ident -> Binder -> r) ->
   (S.Set Ident -> CaseAlternative -> r) ->
   (S.Set Ident -> DoNotationElement -> r) ->
-  S.Set Ident -> Declaration -> r
-everythingWithScope f g h i j = f''
+  ( S.Set Ident -> Declaration       -> r
+  , S.Set Ident -> Expr              -> r
+  , S.Set Ident -> Binder            -> r
+  , S.Set Ident -> CaseAlternative   -> r
+  , S.Set Ident -> DoNotationElement -> r)
+everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
   where
   -- Avoid importing Data.Monoid and getting shadowed names above
   (<>) = mappend

diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs
@@ -57,13 +57,13 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
   lintDeclaration :: Declaration -> m ()
   lintDeclaration = tell . f
     where
-    warningsInDecl = everythingWithScope stepD stepE stepB (\_ _ -> mempty) stepDo moduleNames
+    (warningsInDecl, _, _, _, _) = everythingWithScope stepD stepE stepB (\_ _ -> mempty) stepDo
 
     f :: Declaration -> MultipleErrors
     f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec)
-    f dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl dec <> checkTypeVarsInDecl dec)
+    f dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec)
     f (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)
-    f dec = warningsInDecl dec <> checkTypeVarsInDecl dec
+    f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec
 
     stepD :: S.Set Ident -> Declaration -> MultipleErrors
     stepD _ (TypeClassDeclaration name _ _ decls) = foldMap go decls

diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -102,10 +102,17 @@ collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
 collapseBindingGroupsForValue other = other
 
 usedIdents :: ModuleName -> Declaration -> [Ident]
-usedIdents moduleName = nub . everythingWithScope def usedNamesE def def def S.empty
+usedIdents moduleName = nub . usedIdents' S.empty . getValue
   where
   def _ _ = []
 
+  getValue (ValueDeclaration _ _ [] (Right val)) = val
+  getValue ValueDeclaration{} = internalError "Binders should have been desugared"
+  getValue (PositionedDeclaration _ _ d) = getValue d
+  getValue _ = internalError "Expected ValueDeclaration"
+
+  (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def
+
   usedNamesE :: S.Set Ident -> Expr -> [Ident]
   usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = [name]
   usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = [name]