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