{-# OPTIONS_GHC -fglasgow-exts #-}
module DeriveHand where
import Data
import Data.Generics.Biplate
import Data.Generics.Str
instance Uniplate NExpr where
uniplate x =
case x of
NNeg a -> (One a , \(One a') -> NNeg a' )
NAdd a b -> (Two (One a) (One b) , \(Two (One a') (One b')) -> NAdd a' b' )
NSub a b -> (Two (One a) (One b) , \(Two (One a') (One b')) -> NSub a' b' )
NMul a b -> (Two (One a) (One b) , \(Two (One a') (One b')) -> NMul a' b' )
NDiv a b -> (Two (One a) (One b) , \(Two (One a') (One b')) -> NDiv a' b' )
_ -> (Zero , \_ -> x )
instance Biplate NExpr NExpr where
biplate x = (Zero, const x)
instance Biplate NStm NVar where
biplate x =
case x of
NSDecl a b -> (One b, \(One b') -> NSDecl a b')
NSAss a b -> (Two (One a) get, \(Two (One a') bs) -> NSAss a' (gen bs))
where (get,gen) = biplate b
NSBlock xs -> (get, \xs -> NSBlock (gen xs))
where (get,gen) = biplate xs
NSReturn x -> (get, \xs -> NSReturn (gen xs))
where (get,gen) = biplate x
instance Uniplate NVar where
uniplate x = (Zero, \_ -> x)
instance Biplate NExp NVar where
biplate x =
case x of
NEStm x -> (get, \xs -> NEStm (gen xs))
where (get,gen) = biplate x
NEAdd x y -> (Two get1 get2, \(Two a b) -> NEAdd (gen1 a) (gen2 b))
where
(get1,gen1) = biplate x
(get2,gen2) = biplate y
NEVar x -> (One x, \(One x') -> NEVar x')
_ -> (Zero, \_ -> x)
instance (Biplate y x, Uniplate x) => Biplate [y] x where
biplate [] = (Zero, \_ -> [])
biplate (x:xs) = (Two get1 get2, \(Two a b) -> gen1 a : gen2 b)
where
(get1,gen1) = biplate x
(get2,gen2) = biplate xs
instance Biplate NStm NStm where
biplate x = (One x, \(One x') -> x')
instance Uniplate NStm where
uniplate x =
case x of
NSAss a b -> (get,\xs -> NSAss a (gen xs))
where (get,gen) = biplate b
NSBlock a -> (get,\xs -> NSBlock (gen xs))
where (get,gen) = biplate a
NSReturn a -> (get,\xs -> NSReturn (gen xs))
where (get,gen) = biplate a
_ -> (Zero, \_ -> x)
instance Biplate NExp NStm where
biplate x =
case x of
NEStm a -> (One a, \(One a') -> NEStm a')
NEAdd a b -> (Two get1 get2, \(Two a b) -> NEAdd (gen1 a) (gen2 b))
where
(get1,gen1) = biplate a
(get2,gen2) = biplate b
_ -> (Zero, \_ -> x)
instance Biplate NStm NExp where
biplate x =
case x of
NSAss a b -> (One b, \(One b') -> NSAss a b')
NSReturn a -> (One a, \(One a') -> NSReturn a')
NSBlock a -> (get,\xs -> NSBlock (gen xs))
where (get,gen) = biplate a
_ -> (Zero, \_ -> x)
instance Uniplate NExp where
uniplate x =
case x of
NEStm a -> (get, \xs -> NEStm (gen xs))
where (get,gen) = biplate a
NEAdd a b -> (Two (One a) (One b), \(Two (One a') (One b')) -> NEAdd a' b')
_ -> (Zero, \_ -> x)
instance Biplate NCompany NSalary where
biplate (NC xs) = (get, \xs -> NC (gen xs))
where (get,gen) = biplate xs
instance Biplate NDept NSalary where
biplate (ND a (NE b c) d) = (Two (One c) get, \(Two (One x) xs) -> ND a (NE b x) (gen xs))
where (get,gen) = biplate d
instance Biplate NUnt NSalary where
biplate (NPU (NE a b)) = (One b, \(One x) -> NPU (NE a x))
biplate (NDU x) = (get, \xs -> NDU (gen xs))
where (get,gen) = biplate x
instance Uniplate NSalary where
uniplate x = (Zero, \_ -> x)
instance Biplate NCompany NDept where
biplate (NC x) = (listStr x, NC . strList)
instance Biplate NUnt NDept where
biplate (NDU x) = (One x, \(One x') -> NDU x')
biplate x = (Zero, \_ -> x)
instance Uniplate NDept where
uniplate (ND a b c) = (get, \xs -> ND a b (gen xs))
where (get,gen) = biplate c
{-
data NCompany = NC [NDept] deriving Show
data NDept = ND String NEmployee [NUnt] deriving Show
data NUnt = NPU NEmployee | NDU NDept deriving Show
data NEmployee = NE NPerson NSalary deriving Show
data NPerson = NP String String deriving Show
data NSalary = NS Float deriving Show
-}