bc72c55 · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #1184 from ilexlabs/module-exports

bc72c55Gary Burgess11 years ago

examples/passing/ModuleExport.pursnew file+9

compare with golang

unifiedsplit

@@ -0,0 +1,9 @@

1+module A (module Prelude) where

2+ import Prelude

4+module Main where

5+ import Debug.Trace

6+ import A

8+ main = do

9+ print (show 1.0)

examples/passing/ModuleExportDupes.pursnew file+19

@@ -0,0 +1,19 @@

1+module A (module Prelude) where

2+ import Prelude

4+module B (module Prelude) where

5+ import Prelude

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

8+ import Prelude

9+ import A

10+

11+module Main where

12+ import Debug.Trace

13+ import A

14+ import B

15+ import C

16+ import Prelude

17+

18+ main = do

19+ print (show 1.0)

examples/passing/ModuleExportExcluded.pursnew file+14

@@ -0,0 +1,14 @@

1+module A (module Prelude, foo) where

2+ import Prelude

4+ foo :: Number -> Number

5+ foo _ = 0.0

7+module Main where

8+ import Debug.Trace

9+ import A (foo)

10+

11+ otherwise = false

12+

13+ main = do

14+ print "1.0"

examples/passing/ModuleExportHiding.pursnew file+11

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

1+module A (module Prelude) where

2+ import Prelude

4+module Main where

5+ import Debug.Trace

6+ import A hiding (module Prelude)

8+ otherwise = false

10+ main = do

11+ print "1.0"

examples/passing/ModuleExportQualified.pursnew file+9

@@ -0,0 +1,9 @@

1+module A (module Prelude) where

2+ import Prelude

4+module Main where

5+ import Debug.Trace

6+ import qualified A as B

8+ main = do

9+ print (B.show 1.0)

examples/passing/ModuleExportSelf.pursnew file+14

@@ -0,0 +1,14 @@

1+module A (module A, module Prelude) where

2+ import Prelude

4+ type Foo = Boolean

6+module Main where

7+ import Debug.Trace

8+ import A

10+ bar :: Foo

11+ bar = true

12+

13+ main = do

14+ print (show bar)

psci/PSCi.hs+1

@@ -315,6 +315,7 @@ handleShowImportedModules = do

315 showRef (P.ValueRef ident) = show ident

316 showRef (P.TypeClassRef pn) = show pn

317 showRef (P.TypeInstanceRef ident) = show ident

318+ showRef (P.ModuleRef name) = "module " ++ show name

318 showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref

319 showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref

319

320

320 commaList :: [String] -> String

321 commaList :: [String] -> String

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

@@ -61,6 +61,10 @@ data DeclarationRef

61 --

62 | TypeInstanceRef Ident

63 -- |

64+ -- A module, in its entirety

65+ --

66+ | ModuleRef ModuleName

67+ -- |

64 -- A declaration reference with source position information

68 -- A declaration reference with source position information

65 --

69 --

66 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

70 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

@@ -71,6 +75,7 @@ instance Eq DeclarationRef where

