-- 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

-- | Generic parsing utils.
module Util.Parse where
import qualified Control.Monad.Identity as Identity
import qualified Control.Monad.State.Strict as State
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified Data.Void as Void

import qualified Numeric
import qualified Text.Megaparsec as P
import           Text.Megaparsec ((<?>))
import qualified Text.Megaparsec.Char as P

import qualified Util.Exceptions as Exceptions

import           Global

-- * parsec

type Parser a = ParserT Identity.Identity a
type ParserT m a = P.ParsecT Void.Void Text m a
type ParserS s a = ParserT (State.StateT s Identity.Identity) a

parse :: Parser a -> Text -> Either Text a
parse :: forall a. Parser a -> Text -> Either Text a
parse Parser a
p = Identity (Either Text a) -> Either Text a
forall a. Identity a -> a
Identity.runIdentity (Identity (Either Text a) -> Either Text a)
-> (Text -> Identity (Either Text a)) -> Text -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Parser a -> Text -> Identity (Either Text a)
forall (m :: * -> *) a.
Monad m =>
FilePath -> ParserT m a -> Text -> m (Either Text a)
parseM FilePath
"" Parser a
p

parseM :: Monad m => FilePath -> ParserT m a -> Text -> m (Either Text a)
parseM :: forall (m :: * -> *) a.
Monad m =>
FilePath -> ParserT m a -> Text -> m (Either Text a)
parseM FilePath
fname ParserT m a
p =
    (Either (ParseErrorBundle Text Void) a -> Either Text a)
-> m (Either (ParseErrorBundle Text Void) a) -> m (Either Text a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ParseErrorBundle Text Void -> Text)
-> Either (ParseErrorBundle Text Void) a -> Either Text a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (FilePath -> Text
txt (FilePath -> Text)
-> (ParseErrorBundle Text Void -> FilePath)
-> ParseErrorBundle Text Void
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> FilePath
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> FilePath
P.errorBundlePretty)) (m (Either (ParseErrorBundle Text Void) a) -> m (Either Text a))
-> (Text -> m (Either (ParseErrorBundle Text Void) a))
-> Text
-> m (Either Text a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserT m a
-> FilePath -> Text -> m (Either (ParseErrorBundle Text Void) a)
forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> FilePath -> s -> m (Either (ParseErrorBundle s e) a)
P.runParserT (ParserT m a
p ParserT m a -> ParsecT Void Text m () -> ParserT m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof) FilePath
fname

parseS :: state -> FilePath -> ParserS state a -> Text -> Either Text a
parseS :: forall state a.
state -> FilePath -> ParserS state a -> Text -> Either Text a
parseS state
state FilePath
fname ParserS state a
p = (Either Text a, state) -> Either Text a
forall a b. (a, b) -> a
fst ((Either Text a, state) -> Either Text a)
-> (Text -> (Either Text a, state)) -> Text -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State state (Either Text a) -> state -> (Either Text a, state))
-> state -> State state (Either Text a) -> (Either Text a, state)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State state (Either Text a) -> state -> (Either Text a, state)
forall s a. State s a -> s -> (a, s)
State.runState state
state (State state (Either Text a) -> (Either Text a, state))
-> (Text -> State state (Either Text a))
-> Text
-> (Either Text a, state)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ParserS state a -> Text -> State state (Either Text a)
forall (m :: * -> *) a.
Monad m =>
FilePath -> ParserT m a -> Text -> m (Either Text a)
parseM FilePath
fname ParserS state a
p

parse_maybe :: Parser a -> Text -> Maybe a
parse_maybe :: forall a. Parser a -> Text -> Maybe a
parse_maybe Parser a
p = (Text -> Maybe a) -> (a -> Maybe a) -> Either Text a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> 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 (Either Text a -> Maybe a)
-> (Text -> Either Text a) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> Text -> Either Text a
forall a. Parser a -> Text -> Either Text a
parse Parser a
p

-- | Try to parse a file, or return a default value if the file doesn't exist.
file :: a -> ParserS st a -> st -> FilePath -> IO (Either Text a)
file :: forall a st.
a -> ParserS st a -> st -> FilePath -> IO (Either Text a)
file a
deflt ParserS st a
parser st
state FilePath
fname = do
    Maybe Text
mb_text <- IO Text -> IO (Maybe Text)
forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent (FilePath -> IO Text
Text.IO.readFile FilePath
fname)
    Either Text a -> IO (Either Text a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text a -> IO (Either Text a))
-> Either Text a -> IO (Either Text a)
forall a b. (a -> b) -> a -> b
$ Either Text a
-> (Text -> Either Text a) -> Maybe Text -> Either Text a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> Either Text a
forall a b. b -> Either a b
Right a
deflt) (st -> FilePath -> ParserS st a -> Text -> Either Text a
forall state a.
state -> FilePath -> ParserS state a -> Text -> Either Text a
parseS st
state FilePath
fname ParserS st a
parser) Maybe Text
mb_text

