{-# LANGUAGE ExistentialQuantification #-}

-- |
-- 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@ (e.g. 'Text.ParserCombinators.ReadP.ReadP')
-- 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
import Data.Function ((&))

-- | An 'Applicative' wrapper-type for constructing permutation parsers.
data Permutation m a = P !(Maybe a) [Branch m a]

data Branch m a = forall z. Branch (Permutation m (z -> a)) (m z)

instance Functor m => Functor (Permutation m) where
  fmap :: (a -> b) -> Permutation m a -> Permutation m b
fmap a -> b
f (P Maybe a
v [Branch m a]
bs) = Maybe b -> [Branch m b] -> Permutation m b
forall (m :: * -> *) a. Maybe a -> [Branch 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) -> Branch m a -> Branch m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Branch m a -> Branch m b) -> [Branch m a] -> [Branch m b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Branch m a]
bs)

instance Functor p => Functor (Branch p) where
  fmap :: (a -> b) -> Branch p a -> Branch p b
fmap a -> b
f (Branch Permutation p (z -> a)
perm p z
p) = Permutation p (z -> b) -> p z -> Branch p b
forall (m :: * -> *) a z.
Permutation m (z -> a) -> m z -> Branch m a
Branch (((z -> a) -> z -> b)
-> Permutation p (z -> a) -> Permutation p (z -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b
f (a -> b) -> (z -> a) -> z -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) Permutation p (z -> a)
perm) p z
p

instance Functor m => Applicative (Permutation m) where
  pure :: a -> Permutation m a
pure a
value = Maybe a -> [Branch m a] -> Permutation m a
forall (m :: * -> *) a. Maybe a -> [Branch m a] -> Permutation m a
P (a -> Maybe a
forall a. a -> Maybe a
Just a
value) [Branch m a]
forall (f :: * -> *) a. Alternative f => f a
empty
  lhs :: Permutation m (a -> b)
lhs@(P Maybe (a -> b)
f [Branch m (a -> b)]
v) <*> :: Permutation m (a -> b) -> Permutation m a -> Permutation m b
<*> rhs :: Permutation m a
rhs@(P Maybe a
g [Branch m a]
w) = Maybe b -> [Branch m b] -> Permutation m b
forall (m :: * -> *) a. Maybe a -> [Branch 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) ([Branch m b] -> Permutation m b)
-> [Branch m b] -> Permutation m b
forall a b. (a -> b) -> a -> b
$ (Branch m (a -> b) -> Branch m b
forall a. Branch m (a -> a) -> Branch m a
ins2 (Branch m (a -> b) -> Branch m b)
-> [Branch m (a -> b)] -> [Branch m b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Branch m (a -> b)]
v) [Branch m b] -> [Branch m b] -> [Branch m b]
forall a. Semigroup a => a -> a -> a
<> (Branch m a -> Branch m b
ins1 (Branch m a -> Branch m b) -> [Branch m a] -> [Branch m b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Branch m a]
w)
    where
      ins1 :: Branch m a -> Branch m b
