[Haskell-cafe] Re: a boring parser

[Anatoly Yakovenko]

so whats pretty cool is that I can traverse arbitrary data structures as  well:

data Tree a = Tree (Tree a) a (Tree a) | Bottom
            deriving Show

left a = do
   make $ \ st -> do
      case(st) of
         (Bottom) -> eos
         (Tree left val right) ->
            case (a < val) of
               True -> return $ (val, left)
               False -> noMatch

right a = do
   make $ \ st -> do
      case(st) of
         (Bottom) -> eos
         (Tree left val right) ->
            case (a > val) of
               True -> return $ (val, right)
               False -> noMatch

eqT a = do
   make $ \ st -> do
      case(st) of
         (Bottom) -> eos
         (Tree _ val _) ->
            case (a == val) of
               True -> return $ (val, st)
               False -> noMatch

search a = manyTill (left a <|> right a) (eqT a)

> run (search 5) $ Tree (Tree Bottom 1 Bottom) 3 (Tree Bottom 5 Bottom)
Right (([3],5),Tree Bottom 5 Bottom)



On Wed, Sep 30, 2009 at 8:04 PM, Anatoly Yakovenko
<aeyakovenko at gmail.com> wrote:
> i got annoyed with Parsec and wrote a much more boring parser which
> allows me to parse anything with any kind of matching i want.  Its
> basically a combination of State and Error monads.
>
> So i can use a grep like parser that matches via a regular expression
> over a list of lines
>
> grep re = do
>   vv::B.ByteString <- any
>   let (_,_,_,rv) = (vv =~
> re)::(B.ByteString,B.ByteString,B.ByteString,[B.ByteString])
>   case (rv) of
>      [] -> throwError "no match"
>      _ -> return $ rv
>
>> run (grep $ C.pack "(hello)") $ [C.pack "hello world"]
> Right (["hello"],[])
>
> or use the same library to scan over a string by combining regular expressions
>
> regex re = do
>   make $ \ st -> do
>      case (B.null st) of
>         True -> throwError "eos"
>         _ -> do
>            let (_,_,after,rv) = (st =~
> re)::(B.ByteString,B.ByteString,B.ByteString,[B.ByteString])
>            case (rv) of
>               [] -> throwError "no match"
>               _ -> return $ (rv,after)
>
>
>
>>  run (do aa <- regex $ C.pack "(hello)"; bb <- regex $ C.pack " (world)"; return (aa,bb) ) $ C.pack "hello world"
> Right ((["hello"],["world"]),"")
>
> or simply match integers in a list, or anything that is of type Eq
>
>> run (many1 $ eq 1) [1,1,1,2,3,4]
> Right ([1,1,1],[2,3,4])
>
> i can define lt
>
> lt cc = do
>   vv <- any
>   case (vv < cc) of
>      True -> return $ vv
>      _ -> throwError "no match"
>
> and do
>
>> run (many1 $ lt 5 <|> eq 5) [1..10]
> Right ([1,2,3,4,5],[6,7,8,9,10])
>
> here is the implementation
>
> module Parser( ParserM     --type alias for the parser ParserM a b is
> over "stream" a and returns b
>             , make        --makes a parser from a matching function of
> type :: stream -> m (match_data,stream)
>                           --for example any is implemented via:
>                           --any :: ParserM [a] a
>                           --any = make $ \ ll ->
>                           --   case (ll) of
>                           --         (hh:tt) -> return $ (hh,tt)
>                           --               _ -> throwError "eos
>                           --matches and returns an element from a
> list, which makes any of type :: ParserM [a] a
>             , any         --matches any element from [a] type stream
>             , eq          --matches an equal element from [Eq] stream,
> trivialy implemented in terms of any
>                           --eq :: Eq a => a -> ParserM [a] a
>                           --eq cc = do
>                           --   vv <- any
>                           --   case (vv == cc) of
>                           --      True -> return $ vv
>                           --         _ -> throwError "no match
>             , (<|>)       --or operator, tries the left one then the right one
>             , manyTill    --collects the results of parser 1 until
> parser 2 succeeds
>             , many1       --collects the results of the parser, must
> succeed at least once
>             , many        --collects the results of a parser
>             , run         --runs the parser
>             ) where
>
> import Control.Monad.State.Lazy
> import Control.Monad.Error
> import Test.QuickCheck
> import Control.Monad.Identity
> import Prelude hiding (any)
>
> type ParserM a c = StateT a (ErrorT [Char] Identity) c
>
> make pp = do
>   st <- get
>   (rv,nst) <- pp $ st
>   put $ nst
>   return $ rv
>
> aa <|> bb = aa `catchError` \ _ -> bb
>
> manyTill :: ParserM a c -> ParserM a d -> ParserM a ([c],d)
> manyTill pp ee = do
>   do dd <- ee
>      return $ ([],dd)
>   `catchError` \ _ -> do
>      cc <- pp
>      (ccs,dd) <- manyTill pp ee
>      return $ (cc:ccs,dd)
>
> many1 pp = do
>   rv <- pp
>   rest <- many1 pp `catchError` \ _ -> return $ []
>   return $ rv : rest
>
> many pp = do many1 pp
>         <|> return []
>
>
> any :: ParserM [a] a
> any = make $ \ ll ->
>   case (ll) of
>      (hh:tt) -> return $ (hh,tt)
>      _ -> throwError "eos"
>
> eq :: Eq a => a -> ParserM [a] a
> eq cc = do
>   vv <- any
>   case (vv == cc) of
>      True -> return $ vv
>      _ -> throwError "no match"
>
> lt cc = do
>   vv <- any
>   case (vv < cc) of
>      True -> return $ vv
>      _ -> throwError "no match"
>
> run pp dd = runIdentity $ runErrorT $ runStateT pp dd
> run' = flip run
>
>
> prop_MatchA = (Right ('a',"bc")) == (run' "abc" $ eq 'a')
> prop_MatchEOS = (Left "eos") == (run' ""  $ eq 'a')
> prop_MatchNoMatch = (Left "no match") == (run' ("bcd") $ eq 'a')
>
> prop_MatchABC =(Right ('c',""))== (run' "abc" $ do  eq 'a'
>                                                    eq 'b'
>                                                    eq 'c')
>
> prop_MatchA_C = (run' "abc" $ do eq 'a'
>                                 eq 'd' <|> eq 'b' <|> any
>                                 eq 'c') == (Right ('c',""))
>
> prop_Or =      (run' "abc" $ do { eq 'a'
>                                ; do     { eq 'b'
>                                         ; eq 'd'
>                                         }
>                                  <|> do { eq 'b'
>                                         ; eq 'c'
>                                         }
>                                }) == (Right ('c',""))
>
> prop_UntilC = (Right (("",'c'),"")) == (run' ("c") $ manyTill any $ eq 'c')
>
> prop_Until1 ls =
>   let rv = run' (ls ++ [1]) $ manyTill any $ eq 1
>   in case (rv) of
>      Right ((ls,1),rest) -> (elem 1 ls) == False
>      _ -> False
>
> prop_all1 ls =
>   let rv = run' ([1,1,1] ++ ls) $ many1 $ eq 1
>   in case (rv) of
>      Right (_,(1:_)) -> False
>      Right ((1:1:1:_),_) -> True
>      _ -> False
>