dccc7af · rowtype-yoga/purescript-native

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

Merge pull request #1684 from purescript/class-ref-keyword

Introduce class keyword for refs, allow type refs without ()

commitdccc7af4240a0b795ac711dc9c03a4dd71993ca0 authorGary Burgess <gary.burgess@gmail.com> dateSat 5 Dec 2015, 22:32 (11 years ago) parent4579b16 0e0c37b

11 files changed+210−165

compare with golang

unifiedsplit

examples/passing/ClassRefSyntax.purs+13 examples/passing/TypeWithoutParens.purs+16 psci/PSCi.hs+9−20 src/Language/PureScript/AST/Declarations.hs+10−15 src/Language/PureScript/AST/Exported.hs+3 src/Language/PureScript/Errors.hs+27−16 src/Language/PureScript/Linter/Imports.hs+5−4 src/Language/PureScript/Parser/Declarations.hs+11−25 src/Language/PureScript/Sugar/Names.hs+37−23 src/Language/PureScript/Sugar/Names/Env.hs+5−13 src/Language/PureScript/Sugar/Names/Imports.hs+74−49

examples/passing/ClassRefSyntax.pursnew file+13

@@ -0,0 +1,13 @@

1+module Lib (class X, go) where

3+ class X a where

4+ go :: a -> a

6+module Main where

8+ import Lib (class X, go)

10+ go' :: forall a. (X a) => a -> a

11+ go' = go

12+

13+ main = Control.Monad.Eff.Console.log "Done"

examples/passing/TypeWithoutParens.pursnew file+16

@@ -0,0 +1,16 @@

1+module Lib (X, Y) where

3+ data X = X

4+ type Y = X

6+module Main where

8+ import Lib (X, Y)

10+ idX :: X -> X

11+ idX x = x

12+

13+ idY :: Y -> Y

14+ idY y = y

15+

16+ main = Control.Monad.Eff.Console.log "Done"

psci/PSCi.hs+9−20

@@ -1,23 +1,11 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : PSCi

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- PureScript Compiler Interactive.

13−--

14−-----------------------------------------------------------------------------

15−

