content: {-# LANGUAGE ScopedTypeVariables #-}
  
  module Test.SmartCheck.Matches
    ( matchesShapes
    ) where
  
  import Test.SmartCheck.DataToTree
  import Test.SmartCheck.Types
  import Test.SmartCheck.SmartGen
  
  import Data.List
  import Data.Tree
  
  --------------------------------------------------------------------------------
  
  -- | True if d matches any ds.  Assume all ds are unequal to each other.
  matchesShapes :: SubTypes a => a -> [(a,Replace Idx)] -> Bool
  matchesShapes d = any (matchesShape d)
  
  --------------------------------------------------------------------------------
  
  -- | At each index that we generalize (either value generalization or
  -- constructor generalization), we replace that value from b into a.  At this
  -- point, we check for constructor equality between the two values, decending
  -- their structures.
  matchesShape :: forall a . SubTypes a => a -> (a, Replace Idx) -> Bool
  matchesShape a (b, Replace idxVals idxConstrs)
    | baseType a && baseType b = True
    | toConstr a /= toConstr b = False
    | Just a' <- aRepl         = let x = subTypes a' in
                                 let y = subTypes b  in
                                 all foldEqConstrs (zip x y)
    | otherwise                = False
  
    where
    foldEqConstrs :: (Tree SubT, Tree SubT) -> Bool
    foldEqConstrs (Node (SubT l0) sts0, Node (SubT l1) sts1)
      | baseType l0 && baseType l1 = next
      | toConstr l0 == toConstr l1 = next
      | otherwise                  = False
      where next = all foldEqConstrs (zip sts0 sts1)
  
    bSub :: Idx -> Maybe SubT
    bSub idx = getAtIdx b idx Nothing
  
    updateA :: Idx -> a -> Maybe a
    updateA idx d = maybe Nothing (replace d idx) (bSub idx)
  
    aRepl :: Maybe a
    aRepl = foldl' go (Just a) (idxVals ++ idxConstrs)
      where go ma idx = maybe Nothing (updateA idx) ma
  
  --------------------------------------------------------------------------------
  