{-# 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 qualified Data.Foldable as F (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
<||> :: Permutation m (a -> b) -> m a -> Permutation m b
(<||>) = Permutation m (a -> b) -> m a -> Permutation m b
forall (m :: * -> *) a b.
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
<$$> :: (a -> b) -> m a -> Permutation m b
(<$$>) a -> b
f m a
p = (a -> b) -> Permutation m (a -> b)
forall a b (m :: * -> *). (a -> b) -> Permutation m (a -> b)
newPermutation a -> b
f Permutation m (a -> b) -> m a -> Permutation m b
forall (m :: * -> *) a b.
Functor m =>
Permutation m (a -> b) -> m a -> Permutation m b
<||> m a
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
<|?> :: Permutation m (a -> b) -> (a, m a) -> Permutation m b
(<|?>) Permutation m (a -> b)
perm (a
x,m a
p) = Permutation m (a -> b) -> a -> m a -> Permutation m b
forall (m :: * -> *) a b.
Functor m =>
Permutation m (a -> b) -> a -> m a -> Permutation m b
addOpt Permutation m (a -> b)
perm a
x m a
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
<$?> :: (a -> b) -> (a, m a) -> Permutation m b
(<$?>) a -> b
f (a
x,m a
p) = (a -> b) -> Permutation m (a -> b)
forall a b (m :: * -> *). (a -> b) -> Permutation m (a -> b)
newPermutation a -> b
f Permutation m (a -> b) -> (a, m a) -> Permutation m b
forall (m :: * -> *) a b.
Functor m =>
Permutation m (a -> b) -> (a, m a) -> Permutation m b
<|?> (a
x,m a
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 :: (a -> b) -> Permutation m a -> Permutation m b
fmap a -> b
f (Permutation Maybe a
x [Branch m a]
xs) = Maybe b -> [Branch m b] -> Permutation m b
forall (m :: * -> *) a. Maybe a -> [Branch m a] -> Permutation m a
Permutation ((a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Maybe a
x) ((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]
xs)

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

instance Functor m => Functor (Branch m) where
  fmap :: (a -> b) -> Branch m a -> Branch m b
fmap a -> b
f (Branch Permutation m (b -> a)
perm m b
p) = Permutation m (b -> b) -> m b -> Branch m b
forall (m :: * -> *) a b.
Permutation m (b -> a) -> m b -> Branch m a
Branch (((b -> a) -> b -> b)
-> Permutation m (b -> a) -> Permutation m (b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b
f(a -> b) -> (b -> a) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) Permutation m (b -> a)
perm) m b
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 m a -> m a
permute (Permutation Maybe a
def [Branch m a]
xs)
  = [m a] -> m a
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
F.asum ((Branch m a -> m a) -> [Branch m a] -> [m a]
forall a b. (a -> b) -> [a] -> [b]
map Branch m a -> m a
forall (m :: * -> *) a. Alternative m => Branch m a -> m a
branch [Branch m a]
xs [m a] -> [m a] -> [m a]
forall a. [a] -> [a] -> [a]
++ [m a]
e)
  where
    e :: [m a]
    e :: [m a]
e = [m a] -> (a -> [m a]) -> Maybe a -> [m a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (m a -> [m a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m a -> [m a]) -> (a -> m a) -> a -> [m a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) Maybe a
def
    branch :: Branch m a -> m a
branch (Branch Permutation m (b -> a)
perm m b
p) = ((b -> a) -> b -> a) -> b -> (b -> a) -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (b -> a) -> b -> a
forall a. a -> a
id (b -> (b -> a) -> a) -> m b -> m ((b -> a) -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b
p m ((b -> a) -> a) -> m (b -> a) -> m a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Permutation m (b -> a) -> m (b -> a)
forall (m :: * -> *) a. Alternative m => Permutation m a -> m a
permute Permutation m (b -> a)
perm

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

add :: Functor m => Permutation m (a -> b) -> m a -> Permutation m b
add :: Permutation m (a -> b) -> m a -> Permutation m b
add perm :: Permutation m (a -> b)
perm@(Permutation Maybe (a -> b)
_mf [Branch m (a -> b)]
fs) m a
p
  = Maybe b -> [Branch m b] -> Permutation m b
forall (m :: * -> *) a. Maybe a -> [Branch m a] -> Permutation m a
Permutation Maybe b
forall a. Maybe a
Nothing (Branch m b
firstBranch m b -> [Branch m b] -> [Branch m b]
forall a. a -> [a] -> [a]
:(Branch m (a -> b) -> Branch m b)
-> [Branch m (a -> b)] -> [Branch m b]
forall a b. (a -> b) -> [a] -> [b]
map Branch m (a -> b) -> Branch m b
forall a. Branch m (a -> a) -> Branch m a
insert [Branch m (a -> b)]
fs)
  where
    first :: Branch m b
first = Permutation m (a -> b) -> m a -> Branch m b
forall (m :: * -> *) a b.
Permutation m (b -> a) -> m b -> Branch m a
Branch Permutation m (a -> b)
perm m a
p
    insert :: Branch m (a -> a) -> Branch m a
insert (Branch Permutation m (b -> a -> a)
perm' m b
p')
            = Permutation m (b -> a) -> m b -> Branch m a
forall (m :: * -> *) a b.
Permutation m (b -> a) -> m b -> Branch m a
Branch (Permutation m (a -> b -> a) -> m a -> Permutation m (b -> a)
forall (m :: * -> *) a b.
Functor m =>
Permutation m (a -> b) -> m a -> Permutation m b
add (((b -> a -> a) -> a -> b -> a)
-> Permutation m (b -> a -> a) -> Permutation m (a -> b -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> a -> a) -> a -> b -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Permutation m (b -> a -> a)
perm') m a
p) m b
p'

addOpt :: Functor m => Permutation m (a -> b) -> a -> m a -> Permutation m b
addOpt :: Permutation m (a -> b) -> a -> m a -> Permutation m b
addOpt perm :: Permutation m (a -> b)
perm@(Permutation Maybe (a -> b)
mf [Branch m (a -> b)]
fs) a
x m a
p
  = Maybe b -> [Branch m b] -> Permutation m b
forall (m :: * -> *) a. Maybe a -> [Branch m a] -> Permutation m a
Permutation (((a -> b) -> b) -> Maybe (a -> b) -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
x) Maybe (a -> b)
mf) (Branch m b
firstBranch m b -> [Branch m b] -> [Branch m b]
forall a. a -> [a] -> [a]
:(Branch m (a -> b) -> Branch m b)
-> [Branch m (a -> b)] -> [Branch m b]
forall a b. (a -> b) -> [a] -> [b]
map Branch m (a -> b) -> Branch m b
forall a. Branch m (a -> a) -> Branch m a
insert [Branch m (a -> b)]
fs)
  where
    first :: Branch m b
first = Permutation m (a -> b) -> m a -> Branch m b
forall (m :: * -> *) a b.
Permutation m (b -> a) -> m b -> Branch m a
Branch Permutation m (a -> b)
perm m a
p
    insert :: Branch m (a -> a) -> Branch m a
insert (Branch Permutation m (b -> a -> a)
perm' m b
p') = Permutation m (b -> a) -> m b -> Branch m a
forall (m :: * -> *) a b.
Permutation m (b -> a) -> m b -> Branch m a
Branch (Permutation m (a -> b -> a) -> a -> m a -> Permutation m (b -> a)
forall (m :: * -> *) a b.
Functor m =>
Permutation m (a -> b) -> a -> m a -> Permutation m b
addOpt (((b -> a -> a) -> a -> b -> a)
-> Permutation m (b -> a -> a) -> Permutation m (a -> b -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> a -> a) -> a -> b -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Permutation m (b -> a -> a)
perm') a
x m a
p) m b
p'