b0c35c6 · rowtype-yoga/purescript-native

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

on golang help sign in

An attempt at importing values

b0c35c6Phil Freeman13 years ago

examples/passing/ImportExplicit.purs+1−1

compare with golang

unifiedsplit

@@ -5,7 +5,7 @@ module M1 where

6module Main where

8− import M1 (X)

8+ import M1 (X(..))

10 testX :: X

11 testX = X

src/Data/Generics/Extras.hs+21−10

@@ -47,17 +47,28 @@ everywhereM' f x = do

47-- > go locals lam@(Lam local _) = (local : locals, lam)

48-- > go locals other = (locals, other)

49--

50−everywhereWithContext' :: (Data d) => s -> (forall d1. (Data d1) => s -> d1 -> (s, d1)) -> d -> d

50+everywhereWithContextM' :: (Monad m, Data d) => s -> (forall d1. (Data d1) => s -> d1 -> m (s, d1)) -> d -> m d

51−everywhereWithContext' s0 f x =

51+everywhereWithContextM' s0 f x = do

52− let (s, y) = f s0 x in

52+ (s, y) <- f s0 x

53− gmapT (everywhereWithContext' s f) y

53+ gmapM (everywhereWithContextM' s f) y

55-- |

56-- Make a stateful transformation function

57--

58−mkS :: (Data a, Data b) => (s -> a -> (s, a)) -> s -> b -> (s, b)

58+mkS :: (Monad m, Data a, Data b) => (s -> a -> m (s, a)) -> s -> b -> m (s, b)

59−mkS f s b = fromMaybe (s, b) $ do

59+mkS = extS (curry return)

60− a <- cast b

60+

61+-- |

62+-- Extend a stateful transformation function

63+--

64+extS :: (Monad m, Data a, Data b) => (s -> a -> m (s, a)) -> (s -> b -> m (s, b)) -> (s -> a -> m (s, a))

65+extS f g s a = do

61− let (s', a') = f s a

66+ (s', a') <- f s a

67+ case cast a' of

68+ Just b -> do

69+ (s'', b') <- g s' b

62− b' <- cast a'

70+ case cast b' of

71+ Just a'' -> return (s'', a'')

72+ Nothing -> return (s', a')

63− return (s', b')

73+ Nothing -> return (s', a')

74+

src/Language/PureScript/CodeGen/JS.hs−9

@@ -226,15 +226,6 @@ bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders,

226 binderToJs m e v done'' b

227 go _ _ _ _ = error "Invalid arguments to bindersToJs"

228

229−-- |

230−-- Collect all names introduced in binders in an expression

231−--

232−binderNames :: (Data d) => d -> [Ident]

233−binderNames = everything (++) (mkQ [] go)

234− where

235− go (VarBinder ident) = [ident]

236− go _ = []

237−

238-- |

229-- |

239-- Generate code in the simplified Javascript intermediate representation for a pattern match

230-- Generate code in the simplified Javascript intermediate representation for a pattern match

240-- binder.

231-- binder.

src/Language/PureScript/Declarations.hs+5−24

@@ -72,11 +72,15 @@ data ImportType

72 -- |

73 -- A type constructor import

74 --

75− = TypeImport ProperName

75+ = TypeImport ProperName (Maybe [ProperName])

76 -- |

77 -- A declaration import

78 --

79 | NameImport Ident

80+ -- |

81+ -- A type class import

82+ --

83+ | TypeClassImport ProperName

80 deriving (Show, D.Data, D.Typeable)

84 deriving (Show, D.Data, D.Typeable)

82-- |

86-- |

@@ -183,26 +187,3 @@ isTypeClassDeclaration :: Declaration -> Bool

183isTypeClassDeclaration TypeClassDeclaration{} = True

187isTypeClassDeclaration TypeClassDeclaration{} = True

184isTypeClassDeclaration TypeInstanceDeclaration{} = True

188isTypeClassDeclaration TypeInstanceDeclaration{} = True

185isTypeClassDeclaration _ = False

189isTypeClassDeclaration _ = False

186−

187−-- |

188−-- Extracts names from a list of explicit imports.

189−--

190−nameImports :: [ImportType] -> [Ident]

191−nameImports ((NameImport ident):xs) = ident : nameImports xs

192−nameImports (_ : xs) = nameImports xs

193−nameImports _ = []

194−

195−-- |

196−-- Extracts types from a list of explicit imports.

197−--

198−typeImports :: [ImportType] -> [ProperName]

199−typeImports (TypeImport ident : xs) = ident : typeImports xs

200−typeImports (_ : xs) = typeImports xs

201−typeImports _ = []

202−

203−-- |

204−-- Extracts classes from a list of explicit imports.

205−-- note: class imports are indistinguishable from types at the moment

206−--

207−classImports :: [ImportType] -> [ProperName]

208−classImports = typeImports

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

@@ -88,9 +88,15 @@ parseImportDeclaration = do

88 reserved "import"

89 indented

90 moduleName' <- moduleName

91− idents <- P.optionMaybe $ parens $ commaSep1 (NameImport <$> parseIdent <|> TypeImport <$> properName)

91+ idents <- P.optionMaybe $ parens $ commaSep1 parseExplicitImport

92 return $ ImportDeclaration moduleName' idents

94+parseExplicitImport :: P.Parsec String ParseState ImportType

95+parseExplicitImport = NameImport <$> parseIdent

96+ <|> do name <- properName

97+ dctors <- P.optionMaybe $ parens (Just <$> commaSep1 properName <|> lexeme (P.string "..") *> pure Nothing)

98+ return $ maybe (TypeClassImport name) (TypeImport name) dctors

99+

94parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

100parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

95parseTypeClassDeclaration = do

101parseTypeClassDeclaration = do

96 reserved "class"

102 reserved "class"

src/Language/PureScript/Sugar.hs+5−3

@@ -46,12 +46,14 @@ import Language.PureScript.Sugar.Names as S

46--

47-- * Group mutually recursive value and data declarations into binding groups.

48--

49+-- * Qualify any unqualified names and types

50+--

49desugar :: [Module] -> Either String [Module]

51desugar :: [Module] -> Either String [Module]

50−desugar = rename

51− >=> desugarTypeClasses

52− >=> rebracket

52+desugar = rebracket

53 >=> desugarDo

54 >=> desugarLetBindings

55 >>> desugarCasesModule

56 >=> desugarTypeDeclarationsModule

57+ >=> desugarImports

58+ >=> desugarTypeClasses

57 >=> createBindingGroupsModule

59 >=> createBindingGroupsModule

src/Language/PureScript/Sugar/Names.hs+99−89

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

13-----------------------------------------------------------------------------

15module Language.PureScript.Sugar.Names (

16− rename

16+ desugarImports

17) where

19import Data.Maybe (fromMaybe)

20−import Data.Generics (extM, mkM, everywhereM)

21import Data.List (intersect)

20import Data.List (intersect)

21+import Data.Data

22+import Data.Generics (extM, mkM, everywhereM)

23+import Data.Generics.Extras (mkS, extS, everywhereWithContextM')

23−import Control.Applicative ((<$>), (<*>))

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

24import Control.Monad (forM_, unless, foldM, liftM)

26import Control.Monad (forM_, unless, foldM, liftM)

26import qualified Data.Map as M

28import qualified Data.Map as M

@@ -38,15 +40,15 @@ data ExportEnvironment = ExportEnvironment

38 -- |

40 -- |

39 -- The types exported from each module

41 -- The types exported from each module

40 --

42 --

41− { exportedTypes :: M.Map ModuleName (S.Set ProperName)

43+ { exportedTypes :: M.Map ModuleName (S.Set (ProperName, [ProperName]))

42− -- |

43− -- The data constructors exported from each module, grouped by type constructor

44− --

45− , exportedDataConstructors :: M.Map ModuleName (S.Set (ProperName, [ProperName]))

46 -- |

44 -- |

47 -- The classes exported from each module

45 -- The classes exported from each module

48 --

46 --

49 , exportedTypeClasses :: M.Map ModuleName (S.Set ProperName)

47 , exportedTypeClasses :: M.Map ModuleName (S.Set ProperName)

48+ -- |

49+ -- The values exported from each module

50+ , exportedValues :: M.Map ModuleName (S.Set Ident)

51+ --

50 } deriving (Show)

52 } deriving (Show)

52-- |

54-- |

@@ -65,31 +67,35 @@ data ImportEnvironment = ImportEnvironment

65 -- Local names for classes within a module mapped to to their qualified names

67 -- Local names for classes within a module mapped to to their qualified names

66 --

68 --

67 , importedTypeClasses :: M.Map ProperName (Qualified ProperName)

69 , importedTypeClasses :: M.Map ProperName (Qualified ProperName)

70+ -- |

71+ -- Local names for values within a module mapped to to their qualified names

72+ --

73+ , importedValues :: M.Map Ident (Qualified Ident)

68 } deriving (Show)

74 } deriving (Show)

70-- |

76-- |

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

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

72--

78--

73−addType :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment

79+addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment

74−addType env mn name = do

80+addType env mn name dctors = do

75− types <- addExport (exportedTypes env) mn name

81+ types <- addExport (exportedTypes env) mn (name, dctors)

76− return $ env { exportedTypes = types }

82+ return $ env { exportedTypes = types }

78-- |

84-- |

79−-- Adds a group of data constructors with their associated type constructor the export environment.

85+-- Adds a class to the export environment.

80--

86--

81−addDataConstructors :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment

87+addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment

82−addDataConstructors env mn tcon dcons = do

88+addTypeClass env mn name = do

83− dataConstructors <- addExport (exportedDataConstructors env) mn (tcon, dcons)

89+ classes <- addExport (exportedTypeClasses env) mn name

84− return $ env { exportedDataConstructors = dataConstructors }

90+ return $ env { exportedTypeClasses = classes }

86-- |

92-- |

87-- Adds a class to the export environment.

93-- Adds a class to the export environment.

88--

94--

89−addTypeclass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment

95+addValue :: ExportEnvironment -> ModuleName -> Ident -> Either String ExportEnvironment

90−addTypeclass env mn name = do

96+addValue env mn name = do

91− classes <- addExport (exportedTypeClasses env) mn name

97+ values <- addExport (exportedValues env) mn name

92− return $ env { exportedTypeClasses = classes }

98+ return $ env { exportedValues = values }

94-- |

100-- |

95-- Adds an export to a map of exports of that type.

101-- Adds an export to a map of exports of that type.

@@ -104,8 +110,8 @@ addExport exports mn name = case M.lookup mn exports of

104-- |

110-- |

105-- Replaces all local names with qualified names within a set of modules.

111-- Replaces all local names with qualified names within a set of modules.

106--

112--

107−rename :: [Module] -> Either String [Module]

113+desugarImports :: [Module] -> Either String [Module]

108−rename modules = do

114+desugarImports modules = do

109 exports <- findExports modules

115 exports <- findExports modules

110 mapM (renameInModule' exports) modules

116 mapM (renameInModule' exports) modules

111 where

117 where

@@ -120,20 +126,27 @@ renameInModule :: ImportEnvironment -> Module -> Either String Module

120renameInModule imports (Module mn decls) =

126renameInModule imports (Module mn decls) =

121 Module mn <$> mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder)

127 Module mn <$> mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder)

122 where

128 where

123− updateDecl (TypeInstanceDeclaration cs (Qualified Nothing cn) ts ds) = do

129+ updateDecl (TypeInstanceDeclaration cs (Qualified Nothing cn) ts ds) =

124− cn' <- updateClassName cn

130+ TypeInstanceDeclaration <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds

125− cs' <- updateConstraints cs

131+ updateDecl (ValueDeclaration name bs grd val) =

126− return $ TypeInstanceDeclaration cs' cn' ts ds

132+ ValueDeclaration name <$> updateVars bs <*> updateVars grd <*> updateVars val

133+ where

134+ updateVars :: (Data d) => d -> Either String d

135+ updateVars = everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders)

136+ where

137+ bindFunctionArgs bound (Abs (Left arg) val) = return (arg : bound, Abs (Left arg) val)

138+ bindFunctionArgs bound (Var (Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName ident)

139+ bindFunctionArgs bound other = return (bound, other)

140+ bindBinders :: [Ident] -> ([Binder], Maybe Guard, Value) -> Either String ([Ident], ([Binder], Maybe Guard, Value))

141+ bindBinders bound (bs, grd, val) = return (binderNames bs ++ bound, (bs, grd, val))

127 updateDecl d = return d

142 updateDecl d = return d

128 updateValue (Constructor (Qualified Nothing nm)) = liftM Constructor $ updateDataConstructorName nm

143 updateValue (Constructor (Qualified Nothing nm)) = liftM Constructor $ updateDataConstructorName nm

129 updateValue v = return v

144 updateValue v = return v

130 updateBinder (ConstructorBinder (Qualified Nothing nm) b) = liftM (`ConstructorBinder` b) $ updateDataConstructorName nm

145 updateBinder (ConstructorBinder (Qualified Nothing nm) b) = liftM (`ConstructorBinder` b) $ updateDataConstructorName nm

131 updateBinder v = return v

146 updateBinder v = return v

132 updateType (TypeConstructor (Qualified Nothing nm)) = liftM TypeConstructor $ updateTypeName nm

147 updateType (TypeConstructor (Qualified Nothing nm)) = liftM TypeConstructor $ updateTypeName nm

133− updateType (SaturatedTypeSynonym (Qualified Nothing nm) tys) = do

148+ updateType (SaturatedTypeSynonym (Qualified Nothing nm) tys) =

134− nm' <- updateTypeName nm

135− tys' <- mapM updateType tys

149+ SaturatedTypeSynonym <$> updateTypeName nm <*> mapM updateType tys

136− return $ SaturatedTypeSynonym nm' tys'

137 updateType (ConstrainedType cs t) = liftM (`ConstrainedType` t) $ updateConstraints cs

150 updateType (ConstrainedType cs t) = liftM (`ConstrainedType` t) $ updateConstraints cs

138 updateType t = return t

151 updateType t = return t

139 updateConstraints = mapM updateConstraint

152 updateConstraints = mapM updateConstraint

@@ -142,7 +155,8 @@ renameInModule imports (Module mn decls) =

142 return (nm', ts)

155 return (nm', ts)

143 updateConstraint other = return other

156 updateConstraint other = return other

144 updateTypeName = update "type" importedTypes

157 updateTypeName = update "type" importedTypes

145− updateClassName = update "typeclass" importedTypeClasses

158+ updateClassName = update "type class" importedTypeClasses

159+ updateValueName = update "value" importedValues

146 updateDataConstructorName = update "data constructor" importedDataConstructors

160 updateDataConstructorName = update "data constructor" importedDataConstructors

147 update t get nm = maybe (Left $ "Unknown " ++ t ++ " '" ++ show nm ++ "' in module '" ++ show mn ++ "'") return $ M.lookup nm (get imports)

161 update t get nm = maybe (Left $ "Unknown " ++ t ++ " '" ++ show nm ++ "' in module '" ++ show mn ++ "'") return $ M.lookup nm (get imports)

148

162

@@ -153,12 +167,14 @@ findExports :: [Module] -> Either String ExportEnvironment

153findExports = foldM addModule (ExportEnvironment M.empty M.empty M.empty)

167findExports = foldM addModule (ExportEnvironment M.empty M.empty M.empty)

154 where

168 where

155 addModule env (Module mn ds) = foldM (addDecl mn) env ds

169 addModule env (Module mn ds) = foldM (addDecl mn) env ds

156− addDecl mn env (TypeClassDeclaration tcn _ _) = addTypeclass env mn tcn

170+ addDecl mn env (TypeClassDeclaration tcn _ ds) = do

157− addDecl mn env (DataDeclaration tn _ dcs) = do

171+ env' <- addTypeClass env mn tcn

158− env' <- addDataConstructors env mn tn (map fst dcs)

172+ foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds

159− addType env' mn tn

173+ addDecl mn env (DataDeclaration tn _ dcs) = addType env mn tn (map fst dcs)

160− addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn

174+ addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []

161− addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn

175+ addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []

176+ addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name

177+ addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name

162 addDecl _ env _ = return env

178 addDecl _ env _ = return env

163

179

164-- |

180-- |

@@ -180,59 +196,53 @@ findImports = foldl findImports' M.empty

180-- Constructs a local environment for a module.

196-- Constructs a local environment for a module.

181--

197--

182resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment

198resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment

183−resolveImports env (Module currentModule decls) = ImportEnvironment

199+resolveImports env (Module currentModule decls) =

184− <$> resolve (exportedTypes env) (resolveDefs typeImports)

200+ foldM resolveImport (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)

185− <*> resolve (exportedDataConstructors env) resolveDcons

186− <*> resolve (exportedTypeClasses env) (resolveDefs (const []))

187 where

201 where

188 -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported

202 -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported

189 scope :: M.Map ModuleName (Maybe ExplicitImports)

203 scope :: M.Map ModuleName (Maybe ExplicitImports)

190 scope = M.insert currentModule Nothing (findImports decls)

204 scope = M.insert currentModule Nothing (findImports decls)

191

205

192− -- Resolve all exported names in a set by applying a type-specific resolver function

206+ -- Add data to the ImportEnvironment

193− resolve :: M.Map ModuleName (S.Set id) ->

207+ resolveImport :: ImportEnvironment -> (ModuleName, Maybe ExplicitImports) -> Either String ImportEnvironment

194− (M.Map ProperName (Qualified ProperName) -> ModuleName -> S.Set id -> Maybe ExplicitImports -> Either String (M.Map ProperName (Qualified ProperName))) ->

208+ resolveImport imp (mn, Nothing) = importAll imp mn env

195− Either String (M.Map ProperName (Qualified ProperName))

209+ resolveImport imp (mn, Just expl) = foldM (importExplicit mn) imp expl

196− resolve m f = foldM (\m' (mn, maybeExpl) -> f m' mn (fromMaybe S.empty $ mn `M.lookup` m) maybeExpl) M.empty (M.toList scope)

210+

197−

211+ -- Import something explicitly

198− -- Resolve a single name by adding it to the Map with a specified ModuleName, checking first

212+ importExplicit :: ModuleName -> ImportEnvironment -> ImportType -> Either String ImportEnvironment

199− -- that the name does not currently exist in scope.

213+ importExplicit mn imp (NameImport name) = do

200− resolveDef :: (Ord id, Show id) => ModuleName ->

214+ values' <- updateImports mn (importedValues imp) name

201− M.Map id (Qualified id) ->

215+ return $ imp { importedValues = values' }

202− id ->

216+ importExplicit mn imp (TypeImport name dctors) = do

217+ types' <- updateImports mn (importedTypes imp) name

218+ dctors' <- foldM (updateImports mn) (importedDataConstructors imp) (fromMaybe (allExportedDataConstructors env mn name) dctors)

219+ return $ imp { importedTypes = types', importedDataConstructors = dctors' }

220+ importExplicit mn imp (TypeClassImport name) = do

221+ typeClasses' <- updateImports mn (importedTypeClasses imp) name

222+ return $ imp { importedTypeClasses = typeClasses' }

223+

224+ -- Import everything from a module

225+ importAll :: ImportEnvironment -> ModuleName -> ExportEnvironment -> Either String ImportEnvironment

226+ importAll imp mn env = do

227+ imp' <- foldM (\m (name, dctors) -> importExplicit mn m (TypeImport name (Just dctors))) imp

228+ (S.toList . fromMaybe S.empty $ mn `M.lookup` exportedTypes env)

229+ imp'' <- foldM (\m name -> importExplicit mn m (NameImport name)) imp'

230+ (S.toList . fromMaybe S.empty $ mn `M.lookup` exportedValues env)

231+ foldM (\m name -> importExplicit mn m (TypeClassImport name)) imp''

232+ (S.toList . fromMaybe S.empty $ mn `M.lookup` exportedTypeClasses env)

233+

234+ -- Find all exported data constructors for a given type

235+ allExportedDataConstructors :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName]

236+ allExportedDataConstructors env mn name = fromMaybe (error $ "Unable to find exported data constructors for type " ++ show name ++ " in module " ++ show mn) $ do

237+ s <- mn `M.lookup` exportedTypes env

238+ name `lookup` S.toList s

239+

240+ -- Add something to the ImportEnvironment if it does not already exist there

203− Either String (M.Map id (Qualified id))

241+ updateImports :: (Ord id, Show id) => ModuleName -> M.Map id (Qualified id) -> id -> Either String (M.Map id (Qualified id))

204− resolveDef mn result name = case M.lookup name result of

242+ updateImports mn m name = case M.lookup name m of

205− Nothing -> return $ M.insert name (Qualified (Just mn) name) result

243+ Nothing -> return $ M.insert name (Qualified (Just mn) name) m

206− Just x@(Qualified (Just mn') _) -> Left $ "Module '" ++ show currentModule ++

244+ Just x@(Qualified (Just mn') _) -> Left $ "Module '" ++ show currentModule ++

207− if mn' == currentModule || mn == currentModule

245+ if mn' == currentModule || mn == currentModule

208− then "' defines '" ++ show name ++ "' which conflicts with imported definition '" ++ show (Qualified (Just mn) name) ++ "'"

246+ then "' defines '" ++ show name ++ "' which conflicts with imported definition '" ++ show (Qualified (Just mn) name) ++ "'"

209− else "' has conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just mn) name) ++ "'"

247+ else "' has conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just mn) name) ++ "'"

210−

248+

211− -- Resolve a set of ProperName exports for a specific imported set of names

212− -- This function is used to resolve both types and type classes, hence the filter function as

213− -- its first argument

214− resolveDefs :: (ExplicitImports -> [ProperName]) ->

215− M.Map ProperName (Qualified ProperName) ->

216− ModuleName ->

217− S.Set ProperName ->

218− Maybe ExplicitImports ->

219− Either String (M.Map ProperName (Qualified ProperName))

220− resolveDefs filt result mn names maybeExpl = do

221− names' <- case maybeExpl of

222− Just expl -> do

223− forM_ (filt expl) $ \name ->

224− unless (name `S.member` names) $ Left $ show name ++ " is explictly imported but is not defined in module " ++ show mn

225− return $ S.toList names `intersect` filt expl

226− Nothing -> return $ S.toList names

227− foldM (resolveDef mn) result names'

228−

229− -- Resolve a set of data constructors keyed by their type constructor

230− resolveDcons :: M.Map ProperName (Qualified ProperName) ->

231− ModuleName ->

232− S.Set (ProperName, [ProperName]) ->

233− Maybe ExplicitImports ->

234− Either String (M.Map ProperName (Qualified ProperName))

235− resolveDcons result mn tcons maybeExpl = foldM (foldM $ resolveDef mn) result $ map snd $

236− case maybeExpl of

237− Just expl -> filter ((`elem` typeImports expl) . fst) (S.toList tcons)

238− Nothing -> S.toList tcons

src/Language/PureScript/Sugar/TypeClasses.hs−1

@@ -155,7 +155,6 @@ typeInstanceDictionaryEntryDeclaration mn deps name tys (ValueDeclaration ident

155 lookupIdent members = maybe (Left $ "Type class " ++ show name ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members

156typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"

157

158−

159qualifiedToString :: ModuleName -> Qualified ProperName -> String

158qualifiedToString :: ModuleName -> Qualified ProperName -> String

160qualifiedToString mn (Qualified _ pn) = moduleNameToJs mn ++ "_" ++ runProperName pn

159qualifiedToString mn (Qualified _ pn) = moduleNameToJs mn ++ "_" ++ runProperName pn

161

160

src/Language/PureScript/TypeChecker.hs+7−35

@@ -171,43 +171,15 @@ typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = d

171 return $ d : ds

172typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName idents) : rest) = do

173 env <- getEnv

174− rethrow errorMessage $ do

174+ let instances = filter (\tcd ->

175− guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env

175+ let Qualified (Just mn) _ = tcdName tcd in

176− case idents of

176+ moduleName == mn && tcdType tcd == TCDRegular

177− Nothing -> do

177+ ) (typeClassDictionaries env)

178− shadowIdents (map snd $ filterModule (names env)) env

178+ forM_ instances $ \tcd -> do

179− Just idents' -> do

179+ let (Qualified _ ident) = tcdName tcd

180− shadowIdents (nameImports idents') env

180+ addTypeClassDictionaries [tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (tcdName tcd) }]

181− shadowTypeClassInstances env

182 ds <- typeCheckAll mainModuleName currentModule rest

181 ds <- typeCheckAll mainModuleName currentModule rest

183 return $ d : ds

182 return $ d : ds

184− where

185− errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)

186− filterModule = filter ((== moduleName) . fst) . M.keys

187− filterModuleQ = filter (\(Qualified (Just mn) _) -> mn == moduleName) . M.keys

188− moduleExists env = not (null (filterModule (names env))) || not (null (filterModuleQ (types env)))

189− shadowIdents idents' env =

190− forM_ idents' $ \ident ->

191− case (moduleName, ident) `M.lookup` names env of

192− Just (_, Alias _ _) -> return ()

193− Just (pt, _) -> do

194− guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env

195− modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })

196− Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")

197− shadowTypeClassInstances env = do

198− let instances = filter (\tcd ->

199− let Qualified (Just mn) _ = tcdName tcd in

200− moduleName == mn && tcdType tcd == TCDRegular

201− ) (typeClassDictionaries env)

202− forM_ instances $ \tcd -> do

203− let (Qualified _ ident) = tcdName tcd

204− addTypeClassDictionaries [tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (tcdName tcd) }]

205− constructs (TypeConstructor (Qualified (Just mn) pn')) pn

206− = mn == moduleName && pn' == pn

207− constructs (ForAll _ ty _) pn = ty `constructs` pn

208− constructs (TypeApp (TypeApp t _) ty) pn | t == tyFunction = ty `constructs` pn

209− constructs (TypeApp ty _) pn = ty `constructs` pn

210− constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn

211typeCheckAll mainModuleName moduleName (d@TypeClassDeclaration{} : rest) = do

183typeCheckAll mainModuleName moduleName (d@TypeClassDeclaration{} : rest) = do

212 env <- getEnv

184 env <- getEnv

213 ds <- typeCheckAll mainModuleName moduleName rest

185 ds <- typeCheckAll mainModuleName moduleName rest

src/Language/PureScript/TypeChecker/Types.hs−2

@@ -288,8 +288,6 @@ entails moduleName context goal@(className, tys) = do

288 filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True

289 filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True

290 filterModule _ = False

291− -- Resolve a type class dictionary in scope to an actual value by following any (TCDAlias) pointers

292− -- which originated from module imports

293 canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident

291 canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident

294 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm

292 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm

295 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm

293 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm

src/Language/PureScript/Values.hs+25−13

@@ -21,6 +21,7 @@ import Language.PureScript.Types

21import Language.PureScript.Names

23import Data.Data

24+import Data.Generics (mkQ, everything)

25-- |

26-- |

26-- A guard is just a boolean-valued expression that appears alongside a set of binders

27-- A guard is just a boolean-valued expression that appears alongside a set of binders

@@ -114,19 +115,6 @@ data Value

114 --

115 --

115 | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)

116 | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)

116

117

117−-- |

118−-- The type of a type class dictionary

119−--

120−data TypeClassDictionaryType

121− -- |

122− -- A regular type class dictionary

123− --

124− = TCDRegular

125− -- |

126− -- A type class dictionary which is an alias for an imported dictionary from another module

127− --

128− | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)

129−

130-- |

118-- |

131-- Data representing a type class dictionary which is in scope

119-- Data representing a type class dictionary which is in scope

132--

120--

@@ -154,6 +142,19 @@ data TypeClassDictionaryInScope

154 , tcdType :: TypeClassDictionaryType

142 , tcdType :: TypeClassDictionaryType

155 } deriving (Show, Data, Typeable)

143 } deriving (Show, Data, Typeable)

156

144

145+-- |

146+-- The type of a type class dictionary

147+--

148+data TypeClassDictionaryType

149+ -- |

150+ -- A regular type class dictionary

151+ --

152+ = TCDRegular

153+ -- |

154+ -- A type class dictionary which is an alias for an imported dictionary from another module

155+ --

156+ | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)

157+

157-- |

158-- |

158-- A statement in a do-notation block

159-- A statement in a do-notation block

159--

160--

@@ -215,3 +216,14 @@ data Binder

215 -- A binder which binds its input to an identifier

216 -- A binder which binds its input to an identifier

216 --

217 --

217 | NamedBinder Ident Binder deriving (Show, Data, Typeable)

218 | NamedBinder Ident Binder deriving (Show, Data, Typeable)

219+

220+

221+-- |

222+-- Collect all names introduced in binders in an expression

223+--

224+binderNames :: (Data d) => d -> [Ident]

225+binderNames = everything (++) (mkQ [] go)

226+ where

227+ go (VarBinder ident) = [ident]

228+ go (NamedBinder ident _) = [ident]

229+ go _ = []