3a_asm/Text/Parsec/Perm.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Text.Parsec.Perm
   4 -- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007
   5 -- License     :  BSD-style (see the file libraries/parsec/LICENSE)
   6 --
   7 -- Maintainer  :  derek.a.elkins@gmail.com
   8 -- Stability   :  provisional
   9 -- Portability :  non-portable (uses existentially quantified data constructors)
  10 --
  11 -- This module implements permutation parsers. The algorithm used
  12 -- is fairly complex since we push the type system to its limits :-)
  13 -- The algorithm is described in:
  14 --
  15 -- /Parsing Permutation Phrases,/
  16 -- by Arthur Baars, Andres Loh and Doaitse Swierstra.
  17 -- Published as a functional pearl at the Haskell Workshop 2001.
  18 --
  19 -----------------------------------------------------------------------------
  20
  21 {-# LANGUAGE ExistentialQuantification #-}
  22
  23 module Text.Parsec.Perm
  24     ( PermParser
  25     , StreamPermParser -- abstract
  26
  27     , permute
  28     , (<||>), (<$$>)
  29     , (<|?>), (<$?>)
  30     ) where
  31
  32 import Text.Parsec
  33
  34 import Control.Monad.Identity
  35
  36 infixl 1 <||>, <|?>
  37 infixl 2 <$$>, <$?>
  38
  39
  40 {---------------------------------------------------------------
  41   test -- parse a permutation of
  42   * an optional string of 'a's
  43   * a required 'b'
  44   * an optional 'c'
  45 ---------------------------------------------------------------}
  46 {-
  47 test input
  48   = parse (do{ x <- ptest; eof; return x }) "" input
  49
  50 ptest :: Parser (String,Char,Char)
  51 ptest
  52   = permute $
  53     (,,) <$?> ("",many1 (char 'a'))
  54          <||> char 'b'
  55          <|?> ('_',char 'c')
  56 -}
  57
  58 {---------------------------------------------------------------
  59   Building a permutation parser
  60 ---------------------------------------------------------------}
  61
  62 -- | The expression @perm \<||> p@ adds parser @p@ to the permutation
  63 -- parser @perm@. The parser @p@ is not allowed to accept empty input -
  64 -- use the optional combinator ('<|?>') instead. Returns a
  65 -- new permutation parser that includes @p@.
  66
  67 (<||>) :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> Parsec s st a -> StreamPermParser s st b
  68 (<||>) perm p     = add perm p
  69
  70 -- | The expression @f \<$$> p@ creates a fresh permutation parser
  71 -- consisting of parser @p@. The the final result of the permutation
  72 -- parser is the function @f@ applied to the return value of @p@. The
  73 -- parser @p@ is not allowed to accept empty input - use the optional
  74 -- combinator ('<$?>') instead.
  75 --
  76 -- If the function @f@ takes more than one parameter, the type variable
  77 -- @b@ is instantiated to a functional type which combines nicely with
  78 -- the adds parser @p@ to the ('<||>') combinator. This
  79 -- results in stylized code where a permutation parser starts with a
  80 -- combining function @f@ followed by the parsers. The function @f@
  81 -- gets its parameters in the order in which the parsers are specified,
  82 -- but actual input can be in any order.
  83
  84 (<$$>) :: (Stream s Identity tok) => (a -> b) -> Parsec s st a -> StreamPermParser s st b
  85 (<$$>) f p        = newperm f <||> p
  86
  87 -- | The expression @perm \<||> (x,p)@ adds parser @p@ to the
  88 -- permutation parser @perm@. The parser @p@ is optional - if it can
  89 -- not be applied, the default value @x@ will be used instead. Returns
  90 -- a new permutation parser that includes the optional parser @p@.
  91
  92 (<|?>) :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> (a, Parsec s st a) -> StreamPermParser s st b
  93 (<|?>) perm (x,p) = addopt perm x p
  94
  95 -- | The expression @f \<$?> (x,p)@ creates a fresh permutation parser
  96 -- consisting of parser @p@. The the final result of the permutation
  97 -- parser is the function @f@ applied to the return value of @p@. The
  98 -- parser @p@ is optional - if it can not be applied, the default value
  99 -- @x@ will be used instead.
 100
 101 (<$?>) :: (Stream s Identity tok) => (a -> b) -> (a, Parsec s st a) -> StreamPermParser s st b
 102 (<$?>) f (x,p)    = newperm f <|?> (x,p)
 103
 104 {---------------------------------------------------------------
 105   The permutation tree
 106 ---------------------------------------------------------------}
 107
 108 -- | Provided for backwards compatibility.  The tok type is ignored.
 109
 110 type PermParser tok st a = StreamPermParser String st a
 111
 112 -- | The type @StreamPermParser s st a@ denotes a permutation parser that,
 113 -- when converted by the 'permute' function, parses
 114 -- @s@ streams with user state @st@ and returns a value of
 115 -- type @a@ on success.
 116 --
 117 -- Normally, a permutation parser is first build with special operators
 118 -- like ('<||>') and than transformed into a normal parser
 119 -- using 'permute'.
 120
 121 data StreamPermParser s st a = Perm (Maybe a) [StreamBranch s st a]
 122
 123 -- type Branch st a = StreamBranch String st a
 124
 125 data StreamBranch s st a = forall b. Branch (StreamPermParser s st (b -> a)) (Parsec s st b)
 126
 127 -- | The parser @permute perm@ parses a permutation of parser described
 128 -- by @perm@. For example, suppose we want to parse a permutation of:
 129 -- an optional string of @a@'s, the character @b@ and an optional @c@.
 130 -- This can be described by:
 131 --
 132 -- >  test  = permute (tuple <$?> ("",many1 (char 'a'))
 133 -- >                         <||> char 'b'
 134 -- >                         <|?> ('_',char 'c'))
 135 -- >        where
 136 -- >          tuple a b c  = (a,b,c)
 137
 138 -- transform a permutation tree into a normal parser
 139 permute :: (Stream s Identity tok) => StreamPermParser s st a -> Parsec s st a
 140 permute (Perm def xs)
 141   = choice (map branch xs ++ empty)
 142   where
 143     empty
 144       = case def of
 145           Nothing -> []
 146           Just x  -> [return x]
 147
 148     branch (Branch perm p)
 149       = do{ x <- p
 150           ; f <- permute perm
 151           ; return (f x)
 152           }
 153
 154 -- build permutation trees
 155 newperm :: (Stream s Identity tok) => (a -> b) -> StreamPermParser s st (a -> b)
 156 newperm f
 157   = Perm (Just f) []
 158
 159 add :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> Parsec s st a -> StreamPermParser s st b
 160 add perm@(Perm _mf fs) p
 161   = Perm Nothing (first:map insert fs)
 162   where
 163     first   = Branch perm p
 164     insert (Branch perm' p')
 165             = Branch (add (mapPerms flip perm') p) p'
 166
 167 addopt :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> a -> Parsec s st a -> StreamPermParser s st b
 168 addopt perm@(Perm mf fs) x p
 169   = Perm (fmap ($ x) mf) (first:map insert fs)
 170   where
 171     first   = Branch perm p
 172     insert (Branch perm' p')
 173             = Branch (addopt (mapPerms flip perm') x p) p'
 174
 175
 176 mapPerms :: (Stream s Identity tok) => (a -> b) -> StreamPermParser s st a -> StreamPermParser s st b
 177 mapPerms f (Perm x xs)
 178   = Perm (fmap f x) (map mapBranch xs)
 179   where
 180     mapBranch (Branch perm p)
 181       = Branch (mapPerms (f.) perm) p