{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StandaloneDeriving #-} module Main ( main ) where import SAI.Data.Generics.Shape.SYB ( Homo, ghom, shapeOf, weightedShapeOf ) --import SAI.Data.Generics.Shape.SYB ( Rose(..) ) import SAI.Data.Generics.Shape.SYB ( showAsParens ) import Data.Data ( Data, Typeable ) --import Data.Data import Data.Generics.Aliases ( extQ ) --import Data.Generics.Aliases ( mkT ) --import Data.Generics.Schemes ( everywhere ) --import Data.Generics ( Generic ) --import Data.Tree ( Tree(..) ) 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 ) dud_record = NiceRecord "" 0 ------------------------------ -- small, one department retail company company1 = Company [Department "Sales" (Manager 1 "Deborah" (Salary 75000)) [Employee "Jane" (Salary 35000)]] main = putStrLn $ showAsParens $ shapeOf company1 --main = putStrLn $ show $ shapeOf company1 --main = putStrLn $ show $ test1 company1 --main = putStrLn $ show $ test2 company1 test1 :: CompanyType -> Homo () --test1 :: forall d. Data d => d -> Homo () test1 = ghom (\_ _->()) (const ()) #if 0 --test2 :: EmployeeType -> Homo NiceRecord --test2 :: forall d. Data d => d -> Homo NiceRecord test2 = ghom k (const dud_record `extQ` f_EmployeeType `extQ` f_ManagerType) --test2 = ghom k f where f_EmployeeType (Employee name (Salary salary)) = NiceRecord name (floor salary) f_ManagerType (Manager _ name _) = NiceRecord name 0 k r _ = r #endif