4c6c6db · rowtype-yoga/purescript-native

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

on golang help sign in

Better re-export handling

4c6c6dbGary Burgess11 years ago

examples/failing/ImportHidingModule.pursnew file+10

compare with golang

unifiedsplit

@@ -0,0 +1,10 @@

1+-- @shouldFailWith ImportHidingModule

2+module A where

3+ x = 1

5+module B (module B, module A) where

6+ import A

7+ y = 1

9+module C where

10+ import B hiding (module A)

examples/failing/OverlappingReExport.pursnew file+10

@@ -0,0 +1,10 @@

1+-- @shouldFailWith DuplicateValueExport

2+module A where

3+ x = true

5+module B where

6+ x = false

8+module C (module A, module M2) where

9+ import A

10+ import qualified B as M2

examples/passing/ModuleExportHiding.pursdeleted−11

@@ -1,11 +0,0 @@

1−module A (module Prelude) where

2− import Prelude

3−

4−module Main where

5− import Control.Monad.Eff.Console

6− import A hiding (module Prelude)

7−

8− otherwise = false

9−

10− main = do

11− print "1.0"

examples/passing/ReExportQualified.pursnew file+16

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

1+module A where

2+ x = "Do"

4+module B where

5+ y = "ne"

7+module C (module A, module M2) where

8+ import A

9+ import qualified B as M2

10+

11+module Main where

12+

13+ import Prelude

14+ import C

15+

16+ main = Control.Monad.Eff.Console.log (x ++ y)

purescript.cabal+3

@@ -120,6 +120,9 @@ library

120 Language.PureScript.Sugar.CaseDeclarations

121 Language.PureScript.Sugar.DoNotation

122 Language.PureScript.Sugar.Names

123+ Language.PureScript.Sugar.Names.Env

124+ Language.PureScript.Sugar.Names.Imports

125+ Language.PureScript.Sugar.Names.Exports

123 Language.PureScript.Sugar.ObjectWildcards

126 Language.PureScript.Sugar.ObjectWildcards

124 Language.PureScript.Sugar.Operators

127 Language.PureScript.Sugar.Operators

125 Language.PureScript.Sugar.TypeClasses

128 Language.PureScript.Sugar.TypeClasses

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

@@ -88,6 +88,10 @@ instance Eq DeclarationRef where

88 r == (PositionedDeclarationRef _ _ r') = r == r'

89 _ == _ = False

91+isModuleRef :: DeclarationRef -> Bool

92+isModuleRef (ModuleRef _) = True

93+isModuleRef _ = False

94+

91-- |

95-- |

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

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

93--

97--

src/Language/PureScript/Errors.hs+8

@@ -86,6 +86,7 @@ data SimpleErrorMessage

86 | UnknownExportTypeClass ProperName

87 | UnknownImportValue ModuleName Ident

88 | UnknownExportValue Ident

89+ | UnknownExportModule ModuleName

89 | UnknownImportDataConstructor ModuleName ProperName ProperName

90 | UnknownImportDataConstructor ModuleName ProperName ProperName

90 | UnknownExportDataConstructor ProperName ProperName

91 | UnknownExportDataConstructor ProperName ProperName

91 | ConflictingImport String ModuleName

92 | ConflictingImport String ModuleName

@@ -141,6 +142,7 @@ data SimpleErrorMessage

141 | OverlappingPattern [[Binder]] Bool

142 | OverlappingPattern [[Binder]] Bool

142 | ClassOperator ProperName Ident

143 | ClassOperator ProperName Ident

143 | MisleadingEmptyTypeImport ModuleName ProperName

144 | MisleadingEmptyTypeImport ModuleName ProperName

145+ | ImportHidingModule ModuleName

144 deriving (Show)

146 deriving (Show)

145

147

146-- |

148-- |

@@ -210,6 +212,7 @@ errorCode em = case unwrapErrorMessage em of

210 UnknownExportTypeClass{} -> "UnknownExportTypeClass"

212 UnknownExportTypeClass{} -> "UnknownExportTypeClass"

211 UnknownImportValue{} -> "UnknownImportValue"

213 UnknownImportValue{} -> "UnknownImportValue"

212 UnknownExportValue{} -> "UnknownExportValue"

214 UnknownExportValue{} -> "UnknownExportValue"

215+ UnknownExportModule{} -> "UnknownExportModule"

213 UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"

216 UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"

214 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"

217 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"

215 ConflictingImport{} -> "ConflictingImport"

218 ConflictingImport{} -> "ConflictingImport"

@@ -265,6 +268,7 @@ errorCode em = case unwrapErrorMessage em of

265 OverlappingPattern{} -> "OverlappingPattern"

268 OverlappingPattern{} -> "OverlappingPattern"

266 ClassOperator{} -> "ClassOperator"

269 ClassOperator{} -> "ClassOperator"

267 MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport"

270 MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport"

271+ ImportHidingModule{} -> "ImportHidingModule"

268

272

269-- |

273-- |

270-- A stack trace for an error

274-- A stack trace for an error

@@ -488,6 +492,8 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

488 line $ "Module " ++ show mn ++ " does not export value " ++ show name

492 line $ "Module " ++ show mn ++ " does not export value " ++ show name

489 goSimple (UnknownExportValue name) =

493 goSimple (UnknownExportValue name) =

490 line $ "Cannot export unknown value " ++ show name

494 line $ "Cannot export unknown value " ++ show name

495+ goSimple (UnknownExportModule name) =

496+ line $ "Cannot export unknown module " ++ show name ++ ", it either does not exist or has not been imported by the current module"

491 goSimple (UnknownImportDataConstructor mn tcon dcon) =

497 goSimple (UnknownImportDataConstructor mn tcon dcon) =

492 line $ "Module " ++ show mn ++ " does not export data constructor " ++ show dcon ++ " for type " ++ show tcon

498 line $ "Module " ++ show mn ++ " does not export data constructor " ++ show dcon ++ " for type " ++ show tcon

493 goSimple (UnknownExportDataConstructor tcon dcon) =

499 goSimple (UnknownExportDataConstructor tcon dcon) =

@@ -619,6 +625,8 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

619 ]

625 ]

620 goSimple (MisleadingEmptyTypeImport mn name) =

626 goSimple (MisleadingEmptyTypeImport mn name) =

621 line $ "Importing type " ++ show name ++ "(..) from " ++ show mn ++ " is misleading as it has no exported data constructors"

627 line $ "Importing type " ++ show name ++ "(..) from " ++ show mn ++ " is misleading as it has no exported data constructors"

628+ goSimple (ImportHidingModule name) =

629+ line $ "Attempted to hide module " ++ show name ++ " in import expression, this is not permitted"

622 goSimple (WildcardInferredType ty) =

630 goSimple (WildcardInferredType ty) =

623 line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty

631 line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty

624 goSimple (NotExhaustivePattern bs b) =

632 goSimple (NotExhaustivePattern bs b) =

src/Language/PureScript/Names.hs+13

@@ -102,3 +102,16 @@ instance (a ~ ProperName) => A.FromJSON (Qualified a) where

102qualify :: ModuleName -> Qualified a -> (ModuleName, a)

103qualify m (Qualified Nothing a) = (m, a)

104qualify _ (Qualified (Just m) a) = (m, a)

105+

106+-- |

107+-- Makes a qualified value from a name and module name.

108+--

109+mkQualified :: a -> ModuleName -> Qualified a

110+mkQualified name mn = Qualified (Just mn) name

111+

112+-- |

113+-- Checks whether a qualified value is actually qualified with a module reference

114+--

115+isUnqualified :: Qualified a -> Bool

116+isUnqualified (Qualified Nothing _) = True

117+isUnqualified _ = False

src/Language/PureScript/Sugar/Names.hs+123−505

@@ -1,7 +1,6 @@

1-----------------------------------------------------------------------------

2--

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

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

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

6--

5--

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

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

@@ -12,244 +11,75 @@

12--

11--

13-----------------------------------------------------------------------------

12-----------------------------------------------------------------------------