ins1 (Branch Permutation m (z -> a)
perm m z
p) = Permutation m (z -> b) -> m z -> Branch m b
forall (m :: * -> *) a z.
Permutation m (z -> a) -> m z -> Branch m a
Branch ((a -> b) -> (z -> a) -> z -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ((a -> b) -> (z -> a) -> z -> b)
-> Permutation m (a -> b) -> Permutation m ((z -> a) -> z -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Permutation m (a -> b)
lhs Permutation m ((z -> a) -> z -> b)
-> Permutation m (z -> a) -> Permutation m (z -> b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Permutation m (z -> a)
perm) m z
p
      ins2 :: Branch m (a -> a) -> Branch m a
ins2 (Branch Permutation m (z -> a -> a)
perm m z
p) = Permutation m (z -> a) -> m z -> Branch m a
forall (m :: * -> *) a z.
Permutation m (z -> a) -> m z -> Branch m a
Branch ((z -> a -> a) -> a -> z -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((z -> a -> a) -> a -> z -> a)
-> Permutation m (z -> a -> a) -> Permutation m (a -> z -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Permutation m (z -> a -> a)
perm Permutation m (a -> z -> a)
-> Permutation m a -> Permutation m (z -> a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Permutation m a
rhs) m z
p
  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 [Branch m a]
v) rhs :: Permutation m b
rhs@(P Maybe b
y [Branch m b]
w) = Maybe c -> [Branch m c] -> Permutation m c
forall (m :: * -> *) a. Maybe a -> [Branch 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) ([Branch m c] -> Permutation m c)
-> [Branch m c] -> Permutation m c
forall a b. (a -> b) -> a -> b
$ (Branch m a -> Branch m c
ins2 (Branch m a -> Branch m c) -> [Branch m a] -> [Branch m c]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Branch m a]
v) [Branch m c] -> [Branch m c] -> [Branch m c]
forall a. Semigroup a => a -> a -> a
<> (Branch m b -> Branch m c
ins1 (Branch m b -> Branch m c) -> [Branch m b] -> [Branch m c]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Branch m b]
w)
    where
      ins1 :: Branch m b -> Branch m c
ins1 (Branch Permutation m (z -> b)
perm m z
p) = Permutation m (z -> c) -> m z -> Branch m c
forall (m :: * -> *) a z.
Permutation m (z -> a) -> m z -> Branch m a
Branch ((a -> (z -> b) -> z -> c)
-> Permutation m a
-> Permutation m (z -> b)
-> Permutation m (z -> c)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((b -> c) -> (z -> b) -> z -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ((b -> c) -> (z -> b) -> z -> c)
-> (a -> b -> c) -> a -> (z -> b) -> z -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> c
f) Permutation m a
lhs Permutation m (z -> b)
perm) m z
p
      ins2 :: Branch m a -> Branch m c
ins2 (Branch Permutation m (z -> a)
perm m z
p) = Permutation m (z -> c) -> m z -> Branch m c
forall (m :: * -> *) a z.
Permutation m (z -> a) -> m z -> Branch m a
Branch ((b -> (z -> a) -> z -> c)
-> Permutation m b
-> Permutation m (z -> a)
-> Permutation m (z -> c)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\b
b z -> a
g z
z -> a -> b -> c
f (z -> a
g z
z) b
b) Permutation m b
rhs Permutation m (z -> a)
perm) m z
p

-- | \"Unlifts\" a permutation parser into a parser to be evaluated.
runPermutation ::
  Alternative m =>
  -- | Permutation specification
  Permutation m a ->
  -- | Resulting base monad capable of handling the permutation
  m a
runPermutation :: Permutation m a -> m a
runPermutation = (Branch m a -> m a) -> Permutation m a -> m a
forall (m :: * -> *) a.
Alternative m =>
(Branch m a -> m a) -> Permutation m a -> m a
foldAlt Branch m a -> m a
forall (m :: * -> *) a. Alternative m => Branch m a -> m a
f
  where
    -- INCORRECT   = runPerms t <*> p
    f :: Branch m a -> m a
f (Branch Permutation m (z -> a)
t m z
p) = z -> (z -> a) -> a
forall a b. a -> (a -> b) -> b
(&) (z -> (z -> a) -> a) -> m z -> m ((z -> a) -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m z
p m ((z -> a) -> a) -> m (z -> a) -> m a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Permutation m (z -> a) -> m (z -> a)
forall (m :: * -> *) a. Alternative m => Permutation m a -> m a
runPermutation Permutation m (z -> a)
t

-- | \"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.
--     * If an effect is encountered after a component, another component must
--       immediately follow the effect.
intercalateEffect ::
  Alternative m =>
  -- | Effect to be intercalated between permutation components
  m b ->
  -- | Permutation specification
  Permutation m a ->
  -- | Resulting base applicative capable of handling the permutation
  m a
intercalateEffect :: m b -> Permutation m a -> m a
intercalateEffect m b
effect = (Branch m a -> m a) -> Permutation m a -> m a
forall (m :: * -> *) a.
Alternative m =>
(Branch m a -> m a) -> Permutation m a -> m a
foldAlt (m b -> Branch m a -> m a
forall (m :: * -> *) b a. Alternative m => m b -> Branch m a -> m a
runBranchEff m b
effect)
  where
    runPermEff :: Alternative m => m b -> Permutation m a -> m a
    runPermEff :: m b -> Permutation m a -> m a
runPermEff m b
eff (P Maybe a
v [Branch m a]
bs) =
      m b
eff m b -> m a -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Branch m a -> m a -> m a) -> m a -> [Branch m a] -> m a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) (m a -> m a -> m a)
-> (Branch m a -> m a) -> Branch m a -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m b -> Branch m a -> m a
forall (m :: * -> *) b a. Alternative m => m b -> Branch m a -> m a
runBranchEff m b
eff) m a
forall (f :: * -> *) a. Alternative f => f a
empty [Branch m a]
bs m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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
v

    runBranchEff :: Alternative m => m b -> Branch m a -> m a
    runBranchEff :: m b -> Branch m a -> m a
