3057898 · rowtype-yoga/purescript-native

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

on golang help sign in

Refactor ImportDeclaration

3057898Andrey Popp12 years ago

psci/Main.hs+1−1

compare with golang

unifiedsplit

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

src/Language/PureScript.hs+2−2

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

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

254 where

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

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

256 isExistingImport (PositionedDeclaration _ d) = isExistingImport d

257 isExistingImport _ = False

258

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

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

43 where

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

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

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

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

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

49 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

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

80imports :: Declaration -> [ModuleName]

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

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

82imports other =

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

84 in f other

src/Language/PureScript/Declarations.hs+19−1

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

@@ -161,7 +179,7 @@ data Declaration

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

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

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

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

163 --

181 --

164− | ImportDeclaration ModuleName (Maybe [DeclarationRef]) (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/ModuleDependencies.hs+1−1

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

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

50 where

51 forDecls :: Declaration -> [ModuleName]

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

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

53 forDecls _ = []

55 forValues :: Value -> [ModuleName]

src/Language/PureScript/Parser/Declarations.hs+14−8

@@ -123,20 +123,26 @@ parseImportDeclaration = do

123 where

124 stdImport = do

125 moduleName' <- moduleName

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

126+ stdImportHiding moduleName' <|> stdImportQualifying moduleName'

127− hidingIdents <- P.optionMaybe hidingClause

127+ where

128+ stdImportHiding moduleName' = do

129+ reserved "hiding"

130+ declType <- importDeclarationType Hiding

131+ return $ ImportDeclaration moduleName' declType Nothing

132+ stdImportQualifying moduleName' = do

133+ declType <- importDeclarationType Qualifying

128− return $ ImportDeclaration moduleName' idents hidingIdents Nothing

134+ return $ ImportDeclaration moduleName' declType Nothing

129 qualImport = do

135 qualImport = do

130 reserved "qualified"

136 reserved "qualified"

131 indented

137 indented

132 moduleName' <- moduleName

138 moduleName' <- moduleName

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

139+ declType <- importDeclarationType Qualifying

134 reserved "as"

140 reserved "as"

135 asQ <- moduleName

141 asQ <- moduleName

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

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

137− hidingClause = do

143+ importDeclarationType expectedType = do

138− reserved "hiding"

139− indented *> (parens $ commaSep parseDeclarationRef)

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

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

140

146

141

147

142parseDeclarationRef :: P.Parsec String ParseState DeclarationRef

148parseDeclarationRef :: P.Parsec String ParseState DeclarationRef

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

@@ -359,21 +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−type HiddenImports = [DeclarationRef]

368−

369-- |

362-- |

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

371-- explicitly imported declarations.

364-- explicitly imported declarations.

372--

365--

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

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

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

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

375 where

368 where

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

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

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

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

378 findImports' _ result _ = result

371 findImports' _ result _ = result

379

372

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

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

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

390 -- for the module

383 -- for the module

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

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

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

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

393

386

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

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

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

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

396 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

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

390+ positioned $ resolveImport currentModule mn modExports imp impQual typ

398 where

391 where

399 positioned err = case pos of

392 positioned err = case pos of

400 Nothing -> err

393 Nothing -> err

@@ -403,23 +396,41 @@ resolveImports env (Module currentModule decls _) =

403-- |

396-- |

404-- 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.

405--

398--

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

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

407−resolveImport currentModule importModule exps imps impQual explImports hiddenImports =

400+resolveImport currentModule importModule exps imps impQual =

408− maybe importAll (foldM (\m -> checkRefIsValid >=> (importExplicit m)) imps) explImports

401+ resolveByType

409 where

402 where

410

403

411− -- 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 _ acc _ = acc

425+ in foldl (checkTypeRef ref) False hidden

426+ isHidden hidden ref = ref `elem` hidden

427+

428+ -- Import all symbols

412− importAll :: Either ErrorStack ImportEnvironment

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

413− importAll = do

430+ importAll importer = do

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

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

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

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

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

433+ foldM (\m name -> importer 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

423

434

424 -- Import something explicitly

435 -- Import something explicitly

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

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

@@ -438,22 +449,22 @@ resolveImport currentModule importModule exps imps impQual explImports hiddenImp

438 return $ imp { importedTypeClasses = typeClasses' }

449 return $ imp { importedTypeClasses = typeClasses' }

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

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

440

451

441− -- hiddenImports checked for validness

442− hiddenImports' =

443− mapM checkRefIsValid (fromMaybe [] hiddenImports)

444−

445 -- Check if DeclarationRef points to a existent symbol

452 -- Check if DeclarationRef points to a existent symbol

446− checkRefIsValid :: DeclarationRef -> Either ErrorStack DeclarationRef

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

454+ checkedRefs refs = mapM check refs

455+ where

447− checkRefIsValid ref@(PositionedDeclarationRef pos r) = do

456+ check (PositionedDeclarationRef pos r) = do

448− _ <- rethrowWithPosition pos $ checkRefIsValid r

457+ rethrowWithPosition pos $ check r

449− return ref

450− checkRefIsValid ref@(ValueRef name) =

458+ check ref@(ValueRef name) =

451− checkImportExists "value" values name >> return ref

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

452− checkRefIsValid ref@(TypeRef name _) =

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

453− checkImportExists "type" availableTypes name >> return ref

461+ _ <- checkImportExists "type" availableTypes name

462+ let allDctors = allExportedDataConstructors name

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

464+ return ref

454− checkRefIsValid ref@(TypeClassRef name) =

465+ check ref@(TypeClassRef name) =

455− checkImportExists "type class" classes name >> return ref

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

456− checkRefIsValid _ = error "Invalid argument to checkRefIsValid"

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

457

468

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

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

459 allExportedDataConstructors :: ProperName -> [ProperName]

470 allExportedDataConstructors :: ProperName -> [ProperName]

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

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

188 env <- getEnv

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

190 return $ d : ds

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

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

192 tcds <- getTypeClassDictionaries

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

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