-- -- | Format a ParseError assuming the input is just one line.
-- format1 :: Text -> P.ParseError -> Text
-- format1 input err
--     | line == 1 = "col " <> showt col <> ": " <> msg
--     | otherwise = showt line <> ":" <> showt col <> ": " <> msg
--     where
--     msg = Text.intercalate "; " (show_error err) <> ": " <> showt input
--     pos = P.errorPos err
--     (line, col) = (P.sourceLine pos, P.sourceColumn pos)
--
-- show_error :: P.ParseError -> [Text]
-- show_error = filter (not . Text.null) . Text.lines . txt
--     . Error.showErrorMessages "or" "unknown parse error"
--         "expecting" "unexpected" "end of input"
--     . Error.errorMessages

p_int :: ParserT m Int
p_int :: forall (m :: * -> *). ParserT m Int
p_int = do
    Int
sign <- Int -> ParsecT Void Text m Int -> ParsecT Void Text m Int
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option Int
1 (Token Text -> ParsecT Void Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'-' ParsecT Void Text m (Token Text)
-> ParsecT Void Text m Int -> ParsecT Void Text m Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ParsecT Void Text m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (-Int
1))
    (Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
sign) (Int -> Int) -> ParsecT Void Text m Int -> ParsecT Void Text m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text m Int
forall (m :: * -> *). ParserT m Int
p_nat
    ParsecT Void Text m Int -> FilePath -> ParsecT Void Text m Int
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> FilePath -> m a
<?> FilePath
"int"

-- | Natural number including 0.
p_nat :: ParserT m Int
p_nat :: forall (m :: * -> *). ParserT m Int
p_nat = do
    Text
i <- Maybe FilePath
-> (Token Text -> Bool) -> ParsecT Void Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
P.takeWhile1P Maybe FilePath
forall a. Maybe a
Nothing Char -> Bool
Token Text -> Bool
is_digit
    case ReadS Int
forall a. (Eq a, Num a) => ReadS a
Numeric.readDec (Text -> FilePath
untxt Text
i) of
        (Int
n, FilePath
_) : [(Int, FilePath)]
_ -> Int -> ParsecT Void Text m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
        [(Int, FilePath)]
_ -> ParsecT Void Text m Int
forall (m :: * -> *) a. MonadPlus m => m a
mzero -- this should never happen
    ParsecT Void Text m Int -> FilePath -> ParsecT Void Text m Int
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> FilePath -> m a
<?> FilePath
"nat"

-- | Natural number without 0.
p_positive :: ParserT m Int
p_positive :: forall (m :: * -> *). ParserT m Int
p_positive = do
    Int
n <- ParserT m Int
forall (m :: * -> *). ParserT m Int
p_nat
    if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then ParserT m Int
forall (m :: * -> *) a. MonadPlus m => m a
mzero else Int -> ParserT m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n

p_float :: ParserT m Double
p_float :: forall (m :: * -> *). ParserT m Double
p_float = do
    Double
sign <- Double -> ParsecT Void Text m Double -> ParsecT Void Text m Double
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option Double
1 (Token Text -> ParsecT Void Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'-' ParsecT Void Text m (Token Text)
-> ParsecT Void Text m Double -> ParsecT Void Text m Double
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Double -> ParsecT Void Text m Double
forall (m :: * -> *) a. Monad m => a -> m a
return (-Double
1))
    Double
val <- ParsecT Void Text m Double
forall (m :: * -> *). ParserT m Double
p_unsigned_float
    Double -> ParsecT Void Text m Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
val Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
sign)
    ParsecT Void Text m Double
-> FilePath -> ParsecT Void Text m Double
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> FilePath -> m a
<?> FilePath
"float"

p_unsigned_float :: ParserT m Double
p_unsigned_float :: forall (m :: * -> *). ParserT m Double
p_unsigned_float = do
    Text
i <- Maybe FilePath
-> (Token Text -> Bool) -> ParsecT Void Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
P.takeWhileP Maybe FilePath
forall a. Maybe a
Nothing Char -> Bool
Token Text -> Bool
is_digit
    Text
f <- Text -> ParsecT Void Text m Text -> ParsecT Void Text m Text
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option Text
"" (Token Text -> ParsecT Void Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'.' ParsecT Void Text m (Token Text)
-> ParsecT Void Text m Text -> ParsecT Void Text m Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe FilePath
-> (Token Text -> Bool) -> ParsecT Void Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
P.takeWhile1P Maybe FilePath
forall a. Maybe a
Nothing Char -> Bool
Token Text -> Bool
is_digit)
    if Text -> Bool
Text.null Text
i Bool -> Bool -> Bool
&& Text -> Bool
Text.null Text
f then ParserT m 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 -> ParserT m Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> ParserT m Double) -> Double -> ParserT m 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)
_ -> ParserT m Double
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    ParserT m Double -> FilePath -> ParserT m Double
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> FilePath -> m a
<?> FilePath
"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 ReadS Int
forall a. (Eq a, Num a) => ReadS a
Numeric.readDec (Text -> FilePath
untxt Text
s) of
            (Int
d, FilePath
"") : [(Int, FilePath)]
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
d
            [(Int, FilePath)]
_ -> Maybe Int
forall a. Maybe a
Nothing

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