{-# 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 Data.Bits
import Data.Char
import Data.Kind
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 -> GEltR () (Rep a))
-> (a -> Rep a Any) -> a -> GEltR () (Rep 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)
-> (GEltR () (Rep a) -> Rep a Any) -> GEltR () (Rep 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)
-> (GEltR () (Rep a) -> ((), Rep a Any))
-> GEltR () (Rep 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) @()


class GElt f where
  type GEltR t f
  geltR    :: TypeR t -> TypeR (GEltR t f)
  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)

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
<$> forall (f :: * -> *) t.
GSumElt f =>
TAG -> TagR t -> [(TAG, TagR (GSumEltR t f))]
gsumTagsR @(a :+: b) TAG
0 TagR t
t
  gfromElt :: forall t a. t -> (:+:) a b a -> GEltR t (a :+: b)
gfromElt     = TAG -> t -> (:+:) a b a -> (TAG, GSumEltR t (a :+: b))
forall t a. TAG -> t -> (:+:) a b a -> (TAG, GSumEltR t (a :+: b))
forall (f :: * -> *) t a.
GSumElt f =>
TAG -> t -> f a -> (TAG, GSumEltR t f)
gsumFromElt TAG
0
  gtoElt :: forall t a. GEltR t (a :+: b) -> (t, (:+:) a b a)
gtoElt (TAG
k,GSumEltR (GSumEltR t a) b
x) = TAG -> GSumEltR t (a :+: b) -> (t, (:+:) a b a)
forall t a. TAG -> GSumEltR t (a :+: b) -> (t, (:+:) a b a)
forall (f :: * -> *) t a.
GSumElt f =>
TAG -> GSumEltR t f -> (t, f a)
gsumToElt TAG
k GSumEltR t (a :+: b)
GSumEltR (GSumEltR t a) b
x
  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)
  gsumTagsR    :: TAG -> TagR t -> [(TAG, TagR (GSumEltR t f))]
  gsumFromElt  :: TAG -> t -> f a -> (TAG, GSumEltR t f)
  gsumToElt    :: TAG -> GSumEltR t f -> (t, f a)
  gsumUndef    :: t -> GSumEltR t f
  gsumUntag    :: TagR t -> TagR (GSumEltR t f)

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. TAG -> TagR t -> [(TAG, TagR (GSumEltR t U1))]
gsumTagsR TAG
n TagR t
t      = [(TAG
n, TagR t
TagR (GSumEltR t U1)
t)]
  gsumFromElt :: forall t a. TAG -> t -> U1 a -> (TAG, GSumEltR t U1)
gsumFromElt TAG
n t
t U1 a
U1 = (TAG
n, t
GSumEltR t U1
t)
  gsumToElt :: forall t a. TAG -> GSumEltR t U1 -> (t, U1 a)
gsumToElt TAG
_ GSumEltR t U1
t      = (t
GSumEltR t U1
t, U1 a
forall k (p :: k). U1 p
U1)
  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. TAG -> TagR t -> [(TAG, TagR (GSumEltR t (M1 i c a)))]
gsumTagsR              = forall (f :: * -> *) t.
GSumElt f =>
TAG -> TagR t -> [(TAG, TagR (GSumEltR t f))]
gsumTagsR @a
  gsumFromElt :: forall t a. TAG -> t -> M1 i c a a -> (TAG, GSumEltR t (M1 i c a))
gsumFromElt TAG
n t
t (M1 a a
x) = TAG -> t -> a a -> (TAG, GSumEltR t a)
forall t a. TAG -> t -> a a -> (TAG, GSumEltR t a)
forall (f :: * -> *) t a.
GSumElt f =>
TAG -> t -> f a -> (TAG, GSumEltR t f)
gsumFromElt TAG
n t
t a a
x
  gsumToElt :: forall t a. TAG -> GSumEltR t (M1 i c a) -> (t, M1 i c a a)
