8d5cfc2 · rowtype-yoga/purescript-native

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

Improve warning error locations from typechecker

commit8d5cfc21f4269edc87b435a462e9506b99d4742f authorGary Burgess <gary.burgess@gmail.com> dateTue 25 Aug 2015, 01:08 (11 years ago) parent5d7ab6a

4 files changed+28−21

compare with golang

unifiedsplit

src/Control/Monad/Unify.hs+2−1 src/Language/PureScript/Errors.hs+6 src/Language/PureScript/TypeChecker.hs+10−10 src/Language/PureScript/TypeChecker/Types.hs+10−10

src/Control/Monad/Unify.hs+2−1

@@ -28,6 +28,7 @@ import Data.Monoid

2828import Control.Applicative

2929import Control.Monad.State

3030import Control.Monad.Error.Class (MonadError(..))

31+import Control.Monad.Writer.Class (MonadWriter(..))

3132

3233import Data.HashMap.Strict as M

3334

@@ -92,7 +93,7 @@ class UnificationError t e where

9293-- The type checking monad, which provides the state of the type checker, and error reporting capabilities

9394--

9495newtype UnifyT t m a = UnifyT { unUnify :: StateT (UnifyState t) m a }

95− deriving (Functor, Monad, Applicative, Alternative, MonadPlus)

96+ deriving (Functor, Monad, Applicative, Alternative, MonadPlus, MonadWriter w)

9697

9798instance (MonadState s m) => MonadState s (UnifyT t m) where

9899 get = UnifyT . lift $ get

src/Language/PureScript/Errors.hs+6

@@ -841,6 +841,9 @@ interpretMultipleErrorsAndWarnings (err, ws) = do

841841rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

842842rethrow f = flip catchError $ \e -> throwError (f e)

843843

844+warnAndRethrow :: (MonadError e m, MonadWriter e m) => (e -> e) -> m a -> m a

845+warnAndRethrow f = rethrow f . censor f

846+

844847-- |

845848-- Rethrow an error with source position information

846849--

@@ -850,6 +853,9 @@ rethrowWithPosition pos = rethrow (onErrorMessages (withPosition pos))

850853warnWithPosition :: (MonadWriter MultipleErrors m) => SourceSpan -> m a -> m a

851854warnWithPosition pos = censor (onErrorMessages (withPosition pos))

852855

856+warnAndRethrowWithPosition :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => SourceSpan -> m a -> m a

857+warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos

858+

853859withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage

854860withPosition _ (PositionedError pos err) = withPosition pos err

855861withPosition pos err = PositionedError pos err

src/Language/PureScript/TypeChecker.hs+10−10

@@ -51,7 +51,7 @@ addDataType moduleName dtype name args dctors ctorKind = do

5151 env <- getEnv

5252 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }

5353 forM_ dctors $ \(dctor, tys) ->

54− rethrow (onErrorMessages (ErrorInDataConstructor dctor)) $

54+ warnAndRethrow (onErrorMessages (ErrorInDataConstructor dctor)) $

5555 addDataConstructor moduleName dtype name (map fst args) dctor tys

5656

5757addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()

@@ -137,7 +137,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

137137 where

138138 go :: Declaration -> Check Declaration

139139 go (DataDeclaration dtype name args dctors) = do

140− rethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do

140+ warnAndRethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do

141141 when (dtype == Newtype) $ checkNewtype dctors

142142 checkDuplicateTypeArguments $ map fst args

143143 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)

@@ -150,7 +150,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

150150 checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype

151151 checkNewtype _ = throwError . errorMessage $ InvalidNewtype

152152 go (d@(DataBindingGroupDeclaration tys)) = do

153− rethrow (onErrorMessages ErrorInDataBindingGroup) $ do

153+ warnAndRethrow (onErrorMessages ErrorInDataBindingGroup) $ do

154154 let syns = mapMaybe toTypeSynonym tys

155155 let dataDecls = mapMaybe toDataDecl tys

156156 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

@@ -171,7 +171,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

171171 toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'

172172 toDataDecl _ = Nothing

173173 go (TypeSynonymDeclaration name args ty) = do

174− rethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do

174+ warnAndRethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do

175175 checkDuplicateTypeArguments $ map fst args

176176 kind <- kindsOf False moduleName name args [ty]

177177 let args' = args `withKinds` kind

@@ -179,14 +179,14 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

179179 return $ TypeSynonymDeclaration name args ty

180180 go (TypeDeclaration{}) = error "Type declarations should have been removed"

181181 go (ValueDeclaration name nameKind [] (Right val)) =

182− rethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do

182+ warnAndRethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do

183183 valueIsNotDefined moduleName name

184184 [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]

185185 addValue moduleName name ty nameKind

186186 return $ ValueDeclaration name nameKind [] $ Right val'

187187 go (ValueDeclaration{}) = error "Binders were not desugared"

188188 go (BindingGroupDeclaration vals) =

189− rethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do