161{-# LANGUAGE DoAndIfThenElse #-}

172{-# LANGUAGE GeneralizedNewtypeDeriving #-}

183{-# LANGUAGE RecordWildCards #-}

194{-# LANGUAGE TupleSections #-}

205

6+-- |

7+-- PureScript Compiler Interactive.

8+--

219module PSCi where

2210

2311import Prelude ()

@@ -333,11 +321,12 @@ handleShowImportedModules = do

333321 refsList refs = "(" ++ commaList (map showRef refs) ++ ")"

334322

335323 showRef :: P.DeclarationRef -> String

336− showRef (P.TypeRef pn dctors) = show pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"

337− showRef (P.ValueRef ident) = show ident

338− showRef (P.TypeClassRef pn) = show pn

339− showRef (P.TypeInstanceRef ident) = show ident

340− showRef (P.ModuleRef name) = "module " ++ show name

324+ showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"

325+ showRef (P.ValueRef ident) = N.runIdent ident

326+ showRef (P.TypeClassRef pn) = N.runProperName pn

327+ showRef (P.ProperRef pn) = N.runProperName pn

328+ showRef (P.TypeInstanceRef ident) = N.runIdent ident

329+ showRef (P.ModuleRef name) = "module " ++ N.runModuleName name

341330 showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref

342331

343332 commaList :: [String] -> String

src/Language/PureScript/AST/Declarations.hs+10−15

@@ -1,22 +1,11 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.AST.Declarations

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | Data types for modules and declarations

12−--

13−-----------------------------------------------------------------------------

14−

151{-# LANGUAGE DeriveDataTypeable #-}

162{-# LANGUAGE ScopedTypeVariables #-}

173{-# LANGUAGE TemplateHaskell #-}

184{-# LANGUAGE LambdaCase #-}

195

6+-- |

7+-- Data types for modules and declarations

8+--

209module Language.PureScript.AST.Declarations where

2110

2211import Prelude ()

@@ -77,6 +66,10 @@ data DeclarationRef

7766 --

7867 | ModuleRef ModuleName

7968 -- |

69+ -- An unspecified ProperName ref. This will be replaced with a TypeClassRef

70+ -- or TypeRef during name desugaring.

71+ | ProperRef ProperName

72+ -- |

8073 -- A declaration reference with source position information

8174 --

8275 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

@@ -87,12 +80,14 @@ instance Eq DeclarationRef where

8780 (ValueRef name) == (ValueRef name') = name == name'

8881 (TypeClassRef name) == (TypeClassRef name') = name == name'

8982 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

90− (ModuleRef name) == (ModuleRef name') = name == name'

83+ (ModuleRef name) == (ModuleRef name') = name == name'

84+ (ProperRef name) == (ProperRef name') = name == name'

9185 (PositionedDeclarationRef _ _ r) == r' = r == r'

9286 r == (PositionedDeclarationRef _ _ r') = r == r'

9387 _ == _ = False

9488

9589isModuleRef :: DeclarationRef -> Bool

90+isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r

9691isModuleRef (ModuleRef _) = True

9792isModuleRef _ = False

9893

src/Language/PureScript/AST/Exported.hs+3

@@ -118,6 +118,9 @@ isExported (Just exps) decl = any (matches decl) exps

118118 matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'

119119 matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'

120120

121+ matches (DataDeclaration _ ident _ _) (ProperRef ident') = ident == ident'

122+ matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = ident == ident'

123+

121124 matches (PositionedDeclaration _ _ d) r = d `matches` r

122125 matches d (PositionedDeclarationRef _ _ r) = d `matches` r

123126 matches _ _ = False

src/Language/PureScript/Errors.hs+27−16

@@ -1,17 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Error

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−--

13−-----------------------------------------------------------------------------

14−

151{-# LANGUAGE GeneralizedNewtypeDeriving #-}

162{-# LANGUAGE FlexibleContexts #-}

173{-# LANGUAGE RecordWildCards #-}

@@ -143,6 +129,8 @@ data SimpleErrorMessage

143129 | UnusedDctorImport ProperName

144130 | UnusedDctorExplicitImport ProperName [ProperName]

145131 | DeprecatedQualifiedSyntax ModuleName ModuleName

132+ | DeprecatedClassImport ModuleName ProperName

133+ | DeprecatedClassExport ProperName

146134 | RedundantUnqualifiedImport ModuleName ImportDeclarationType

147135 | DuplicateSelectiveImport ModuleName

148136 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

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

285273 UnusedDctorImport{} -> "UnusedDctorImport"

286274 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

287275 DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"

276+ DeprecatedClassImport{} -> "DeprecatedClassImport"

277+ DeprecatedClassExport{} -> "DeprecatedClassExport"

288278 RedundantUnqualifiedImport{} -> "RedundantUnqualifiedImport"

289279 DuplicateSelectiveImport{} -> "DuplicateSelectiveImport"

290280 DuplicateImport{} -> "DuplicateImport"

@@ -784,8 +774,28 @@ prettyPrintSingleError full level e = do

784774 , indent $ paras $ map (line .runProperName) names ]

785775

786776 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =

787− paras [ line $ "The import of type " ++ runModuleName name ++ " as " ++ runModuleName qualName ++ " uses the deprecated 'import qualified' syntax."

788− , line $ "This syntax form will be removed in PureScript 0.9." ]

777+ paras [ line $ "Import uses the deprecated 'qualified' syntax:"

778+ , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName

779+ , line "Should instead use the form:"

780+ , indent $ line $ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName

781+ , line $ "The deprecated syntax will be removed in PureScript 0.9."

782+ ]

783+

784+ renderSimpleErrorMessage (DeprecatedClassImport mn name) =

785+ paras [ line $ "Class import from " ++ runModuleName mn ++ " uses deprecated syntax that omits the 'class' keyword:"

786+ , indent $ line $ runProperName name

787+ , line "Should instead use the form:"

788+ , indent $ line $ "class " ++ runProperName name

789+ , line $ "The deprecated syntax will be removed in PureScript 0.9."

790+ ]

791+

792+ renderSimpleErrorMessage (DeprecatedClassExport name) =

793+ paras [ line $ "Class export uses deprecated syntax that omits the 'class' keyword:"

794+ , indent $ line $ runProperName name

795+ , line "Should instead use the form:"

796+ , indent $ line $ "class " ++ runProperName name

797+ , line $ "The deprecated syntax will be removed in PureScript 0.9."

798+ ]

789799

790800 renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) =

791801 line $ "Import of " ++ prettyPrintImport name imp Nothing ++ " is redundant due to a whole-module import"

@@ -947,6 +957,7 @@ prettyPrintSingleError full level e = do

947957 prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"

948958 prettyPrintRef (ValueRef ident) = showIdent ident

949959 prettyPrintRef (TypeClassRef pn) = runProperName pn

960+ prettyPrintRef (ProperRef pn) = runProperName pn

950961 prettyPrintRef (TypeInstanceRef ident) = showIdent ident

951962 prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name

952963 prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

src/Language/PureScript/Linter/Imports.hs+5−4

@@ -11,7 +11,7 @@ import Data.Maybe (mapMaybe)

1111import Data.List ((\\), find, intersect, nub)

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

1313import Control.Monad.Writer.Class

14−import Control.Monad(unless,when)

14+import Control.Monad (unless,when)

1515import Data.Foldable (forM_)

1616

1717import Language.PureScript.AST.Declarations

@@ -78,10 +78,11 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do

7878

7979 -- rely on exports being elaborated by this point

8080 alwaysUsedModules :: [ ModuleName ]

81− alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe isExport) mexports

81+ alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe extractModule) mexports

8282 where

83− isExport (ModuleRef mn) = Just mn

84− isExport _ = Nothing

83+ extractModule (PositionedDeclarationRef _ _ r) = extractModule r

84+ extractModule (ModuleRef mn) = Just mn

85+ extractModule _ = Nothing

8586

8687 qnameUsed :: Maybe ModuleName -> Bool

8788 qnameUsed (Just qn) = qn `elem` alwaysUsedModules

src/Language/PureScript/Parser/Declarations.hs+11−25

@@ -1,22 +1,10 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Parser.Declarations

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- Parsers for module definitions and declarations

13−--

14−-----------------------------------------------------------------------------

15−

161{-# LANGUAGE FlexibleContexts #-}

172{-# LANGUAGE ScopedTypeVariables #-}

183{-# LANGUAGE TupleSections #-}

194

5+-- |

6+-- Parsers for module definitions and declarations

7+--

208module Language.PureScript.Parser.Declarations (

219 parseDeclaration,

2210 parseModule,

@@ -170,18 +158,16 @@ parseImportDeclaration' = do

170158

171159parseDeclarationRef :: TokenParser DeclarationRef

172160parseDeclarationRef =

173− parseModuleRef <|>

174161 withSourceSpan PositionedDeclarationRef

175− (ValueRef <$> parseIdent

176− <|> do name <- properName

177− dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)

178− return $ maybe (TypeClassRef name) (TypeRef name) dctors

179− )

162+ $ (ValueRef <$> parseIdent)

163+ <|> parseProperRef

164+ <|> (TypeClassRef <$> (reserved "class" *> properName))

165+ <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName))

180166 where

181− parseModuleRef :: TokenParser DeclarationRef

182− parseModuleRef = do

183− name <- indented *> reserved "module" *> moduleName

184− return $ ModuleRef name

167+ parseProperRef = do

168+ name <- properName

169+ dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)

170+ return $ maybe (ProperRef name) (TypeRef name) dctors

185171

186172parseTypeClassDeclaration :: TokenParser Declaration

187173parseTypeClassDeclaration = do

src/Language/PureScript/Sugar/Names.hs+37−23

@@ -1,16 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Sugar.Names

4−-- License : MIT (http://opensource.org/licenses/MIT)

5−--

6−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

7−-- Stability : experimental

8−-- Portability :

9−--

10−-- |

11−--

12−-----------------------------------------------------------------------------

13−

141{-# LANGUAGE FlexibleContexts #-}

152{-# LANGUAGE RecordWildCards #-}

163{-# LANGUAGE ScopedTypeVariables #-}

@@ -49,8 +36,9 @@ import Language.PureScript.Linter.Imports

4936desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

5037desugarImports externs modules = do

5138 env <- silence $ foldM externsEnv primEnv externs

52− env' <- foldM updateEnv env modules

53− traverse (renameInModule' env') modules

39+ modules' <- traverse updateExportRefs modules

40+ (modules'', env') <- foldM updateEnv ([], env) modules'

41+ traverse (renameInModule' env') modules''

5442 where

5543 silence :: m a -> m a

5644 silence = censor (const mempty)

@@ -90,16 +78,16 @@ desugarImports externs modules = do

9078 toExportedValue (PositionedDeclarationRef _ _ r) = toExportedValue r

9179 toExportedValue _ = Nothing

9280

93− updateEnv :: Env -> Module -> m Env

94− updateEnv env m@(Module ss _ mn _ refs) =

81+ updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)

82+ updateEnv (ms, env) m@(Module ss _ mn _ refs) =

9583 case mn `M.lookup` env of

9684 Just m' -> throwError . errorMessage $ RedefinedModule mn [envModuleSourceSpan m', ss]

9785 Nothing -> do

9886 members <- findExportable m

9987 let env' = M.insert mn (ss, nullImports, members) env

100− imps <- resolveImports env' m

88+ (m', imps) <- resolveImports env' m

10189 exps <- maybe (return members) (resolveExports env' mn imps members) refs

102− return $ M.insert mn (ss, imps, exps) env

90+ return (m' : ms, M.insert mn (ss, imps, exps) env)

10391

10492 renameInModule' :: Env -> Module -> m Module

10593 renameInModule' env m@(Module _ _ mn _ _) =

@@ -262,7 +250,7 @@ renameInModule env imports (Module ss coms mn decls exps) =

262250 -- by qualified importing). If that's not the case, then we just need to

263251 -- check it refers to a symbol in another module.

264252 (Nothing, Just mn'') -> do

265− modExports <- getExports mn''

253+ modExports <- getExports env mn''

266254 maybe (throwError . errorMessage $ unknown qname) return (getE modExports name)

267255 -- If neither of the above cases are true then it's an undefined or

268256 -- unimported symbol.

@@ -272,6 +260,32 @@ renameInModule env imports (Module ss coms mn decls exps) =

272260 Nothing -> err

273261 Just pos' -> rethrowWithPosition pos' err

274262

275− -- Gets the exports for a module, or an error message if the module doesn't exist

276− getExports :: ModuleName -> m Exports

277− getExports mn' = maybe (throwError . errorMessage $ UnknownModule mn') (return . envModuleExports) $ M.lookup mn' env

263+-- |

264+-- Replaces `ProperRef` export values with a `TypeRef` or `TypeClassRef`

265+-- depending on what is availble within the module. Warns when a `ProperRef`

266+-- desugars into a `TypeClassRef`.

267+--

268+updateExportRefs :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> m Module

269+updateExportRefs (Module ss coms mn decls exps) =

270+ Module ss coms mn decls <$> traverse (traverse updateRef) exps

271+ where

272+

273+ updateRef :: DeclarationRef -> m DeclarationRef

274+ updateRef (ProperRef name)

275+ | name `elem` classNames = do

276+ tell . errorMessage $ DeprecatedClassExport name

277+ return $ TypeClassRef name

278+ -- Fall through case here - assume it's a type if it's not a class.

279+ -- If it's a reference to something that doesn't actually exist it will

280+ -- be picked up elsewhere

281+ | otherwise = return $ TypeRef name (Just [])

282+ updateRef (PositionedDeclarationRef pos com ref) =

283+ warnWithPosition pos $ PositionedDeclarationRef pos com <$> updateRef ref

284+ updateRef other = return other

285+

286+ classNames :: [ProperName]

287+ classNames = mapMaybe go decls

288+ where

289+ go (PositionedDeclaration _ _ d) = go d

290+ go (TypeClassDeclaration name _ _ _) = Just name

291+ go _ = Nothing

src/Language/PureScript/Sugar/Names/Env.hs+5−13

@@ -1,16 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Sugar.Names.Env

4−-- License : MIT (http://opensource.org/licenses/MIT)

5−--

6−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

7−-- Stability : experimental

8−-- Portability :

9−--

10−-- |

11−--

12−-----------------------------------------------------------------------------

13−

141{-# LANGUAGE FlexibleContexts #-}

152

163module Language.PureScript.Sugar.Names.Env

@@ -26,6 +13,7 @@ module Language.PureScript.Sugar.Names.Env

2613 , exportType

2714 , exportTypeClass

2815 , exportValue

16+ , getExports

2917 ) where

3018

3119import qualified Data.Map as M

@@ -189,3 +177,7 @@ addExport what name mn exports =

189177--

190178throwConflictError :: (MonadError MultipleErrors m) => (a -> SimpleErrorMessage) -> a -> m b

191179throwConflictError conflict = throwError . errorMessage . conflict

180+

181+-- Gets the exports for a module, or an error message if the module doesn't exist

182+getExports :: (MonadError MultipleErrors m) => Env -> ModuleName -> m Exports

183+getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ M.lookup mn env

src/Language/PureScript/Sugar/Names/Imports.hs+74−49

@@ -1,16 +1,3 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Sugar.Names.Imports

4−-- License : MIT (http://opensource.org/licenses/MIT)

5−--

6−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

7−-- Stability : experimental

8−-- Portability :

9−--

10−-- |

11−--

12−-----------------------------------------------------------------------------

13−

141{-# LANGUAGE FlexibleContexts #-}

152{-# LANGUAGE ScopedTypeVariables #-}

163{-# LANGUAGE TupleSections #-}

@@ -47,34 +34,36 @@ import Language.PureScript.Sugar.Names.Env

4734-- Finds the imports within a module, mapping the imported module name to an optional set of

4835-- explicitly imported declarations.

4936--

50−findImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Declaration] -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])

37+findImports

38+ :: forall m

39+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

40+ => [Declaration]

41+ -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])

5142findImports = foldM (go Nothing) M.empty

5243 where

5344 go pos result (ImportDeclaration mn typ qual isOldSyntax) = do

5445 when isOldSyntax . tell . errorMessage $ DeprecatedQualifiedSyntax mn (fromJust qual)

55− checkImportRefType typ

5646 let imp = (pos, typ, qual)

5747 return $ M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result

5848 go _ result (PositionedDeclaration pos _ d) = warnAndRethrowWithPosition pos $ go (Just pos) result d

5949 go _ result _ = return result

6050

61− -- Ensure that modules don't appear in an `import X hiding (...)`

62− checkImportRefType :: ImportDeclarationType -> m ()

63− checkImportRefType (Hiding refs) = traverse_ checkImportRef refs

64− checkImportRefType _ = return ()

65− checkImportRef :: DeclarationRef -> m ()

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

67− checkImportRef _ = return ()

68−

6951type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)

7052

7153-- |

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

7355--

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

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

56+resolveImports

57+ :: forall m

58+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

59+ => Env

60+ -> Module

61+ -> m (Module, Imports)

62+resolveImports env (Module ss coms currentModule decls exps) =

7663 warnAndRethrow (addHint (ErrorInModule currentModule)) $ do

77− imports <- findImports decls

64+

65+ decls' <- traverse updateImportRef decls

66+ imports <- findImports decls'

7867

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

8069

@@ -110,7 +99,8 @@ resolveImports env (Module _ _ currentModule decls _) =

11099 return ()

111100

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

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

102+ resolved <- foldM (resolveModuleImport currentModule env) nullImports (M.toList scope)

103+ return (Module ss coms currentModule decls' exps, resolved)

114104

115105 where

116106 selfCartesianSubset :: [a] -> [(a, a)]

@@ -142,12 +132,38 @@ resolveImports env (Module _ _ currentModule decls _) =

142132 warn :: Maybe SourceSpan -> SimpleErrorMessage -> m ()

143133 warn pos msg = maybe id warnWithPosition pos $ tell . errorMessage $ msg

144134

135+ updateImportRef :: Declaration -> m Declaration

136+ updateImportRef (PositionedDeclaration pos com d) =

137+ warnWithPosition pos $ PositionedDeclaration pos com <$> updateImportRef d

138+ updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do

139+ modExports <- getExports env mn

140+ typ' <- case typ of

141+ Implicit -> return Implicit

142+ Explicit refs -> Explicit <$> updateProperRef mn modExports `traverse` refs

143+ Hiding refs -> Hiding <$> updateProperRef mn modExports `traverse` refs

144+ return $ ImportDeclaration mn typ' qual isOldSyntax

145+ updateImportRef other = return other

146+

147+ updateProperRef :: ModuleName -> Exports -> DeclarationRef -> m DeclarationRef

148+ updateProperRef importModule modExports (ProperRef name) =

149+ if name `elem` (fst `map` exportedTypeClasses modExports)

150+ then do

151+ tell . errorMessage $ DeprecatedClassImport importModule name

152+ return $ TypeClassRef name

153+ else return $ TypeRef name (Just [])

154+ updateProperRef importModule modExports (PositionedDeclarationRef pos com ref) =

155+ PositionedDeclarationRef pos com <$> updateProperRef importModule modExports ref

156+ updateProperRef _ _ other = return other

157+

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

146−resolveModuleImport ::

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

148− ModuleName -> Env -> Imports ->

149− (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) ->

150− m Imports

159+resolveModuleImport

160+ :: forall m

161+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

162+ => ModuleName

163+ -> Env

164+ -> Imports

165+ -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])

166+ -> m Imports

151167resolveModuleImport currentModule env ie (mn, imps) = foldM go ie imps

152168 where

153169 go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports

@@ -163,17 +179,24 @@ resolveModuleImport currentModule env ie (mn, imps) = foldM go ie imps

163179-- |

164180-- Extends the local environment for a module by resolving an import of another module.

165181--

166−resolveImport :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> ModuleName -> Exports -> Imports -> Maybe ModuleName -> ImportDeclarationType -> m Imports

167−resolveImport currentModule importModule exps imps impQual =

168− resolveByType

182+resolveImport

183+ :: forall m

184+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

185+ => ModuleName

186+ -> ModuleName

187+ -> Exports

188+ -> Imports

189+ -> Maybe ModuleName

190+ -> ImportDeclarationType

191+ -> m Imports

192+resolveImport currentModule importModule exps imps impQual = resolveByType

169193 where

170194

171195 resolveByType :: ImportDeclarationType -> m Imports

172196 resolveByType Implicit = importAll importExplicit

173− resolveByType (Explicit explImports) = checkRefs explImports >> foldM importExplicit imps explImports

174− resolveByType (Hiding hiddenImports) = do

175− checkRefs hiddenImports

176− imps' <- importAll (importNonHidden hiddenImports)

197+ resolveByType (Explicit refs) = checkRefs False refs >> foldM importExplicit imps refs

198+ resolveByType (Hiding refs) = do

199+ imps' <- checkRefs True refs >> importAll (importNonHidden refs)

177200 let isEmptyImport

178201 = M.null (importedTypes imps')

179202 && M.null (importedDataConstructors imps')

@@ -183,8 +206,8 @@ resolveImport currentModule importModule exps imps impQual =

183206 return imps'

184207

185208 -- Check that a 'DeclarationRef' refers to an importable symbol

186− checkRefs :: [DeclarationRef] -> m ()

187− checkRefs = traverse_ check

209+ checkRefs :: Bool -> [DeclarationRef] -> m ()

210+ checkRefs isHiding = traverse_ check

188211 where

189212 check (PositionedDeclarationRef pos _ r) =

190213 rethrowWithPosition pos $ check r

@@ -196,9 +219,9 @@ resolveImport currentModule importModule exps imps impQual =

196219 maybe (return ()) (traverse_ $ checkDctorExists name allDctors) dctors

197220 check (TypeClassRef name) =

198221 checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name

199− --check (ModuleRef name) =

200− -- checkImportExists (const UnknownModule) (exportedModules exps) name

201− check _ = internalError "Invalid argument to checkRefs"

222+ check (ModuleRef name) | isHiding =

223+ throwError . errorMessage $ ImportHidingModule name

224+ check r = internalError $ "Invalid argument to checkRefs: " ++ show r

202225

203226 -- Check that an explicitly imported item exists in the module it is being imported from

204227 checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()

@@ -264,11 +287,13 @@ resolveImport currentModule importModule exps imps impQual =

264287 Just ((_, dctors), mn) -> map (, mn) dctors

265288

266289 -- Add something to the Imports if it does not already exist there

267− updateImports :: (Ord a) => M.Map (Qualified a) (Qualified a, ModuleName)

268− -> (a -> String)

269− -> [(a, ModuleName)]

270− -> a

271− -> m (M.Map (Qualified a) (Qualified a, ModuleName))

290+ updateImports

291+ :: (Ord a)

292+ => M.Map (Qualified a) (Qualified a, ModuleName)

293+ -> (a -> String)

294+ -> [(a, ModuleName)]

295+ -> a

296+ -> m (M.Map (Qualified a) (Qualified a, ModuleName))

272297 updateImports imps' render exps' name = case M.lookup (Qualified impQual name) imps' of

273298

274299 -- If the name is not already present add it to the list, after looking up