Kapitel 6: Programmiertechniken

hugs Read
ghc -c Read.lhs

> module Read
> where

> data Tree lab                 =  Empty | Node (Tree lab) lab (Tree lab)

< type ReadS a                  =  String -> [(a, String)]

< lex                           ::  ReadS String

> readsTree                     :: (Read a) => ReadS (Tree a)
> readsTree s                   =  [ (Empty, x) | ("Empty", x) <- lex s ]
>                               ++ [ (Node l a r, y)
>                                  | ("(",    t) <- lex s,
>                                    ("Node", u) <- lex t,
>                                    (l,      v) <- readsTree u,
>                                    (a,      w) <- reads v,
>                                    (r,      x) <- readsTree w,
>                                    (")",    y) <- lex x ]

> readsTreePrec                 :: (Read a) => Int -> ReadS (Tree a)
> readsTreePrec d s             =  readParen False readEmpty s
>                               ++ readParen (d >= 10) readNode s
>     where
>     readEmpty s               =  [ (Empty, x) | ("Empty", x) <- lex s ]
>     readNode s                =  [ (Node l a r, x)
>                                  | ("Node", u) <- lex s,
>                                    (l,      v) <- readsTreePrec 10 u,
>                                    (a,      w) <- reads v,
>                                    (r,      x) <- readsTreePrec 10 w ]

< readParen                     :: Bool -> ReadS a -> ReadS a
< readParen b g                 =  if b then mandatory else optional
<     where optional r          =  g r ++ mandatory r
<           mandatory r         =  [ (x,u) | ("(", s) <- lex r,
<                                            (x,   t) <- optional s,
<                                            (")", u) <- lex t    ]

< class Read a where 
<     readsPrec                 :: Int -> ReadS a
<     readList                  :: ReadS [a]
<
<     readList                  =  readParen False (\r ->
<                                  [ pr | ("[", s) <- lex r,
<                                         pr       <- readl s ])
<         where
<         readl s               =  [ ([], t)     | ("]", t) <- lex s ]
<                               ++ [ (x : xs, u) | (x, t)   <- reads s,
<                                          (xs, u)  <- readl' t ]
<         readl' s              =  [ ([], t)    | ("]", t) <- lex s]
<                               ++ [ (x : xs,v) | (",", t) <- lex s,
<                                                 (x,   u) <- reads t,
<                                                 (xs,  v) <- readl' u ]

> instance (Read a) => Read (Tree a) where
>     readsPrec d s             =  readParen False readEmpty s
>                               ++ readParen (d >= 10) readNode s
>         where
>         readEmpty s           =  [ (Empty, x) | ("Empty", x) <- lex s ]
>         readNode s            =  [ (Node l a r, x)
>                                  | ("Node", u) <- lex s,
>                                    (l,      v) <- readsPrec 10 u,
>                                    (a,      w) <- reads v,
>                                    (r,      x) <- readsPrec 10 w ]