{-# OPTIONS_GHC -fglasgow-exts #-}

module Data where

import Data.Generics


-- * SECTION 1

data Expr  =  Val  Int         -- a literal value
           |  Var  String      -- a variable
           |  Neg  Expr        -- negation
           |  Add  Expr  Expr  -- addition
           |  Sub  Expr  Expr  -- subtraction
           |  Mul  Expr  Expr  -- multiplication
           |  Div  Expr  Expr  -- division
           deriving (Eq,Show)


-- normal version
data NExpr  =  NVal  Int         -- a literal value
            |  NVar  String      -- a variable
            |  NNeg  NExpr        -- negation
            |  NAdd  NExpr  NExpr  -- addition
            |  NSub  NExpr  NExpr  -- subtraction
            |  NMul  NExpr  NExpr  -- multiplication
            |  NDiv  NExpr  NExpr  -- division
            deriving (Show,Eq,Data,Typeable)


data DExpr

-- Compos version
type CExpr = GExpr DExpr

-- GADT version
data GExpr :: * -> * where
    CVal :: Int           -> GExpr DExpr -- a literal value
    CVar :: String        -> GExpr DExpr -- a variable
    CNeg :: CExpr          -> GExpr DExpr -- negation
    CAdd :: CExpr -> CExpr  -> GExpr DExpr -- addition
    CSub :: CExpr -> CExpr  -> GExpr DExpr -- subtraction
    CMul :: CExpr -> CExpr  -> GExpr DExpr -- multiplication
    CDiv :: CExpr -> CExpr  -> GExpr DExpr -- division


instance Eq (GExpr a) where
    (CVal a1) == (CVal a2) = a1 == a2
    (CVar a1) == (CVar a2) = a1 == a2
    (CNeg a1) == (CNeg a2) = a1 == a2
    (CAdd a1 b1) == (CAdd a2 b2) = a1 == a2 && b1 == b2
    (CSub a1 b1) == (CSub a2 b2) = a1 == a2 && b1 == b2
    (CMul a1 b1) == (CMul a2 b2) = a1 == a2 && b1 == b2
    (CDiv a1 b1) == (CDiv a2 b2) = a1 == a2 && b1 == b2
    _ == _ = False



unwrapN :: Expr -> NExpr
unwrapN x = case x of
    Val x -> NVal x
    Var x -> NVar x
    Neg x -> NNeg (unwrapN x)
    Add x y -> NAdd (unwrapN x) (unwrapN y)
    Sub x y -> NSub (unwrapN x) (unwrapN y)
    Mul x y -> NMul (unwrapN x) (unwrapN y)
    Div x y -> NDiv (unwrapN x) (unwrapN y)

rewrapN :: NExpr -> Expr
rewrapN x = case x of
    NVal x -> Val x
    NVar x -> Var x
    NNeg x -> Neg (rewrapN x)
    NAdd x y -> Add (rewrapN x) (rewrapN y)
    NSub x y -> Sub (rewrapN x) (rewrapN y)
    NMul x y -> Mul (rewrapN x) (rewrapN y)
    NDiv x y -> Div (rewrapN x) (rewrapN y)


unwrapC :: Expr -> CExpr
unwrapC x = case x of
    Val x -> CVal x
    Var x -> CVar x
    Neg x -> CNeg (unwrapC x)
    Add x y -> CAdd (unwrapC x) (unwrapC y)
    Sub x y -> CSub (unwrapC x) (unwrapC y)
    Mul x y -> CMul (unwrapC x) (unwrapC y)
    Div x y -> CDiv (unwrapC x) (unwrapC y)

rewrapC :: CExpr -> Expr
rewrapC x = case x of
    CVal x -> Val x
    CVar x -> Var x
    CNeg x -> Neg (rewrapC x)
    CAdd x y -> Add (rewrapC x) (rewrapC y)
    CSub x y -> Sub (rewrapC x) (rewrapC y)
    CMul x y -> Mul (rewrapC x) (rewrapC y)
    CDiv x y -> Div (rewrapC x) (rewrapC y)


-- * SECTION 2


data Stm = SDecl Typ Var
         | SAss  Var Exp
         | SBlock [Stm]
         | SReturn Exp
         deriving (Eq,Show)

data Exp = EStm Stm
         | EAdd Exp Exp
         | EVar Var
         | EInt Int
         deriving (Eq,Show)

data Var = V String
         deriving (Eq,Show)

data Typ = T_int | T_float
         deriving (Eq,Show)


data NStm = NSDecl NTyp NVar
         | NSAss  NVar NExp
         | NSBlock [NStm]
         | NSReturn NExp
         deriving (Data,Typeable,Show)

data NExp = NEStm NStm
         | NEAdd NExp NExp
         | NEVar NVar
         | NEInt Int
         deriving (Data,Typeable,Show)

data NVar = NV String
         deriving (Data,Typeable,Show)

data NTyp = NT_int | NT_float
         deriving (Data,Typeable,Show)


data CStm; data CExp; data CVar; data CTyp

data CTree :: * -> * where
    CSDecl :: CTree CTyp -> CTree CVar -> CTree CStm
    CSAss :: CTree CVar -> CTree CExp -> CTree CStm
    CSBlock :: [CTree CStm] -> CTree CStm
    CSReturn :: CTree CExp -> CTree CStm
    CEStm :: CTree CStm -> CTree CExp
    CEAdd :: CTree CExp -> CTree CExp -> CTree CExp
    CEVar :: CTree CVar -> CTree CExp
    CEInt :: Int -> CTree CExp
    CV :: String -> CTree CVar
    CT_int :: CTree CTyp
    CT_float :: CTree CTyp


unwrapStmN x = case x of
    SDecl x y -> NSDecl (unwrapTypN x) (unwrapVarN y)
    SAss x y -> NSAss (unwrapVarN x) (unwrapExpN y)
    SBlock x -> NSBlock (map unwrapStmN x)
    SReturn x -> NSReturn (unwrapExpN x)

unwrapExpN x = case x of
    EStm x -> NEStm (unwrapStmN x)
    EAdd x y -> NEAdd (unwrapExpN x) (unwrapExpN y)
    EVar x -> NEVar (unwrapVarN x)
    EInt x -> NEInt x

unwrapVarN (V x) = (NV x)

unwrapTypN x = case x of
    T_int -> NT_int
    T_float -> NT_float


rewrapStmN x = case x of
    NSDecl x y -> SDecl (rewrapTypN x) (rewrapVarN y)
    NSAss x y -> SAss (rewrapVarN x) (rewrapExpN y)
    NSBlock x -> SBlock (map rewrapStmN x)
    NSReturn x -> SReturn (rewrapExpN x)

rewrapExpN x = case x of
    NEStm x -> EStm (rewrapStmN x)
    NEAdd x y -> EAdd (rewrapExpN x) (rewrapExpN y)
    NEVar x -> EVar (rewrapVarN x)
    NEInt x -> EInt x

rewrapVarN (NV x) = (V x)

rewrapTypN x = case x of
    NT_int -> T_int
    NT_float -> T_float



unwrapStmC x = case x of
    SDecl x y -> CSDecl (unwrapTypC x) (unwrapVarC y)
    SAss x y -> CSAss (unwrapVarC x) (unwrapExpC y)
    SBlock x -> CSBlock (map unwrapStmC x)
    SReturn x -> CSReturn (unwrapExpC x)

unwrapExpC x = case x of
    EStm x -> CEStm (unwrapStmC x)
    EAdd x y -> CEAdd (unwrapExpC x) (unwrapExpC y)
    EVar x -> CEVar (unwrapVarC x)
    EInt x -> CEInt x

unwrapVarC (V x) = (CV x)

unwrapTypC x = case x of
    T_int -> CT_int
    T_float -> CT_float


rewrapStmC :: CTree CStm -> Stm
rewrapStmC x = case x of
    CSDecl x y -> SDecl (rewrapTypC x) (rewrapVarC y)
    CSAss x y -> SAss (rewrapVarC x) (rewrapExpC y)
    CSBlock x -> SBlock (map rewrapStmC x)
    CSReturn x -> SReturn (rewrapExpC x)

rewrapExpC :: CTree CExp -> Exp
rewrapExpC x = case x of
    CEStm x -> EStm (rewrapStmC x)
    CEAdd x y -> EAdd (rewrapExpC x) (rewrapExpC y)
    CEVar x -> EVar (rewrapVarC x)
    CEInt x -> EInt x

rewrapVarC :: CTree CVar -> Var
rewrapVarC (CV x) = (V x)

rewrapTypC :: CTree CTyp -> Typ
rewrapTypC x = case x of
    CT_int -> T_int
    CT_float -> T_float


-- * SECTION 3


data Company = C [Dept] deriving Show
data Dept = D String Employee [Unt] deriving Show
data Unt = PU Employee | DU Dept deriving Show
data Employee = E Person Salary deriving Show
data Person = P String String deriving Show
data Salary = S Integer deriving Show

data NCompany = NC [NDept] deriving (Data,Typeable)
data NDept = ND String NEmployee [NUnt] deriving (Data,Typeable)
data NUnt = NPU NEmployee | NDU NDept deriving (Data,Typeable)
data NEmployee = NE NPerson NSalary deriving (Data,Typeable)
data NPerson = NP String String deriving (Data,Typeable)
data NSalary = NS Integer deriving (Data,Typeable)


data CCompany; data CDept
data CUnit; data CEmployee
data CPerson; data CSalary

data Paradise :: * -> * where
    CC :: [Paradise CDept] -> Paradise CCompany
    CD :: String -> Paradise CEmployee -> [Paradise CUnit] -> Paradise CDept
    CPU :: Paradise CEmployee -> Paradise CUnit
    CDU :: Paradise CDept -> Paradise CUnit
    CE :: Paradise CPerson -> Paradise CSalary -> Paradise CEmployee
    CP :: String -> String -> Paradise CPerson
    CS :: Integer -> Paradise CSalary

unwrapCN (C xs) = NC (map unwrapDN xs)
unwrapDN (D a b c) = ND a (unwrapEN b) (map unwrapUN c)
unwrapUN (PU a) = NPU (unwrapEN a)
unwrapUN (DU a) = NDU (unwrapDN a)
unwrapEN (E a b) = NE (unwrapPN a) (unwrapSN b)
unwrapPN (P a b) = NP a b
unwrapSN (S a) = NS a

rewrapCN (NC xs) = C (map rewrapDN xs)
rewrapDN (ND a b c) = D a (rewrapEN b) (map rewrapUN c)
rewrapUN (NPU a) = PU (rewrapEN a)
rewrapUN (NDU a) = DU (rewrapDN a)
rewrapEN (NE a b) = E (rewrapPN a) (rewrapSN b)
rewrapPN (NP a b) = P a b
rewrapSN (NS a) = S a

unwrapCC (C xs) = CC (map unwrapDC xs)
unwrapDC (D a b c) = CD a (unwrapEC b) (map unwrapUC c)
unwrapUC (PU a) = CPU (unwrapEC a)
unwrapUC (DU a) = CDU (unwrapDC a)
unwrapEC (E a b) = CE (unwrapPC a) (unwrapSC b)
unwrapPC (P a b) = CP a b
unwrapSC (S a) = CS a

rewrapCC :: Paradise CCompany -> Company
rewrapCC (CC xs) = C (map rewrapDC xs)

rewrapDC :: Paradise CDept -> Dept
rewrapDC (CD a b c) = D a (rewrapEC b) (map rewrapUC c)

rewrapUC :: Paradise CUnit -> Unt
rewrapUC (CPU a) = PU (rewrapEC a)
rewrapUC (CDU a) = DU (rewrapDC a)

rewrapEC :: Paradise CEmployee -> Employee
rewrapEC (CE a b) = E (rewrapPC a) (rewrapSC b)

rewrapPC :: Paradise CPerson -> Person
rewrapPC (CP a b) = P a b

rewrapSC :: Paradise CSalary -> Salary
rewrapSC (CS a) = S a