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

[Andrew Coppin]

-- This is probably line-wrapped horribly...



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}

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



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

instance (Source src) => Monad (Process st src 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 src x st
get_state = Process(\ps -> (state ps, ps))

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

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

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

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



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

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

many :: (Source src) => Process st src x y -> Process st src 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 src 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 :: (Source src0) => st0 -> Process st0 src0 x [y] -> st1 -> 
Process st1 (Stack st0 src0 x) y z -> Process st9 src0 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})
    )


-- If you want something to test with...

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 :: (Source src, Integral x) => Process st src 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]