Uniplate.Data vs hand written Lens.Plated vs generic-lens
-- 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 #-} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment