sai-shape-syb-0.2.0: tests/test-02.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}

-- has to have separate line for Data and Typeable, so not worth it here;
-- can be useful for supplying instances for datatypes in other modules.
{-  LANGUAGE StandaloneDeriving #-}

  module Main ( main ) where

  import SAI.Data.Generics.Shape.SYB ( Homo, ghom, shapeOf, weightedShapeOf )
  import Data.Data ( Data, Typeable )
--import Data.Generics.Aliases ( mkT )
--import Data.Generics.Schemes ( everywhere )
  import Data.Generics.Aliases ( mkQ )
  import Data.Generics.Aliases ( extQ )

#if 0
  data TC = C1 Float (Int,Int) | C2 TD TC TD deriving ( Data, Typeable )
--data TC = C1 Float (Int,Int) | C2 TD TC TD
  data TD = D TC
  deriving instance Data TD
  deriving instance Typeable TD
--deriving instance ( Data, Typeable ) TD
#else
  data TC = C1 Float (Int,Int) | C2 TD TC TD deriving ( Data, Typeable )
  data TD = D TC deriving ( Data, Typeable )
#endif
  exprCD = C2 (D (C1 1.0 (1,2))) (C1 3.0 (3,4)) (D (C1 5.0 (5,6)))

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

  main = putStrLn $ show $ test2 exprCD
--main = putStrLn $ show $ test1 exprCD

  -- XXX What is needed is mkQ (and perhaps extQ).
  -- This makes a generic query out of a type-specific one.
  -- (Recall that a "query" is a function from d -> r,
  -- where d is generic (forall d. Data d =>).)

  test1 :: TC -> Homo Result
  test1 = ghom (mkQ dud_result f) (\r _->r)
--test1 = ghom (mkQ (const dud_result) f) (\r _->r)
   where
    -- This is only generic in the sense that you don't
    -- need to match all ctors?...
--  f :: forall d. Data d => d -> Result
    f (C1 _ pair) = pair_result pair
    f (C2 _ _ d2@(D c)) = f c
    f x = dud_result

--test2 :: TC -> Homo Result
  test2 = ghom ((const dud_result) `extQ` fTC `extQ` fTD) (\r _->r)
--test2 = ghom ((const dud_result) `extQ` (mkQ dud_result fTC) `extQ` (mkQ dud_result fTD)) (\r _->r)
--test2 = ghom ((mkQ dud_result fTC) `extQ` (mkQ dud_result fTD)) (\r _->r)
   where
    fTC :: TC -> Result
    fTC (C1 _ pair) = pair_result pair
--  fTC (C2 _ _ d2@(D c)) = fTC c
    fTC x = dud_result
    fTD :: TD -> Result
    fTD (D c) = fTC c
    fTD x = dud_result

  wtdShapeOf :: forall d. Data d => d -> Homo Int
  wtdShapeOf = ghom (const 1) (+)  -- as of typing this line, battery died!