Skip to content

Instantly share code, notes, and snippets.

@kosmikus
Created April 18, 2018 12:30
Show Gist options
  • Save kosmikus/c11519a62061c5b5d7bab3893210d6e6 to your computer and use it in GitHub Desktop.
Save kosmikus/c11519a62061c5b5d7bab3893210d6e6 to your computer and use it in GitHub Desktop.
DerivingVia and SOP experiments
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module SOPNF where
import Control.DeepSeq
import Data.Kind
import qualified GHC.Generics as GHC
import Generics.SOP
-- Nothing about the following is truly tied to using generics-sop. A similar
-- construction should work with GHC.Generics as well. But it's a bit nicer
-- with generics-sop because the notion of a code is more explicit.
-- * 'NFData' generically using generics-sop
-- | Generic version of 'rnf', operating on sums of products.
--
grnf :: forall code . (All2 NFData code, All SListI code) => SOP I code -> ()
grnf = rnf . hcollapse . hcmap (Proxy @NFData) (mapIK rnf)
-- | Adapter for using the SOP default with @DerivingVia@.
--
newtype SOPGeneric a = SOPGeneric a
-- | Generic instance just converts and calls 'grnf'.
--
instance (Generic a, All2 NFData (Code a)) => NFData (SOPGeneric a) where
rnf (SOPGeneric x) = grnf @(Code a) (from x)
-- | Example small datatype where we can use the SOP-generic default
-- we just defined.
--
data MySmallType = MySmallType Int Bool
deriving (GHC.Generic, Generic)
deriving NFData via (SOPGeneric MySmallType)
-- * Lifting instances via SOP-compatible codes
-- | Collection of constraints that expesses that a given type @a@ has an SOP code
-- that is compatible with @code@. Here, compatibility of two codes means that all
-- types occurring in the codes are pointwise coercible into each other.
--
type SOPCompatible (a :: Type) (code :: [[Type]]) =
( Generic a
, AllZip2 (LiftedCoercible I I) (Code a) code
, All SListI code
)
-- | A modified version of 'from' that does not map a type to its SOP representation,
-- but to a given compaitble SOP representation as indicated by @code@.
--
fromCompatible :: forall a code . (SOPCompatible a code) => a -> SOP I code
fromCompatible = hcoerce . from
-- | Adapter for making use of an SOP-compatible code in instances.
--
newtype SOPCompatibleWith a (code :: [[Type]]) = SOPCompatibleWith a
-- | Adapted instance can reuse the same 'grnf' as above.
--
instance (SOPCompatible a code, All2 NFData code) => NFData (SOPCompatibleWith a code) where
rnf (SOPCompatibleWith x) = grnf @code (fromCompatible x)
-- * Example
-- | The purpose of 'Foo' is just to actually check whether it all works as expected,
-- as there *is* an instance @NFData (a -> b)@, but there is no instance @NFData Foo@.
--
newtype Foo = Foo (Int -> Char)
-- | We use the 'Ignore' newtype as an adapter so that we do not have to provide an
-- 'NFData' instance for the wrapped type.
--
newtype Ignore a = Ignore { runIgnore :: a }
-- | Instance that ignores the wrapped type.
--
instance NFData (Ignore a) where
rnf _ = ()
-- | Another small datatype which makes use of 'Foo', so that we cannot
-- use the normal 'NFData' instances.
--
data AnotherSmallType = AnotherSmallType Int Foo Bool
deriving (GHC.Generic, Generic)
deriving NFData via (AnotherSmallType `SOPCompatibleWith` '[ '[ Int, Ignore Foo, Bool ] ])
-- * Computing the modified / compatible code via type-level functions
-- The following three type families recursively traverse the list of list
-- of types that is a code and replace all members of the exclusion list with
-- 'Ignore'-wrapped versions.
--
-- Of course, this can be done in various other ways that would be more
-- generic and reusable for other similar replacement / modification operations.
type family Exclude (es :: [Type]) (code :: [[Type]]) :: [[Type]] where
Exclude es '[] = '[]
Exclude es (x : xs) = Exclude' es x ': Exclude es xs
type family Exclude' (es :: [Type]) (xs :: [Type]) :: [Type] where
Exclude' es '[] = '[]
Exclude' es (a : xs) = Exclude'' es a : Exclude' es xs
type family Exclude'' (es :: [Type]) (x :: Type) :: Type where
Exclude'' '[] x = x
Exclude'' (e : es) e = Ignore e
Exclude'' (e : es) x = Exclude'' es x
-- | Adapter for using a code with excluded types in instances.
newtype Excluding (es :: [Type]) (a :: Type) = Excluding a
-- | The `NFData` instance for 'Excluding' can be derived.
-- Standalone deriving is necessary here because the context cannot
-- be inferred. (Not entirely clear to me why not.)
--
deriving via (a `SOPCompatibleWith` Exclude es (Code a))
instance (SOPCompatible a (Exclude es (Code a)), All2 NFData (Exclude es (Code a))) => NFData (Excluding es a)
-- | Example of somewhat bigger type using exclusion by type.
--
data MyBigType =
MyBigType
{ f1 :: Int
, f2 :: Double
, f3 :: Foo
, f4 :: Char
}
deriving (GHC.Generic, Generic)
deriving NFData via (Excluding '[ Foo ] MyBigType)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment