{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE EmptyDataDecls #-}
module Regular where
import Datatypes
import Generics.Regular hiding (right)
import Generics.Regular.Transformations.Explicit as Ex
import Generics.Regular.Transformations.RewriteRules as RR
import Generics.Regular.Zipper
import Generics.Regular.Transformations.ZipperState
import Generics.Regular.Transformations.TH
import Control.Monad ( (>=>) )
import Generics.Regular.Rewriting hiding (left, right)
import Data.Maybe (fromJust)
--------------------------------------------------------------------------------
-- Regular representations for the example datatypes
--------------------------------------------------------------------------------
--Trees
$(deriveAll ''Tree "PFTree")
type instance PF Tree = PFTree
-- Lists
$(deriveAll ''List "PFL")
type instance PF (List a) = PFL a
-- Something more exotic
$(deriveAll ''X "PFX")
type instance PF X = PFX
-- Example for paper (do manual instance to avoid C's)
type instance PF Expr = K String :+: K Integer :+: I :+: I :*: I
instance Regular Expr where
from (Var s) = L (K s)
from (Const i) = R (L (K i))
from (Neg e) = R (R (L (I e)))
from (Add e1 e2) = R (R (R (I e1 :*: I e2)))
to (L (K s)) = Var s
to (R (L (K i))) = Const i
to (R (R (L (I e)))) = Neg e
to (R (R (R (I e1 :*: I e2)))) = Add e1 e2
--------------------------------------------------------------------------------
-- Examples for the paper
--------------------------------------------------------------------------------
-- Some example values
expr1 :: Expr
expr1 = Add (Const 1) (Var "a")
expr2 :: Expr
expr2 = Add (Const 1) (Neg (Var "a"))
expr3 :: Expr
expr3 = Add (Var "a") (Const 1)
instance RR.Transform Expr
instance Ex.Transform Expr
instance Show (Fix (WithRef Expr)) where
show (In (Ref p)) = "Ref " ++ show p
-- Insertion (expr1 => expr2)
rewriteRulesIns :: Maybe Expr
rewriteRulesIns = RR.apply [(down >=> right, rule1)] expr1
where rule1 :: Rule Expr
rule1 = rule $ \x -> x :~> Neg x
zipperStateIns :: Maybe Expr
zipperStateIns = navigate expr1 $ do
downMonad >> rightMonad
updateMonad Neg
explicitIns :: Maybe Expr
explicitIns = Ex.apply addNeg expr1
where addNeg :: Ex.Transformation Expr
addNeg = [ ([1], In . InR . R . R . L . I . In $ Ref [1]) ]
-- Deletion (expr2 => expr1)
rewriteRulesDel :: Maybe Expr
rewriteRulesDel = RR.apply [(down >=> right, rule2)] expr2
where rule2 :: Rule Expr
rule2 = rule $ \x -> Neg x :~> x
zipperStateDel :: Maybe Expr
zipperStateDel = navigate expr2 $ do
r <- downMonad >> rightMonad >> downMonad
upMonad
updateMonad (const r)
explicitDel :: Maybe Expr
explicitDel = Ex.apply delNeg expr2
where delNeg :: Ex.Transformation Expr
delNeg = [ ([1], In (Ref [1,0])) ]
-- Swapping (expr1 => expr3)
rewriteRulesSwap :: Maybe Expr
rewriteRulesSwap = RR.apply [(return, rule3)] expr1
where rule3 :: Rule Expr
rule3 = rule $ \l r -> Add l r :~> Add r l
zipperStateSwap :: Maybe Expr
zipperStateSwap = navigate expr1 $ do
l <- downMonad
r <- rightMonad
updateMonad (const l)
leftMonad
updateMonad (const r)
explicitSwap :: Maybe Expr
explicitSwap = Ex.apply swap' expr1
where swap' :: Ex.Transformation Expr
swap' = [ ([0], In $ Ref [1])
, ([1], In $ Ref [0])]
-- Rotation
rotate1 = Add (Var "a") (Add (Var "b") (Var "c"))
rotate2 = Add (Add (Var "a") (Var "b")) (Var "c")
rotate = diff rotate1 rotate2
--------------------------------------------------------------------------------
-- Other RewriteRules examples
--------------------------------------------------------------------------------
instance RR.Transform Tree
instance RR.Transform X
-- Test swapping two subtrees. Note the nice syntax!
swap :: Rule Tree
swap = rule $ \t1 t2 -> Bin t1 t2 :~> Bin t2 t1
t1 = RR.apply [(return , swap)] exTree4
t2 = RR.apply [(down , swap)] exTree4
t3 = RR.apply [(down >=> right, swap)] exTree4
t4 = RR.apply [(down >=> right, swap), (return, swap)] exTree4 -- == id
-- A tricky example
ruleSwapC, ruleAddB :: Rule X
ruleSwapC = rule $ \x y -> XC x y :~> XC y x
ruleAddB = rule $ \x -> XA x :~> XA (XB x)
t6 = RR.apply [(down >=> down >=> down, ruleSwapC)] exX1
t7 = RR.apply [(down >=> down, ruleAddB)] (fromJust t6)
t8 = RR.apply [(return, ruleAddB)] (fromJust t7)
t9 = t8 == Just exX2 -- True
--------------------------------------------------------------------------------
-- Other ZipperState examples
--------------------------------------------------------------------------------
-- An example using a zipper with state
t5 = navigate exTree4 $
do downMonad >> downMonad
saveMonad
upMonad >> rightMonad >> downMonad >> rightMonad
saveMonad
x1 <- loadMonad
updateMonad (const x1)
upMonad >> leftMonad >> downMonad
x2 <- loadMonad
updateMonad (const x2)
--------------------------------------------------------------------------------
-- A nicer interface for Expr, could be generated using Template Haskell
--------------------------------------------------------------------------------
data ExprEH
= VarEH String
| ConstEH Integer
| NegEH ExprEH
| AddEH ExprEH ExprEH
| RefEH Path
deriving Show
instance HasRef Expr where
type RefRep Expr = ExprEH
toRef (Ref p) = RefEH p
toRef (InR (L (K s))) = VarEH s
toRef (InR (R (L (K i)))) = ConstEH i
toRef (InR (R (R (L (I e))))) = NegEH e
toRef (InR (R (R (R (I e1 :*: I e2))))) = AddEH e1 e2
fromRef (RefEH p) = Ref p
fromRef (VarEH s) = InR (L (K s))
fromRef (ConstEH i) = InR (R (L (K i)))
fromRef (NegEH e) = InR (R (R (L (I e))))
fromRef (AddEH e1 e2) = InR (R (R (R (I e1 :*: I e2))))
$(deriveRefRep ''Tree (postfix "EH"))
deriving instance Show TreeEH
-- Test
instance Ex.Transform Tree
treeSwapNice :: Maybe Tree
treeSwapNice = Ex.apply (fromNiceTransformation swap) exTree1
where swap = [([0],RefTree [1]),([1],RefTree [0])]
treeDiff :: Ex.NiceTransformation Tree
treeDiff = toNiceTransformation $ Ex.diff exTree3 exTree5
explicitInsNice :: Maybe Expr
explicitInsNice = Ex.apply (fromNiceTransformation addNeg) expr1
where addNeg :: NiceTransformation Expr
addNeg = [ ([1], NegEH (RefEH [1])) ]