1 module Parse
    2       (Parse, Parses,                       --  data types
    3        thenP, returnP, eachP, consP,                  --  sequencing and success
    4        elseP, failP, guardP, filterP,                 --  alternation and failure
    5        starP, plusP, cutP,                            --  repetition and cut
    6        endP, itemP, litP, litsP, exactlyP,            --  end, next item, and literals
    7        spacesP, lexP, lexicalP, lexactlyP,            --  spaces and lexemes
    8        asciiP, controlP, printP, spaceP,              --  character parsers
    9        alphaP, upperP, lowerP, digitP, alphanumP,
   10        surroundP, plusSepP, starSepP, parenP, listP,  --  surrounds and separators
   11        useP)                                          --  using a parser      
   12       where
   13 
   14 import Char -- 1.3
   15 
   16 #if __HASKELL1__ < 5
   17 #define isAlphaNum isAlphanum
   18 #endif
   19 
   20 infixr 1      `elseP`
   21 infix  2      `thenP`
   22 infix  2      `eachP`
   23 infixr 3      `filterP`
   24 infixr 3      `guardP`
   25 type Parse a x  =  a -> [(x, a)]
   26 type Parses x  =  Parse String x
   27 thenP         :: Parse a x -> (x -> Parse a y) -> Parse a y
   28 xP `thenP` kP =  \a -> [ (y,c) | (x,b) <- xP a, (y,c) <- kP x b ]
   29 returnP       :: x -> Parse a x
   30 returnP x     =  \a -> [ (x,a) ]
   31 eachP         :: Parse a x -> (x -> y) -> Parse a y
   32 xP `eachP` f  =  xP `thenP` (\x -> returnP (f x))
   33 consP           :: Parse a x -> Parse a [x] -> Parse a [x]
   34 xP `consP` xsP  =  xP   `thenP` (\x ->
   35                    xsP  `thenP` (\xs ->
   36                         returnP (x:xs)))
   37 elseP         :: Parse a x -> Parse a x -> Parse a x
   38 xP `elseP` yP =  \a -> xP a ++ yP a
   39 failP         :: Parse a x
   40 failP         =  \a -> []
   41 guardP        :: Bool -> Parse a x -> Parse a x
   42 guardP b xP   =  if  b  then  xP  else  failP
   43 filterP       :: (x -> Bool) -> Parse a x -> Parse a x
   44 filterP p xP  =  xP `thenP` (\x -> p x `guardP` returnP x)
   45 starP         :: Parse a x -> Parse a [x]
   46 starP xP      =  cutP (plusP xP `elseP` returnP [])
   47 plusP         :: Parse a x -> Parse a [x]
   48 plusP xP      =  xP `consP` starP xP
   49 cutP          :: Parse a x -> Parse a x
   50 cutP xP       =  \a -> case  xP a  of  { ~(~(x,b):_) -> [(x,b)] }
   51 endP          :: Parse [x] ()
   52 endP          =  \xs -> if  null xs  then  returnP () xs  else  failP xs
   53 itemP         :: Parse [x] x
   54 itemP         =  \xs -> if  null xs  then  failP xs
   55                                      else  returnP (head xs) (tail xs)
   56 litP          :: (Eq x) => x -> Parse [x] x
   57 litP c        =  (\x -> c==x) `filterP` itemP
   58 litsP         :: (Eq x) => [x] -> Parse [x] [x]
   59 litsP []      =  returnP []
   60 litsP (c:cs)  =  litP c `consP` litsP cs
   61 exactlyP      :: Parse [y] x -> Parse [y] x
   62 exactlyP xP   =  xP `thenP` (\x -> endP `thenP` (\() -> returnP x))
   63 spacesP       :: Parses String
   64 spacesP       =  starP spaceP
   65 lexicalP      :: Parses x -> Parses x
   66 lexicalP xP   =  xP `thenP` (\x -> spacesP `thenP` (\_ -> returnP x))
   67 lexP          :: String -> Parses String
   68 lexP cs       =  lexicalP (litsP cs)
   69 lexactlyP     :: Parses x -> Parses x
   70 lexactlyP xP  =  spacesP `thenP` (\_ -> exactlyP xP)
   71 asciiP, controlP, printP, spaceP, upperP      :: Parses Char
   72 lowerP, alphaP, digitP, alphanumP             :: Parses Char
   73 asciiP        =  isAscii    `filterP` itemP
   74 controlP      =  isControl  `filterP` itemP
   75 printP        =  isPrint    `filterP` itemP
   76 spaceP        =  isSpace    `filterP` itemP
   77 upperP        =  isUpper    `filterP` itemP
   78 lowerP        =  isLower    `filterP` itemP
   79 alphaP        =  isAlpha    `filterP` itemP
   80 digitP        =  isDigit    `filterP` itemP
   81 alphanumP     =  isAlphaNum `filterP` itemP
   82 surroundP             :: String -> Parses x -> String -> Parses x
   83 surroundP l xP r      =  lexP l       `thenP` (\_ ->
   84                          xP           `thenP` (\x ->
   85                          lexP r       `thenP` (\_ ->
   86                                       returnP x)))
   87 plusSepP              :: String -> Parses x -> Parses [x]
   88 plusSepP s xP         =  xP `consP` starP (lexP s `thenP` (\_ -> xP))
   89 starSepP              :: String -> Parses x -> Parses [x]
   90 starSepP s xP         =  plusSepP s xP `elseP` returnP []
   91 parenP                :: Parses x -> Parses x
   92 parenP xP             =  surroundP "(" xP ")"
   93 listP                 :: Parses x -> Parses [x]
   94 listP xP              =  surroundP "[" (starSepP "," xP) "]"
   95 useP          :: x -> Parse a x -> (a -> x)
   96 useP failx xP =  \a -> case  xP a  of { [] -> failx; ((x,_):_) -> x }