{-# OPTIONS -fglasgow-exts -fallow-overlapping-instances -fallow-undecidable-instances -fallow-incoherent-instances #-}

-- Shrink using the SYB library...

module Shrink where
--  import Data.Typeable
  import SYBnew

  --------- shrink-specific code -----------
  data ShrinkD a = ShrinkD { shrinkD   :: a -> [a],
 			     childrenD :: a -> [a] }

  class Shrink a where
     shrink   :: a -> [a]
     children :: a -> [a]

  instance Shrink a => Sat (ShrinkD a) where
    dict = ShrinkD { shrinkD   = shrink
		  , childrenD = children }

  instance Data ShrinkD a => Shrink a where
    shrink t   = (childrenD dict) t ++ shrinkStep t
    children t = [y | Just y <- gmapQ shrinkProxy cast t]

  shrinkProxy :: ShrinkD ()
  shrinkProxy = error "urk"

  shrinkStep :: Data ShrinkD t => t -> [t]
  shrinkStep t = let 
		   M _ ts = gmapM shrinkProxy (\x -> M x (shrinkD dict x)) t
		 in ts

  --------- The M monad -----------
  data M a = M a [a]	

  instance Monad M where
    return x = M x []
    (M x xs) >>= k = M r (rs1 ++ rs2)
	where
	  M r rs1 = k x
	  rs2 = [r | x <- xs, let M r _ = k x]

  -------- Special Cases -------------------

{-
  instance Shrink a => Shrink (a,b) where
     shrink (x,y) = [ (x', y) | x' <- shrink x ]
     children _   = []

  instance Shrink Int where
     shrink i   = [i - 1] 
     children i = []
-}

  ------------- List with Length -----------------

  data ListWithLength a = LWL [a] Int deriving (Show)
  -- Invariant: the Int is the length of the list

  $(derive [''ListWithLength])

  instance (Data ShrinkD a) => Shrink (ListWithLength a) where
     shrink t@(LWL l i) = children t ++ (map (\x -> (LWL x i)) (shrinkStep l))
     children (LWL (hd:tl) i) = [LWL tl (i-1)]
     children (LWL [] _) = []

  main = do print (shrink ("ab", "cd"))
	    print (shrink ('a','b'))
            print (shrink "abc")
            print (shrink [1::Int,2,3])
            print (shrink (LWL [1::Int,2,3] 3))