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