14+{-# LANGUAGE CPP #-}

15{-# LANGUAGE FlexibleContexts #-}

16{-# LANGUAGE ScopedTypeVariables #-}

17−{-# LANGUAGE PatternGuards #-}

18−{-# LANGUAGE CPP #-}

20−module Language.PureScript.Sugar.Names (

18+module Language.PureScript.Sugar.Names (desugarImports) where

21− desugarImports

22−) where

24−import Data.List (find, nub, (\\))

20+import Data.List (find, nub)

25−import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)

21+import Data.Maybe (fromMaybe, mapMaybe)

27#if __GLASGOW_HASKELL__ < 710

23#if __GLASGOW_HASKELL__ < 710

28import Control.Applicative (Applicative(..), (<$>), (<*>))

24import Control.Applicative (Applicative(..), (<$>), (<*>))

29#endif

25#endif

30import Control.Monad

26import Control.Monad

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

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

32−import Control.Monad.Writer (MonadWriter(..), censor)

28+import Control.Monad.Writer (MonadWriter(..))

34import qualified Data.Map as M

30import qualified Data.Map as M

36import Language.PureScript.AST

32import Language.PureScript.AST

37import Language.PureScript.Names

33import Language.PureScript.Names

38import Language.PureScript.Types

34import Language.PureScript.Types

39−import Language.PureScript.Environment

40import Language.PureScript.Errors

35import Language.PureScript.Errors

41import Language.PureScript.Traversals

36import Language.PureScript.Traversals

42−

43−import qualified Language.PureScript.Constants as C

37+import Language.PureScript.Sugar.Names.Env

44−

38+import Language.PureScript.Sugar.Names.Imports

45−-- |

39+import Language.PureScript.Sugar.Names.Exports

46−-- The global export environment - every declaration exported from every module.

47−--

48−type ExportEnvironment = M.Map ModuleName Exports

49−

50−-- |

51−-- The exported declarations from a module.

52−--

53−data Exports = Exports

54− {

55− -- |

56− -- The filename of the module these exports are for

57− --

58− moduleSourceSpan :: SourceSpan

59− -- |

60− -- The types exported from each module

61− --

62− , exportedTypes :: [(ProperName, [ProperName])]

63− -- |

64− -- The classes exported from each module

65− --

66− , exportedTypeClasses :: [ProperName]

67− -- |

68− -- The values exported from each module

69− --

70− , exportedValues :: [Ident]

71− -- |

72− -- The modules exported from each module

73− --

74− , exportedModules :: [ModuleName]

75− } deriving (Show)

76−

77−-- |

78−-- An imported environment for a particular module. This also contains the module's own members.

79−--

80−data ImportEnvironment = ImportEnvironment

81− {

82− -- |

83− -- Local names for types within a module mapped to to their qualified names

84− --

85− importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)

86− -- |

87− -- Local names for data constructors within a module mapped to to their qualified names

88− --

89− , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName)

90− -- |

91− -- Local names for classes within a module mapped to to their qualified names

92− --

93− , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName)

94− -- |

95− -- Local names for values within a module mapped to to their qualified names

96− --

97− , importedValues :: M.Map (Qualified Ident) (Qualified Ident)

98− } deriving (Show)

99−

100−-- |

101−-- Updates the exports for a module from the global environment. If the module was not previously

102−-- present in the global environment, it is created.

103−--

104−updateExportedModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> (Exports -> m Exports) -> m ExportEnvironment

105−updateExportedModule env mn update = do

106− let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env

107− exports' <- update exports

108− return $ M.insert mn exports' env

109−

110−-- |

111−-- Adds an empty module to an ExportEnvironment.

112−--

113−addEmptyModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> SourceSpan -> m ExportEnvironment

114−addEmptyModule env name ss =

115− case name `M.lookup` env of

116− Just m -> throwError . errorMessage $ RedefinedModule name [moduleSourceSpan m, ss]

117− Nothing -> return $ M.insert name (Exports ss [] [] [] []) env

118−

119−-- |

120−-- Adds a type belonging to a module to the export environment.

121−--

122−addType :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> m ExportEnvironment

123−addType env mn name dctors = updateExportedModule env mn $ \m -> do

124− let exTypes = exportedTypes m

125− let exDctors = snd `concatMap` exTypes

126− let exClasses = exportedTypeClasses m

127− when (any ((== name) . fst) exTypes) $ throwConflictError ConflictingTypeDecls name

128− when (name `elem` exClasses) $ throwConflictError TypeConflictsWithClass name

129− forM_ dctors $ \dctor -> do

130− when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor

131− when (dctor `elem` exClasses) $ throwConflictError CtorConflictsWithClass dctor

132− return $ m { exportedTypes = (name, dctors) : exTypes }

133−

134−-- |

135−-- Adds a class to the export environment.

136−--

137−addTypeClass :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> m ExportEnvironment

138−addTypeClass env mn name = updateExportedModule env mn $ \m -> do

139− let exTypes = exportedTypes m

140− let exDctors = snd `concatMap` exTypes

141− when (any ((== name) . fst) exTypes) $ throwConflictError ClassConflictsWithType name

142− when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

143− classes <- addExport DuplicateClassExport (exportedTypeClasses m) name

144− return $ m { exportedTypeClasses = classes }

145−

146−-- |

147−-- Adds a class to the export environment.

148−--

149−addValue :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> Ident -> m ExportEnvironment

150−addValue env mn name = updateExportedModule env mn $ \m -> do

151− values <- addExport DuplicateValueExport (exportedValues m) name

152− return $ m { exportedValues = values }

153−

154−-- |

155−-- Adds an entry to a list of exports unless it is already present, in which case an error is

156−-- returned.

157−--

158−addExport :: (Applicative m, MonadError MultipleErrors m, Eq a, Show a) => (a -> SimpleErrorMessage) -> [a] -> a -> m [a]

159−addExport what exports name =

160− if name `elem` exports

161− then throwConflictError what name

162− else return $ name : exports

163

164-- |

41-- |

165−-- Replaces all local names with qualified names within a set of modules.

42+-- Replaces all local names with qualified names within a list of modules. The

43+-- modules should be topologically sorted beforehand.

166--

44--

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

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

168desugarImports modules = do

46desugarImports modules = do

169− unfilteredExports <- findExports modules

47+ env <- foldM updateEnv initEnv modules

170− exports <- foldM filterModuleExports unfilteredExports modules

171− let modules' = moduleReexports <$> modules

172− mapM (renameInModule' unfilteredExports exports) modules'

48+ mapM (renameInModule' env) modules

173 where

49 where

174− moduleReexports :: Module -> Module

50+ updateEnv :: Env -> Module -> m Env

175− moduleReexports (Module ss coms mn decls exps) =

176− let importedMods = catMaybes findImports'

177− in (Module ss coms mn (decls ++ (concatMap reexports importedMods)) exps)

178− where

179− imports :: [Declaration]

180− imports = filter isImportDecl decls

181− findImports' :: [Maybe (Declaration, Module)]

182− findImports' = go <$> modules

183− where

184− go :: Module -> Maybe (Declaration, Module)

185− go m@(Module _ _ mn' _ (Just exps'))

51+ updateEnv env m@(Module ss _ mn _ refs) =

186− | any isModExport exps', Just d <- find ((== mn') . importedModName) imports = Just (d, m)

52+ case mn `M.lookup` env of

187− where

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

188− importedModName :: Declaration -> ModuleName

54+ Nothing -> do

189− importedModName (ImportDeclaration imn _ _) = imn

55+ members <- findExportable m

190− importedModName (PositionedDeclaration _ _ d) = importedModName d

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

191− importedModName _ = error "Not an import decl"

57+ imps <- resolveImports env' m

192− go _ = Nothing

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

193− reexports :: (Declaration, Module) -> [Declaration]

59+ return $ M.insert mn (ss, imps, exps) env

