{-# language AllowAmbiguousTypes #-}
{-# language CPP #-}
{-# language DataKinds #-}
{-# language DefaultSignatures #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language GADTs #-}
{-# language MultiParamTypeClasses #-}
{-# language PolyKinds #-}
{-# language ScopedTypeVariables #-}
{-# language TypeApplications #-}
{-# language TypeInType #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}

{-# OPTIONS_HADDOCK not-home #-}

-- | Record types in Haskell can be made lazy through lazy pattern
-- matching. This module offers functions for making them lazy
-- /generically/.
module Data.Lazify.Generic.Internal (
    GenericLazifiable (..)
  , LazifiableG (..)
  , ($~)
  ) where
import GHC.Generics
import GHC.Exts (TYPE)
import GHC.TypeLits
import Data.Type.Equality ((:~:)(..), (:~~:)(..), type (~~))
import Data.Type.Coercion (Coercion (..))
import Data.Coerce
import Type.Reflection (Typeable, TypeRep, typeRep)

-- | This class is intended to be used primarily with the
-- generic instance given in this module. However, users are free
-- to write @{-\# OVERLAPPING \#-}@ instances whenever necessary.
class GenericLazifiable a where
  -- | Lazify a record using its generic representation.
  --
  -- Note that newtypes are treated specially: a newtype is lazified
  -- by lazifying its /underlying/ type.
  lazifyGeneric :: a -> a

-- | The generic instance.
instance (Generic a, LazifiableG a (Rep a)) => GenericLazifiable a where
  lazifyGeneric :: a -> a
lazifyGeneric = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> (a -> Rep a Any) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k k (a :: k) (f :: k -> *) (p :: k).
LazifiableG a f =>
f p -> f p
forall (f :: * -> *) p. LazifiableG a f => f p -> f p
lazifyG @a (Rep a Any -> Rep a Any) -> (a -> Rep a Any) -> a -> Rep a Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from

-- Instances for non-Generic types
instance {-# OVERLAPPING #-} a ~ b => GenericLazifiable (a :~: b) where
  lazifyGeneric :: (a :~: b) -> a :~: b
lazifyGeneric a :~: b
_ = a :~: b
forall k (a :: k). a :~: a
Refl

instance {-# OVERLAPPING #-} a ~~ b => GenericLazifiable (a :~~: b) where
  lazifyGeneric :: (a :~~: b) -> a :~~: b
lazifyGeneric a :~~: b
_ = a :~~: b
forall k1 (a :: k1). a :~~: a
HRefl

instance {-# OVERLAPPING #-} Typeable a => GenericLazifiable (TypeRep a) where
  lazifyGeneric :: TypeRep a -> TypeRep a
lazifyGeneric TypeRep a
_ = TypeRep a
forall k (a :: k). Typeable a => TypeRep a
typeRep

instance {-# OVERLAPPING #-} Coercible a b => GenericLazifiable (Coercion a b) where
  lazifyGeneric :: Coercion a b -> Coercion a b
lazifyGeneric Coercion a b
_ = Coercion a b
forall k (a :: k) (b :: k). Coercible a b => Coercion a b
Coercion

-- Instances for large tuples whose generic instances
-- are too big to optimize well.
instance {-# OVERLAPPING #-} GenericLazifiable (a,b,c,d,e,f,g,h) where
  lazifyGeneric :: (a, b, c, d, e, f, g, h) -> (a, b, c, d, e, f, g, h)
lazifyGeneric ~(a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h) = (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h)
instance {-# OVERLAPPING #-} GenericLazifiable (a,b,c,d,e,f,g,h,i) where
  lazifyGeneric :: (a, b, c, d, e, f, g, h, i) -> (a, b, c, d, e, f, g, h, i)
lazifyGeneric ~(a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i) = (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i)
instance {-# OVERLAPPING #-} GenericLazifiable (a,b,c,d,e,f,g,h,i,j) where
  lazifyGeneric :: (a, b, c, d, e, f, g, h, i, j) -> (a, b, c, d, e, f, g, h, i, j)
lazifyGeneric ~(a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i,j
j) = (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i,j
j)

-- | A 'Generic' representation that can be lazified.
class LazifiableG a f where
  -- | Lazify a 'Generic' representation.
  lazifyG :: f p -> f p

-- | Apply a function to a lazified value.
--
-- Note to users of @TypeApplications@: For GHC >= 9.0.1, the representation
-- is marked as inferred. Before that, doing so is impossible and the
-- representation must be passed as the first type argument. I'm sorry.
#if __GLASGOW_HASKELL__ >= 900
($~) :: forall {rep} a (b :: TYPE rep). GenericLazifiable a => (a -> b) -> a -> b
#else
($~) :: forall rep a (b :: TYPE rep). GenericLazifiable a => (a -> b) -> a -> b
#endif
a -> b
f $~ :: (a -> b) -> a -> b
$~ a
a = a -> b
f (a -> a
forall a. GenericLazifiable a => a -> a
lazifyGeneric a
a)

-- Non-newtype cases
instance LazifiableG a f => LazifiableG a (D1 ('MetaData x y z 'False) f) where
  lazifyG :: D1 ('MetaData x y z 'False) f p -> D1 ('MetaData x y z 'False) f p
lazifyG (M1 f p
x) = f p -> D1 ('MetaData x y z 'False) f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> f p
forall k k (a :: k) (f :: k -> *) (p :: k).
LazifiableG a f =>
f p -> f p
lazifyG @a f p
x)
instance LazifiableG a f => LazifiableG a (C1 c f) where
  lazifyG :: C1 c f p -> C1 c f p
lazifyG (M1 f p
x) = f p -> C1 c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> f p
forall k k (a :: k) (f :: k -> *) (p :: k).
LazifiableG a f =>
f p -> f p
lazifyG @a f p
x)
instance LazifiableG a f => LazifiableG a (S1 ('MetaSel _p _q _r 'DecidedLazy) f) where
  lazifyG :: S1 ('MetaSel _p _q _r 'DecidedLazy) f p
-> S1 ('MetaSel _p _q _r 'DecidedLazy) f p
lazifyG (M1 f p
m) = f p -> S1 ('MetaSel _p _q _r 'DecidedLazy) f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> f p
forall k k (a :: k) (f :: k -> *) (p :: k).
LazifiableG a f =>
f p -> f p
lazifyG @a f p
m)
instance TypeError ('Text "Can't lazify " ':<>: 'ShowType a ':<>: 'Text ":"
                    ':$$: 'Text "It has a strict field.")
  => LazifiableG a (S1 ('MetaSel _p _q _r 'DecidedStrict) f) where
  lazifyG :: S1 ('MetaSel _p _q _r 'DecidedStrict) f p
-> S1 ('MetaSel _p _q _r 'DecidedStrict) f p
lazifyG S1 ('MetaSel _p _q _r 'DecidedStrict) f p
_ = [Char] -> S1 ('MetaSel _p _q _r 'DecidedStrict) f p
forall a. HasCallStack => [Char] -> a
error [Char]
"Unreachable"
instance TypeError ('Text "Can't lazify " ':<>: 'ShowType a ':<>: 'Text ":"
                    ':$$: 'Text "It has a strict (unpacked) field.")
  => LazifiableG a (S1 ('MetaSel _p _q _r 'DecidedUnpack) f) where
  lazifyG :: S1 ('MetaSel _p _q _r 'DecidedUnpack) f p
-> S1 ('MetaSel _p _q _r 'DecidedUnpack) f p
lazifyG S1 ('MetaSel _p _q _r 'DecidedUnpack) f p
_ = [Char] -> S1 ('MetaSel _p _q _r 'DecidedUnpack) f p
forall a. HasCallStack => [Char] -> a
error [Char]
"Unreachable"

-- For a newtype, we need to lazify whatever it *wraps*.
-- Unfortunately, we lose error context here, but we want
-- users to be able to write overlapping instances of GenericLazifiable
-- if they really need to.
instance GenericLazifiable c => LazifiableG a (D1 ('MetaData x y z 'True) (C1 _p (S1 _q (Rec0 c)))) where
  lazifyG :: D1 ('MetaData x y z 'True) (C1 _p (S1 _q (Rec0 c))) p
-> D1 ('MetaData x y z 'True) (C1 _p (S1 _q (Rec0 c))) p
lazifyG (M1 (M1 (M1 (K1 c
x)))) = M1 C _p (S1 _q (Rec0 c)) p
-> D1 ('MetaData x y z 'True) (C1 _p (S1 _q (Rec0 c))) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (M1 S _q (Rec0 c) p -> M1 C _p (S1 _q (Rec0 c)) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R c p -> M1 S _q (Rec0 c) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (c -> K1 R c p
forall k i c (p :: k). c -> K1 i c p
K1 (c -> c
forall a. GenericLazifiable a => a -> a
lazifyGeneric c
x))))

instance LazifiableG a (K1 i c) where
  lazifyG :: K1 i c p -> K1 i c p
lazifyG K1 i c p
x = K1 i c p
x

instance LazifiableG a U1 where
  lazifyG :: U1 p -> U1 p
lazifyG U1 p
_ = U1 p
forall k (p :: k). U1 p
U1

instance (LazifiableG a f, LazifiableG a g) => LazifiableG a (f :*: g) where
  lazifyG :: (:*:) f g p -> (:*:) f g p
lazifyG ~(f p
x :*: g p
y) = f p -> f p
forall k k (a :: k) (f :: k -> *) (p :: k).
LazifiableG a f =>
f p -> f p
lazifyG @a f p
x f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g p -> g p
forall k k (a :: k) (f :: k -> *) (p :: k).
LazifiableG a f =>
f p -> f p
lazifyG @a g p
y

-- There is no instance for V1 because an uninhabited datatype can't be
-- lazified.

-- There is no instance for f :+: g. A sum can only be lazified if
-- one of its components is *strict* and *uninhabited* while the other
-- is lazifiable. Unfortunately, there are lots of ways this can
-- occur, leading to incompatible constraints.
instance TypeError ('Text "Can't lazify " ':<>: 'ShowType a ':<>: 'Text ":"
                    ':$$: 'Text "It is a sum type.")
  => LazifiableG a (f :+: g) where
  lazifyG :: (:+:) f g p -> (:+:) f g p
lazifyG (:+:) f g p
_ = [Char] -> (:+:) f g p
forall a. HasCallStack => [Char] -> a
error [Char]
"Unreachable"