{-# 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])) ]