a118d14 · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #319 from garyb/name-decl-errors

a118d14Phil Freeman13 years ago

src/Language/PureScript/Sugar/Names.hs+42−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,21 @@ 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

188+ go (DataDeclaration name args dctors) =

189+ rethrowFor "data declaration" name $ DataDeclaration <$> pure name <*> pure args <*> updateAll dctors

190+ go (DataBindingGroupDeclaration decls') =

191+ DataBindingGroupDeclaration <$> mapM go decls'

192+ go (TypeSynonymDeclaration name ps ty) =

193+ rethrowFor "type synonym" name $ TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty

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

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

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

195+ TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> updateType' ts <*> mapM go ds

183− updateDecl (ExternInstanceDeclaration name cs cn ts) =

196+ go (ExternInstanceDeclaration name cs cn ts) =

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

197+ ExternInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> updateType' ts

185− updateDecl d = return d

186−

187− updateVars :: Declaration -> Either String Declaration

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

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

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

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

200+ rethrowFor "declaration" name $ ValueDeclaration name nameKind [] Nothing <$> updateAll val'

190 where

201 where

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

202 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

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

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

206 letBoundVariable :: Declaration -> Ident

217 letBoundVariable :: Declaration -> Ident

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

218 letBoundVariable (ValueDeclaration ident _ _ _ _) = ident

208 letBoundVariable _ = error "Invalid argument to letBoundVariable"

219 letBoundVariable _ = error "Invalid argument to letBoundVariable"

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

220+ 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

221+ go (ExternDeclaration fit name js ty) =

211− updateVars other = return other

222+ rethrowFor "declaration" name $ ExternDeclaration <$> pure fit <*> pure name <*> pure js <*> updateType' ty

223+ go (BindingGroupDeclaration decls') = do

224+ BindingGroupDeclaration <$> mapM go' decls'

225+ where go' = \(name, nk, value) -> rethrowFor "declaration" name $ (,,) <$> pure name <*> pure nk <*> updateAll value

226+ go d = updateAll d

227+

228+ rethrowFor :: (Show a) => String -> a -> Either String b -> Either String b

229+ rethrowFor what name = rethrow $ "Error in " ++ what ++ " '" ++ show name ++ "'"

230+

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

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

233+

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

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

213 updateValue v = return v

235 updateValue v = return v

236+

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

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

215 updateBinder v = return v

238 updateBinder v = return v

239+

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

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

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

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

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

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

219 updateType t = return t

243 updateType t = return t

244+ updateType' :: Data d => d -> Either String d

245+ updateType' = everywhereM (mkM updateType)

246+

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

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

221

248

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

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