34f5238 · rowtype-yoga/purescript-native

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

Elaborate re-exports

commit34f5238cc4cffeae98321b2df9b13f979ff61b79 authorGary Burgess <gary.burgess@gmail.com> dateFri 10 Jun 2016, 14:32 (10 years ago) parentde8ab59

5 files changed+94−58

compare with golang

unifiedsplit

src/Language/PureScript/AST/Declarations.hs+12−6 src/Language/PureScript/Errors.hs+31−16 src/Language/PureScript/Interactive.hs+21−12 src/Language/PureScript/Sugar/Names.hs+28−23 src/Language/PureScript/Sugar/Names/Imports.hs+2−1

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

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

8080 --

8181 | ModuleRef ModuleName

8282 -- |

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

84+ -- elaboration in name desugaring.

85+ --

86+ | ReExportRef ModuleName DeclarationRef

87+ -- |

8388 -- A declaration reference with source position information

8489 --

8590 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

8691 deriving (Show, Read)

8792

8893instance Eq DeclarationRef where

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

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

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

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

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

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

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

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

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

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

9499 (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'

96102 (PositionedDeclarationRef _ _ r) == r' = r == r'

97103 r == (PositionedDeclarationRef _ _ r') = r == r'

98104 _ == _ = False

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

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

1515import Data.Either (lefts, rights)

1616import Data.Foldable (fold)

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

18−import Data.Maybe (maybeToList)

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

1919import Data.Ord (comparing)

2020import qualified Data.Map as M

2121

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

422422

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

424424 importSuggestion mn refs qual =

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

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

426426

427427 qstr :: Maybe ModuleName -> String

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

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

11591159-- Pretty print and export declaration

11601160prettyPrintExport :: DeclarationRef -> String

11611161prettyPrintExport (TypeRef pn _) = runProperName pn

1162−prettyPrintExport ref = prettyPrintRef ref

1162+prettyPrintExport ref =

1163+ fromMaybe

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

1165+ (prettyPrintRef ref)

11631166

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

11651168prettyPrintImport mn idt qual =

11661169 let i = case idt of

11671170 Implicit -> runModuleName mn

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

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

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

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

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

11711174

1172−prettyPrintRef :: DeclarationRef -> String

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

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

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

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

1177−prettyPrintRef (ValueRef ident) = showIdent ident

1178−prettyPrintRef (ValueOpRef op) = showOp op

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

1180−prettyPrintRef (TypeInstanceRef ident) = showIdent ident

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

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

1175+prettyPrintRef :: DeclarationRef -> Maybe String

1176+prettyPrintRef (TypeRef pn Nothing) =

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

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

1179+ Just $ runProperName pn

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

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

1182+prettyPrintRef (TypeOpRef op) =

1183+ Just $ "type " ++ showOp op

1184+prettyPrintRef (ValueRef ident) =

1185+ Just $ showIdent ident

1186+prettyPrintRef (ValueOpRef op) =

1187+ Just $ showOp op

1188+prettyPrintRef (TypeClassRef pn) =

1189+ Just $ "class " ++ runProperName pn

1190+prettyPrintRef (TypeInstanceRef ident) =

1191+ Just $ showIdent ident

1192+prettyPrintRef (ModuleRef name) =

1193+ Just $ "module " ++ runModuleName name

1194+prettyPrintRef (ReExportRef _ _) =

1195+ Nothing

1196+prettyPrintRef (PositionedDeclarationRef _ _ ref) =

1197+ prettyPrintRef ref

11831198

11841199-- |

11851200-- Pretty print multiple errors

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

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

11{-# LANGUAGE DoAndIfThenElse #-}

22{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

43{-# LANGUAGE MultiParamTypeClasses #-}

5−{-# LANGUAGE RecordWildCards #-}

64{-# LANGUAGE TupleSections #-}

75{-# LANGUAGE DataKinds #-}

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

1917import Prelude.Compat

2018

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

20+import Data.Maybe (mapMaybe)

2221import qualified Data.Map as M

2322

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

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

188187 showDeclType P.Implicit = ""

189188 showDeclType (P.Explicit refs) = refsList refs

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

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

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

192191

193− showRef :: P.DeclarationRef -> String

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

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

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

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

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

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

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

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

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

193+ showRef (P.TypeRef pn dctors) =

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

195+ showRef (P.TypeOpRef op) =

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

197+ showRef (P.ValueRef ident) =

198+ Just $ N.runIdent ident

199+ showRef (P.ValueOpRef op) =

200+ Just $ N.showOp op

201+ showRef (P.TypeClassRef pn) =

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

203+ showRef (P.TypeInstanceRef ident) =

204+ Just $ N.runIdent ident

205+ showRef (P.ModuleRef name) =

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

207+ showRef (P.ReExportRef _ _) =

208+ Nothing

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

210+ showRef ref

202211

203212 commaList :: [String] -> String

204213 commaList = intercalate ", "

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

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

1010

1111import Prelude.Compat

1212

13−import Control.Arrow (first, second)

13+import Control.Arrow (first)

1414import Control.Monad

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

1616import Control.Monad.State.Lazy

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

8484 toExportedType _ = Nothing

8585

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

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

87+ exportedTypeOps = exportedRefs getTypeOpRef

8888

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

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

90+ exportedTypeClasses = exportedRefs getTypeClassRef

9191

9292 exportedValues :: M.Map Ident ModuleName

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

93+ exportedValues = exportedRefs getValueRef

9494

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

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

96+ exportedValueOps = exportedRefs getValueOpRef

97+

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

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

97100

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

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

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

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

111114 warnAndRethrow (addHint (ErrorInModule mn)) $ do

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

114− lintImports m' env used

115− return m'

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

117+ let m'' = elaborateExports exps m'

118+ lintImports m'' env used

119+ return m''

116120

117121-- |

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

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

121125--

122126elaborateExports :: Exports -> Module -> Module

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

124− Module ss coms mn decls $

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

126− map TypeOpRef (my exportedTypeOps) ++

127− map TypeClassRef (my exportedTypeClasses) ++

128− map ValueRef (my exportedValues) ++

129− map ValueOpRef (my exportedValueOps) ++

130− maybe [] (filter isModuleRef) refs

128+ Module ss coms mn decls $ Just

129+ $ elaboratedTypeRefs

130+ ++ go TypeOpRef exportedTypeOps

131+ ++ go TypeClassRef exportedTypeClasses

132+ ++ go ValueRef exportedValues

133+ ++ go ValueOpRef exportedValueOps

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

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

136136

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

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

137+ elaboratedTypeRefs :: [DeclarationRef]

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

139142

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

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

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

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)

142147

143148-- |

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

207207 return $ imp { importedTypeClasses = typeClasses' }

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

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

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

210211

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

212213 allExportedDataConstructors

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

218219

219220 -- Add something to an import resolution list

220221 updateImports

221− :: (Ord a)

222+ :: Ord a

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

223224 -> M.Map a b

224225 -> (b -> ModuleName)