{-# 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 :: forall p.
GHKD_ f (M1 index meta inner) p -> f (M1 index meta inner p)
gconstruct   = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (rep :: * -> *) p.
GConstruct f rep =>
GHKD_ f rep p -> f (rep p)
gconstruct forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1
  gdeconstruct :: forall p. M1 index meta inner p -> GHKD_ f (M1 index meta inner) p
gdeconstruct = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (rep :: * -> *) p.
GConstruct f rep =>
rep p -> GHKD_ f rep p
gdeconstruct @f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (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 :: forall p. GHKD_ f (left :*: right) p -> f ((:*:) left right p)
gconstruct   (GHKD_ f left p
l :*: GHKD_ f right p
r) = forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) (rep :: * -> *) p.
GConstruct f rep =>
GHKD_ f rep p -> f (rep p)
gconstruct      GHKD_ f left p
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) (rep :: * -> *) p.
GConstruct f rep =>
GHKD_ f rep p -> f (rep p)
gconstruct      GHKD_ f right p
r
  gdeconstruct :: forall p. (:*:) left right p -> GHKD_ f (left :*: right) p
gdeconstruct (left p
l :*: right p
r) =           forall (f :: * -> *) (rep :: * -> *) p.
GConstruct f rep =>
rep p -> GHKD_ f rep p
gdeconstruct @f left p
l forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g 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 :: forall p. GHKD_ f (K1 index inner) p -> f (K1 index inner p)
gconstruct (K1 f inner
x) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i c (p :: k). c -> K1 i c p
K1 f inner
x
  gdeconstruct :: forall p. K1 index inner p -> GHKD_ f (K1 index inner) p
gdeconstruct (K1 inner
x) = forall k i c (p :: k). c -> K1 i c p
K1 (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   = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a x. Generic a => Rep a x -> a
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (rep :: * -> *) p.
GConstruct f rep =>
GHKD_ f rep p -> f (rep p)
gconstruct forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall structure (f :: * -> *).
HKD structure f -> HKD_ f structure Void
runHKD
  deconstruct :: structure -> HKD structure f
deconstruct = forall structure (f :: * -> *).
HKD_ f structure Void -> HKD structure f
HKD forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (rep :: * -> *) p.
GConstruct f rep =>
rep p -> GHKD_ f rep p
gdeconstruct @f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from