transformations-0.2.0.0: examples/Expr.hs

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

module Main where

import Generics.MultiRec hiding (show)
import Generics.MultiRec.TH
import Test.QuickCheck
import Test.QuickCheck.Random
import Control.Monad
import Generics.MultiRec.Transformations.Main
import Generics.MultiRec.Transformations.MemoTable

data Expr  =  Var    String
           |  Const  Int
           |  Neg    Expr
           |  Add    Expr Expr
          deriving (Show, Ord, Eq)

data ExprAST :: * -> * where
  Expr :: ExprAST Expr

type instance Ixs ExprAST = '[ Expr ]

$(deriveAll ''ExprAST)

instance Arbitrary Expr where
  shrink (Var v)   = map Var   (shrink v)
  shrink (Const v) = map Const (shrink v)
  shrink (Neg l)   = [l]
  shrink (Add l r) = [l,r]

  arbitrary = sized expr'
    where expr' 0 = oneof [liftM Var arbitrary, liftM Const arbitrary]
          expr' n | n>0 =
                oneof [ liftM Var arbitrary
                      , liftM Const arbitrary
                      , liftM Neg (expr' (pred n))
                      , liftM2 Add subtree subtree ]
            where subtree = expr' (n `div` 2)

expr1, expr2, expr3 :: Expr
expr1  =  Add (Const 1) (Var "a")
expr2  =  Add (Const 1) (Neg (Var "a"))
expr3  =  Add (Var "a") (Const 1)