isTreeOrdered causing headaches

Test.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where

import Data.Treap

import Test.QuickCheck

instance (Arbitrary h, Arbitrary t, Arbitrary a, Ord h, Ord t) => Arbitrary (Treap h t a) where
  arbitrary = sized $ \n -> do
    s <- choose (0, n)
    if s == 0
      then return Empty
      else do
      h <- arbitrary
      t <- arbitrary
      a <- arbitrary
      l <- sub h (<= t) s
      r <- sub h (>= t) s
      return $ Treap (Node l h t a r)
        where
          sub h0 tp n = do
            s <- choose (0, n)
            if s == 0
              then return Empty
              else do
              h <- arbitrary `suchThat` (>= h0)
              t <- arbitrary `suchThat` tp
              a <- arbitrary
              l <- sub h (<= t) s
              r <- sub h (>= t) s
              return $ Treap (Node l h t a r)
  shrink Empty = []
  shrink (Treap (Node l h t a r)) =
    [Empty] ++
    [l, r] ++
    [Treap (Node l' h t a' r') | (l', a', r') <- shrink (l, a, r)]

isHeapOrdered :: Ord h => Treap h t a -> Bool
isHeapOrdered Empty = True
isHeapOrdered (Treap (Node l h _ _ r)) = leftheap && rightheap
  where
    leftheap = case l of
      Empty -> True
      Treap (Node _ hl _ _ _) -> h <= hl && isHeapOrdered l
    rightheap = case l of
      Empty -> True
      Treap (Node _ hr _ _ _) -> h <= hr && isHeapOrdered r

isTreeOrdered :: Ord t => Treap h t a -> Bool
isTreeOrdered Empty = True
isTreeOrdered (Treap (Node l _ t _ r)) = lefttree && righttree
  where
    lefttree = case l of
      Empty -> True
      Treap (Node _ _ tl _ _) -> tl <= t && isTreeOrdered l
    righttree = case r of
      Empty -> True
      Treap (Node _ _ tr _ _) -> t <= tr && isTreeOrdered r

infixl 1 $-
($-) :: (Treap Int Int Int -> a) -> Treap Int Int Int -> a
f $- treap = f treap

main :: IO ()
main = do
  quickCheck (\c -> isTreeOrdered $- c)
  quickCheck (\c -> isHeapOrdered $- c)
  quickCheck (\c h t a -> isTreeOrdered $- insert c h t a)
  quickCheck (\c h t a -> isHeapOrdered $- insert c h t a)

Treap.hs

{-# LANGUAGE DeriveDataTypeable #-}
module Data.Treap where

import Data.Data (Typeable, Data)

data Treap1 h t a = Node (Treap h t a) h t a (Treap h t a) deriving (Show, Typeable, Data)
data Treap h t a = Treap (Treap1 h t a) | Empty deriving (Show, Typeable, Data)

insert' :: (Ord h, Ord t) => Treap h t a -> h -> t -> a -> Treap1 h t a
insert' Empty h t a = Node Empty h t a Empty
insert' x@(Treap (Node l h1 t1 a1 r)) h2 t2 a2 = case (h1 <= h2, t1 <= t2) of
  (False, False) -> case l of
    Empty -> Node l h2 t2 a2 x
    Treap (Node _ _ t3 _ _) -> if t3 <= t2
      then Node l h2 t2 a2 (Treap (Node Empty h1 t1 a1 r))
      else Node Empty h2 t2 a2 x
  (False, True) -> case r of
    Empty -> Node x h2 t2 a2 r
    Treap (Node _ _ t3 _ _) -> if t3 <= t2
      then Node x h2 t2 a2 Empty
      else Node (Treap (Node l h1 t1 a1 Empty)) h2 t2 a2 r
  (True, False) -> Node (insert l h2 t2 a2) h1 t1 a1 r
  (True, True) -> Node l h1 t1 a1 (insert r h2 t2 a2)

insert :: (Ord h, Ord t) => Treap h t a -> h -> t -> a -> Treap h t a
insert treap h t a = Treap (insert' treap h t a)