-- |
-- Module      :  Control.Applicative.Permutations
-- Copyright   :  © 2017–present Alex Washburn
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- This module is a generalization of the package @parsec-permutation@
-- authored by Samuel Hoffstaetter:
--
-- https://hackage.haskell.org/package/parsec-permutation
--
-- This module also takes inspiration from the algorithm is described in:
-- /Parsing Permutation Phrases/, by Arthur Baars, Andres Löh and Doaitse
-- Swierstra. Published as a functional pearl at the Haskell Workshop 2001:
--
-- https://www.cs.ox.ac.uk/jeremy.gibbons/wg21/meeting56/loeh-paper.pdf
--
-- From these two works we derive a flexible and general method for parsing
-- permutations over an 'Applicative' structure. Quite useful in conjunction
-- with \"Free\" constructions of 'Applicative's, 'Monad's, etc.
--
-- Other permutation parsing libraries tend towards using special \"almost
-- applicative\" combinators for construction which denies the library user
-- the ability to lift and unlift permutation parsing into any 'Applicative'
-- computational context. We redefine these combinators as convenience
-- operators here alongside the equivalent 'Applicative' instance.
--
-- For example, suppose we want to parse a permutation of: an optional
-- string of @a@'s, the character @b@ and an optional @c@. Using a standard
-- parsing library combinator @char@, this can be described using the
-- 'Applicative' instance by:
--
-- > test = runPermutation $
-- >          (,,) <$> toPermutationWithDefault ""  (some (char 'a'))
-- >               <*> toPermutation (char 'b')
-- >               <*> toPermutationWithDefault '_' (char 'c')
--
-- @since 0.2.0

module Control.Applicative.Permutations
  ( -- ** Permutation type
    Permutation
    -- ** Permutation evaluators
  , runPermutation
  , intercalateEffect
    -- ** Permutation constructors
  , toPermutation
  , toPermutationWithDefault )
where

import Control.Applicative

-- | An 'Applicative' wrapper-type for constructing permutation parsers.

data Permutation m a = P !(Maybe a) (m (Permutation m a))

instance Functor m => Functor (Permutation m) where
  fmap :: (a -> b) -> Permutation m a -> Permutation m b
fmap a -> b
f (P Maybe a
v m (Permutation m a)
p) = Maybe b -> m (Permutation m b) -> Permutation m b
forall (m :: * -> *) a.
Maybe a -> m (Permutation m a) -> Permutation m a
P (a -> b
f (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
v) ((a -> b) -> Permutation m a -> Permutation m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Permutation m a -> Permutation m b)
-> m (Permutation m a) -> m (Permutation m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Permutation m a)
p)

instance Alternative m => Applicative (Permutation m) where
  pure :: a -> Permutation m a
pure a
value = Maybe a -> m (Permutation m a) -> Permutation m a
forall (m :: * -> *) a.
Maybe a -> m (Permutation m a) -> Permutation m a
P (a -> Maybe a
forall a. a -> Maybe a
Just a
value) m (Permutation m a)
forall (f :: * -> *) a. Alternative f => f a
empty
  lhs :: Permutation m (a -> b)
lhs@(P Maybe (a -> b)
f m (Permutation m (a -> b))
v) <*> :: Permutation m (a -> b) -> Permutation m a -> Permutation m b
<*> rhs :: Permutation m a
rhs@(P Maybe a
g m (Permutation m a)
w) = Maybe b -> m (Permutation m b) -> Permutation m b
forall (m :: * -> *) a.
Maybe a -> m (Permutation m a) -> Permutation m a
P (Maybe (a -> b)
f Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe a
g) (m (Permutation m b)
lhsAlt m (Permutation m b) -> m (Permutation m b) -> m (Permutation m b)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m (Permutation m b)
rhsAlt)
    where
      lhsAlt :: m (Permutation m b)
lhsAlt = (Permutation m (a -> b) -> Permutation m a -> Permutation m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Permutation m a
rhs) (Permutation m (a -> b) -> Permutation m b)
-> m (Permutation m (a -> b)) -> m (Permutation m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Permutation m (a -> b))
v
      rhsAlt :: m (Permutation m b)
rhsAlt = (Permutation m (a -> b)
lhs Permutation m (a -> b) -> Permutation m a -> Permutation m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>) (Permutation m a -> Permutation m b)
-> m (Permutation m a) -> m (Permutation m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Permutation m a)
w
  liftA2 :: (a -> b -> c)
