{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Safe #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Parsec.Perm
-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007
-- License     :  BSD-style (see the file libraries/parsec/LICENSE)
--
-- Maintainer  :  derek.a.elkins@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable (uses existentially quantified data constructors)
--
-- This module implements permutation parsers. The algorithm used
-- is fairly complex since we push the type system to its limits :-)
-- 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.
--
-- From the abstract: 
--
-- A permutation phrase is a sequence of elements (possibly of different types) 
-- in which each element occurs exactly once and the order is irrelevant. 
-- Some of the permutable elements may be optional.
--
-----------------------------------------------------------------------------


module Text.Parsec.Perm
    ( PermParser
    , StreamPermParser -- abstract

    , permute
    , (<||>), (<$$>)
    , (<|?>), (<$?>)
    ) where

import Text.Parsec

import Control.Monad.Identity
#if MIN_VERSION_base(4,7,0)
import Data.Typeable ( Typeable )
#else
-- For GHC 7.6
import Data.Typeable ( Typeable3 )
#endif

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


{---------------------------------------------------------------
  test -- parse a permutation of
  * an optional string of 'a's
  * a required 'b'
  * an optional 'c'
---------------------------------------------------------------}
{-
test input
  = parse (do{ x <- ptest; eof; return x }) "" input

ptest :: Parser (String,Char,Char)
ptest
  = permute $
    (,,) <$?> ("",many1 (char 'a'))
         <||> char 'b'
         <|?> ('_',char 'c')
-}

{---------------------------------------------------------------
  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@.

(<||>) :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> Parsec s st a -> StreamPermParser s st b
<||> :: StreamPermParser s st (a -> b)
-> Parsec s st a -> StreamPermParser s st b
(<||>) StreamPermParser s st (a -> b)
perm Parsec s st a
p     = StreamPermParser s st (a -> b)
-> Parsec s st a -> StreamPermParser s st b
forall s tok st a b.
Stream s Identity tok =>
StreamPermParser s st (a -> b)
-> Parsec s st a -> StreamPermParser s st b
add StreamPermParser s st (a -> b)
perm Parsec s st a
p

-- | The expression @f \<$$> p@ creates a fresh permutation parser
-- consisting of parser @p@. The 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.

(<$$>) :: (Stream s Identity tok) => (a -> b) -> Parsec s st a -> StreamPermParser s st b
<$$> :: (a -> b) -> Parsec s st a -> StreamPermParser s st b
(<$$>) a -> b
f Parsec s st a
p        = (a -> b) -> StreamPermParser s st (a -> b)
forall s tok a b st.
Stream s Identity tok =>
(a -> b) -> StreamPermParser s st (a -> b)
newperm a -> b
f StreamPermParser s st (a -> b)
-> Parsec s st a -> StreamPermParser s st b
forall s tok st a b.
Stream s Identity tok =>
StreamPermParser s st (a -> b)
-> Parsec s st a -> StreamPermParser s st b
<||> Parsec s st a
p

-- | 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@.

(<|?>) :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> (a, Parsec s st a) -> StreamPermParser s st b
<|?> :: StreamPermParser s st (a -> b)
-> (a, Parsec s st a) -> StreamPermParser s st b
(<|?>) StreamPermParser s st (a -> b)
perm (a
x,Parsec s st a
p) = StreamPermParser s st (a -> b)
-> a -> Parsec s st a -> StreamPermParser s st b
forall s tok st a b.
Stream s Identity tok =>
StreamPermParser s st (a -> b)
-> a -> Parsec s st a -> StreamPermParser s st b
addopt StreamPermParser s st (a -> b)
perm a
x Parsec s st a
p

-- | The expression @f \<$?> (x,p)@ creates a fresh permutation parser
-- consisting of parser @p@. The 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.

(<$?>) :: (Stream s Identity tok) => (a -> b) -> (a, Parsec s st a) -> StreamPermParser s st b
<$?> :: (a -> b) -> (a, Parsec s st a) -> StreamPermParser s st b
(<$?>) a -> b
f (a
x,Parsec s st a
p)    = (a -> b) -> StreamPermParser s st (a -> b)
forall s tok a b st.
Stream s Identity tok =>
(a -> b) -> StreamPermParser s st (a -> b)
newperm a -> b
f StreamPermParser s st (a -> b)
-> (a, Parsec s st a) -> StreamPermParser s st b
forall s tok st a b.
Stream s Identity tok =>
StreamPermParser s st (a -> b)
-> (a, Parsec s st a) -> StreamPermParser s st b
<|?> (a
x,Parsec s st a
p)

{---------------------------------------------------------------
  The permutation tree
---------------------------------------------------------------}

-- | Provided for backwards compatibility.  The tok type is ignored.

type PermParser tok st a = StreamPermParser String st a

-- | The type @StreamPermParser s st a@ denotes a permutation parser that,
-- when converted by the 'permute' function, parses
-- @s@ streams with user state @st@ 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 StreamPermParser s st a = Perm (Maybe a) [StreamBranch s st a]
#if MIN_VERSION_base(4,7,0)
    deriving ( Typeable )
#else
deriving instance Typeable3 StreamPermParser
#endif

-- type Branch st a = StreamBranch String st a

data StreamBranch s st a = forall b. Branch (StreamPermParser s st (b -> a)) (Parsec s st b)
#if MIN_VERSION_base(4,7,0)
    deriving ( Typeable )
#else
deriving instance Typeable3 StreamBranch
#endif

-- | 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 <$?> ("",many1 (char 'a'))
-- >                         <||> char 'b'
-- >                         <|?> ('_',char 'c'))
-- >        where
-- >          tuple a b c  = (a,b,c)