runBranchEff m b
eff (Branch Permutation m (z -> a)
t m z
p) = z -> (z -> a) -> a
forall a b. a -> (a -> b) -> b
(&) (z -> (z -> a) -> a) -> m z -> m ((z -> a) -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m z
p m ((z -> a) -> a) -> m (z -> a) -> m a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m b -> Permutation m (z -> a) -> m (z -> a)
forall (m :: * -> *) b a.
Alternative m =>
m b -> Permutation m a -> m a
runPermEff m b
eff Permutation m (z -> a)
t

-- | \"Lifts\" a parser to a permutation parser.
toPermutation ::
  Alternative m =>
  -- | Permutation component
  m a ->
  Permutation m a
toPermutation :: m a -> Permutation m a
toPermutation = Maybe a -> [Branch m a] -> Permutation m a
forall (m :: * -> *) a. Maybe a -> [Branch m a] -> Permutation m a
P Maybe a
forall a. Maybe a
Nothing ([Branch m a] -> Permutation m a)
-> (m a -> [Branch m a]) -> m a -> Permutation m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch m a -> [Branch m a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Branch m a -> [Branch m a])
-> (m a -> Branch m a) -> m a -> [Branch m a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> Branch m a
forall (m :: * -> *) a. Functor m => m a -> Branch m a
branch

-- | \"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 =>
  -- | Default Value
  a ->
  -- | Permutation component
  m a ->
  Permutation m a
toPermutationWithDefault :: a -> m a -> Permutation m a
toPermutationWithDefault a
v = Maybe a -> [Branch m a] -> Permutation m a
forall (m :: * -> *) a. Maybe a -> [Branch m a] -> Permutation m a
P (a -> Maybe a
forall a. a -> Maybe a
Just a
v) ([Branch m a] -> Permutation m a)
-> (m a -> [Branch m a]) -> m a -> Permutation m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch m a -> [Branch m a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Branch m a -> [Branch m a])
-> (m a -> Branch m a) -> m a -> [Branch m a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> Branch m a
forall (m :: * -> *) a. Functor m => m a -> Branch m a
branch

branch :: Functor m => m a -> Branch m a
branch :: m a -> Branch m a
branch = Permutation m (a -> a) -> m a -> Branch m a
forall (m :: * -> *) a z.
Permutation m (z -> a) -> m z -> Branch m a
Branch (Permutation m (a -> a) -> m a -> Branch m a)
-> Permutation m (a -> a) -> m a -> Branch m a
forall a b. (a -> b) -> a -> b
$ (a -> a) -> Permutation m (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id

foldAlt :: Alternative m => (Branch m a -> m a) -> Permutation m a -> m a
foldAlt :: (Branch m a -> m a) -> Permutation m a -> m a
foldAlt Branch m a -> m a
f (P Maybe a
v [Branch m a]
bs) = (Branch m a -> m a -> m a) -> m a -> [Branch m a] -> m a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) (m a -> m a -> m a)
-> (Branch m a -> m a) -> Branch m a -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch m a -> m a
f) (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
v) [Branch m a]
bs