{-# LANGUAGE ExistentialQuantification #-}

-- |
-- Module      :  Control.Applicative.Permutations
-- Copyright   :  © 2017–present Alex Washburn
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <[email protected]>
-- 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 :: forall a b. (a -> b) -> Permutation m a -> Permutation m b
fmap a -> b
f (P Maybe a
v [Branch m a]
bs) = forall (m :: * -> *) a. Maybe a -> [Branch m a] -> Permutation m a
P (a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
v) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Branch m a]
bs)

instance Functor p => Functor (Branch p) where
  fmap :: forall a b. (a -> b) -> Branch p a -> Branch p b
fmap a -> b
f (Branch Permutation p (z -> a)
perm p z
p) = forall (m :: * -> *) a z.
Permutation m (z -> a) -> m z -> Branch m a
Branch (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b
f 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 :: forall a. a -> Permutation m a
pure a
value = forall (m :: * -> *) a. Maybe a -> [Branch m a] -> Permutation m a
P (forall a. a -> Maybe a
Just a
value) forall (f :: * -> *) a. Alternative f => f a
empty
  lhs :: Permutation m (a -> b)
lhs@(P Maybe (a -> b)
f [Branch m (a -> b)]
v) <*> :: forall a b.
Permutation m (a -> b) -> Permutation m a -> Permutation m b
<*> rhs :: Permutation m a
rhs@(P Maybe a
g [Branch m a]
w) = forall (m :: * -> *) a. Maybe a -> [Branch m a] -> Permutation m a
P (Maybe (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe a
g) forall a b. (a -> b) -> a -> b
$ (forall {a}. Branch m (a -> a) -> Branch m a
ins2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Branch m (a -> b)]
v) forall a. Semigroup a => a -> a -> a
<> (Branch m a -> Branch m b
ins1 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) = forall (m :: * -> *) a z.
Permutation m (z -> a) -> m z -> Branch m a
Branch (forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Permutation m (a -> b)
lhs 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) = forall (m :: * -> *) a z.
Permutation m (z -> a) -> m z -> Branch m a
Branch (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Permutation m (z -> a -> a)
perm forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Permutation m a
rhs) m z
p
  liftA2 :: forall a b c.
(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) = forall (m :: * -> *) a. Maybe a -> [Branch m a] -> Permutation m a
P (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) forall a b. (a -> b) -> a -> b
$ (Branch m a -> Branch m c
ins2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Branch m a]
v) forall a. Semigroup a => a -> a -> a
<> (Branch m b -> Branch m c
ins1 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) = forall (m :: * -> *) a z.
Permutation m (z -> a) -> m z -> Branch m a
Branch (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (forall b c a. (b -> c) -> (a -> b) -> a -> 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) = forall (m :: * -> *) a z.
Permutation m (z -> a) -> m z -> Branch m a
Branch (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 :: forall (m :: * -> *) a. Alternative m => Permutation m a -> m a
runPermutation = forall (m :: * -> *) a.
Alternative m =>
(Branch m a -> m a) -> Permutation m a -> m a
foldAlt 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) = forall a b. a -> (a -> b) -> b
(&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m z
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 :: forall (m :: * -> *) b a.
Alternative m =>
m b -> Permutation m a -> m a
intercalateEffect m b
effect = forall (m :: * -> *) a.
Alternative m =>
(Branch m a -> m a) -> Permutation m a -> m a
foldAlt (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 :: forall (m :: * -> *) b a.
Alternative m =>
m b -> Permutation m a -> m a
runPermEff m b
eff (P Maybe a
v [Branch m a]
bs) =
      m b
eff forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) b a. Alternative m => m b -> Branch m a -> m a
runBranchEff m b
eff) forall (f :: * -> *) a. Alternative f => f a
empty [Branch m a]
bs forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (f :: * -> *) a. Alternative f => f a
empty forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
v

    runBranchEff :: Alternative m => m b -> Branch m a -> m a
    runBranchEff :: forall (m :: * -> *) b a. Alternative m => m b -> Branch m a -> m a
runBranchEff m b
eff (Branch Permutation m (z -> a)
t m z
p) = forall a b. a -> (a -> b) -> b
(&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m z
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 :: forall (m :: * -> *) a. Alternative m => m a -> Permutation m a
toPermutation = forall (m :: * -> *) a. Maybe a -> [Branch m a] -> Permutation m a
P forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (m :: * -> *) a.
Alternative m =>
a -> m a -> Permutation m a
toPermutationWithDefault a
v = forall (m :: * -> *) a. Maybe a -> [Branch m a] -> Permutation m a
P (forall a. a -> Maybe a
Just a
v) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Functor m => m a -> Branch m a
branch

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

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