{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {- | The 'Newtype' typeclass and related functions. Primarily pulled from Conor McBride's Epigram work. Some examples: >>> ala Sum foldMap [1,2,3,4] 10 >>> ala Endo foldMap [(+1), (+2), (subtract 1), (*2)] 3 8 >>> under2 Min (<>) 2 1 1 >>> over All not (All False) All {getAll = True) This package includes 'Newtype' instances for all the (non-GHC\/foreign) newtypes in base (as seen in the examples). However, there are neat things you can do with this with /any/ newtype and you should definitely define your own 'Newtype' instances for the power of this library. For example, see @ala Cont traverse@, with the proper 'Newtype' instance for Cont. You can easily define new instances for your newtypes with the help of GHC.Generics > {-# LANGUAGE DeriveGeneric #-} > import GHC.Generics > > (...) > newtype Example = Example Int > deriving (Generic) > > instance Newtype Example > This avoids the use of Template Haskell (TH) to get new instances. -} module Control.Newtype.Generics ( Newtype(..) , op , ala , ala' , under , over , under2 , over2 , underF , overF ) where import Control.Applicative import Control.Arrow import Data.Functor.Compose import Data.Functor.Identity #if MIN_VERSION_base(4,7,0) import Data.Fixed #endif import Data.Monoid import Data.Ord #if MIN_VERSION_base(4,9,0) import qualified Data.Semigroup import Data.Semigroup (Min(..), Max(..), WrappedMonoid(..), Option(..)) #endif import GHC.Generics {-import Generics.Deriving-} -- | Given a newtype @n@, we will always have the same unwrapped type @o@, -- meaning we can represent this with a fundep @n -> o@. -- -- Any instance of this class just needs to let @pack@ equal to the newtype's -- constructor, and let @unpack@ destruct the newtype with pattern matching. {-class Newtype n o | n -> o where-} {-pack :: o -> n-} {-unpack :: n -> o-} -- Generic Newtype class GNewtype n where type GO n :: * gpack :: GO n -> n p gunpack :: n p -> GO n -- We only need one instance, if these generic functions are only to work for -- newtypes, as these have a fixed form. For example, for a newtype X = Y, -- Rep X = D1 ... (C1 ... (S1 ... (K1 ... Y))) instance GNewtype (D1 d (C1 c (S1 s (K1 i a)))) where type GO (D1 d (C1 c (S1 s (K1 i a)))) = a gpack x = M1 (M1 (M1 (K1 x))) gunpack (M1 (M1 (M1 (K1 x)))) = x -- Original Newtype class, extended with generic defaults (trivial) and deprived -- of the second type argument (less trivial, as it involves a type family with -- a default, plus an equality constraint for the related type family in -- GNewtype). We do get rid of MultiParamTypeClasses and FunctionalDependencies, -- though. -- | As long as the type @n@ is an instance of Generic, you can create an instance -- with just @instance Newtype n@ class Newtype n where type O n :: * type O n = GO (Rep n) pack :: O n -> n default pack :: (Generic n, GNewtype (Rep n), O n ~ GO (Rep n)) => O n -> n pack = to . gpack unpack :: n -> O n default unpack :: (Generic n, GNewtype (Rep n), O n ~ GO (Rep n)) => n -> O n unpack = gunpack . from -- | -- This function serves two purposes: -- -- 1. Giving you the unpack of a newtype without you needing to remember the name. -- -- 2. Showing that the first parameter is /completely ignored/ on the value level, -- meaning the only reason you pass in the constructor is to provide type -- information. Typeclasses sure are neat. -- -- >>> op Identity (Identity 3) -- 3 op :: (Newtype n,o ~ O n ) => (o -> n) -> n -> o op _ = unpack -- | The workhorse of the package. Given a "packer" and a \"higher order function\" (/hof/), -- it handles the packing and unpacking, and just sends you back a regular old -- function, with the type varying based on the /hof/ you passed. -- -- The reason for the signature of the /hof/ is due to 'ala' not caring about structure. -- To illustrate why this is important, consider this alternative implementation of 'under2': -- -- > under2 :: (Newtype n, Newtype n', o' ~ O n', o ~ O n) -- > => (o -> n) -> (n -> n -> n') -> (o -> o -> o') -- > under2' pa f o0 o1 = ala pa (\p -> uncurry f . bimap p p) (o0, o1) -- -- Being handed the "packer", the /hof/ may apply it in any structure of its choosing – -- in this case a tuple. -- -- >>> ala Sum foldMap [1,2,3,4] -- 10 ala :: (Newtype n, Newtype n', o' ~ O n', o ~ O n) => (o -> n) -> ((o -> n) -> b -> n') -> (b -> o') ala pa hof = ala' pa hof id -- | This is the original function seen in Conor McBride's work. -- The way it differs from the 'ala' function in this package, -- is that it provides an extra hook into the \"packer\" passed to the hof. -- However, this normally ends up being @id@, so 'ala' wraps this function and -- passes @id@ as the final parameter by default. -- If you want the convenience of being able to hook right into the hof, -- you may use this function. -- -- >>> ala' Sum foldMap length ["hello", "world"] -- 10 -- -- >>> ala' First foldMap (readMaybe @Int) ["x", "42", "1"] -- Just 42 ala' :: (Newtype n, Newtype n', o' ~ O n', o ~ O n) => (o -> n) -> ((a -> n) -> b -> n') -> (a -> o) -> (b -> o') ala' _ hof f = unpack . hof (pack . f) -- | A very simple operation involving running the function \'under\' the newtype. -- -- >>> under Product (stimes 3) 3 -- 27 under :: (Newtype n, Newtype n', o' ~ O n', o ~ O n) => (o -> n) -> (n -> n') -> (o -> o') under _ f = unpack . f . pack -- | The opposite of 'under'. I.e., take a function which works on the -- underlying types, and switch it to a function that works on the newtypes. -- -- >>> over All not (All False) -- All {getAll = True} over :: (Newtype n, Newtype n', o' ~ O n', o ~ O n) => (o -> n) -> (o -> o') -> (n -> n') over _ f = pack . f . unpack -- | Lower a binary function to operate on the underlying values. -- -- >>> under2 Any (<>) True False -- True -- -- @since 0.5.2 under2 :: (Newtype n, Newtype n', o' ~ O n', o ~ O n) => (o -> n) -> (n -> n -> n') -> (o -> o -> o') under2 _ f o0 o1 = unpack $ f (pack o0) (pack o1) -- | The opposite of 'under2'. -- -- @since 0.5.2 over2 :: (Newtype n, Newtype n', o' ~ O n', o ~ O n) => (o -> n) -> (o -> o -> o') -> (n -> n -> n') over2 _ f n0 n1 = pack $ f (unpack n0) (unpack n1) -- | 'under' lifted into a Functor. underF :: (Newtype n, Newtype n', o' ~ O n', o ~ O n, Functor f, Functor g) => (o -> n) -> (f n -> g n') -> (f o -> g o') underF _ f = fmap unpack . f . fmap pack -- | 'over' lifted into a Functor. overF :: (Newtype n, Newtype n', o' ~ O n', o ~ O n, Functor f, Functor g) => (o -> n) -> (f o -> g o') -> (f n -> g n') overF _ f = fmap pack . f . fmap unpack -- Instances from Control.Applicative instance Newtype (WrappedMonad m a) where type O (WrappedMonad m a) = m a pack = WrapMonad unpack (WrapMonad a) = a instance Newtype (WrappedArrow a b c) where type O (WrappedArrow a b c) = a b c pack = WrapArrow unpack (WrapArrow a) = a instance Newtype (ZipList a) where type O (ZipList a) = [a] pack = ZipList unpack (ZipList a) = a -- Instances from Control.Arrow instance Newtype (Kleisli m a b) where type O (Kleisli m a b) = a -> m b pack = Kleisli unpack (Kleisli a) = a instance Newtype (ArrowMonad a b) where type O (ArrowMonad a b) = a () b pack = ArrowMonad unpack (ArrowMonad a) = a #if MIN_VERSION_base(4,7,0) -- Instances from Data.Fixed -- | @since 0.5.1 instance Newtype (Fixed a) where type O (Fixed a) = Integer pack = MkFixed unpack (MkFixed x) = x #endif -- Instances from Data.Functor.Compose -- | @since 0.5.1 instance Newtype (Compose f g a) where type O (Compose f g a) = f (g a) pack = Compose unpack (Compose x) = x -- Instances from Data.Functor.Const instance Newtype (Const a x) where type O (Const a x) = a pack = Const unpack (Const a) = a -- Instances from Data.Functor.Identity -- | @since 0.5.1 instance Newtype (Identity a) where type O (Identity a) = a pack = Identity unpack (Identity a) = a -- Instances from Data.Monoid -- | @since 0.5.1 instance Newtype (Dual a) where type O (Dual a) = a pack = Dual unpack (Dual a) = a instance Newtype (Endo a) where type O (Endo a) = (a -> a) pack = Endo unpack (Endo a) = a instance Newtype All where type O All = Bool pack = All unpack (All x) = x instance Newtype Any where type O Any = Bool pack = Any unpack (Any x) = x instance Newtype (Sum a) where type O (Sum a) = a pack = Sum unpack (Sum a) = a instance Newtype (Product a) where type O (Product a) = a pack = Product unpack (Product a) = a instance Newtype (First a) where type O (First a) = Maybe a pack = First unpack (First a) = a instance Newtype (Last a) where type O (Last a) = Maybe a pack = Last unpack (Last a) = a #if MIN_VERSION_base(4,8,0) -- | @since 0.5.1 instance Newtype (Alt f a) where type O (Alt f a) = f a pack = Alt unpack (Alt x) = x #endif -- Instances from Data.Ord -- | @since 0.5.1 instance Newtype (Down a) where type O (Down a) = a pack = Down unpack (Down a) = a #if MIN_VERSION_base(4,9,0) -- Instances from Data.Semigroup -- | @since 0.5.1 instance Newtype (Min a) where type O (Min a) = a pack = Min unpack (Min a) = a -- | @since 0.5.1 instance Newtype (Max a) where type O (Max a) = a pack = Max unpack (Max a) = a -- | @since 0.5.1 instance Newtype (Data.Semigroup.First a) where type O (Data.Semigroup.First a) = a pack = Data.Semigroup.First unpack (Data.Semigroup.First a) = a -- | @since 0.5.1 instance Newtype (Data.Semigroup.Last a) where type O (Data.Semigroup.Last a) = a pack = Data.Semigroup.Last unpack (Data.Semigroup.Last a) = a -- | @since 0.5.1 instance Newtype (WrappedMonoid m) where type O (WrappedMonoid m) = m pack = WrapMonoid unpack (WrapMonoid m) = m -- | @since 0.5.1 instance Newtype (Option a) where type O (Option a) = Maybe a pack = Option unpack (Option x) = x #endif