Gave Parsec errors proper positioning info

This commit is contained in:
Vidar Holen 2012-11-04 18:58:34 -08:00
parent d5587dd104
commit 22ae83e372
3 changed files with 25 additions and 5 deletions

View File

@ -3,7 +3,6 @@
module Shpell.Parser (Token(..), Note(..), Severity(..), parseShell, ParseResult(..), ParseNote(..), notesFromMap, Metadata(..), doAnalysis, doTransform, sortNotes) where module Shpell.Parser (Token(..), Note(..), Severity(..), parseShell, ParseResult(..), ParseNote(..), notesFromMap, Metadata(..), doAnalysis, doTransform, sortNotes) where
import Text.Parsec import Text.Parsec
import Text.Parsec.Pos (initialPos)
import Debug.Trace import Debug.Trace
import Control.Monad import Control.Monad
import Control.Monad.Identity import Control.Monad.Identity
@ -14,7 +13,9 @@ import qualified Control.Monad.State as Ms
import Data.Maybe import Data.Maybe
import Prelude hiding (readList) import Prelude hiding (readList)
import System.IO import System.IO
import Text.Parsec.Error
import qualified Text.Regex as Re import qualified Text.Regex as Re
import GHC.Exts (sortWith)
@ -993,8 +994,22 @@ sortNotes = sortBy compareNotes
data ParseResult = ParseResult { parseResult :: Maybe (Token, Map.Map Id Metadata), parseNotes :: [ParseNote] } data ParseResult = ParseResult { parseResult :: Maybe (Token, Map.Map Id Metadata), parseNotes :: [ParseNote] }
makeErrorFor parsecError =
ParseNote (errorPos parsecError) ErrorC $ getStringFromParsec $ errorMessages parsecError
getStringFromParsec errors =
case map snd $ sortWith fst $ map f errors of
(s:_) -> s
_ -> "Unknown error"
where f err =
case err of
UnExpect s -> (1, "Aborting due to unexpected " ++ s ++". Is this valid?")
SysUnExpect s -> (2, "Internal unexpected " ++ s ++ ". Submit a bug.")
Expect s -> (3, "Expected " ++ s ++ "")
Message s -> (4, "Message: " ++ s)
parseShell filename contents = do parseShell filename contents = do
case rp (parseWithNotes readScript) filename contents of case rp (parseWithNotes readScript) filename contents of
(Right (script, map, notes), parsenotes) -> ParseResult (Just (script, map)) (nub $ sortNotes $ notes ++ parsenotes) (Right (script, map, notes), parsenotes) -> ParseResult (Just (script, map)) (nub $ sortNotes $ notes ++ parsenotes)
(Left err, p) -> ParseResult Nothing (nub $ sortNotes $ (ParseNote (initialPos "-") ErrorC $ "Parsing failed: " ++ (show err)):(p)) (Left err, p) -> ParseResult Nothing (nub $ sortNotes $ (makeErrorFor err):p)

View File

@ -4,6 +4,7 @@ import Shpell.Parser
import Shpell.Analytics import Shpell.Analytics
import Data.Maybe import Data.Maybe
import Text.Parsec.Pos import Text.Parsec.Pos
import Data.List
shpellCheck :: String -> [ShpellComment] shpellCheck :: String -> [ShpellComment]
shpellCheck script = shpellCheck script =
@ -14,7 +15,7 @@ shpellCheck script =
return $ notesFromMap newMap return $ notesFromMap newMap
) )
in in
map formatNote $ sortNotes allNotes map formatNote $ nub $ sortNotes allNotes
data ShpellComment = ShpellComment { shpellLine :: Int, shpellColumn :: Int, shpellSeverity :: String, shpellComment :: String } data ShpellComment = ShpellComment { shpellLine :: Int, shpellColumn :: Int, shpellSeverity :: String, shpellComment :: String }

View File

@ -32,13 +32,17 @@ doFile path colorFunc = do
doInput filename contents colorFunc = do doInput filename contents colorFunc = do
let fileLines = lines contents let fileLines = lines contents
let lineCount = length fileLines
let comments = shpellCheck contents let comments = shpellCheck contents
let groups = groupWith shpellLine comments let groups = groupWith shpellLine comments
if not $ null comments then do if not $ null comments then do
mapM_ (\x -> do mapM_ (\x -> do
let line = fileLines !! (shpellLine (head x) - 1) let lineNum = shpellLine (head x)
let line = if lineNum < 1 || lineNum >= lineCount
then ""
else fileLines !! (lineNum - 1)
putStrLn "" putStrLn ""
putStrLn $ colorFunc "message" ("In " ++ filename ++" line " ++ (show $ shpellLine (head x)) ++ ":") putStrLn $ colorFunc "message" ("In " ++ filename ++" line " ++ (show $ lineNum) ++ ":")
putStrLn (colorFunc "source" line) putStrLn (colorFunc "source" line)
mapM (\c -> putStrLn (colorFunc (shpellSeverity c) $ cuteIndent c)) x mapM (\c -> putStrLn (colorFunc (shpellSeverity c) $ cuteIndent c)) x
putStrLn "" putStrLn ""