git.iko.soy/rowtype-yoga/purescript-native
on 69f8b3e help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Linter.hs
113 lines 4.5 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 _ _ = mempty
76 stepB :: S.Set Ident -> Binder -> MultipleErrors
77 stepB s (VarBinder name) | name `S.member` s = errorMessage (ShadowedName name)
78 stepB s (NamedBinder name _) | name `S.member` s = errorMessage (ShadowedName name)
79 stepB _ _ = mempty
81 stepDo :: S.Set Ident -> DoNotationElement -> MultipleErrors
82 stepDo s (DoNotationLet ds') = foldMap go ds'
83 where
84 go d | Just i <- getDeclIdent d
85 , i `S.member` s = errorMessage (ShadowedName i)
86 | otherwise = mempty
87 stepDo _ _ = mempty
89 checkTypeVarsInDecl :: Declaration -> MultipleErrors
90 checkTypeVarsInDecl d = let (f, _, _, _, _) = accumTypes checkTypeVars in f d
92 checkTypeVars :: Type -> MultipleErrors
93 checkTypeVars ty = everythingWithContextOnTypes S.empty mempty mappend step ty <> findUnused ty
94 where
95 step :: S.Set String -> Type -> (S.Set String, MultipleErrors)
96 step s (ForAll tv _ _) = bindVar s tv
97 step s _ = (s, mempty)
98 bindVar :: S.Set String -> String -> (S.Set String, MultipleErrors)
99 bindVar = bind ShadowedTypeVar
100 findUnused :: Type -> MultipleErrors
101 findUnused ty' =
102 let used = usedTypeVariables ty'
103 declared = everythingOnTypes (++) go ty'
104 unused = nub declared \\ nub used
105 in foldl (<>) mempty $ map (errorMessage . UnusedTypeVar) unused
106 where
107 go :: Type -> [String]
108 go (ForAll tv _ _) = [tv]
109 go _ = []
111 bind :: (Ord a) => (a -> SimpleErrorMessage) -> S.Set a -> a -> (S.Set a, MultipleErrors)
112 bind mkError s name | name `S.member` s = (s, errorMessage (mkError name))
113 | otherwise = (S.insert name s, mempty)