{-# LANGUAGE CPP #-}

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-  LANGUAGE NoMonomorphismRestriction #-}

{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}

-------------------------------------------------------------------------------

  module ShapeSyb ( tests, main_tests ) where

-------------------------------------------------------------------------------

  import Test.HUnit

  import SAI.Data.Generics.Shape

  import Data.Data ( Data, Typeable )
  import Data.Generics.Aliases ( mkQ, extQ )
  import Data.Generics.Aliases ( GenericQ )
  import Data.List ( intercalate )
  import Control.Exception ( evaluate )
--import Data.Dynamic

  -- Testing abstract datatype:
  import qualified Data.Map as Map
  import Data.Map ( Map )

--import Debug.Trace ( trace )

  import Control.Monad
  import Data.Maybe

  import System.IO.Unsafe ( unsafePerformIO )

-------------------------------------------------------------------------------

  -- Sample types and values (constructor application expressions).
  -- Expected structures are shown in parentheses language.

  test_list = [[1,2],[3],[4,5,6::Int]]

  data TA = A1 | A2 TB TA TB
  data TB = B TA

  exprAB = A2 (B A1) A1 (B A1)
  -- ((())()(()))

  data TC = C1 Float (Int,Int) | C2 TD TC TD | C3 TC
  data TD = D TC

  exprCD = C2 (D (C1 1.1 (4,5))) (C3 (C1 2.2 (6,7))) (D (C1 3.3 (8,9)))
  -- (((()(()())))((()(()())))((()(()())))

  data TE = E1 String | E2 (Int,Int) TF
  data TF = F TE String

  exprEF = E2 (2,5) (F (E1 "foo") "bar")
  -- ((()(())())()())

  -- For testing that Dynamic can recover nodes elided below a node.
  data TG = G TH
  data TH = H TI
  data TI = I
  data TJ = J | J1 TJ | J2 TJ | J3 TJ
  exprGHI = G (H I)  -- multiple types
  exprJ = J1 (J2 (J3 J))  -- multiple data constructors

  data TK = K1 TL | K2 TM | K3
  data TL = L1 | L2 TL | L3 TM
  data TM = M1 TL TL | M2 TK
  exprKLM = K2 (M1 (L2 L1) (L2 (L3 (M2 K3))))

  exprN = Map.fromList [("sfv",2.2),("pdsfhp",3.3),("",1.1)] :: Map String Float

  -- requires -XStandaloneDeriving (this isn't really what it's for...)
  deriving instance Data TA ; deriving instance Typeable TA
  deriving instance Data TB ; deriving instance Typeable TB
  deriving instance Data TC ; deriving instance Typeable TC
  deriving instance Data TD ; deriving instance Typeable TD
  deriving instance Data TE ; deriving instance Typeable TE
  deriving instance Data TF ; deriving instance Typeable TF
  deriving instance Data TG ; deriving instance Typeable TG
  deriving instance Data TH ; deriving instance Typeable TH
  deriving instance Data TI ; deriving instance Typeable TI
  deriving instance Data TJ ; deriving instance Typeable TJ
  deriving instance Data TK ; deriving instance Typeable TK
  deriving instance Data TL ; deriving instance Typeable TL
  deriving instance Data TM ; deriving instance Typeable TM

  -- often you would not have any Show instance for your
  -- source types, but here it's useful for preparing
  -- my writeup...
  deriving instance Show TA
  deriving instance Show TB
  deriving instance Show TC
  deriving instance Show TD
  deriving instance Show TE
  deriving instance Show TF
  deriving instance Show TG
  deriving instance Show TH
  deriving instance Show TI
  deriving instance Show TJ
  deriving instance Show TK
  deriving instance Show TL
  deriving instance Show TM

-------------------------------------------------------------------------------

  -- Target type for some of the homomorphisms exercised.

  -- Typeable for Hetero/Bi which use Data.Dynamic.
  -- Eq used to be needed for filterHomo etc. but not anymore.
  data Result = Result (Int,Int) deriving ( Show, Typeable )

  -- A lifted type (Result (Maybe (Int,Int)) would be better)!
  dud_result = Result (0,0)

  pair_result pair = Result pair

-------------------------------------------------------------------------------

  test0 :: TC -> Homo Result
  test0 = ghom (mkQ dud_result f)
--test0 = ghom (\r _->r) (mkQ dud_result f)
   where
    -- This is only generic in the sense that other types
    -- will still be traversed (passed over).
--  f :: TC -> Result
    f (C1 _ pair) = pair_result pair
    f (C2 _ _ d2@(D c)) = let g (Result (x,y)) = Result (y,x) in g (f c)
--  f (C2 _ _ d2@(D c)) = f c  -- line above is more interesting
    f x = dud_result  -- still needed! (notwithstanding mkQ)
--  f x = x

#if 1

#if 0

--test1 :: TC -> Homo Result
--test1 = ghomP (mkQ True p) (\r _->r) (mkQ dud_result f)
  test1 = ghomP p' (\r _->r) (mkQ dud_result f)
   where

    f :: TC -> Result  -- correct (but unneeded)
--- f :: forall b. Data b => b -> Result  -- wrong (we'd like it though)
    f (C1 _ pair) = pair_result pair
    f (C2 _ _ d2@(D c)) = let g (Result (x,y)) = Result (y,x) in g (f c)
--  f (C2 _ _ d2@(D c)) = f c  -- line above is more interesting
    f x = dud_result

    p :: TC -> Bool  -- correct (but unneeded)
--- p :: forall e. (Data e, Typeable e) => e -> Bool  -- (would be nice)
    p (C1 _ (i1,i2)) = i1 < 7
--  p (C1 _ (i1,i2)) = i1 < i2
--  p (C2 _ _ d2@(D c)) = p c
    p x = True
    -- one or the other sig. is NEEDED:
--  p' :: forall d. (Data d, Typeable d) => d -> Bool
    p' :: GenericQ Bool
--  p' = mkQ True (\x -> p (x :: (forall d. (Data d, Typeable d) => d)))
--  p' = mkQ True (\x -> p (x :: (forall d. (Data d) => d)))
    p' = mkQ True p
--mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
--type GenericQ r = forall a. Data a => a -> r
--data TC = C1 Float (Int,Int) | C2 TD TC TD deriving ( Data, Typeable )
--data TD = D TC deriving ( Data, Typeable )

#else

  -- It is necessary to have SOME boilerplate in the user code,
  -- like "mkQ", because the type system won't let me pass a
  -- generically-typed function f to be mkQ'd in callee?
  -- It's tempting to just go with k = (\r _->r) internally,
  -- were it not for the early precedent of weightedShapeOf...
  -- Still, mapping a ()-tree to an Int-tree bearing branch
  -- weights is not really in the purview of this mini-project,
  -- so, yeah, I'm getting rid of that!...  Yay!
  -----------
  -- Later: needed to make f as a whole return Maybe r...
  test1 :: TC -> [Homo Result]
  test1 = gfilter (mkQP p f)
   where
#if 1
    p :: Result -> Bool
    p (Result (x,_)) = x < 7
    p x = False
#else
    p :: TC -> Bool
    p (C1 _ (i1,i2)) = i1 < 7
    p x = True
#endif
    f :: TC -> Maybe Result
--  f :: TC -> Result
    f (C1 _ pair)
      = Just $ pair_result pair
    f (C2 _ _ d2@(D c))
      = let g (Just (Result (x,y))) = Just (Result (y,x)) in g (f c)
    f x = Nothing
--  f x = dud_result

#endif

  test1b :: TC -> Homo Result
  test1b = gfilter_ dud_result (mkQP p f)
   where
#if 1
    p :: Result -> Bool
    p (Result (x,_)) = x < 7
    p x = False
#else
    p :: TC -> Bool
    p (C1 _ (i1,i2)) = i1 < 7
    p x = True
#endif
    f :: TC -> Maybe Result
--  f :: TC -> Result
    f (C1 _ pair)
      = Just $ pair_result pair
    f (C2 _ _ d2@(D c))
      = let g (Just (Result (x,y))) = Just (Result (y,x)) in g (f c)
    f x = Nothing
--  f x = dud_result
#if 0
  test1' :: TC -> Homo Result
  test1' = ghomP' p (mkQ dud_result f)
   where
--  f :: forall d. Data d => d -> Result
    f (C1 _ pair) = pair_result pair
    f (C2 _ _ d2@(D c)) = let g (Result (x,y)) = Result (y,x) in g (f c)
--  f (C2 _ _ d2@(D c)) = f c  -- line above is more interesting
    f x = dud_result
--  f x = x
--  p :: Homo Result -> Bool
--  p (R (Result (x,y)) _) = not $ x == 0 && y == 0
    p :: Result -> Bool
    p (Result (x,y)) = not $ x == 0 && y == 0
#endif

#endif

  test2 :: TC -> Homo Result
  test2 = ghom ((const dud_result) `extQ` fTC `extQ` fTD)
   where

    fTC :: TC -> Result
    fTC (C1 _ pair) = pair_result pair
    -- Note we don't need to cover all the cases, or provide a base case;
    -- SYB provides the default case for us automatically.
    fTC x = dud_result
--  fTC x = x

    fTD :: TD -> Result
    fTD (D c) = Result (1,1)
--  fTD (D c) = (mkQ (const dud_result) fTC) c  -- why not?
--  fTD (D c) = fTC c  -- risk non-exhaustive patterns runtime errpr
    fTD x = dud_result
--  fTD x = x

---------------------------------------

  data CompanyType = Company [DepartmentType]
  data DepartmentType = Department String ManagerType [EmployeeType]
  data ManagerType = Manager { rank :: Float
                             , manName :: String
                             , manSalary :: SalaryType }
  data EmployeeType = Employee { empName :: String
                               , empSalary :: SalaryType }
  data SalaryType = Salary Float

  deriving instance Data CompanyType    ; deriving instance Typeable CompanyType
  deriving instance Data DepartmentType ; deriving instance Typeable DepartmentType
  deriving instance Data ManagerType    ; deriving instance Typeable ManagerType
  deriving instance Data EmployeeType   ; deriving instance Typeable EmployeeType
  deriving instance Data SalaryType     ; deriving instance Typeable SalaryType

  deriving instance Show CompanyType
  deriving instance Show DepartmentType
  deriving instance Show ManagerType
  deriving instance Show EmployeeType
  deriving instance Show SalaryType

  data NiceRecord =   NiceHole
                    | NiceRecord { nice_name :: String
                                 , nice_salary :: Int }
    deriving ( Show )

  isNiceHole NiceHole = True
  isNiceHole _ = False

------------------------------

  -- small, one department retail company
  company1 = Company [Department "Sales" (Manager 1 "Deborah" (Salary 75000)) [Employee "Jane" (Salary 35000)]]

--test4 :: EmployeeType -> Homo NiceRecord
--test4 :: forall d. Data d => d -> Homo NiceRecord
  test4 = ghom (const NiceHole `extQ` f_EmployeeType `extQ` f_ManagerType)
--test4 = ghom f
   where
    -- No sum types involved, so no explicit defaults
    -- needed (unlike in previous examples).
    f_EmployeeType (Employee name (Salary salary))
      = NiceRecord name (floor salary)
    f_ManagerType (Manager _ name _)
      = NiceRecord name 0

  test5 :: [[Int]] -> [[Maybe Bool]]
  test5 = map (map (\x ->if odd x then Just True else Nothing))

-----------------------------------

#if 1
  -- XXX This is now a hack; I'm only trying to make my
  -- executable "test-sai-shape-syb" (test-05.hs) instead
  -- work as unit-tests in cabal; the sole reason being,
  -- to prevent building it every rebuild, as building
  -- this and linking it takes like 20 seconds!...
  main_tests :: IO Int
  main_tests = do
#if 1
          -- When developing SYB code, it can matter whether or
          -- not your functions are used -- if they're not demanded,
          -- you may get (compile-time) type errors requiring explicit
          -- type signatures.  This can be prevented by creating
          -- artificial demand thus:
          evaluate (test4 company1)
#endif
          putStrLn $ intercalate "\n" [ ""

           , "> showAsParens (shapeOf (1,2,3))\n  "
           , let x = ((1,2,3)::(Int,Int,Int)) in showAsParens (shapeOf x) ++ "        " ++ show (sizeOf x) ++ " nodes" ++ "\n"
           , "> showAsParens (shapeOf [1,2,3])\n  "
           , showAsParens (shapeOf [1,2,3::Int]) ++ "   " ++ show (sizeOf ([1,2,3::Int])) ++ " nodes" ++ "\n"
           , "> showAsParensEnriched $ ghom (mkQ 0 (id::Int->Int)) [1,2,3])\n  "
           , (showAsParensEnriched $ ghom (mkQ 0 (id::Int->Int)) [1,2,3::Int]) ++ "\n"
           , "> showAsParensEnrichedWhen (>0) $ ghom (mkQ 0 (id::Int->Int)) [1,2,3])\n  "
           , (showAsParensEnrichedWhen (>0) $ ghom (mkQ 0 (id::Int->Int)) [1,2,3::Int]) ++ "\n"
           , "> showAsParensEnrichedM $ ghom (mkQ Nothing ((\\x->Just x)::Int->Maybe Int)) [1,2,3]\n  "
           , (showAsParensEnrichedM $ ghom (mkQ Nothing ((\x->Just x)::Int->Maybe Int)) [1,2,3::Int]) ++ "\n"

           , "\nPossibly, [[Int]], although polytypic, was not a good type for so many examples."
           , "(Some examples with ADTs come after.)\n"
           , "> show test_list\n  "
           ,  show test_list ++ "\n"
           , "> showHetero $ ghomDyn test_list\n  "
           , showHetero $ ghomDyn test_list
           , "> showHomo $ shapeOf test_list\n  "
           ,  showHomo $ shapeOf test_list
           , "> showAsParens $ shapeOf test_list\n  "
           , (showAsParens $ shapeOf test_list) ++ "\n"
           , "> showAsParensEnriched $ weightedShapeOf test_list\n  "
           , (showAsParensEnriched $ weightedShapeOf test_list) ++ "\n"
           , "> showAsParensBool $ ghom (mkQ False (odd::Int->Bool)) test_list\n  "
           , (showAsParensBool $ ghom (mkQ False (odd::Int->Bool)) test_list) ++ "\n"
           , "The parentheses around the leaves are not strictly needed,"
           , "but the result would be harder to read:"
           , ""
           , "(.(.*(...))(.(.*.)(.(..(.*(...))).)))"
           , ""
           , "> showAsParensEnriched $ ghom (mkQ False (odd::Int->Bool)) test_list\n  "
           , (showAsParensEnriched $ ghom (mkQ False (odd::Int->Bool)) test_list) ++ "\n"
           , "> showAsParensEnrichedWhen id $ ghom (mkQ False (odd::Int->Bool)) test_list\n  "
           , (showAsParensEnrichedWhen id $ ghom (mkQ False (odd::Int->Bool)) test_list) ++ "\n"
           , "> showHomo $ ghom (mkQ False (odd::Int->Bool)) test_list\n  "
           ,  showHomo $ ghom (mkQ False (odd::Int->Bool)) test_list
           , "> showHomoWhen id $ ghom (mkQ False (odd::Int->Bool)) test_list\n  "
           ,  showHomoWhen id $ ghom (mkQ False (odd::Int->Bool)) test_list
           , "> showHomoWhen (>0) $ ghom (mkQ 0 (id::Int->Int)) test_list\n  "
           ,  showHomoWhen (>0) $ ghom (mkQ 0 (id::Int->Int)) test_list
           , "> showHomo $ filterHomo id $ ghom (mkQ False (odd::Int->Bool)) test_list\n  "
           ,  showHomo $ filterHomo id $ ghom (mkQ False (odd::Int->Bool)) test_list
           , "> showHomo $ filterHomoM id $ ghom (mkQ False (odd::Int->Bool)) test_list\n  "
           ,  showHomo $ filterHomoM id $ ghom (mkQ False (odd::Int->Bool)) test_list
           , "> showHomo $ filterHomoM odd $ ghom (mkQ 0 (id::Int->Int)) test_list\n  "
           ,  showHomo $ filterHomoM odd $ ghom (mkQ 0 (id::Int->Int)) test_list
           , "> showHomo $ filterHomo (>0) $ ghom (mkQ 0 (id::Int->Int)) test_list\n  "
           ,  showHomo $ filterHomo (>0) $ ghom (mkQ 0 (id::Int->Int)) test_list
           , "> showHomo $ filterHomoM (>0) $ ghom (mkQ 0 (id::Int->Int)) test_list\n  "
           ,  showHomo $ filterHomoM (>0) $ ghom (mkQ 0 (id::Int->Int)) test_list
           , "> showHomo $ filterHomoM (>=0) $ ghom (mkQ (-1) (id::Int->Int) `extQ` ((\\_->0)::[Int]->Int)) test_list\n  "
           ,  showHomo $ filterHomoM (>=0) $ ghom (mkQ (-1) (id::Int->Int) `extQ` ((\_->0)::[Int]->Int)) test_list
           , "> showHetero $ ghomDyn test_list\n  "
           ,  showHetero $ ghomDyn test_list
           , "> showHetero $ filterHetero (/=(3::Int)) $ ghomDyn test_list\n  "
           ,  showHetero $ filterHetero (/=(3::Int)) $ ghomDyn test_list
           , "> showBi $ heteroToBi False (odd::Int->Bool) $ ghomDyn test_list\n  "
           , "or, equivalently\n"
           , "> showBi $ ghomBi (mkQ False (odd::Int->Bool)) test_list\n  "
--         ,  showBi $ heteroToBi False (odd::Int->Bool) $ ghomDyn test_list
           ,  showBi $ ghomBi (mkQ False (odd::Int->Bool)) test_list

#if 1

#if 0
           , "> showHomo $ heteroToHomo $ filterHetero (/=3::Int) $ ghomDyn test_list\n  "
           ,  showHomo $ heteroToHomo $ filterHetero (/=3::Int) $ ghomDyn test_list
#endif
           , "> showBi $ filterBi id $ ghomBi (mkQ False (odd::Int->Bool)) test_list\n  "
           ,  showBi $ filterBi id $ ghomBi (mkQ False (odd::Int->Bool)) test_list
           , "> showHomo $ biToHomo $ filterBi id $ ghomBi (mkQ False (odd::Int->Bool)) test_list\n  "
           ,  showHomo $ biToHomo $ filterBi id $ ghomBi (mkQ False (odd::Int->Bool)) test_list
           , "> let f (x::Int) = if odd x then Just x else Nothing\n"
           , "> showHomo $ ghom (mkQ Nothing f) test_list\n  "
           ,  showHomo $ ghom (mkQ Nothing (\x -> if odd (x::Int) then Just x else Nothing)) test_list
           , "> showHomo $ filterHomoMM $ ghom (mkQ Nothing f) test_list\n  "
           ,  showHomo $ filterHomoMM $ ghom (mkQ Nothing (\x -> if odd (x::Int) then Just x else Nothing)) test_list
           , "> showHomo $ unliftHomoM 0 $ filterHomoMM $ ghom (mkQ Nothing f) test_list\n  "
           ,  showHomo $ unliftHomoM 0 $ filterHomoMM $ ghom (mkQ Nothing (\x -> if odd (x::Int) then Just x else Nothing)) test_list

#endif

#if 1
           , "\nTesting algebraic data types:\n"
           , "data TA = A1 | A2 TB TA TB"
           , "data TB = B TA"
           , "exprAB = A2 (B A1) A1 (B A1)"
           , ""
           , "data TC = C1 Float (Int,Int) | C2 TD TC TD | C3 TC"
           , "data TD = D TC"
           , "exprCD = C2 (D (C1 1.1 (4,5))) (C3 (C1 2.2 (6,7))) (D (C1 3.3 (8,9)))"
           , ""
           , "data TE = E1 String | E2 (Int,Int) TF"
           , "data TF = F TE String"
           , "exprEF = E2 (2,5) (F (E1 \"foo\") \"bar\")"
           , ""
           , "> showAsParens $ shapeOf exprAB\n  "
           , (showAsParens $ shapeOf exprAB) ++ "\n"
           , "> showAsParens $ shapeOf exprCD\n  "
           , (showAsParens $ shapeOf exprCD) ++ "\n"
           , "> showAsParens $ shapeOf exprEF\n  "
           , (showAsParens $ shapeOf exprEF) ++ "\n"
           , "> showAsParens $ shapeOf_ exprEF  -- String treated as atomic\n"
           , (showAsParens $ shapeOf_ exprEF) ++ "\n"
           , "> showAsParensEnriched $ weightedShapeOf_ exprEF\n  "
           , (showAsParensEnriched $ weightedShapeOf_ exprEF) ++ "\n"
#endif

#if 1

           , "> show $ ( ( unGhomDyn $ ghomDyn exprEF ) :: TE )\n  "
           , (show $ ( ( unGhomDyn $ ghomDyn exprEF ) :: TE ) ) ++ "\n"

           , "> showHomo $ ( gempty exprEF :: BiM Int )\n  "
           , (showHomo $ ( gempty exprEF :: BiM Int )) ++ "\n"

           , "Progressive refinement and accumulation:\n"
#if 1
           , "\
> (showBi $\n\
     ( grefine\n\
         (\\ x -> case x of { E2 (y,z) _ -> Just (z+3)\n\
                           ; _ -> Nothing })\n\
         ( gempty exprEF :: BiM Int )\n\
     )\n\
  )\n"
#endif
           , (showBi $
                ( grefine
                    (\ x -> case x of { E2 (y,z) _ -> Just (z+3)
                                      ; _ -> Nothing })
                    ( gempty exprEF :: BiM Int )
                )
             )

#if 1
           , "\
> (showBi $\n\
    ( gaccum\n\
        ((\\r1 r2 -> r1+r2) :: Int -> Int -> Int)\n\
        (\\ x -> case x of { E1 s -> Just (length s)\n\
                          ; _ -> Nothing })\n\
        ( grefine\n\
            (\\ x -> case x of { E2 (y,z) _ -> Just (z+3)\n\
                              ; _ -> Nothing })\n\
            ( gempty exprEF :: BiM Int )\n\
        )\n\
    )\n\
  )\n"
#endif
           , (showBi $
               ( gaccum
                   ((\r1 r2 -> r1+r2) :: Int -> Int -> Int)
                   (\ x -> case x of { E1 s -> Just (length s)
                                     ; _ -> Nothing })
                   ( grefine
                       (\ x -> case x of { E2 (y,z) _ -> Just (z+3)
                                         ; _ -> Nothing })
                       ( gempty exprEF :: BiM Int )
                   )
               )
             )

#if 0
           , "\nTesting that a Dynamic node can recover nodes elided below it:\n"
           , "Testing a chain of types:\n"
           , "> let (f::TH->Bool) x = case x of { H _ -> False ; _ -> True }\n"
           , "> show exprGHI\n"
           , show exprGHI ++ "\n"
           , "> showBi $ ghomBi (mkQ True f) exprGHI\n"
           , showBi $ ghomBi (mkQ True ( (\ x -> case x of { H _ -> False ; _ -> True }) :: TH -> Bool ) ) exprGHI
           , "> showBi $ filterBi id $ ghomBi (mkQ True f) exprGHI\n"
           , showBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { H _ -> False ; _ -> True }) :: TH -> Bool ) ) exprGHI
           , "> ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True f) exprGHI ) :: TG ) )\n"
           , ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { H _ -> False ; _ -> True }) :: TH -> Bool ) ) exprGHI ) :: TG ) ) ++ "\n"

           , "Testing a chain of constructors:\n"
           , "> show exprJ\n"
           , show exprJ ++ "\n"
           , "> let (f::TJ->Bool) x = case x of { J1 _ -> False ; J3 _ -> False; _ -> True }\n"
           , "> showBi $ ghomBi (mkQ True f) exprJ\n"
           , showBi $ ghomBi (mkQ True ( (\ x -> case x of { J1 _ -> False ; J3 _ -> False; _ -> True }) :: TJ -> Bool ) ) exprJ
           , "> showBi $ filterBi id $ ghomBi (mkQ True f) exprJ\n"
           , showBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { J1 _ -> False ; J3 _ -> False; _ -> True }) :: TJ -> Bool ) ) exprJ
           , "> ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True f) exprJ ) :: TJ ) )\n"
           , ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { J1 _ -> False ; J3 _ -> False; _ -> True }) :: TJ -> Bool ) ) exprJ ) :: TJ ) ) ++ "\n"

           , "Testing a mixture of types and constructors:\n"
           , "> show exprKLM\n"
           , show exprKLM ++ "\n"
           , "> let (f::TL->Bool) x = case x of { L2 _ -> False ; L3 _ -> False; _ -> True }\n"
           , "> showBi $ ghomBi (mkQ True f) exprKLM\n"
           , showBi $ ghomBi (mkQ True ( (\ x -> case x of { L2 _ -> False ; L3 _ -> False; _ -> True }) :: TL -> Bool ) ) exprKLM
           , "> showBi $ filterBi id $ ghomBi (mkQ True f) exprKLM\n"
           , showBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { L2 _ -> False ; L3 _ -> False; _ -> True }) :: TL -> Bool ) ) exprKLM
           , "> ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True f) exprKLM ) :: TK ) )\n"
           , ( show $ ( ( unGhomBi $ filterBi id $ ghomBi (mkQ True ( (\ x -> case x of { L2 _ -> False ; L3 _ -> False; _ -> True }) :: TL -> Bool ) ) exprKLM ) :: TK ) ) ++ "\n"
