{-# OPTIONS_HADDOCK not-home #-}

{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MonoLocalBinds        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

{-|
Module      : Data.Generic.HKD.Construction
Description : Convert to and from the generic HKD structure.
Copyright   : (c) Tom Harding, 2019
License     : MIT
Maintainer  : tom.harding@habito.com
Stability   : experimental
-}
module Data.Generic.HKD.Construction
  ( Construct (..)
  ) where

import Data.Generic.HKD.Types (HKD (..), GHKD_)
import Data.Kind (Type)
import GHC.Generics

-- | When working with the HKD representation, it is useful to have a way to
-- convert to and from our original type. To do this, we can:
--
-- * @construct@ the original type from our HKD representation, and
--
-- * @deconstruct@ the original type /into/ our HKD representation.
--
-- As an example, we can try (unsuccessfully) to construct an @(Int, Bool)@
-- tuple from an unpopulated partial structure.
-- 
-- >>> :set -XTypeApplications
-- >>> import Data.Monoid (Last)
--
-- >>> construct (mempty @(HKD (Int, Bool) Last))
-- Last {getLast = Nothing}
--
-- We can also /deconstruct/ a tuple into a partial structure:
--
-- >>> deconstruct @[] ("Hello", True)
-- (,) ["Hello"] [True]
--
-- These two methods also satisfy the round-tripping property:
--
-- prop> construct (deconstruct x) == [ x :: (Int, Bool, String) ]
class Construct (f :: Type -> Type) (structure :: Type) where
  construct   :: HKD structure f -> f structure
  deconstruct :: structure -> HKD structure f

class GConstruct (f :: Type -> Type) (rep :: Type -> Type) where
  gconstruct   :: GHKD_ f rep p -> f (rep p)
  gdeconstruct :: rep p -> GHKD_ f rep p

instance (Functor f, GConstruct f inner)
    => GConstruct f (M1 index meta inner) where
  gconstruct :: GHKD_ f (M1 index meta inner) p -> f (M1 index meta inner p)
gconstruct   = (inner p -> M1 index meta inner p)
-> f (inner p) -> f (M1 index meta inner p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap inner p -> M1 index meta inner p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f (inner p) -> f (M1 index meta inner p))
-> (M1 index meta (GHKD_ f inner) p -> f (inner p))
-> M1 index meta (GHKD_ f inner) p
-> f (M1 index meta inner p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GHKD_ f inner p -> f (inner p)
forall (f :: * -> *) (rep :: * -> *) p.
GConstruct f rep =>
GHKD_ f rep p -> f (rep p)
gconstruct (GHKD_ f inner p -> f (inner p))
-> (M1 index meta (GHKD_ f inner) p -> GHKD_ f inner p)
-> M1 index meta (GHKD_ f inner) p
-> f (inner p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 index meta (GHKD_ f inner) p -> GHKD_ f inner p
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1
  gdeconstruct :: M1 index meta inner p -> GHKD_ f (M1 index meta inner) p
gdeconstruct = GHKD_ f inner p -> M1 index meta (GHKD_ f inner) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (GHKD_ f inner p -> M1 index meta (GHKD_ f inner) p)
-> (M1 index meta inner p -> GHKD_ f inner p)
-> M1 index meta inner p
-> M1 index meta (GHKD_ f inner) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rep :: * -> *) p.
GConstruct f rep =>
rep p -> GHKD_ f rep p
forall (f :: * -> *) (rep :: * -> *) p.
GConstruct f rep =>
rep p -> GHKD_ f rep p
gdeconstruct @f (inner p -> GHKD_ f inner p)
-> (M1 index meta inner p -> inner p)
-> M1 index meta inner p
-> GHKD_ f inner p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 index meta inner p -> inner p
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

instance (Applicative f, GConstruct f left, GConstruct f right)
    => GConstruct f (left :*: right) where
  gconstruct :: GHKD_ f (left :*: right) p -> f ((:*:) left right p)
gconstruct   (l :*: r) = left p -> right p -> (:*:) left right p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (left p -> right p -> (:*:) left right p)
-> f (left p) -> f (right p -> (:*:) left right p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GHKD_ f left p -> f (left p)
forall (f :: * -> *) (rep :: * -> *) p.
GConstruct f rep =>
GHKD_ f rep p -> f (rep p)
gconstruct      GHKD_ f left p
l f (right p -> (:*:) left right p)
-> f (right p) -> f ((:*:) left right p)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GHKD_ f right p -> f (right p)
forall (f :: * -> *) (rep :: * -> *) p.
GConstruct f rep =>
GHKD_ f rep p -> f (rep p)
gconstruct      GHKD_ f right p
r
  gdeconstruct :: (:*:) left right p -> GHKD_ f (left :*: right) p
gdeconstruct (left p
l :*: right p
r) =           left p -> GHKD_ f left p
forall (f :: * -> *) (rep :: * -> *) p.
GConstruct f rep =>
rep p -> GHKD_ f rep p
gdeconstruct @f left p
l GHKD_ f left p
-> GHKD_ f right p -> (:*:) (GHKD_ f left) (GHKD_ f right) p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: right p -> GHKD_ f right p
forall (f :: * -> *) (rep :: * -> *) p.
GConstruct f rep =>
rep p -> GHKD_ f rep p
gdeconstruct @f right p
r

instance Applicative f => GConstruct f (K1 index inner) where
  gconstruct :: GHKD_ f (K1 index inner) p -> f (K1 index inner p)
gconstruct (K1 x) = (inner -> K1 index inner p) -> f inner -> f (K1 index inner p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap inner -> K1 index inner p
forall k i c (p :: k). c -> K1 i c p
K1 f inner
x
  gdeconstruct :: K1 index inner p -> GHKD_ f (K1 index inner) p
gdeconstruct (K1 inner
x) = f inner -> K1 index (f inner) p
forall k i c (p :: k). c -> K1 i c p
K1 (inner -> f inner
forall (f :: * -> *) a. Applicative f => a -> f a
pure inner
x)

instance (Applicative f, Generic structure, GConstruct f (Rep structure))
    => Construct f structure where
  construct :: HKD structure f -> f structure
construct   = (Rep structure Void -> structure)
-> f (Rep structure Void) -> f structure
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep structure Void -> structure
forall a x. Generic a => Rep a x -> a
to (f (Rep structure Void) -> f structure)
-> (HKD structure f -> f (Rep structure Void))
-> HKD structure f
-> f structure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GHKD_ f (Rep structure) Void -> f (Rep structure Void)
forall (f :: * -> *) (rep :: * -> *) p.
GConstruct f rep =>
GHKD_ f rep p -> f (rep p)
gconstruct (GHKD_ f (Rep structure) Void -> f (Rep structure Void))
-> (HKD structure f -> GHKD_ f (Rep structure) Void)
-> HKD structure f
-> f (Rep structure Void)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HKD structure f -> GHKD_ f (Rep structure) Void
forall structure (f :: * -> *).
HKD structure f -> HKD_ f structure Void
runHKD
  deconstruct :: structure -> HKD structure f
deconstruct = GHKD_ f (Rep structure) Void -> HKD structure f
forall structure (f :: * -> *).
HKD_ f structure Void -> HKD structure f
HKD (GHKD_ f (Rep structure) Void -> HKD structure f)
-> (structure -> GHKD_ f (Rep structure) Void)
-> structure
-> HKD structure f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rep :: * -> *) p.
GConstruct f rep =>
rep p -> GHKD_ f rep p
forall (f :: * -> *) (rep :: * -> *) p.
GConstruct f rep =>
rep p -> GHKD_ f rep p
gdeconstruct @f (Rep structure Void -> GHKD_ f (Rep structure) Void)
-> (structure -> Rep structure Void)
-> structure
-> GHKD_ f (Rep structure) Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. structure -> Rep structure Void
forall a x. Generic a => a -> Rep a x
from