KURE

I've been using Andy Gill's KURE, unfortunately there aren't many examples on the web. Here are two versions of Company the SYB example. One version has handwritten bolierplate, they other uses kure-your-boilerplate. The Template Haskell generated by kyb has problems with the monomorphism restriction - it needs to be turned off, otherwise there will be type errors for crushU. Also the Generic union type - here CGeneric - needs a (hand-coded) instance of Term where the Generic is its own Generic root!

{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE NoMonomorphismRestriction  #-}
{-# OPTIONS -Wall #-}

-- NOTE - without NoMonomorphismRestriction, the generated 
-- function crushU has type errors


module Company where

import Language.KURE
import Language.KURE.Boilerplate

import Control.Monad
import Control.Monad.Identity
import Data.Monoid



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

-- An illustrative company
genCom :: Company
genCom = C [D "Research" joe  [PU mike, PU kate],
            D "Strategy" mary []]

joe, mike, kate, mary :: Employee
joe  = E (P "Joe"  "Oregon") (S 8000)
mike = E (P "Mike" "Boston") (S 1000)
kate = E (P "Kate" "San Diego") (S 2000)
mary = E (P "Mary" "Washington") (S 100000)


data CGeneric = GCompany  Company
              | GDept     Dept
              | GUnt      Unt
              | GEmployee Employee
              | GPerson   Person
              | GSalary   Salary

instance Term Company where
  type Generic Company  = CGeneric
  inject                = GCompany
  select (GCompany a)   = Just a
  select _              = Nothing               

instance Term Dept where
  type Generic Dept     = CGeneric
  inject                = GDept
  select (GDept a)      = Just a
  select _              = Nothing               

instance Term Unt where
  type Generic Unt      = CGeneric
  inject                = GUnt
  select (GUnt a)       = Just a
  select _              = Nothing               

instance Term Employee where
  type Generic Employee = CGeneric
  inject                = GEmployee
  select (GEmployee a)  = Just a
  select _              = Nothing               

instance Term Person where
  type Generic Person   = CGeneric
  inject                = GPerson
  select (GPerson a)    = Just a
  select _              = Nothing               


instance Term Salary where
  type Generic Salary   = CGeneric
  inject                = GSalary
  select (GSalary a)    = Just a
  select _              = Nothing               

instance Term CGeneric where
  type Generic CGeneric = CGeneric  -- CGeneric is its own Generic root.
  inject    = id
  select e  = return e


$(kureYourBoilerplate ''CGeneric [(''Identity, ''())])

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



--- Increase salary

-- increase everyone's salary by 10%, topdown.
-- transformer, non-contextual, full, topdown, left-to-right
-- f1 :: Data t => Float -> t -> Maybe t
-- f1 k = traverse Trans NoCtx Full FromTop FromLeft (always $ incS k)

rewriteStep :: Float -> Rewrite Identity () Salary
rewriteStep k = rewrite $ \ e -> return (incS k e)



f1 :: (CGeneric ~ Generic exp, Term exp) 
   => Float -> Rewrite Identity () exp
f1 k = extractR $ topdownR $ tryR $ promoteR (rewriteStep k)


demo1 :: IO ()
demo1 = do 
    print $ runIdentity $ runRewrite (f1 0.10) () genCom
    print $ runIdentity $ runRewrite (f1 0.10) () joe
    print $ runIdentity $ runRewrite (f1 0.10) () (S 10000.0)

Here's a version with handwritten boilerplate, note that the Generic union type (CGeneric) needs a Walker instance just like the other types:

{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# OPTIONS -Wall #-}

module Company where

import Language.KURE

import Control.Monad
import Control.Monad.Identity
import Data.Monoid



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

-- An illustrative company
genCom :: Company
genCom = C [D "Research" joe  [PU mike, PU kate],
            D "Strategy" mary []]

joe, mike, kate, mary :: Employee
joe  = E (P "Joe"  "Oregon") (S 8000)
mike = E (P "Mike" "Boston") (S 1000)
kate = E (P "Kate" "San Diego") (S 2000)
mary = E (P "Mary" "Washington") (S 100000)


data CGeneric = GCompany  Company
              | GDept     Dept
              | GUnt      Unt
              | GEmployee Employee
              | GPerson   Person
              | GSalary   Salary

instance Term Company where
  type Generic Company  = CGeneric
  inject                = GCompany
  select (GCompany a)   = Just a
  select _              = Nothing               

instance Term Dept where
  type Generic Dept     = CGeneric
  inject                = GDept
  select (GDept a)      = Just a
  select _              = Nothing               

instance Term Unt where
  type Generic Unt      = CGeneric
  inject                = GUnt
  select (GUnt a)       = Just a
  select _              = Nothing               

instance Term Employee where
  type Generic Employee = CGeneric
  inject                = GEmployee
  select (GEmployee a)  = Just a
  select _              = Nothing               

instance Term Person where
  type Generic Person   = CGeneric
  inject                = GPerson
  select (GPerson a)    = Just a
  select _              = Nothing               

instance Term Salary where
  type Generic Salary   = CGeneric
  inject                = GSalary
  select (GSalary a)    = Just a
  select _              = Nothing               

instance Term CGeneric where
  type Generic CGeneric = CGeneric  -- CGeneric is its own Generic root.
  inject    = id
  select e  = return e


instance (Monoid dec, Monad m) => Walker m dec Company where
  allR rr   = companyR (extractR rr)
  crushU rr = companyU (extractU rr)


companyR :: (Monoid dec, Monad m) 
         => Rewrite m dec Dept -> Rewrite m dec Company
companyR rr = transparently $ translate $ \ (C xs) -> 
    liftM C (mapM (apply rr) xs)
   

companyU :: (Monad m, Monoid dec, Monoid r)
         => Translate m dec Dept r -> Translate m dec Company r
companyU rr = translate $ \ (C xs) -> 
    liftM mconcat $ mapM (apply rr) xs


instance (Monoid dec, Monad m) => Walker m dec Dept where
  allR rr   = deptR (extractR rr) (extractR rr)
  crushU rr = deptU (extractU rr) (extractU rr)


deptR :: (Monoid dec, Monad m) 
    => Rewrite m dec Employee -> Rewrite m dec Unt -> Rewrite m dec Dept
deptR rr1 rr2  = transparently $ translate $ \ (D name m us) -> 
    liftM2 (D name) (apply rr1 m) (mapM (apply rr2) us)
   

deptU :: (Monad m, Monoid dec, Monoid r)
     => Translate m dec Employee r -> Translate m dec Unt r
     -> Translate m dec Dept r 
deptU rr1 rr2 = translate $ \ (D _ a xs) -> 
    liftM2 mappend (apply rr1 a) (liftM mconcat (mapM (apply rr2) xs))




instance (Monoid dec, Monad m) => Walker m dec Unt where
  allR rr   = puR (extractR rr) 
           <+ duR (extractR rr)
  crushU rr = puU (extractU rr) 
           <+ duU (extractU rr)


puR :: (Monoid dec, Monad m) 
    => Rewrite m dec Employee -> Rewrite m dec Unt
puR rr = transparently $ translate $ \ e -> case e of
    PU e1 -> liftM PU (apply rr e1)
    _     -> fail "puR"

puU :: (Monad m, Monoid dec, Monoid r)
     => Translate m dec Employee r -> Translate m dec Unt r
puU rr = translate $ \ e -> case e of 
    PU e1 -> apply rr e1
    _     -> fail "puU"

duR :: (Monoid dec, Monad m) 
    => Rewrite m dec Dept -> Rewrite m dec Unt
duR rr = transparently $ translate $ \ e -> case e of
    DU d1 -> liftM DU (apply rr d1)
    _     -> fail "duR"

duU :: (Monad m, Monoid dec, Monoid r)
     => Translate m dec Dept r -> Translate m dec Unt r
duU rr = translate $ \ e -> case e of 
    DU d1 -> apply rr d1
    _     -> fail "duU"


instance (Monoid dec, Monad m) => Walker m dec Employee where
  allR rr   = employeeR (extractR rr) (extractR rr)
  crushU rr = employeeU (extractU rr) (extractU rr)


employeeR :: (Monoid dec, Monad m) 
          => Rewrite m dec Person -> Rewrite m dec Salary 
          -> Rewrite m dec Employee
employeeR rr1 rr2 = transparently $ translate $ \ (E p s) ->
    liftM2 E (apply rr1 p) (apply rr2 s)

employeeU :: (Monad m, Monoid dec, Monoid r)
          => Translate m dec Person r -> Translate m dec Salary r
          -> Translate m dec Employee r
employeeU rr1 rr2 = translate $ \ (E p s) ->
    liftM2 mappend (apply rr1 p) (apply rr2 s)


instance (Monoid dec, Monad m) => Walker m dec Person where
  allR _   = personR
  crushU _ = personU

personR :: (Monoid dec, Monad m)
        => Rewrite m dec Person
personR = transparently $ rewrite $ return 

personU :: (Monad m, Monoid dec, Monoid r)
        => Translate m dec Person r
personU = translate $ \ _ -> return mempty


instance (Monoid dec, Monad m) => Walker m dec Salary where
  allR _   = salaryR
  crushU _ = salaryU

salaryR :: (Monoid dec, Monad m)
        => Rewrite m dec Salary
salaryR = transparently $ rewrite $ return 

salaryU :: (Monad m, Monoid dec, Monoid r)
        => Translate m dec Salary r
salaryU = translate $ \ _ -> return mempty



instance (Monoid dec, Monad m) => Walker m dec CGeneric where
  allR rr = promoteR (companyR (extractR rr))
         <+ promoteR (deptR (extractR rr) (extractR rr))
         <+ promoteR (puR (extractR rr) <+ duR (extractR rr))
         <+ promoteR (employeeR (extractR rr) (extractR rr))
         <+ promoteR personR
         <+ promoteR salaryR
  crushU rr = promoteU (companyU (extractU rr))
           <+ promoteU (deptU (extractU rr) (extractU rr))
           <+ promoteU (puU (extractU rr) <+ duU (extractU rr))
           <+ promoteU (employeeU (extractU rr) (extractU rr))
           <+ promoteU personU
           <+ promoteU salaryU



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



--- Increase salary

-- increase everyone's salary by 10%, topdown.
-- transformer, non-contextual, full, topdown, left-to-right
-- f1 :: Data t => Float -> t -> Maybe t
-- f1 k = traverse Trans NoCtx Full FromTop FromLeft (always $ incS k)

rewriteStep :: (Monad m, Monoid dec) => Float -> Rewrite m dec Salary
rewriteStep k = rewrite $ \ e -> return (incS k e)


f1 :: (Monad m, Monoid dec, Term exp, CGeneric ~ Generic exp) 
   => Float -> Rewrite m dec exp
f1 k = extractR $ topdownR $ tryR $ promoteR (rewriteStep k)


demo1 :: IO ()
demo1 = do 
    print $ runIdentity $ runRewrite (f1 0.10) () genCom
    print $ runIdentity $ runRewrite (f1 0.10) () joe
    print $ runIdentity $ runRewrite (f1 0.10) () (S 10000.0)