5299aa1 · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #522 from andreypopp/feature/import-hiding

5299aa1Gary Burgess12 years ago

examples/passing/ImportHiding.pursnew file+18

compare with golang

unifiedsplit

@@ -0,0 +1,18 @@

1+module Main where

3+import Debug.Trace

4+import Prelude hiding (

5+ show, -- a value

6+ Show, -- a type class

7+ Unit(..) -- a constructor

8+ )

10+show = 1

11+

12+class Show a where

13+ noshow :: a -> a

14+

15+data Unit = X | Y

16+

17+main = do

18+ print show

psci/Main.hs+2−2

@@ -246,7 +246,7 @@ createTemporaryModule :: Bool -> PSCiState -> P.Value -> P.Module

246createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetBindings = lets} value =

247 let

248 moduleName = P.ModuleName [P.ProperName "Main"]

249− importDecl m = P.ImportDeclaration m Nothing Nothing

249+ importDecl m = P.ImportDeclaration m P.Unqualified Nothing

250 traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"]

251 trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))

252 itValue = foldl (\x f -> f x) value lets

@@ -264,7 +264,7 @@ createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module

264createTemporaryModuleForKind PSCiState{psciImportedModuleNames = imports} typ =

265 let

266 moduleName = P.ModuleName [P.ProperName "Main"]

267− importDecl m = P.ImportDeclaration m Nothing Nothing

267+ importDecl m = P.ImportDeclaration m P.Unqualified Nothing

268 itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ

269 in

270 P.Module moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing

src/Language/PureScript.hs+1−1

@@ -250,7 +250,7 @@ reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]

250addDefaultImport :: ModuleName -> Module -> Module

251addDefaultImport toImport m@(Module mn decls exps) =

252 if isExistingImport `any` decls || mn == toImport then m

253− else Module mn (ImportDeclaration toImport Nothing Nothing : decls) exps

253+ else Module mn (ImportDeclaration toImport Unqualified Nothing : decls) exps

254 where

255 isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True

256 isExistingImport (PositionedDeclaration _ d) = isExistingImport d

src/Language/PureScript/Declarations.hs+21−3

@@ -113,6 +113,24 @@ instance Eq DeclarationRef where

113 r == (PositionedDeclarationRef _ r') = r == r'

114 _ == _ = False

115

116+-- |

117+-- The data type which specifies type of import declaration

118+--

119+data ImportDeclarationType

120+ -- |

121+ -- Unqualified import

122+ --

123+ = Unqualified

124+ -- |

125+ -- Qualified import with a list of references to import

126+ --

127+ | Qualifying [DeclarationRef]

128+ -- |

129+ -- Import with hiding clause with a list of references to hide

130+ --

131+ | Hiding [DeclarationRef]

132+ deriving (Show, D.Data, D.Typeable)

133+

116-- |

134-- |

117-- The data type of declarations

135-- The data type of declarations

118--

136--

@@ -158,10 +176,10 @@ data Declaration

158 --

176 --

159 | FixityDeclaration Fixity String

177 | FixityDeclaration Fixity String

160 -- |

178 -- |

161− -- A module import (module name, optional set of identifiers to import, optional "qualified as"

179+ -- A module import (module name, optional set of identifiers to import,

162− -- name)

180+ -- optional set of identifiers to hide, optional "qualified as" name)

163 --

181 --

164− | ImportDeclaration ModuleName (Maybe [DeclarationRef]) (Maybe ModuleName)

182+ | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName)

165 -- |

183 -- |

166 -- A type class declaration (name, argument, implies, member declarations)

184 -- A type class declaration (name, argument, implies, member declarations)

167 --

185 --

src/Language/PureScript/Parser/Declarations.hs+15−4

@@ -123,16 +123,27 @@ parseImportDeclaration = do

123 where

124 stdImport = do

125 moduleName' <- moduleName

126− idents <- P.optionMaybe $ indented *> (parens $ commaSep parseDeclarationRef)

126+ stdImportHiding moduleName' <|> stdImportQualifying moduleName'

127+ where

128+ stdImportHiding mn = do

129+ reserved "hiding"

130+ declType <- importDeclarationType Hiding

131+ return $ ImportDeclaration mn declType Nothing

132+ stdImportQualifying mn = do

133+ declType <- importDeclarationType Qualifying

127− return $ ImportDeclaration moduleName' idents Nothing

134+ return $ ImportDeclaration mn declType Nothing

