transformations-0.1.1.0: examples/MultiRec.hs

{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE TypeSynonymInstances  #-}
{-# LANGUAGE EmptyDataDecls        #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE StandaloneDeriving    #-}

module MultiRec where

import Datatypes
import Generics.MultiRec.Any
import Generics.MultiRec.Transformations.RewriteRules as RR
import Generics.MultiRec.Transformations.ZipperState
import Generics.MultiRec.Transformations.Explicit as Ex
import Generics.MultiRec.Transformations.TH
import Generics.MultiRec.Rewriting
import Generics.MultiRec.Zipper

import Generics.MultiRec hiding (show)
import Generics.MultiRec.TH

import Control.Monad ( (>=>) )

--------------------------------------------------------------------------------
-- Multirec representations for the example datatypes
--------------------------------------------------------------------------------
data TreeAST :: * -> * where
  Tree :: TreeAST Tree

$(deriveAll ''TreeAST)

data ListAST :: * -> * -> * where
  List :: ListAST a (List a)

$(deriveAll ''ListAST)

data XAST :: * -> * where
  X :: XAST X

$(deriveAll ''XAST)

data ZigZag :: * -> * where
  Zig :: ZigZag Zig
  Zag :: ZigZag Zag

$(deriveAll ''ZigZag)

data AST i where
  BExpr  :: AST BExpr
  AExpr  :: AST AExpr
  Stmt   :: AST Stmt

$(deriveAll ''AST)

--------------------------------------------------------------------------------
-- Rewrite rules solution
--------------------------------------------------------------------------------
instance RR.Transform AST

-- Now we can simply do the above transformation in a nice way!
rr = RR.apply [insert (down >=> right >=> right) change] Stmt prog1 == Just prog2
  where
    change = rule $ \e a b -> If e a b :~> If (Not e) b a

-- The same one in two steps, which illustrates that rules can be of different
-- types
rr2 = RR.apply [ insert (down >=> right >=> right) swap
               , insert down addNot] Stmt prog1          == Just prog2
  where
    swap   :: Rule AST Stmt
    swap   = rule $ \e a b -> If e a b :~> If e b a
    addNot :: Rule AST BExpr
    addNot = rule $ \e -> e :~> Not e

--------------------------------------------------------------------------------
-- Zipper with state
--------------------------------------------------------------------------------
zs = navigate Stmt prog1 $ do
  downMonad >> rightMonad >> rightMonad
  -- Swap
  l <- downMonad >> rightMonad
  r <- rightMonad
  updateMonad (\p _ -> matchAny p l)
  leftMonad
  updateMonad (\p _ -> matchAny p r)
  -- Add the not
  leftMonad
  updateMonad (\p e -> case p of
                  BExpr -> Just (Not e)
                  _     -> Nothing)

--------------------------------------------------------------------------------
-- Explicit
--------------------------------------------------------------------------------
instance Ex.Transform AST

-- Ordering index of AST as AExpr < BExpr < Stmt
instance OrdI AST where
  indexI AExpr = 0
  indexI BExpr = 1
  indexI Stmt  = 2

$(deriveRefRep ''AST (postfix "EH"))
deriving instance Show AExprEH
deriving instance Show BExprEH
deriving instance Show StmtEH

-- Show existentials
instance Show (NiceInsert AST) where
  show (NiceInsert AExpr x l) = "NiceInsert AExpr " ++ show x ++ " (" ++ show l ++ ")"
  show (NiceInsert BExpr x l) = "NiceInsert BExpr " ++ show x ++ " (" ++ show l ++ ")"
  show (NiceInsert Stmt x l)  = "NiceInsert Stmt " ++ show x ++ " (" ++ show l ++ ")"

-- Actual example
{- This prints: (note the different reference types here)
  [ NiceInsert BExpr [2,0] (NotEH (RefBExpr [2,0]))
  , NiceInsert Stmt [2,1] (RefStmt [2,2])
  , NiceInsert Stmt [2,2] (RefStmt [2,1]) ]
-}
expl1 = print $ toNiceTransformation $ diff Stmt prog1 prog2
expl2 = print $ toNiceTransformation $ diff Stmt prog3 prog4
expl3 = print $ toNiceTransformation $ diff Stmt prog5 prog6