bc72c55 · rowtype-yoga/purescript-native

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

Merge pull request #1184 from ilexlabs/module-exports

Support for entire-module (re-)exports

commitbc72c55d0b0a6c92ac4da49e4f75761afe04efa4 authorGary Burgess <gary.burgess@gmail.com> dateSun 28 Jun 2015, 20:19 (11 years ago) parenta11335e 661edfb

12 files changed+182−9

compare with golang

unifiedsplit

examples/passing/ModuleExport.purs+9 examples/passing/ModuleExportDupes.purs+19 examples/passing/ModuleExportExcluded.purs+14 examples/passing/ModuleExportHiding.purs+11 examples/passing/ModuleExportQualified.purs+9 examples/passing/ModuleExportSelf.purs+14 psci/PSCi.hs+1 src/Language/PureScript/AST/Declarations.hs+5 src/Language/PureScript/CodeGen/Externs.hs+16−1 src/Language/PureScript/Errors.hs+1 src/Language/PureScript/Parser/Declarations.hs+9−1 src/Language/PureScript/Sugar/Names.hs+74−7

examples/passing/ModuleExport.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 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

315315 showRef (P.ValueRef ident) = show ident

316316 showRef (P.TypeClassRef pn) = show pn

317317 showRef (P.TypeInstanceRef ident) = show ident

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

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

319320

320321 commaList :: [String] -> String

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

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

6161 --

6262 | TypeInstanceRef Ident

6363 -- |

64+ -- A module, in its entirety

65+ --

66+ | ModuleRef ModuleName

67+ -- |

6468 -- A declaration reference with source position information

6569 --

6670 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

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

7175 (ValueRef name) == (ValueRef name') = name == name'

7276 (TypeClassRef name) == (TypeClassRef name') = name == name'

7377 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

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

7479 (PositionedDeclarationRef _ _ r) == r' = r == r'

7580 r == (PositionedDeclarationRef _ _ r') = r == r'

7681 _ == _ = False

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

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

3838moduleToPs :: Module -> Environment -> String

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

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

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

41+ let exps = listExports exts

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

4243 mapM_ declToPs ds

4344 mapM_ exportToPs exts

4445 where

4546

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+

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

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

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

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

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

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

115128

129+ exportToPs (ModuleRef _) = return ()

130+

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

117132 toTypeVar (s, Nothing) = TypeVar s

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

src/Language/PureScript/Errors.hs+1

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

688688 prettyPrintExport (ValueRef ident) = show ident

689689 prettyPrintExport (TypeClassRef pn) = show pn

690690 prettyPrintExport (TypeInstanceRef ident) = show ident

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

691692 prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

692693

693694 -- |

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

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

186186

187187

188188parseDeclarationRef :: TokenParser DeclarationRef

189−parseDeclarationRef = withSourceSpan PositionedDeclarationRef $

189+parseDeclarationRef =

190+ parseModuleRef <|> (

191+ withSourceSpan PositionedDeclarationRef $

190192 ValueRef <$> parseIdent

191193 <|> do name <- properName

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

193195 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

194202

195203parseTypeClassDeclaration :: TokenParser Declaration

196204parseTypeClassDeclaration = do

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

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

1414

1515{-# LANGUAGE FlexibleContexts #-}

1616{-# LANGUAGE ScopedTypeVariables #-}

17+{-# LANGUAGE PatternGuards #-}

1718

1819module Language.PureScript.Sugar.Names (

1920 desugarImports

2021) where

2122

22−import Data.List (nub)

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

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

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

2425

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

2627import Control.Monad

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

5960 -- The values exported from each module

6061 --

6162 , exportedValues :: [Ident]

63+ -- |

64+ -- The modules exported from each module

65+ --

66+ , exportedModules :: [ModuleName]

6267 } deriving (Show)

6368

6469-- |

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

101106addEmptyModule env name =

102107 if name `M.member` env

103108 then throwError . errorMessage $ RedefinedModule name

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

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

105110

106111-- |

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

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

155160desugarImports modules = do

156161 unfilteredExports <- findExports modules

157162 exports <- foldM filterModuleExports unfilteredExports modules

158− mapM (renameInModule' unfilteredExports exports) modules

163+ let modules' = moduleReexports <$> modules

164+ mapM (renameInModule' unfilteredExports exports) modules'

159165 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

160208

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

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

163211 -- exported.

164212 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

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

166223 filterModuleExports env _ = return env

167224

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

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

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

185242 map TypeClassRef (exportedTypeClasses exps) ++

186− map ValueRef (exportedValues exps))

243+ map ValueRef (exportedValues exps) ++

244+ map ModuleRef (exportedModules exps))

187245

188246-- |

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

314372 where

315373

316374 -- The exported types from the Prim module

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

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

318376 where

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

320378

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

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

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

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

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

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

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

362421

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

364423 -- exports

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

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

396455 filterValues _ result _ = return result

397456

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+

398463-- |

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

400465-- explicitly imported declarations.

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

501566 return ref

502567 check ref@(TypeClassRef name) =

503568 checkImportExists UnknownTypeClass classes name >> return ref

569+ check ref@(ModuleRef name) =

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

504571 check _ = error "Invalid argument to checkRefIsValid"

505572

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