128 qualImport = do

135 qualImport = do

129 reserved "qualified"

136 reserved "qualified"

130 indented

137 indented

131 moduleName' <- moduleName

138 moduleName' <- moduleName

132− idents <- P.optionMaybe $ indented *> (parens $ commaSep parseDeclarationRef)

139+ declType <- importDeclarationType Qualifying

133 reserved "as"

140 reserved "as"

134 asQ <- moduleName

141 asQ <- moduleName

135− return $ ImportDeclaration moduleName' idents (Just asQ)

142+ return $ ImportDeclaration moduleName' declType (Just asQ)

143+ importDeclarationType expectedType = do

144+ idents <- P.optionMaybe $ indented *> (parens $ commaSep parseDeclarationRef)

145+ return $ fromMaybe Unqualified (expectedType <$> idents)

146+

136

147

137parseDeclarationRef :: P.Parsec String ParseState DeclarationRef

148parseDeclarationRef :: P.Parsec String ParseState DeclarationRef

138parseDeclarationRef = PositionedDeclarationRef <$> sourcePos <*>

149parseDeclarationRef = PositionedDeclarationRef <$> sourcePos <*>

src/Language/PureScript/Sugar/Names.hs+59−24

@@ -359,19 +359,14 @@ filterExports mn exps env = do

359 else throwError $ mkErrorStack ("Cannot export undefined value '" ++ show name ++ "'") Nothing

360 filterValues _ result _ = return result

361

362−-- |

363−-- Type representing a set of declarations being explicitly imported from a module

364−--

365−type ExplicitImports = [DeclarationRef]

366−

367-- |

362-- |

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

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

369-- explicitly imported declarations.

364-- explicitly imported declarations.

370--

365--

371−findImports :: [Declaration] -> M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)

366+findImports :: [Declaration] -> M.Map ModuleName (Maybe SourcePos, ImportDeclarationType, Maybe ModuleName)

