-- 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 = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text, Text) -> Text
fmt forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Text -> Either (Text, Text) a
parse_all Parser a
p Text
text
    where
    fmt :: (Text, Text) -> Text
fmt (Text
rest, Text
msg) = Text
"parse error: " forall a. Semigroup a => a -> a -> a
<> Maybe Int -> Text -> Text
error_context Maybe Int
col Text
text forall a. Semigroup a => a -> a -> a
<> 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 forall a. Parser a -> Text -> Either (Text, Text) a
parse_all Parser a
p Text
text of
    Right a
val -> forall a b. b -> Either a b
Right a
val
    Left (Text
rest, Text
msg) -> forall a b. a -> Either a b
Left 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 {
    -- | Line with the error, and 1-based row and column.
    Error -> Maybe (Text, (Int, Int))
_position :: Maybe (Text, (Row, Column))
    , Error -> Text
_message :: Text
    } deriving (Error -> Error -> Bool
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
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 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 = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (\(Int
r, Int
c) -> (Int
rforall a. Num a => a -> a -> a
+Int
row, Int
cforall a. Num a => a -> a -> a
+Int
col)) 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 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) = forall a. Monoid a => [a] -> a
mconcat
    [ forall a. Show a => a -> Text
showt Int
row, Text
":", forall a. Show a => a -> Text
showt Int
column, Text
": ", Text
msg, Text
" in line "
    , Maybe Int -> Text -> Text
error_context (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
"\"" forall a. Semigroup a => a -> a -> a
<> Text
expr forall a. Semigroup a => a -> a -> a
<> Text
"\""
error_context (Just Int
i) Text
expr = Text
"\"" forall a. Semigroup a => a -> a -> a
<> Text
pre forall a. Semigroup a => a -> a -> a
<> Text
char forall a. Semigroup a => a -> a -> a
<> Text
post 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)
    -- This just has to look distinctively not like ascii and stick out a bit.
    char :: Text
char = Text
"⎣"

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 = forall {b}. IResult Text b -> Either (Text, Text) b
go (forall a. Parser a -> Text -> Result a
A.parse Parser a
p Text
text)
    where
    -- The msg can be really unclear, like "string", so put quotes on to
    -- at least tell it's trying to be an error.
    go :: IResult Text b -> Either (Text, Text) b
go (A.Fail Text
rest [String]
contexts String
msg) = forall a b. a -> Either a b
Left (Text
rest, Text
"'" forall a. Semigroup a => a -> a -> a
<> String -> Text
txt String
msg forall a. Semigroup a => a -> a -> a
<> Text
"'" forall a. Semigroup a => a -> a -> a
<> Text
c)
        where
        c :: Text
c = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
contexts then Text
""
            else Text
" [" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map String -> Text
txt [String]
contexts) 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 = forall a b. b -> Either a b
Right b
val
        | Bool
otherwise = 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 = forall {a}. (Num a, Enum a) => Int -> Maybe (Text, (a, Int))
infer 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 = forall {b} {b} {a} {a}. Num b => b -> (b, b, (a, a)) -> (a, (a, b))
extract Int
i forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\(Int
_, Int
end, (a, Text)
_) -> Int
end forall a. Ord a => a -> a -> Bool
> Int
i)
        (forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int]
sums (forall a. Int -> [a] -> [a]
drop Int
1 [Int]
sums) (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 forall a. Num a => a -> a -> a
- b
start forall a. Num a => a -> a -> a
+ b
1))
    sums :: [Int]
sums = forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) Int
0 (forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Num a => a -> a -> a
+Int
1) 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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Int
Text.length Text
text forall a. Num a => a -> a -> a
- Text -> Int
Text.length Text
rest
    | Bool
otherwise = 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just (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 = forall a. Parser a -> Text -> Maybe a
maybe_parse Parser a
parser forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
txt

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

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

nat :: Text -> Maybe Int
nat :: Text -> Maybe Int
nat = 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 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p 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 = forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just 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 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
A.skipSpace

p_float :: Parser Double
p_float :: Parser Double
p_float = do
    Double
sign <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Double
1 (Char -> Parser Char
A.char Char
'-' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (-Double
1))
    Double
val <- Parser Double
p_unsigned_float
    forall (m :: * -> *) a. Monad m => a -> m a
return (Double
val forall a. Num a => a -> a -> a
* Double
sign)
    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 <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Text
"" (Char -> Parser Char
A.char Char
'.' 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 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') -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i'
            forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
f' forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
10 forall a b. (Num a, Integral b) => a -> b -> a
^ Text -> Int
Text.length Text
f)
        (Maybe Int, Maybe Int)
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
    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 = forall a. a -> Maybe a
Just Int
0
        | Bool
otherwise = case forall a. Integral a => Reader a
Text.Read.decimal Text
s of
            Right (Int
d, Text
rest) | Text -> Bool
Text.null Text
rest -> forall a. a -> Maybe a
Just Int
d
            Either String (Int, Text)
_ -> forall a. Maybe a
Nothing

p_int :: Parser Int
p_int :: Parser Int
p_int = do
    Char
sign <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Char
'+' ((Char -> Bool) -> Parser Char
A.satisfy (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
'+' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'-'))
    Int
val <- Parser Int
p_nat
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (if Char
sign forall a. Eq a => a -> a -> Bool
== Char
'-' then -Int
1 else Int
1) 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 forall a. Integral a => Reader a
Text.Read.decimal Text
i of
        Right (Int
d, Text
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
d
        Left String
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero

is_digit :: Char -> Bool
is_digit :: Char -> Bool
is_digit Char
c = Char
c forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c 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 (forall a. Eq a => a -> a -> Bool
/= Char
' ')