-> Permutation m a -> Permutation m b -> Permutation m c
liftA2 a -> b -> c
f lhs :: Permutation m a
lhs@(P Maybe a
x m (Permutation m a)
v) rhs :: Permutation m b
rhs@(P Maybe b
y m (Permutation m b)
w) = Maybe c -> m (Permutation m c) -> Permutation m c
forall (m :: * -> *) a.
Maybe a -> m (Permutation m a) -> Permutation m a
P ((a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f Maybe a
x Maybe b
y) (m (Permutation m c)
lhsAlt m (Permutation m c) -> m (Permutation m c) -> m (Permutation m c)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m (Permutation m c)
rhsAlt)
    where
      lhsAlt :: m (Permutation m c)
lhsAlt = (\Permutation m a
p -> (a -> b -> c)
-> Permutation m a -> Permutation m b -> Permutation m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f Permutation m a
p Permutation m b
rhs) (Permutation m a -> Permutation m c)
-> m (Permutation m a) -> m (Permutation m c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Permutation m a)
v
      rhsAlt :: m (Permutation m c)
rhsAlt = (a -> b -> c)
-> Permutation m a -> Permutation m b -> Permutation m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f Permutation m a
lhs (Permutation m b -> Permutation m c)
-> m (Permutation m b) -> m (Permutation m c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Permutation m b)
w

-- | \"Unlifts\" a permutation parser into a parser to be evaluated.

runPermutation
  :: ( Alternative m
     , Monad m)
  => Permutation m a -- ^ Permutation specification
  -> m a             -- ^ Resulting base monad capable of handling the permutation
runPermutation :: Permutation m a -> m a
runPermutation (P Maybe a
value m (Permutation m a)
parser) = m (Permutation m a) -> m (Maybe (Permutation m a))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m (Permutation m a)
parser m (Maybe (Permutation m a))
-> (Maybe (Permutation m a) -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Permutation m a) -> m a
forall (f :: * -> *).
(Alternative f, Monad f) =>
Maybe (Permutation f a) -> f a
f
   where
      f :: Maybe (Permutation f a) -> f a
f  Maybe (Permutation f a)
Nothing = f a -> (a -> f a) -> Maybe a -> f a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe f a
forall (f :: * -> *) a. Alternative f => f a
empty a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
value
      f (Just Permutation f a
p) = Permutation f a -> f a
forall (m :: * -> *) a.
(Alternative m, Monad m) =>
Permutation m a -> m a
runPermutation Permutation f a
p

-- | \"Unlifts\" a permutation parser into a parser to be evaluated with an
-- intercalated effect. Useful for separators between permutation elements.
--
-- For example, suppose that similar to above we want to parse a permutation
-- of: an optional string of @a@'s, the character @b@ and an optional @c@.
-- /However/, we also want each element of the permutation to be separated
-- by a colon. Using a standard parsing library combinator @char@, this can
-- be described using the 'Applicative' instance by:
--
-- > test = intercalateEffect (char ':') $
-- >          (,,) <$> toPermutationWithDefault "" (some (char 'a'))
-- >               <*> toPermutation (char 'b')
-- >               <*> toPermutationWithDefault '_' (char 'c')
--
-- This will accept strings such as: \"a:b:c\", \"b:c:a\", \"b:aa\", \"b\",
-- etc.
--
-- Note that the effect is intercalated /between/ permutation components and
-- that:
--
--     * There is never an effect parsed preceeding the first component of
--       the permutation.
--     * There is never an effect parsed following the last component of the
--       permutation.
--     * No effects are intercalated between missing components with a
--       default value.

intercalateEffect
  :: ( Alternative m
     , Monad m)
  => m b             -- ^ Effect to be intercalated between permutation components
  -> Permutation m a -- ^ Permutation specification
  -> m a             -- ^ Resulting base monad capable of handling the permutation
intercalateEffect :: m b -> Permutation m a -> m a
intercalateEffect = m () -> m b -> Permutation m a -> m a
forall (m :: * -> *) c b a.
(Alternative m, Monad m) =>
m c -> m b -> Permutation m a -> m a
run m ()
noEffect
   where
     noEffect :: m ()
noEffect = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

     run :: (Alternative m, Monad m) => m c -> m b -> Permutation m a -> m a
     run :: m c -> m b -> Permutation m a -> m a
run m c
headSep m b
tailSep (P Maybe a
value m (Permutation m a)
parser) = m c -> m (Maybe c)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m c
headSep m (Maybe c) -> (Maybe c -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe c -> m a
forall a. Maybe a -> m a
f
       where
         f :: Maybe a -> m a
f  Maybe a
Nothing = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall (f :: * -> *) a. Alternative f => f a
empty a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
value
         f (Just a
_) = m (Permutation m a) -> m (Maybe (Permutation m a))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m (Permutation m a)
parser m (Maybe (Permutation m a))
-> (Maybe (Permutation m a) -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Permutation m a) -> m a
g
         g :: Maybe (Permutation m a) -> m a
g  Maybe (Permutation m a)
Nothing = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall (f :: * -> *) a. Alternative f => f a
empty a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
value
         g (Just Permutation m a
p) = m b -> m b -> Permutation m a -> m a
forall (m :: * -> *) c b a.
(Alternative m, Monad m) =>
m c -> m b -> Permutation m a -> m a
run m b
tailSep m b
tailSep Permutation m a
p

-- | \"Lifts\" a parser to a permutation parser.

toPermutation
  :: Alternative m
  => m a -- ^ Permutation component
  -> Permutation m a
toPermutation :: m a -> Permutation m a
toPermutation m a
p = Maybe a -> m (Permutation m a) -> Permutation m a
forall (m :: * -> *) a.
Maybe a -> m (Permutation m a) -> Permutation m a
P Maybe a
forall a. Maybe a
Nothing (m (Permutation m a) -> Permutation m a)
-> m (Permutation m a) -> Permutation m a
forall a b. (a -> b) -> a -> b
$ a -> Permutation m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Permutation m a) -> m a -> m (Permutation m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
p

-- | \"Lifts\" a parser with a default value to a permutation parser.
--
-- If no permutation containing the supplied parser can be parsed from the input,
-- then the supplied default value is returned in lieu of a parse result.

toPermutationWithDefault
  :: Alternative m
  => a   -- ^ Default Value
  -> m a -- ^ Permutation component
  -> Permutation m a
toPermutationWithDefault :: a -> m a -> Permutation m a
toPermutationWithDefault a
v m a
p = Maybe a -> m (Permutation m a) -> Permutation m a
forall (m :: * -> *) a.
Maybe a -> m (Permutation m a) -> Permutation m a
P (a -> Maybe a
forall a. a -> Maybe a
Just a
v) (m (Permutation m a) -> Permutation m a)
-> m (Permutation m a) -> Permutation m a
forall a b. (a -> b) -> a -> b
$ a -> Permutation m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Permutation m a) -> m a -> m (Permutation m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
p