{-# 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"
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