Skip to content

Instantly share code, notes, and snippets.

@soupi soupi/Plate.hs

Last active Jan 30, 2020
Embed
What would you like to do?
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
You can’t perform that action at this time.