Text/ParserCombinators/Parsec/Perm.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Text.ParserCombinators.Parsec.Perm
   4 -- Copyright   :  (c) Daan Leijen 1999-2001
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  daan@cs.uu.nl
   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 module Text.ParserCombinators.Parsec.Perm
  22                   ( PermParser  -- abstract
  23
  24                   , permute
  25                   , (<||>), (<$$>)
  26                   , (<|?>), (<$?>)
  27                   ) where
  28
  29 import Text.ParserCombinators.Parsec
  30
  31 {---------------------------------------------------------------
  32
  33 ---------------------------------------------------------------}
  34 infixl 1 <||>, <|?>
  35 infixl 2 <$$>, <$?>
  36
  37
  38 {---------------------------------------------------------------
  39   test -- parse a permutation of
  40   * an optional string of 'a's
  41   * a required 'b'
  42   * an optional 'c'
  43 ---------------------------------------------------------------}
  44 test input
  45   = parse (do{ x <- ptest; eof; return x }) "" input
  46
  47 ptest :: Parser (String,Char,Char)
  48 ptest
  49   = permute $
  50     (,,) <$?> ("",many1 (char 'a'))
  51          <||> char 'b'
  52          <|?> ('_',char 'c')
  53
  54
  55 {---------------------------------------------------------------
  56   Building a permutation parser
  57 ---------------------------------------------------------------}
  58 (<||>) :: PermParser tok st (a -> b) -> GenParser tok st a -> PermParser tok st b
  59 (<||>) perm p     = add perm p
  60 (<$$>) f p        = newperm f <||> p
  61
  62 (<|?>) perm (x,p) = addopt perm x p
  63 (<$?>) f (x,p)    = newperm f <|?> (x,p)
  64
  65
  66
  67 {---------------------------------------------------------------
  68   The permutation tree
  69 ---------------------------------------------------------------}
  70 data PermParser tok st a = Perm (Maybe a) [Branch tok st a]
  71 data Branch tok st a     = forall b. Branch (PermParser tok st (b -> a)) (GenParser tok st b)
  72
  73
  74 -- transform a permutation tree into a normal parser
  75 permute :: PermParser tok st a -> GenParser tok st a
  76 permute (Perm def xs)
  77   = choice (map branch xs ++ empty)
  78   where
  79     empty
  80       = case def of
  81           Nothing -> []
  82           Just x  -> [return x]
  83
  84     branch (Branch perm p)
  85       = do{ x <- p
  86           ; f <- permute perm
  87           ; return (f x)
  88           }
  89
  90 -- build permutation trees
  91 newperm :: (a -> b) -> PermParser tok st (a -> b)
  92 newperm f
  93   = Perm (Just f) []
  94
  95 add :: PermParser tok st (a -> b) -> GenParser tok st a -> PermParser tok st b
  96 add perm@(Perm mf fs) p
  97   = Perm Nothing (first:map insert fs)
  98   where
  99     first   = Branch perm p
 100     insert (Branch perm' p')
 101             = Branch (add (mapPerms flip perm') p) p'
 102
 103 addopt :: PermParser tok st (a -> b) -> a -> GenParser tok st a -> PermParser tok st b
 104 addopt perm@(Perm mf fs) x p
 105   = Perm (fmap ($ x) mf) (first:map insert fs)
 106   where
 107     first   = Branch perm p
 108     insert (Branch perm' p')
 109             = Branch (addopt (mapPerms flip perm') x p) p'
 110
 111
 112 mapPerms :: (a -> b) -> PermParser tok st a -> PermParser tok st b
 113 mapPerms f (Perm x xs)
 114   = Perm (fmap f x) (map (mapBranch f) xs)
 115   where
 116     mapBranch f (Branch perm p)
 117       = Branch (mapPerms (f.) perm) p