From 34c8305328392daa06b7d63ce85068a56ceb282e Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 16 May 2021 17:09:37 +0200 Subject: [PATCH] Turn ElField into a newtype (#150) --- Data/Vinyl.hs | 2 +- Data/Vinyl/Class/Method.hs | 18 +++++++-------- Data/Vinyl/Derived.hs | 2 +- Data/Vinyl/Functor.hs | 8 ++++--- benchmarks/AccessorsBench.hs | 45 ++++++++++++++++++++++-------------- benchmarks/Bench/ARec.hs | 7 +++++- benchmarks/Bench/SRec.hs | 34 +++++++++++++++++++++++++++ vinyl.cabal | 1 + 8 files changed, 85 insertions(+), 32 deletions(-) create mode 100644 benchmarks/Bench/SRec.hs diff --git a/Data/Vinyl.hs b/Data/Vinyl.hs index 8057615..ed426ea 100644 --- a/Data/Vinyl.hs +++ b/Data/Vinyl.hs @@ -13,7 +13,7 @@ module Data.Vinyl import Data.Vinyl.Core import Data.Vinyl.Class.Method (RecMapMethod(..), RecPointed(..)) -import Data.Vinyl.Class.Method (rmapMethodF, mapFields) +import Data.Vinyl.Class.Method (rmapMethodF) import Data.Vinyl.Class.Method (rtraverseInMethod, rsequenceInFields) import Data.Vinyl.ARec (ARec, toARec, fromARec) import Data.Vinyl.Derived diff --git a/Data/Vinyl/Class/Method.hs b/Data/Vinyl/Class/Method.hs index d10774a..f0fbdb8 100644 --- a/Data/Vinyl/Class/Method.hs +++ b/Data/Vinyl/Class/Method.hs @@ -28,7 +28,7 @@ module Data.Vinyl.Class.Method ( -- * Mapping methods over records RecMapMethod(..) , rmapMethodF - , mapFields + -- , mapFields , RecMapMethod1(..) , RecPointed(..) , rtraverseInMethod @@ -212,14 +212,14 @@ rmapMethodF :: forall c f ts. (Functor f, FieldPayload f ~ 'FieldId, RecMapMetho rmapMethodF f = rmapMethod @c (fmap f) {-# INLINE rmapMethodF #-} --- | Apply a typeclass method to each field of a 'FieldRec'. This is a --- specialization of 'rmapMethod'. -mapFields :: forall c ts. RecMapMethod c ElField ts - => (forall a. c a => a -> a) -> FieldRec ts -> FieldRec ts -mapFields f = rmapMethod @c g - where g :: c (PayloadType ElField t) => ElField t -> ElField t - g (Field x) = Field (f x) -{-# INLINE mapFields #-} +-- -- | Apply a typeclass method to each field of a 'FieldRec'. This is a +-- -- specialization of 'rmapMethod'. +-- mapFields :: forall c ts. RecMapMethod c ElField ts +-- => (forall a. c a => a -> a) -> FieldRec ts -> FieldRec ts +-- mapFields f = rmapMethod @c g +-- where g :: c (PayloadType ElField t) => ElField t -> ElField t +-- g (Field x) = Field (f x) +-- {-# INLINE mapFields #-} -- | Like 'rtraverseIn', but the function between functors may be -- constrained. diff --git a/Data/Vinyl/Derived.hs b/Data/Vinyl/Derived.hs index a1bd071..6ed7582 100644 --- a/Data/Vinyl/Derived.hs +++ b/Data/Vinyl/Derived.hs @@ -46,7 +46,7 @@ getField :: ElField '(s,t) -> t getField (Field x) = x -- | Get the label name of an 'ElField'. -getLabel :: forall s t. ElField '(s,t) -> String +getLabel :: forall s t. KnownSymbol s => ElField '(s,t) -> String getLabel (Field _) = symbolVal (Proxy::Proxy s) -- | 'ElField' is isomorphic to a functor something like @Compose diff --git a/Data/Vinyl/Functor.hs b/Data/Vinyl/Functor.hs index 8d66021..1ec1866 100644 --- a/Data/Vinyl/Functor.hs +++ b/Data/Vinyl/Functor.hs @@ -41,7 +41,7 @@ import Foreign.Ptr (castPtr) import Foreign.Storable import GHC.Generics import GHC.TypeLits -import GHC.Types (Type) +import Data.Vinyl.TypeLevel (Snd) {- $introduction This module provides functors and functor compositions @@ -107,8 +107,10 @@ newtype Const (a :: *) (b :: k) -- | A value with a phantom 'Symbol' label. It is not a -- Haskell 'Functor', but it is used in many of the same places a -- 'Functor' is used in vinyl. -data ElField (field :: (Symbol, Type)) where - Field :: KnownSymbol s => !t -> ElField '(s,t) +-- +-- Morally: newtype ElField (s, t) = Field t +-- But GHC doesn't allow that +newtype ElField (t :: (Symbol, *)) = Field (Snd t) deriving instance Eq t => Eq (ElField '(s,t)) deriving instance Ord t => Ord (ElField '(s,t)) diff --git a/benchmarks/AccessorsBench.hs b/benchmarks/AccessorsBench.hs index 6d29823..5fe3c07 100644 --- a/benchmarks/AccessorsBench.hs +++ b/benchmarks/AccessorsBench.hs @@ -7,6 +7,7 @@ import Control.Monad (unless) import Criterion.Main +import GHC.Arr import Data.Monoid (Endo(..)) import Data.Vinyl import Data.Vinyl.Syntax () @@ -15,7 +16,8 @@ import System.Exit (exitFailure) import qualified Bench.ARecOld as ARecOld import Bench.ARec -import Bench.Rec +import Bench.SRec +import Bench.Rec data HaskRec = HaskRec { a0 :: Int, @@ -126,6 +128,8 @@ main = arec = mkARec 0 arecOld = ARecOld.mkARec 0 srec = toSRec newF + arr = listArray (0,0) [0] + smallArr = mkSmallArray (0 :: Int) unless (rvalf #a15 arec == rvalf #a15 newF) (do putStrLn "AFieldRec accessor disagrees with rvalf" exitFailure) @@ -145,15 +149,21 @@ main = (do putStrLn "ARec record updates are inconsistent" exitFailure) defaultMain - [ {-bgroup "Update" + [ bgroup "primitives" + [ bench "pattern match" $ whnf a0 haskRec + , bench "array access" $ whnf (! 0) arr + , bench "small array access" $ whnf readSmallArray smallArr + ] + {-bgroup "Update" [ bench "Haskell Record" $ nf (a15 . updateHaskRec) haskRec , bench "Rec" $ nf (rvalf #a15 . updateRec) newF , bench "ARec" $ nf (rvalf #a15 . updateARec) arec , bench "SRec" $ nf (rvalf #a15 . updateSRec) srec ] , -} - bgroup "creating" + , bgroup "creating" [ bench "vinyl record" $ whnf mkRec 0 + , bench "toSRec" $ whnf mkToSRec 0 , bench "Old style ARec with toARec " $ whnf ARecOld.mkToARec 0 , bench "Old style ARec with toARecFast " $ whnf ARecOld.mkToARecFast 0 , bench "Old style ARec with arec " $ whnf ARecOld.mkARec 0 @@ -166,24 +176,25 @@ main = {- , bench "strict haskell record" $ whnf sumSHaskRec shaskRec , bench "unboxed strict haskell record" $ whnf sumUSHaskRec ushaskRec -} + , bench "vinyl SRec" $ nf sumSRec srec , bench "vinyl Rec" $ nf sumRec newF , bench "vinyl ARec" $ nf sumARec arec , bench "vinyl ARec Old" $ nf ARecOld.sumARec arecOld ] - , bgroup "FieldRec" - [ bench "a0" $ nf (rvalf #a0) newF - , bench "a4" $ nf (rvalf #a4) newF - , bench "a8" $ nf (rvalf #a8) newF - , bench "a12" $ nf (rvalf #a12) newF - , bench "a15" $ nf (rvalf #a15) newF - ] - , bgroup "AFieldRec" - [ bench "a0" $ nf (rvalf #a0) arec - -- , bench "a4" $ nf (rvalf #a4) arec - -- , bench "a8" $ nf (rvalf #a8) arec - -- , bench "a12" $ nf (rvalf #a12) arec - , bench "a15" $ nf (rvalf #a15) arec - ] + -- , bgroup "FieldRec" + -- [ bench "a0" $ nf (rvalf #a0) newF + -- , bench "a4" $ nf (rvalf #a4) newF + -- , bench "a8" $ nf (rvalf #a8) newF + -- , bench "a12" $ nf (rvalf #a12) newF + -- , bench "a15" $ nf (rvalf #a15) newF + -- ] + -- , bgroup "AFieldRec" + -- [ bench "a0" $ nf (rvalf #a0) arec + -- -- , bench "a4" $ nf (rvalf #a4) arec + -- -- , bench "a8" $ nf (rvalf #a8) arec + -- -- , bench "a12" $ nf (rvalf #a12) arec + -- , bench "a15" $ nf (rvalf #a15) arec + -- ] {- , bgroup "SFieldRec" [ bench "a0" $ nf (rvalf #a0) srec -- , bench "a4" $ nf (rvalf #a4) srec diff --git a/benchmarks/Bench/ARec.hs b/benchmarks/Bench/ARec.hs index 4aa8a04..a092eb6 100644 --- a/benchmarks/Bench/ARec.hs +++ b/benchmarks/Bench/ARec.hs @@ -5,7 +5,12 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} -module Bench.ARec where +module Bench.ARec + ( module Bench.ARec + , mkSmallArray + , readSmallArray + ) +where import Data.Vinyl import Data.Vinyl.ARec.Internal diff --git a/benchmarks/Bench/SRec.hs b/benchmarks/Bench/SRec.hs new file mode 100644 index 0000000..7cd8c57 --- /dev/null +++ b/benchmarks/Bench/SRec.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE GADTs #-} + +module Bench.SRec where + +import Data.Vinyl.SRec +import Data.Vinyl + +import Bench.Rec (Fields) + + +mkToSRec :: Int -> SRec ElField Fields +mkToSRec i= toSRec (Field i :& Field i :& Field i :& Field i :& + Field i :& Field i :& Field i :& Field i :& + Field i :& Field i :& Field i :& Field i :& + Field i :& Field i :& Field i :& Field 99 :& + RNil) + + +sumSRec :: SRec ElField Fields -> Int +sumSRec str = + get #a0 str + get #a1 str + get #a2 str + get #a3 str + get #a4 str + + get #a5 str + get #a6 str + get #a7 str + get #a8 str + + get #a9 str + get #a10 str + get #a11 str + get #a12 str + + get #a13 str + get #a14 str + get #a15 str + where + get (label :: Label s) r = + case rget @'(s, Int) r of + Field v -> v + {-# INLINE get #-} diff --git a/vinyl.cabal b/vinyl.cabal index fa3c8ba..301e1a9 100644 --- a/vinyl.cabal +++ b/vinyl.cabal @@ -80,6 +80,7 @@ benchmark accessors main-is: AccessorsBench.hs build-depends: base, criterion, tagged, vinyl, microlens other-modules: Bench.ARec + other-modules: Bench.SRec Bench.Rec Bench.ARecOld ghc-options: -O2