(exercise) Peano numbers in Haskell

nat.hs

module MyNat (MyNat) where
import Data.Ratio

data MyNat = Z | S !MyNat deriving (Read, Show, Eq)

natapl :: MyNat -> (a -> a) -> a -> a
natapl Z f n = n
natapl (S x) f n = natapl x f (f n)

natsub :: MyNat -> MyNat -> (MyNat -> a) -> (MyNat -> a) -> a -> a
natsub Z Z _ _ z = z
natsub (S x) Z p _ _ = p x
natsub Z (S x) _ m _ = m x
natsub (S x) (S y) p m z = natsub x y p m z

instance Ord MyNat where
    -- compare x y = natsub x y (const GT) (const LT) EQ
    compare Z Z = EQ
    compare Z (S _) = LT
    compare (S _) Z = GT
    compare (S x) (S y) = compare x y

instance Num MyNat where
    Z + x = x
    (S x) + y = x + (S y)
    x - Z = x
    (S x) - (S y) = x - y
    x * y = natapl x (y+) Z
    abs = id
    negate Z = Z
    signum Z = Z
    signum (S _) = S Z
    fromInteger x =
        case compare 0 x of
            EQ -> Z
            LT -> S (fromInteger (x - 1))

instance Real MyNat where
    toRational = (%1) . toInteger

instance Enum MyNat where
    succ = S
    pred (S x) = x
    toEnum x =
        case compare 0 x of
            EQ -> Z
            LT -> S (toEnum (x - 1))
    fromEnum x = natapl x succ 0
    enumFrom x = x:(enumFrom (S x))
    enumFromThen x x' =
        let incr i Z d = (S i):(incr (S i) d d)
            incr i (S d') d = incr (S i) d' d
            decr Z _ _ = []
            decr (S i) Z d = i:(decr i d d)
            decr (S i) (S d') d = decr i d' d
            z = x:z
        in natsub x x' (\d -> x:(decr x d d)) (\d -> x:(incr x d d)) z
    enumFromTo x y =
        let incr _ Z = []
            incr i (S r) = i:(incr (S i) r)
        in natsub x y (const []) (\r -> x:(incr (S x) r)) [x]
    enumFromThenTo x x' y =
        let p' r = natsub x x' (\d -> x:(decr x r d d)) (const []) []
            m' r = natsub x x' (const []) (\d -> x:(incr x r d d)) z
            incr _ Z (S _) _ = []
            incr i Z Z _ = [S i]
            incr i (S r) Z d = (S i):(incr (S i) r d d)
            incr i (S r) (S d') d = incr (S i) r d' d
            decr _ Z (S _) _ = []
            decr Z _ _ _ = []
            decr (S i) Z Z _ = [i]
            decr (S i) (S r) Z d = i:(decr i r d d)
            decr (S i) (S r) (S d') d = decr i r d' d
            z = x:z
        in natsub x y p' m' (if x == x' then z else [x])

instance Integral MyNat where
    quot x (S y) =
        let go Z _ q = q
            go (S i) Z q = go i y (S q)
            go (S i) (S d) q = go i d q
        in go x y Z
    rem x (S y) =
        let go Z _ r = r
            go (S i) Z r = go i y Z
            go (S i) (S d) r = go i d (S r)
        in go x y Z
    div = quot
    mod = rem
    quotRem x (S y) =
        let go Z _ q r = (q, r)
            go (S i) Z q r = go i y (S q) Z
            go (S i) (S d) q r = go i d q (S r)
        in go x y Z Z
    divMod = quotRem
    toInteger x = natapl x succ 0