b0c35c6 · rowtype-yoga/purescript-native

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

An attempt at importing values

commitb0c35c609c053ca8edd9cae803fa322e0528aad9 authorPhil Freeman <paf31@cantab.net> dateSun 2 Mar 2014, 22:54 (13 years ago) parent7abdae9

11 files changed+170−188

compare with golang

unifiedsplit

examples/passing/ImportExplicit.purs+1−1 src/Data/Generics/Extras.hs+21−10 src/Language/PureScript/CodeGen/JS.hs−9 src/Language/PureScript/Declarations.hs+5−24 src/Language/PureScript/Parser/Declarations.hs+7−1 src/Language/PureScript/Sugar.hs+5−3 src/Language/PureScript/Sugar/Names.hs+99−89 src/Language/PureScript/Sugar/TypeClasses.hs−1 src/Language/PureScript/TypeChecker.hs+7−35 src/Language/PureScript/TypeChecker/Types.hs−2 src/Language/PureScript/Values.hs+25−13

examples/passing/ImportExplicit.purs+1−1

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

66module Main where

8− import M1 (X)

8+ import M1 (X(..))

1010 testX :: X

1111 testX = X

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

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

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

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

4949--

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

51−everywhereWithContext' s0 f x =

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

53− gmapT (everywhereWithContext' s f) y

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

51+everywhereWithContextM' s0 f x = do

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

53+ gmapM (everywhereWithContextM' s f) y

5454

5555-- |

5656-- Make a stateful transformation function

5757--

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

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

60− a <- cast b

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

62− b' <- cast a'

63− return (s', b')

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

59+mkS = extS (curry return)

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

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

67+ case cast a' of

68+ Just b -> do

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

70+ case cast b' of

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

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

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,

226226 binderToJs m e v done'' b

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

228228

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−

238229-- |

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

240231-- binder.

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

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

7272 -- |

7373 -- A type constructor import

7474 --

75− = TypeImport ProperName

75+ = TypeImport ProperName (Maybe [ProperName])

7676 -- |

7777 -- A declaration import

7878 --

7979 | NameImport Ident

80+ -- |

81+ -- A type class import

82+ --

83+ | TypeClassImport ProperName

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

8185

8286-- |

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

183187isTypeClassDeclaration TypeClassDeclaration{} = True

184188isTypeClassDeclaration TypeInstanceDeclaration{} = True

185189isTypeClassDeclaration _ = 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

8888 reserved "import"

8989 indented

9090 moduleName' <- moduleName

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

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

9292 return $ ImportDeclaration moduleName' idents

9393

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+

94100parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

95101parseTypeClassDeclaration = do

96102 reserved "class"

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

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

4646--

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

4848--

49+-- * Qualify any unqualified names and types

50+--

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

50−desugar = rename

51− >=> desugarTypeClasses

52− >=> rebracket

52+desugar = rebracket

5353 >=> desugarDo

5454 >=> desugarLetBindings

5555 >>> desugarCasesModule

5656 >=> desugarTypeDeclarationsModule

57+ >=> desugarImports

58+ >=> desugarTypeClasses

5759 >=> createBindingGroupsModule

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

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

1313-----------------------------------------------------------------------------

1414

1515module Language.PureScript.Sugar.Names (

16− rename

16+ desugarImports

1717) where

1818

1919import Data.Maybe (fromMaybe)

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

2120import Data.List (intersect)

21+import Data.Data

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

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

2224

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

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

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

2527

2628import qualified Data.Map as M

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

3840 -- |

3941 -- The types exported from each module

4042 --

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

42− -- |

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

44− --

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

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

4644 -- |

4745 -- The classes exported from each module

4846 --

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

48+ -- |

49+ -- The values exported from each module

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

51+ --

5052 } deriving (Show)

5153

5254-- |

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

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

6668 --

6769 , 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)

6874 } deriving (Show)

6975

7076-- |

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

7278--

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

74−addType env mn name = do

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

76− return $ env { exportedTypes = types }

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

80+addType env mn name dctors = do

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

