Improve warning error locations from typechecker

garyb · garyb · commit 8d5cfc21f426 · 2015-08-25T01:08:27.000+01:00
diff --git a/src/Control/Monad/Unify.hs b/src/Control/Monad/Unify.hs
@@ -28,6 +28,7 @@ import Data.Monoid
 import Control.Applicative
 import Control.Monad.State
 import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Writer.Class (MonadWriter(..))
 
 import Data.HashMap.Strict as M
 
@@ -92,7 +93,7 @@ class UnificationError t e where
 -- The type checking monad, which provides the state of the type checker, and error reporting capabilities
 --
 newtype UnifyT t m a = UnifyT { unUnify :: StateT (UnifyState t) m a }
-  deriving (Functor, Monad, Applicative, Alternative, MonadPlus)
+  deriving (Functor, Monad, Applicative, Alternative, MonadPlus, MonadWriter w)
 
 instance (MonadState s m) => MonadState s (UnifyT t m) where
   get = UnifyT . lift $ get
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -841,6 +841,9 @@ interpretMultipleErrorsAndWarnings (err, ws) = do
 rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
 rethrow f = flip catchError $ \e -> throwError (f e)
 
+warnAndRethrow :: (MonadError e m, MonadWriter e m) => (e -> e) -> m a -> m a
+warnAndRethrow f = rethrow f . censor f
+
 -- |
 -- Rethrow an error with source position information
 --
@@ -850,6 +853,9 @@ rethrowWithPosition pos = rethrow (onErrorMessages (withPosition pos))
 warnWithPosition :: (MonadWriter MultipleErrors m) => SourceSpan -> m a -> m a
 warnWithPosition pos = censor (onErrorMessages (withPosition pos))
 
+warnAndRethrowWithPosition :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => SourceSpan -> m a -> m a
+warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos
+
 withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage
 withPosition _ (PositionedError pos err) = withPosition pos err
 withPosition pos err = PositionedError pos err
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
@@ -51,7 +51,7 @@ addDataType moduleName dtype name args dctors ctorKind = do
   env <- getEnv
   putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
   forM_ dctors $ \(dctor, tys) ->
-    rethrow (onErrorMessages (ErrorInDataConstructor dctor)) $
+    warnAndRethrow (onErrorMessages (ErrorInDataConstructor dctor)) $
       addDataConstructor moduleName dtype name (map fst args) dctor tys
 
 addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
@@ -137,7 +137,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
   where
   go :: Declaration -> Check Declaration
   go (DataDeclaration dtype name args dctors) = do
-    rethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do
+    warnAndRethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do
       when (dtype == Newtype) $ checkNewtype dctors
       checkDuplicateTypeArguments $ map fst args
       ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
@@ -150,7 +150,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
     checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype
     checkNewtype _ = throwError . errorMessage $ InvalidNewtype
   go (d@(DataBindingGroupDeclaration tys)) = do
