a51686f · rowtype-yoga/purescript-native

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

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

commita51686fde97c39005098f4c68a7d8cf324168f4c authorAndrey Popp <8mayday@gmail.com> dateWed 30 Jul 2014, 11:43 (12 years ago) parenta316590

9 files changed+61−30

compare with golang

unifiedsplit

psci/Main.hs+1−1 src/Language/PureScript.hs+2−2 src/Language/PureScript/CodeGen/Externs.hs+1−1 src/Language/PureScript/CodeGen/JS.hs+1−1 src/Language/PureScript/Declarations.hs+3−3 src/Language/PureScript/ModuleDependencies.hs+1−1 src/Language/PureScript/Parser/Declarations.hs+7−2 src/Language/PureScript/Sugar/Names.hs+44−18 src/Language/PureScript/TypeChecker.hs+1−1

psci/Main.hs+1−1

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

src/Language/PureScript.hs+2−2

@@ -250,9 +250,9 @@ 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 Nothing Nothing Nothing : decls) exps

254254 where

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

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

256256 isExistingImport (PositionedDeclaration _ d) = isExistingImport d

257257 isExistingImport _ = False

258258

src/Language/PureScript/CodeGen/Externs.hs+1−1

@@ -43,7 +43,7 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

4343 where

4444

4545 declToPs :: Declaration -> Writer [String] ()

46− declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"]

46+ declToPs (ImportDeclaration mn _ _ _) = tell ["import " ++ show mn ++ " ()"]

4747 declToPs (FixityDeclaration (Fixity assoc prec) ident) =

4848 tell [ unwords [ show assoc, show prec, ident ] ]

4949 declToPs (PositionedDeclaration _ d) = declToPs d

src/Language/PureScript/CodeGen/JS.hs+1−1

@@ -78,7 +78,7 @@ importToJs mt opts mn = JSVariableIntroduction (moduleNameToJs mn) (Just moduleB

7878 Globals -> JSAccessor (moduleNameToJs mn) (JSVar (fromJust (optionsBrowserNamespace opts)))

7979

8080imports :: Declaration -> [ModuleName]

81−imports (ImportDeclaration mn _ _) = [mn]

81+imports (ImportDeclaration mn _ _ _) = [mn]

8282imports other =

8383 let (f, _, _, _, _) = everythingOnValues (++) (const []) collectV collectB (const []) (const [])

8484 in f other

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

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

158158 --

159159 | FixityDeclaration Fixity String

160160 -- |

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

162− -- name)

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

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

163163 --

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

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

165165 -- |

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

167167 --

src/Language/PureScript/ModuleDependencies.hs+1−1

@@ -49,7 +49,7 @@ usedModules :: Declaration -> [ModuleName]

4949usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) in nub . f

5050 where

5151 forDecls :: Declaration -> [ModuleName]

52− forDecls (ImportDeclaration mn _ _) = [mn]

52+ forDecls (ImportDeclaration mn _ _ _) = [mn]

5353 forDecls _ = []

5454

5555 forValues :: Value -> [ModuleName]

src/Language/PureScript/Parser/Declarations.hs+7−2

@@ -124,7 +124,8 @@ parseImportDeclaration = do

124124 stdImport = do

125125 moduleName' <- moduleName

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

127− return $ ImportDeclaration moduleName' idents Nothing

127+ hidingIdents <- P.optionMaybe hidingClause

128+ return $ ImportDeclaration moduleName' idents hidingIdents Nothing

128129 qualImport = do

129130 reserved "qualified"

130131 indented

@@ -132,7 +133,11 @@ parseImportDeclaration = do

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

133134 reserved "as"

134135 asQ <- moduleName

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

136+ return $ ImportDeclaration moduleName' idents Nothing (Just asQ)

137+ hidingClause = do

138+ reserved "hiding"

139+ indented *> (parens $ commaSep parseDeclarationRef)

140+

136141

137142parseDeclarationRef :: P.Parsec String ParseState DeclarationRef

138143parseDeclarationRef = PositionedDeclarationRef <$> sourcePos <*>

src/Language/PureScript/Sugar/Names.hs+44−18

@@ -364,14 +364,16 @@ filterExports mn exps env = do

364364--

365365type ExplicitImports = [DeclarationRef]

366366

367+type HiddenImports = [DeclarationRef]