194− reexports (ImportDeclaration _ (Hiding refs) _, (Module ss' coms' mn' ds' (Just exps'))) =

60+

195− case nonHiddenRefs of

196− [] -> []

197− _ -> reexports (ImportDeclaration mn' Implicit Nothing, Module ss' coms' mn' ds' (Just nonHiddenRefs))

198− where

199− nonHiddenRefs :: [DeclarationRef]

200− nonHiddenRefs = filter isModExport exps' \\ filter isModExport refs

201− reexports (ImportDeclaration _ ty qual, Module _ _ _ _ (Just exps')) =

202− let ty' = case ty of

203− Explicit _ -> Explicit []

204− _ -> ty

205− in (\m -> ImportDeclaration m ty' qual) <$> (catMaybes $ go <$> exps')

206− where

207− go :: DeclarationRef -> Maybe ModuleName

208− go (ModuleRef mn') = Just mn'

209− go _ = Nothing

210− reexports (PositionedDeclaration _ _ d, m@(Module _ _ _ _ (Just _))) = reexports (d, m)

211− reexports _ = []

212−

213− isModExport :: DeclarationRef -> Bool

214− isModExport (ModuleRef _) = True

215− isModExport _ = False

216−

217− -- Filters the exports for a module in the global exports environment so that only explicitly

218− -- exported members remain. If the module does not explicitly export anything, everything is

219− -- exported.

220− filterModuleExports :: ExportEnvironment -> Module -> m ExportEnvironment

221− filterModuleExports env (Module _ _ mn _ (Just exps))

222− | any isSelfModuleExport exps, Just exps' <- M.lookup mn env =

223− let moduleNames = filter (/= mn) $ (\(ModuleRef mn') -> mn') <$> filter isModExport exps

224− in return $ M.insert mn (exps' {exportedModules = moduleNames}) env

225− where

226− isSelfModuleExport :: DeclarationRef -> Bool

227− isSelfModuleExport (ModuleRef mn') | mn' == mn = True

228− isSelfModuleExport (PositionedDeclarationRef _ _ ref) = isSelfModuleExport ref

229− isSelfModuleExport _ = False

230− filterModuleExports env (Module _ _ mn _ (Just exps)) = filterExports mn exps env

231− filterModuleExports env _ = return env

232−

233− -- Rename and check all the names within a module. We tweak the global exports environment so

234− -- the module has access to an unfiltered list of its own members.

235− renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> m Module

61+ renameInModule' :: Env -> Module -> m Module

236− renameInModule' unfilteredExports exports m@(Module _ _ mn _ _) =

62+ renameInModule' env m@(Module _ _ mn _ _) =

237 rethrow (onErrorMessages (ErrorInModule mn)) $ do

63 rethrow (onErrorMessages (ErrorInModule mn)) $ do

238− let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports

239− let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports

64+ let (_, imps, exps) = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn env

240− imports <- resolveImports env m

241− elaborateImports <$> renameInModule imports env (elaborateExports exps m)

65+ elaborateImports <$> renameInModule env imps (elaborateExports exps m)

242

243-- |

67-- |

244−-- Make all exports for a module explicit. This may still effect modules that have an exports list,

68+-- Make all exports for a module explicit. This may still effect modules that

245−-- as it will also make all data constructor exports explicit.

69+-- have an exports list, as it will also make all data constructor exports

70+-- explicit.

246--

71--

247elaborateExports :: Exports -> Module -> Module

72elaborateExports :: Exports -> Module -> Module

248−elaborateExports exps (Module ss coms mn decls _) = Module ss coms mn decls (Just $

73+elaborateExports exps (Module ss coms mn decls _) =

74+ Module ss coms mn decls $

249− map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (exportedTypes exps) ++

75+ Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (my exportedTypes) ++

250− map TypeClassRef (exportedTypeClasses exps) ++

76+ map TypeClassRef (my exportedTypeClasses) ++

251− map ValueRef (exportedValues exps) ++

77+ map ValueRef (my exportedValues)

252− map ModuleRef (exportedModules exps))

78+ where

79+ -- Extracts a list of values from the exports and filters out any values that

80+ -- are re-exports from other modules.

81+ my :: (Exports -> [(a, ModuleName)]) -> [a]

82+ my f = fst `map` filter ((== mn) . snd) (f exps)

253

254-- |

84-- |

255-- Add `import X ()` for any modules where there are only fully qualified references to members.

85-- Add `import X ()` for any modules where there are only fully qualified references to members.

@@ -272,14 +102,15 @@ elaborateImports (Module ss coms mn decls exps) = Module ss coms mn decls' exps

272-- Replaces all local names with qualified names within a module and checks that all existing

102-- Replaces all local names with qualified names within a module and checks that all existing

273-- qualified names are valid.

103-- qualified names are valid.

274--

104--

275−renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ImportEnvironment -> ExportEnvironment -> Module -> m Module

105+renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => Env -> Imports -> Module -> m Module

276−renameInModule imports exports (Module ss coms mn decls exps) =

106+renameInModule env imports (Module ss coms mn decls exps) =

277 Module ss coms mn <$> parU decls go <*> pure exps

107 Module ss coms mn <$> parU decls go <*> pure exps

278 where

108 where

279 (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS

109 (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS

280

110

281 updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)

111 updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)

282− updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = return ((Just pos, bound), d)

112+ updateDecl (_, bound) d@(PositionedDeclaration pos _ _) =

113+ return ((Just pos, bound), d)

283 updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =

114 updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =

284 (,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)

115 (,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)

285 updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =

116 updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =

@@ -297,30 +128,37 @@ renameInModule imports exports (Module ss coms mn decls exps) =

297 updateDecl s d = return (s, d)

128 updateDecl s d = return (s, d)

298

129

299 updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)

130 updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)

300− updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v)

131+ updateValue (_, bound) v@(PositionedValue pos' _ _) =

132+ return ((Just pos', bound), v)

301− updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')

133+ updateValue (pos, bound) (Abs (Left arg) val') =

134+ return ((pos, arg : bound), Abs (Left arg) val')

302 updateValue (pos, bound) (Let ds val') = do

135 updateValue (pos, bound) (Let ds val') = do

303− let args = mapMaybe letBoundVariable ds

136+ let args = mapMaybe letBoundVariable ds

304− unless (length (nub args) == length args) $

137+ unless (length (nub args) == length args) $

305− maybe id rethrowWithPosition pos $

138+ maybe id rethrowWithPosition pos $

306− throwError . errorMessage $ OverlappingNamesInLet

139+ throwError . errorMessage $ OverlappingNamesInLet

307− return ((pos, args ++ bound), Let ds val')

140+ return ((pos, args ++ bound), Let ds val')

308− where

309 updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =

141 updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =

310 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

142 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

311 updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =

143 updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =

312 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

144 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

145+ updateValue s@(pos, _) (Constructor name) =

313− updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos)

146+ (,) s <$> (Constructor <$> updateDataConstructorName name pos)

147+ updateValue s@(pos, _) (TypedValue check val ty) =

314− updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)

148+ (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)

315 updateValue s v = return (s, v)

149 updateValue s v = return (s, v)

316

150

317 updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)

151 updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)

318− updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((Just pos, bound), v)

152+ updateBinder (_, bound) v@(PositionedBinder pos _ _) =

153+ return ((Just pos, bound), v)

154+ updateBinder s@(pos, _) (ConstructorBinder name b) =

319− updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)

155+ (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)

320− updateBinder s v = return (s, v)

156+ updateBinder s v =

157+ return (s, v)

321

158

322 updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)

159 updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)

323− updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c)

160+ updateCase (pos, bound) c@(CaseAlternative bs _) =

161+ return ((pos, concatMap binderNames bs ++ bound), c)

324

162

325 letBoundVariable :: Declaration -> Maybe Ident

163 letBoundVariable :: Declaration -> Maybe Ident

326 letBoundVariable (ValueDeclaration ident _ _ _) = Just ident

164 letBoundVariable (ValueDeclaration ident _ _ _) = Just ident

@@ -328,298 +166,78 @@ renameInModule imports exports (Module ss coms mn decls exps) =

328 letBoundVariable _ = Nothing

166 letBoundVariable _ = Nothing

329

167

330 updateTypesEverywhere :: Maybe SourceSpan -> Type -> m Type

168 updateTypesEverywhere :: Maybe SourceSpan -> Type -> m Type

331− updateTypesEverywhere pos0 = everywhereOnTypesM (updateType pos0)

169+ updateTypesEverywhere pos = everywhereOnTypesM updateType

332 where

170 where

333− updateType :: Maybe SourceSpan -> Type -> m Type

171+ updateType :: Type -> m Type

334− updateType pos (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos

172+ updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos

335− updateType pos (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys

173+ updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys

336− updateType pos (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t

174+ updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t

337− updateType _ t = return t

175+ updateType t = return t

338

176

177+ updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]

339 updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts)

178 updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts)

340

179

180+ updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

341− updateTypeName = update UnknownType importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))

181+ updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes)

182+

183+ updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

184+ updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes)

185+

186+ updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

342− updateClassName = update UnknownTypeClass importedTypeClasses (flip elem . exportedTypeClasses)

187+ updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses)

188+

189+ updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)

343− updateValueName = update UnknownValue importedValues (flip elem . exportedValues)

190+ updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues)

344− updateDataConstructorName = update (flip UnknownDataConstructor Nothing) importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))

191+

192+ -- Used when performing an update to qualify values and classes with their

193+ -- module of original definition.

194+ resolve :: (Eq a) => [(a, ModuleName)] -> a -> Maybe (Qualified a)

195+ resolve as name = mkQualified name <$> name `lookup` as

