{-# LANGUAGE AllowAmbiguousTypes  #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DefaultSignatures    #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TupleSections        #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module      : Data.Array.Accelerate.Sugar.Elt
-- Copyright   : [2008..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--

module Data.Array.Accelerate.Sugar.Elt ( Elt(..) )
  where

import Data.Array.Accelerate.Representation.Elt
import Data.Array.Accelerate.Representation.Tag
import Data.Array.Accelerate.Representation.Type
import Data.Array.Accelerate.Type

import Control.Applicative                                          ( (<|>) )
import qualified Control.Monad.State.Lazy                           as LState
import Control.Monad.Fix                                            ( mfix )
import Data.Char
import Data.Kind
import Data.Maybe                                                   ( fromMaybe )
import Data.Proxy
import Language.Haskell.TH.Extra                                    hiding ( Type )

import GHC.Generics


-- | The 'Elt' class characterises the allowable array element types, and
-- hence the types which can appear in scalar Accelerate expressions of
-- type 'Data.Array.Accelerate.Exp'.
--
-- Accelerate arrays consist of simple atomic types as well as nested
-- tuples thereof, stored efficiently in memory as consecutive unpacked
-- elements without pointers. It roughly consists of:
--
--  * Signed and unsigned integers (8, 16, 32, and 64-bits wide)
--  * Floating point numbers (half, single, and double precision)
--  * 'Char'
--  * 'Bool'
--  * ()
--  * Shapes formed from 'Z' and (':.')
--  * Nested tuples of all of these, currently up to 16-elements wide
--
-- Adding new instances for 'Elt' consists of explaining to Accelerate how
-- to map between your data type and a (tuple of) primitive values. For
-- examples see:
--
--  * "Data.Array.Accelerate.Data.Complex"
--  * "Data.Array.Accelerate.Data.Monoid"
--  * <https://hackage.haskell.org/package/linear-accelerate linear-accelerate>
--  * <https://hackage.haskell.org/package/colour-accelerate colour-accelerate>
--
-- For simple types it is possible to derive 'Elt' automatically, for
-- example:
--
-- > data Point = Point Int Float
-- >   deriving (Generic, Elt)
--
-- > data Option a = None | Just a
-- >   deriving (Generic, Elt)
--
-- See the function 'Data.Array.Accelerate.match' for details on how to use
-- sum types in embedded code.
--
class Elt a where
  -- | Type representation mapping, which explains how to convert a type
  -- from the surface type into the internal representation type consisting
  -- only of simple primitive types, unit '()', and pair '(,)'.
  --
  type EltR a :: Type
  type EltR a = GEltR () (Rep a)
  --
  eltR    :: TypeR (EltR a)
  tagsR   :: [TagR (EltR a)]
  fromElt :: a -> EltR a
  toElt   :: EltR a -> a

  default eltR
      :: (GElt (Rep a), EltR a ~ GEltR () (Rep a))
      => TypeR (EltR a)
  eltR = forall (f :: * -> *) t. GElt f => TypeR t -> TypeR (GEltR t f)
geltR @(Rep a) TypeR ()
forall (s :: * -> *). TupR s ()
TupRunit

  default tagsR
      :: (Generic a, GElt (Rep a), EltR a ~ GEltR () (Rep a))
      => [TagR (EltR a)]
  tagsR = forall (f :: * -> *) t. GElt f => TagR t -> [TagR (GEltR t f)]
gtagsR @(Rep a) TagR ()
TagRunit

  default fromElt
      :: (Generic a, GElt (Rep a), EltR a ~ GEltR () (Rep a))
      => a
      -> EltR a
  fromElt = () -> Rep a Any -> GEltR () (Rep a)
forall t a. t -> Rep a a -> GEltR t (Rep a)
forall (f :: * -> *) t a. GElt f => t -> f a -> GEltR t f
gfromElt () (Rep a Any -> EltR a) -> (a -> Rep a Any) -> a -> EltR a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from

  default toElt
      :: (Generic a, GElt (Rep a), EltR a ~ GEltR () (Rep a))
      => EltR a
      -> a
  toElt = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a Any -> a) -> (EltR a -> Rep a Any) -> EltR a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), Rep a Any) -> Rep a Any
forall a b. (a, b) -> b
snd (((), Rep a Any) -> Rep a Any)
-> (EltR a -> ((), Rep a Any)) -> EltR a -> Rep a Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) t a. GElt f => GEltR t f -> (t, f a)
gtoElt @(Rep a) @()


-- | Given:
--
-- > data Test = A Int | B Int Float | C Float | D Double deriving (Show, Generic, Elt)
--
-- the call `geltR @(Rep Test) t` produces:
--
-- > TupRsingle Word8 :* (t :* tInt :* tInt :* tFloat :* tFloat :* tDouble)
--
-- where we abbreviate:
--
-- * TupRpair as (:*), infixl (i.e. "a :* b :* c" means "(a :* b) :* c")
-- * TupRsingle Int as tInt
-- * TupRsingle Float as tFloat
--
-- The first Word8 is the sum type tag.
--
-- This tag is not generated if there is only one constructor, so for example, given:
--
-- > data Test2 = T Int Float deriving (Show, Generic, Elt)
--
-- the call `geltR @Test2 t` produces: (using the same abbreviations)
--
-- > t :* tInt :* tFloat
--
-- To make sure the tag gets included conditionally, but only once if there are
-- many levels of (:+:) in the Generics representation -- and to furthermore
-- avoid needing a third type class -- we do a bit of a strange dance.
--
-- * The Elt default methods invoke GElt at the Rep of the data type. This may
--   be a (:+:) if it has more than 1 constructor, and something else
--   otherwise.
-- * GElt generates the tag in its instance for (:+:), and calls out to GSumElt
--   to actually handle the sum type constructors. Whenever GSumElt reaches a
--   non-(:+:), it calls back into GElt, which, from now on, will never
--   encounter (:+:) any more.
-- * GElt then handles the products (i.e. the data type constructor fields) and
--   finishes.
--
-- So to understand the full, precise control flow, one should start reading in
-- Elt, proceed with the GElt class and its (:+:) instance, then the full
-- definition of GSumElt, and finally the remaining instances of GElt.
class GElt f where
  -- | The @t@ variable is an additional uninterpreted type that's paired up
  -- all the way at the left of the produced (left-associated) product. The
  -- functions here are written in "CPS-style", in order to produce a long list
  -- instead of a tree structure.
  type GEltR t f
  geltR    :: TypeR t -> TypeR (GEltR t f)
  -- | This expands all sum types recursively; see the doc comment on 'TagR'.
  gtagsR   :: TagR t -> [TagR (GEltR t f)]
  gfromElt :: t -> f a -> GEltR t f
  gtoElt   :: GEltR t f -> (t, f a)
  --
  gundef   :: t -> GEltR t f
  guntag   :: TagR t -> TagR (GEltR t f)  -- ^ generate TagRundef for all leaves

