-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NondecreasingIndentation #-}
{- | Parsing utilities for Text, using Attoparsec.

    This module also exports some basic combinators.  The idea is that modules
    that want to do a bit of parsing should be able to import this and need not
    import the underlying parsing library, which should make it easier to
    switch parsing libraries in the future if I want to.  Of course the parsers
    may return a different type (ByteString vs. Text) so callers will still
    need a little modification to switch libraries.
-}
module Util.ParseText (module Util.ParseText, many) where
import Control.Applicative (many)
import qualified Data.Attoparsec.Text as A
import Data.Attoparsec.Text ((<?>))
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Read as Text.Read

import Global


type Parser a = A.Parser a

-- | Parse all the text, and annotate the error with the char number.  For
-- single-line input.
parse1 :: Parser a -> Text -> Either Text a
parse1 :: forall a. Parser a -> Text -> Either Text a
parse1 Parser a
p Text
text = case Parser a -> Text -> Either (Text, Text) a
forall a. Parser a -> Text -> Either (Text, Text) a
parse_all Parser a
p Text
text of
    Right a
val -> a -> Either Text a
forall a b. b -> Either a b
Right a
val
    Left (Text
rest, Text
msg) -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$
        Text
"parse error: char " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Int -> Text) -> Maybe Int -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"?" Int -> Text
forall a. Show a => a -> Text
showt Maybe Int
col Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" of "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Int -> Text -> Text
error_context Maybe Int
col Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
        where col :: Maybe Int
col = Text -> Text -> Maybe Int
infer_column Text
text Text
rest

-- | Parse all of the text, and annotate the error with line number and column.
parse :: Parser a -> Text -> Either Error a
parse :: forall a. Parser a -> Text -> Either Error a
parse Parser a
p Text
text = case Parser a -> Text -> Either (Text, Text) a
forall a. Parser a -> Text -> Either (Text, Text) a
parse_all Parser a
p Text
text of
    Right a
val -> a -> Either Error a
forall a b. b -> Either a b
Right a
val
    Left (Text
rest, Text
msg) -> Error -> Either Error a
forall a b. a -> Either a b
Left (Error -> Either Error a) -> Error -> Either Error a
forall a b. (a -> b) -> a -> b
$ Maybe (Text, (Int, Int)) -> Text -> Error
Error Maybe (Text, (Int, Int))
loc Text
msg
        where loc :: Maybe (Text, (Int, Int))
loc = Text -> Text -> Maybe (Text, (Int, Int))
infer_location Text
text Text
rest

data Error = Error {
    Error -> Maybe (Text, (Int, Int))
_position :: Maybe (Text, (Row, Column))
    , Error -> Text
_message ::Text
    } deriving (Error -> Error -> Bool
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: Error -> Error -> Bool
Eq, Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)
type Row = Int
type Column = Int

prefix :: Text -> Error -> Error
prefix :: Text -> Error -> Error
prefix Text
pref Error
err = Error
err { _message :: Text
_message = Text
pref Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Error -> Text
_message Error
err }

offset :: (Row, Column) -> Error -> Error
offset :: (Int, Int) -> Error -> Error
offset (Int
row, Int
col) Error
err =
    Error
