git.iko.soy/rowtype-yoga/purescript-native
on 47c0ffb help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Linter.hs
121 lines 4.8 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 GeneralizedNewtypeDeriving #-}
16{-# LANGUAGE FlexibleContexts #-}
17{-# LANGUAGE ScopedTypeVariables #-}
18{-# LANGUAGE CPP #-}
20module Language.PureScript.Linter (lint, module L) where
22import Data.List (mapAccumL, nub, (\\))
23import Data.Maybe (mapMaybe)
24import Data.Monoid
26import qualified Data.Set as S
28#if __GLASGOW_HASKELL__ < 710
29import Control.Applicative
30#endif
31import Control.Monad.Writer.Class
33import Language.PureScript.Crash
34import Language.PureScript.AST
35import Language.PureScript.Names
36import Language.PureScript.Errors
37import Language.PureScript.Types
38import Language.PureScript.Linter.Exhaustive as L
39import Language.PureScript.Linter.Imports as L
41-- | Lint the PureScript AST.
42-- |
43-- | Right now, this pass only performs a shadowing check.
44lint :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Module -> m ()
45lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds
46 where
47 moduleNames :: S.Set Ident
48 moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))
50 getDeclIdent :: Declaration -> Maybe Ident
51 getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d
52 getDeclIdent (ValueDeclaration ident _ _ _) = Just ident
53 getDeclIdent (ExternDeclaration ident _) = Just ident
54 getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident
55 getDeclIdent (BindingGroupDeclaration _) = internalError "lint: binding groups should not be desugared yet."
56 getDeclIdent _ = Nothing
58 lintDeclaration :: Declaration -> m ()
59 lintDeclaration d =
60 let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend stepD stepE stepB def def
62 f' :: Declaration -> MultipleErrors
63 f' (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' dec)
64 f' dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (f dec <> checkTypeVarsInDecl dec)
65 f' (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)
66 f' dec = f dec <> checkTypeVarsInDecl dec
68 in tell (f' d)
69 where
70 def s _ = (s, mempty)
72 stepD :: S.Set Ident -> Declaration -> (S.Set Ident, MultipleErrors)
73 stepD s (TypeClassDeclaration name _ _ decls) = (s, foldr go mempty decls)
74 where
75 go :: Declaration -> MultipleErrors -> MultipleErrors
76 go (PositionedDeclaration _ _ d') errs = go d' errs
77 go (TypeDeclaration op@(Op _) _) errs = errorMessage (ClassOperator name op) <> errs
78 go _ errs = errs
79 stepD s _ = (s, mempty)
81 stepE :: S.Set Ident -> Expr -> (S.Set Ident, MultipleErrors)
82 stepE s (Abs (Left name) _) = bindName s name
83 stepE s (Let ds' _) =
84 case mapAccumL bindName s (nub (mapMaybe getDeclIdent ds')) of
85 (s', es) -> (s', mconcat es)
86 stepE s _ = (s, mempty)
88 stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors)
89 stepB s (VarBinder name) = bindName s name
90 stepB s (NamedBinder name _) = bindName s name
91 stepB s (TypedBinder _ b) = stepB s b
92 stepB s _ = (s, mempty)
94 bindName :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)
95 bindName = bind ShadowedName
97 checkTypeVarsInDecl :: Declaration -> MultipleErrors
98 checkTypeVarsInDecl d = let (f, _, _, _, _) = accumTypes checkTypeVars in f d
100 checkTypeVars :: Type -> MultipleErrors
101 checkTypeVars ty = everythingWithContextOnTypes S.empty mempty mappend step ty <> findUnused ty
102 where
103 step :: S.Set String -> Type -> (S.Set String, MultipleErrors)
104 step s (ForAll tv _ _) = bindVar s tv
105 step s _ = (s, mempty)
106 bindVar :: S.Set String -> String -> (S.Set String, MultipleErrors)
107 bindVar = bind ShadowedTypeVar
108 findUnused :: Type -> MultipleErrors
109 findUnused ty' =
110 let used = usedTypeVariables ty'
111 declared = everythingOnTypes (++) go ty'
112 unused = nub declared \\ nub used
113 in foldl (<>) mempty $ map (errorMessage . UnusedTypeVar) unused
114 where
115 go :: Type -> [String]
116 go (ForAll tv _ _) = [tv]
117 go _ = []
119 bind :: (Ord a) => (a -> SimpleErrorMessage) -> S.Set a -> a -> (S.Set a, MultipleErrors)
120 bind mkError s name | name `S.member` s = (s, errorMessage (mkError name))
121 | otherwise = (S.insert name s, mempty)