Turn ElField into a newtype (VinylRecords#150)

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

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.

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

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))

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

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

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 #-}

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