Helpful.hs

{-# LANGUAGE OverloadedStrings #-}
-- |

module Data.Attoparsec.Text.Helpful
    (parseHelpfully)
    where

import           Data.Attoparsec.Text (Parser)
import qualified Data.Attoparsec.Text as P
import           Data.List
import           Data.Maybe
import           Data.Text (Text)
import qualified Data.Text as T
import           Prelude hiding (head)

-- | Parse and generate a helpful parse error.
parseHelpfully :: FilePath -> Text -> (Parser a) -> Either String a
parseHelpfully fp text parser =
    case P.parse parser text of
        P.Fail remaining ctx msg ->
            Left
                (intercalate
                     "\n"
                     [ loc
                     , "  Parse error: "
                     , "    " ++ msg
                     , if null ctx
                           then "  No context available."
                           else "  While parsing " ++
                                intercalate
                                    "\n    of "
                                    (reverse
                                         (map
                                              (\c ->
                                                    c)
                                              ctx)) ++
                                "."
                     , "  On this line: "
                     , "    " ++ T.unpack curline])
            where loc = fp ++ ":" ++ show line ++ ":" ++ show col ++ ": "
                  (line,col,curline) = calculatePosition text remaining
        P.Partial _ -> Left "unexpected end of input"
        P.Done _ r -> Right r
  where
    calculatePosition :: Text -> Text -> (Int,Int,Text)
    calculatePosition original remaining =
        (line,col,curLine)
      where charPos = T.length original - T.length remaining
            sofar = T.take charPos original
            lines' = T.split isNewline sofar
            line = length lines'
            curLine = fromMaybe "" (listToMaybe (drop (length lines' - 2) lines'))
            beforeLines = take (length lines' - 1) lines'
            col = charPos - (sum (map T.length beforeLines))

isNewline :: Char -> Bool
isNewline c = (c == '\r' || c == '\n')