5299aa1 · rowtype-yoga/purescript-native

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

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

Add `import ... hiding (...)` construct

commit5299aa198e9b5a214d54205c02006dfdfb331272 authorGary Burgess <gary.burgess@gmail.com> dateMon 4 Aug 2014, 21:14 (12 years ago) parenta316590 4e5071b

6 files changed+116−34

compare with golang

unifiedsplit

examples/passing/ImportHiding.purs+18 psci/Main.hs+2−2 src/Language/PureScript.hs+1−1 src/Language/PureScript/Declarations.hs+21−3 src/Language/PureScript/Parser/Declarations.hs+15−4 src/Language/PureScript/Sugar/Names.hs+59−24

examples/passing/ImportHiding.pursnew file+18

@@ -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

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

247247 let

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

249− importDecl m = P.ImportDeclaration m Nothing Nothing

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

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

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

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

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

264264createTemporaryModuleForKind PSCiState{psciImportedModuleNames = imports} typ =

265265 let

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

267− importDecl m = P.ImportDeclaration m Nothing Nothing

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

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

269269 in

270270 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 ]

250250addDefaultImport :: ModuleName -> Module -> Module

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

252252 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

254254 where

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

256256 isExistingImport (PositionedDeclaration _ d) = isExistingImport d

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

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

113113 r == (PositionedDeclarationRef _ r') = r == r'

114114 _ == _ = False

115115

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+

116134-- |

117135-- The data type of declarations

118136--

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

158176 --

159177 | FixityDeclaration Fixity String

160178 -- |

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

162− -- name)

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

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

163181 --

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

182+ | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName)

165183 -- |

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

167185 --

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

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

123123 where

124124 stdImport = do

125125 moduleName' <- moduleName

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

127− return $ ImportDeclaration moduleName' idents Nothing

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

134+ return $ ImportDeclaration mn declType Nothing

128135 qualImport = do

129136 reserved "qualified"

130137 indented

131138 moduleName' <- moduleName

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

139+ declType <- importDeclarationType Qualifying

133140 reserved "as"

134141 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+

136147

137148parseDeclarationRef :: P.Parsec String ParseState DeclarationRef

138149parseDeclarationRef = PositionedDeclarationRef <$> sourcePos <*>

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

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

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

360360 filterValues _ result _ = return result

361361

362−-- |

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

364−--

365−type ExplicitImports = [DeclarationRef]

366−

367362-- |

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

369364-- explicitly imported declarations.

370365--

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

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

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

373368 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

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

376371 findImports' _ result _ = result

377372

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

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

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

388383 -- for the module

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

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

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

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

391386

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

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

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

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

394389 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

396391 where

397392 positioned err = case pos of

398393 Nothing -> err

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

401396-- |

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

403398--

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

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

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

400+resolveImport currentModule importModule exps imps impQual =

401+ resolveByType

406402 where

407403

408− -- Import everything from a module

409− importAll :: Either ErrorStack ImportEnvironment

410− importAll = do

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

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

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

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

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

431+ importAll importer = do

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

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

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

414435

415436 -- Import something explicitly

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

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

418439 importExplicit imp (ValueRef name) = do

419− _ <- checkImportExists "value" values name

420440 values' <- updateImports (importedValues imp) name

421441 return $ imp { importedValues = values' }

422442 importExplicit imp (TypeRef name dctors) = do

423− _ <- checkImportExists "type" availableTypes name

424443 types' <- updateImports (importedTypes imp) name

425444 let allDctors = allExportedDataConstructors name

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

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

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

429448 importExplicit imp (TypeClassRef name) = do

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

431449 typeClasses' <- updateImports (importedTypeClasses imp) name

432450 return $ imp { importedTypeClasses = typeClasses' }

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

434452

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+

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

436471 allExportedDataConstructors :: ProperName -> [ProperName]

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

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

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

445480 where

446481 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) ++ "'"

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

449484

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