9b05933 · rowtype-yoga/purescript-native

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

on golang help sign in

Fix failing tests

9b05933Phil Freeman13 years ago

src/Language/PureScript/Sugar/Names.hs+17−9

compare with golang

unifiedsplit

@@ -84,10 +84,16 @@ data ImportEnvironment = ImportEnvironment

84--

85updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either String Exports) -> Either String ExportEnvironment

86updateExportedModule env mn update = do

87− let exports = fromMaybe (Exports S.empty S.empty S.empty) $ mn `M.lookup` env

87+ let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env

88 exports' <- update exports

89 return $ M.insert mn exports' env

91+-- |

92+-- Adds an empty module to an ExportEnvironment.

93+--

94+addEmptyModule :: ExportEnvironment -> ModuleName -> ExportEnvironment

95+addEmptyModule env name = M.insert name (Exports S.empty S.empty S.empty) env

96+

91-- |

97-- |

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

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

93--

99--

@@ -144,26 +150,28 @@ rethrowForModule (Module mn _) = flip catchError $ \e -> throwError ("Error in m

144--

150--

145renameInModule :: ImportEnvironment -> Module -> Either String Module

151renameInModule :: ImportEnvironment -> Module -> Either String Module

146renameInModule imports (Module mn decls) =

152renameInModule imports (Module mn decls) =

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

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

148 where

154 where

149 updateDecl (TypeInstanceDeclaration cs (Qualified Nothing cn) ts ds) =

155 updateDecl (TypeInstanceDeclaration cs (Qualified Nothing cn) ts ds) =

150− TypeInstanceDeclaration <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> updateVars ds

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

151− updateDecl (ValueDeclaration name bs grd val) =

152− ValueDeclaration name <$> updateVars bs <*> updateVars grd <*> updateVars val

153 updateDecl d = return d

157 updateDecl d = return d

154

158

155− updateVars :: (Data d) => d -> Either String d

159+ updateVars :: Declaration -> Either String Declaration

160+ updateVars (ValueDeclaration name [] Nothing val) =

156− updateVars = everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders)

161+ ValueDeclaration name [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val

157 where

162 where

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

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

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

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

160 bindFunctionArgs bound other = return (bound, other)

165 bindFunctionArgs bound other = return (bound, other)

161 bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)

166 bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)

162 bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)

167 bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)

168+ updateVars (ValueDeclaration name _ _ _) = error $ "Binders should have been desugared in " ++ show name

169+ updateVars other = return other

163

170

164 updateValue (Constructor (Qualified Nothing nm)) =

171 updateValue (Constructor (Qualified Nothing nm)) =

165 Constructor <$> updateDataConstructorName nm

172 Constructor <$> updateDataConstructorName nm

166 updateValue v = return v

173 updateValue v = return v

174+

167 updateBinder (ConstructorBinder (Qualified Nothing nm) b) =

175 updateBinder (ConstructorBinder (Qualified Nothing nm) b) =

168 ConstructorBinder <$> updateDataConstructorName nm <*> pure b

176 ConstructorBinder <$> updateDataConstructorName nm <*> pure b

169 updateBinder v = return v

177 updateBinder v = return v

@@ -189,7 +197,7 @@ renameInModule imports (Module mn decls) =

189findExports :: [Module] -> Either String ExportEnvironment

197findExports :: [Module] -> Either String ExportEnvironment

190findExports = foldM addModule M.empty

198findExports = foldM addModule M.empty

191 where

199 where

192− addModule env m@(Module mn ds) = rethrowForModule m $ foldM (addDecl mn) env ds

200+ addModule env m@(Module mn ds) = rethrowForModule m $ foldM (addDecl mn) (addEmptyModule env mn) ds

193 addDecl mn env (TypeClassDeclaration tcn _ ds) = do

201 addDecl mn env (TypeClassDeclaration tcn _ ds) = do

194 env' <- addTypeClass env mn tcn

202 env' <- addTypeClass env mn tcn

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

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

@@ -226,7 +234,7 @@ resolveImports env (Module currentModule decls) =

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

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

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

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

228 resolveImport' imp (mn, i) = do

236 resolveImport' imp (mn, i) = do

229− let m = fromMaybe (Exports S.empty S.empty S.empty) $ mn `M.lookup` env

237+ m <- maybe (throwError $ "Cannot import unknown module '" ++ show mn ++ "'") return $ mn `M.lookup` env

230 resolveImport currentModule mn m imp i

238 resolveImport currentModule mn m imp i

231

239

232-- |

240-- |