-- |
-- Module      :  Snack.Combinators
-- License     :  CC0-1.0
--
-- Maintainer  :  mordae@anilinux.org
-- Stability   :  unstable
-- Portability :  non-portable (ghc)
--

module Snack.Combinators
  ( provided
  , choice
  , count
  , eitherP
  , option
  , many1
  , manyTill
  , sepBy
  , sepBy1
  , wrap
  , inRange
  , notInRange
  )
where
  import Control.Applicative
  import Data.Maybe

  import {-# SOURCE #-} qualified Data.ByteString.Parser as BSP
  import {-# SOURCE #-} qualified Data.Text.Parser as TP


  -- |
  -- Fails if the value returned by the parser does not conform to the
  -- predicate. Generalized form of 'Data.ByteString.Parser.Char8.string'.
  --
  -- Example:
  --
  -- @
  -- pInput = takeWhile isLetter \`provided\` (odd . length)
  -- @
  --
  {-# INLINE CONLIKE provided #-}
  {-# SPECIALIZE provided :: BSP.Parser a -> (a -> Bool) -> BSP.Parser a #-}
  {-# SPECIALIZE provided :: TP.Parser a -> (a -> Bool) -> TP.Parser a #-}
  provided :: (Alternative m, Monad m) => m a -> (a -> Bool) -> m a
  provided :: m a -> (a -> Bool) -> m a
provided m a
par a -> Bool
test = do
    a
x <- m a
par
    if a -> Bool
test a
x
       then a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
       else m a
forall (f :: * -> *) a. Alternative f => f a
Control.Applicative.empty


  -- |
  -- Tries various parsers, one by one.
  --
  -- Example:
  --
  -- @
  -- pExpression = choice [ pConstant
  --                      , pVariable
  --                      , pBinaryOperation
  --                      , pFunctionApplication
  --                      ]
  -- @
  --
  {-# INLINE CONLIKE choice #-}
  {-# SPECIALIZE choice :: [BSP.Parser a] -> BSP.Parser a #-}
  {-# SPECIALIZE choice :: [TP.Parser a] -> TP.Parser a #-}
  choice :: (Alternative f) => [f a] -> f a
#if MIN_VERSION_base(4, 16, 0)
  choice = asum
#else
  choice :: [f a] -> f a
choice = (f a -> f a -> f a) -> f a -> [f a] -> f a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) f a
forall (f :: * -> *) a. Alternative f => f a
empty
#endif


  -- |
  -- Replicates the parser given number of times, collecting the results
  -- in a list. Fails if any instance of the parser fails.
  --
  -- Example:
  --
  -- @
  -- pFourWords = (:) \<$\> word \<*\> count 3 (blank *> word)
  --   where word  = takeWhile1 isLetter
  --         blank = takeWhile1 isSpace
  -- @
  --
  {-# INLINE CONLIKE count #-}
  {-# SPECIALIZE count :: Int -> BSP.Parser a -> BSP.Parser [a] #-}
  {-# SPECIALIZE count :: Int -> TP.Parser a -> TP.Parser [a] #-}
  count :: (Monad m) => Int -> m a -> m [a]
  count :: Int -> m a -> m [a]
count Int
n m a
p = [m a] -> m [a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
Prelude.sequence (Int -> m a -> [m a]
forall a. Int -> a -> [a]
Prelude.replicate Int
n m a
p)


  -- |
  -- Captures first parser as @Left@ or the second as @Right@.
  --
  {-# INLINE CONLIKE eitherP #-}
  {-# SPECIALIZE eitherP :: BSP.Parser a -> BSP.Parser b -> BSP.Parser (Either a b) #-}
  {-# SPECIALIZE eitherP :: TP.Parser a -> TP.Parser b -> TP.Parser (Either a b) #-}
  eitherP :: (Alternative f) => f a -> f b -> f (Either a b)
  eitherP :: f a -> f b -> f (Either a b)
eitherP f a
left f b
right = (a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> f a -> f (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
left) f (Either a b) -> f (Either a b) -> f (Either a b)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> f b -> f (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
right)


  -- |
  -- Shortcut for 'optional' with a default value.
  --
  -- Example:
  --
  -- @
  -- data Contact =
  --  Contact
  --    { contactName  :: Text
  --    , contactEmail :: Maybe Text
  --    }
  --
  -- pContact = Contact \<$\> pFullName \<*\> option pEmail
  -- @
  --
  {-# INLINE CONLIKE option #-}
  {-# SPECIALIZE option :: a -> BSP.Parser a -> BSP.Parser a #-}
  {-# SPECIALIZE option :: a -> TP.Parser a -> TP.Parser a #-}
  option :: (Alternative f) => a -> f a -> f a
  option :: a -> f a -> f a
option a
dfl f a
par = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
dfl (Maybe a -> a) -> f (Maybe a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a -> f (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional f a
par


  -- |
  -- Like 'many1', but requires at least one match.
  --
  {-# INLINE many1 #-}
  {-# SPECIALIZE many1 :: BSP.Parser a -> BSP.Parser [a] #-}
  {-# SPECIALIZE many1 :: TP.Parser a -> TP.Parser [a] #-}
  many1 :: (Alternative f) => f a -> f [a]
  many1 :: f a -> f [a]
many1 = f a -> f [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some


  -- |
  -- Like 'many', but stops once the second parser matches the input ahead.
  --
  -- Example:
  --
  -- @
  -- pBodyLines = pLine \`manyTill\` pEnd
  --   where pLine = takeTill (== '\n')
  --         pEnd  = string "\n.\n"
  -- @
  --
  {-# INLINE CONLIKE manyTill #-}
  {-# SPECIALIZE manyTill :: BSP.Parser a -> BSP.Parser a -> BSP.Parser [a] #-}
  {-# SPECIALIZE manyTill :: TP.Parser a -> TP.Parser a -> TP.Parser [a] #-}
  manyTill :: (Alternative f) => f a -> f a -> f [a]
  manyTill :: f a -> f a -> f [a]
manyTill f a
par f a
stop = f [a]
loop
    where loop :: f [a]
loop = (f a
stop f a -> f [a] -> f [a]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [a] -> f [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) f [a] -> f [a] -> f [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((:) (a -> [a] -> [a]) -> f a -> f ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
par f ([a] -> [a]) -> f [a] -> f [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f [a]
loop)


  -- |
  -- Similar to 'many', but interleaves the first parser with the second.
  --
  -- Example:
  --
  -- @
  -- pLines = pLine `sepBy` char '\n'
  -- @
  --
  {-# INLINE CONLIKE sepBy #-}
  {-# SPECIALIZE sepBy :: BSP.Parser a -> BSP.Parser b -> BSP.Parser [a] #-}
  {-# SPECIALIZE sepBy :: TP.Parser a -> TP.Parser b -> TP.Parser [a] #-}
  sepBy :: (Alternative f) => f a -> f b -> f [a]
  sepBy :: f a -> f b -> f [a]
sepBy f a
par f b
sep = f a -> f b -> f [a]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
sepBy1 f a
par f b
sep f [a] -> f [a] -> f [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> f [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []


  -- |
  -- Like 'sepBy', but requires at least one match.
  --
  {-# INLINE CONLIKE sepBy1 #-}
  {-# SPECIALIZE sepBy1 :: BSP.Parser a -> BSP.Parser b -> BSP.Parser [a] #-}
  {-# SPECIALIZE sepBy1 :: TP.Parser a -> TP.Parser b -> TP.Parser [a] #-}
  sepBy1 :: (Alternative f) => f a -> f b -> f [a]
  sepBy1 :: f a -> f b -> f [a]
sepBy1 f a
par f b
sep = f [a]
loop
    where loop :: f [a]
loop = (:) (a -> [a] -> [a]) -> f a -> f ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
par f ([a] -> [a]) -> f [a] -> f [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((f b
sep f b -> f [a] -> f [a]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f [a]
loop) f [a] -> f [a] -> f [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> f [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])


  -- |
  -- Wraps the parser from both sides.
  --
  -- Example:
  --
  -- @
  -- pToken = takeWhile1 (inClass "A-Za-z0-9_") \`wrap\` takeWhile isSpace
  -- @
  --
  {-# INLINE CONLIKE wrap #-}
  {-# SPECIALIZE wrap :: BSP.Parser a -> BSP.Parser b -> BSP.Parser a #-}
  {-# SPECIALIZE wrap :: TP.Parser a -> TP.Parser b -> TP.Parser a #-}
  wrap :: (Applicative f) => f a -> f b -> f a
  wrap :: f a -> f b -> f a
wrap f a
par f b
wrapper = f b
wrapper f b -> f a -> f a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f a
par f a -> f b -> f a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* f b
wrapper


  -- |
  -- Tests whether the character lies within given range.
  --
  -- Definition:
  --
  -- @
  -- inRange lo hi = \c -> (lo <= c && c <= hi)
  -- @
  --
  {-# INLINE CONLIKE inRange #-}
  inRange :: Char -> Char -> Char -> Bool
  inRange :: Char -> Char -> Char -> Bool
inRange Char
lo Char
hi = \Char
c -> (Char
lo 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
hi)


  -- |
  -- Negation of 'inRange'.
  --
  -- Definition:
  --
  -- @
  -- notInRange lo hi = \c -> (c <= lo || hi <= c)
  -- @
  --
  {-# INLINE CONLIKE notInRange #-}
  notInRange :: Char -> Char -> Char -> Bool
  notInRange :: Char -> Char -> Char -> Bool
notInRange Char
lo Char
hi = \Char
c -> (Char
lo 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
hi)


-- vim:set ft=haskell sw=2 ts=2 et: