{-# LANGUAGE CPP #-}

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

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

  module Main ( main ) where

  import SAI.Data.Generics.Shape.SYB ( Homo, ghom )
  import SAI.Data.Generics.Shape.SYB ( shapeOf, weightedShapeOf )
  import SAI.Data.Generics.Shape.SYB ( showAsParens )
  import SAI.Data.Generics.Shape.SYB ( showAsParensEnriched )
  import SAI.Data.Generics.Shape.SYB ( filterHomo )
--import SAI.Data.Generics.Shape.SYB ( ghomP )
  import SAI.Data.Generics.Shape.SYB ( ghomP' )
  import SAI.Data.Generics.Shape.SYB ( ghomP'' )
  import Data.Data ( Data, Typeable )
  import Data.Generics.Aliases ( mkQ, extQ )
  import Data.Generics.Aliases ( GenericQ )
  import Data.List ( intersperse )
  import Control.Exception ( evaluate )
  import Data.Function ( fix )

--import SAI.Data.Generics.Shape.SYB.GHC  -- this will add over 10 MB to the executable size (dynamically-linked!)

  data TA = A1 | A2 TB TA TB deriving ( Data, Typeable )
  data TB = B TA deriving ( Data, Typeable )
  exprAB = A2 (B A1) A1 (B A1)

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

  -- often you would not have any Show instance for your
  -- source types, but here it's useful for preparing
  -- my writeup...
  data TC = C1 Float (Int,Int) | C2 TD TC TD | C3 TC
    deriving ( Show, Data, Typeable )
--  deriving ( Data, Typeable )
  data TD = D TC
    deriving ( Show, Data, Typeable )
--  deriving ( Data, Typeable )
  exprCD = C2 (D (C1 1.1 (4,5))) (C3 (C1 2.2 (6,7))) (D (C1 3.3 (8,9)))

  data Result = Result (Int,Int) deriving ( Show, Eq, Data, Typeable )
--data Result = Result (Int,Int) deriving ( Show, Eq )  -- Eq for filterHomo
--data Result = Result (Int,Int) deriving ( Show )
  dud_result = Result (0,0)
  pair_result pair = Result pair

  test1 :: TC -> Homo Result
  test1 = ghom (\r _->r) (mkQ dud_result f)
   where
    -- This is only generic in the sense that you don't
    -- need to match all ctors; but nodes of other types
    -- will still be traversed (passed over):
--  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  -- still needed! (notwithstanding mkQ)
--  f x = x

  test1' :: TC -> Homo Result
  test1' = ghomP' p (\r _->r) (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

#if 1
--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 )
#endif

  test2 :: TC -> Homo Result
  test2 = ghom (\r _->r) ((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 Data DepartmentType
  deriving instance Data ManagerType
  deriving instance Data EmployeeType
  deriving instance Data SalaryType
  deriving instance Typeable CompanyType
  deriving instance Typeable DepartmentType
  deriving instance Typeable ManagerType
  deriving instance Typeable EmployeeType
  deriving instance Typeable SalaryType

  data NiceRecord = NiceRecord { nice_name :: String
                               , nice_salary :: Int }
    deriving ( Show, Eq )
--  deriving ( Show )
  dud_record = NiceRecord "" 0

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

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

  test3 :: CompanyType -> Homo ()
--test3 :: forall d. Data d => d -> Homo ()
  test3 = ghom (\_ _->()) (const ())

--test4 :: EmployeeType -> Homo NiceRecord
--test4 :: forall d. Data d => d -> Homo NiceRecord
  test4 = ghom k (const dud_record `extQ` f_EmployeeType `extQ` f_ManagerType)
--test4 = ghom k 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
    k r _ = r

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

  main = do
          evaluate (test4 company1)
          putStrLn $ concat $ intersperse "\n" [ ""
#if 0
#elif 1
--         , show $ test4' company1
           , "show exprCD\n  "
           , show exprCD ++ "\n"
           , "show $ shapeOf exprCD\n  "
           , show $ shapeOf exprCD
           , "showAsParens $ shapeOf exprCD\n  "
           , (showAsParens $ shapeOf exprCD) ++ "\n"
           , "showAsParens $ weightedShapeOf exprCD\n  "
           , (showAsParens $ weightedShapeOf exprCD) ++ "\n"
           , "showAsParensEnriched $ weightedShapeOf exprCD\n  "
           , (showAsParensEnriched $ weightedShapeOf exprCD) ++ "\n"
           , "show $ test1 exprCD\n  "
           , show $ test1 exprCD
           , "show $ test1' exprCD\n  "
           , show $ test1' exprCD
           , "show $ test1'' exprCD\n  "
           , show $ test1'' exprCD
           , "show $ filterHomo p1 $ test1'' exprCD\n  "
           , show $ filterHomo p1 $ test1'' exprCD
           , "show $ filterHomo p1 $ test1 exprCD\n  "
           , show $ filterHomo p1 $ test1 exprCD
           , "show $ test2 exprCD\n  "
           , show $ test2 exprCD
           , "show $ filterHomo p1 $ test2 exprCD\n  "
           , show $ filterHomo p1 $ test2 exprCD
#elif 0
           , show $ filterHomo p3 $ test4 company1
#if 0
           , show $ filterHomo p3 $ shapeOf exprAB
#endif
           , show $                  weightedShapeOf exprAB
           , show $ filterHomo p2 $ weightedShapeOf exprAB
           , show $                  weightedShapeOf ( [[1,2],[3],[4,5,6]] :: [[Int]] )
           , show $ filterHomo p2 $ weightedShapeOf ( [[1,2],[3],[4,5,6]] :: [[Int]] )
--         , show $ filterHomo p2 $ weightedShapeOf [[1,2],[3],[4,5,6]]
--         , show $                  test2 exprCD
--         , show $ filterHomo p1 $ test2 exprCD
           , show $                  test1 exprCD
--         , show $ fix (filterHomo p1) $ test1 exprCD
           , show $ filterHomo p1 $ test1 exprCD
--         , show $ filterHomo p1 $ filterHomo p1 $ test1 exprCD
--         , show $ filterHomo p1 $ filterHomo p1 $ filterHomo p1 $ test1 exprCD
--         , show $ filterHomo p1 $ filterHomo p1 $ filterHomo p1 $ filterHomo p1 $ test1 exprCD
#elif 0
           , showAsParens $ shapeOf company1
           , show $ shapeOf company1
           , show $ test3 company1
           , show $ test4 company1
           , show $ shapeOf exprAB
           , show $ weightedShapeOf exprAB
           , show $ weightedShapeOf ( [[1,2],[3],[4,5,6]] :: [[Int]] )
--         , show $ weightedShapeOf [[1,2],[3],[4,5,6]]
           , show $ test2 exprCD
           , show $ test1 exprCD
#endif
           ]
   where
    p1 (Result (x,y)) = not $ x == 0 && y == 0
    p2 x = x /= 3
--  p2 x = x /= ( 3 :: Int )
    p3 = (/= dud_record)

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