368+

367369-- |

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

369371-- explicitly imported declarations.

370372--

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

373+findImports :: [Declaration] -> M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe HiddenImports, Maybe ModuleName)

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

373375 where

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

376+ findImports' pos result (ImportDeclaration mn expl hidden qual) = M.insert mn (pos, expl, hidden, qual) result

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

376378 findImports' _ result _ = result

377379

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

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

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

388390 -- for the module

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

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

391+ scope :: M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe HiddenImports, Maybe ModuleName)

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

391393

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

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

394+ resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, Maybe ExplicitImports, Maybe HiddenImports, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment

395+ resolveImport' imp (mn, (pos, explImports, hiddenImports, impQual)) = do

394396 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

397+ positioned $ resolveImport currentModule mn modExports imp impQual explImports hiddenImports

396398 where

397399 positioned err = case pos of

398400 Nothing -> err

@@ -401,37 +403,61 @@ resolveImports env (Module currentModule decls _) =

401403-- |

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

403405--

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)

406+resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> Maybe ExplicitImports -> Maybe HiddenImports -> Either ErrorStack ImportEnvironment

407+resolveImport currentModule importModule exps imps impQual explImports hiddenImports =

408+ maybe importAll (foldM importExplicit imps) explImports

406409 where

407410

408411 -- Import everything from a module

409412 importAll :: Either ErrorStack ImportEnvironment

410413 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)

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

415+ imp'' <- foldM (\m name -> importExplicitNotHidden m (ValueRef name)) imp' (exportedValues exps)

416+ foldM (\m name -> importExplicitNotHidden m (TypeClassRef name)) imp'' (exportedTypeClasses exps)

417+

418+ -- Import something explicitly only if it's not hidden

419+ importExplicitNotHidden :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment

420+ importExplicitNotHidden m value = do

421+ hidden <- hiddenImports'

422+ if elem value hidden then (Right m) else importExplicit m value

414423

415424 -- Import something explicitly

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

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

418− importExplicit imp (ValueRef name) = do

419− _ <- checkImportExists "value" values name

427+ importExplicit imp ref@(ValueRef name) = do

428+ _ <- checkRefIsValid ref

420429 values' <- updateImports (importedValues imp) name

421430 return $ imp { importedValues = values' }

422− importExplicit imp (TypeRef name dctors) = do

423− _ <- checkImportExists "type" availableTypes name

431+ importExplicit imp ref@(TypeRef name dctors) = do

432+ _ <- checkRefIsValid ref

424433 types' <- updateImports (importedTypes imp) name

425434 let allDctors = allExportedDataConstructors name

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

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

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

429− importExplicit imp (TypeClassRef name) = do

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

438+ importExplicit imp ref@(TypeClassRef name) = do

439+ _ <- checkRefIsValid ref

431440 typeClasses' <- updateImports (importedTypeClasses imp) name

432441 return $ imp { importedTypeClasses = typeClasses' }

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

434443

444+ -- hiddenImports checked for validness

445+ hiddenImports' =

446+ mapM checkRefIsValid (fromMaybe [] hiddenImports)

447+

448+ -- Check if DeclarationRef points to a existent symbol

449+ checkRefIsValid :: DeclarationRef -> Either ErrorStack DeclarationRef

450+ checkRefIsValid ref@(PositionedDeclarationRef pos r) = do

451+ _ <- rethrowWithPosition pos $ checkRefIsValid r

452+ return ref

453+ checkRefIsValid ref@(ValueRef name) =

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

455+ checkRefIsValid ref@(TypeRef name _) =

456+ checkImportExists "type" availableTypes name >> return ref

457+ checkRefIsValid ref@(TypeClassRef name) =

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

459+ checkRefIsValid _ = error "Invalid argument to checkRefIsValid"

460+

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

436462 allExportedDataConstructors :: ProperName -> [ProperName]

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

src/Language/PureScript/TypeChecker.hs+1−1

@@ -188,7 +188,7 @@ typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = d

188188 env <- getEnv

189189 guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env

190190 return $ d : ds

191−typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _) : rest) = do

191+typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _ _) : rest) = do

192192 tcds <- getTypeClassDictionaries

193193 let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in moduleName == mn) tcds

194194 addTypeClassDictionaries [ tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }