{-# OPTIONS -fglasgow-exts #-}

-----------------------------------------------------------------------------
-- |
-- Maintainer  :  joost.visser@di.uminho.pt, alcino@di.uminho.pt
-- Stability   :  experimental
-- Portability :  portable
--
-- Example of format evolution and data mapping, using a 
-- recursive datatype for employee hierarchies (organograms).
--
-----------------------------------------------------------------------------

module Data.Transform.TwoLevelOrganogramExample where

import Data.Transform.TwoLevel
import Data.List as List
import Control.Monad
import Data.Map as Map

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

{- Adapted from the online \emph{.NET Framework Developer's Guide} (\url{http://msdn.microsoft.com/library/}), for representing employee hierarchies.

<xs:schema xmlns:xs="http://www.w3.org/2001/XMLSchema">
  <xs:element name="Emp" type="EmployeeType" />
  <xs:complexType name="EmployeeType">
    <xs:sequence>
      <xs:element name="Emp" type="EmployeeType" />
    </xs:sequence> 
    <xs:attribute name="EmployeeID" type="xs:ID" />
    <xs:attribute name="FirstName" type="xs:string"/>
    <xs:attribute name="LastName" type="xs:string"/>
  </xs:complexType>
</xs:schema>

-}

data Emp = Emp EmployeeType deriving (Show,Eq)
data EmployeeType = EmployeeType {
        emp_seq :: [EmployeeType],
        job :: String,
        firstName :: String,
        lastName :: String
   } deriving (Show,Eq)

-- emp :: Type EmpT
emp = Tag "Emp" employeeType
employeeType = Mu employeeTypeF
employeeTypeF =
  ((List . Tag "Emp") :@: ID) :*:
  (K $ Tag "job" String) :*:
  (K $ Tag "firstName" String) :*:
  (K $ Tag "lastName" String)

type EmpT = Mu (
  ([] :@: ID) :*:
  (K String) :*:
  (K String) :*:
  (K String)
 )

-- | Map nominal type onto a structural one.
emp2fix :: Emp -> EmpT
emp2fix (Emp et) = ana aux et
 where
  aux (EmployeeType s e f l) = Pair (
          Comp (Prelude.map Id s)) (Pair (
          Const e) (Pair (
          Const f) (
          Const l)))

-- The European Commission
-- http://europa.eu.int/comm/commission_barroso/index_en.htm
ec = Emp $ EmployeeType {
  emp_seq = [
     EmployeeType {
        emp_seq = [
            EmployeeType [] "Driver" "Asdren" "Juniku",  
            EmployeeType [] "Head of Cabinet" "Ben" "Smulders"
         ],
        job = "Competition",
        firstName = "Neelie",
        lastName  = "Kroes" 
      },
     EmployeeType [] "Trade" "Peter" "Mandelson"
   ],
  job = "President",
  firstName = "Durao",
  lastName  = "Barroso"
 }

test = do

  -- Map the original format to a database
  let (Just vw) = toRDB emp
  putStrLn $ showType vw
  
  -- Forward migration
  let rdbType = Prod (Prod 
       Int (
       Map Int (Prod (Prod String String) String))) (
       Map (Prod Int Int) Int) 
  unless (showType vw == show rdbType) $ fail "Different type expected"
  let (Just ecDB) = forth vw rdbType $ emp2fix ec
  putStrLn $ gshow rdbType ecDB
  
  -- Backward migration
  let (Just ec') = back vw rdbType ecDB
  putStrLn $ gshow emp ec'
  unless (gshow emp ec' == gshow emp (emp2fix ec)) $ fail "Original value not recovered"
  
  -- Evolve format to allow several jobs per person.
  -- let (Just vw1) = (once (inside "job" allowRep1)) emp
  -- putStrLn $ showType vw1



testDyn = do

  -- Map the original format to a database
  let (Just vw) = toRDB emp
  putStrLn $ showType vw

  -- Forward migration
  putStrLn "Forward migration ..."
  let (Just ecRdbDyn) = forthDyn vw $ emp2fix ec
  putStrLn $ show ecRdbDyn
  putStrLn $ applyDyn gshow ecRdbDyn
 
  -- Backward migration to original format
  putStrLn "Backward migration to original format ..."
  let (Just ec'') = backDyn vw ecRdbDyn
  unless (ec'' == emp2fix ec) $ fail "Original value not recovered"
  unless (gshow emp ec'' == gshow emp (emp2fix ec)) $ fail "Original value not recovered"
  putStrLn $ gshow emp ec''
  
  -- Backward migration to *different* format
  putStrLn "Backward migration to *different* format ..."
  let empList = List (Prod (Tag "function" String) (Prod (Tag "first" String) (Tag "last" String)))
  -- let (Just vw') = (toRDB >>> (addfield (Map (Prod Int Int) Int) Map.empty) >>> (addfieldl Int (-1))) empList
  let (Just vw') = (toRDB >>> (addfieldl Int (-1)) >>> (addfield (Map (Prod Int Int) Int) Map.empty)) empList
  putStrLn $ showType vw'
  let (Just el) = backDyn vw' ecRdbDyn
  putStrLn $ gshow empList el

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