instance GElt U1 where
  type GEltR t U1 = t
  geltR :: forall t. TypeR t -> TypeR (GEltR t U1)
geltR TypeR t
t       = TypeR t
TupR ScalarType (GEltR t U1)
t
  gtagsR :: forall t. TagR t -> [TagR (GEltR t U1)]
gtagsR TagR t
t      = [TagR t
TagR (GEltR t U1)
t]
  gfromElt :: forall t a. t -> U1 a -> GEltR t U1
gfromElt t
t U1 a
U1 = t
GEltR t U1
t
  gtoElt :: forall t a. GEltR t U1 -> (t, U1 a)
gtoElt GEltR t U1
t      = (t
GEltR t U1
t, U1 a
forall k (p :: k). U1 p
U1)
  gundef :: forall t. t -> GEltR t U1
gundef t
t      = t
GEltR t U1
t
  guntag :: forall t. TagR t -> TagR (GEltR t U1)
guntag TagR t
t      = TagR t
TagR (GEltR t U1)
t

instance GElt a => GElt (M1 i c a) where
  type GEltR t (M1 i c a) = GEltR t a
  geltR :: forall t. TypeR t -> TypeR (GEltR t (M1 i c a))
geltR             = forall (f :: * -> *) t. GElt f => TypeR t -> TypeR (GEltR t f)
geltR @a
  gtagsR :: forall t. TagR t -> [TagR (GEltR t (M1 i c a))]
gtagsR            = forall (f :: * -> *) t. GElt f => TagR t -> [TagR (GEltR t f)]
gtagsR @a
  gfromElt :: forall t a. t -> M1 i c a a -> GEltR t (M1 i c a)
gfromElt t
t (M1 a a
x) = t -> a a -> GEltR t a
forall t a. t -> a a -> GEltR t a
forall (f :: * -> *) t a. GElt f => t -> f a -> GEltR t f
gfromElt t
t a a
x
  gtoElt :: forall t a. GEltR t (M1 i c a) -> (t, M1 i c a a)
gtoElt         GEltR t (M1 i c a)
x  = let (t
t, a a
x1) = GEltR t a -> (t, a a)
forall t a. GEltR t a -> (t, a a)
forall (f :: * -> *) t a. GElt f => GEltR t f -> (t, f a)
gtoElt GEltR t a
GEltR t (M1 i c a)
x in (t
t, a a -> M1 i c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 a a
x1)
  gundef :: forall t. t -> GEltR t (M1 i c a)
gundef            = forall (f :: * -> *) t. GElt f => t -> GEltR t f
gundef @a
  guntag :: forall t. TagR t -> TagR (GEltR t (M1 i c a))
guntag            = forall (f :: * -> *) t. GElt f => TagR t -> TagR (GEltR t f)
guntag @a

instance Elt a => GElt (K1 i a) where
  type GEltR t (K1 i a) = (t, EltR a)
  geltR :: forall t. TypeR t -> TypeR (GEltR t (K1 i a))
geltR TypeR t
t           = TypeR t -> TupR ScalarType (EltR a) -> TupR ScalarType (t, EltR a)
forall (s :: * -> *) a1 b. TupR s a1 -> TupR s b -> TupR s (a1, b)
TupRpair TypeR t
t (forall a. Elt a => TypeR (EltR a)
eltR @a)
  gtagsR :: forall t. TagR t -> [TagR (GEltR t (K1 i a))]
