Merge pull request purescript#1271 from purescript/improve-error-positions

garyb · garyb · commit fcb66d4bba2c · 2015-07-16T18:39:45.000+01:00
Improve error positions from typechecker
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
@@ -31,6 +31,7 @@ import Data.Foldable (for_)
 
 import qualified Data.Map as M
 
+import Control.Applicative ((<$>), (<*))
 import Control.Monad.State
 import Control.Monad.Error.Class (MonadError(..))
 
@@ -129,25 +130,23 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms
 --  * Process module imports
 --
 typeCheckAll :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]
-typeCheckAll mainModuleName moduleName exps = go
+typeCheckAll mainModuleName moduleName exps ds = mapM go ds <* mapM_ checkOrphanFixities ds
   where
-  go :: [Declaration] -> Check [Declaration]
-  go [] = return []
-  go (DataDeclaration dtype name args dctors : rest) = do
+  go :: Declaration -> Check Declaration
+  go (DataDeclaration dtype name args dctors) = do
     rethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do
       when (dtype == Newtype) $ checkNewtype dctors
       checkDuplicateTypeArguments $ map fst args
       ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
       let args' = args `withKinds` ctorKind
       addDataType moduleName dtype name args' dctors ctorKind
-    ds <- go rest
-    return $ DataDeclaration dtype name args dctors : ds
+    return $ DataDeclaration dtype name args dctors
     where
     checkNewtype :: [(ProperName, [Type])] -> Check ()
     checkNewtype [(_, [_])] = return ()
     checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype
     checkNewtype _ = throwError . errorMessage $ InvalidNewtype
-  go (d@(DataBindingGroupDeclaration tys) : rest) = do
+  go (d@(DataBindingGroupDeclaration tys)) = do
     rethrow (onErrorMessages ErrorInDataBindingGroup) $ do
       let syns = mapMaybe toTypeSynonym tys
       let dataDecls = mapMaybe toDataDecl tys
@@ -160,35 +159,31 @@ typeCheckAll mainModuleName moduleName exps = go
         checkDuplicateTypeArguments $ map fst args
         let args' = args `withKinds` kind
         addTypeSynonym moduleName name args' ty kind
-    ds <- go rest
-    return $ d : ds
+    return d
     where
     toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
     toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d'
     toTypeSynonym _ = Nothing
     toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
     toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
     toDataDecl _ = Nothing
-  go (TypeSynonymDeclaration name args ty : rest) = do
+  go (TypeSynonymDeclaration name args ty) = do
     rethrow (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
-    ds <- go rest
-    return $ TypeSynonymDeclaration name args ty : ds
-  go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
-  go (ValueDeclaration name nameKind [] (Right val) : rest) = do
-    d <- rethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do
+    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
       valueIsNotDefined moduleName name
       [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
       addValue moduleName name ty nameKind
       return $ ValueDeclaration name nameKind [] $ Right val'
-    ds <- go rest
-    return $ d : ds
-  go (ValueDeclaration{} : _) = error "Binders were not desugared"
-  go (BindingGroupDeclaration vals : rest) = do
-    d <- rethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
+  go (ValueDeclaration{}) = error "Binders were not desugared"
+  go (BindingGroupDeclaration vals) =
+    rethrow (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
@@ -200,53 +195,49 @@ typeCheckAll mainModuleName moduleName exps = go
         addValue moduleName name ty nameKind
         return (name, nameKind, val)
       return $ BindingGroupDeclaration vals'
-    ds <- go rest
-    return $ d : ds
-  go (d@(ExternDataDeclaration name kind) : rest) = do
+  go (d@(ExternDataDeclaration name kind)) = do
     env <- getEnv
     putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
-    ds <- go rest
-    return $ d : ds
-  go (d@(ExternDeclaration name ty) : rest) = do
+    return d
+  go (d@(ExternDeclaration name ty)) = do
     rethrow (onErrorMessages (ErrorInForeignImport name)) $ do
       env <- getEnv
       kind <- kindOf moduleName ty
       guardWith (errorMessage (ExpectedType kind)) $ kind == Star
       case M.lookup (moduleName, name) (names env) of
         Just _ -> throwError . errorMessage $ RedefinedIdent name
         Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })
-    ds <- go rest
-    return $ d : ds
-  go (d@(FixityDeclaration _ name) : rest) = do
-    ds <- go rest
-    env <- getEnv
-    guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
-    return $ d : ds
-  go (d@(ImportDeclaration importedModule _ _) : rest) = do
+    return d
+  go (d@(FixityDeclaration{})) = return d
+  go (d@(ImportDeclaration importedModule _ _)) = do
     instances <- lookupTypeClassDictionaries $ Just importedModule
     addTypeClassDictionaries (Just moduleName) instances
-    ds <- go rest
-    return $ d : ds
-  go (d@(TypeClassDeclaration pn args implies tys) : rest) = do
+    return d
+  go (d@(TypeClassDeclaration pn args implies tys)) = do
     addTypeClass moduleName pn args implies tys
-    ds <- go rest
-    return $ d : ds
-  go (d@(TypeInstanceDeclaration dictName deps className tys _) : rest) = do
-    goInstance d dictName deps className tys rest
-  go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do
-    goInstance d dictName deps className tys rest
-  go (PositionedDeclaration pos com d : rest) =
-    rethrowWithPosition pos $ do
-      (d' : rest') <- go (d : rest)
-      return (PositionedDeclaration pos com d' : rest')
-  goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Check [Declaration]
-  goInstance d dictName deps className tys rest = do
+    return d
+  go (d@(TypeInstanceDeclaration dictName deps className tys _)) =
+    goInstance d dictName deps className tys
+  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
+
+  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
+  checkOrphanFixities _ = return ()
+
+  goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> Check Declaration
+  goInstance d dictName deps className tys = do
     mapM_ (checkTypeClassInstance moduleName) tys
     forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
     let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported
     addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (canonicalizeDictionary dict) dict
-    ds <- go rest
-    return $ d : ds
+    return d
 
     where
 