82+ return $ env { exportedTypes = types }

7783

7884-- |

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

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

8086--

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

82−addDataConstructors env mn tcon dcons = do

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

84− return $ env { exportedDataConstructors = dataConstructors }

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

88+addTypeClass env mn name = do

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

90+ return $ env { exportedTypeClasses = classes }

8591

8692-- |

8793-- Adds a class to the export environment.

8894--

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

90−addTypeclass env mn name = do

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

92− return $ env { exportedTypeClasses = classes }

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

96+addValue env mn name = do

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

98+ return $ env { exportedValues = values }

9399

94100-- |

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

104110-- |

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

106112--

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

108−rename modules = do

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

114+desugarImports modules = do

109115 exports <- findExports modules

110116 mapM (renameInModule' exports) modules

111117 where

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

120126renameInModule imports (Module mn decls) =

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

122128 where

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

124− cn' <- updateClassName cn

125− cs' <- updateConstraints cs

126− return $ TypeInstanceDeclaration cs' cn' ts ds

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

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

131+ updateDecl (ValueDeclaration name bs grd val) =

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

127142 updateDecl d = return d

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

129144 updateValue v = return v

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

131146 updateBinder v = return v

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

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

134− nm' <- updateTypeName nm

135− tys' <- mapM updateType tys

136− return $ SaturatedTypeSynonym nm' tys'

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

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

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

138151 updateType t = return t

139152 updateConstraints = mapM updateConstraint

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

142155 return (nm', ts)

143156 updateConstraint other = return other

144157 updateTypeName = update "type" importedTypes

145− updateClassName = update "typeclass" importedTypeClasses

158+ updateClassName = update "type class" importedTypeClasses

159+ updateValueName = update "value" importedValues

146160 updateDataConstructorName = update "data constructor" importedDataConstructors

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

148162

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

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

154168 where

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

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

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

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

159− addType env' mn tn

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

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

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

171+ env' <- addTypeClass env mn tcn

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

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

174+ addDecl mn env (TypeSynonymDeclaration 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

162178 addDecl _ env _ = return env

163179

164180-- |

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

180196-- Constructs a local environment for a module.

181197--

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

183−resolveImports env (Module currentModule decls) = ImportEnvironment

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

185− <*> resolve (exportedDataConstructors env) resolveDcons

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

199+resolveImports env (Module currentModule decls) =

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

187201 where

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

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

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

191205

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

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

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

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

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

197−

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

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

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

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

202− id ->

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

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

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

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

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

208− 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) ++ "'"

210−

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

206+ -- Add data to the ImportEnvironment

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

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

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

210+

211+ -- Import something explicitly

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

213+ importExplicit mn imp (NameImport name) = do

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

215+ return $ imp { importedValues = values' }

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

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

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

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

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

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

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

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

248+

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

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

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

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

157157

158−

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

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

161160

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

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

171171 return $ d : ds

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

173173 env <- getEnv

174− rethrow errorMessage $ do

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

176− case idents of

177− Nothing -> do

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

179− Just idents' -> do

180− shadowIdents (nameImports idents') env

181− shadowTypeClassInstances env

174+ let instances = filter (\tcd ->

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

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

177+ ) (typeClassDictionaries env)

178+ forM_ instances $ \tcd -> do

179+ let (Qualified _ ident) = tcdName tcd

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

182181 ds <- typeCheckAll mainModuleName currentModule rest

183182 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

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

212184 env <- getEnv

213185 ds <- typeCheckAll mainModuleName moduleName rest

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

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

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

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

290290 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

293291 canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident

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

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

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

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

2121import Language.PureScript.Names

2222

2323import Data.Data

24+import Data.Generics (mkQ, everything)

2425

2526-- |

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

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

114115 --

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

116117

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−

130118-- |

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

132120--

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

154142 , tcdType :: TypeClassDictionaryType

155143 } deriving (Show, Data, Typeable)

156144

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+

157158-- |

158159-- A statement in a do-notation block

159160--

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

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

216217 --

217218 | 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 _ = []