{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

-- | Pack/unpack newtypes.
--
-- === Warning
--
-- This is an internal module: it is not subject to any versioning policy,
-- breaking changes can happen at any time.
--
-- If something here seems useful, please report it or create a pull request to
-- export it from an external module.

module Generic.Data.Internal.Newtype where

import Data.Coerce (Coercible, coerce)
import Data.Kind (Constraint)
import GHC.Generics (Generic(..), D1, C1, S1, K1)
import GHC.TypeLits (TypeError, ErrorMessage(..))

import Generic.Data.Internal.Meta (MetaDataNewtype, MetaOf)

-- | Class of newtypes. There is an instance @'Newtype' a@ if and only if @a@
-- is a newtype and an instance of 'Generic'.
class (Generic a, Coercible a (Old a), Newtype' a) => Newtype a
instance (Generic a, Coercible a (Old a), Newtype' a) => Newtype a

-- | The type wrapped by a newtype.
--
-- @
-- newtype Foo = Foo { bar :: Bar } deriving 'Generic'
-- -- Old Foo ~ Bar
-- @
type Old a = GOld (Rep a)

type family GOld (f :: * -> *) where
  GOld (D1 _d (C1 _c (S1 _s (K1 _i b)))) = b

-- | Use 'Newtype' instead.
type Newtype' a = NewtypeErr a (MetaDataNewtype (MetaOf (Rep a)))

type family NewtypeErr a (b :: Bool) :: Constraint where
  NewtypeErr a 'True = ()
  NewtypeErr a 'False = TypeError
    ('Text "The type " ':<>: 'ShowType a ':<>: 'Text " is not a newtype.")

-- | Generic newtype destructor.
unpack :: Newtype a => a -> Old a
unpack = coerce

-- | Generic newtype constructor.
pack :: Newtype a => Old a -> a
pack = coerce