megaparsec/Text/MegaParsec/Perm.hs
2015-07-30 21:45:06 +06:00

135 lines
5.3 KiB
Haskell
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

-- |
-- Module : Text.MegaParsec.Perm
-- Copyright : © 19992001 Daan Leijen, © 2007 Paolo Martini, © 2015 MegaParsec contributors
-- License : BSD3
--
-- Maintainer : Mark Karpov <markkarpov@opmbx.org>
-- Stability : experimental
-- 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.
module Text.MegaParsec.Perm
( StreamPermParser -- abstract
, permute
, (<||>)
, (<$$>)
, (<|?>)
, (<$?>) )
where
import Control.Monad.Identity
import Text.MegaParsec
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@.
(<||>) :: Stream s Identity tok => StreamPermParser s st (a -> b) ->
Parsec s st a -> StreamPermParser s st b
(<||>) = add
-- | 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
f <$$> p = newperm f <||> 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
perm <|?> (x, p) = addopt perm x 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
f <$?> xp = newperm f <|?> xp
-- The permutation tree
-- | 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]
data StreamBranch s st a =
forall b. Branch (StreamPermParser s st (b -> a)) (Parsec s st b)
-- | 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 (Perm def xs) = choice (fmap branch xs ++ empty)
where empty = case def of
Nothing -> []
Just x -> [return x]
branch (Branch perm p) = (flip ($)) <$> p <*> permute perm
-- Build permutation trees
newperm :: Stream s Identity tok => (a -> b) -> StreamPermParser s st (a -> b)
newperm f = Perm (Just f) []
add :: Stream s Identity tok => StreamPermParser s st (a -> b) ->
Parsec s st a -> StreamPermParser s st b
add perm@(Perm _mf fs) p = Perm Nothing (first : fmap insert fs)
where first = Branch perm p
insert (Branch perm' p') = Branch (add (mapPerms flip perm') p) p'
addopt :: Stream s Identity tok => StreamPermParser s st (a -> b) ->
a -> Parsec s st a -> StreamPermParser s st b
addopt perm@(Perm mf fs) x p
= Perm (fmap ($ x) mf) (first:map insert fs)
where first = Branch perm p
insert (Branch perm' p') = Branch (addopt (mapPerms flip perm') x p) p'
mapPerms :: Stream s Identity tok => (a -> b) ->
StreamPermParser s st a -> StreamPermParser s st b
mapPerms f (Perm x xs) = Perm (fmap f x) (map mapBranch xs)
where mapBranch (Branch perm p) = Branch (mapPerms (f.) perm) p