gtagsR TagR t
t          = TagR t -> TagR (EltR a) -> TagR (t, EltR a)
forall a1 b. TagR a1 -> TagR b -> TagR (a1, b)
TagRpair TagR t
t (TagR (EltR a) -> TagR (t, EltR a))
-> [TagR (EltR a)] -> [TagR (t, EltR a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Elt a => [TagR (EltR a)]
tagsR @a
  gfromElt :: forall t a. t -> K1 i a a -> GEltR t (K1 i a)
gfromElt t
t (K1 a
x) = (t
t, a -> EltR a
forall a. Elt a => a -> EltR a
fromElt a
x)
  gtoElt :: forall t a. GEltR t (K1 i a) -> (t, K1 i a a)
gtoElt     (t
t, EltR a
x) = (t
t, a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (EltR a -> a
forall a. Elt a => EltR a -> a
toElt EltR a
x))
  gundef :: forall t. t -> GEltR t (K1 i a)
gundef t
t          = (t
t, TupR ScalarType (EltR a) -> EltR a
forall t. TypeR t -> t
undefElt (forall a. Elt a => TypeR (EltR a)
eltR @a))
  guntag :: forall t. TagR t -> TagR (GEltR t (K1 i a))
guntag TagR t
t          = TagR t -> TagR (EltR a) -> TagR (t, EltR a)
forall a1 b. TagR a1 -> TagR b -> TagR (a1, b)
TagRpair TagR t
t (TupR ScalarType (EltR a) -> TagR (EltR a)
forall t. TypeR t -> TagR t
untag (forall a. Elt a => TypeR (EltR a)
eltR @a))

instance (GElt a, GElt b) => GElt (a :*: b) where
  type GEltR t (a :*: b) = GEltR (GEltR t a) b
  geltR :: forall t. TypeR t -> TypeR (GEltR t (a :*: b))
geltR  = forall (f :: * -> *) t. GElt f => TypeR t -> TypeR (GEltR t f)
geltR @b (TypeR (GEltR t a) -> TypeR (GEltR (GEltR t a) b))
-> (TypeR t -> TypeR (GEltR t a))
-> TypeR t
-> TypeR (GEltR (GEltR t a) b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) t. GElt f => TypeR t -> TypeR (GEltR t f)
geltR @a
  gtagsR :: forall t. TagR t -> [TagR (GEltR t (a :*: b))]
gtagsR = (TagR (GEltR t a) -> [TagR (GEltR (GEltR t a) b)])
-> [TagR (GEltR t a)] -> [TagR (GEltR (GEltR t a) b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (f :: * -> *) t. GElt f => TagR t -> [TagR (GEltR t f)]
gtagsR @b) ([TagR (GEltR t a)] -> [TagR (GEltR (GEltR t a) b)])
-> (TagR t -> [TagR (GEltR t a)])
-> TagR t
-> [TagR (GEltR (GEltR t a) b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) t. GElt f => TagR t -> [TagR (GEltR t f)]
gtagsR @a
  gfromElt :: forall t a. t -> (:*:) a b a -> GEltR t (a :*: b)
gfromElt t
t (a a
a :*: b a
b) = GEltR t a -> b a -> GEltR (GEltR t a) b
forall t a. t -> b a -> GEltR t b
forall (f :: * -> *) t a. GElt f => t -> f a -> GEltR t f
gfromElt (t -> a a -> GEltR t a
forall t a. t -> a a -> GEltR t a
forall (f :: * -> *) t a. GElt f => t -> f a -> GEltR t f
gfromElt t
t a a
a) b a
b
  gtoElt :: forall t a. GEltR t (a :*: b) -> (t, (:*:) a b a)
gtoElt GEltR t (a :*: b)
t =
    let (GEltR t a
t1, b a
b) = GEltR (GEltR t a) b -> (GEltR t a, b a)
forall t a. GEltR t b -> (t, b a)
forall (f :: * -> *) t a. GElt f => GEltR t f -> (t, f a)
gtoElt GEltR t (a :*: b)
GEltR (GEltR t a) b
t
        (t
t2, a a
a) = GEltR t a -> (t, a a)
forall t a. GEltR t a -> (t, a a)
forall (f :: * -> *) t a. GElt f => GEltR t f -> (t, f a)
gtoElt GEltR t a
t1
    in
    (t
t2, a a
a a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b a
b)
  gundef :: forall t. t -> GEltR t (a :*: b)
gundef t
t = forall (f :: * -> *) t. GElt f => t -> GEltR t f
gundef @b (forall (f :: * -> *) t. GElt f => t -> GEltR t f
gundef @a t
t)
  guntag :: forall t. TagR t -> TagR (GEltR t (a :*: b))
guntag TagR t
t = forall (f :: * -> *) t. GElt f => TagR t -> TagR (GEltR t f)
guntag @b (forall (f :: * -> *) t. GElt f => TagR t -> TagR (GEltR t f)
guntag @a TagR t
t)

instance (GElt a, GElt b, GSumElt (a :+: b)) => GElt (a :+: b) where
  type GEltR t (a :+: b) = (TAG, GSumEltR t (a :+: b))
  geltR :: forall t. TypeR t -> TypeR (GEltR t (a :+: b))
geltR TypeR t
t      = TupR ScalarType TAG
-> TupR ScalarType (GSumEltR (GSumEltR t a) b)
-> TupR ScalarType (TAG, GSumEltR (GSumEltR t a) b)
forall (s :: * -> *) a1 b. TupR s a1 -> TupR s b -> TupR s (a1, b)
TupRpair (ScalarType TAG -> TupR ScalarType TAG
forall (s :: * -> *) a. s a -> TupR s a
TupRsingle ScalarType TAG
forall a. IsScalar a => ScalarType a
scalarType) (forall (f :: * -> *) t.
GSumElt f =>
TypeR t -> TypeR (GSumEltR t f)
gsumEltR @(a :+: b) TypeR t
t)
  gtagsR :: forall t. TagR t -> [TagR (GEltR t (a :+: b))]
gtagsR TagR t
t     = (TAG
 -> TagR (GSumEltR (GSumEltR t a) b)
 -> TagR (TAG, GSumEltR (GSumEltR t a) b))
-> (TAG, TagR (GSumEltR (GSumEltR t a) b))
-> TagR (TAG, GSumEltR (GSumEltR t a) b)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TAG
-> TagR (GSumEltR (GSumEltR t a) b)
-> TagR (TAG, GSumEltR (GSumEltR t a) b)
forall a1. TAG -> TagR a1 -> TagR (TAG, a1)
TagRtag ((TAG, TagR (GSumEltR (GSumEltR t a) b))
 -> TagR (TAG, GSumEltR (GSumEltR t a) b))
-> [(TAG, TagR (GSumEltR (GSumEltR t a) b))]
-> [TagR (TAG, GSumEltR (GSumEltR t a) b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State TAG [(TAG, TagR (GSumEltR (GSumEltR t a) b))]
-> TAG -> [(TAG, TagR (GSumEltR (GSumEltR t a) b))]
forall s a. State s a -> s -> a
LState.evalState (forall (f :: * -> *) t.
GSumElt f =>
TagR t -> State TAG [(TAG, TagR (GSumEltR t f))]
gsumTagsR @(a :+: b) TagR t
t) TAG
0
  gfromElt :: forall t a. t -> (:+:) a b a -> GEltR t (a :+: b)
gfromElt t
t (:+:) a b a
x = State TAG (TAG, GSumEltR (GSumEltR t a) b)
-> TAG -> (TAG, GSumEltR (GSumEltR t a) b)
forall s a. State s a -> s -> a
LState.evalState (t -> (:+:) a b a -> State TAG (TAG, GSumEltR t (a :+: b))
forall t a.
t -> (:+:) a b a -> State TAG (TAG, GSumEltR t (a :+: b))
forall (f :: * -> *) t a.
GSumElt f =>
t -> f a -> State TAG (TAG, GSumEltR t f)
gsumFromElt t
t (:+:) a b a
x) TAG
0
  gtoElt :: forall t a. GEltR t (a :+: b) -> (t, (:+:) a b a)
gtoElt (TAG
k,GSumEltR (GSumEltR t a) b
x) = let (t
t, Maybe ((:+:) a b a)
x') = State TAG (t, Maybe ((:+:) a b a))
-> TAG -> (t, Maybe ((:+:) a b a))
forall s a. State s a -> s -> a
LState.evalState (TAG -> GSumEltR t (a :+: b) -> State TAG (t, Maybe ((:+:) a b a))
forall t a.
TAG -> GSumEltR t (a :+: b) -> State TAG (t, Maybe ((:+:) a b a))
forall (f :: * -> *) t a.
GSumElt f =>
TAG -> GSumEltR t f -> State TAG (t, Maybe (f a))
gsumToElt TAG
k GSumEltR t (a :+: b)
GSumEltR (GSumEltR t a) b
x) TAG
0
                 in (t
t, (:+:) a b a -> Maybe ((:+:) a b a) -> (:+:) a b a
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> (:+:) a b a
forall a. HasCallStack => [Char] -> a
error [Char]
err) Maybe ((:+:) a b a)
x')
    where err :: [Char]
err = [Char]
"Elt: no sum type tag matched (k=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TAG -> [Char]
forall a. Show a => a -> [Char]
show TAG
k [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
  gundef :: forall t. t -> GEltR t (a :+: b)
gundef t
t     = (TAG
0xff, forall (f :: * -> *) t. GSumElt f => t -> GSumEltR t f
gsumUndef @(a :+: b) t
t)
  guntag :: forall t. TagR t -> TagR (GEltR t (a :+: b))
guntag TagR t
t     = TagR TAG
-> TagR (GSumEltR (GSumEltR t a) b)
-> TagR (TAG, GSumEltR (GSumEltR t a) b)
forall a1 b. TagR a1 -> TagR b -> TagR (a1, b)
TagRpair (ScalarType TAG -> TagR TAG
forall a. ScalarType a -> TagR a
TagRundef ScalarType TAG
forall a. IsScalar a => ScalarType a
scalarType) (forall (f :: * -> *) t. GSumElt f => TagR t -> TagR (GSumEltR t f)
gsumUntag @(a :+: b) TagR t
t)


class GSumElt f where
  type GSumEltR t f
  gsumEltR     :: TypeR t -> TypeR (GSumEltR t f)
  -- | The state monad here is a /lazy/ state monad. We need this for 'gsumToElt' of '(:+:)'.
  gsumTagsR    :: TagR t -> LState.State TAG [(TAG, TagR (GSumEltR t f))]
  gsumFromElt  :: t -> f a -> LState.State TAG (TAG, GSumEltR t f)
  gsumCountTags :: Proxy f -> LState.State TAG ()
  gsumToElt    :: TAG -> GSumEltR t f -> LState.State TAG (t, Maybe (f a))
  gsumUndef    :: t -> GSumEltR t f
  gsumUntag    :: TagR t -> TagR (GSumEltR t f)

genTag :: LState.State TAG TAG
genTag :: State TAG TAG
genTag = (TAG -> (TAG, TAG)) -> State TAG TAG
forall a. (TAG -> (a, TAG)) -> StateT TAG Identity a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
LState.state (\TAG
s -> (TAG
s, TAG
s TAG -> TAG -> TAG
forall a. Num a => a -> a -> a
+ TAG
1))

instance GSumElt U1 where
  type GSumEltR t U1 = t
  gsumEltR :: forall t. TypeR t -> TypeR (GSumEltR t U1)
gsumEltR TypeR t
t         = TypeR t
TupR ScalarType (GSumEltR t U1)
t
  gsumTagsR :: forall t. TagR t -> State TAG [(TAG, TagR (GSumEltR t U1))]
gsumTagsR TagR t
t        = do TAG
n <- State TAG TAG
genTag; [(TAG, TagR t)] -> StateT TAG Identity [(TAG, TagR t)]
forall a. a -> StateT TAG Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(TAG
n, TagR t
t)]
  gsumFromElt :: forall t a. t -> U1 a -> State TAG (TAG, GSumEltR t U1)
gsumFromElt t
t U1 a
U1   = do TAG
n <- State TAG TAG
genTag; (TAG, t) -> StateT TAG Identity (TAG, t)
forall a. a -> StateT TAG Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TAG
n, t
t)
  gsumCountTags :: Proxy U1 -> State TAG ()
gsumCountTags Proxy U1
_    = () () -> State TAG TAG -> State TAG ()
forall a b. a -> StateT TAG Identity b -> StateT TAG Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ State TAG TAG
genTag
  gsumToElt :: forall t a. TAG -> GSumEltR t U1 -> State TAG (t, Maybe (U1 a))
gsumToElt TAG
k GSumEltR t U1
t      = do TAG
n <- State TAG TAG
genTag
                          (t, Maybe (U1 a)) -> State TAG (t, Maybe (U1 a))
forall a. a -> StateT TAG Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t
GSumEltR t U1
t, if TAG
n TAG -> TAG -> Bool
forall a. Eq a => a -> a -> Bool
== TAG
k then U1 a -> Maybe (U1 a)
forall a. a -> Maybe a
Just U1 a
forall k (p :: k). U1 p
U1 else Maybe (U1 a)
forall a. Maybe a
Nothing)
  gsumUndef :: forall t. t -> GSumEltR t U1
gsumUndef t
t        = t
GSumEltR t U1
t
  gsumUntag :: forall t. TagR t -> TagR (GSumEltR t U1)
gsumUntag TagR t
t        = TagR t
TagR (GSumEltR t U1)
t

instance GSumElt a => GSumElt (M1 i c a) where
  type GSumEltR t (M1 i c a) = GSumEltR t a
  gsumEltR :: forall t. TypeR t -> TypeR (GSumEltR t (M1 i c a))
gsumEltR               = forall (f :: * -> *) t.
GSumElt f =>
TypeR t -> TypeR (GSumEltR t f)
gsumEltR @a
  gsumTagsR :: forall t. TagR t -> State TAG [(TAG, TagR (GSumEltR t (M1 i c a)))]
gsumTagsR              = forall (f :: * -> *) t.
GSumElt f =>
TagR t -> State TAG [(TAG, TagR (GSumEltR t f))]
gsumTagsR @a
  gsumFromElt :: forall t a.
t -> M1 i c a a -> State TAG (TAG, GSumEltR t (M1 i c a))
gsumFromElt t
t (M1 a a
x)   = t -> a a -> State TAG (TAG, GSumEltR t a)
forall t a. t -> a a -> State TAG (TAG, GSumEltR t a)
forall (f :: * -> *) t a.
GSumElt f =>
t -> f a -> State TAG (TAG, GSumEltR t f)
gsumFromElt t
t a a
x
  gsumCountTags :: Proxy (M1 i c a) -> State TAG ()
gsumCountTags Proxy (M1 i c a)
_        = Proxy a -> State TAG ()
forall (f :: * -> *). GSumElt f => Proxy f -> State TAG ()
gsumCountTags (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @a)
  gsumToElt :: forall t a.
TAG -> GSumEltR t (M1 i c a) -> State TAG (t, Maybe (M1 i c a a))
gsumToElt TAG
k GSumEltR t (M1 i c a)
x          = (\(t
t, Maybe (a a)
x') -> (t
t, (a a -> M1 i c a a) -> Maybe (a a) -> Maybe (M1 i c a a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a a -> M1 i c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 Maybe (a a)
x')) ((t, Maybe (a a)) -> (t, Maybe (M1 i c a a)))
-> StateT TAG Identity (t, Maybe (a a))
-> StateT TAG Identity (t, Maybe (M1 i c a a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TAG -> GSumEltR t a -> StateT TAG Identity (t, Maybe (a a))
forall t a. TAG -> GSumEltR t a -> State TAG (t, Maybe (a a))
forall (f :: * -> *) t a.
GSumElt f =>
TAG -> GSumEltR t f -> State TAG (t, Maybe (f a))
gsumToElt TAG
k GSumEltR t a
GSumEltR t (M1 i c a)
x
  gsumUndef :: forall t. t -> GSumEltR t (M1 i c a)
gsumUndef              = forall (f :: * -> *) t. GSumElt f => t -> GSumEltR t f
gsumUndef @a
  gsumUntag :: forall t. TagR t -> TagR (GSumEltR t (M1 i c a))
gsumUntag              = forall (f :: * -> *) t. GSumElt f => TagR t -> TagR (GSumEltR t f)
gsumUntag @a

instance Elt a => GSumElt (K1 i a) where
  type GSumEltR t (K1 i a) = (t, EltR a)
  gsumEltR :: forall t. TypeR t -> TypeR (GSumEltR t (K1 i a))
gsumEltR TypeR t
t             = TypeR t -> TupR ScalarType (EltR a) -> TupR ScalarType (t, EltR a)
forall (s :: * -> *) a1 b. TupR s a1 -> TupR s b -> TupR s (a1, b)
TupRpair TypeR t
t (forall a. Elt a => TypeR (EltR a)
eltR @a)
  gsumTagsR :: forall t. TagR t -> State TAG [(TAG, TagR (GSumEltR t (K1 i a)))]
gsumTagsR TagR t
t            = do TAG
n <- State TAG TAG
genTag; [(TAG, TagR (t, EltR a))]
-> StateT TAG Identity [(TAG, TagR (t, EltR a))]
forall a. a -> StateT TAG Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TAG
n,) (TagR (t, EltR a) -> (TAG, TagR (t, EltR a)))
-> (TagR (EltR a) -> TagR (t, EltR a))
-> TagR (EltR a)
-> (TAG, TagR (t, EltR a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagR t -> TagR (EltR a) -> TagR (t, EltR a)
forall a1 b. TagR a1 -> TagR b -> TagR (a1, b)
TagRpair TagR t
t (TagR (EltR a) -> (TAG, TagR (t, EltR a)))
-> [TagR (EltR a)] -> [(TAG, TagR (t, EltR a))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Elt a => [TagR (EltR a)]
tagsR @a)
  gsumFromElt :: forall t a. t -> K1 i a a -> State TAG (TAG, GSumEltR t (K1 i a))
gsumFromElt t
t (K1 a
x)   = do TAG
n <- State TAG TAG
genTag; (TAG, (t, EltR a)) -> StateT TAG Identity (TAG, (t, EltR a))
forall a. a -> StateT TAG Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TAG
n, (t
t, a -> EltR a
forall a. Elt a => a -> EltR a
fromElt a
x))
  gsumCountTags :: Proxy (K1 i a) -> State TAG ()
gsumCountTags Proxy (K1 i a)
_        = () () -> State TAG TAG -> State TAG ()
forall a b. a -> StateT TAG Identity b -> StateT TAG Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ State TAG TAG
genTag
  gsumToElt :: forall t a.
TAG -> GSumEltR t (K1 i a) -> State TAG (t, Maybe (K1 i a a))
gsumToElt TAG
k ~(t
t, EltR a
x)    = do TAG
n <- State TAG TAG
genTag
                              (t, Maybe (K1 i a a)) -> State TAG (t, Maybe (K1 i a a))
forall a. a -> StateT TAG Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t
t, if TAG
n TAG -> TAG -> Bool
forall a. Eq a => a -> a -> Bool
== TAG
k then K1 i a a -> Maybe (K1 i a a)
forall a. a -> Maybe a
Just (a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (EltR a -> a
forall a. Elt a => EltR a -> a
toElt EltR a
x)) else Maybe (K1 i a a)
forall a. Maybe a
Nothing)
  gsumUndef :: forall t. t -> GSumEltR t (K1 i a)
gsumUndef t
t            = (t
t, TupR ScalarType (EltR a) -> EltR a
forall t. TypeR t -> t
undefElt (forall a. Elt a => TypeR (EltR a)
eltR @a))
  gsumUntag :: forall t. TagR t -> TagR (GSumEltR t (K1 i a))
gsumUntag TagR t
t            = TagR t -> TagR (EltR a) -> TagR (t, EltR a)
forall a1 b. TagR a1 -> TagR b -> TagR (a1, b)
TagRpair TagR t
t (TupR ScalarType (EltR a) -> TagR (EltR a)
forall t. TypeR t -> TagR t
untag (forall a. Elt a => TypeR (EltR a)
eltR @a))

instance (GElt a, GElt b) => GSumElt (a :*: b) where
  type GSumEltR t (a :*: b) = GEltR t (a :*: b)
  gsumEltR :: forall t. TypeR t -> TypeR (GSumEltR t (a :*: b))
gsumEltR                  = forall (f :: * -> *) t. GElt f => TypeR t -> TypeR (GEltR t f)
geltR @(a :*: b)
  gsumTagsR :: forall t. TagR t -> State TAG [(TAG, TagR (GSumEltR t (a :*: b)))]
gsumTagsR TagR t
t               = do TAG
n <- State TAG TAG
genTag; [(TAG, TagR (GEltR (GEltR t a) b))]
-> StateT TAG Identity [(TAG, TagR (GEltR (GEltR t a) b))]
forall a. a -> StateT TAG Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TAG
n,) (TagR (GEltR (GEltR t a) b) -> (TAG, TagR (GEltR (GEltR t a) b)))
-> [TagR (GEltR (GEltR t a) b)]
-> [(TAG, TagR (GEltR (GEltR t a) b))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) t. GElt f => TagR t -> [TagR (GEltR t f)]
gtagsR @(a :*: b) TagR t
t)
  gsumFromElt :: forall t a.
t -> (:*:) a b a -> State TAG (TAG, GSumEltR t (a :*: b))
gsumFromElt t
t (a a
a :*: b a
b)   = do TAG
n <- State TAG TAG
genTag; (TAG, GEltR (GEltR t a) b)
-> StateT TAG Identity (TAG, GEltR (GEltR t a) b)
forall a. a -> StateT TAG Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TAG
n, t -> (:*:) a b a -> GEltR t (a :*: b)
forall t a. t -> (:*:) a b a -> GEltR t (a :*: b)
forall (f :: * -> *) t a. GElt f => t -> f a -> GEltR t f
gfromElt t
t (a a
a a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b a
b))
  gsumCountTags :: Proxy (a :*: b) -> State TAG ()
gsumCountTags Proxy (a :*: b)
_           = () () -> State TAG TAG -> State TAG ()
forall a b. a -> StateT TAG Identity b -> StateT TAG Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ State TAG TAG
genTag
  gsumToElt :: forall t a.
TAG -> GSumEltR t (a :*: b) -> State TAG (t, Maybe ((:*:) a b a))
gsumToElt TAG
k GSumEltR t (a :*: b)
t0            = do TAG
n <- State TAG TAG
genTag
                                 -- Note that gtoElt produces x lazily, so this
                                 -- does not read any spurious undefs.
                                 let (t
t, (:*:) a b a
x) = GEltR t (a :*: b) -> (t, (:*:) a b a)
forall t a. GEltR t (a :*: b) -> (t, (:*:) a b a)
forall (f :: * -> *) t a. GElt f => GEltR t f -> (t, f a)
gtoElt GSumEltR t (a :*: b)
GEltR t (a :*: b)
t0
                                 (t, Maybe ((:*:) a b a)) -> State TAG (t, Maybe ((:*:) a b a))
forall a. a -> StateT TAG Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t
t, if TAG
n TAG -> TAG -> Bool
forall a. Eq a => a -> a -> Bool
== TAG
k then (:*:) a b a -> Maybe ((:*:) a b a)
forall a. a -> Maybe a
Just (:*:) a b a
x else Maybe ((:*:) a b a)
forall a. Maybe a
Nothing)
  gsumUndef :: forall t. t -> GSumEltR t (a :*: b)
gsumUndef       = forall (f :: * -> *) t. GElt f => t -> GEltR t f
gundef @(a :*: b)
  gsumUntag :: forall t. TagR t -> TagR (GSumEltR t (a :*: b))
gsumUntag       = forall (f :: * -> *) t. GElt f => TagR t -> TagR (GEltR t f)
guntag @(a :*: b)

instance (GSumElt a, GSumElt b) => GSumElt (a :+: b) where
  type GSumEltR t (a :+: b) = GSumEltR (GSumEltR t a) b
  gsumEltR :: forall t. TypeR t -> TypeR (GSumEltR t (a :+: b))
gsumEltR = forall (f :: * -> *) t.
GSumElt f =>
TypeR t -> TypeR (GSumEltR t f)
gsumEltR @b (TypeR (GSumEltR t a) -> TypeR (GSumEltR (GSumEltR t a) b))
-> (TypeR t -> TypeR (GSumEltR t a))
-> TypeR t
-> TypeR (GSumEltR (GSumEltR t a) b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) t.
GSumElt f =>
TypeR t -> TypeR (GSumEltR t f)
gsumEltR @a

  gsumTagsR :: forall t. TagR t -> State TAG [(TAG, TagR (GSumEltR t (a :+: b)))]
gsumTagsR TagR t
t = do
    [(TAG, TagR (GSumEltR t a))]
a <- forall (f :: * -> *) t.
GSumElt f =>
TagR t -> State TAG [(TAG, TagR (GSumEltR t f))]
gsumTagsR @a TagR t
t
    -- join b (filled with undefs) to the TagR's for 'a':
    let a' :: [(TAG, TagR (GSumEltR (GSumEltR t a) b))]
a' = ((TAG, TagR (GSumEltR t a))
 -> (TAG, TagR (GSumEltR (GSumEltR t a) b)))
-> [(TAG, TagR (GSumEltR t a))]
-> [(TAG, TagR (GSumEltR (GSumEltR t a) b))]
forall a b. (a -> b) -> [a] -> [b]
map (\(TAG
tag, TagR (GSumEltR t a)
tagrA) -> (TAG
tag, forall (f :: * -> *) t. GSumElt f => TagR t -> TagR (GSumEltR t f)
gsumUntag @b TagR (GSumEltR t a)
tagrA)) [(TAG, TagR (GSumEltR t a))]
a
    [(TAG, TagR (GSumEltR (GSumEltR t a) b))]
b <- forall (f :: * -> *) t.
GSumElt f =>
TagR t -> State TAG [(TAG, TagR (GSumEltR t f))]
gsumTagsR @b (forall (f :: * -> *) t. GSumElt f => TagR t -> TagR (GSumEltR t f)
gsumUntag @a TagR t
t)
    [(TAG, TagR (GSumEltR (GSumEltR t a) b))]
-> StateT TAG Identity [(TAG, TagR (GSumEltR (GSumEltR t a) b))]
forall a. a -> StateT TAG Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(TAG, TagR (GSumEltR (GSumEltR t a) b))]
a' [(TAG, TagR (GSumEltR (GSumEltR t a) b))]
-> [(TAG, TagR (GSumEltR (GSumEltR t a) b))]
-> [(TAG, TagR (GSumEltR (GSumEltR t a) b))]
forall a. [a] -> [a] -> [a]
++ [(TAG, TagR (GSumEltR (GSumEltR t a) b))]
b)

  gsumFromElt :: forall t a.
t -> (:+:) a b a -> State TAG (TAG, GSumEltR t (a :+: b))
gsumFromElt t
t (L1 a a
a) = do
    (TAG
n, GSumEltR t a
reprA) <- t -> a a -> StateT TAG Identity (TAG, GSumEltR t a)
forall t a. t -> a a -> State TAG (TAG, GSumEltR t a)
forall (f :: * -> *) t a.
GSumElt f =>
t -> f a -> State TAG (TAG, GSumEltR t f)
gsumFromElt t
t a a
a
    (TAG, GSumEltR (GSumEltR t a) b)
-> StateT TAG Identity (TAG, GSumEltR (GSumEltR t a) b)
forall a. a -> StateT TAG Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TAG
n, forall (f :: * -> *) t. GSumElt f => t -> GSumEltR t f
gsumUndef @b GSumEltR t a
reprA)  -- join undef-filled b to this rep of A
  gsumFromElt t
t (R1 b a
b) = do
    Proxy a -> State TAG ()
forall (f :: * -> *). GSumElt f => Proxy f -> State TAG ()
gsumCountTags (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @a)  -- skip the tags in the left alternatives
    GSumEltR t a
-> b a -> StateT TAG Identity (TAG, GSumEltR (GSumEltR t a) b)
forall t a. t -> b a -> State TAG (TAG, GSumEltR t b)
forall (f :: * -> *) t a.
GSumElt f =>
t -> f a -> State TAG (TAG, GSumEltR t f)
gsumFromElt (forall (f :: * -> *) t. GSumElt f => t -> GSumEltR t f
gsumUndef @a t
t) b a
b

  gsumCountTags :: Proxy (a :+: b) -> State TAG ()
gsumCountTags Proxy (a :+: b)
_ = Proxy a -> State TAG ()
forall (f :: * -> *). GSumElt f => Proxy f -> State TAG ()
gsumCountTags (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @a) State TAG () -> State TAG () -> State TAG ()
forall a b.
StateT TAG Identity a
-> StateT TAG Identity b -> StateT TAG Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Proxy b -> State TAG ()
forall (f :: * -> *). GSumElt f => Proxy f -> State TAG ()
gsumCountTags (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @b)

  gsumToElt :: forall t a.
TAG -> GSumEltR t (a :+: b) -> State TAG (t, Maybe ((:+:) a b a))
gsumToElt TAG
k GSumEltR t (a :+: b)
t0 = do
    -- The starting tag for the traversal of 'b' depends on the number of tags
    -- generated when traversing 'a'. However, in t0, the data for 'b' is
    -- on the outside, meaning that we can only get the initial 't' for the 'a'
    -- traversal by traversing 'b' first. We solve this circular dependency by
    -- observing that gsumToElt can count the tags before it needs its 't'
    -- argument, so we can tie a knot.
    -- We could also escape the State monad here with evalState, and explicitly
    -- gsumCountTags first, then traverse 'b', and finally traverse 'a'. But
    -- that would be ugly.
    (GSumEltR t a
_t1, t
t2, Maybe (b a)
mres1, Maybe (a a)
mres2) <- ((GSumEltR t a, t, Maybe (b a), Maybe (a a))
 -> StateT TAG Identity (GSumEltR t a, t, Maybe (b a), Maybe (a a)))
-> StateT TAG Identity (GSumEltR t a, t, Maybe (b a), Maybe (a a))
forall a. (a -> StateT TAG Identity a) -> StateT TAG Identity a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (((GSumEltR t a, t, Maybe (b a), Maybe (a a))
  -> StateT TAG Identity (GSumEltR t a, t, Maybe (b a), Maybe (a a)))
 -> StateT TAG Identity (GSumEltR t a, t, Maybe (b a), Maybe (a a)))
-> ((GSumEltR t a, t, Maybe (b a), Maybe (a a))
    -> StateT TAG Identity (GSumEltR t a, t, Maybe (b a), Maybe (a a)))
-> StateT TAG Identity (GSumEltR t a, t, Maybe (b a), Maybe (a a))
forall a b. (a -> b) -> a -> b
$ \ ~(GSumEltR t a
t1, t
_t2, Maybe (b a)
_mres1, Maybe (a a)
_mres2) ->do
      (t
t2', Maybe (a a)
mres2) <- forall (f :: * -> *) t a.
GSumElt f =>
TAG -> GSumEltR t f -> State TAG (t, Maybe (f a))
gsumToElt @a TAG
k GSumEltR t a
t1
      (GSumEltR t a
t1', Maybe (b a)
mres1) <- forall (f :: * -> *) t a.
GSumElt f =>
TAG -> GSumEltR t f -> State TAG (t, Maybe (f a))
gsumToElt @b TAG
k GSumEltR t (a :+: b)
GSumEltR (GSumEltR t a) b
t0
      (GSumEltR t a, t, Maybe (b a), Maybe (a a))
-> StateT TAG Identity (GSumEltR t a, t, Maybe (b a), Maybe (a a))
forall a. a -> StateT TAG Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GSumEltR t a
t1', t
t2', Maybe (b a)
mres1, Maybe (a a)
mres2)
    (t, Maybe ((:+:) a b a)) -> State TAG (t, Maybe ((:+:) a b a))