196+

197+ -- Used when performing an update to qualify types with their module of

198+ -- original definition.

199+ resolveType :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)

200+ resolveType tys name = mkQualified name . snd <$> find ((== name) . fst . fst) tys

345

201

202+ -- Used when performing an update to qualify data constructors with their

203+ -- module of original definition.

204+ resolveDctor :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)

205+ resolveDctor tys name = mkQualified name . snd <$> find (elem name . snd . fst) tys

206+

346− -- Update names so unqualified references become qualified, and locally qualified references

207+ -- Update names so unqualified references become qualified, and locally

347− -- are replaced with their canoncial qualified names (e.g. M.Map -> Data.Map.Map)

208+ -- qualified references are replaced with their canoncial qualified names

209+ -- (e.g. M.Map -> Data.Map.Map).

348 update :: (Ord a, Show a) => (Qualified a -> SimpleErrorMessage)

210 update :: (Ord a, Show a) => (Qualified a -> SimpleErrorMessage)

349− -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))

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

350− -> (Exports -> a -> Bool)

212+ -> (Exports -> a -> Maybe (Qualified a))

351 -> Qualified a

213 -> Qualified a

352 -> Maybe SourceSpan

214 -> Maybe SourceSpan

353 -> m (Qualified a)

215 -> m (Qualified a)

354− update unknown getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of

216+ update unknown imps getE qname@(Qualified mn' name) pos = positioned $

355− (Just qname', _) -> return qname'

217+ case (M.lookup qname imps, mn') of

218+ -- We found the name in our imports, so we return the name for it,

219+ -- qualifying with the name of the module it was originally defined in

220+ -- rather than the module we're importing from, to handle the case of

221+ -- re-exports.

222+ (Just (_, mnOrig), _) -> return $ Qualified (Just mnOrig) name

223+ -- If the name wasn't found in our imports but was qualified then we need

224+ -- to check whether it's a failed import from a "pseudo" module (created

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

226+ -- check it refers to a symbol in another module.

356− (Nothing, Just mn'') -> do

227+ (Nothing, Just mn'') -> do

357− when (isExplicitQualModule mn'') . throwError . errorMessage $ unknown qname

228+ when (isExplicitQualModule mn'') . throwError . errorMessage $ unknown qname

358− modExports <- getExports mn''

229+ modExports <- getExports mn''

359− if checkE modExports name

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

360− then return qname

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

361− else throwError . errorMessage $ unknown qname

232+ -- unimported symbol.

362− _ -> throwError . errorMessage $ unknown qname

233+ _ -> throwError . errorMessage $ unknown qname

363 where

234 where

364 isExplicitQualModule :: ModuleName -> Bool

235 isExplicitQualModule :: ModuleName -> Bool

365− isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imports')

236+ isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imps)

366− imports' = getI imports

367 positioned err = case pos of

237 positioned err = case pos of

368 Nothing -> err

238 Nothing -> err

369 Just pos' -> rethrowWithPosition pos' err

239 Just pos' -> rethrowWithPosition pos' err

370

240

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

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

372 getExports :: ModuleName -> m Exports

242 getExports :: ModuleName -> m Exports

373− getExports mn' = maybe (throwError . errorMessage $ UnknownModule mn') return $ M.lookup mn' exports

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

374−

375−-- |

376−-- Finds all exported declarations in a set of modules.

377−--

378−findExports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m ExportEnvironment

379−findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) primExports

380− where

381−

382− -- The exported types from the Prim module

383− primExports = Exports (internalModuleSourceSpan "<Prim>") (mkTypeEntry `map` M.keys primTypes) [] [] []

384− where

385− mkTypeEntry (Qualified _ name) = (name, [])

386−

387− -- Add all of the exported declarations from a module to the global export environment

388− addModule :: ExportEnvironment -> Module -> m ExportEnvironment

389− addModule env (Module ss _ mn ds _) = do

390− env' <- addEmptyModule env mn ss

391− rethrow (onErrorMessages (ErrorInModule mn)) $ foldM (addDecl mn) env' ds

392−

393− -- Add a declaration from a module to the global export environment

394− addDecl :: ModuleName -> ExportEnvironment -> Declaration -> m ExportEnvironment

395− addDecl mn env (TypeClassDeclaration tcn _ _ ds) = do

396− env' <- addTypeClass env mn tcn

397− foldM go env' ds

398− where

399− go env'' (TypeDeclaration name _) = addValue env'' mn name

400− go env'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go env'' d

401− go _ _ = error "Invalid declaration in TypeClassDeclaration"

402− addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)

403− addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []

404− addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []

405− addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name

406− addDecl mn env (ExternDeclaration name _) = addValue env mn name

407− addDecl mn env (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ addDecl mn env d

408− addDecl _ env _ = return env

409−

410−-- |

411−-- Filters the exports for a module to ensure only explicit exports are kept in the global exports

412−-- environment.

413−--

414−filterExports :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> ExportEnvironment -> m ExportEnvironment

415−filterExports mn exps env = do

416− let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)

417− moduleExports' <- rethrow (onErrorMessages (ErrorInModule mn)) $ filterModule moduleExports

418− return $ M.insert mn moduleExports' env

419− where

420−

421− -- Filter the exports for the specific module

422− filterModule :: Exports -> m Exports

423− filterModule exported = do

424− types' <- foldM (filterTypes $ exportedTypes exported) [] exps

425− values <- foldM (filterValues $ exportedValues exported) [] exps

426− classes <- foldM (filterClasses $ exportedTypeClasses exported) [] exps

427− modules <- foldM (filterModules $ exportedModules exported) [] exps

428− return exported { exportedTypes = types', exportedTypeClasses = classes, exportedValues = values, exportedModules = modules }

429−

430− -- Ensure the exported types and data constructors exist in the module and add them to the set of

431− -- exports

432− filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> m [(ProperName, [ProperName])]

433− filterTypes expTys result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes expTys result r

434− filterTypes expTys result (TypeRef name expDcons) = do

435− dcons <- maybe (throwError . errorMessage . UnknownExportType $ name) return $ name `lookup` expTys

436− dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons

437− return $ (name, dcons') : result

438− filterTypes _ result _ = return result

439−

440− -- Ensure the exported data constructors exists for a type and add them to the list of exports

441− filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> m [ProperName]

442− filterDcons tcon exps' result name =

443− if name `elem` exps'

444− then return $ name : result

445− else throwError . errorMessage $ UnknownExportDataConstructor tcon name

446−

447− -- Ensure the exported classes exist in the module and add them to the set of exports

448− filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> m [ProperName]

449− filterClasses exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterClasses exps' result r

450− filterClasses exps' result (TypeClassRef name) =

451− if name `elem` exps'

452− then return $ name : result

453− else throwError . errorMessage . UnknownExportTypeClass $ name

454− filterClasses _ result _ = return result

455−

456− -- Ensure the exported values exist in the module and add them to the set of exports

457− filterValues :: [Ident] -> [Ident] -> DeclarationRef -> m [Ident]

458− filterValues exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterValues exps' result r

459− filterValues exps' result (ValueRef name) =

460− if name `elem` exps'

461− then return $ name : result

462− else throwError . errorMessage . UnknownExportValue $ name

463− filterValues _ result _ = return result

464−

465− -- Add the exported modules to the set of exports

466− filterModules :: [ModuleName] -> [ModuleName] -> DeclarationRef -> m [ModuleName]

467− filterModules exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterModules exps' result r

468− filterModules _ result (ModuleRef name) = return $ name : result

469− filterModules _ result _ = return result

470−

471−-- |

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

473−-- explicitly imported declarations.

474−--

475−findImports :: [Declaration] -> M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]

476−findImports = foldl (findImports' Nothing) M.empty

477− where

478− findImports' pos result (ImportDeclaration mn typ qual) =

479− case mn `M.lookup` result of

480− Just is -> M.insert mn ((pos, typ, qual):is) result

481− Nothing -> M.insert mn [(pos, typ, qual)] result

482− findImports' _ result (PositionedDeclaration pos _ d) = findImports' (Just pos) result d

483− findImports' _ result _ = result

484−

485−-- |

486−-- Constructs a local environment for a module.

487−--

488−resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ExportEnvironment -> Module -> m ImportEnvironment

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

490− censor (onErrorMessages (ErrorInModule currentModule)) $

491− foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)

492− where

493−

494− -- A Map from module name to the source position for the import, the list of imports from that

495− -- module (where Nothing indicates everything is to be imported), and optionally a qualified name

496− -- for the module

497− scope :: M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]

