{-# LANGUAGE RankNTypes #-}

module System.Directory.Watchman.BSER.Parser
    ( FromBSER(..)
    , Parser
    , Result(..)
    , parse
    , (.:)
    ) where

import Data.Foldable (toList)
import Control.Applicative
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.Map.Strict as M
import Data.Sequence (Seq)

import System.Directory.Watchman.BSER

data Result a
    = Error String
    | Success a
    deriving (Int -> Result a -> ShowS
[Result a] -> ShowS
Result a -> String
(Int -> Result a -> ShowS)
-> (Result a -> String) -> ([Result a] -> ShowS) -> Show (Result a)
forall a. Show a => Int -> Result a -> ShowS
forall a. Show a => [Result a] -> ShowS
forall a. Show a => Result a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result a] -> ShowS
$cshowList :: forall a. Show a => [Result a] -> ShowS
show :: Result a -> String
$cshow :: forall a. Show a => Result a -> String
showsPrec :: Int -> Result a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Result a -> ShowS
Show, Result a -> Result a -> Bool
(Result a -> Result a -> Bool)
-> (Result a -> Result a -> Bool) -> Eq (Result a)
forall a. Eq a => Result a -> Result a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result a -> Result a -> Bool
$c/= :: forall a. Eq a => Result a -> Result a -> Bool
== :: Result a -> Result a -> Bool
$c== :: forall a. Eq a => Result a -> Result a -> Bool
Eq)

type Failure r = String -> Result r
type Success a r = a -> Result r

newtype Parser a = Parser
    { Parser a -> forall r. Failure r -> Success a r -> Result r
runParser :: forall r. Failure r -> Success a r -> Result r
    }

instance Monad Parser where
    Parser a
m >>= :: Parser a -> (a -> Parser b) -> Parser b
>>= a -> Parser b
g = (forall r. Failure r -> Success b r -> Result r) -> Parser b
forall a.
(forall r. Failure r -> Success a r -> Result r) -> Parser a
Parser ((forall r. Failure r -> Success b r -> Result r) -> Parser b)
-> (forall r. Failure r -> Success b r -> Result r) -> Parser b
forall a b. (a -> b) -> a -> b
$ \Failure r
kf Success b r
ks -> let ks' :: a -> Result r
ks' a
a = Parser b -> Failure r -> Success b r -> Result r
forall a.
Parser a -> forall r. Failure r -> Success a r -> Result r
runParser (a -> Parser b
g a
a) Failure r
kf Success b r
ks
                                 in Parser a -> Failure r -> (a -> Result r) -> Result r
