git.iko.soy/rowtype-yoga/purescript-native
on 0f9d2f7 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Linter.hs
88 lines 3.3 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Language.PureScript.Linter
4-- Copyright : (c) Copyright 2015 PureScript
5-- License : 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 #-}
19module Language.PureScript.Linter (lint, module L) where
21import Data.List (mapAccumL, nub)
22import Data.Maybe (mapMaybe)
23import Data.Monoid
25import qualified Data.Set as S
27import Control.Applicative
28import Control.Monad.Writer.Class
30import Language.PureScript.AST
31import Language.PureScript.Names
32import Language.PureScript.Errors
33import Language.PureScript.Linter.Exhaustive as L
35-- | Lint the PureScript AST.
36-- |
37-- | Right now, this pass only performs a shadowing check.
38lint :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Module -> m ()
39lint (Module _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ lintDeclaration ds
40 where
41 moduleNames :: S.Set Ident
42 moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))
44 getDeclIdent :: Declaration -> Maybe Ident
45 getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d
46 getDeclIdent (ValueDeclaration ident _ _ _) = Just ident
47 getDeclIdent (ExternDeclaration ident _) = Just ident
48 getDeclIdent (ExternInstanceDeclaration ident _ _ _) = Just ident
49 getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident
50 getDeclIdent (BindingGroupDeclaration _) = error "lint: binding groups should not be desugared yet."
51 getDeclIdent _ = Nothing
53 lintDeclaration :: Declaration -> m ()
54 lintDeclaration d =
55 let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend stepD stepE stepB def def
57 f' :: Declaration -> MultipleErrors
58 f' (PositionedDeclaration pos _ dec) = onErrorMessages (PositionedError pos) (f' dec)
59 f' dec = f dec
61 in tell (f' d)
62 where
63 def s _ = (s, mempty)
65 stepD :: S.Set Ident -> Declaration -> (S.Set Ident, MultipleErrors)
66 stepD s (TypeClassDeclaration name _ _ decls) = (s, foldr go mempty decls)
67 where
68 go :: Declaration -> MultipleErrors -> MultipleErrors
69 go (PositionedDeclaration _ _ d') errs = go d' errs
70 go (TypeDeclaration op@(Op _) _) errs = errorMessage (ClassOperator name op) <> errs
71 go _ errs = errs
72 stepD s _ = (s, mempty)
74 stepE :: S.Set Ident -> Expr -> (S.Set Ident, MultipleErrors)
75 stepE s (Abs (Left name) _) = bind s name
76 stepE s (Let ds' _) =
77 case mapAccumL bind s (nub (mapMaybe getDeclIdent ds')) of
78 (s', es) -> (s', mconcat es)
79 stepE s _ = (s, mempty)
81 stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors)
82 stepB s (VarBinder name) = bind s name
83 stepB s (NamedBinder name _) = bind s name
84 stepB s _ = (s, mempty)
86 bind :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)
87 bind s name | name `S.member` s = (s, errorMessage (ShadowedName name))
88 | otherwise = (S.insert name s, mempty)