498− scope = M.insert currentModule [(Nothing, Implicit, Nothing)] (findImports decls)

499−

500− resolveImport' :: ImportEnvironment -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) -> m ImportEnvironment

501− resolveImport' ie (mn, imps) = foldM go ie imps

502− where

503− go :: ImportEnvironment -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m ImportEnvironment

504− go ie' (pos, typ, impQual) = do

505− modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) return $ mn `M.lookup` env

506− positioned $ resolveImport currentModule mn modExports ie' impQual typ

507− where

508− positioned err = case pos of

509− Nothing -> err

510− Just pos' -> rethrowWithPosition pos' err

511−

512−-- |

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

514−--

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

516−resolveImport currentModule importModule exps imps impQual =

517− resolveByType

518− where

519−

520− resolveByType :: ImportDeclarationType -> m ImportEnvironment

521− resolveByType Implicit = importAll importExplicit

522− resolveByType (Explicit explImports) = checkedRefs explImports >> foldM importExplicit imps explImports

523− resolveByType (Hiding hiddenImports) = checkedRefs hiddenImports >> importAll (importNonHidden hiddenImports)

524−

525− importNonHidden :: [DeclarationRef] -> ImportEnvironment -> DeclarationRef -> m ImportEnvironment

526− importNonHidden hidden m ref =

527− if isHidden hidden ref

528− then return m

529− else importExplicit m ref

530−

531− isHidden :: [DeclarationRef] -> DeclarationRef -> Bool

532− isHidden hidden ref@(TypeRef _ _) =

533− let

534− checkTypeRef _ True _ = True

535− checkTypeRef r acc (PositionedDeclarationRef _ _ h) = checkTypeRef r acc h

536− checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc

537− checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'

538− checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'

539− checkTypeRef (PositionedDeclarationRef _ _ r) acc hiddenRef = checkTypeRef r acc hiddenRef

540− checkTypeRef _ acc _ = acc

541− in foldl (checkTypeRef ref) False hidden

542− isHidden hidden ref = ref `elem` hidden

543−

544− -- Import all symbols

545− importAll :: (ImportEnvironment -> DeclarationRef -> m ImportEnvironment) -> m ImportEnvironment

546− importAll importer = do

547− imp' <- foldM (\m (name, dctors) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)

548− imp'' <- foldM (\m name -> importer m (ValueRef name)) imp' (exportedValues exps)

549− foldM (\m name -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)

550−

551− -- Import something explicitly

552− importExplicit :: ImportEnvironment -> DeclarationRef -> m ImportEnvironment

553− importExplicit imp (PositionedDeclarationRef pos _ r) =

554− rethrowWithPosition pos . warnWithPosition pos $ importExplicit imp r

555− importExplicit imp (ValueRef name) = do

556− values' <- updateImports (importedValues imp) name