#endif

           , "\nTesting filterHomoM and filterBiM:\n"
           , "> show test_list\n"
           , show test_list ++ "\n"
           , "> showHomo $ filterHomoM odd $ ghom (mkQ 0 (id::Int->Int)) test_list\n"
           , showHomo $ filterHomoM odd $ ghom (mkQ 0 (id::Int->Int)) test_list
           , "> showBi $ filterBiM odd $ ghomBi (mkQ 0 (id::Int->Int)) test_list\n"
           , showBi $ filterBiM odd $ ghomBi (mkQ 0 (id::Int->Int)) test_list
--         , showBi $ filterBiM odd $ ghomBi (mkQ (-1) (id::Int->Int)) test_list

           -- is WORKING!...
           , "\nTesting abstract datatype:\n"
           , "> show exprN\n"
           , show exprN ++ "\n"
           , "> show $ Map.toList exprN\n"
           , (show $ Map.toList exprN) ++ "\n"
           , "> showHomo $ shapeOf_ exprN   -- String treated as atomic\n"
           , showHomo $ shapeOf_ exprN
           , "> showHomo $ shapeOf exprN\n"
           , showHomo $ shapeOf exprN
#if 0
-- Worse than futile...
           , "> showAsParensEnriched $ shapeOf exprN\n"
           , (showAsParensEnriched $ shapeOf exprN) ++ "\n"
