Ticket #1544: alt-read.hs

File alt-read.hs, 1.9 KB (added by jcpetruzza@…, 8 years ago)

Manual Read instance for Exp type

Line 
1import Test.QuickCheck
2
3import Control.Monad ( liftM, liftM2 )
4import Text.Read
5import GHC.Read ( paren )
6
7
8data Exp = C | N Exp | Exp :+: Exp | Exp :-: Exp deriving (Eq, Show)
9
10instance Read Exp where
11    readPrec = choice [do t <- prefixCons;     maybeInfixCons t,
12                       do t <- paren readPrec; maybeInfixCons t]
13        where prefixCons = choice [
14                                   do Ident "C" <- lexP; return C,
15                                   --
16                                  prec 10 $
17                                   do Ident "N" <- lexP
18                                      N `liftM` (step readPrec)
19                                  ]
20              --
21              maybeInfixCons t = first [prec 9 $ do Symbol ":+:" <- lexP
22                                                    t' <- step readPrec
23                                                    maybeInfixCons (t :+: t'),
24                                        --
25                                        prec 9 $ do Symbol ":-:" <- lexP
26                                                    t' <- step readPrec
27                                                    maybeInfixCons (t :-: t'),
28                                        --
29                                        return t]
30
31first :: [ReadPrec a] -> ReadPrec a
32first = foldr1 (<++)
33
34instance Arbitrary Exp where
35    arbitrary = sized arb
36        where arb 0 = return C
37              arb n = oneof [return C,
38                             N `liftM` resize (n-1) arbitrary,
39                             liftM2 (:+:) (halved arbitrary) (halved arbitrary),
40                             liftM2 (:-:) (halved arbitrary) (halved arbitrary)]
41                      where halved = resize (n `div` 2)
42    coarbitrary = undefined
43
44prop_readshow :: Exp -> Bool
45prop_readshow t = t == (read . show $ t)
46
47main = print (read "(((((((((((((((C)))))))))))))))" :: Exp)