557− return $ imp { importedValues = values' }

558− importExplicit imp (TypeRef name dctors) = do

559− types' <- updateImports (importedTypes imp) name

560− let allDctors = allExportedDataConstructors name

561− maybe (return ()) (mapM_ $ checkDctorExists name allDctors) dctors

562− when (null allDctors && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name

563− dctors' <- foldM updateImports (importedDataConstructors imp) (fromMaybe allDctors dctors)

564− return $ imp { importedTypes = types', importedDataConstructors = dctors' }

565− importExplicit imp (TypeClassRef name) = do

566− typeClasses' <- updateImports (importedTypeClasses imp) name

567− return $ imp { importedTypeClasses = typeClasses' }

568− importExplicit _ _ = error "Invalid argument to importExplicit"

569−

570− -- Check if DeclarationRef points to an existent symbol

571− checkedRefs :: [DeclarationRef] -> m ()

572− checkedRefs = mapM_ check

573− where

574− check (PositionedDeclarationRef pos _ r) =

575− rethrowWithPosition pos $ check r

576− check (ValueRef name) =

577− checkImportExists UnknownImportValue values name

578− check (TypeRef name dctors) = do

579− checkImportExists UnknownImportType availableTypes name

580− let allDctors = allExportedDataConstructors name

581− maybe (return ()) (mapM_ $ checkDctorExists name allDctors) dctors

582− check (TypeClassRef name) =

583− checkImportExists UnknownImportTypeClass classes name

584− check (ModuleRef name) =

585− checkImportExists (const UnknownModule) (exportedModules exps) name

586− check _ = error "Invalid argument to checkRefIsValid"

587−

588− -- Find all exported data constructors for a given type

589− allExportedDataConstructors :: ProperName -> [ProperName]

590− allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps

591−

592− -- Add something to the ImportEnvironment if it does not already exist there

593− updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> m (M.Map (Qualified a) (Qualified a))

594− updateImports m name = case M.lookup (Qualified impQual name) m of

595− Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m

596− Just (Qualified Nothing _) -> error "Invalid state in updateImports"

597− Just (Qualified (Just mn) _)

598− | mn == importModule -> return m

599− | otherwise -> throwError . errorMessage $ err

600− where

601− err = if currentModule `elem` [mn, importModule]

602− then ConflictingImport (show name) importModule

603− else ConflictingImports (show name) mn importModule

604−

605−

606− -- The available values, types, and classes in the module being imported

607− values = exportedValues exps

608− availableTypes = fst `map` exportedTypes exps

609− classes = exportedTypeClasses exps

610−

611− -- Ensure that an explicitly imported data constructor exists for the type it is being imported

612− -- from

613− checkDctorExists :: ProperName -> [ProperName] -> ProperName -> m ()

614− checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)

615−

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

617− checkImportExists :: (Eq a, Show a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()

618− checkImportExists unknown exports item =

619− when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item

620−

621−-- |

622−-- Raises an error for when there is more than one definition for something.

623−--

624−throwConflictError :: (Applicative m, MonadError MultipleErrors m, Show a) => (a -> SimpleErrorMessage) -> a -> m b

625−throwConflictError conflict = throwError . errorMessage . conflict

src/Language/PureScript/Sugar/Names/Env.hsnew file+197

@@ -0,0 +1,197 @@

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+

14+{-# LANGUAGE FlexibleContexts #-}

15+--{-# LANGUAGE ScopedTypeVariables #-}

16+--{-# LANGUAGE PatternGuards #-}

17+--{-# LANGUAGE RankNTypes #-}

18+--{-# LANGUAGE TupleSections #-}

19+

20+module Language.PureScript.Sugar.Names.Env

21+ ( Imports(..)

22+ , nullImports

23+ , Exports(..)

24+ , nullExports

25+ , Env

26+ , initEnv

27+ , envModuleSourceSpan

28+ , envModuleImports

29+ , envModuleExports

30+ , exportType

31+ , exportTypeClass

32+ , exportValue

33+ ) where

34+

35+import Control.Monad

36+import Control.Monad.Error.Class (MonadError(..))

37+

38+import qualified Data.Map as M

39+

40+import Language.PureScript.AST

41+import Language.PureScript.Names

42+import Language.PureScript.Environment

43+import Language.PureScript.Errors

44+

45+-- |

46+-- The imported declarations for a module, including the module's own members.

47+--

48+data Imports = Imports

49+ {

50+ -- |

51+ -- Local names for types within a module mapped to to their qualified names

52+ --

53+ importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)

54+ -- |

55+ -- Local names for data constructors within a module mapped to to their qualified names

56+ --

57+ , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)

58+ -- |

59+ -- Local names for classes within a module mapped to to their qualified names

60+ --

61+ , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)

62+ -- |

63+ -- Local names for values within a module mapped to to their qualified names

64+ --

65+ , importedValues :: M.Map (Qualified Ident) (Qualified Ident, ModuleName)

66+ -- |

67+ -- The list of modules that have been imported into the current scope.

68+ --

69+ , importedModules :: [ModuleName]

70+ } deriving (Show)

71+

72+-- |

73+-- An empty 'Imports' value.

74+--

75+nullImports :: Imports

76+nullImports = Imports M.empty M.empty M.empty M.empty []

77+

78+-- |

79+-- The exported declarations from a module.

80+--

81+data Exports = Exports

82+ {

83+ -- |

84+ -- The types exported from each module along with the module they originally

85+ -- came from.

86+ --

87+ exportedTypes :: [((ProperName, [ProperName]), ModuleName)]

88+ -- |

89+ -- The classes exported from each module along with the module they originally

90+ -- came from.

91+ --

92+ , exportedTypeClasses :: [(ProperName, ModuleName)]

93+ -- |

94+ -- The values exported from each module along with the module they originally

95+ -- came from.

96+ --

97+ , exportedValues :: [(Ident, ModuleName)]

98+ } deriving (Show)

99+

100+-- |

101+-- An empty 'Exports' value.

102+--

103+nullExports :: Exports

104+nullExports = Exports [] [] []

105+

106+-- |

107+-- The imports and exports for a collection of modules. The 'SourceSpan' is used

108+-- to store the source location of the module with a given name, used to provide

109+-- useful information when there is a duplicate module definition.

110+--

111+type Env = M.Map ModuleName (SourceSpan, Imports, Exports)

112+

113+-- |

114+-- Extracts the 'SourceSpan' from an 'Env' value.

115+--

116+envModuleSourceSpan :: (SourceSpan, a, b) -> SourceSpan

117+envModuleSourceSpan (ss, _, _) = ss

118+

119+-- |

120+-- Extracts the 'Imports' from an 'Env' value.

121+--

122+envModuleImports :: (a, Imports, b) -> Imports

123+envModuleImports (_, imps, _) = imps

124+

125+-- |

126+-- Extracts the 'Exports' from an 'Env' value.

127+--

128+envModuleExports :: (a, b, Exports) -> Exports

129+envModuleExports (_, _, exps) = exps

130+

131+-- |

132+-- The exported types from the @Prim@ module

133+--

134+primExports :: Exports

135+primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []

136+ where

137+ mkTypeEntry (Qualified _ name) = ((name, []), ModuleName [ProperName "Prim"])

138+

139+-- |

140+-- The initial global import/export environment containing the @Prim@ module.

141+--

142+initEnv :: Env

143+initEnv = M.singleton

144+ (ModuleName [ProperName "Prim"])

145+ (internalModuleSourceSpan "<Prim>", nullImports, primExports)

146+

147+-- |

148+-- Safely adds a type and its data constructors to some exports, returning an

149+-- error if a conflict occurs.

150+--

151+exportType :: (MonadError MultipleErrors m) => Exports -> ProperName -> [ProperName] -> ModuleName -> m Exports

152+exportType exps name dctors mn = do

153+ let exTypes = exportedTypes exps

154+ let exDctors = (snd . fst) `concatMap` exTypes

155+ let exClasses = exportedTypeClasses exps

156+ when (any (\((name', _), _) -> name == name') exTypes) $ throwConflictError ConflictingTypeDecls name

157+ when (any ((== name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name

158+ forM_ dctors $ \dctor -> do

159+ when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor

160+ when (any ((== dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor

161+ return $ exps { exportedTypes = ((name, dctors), mn) : exTypes }

162+

163+-- |

164+-- Safely adds a class to some exports, returning an error if a conflict occurs.

165+--

166+exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName -> ModuleName -> m Exports

167+exportTypeClass exps name mn = do

168+ let exTypes = exportedTypes exps

169+ let exDctors = (snd . fst) `concatMap` exTypes

170+ when (any (\((name', _), _) -> name == name') exTypes) $ throwConflictError ClassConflictsWithType name

171+ when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

172+ classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)

173+ return $ exps { exportedTypeClasses = classes }

174+

175+-- |

176+-- Safely adds a value to some exports, returning an error if a conflict occurs.

177+--

178+exportValue :: (MonadError MultipleErrors m) => Exports -> Ident -> ModuleName -> m Exports

179+exportValue exps name mn = do

180+ values <- addExport DuplicateValueExport name mn (exportedValues exps)

181+ return $ exps { exportedValues = values }

182+

183+-- |

184+-- Adds an entry to a list of exports unless it is already present, in which case an error is

185+-- returned.

186+--

187+addExport :: (MonadError MultipleErrors m, Eq a, Show a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)]

188+addExport what name mn exports =

189+ if any ((== name) . fst) exports

190+ then throwConflictError what name

191+ else return $ (name, mn) : exports

192+

193+-- |

194+-- Raises an error for when there is more than one definition for something.

195+--

196+throwConflictError :: (MonadError MultipleErrors m, Show a) => (a -> SimpleErrorMessage) -> a -> m b

197+throwConflictError conflict = throwError . errorMessage . conflict

src/Language/PureScript/Sugar/Names/Exports.hsnew file+236

@@ -0,0 +1,236 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Sugar.Names.Exports

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+

14+{-# LANGUAGE CPP #-}

15+{-# LANGUAGE FlexibleContexts #-}

16+{-# LANGUAGE RankNTypes #-}

17+{-# LANGUAGE ScopedTypeVariables #-}

18+{-# LANGUAGE TupleSections #-}

19+

20+module Language.PureScript.Sugar.Names.Exports

21+ ( findExportable

22+ , resolveExports

23+ ) where

24+

25+import Data.List (find, intersect)

26+import Data.Maybe (fromMaybe, mapMaybe)

27+

28+#if __GLASGOW_HASKELL__ < 710

29+import Control.Applicative (Applicative(..), (<$>), (<*>))

30+#endif

31+import Control.Monad

32+import Control.Monad.Error.Class (MonadError(..))

33+

34+import qualified Data.Map as M

35+

36+import Language.PureScript.AST

37+import Language.PureScript.Names

38+import Language.PureScript.Errors

39+import Language.PureScript.Sugar.Names.Env

40+

41+-- |

42+-- Finds all exportable members of a module, disregarding any explicit exports.

43+--

44+findExportable :: forall m. (Applicative m, MonadError MultipleErrors m) => Module -> m Exports

45+findExportable (Module _ _ mn ds _) =

46+ rethrow (onErrorMessages (ErrorInModule mn)) $ foldM updateExports nullExports ds

47+ where

48+ updateExports :: Exports -> Declaration -> m Exports

49+ updateExports exps (TypeClassDeclaration tcn _ _ ds') = do

50+ exps' <- exportTypeClass exps tcn mn

51+ foldM go exps' ds'

52+ where

53+ go exps'' (TypeDeclaration name _) = exportValue exps'' name mn

54+ go exps'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go exps'' d

55+ go _ _ = error "Invalid declaration in TypeClassDeclaration"

56+ updateExports exps (DataDeclaration _ tn _ dcs) = exportType exps tn (map fst dcs) mn

57+ updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn

58+ updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn

59+ updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn

60+ updateExports exps (ExternDeclaration name _) = exportValue exps name mn

61+ updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d

62+ updateExports exps _ = return exps

63+

64+-- |

65+-- Resolves the exports for a module, filtering out members that have not been

66+-- exported and elaborating re-exports of other modules.

67+--

68+resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports

69+resolveExports env mn imps exps refs =

70+ rethrow (onErrorMessages (ErrorInModule mn)) $ do

71+ filtered <- filterModule mn exps refs

72+ foldM elaborateModuleExports filtered refs

73+

74+ where

75+

76+ -- Takes the current module's imports, the accumulated list of exports, and a

77+ -- `DeclarationRef` for an explicit export. When the ref refers to another

78+ -- module, export anything from the imports that matches for that module.

79+ elaborateModuleExports :: Exports -> DeclarationRef -> m Exports

80+ elaborateModuleExports result (PositionedDeclarationRef pos _ r) =

81+ rethrowWithPosition pos $ elaborateModuleExports result r

82+ elaborateModuleExports result (ModuleRef name) | name == mn = do

83+ let types' = exportedTypes result ++ exportedTypes exps

84+ let classes' = exportedTypeClasses result ++ exportedTypeClasses exps

85+ let values' = exportedValues result ++ exportedValues exps

86+ return result { exportedTypes = types'

87+ , exportedTypeClasses = classes'

88+ , exportedValues = values' }

89+ elaborateModuleExports result (ModuleRef name) = do

90+ let isPseudo = isPseudoModule name

91+ when (not isPseudo && not (isImportedModule name)) $

92+ throwError . errorMessage . UnknownExportModule $ name

93+ let reTypes = extract isPseudo name (importedTypes imps)

94+ let reDctors = extract isPseudo name (importedDataConstructors imps)

95+ let reClasses = extract isPseudo name (importedTypeClasses imps)

96+ let reValues = extract isPseudo name (importedValues imps)

97+ result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)

98+ result'' <- foldM (uncurry . exportTypeClass) result' (map resolveClass reClasses)

99+ foldM (uncurry . exportValue) result'' (map resolveValue reValues)

100+ elaborateModuleExports result _ = return result

101+

102+ -- Extracts a list of values for a module based on a lookup table. If the

103+ -- boolean is true the values are filtered by the qualification of the

104+ extract :: Bool -> ModuleName -> M.Map (Qualified a) (Qualified a, ModuleName) -> [Qualified a]

105+ extract True name = map fst . M.elems . M.filterWithKey (\k _ -> eqQual name k)

106+ extract False name = map fst . M.elems . M.filter (eqQual name . fst)

107+

108+ -- Check whether a module name refers to a "pseudo module" that came into

109+ -- existence in an import scope due to importing one or more modules as

110+ -- qualified.

111+ isPseudoModule :: ModuleName -> Bool

112+ isPseudoModule = testQuals M.keys

113+ where

114+ -- Test for the presence of a `ModuleName` in a set of imports, using a

115+ -- function to either extract the keys or values. We test the keys to see if a

116+ -- value being re-exported belongs to a qualified module, and we test the

117+ -- values if that fails to see whether the value has been imported at all.

118+ testQuals :: (forall a. M.Map (Qualified a) (Qualified a, ModuleName) -> [Qualified a]) -> ModuleName -> Bool

119+ testQuals f mn' = any (eqQual mn') (f (importedTypes imps))

120+ || any (eqQual mn') (f (importedDataConstructors imps))

121+ || any (eqQual mn') (f (importedTypeClasses imps))

122+ || any (eqQual mn') (f (importedValues imps))

123+

124+ -- Check whether a module name refers to a module that has been imported

125+ -- without qualification into an import scope.

126+ isImportedModule :: ModuleName -> Bool

127+ isImportedModule = flip elem (importedModules imps)

128+

129+ -- Check whether a module name matches that of a qualified value.

130+ eqQual :: ModuleName -> Qualified a -> Bool

131+ eqQual mn'' (Qualified (Just mn''') _) = mn'' == mn'''

132+ eqQual _ _ = False

133+

134+ -- Constructs a list of types with their data constructors and the original

135+ -- module they were defined in from a list of type and data constructor names.

136+ resolveTypeExports :: [Qualified ProperName] -> [Qualified ProperName] -> [((ProperName, [ProperName]), ModuleName)]

137+ resolveTypeExports tctors dctors = map go tctors

138+ where

139+ go :: Qualified ProperName -> ((ProperName, [ProperName]), ModuleName)

140+ go (Qualified (Just mn'') name) = fromMaybe (error "Missing value in resolveTypeExports") $ do

141+ exps' <- envModuleExports <$> mn'' `M.lookup` env

142+ ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')

143+ let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mnOrig then Just dctor else Nothing) dctors

144+ return ((name, intersect relevantDctors dctors'), mnOrig)

145+ go (Qualified Nothing _) = error "Unqualified value in resolveTypeExports"

146+

147+

148+ -- Looks up an imported class and re-qualifies it with the original module it

149+ -- came from.

150+ resolveClass :: Qualified ProperName -> (ProperName, ModuleName)

151+ resolveClass className = splitQual $ fromMaybe (error "Missing value in resolveClass") $

152+ resolve exportedTypeClasses className

153+

154+ -- Looks up an imported value and re-qualifies it with the original module it

155+ -- came from.

156+ resolveValue :: Qualified Ident -> (Ident, ModuleName)

157+ resolveValue ident = splitQual $ fromMaybe (error "Missing value in resolveValue") $

158+ resolve exportedValues ident

159+

160+ resolve :: (Eq a) => (Exports -> [(a, ModuleName)]) -> Qualified a -> Maybe (Qualified a)

161+ resolve f (Qualified (Just mn'') a) = do

162+ exps' <- envModuleExports <$> mn'' `M.lookup` env

163+ mn''' <- snd <$> find ((== a) . fst) (f exps')

164+ return $ Qualified (Just mn''') a

165+ resolve _ _ = error "Unqualified value in resolve"

166+

167+ -- A partial function that takes a qualified value and extracts the value and

168+ -- qualified module components.

169+ splitQual :: Qualified a -> (a, ModuleName)

170+ splitQual (Qualified (Just mn'') a) = (a, mn'')

171+ splitQual _ = error "Unqualified value in splitQual"

172+

173+-- |

174+-- Filters the full list of exportable values, types, and classes for a module

175+-- based on a list of export declaration references.

176+--

177+filterModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> Exports -> [DeclarationRef] -> m Exports

178+filterModule mn exps refs = do

179+ types <- foldM (filterTypes $ exportedTypes exps) [] refs

180+ values <- foldM (filterValues $ exportedValues exps) [] refs

181+ classes <- foldM (filterClasses $ exportedTypeClasses exps) [] refs

182+ return exps { exportedTypes = types , exportedTypeClasses = classes , exportedValues = values }

183+

184+ where

185+

186+ -- Takes a list of all the exportable types with their data constructors, the

187+ -- accumulated list of filtered exports, and a `DeclarationRef` for an

188+ -- explicit export. When the ref refers to a type in the list of exportable

189+ -- values, the type and specified data constructors are included in the

190+ -- result.

191+ filterTypes :: [((ProperName, [ProperName]), ModuleName)] -> [((ProperName, [ProperName]), ModuleName)] -> DeclarationRef -> m [((ProperName, [ProperName]), ModuleName)]

192+ filterTypes exps' result (PositionedDeclarationRef pos _ r) =

193+ rethrowWithPosition pos $ filterTypes exps' result r

194+ filterTypes exps' result (TypeRef name expDcons) =

195+ case (\((name', _), mn') -> name == name' && mn == mn') `find` exps' of

196+ Nothing -> throwError . errorMessage . UnknownExportType $ name

197+ Just ((_, dcons), _) -> do

198+ let expDcons' = fromMaybe dcons expDcons

199+ mapM_ (checkDcon name dcons) expDcons'

200+ return $ ((name, expDcons'), mn) : result

201+ filterTypes _ result _ = return result

202+

203+ -- Ensures a data constructor is exportable for a given type. Takes a type

204+ -- name, a list of exportable data constructors for the type, and the name of

205+ -- the data constructor to check.

206+ checkDcon :: ProperName -> [ProperName] -> ProperName -> m ()

207+ checkDcon tcon exps' name =

208+ if name `elem` exps'

209+ then return ()

210+ else throwError . errorMessage $ UnknownExportDataConstructor tcon name

211+

212+ -- Takes a list of all the exportable classes, the accumulated list of

213+ -- filtered exports, and a `DeclarationRef` for an explicit export. When the

214+ -- ref refers to a class in the list of exportable classes, the class is

215+ -- included in the result.

216+ filterClasses :: [(ProperName, ModuleName)] -> [(ProperName, ModuleName)] -> DeclarationRef -> m [(ProperName, ModuleName)]

217+ filterClasses exps' result (PositionedDeclarationRef pos _ r) =

218+ rethrowWithPosition pos $ filterClasses exps' result r

219+ filterClasses exps' result (TypeClassRef name) =

220+ if (name, mn) `elem` exps'

221+ then return $ (name, mn) : result

222+ else throwError . errorMessage . UnknownExportTypeClass $ name

223+ filterClasses _ result _ = return result

224+

225+ -- Takes a list of all the exportable values, the accumulated list of filtered

226+ -- exports, and a `DeclarationRef` for an explicit export. When the ref refers

227+ -- to a value in the list of exportable values, the value is included in the

228+ -- result.

229+ filterValues :: [(Ident, ModuleName)] -> [(Ident, ModuleName)] -> DeclarationRef -> m [(Ident, ModuleName)]

230+ filterValues exps' result (PositionedDeclarationRef pos _ r) =

231+ rethrowWithPosition pos $ filterValues exps' result r

232+ filterValues exps' result (ValueRef name) =

233+ if (name, mn) `elem` exps'

234+ then return $ (name, mn) : result

235+ else throwError . errorMessage . UnknownExportValue $ name

236+ filterValues _ result _ = return result

src/Language/PureScript/Sugar/Names/Imports.hsnew file+202

@@ -0,0 +1,202 @@

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+

14+{-# LANGUAGE CPP #-}

15+{-# LANGUAGE FlexibleContexts #-}

16+{-# LANGUAGE ScopedTypeVariables #-}

17+{-# LANGUAGE TupleSections #-}

18+

19+module Language.PureScript.Sugar.Names.Imports (resolveImports) where

20+

21+import Data.List (find)

22+import Data.Maybe (fromMaybe, isNothing)

23+

24+import Control.Arrow (first)

25+#if __GLASGOW_HASKELL__ < 710

26+import Control.Applicative (Applicative(..), (<$>), (<*>))

27+#endif

28+import Control.Monad

29+import Control.Monad.Error.Class (MonadError(..))

30+import Control.Monad.Writer (MonadWriter(..), censor)

31+

32+import qualified Data.Map as M

33+

34+import Language.PureScript.AST

35+import Language.PureScript.Names

36+import Language.PureScript.Errors

37+import Language.PureScript.Sugar.Names.Env

38+

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

40+-- explicitly imported declarations.

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

42+findImports = foldM (go Nothing) M.empty

43+ where

44+ go pos result (ImportDeclaration mn typ qual) = do

45+ checkImportRefType typ

46+ let imp = (pos, typ, qual)

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

48+ go _ result (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go (Just pos) result d

49+ go _ result _ = return result

50+

51+ -- Ensure that classes don't appear in an `import X hiding (...)`

52+ checkImportRefType :: ImportDeclarationType -> m ()

53+ checkImportRefType (Hiding refs) = mapM_ checkImportRef refs

54+ checkImportRefType _ = return ()

55+ checkImportRef :: DeclarationRef -> m ()

56+ checkImportRef (ModuleRef name) = throwError . errorMessage $ ImportHidingModule name

57+ checkImportRef _ = return ()

58+

59+-- |

60+-- Constructs a set of imports for a module.

61+--

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

63+resolveImports env (Module _ _ currentModule decls _) =

64+ censor (onErrorMessages (ErrorInModule currentModule)) $ do

65+ scope <- M.insert currentModule [(Nothing, Implicit, Nothing)] <$> findImports decls

66+ foldM resolveImport' nullImports (M.toList scope)

67+ where

68+

69+ resolveImport' :: Imports -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) -> m Imports

70+ resolveImport' ie (mn, imps) = foldM go ie imps

71+ where

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

73+ go ie' (pos, typ, impQual) = do

74+ modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env

75+ let ie'' = ie' { importedModules = mn : importedModules ie' }

76+ positioned $ resolveImport currentModule mn modExports ie'' impQual typ

77+ where

78+ positioned err = case pos of

79+ Nothing -> err

80+ Just pos' -> rethrowWithPosition pos' err

81+

82+-- |

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

84+--

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

86+resolveImport currentModule importModule exps imps impQual =

87+ resolveByType

88+ where

89+

90+ resolveByType :: ImportDeclarationType -> m Imports

91+ resolveByType Implicit = importAll importExplicit

92+ resolveByType (Explicit explImports) = checkRefs explImports >> foldM importExplicit imps explImports

93+ resolveByType (Hiding hiddenImports) = checkRefs hiddenImports >> importAll (importNonHidden hiddenImports)

94+

95+ -- Check that a 'DeclarationRef' refers to an importable symbol

96+ checkRefs :: [DeclarationRef] -> m ()

97+ checkRefs = mapM_ check

98+ where

99+ check (PositionedDeclarationRef pos _ r) =

100+ rethrowWithPosition pos $ check r

101+ check (ValueRef name) =

102+ checkImportExists UnknownImportValue (fst `map` exportedValues exps) name

103+ check (TypeRef name dctors) = do

104+ checkImportExists UnknownImportType ((fst . fst) `map` exportedTypes exps) name

105+ let allDctors = fst `map` allExportedDataConstructors name

106+ maybe (return ()) (mapM_ $ checkDctorExists name allDctors) dctors

107+ check (TypeClassRef name) =

108+ checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name

109+ --check (ModuleRef name) =

110+ -- checkImportExists (const UnknownModule) (exportedModules exps) name

111+ check _ = error "Invalid argument to checkRefs"

112+

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

114+ checkImportExists :: (Eq a, Show a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()

115+ checkImportExists unknown exports item =

116+ when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item

117+

118+ -- Ensure that an explicitly imported data constructor exists for the type it is being imported

119+ -- from

120+ checkDctorExists :: ProperName -> [ProperName] -> ProperName -> m ()

121+ checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)

122+

123+ importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports

124+ importNonHidden hidden m ref | isHidden ref = return m

125+ | otherwise = importExplicit m ref

126+ where

127+ -- TODO: rework this to be not confusing

128+ isHidden :: DeclarationRef -> Bool

129+ isHidden ref'@(TypeRef _ _) = foldl (checkTypeRef ref') False hidden

130+ isHidden ref' = ref' `elem` hidden

131+ checkTypeRef :: DeclarationRef -> Bool -> DeclarationRef -> Bool

132+ checkTypeRef _ True _ = True

133+ checkTypeRef r acc (PositionedDeclarationRef _ _ h) = checkTypeRef r acc h

134+ checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc

135+ checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'

136+ checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'

137+ checkTypeRef (PositionedDeclarationRef _ _ r) acc hiddenRef = checkTypeRef r acc hiddenRef

138+ checkTypeRef _ acc _ = acc

139+

140+ -- Import all symbols

141+ importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports

142+ importAll importer = do

143+ imp' <- foldM (\m ((name, dctors), _) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)

144+ imp'' <- foldM (\m (name, _) -> importer m (ValueRef name)) imp' (exportedValues exps)

145+ foldM (\m (name, _) -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)

146+

147+ -- Import something explicitly

148+ importExplicit :: Imports -> DeclarationRef -> m Imports

149+ importExplicit imp (PositionedDeclarationRef pos _ r) =

150+ rethrowWithPosition pos . warnWithPosition pos $ importExplicit imp r

151+ importExplicit imp (ValueRef name) = do

152+ values' <- updateImports (importedValues imp) (exportedValues exps) name

153+ return $ imp { importedValues = values' }

154+ importExplicit imp (TypeRef name dctors) = do

155+ types' <- updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name

156+ let exportedDctors :: [(ProperName, ModuleName)]

157+ exportedDctors = allExportedDataConstructors name

158+ dctorNames :: [ProperName]

159+ dctorNames = fst `map` exportedDctors

160+ maybe (return ()) (mapM_ $ checkDctorExists name dctorNames) dctors

161+ when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name

162+ dctors' <- foldM (flip updateImports exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors)

163+ return $ imp { importedTypes = types', importedDataConstructors = dctors' }

164+ importExplicit imp (TypeClassRef name) = do

165+ typeClasses' <- updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name

166+ return $ imp { importedTypeClasses = typeClasses' }

167+ importExplicit _ _ = error "Invalid argument to importExplicit"

168+

169+ -- Find all exported data constructors for a given type

170+ allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)]

171+ allExportedDataConstructors name =

172+ case find ((== name) . fst . fst) (exportedTypes exps) of

173+ Nothing -> error "Invalid state in allExportedDataConstructors"

174+ Just ((_, dctors), mn) -> map (, mn) dctors

175+

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

177+ updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a, ModuleName)

178+ -> [(a, ModuleName)]

179+ -> a

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

181+ updateImports imps' exps' name = case M.lookup (Qualified impQual name) imps' of

182+

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

184+ -- where it was originally defined

185+ Nothing ->

186+ let mnOrig = fromMaybe (error "Invalid state in updateImports") (name `lookup` exps')

187+ in return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name, mnOrig) imps'

188+

189+ -- If the name already is present check whether it's a duplicate import

190+ -- before rejecting it. For example, if module A defines X, and module B

191+ -- re-exports A, importing A and B in C should not result in a "conflicting

192+ -- import for `x`" error

193+ Just (Qualified (Just mn) _, mnOrig)

194+ | mnOrig == fromMaybe (error "Invalid state in updateImports") (name `lookup` exps') -> return imps'

195+ | otherwise -> throwError . errorMessage $ err

196+ where

197+ err = if currentModule `elem` [mn, importModule]

198+ then ConflictingImport (show name) importModule

199+ else ConflictingImports (show name) mn importModule

200+

201+ Just (Qualified Nothing _, _) ->

202+ error "Invalid state in updateImports"

tests/Main.hs+1−2

@@ -1,8 +1,7 @@

1-----------------------------------------------------------------------------

2--

3-- Module : Main

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

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

6--

5--

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

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

8-- Stability : experimental

7-- Stability : experimental

tests/common/TestsSetup.hs+6−4

@@ -10,15 +10,17 @@

10-- |

11--

12-----------------------------------------------------------------------------

13+

14+{-# LANGUAGE CPP #-}

15+

13module TestsSetup where

16module TestsSetup where

15import Data.Maybe (fromMaybe)

18import Data.Maybe (fromMaybe)

16−import Control.Applicative

17−

18−import Control.Monad

20+#if __GLASGOW_HASKELL__ < 710

20import Control.Applicative

21import Control.Applicative

21−

22+#endif

23+import Control.Monad

22import Control.Monad.Trans.Maybe

24import Control.Monad.Trans.Maybe

24import System.Process

26import System.Process