forall a.
Parser a -> forall r. Failure r -> Success a r -> Result r
runParser Parser a
m Failure r
kf a -> Result r
ks'
    {-# INLINE (>>=) #-}
    return :: a -> Parser a
return a
a = (forall r. Failure r -> Success a r -> Result r) -> Parser a
forall a.
(forall r. Failure r -> Success a r -> Result r) -> Parser a
Parser ((forall r. Failure r -> Success a r -> Result r) -> Parser a)
-> (forall r. Failure r -> Success a r -> Result r) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Failure r
_kf Success a r
ks -> Success a r
ks a
a
    {-# INLINE return #-}

instance MonadFail Parser where
    fail :: String -> Parser a
fail String
msg = (forall r. Failure r -> Success a r -> Result r) -> Parser a
forall a.
(forall r. Failure r -> Success a r -> Result r) -> Parser a
Parser ((forall r. Failure r -> Success a r -> Result r) -> Parser a)
-> (forall r. Failure r -> Success a r -> Result r) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Failure r
kf Success a r
_ks -> Failure r
kf String
msg
    {-# INLINE fail #-}

instance Functor Parser where
    fmap :: (a -> b) -> Parser a -> Parser b
fmap a -> b
f Parser a
m = (forall r. Failure r -> Success b r -> Result r) -> Parser b
forall a.
(forall r. Failure r -> Success a r -> Result r) -> Parser a
Parser ((forall r. Failure r -> Success b r -> Result r) -> Parser b)
-> (forall r. Failure r -> Success b r -> Result r) -> Parser b
forall a b. (a -> b) -> a -> b
$ \Failure r
kf Success b r
ks -> let ks' :: a -> Result r
ks' a
a = Success b r
ks (a -> b
f a
a)
                                  in Parser a -> Failure r -> (a -> Result r) -> Result r
forall a.
Parser a -> forall r. Failure r -> Success a r -> Result r
runParser Parser a
m Failure r
kf a -> Result r
ks'
    {-# INLINE fmap #-}

instance Applicative Parser where
    pure :: a -> Parser a
pure  = a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return
    {-# INLINE pure #-}
    <*> :: Parser (a -> b) -> Parser a -> Parser b
(<*>) = Parser (a -> b) -> Parser a -> Parser b
forall a b. Parser (a -> b) -> Parser a -> Parser b
apP
    {-# INLINE (<*>) #-}

instance Alternative Parser where
    empty :: Parser a
empty = String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty"
    {-# INLINE empty #-}
    <|> :: Parser a -> Parser a -> Parser a
(<|>) = Parser a -> Parser a -> Parser a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
    {-# INLINE (<|>) #-}

instance MonadPlus Parser where
    mzero :: Parser a
mzero = String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mzero"
    {-# INLINE mzero #-}
    mplus :: Parser a -> Parser a -> Parser a
mplus Parser a
a Parser a
b = (forall r. Failure r -> Success a r -> Result r) -> Parser a
forall a.
(forall r. Failure r -> Success a r -> Result r) -> Parser a
Parser ((forall r. Failure r -> Success a r -> Result r) -> Parser a)
-> (forall r. Failure r -> Success a r -> Result r) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Failure r
kf Success a r
ks -> let kf' :: p -> Result r
kf' p
_ = Parser a -> Failure r -> Success a r -> Result r
forall a.
Parser a -> forall r. Failure r -> Success a r -> Result r
runParser Parser a
b Failure r
kf Success a r
ks
                                   in Parser a -> Failure r -> Success a r -> Result r
forall a.
Parser a -> forall r. Failure r -> Success a r -> Result r
runParser Parser a
a Failure r
forall p. p -> Result r
kf' Success a r
ks
    {-# INLINE mplus #-}

instance Semigroup  (Parser a) where
    <> :: Parser a -> Parser a -> Parser a
(<>) = Parser a -> Parser a -> Parser a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance Monoid (Parser a) where
    mempty :: Parser a
mempty  = String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mempty"
    {-# INLINE mempty #-}
    mappend :: Parser a -> Parser a -> Parser a
mappend = Parser a -> Parser a -> Parser a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
    {-# INLINE mappend #-}

apP :: Parser (a -> b) -> Parser a -> Parser b
apP :: Parser (a -> b) -> Parser a -> Parser b
apP Parser (a -> b)
d Parser a
e = do
  a -> b
b <- Parser (a -> b)
d
  a
a <- Parser a
e
  b -> Parser b
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
b a
a)


class FromBSER a where
    parseBSER :: BSERValue -> Parser a

instance FromBSER BSERValue where
    parseBSER :: BSERValue -> Parser BSERValue
parseBSER BSERValue
x = BSERValue -> Parser BSERValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure BSERValue
x

instance FromBSER ByteString where
    parseBSER :: BSERValue -> Parser ByteString
parseBSER (BSERString ByteString
s) = ByteString -> Parser ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
s
    parseBSER BSERValue
_ = String -> Parser ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not a string"

instance FromBSER Bool where
    parseBSER :: BSERValue -> Parser Bool
parseBSER (BSERBool Bool
b) = Bool -> Parser Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b
    parseBSER BSERValue
_ = String -> Parser Bool
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not a boolean"

instance FromBSER a => FromBSER [a] where
    parseBSER :: BSERValue -> Parser [a]
parseBSER (BSERArray Seq BSERValue
a) = do
        Seq a
elems <- (BSERValue -> Parser a) -> Seq BSERValue -> Parser (Seq a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BSERValue -> Parser a
forall a. FromBSER a => BSERValue -> Parser a
parseBSER Seq BSERValue
a
        [a] -> Parser [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq a
elems)
    parseBSER BSERValue
_ = String -> Parser [a]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not an array"

instance FromBSER a => FromBSER (Seq a) where
    parseBSER :: BSERValue -> Parser (Seq a)
parseBSER (BSERArray Seq BSERValue
a) = do
        (BSERValue -> Parser a) -> Seq BSERValue -> Parser (Seq a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BSERValue -> Parser a
forall a. FromBSER a => BSERValue -> Parser a
parseBSER Seq BSERValue
a
    parseBSER BSERValue
_ = String -> Parser (Seq a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not an array"

-- | Run a 'Parser'.
parse :: (a -> Parser b) -> a -> Result b
parse :: (a -> Parser b) -> a -> Result b
parse a -> Parser b
m a
v = Parser b -> Failure b -> Success b b -> Result b
forall a.
Parser a -> forall r. Failure r -> Success a r -> Result r
runParser (a -> Parser b
m a
v) Failure b
forall a. String -> Result a
Error Success b b
forall a. a -> Result a
Success
{-# INLINE parse #-}

(.:) :: (FromBSER a) => BSERObject -> ByteString -> Parser a
BSERObject
obj .: :: BSERObject -> ByteString -> Parser a
.: ByteString
key = case ByteString -> BSERObject -> Maybe BSERValue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ByteString
key BSERObject
obj of
                Maybe BSERValue
Nothing -> Parser a
forall (f :: * -> *) a. Alternative f => f a
empty
                Just BSERValue
v  -> BSERValue -> Parser a
forall a. FromBSER a => BSERValue -> Parser a
parseBSER BSERValue
v