[Haskell-cafe] A very nontrivial parser [Source code]
Jonathan Cast
jcast at ou.edu
Thu Jul 5 17:36:58 EDT 2007
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
More information about the Haskell-Cafe
mailing list