Ticket #1544: alt-read.hs

import Test.QuickCheck

import Control.Monad ( liftM, liftM2 )
import Text.Read
import GHC.Read ( paren )


data Exp = C | N Exp | Exp :+: Exp | Exp :-: Exp deriving (Eq, Show)

instance Read Exp where
    readPrec = choice [do t <- prefixCons;     maybeInfixCons t,
                       do t <- paren readPrec; maybeInfixCons t]
        where prefixCons = choice [
                                   do Ident "C" <- lexP; return C,
                                   --
                                  prec 10 $
                                   do Ident "N" <- lexP
                                      N `liftM` (step readPrec)
                                  ]
              --
              maybeInfixCons t = first [prec 9 $ do Symbol ":+:" <- lexP
                                                    t' <- step readPrec
                                                    maybeInfixCons (t :+: t'),
                                        --
                                        prec 9 $ do Symbol ":-:" <- lexP
                                                    t' <- step readPrec
                                                    maybeInfixCons (t :-: t'),
                                        --
                                        return t]

first :: [ReadPrec a] -> ReadPrec a
first = foldr1 (<++)

instance Arbitrary Exp where
    arbitrary = sized arb
        where arb 0 = return C
              arb n = oneof [return C,
                             N `liftM` resize (n-1) arbitrary,
                             liftM2 (:+:) (halved arbitrary) (halved arbitrary),
                             liftM2 (:-:) (halved arbitrary) (halved arbitrary)]
                      where halved = resize (n `div` 2)
    coarbitrary = undefined

prop_readshow :: Exp -> Bool
prop_readshow t = t == (read . show $ t)

main = print (read "(((((((((((((((C)))))))))))))))" :: Exp)