2ea411d · rowtype-yoga/purescript-native

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

on golang help sign in

Include name of declaration in name-related error

2ea411dGary Burgess13 years ago

src/Language/PureScript/Sugar/Names.hs+29−15

compare with golang

unifiedsplit

@@ -16,6 +16,7 @@ module Language.PureScript.Sugar.Names (

16 desugarImports

17) where

19+import Data.Data

19import Data.Maybe (fromMaybe, isJust)

20import Data.Maybe (fromMaybe, isJust)

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

21import Data.Generics (extM, mkM, everywhereM)

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

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

@@ -155,10 +156,16 @@ desugarImports modules = do

155 renameInModule imports env (elaborateExports exps m)

156 renameInModule imports env (elaborateExports exps m)

156

157

157-- |

158-- |

158−-- Rethrow an error with the name of the current module in the case of a failure

159+-- Rethrow an error with an extra message line prepended

160+--

161+rethrow :: String -> Either String a -> Either String a

162+rethrow msg = flip catchError $ \e -> throwError (msg ++ ":\n" ++ e)

163+

164+-- |

165+-- Rethrow an error with details of the current module prepended to the message

159--

166--

160rethrowForModule :: Module -> Either String a -> Either String a

167rethrowForModule :: Module -> Either String a -> Either String a

161−rethrowForModule (Module mn _ _) = flip catchError $ \e -> throwError ("Error in module '" ++ show mn ++ "':\n" ++ e)

168+rethrowForModule (Module mn _ _) = rethrow $ "Error in module '" ++ show mn ++ "'"

162

169

163-- |

170-- |

164-- Make all exports for a module explicit. This may still effect modules that have an exports list,

171-- Make all exports for a module explicit. This may still effect modules that have an exports list,

@@ -176,17 +183,15 @@ elaborateExports exps (Module mn decls _) = Module mn decls (Just $

176--

183--

177renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either String Module

184renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either String Module

178renameInModule imports exports (Module mn decls exps) =

185renameInModule imports exports (Module mn decls exps) =

179− Module mn <$> (mapM updateDecl decls >>= (mapM updateVars >=> everywhereM (mkM updateType `extM` updateValue `extM` updateBinder))) <*> pure exps

186+ Module mn <$> mapM go decls <*> pure exps

180 where

187 where

181− updateDecl (TypeInstanceDeclaration name cs cn ts ds) =

188+ go (TypeInstanceDeclaration name cs cn ts ds) =

182− TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds

189+ TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> everywhereM (mkM updateType) ts <*> mapM go ds

183− updateDecl (ExternInstanceDeclaration name cs cn ts) =

190+ go (ExternInstanceDeclaration name cs cn ts) =

184− ExternInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts

191+ ExternInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> everywhereM (mkM updateType) ts

185− updateDecl d = return d

186−

187− updateVars :: Declaration -> Either String Declaration

188− updateVars (ValueDeclaration name nameKind [] Nothing val) =

192+ go (ValueDeclaration name nameKind [] Nothing val) = do

189− ValueDeclaration name nameKind [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val

193+ val' <- everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val

194+ rethrowForDecl name $ ValueDeclaration name nameKind [] Nothing <$> updateAll val'

190 where

195 where

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

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

192 bindFunctionArgs bound (Let ds val') = let args = map letBoundVariable ds in

197 bindFunctionArgs bound (Let ds val') = let args = map letBoundVariable ds in

@@ -206,17 +211,26 @@ renameInModule imports exports (Module mn decls exps) =

206 letBoundVariable :: Declaration -> Ident

211 letBoundVariable :: Declaration -> Ident

207 letBoundVariable (ValueDeclaration ident _ _ _ _) = ident

212 letBoundVariable (ValueDeclaration ident _ _ _ _) = ident

208 letBoundVariable _ = error "Invalid argument to letBoundVariable"

213 letBoundVariable _ = error "Invalid argument to letBoundVariable"

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

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

210− updateVars (TypeInstanceDeclaration name deps className tys ds) = TypeInstanceDeclaration name deps className tys <$> mapM updateVars ds

215+ go d = updateAll d

211− updateVars other = return other

216+

217+ rethrowForDecl :: Ident -> Either String a -> Either String a

218+ rethrowForDecl name = rethrow $ "Error in declaration '" ++ show name ++ "'"

219+

220+ updateAll :: Data d => d -> Either String d

221+ updateAll = everywhereM (mkM updateType `extM` updateValue `extM` updateBinder)

222+

212 updateValue (Constructor name) = Constructor <$> updateDataConstructorName name

223 updateValue (Constructor name) = Constructor <$> updateDataConstructorName name

213 updateValue v = return v

224 updateValue v = return v

225+

214 updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b

226 updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b

215 updateBinder v = return v

227 updateBinder v = return v

228+

216 updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name

229 updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name

217 updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys

230 updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys

218 updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t

231 updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t

219 updateType t = return t

232 updateType t = return t

233+

220 updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)

234 updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)

221

235

222 updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` (exportedTypes mes)))

236 updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` (exportedTypes mes)))