git.iko.soy/rowtype-yoga/purescript-native
on 7b5ab61 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Linter.hs
73 lines 2.6 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) 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
34-- | Lint the PureScript AST.
35-- |
36-- | Right now, this pass only performs a shadowing check.
37lint :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Module -> m ()
38lint (Module _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ lintDeclaration ds
39 where
40 moduleNames :: S.Set Ident
41 moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))
43 getDeclIdent :: Declaration -> Maybe Ident
44 getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d
45 getDeclIdent (ValueDeclaration ident _ _ _) = Just ident
46 getDeclIdent (ExternDeclaration ident _) = Just ident
47 getDeclIdent (ExternInstanceDeclaration ident _ _ _) = Just ident
48 getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident
49 getDeclIdent (BindingGroupDeclaration _) = error "lint: binding groups should not be desugared yet."
50 getDeclIdent _ = Nothing
52 lintDeclaration :: Declaration -> m ()
53 lintDeclaration d =
54 let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend def stepE stepB def def
55 in tell (f d)
56 where
57 def s _ = (s, mempty)
59 stepE :: S.Set Ident -> Expr -> (S.Set Ident, MultipleErrors)
60 stepE s (Abs (Left name) _) = bind s name
61 stepE s (Let ds' _) =
62 case mapAccumL bind s (nub (mapMaybe getDeclIdent ds')) of
63 (s', es) -> (s', mconcat es)
64 stepE s _ = (s, mempty)
66 stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors)
67 stepB s (VarBinder name) = bind s name
68 stepB s (NamedBinder name _) = bind s name
69 stepB s _ = (s, mempty)
71 bind :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)
72 bind s name | name `S.member` s = (s, errorMessage (ShadowedName name))
73 | otherwise = (S.insert name s, mempty)