    {-# LANGUAGE ExistentialQuantification #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Text.Parser.Permutation
    -- Copyright   :  (c) Edward Kmett 2011-2012
    --                (c) Paolo Martini 2007
    --                (c) Daan Leijen 1999-2001
    -- License     :  BSD-style
    --
    -- Maintainer  :  ekmett@gmail.com
    -- Stability   :  provisional
    -- Portability :  non-portable
    --
    -- This module implements permutation parsers. The algorithm is described in:
    --
    -- /Parsing Permutation Phrases,/
    -- by Arthur Baars, Andres Loh and Doaitse Swierstra.
    -- Published as a functional pearl at the Haskell Workshop 2001.
    --
    -----------------------------------------------------------------------------
    module Text.Parser.Permutation
        ( Permutation
        , permute
        , (<||>), (<$$>)
        , (<|?>), (<$?>)
        ) where

    import Control.Applicative
    import Data.Foldable (asum)

    infixl 1 <||>, <|?>
    infixl 2 <$$>, <$?>

    ----------------------------------------------------------------
    --  Building a permutation parser
    ----------------------------------------------------------------

    -- | The expression @perm \<||> p@ adds parser @p@ to the permutation
    -- parser @perm@. The parser @p@ is not allowed to accept empty input -
    -- use the optional combinator ('<|?>') instead. Returns a
    -- new permutation parser that includes @p@.

    (<||>) :: Functor m => Permutation m (a -> b) -> m a -> Permutation m b
    (<||>) = add
    {-# INLINE (<||>) #-}

    -- | The expression @f \<$$> p@ creates a fresh permutation parser
    -- consisting of parser @p@. The final result of the permutation
    -- parser is the function @f@ applied to the return value of @p@. The
    -- parser @p@ is not allowed to accept empty input - use the optional
    -- combinator ('<$?>') instead.
    --
    -- If the function @f@ takes more than one parameter, the type variable
    -- @b@ is instantiated to a functional type which combines nicely with
    -- the adds parser @p@ to the ('<||>') combinator. This
    -- results in stylized code where a permutation parser starts with a
    -- combining function @f@ followed by the parsers. The function @f@
    -- gets its parameters in the order in which the parsers are specified,
    -- but actual input can be in any order.

    (<$$>) :: Functor m => (a -> b) -> m a -> Permutation m b
    (<$$>) f p = newPermutation f <||> p
    {-# INLINE (<$$>) #-}

    -- | The expression @perm \<|?> (x,p)@ adds parser @p@ to the
    -- permutation parser @perm@. The parser @p@ is optional - if it can
    -- not be applied, the default value @x@ will be used instead. Returns
    -- a new permutation parser that includes the optional parser @p@.

    (<|?>) :: Functor m => Permutation m (a -> b) -> (a, m a) -> Permutation m b
    (<|?>) perm (x,p) = addOpt perm x p
    {-# INLINE (<|?>) #-}

    -- | The expression @f \<$?> (x,p)@ creates a fresh permutation parser
    -- consisting of parser @p@. The final result of the permutation
    -- parser is the function @f@ applied to the return value of @p@. The
    -- parser @p@ is optional - if it can not be applied, the default value
    -- @x@ will be used instead.

    (<$?>) :: Functor m => (a -> b) -> (a, m a) -> Permutation m b
    (<$?>) f (x,p) = newPermutation f <|?> (x,p)
    {-# INLINE (<$?>) #-}

    ----------------------------------------------------------------
    -- The permutation tree
    ----------------------------------------------------------------

    -- | The type @Permutation m a@ denotes a permutation parser that,
    -- when converted by the 'permute' function, parses
    -- using the base parsing monad @m@ and returns a value of
    -- type @a@ on success.
    --
    -- Normally, a permutation parser is first build with special operators
    -- like ('<||>') and than transformed into a normal parser
    -- using 'permute'.

    data Permutation m a = Permutation (Maybe a) [Branch m a]

    instance Functor m => Functor (Permutation m) where
      fmap f (Permutation x xs) = Permutation (fmap f x) (fmap f <$> xs)

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

    instance Functor m => Functor (Branch m) where
      fmap f (Branch perm p) = Branch (fmap (f.) perm) p

    -- | The parser @permute perm@ parses a permutation of parser described
    -- by @perm@. For example, suppose we want to parse a permutation of:
    -- an optional string of @a@'s, the character @b@ and an optional @c@.
    -- This can be described by:
    --
    -- >  test  = permute (tuple <$?> ("",some (char 'a'))
    -- >                         <||> char 'b'
    -- >                         <|?> ('_',char 'c'))
    -- >        where
    -- >          tuple a b c  = (a,b,c)

    -- transform a permutation tree into a normal parser
    permute :: forall m a. Alternative m => Permutation m a -> m a
    permute (Permutation def xs)
      = asum (map branch xs ++ e)
      where
        e :: [m a]
        e = maybe [] (pure . pure) def
        branch (Branch perm p) = flip id <$> p <*> permute perm

    -- build permutation trees
    newPermutation :: (a -> b) -> Permutation m (a -> b)
    newPermutation f = Permutation (Just f) []
    {-# INLINE newPermutation #-}

    add :: Functor m => Permutation m (a -> b) -> m a -> Permutation m b
    add perm@(Permutation _mf fs) p
      = Permutation Nothing (first:map insert fs)
      where
        first = Branch perm p
        insert (Branch perm' p')
                = Branch (add (fmap flip perm') p) p'

    addOpt :: Functor m => Permutation m (a -> b) -> a -> m a -> Permutation m b
    addOpt perm@(Permutation mf fs) x p
      = Permutation (fmap ($ x) mf) (first:map insert fs)
      where
        first = Branch perm p
        insert (Branch perm' p') = Branch (addOpt (fmap flip perm') x p) p'