e96d7b6 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Warn on duplicate values in import lists

e96d7b6Gary Burgess11 years ago

src/Language/PureScript/AST/Declarations.hs+25

compare with golang

unifiedsplit

@@ -15,6 +15,7 @@

15{-# LANGUAGE DeriveDataTypeable #-}

16{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE TemplateHaskell #-}

18+{-# LANGUAGE LambdaCase #-}

19module Language.PureScript.AST.Declarations where

20module Language.PureScript.AST.Declarations where

@@ -22,6 +23,8 @@ import Prelude ()

22import Prelude.Compat

23import Prelude.Compat

24import Data.Aeson.TH

25import Data.Aeson.TH

26+import Data.List (nub, (\\))

27+import Data.Maybe (mapMaybe)

26import qualified Data.Data as D

29import qualified Data.Data as D

27import qualified Data.Map as M

30import qualified Data.Map as M

@@ -93,6 +96,28 @@ isModuleRef :: DeclarationRef -> Bool

93isModuleRef (ModuleRef _) = True

96isModuleRef (ModuleRef _) = True

94isModuleRef _ = False

97isModuleRef _ = False

99+-- |

100+-- Finds duplicate values in a list of declaration refs. The returned values

101+-- are the duplicate refs with data constructors elided, and then a separate

102+-- list of duplicate data constructors.

103+--

104+findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName])

105+findDuplicateRefs refs =

106+ let positionless = stripPosInfo `map` refs

107+ simplified = simplifyTypeRefs `map` positionless

108+ dupeRefs = nub $ simplified \\ nub simplified

109+ dupeCtors = concat $ flip mapMaybe positionless $ \case

110+ TypeRef _ (Just dctors) ->

111+ let dupes = dctors \\ nub dctors

112+ in if null dupes then Nothing else Just dupes

113+ _ -> Nothing

114+ in (dupeRefs, dupeCtors)

115+ where

116+ stripPosInfo (PositionedDeclarationRef _ _ ref) = stripPosInfo ref

117+ stripPosInfo other = other

118+ simplifyTypeRefs (TypeRef pn _) = TypeRef pn Nothing

119+ simplifyTypeRefs other = other

120+

96-- |

121-- |

97-- The data type which specifies type of import declaration

122-- The data type which specifies type of import declaration

98--

123--

src/Language/PureScript/Errors.hs+10

@@ -146,6 +146,8 @@ data SimpleErrorMessage

146 | RedundantUnqualifiedImport ModuleName ImportDeclarationType

147 | DuplicateSelectiveImport ModuleName

148 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

149+ | DuplicateImportRef String

150+ | DuplicateExportRef String

149 | IntOutOfRange Integer String Integer Integer

151 | IntOutOfRange Integer String Integer Integer

150 deriving (Show)

152 deriving (Show)

151

153

@@ -285,6 +287,8 @@ errorCode em = case unwrapErrorMessage em of

285 RedundantUnqualifiedImport{} -> "RedundantUnqualifiedImport"

287 RedundantUnqualifiedImport{} -> "RedundantUnqualifiedImport"

286 DuplicateSelectiveImport{} -> "DuplicateSelectiveImport"

288 DuplicateSelectiveImport{} -> "DuplicateSelectiveImport"

287 DuplicateImport{} -> "DuplicateImport"

289 DuplicateImport{} -> "DuplicateImport"

290+ DuplicateImportRef{} -> "DuplicateImportRef"

291+ DuplicateExportRef{} -> "DuplicateExportRef"

288 IntOutOfRange{} -> "IntOutOfRange"

292 IntOutOfRange{} -> "IntOutOfRange"

289

293

290

294

@@ -790,6 +794,12 @@ prettyPrintSingleError full level e = do

790 renderSimpleErrorMessage (DuplicateImport name imp qual) =

794 renderSimpleErrorMessage (DuplicateImport name imp qual) =

791 line $ "Duplicate import of " ++ prettyPrintImport name imp qual

795 line $ "Duplicate import of " ++ prettyPrintImport name imp qual

792

796

797+ renderSimpleErrorMessage (DuplicateImportRef ref) =

798+ line $ "Import list contains multiple references to " ++ ref

799+

800+ renderSimpleErrorMessage (DuplicateExportRef ref) =

801+ line $ "Export list contains multiple references to " ++ ref

802+

793 renderSimpleErrorMessage (IntOutOfRange value backend lo hi) =

803 renderSimpleErrorMessage (IntOutOfRange value backend lo hi) =

794 paras [ line $ "Integer value " ++ show value ++ " is out of range for the " ++ backend ++ " backend."

804 paras [ line $ "Integer value " ++ show value ++ " is out of range for the " ++ backend ++ " backend."

795 , line $ "Acceptable values fall within the range " ++ show lo ++ " to " ++ show hi ++ " (inclusive)." ]

805 , line $ "Acceptable values fall within the range " ++ show lo ++ " to " ++ show hi ++ " (inclusive)." ]

src/Language/PureScript/Linter/Imports.hs+2−2

@@ -8,7 +8,7 @@ import Prelude.Compat

9import qualified Data.Map as M

10import Data.Maybe (mapMaybe)

11−import Data.List ((\\), find, intersect)

11+import Data.List ((\\), find, intersect, nub)

12import Control.Monad.Error.Class (MonadError(..))

13import Control.Monad.Writer.Class

14import Control.Monad(unless,when)

@@ -50,7 +50,7 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do

50 in case declType of

51 Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni

52 Explicit declrefs -> do

53− let idents = mapMaybe runDeclRef declrefs

53+ let idents = nub (mapMaybe runDeclRef declrefs)

54 let diff = idents \\ usedNames

55 case (length diff, length idents) of

56 (0, _) -> return ()

src/Language/PureScript/Sugar/Names/Imports.hs+58−16

@@ -14,6 +14,7 @@

14{-# LANGUAGE FlexibleContexts #-}

15{-# LANGUAGE ScopedTypeVariables #-}

16{-# LANGUAGE TupleSections #-}

17+{-# LANGUAGE LambdaCase #-}

18module Language.PureScript.Sugar.Names.Imports

19module Language.PureScript.Sugar.Names.Imports

19 ( resolveImports

20 ( resolveImports

@@ -24,9 +25,10 @@ module Language.PureScript.Sugar.Names.Imports

24import Prelude ()

25import Prelude ()

25import Prelude.Compat

26import Prelude.Compat

27−import Data.List (find, delete)

28+import Data.List (find, delete, (\\))

28import Data.Maybe (fromMaybe, isJust, isNothing, fromJust)

29import Data.Maybe (fromMaybe, isJust, isNothing, fromJust)

29import Data.Foldable (traverse_, for_)

30import Data.Foldable (traverse_, for_)

31+import Data.Traversable (for)

31import Control.Arrow (first)

33import Control.Arrow (first)

32import Control.Monad

34import Control.Monad

@@ -64,33 +66,48 @@ findImports = foldM (go Nothing) M.empty

64 checkImportRef (ModuleRef name) = throwError . errorMessage $ ImportHidingModule name

66 checkImportRef (ModuleRef name) = throwError . errorMessage $ ImportHidingModule name

65 checkImportRef _ = return ()

67 checkImportRef _ = return ()

69+type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)

70+

67-- |

71-- |

68-- Constructs a set of imports for a module.

72-- Constructs a set of imports for a module.

69--

73--

70−resolveImports :: (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports

74+resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports

71resolveImports env (Module _ _ currentModule decls _) =

75resolveImports env (Module _ _ currentModule decls _) =

72 warnAndRethrow (addHint (ErrorInModule currentModule)) $ do

76 warnAndRethrow (addHint (ErrorInModule currentModule)) $ do

73 imports <- findImports decls

77 imports <- findImports decls

75 for_ (M.toList imports) $ \(mn, imps) -> do

79 for_ (M.toList imports) $ \(mn, imps) -> do

76− let unqual = filter (\(_, _, q) -> isJust q) (reverse imps)

81+ -- Better ordering for the warnings: the list is in last-import-first

82+ -- order, but we want the first appearence of an import to be the primary,

83+ -- and warnings to appear for later imports

84+ let imps' = reverse imps

85+

78− when (length imps > 1) $ for_ (selfCartesianSubset imps) $

86+ warned <- foldM (checkDuplicateImports mn) [] (selfCartesianSubset imps')

79− \((_, t1, q1), (pos, t2, q2)) ->

87+

80− when (t1 == t2 && q1 == q2) $

88+ let unqual = filter (\(_, _, q) -> isJust q) (imps' \\ warned)

81− maybe id warnWithPosition pos $

82− tell . errorMessage $ DuplicateImport mn t2 q2

90+ warned' <- (warned ++) <$>

84− when (length unqual > 1) $

91+ if (length unqual < 2)

92+ then return []

85− case find (\(_, typ, _) -> typ == Implicit) unqual of

93+ else case find (\(_, typ, _) -> typ == Implicit) unqual of

86 Just i ->

94 Just i ->

87− for_ (delete i unqual) $ \(pos, typ, _) ->

95+ for (delete i unqual) $ \i'@(pos, typ, _) -> do

88− maybe id warnWithPosition pos $

89− tell $ errorMessage $ RedundantUnqualifiedImport mn typ

96+ warn pos $ RedundantUnqualifiedImport mn typ

97+ return i'

90 Nothing ->

98 Nothing ->

91− for_ (tail unqual) $ \(pos, _, _) ->

99+ for (tail unqual) $ \i@(pos, _, _) -> do

92− maybe id warnWithPosition pos $

93− tell $ errorMessage $ DuplicateSelectiveImport mn

100+ warn pos $ DuplicateSelectiveImport mn

101+ return i

102+

103+ for_ (imps' \\ warned') $ \(pos, typ, _) ->

104+ let (dupeRefs, dupeDctors) = findDuplicateRefs $ case typ of

105+ Explicit refs -> refs

106+ Hiding refs -> refs

107+ _ -> []

108+ in warnDupeRefs pos dupeRefs >> warnDupeDctors pos dupeDctors

109+

110+ return ()

111

95 let scope = M.insert currentModule [(Nothing, Implicit, Nothing)] imports

112 let scope = M.insert currentModule [(Nothing, Implicit, Nothing)] imports

96 foldM (resolveModuleImport currentModule env) nullImports (M.toList scope)

113 foldM (resolveModuleImport currentModule env) nullImports (M.toList scope)

@@ -100,6 +117,31 @@ resolveImports env (Module _ _ currentModule decls _) =

100 selfCartesianSubset (x : xs) = [(x, y) | y <- xs] ++ selfCartesianSubset xs

117 selfCartesianSubset (x : xs) = [(x, y) | y <- xs] ++ selfCartesianSubset xs

101 selfCartesianSubset [] = []

118 selfCartesianSubset [] = []

102

119

120+ checkDuplicateImports :: ModuleName -> [ImportDef] -> (ImportDef, ImportDef) -> m [ImportDef]

121+ checkDuplicateImports mn xs ((_, t1, q1), (pos, t2, q2)) =

122+ if (t1 == t2 && q1 == q2)

123+ then do

124+ warn pos $ DuplicateImport mn t2 q2

125+ return $ (pos, t2, q2) : xs

126+ else return xs

127+

128+ warnDupeRefs :: Maybe SourceSpan -> [DeclarationRef] -> m ()

129+ warnDupeRefs pos = traverse_ $ \case

130+ TypeRef name _ -> warnDupe pos $ "type " ++ runProperName name

131+ ValueRef name -> warnDupe pos $ "value " ++ runIdent name

132+ TypeClassRef name -> warnDupe pos $ "class " ++ runProperName name

133+ ModuleRef name -> warnDupe pos $ "module " ++ runModuleName name

134+ _ -> return ()

135+

136+ warnDupeDctors :: Maybe SourceSpan -> [ProperName] -> m ()

137+ warnDupeDctors pos = traverse_ (warnDupe pos . ("data constructor " ++) . runProperName)

138+

139+ warnDupe :: Maybe SourceSpan -> String -> m ()

140+ warnDupe pos ref = warn pos $ DuplicateImportRef ref

141+

142+ warn :: Maybe SourceSpan -> SimpleErrorMessage -> m ()

143+ warn pos msg = maybe id warnWithPosition pos $ tell . errorMessage $ msg

144+

103-- | Constructs a set of imports for a single module import.

145-- | Constructs a set of imports for a single module import.

104resolveModuleImport ::

146resolveModuleImport ::

105 forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

147 forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>