@@ -16,6 +16,7 @@ module Language.PureScript.Sugar.Names (
1616 desugarImports
1717) where
1818
19+import Data.Data
1920import Data.Maybe (fromMaybe, isJust)
2021import Data.Generics (extM, mkM, everywhereM)
2122import Data.Generics.Extras (mkS, extS, everywhereWithContextM')
@@ -155,10 +156,16 @@ desugarImports modules = do
155156 renameInModule imports env (elaborateExports exps m)
156157
157158-- |
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
159166--
160167rethrowForModule :: 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 ++ "'"
162169
163170-- |
164171-- 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 $
176183--
177184renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either String Module
178185renameInModule 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
180187 where
181− updateDecl (TypeInstanceDeclaration name cs cn ts ds) =
182− TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds
183− updateDecl (ExternInstanceDeclaration name cs cn ts) =
184− ExternInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts
185− updateDecl d = return d
186−
187− updateVars :: Declaration -> Either String Declaration
188− updateVars (ValueDeclaration name nameKind [] Nothing val) =
189− ValueDeclaration name nameKind [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val
188+ go (TypeInstanceDeclaration name cs cn ts ds) =
189+ TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> everywhereM (mkM updateType) ts <*> mapM go ds
190+ go (ExternInstanceDeclaration name cs cn ts) =
191+ ExternInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> everywhereM (mkM updateType) ts
192+ go (ValueDeclaration name nameKind [] Nothing val) = do
193+ val' <- everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val
194+ rethrowForDecl name $ ValueDeclaration name nameKind [] Nothing <$> updateAll val'
190195 where
191196 bindFunctionArgs bound (Abs (Left arg) val') = return (arg : bound, Abs (Left arg) val')
192197 bindFunctionArgs bound (Let ds val') = let args = map letBoundVariable ds in
@@ -206,17 +211,26 @@ renameInModule imports exports (Module mn decls exps) =
206211 letBoundVariable :: Declaration -> Ident
207212 letBoundVariable (ValueDeclaration ident _ _ _ _) = ident
208213 letBoundVariable _ = error "Invalid argument to letBoundVariable"
209− updateVars (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
211− updateVars other = return other
214+ go (ValueDeclaration name _ _ _ _) = error $ "Binders should have been desugared in " ++ show name
215+ go d = updateAll d
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+
212223 updateValue (Constructor name) = Constructor <$> updateDataConstructorName name
213224 updateValue v = return v
225+
214226 updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b
215227 updateBinder v = return v
228+
216229 updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name
217230 updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys
218231 updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t
219232 updateType t = return t
233+
220234 updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)
221235
222236 updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` (exportedTypes mes)))