{-# LANGUAGE ConstraintKinds         #-}
{-# LANGUAGE DataKinds               #-}
{-# LANGUAGE DefaultSignatures       #-}
{-# LANGUAGE DeriveGeneric           #-}
{-# LANGUAGE FlexibleContexts        #-}
{-# LANGUAGE FlexibleInstances       #-}
{-# LANGUAGE GADTs                   #-}
{-# LANGUAGE KindSignatures          #-}
{-# LANGUAGE MultiParamTypeClasses   #-}
{-# LANGUAGE PolyKinds               #-}
{-# LANGUAGE QuantifiedConstraints   #-}
{-# LANGUAGE RankNTypes              #-}
{-# LANGUAGE ScopedTypeVariables     #-}
{-# LANGUAGE StandaloneDeriving      #-}
{-# LANGUAGE TypeFamilies            #-}
{-# LANGUAGE TypeOperators           #-}
{-# LANGUAGE UndecidableInstances    #-}
-- |Introduces closed representations functor
-- for "GHC.Generics" style generics.
module Generics.Simplistic
  ( -- ** Re-exports from "GHC.Generics.Extra" module
    Generic, Rep, Rep1, Par1, Rec1, (:.:)(..), V1, U1(..), (:+:)(..)
  , (:*:)(..), K1(..), M1(..), (:=>:)(..), R
  -- * Simplistic representation on @*@ types
  , GMeta(..), SMeta(..), SMetaI(..), SRep(..) , I(..) , Simplistic
  -- ** Constraints over the leaves of a data type
  , OnLeaves
  -- ** Combinators
  -- *** Maps , zips and folds
  , repMap , repMapM , repMapCM
  , zipSRep , repLeaves , repLeavesC , repLeavesList
  -- *** Metadata
  , getDatatypeName , getConstructorName
  , repDatatypeName , repConstructorName
  -- ** Shallow Conversion
  , fromS , toS , GShallow(..)
  -- * Simplistic representation on @* -> *@ types
  , SRep1(..) , OnLeaves1 , fromS1 , toS1 , GShallow1(..) , Simplistic1
  -- * Auxiliary constraints
  , Implies, Trivial
  ) where

import Data.Proxy
import Control.Monad.Identity
import Control.DeepSeq

import GHC.Generics
import GHC.Generics.Extra
import GHC.Exts (Constraint)

import Generics.Simplistic.Util 

---------------------
-- Representations --
---------------------

data SMeta i t where
  SM_D :: Datatype    d => SMeta D d
  SM_C :: Constructor c => SMeta C c
  SM_S :: Selector    s => SMeta S s
deriving instance Show (SMeta i t)
deriving instance Eq   (SMeta i t)

-- Dirty trick to access the dictionaries I need
data SMetaI d f x = SMetaI

smetaI :: SMeta i t -> SMetaI t Proxy ()
smetaI :: SMeta i t -> SMetaI t Proxy ()
smetaI _ = SMetaI t Proxy ()
forall k k k (d :: k) (f :: k) (x :: k). SMetaI d f x
SMetaI

getDatatypeName :: SMeta D d -> String
getDatatypeName :: SMeta D d -> String
getDatatypeName x :: SMeta D d
x@SMeta D d
SM_D = SMetaI d Proxy () -> String
forall k (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
datatypeName (SMeta D d -> SMetaI d Proxy ()
forall k k i (t :: k). SMeta i t -> SMetaI t Proxy ()
smetaI SMeta D d
x)

getConstructorName :: SMeta C c -> String
getConstructorName :: SMeta C c -> String
getConstructorName x :: SMeta C c
x@SMeta C c
SM_C = SMetaI c Proxy () -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName (SMeta C c -> SMetaI c Proxy ()
forall k k i (t :: k). SMeta i t -> SMetaI t Proxy ()
smetaI SMeta C c
x)

-- |Singletons for metainformation
class GMeta i c where
  smeta :: SMeta i c

instance Constructor c => GMeta C c where
  smeta :: SMeta C c
smeta = SMeta C c
forall k (c :: k). Constructor c => SMeta C c
SM_C

instance Datatype d => GMeta D d where
  smeta :: SMeta D d
smeta = SMeta D d
forall k (d :: k). Datatype d => SMeta D d
SM_D

instance Selector s => GMeta S s where
  smeta :: SMeta S s
smeta = SMeta S s
forall k (s :: k). Selector s => SMeta S s
SM_S

-- |Given some @a@, a value of type @SRep w (Rep a)@ is
-- a closed representation of a generic value of type @a@.
infixr 5 :**:
data SRep w f where
  S_U1   ::                          SRep w U1
  S_L1   ::              SRep w f -> SRep w (f :+: g)
  S_R1   ::              SRep w g -> SRep w (f :+: g)
  (:**:) :: SRep w f  -> SRep w g -> SRep w (f :*: g)
  S_K1   ::              w a      -> SRep w (K1 i a)
  S_M1   :: SMeta i t -> SRep w f -> SRep w (M1 i t f)
  S_ST   ::         c => SRep w f -> SRep w (c :=>: f)
deriving instance (forall a. Show (w a)) => Show (SRep w f)
deriving instance (forall a. Eq   (w a)) => Eq   (SRep w f)
instance (forall x . NFData (w x)) => NFData (SRep w f) where
  rnf :: SRep w f -> ()
rnf S_U1       = ()
  rnf (S_K1 w :: w a
w)   = w a -> ()
forall a. NFData a => a -> ()
rnf w a
w
  rnf (S_M1 _ x :: SRep w f
x) = SRep w f -> ()
forall a. NFData a => a -> ()
rnf SRep w f
x
  rnf (S_L1 x :: SRep w f
x)   = SRep w f -> ()
forall a. NFData a => a -> ()
rnf SRep w f
x
  rnf (S_R1 x :: SRep w g
x)   = SRep w g -> ()
forall a. NFData a => a -> ()
rnf SRep w g
x
  rnf (x :: SRep w f
x :**: y :: SRep w g
y) = SRep w f -> ()
forall a. NFData a => a -> ()
rnf SRep w f
x () -> () -> ()
forall a b. a -> b -> b
`seq` SRep w g -> ()
forall a. NFData a => a -> ()
rnf SRep w g
y
  rnf (S_ST x :: SRep w f
x)   = SRep w f -> ()
forall a. NFData a => a -> ()
rnf SRep w f
x 

-- |All types supported by "GHC.Generics" are /simplistic/, this
-- constraint just couples their necessary together.
type Simplistic a = (Generic a , GShallow (Rep a))

-- |Computes the constraint that corresponds to ensuring all
-- leaves of a representation satisfy a given constraint.
-- For example,
--
-- > OnLeaves Eq (Rep (Either a b)) = (Eq a , Eq b)
--
type family OnLeaves (c :: * -> Constraint) (f :: * -> *) :: Constraint where
  OnLeaves c V1        = ()
  OnLeaves c U1        = ()
  OnLeaves c (f :+: g)  = (OnLeaves c f, OnLeaves c g)
  OnLeaves c (f :*: g)  = (OnLeaves c f, OnLeaves c g)
  OnLeaves c (K1 i a)   = c a
  OnLeaves c (M1 i p f) = OnLeaves c f
  OnLeaves c (d :=>: f) = Implies d (OnLeaves c f)

-- |Retrieves the datatype name for a representation.
-- /WARNING; UNSAFE/ this function only works if @f@ is the representation of
-- a type constructed with "GHC.Generics" builtin mechanisms.
repDatatypeName :: SRep w f -> String
repDatatypeName :: SRep w f -> String
repDatatypeName (S_M1 x :: SMeta i t
x@SMeta i t
SM_D _)
  = SMeta D t -> String
forall k (d :: k). SMeta D d -> String
getDatatypeName SMeta i t
SMeta D t
x
repDatatypeName (S_M1 _ x :: SRep w f
x)
  = SRep w f -> String
forall k (w :: * -> *) (f :: k -> *). SRep w f -> String
repDatatypeName SRep w f
x
repDatatypeName (S_L1 x :: SRep w f
x)
  = SRep w f -> String
forall k (w :: * -> *) (f :: k -> *). SRep w f -> String
repDatatypeName SRep w f
x
repDatatypeName (S_R1 x :: SRep w g
x)
  = SRep w g -> String
forall k (w :: * -> *) (f :: k -> *). SRep w f -> String
repDatatypeName SRep w g
x
repDatatypeName _
  = ShowS
forall a. HasCallStack => String -> a
error "Please; use GHC's deriving mechanism. This keeps M1's at the top of the Rep"

-- |Retrieves the constructor name for a representation.
-- /WARNING; UNSAFE/ this function only works if @f@ is the representation of
-- a type constructed with "GHC.Generics" builtin mechanisms.
repConstructorName :: SRep w f -> String
repConstructorName :: SRep w f -> String
repConstructorName (S_M1 x :: SMeta i t
x@SMeta i t
SM_C _)
  = SMeta C t -> String
forall k (c :: k). SMeta C c -> String
getConstructorName SMeta i t
SMeta C t
x
repConstructorName (S_M1 _ x :: SRep w f
x)
  = SRep w f -> String
forall k (w :: * -> *) (f :: k -> *). SRep w f -> String
repConstructorName SRep w f
x
repConstructorName (S_L1 x :: SRep w f
x)
  = SRep w f -> String
forall k (w :: * -> *) (f :: k -> *). SRep w f -> String
repConstructorName SRep w f
x
repConstructorName (S_R1 x :: SRep w g
x)
  = SRep w g -> String
forall k (w :: * -> *) (f :: k -> *). SRep w f -> String
repConstructorName SRep w g
x
repConstructorName _
  = ShowS
forall a. HasCallStack => String -> a
error "Please; use GHC's deriving mechanism. This keeps M1's at the top of the Rep"

-- |Zips two representations together if they are made up of
-- the same constructor. For example,
--
-- > zipSRep (fromS (: 1 [])) (fromS (: 2 (: 3 [])))
-- >  == Just (fromS (: (1 , 2) ([] , [3])))
-- >
-- > zipSRep (fromS (: 1 [])) (fromS [])
-- >  == Nothing
zipSRep :: SRep w f -> SRep z f -> Maybe (SRep (w :*: z) f)
zipSRep :: SRep w f -> SRep z f -> Maybe (SRep (w :*: z) f)
zipSRep S_U1         S_U1         = SRep (w :*: z) U1 -> Maybe (SRep (w :*: z) U1)
forall (m :: * -> *) a. Monad m => a -> m a
return SRep (w :*: z) U1
forall k (w :: * -> *). SRep w U1
S_U1
zipSRep (S_L1 x :: SRep w f
x)     (S_L1 y :: SRep z f
y)     = SRep (w :*: z) f -> SRep (w :*: z) (f :+: g)
forall k (w :: * -> *) (f :: k -> *) (g :: k -> *).
SRep w f -> SRep w (f :+: g)
S_L1 (SRep (w :*: z) f -> SRep (w :*: z) (f :+: g))
-> Maybe (SRep (w :*: z) f) -> Maybe (SRep (w :*: z) (f :+: g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SRep w f -> SRep z f -> Maybe (SRep (w :*: z) f)
forall k (w :: * -> *) (f :: k -> *) (z :: * -> *).
SRep w f -> SRep z f -> Maybe (SRep (w :*: z) f)
zipSRep SRep w f
x SRep z f
SRep z f
y
zipSRep (S_R1 x :: SRep w g
x)     (S_R1 y :: SRep z g
y)     = SRep (w :*: z) g -> SRep (w :*: z) (f :+: g)
forall k (w :: * -> *) (g :: k -> *) (f :: k -> *).
SRep w g -> SRep w (f :+: g)
S_R1 (SRep (w :*: z) g -> SRep (w :*: z) (f :+: g))
-> Maybe (SRep (w :*: z) g) -> Maybe (SRep (w :*: z) (f :+: g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SRep w g -> SRep z g -> Maybe (SRep (w :*: z) g)
forall k (w :: * -> *) (f :: k -> *) (z :: * -> *).
SRep w f -> SRep z f -> Maybe (SRep (w :*: z) f)
zipSRep SRep w g
x SRep z g
SRep z g
y
zipSRep (S_M1 m :: SMeta i t
m x :: SRep w f
x)   (S_M1 _ y :: SRep z f
y)   = SMeta i t -> SRep (w :*: z) f -> SRep (w :*: z) (M1 i t f)
forall k i (t :: Meta) (w :: * -> *) (f :: k -> *).
SMeta i t -> SRep w f -> SRep w (M1 i t f)
S_M1 SMeta i t
m (SRep (w :*: z) f -> SRep (w :*: z) (M1 i t f))
-> Maybe (SRep (w :*: z) f) -> Maybe (SRep (w :*: z) (M1 i t f))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SRep w f -> SRep z f -> Maybe (SRep (w :*: z) f)
forall k (w :: * -> *) (f :: k -> *) (z :: * -> *).
SRep w f -> SRep z f -> Maybe (SRep (w :*: z) f)
zipSRep SRep w f
x SRep z f
SRep z f
y
zipSRep (x1 :: SRep w f
x1 :**: x2 :: SRep w g
x2) (y1 :: SRep z f
y1 :**: y2 :: SRep z g
y2) = SRep (w :*: z) f -> SRep (w :*: z) g -> SRep (w :*: z) (f :*: g)
forall k (w :: * -> *) (f :: k -> *) (g :: k -> *).
SRep w f -> SRep w g -> SRep w (f :*: g)
(:**:) (SRep (w :*: z) f -> SRep (w :*: z) g -> SRep (w :*: z) (f :*: g))
-> Maybe (SRep (w :*: z) f)
-> Maybe (SRep (w :*: z) g -> SRep (w :*: z) (f :*: g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SRep w f -> SRep z f -> Maybe (SRep (w :*: z) f)
forall k (w :: * -> *) (f :: k -> *) (z :: * -> *).
SRep w f -> SRep z f -> Maybe (SRep (w :*: z) f)
zipSRep SRep w f
x1 SRep z f
SRep z f
y1) Maybe (SRep (w :*: z) g -> SRep (w :*: z) (f :*: g))
-> Maybe (SRep (w :*: z) g) -> Maybe (SRep (w :*: z) (f :*: g))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (SRep w g -> SRep z g -> Maybe (SRep (w :*: z) g)
forall k (w :: * -> *) (f :: k -> *) (z :: * -> *).
SRep w f -> SRep z f -> Maybe (SRep (w :*: z) f)
zipSRep SRep w g
x2 SRep z g
SRep z g
y2)
zipSRep (S_K1 x :: w a
x)     (S_K1 y :: z a
y)     = SRep (w :*: z) (K1 i a) -> Maybe (SRep (w :*: z) f)
forall (m :: * -> *) a. Monad m => a -> m a
return (SRep (w :*: z) (K1 i a) -> Maybe (SRep (w :*: z) f))
-> SRep (w :*: z) (K1 i a) -> Maybe (SRep (w :*: z) f)
forall a b. (a -> b) -> a -> b
$ (:*:) w z a -> SRep (w :*: z) (K1 i a)
forall k (w :: * -> *) a i. w a -> SRep w (K1 i a)
S_K1 (w a
x w a -> z a -> (:*:) w z a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: z a
z a
y)
zipSRep _            _            = Maybe (SRep (w :*: z) f)
forall a. Maybe a
Nothing

-- |Performs a /crush/ over the leaves of a 'SRep' carrying a constraint
-- around.
repLeavesC :: (OnLeaves c rep)
           => Proxy c
           -> (forall x . c x => w x -> r) -- ^ leaf extraction
           -> (r -> r -> r)         -- ^ join product
           -> r                     -- ^ empty
           -> SRep w rep -> r
repLeavesC :: Proxy c
-> (forall x. c x => w x -> r)
-> (r -> r -> r)
-> r
-> SRep w rep
-> r
repLeavesC _ _ _ e :: r
e S_U1       = r
e
repLeavesC p :: Proxy c
p l :: forall x. c x => w x -> r
l j :: r -> r -> r
j e :: r
e (S_L1 x :: SRep w f
x)   = Proxy c
-> (forall x. c x => w x -> r)
-> (r -> r -> r)
-> r
-> SRep w f
-> r
forall (c :: * -> Constraint) (rep :: * -> *) (w :: * -> *) r.
OnLeaves c rep =>
Proxy c
-> (forall x. c x => w x -> r)
-> (r -> r -> r)
-> r
-> SRep w rep
-> r
repLeavesC Proxy c
p forall x. c x => w x -> r
l r -> r -> r
j r
e SRep w f
x
repLeavesC p :: Proxy c
p l :: forall x. c x => w x -> r
l j :: r -> r -> r
j e :: r
e (S_R1 x :: SRep w g
x)   = Proxy c
-> (forall x. c x => w x -> r)
-> (r -> r -> r)
-> r
-> SRep w g
-> r
forall (c :: * -> Constraint) (rep :: * -> *) (w :: * -> *) r.
OnLeaves c rep =>
Proxy c
-> (forall x. c x => w x -> r)
-> (r -> r -> r)
-> r
-> SRep w rep
-> r
repLeavesC Proxy c
p forall x. c x => w x -> r
l r -> r -> r
j r
e SRep w g
x
repLeavesC p :: Proxy c
p l :: forall x. c x => w x -> r
l j :: r -> r -> r
j e :: r
e (S_M1 _ x :: SRep w f
x) = Proxy c
-> (forall x. c x => w x -> r)
-> (r -> r -> r)
-> r
-> SRep w f
-> r
forall (c :: * -> Constraint) (rep :: * -> *) (w :: * -> *) r.
OnLeaves c rep =>
Proxy c
-> (forall x. c x => w x -> r)
-> (r -> r -> r)
-> r
-> SRep w rep
-> r
repLeavesC Proxy c
p forall x. c x => w x -> r
l r -> r -> r
j r
e SRep w f
x
repLeavesC p :: Proxy c
p l :: forall x. c x => w x -> r
l j :: r -> r -> r
j e :: r
e (x :: SRep w f
x :**: y :: SRep w g
y) = r -> r -> r
j (Proxy c
-> (forall x. c x => w x -> r)
-> (r -> r -> r)
-> r
-> SRep w f
-> r
forall (c :: * -> Constraint) (rep :: * -> *) (w :: * -> *) r.
OnLeaves c rep =>
Proxy c
-> (forall x. c x => w x -> r)
-> (r -> r -> r)
-> r
-> SRep w rep
-> r
repLeavesC Proxy c
p forall x. c x => w x -> r
l r -> r -> r
j r
e SRep w f
x) (Proxy c
-> (forall x. c x => w x -> r)
-> (r -> r -> r)
-> r
-> SRep w g
-> r
forall (c :: * -> Constraint) (rep :: * -> *) (w :: * -> *) r.
OnLeaves c rep =>
Proxy c
-> (forall x. c x => w x -> r)
-> (r -> r -> r)
-> r
-> SRep w rep
-> r
repLeavesC Proxy c
p forall x. c x => w x -> r
l r -> r -> r
j r
e SRep w g
y)
repLeavesC _ l :: forall x. c x => w x -> r
l _ _ (S_K1 x :: w a
x)   = w a -> r
forall x. c x => w x -> r
l w a
x
repLeavesC p :: Proxy c
p l :: forall x. c x => w x -> r
l j :: r -> r -> r
j e :: r
e (S_ST x :: SRep w f
x)   = Proxy c
-> (forall x. c x => w x -> r)
-> (r -> r -> r)
-> r
-> SRep w f
-> r
forall (c :: * -> Constraint) (rep :: * -> *) (w :: * -> *) r.
OnLeaves c rep =>
Proxy c
-> (forall x. c x => w x -> r)
-> (r -> r -> r)
-> r
-> SRep w rep
-> r
repLeavesC Proxy c
p forall x. c x => w x -> r
l r -> r -> r
j r
e SRep w f
x


-- |Performs a /crush/ over the leaves of a 'SRep'
repLeaves :: (forall x . w x -> r) -- ^ leaf extraction
          -> (r -> r -> r)         -- ^ join product
          -> r                     -- ^ empty
          -> SRep w rep -> r
repLeaves :: (forall x. w x -> r) -> (r -> r -> r) -> r -> SRep w rep -> r
repLeaves _ _ e :: r
e S_U1       = r
e
repLeaves l :: forall x. w x -> r
l j :: r -> r -> r
j e :: r
e (S_L1 x :: SRep w f
x)   = (forall x. w x -> r) -> (r -> r -> r) -> r -> SRep w f -> r
forall k (w :: * -> *) r (rep :: k -> *).
(forall x. w x -> r) -> (r -> r -> r) -> r -> SRep w rep -> r
repLeaves forall x. w x -> r
l r -> r -> r
j r
e SRep w f
x
repLeaves l :: forall x. w x -> r
l j :: r -> r -> r
j e :: r
e (S_R1 x :: SRep w g
x)   = (forall x. w x -> r) -> (r -> r -> r) -> r -> SRep w g -> r
forall k (w :: * -> *) r (rep :: k -> *).
(forall x. w x -> r) -> (r -> r -> r) -> r -> SRep w rep -> r
repLeaves forall x. w x -> r
l r -> r -> r
j r
e SRep w g
x
repLeaves l :: forall x. w x -> r
l j :: r -> r -> r
j e :: r
e (S_M1 _ x :: SRep w f
x) = (forall x. w x -> r) -> (r -> r -> r) -> r -> SRep w f -> r
forall k (w :: * -> *) r (rep :: k -> *).
(forall x. w x -> r) -> (r -> r -> r) -> r -> SRep w rep -> r
repLeaves forall x. w x -> r
l r -> r -> r
j r
e SRep w f
x
repLeaves l :: forall x. w x -> r
l j :: r -> r -> r
j e :: r
e (x :: SRep w f
x :**: y :: SRep w g
y) = r -> r -> r
j ((forall x. w x -> r) -> (r -> r -> r) -> r -> SRep w f -> r
forall k (w :: * -> *) r (rep :: k -> *).
(forall x. w x -> r) -> (r -> r -> r) -> r -> SRep w rep -> r
repLeaves forall x. w x -> r
l r -> r -> r
j r
e SRep w f
x) ((forall x. w x -> r) -> (r -> r -> r) -> r -> SRep w g -> r
forall k (w :: * -> *) r (rep :: k -> *).
(forall x. w x -> r) -> (r -> r -> r) -> r -> SRep w rep -> r
repLeaves forall x. w x -> r
l r -> r -> r
j r
e SRep w g
y)
repLeaves l :: forall x. w x -> r
l _ _ (S_K1 x :: w a
x)   = w a -> r
forall x. w x -> r
l w a
x
repLeaves l :: forall x. w x -> r
l j :: r -> r -> r
j e :: r
e (S_ST x :: SRep w f
x)   = (forall x. w x -> r) -> (r -> r -> r) -> r -> SRep w f -> r
forall k (w :: * -> *) r (rep :: k -> *).
(forall x. w x -> r) -> (r -> r -> r) -> r -> SRep w rep -> r
repLeaves forall x. w x -> r
l r -> r -> r
j r
e SRep w f
x

-- |Example of 'repLeaves' that places the values of @w@ inside
-- a list.
repLeavesList :: SRep w rep -> [Exists w]
repLeavesList :: SRep w rep -> [Exists w]
repLeavesList = (forall x. w x -> [Exists w])
-> ([Exists w] -> [Exists w] -> [Exists w])
-> [Exists w]
-> SRep w rep
-> [Exists w]
forall k (w :: * -> *) r (rep :: k -> *).
(forall x. w x -> r) -> (r -> r -> r) -> r -> SRep w rep -> r
repLeaves ((Exists w -> [Exists w] -> [Exists w]
forall a. a -> [a] -> [a]
:[]) (Exists w -> [Exists w]) -> (w x -> Exists w) -> w x -> [Exists w]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w x -> Exists w
forall k (f :: k -> *) (x :: k). f x -> Exists f
Exists) [Exists w] -> [Exists w] -> [Exists w]
forall a. [a] -> [a] -> [a]
(++) []

-- |Maps a function over a representation taking into
-- account that the leaves of the representation satisfy
-- a given constraint.
repMapCM :: (Monad m , OnLeaves c rep)
         => Proxy c -- ^ Which constraint shall be threaded through
         -> (forall y . c y => f y -> m (g y))
         -> SRep f rep -> m (SRep g rep)
repMapCM :: Proxy c
-> (forall y. c y => f y -> m (g y))
-> SRep f rep
-> m (SRep g rep)
repMapCM _p :: Proxy c
_p _f :: forall y. c y => f y -> m (g y)
_f (SRep f rep
S_U1)     = SRep g U1 -> m (SRep g U1)
forall (m :: * -> *) a. Monad m => a -> m a
return SRep g U1
forall k (w :: * -> *). SRep w U1
S_U1
repMapCM _p :: Proxy c
_p f :: forall y. c y => f y -> m (g y)
f  (S_K1 x :: f a
x)   = g a -> SRep g (K1 i a)
forall k (w :: * -> *) a i. w a -> SRep w (K1 i a)
S_K1   (g a -> SRep g (K1 i a)) -> m (g a) -> m (SRep g (K1 i a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a -> m (g a)
forall y. c y => f y -> m (g y)
f f a
x
repMapCM p :: Proxy c
p  f :: forall y. c y => f y -> m (g y)
f  (S_M1 m :: SMeta i t
m x :: SRep f f
x) = SMeta i t -> SRep g f -> SRep g (M1 i t f)
forall k i (t :: Meta) (w :: * -> *) (f :: k -> *).
SMeta i t -> SRep w f -> SRep w (M1 i t f)
S_M1 SMeta i t
m (SRep g f -> SRep g (M1 i t f))
-> m (SRep g f) -> m (SRep g (M1 i t f))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy c
-> (forall y. c y => f y -> m (g y)) -> SRep f f -> m (SRep g f)
forall (m :: * -> *) (c :: * -> Constraint) (rep :: * -> *)
       (f :: * -> *) (g :: * -> *).
(Monad m, OnLeaves c rep) =>
Proxy c
-> (forall y. c y => f y -> m (g y))
-> SRep f rep
-> m (SRep g rep)
repMapCM Proxy c
p forall y. c y => f y -> m (g y)
f SRep f f
x
repMapCM p :: Proxy c
p  f :: forall y. c y => f y -> m (g y)
f  (S_L1 x :: SRep f f
x)   = SRep g f -> SRep g (f :+: g)
forall k (w :: * -> *) (f :: k -> *) (g :: k -> *).
SRep w f -> SRep w (f :+: g)
S_L1   (SRep g f -> SRep g (f :+: g))
-> m (SRep g f) -> m (SRep g (f :+: g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy c
-> (forall y. c y => f y -> m (g y)) -> SRep f f -> m (SRep g f)
forall (m :: * -> *) (c :: * -> Constraint) (rep :: * -> *)
       (f :: * -> *) (g :: * -> *).
(Monad m, OnLeaves c rep) =>
Proxy c
-> (forall y. c y => f y -> m (g y))
-> SRep f rep
-> m (SRep g rep)
repMapCM Proxy c
p forall y. c y => f y -> m (g y)
f SRep f f
x
repMapCM p :: Proxy c
p  f :: forall y. c y => f y -> m (g y)
f  (S_R1 x :: SRep f g
x)   = SRep g g -> SRep g (f :+: g)
forall k (w :: * -> *) (g :: k -> *) (f :: k -> *).
SRep w g -> SRep w (f :+: g)
S_R1   (SRep g g -> SRep g (f :+: g))
-> m (SRep g g) -> m (SRep g (f :+: g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy c
-> (forall y. c y => f y -> m (g y)) -> SRep f g -> m (SRep g g)
forall (m :: * -> *) (c :: * -> Constraint) (rep :: * -> *)
       (f :: * -> *) (g :: * -> *).
(Monad m, OnLeaves c rep) =>
Proxy c
-> (forall y. c y => f y -> m (g y))
-> SRep f rep
-> m (SRep g rep)
repMapCM Proxy c
p forall y. c y => f y -> m (g y)
f SRep f g
x
repMapCM p :: Proxy c
p  f :: forall y. c y => f y -> m (g y)
f  (x :: SRep f f
x :**: y :: SRep f g
y) = SRep g f -> SRep g g -> SRep g (f :*: g)
forall k (w :: * -> *) (f :: k -> *) (g :: k -> *).
SRep w f -> SRep w g -> SRep w (f :*: g)
(:**:) (SRep g f -> SRep g g -> SRep g (f :*: g))
-> m (SRep g f) -> m (SRep g g -> SRep g (f :*: g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy c
-> (forall y. c y => f y -> m (g y)) -> SRep f f -> m (SRep g f)
forall (m :: * -> *) (c :: * -> Constraint) (rep :: * -> *)
       (f :: * -> *) (g :: * -> *).
(Monad m, OnLeaves c rep) =>
Proxy c
-> (forall y. c y => f y -> m (g y))
-> SRep f rep
-> m (SRep g rep)
repMapCM Proxy c
p forall y. c y => f y -> m (g y)
f SRep f f
x m (SRep g g -> SRep g (f :*: g))
-> m (SRep g g) -> m (SRep g (f :*: g))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Proxy c
-> (forall y. c y => f y -> m (g y)) -> SRep f g -> m (SRep g g)
forall (m :: * -> *) (c :: * -> Constraint) (rep :: * -> *)
       (f :: * -> *) (g :: * -> *).
(Monad m, OnLeaves c rep) =>
Proxy c
-> (forall y. c y => f y -> m (g y))
-> SRep f rep
-> m (SRep g rep)
repMapCM Proxy c
p forall y. c y => f y -> m (g y)
f SRep f g
y
repMapCM p :: Proxy c
p  f :: forall y. c y => f y -> m (g y)
f  (S_ST x :: SRep f f
x)   = SRep g f -> SRep g (c :=>: f)
forall k (c :: Constraint) (w :: * -> *) (f :: k -> *).
c =>
SRep w f -> SRep w (c :=>: f)
S_ST   (SRep g f -> SRep g (c :=>: f))
-> m (SRep g f) -> m (SRep g (c :=>: f))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy c
-> (forall y. c y => f y -> m (g y)) -> SRep f f -> m (SRep g f)
forall (m :: * -> *) (c :: * -> Constraint) (rep :: * -> *)
       (f :: * -> *) (g :: * -> *).
(Monad m, OnLeaves c rep) =>
Proxy c
-> (forall y. c y => f y -> m (g y))
-> SRep f rep
-> m (SRep g rep)
repMapCM Proxy c
p forall y. c y => f y -> m (g y)
f SRep f f
x 

-- |Maps a monadic function over the representation
repMapM :: (Monad m)
        => (forall y . f y -> m (g y))
        -> SRep f rep -> m (SRep g rep)
repMapM :: (forall y. f y -> m (g y)) -> SRep f rep -> m (SRep g rep)
repMapM _f :: forall y. f y -> m (g y)
_f (SRep f rep
S_U1)    = SRep g U1 -> m (SRep g U1)
forall (m :: * -> *) a. Monad m => a -> m a
return SRep g U1
forall k (w :: * -> *). SRep w U1
S_U1
repMapM f :: forall y. f y -> m (g y)
f (S_K1 x :: f a
x)   = g a -> SRep g (K1 i a)
forall k (w :: * -> *) a i. w a -> SRep w (K1 i a)
S_K1 (g a -> SRep g (K1 i a)) -> m (g a) -> m (SRep g (K1 i a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a -> m (g a)
forall y. f y -> m (g y)
f f a
x
repMapM f :: forall y. f y -> m (g y)
f (S_M1 m :: SMeta i t
m x :: SRep f f
x) = SMeta i t -> SRep g f -> SRep g (M1 i t f)
forall k i (t :: Meta) (w :: * -> *) (f :: k -> *).
SMeta i t -> SRep w f -> SRep w (M1 i t f)
S_M1 SMeta i t
m (SRep g f -> SRep g (M1 i t f))
-> m (SRep g f) -> m (SRep g (M1 i t f))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall y. f y -> m (g y)) -> SRep f f -> m (SRep g f)
forall k (m :: * -> *) (f :: * -> *) (g :: * -> *) (rep :: k -> *).
Monad m =>
(forall y. f y -> m (g y)) -> SRep f rep -> m (SRep g rep)
repMapM forall y. f y -> m (g y)
f SRep f f
x
repMapM f :: forall y. f y -> m (g y)
f (S_L1 x :: SRep f f
x)   = SRep g f -> SRep g (f :+: g)
forall k (w :: * -> *) (f :: k -> *) (g :: k -> *).
SRep w f -> SRep w (f :+: g)
S_L1 (SRep g f -> SRep g (f :+: g))
-> m (SRep g f) -> m (SRep g (f :+: g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall y. f y -> m (g y)) -> SRep f f -> m (SRep g f)
forall k (m :: * -> *) (f :: * -> *) (g :: * -> *) (rep :: k -> *).
Monad m =>
(forall y. f y -> m (g y)) -> SRep f rep -> m (SRep g rep)
repMapM forall y. f y -> m (g y)
f SRep f f
x
repMapM f :: forall y. f y -> m (g y)
f (S_R1 x :: SRep f g
x)   = SRep g g -> SRep g (f :+: g)
forall k (w :: * -> *) (g :: k -> *) (f :: k -> *).
SRep w g -> SRep w (f :+: g)
S_R1 (SRep g g -> SRep g (f :+: g))
-> m (SRep g g) -> m (SRep g (f :+: g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall y. f y -> m (g y)) -> SRep f g -> m (SRep g g)
forall k (m :: * -> *) (f :: * -> *) (g :: * -> *) (rep :: k -> *).
Monad m =>
(forall y. f y -> m (g y)) -> SRep f rep -> m (SRep g rep)
repMapM forall y. f y -> m (g y)
f SRep f g
x
repMapM f :: forall y. f y -> m (g y)
f (S_ST x :: SRep f f
x)   = SRep g f -> SRep g (c :=>: f)
forall k (c :: Constraint) (w :: * -> *) (f :: k -> *).
c =>
SRep w f -> SRep w (c :=>: f)
S_ST (SRep g f -> SRep g (c :=>: f))
-> m (SRep g f) -> m (SRep g (c :=>: f))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall y. f y -> m (g y)) -> SRep f f -> m (SRep g f)
forall k (m :: * -> *) (f :: * -> *) (g :: * -> *) (rep :: k -> *).
Monad m =>
(forall y. f y -> m (g y)) -> SRep f rep -> m (SRep g rep)
repMapM forall y. f y -> m (g y)
f SRep f f
x
repMapM f :: forall y. f y -> m (g y)
f (x :: SRep f f
x :**: y :: SRep f g
y)
  = SRep g f -> SRep g g -> SRep g (f :*: g)
forall k (w :: * -> *) (f :: k -> *) (g :: k -> *).
SRep w f -> SRep w g -> SRep w (f :*: g)
(:**:) (SRep g f -> SRep g g -> SRep g (f :*: g))
-> m (SRep g f) -> m (SRep g g -> SRep g (f :*: g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall y. f y -> m (g y)) -> SRep f f -> m (SRep g f)
forall k (m :: * -> *) (f :: * -> *) (g :: * -> *) (rep :: k -> *).
Monad m =>
(forall y. f y -> m (g y)) -> SRep f rep -> m (SRep g rep)
repMapM forall y. f y -> m (g y)
f SRep f f
x m (SRep g g -> SRep g (f :*: g))
-> m (SRep g g) -> m (SRep g (f :*: g))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall y. f y -> m (g y)) -> SRep f g -> m (SRep g g)
forall k (m :: * -> *) (f :: * -> *) (g :: * -> *) (rep :: k -> *).
Monad m =>
(forall y. f y -> m (g y)) -> SRep f rep -> m (SRep g rep)
repMapM forall y. f y -> m (g y)
f SRep f g
y

-- |Maps a simple functino over the representation
repMap :: (forall y . f y -> g y)
       -> SRep f rep -> SRep g rep
repMap :: (forall y. f y -> g y) -> SRep f rep -> SRep g rep
repMap f :: forall y. f y -> g y
f = Identity (SRep g rep) -> SRep g rep
forall a. Identity a -> a
runIdentity (Identity (SRep g rep) -> SRep g rep)
-> (SRep f rep -> Identity (SRep g rep))
-> SRep f rep
-> SRep g rep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall y. f y -> Identity (g y))
-> SRep f rep -> Identity (SRep g rep)
forall k (m :: * -> *) (f :: * -> *) (g :: * -> *) (rep :: k -> *).
Monad m =>
(forall y. f y -> m (g y)) -> SRep f rep -> m (SRep g rep)
repMapM (g y -> Identity (g y)
forall (m :: * -> *) a. Monad m => a -> m a
return (g y -> Identity (g y)) -> (f y -> g y) -> f y -> Identity (g y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f y -> g y
forall y. f y -> g y
f)

--------------------------------

-- |Identity functor
newtype I x = I { I x -> x
unI :: x }
  deriving I x -> I x -> Bool
(I x -> I x -> Bool) -> (I x -> I x -> Bool) -> Eq (I x)
forall x. Eq x => I x -> I x -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: I x -> I x -> Bool
$c/= :: forall x. Eq x => I x -> I x -> Bool
== :: I x -> I x -> Bool
$c== :: forall x. Eq x => I x -> I x -> Bool
Eq

instance Show x => Show (I x) where
  showsPrec :: Int -> I x -> ShowS
showsPrec p :: Int
p (I x :: x
x) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString "I " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> x -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 11 x
x
instance Functor I where
  fmap :: (a -> b) -> I a -> I b
fmap f :: a -> b
f (I x :: a
x) = b -> I b
forall x. x -> I x
I (a -> b
f a
x)
instance Applicative I where
  pure :: a -> I a
pure        = a -> I a
forall x. x -> I x
I
  I f :: a -> b
f <*> :: I (a -> b) -> I a -> I b
<*> I x :: a
x = b -> I b
forall x. x -> I x
I (a -> b
f a
x)
instance Monad I where
  I x :: a
x >>= :: I a -> (a -> I b) -> I b
>>= f :: a -> I b
f = a -> I b
f a
x

-- |Shallow conversion between "GHC.Generics" representation
-- and 'SRep'; The 'fromS' and 'toS' functions provide the
-- toplevel api.
class GShallow f where
  sfrom :: f x -> SRep I f
  sto   :: SRep I f -> f x

instance GShallow U1 where
  sfrom :: U1 x -> SRep I U1
sfrom U1 = SRep I U1
forall k (w :: * -> *). SRep w U1
S_U1
  sto :: SRep I U1 -> U1 x
sto S_U1 = U1 x
forall k (p :: k). U1 p
U1

instance (GShallow f , GShallow g) => GShallow (f :+: g) where
  sfrom :: (:+:) f g x -> SRep I (f :+: g)
sfrom (L1 x :: f x
x) = SRep I f -> SRep I (f :+: g)
forall k (w :: * -> *) (f :: k -> *) (g :: k -> *).
SRep w f -> SRep w (f :+: g)
S_L1 (f x -> SRep I f
forall k (f :: k -> *) (x :: k). GShallow f => f x -> SRep I f
sfrom f x
x)
  sfrom (R1 x :: g x
x) = SRep I g -> SRep I (f :+: g)
forall k (w :: * -> *) (g :: k -> *) (f :: k -> *).
SRep w g -> SRep w (f :+: g)
S_R1 (g x -> SRep I g
forall k (f :: k -> *) (x :: k). GShallow f => f x -> SRep I f
sfrom g x
x)
  sto :: SRep I (f :+: g) -> (:+:) f g x
sto (S_L1 x :: SRep I f
x) = f x -> (:+:) f g x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (SRep I f -> f x
forall k (f :: k -> *) (x :: k). GShallow f => SRep I f -> f x
sto SRep I f
x)
  sto (S_R1 x :: SRep I g
x) = g x -> (:+:) f g x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (SRep I g -> g x
forall k (f :: k -> *) (x :: k). GShallow f => SRep I f -> f x
sto SRep I g
x)

instance (GShallow f , GShallow g) => GShallow (f :*: g) where
  sfrom :: (:*:) f g x -> SRep I (f :*: g)
sfrom (x :: f x
x :*:  y :: g x
y) = f x -> SRep I f
forall k (f :: k -> *) (x :: k). GShallow f => f x -> SRep I f
sfrom f x
x SRep I f -> SRep I g -> SRep I (f :*: g)
forall k (w :: * -> *) (f :: k -> *) (g :: k -> *).
SRep w f -> SRep w g -> SRep w (f :*: g)
:**: g x -> SRep I g
forall k (f :: k -> *) (x :: k). GShallow f => f x -> SRep I f
sfrom g x
y
  sto :: SRep I (f :*: g) -> (:*:) f g x
sto   (x :: SRep I f
x :**: y :: SRep I g
y) = SRep I f -> f x
forall k (f :: k -> *) (x :: k). GShallow f => SRep I f -> f x
sto SRep I f
x   f x -> g x -> (:*:) f g x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*:  SRep I g -> g x
forall k (f :: k -> *) (x :: k). GShallow f => SRep I f -> f x
sto SRep I g
y

instance (GShallow f , GMeta i c) => GShallow (M1 i c f) where
  sfrom :: M1 i c f x -> SRep I (M1 i c f)
sfrom (M1 x :: f x
x)   = SMeta i c -> SRep I f -> SRep I (M1 i c f)
forall k i (t :: Meta) (w :: * -> *) (f :: k -> *).
SMeta i t -> SRep w f -> SRep w (M1 i t f)
S_M1 SMeta i c
forall k i (c :: k). GMeta i c => SMeta i c
smeta (f x -> SRep I f
forall k (f :: k -> *) (x :: k). GShallow f => f x -> SRep I f
sfrom f x
x)
  sto :: SRep I (M1 i c f) -> M1 i c f x
sto (S_M1 _ x :: SRep I f
x) = f x -> M1 i c f x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (SRep I f -> f x
forall k (f :: k -> *) (x :: k). GShallow f => SRep I f -> f x
sto SRep I f
x)

instance GShallow (K1 R x) where
  sfrom :: K1 R x x -> SRep I (K1 R x)
sfrom (K1 x :: x
x) = I x -> SRep I (K1 R x)
forall k (w :: * -> *) a i. w a -> SRep w (K1 i a)
S_K1 (x -> I x
forall x. x -> I x
I x
x)
  sto :: SRep I (K1 R x) -> K1 R x x
sto (S_K1 (I x :: a
x)) = a -> K1 R a x
forall k i c (p :: k). c -> K1 i c p
K1 a
x

-- |Converts a value of a generic type directly to its
-- (shallow) simplistic representation.
fromS :: (Simplistic a) => a -> SRep I (Rep a)
fromS :: a -> SRep I (Rep a)
fromS = Rep a Any -> SRep I (Rep a)
forall k (f :: k -> *) (x :: k). GShallow f => f x -> SRep I f
sfrom (Rep a Any -> SRep I (Rep a))
-> (a -> Rep a Any) -> a -> SRep I (Rep a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from

-- |Converts a simplistic representation back to its corresponding
-- value of type @a@.
toS :: (Simplistic a) => SRep I (Rep a) -> a
toS :: SRep I (Rep a) -> a
toS = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a)
-> (SRep I (Rep a) -> Rep a Any) -> SRep I (Rep a) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SRep I (Rep a) -> Rep a Any
forall k (f :: k -> *) (x :: k). GShallow f => SRep I f -> f x
sto

-- TODO: Study whether it makes sense to add rules
--       and inline pragmas for performance.
-- {-# RULES "sfrom/sto" forall x.  sfrom (sto x) = x #-}
-- {-# RULES "sto/sfrom" forall x.  sto (sfrom x) = x #-}

---------------------------------------
---------------------------------------
-- Representation of `* -> *` types  --
---------------------------------------
---------------------------------------

-- $simplistic1
--
-- "GHC.Generics" provides 'Rep' for types of kind @*@
-- and 'Rep1' for types of kind @* -> *@. Similarly,
-- we also provide 'SRep1' for a closed-universe interpretation
-- of 'Rep1'. It is worth noting the support is limitted and
-- we have not yet written combinators for 'SRep1' like we
-- did for 'SRep'. An example usage of 'SRep1' can be found
-- in "Generics.Simplistic.Derive.Functor".

infixr 5 :***:

-- |Similar to 'SRep', but is indexed over the functors that
-- make up a 'Rep1', used to explicitely encode types with
-- one parameter. 
data SRep1 f x where
  S1_U1   ::                           SRep1 U1         x
  S1_L1   ::              SRep1 f x -> SRep1 (f :+: g)  x
  S1_R1   ::              SRep1 g x -> SRep1 (f :+: g)  x
  (:***:) :: SRep1 f x -> SRep1 g x -> SRep1 (f :*: g)  x
  S1_K1   ::          a             -> SRep1 (K1 i a)   x
  S1_M1   :: SMeta i t -> SRep1 f x -> SRep1 (M1 i t f) x
  S1_ST   ::        c =>  SRep1 f x -> SRep1 (c :=>: f) x
  S1_Par  ::          x             -> SRep1 Par1       x
  S1_Rec  ::          f x           -> SRep1 (Rec1 f)   x
  S1_Comp ::          f (SRep1 g x) -> SRep1 (f :.: g)  x

type Simplistic1 f = (Generic1 f, GShallow1 (Rep1 f))

type family OnLeaves1 (c :: * -> Constraint) (r :: (* -> *) -> Constraint)
                      (f :: * -> *) :: Constraint where
  OnLeaves1 c r V1         = ()
  OnLeaves1 c r U1         = ()
  OnLeaves1 c r (f :+: g)  = (OnLeaves1 c r f, OnLeaves1 c r g)
  OnLeaves1 c r (f :*: g)  = (OnLeaves1 c r f, OnLeaves1 c r g)
  OnLeaves1 c r (K1 i a)   = c a
  OnLeaves1 c r (M1 i p f) = OnLeaves1 c r f
  OnLeaves1 c r (d :=>: f) = Implies d (OnLeaves1 c r f)
  OnLeaves1 c r Par1       = ()
  OnLeaves1 c r (Rec1 f)   = r f
  OnLeaves1 c r (f :.: g)  = (r f, OnLeaves1 c r g)

-- |Converts a value of a generic type directly to its
-- (shallow) simplistic1 representation with a parameter.
fromS1 :: (Simplistic1 f) => f x -> SRep1 (Rep1 f) x
fromS1 :: f x -> SRep1 (Rep1 f) x
fromS1 = Rep1 f x -> SRep1 (Rep1 f) x
forall (f :: * -> *) a. GShallow1 f => f a -> SRep1 f a
sfrom1 (Rep1 f x -> SRep1 (Rep1 f) x)
-> (f x -> Rep1 f x) -> f x -> SRep1 (Rep1 f) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> Rep1 f x
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1

-- |Converts a simplistic1 representation back to its corresponding
-- value of type @a@.
toS1 :: (Simplistic1 f) => SRep1 (Rep1 f) x -> f x
toS1 :: SRep1 (Rep1 f) x -> f x
toS1 = Rep1 f x -> f x
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Rep1 f x -> f x)
-> (SRep1 (Rep1 f) x -> Rep1 f x) -> SRep1 (Rep1 f) x -> f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SRep1 (Rep1 f) x -> Rep1 f x
forall (f :: * -> *) a. GShallow1 f => SRep1 f a -> f a
sto1

class GShallow1 f where
  sfrom1 :: f a -> SRep1 f a
  sto1   :: SRep1 f a -> f a
instance GShallow1 V1 where
  sfrom1 :: V1 a -> SRep1 V1 a
sfrom1 = V1 a -> SRep1 V1 a
forall a. HasCallStack => a
undefined
  sto1 :: SRep1 V1 a -> V1 a
sto1   = SRep1 V1 a -> V1 a
forall a. HasCallStack => a
undefined
instance GShallow1 U1 where
  sfrom1 :: U1 a -> SRep1 U1 a
sfrom1 U1 = SRep1 U1 a
forall x. SRep1 U1 x
S1_U1
  sto1 :: SRep1 U1 a -> U1 a
sto1   S1_U1 = U1 a
forall k (p :: k). U1 p
U1
instance (GShallow1 f, GShallow1 g) => GShallow1 (f :+: g) where
  sfrom1 :: (:+:) f g a -> SRep1 (f :+: g) a
sfrom1 (L1 x :: f a
x) = SRep1 f a -> SRep1 (f :+: g) a
forall (f :: * -> *) x (g :: * -> *).
SRep1 f x -> SRep1 (f :+: g) x
S1_L1 (f a -> SRep1 f a
forall (f :: * -> *) a. GShallow1 f => f a -> SRep1 f a
sfrom1 f a
x)
  sfrom1 (R1 y :: g a
y) = SRep1 g a -> SRep1 (f :+: g) a
forall (g :: * -> *) x (f :: * -> *).
SRep1 g x -> SRep1 (f :+: g) x
S1_R1 (g a -> SRep1 g a
forall (f :: * -> *) a. GShallow1 f => f a -> SRep1 f a
sfrom1 g a
y)
  sto1 :: SRep1 (f :+: g) a -> (:+:) f g a
sto1   (S1_L1 x :: SRep1 f a
x) = f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (SRep1 f a -> f a
forall (f :: * -> *) a. GShallow1 f => SRep1 f a -> f a
sto1 SRep1 f a
x)
  sto1   (S1_R1 y :: SRep1 g a
y) = g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (SRep1 g a -> g a
forall (f :: * -> *) a. GShallow1 f => SRep1 f a -> f a
sto1 SRep1 g a
y)
instance (GShallow1 f, GShallow1 g) => GShallow1 (f :*: g) where
  sfrom1 :: (:*:) f g a -> SRep1 (f :*: g) a
sfrom1 (x :: f a
x :*: y :: g a
y) = f a -> SRep1 f a
forall (f :: * -> *) a. GShallow1 f => f a -> SRep1 f a
sfrom1 f a
x SRep1 f a -> SRep1 g a -> SRep1 (f :*: g) a
forall (f :: * -> *) x (a :: * -> *).
SRep1 f x -> SRep1 a x -> SRep1 (f :*: a) x
:***: g a -> SRep1 g a
forall (f :: * -> *) a. GShallow1 f => f a -> SRep1 f a
sfrom1 g a
y
  sto1 :: SRep1 (f :*: g) a -> (:*:) f g a
sto1   (x :: SRep1 f a
x :***: y :: SRep1 g a
y) = SRep1 f a -> f a
forall (f :: * -> *) a. GShallow1 f => SRep1 f a -> f a
sto1 SRep1 f a
x f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: SRep1 g a -> g a
forall (f :: * -> *) a. GShallow1 f => SRep1 f a -> f a
sto1 SRep1 g a
y
instance GShallow1 (K1 i a) where
  sfrom1 :: K1 i a a -> SRep1 (K1 i a) a
sfrom1 (K1 x :: a
x) = a -> SRep1 (K1 i a) a
forall a i x. a -> SRep1 (K1 i a) x
S1_K1 a
x
  sto1 :: SRep1 (K1 i a) a -> K1 i a a
sto1   (S1_K1 x :: a
x) = a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 a
x
instance (GMeta i t, GShallow1 f) => GShallow1 (M1 i t f) where
  sfrom1 :: M1 i t f a -> SRep1 (M1 i t f) a
sfrom1 (M1 x :: f a
x) = SMeta i t -> SRep1 f a -> SRep1 (M1 i t f) a
forall i (t :: Meta) (c :: * -> *) x.
SMeta i t -> SRep1 c x -> SRep1 (M1 i t c) x
S1_M1 SMeta i t
forall k i (c :: k). GMeta i c => SMeta i c
smeta (f a -> SRep1 f a
forall (f :: * -> *) a. GShallow1 f => f a -> SRep1 f a
sfrom1 f a
x)
  sto1 :: SRep1 (M1 i t f) a -> M1 i t f a
sto1   (S1_M1 _ x :: SRep1 f a
x) = f a -> M1 i t f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (SRep1 f a -> f a
forall (f :: * -> *) a. GShallow1 f => SRep1 f a -> f a
sto1 SRep1 f a
x)
instance (c => GShallow1 f) => GShallow1 (c :=>: f) where
  sfrom1 :: (:=>:) c f a -> SRep1 (c :=>: f) a
sfrom1 (SuchThat x :: f a
x) = SRep1 f a -> SRep1 (c :=>: f) a
forall (c :: Constraint) (f :: * -> *) x.
c =>
SRep1 f x -> SRep1 (c :=>: f) x
S1_ST (f a -> SRep1 f a
forall (f :: * -> *) a. GShallow1 f => f a -> SRep1 f a
sfrom1 f a
x)
  sto1 :: SRep1 (c :=>: f) a -> (:=>:) c f a
sto1   (S1_ST x :: SRep1 f a
x) = f a -> (:=>:) c f a
forall k (c :: Constraint) (f :: k -> *) (a :: k).
c =>
f a -> (:=>:) c f a
SuchThat (SRep1 f a -> f a
forall (f :: * -> *) a. GShallow1 f => SRep1 f a -> f a
sto1 SRep1 f a
x)
instance GShallow1 Par1 where
  sfrom1 :: Par1 a -> SRep1 Par1 a
sfrom1 (Par1 x :: a
x) = a -> SRep1 Par1 a
forall x. x -> SRep1 Par1 x
S1_Par a
x
  sto1 :: SRep1 Par1 a -> Par1 a
sto1   (S1_Par x :: a
x) = a -> Par1 a
forall p. p -> Par1 p
Par1 a
x
instance GShallow1 (Rec1 f) where
  sfrom1 :: Rec1 f a -> SRep1 (Rec1 f) a
sfrom1 (Rec1 x :: f a
x) = f a -> SRep1 (Rec1 f) a
forall (f :: * -> *) x. f x -> SRep1 (Rec1 f) x
S1_Rec f a
x
  sto1 :: SRep1 (Rec1 f) a -> Rec1 f a
sto1   (S1_Rec x :: f a
x) = f a -> Rec1 f a
forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 f a
x
instance (Functor f, GShallow1 g) => GShallow1 (f :.: g) where
  sfrom1 :: (:.:) f g a -> SRep1 (f :.: g) a
sfrom1 (Comp1 x :: f (g a)
x) = f (SRep1 g a) -> SRep1 (f :.: g) a
forall (f :: * -> *) (g :: * -> *) x.
f (SRep1 g x) -> SRep1 (f :.: g) x
S1_Comp ((g a -> SRep1 g a) -> f (g a) -> f (SRep1 g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap g a -> SRep1 g a
forall (f :: * -> *) a. GShallow1 f => f a -> SRep1 f a
sfrom1 f (g a)
x)
  sto1 :: SRep1 (f :.: g) a -> (:.:) f g a
sto1   (S1_Comp x :: f (SRep1 g a)
x) = f (g a) -> (:.:) f g a
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 ((SRep1 g a -> g a) -> f (SRep1 g a) -> f (g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SRep1 g a -> g a
forall (f :: * -> *) a. GShallow1 f => SRep1 f a -> f a
sto1 f (SRep1 g a)
x)