{-# language AllowAmbiguousTypes #-}
{-# language CPP #-}
{-# language DataKinds #-}
{-# language DefaultSignatures #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language MultiParamTypeClasses #-}
{-# language PolyKinds #-}
{-# language ScopedTypeVariables #-}
{-# language TypeFamilies #-}
{-# language TypeInType #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}
{-# language TypeApplications #-}
{-# OPTIONS_HADDOCK not-home #-}
module Data.Lazify.Internal (
Lazifiable (..)
, GLazifiable (..)
, genericLazify
, ($~)
) where
import GHC.Generics
import Data.Functor.Product
import Data.Proxy
import Data.Functor.Identity (Identity)
import Control.Monad.Trans.Identity (IdentityT)
import Data.Functor.Compose (Compose)
import Data.Coerce (Coercible)
import Data.Type.Coercion (Coercion(..))
import Control.Applicative (Const)
import Data.Tagged (Tagged)
import GHC.Exts (TYPE)
import Data.Type.Equality ((:~:)(..))
import qualified Data.Monoid as M
import qualified Data.Semigroup as S
import Data.List.NonEmpty (NonEmpty)
import Data.Type.Equality ((:~~:)(..), type (~~))
import Type.Reflection (Typeable, TypeRep, typeRep)
import Data.Tree (Tree (..))
#if MIN_VERSION_base (4,15,0)
import GHC.Tuple (Solo)
#endif
import qualified Control.Applicative.Backwards as AppBackwards
import qualified Data.Functor.Reverse as TravReverse
import GHC.TypeLits
class Lazifiable a where
lazify :: a -> a
default lazify :: (Generic a, GLazifiable a (Rep a)) => a -> a
lazify a
x = a -> a
forall a. (Generic a, GLazifiable a (Rep a)) => a -> a
genericLazify a
x
class GLazifiable a f where
glazify :: f p -> f p
genericLazify :: forall a. (Generic a, GLazifiable a (Rep a)) => a -> a
genericLazify :: a -> a
genericLazify = 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).
GLazifiable a f =>
f p -> f p
forall (f :: * -> *) p. GLazifiable a f => f p -> f p
glazify @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
#if __GLASGOW_HASKELL__ >= 900
($~) :: forall {rep} a (b :: TYPE rep). Lazifiable a => (a -> b) -> a -> b
#else
($~) :: forall rep a (b :: TYPE rep). Lazifiable a => (a -> b) -> a -> b
#endif
a -> b
f $~ :: (a -> b) -> a -> b
$~ a
a = a -> b
f (a -> a
forall a. Lazifiable a => a -> a
lazify a
a)
instance GLazifiable a f => GLazifiable a (D1 ('MetaData x y z 'False) f) where
glazify :: D1 ('MetaData x y z 'False) f p -> D1 ('MetaData x y z 'False) f p
glazify (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).
GLazifiable a f =>
f p -> f p
glazify @a f p
x)
instance GLazifiable a f => GLazifiable a (C1 c f) where
glazify :: C1 c f p -> C1 c f p
glazify (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).
GLazifiable a f =>
f p -> f p
glazify @a f p
x)
instance GLazifiable a f => GLazifiable a (S1 ('MetaSel _p _q _r 'DecidedLazy) f) where
glazify :: S1 ('MetaSel _p _q _r 'DecidedLazy) f p
-> S1 ('MetaSel _p _q _r 'DecidedLazy) f p
glazify (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).
GLazifiable a f =>
f p -> f p
glazify @a f p
m)
instance TypeError ('Text "Can't lazify " ':<>: 'ShowType a ':<>: 'Text ":"
':$$: 'Text "It has a strict field.")
=> GLazifiable a (S1 ('MetaSel _p _q _r 'DecidedStrict) f) where
glazify :: S1 ('MetaSel _p _q _r 'DecidedStrict) f p
-> S1 ('MetaSel _p _q _r 'DecidedStrict) f p
glazify 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.")
=> GLazifiable a (S1 ('MetaSel _p _q _r 'DecidedUnpack) f) where
glazify :: S1 ('MetaSel _p _q _r 'DecidedUnpack) f p
-> S1 ('MetaSel _p _q _r 'DecidedUnpack) f p
glazify 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"
instance Lazifiable c
=> GLazifiable a (D1 ('MetaData x y z 'True) (C1 _m (S1 _o (Rec0 c)))) where
glazify :: D1 ('MetaData x y z 'True) (C1 _m (S1 _o (Rec0 c))) p
-> D1 ('MetaData x y z 'True) (C1 _m (S1 _o (Rec0 c))) p
glazify (M1 (M1 (M1 (K1 c
x)))) = M1 C _m (S1 _o (Rec0 c)) p
-> D1 ('MetaData x y z 'True) (C1 _m (S1 _o (Rec0 c))) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (M1 S _o (Rec0 c) p -> M1 C _m (S1 _o (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 _o (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. Lazifiable a => a -> a
lazify c
x))))
instance GLazifiable a (K1 i c) where
glazify :: K1 i c p -> K1 i c p
glazify K1 i c p
x = K1 i c p
x
instance GLazifiable a U1 where
glazify :: U1 p -> U1 p
glazify U1 p
_ = U1 p
forall k (p :: k). U1 p
U1
instance (GLazifiable a f, GLazifiable a g) => GLazifiable a (f :*: g) where
glazify :: (:*:) f g p -> (:*:) f g p
glazify ~(f p
x :*: g p
y) = f p -> f p
forall k k (a :: k) (f :: k -> *) (p :: k).
GLazifiable a f =>
f p -> f p
glazify @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).
GLazifiable a f =>
f p -> f p
glazify @a g p
y
instance TypeError ('Text "Can't lazify " ':<>: 'ShowType a ':<>: 'Text ":"
':$$: 'Text "It is a sum type.")
=> GLazifiable a (f :+: g) where
glazify :: (:+:) f g p -> (:+:) f g p
glazify (:+:) f g p
_ = [Char] -> (:+:) f g p
forall a. HasCallStack => [Char] -> a
error [Char]
"Unreachable"
instance Lazifiable (Proxy a)
instance Lazifiable (Product f g a)
instance Lazifiable a => Lazifiable (Identity a)
instance Lazifiable a => Lazifiable (Const a b)
instance Lazifiable b => Lazifiable (Tagged a b)
instance Lazifiable (f (g a)) => Lazifiable (Compose f g a)
instance Lazifiable (f (g a)) => Lazifiable ((f :.: g) a)
instance Lazifiable a => Lazifiable (S.First a)
instance Lazifiable a => Lazifiable (S.Last a)
instance Lazifiable a => Lazifiable (S.Min a)
instance Lazifiable a => Lazifiable (S.Max a)
instance Lazifiable a => Lazifiable (S.Product a)
instance Lazifiable a => Lazifiable (S.Sum a)
instance Lazifiable a => Lazifiable (S.Dual a)
instance Lazifiable a => Lazifiable (S.WrappedMonoid a)
instance Lazifiable (S.Arg a b)
instance Lazifiable (NonEmpty a)
instance Lazifiable (Tree a)
instance Lazifiable (f a) => Lazifiable (M.Alt f a)
#if MIN_VERSION_base(4,12,0)
instance Lazifiable (f a) => Lazifiable (M.Ap f a)
#endif
instance Lazifiable (f a) => Lazifiable (AppBackwards.Backwards f a)
instance Lazifiable (t a) => Lazifiable (TravReverse.Reverse t a)
instance Lazifiable (f a) => Lazifiable (IdentityT f a)
instance a ~ b => Lazifiable (a :~: b) where
lazify :: (a :~: b) -> a :~: b
lazify a :~: b
_ = a :~: b
forall k (a :: k). a :~: a
Refl
instance a ~~ b => Lazifiable (a :~~: b) where
lazify :: (a :~~: b) -> a :~~: b
lazify a :~~: b
_ = a :~~: b
forall k1 (a :: k1). a :~~: a
HRefl
instance Typeable a => Lazifiable (TypeRep a) where
lazify :: TypeRep a -> TypeRep a
lazify TypeRep a
_ = TypeRep a
forall k (a :: k). Typeable a => TypeRep a
typeRep
instance Coercible a b => Lazifiable (Coercion a b) where
lazify :: Coercion a b -> Coercion a b
lazify Coercion a b
_ = Coercion a b
forall k (a :: k) (b :: k). Coercible a b => Coercion a b
Coercion
instance Lazifiable ()
#if MIN_VERSION_base (4,15,0)
instance Lazifiable (Solo a)
#endif
instance Lazifiable (a,b)
instance Lazifiable (a,b,c)
instance Lazifiable (a,b,c,d)
instance Lazifiable (a,b,c,d,e)
instance Lazifiable (a,b,c,d,e,f)
instance Lazifiable (a,b,c,d,e,f,g)
instance Lazifiable (a,b,c,d,e,f,g,h) where
lazify :: (a, b, c, d, e, f, g, h) -> (a, b, c, d, e, f, g, h)
lazify ~(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 Lazifiable (a,b,c,d,e,f,g,h,i) where
lazify :: (a, b, c, d, e, f, g, h, i) -> (a, b, c, d, e, f, g, h, i)
lazify ~(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 Lazifiable (a,b,c,d,e,f,g,h,i,j) where
lazify :: (a, b, c, d, e, f, g, h, i, j) -> (a, b, c, d, e, f, g, h, i, j)
lazify ~(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)