34f5238 · rowtype-yoga/purescript-native

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

on golang help sign in

Elaborate re-exports

34f5238Gary Burgess10 years ago

src/Language/PureScript/AST/Declarations.hs+12−6

compare with golang

unifiedsplit

@@ -80,19 +80,25 @@ data DeclarationRef

80 --

81 | ModuleRef ModuleName

82 -- |

83+ -- A value re-exported from another module. These will be inserted during

84+ -- elaboration in name desugaring.

85+ --

86+ | ReExportRef ModuleName DeclarationRef

87+ -- |

83 -- A declaration reference with source position information

88 -- A declaration reference with source position information

84 --

89 --

85 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

90 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

86 deriving (Show, Read)

91 deriving (Show, Read)

88instance Eq DeclarationRef where

93instance Eq DeclarationRef where

89− (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'

94+ (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'

90− (TypeOpRef name) == (TypeOpRef name') = name == name'

95+ (TypeOpRef name) == (TypeOpRef name') = name == name'

91− (ValueRef name) == (ValueRef name') = name == name'

96+ (ValueRef name) == (ValueRef name') = name == name'

92− (ValueOpRef name) == (ValueOpRef name') = name == name'

97+ (ValueOpRef name) == (ValueOpRef name') = name == name'

93− (TypeClassRef name) == (TypeClassRef name') = name == name'

98+ (TypeClassRef name) == (TypeClassRef name') = name == name'

94 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

99 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

95− (ModuleRef name) == (ModuleRef name') = name == name'

100+ (ModuleRef name) == (ModuleRef name') = name == name'

101+ (ReExportRef mn ref) == (ReExportRef mn' ref') = mn == mn' && ref == ref'

96 (PositionedDeclarationRef _ _ r) == r' = r == r'

102 (PositionedDeclarationRef _ _ r) == r' = r == r'

97 r == (PositionedDeclarationRef _ _ r') = r == r'

103 r == (PositionedDeclarationRef _ _ r') = r == r'

98 _ == _ = False

104 _ == _ = False

src/Language/PureScript/Errors.hs+31−16

@@ -15,7 +15,7 @@ import Data.Char (isSpace)

15import Data.Either (lefts, rights)

16import Data.Foldable (fold)

17import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition)

18−import Data.Maybe (maybeToList)

18+import Data.Maybe (maybeToList, fromMaybe, mapMaybe)

19import Data.Ord (comparing)

20import qualified Data.Map as M

@@ -422,7 +422,7 @@ errorSuggestion err = case err of

422

423 importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> String

424 importSuggestion mn refs qual =

425− "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" ++ qstr qual

425+ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")" ++ qstr qual

426

427 qstr :: Maybe ModuleName -> String

428 qstr (Just mn) = " as " ++ runModuleName mn

@@ -1159,27 +1159,42 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

1159-- Pretty print and export declaration

1160prettyPrintExport :: DeclarationRef -> String

1161prettyPrintExport (TypeRef pn _) = runProperName pn

1162−prettyPrintExport ref = prettyPrintRef ref

1162+prettyPrintExport ref =

1163+ fromMaybe

1164+ (internalError "prettyPrintRef returned Nothing in prettyPrintExport")

1165+ (prettyPrintRef ref)

1163

1166

1164prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String

1167prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String

1165prettyPrintImport mn idt qual =

1168prettyPrintImport mn idt qual =

1166 let i = case idt of

1169 let i = case idt of

1167 Implicit -> runModuleName mn

1170 Implicit -> runModuleName mn

1168− Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"

1171+ Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")"

1169− Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")"

1172+ Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (mapMaybe prettyPrintRef refs) ++ ")"

1170 in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual

1173 in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual

1171

1174

1172−prettyPrintRef :: DeclarationRef -> String

1175+prettyPrintRef :: DeclarationRef -> Maybe String

1173−prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)"

1176+prettyPrintRef (TypeRef pn Nothing) =

1177+ Just $ runProperName pn ++ "(..)"

1174−prettyPrintRef (TypeRef pn (Just [])) = runProperName pn

1178+prettyPrintRef (TypeRef pn (Just [])) =

1179+ Just $ runProperName pn

1180+prettyPrintRef (TypeRef pn (Just dctors)) =

1175−prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"

1181+ Just $ runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"

1176−prettyPrintRef (TypeOpRef op) = "type " ++ showOp op

1182+prettyPrintRef (TypeOpRef op) =

1183+ Just $ "type " ++ showOp op

1177−prettyPrintRef (ValueRef ident) = showIdent ident

1184+prettyPrintRef (ValueRef ident) =

1185+ Just $ showIdent ident

1178−prettyPrintRef (ValueOpRef op) = showOp op

1186+prettyPrintRef (ValueOpRef op) =

1187+ Just $ showOp op

1179−prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn

1188+prettyPrintRef (TypeClassRef pn) =

1189+ Just $ "class " ++ runProperName pn

1180−prettyPrintRef (TypeInstanceRef ident) = showIdent ident

1190+prettyPrintRef (TypeInstanceRef ident) =

1191+ Just $ showIdent ident

1181−prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name

1192+prettyPrintRef (ModuleRef name) =

1193+ Just $ "module " ++ runModuleName name

1194+prettyPrintRef (ReExportRef _ _) =

1195+ Nothing

1182−prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

1196+prettyPrintRef (PositionedDeclarationRef _ _ ref) =

1197+ prettyPrintRef ref

1183

1198

1184-- |

1199-- |

1185-- Pretty print multiple errors

1200-- Pretty print multiple errors

src/Language/PureScript/Interactive.hs+21−12

@@ -1,8 +1,6 @@

1{-# LANGUAGE DoAndIfThenElse #-}

2{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

5−{-# LANGUAGE RecordWildCards #-}

6{-# LANGUAGE TupleSections #-}

4{-# LANGUAGE TupleSections #-}

7{-# LANGUAGE DataKinds #-}

5{-# LANGUAGE DataKinds #-}

@@ -19,6 +17,7 @@ import Prelude ()

19import Prelude.Compat

17import Prelude.Compat

21import Data.List (intercalate, nub, sort, find, foldl')

19import Data.List (intercalate, nub, sort, find, foldl')

20+import Data.Maybe (mapMaybe)

22import qualified Data.Map as M

21import qualified Data.Map as M

24import Control.Monad.IO.Class (MonadIO, liftIO)

23import Control.Monad.IO.Class (MonadIO, liftIO)

@@ -188,17 +187,27 @@ handleShowImportedModules = do

188 showDeclType P.Implicit = ""

187 showDeclType P.Implicit = ""

189 showDeclType (P.Explicit refs) = refsList refs

188 showDeclType (P.Explicit refs) = refsList refs

190 showDeclType (P.Hiding refs) = " hiding " ++ refsList refs

189 showDeclType (P.Hiding refs) = " hiding " ++ refsList refs

191− refsList refs = " (" ++ commaList (map showRef refs) ++ ")"

190+ refsList refs = " (" ++ commaList (mapMaybe showRef refs) ++ ")"

192

191

193− showRef :: P.DeclarationRef -> String

192+ showRef :: P.DeclarationRef -> Maybe String

193+ showRef (P.TypeRef pn dctors) =

194− showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"

194+ Just $ N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"

195− showRef (P.TypeOpRef op) = "type " ++ N.showOp op

195+ showRef (P.TypeOpRef op) =

196+ Just $ "type " ++ N.showOp op

196− showRef (P.ValueRef ident) = N.runIdent ident

197+ showRef (P.ValueRef ident) =

198+ Just $ N.runIdent ident

197− showRef (P.ValueOpRef op) = N.showOp op

199+ showRef (P.ValueOpRef op) =

200+ Just $ N.showOp op

198− showRef (P.TypeClassRef pn) = "class " ++ N.runProperName pn

201+ showRef (P.TypeClassRef pn) =

202+ Just $ "class " ++ N.runProperName pn

199− showRef (P.TypeInstanceRef ident) = N.runIdent ident

203+ showRef (P.TypeInstanceRef ident) =

204+ Just $ N.runIdent ident

205+ showRef (P.ModuleRef name) =

200− showRef (P.ModuleRef name) = "module " ++ N.runModuleName name

206+ Just $ "module " ++ N.runModuleName name

207+ showRef (P.ReExportRef _ _) =

208+ Nothing

201− showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref

209+ showRef (P.PositionedDeclarationRef _ _ ref) =

210+ showRef ref

202

211

203 commaList :: [String] -> String

212 commaList :: [String] -> String

204 commaList = intercalate ", "

213 commaList = intercalate ", "

src/Language/PureScript/Sugar/Names.hs+28−23

@@ -10,7 +10,7 @@ module Language.PureScript.Sugar.Names

11import Prelude.Compat

13−import Control.Arrow (first, second)

13+import Control.Arrow (first)

14import Control.Monad

15import Control.Monad.Error.Class (MonadError(..))

16import Control.Monad.State.Lazy

@@ -84,16 +84,19 @@ desugarImportsWithEnv externs modules = do

84 toExportedType _ = Nothing

86 exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName

87− exportedTypeOps = M.fromList $ (, efModuleName) <$> mapMaybe getTypeOpRef efExports

87+ exportedTypeOps = exportedRefs getTypeOpRef

89 exportedTypeClasses :: M.Map (ProperName 'ClassName) ModuleName

90− exportedTypeClasses = M.fromList $ (, efModuleName) <$> mapMaybe getTypeClassRef efExports

90+ exportedTypeClasses = exportedRefs getTypeClassRef

92 exportedValues :: M.Map Ident ModuleName

93− exportedValues = M.fromList $ (, efModuleName) <$> mapMaybe getValueRef efExports

93+ exportedValues = exportedRefs getValueRef

95 exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName

96+ exportedValueOps = exportedRefs getValueOpRef

97+

98+ exportedRefs :: Ord a => (DeclarationRef -> Maybe a) -> M.Map a ModuleName

96− exportedValueOps = M.fromList $ (, efModuleName) <$> mapMaybe getValueOpRef efExports

99+ exportedRefs f = M.fromList $ (, efModuleName) <$> mapMaybe f efExports

100

98 updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)

101 updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)

99 updateEnv (ms, env) m@(Module ss _ mn _ refs) =

102 updateEnv (ms, env) m@(Module ss _ mn _ refs) =

@@ -110,9 +113,10 @@ desugarImportsWithEnv externs modules = do

110 renameInModule' env m@(Module _ _ mn _ _) =

113 renameInModule' env m@(Module _ _ mn _ _) =

111 warnAndRethrow (addHint (ErrorInModule mn)) $ do

114 warnAndRethrow (addHint (ErrorInModule mn)) $ do

112 let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env

115 let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env

113− (m', used) <- flip runStateT M.empty $ renameInModule imps (elaborateExports exps m)

116+ (m', used) <- flip runStateT M.empty $ renameInModule imps m

117+ let m'' = elaborateExports exps m'

114− lintImports m' env used

118+ lintImports m'' env used

115− return m'

119+ return m''

116

120

117-- |

121-- |

118-- Make all exports for a module explicit. This may still effect modules that

122-- Make all exports for a module explicit. This may still effect modules that

@@ -121,24 +125,25 @@ desugarImportsWithEnv externs modules = do

121--

125--

122elaborateExports :: Exports -> Module -> Module

126elaborateExports :: Exports -> Module -> Module

123elaborateExports exps (Module ss coms mn decls refs) =

127elaborateExports exps (Module ss coms mn decls refs) =

124− Module ss coms mn decls $

128+ Module ss coms mn decls $ Just

125− Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) myTypes ++

129+ $ elaboratedTypeRefs

126− map TypeOpRef (my exportedTypeOps) ++

130+ ++ go TypeOpRef exportedTypeOps

127− map TypeClassRef (my exportedTypeClasses) ++

131+ ++ go TypeClassRef exportedTypeClasses

128− map ValueRef (my exportedValues) ++

132+ ++ go ValueRef exportedValues

129− map ValueOpRef (my exportedValueOps) ++

133+ ++ go ValueOpRef exportedValueOps

130− maybe [] (filter isModuleRef) refs

134+ ++ maybe [] (filter isModuleRef) refs

131 where

135 where

132− -- Extracts a list of values from the exports and filters out any values that

133− -- are re-exports from other modules.

134− my :: (Exports -> M.Map a ModuleName) -> [a]

135− my = map fst <$> filt (== mn)

136

137− myTypes :: [(ProperName 'TypeName, [ProperName 'ConstructorName])]

137+ elaboratedTypeRefs :: [DeclarationRef]

138− myTypes = second fst <$> filt ((== mn) . snd) exportedTypes

138+ elaboratedTypeRefs =

139+ flip map (M.toList (exportedTypes exps)) $ \(tctor, (dctors, mn')) ->

140+ let ref = TypeRef tctor (Just dctors)

141+ in if mn == mn' then ref else ReExportRef mn' ref

139

142

140− filt :: (b -> Bool) -> (Exports -> M.Map a b) -> [(a, b)]

143+ go :: (a -> DeclarationRef) -> (Exports -> M.Map a ModuleName) -> [DeclarationRef]

141− filt predicate f = M.toList $ predicate `M.filter` f exps

144+ go toRef select =

145+ flip map (M.toList (select exps)) $ \(export, mn') ->

146+ if mn == mn' then toRef export else ReExportRef mn' (toRef export)

142

147

143-- |

148-- |

144-- Replaces all local names with qualified names within a module and checks that all existing

149-- Replaces all local names with qualified names within a module and checks that all existing

src/Language/PureScript/Sugar/Names/Imports.hs+2−1

@@ -207,6 +207,7 @@ resolveImport importModule exps imps impQual = resolveByType

207 return $ imp { importedTypeClasses = typeClasses' }

208 importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef"

209 importRef _ _ ModuleRef{} = internalError "ModuleRef in importRef"

210+ importRef _ _ ReExportRef{} = internalError "ReExportRef in importRef"

210

211

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

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

212 allExportedDataConstructors

213 allExportedDataConstructors

@@ -218,7 +219,7 @@ resolveImport importModule exps imps impQual = resolveByType

218

219

219 -- Add something to an import resolution list

220 -- Add something to an import resolution list

220 updateImports

221 updateImports

221− :: (Ord a)

222+ :: Ord a

222 => M.Map (Qualified a) [ImportRecord a]

223 => M.Map (Qualified a) [ImportRecord a]

223 -> M.Map a b

224 -> M.Map a b

224 -> (b -> ModuleName)

225 -> (b -> ModuleName)