err { _position :: Maybe (Text, (Int, Int))
_position = ((Int, Int) -> (Int, Int))
-> (Text, (Int, Int)) -> (Text, (Int, Int))
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (\(Int
r, Int
c) -> (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
row, Int
cInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
col)) ((Text, (Int, Int)) -> (Text, (Int, Int)))
-> Maybe (Text, (Int, Int)) -> Maybe (Text, (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Error -> Maybe (Text, (Int, Int))
_position Error
err }

message :: Text -> Error
message :: Text -> Error
message = Maybe (Text, (Int, Int)) -> Text -> Error
Error Maybe (Text, (Int, Int))
forall a. Maybe a
Nothing

show_error :: Error -> Text
show_error :: Error -> Text
show_error (Error Maybe (Text, (Int, Int))
Nothing Text
msg) = Text
msg
show_error (Error (Just (Text
line, (Int
row, Int
column))) Text
msg) = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
    [ Int -> Text
forall a. Show a => a -> Text
showt Int
row, Text
":", Int -> Text
forall a. Show a => a -> Text
showt Int
column, Text
": ", Text
msg, Text
" in line "
    , Maybe Int -> Text -> Text
error_context (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
column) Text
line
    ]

error_context :: Maybe Int -> Text -> Text
error_context :: Maybe Int -> Text -> Text
error_context Maybe Int
Nothing Text
expr = Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
expr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
error_context (Just Int
i) Text
expr = Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pre Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"»" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
post Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
    where (Text
pre, Text
post) = (Int -> Text -> Text
Text.take Int
i Text
expr, Int -> Text -> Text
Text.drop Int
i Text
expr)

parse_all :: A.Parser a -> Text -> Either (Text, Text) a
parse_all :: forall a. Parser a -> Text -> Either (Text, Text) a
parse_all Parser a
p Text
text = IResult Text a -> Either (Text, Text) a
forall {b}. IResult Text b -> Either (Text, Text) b
go (Parser a -> Text -> IResult Text a
forall a. Parser a -> Text -> Result a
A.parse Parser a
p Text
text)
    where
    go :: IResult Text b -> Either (Text, Text) b
go (A.Fail Text
rest [String]
contexts String
msg) = (Text, Text) -> Either (Text, Text) b
forall a b. a -> Either a b
Left (Text
rest, String -> Text
txt String
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c)
        where
        c :: Text
c = if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
contexts then Text
""
            else Text
" [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
txt [String]
contexts) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
    go (A.Partial Text -> IResult Text b
cont) = IResult Text b -> Either (Text, Text) b
go (Text -> IResult Text b
cont Text
"")
    go (A.Done Text
rest b
val)
        | Text -> Bool
Text.null Text
rest = b -> Either (Text, Text) b
forall a b. b -> Either a b
Right b
val
        | Bool
otherwise = (Text, Text) -> Either (Text, Text) b
forall a b. a -> Either a b
Left (Text
rest, Text
"expected eof")

infer_location :: Text -> Text -> Maybe (Text, (Int, Int))
    -- ^ (line, row from 1, column from 1)
infer_location :: Text -> Text -> Maybe (Text, (Int, Int))
infer_location Text
text Text
rest = Int -> Maybe (Text, (Int, Int))
forall {a}. (Num a, Enum a) => Int -> Maybe (Text, (a, Int))
infer (Int -> Maybe (Text, (Int, Int)))
-> Maybe Int -> Maybe (Text, (Int, Int))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Text -> Maybe Int
infer_column Text
text Text
rest
    where
    infer :: Int -> Maybe (Text, (a, Int))
infer Int
i = Int -> (Int, Int, (a, Text)) -> (Text, (a, Int))
forall {b} {b} {a} {a}. Num b => b -> (b, b, (a, a)) -> (a, (a, b))
extract Int
i ((Int, Int, (a, Text)) -> (Text, (a, Int)))
-> Maybe (Int, Int, (a, Text)) -> Maybe (Text, (a, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int, Int, (a, Text)) -> Bool)
-> [(Int, Int, (a, Text))] -> Maybe (Int, Int, (a, Text))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\(Int
_, Int
end, (a, Text)
_) -> Int
end Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
i)
        ([Int] -> [Int] -> [(a, Text)] -> [(Int, Int, (a, Text))]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int]
sums (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1 [Int]
sums) ([a] -> [Text] -> [(a, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a
1..] [Text]
lines))
    extract :: b -> (b, b, (a, a)) -> (a, (a, b))
extract b
i (b
start, b
_, (a
row, a
line)) = (a
line, (a
row, b
i b -> b -> b
forall a. Num a => a -> a -> a
- b
start))
    sums :: [Int]
sums = (Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0 ((Text -> Int) -> [Text] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Int) -> (Text -> Int) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
Text.length) [Text]
lines)
    lines :: [Text]
lines = Text -> [Text]
Text.lines Text
text

infer_column :: Text -> Text -> Maybe Int
infer_column :: Text -> Text -> Maybe Int
infer_column Text
text Text
rest
    | Text
rest Text -> Text -> Bool
`Text.isSuffixOf` Text
text =
        Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> Int
Text.length Text
text Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
Text.length Text
rest Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing

-- * casual parsing

maybe_parse :: Parser a -> Text -> Maybe a
maybe_parse :: forall a. Parser a -> Text -> Maybe a
maybe_parse Parser a
parser Text
text = ((Text, Text) -> Maybe a)
-> (a -> Maybe a) -> Either (Text, Text) a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> (Text, Text) -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just (Parser a -> Text -> Either (Text, Text) a
forall a. Parser a -> Text -> Either (Text, Text) a
parse_all Parser a
parser Text
text)

maybe_parse_string :: Parser a -> String -> Maybe a
maybe_parse_string :: forall a. Parser a -> String -> Maybe a
maybe_parse_string Parser a
parser = Parser a -> Text -> Maybe a
forall a. Parser a -> Text -> Maybe a
maybe_parse Parser a
parser (Text -> Maybe a) -> (String -> Text) -> String -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
txt

