1{-# LANGUAGE CPP                    #-}
2{-# LANGUAGE DefaultSignatures      #-}
3{-# LANGUAGE FlexibleInstances      #-}
4{-# LANGUAGE FunctionalDependencies #-}
5-- | Per Conor McBride, the 'Newtype' typeclass represents the packing and
6-- unpacking of a newtype, and allows you to operatate under that newtype with
7-- functions such as 'ala'.
8module Distribution.Compat.Newtype (
9    Newtype (..),
10    ala,
11    alaf,
12    pack',
13    unpack',
14    ) where
15
16import Data.Functor.Identity (Identity (..))
17import Data.Monoid (Sum (..), Product (..), Endo (..))
18
19#if MIN_VERSION_base(4,7,0)
20import Data.Coerce (coerce, Coercible)
21#else
22import Unsafe.Coerce (unsafeCoerce)
23#endif
24
25-- | The @FunctionalDependencies@ version of 'Newtype' type-class.
26--
27-- Since Cabal-3.0 class arguments are in a different order than in @newtype@ package.
28-- This change is to allow usage with @DeriveAnyClass@ (and @DerivingStrategies@, in GHC-8.2).
29-- Unfortunately one has to repeat inner type.
30--
31-- @
32-- newtype New = New Old
33--   deriving anyclass (Newtype Old)
34-- @
35--
36-- Another approach would be to use @TypeFamilies@ (and possibly
37-- compute inner type using "GHC.Generics"), but we think @FunctionalDependencies@
38-- version gives cleaner type signatures.
39--
40class Newtype o n | n -> o where
41    pack   :: o -> n
42#if MIN_VERSION_base(4,7,0)
43    default pack :: Coercible o n => o -> n
44    pack = coerce
45#else
46    default pack :: o -> n
47    pack = unsafeCoerce
48#endif
49
50    unpack :: n -> o
51#if MIN_VERSION_base(4,7,0)
52    default unpack :: Coercible n o => n -> o
53    unpack = coerce
54#else
55    default unpack :: n -> o
56    unpack = unsafeCoerce
57#endif
58
59instance Newtype a (Identity a)
60instance Newtype a (Sum a)
61instance Newtype a (Product a)
62instance Newtype (a -> a) (Endo a)
63
64-- |
65--
66-- >>> ala Sum foldMap [1, 2, 3, 4 :: Int]
67-- 10
68--
69-- /Note:/ the user supplied function for the newtype is /ignored/.
70--
71-- >>> ala (Sum . (+1)) foldMap [1, 2, 3, 4 :: Int]
72-- 10
73ala :: (Newtype o n, Newtype o' n') => (o -> n) -> ((o -> n) -> b -> n') -> (b -> o')
74ala pa hof = alaf pa hof id
75
76-- |
77--
78-- >>> alaf Sum foldMap length ["cabal", "install"]
79-- 12
80--
81-- /Note:/ as with 'ala', the user supplied function for the newtype is /ignored/.
82alaf :: (Newtype o n, Newtype o' n') => (o -> n) -> ((a -> n) -> b -> n') -> (a -> o) -> (b -> o')
83alaf _ hof f = unpack . hof (pack . f)
84
85-- | Variant of 'pack', which takes a phantom type.
86pack' :: Newtype o n => (o -> n) -> o -> n
87pack' _ = pack
88
89-- | Variant of 'unpack', which takes a phantom type.
90unpack' :: Newtype o n => (o -> n) -> n -> o
91unpack' _ = unpack
92