#endif
           , "> showHomoWhen (>0) $ ghomP (mkQ False (\\ (_::String) -> True)) (mkQ 0 (\\ (x::Float) -> x) `extQ` (\\ (_::String) -> 0)) exprN\n"
           , showHomoWhen (>0) $ ghomP (mkQ False (\ (_::String)->True)) (mkQ 0 (\ (x::Float) -> x) `extQ` (\ (_::String) -> 0)) exprN
           , "> showHomoWhen (>0) $ ghom (mkQ 0 (\\ (x::Float) -> x)) exprN\n"
           , showHomoWhen (>0) $ ghom (mkQ 0 (\ (x::Float) -> x)) exprN
           , "> showHomo $ filterHomo (>0) $ ghom (mkQ 0 (\\ (x::Float) -> x)) exprN\n"
           , showHomo $ filterHomo (>0) $ ghom (mkQ 0 (\ (x::Float) -> x)) exprN
           , "> showHomo $ filterHomoM (>0) $ ghom (mkQ 0 (\\ (x::Float) -> x)) exprN\n"
           , showHomo $ filterHomoM (>0) $ ghom (mkQ 0 (\ (x::Float) -> x)) exprN

#if 1

           , "show exprCD\n  "
           ,  show exprCD ++ "\n"
           , "showHomo $ shapeOf exprCD\n  "
           ,  showHomo $ shapeOf exprCD
           , "showAsParens $ shapeOf exprCD\n  "
           , (showAsParens $ shapeOf exprCD) ++ "\n"
           , "showHomo $ test0 exprCD\n  "
           ,  showHomo $ test0 exprCD
           , "concatMap showHomo $ test1 exprCD  -- gfilter\n  "
           , (concatMap showHomo $ test1 exprCD) ++ "\n"
           , "showHomo $ test1b exprCD  -- gfilter_\n  "
           ,  showHomo $ test1b exprCD
           , "showHomo $ test2 exprCD\n  "
           ,  showHomo $ test2 exprCD
           , "showHomo $ filterHomo (\\ (Result (x,y)) -> not $ x == 0 && y == 0 ) $ test2 exprCD\n  "
           ,  showHomo $ filterHomo (\ (Result (x,y)) -> not $ x == 0 && y == 0 ) $ test2 exprCD

           , "showHomo $ shapeOf exprEF\n  "
           ,  showHomo $ shapeOf exprEF

           , "show company1\n  "
           ,  show company1 ++ "\n"
           , "showAsParens $ shapeOf_ company1\n  "
           , (showAsParens $ shapeOf_ company1) ++ "\n"
           , "showHomo $ shapeOf_ company1\n  "
           ,  showHomo $ shapeOf_ company1
           , "showHomo $ test4 company1\n  "
           ,  showHomo $ test4 company1
           , "showHomo $ filterHomo (not . isNiceHole) $ test4 company1\n  "
           ,  showHomo $ filterHomo (not . isNiceHole) $ test4 company1
--         ,  showHomo $ filterHomo (not . isNiceHole) $ shapeOf exprAB  -- pointless

#endif

#endif

           ]
#endif
          return 0

-------------------------------------------------------------------------------

-- XXX A better way to "fail on purpose" is to have the test
-- return ExitFailure, no?...
--tests = (unsafePerformIO main_tests == output) ~? "FAILING ON PURPOSE TO DISPLAY THE LOGGED OUTPUT!"  -- yeah but it wasn't printed
  tests = unsafePerformIO
            ( do n <- main_tests
                 putStrLn "FAILING ON PURPOSE TO DISPLAY THE LOGGED OUTPUT!\n"
                 return n )
            ~=? output
  output = 1::Int  -- force test to fail! (so we see the output!)
--output = 0::Int
--output = ()

-------------------------------------------------------------------------------