{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module      : Data.Array.Accelerate.Representation.Type
-- 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.Representation.Type
  where

import Data.Array.Accelerate.Type
import Data.Primitive.Vec

import Language.Haskell.TH


-- | Both arrays (Acc) and expressions (Exp) are represented as nested
-- pairs consisting of:
--
--   * unit (void)
--
--   * pairs: representing compound values (i.e. tuples) where each component
--     will be stored in a separate array.
--
--   * single array / scalar types
--     in case of expressions: values which go in registers. These may be single value
--     types such as int and float, or SIMD vectors of single value types such
--     as <4 * float>. We do not allow vectors-of-vectors.
--
data TupR s a where
  TupRunit   ::                         TupR s ()
  TupRsingle :: s a                  -> TupR s a
  TupRpair   :: TupR s a -> TupR s b -> TupR s (a, b)

instance Show (TupR ScalarType a) where
  show :: TupR ScalarType a -> String
show TupR ScalarType a
TupRunit       = String
"()"
  show (TupRsingle ScalarType a
t) = ScalarType a -> String
forall a. Show a => a -> String
show ScalarType a
t
  show (TupRpair TupR ScalarType a
a TupR ScalarType b
b) = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TupR ScalarType a -> String
forall a. Show a => a -> String
show TupR ScalarType a
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ TupR ScalarType b -> String
forall a. Show a => a -> String
show TupR ScalarType b
b String -> ShowS
forall a. [a] -> [a] -> [a]
++String
")"

type TypeR = TupR ScalarType

rnfTupR :: (forall b. s b -> ()) -> TupR s a -> ()
rnfTupR :: (forall b. s b -> ()) -> TupR s a -> ()
rnfTupR forall b. s b -> ()
_ TupR s a
TupRunit       = ()
rnfTupR forall b. s b -> ()
f (TupRsingle s a
s) = s a -> ()
forall b. s b -> ()
f s a
s
rnfTupR forall b. s b -> ()
f (TupRpair TupR s a
a TupR s b
b) = (forall b. s b -> ()) -> TupR s a -> ()
forall (s :: * -> *) a. (forall b. s b -> ()) -> TupR s a -> ()
rnfTupR forall b. s b -> ()
f TupR s a
a () -> () -> ()
`seq` (forall b. s b -> ()) -> TupR s b -> ()
forall (s :: * -> *) a. (forall b. s b -> ()) -> TupR s a -> ()
rnfTupR forall b. s b -> ()
f TupR s b
b

rnfTypeR :: TypeR t -> ()
rnfTypeR :: TypeR t -> ()
rnfTypeR = (forall b. ScalarType b -> ()) -> TypeR t -> ()
forall (s :: * -> *) a. (forall b. s b -> ()) -> TupR s a -> ()
rnfTupR forall b. ScalarType b -> ()
rnfScalarType

liftTupR :: (forall b. s b -> Q (TExp (s b))) -> TupR s a -> Q (TExp (TupR s a))
liftTupR :: (forall b. s b -> Q (TExp (s b)))
-> TupR s a -> Q (TExp (TupR s a))
liftTupR forall b. s b -> Q (TExp (s b))
_ TupR s a
TupRunit       = [|| TupRunit ||]
liftTupR forall b. s b -> Q (TExp (s b))
f (TupRsingle s a
s) = [|| TupRsingle $$(f s) ||]
liftTupR forall b. s b -> Q (TExp (s b))
f (TupRpair TupR s a
a TupR s b
b) = [|| TupRpair $$(liftTupR f a) $$(liftTupR f b) ||]

liftTypeR :: TypeR t -> Q (TExp (TypeR t))
liftTypeR :: TypeR t -> Q (TExp (TypeR t))
liftTypeR TypeR t
TupRunit         = [|| TupRunit ||]
liftTypeR (TupRsingle ScalarType t
t)   = [|| TupRsingle $$(liftScalarType t) ||]
liftTypeR (TupRpair TupR ScalarType a
ta TupR ScalarType b
tb) = [|| TupRpair $$(liftTypeR ta) $$(liftTypeR tb) ||]

liftTypeQ :: TypeR t -> TypeQ
liftTypeQ :: TypeR t -> TypeQ
liftTypeQ = TypeR t -> TypeQ
forall t. TypeR t -> TypeQ
tuple
  where
    tuple :: TypeR t -> TypeQ
    tuple :: TypeR t -> TypeQ
tuple TypeR t
TupRunit         = [t| () |]
    tuple (TupRpair TupR ScalarType a
t1 TupR ScalarType b
t2) = [t| ($(tuple t1), $(tuple t2)) |]
    tuple (TupRsingle ScalarType t
t)   = ScalarType t -> TypeQ
forall t. ScalarType t -> TypeQ
scalar ScalarType t
t

    scalar :: ScalarType t -> TypeQ
    scalar :: ScalarType t -> TypeQ
scalar (SingleScalarType SingleType t
t) = SingleType t -> TypeQ
forall t. SingleType t -> TypeQ
single SingleType t
t
    scalar (VectorScalarType VectorType (Vec n a)
t) = VectorType (Vec n a) -> TypeQ
forall (n :: Nat) a. VectorType (Vec n a) -> TypeQ
vector VectorType (Vec n a)
t

    vector :: VectorType (Vec n a) -> TypeQ
    vector :: VectorType (Vec n a) -> TypeQ
vector (VectorType Int
n SingleType a
t) = [t| Vec $(litT (numTyLit (toInteger n))) $(single t) |]

    single :: SingleType t -> TypeQ
    single :: SingleType t -> TypeQ
single (NumSingleType NumType t
t) = NumType t -> TypeQ
forall t. NumType t -> TypeQ
num NumType t
t

    num :: NumType t -> TypeQ
    num :: NumType t -> TypeQ
num (IntegralNumType IntegralType t
t) = IntegralType t -> TypeQ
forall t. IntegralType t -> TypeQ
integral IntegralType t
t
    num (FloatingNumType FloatingType t
t) = FloatingType t -> TypeQ
forall t. FloatingType t -> TypeQ
floating FloatingType t
t

    integral :: IntegralType t -> TypeQ
    integral :: IntegralType t -> TypeQ
integral IntegralType t
TypeInt    = [t| Int |]
    integral IntegralType t
TypeInt8   = [t| Int8 |]
    integral IntegralType t
TypeInt16  = [t| Int16 |]
    integral IntegralType t
TypeInt32  = [t| Int32 |]
    integral IntegralType t
TypeInt64  = [t| Int64 |]
    integral IntegralType t
TypeWord   = [t| Word |]
    integral IntegralType t
TypeWord8  = [t| Word8 |]
    integral IntegralType t
TypeWord16 = [t| Word16 |]
    integral IntegralType t
TypeWord32 = [t| Word32 |]
    integral IntegralType t
TypeWord64 = [t| Word64 |]

    floating :: FloatingType t -> TypeQ
    floating :: FloatingType t -> TypeQ
floating FloatingType t
TypeHalf   = [t| Half |]
    floating FloatingType t
TypeFloat  = [t| Float |]
    floating FloatingType t
TypeDouble = [t| Double |]

runQ $
  let
      mkT :: Int -> Q Dec
      mkT n =
        let xs  = [ mkName ('x' : show i) | i <- [0 .. n-1] ]
            ts  = map varT xs
            rhs = foldl (\a b -> [t| ($a, $b) |]) [t| () |] ts
         in
         tySynD (mkName ("Tup" ++ show n)) (map plainTV xs) rhs
  in
  mapM mkT [2..16]