Company.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Transform.Examples.Company
-- Copyright   :  (c) 2010 University of Minho
-- License     :  BSD3
--
-- Maintainer  :  hpacheco@di.uminho.pt
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Pointless Rewrite:
-- automatic transformation system for point-free programs
-- 
-- Company strategic specialization example
--
-----------------------------------------------------------------------------

module Transform.Examples.Company where

import Data.Type
import Data.Pf
import Data.Eval
import Transform.Rewriting
import Transform.Rules.SYB
import Transform.Rules.PF

import Generics.Pointless.Functors

-- * Type Definitions

data Company = C [Dept] deriving Show
data Dept = D Name Manager [Either Employee Dept] deriving Show
data Employee = E Person Salary deriving Show
data Person = P Name Address deriving Show
data Salary = S Int deriving Show
type Manager = Employee 
type Name = String 
type Address = String

-- * Type Instances

type instance PF Company = Const [Dept]
type instance PF Dept = Const Name :*: (Const Manager :*: ([] :@: (Const Employee :+: Id)))
type instance PF Employee = Const Person :*: Const Salary
type instance PF Person = Const Name :*: Const Address
type instance PF Salary = Const Int

instance Typeable Company where
    typeof = Data "Company" fctrof
instance Mu Company where
    inn l = C l
    out (C l) = l
instance Typeable Dept where
    typeof = Data "Dept" fctrof
instance Mu Dept where
    inn (n,(m,l)) = D n m l
    out (D n m l) = (n,(m,l))
instance Typeable Employee where
    typeof = Data "Employee" fctrof
instance Mu Employee where
    inn (p,s) = E p s
    out (E p s) = (p,s)
instance Typeable Person where
    typeof = Data "Person" fctrof
instance Mu Person where
    inn (n,a) = P n a
    out (P n a) = (n,a)
instance Typeable Salary where
    typeof = Data "Salary" fctrof
instance Mu Salary where
    inn i = S i
    out (S i) = i

genCom :: Company 
genCom = C [dralf]
dralf, dblair :: Dept
dralf = D "Research" ralf [Left joost, Left marlow, Right dblair]
dblair = D "Strategy" blair []
ralf, joost, marlow, blair :: Employee 
ralf = E (P "Ralf" "Amsterdam") (S 8000) 
joost = E (P "Joost" "Amsterdam") (S 1000) 
marlow = E (P "Marlow" "Cambridge") (S 2000) 
blair = E (P "Blair" "London") (S 100000)


company :: Type Company
company = typeof
dept :: Type Dept
dept = typeof
person :: Type Person
person = typeof
employee :: Type Employee
employee = typeof
salary :: Type Salary
salary = typeof

-- | Increment Salaries of Employees

incE' :: Int -> Employee -> Employee
incE' k (E p (S i)) = E p $ S $ i*(1+k)
incE :: Int -> Pf (Employee -> Employee)
incE k = FUN "incE" (incE' k)

increaseEmployee :: Int -> Pf (Company -> Company)
increaseEmployee k = APPLY company $ EVERYWHERE $ MKT employee (incE k)

evalIncE = eval typeof (increaseEmployee 1) genCom
reduceIncE = reduceIO (optimise_tp >>> optimise_pf >>> beautify_pf) typeof (increaseEmployee 1)

-- | Increment All Salaries

incS :: Int -> Pf (Salary -> Salary)
incS k = INN .= FUN "incS" (*(1+k)) .= OUT

increaseSalary :: Int -> Pf (Company -> Company)
increaseSalary k = APPLY company $ EVERYWHERE $ MKT salary (incS k)

evalIncS = eval typeof (increaseSalary 1) genCom
reduceIncS = reduceIO (optimise_tp >>> optimise_pf >>> beautify_pf) typeof (increaseSalary 1)

-- | Sum All Salaries

bills :: Pf (Salary -> Int)
bills = OUT

salaryBill :: Pf (Company -> Int)
salaryBill = APPLYQ company $ EVERYTHING $ MKQ salary bills

evalBill = eval typeof salaryBill genCom
reduceBill = reduceIO (optimise_tu >>> optimise_pf >>> beautify_pf) typeof salaryBill

billE' :: Employee -> Int
billE' (E _ (S i)) = i
billE :: Pf (Employee -> Int)
billE = FUN "billE" billE'

salaryBillE :: Pf (Company -> Int)
salaryBillE = APPLYQ company $ EVERYTHING $ MKQ employee billE

evalBillE = eval typeof salaryBillE genCom
reduceBillE = reduceIO (optimise_tu >>> optimise_pf >>> beautify_pf) typeof salaryBillE