71 (ValueRef name) == (ValueRef name') = name == name'

75 (ValueRef name) == (ValueRef name') = name == name'

72 (TypeClassRef name) == (TypeClassRef name') = name == name'

76 (TypeClassRef name) == (TypeClassRef name') = name == name'

73 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

77 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

78+ (ModuleRef name) == (ModuleRef name') = name == name'

74 (PositionedDeclarationRef _ _ r) == r' = r == r'

79 (PositionedDeclarationRef _ _ r) == r' = r == r'

75 r == (PositionedDeclarationRef _ _ r') = r == r'

80 r == (PositionedDeclarationRef _ _ r') = r == r'

76 _ == _ = False

81 _ == _ = False

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

@@ -38,11 +38,24 @@ import Language.PureScript.Types

38moduleToPs :: Module -> Environment -> String

39moduleToPs (Module _ _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"

40moduleToPs (Module _ moduleName ds (Just exts)) env = intercalate "\n" . execWriter $ do

41+ let exps = listExports exts

41− tell [ "module " ++ runModuleName moduleName ++ " where"]

42+ tell ["module " ++ runModuleName moduleName ++ (if null exps then "" else " (" ++ exps ++ ")") ++ " where"]

42 mapM_ declToPs ds

43 mapM_ declToPs ds

43 mapM_ exportToPs exts

44 mapM_ exportToPs exts

44 where

45 where

47+ listExports :: [DeclarationRef] -> String

48+ listExports = intercalate ", " . mapMaybe listExport

49+

50+ listExport :: DeclarationRef -> Maybe String

51+ listExport (PositionedDeclarationRef _ _ d) = listExport d

52+ listExport (TypeRef name Nothing) = Just $ show name ++ "()"

53+ listExport (TypeRef name (Just dctors)) = Just $ show name ++ "(" ++ intercalate ", " (map show dctors) ++ ")"

54+ listExport (ValueRef name) = Just $ show name

55+ listExport (TypeClassRef name) = Just $ show name

56+ listExport (ModuleRef name) = Just $ "module " ++ show name

57+ listExport _ = Nothing

58+

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

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

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

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

48 declToPs (FixityDeclaration (Fixity assoc prec) op) =

61 declToPs (FixityDeclaration (Fixity assoc prec) op) =

@@ -113,6 +126,8 @@ moduleToPs (Module _ moduleName ds (Just exts)) env = intercalate "\n" . execWri

113 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "

126 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "

114 tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]

127 tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]

115

128

129+ exportToPs (ModuleRef _) = return ()

130+

116 toTypeVar :: (String, Maybe Kind) -> Type

131 toTypeVar :: (String, Maybe Kind) -> Type

117 toTypeVar (s, Nothing) = TypeVar s

132 toTypeVar (s, Nothing) = TypeVar s

118 toTypeVar (s, Just k) = KindedType (TypeVar s) k

133 toTypeVar (s, Just k) = KindedType (TypeVar s) k

src/Language/PureScript/Errors.hs+1

@@ -688,6 +688,7 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag

688 prettyPrintExport (ValueRef ident) = show ident

689 prettyPrintExport (TypeClassRef pn) = show pn

690 prettyPrintExport (TypeInstanceRef ident) = show ident

691+ prettyPrintExport (ModuleRef name) = "module " ++ show name

691 prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

692 prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

692

693

693 -- |

694 -- |

src/Language/PureScript/Parser/Declarations.hs+9−1

@@ -186,11 +186,19 @@ parseImportDeclaration' = do

186

187

188parseDeclarationRef :: TokenParser DeclarationRef

189+parseDeclarationRef =

190+ parseModuleRef <|> (

189−parseDeclarationRef = withSourceSpan PositionedDeclarationRef $

191+ withSourceSpan PositionedDeclarationRef $

190 ValueRef <$> parseIdent

192 ValueRef <$> parseIdent

191 <|> do name <- properName

193 <|> do name <- properName

192 dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)

194 dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)

193 return $ maybe (TypeClassRef name) (TypeRef name) dctors

195 return $ maybe (TypeClassRef name) (TypeRef name) dctors

196+ )

197+ where

198+ parseModuleRef :: TokenParser DeclarationRef

199+ parseModuleRef = do

200+ name <- indented *> reserved "module" *> moduleName

201+ return $ ModuleRef name

194

202

195parseTypeClassDeclaration :: TokenParser Declaration

203parseTypeClassDeclaration :: TokenParser Declaration

196parseTypeClassDeclaration = do

204parseTypeClassDeclaration = do

src/Language/PureScript/Sugar/Names.hs+74−7

@@ -14,13 +14,14 @@

15{-# LANGUAGE FlexibleContexts #-}

16{-# LANGUAGE ScopedTypeVariables #-}

17+{-# LANGUAGE PatternGuards #-}

18module Language.PureScript.Sugar.Names (

19module Language.PureScript.Sugar.Names (

19 desugarImports

20 desugarImports

20) where

21) where

22−import Data.List (nub)

23+import Data.List (find, nub, (\\))

23−import Data.Maybe (fromMaybe, isJust, mapMaybe)

24+import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)

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

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

26import Control.Monad

27import Control.Monad

@@ -59,6 +60,10 @@ data Exports = Exports

59 -- The values exported from each module

60 -- The values exported from each module

60 --

61 --

61 , exportedValues :: [Ident]

62 , exportedValues :: [Ident]

63+ -- |

64+ -- The modules exported from each module

65+ --

66+ , exportedModules :: [ModuleName]

62 } deriving (Show)

67 } deriving (Show)

64-- |

69-- |

@@ -101,7 +106,7 @@ addEmptyModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironm

101addEmptyModule env name =

106addEmptyModule env name =

102 if name `M.member` env

107 if name `M.member` env

103 then throwError . errorMessage $ RedefinedModule name

108 then throwError . errorMessage $ RedefinedModule name

104− else return $ M.insert name (Exports [] [] []) env

109+ else return $ M.insert name (Exports [] [] [] []) env

105

110

106-- |

111-- |

107-- Adds a type belonging to a module to the export environment.

112-- Adds a type belonging to a module to the export environment.

@@ -155,13 +160,65 @@ desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Mod

155desugarImports modules = do

160desugarImports modules = do

156 unfilteredExports <- findExports modules

161 unfilteredExports <- findExports modules

157 exports <- foldM filterModuleExports unfilteredExports modules

162 exports <- foldM filterModuleExports unfilteredExports modules

163+ let modules' = moduleReexports <$> modules

158− mapM (renameInModule' unfilteredExports exports) modules

164+ mapM (renameInModule' unfilteredExports exports) modules'

159 where

165 where

166+ moduleReexports :: Module -> Module

167+ moduleReexports (Module coms mn decls exps) =

168+ let importedMods = catMaybes findImports'

169+ in (Module coms mn (decls ++ (concatMap reexports importedMods)) exps)

170+ where

171+ imports :: [Declaration]

172+ imports = filter isImportDecl decls

173+ findImports' :: [Maybe (Declaration, Module)]

174+ findImports' = go <$> modules

175+ where

176+ go :: Module -> Maybe (Declaration, Module)

177+ go m@(Module _ mn' _ (Just exps'))

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

179+ where

180+ importedModName :: Declaration -> ModuleName

181+ importedModName (ImportDeclaration imn _ _) = imn

182+ importedModName (PositionedDeclaration _ _ d) = importedModName d

183+ importedModName _ = error "Not an import decl"

184+ go _ = Nothing

185+ reexports :: (Declaration, Module) -> [Declaration]

186+ reexports (ImportDeclaration _ (Hiding refs) _, (Module coms' mn' ds' (Just exps'))) =

187+ case nonHiddenRefs of

188+ [] -> []

189+ _ -> reexports (ImportDeclaration mn' Implicit Nothing, Module coms' mn' ds' (Just nonHiddenRefs))

190+ where

191+ nonHiddenRefs :: [DeclarationRef]

192+ nonHiddenRefs = filter isModExport exps' \\ filter isModExport refs

193+ reexports (ImportDeclaration _ ty qual, Module _ _ _ (Just exps')) =

194+ let ty' = case ty of

195+ Explicit _ -> Explicit []

196+ _ -> ty

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

198+ where

199+ go :: DeclarationRef -> Maybe ModuleName

200+ go (ModuleRef mn') = Just mn'

201+ go _ = Nothing

202+ reexports (PositionedDeclaration _ _ d, m@(Module _ _ _ (Just _))) = reexports (d, m)

203+ reexports _ = []

204+

205+ isModExport :: DeclarationRef -> Bool

206+ isModExport (ModuleRef _) = True

207+ isModExport _ = False

160

208

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

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

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

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

163 -- exported.

211 -- exported.

164 filterModuleExports :: ExportEnvironment -> Module -> m ExportEnvironment

212 filterModuleExports :: ExportEnvironment -> Module -> m ExportEnvironment

213+ filterModuleExports env (Module _ mn _ (Just exps))

214+ | any isSelfModuleExport exps, Just exps' <- M.lookup mn env =

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

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

217+ where

218+ isSelfModuleExport :: DeclarationRef -> Bool

219+ isSelfModuleExport (ModuleRef mn') | mn' == mn = True

220+ isSelfModuleExport (PositionedDeclarationRef _ _ ref) = isSelfModuleExport ref

221+ isSelfModuleExport _ = False

165 filterModuleExports env (Module _ mn _ (Just exps)) = filterExports mn exps env

222 filterModuleExports env (Module _ mn _ (Just exps)) = filterExports mn exps env

166 filterModuleExports env _ = return env

223 filterModuleExports env _ = return env

167

224

@@ -183,7 +240,8 @@ elaborateExports :: Exports -> Module -> Module

183elaborateExports exps (Module coms mn decls _) = Module coms mn decls (Just $

240elaborateExports exps (Module coms mn decls _) = Module coms mn decls (Just $

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

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

185 map TypeClassRef (exportedTypeClasses exps) ++

242 map TypeClassRef (exportedTypeClasses exps) ++

186− map ValueRef (exportedValues exps))

243+ map ValueRef (exportedValues exps) ++

244+ map ModuleRef (exportedModules exps))

187

245

188-- |

246-- |

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

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

@@ -314,7 +372,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri

314 where

372 where

315

373

316 -- The exported types from the Prim module

374 -- The exported types from the Prim module

317− primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []

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

318 where

376 where

319 mkTypeEntry (Qualified _ name) = (name, [])

377 mkTypeEntry (Qualified _ name) = (name, [])

320

378

@@ -358,7 +416,8 @@ filterExports mn exps env = do

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

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

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

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

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

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

419+ modules <- foldM (filterModules $ exportedModules exported) [] exps

361− return exported { exportedTypes = types', exportedTypeClasses = classes, exportedValues = values }

420+ return exported { exportedTypes = types', exportedTypeClasses = classes, exportedValues = values, exportedModules = modules }

362

421

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

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

364 -- exports

423 -- exports

@@ -395,6 +454,12 @@ filterExports mn exps env = do

395 else throwError . errorMessage . UnknownValue $ Qualified (Just mn) name

454 else throwError . errorMessage . UnknownValue $ Qualified (Just mn) name

396 filterValues _ result _ = return result

455 filterValues _ result _ = return result

397

456

457+ -- Add the exported modules to the set of exports

458+ filterModules :: [ModuleName] -> [ModuleName] -> DeclarationRef -> m [ModuleName]

459+ filterModules exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterModules exps' result r

460+ filterModules _ result (ModuleRef name) = return $ name : result

461+ filterModules _ result _ = return result

462+

398-- |

463-- |

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

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

400-- explicitly imported declarations.

465-- explicitly imported declarations.

@@ -501,6 +566,8 @@ resolveImport currentModule importModule exps imps impQual =

501 return ref

566 return ref

502 check ref@(TypeClassRef name) =

567 check ref@(TypeClassRef name) =

503 checkImportExists UnknownTypeClass classes name >> return ref

568 checkImportExists UnknownTypeClass classes name >> return ref

569+ check ref@(ModuleRef name) =

570+ checkImportExists (UnknownModule . (\(Qualified _ m) -> m)) (exportedModules exps) name >> return ref

504 check _ = error "Invalid argument to checkRefIsValid"

571 check _ = error "Invalid argument to checkRefIsValid"

505

572

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

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