-- transform a permutation tree into a normal parser
permute :: (Stream s Identity tok) => StreamPermParser s st a -> Parsec s st a
permute :: StreamPermParser s st a -> Parsec s st a
permute (Perm Maybe a
def [StreamBranch s st a]
xs)
  = [Parsec s st a] -> Parsec s st a
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ((StreamBranch s st a -> Parsec s st a)
-> [StreamBranch s st a] -> [Parsec s st a]
forall a b. (a -> b) -> [a] -> [b]
map StreamBranch s st a -> Parsec s st a
forall s tok st a.
Stream s Identity tok =>
StreamBranch s st a -> ParsecT s st Identity a
branch [StreamBranch s st a]
xs [Parsec s st a] -> [Parsec s st a] -> [Parsec s st a]
forall a. [a] -> [a] -> [a]
++ [Parsec s st a]
empty)
  where
    empty :: [Parsec s st a]
empty
      = case Maybe a
def of
          Maybe a
Nothing -> []
          Just a
x  -> [a -> Parsec s st a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x]

    branch :: StreamBranch s st a -> ParsecT s st Identity a
branch (Branch StreamPermParser s st (b -> a)
perm Parsec s st b
p)
      = do{ b
x <- Parsec s st b
p
          ; b -> a
f <- StreamPermParser s st (b -> a) -> Parsec s st (b -> a)
forall s tok st a.
Stream s Identity tok =>
StreamPermParser s st a -> Parsec s st a
permute StreamPermParser s st (b -> a)
perm
          ; a -> ParsecT s st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> a
f b
x)
          }

-- build permutation trees
newperm :: (Stream s Identity tok) => (a -> b) -> StreamPermParser s st (a -> b)
newperm :: (a -> b) -> StreamPermParser s st (a -> b)
newperm a -> b
f
  = Maybe (a -> b)
-> [StreamBranch s st (a -> b)] -> StreamPermParser s st (a -> b)
forall s st a.
Maybe a -> [StreamBranch s st a] -> StreamPermParser s st a
Perm ((a -> b) -> Maybe (a -> b)
forall a. a -> Maybe a
Just a -> b
f) []

add :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> Parsec s st a -> StreamPermParser s st b
add :: StreamPermParser s st (a -> b)
-> Parsec s st a -> StreamPermParser s st b
add perm :: StreamPermParser s st (a -> b)
perm@(Perm Maybe (a -> b)
_mf [StreamBranch s st (a -> b)]
fs) Parsec s st a
p
  = Maybe b -> [StreamBranch s st b] -> StreamPermParser s st b
forall s st a.
Maybe a -> [StreamBranch s st a] -> StreamPermParser s st a
Perm Maybe b
forall a. Maybe a
Nothing (StreamBranch s st b
firstStreamBranch s st b
-> [StreamBranch s st b] -> [StreamBranch s st b]
forall a. a -> [a] -> [a]
:(StreamBranch s st (a -> b) -> StreamBranch s st b)
-> [StreamBranch s st (a -> b)] -> [StreamBranch s st b]
forall a b. (a -> b) -> [a] -> [b]
map StreamBranch s st (a -> b) -> StreamBranch s st b
forall tok a.
Stream s Identity tok =>
StreamBranch s st (a -> a) -> StreamBranch s st a
insert [StreamBranch s st (a -> b)]
fs)
  where
    first :: StreamBranch s st b
first   = StreamPermParser s st (a -> b)
-> Parsec s st a -> StreamBranch s st b
forall s st a b.
StreamPermParser s st (b -> a)
-> Parsec s st b -> StreamBranch s st a
Branch StreamPermParser s st (a -> b)
perm Parsec s st a
p
    insert :: StreamBranch s st (a -> a) -> StreamBranch s st a
