git.iko.soy/rowtype-yoga/purescript-native
on fca3655 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Linter.hs
103 lines 4.3 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
14import Data.Text (Text)
16import Language.PureScript.AST
17import Language.PureScript.Crash
18import Language.PureScript.Errors
19import Language.PureScript.Linter.Exhaustive as L
20import Language.PureScript.Linter.Imports as L
21import Language.PureScript.Names
22import Language.PureScript.Types
24-- | Lint the PureScript AST.
25-- |
26-- | Right now, this pass only performs a shadowing check.
27lint :: forall m. (MonadWriter MultipleErrors m) => Module -> m ()
28lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds
29 where
30 moduleNames :: S.Set Ident
31 moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))
33 getDeclIdent :: Declaration -> Maybe Ident
34 getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d
35 getDeclIdent (ValueDeclaration ident _ _ _) = Just ident
36 getDeclIdent (ExternDeclaration ident _) = Just ident
37 getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident
38 getDeclIdent (BindingGroupDeclaration _) = internalError "lint: binding groups should not be desugared yet."
39 getDeclIdent _ = Nothing
41 lintDeclaration :: Declaration -> m ()
42 lintDeclaration = tell . f
43 where
44 (warningsInDecl, _, _, _, _) = everythingWithScope (\_ _ -> mempty) stepE stepB (\_ _ -> mempty) stepDo
46 f :: Declaration -> MultipleErrors
47 f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec)
48 f (TypeClassDeclaration name args _ _ decs) = addHint (ErrorInTypeClassDeclaration name) (foldMap (f' (S.fromList $ fst <$> args)) decs)
49 f dec = f' S.empty dec
51 f' :: S.Set Text -> Declaration -> MultipleErrors
52 f' s (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' s dec)
53 f' s dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec)
54 f' s (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars s ty)
55 f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec
57 stepE :: S.Set Ident -> Expr -> MultipleErrors
58 stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name)
59 stepE s (Let ds' _) = foldMap go ds'
60 where
61 go d | Just i <- getDeclIdent d
62 , i `S.member` s = errorMessage (ShadowedName i)
63 | otherwise = mempty
64 stepE _ _ = mempty
66 stepB :: S.Set Ident -> Binder -> MultipleErrors
67 stepB s (VarBinder name) | name `S.member` s = errorMessage (ShadowedName name)
68 stepB s (NamedBinder name _) | name `S.member` s = errorMessage (ShadowedName name)
69 stepB _ _ = mempty
71 stepDo :: S.Set Ident -> DoNotationElement -> MultipleErrors
72 stepDo s (DoNotationLet ds') = foldMap go ds'
73 where
74 go d | Just i <- getDeclIdent d
75 , i `S.member` s = errorMessage (ShadowedName i)
76 | otherwise = mempty
77 stepDo _ _ = mempty
79 checkTypeVarsInDecl :: S.Set Text -> Declaration -> MultipleErrors
80 checkTypeVarsInDecl s d = let (f, _, _, _, _) = accumTypes (checkTypeVars s) in f d
82 checkTypeVars :: S.Set Text -> Type -> MultipleErrors
83 checkTypeVars set ty = everythingWithContextOnTypes set mempty mappend step ty <> findUnused ty
84 where
85 step :: S.Set Text -> Type -> (S.Set Text, MultipleErrors)
86 step s (ForAll tv _ _) = bindVar s tv
87 step s _ = (s, mempty)
88 bindVar :: S.Set Text -> Text -> (S.Set Text, MultipleErrors)
89 bindVar = bind ShadowedTypeVar
90 findUnused :: Type -> MultipleErrors
91 findUnused ty' =
92 let used = usedTypeVariables ty'
93 declared = everythingOnTypes (++) go ty'
94 unused = nub declared \\ nub used
95 in foldl (<>) mempty $ map (errorMessage . UnusedTypeVar) unused
96 where
97 go :: Type -> [Text]
98 go (ForAll tv _ _) = [tv]
99 go _ = []
101 bind :: (Ord a) => (a -> SimpleErrorMessage) -> S.Set a -> a -> (S.Set a, MultipleErrors)
102 bind mkError s name | name `S.member` s = (s, errorMessage (mkError name))
103 | otherwise = (S.insert name s, mempty)