[Haskell-cafe] A very nontrivial parser [Source code]

[Jonathan Cast]

On Thursday 05 July 2007, Andrew Coppin wrote:
<snip>

This version works (I think).  Also, using this syntax may make the 
distinction between existential constructors and rank-2 constructors a little 
clearer.

*AlgoRLE> run decodeRLEb1 $ start () $ encodeRLEb [1, 2, 3]
([1],PState {state = (), source = [2,3]})

--- Process.hs ---

{-# LANGUAGE Rank2Types #-}

module Process
    (
      Source (..),
      PState (), start,
      Process (run),
      get_state, set_state, alt_state,
      get, eof,
      pure, count, many,
      stack
    )
  where

class Source src where
  empty :: src x -> Bool
  fetch :: src x -> (x, src x)

instance Source [] where
  empty = null
  fetch xs = (head xs, tail xs)

data PState st src x = PState {state :: st, source :: src x}
  deriving (Eq, Ord, Show)

start :: (Source src) => st -> src x -> PState st src x
start = PState

data Process st x y
  = Process {run :: forall src. Source src => PState st src x ->
                                (y, PState st src x)}

instance Monad (Process st x) where
  return x = Process (\ps -> (x, ps))
  p >>=  f = Process (\ps -> let (y, xs) = run p ps in run (f y) xs)

get_state :: Process st x st
get_state = Process(\ps -> (state ps, ps))

set_state :: st -> Process st x ()
set_state st = Process (\ps -> ((), ps {state = st}))

alt_state :: (st -> st) -> Process st x ()
alt_state f = do
  st <- get_state
  set_state (f st)

get :: Process st x x
get = Process (\ps -> let (x,xs) = fetch (source ps)
                      in (x, ps {source = xs}))

eof :: Process st x Bool
eof = Process (\ps -> (empty (source ps), ps))



pure :: (x -> y) -> Process st x y
pure f = do
  x <- get
  return (f x)

count :: (Integral n) => n -> Process st x y -> Process st x [y]
count 0 _ = return []
count n p = do
  y  <- p
  ys <- count (n-1) p
  return (y:ys)

many :: Process st x y -> Process st x [y]
many p = do
  end <- eof
  if end
    then return []
    else do
      y  <- p
      ys <- many p
      return (y:ys)

data Stack st src x y = Stack {
  pstate :: PState st src x,
  pro :: Process st x [y], buffer :: [y]}

instance (Source src) => Source (Stack st src x) where
  empty stack = empty $ source $ pstate stack
  fetch stack
    | empty (buffer stack) = let (ys,xs) = run (pro stack) (pstate stack)
                             in fetch (stack {pstate = xs, buffer = ys})
    | otherwise            = let (y, ys) = fetch (buffer stack)
                             in (y, stack {buffer = ys})

stack :: st0 -> Process st0 x [y] -> st1 -> Process st1 y z -> Process st9 x z
stack st0 p0 st1 p1 =
  Process
    (\ps ->
      let
        ps0  = PState {state = st0, source = source ps}
        ps1  = PState {state = st1, source = src1}
        src1 = Stack  {pstate = ps0, pro = p0, buffer = []}
        (z, ys) = run p1 ps1
      in (z, ps {source = source $ pstate $ source ys})
    )

--- AlgoRLE.hs ---

module AlgoRLE where

import Data.List
import Process

encodeRLE :: (Eq x, Integral n) => [x] -> [(n,x)]
encodeRLE = map (\xs -> (genericLength xs, head xs)) . group

decodeRLE :: (Integral n) => [(n,x)] -> [x]
decodeRLE = concatMap (uncurry genericReplicate)


encodeRLEb :: (Integral x) => [x] -> [x]
encodeRLEb = concatMap work . encodeRLE
  where
    work (1,0)    = [0,0]
    work (n,0)    = [0,n-1,0]
    work (n,x)
      | n >  3    = [0,n-1,x]
      | otherwise = genericReplicate n x

decodeRLEb :: (Integral x) => [x] -> [x]
decodeRLEb = concat . fst . run (many decodeRLEb1) . start ()

decodeRLEb1 :: (Integral x) => Process st x [x]
decodeRLEb1 = do
  v <- get
  if v == 0
    then do
      n <- get
      if n == 0
        then return [0,0]
        else do
          x <- get
          return $ genericReplicate (n+1) x
    else return [v]

Jonathan Cast
http://sourceforge.net/projects/fid-core
http://sourceforge.net/projects/fid-emacs