insert (Branch StreamPermParser s st (b -> a -> a)
perm' Parsec s st b
p')
            = StreamPermParser s st (b -> a)
-> Parsec s st b -> StreamBranch s st a
forall s st a b.
StreamPermParser s st (b -> a)
-> Parsec s st b -> StreamBranch s st a
Branch (StreamPermParser s st (a -> b -> a)
-> Parsec s st a -> StreamPermParser s st (b -> a)
forall s tok st a b.
Stream s Identity tok =>
StreamPermParser s st (a -> b)
-> Parsec s st a -> StreamPermParser s st b
add (((b -> a -> a) -> a -> b -> a)
-> StreamPermParser s st (b -> a -> a)
-> StreamPermParser s st (a -> b -> a)
forall s tok a b st.
Stream s Identity tok =>
(a -> b) -> StreamPermParser s st a -> StreamPermParser s st b
mapPerms (b -> a -> a) -> a -> b -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StreamPermParser s st (b -> a -> a)
perm') Parsec s st a
p) Parsec s st b
p'

addopt :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> a -> Parsec s st a -> StreamPermParser s st b
addopt :: StreamPermParser s st (a -> b)
-> a -> Parsec s st a -> StreamPermParser s st b
addopt perm :: StreamPermParser s st (a -> b)
perm@(Perm Maybe (a -> b)
mf [StreamBranch s st (a -> b)]
fs) a
x Parsec s st a
p
  = Maybe b -> [StreamBranch s st b] -> StreamPermParser s st b
forall s st a.
Maybe a -> [StreamBranch s st a] -> StreamPermParser s st a
Perm (((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) (StreamBranch s st b
firstStreamBranch s st b
-> [StreamBranch s st b] -> [StreamBranch s st b]
forall a. a -> [a] -> [a]
:(StreamBranch s st (a -> b) -> StreamBranch s st b)
-> [StreamBranch s st (a -> b)] -> [StreamBranch s st b]
forall a b. (a -> b) -> [a] -> [b]
map StreamBranch s st (a -> b) -> StreamBranch s st b
forall tok a.
Stream s Identity tok =>
StreamBranch s st (a -> a) -> StreamBranch s st a
insert [StreamBranch s st (a -> b)]
fs)
  where
    first :: StreamBranch s st b
first   = StreamPermParser s st (a -> b)
-> Parsec s st a -> StreamBranch s st b
forall s st a b.
StreamPermParser s st (b -> a)
-> Parsec s st b -> StreamBranch s st a
Branch StreamPermParser s st (a -> b)
perm Parsec s st a
p
    insert :: StreamBranch s st (a -> a) -> StreamBranch s st a
insert (Branch StreamPermParser s st (b -> a -> a)
perm' Parsec s st b
p')
            = StreamPermParser s st (b -> a)
-> Parsec s st b -> StreamBranch s st a
forall s st a b.
StreamPermParser s st (b -> a)
-> Parsec s st b -> StreamBranch s st a
Branch (StreamPermParser s st (a -> b -> a)
-> a -> Parsec s st a -> StreamPermParser s st (b -> a)
forall s tok st a b.
Stream s Identity tok =>
StreamPermParser s st (a -> b)
-> a -> Parsec s st a -> StreamPermParser s st b
addopt (((b -> a -> a) -> a -> b -> a)
-> StreamPermParser s st (b -> a -> a)
-> StreamPermParser s st (a -> b -> a)
forall s tok a b st.
Stream s Identity tok =>
(a -> b) -> StreamPermParser s st a -> StreamPermParser s st b
mapPerms (b -> a -> a) -> a -> b -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StreamPermParser s st (b -> a -> a)
perm') a
x Parsec s st a
p) Parsec s st b
p'


mapPerms :: (Stream s Identity tok) => (a -> b) -> StreamPermParser s st a -> StreamPermParser s st b
mapPerms :: (a -> b) -> StreamPermParser s st a -> StreamPermParser s st b
mapPerms a -> b
f (Perm Maybe a
x [StreamBranch s st a]
xs)
  = Maybe b -> [StreamBranch s st b] -> StreamPermParser s st b
forall s st a.
Maybe a -> [StreamBranch s st a] -> StreamPermParser s st a
Perm ((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) ((StreamBranch s st a -> StreamBranch s st b)
-> [StreamBranch s st a] -> [StreamBranch s st b]
forall a b. (a -> b) -> [a] -> [b]
map StreamBranch s st a -> StreamBranch s st b
forall s tok st.
Stream s Identity tok =>
StreamBranch s st a -> StreamBranch s st b
mapBranch [StreamBranch s st a]
xs)
  where
    mapBranch :: StreamBranch s st a -> StreamBranch s st b
mapBranch (Branch StreamPermParser s st (b -> a)
perm Parsec s st b
p)
      = StreamPermParser s st (b -> b)
-> Parsec s st b -> StreamBranch s st b
forall s st a b.
StreamPermParser s st (b -> a)
-> Parsec s st b -> StreamBranch s st a
Branch (((b -> a) -> b -> b)
-> StreamPermParser s st (b -> a) -> StreamPermParser s st (b -> b)
forall s tok a b st.
Stream s Identity tok =>
(a -> b) -> StreamPermParser s st a -> StreamPermParser s st b
mapPerms (a -> b
f(a -> b) -> (b -> a) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) StreamPermParser s st (b -> a)
perm) Parsec s st b
p