forall a. a -> StateT TAG Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t
t2, (b a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (b a -> (:+:) a b a) -> Maybe (b a) -> Maybe ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (b a)
mres1) Maybe ((:+:) a b a) -> Maybe ((:+:) a b a) -> Maybe ((:+:) a b a)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (a a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (a a -> (:+:) a b a) -> Maybe (a a) -> Maybe ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (a a)
mres2))

  gsumUndef :: forall t. t -> GSumEltR t (a :+: b)
gsumUndef t
t = forall (f :: * -> *) t. GSumElt f => t -> GSumEltR t f
gsumUndef @b (forall (f :: * -> *) t. GSumElt f => t -> GSumEltR t f
gsumUndef @a t
t)
  gsumUntag :: forall t. TagR t -> TagR (GSumEltR t (a :+: b))
gsumUntag TagR t
t = forall (f :: * -> *) t. GSumElt f => TagR t -> TagR (GSumEltR t f)
gsumUntag @b (forall (f :: * -> *) t. GSumElt f => TagR t -> TagR (GSumEltR t f)
gsumUntag @a TagR t
t)


untag :: TypeR t -> TagR t
untag :: forall t. TypeR t -> TagR t
untag TupR ScalarType t
TupRunit         = TagR t
TagR ()
TagRunit
untag (TupRsingle ScalarType t
t)   = ScalarType t -> TagR t
forall a. ScalarType a -> TagR a
TagRundef ScalarType t
t
untag (TupRpair TupR ScalarType a1
ta TupR ScalarType b
tb) = TagR a1 -> TagR b -> TagR (a1, b)
forall a1 b. TagR a1 -> TagR b -> TagR (a1, b)
TagRpair (TupR ScalarType a1 -> TagR a1
forall t. TypeR t -> TagR t
untag TupR ScalarType a1
ta) (TupR ScalarType b -> TagR b
forall t. TypeR t -> TagR t
untag TupR ScalarType b
tb)