-    rethrow (onErrorMessages ErrorInDataBindingGroup) $ do
+    warnAndRethrow (onErrorMessages ErrorInDataBindingGroup) $ do
       let syns = mapMaybe toTypeSynonym tys
       let dataDecls = mapMaybe toDataDecl tys
       (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
@@ -171,22 +171,22 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
     toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
     toDataDecl _ = Nothing
   go (TypeSynonymDeclaration name args ty) = do
-    rethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do
+    warnAndRethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do
       checkDuplicateTypeArguments $ map fst args
       kind <- kindsOf False moduleName name args [ty]
       let args' = args `withKinds` kind
       addTypeSynonym moduleName name args' ty kind
     return $ TypeSynonymDeclaration name args ty
   go (TypeDeclaration{}) = error "Type declarations should have been removed"
   go (ValueDeclaration name nameKind [] (Right val)) =
-    rethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do
+    warnAndRethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do
       valueIsNotDefined moduleName name
       [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
       addValue moduleName name ty nameKind
       return $ ValueDeclaration name nameKind [] $ Right val'
   go (ValueDeclaration{}) = error "Binders were not desugared"
   go (BindingGroupDeclaration vals) =
-    rethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
+    warnAndRethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
       forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
         valueIsNotDefined moduleName name
       tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
@@ -203,7 +203,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
     putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
     return d
   go (d@(ExternDeclaration name ty)) = do
-    rethrow (onErrorMessages (ErrorInForeignImport name)) $ do
+    warnAndRethrow (onErrorMessages (ErrorInForeignImport name)) $ do
       env <- getEnv
       kind <- kindOf moduleName ty
       guardWith (errorMessage (ExpectedType kind)) $ kind == Star
@@ -224,14 +224,14 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
   go (d@(ExternInstanceDeclaration dictName deps className tys)) =
     goInstance d dictName deps className tys
   go (PositionedDeclaration pos com d) =
-    rethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
+    warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
 
   checkOrphanFixities :: Declaration -> Check ()
   checkOrphanFixities (FixityDeclaration _ name) = do
     env <- getEnv
     guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
   checkOrphanFixities (PositionedDeclaration pos _ d) =
-    rethrowWithPosition pos $ checkOrphanFixities d
+    warnAndRethrowWithPosition pos $ checkOrphanFixities d
   checkOrphanFixities _ = return ()
 
   goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> Check Declaration
@@ -274,7 +274,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
 --
 typeCheckModule :: Maybe ModuleName -> Module -> Check Module
 typeCheckModule _ (Module _ _ _ _ Nothing) = error "exports should have been elaborated"
-typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = rethrow (onErrorMessages (ErrorInModule mn)) $ do
+typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = warnAndRethrow (onErrorMessages (ErrorInModule mn)) $ do
   modify (\s -> s { checkCurrentModule = Just mn })
   decls' <- typeCheckAll mainModuleName mn exps decls
   forM_ exps $ \e -> do
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
@@ -184,7 +184,7 @@ replaceTypeClassDictionaries mn =
   where
   go (TypeClassDictionary constraint dicts) = do
     env <- getEnv
-    entails env mn dicts constraint 
+    entails env mn dicts constraint
   go other = return other
 
 -- |
@@ -305,7 +305,7 @@ infer' (TypedValue checkType val ty) = do
   ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
   val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val
   return $ TypedValue True val' ty'
-infer' (PositionedValue pos _ val) = rethrowWithPosition pos $ infer' val
+infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val
 infer' _ = error "Invalid argument to infer"
 
 inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)
@@ -334,7 +334,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
   bindNames dict $ do
     makeBindingGroupVisible
     inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
-inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = rethrowWithPosition pos $ do
+inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPosition pos $ do
   (d' : ds', val') <- inferLetBinding seen (d : ds) ret j
   return (PositionedDeclaration pos com d' : ds', val')
 inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"
@@ -406,7 +406,7 @@ inferBinder val (NamedBinder name binder) = do
   m <- inferBinder val binder
   return $ M.insert name val m
 inferBinder val (PositionedBinder pos _ binder) =
-  rethrowWithPosition pos $ inferBinder val binder
+  warnAndRethrowWithPosition pos $ inferBinder val binder
 
 -- |
 -- Check the types of the return values in a set of binders in a case statement
@@ -458,15 +458,15 @@ check' val t@(ConstrainedType constraints ty) = do
   val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty
   return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
   where
-  -- | Add a dictionary for the constraint to the scope, and dictionaries 
+  -- | Add a dictionary for the constraint to the scope, and dictionaries
   -- for all implies superclass instances.
   newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> Check [TypeClassDictionaryInScope]
   newDictionaries path name (className, instanceTy) = do
-    tcs <- gets (typeClasses . checkEnv) 
+    tcs <- gets (typeClasses . checkEnv)
     let (args, _, superclasses) = fromMaybe (error "newDictionaries: type class lookup failed") $ M.lookup className tcs
-    supDicts <- join <$> zipWithM (\(supName, supArgs) index -> 
-                                      newDictionaries ((supName, index) : path) 
-                                                      name 
+    supDicts <- join <$> zipWithM (\(supName, supArgs) index ->
+                                      newDictionaries ((supName, index) : path)
+                                                      name
                                                       (supName, instantiateSuperclass (map fst args) supArgs instanceTy)
                                   ) superclasses [0..]
     return (TypeClassDictionaryInScope name path className instanceTy Nothing TCDRegular : supDicts)
@@ -586,7 +586,7 @@ check' val kt@(KindedType ty kind) = do
   val' <- check' val ty
   return $ TypedValue True val' kt
 check' (PositionedValue pos _ val) ty =
-  rethrowWithPosition pos $ check' val ty
+  warnAndRethrowWithPosition pos $ check' val ty
 check' val ty = throwError . errorMessage $ ExprDoesNotHaveType val ty
 
 containsTypeSynonyms :: Type -> Bool