372findImports = foldl (findImports' Nothing) M.empty

367findImports = foldl (findImports' Nothing) M.empty

373 where

368 where

374− findImports' pos result (ImportDeclaration mn expl qual) = M.insert mn (pos, expl, qual) result

369+ findImports' pos result (ImportDeclaration mn typ qual) = M.insert mn (pos, typ, qual) result

375 findImports' _ result (PositionedDeclaration pos d) = findImports' (Just pos) result d

370 findImports' _ result (PositionedDeclaration pos d) = findImports' (Just pos) result d

376 findImports' _ result _ = result

371 findImports' _ result _ = result

377

372

@@ -386,13 +381,13 @@ resolveImports env (Module currentModule decls _) =

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

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

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

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

388 -- for the module

383 -- for the module

389− scope :: M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)

384+ scope :: M.Map ModuleName (Maybe SourcePos, ImportDeclarationType, Maybe ModuleName)

390− scope = M.insert currentModule (Nothing, Nothing, Nothing) (findImports decls)

385+ scope = M.insert currentModule (Nothing, Unqualified, Nothing) (findImports decls)

391

386

392− resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment

387+ resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, ImportDeclarationType, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment

393− resolveImport' imp (mn, (pos, explImports, impQual)) = do

388+ resolveImport' imp (mn, (pos, typ, impQual)) = do

394 modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env

389 modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env

395− positioned $ resolveImport currentModule mn modExports imp impQual explImports

390+ positioned $ resolveImport currentModule mn modExports imp impQual typ

396 where

391 where

397 positioned err = case pos of

392 positioned err = case pos of

398 Nothing -> err

393 Nothing -> err

@@ -401,37 +396,77 @@ resolveImports env (Module currentModule decls _) =

401-- |

396-- |

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

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

403--

398--

404−resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> Maybe ExplicitImports-> Either ErrorStack ImportEnvironment

399+resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> Either ErrorStack ImportEnvironment

405−resolveImport currentModule importModule exps imps impQual = maybe importAll (foldM importExplicit imps)

400+resolveImport currentModule importModule exps imps impQual =

401+ resolveByType

406 where

402 where

407

403

408− -- Import everything from a module

404+ resolveByType :: ImportDeclarationType -> Either ErrorStack ImportEnvironment

405+ resolveByType Unqualified = importAll importExplicit

406+ resolveByType (Qualifying explImports) = (checkedRefs >=> foldM importExplicit imps) explImports

407+ resolveByType (Hiding hiddenImports) = do

408+ hiddenImports' <- checkedRefs hiddenImports

409+ importAll (importNonHidden hiddenImports')

410+

411+ importNonHidden :: [DeclarationRef] -> ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment

412+ importNonHidden hidden m ref =

413+ if isHidden hidden ref

414+ then return m

415+ else importExplicit m ref

416+

417+ isHidden :: [DeclarationRef] -> DeclarationRef -> Bool

418+ isHidden hidden ref@(TypeRef _ _) =

419+ let

420+ checkTypeRef _ True _ = True

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

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

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

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

425+ checkTypeRef _ acc _ = acc

426+ in foldl (checkTypeRef ref) False hidden

427+ isHidden hidden ref = ref `elem` hidden

428+

429+ -- Import all symbols

409− importAll :: Either ErrorStack ImportEnvironment

430+ importAll :: (ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment) -> Either ErrorStack ImportEnvironment

410− importAll = do

431+ importAll importer = do

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

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

412− imp'' <- foldM (\m name -> importExplicit m (ValueRef name)) imp' (exportedValues exps)

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

413− foldM (\m name -> importExplicit m (TypeClassRef name)) imp'' (exportedTypeClasses exps)

434+ foldM (\m name -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)

414

435

415 -- Import something explicitly

436 -- Import something explicitly

416 importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment

437 importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment

417 importExplicit imp (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ importExplicit imp r

438 importExplicit imp (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ importExplicit imp r

418 importExplicit imp (ValueRef name) = do

439 importExplicit imp (ValueRef name) = do

419− _ <- checkImportExists "value" values name

420 values' <- updateImports (importedValues imp) name

440 values' <- updateImports (importedValues imp) name

421 return $ imp { importedValues = values' }

441 return $ imp { importedValues = values' }

422 importExplicit imp (TypeRef name dctors) = do

442 importExplicit imp (TypeRef name dctors) = do

423− _ <- checkImportExists "type" availableTypes name

424 types' <- updateImports (importedTypes imp) name

443 types' <- updateImports (importedTypes imp) name

425 let allDctors = allExportedDataConstructors name

444 let allDctors = allExportedDataConstructors name

426 dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors

445 dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors

427 dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'

446 dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'

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

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

429 importExplicit imp (TypeClassRef name) = do

448 importExplicit imp (TypeClassRef name) = do

430− _ <- checkImportExists "type class" classes name

431 typeClasses' <- updateImports (importedTypeClasses imp) name

449 typeClasses' <- updateImports (importedTypeClasses imp) name

432 return $ imp { importedTypeClasses = typeClasses' }

450 return $ imp { importedTypeClasses = typeClasses' }

433 importExplicit _ _ = error "Invalid argument to importExplicit"

451 importExplicit _ _ = error "Invalid argument to importExplicit"

434

452

453+ -- Check if DeclarationRef points to an existent symbol

454+ checkedRefs :: [DeclarationRef] -> Either ErrorStack [DeclarationRef]

455+ checkedRefs refs = mapM check refs

456+ where

457+ check (PositionedDeclarationRef pos r) = do

458+ rethrowWithPosition pos $ check r

459+ check ref@(ValueRef name) =

460+ checkImportExists "value" values name >> return ref

461+ check ref@(TypeRef name dctors) = do

462+ _ <- checkImportExists "type" availableTypes name

463+ let allDctors = allExportedDataConstructors name

464+ _ <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors

465+ return ref

466+ check ref@(TypeClassRef name) =

467+ checkImportExists "type class" classes name >> return ref

468+ check _ = error "Invalid argument to checkRefIsValid"

469+

435 -- Find all exported data constructors for a given type

470 -- Find all exported data constructors for a given type

436 allExportedDataConstructors :: ProperName -> [ProperName]

471 allExportedDataConstructors :: ProperName -> [ProperName]

437 allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps

472 allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps

@@ -444,7 +479,7 @@ resolveImport currentModule importModule exps imps impQual = maybe importAll (fo

444 Just x@(Qualified (Just mn) _) -> throwError $ mkErrorStack err Nothing

479 Just x@(Qualified (Just mn) _) -> throwError $ mkErrorStack err Nothing

445 where

480 where

446 err = if mn == currentModule || importModule == currentModule

481 err = if mn == currentModule || importModule == currentModule

447− then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"

482+ then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just mn) name) ++ "'"

448 else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"

483 else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"

449

484

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

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