189+ warnAndRethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do

190190 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->

191191 valueIsNotDefined moduleName name

192192 tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals

@@ -203,7 +203,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

203203 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }

204204 return d

205205 go (d@(ExternDeclaration name ty)) = do

206− rethrow (onErrorMessages (ErrorInForeignImport name)) $ do

206+ warnAndRethrow (onErrorMessages (ErrorInForeignImport name)) $ do

207207 env <- getEnv

208208 kind <- kindOf moduleName ty

209209 guardWith (errorMessage (ExpectedType kind)) $ kind == Star

@@ -224,14 +224,14 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

224224 go (d@(ExternInstanceDeclaration dictName deps className tys)) =

225225 goInstance d dictName deps className tys

226226 go (PositionedDeclaration pos com d) =

227− rethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

227+ warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

228228

229229 checkOrphanFixities :: Declaration -> Check ()

230230 checkOrphanFixities (FixityDeclaration _ name) = do

231231 env <- getEnv

232232 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env

233233 checkOrphanFixities (PositionedDeclaration pos _ d) =

234− rethrowWithPosition pos $ checkOrphanFixities d

234+ warnAndRethrowWithPosition pos $ checkOrphanFixities d

235235 checkOrphanFixities _ = return ()

236236

237237 goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> Check Declaration

@@ -274,7 +274,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

274274--

275275typeCheckModule :: Maybe ModuleName -> Module -> Check Module

276276typeCheckModule _ (Module _ _ _ _ Nothing) = error "exports should have been elaborated"

277−typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = rethrow (onErrorMessages (ErrorInModule mn)) $ do

277+typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = warnAndRethrow (onErrorMessages (ErrorInModule mn)) $ do

278278 modify (\s -> s { checkCurrentModule = Just mn })

279279 decls' <- typeCheckAll mainModuleName mn exps decls

280280 forM_ exps $ \e -> do

src/Language/PureScript/TypeChecker/Types.hs+10−10

@@ -184,7 +184,7 @@ replaceTypeClassDictionaries mn =

184184 where

185185 go (TypeClassDictionary constraint dicts) = do

186186 env <- getEnv

187− entails env mn dicts constraint

187+ entails env mn dicts constraint

188188 go other = return other

189189

190190-- |

@@ -305,7 +305,7 @@ infer' (TypedValue checkType val ty) = do

305305 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

306306 val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val

307307 return $ TypedValue True val' ty'

308−infer' (PositionedValue pos _ val) = rethrowWithPosition pos $ infer' val

308+infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val

309309infer' _ = error "Invalid argument to infer"

310310

311311inferLetBinding :: [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

334334 bindNames dict $ do

335335 makeBindingGroupVisible

336336 inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j

337−inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = rethrowWithPosition pos $ do

337+inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPosition pos $ do

338338 (d' : ds', val') <- inferLetBinding seen (d : ds) ret j

339339 return (PositionedDeclaration pos com d' : ds', val')

340340inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"

@@ -406,7 +406,7 @@ inferBinder val (NamedBinder name binder) = do

406406 m <- inferBinder val binder

407407 return $ M.insert name val m

408408inferBinder val (PositionedBinder pos _ binder) =

409− rethrowWithPosition pos $ inferBinder val binder

409+ warnAndRethrowWithPosition pos $ inferBinder val binder

410410

411411-- |

412412-- 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

458458 val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty

459459 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t

460460 where

461− -- | Add a dictionary for the constraint to the scope, and dictionaries

461+ -- | Add a dictionary for the constraint to the scope, and dictionaries

462462 -- for all implies superclass instances.

463463 newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> Check [TypeClassDictionaryInScope]

464464 newDictionaries path name (className, instanceTy) = do

465− tcs <- gets (typeClasses . checkEnv)

465+ tcs <- gets (typeClasses . checkEnv)

466466 let (args, _, superclasses) = fromMaybe (error "newDictionaries: type class lookup failed") $ M.lookup className tcs

467− supDicts <- join <$> zipWithM (\(supName, supArgs) index ->

468− newDictionaries ((supName, index) : path)

469− name

467+ supDicts <- join <$> zipWithM (\(supName, supArgs) index ->

468+ newDictionaries ((supName, index) : path)

469+ name

470470 (supName, instantiateSuperclass (map fst args) supArgs instanceTy)

471471 ) superclasses [0..]

472472 return (TypeClassDictionaryInScope name path className instanceTy Nothing TCDRegular : supDicts)

@@ -586,7 +586,7 @@ check' val kt@(KindedType ty kind) = do

586586 val' <- check' val ty

587587 return $ TypedValue True val' kt

588588check' (PositionedValue pos _ val) ty =

589− rethrowWithPosition pos $ check' val ty

589+ warnAndRethrowWithPosition pos $ check' val ty

590590check' val ty = throwError . errorMessage $ ExprDoesNotHaveType val ty

591591

592592containsTypeSynonyms :: Type -> Bool