gsumToElt TAG
k GSumEltR t (M1 i c a)
x          = let (t
t, a a
x') = TAG -> GSumEltR t a -> (t, a a)
forall t a. TAG -> GSumEltR t a -> (t, a a)
forall (f :: * -> *) t a.
GSumElt f =>
TAG -> GSumEltR t f -> (t, f a)
gsumToElt TAG
k GSumEltR t a
GSumEltR 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
x')
  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
  gsumUndef :: forall t. t -> GSumEltR t (M1 i c a)
gsumUndef              = forall (f :: * -> *) t. GSumElt f => t -> GSumEltR t f
gsumUndef @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. TAG -> TagR t -> [(TAG, TagR (GSumEltR t (K1 i a)))]
gsumTagsR TAG
n TagR t
t          = (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. TAG -> t -> K1 i a a -> (TAG, GSumEltR t (K1 i a))
gsumFromElt TAG
n t
t (K1 a
x) = (TAG
n, (t
t, a -> EltR a
forall a. Elt a => a -> EltR a
fromElt a
x))
  gsumToElt :: forall t a. TAG -> GSumEltR t (K1 i a) -> (t, K1 i a a)
gsumToElt TAG
_ (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))
  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))
  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))

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. TAG -> TagR t -> [(TAG, TagR (GSumEltR t (a :*: b)))]
gsumTagsR TAG
n TagR t
t             = (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. TAG -> t -> (:*:) a b a -> (TAG, GSumEltR t (a :*: b))
gsumFromElt TAG
n t
t (a a
a :*: b a
b) = (TAG
n, 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)
  gsumToElt :: forall t a. TAG -> GSumEltR t (a :*: b) -> (t, (:*:) a b a)
gsumToElt TAG
_ GSumEltR t (a :*: b)
t0 =
    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 GSumEltR t (a :*: b)
GEltR (GEltR t a) b
t0
        (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)
  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

  gsumFromElt :: forall t a. TAG -> t -> (:+:) a b a -> (TAG, GSumEltR t (a :+: b))
gsumFromElt TAG
n t
t (L1 a a
a) = let (TAG
m,GSumEltR t a
r) = TAG -> t -> a a -> (TAG, GSumEltR t a)
forall t a. TAG -> t -> a a -> (TAG, GSumEltR t a)
forall (f :: * -> *) t a.
GSumElt f =>
TAG -> t -> f a -> (TAG, GSumEltR t f)
gsumFromElt TAG
n t
t a a
a
                            in (TAG -> Int -> TAG
forall a. Bits a => a -> Int -> a
shiftL TAG
m Int
1, forall (f :: * -> *) t. GSumElt f => t -> GSumEltR t f
gsumUndef @b GSumEltR t a
r)
  gsumFromElt TAG
n t
t (R1 b a
b) = let (TAG
m,GSumEltR (GSumEltR t a) b
r) = TAG -> GSumEltR t a -> b a -> (TAG, GSumEltR (GSumEltR t a) b)
forall t a. TAG -> t -> b a -> (TAG, GSumEltR t b)
forall (f :: * -> *) t a.
GSumElt f =>
TAG -> t -> f a -> (TAG, GSumEltR t f)
gsumFromElt TAG
n (forall (f :: * -> *) t. GSumElt f => t -> GSumEltR t f
gsumUndef @a t
t) b a
b
                            in (TAG -> Int -> TAG
forall a. Bits a => a -> Int -> a
setBit (TAG
m TAG -> Int -> TAG
forall a. Bits a => a -> Int -> a
`shiftL` Int
1) Int
0, GSumEltR t (a :+: b)
GSumEltR (GSumEltR t a) b
r)

  gsumToElt :: forall t a. TAG -> GSumEltR t (a :+: b) -> (t, (:+:) a b a)
gsumToElt TAG
k GSumEltR t (a :+: b)
t0 =
    let (GSumEltR t a
t1, b a
b) = TAG -> GSumEltR (GSumEltR t a) b -> (GSumEltR t a, b a)
forall t a. TAG -> GSumEltR t b -> (t, b a)
forall (f :: * -> *) t a.
GSumElt f =>
TAG -> GSumEltR t f -> (t, f a)
gsumToElt (TAG -> Int -> TAG
forall a. Bits a => a -> Int -> a
shiftR TAG
k Int
1) GSumEltR t (a :+: b)
GSumEltR (GSumEltR t a) b
t0
        (t
t2, a a
a) = TAG -> GSumEltR t a -> (t, a a)
forall t a. TAG -> GSumEltR t a -> (t, a a)
forall (f :: * -> *) t a.
GSumElt f =>
TAG -> GSumEltR t f -> (t, f a)
gsumToElt (TAG -> Int -> TAG
forall a. Bits a => a -> Int -> a
shiftR TAG
k Int
1) GSumEltR t a
t1
     in
     if TAG -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit TAG
k Int
0
        then (t
t2, b a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 b a
b)
        else (t
t2, a a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 a a
a)

  gsumTagsR :: forall t. TAG -> TagR t -> [(TAG, TagR (GSumEltR t (a :+: b)))]
gsumTagsR TAG
k TagR t
t =
    let a :: [(TAG, TagR (GSumEltR t a))]
a = forall (f :: * -> *) t.
GSumElt f =>
TAG -> TagR t -> [(TAG, TagR (GSumEltR t f))]
gsumTagsR @a TAG
k TagR t
t
        b :: [(TAG, TagR (GSumEltR (GSumEltR t a) b))]
b = forall (f :: * -> *) t.
GSumElt f =>
TAG -> TagR t -> [(TAG, TagR (GSumEltR t f))]
gsumTagsR @b TAG
k (forall (f :: * -> *) t. GSumElt f => TagR t -> TagR (GSumEltR t f)
gsumUntag @a TagR t
t)
     in
     ((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
x,TagR (GSumEltR t a)
y) ->         (TAG
x TAG -> Int -> TAG
forall a. Bits a => a -> Int -> a
`shiftL` Int
1, forall (f :: * -> *) t. GSumElt f => TagR t -> TagR (GSumEltR t f)
gsumUntag @b TagR (GSumEltR t a)
y)) [(TAG, TagR (GSumEltR t a))]
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))
 -> (TAG, TagR (GSumEltR (GSumEltR t a) b)))
-> [(TAG, TagR (GSumEltR (GSumEltR t a) b))]
-> [(TAG, TagR (GSumEltR (GSumEltR t a) b))]
forall a b. (a -> b) -> [a] -> [b]
map (\(TAG
x,TagR (GSumEltR (GSumEltR t a) b)
y) -> (TAG -> Int -> TAG
forall a. Bits a => a -> Int -> a
setBit (TAG
x TAG -> Int -> TAG
forall a. Bits a => a -> Int -> a
`shiftL` Int
1) Int
0, TagR (GSumEltR (GSumEltR t a) b)
y)) [(TAG, TagR (GSumEltR (GSumEltR t a) b))]
b

  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)