import Monad
import Data.Typeable

-- trida Data + funkce (mkT, everywhere,...) jsou definovane v Data.Generics
-- Typeable a Data lze v ghc derivovat (nestandardni rozsireni)

-- shamelessly stolen from "Scrap your boilerplate: a practical design pattern for generic programming"

data Company = C [Dept] deriving (Show,Typeable)
data Dept = D Name Manager [SubUnit] deriving (Show,Typeable)
data SubUnit = PU Employee | DU Dept deriving (Show,Typeable)
data Employee = E Person Salary deriving (Show,Typeable)
data Person = P Name Address deriving (Show,Typeable)
data Salary = S Float deriving (Show,Typeable)
type Manager = Employee
type Name = String
type Address = String

genCom :: Company
genCom = C [D "Research" ralf [PU joost, PU marlow], D "Strategy" blair [DU (D "bla" blae [])]]
ralf, joost, marlow, blair, blae :: 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)
blae = E (P "Blae" "London") (S 100000)

-- zvyseni platu

-- "zajimava cast"
increase :: Float -> Company -> Company
increase k (C ds) = C (map (incD k) ds)

incS :: Float -> Salary -> Salary
incS k (S s) = S (s * (1+k))

-- boilerplate
incD :: Float -> Dept -> Dept
incD k (D nm mgr us) = D nm (incE k mgr) (map (incU k) us)

incU :: Float -> SubUnit -> SubUnit
incU k (PU e) = PU (incE k e)
incU k (DU d) = DU (incD k d)

incE :: Float -> Employee -> Employee
incE k (E p s) = E p (incS k s)

-- chceme reseni bez specializovaneho boilerplatu

increase1 :: Float -> Company -> Company
increase1 k = everywhere (mkT (incS k))

-- mkT -- transformuje funkci tak, aby se dala pouzit na
       -- libovolny typ.  Pro Salary provede zvyseni, jinak
       -- identita

-- pro mkT je potreba pretypovani (v Data.Typeable)

-- class Typeable
-- cast :: (Typeable a, Typeable b) => a -> Maybe b

-- cast 'a'::Maybe Char = Just 'a'
-- cast 'a'::Maybe Bool = Nothing
-- cast (1::Integer)::Maybe Bool = Nothing
-- cast (1::Integer)::Maybe Int = Nothing

mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT f = case cast f of
           Just g -> g
           Nothing -> id

-- (mkT (incS 0.3)) (S 5) = S 6.5
-- (mkT (incS 0.3)) (8::Integer) = 8

-- everywhere -- genericke prochazeni

-- aplikuj funkci na potomky
class Typeable a => Data a where
  gmapT :: (forall b. Data b => b -> b) -> a -> a
  gmapQ :: (forall b. Data b => b -> r) -> a -> [r]

instance Data Company where
  gmapT f (C depts) = C (f depts)
  gmapQ f (C depts) = [f depts]
instance Data Dept where
  gmapT f (D name man subs) = D name (f man) (f subs)
  gmapQ f (D name man subs) = [f man, f subs]
instance Data SubUnit where
  gmapT f (PU emp) = PU (f emp)
  gmapT f (DU dept) = DU (f dept)
  gmapQ f (PU emp) = [f emp]
  gmapQ f (DU dept) = [f dept]
instance Data Employee where
  gmapT f (E per sal) = E (f per) (f sal)
  gmapQ f (E per sal) = [f per, f sal]
instance Data Person where
  gmapT f p = p
  gmapQ f p = []
instance Data Salary where
  gmapT f s = s
  gmapQ f s = []

instance Data a => Data [a] where
  gmapT f [] = []
  gmapT f (x:xs) = f x : f xs
  gmapQ f [] = []
  gmapQ f (x:xs) = [f x, f xs]

-- Apply a transformation everywhere, bottom-up
everywhere :: Data a => (forall b. Data b => b -> b) -> a -> a
everywhere f x = f (gmapT (everywhere f) x)

-- Apply a transformation everywhere, top-down
everywhereR :: Data a => (forall b. Data b => b -> b) -> a -> a
everywhereR f x = gmapT (everywhereR f) (f x)

-- dalsi funkce lze psat bez potreby menit/opakovat boilerplat;
-- zruseni departmentu a presun jeho zamestnancu do nadrazeneho
-- departmentu:

flatten::Name->Company->Company
flatten d = everywhere (mkT (flatD d))

flatD :: Name->Dept->Dept
flatD d (D n m us) = D n m (concatMap unwrap us)
  where
    unwrap (DU (D d' m us)) | d == d' = PU m : us
    unwrap u = [u]

-- dotazy -- kolik utratime za platy?

totalSalary::Company -> Float
totalSalary = everything (+) (0 `mkQ` getSalary)

getSalary::Salary->Float
getSalary (S s) = s

mkQ :: (Typeable a, Typeable b) => r -> (b->r) -> a -> r
mkQ r q a = case cast a of
              Just b -> q b
	      Nothing -> r

everything :: Data a => (r -> r -> r) -> (forall a. Data a => a -> r) -> a -> r
everything k f x = foldl k (f x) (gmapQ (everything k f) x)

-- hledani

find :: MonadPlus m => Name -> Company -> m Dept
find n = everything mplus (mzero `mkQ` findD n)

findD::MonadPlus m => String->Dept -> m Dept
findD n d@(D n' _ _)
  | n == n' = return d
  | otherwise = mzero