float :: Text -> Maybe Double
float :: Text -> Maybe Double
float = Parser Double -> Text -> Maybe Double
forall a. Parser a -> Text -> Maybe a
maybe_parse Parser Double
p_float

int :: Text -> Maybe Int
int :: Text -> Maybe Int
int = Parser Int -> Text -> Maybe Int
forall a. Parser a -> Text -> Maybe a
maybe_parse Parser Int
p_int

nat :: Text -> Maybe Int
nat :: Text -> Maybe Int
nat = Parser Int -> Text -> Maybe Int
forall a. Parser a -> Text -> Maybe a
maybe_parse Parser Int
p_nat

-- * combinators

between :: Parser x -> Parser y -> Parser a -> Parser a
between :: forall x y a. Parser x -> Parser y -> Parser a -> Parser a
between Parser x
open Parser y
close Parser a
p = Parser x
open Parser x -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p Parser a -> Parser y -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser y
close

optional :: Parser a -> Parser (Maybe a)
optional :: forall a. Parser a -> Parser (Maybe a)
optional Parser a
p = Maybe a -> Parser Text (Maybe a) -> Parser Text (Maybe a)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Maybe a
forall a. Maybe a
Nothing (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Parser a -> Parser Text (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
p)

-- * parsers

-- | Convert a parser into a lexeme parser by skipping whitespace afterwards.
lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme Parser a
p = Parser a
p Parser a -> Parser Text () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
A.skipSpace

p_float :: Parser Double
p_float :: Parser Double
p_float = do
    Double
sign <- Double -> Parser Double -> Parser Double
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Double
1 (Char -> Parser Char
A.char Char
'-' Parser Char -> Parser Double -> Parser Double
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Double -> Parser Double
forall (m :: * -> *) a. Monad m => a -> m a
return (-Double
1))
    Double
val <- Parser Double
p_unsigned_float
    Double -> Parser Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
val Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
sign)
    Parser Double -> String -> Parser Double
forall i a. Parser i a -> String -> Parser i a
<?> String
"float"

p_unsigned_float :: Parser Double
p_unsigned_float :: Parser Double
p_unsigned_float = do
    Text
i <- (Char -> Bool) -> Parser Text
A.takeWhile Char -> Bool
is_digit
    Text
f <- Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Text
"" (Char -> Parser Char
A.char Char
'.' Parser Char -> Parser Text -> Parser Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Parser Text
A.takeWhile1 Char -> Bool
is_digit)
    if Text -> Bool
Text.null Text
i Bool -> Bool -> Bool
&& Text -> Bool
Text.null Text
f then Parser Double
forall (m :: * -> *) a. MonadPlus m => m a
mzero else do
    case (Text -> Maybe Int
dec Text
i, Text -> Maybe Int
dec Text
f) of
        (Just Int
i', Just Int
f') -> Double -> Parser Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Parser Double) -> Double -> Parser Double
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i'
            Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
f' Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
10 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Text -> Int
Text.length Text
f)
        (Maybe Int, Maybe Int)
_ -> Parser Double
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    Parser Double -> String -> Parser Double
forall i a. Parser i a -> String -> Parser i a
<?> String
"unsigned float"
    where
    dec :: Text -> Maybe Int
    dec :: Text -> Maybe Int
dec Text
s
        | Text -> Bool
Text.null Text
s = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
        | Bool
otherwise = case Reader Int
forall a. Integral a => Reader a
Text.Read.decimal Text
s of
            Right (Int
d, Text
rest) | Text -> Bool
Text.null Text
rest -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
d
            Either String (Int, Text)
_ -> Maybe Int
forall a. Maybe a
Nothing

p_int :: Parser Int
p_int :: Parser Int
p_int = do
    Char
sign <- Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Char
'+' ((Char -> Bool) -> Parser Char
A.satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'))
    Int
val <- Parser Int
p_nat
    Int -> Parser Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Parser Int) -> Int -> Parser Int
forall a b. (a -> b) -> a -> b
$ (if Char
sign Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' then -Int
1 else Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
val

p_nat :: Parser Int
p_nat :: Parser Int
p_nat = do
    Text
i <- (Char -> Bool) -> Parser Text
A.takeWhile1 Char -> Bool
is_digit
    case Reader Int
forall a. Integral a => Reader a
Text.Read.decimal Text
i of
        Right (Int
d, Text
_) -> Int -> Parser Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
d
        Left String
_ -> Parser Int
forall (m :: * -> *) a. MonadPlus m => m a
mzero

is_digit :: Char -> Bool
is_digit :: Char -> Bool
is_digit Char
c = Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9'

-- | A word of non-space chars.
p_word :: Parser Text
p_word :: Parser Text
p_word = (Char -> Bool) -> Parser Text
A.takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ')