git.iko.soy/rowtype-yoga/purescript-native
on 2dd0f79 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Linter.hs
107 lines 4.4 kB history raw
1-- |
2-- This module implements a simple linting pass on the PureScript AST.
3--
4module Language.PureScript.Linter (lint, module L) where
6import Prelude.Compat
8import Control.Monad.Writer.Class
10import Data.List (nub, (\\))
11import Data.Maybe (mapMaybe)
12import Data.Monoid
13import qualified Data.Set as S
15import Language.PureScript.AST
16import Language.PureScript.Crash
17import Language.PureScript.Errors
18import Language.PureScript.Linter.Exhaustive as L
19import Language.PureScript.Linter.Imports as L
20import Language.PureScript.Names
21import Language.PureScript.Types
23-- | Lint the PureScript AST.
24-- |
25-- | Right now, this pass only performs a shadowing check.
26lint :: forall m. (MonadWriter MultipleErrors m) => Module -> m ()
27lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds
28 where
29 moduleNames :: S.Set Ident
30 moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))
32 getDeclIdent :: Declaration -> Maybe Ident
33 getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d
34 getDeclIdent (ValueDeclaration ident _ _ _) = Just ident
35 getDeclIdent (ExternDeclaration ident _) = Just ident
36 getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident
37 getDeclIdent (BindingGroupDeclaration _) = internalError "lint: binding groups should not be desugared yet."
38 getDeclIdent _ = Nothing
40 lintDeclaration :: Declaration -> m ()
41 lintDeclaration = tell . f
42 where
43 (warningsInDecl, _, _, _, _) = everythingWithScope stepD stepE stepB (\_ _ -> mempty) stepDo
45 f :: Declaration -> MultipleErrors
46 f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec)
47 f dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec)
48 f (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)
49 f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec
51 stepD :: S.Set Ident -> Declaration -> MultipleErrors
52 stepD _ (ValueDeclaration (Op name) _ _ _) = errorMessage (DeprecatedOperatorDecl name)
53 stepD _ (TypeClassDeclaration _ _ _ decls) = foldMap go decls
54 where
55 go :: Declaration -> MultipleErrors
56 go (PositionedDeclaration _ _ d') = go d'
57 go (TypeDeclaration (Op name) _) = errorMessage (DeprecatedOperatorDecl name)
58 go _ = mempty
59 stepD _ _ = mempty
61 stepE :: S.Set Ident -> Expr -> MultipleErrors
62 stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name)
63 stepE s (Let ds' _) = foldMap go ds'
64 where
65 go d | Just i <- getDeclIdent d
66 , i `S.member` s = errorMessage (ShadowedName i)
67 | otherwise = mempty
68 stepE _ _ = mempty
70 stepB :: S.Set Ident -> Binder -> MultipleErrors
71 stepB s (VarBinder name) | name `S.member` s = errorMessage (ShadowedName name)
72 stepB s (NamedBinder name _) | name `S.member` s = errorMessage (ShadowedName name)
73 stepB _ _ = mempty
75 stepDo :: S.Set Ident -> DoNotationElement -> MultipleErrors
76 stepDo s (DoNotationLet ds') = foldMap go ds'
77 where
78 go d | Just i <- getDeclIdent d
79 , i `S.member` s = errorMessage (ShadowedName i)
80 | otherwise = mempty
81 stepDo _ _ = mempty
83 checkTypeVarsInDecl :: Declaration -> MultipleErrors
84 checkTypeVarsInDecl d = let (f, _, _, _, _) = accumTypes checkTypeVars in f d
86 checkTypeVars :: Type -> MultipleErrors
87 checkTypeVars ty = everythingWithContextOnTypes S.empty mempty mappend step ty <> findUnused ty
88 where
89 step :: S.Set String -> Type -> (S.Set String, MultipleErrors)
90 step s (ForAll tv _ _) = bindVar s tv
91 step s _ = (s, mempty)
92 bindVar :: S.Set String -> String -> (S.Set String, MultipleErrors)
93 bindVar = bind ShadowedTypeVar
94 findUnused :: Type -> MultipleErrors
95 findUnused ty' =
96 let used = usedTypeVariables ty'
97 declared = everythingOnTypes (++) go ty'
98 unused = nub declared \\ nub used
99 in foldl (<>) mempty $ map (errorMessage . UnusedTypeVar) unused
100 where
101 go :: Type -> [String]
102 go (ForAll tv _ _) = [tv]
103 go _ = []
105 bind :: (Ord a) => (a -> SimpleErrorMessage) -> S.Set a -> a -> (S.Set a, MultipleErrors)
106 bind mkError s name | name `S.member` s = (s, errorMessage (mkError name))
107 | otherwise = (S.insert name s, mempty)