Uniplate.Data vs hand written Lens.Plated vs generic-lens

Plate.hs

-- stack exec --package uniplate --package criterion -- ghc Plate.hs -O
-- ./Plate --output=results.html


{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE LambdaCase #-}

{-# language DeriveDataTypeable, LambdaCase #-}
{-# LANGUAGE AllowAmbiguousTypes       #-}
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE DuplicateRecordFields     #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TypeApplications          #-}

import Control.Monad
import GHC.Generics
import Data.Data
import qualified Data.Generics.Uniplate.Data as Uniplate
import Criterion.Main

data Expr
  = Lit Int
  | Add Expr Expr
  | Mul Expr Expr
  | Div Expr Expr
  | Sub Expr Expr
  | Neg Expr
  deriving (Show, Eq, Data, Generic)

eval :: Expr -> [Int] -> Int
eval e r = case (e, r) of
  (Lit i, _) -> i
  (Add{}, [r1, r2]) -> r1 + r2
  (Mul{}, [r1, r2]) -> r1 * r2
  (Div{}, [r1, r2]) -> r1 `mod` r2
  (Sub{}, [r1, r2]) -> r1 - r2
  (Neg{}, [r1]) -> 0 - r1

opts :: Expr -> Expr
opts = \case
  Add (Lit 0) e -> e
  Add e (Lit 0) -> e
  Mul (Lit 1) e -> e
  Mul e (Lit 1) -> e
  Mul (Lit 0) _ -> Lit 0
  Mul _ (Lit 0) -> Lit 0
  Neg (Neg e) -> e
  e -> e

main :: IO ()
main = (check *>) $ defaultMain $
  zipWith
    ( \n expr -> bgroup ("expr " ++ show n)
      [ bgroup "transform"
        [ bench "uniplate"  $ whnf (Uniplate.transform opts) expr
        , bench "generic-plate"  $ whnf (transform opts) expr
        ]
      ]
    )
    [1..]
    exprs

check = do
  forM_ (zip [1..] exprs) $ \(i, expr) -> do
    do let
         uniplate = (Uniplate.transform opts) expr
         generic_transform = (transform opts) expr

       unless (uniplate == generic_transform) $
         error $ unlines
           [ "transform/" <> show i
           , "expr:     " <> show expr
           , "uniplate: " <> show uniplate
           , "gplate:   " <> show generic_transform
           ]

  putStrLn "Tests pass. All good."
    

exprs :: [Expr]
exprs =
  [ Lit 1
  , Add (Lit 1) (Lit 2)
  , Mul (Lit 3) (Add (Lit 1) (Lit 2))
  , Sub
    (Mul (Lit 3) (Add (Lit 1) (Lit 2)))
    (Div (Lit 3) (Add (Mul (Lit 3) (Add (Lit 1) (Lit 2))) (Lit 2)))
  , Add
    ( Sub
      (Neg (Mul (Lit 3) (Add (Lit 1) (Lit 2))))
      (Div (Lit 3) (Add (Mul (Lit 3) (Add (Lit 1) (Lit 2))) (Lit 2)))
    )
    (Div (Mul (Lit 3) (Add (Lit 1) (Lit 2))) (Add (Mul (Lit 3) (Add (Lit 1) (Lit 2))) (Lit 2)))
  , Add
    ( Sub
      (Neg (Mul (Lit 0) (Add (Lit 1) (Lit 2))))
      (Div (Lit 3) (Add (Mul (Lit 3) (Add (Lit 1) (Lit 2))) (Lit 2)))
    )
    (Div (Mul (Lit 1) (Add (Lit 1) (Lit 2))) (Add (Mul (Lit 3) (Add (Lit 1) (Lit 2))) (Lit 2)))
  , Add
    ( Sub
      (Neg (Neg (Mul (Lit 0) (Add (Lit 1) (Lit 2)))))
      (Div (Lit 3) (Add (Mul (Lit 3) (Add (Lit 1) (Lit 2))) (Lit 2)))
    )
    (Div (Mul (Lit 1) (Add (Lit 1) (Lit 2))) (Add (Mul (Lit 3) (Add (Lit 1) (Lit 2))) (Lit 2)))
  ]

---------------
-- Transform --
---------------

-- GTransform --

class GTransform a struct where
  gtransform :: (a -> a) -> struct x -> struct x

instance GTransform a U1 where
  gtransform _ U1 = U1
  {-# inline gtransform #-}

instance GTransform a V1 where
  gtransform _ x = x
  {-# inline gtransform #-}

instance {-# OVERLAPPING #-} TransformRec a a => GTransform a (K1 _1 a) where
  gtransform f (K1 a) = K1 (f $ transformRec f a)
  {-# inline gtransform #-}

instance TransformRec a b => GTransform a (K1 _1 b) where
  gtransform f (K1 b) = K1 (transformRec f b)
  {-# inline gtransform #-}

instance (GTransform a x, GTransform a y) => GTransform a (x :+: y) where
  gtransform f = \case
    L1 x -> L1 $ gtransform f x
    R1 y -> R1 $ gtransform f y
  {-# inline gtransform #-}

instance (GTransform a x, GTransform a y) => GTransform a (x :*: y) where
  gtransform f (x :*: y) = gtransform f x :*: gtransform f y
  {-# inline gtransform #-}

instance GTransform a struct => GTransform a (M1 _x _y struct) where
  gtransform f (M1 a) = M1 $ gtransform f a
  {-# inline gtransform #-}

-- TransformRec --

class TransformRec a x where
  transformRec :: (a -> a) -> x -> x
  default transformRec :: Generic x => GTransform a (Rep x) => (a -> a) -> x -> x
  transformRec f x = to (gtransform f (from x))
  {-# inline transformRec #-}

instance {-# OVERLAPPING #-} (Generic b, GTransform a (Rep b)) => TransformRec a b where
  transformRec f x = to (gtransform f (from x))
  {-# inline transformRec #-}

instance {-# overlapping #-} TransformRec a Int where
  transformRec f x = x
  {-# inline transformRec #-}

-- TransformBi --

class TransformBi a x where
  transformBi :: (a -> a) -> x -> x
  default transformBi :: Generic x => GTransform a (Rep x) => (a -> a) -> x -> x
  transformBi f x = to (gtransform f (from x))
  {-# inline transformBi #-}

instance {-# overlapping #-} (Generic x, GTransform x (Rep x)) => TransformBi x x where
  transformBi f x = f (to (gtransform f (from x)))
  {-# inline transformBi #-}

instance {-# overlapping #-} (Generic x, GTransform a (Rep x)) => TransformBi a x


transform :: TransformBi a a => (a -> a) -> a -> a
transform = transformBi
{-# inline transform #-}