-- Note: [Deriving Elt]
--
-- We can't use the cunning generalised newtype deriving mechanism, because
-- the generated 'eltR' function does not type check. For example, it will
-- generate the following implementation for 'CShort':
--
-- > eltR
-- >   = coerce
-- >       @(TypeR (EltR Int16))
-- >       @(TypeR (EltR CShort))
-- >       (eltR :: TypeR (EltR CShort))
--
-- Which yields the error "couldn't match type 'EltR a0' with 'Int16'".
-- Since this function returns a type family type, the type signature on the
-- result is not enough to fix the type 'a'. Instead, we require the use of
-- (visible) type applications:
--
-- > eltR
-- >   = coerce
-- >       @(TypeR (EltR Int16))
-- >       @(TypeR (EltR CShort))
-- >       (eltR @(EltR CShort))
--
-- Note that this does not affect deriving instances via 'Generic'
--
-- Instances for basic types are generated at the end of this module.
--

instance Elt ()
instance Elt Bool
instance Elt Ordering
instance Elt a => Elt (Maybe a)
instance (Elt a, Elt b) => Elt (Either a b)

instance Elt Char where
  type EltR Char = Word32
  eltR :: TypeR (EltR Char)
eltR    = ScalarType Word32 -> TupR ScalarType Word32
forall (s :: * -> *) a. s a -> TupR s a
TupRsingle ScalarType Word32
forall a. IsScalar a => ScalarType a
scalarType
  tagsR :: [TagR (EltR Char)]
tagsR   = [ScalarType Word32 -> TagR Word32
forall a. ScalarType a -> TagR a
TagRsingle ScalarType Word32
forall a. IsScalar a => ScalarType a
scalarType]
  toElt :: EltR Char -> Char
toElt   = Int -> Char
chr (Int -> Char) -> (Word32 -> Int) -> Word32 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  fromElt :: Char -> EltR Char
fromElt = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> (Char -> Int) -> Char -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord

runQ $ do
  let
      -- XXX: we might want to do the digItOut trick used by FromIntegral?
      --
      integralTypes :: [Name]
      integralTypes =
        [ ''Int
        , ''Int8
        , ''Int16
        , ''Int32
        , ''Int64
        , ''Word
        , ''Word8
        , ''Word16
        , ''Word32
        , ''Word64
        ]

      floatingTypes :: [Name]
      floatingTypes =
        [ ''Half
        , ''Float
        , ''Double
        ]

      newtypes :: [Name]
      newtypes =
        [ ''CShort
        , ''CUShort
        , ''CInt
        , ''CUInt
        , ''CLong
        , ''CULong
        , ''CLLong
        , ''CULLong
        , ''CFloat
        , ''CDouble
        , ''CChar
        , ''CSChar
        , ''CUChar
        ]

      mkSimple :: Name -> Q [Dec]
      mkSimple name =
        let t = conT name
        in
        [d| instance Elt $t where
              type EltR $t = $t
              eltR    = TupRsingle scalarType
              tagsR   = [TagRsingle scalarType]
              fromElt = id
              toElt   = id
          |]

      mkTuple :: Int -> Q Dec
      mkTuple n =
        let
            xs  = [ mkName ('x' : show i) | i <- [0 .. n-1] ]
            ts  = map varT xs
            res = tupT ts
            ctx = mapM (appT [t| Elt |]) ts
        in
        instanceD ctx [t| Elt $res |] []

      -- mkVecElt :: Name -> Integer -> Q [Dec]
      -- mkVecElt name n =
      --   let t = conT name
      --       v = [t| Vec $(litT (numTyLit n)) $t |]
      --    in
      --    [d| instance Elt $v where
      --          type EltR $v = $v
      --          eltR    = TupRsingle scalarType
      --          fromElt = id
      --          toElt   = id
      --      |]

      -- ghci> $( stringE . show =<< reify ''CFloat )
      -- TyConI (NewtypeD [] Foreign.C.Types.CFloat [] Nothing (NormalC Foreign.C.Types.CFloat [(Bang NoSourceUnpackedness NoSourceStrictness,ConT GHC.Types.Float)]) [])
      --
      mkNewtype :: Name -> Q [Dec]
      mkNewtype name = do
        r    <- reify name
        base <- case r of
                  TyConI (NewtypeD _ _ _ _ (NormalC _ [(_, ConT b)]) _) -> return b
                  _                                                     -> error "unexpected case generating newtype Elt instance"
        --
        [d| instance Elt $(conT name) where
              type EltR $(conT name) = $(conT base)
              eltR = TupRsingle scalarType
              tagsR = [TagRsingle scalarType]
              fromElt $(conP (mkName (nameBase name)) [varP (mkName "x")]) = x
              toElt = $(conE (mkName (nameBase name)))
          |]
  --
  ss <- mapM mkSimple (integralTypes ++ floatingTypes)
  ns <- mapM mkNewtype newtypes
  ts <- mapM mkTuple [2..16]
  -- vs <- sequence [ mkVecElt t n | t <- integralTypes ++ floatingTypes, n <- [2,3,4,8,16] ]
  return (concat ss ++ concat ns ++ ts)