{-# LANGUAGE GADTs               #-}
{-# LANGUAGE PatternGuards       #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module      : Data.Array.Accelerate.Analysis.Hash
-- Copyright   : [2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--

module Data.Array.Accelerate.Analysis.Hash (

  -- hashing expressions
  Hash,
  hashPreOpenAcc,
  hashPreOpenFun,
  hashPreOpenExp,

  -- auxiliary
  EncodeAcc,
  encodePreOpenAcc, encodeOpenAcc,
  encodePreOpenExp, encodeOpenExp,
  encodePreOpenFun,
  hashQ,

) where

import Data.Array.Accelerate.AST
import Data.Array.Accelerate.Analysis.Hash.TH
import Data.Array.Accelerate.Array.Sugar
import Data.Array.Accelerate.Array.Representation                   ( SliceIndex(..) )
import Data.Array.Accelerate.Product
import Data.Array.Accelerate.Type

import Crypto.Hash
import Data.Bits
import Data.ByteString.Builder
import Data.ByteString.Builder.Extra
import Data.Monoid
import Foreign.C.Types
import System.IO.Unsafe                                             ( unsafePerformIO )
import System.Mem.StableName                                        ( hashStableName, makeStableName )
import Prelude                                                      hiding ( exp )


-- Hashing
-- -------

type Hash = Digest SHA3_256

hashPreOpenAcc :: EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash
hashPreOpenAcc encodeAcc = hashlazy . toLazyByteString . encodePreOpenAcc encodeAcc

hashPreOpenFun :: EncodeAcc acc -> PreOpenFun acc env aenv f -> Hash
hashPreOpenFun encodeAcc = hashlazy . toLazyByteString . encodePreOpenFun encodeAcc

hashPreOpenExp :: EncodeAcc acc -> PreOpenExp acc env aenv t -> Hash
hashPreOpenExp encodeAcc = hashlazy . toLazyByteString . encodePreOpenExp encodeAcc


-- Array computations
-- ------------------

type EncodeAcc acc = forall aenv a. acc aenv a -> Builder

{-# INLINE encodeOpenAcc #-}
encodeOpenAcc :: OpenAcc aenv arrs -> Builder
encodeOpenAcc (OpenAcc pacc) = encodePreOpenAcc encodeOpenAcc pacc

{-# INLINE encodePreOpenAcc #-}
encodePreOpenAcc
    :: forall acc aenv arrs.
       EncodeAcc acc
    -> PreOpenAcc acc aenv arrs
    -> Builder
encodePreOpenAcc encodeAcc pacc =
  let
      {-# INLINE travA #-}
      travA :: forall aenv' a. Arrays a => acc aenv' a -> Builder
      travA a = encodeArraysType (arrays (undefined::a)) <> encodeAcc a

      {-# INLINE travE #-}
      travE :: PreOpenExp acc env' aenv' e -> Builder
      travE = encodePreOpenExp encodeAcc

      {-# INLINE travF #-}
      travF :: PreOpenFun acc env' aenv' f -> Builder
      travF = encodePreOpenFun encodeAcc

      {-# INLINE travB #-}
      travB :: PreBoundary acc aenv' (Array sh e) -> Builder
      travB = encodePreBoundary encodeAcc

      {-# INLINE nacl #-}
      nacl :: Arrays arrs => Builder
      nacl = encodeArraysType (arrays (undefined::arrs))
  in
  case pacc of
    Alet bnd body               -> intHost $(hashQ "Alet")        <> travA bnd <> travA body
    Avar v                      -> intHost $(hashQ "Avar")        <> nacl <> encodeIdx v
    Atuple t                    -> intHost $(hashQ "Atuple")      <> nacl <> encodeAtuple encodeAcc t
    Aprj ix a                   -> intHost $(hashQ "Aprj")        <> nacl <> encodeTupleIdx ix <> travA a
    Apply f a                   -> intHost $(hashQ "Apply")       <> nacl <> encodePreOpenAfun encodeAcc f <> travA a
    Aforeign _ f a              -> intHost $(hashQ "Aforeign")    <> nacl <> encodePreOpenAfun encodeAcc f <> travA a
    Use a                       -> intHost $(hashQ "Use")         <> encodeArrays (arrays (undefined::arrs)) a
    Awhile p f a                -> intHost $(hashQ "Awhile")      <> encodePreOpenAfun encodeAcc f <> encodePreOpenAfun encodeAcc p <> travA a
    Unit e                      -> intHost $(hashQ "Unit")        <> travE e
    Generate e f                -> intHost $(hashQ "Generate")    <> travE e  <> travF f
    Acond e a1 a2               -> intHost $(hashQ "Acond")       <> travE e  <> travA a1 <> travA a2
    Reshape sh a                -> intHost $(hashQ "Reshape")     <> travE sh <> travA a
    Transform sh f1 f2 a        -> intHost $(hashQ "Transform")   <> travE sh <> travF f1 <> travF f2 <> travA a
    Replicate spec ix a         -> intHost $(hashQ "Replicate")   <> travE ix <> travA a  <> encodeSliceIndex spec
    Slice spec a ix             -> intHost $(hashQ "Slice")       <> travE ix <> travA a  <> encodeSliceIndex spec
    Map f a                     -> intHost $(hashQ "Map")         <> travF f  <> travA a
    ZipWith f a1 a2             -> intHost $(hashQ "ZipWith")     <> travF f  <> travA a1 <> travA a2
    Fold f e a                  -> intHost $(hashQ "Fold")        <> travF f  <> travE e  <> travA a
    Fold1 f a                   -> intHost $(hashQ "Fold1")       <> travF f  <> travA a
    FoldSeg f e a s             -> intHost $(hashQ "FoldSeg")     <> travF f  <> travE e  <> travA a  <> travA s
    Fold1Seg f a s              -> intHost $(hashQ "Fold1Seg")    <> travF f  <> travA a  <> travA s
    Scanl f e a                 -> intHost $(hashQ "Scanl")       <> travF f  <> travE e  <> travA a
    Scanl' f e a                -> intHost $(hashQ "Scanl'")      <> travF f  <> travE e  <> travA a
    Scanl1 f a                  -> intHost $(hashQ "Scanl1")      <> travF f  <> travA a
    Scanr f e a                 -> intHost $(hashQ "Scanr")       <> travF f  <> travE e  <> travA a
    Scanr' f e a                -> intHost $(hashQ "Scanr'")      <> travF f  <> travE e  <> travA a
    Scanr1 f a                  -> intHost $(hashQ "Scanr1")      <> travF f  <> travA a
    Backpermute sh f a          -> intHost $(hashQ "Backpermute") <> travF f  <> travE sh <> travA a
    Permute f1 a1 f2 a2         -> intHost $(hashQ "Permute")     <> travF f1 <> travA a1 <> travF f2 <> travA a2
    Stencil f b a               -> intHost $(hashQ "Stencil")     <> travF f  <> travB b  <> travA a
    Stencil2 f b1 a1 b2 a2      -> intHost $(hashQ "Stencil2")    <> travF f  <> travB b1 <> travA a1 <> travB b2 <> travA a2

{--
encodePreOpenSeq :: forall acc aenv senv arrs. EncodeAcc acc -> PreOpenSeq acc aenv senv arrs -> Int
encodePreOpenSeq encodeAcc s =
  let
      travA :: acc aenv' a -> Builder
      travA = encodeAcc -- XXX: plus type information?

      travE :: PreOpenExp acc env' aenv' e -> Builder
      travE = encodePreOpenExp encodeAcc

      travAF :: PreOpenAfun acc aenv' f -> Builder
      travAF = encodePreOpenAfun encodeAcc

      travF :: PreOpenFun acc env' aenv' f -> Builder
      travF = encodePreOpenFun encodeAcc

      travS :: PreOpenSeq acc aenv senv' arrs' -> Builder
      travS = encodePreOpenSeq encodeAcc

      travV :: forall a. Arrays a => Idx senv' a -> Builder
      travV v = encodeArraysType (arrays (undefined::a)) <> encodeIdx v

      travP :: Producer acc aenv senv a -> Builder
      travP p =
        case p of
          StreamIn arrs       -> intHost . unsafePerformIO $! hashStableName `fmap` makeStableName arrs
          ToSeq spec _ acc    -> intHost $(hashQ "ToSeq")         <> travA  acc <> stringUtf8 (show spec)
          MapSeq f x          -> intHost $(hashQ "MapSeq")        <> travAF f   <> travV x
          ChunkedMapSeq f x   -> intHost $(hashQ "ChunkedMapSeq") <> travAF f   <> travV x
          ZipWithSeq f x y    -> intHost $(hashQ "ZipWithSeq")    <> travAF f   <> travV x <> travV y
          ScanSeq f e x       -> intHost $(hashQ "ScanSeq")       <> travF  f   <> travE e <> travV x

      travC :: Consumer acc aenv senv' a -> Builder
      travC c =
        case c of
          FoldSeq f e x          -> intHost $(hashQ "FoldSeq")        <> travF  f <> travE e   <> travV x
          FoldSeqFlatten f acc x -> intHost $(hashQ "FoldSeqFlatten") <> travAF f <> travA acc <> travV x
          Stuple t               -> intHost $(hashQ "Stuple")         <> encodeAtuple travC t
  in
  case s of
    Producer p s' -> intHost $(hashQ "Producer")   <> travP p <> travS s'
    Consumer c    -> intHost $(hashQ "Consumer")   <> travC c
    Reify ix      -> intHost $(hashQ "Reify")      <> travV ix
--}

{-# INLINE encodeIdx #-}
encodeIdx :: Idx env t -> Builder
encodeIdx = intHost . idxToInt

{-# INLINE encodeTupleIdx #-}
encodeTupleIdx :: TupleIdx tup e -> Builder
encodeTupleIdx = intHost . tupleIdxToInt

{-# INLINE encodeArrays #-}
encodeArrays :: ArraysR a -> a -> Builder
encodeArrays ArraysRunit         ()       = mempty
encodeArrays (ArraysRpair r1 r2) (a1, a2) = encodeArrays r1 a1 <> encodeArrays r2 a2
encodeArrays ArraysRarray        ad       = intHost . unsafePerformIO $! hashStableName `fmap` makeStableName ad

{-# INLINE encodeArraysType #-}
encodeArraysType :: forall a. ArraysR a -> Builder
encodeArraysType ArraysRunit         = intHost $(hashQ "ArraysRunit")
encodeArraysType (ArraysRpair r1 r2) = intHost $(hashQ "ArraysRpair")  <> encodeArraysType r1 <> encodeArraysType r2
encodeArraysType ArraysRarray        = intHost $(hashQ "ArraysRarray") <> encodeArrayType (undefined::a)
  where
    {-# INLINE encodeArrayType #-}
    encodeArrayType :: forall sh e. (Shape sh, Elt e) => Array sh e -> Builder
    encodeArrayType _ = encodeTupleType (eltType (undefined::sh)) <> encodeTupleType (eltType (undefined::e))

{-# INLINE encodeAtuple #-}
encodeAtuple :: EncodeAcc acc -> Atuple (acc aenv) a -> Builder
encodeAtuple _     NilAtup        = intHost $(hashQ "NilAtup")
encodeAtuple travA (SnocAtup t a) = intHost $(hashQ "SnocAtup") <> encodeAtuple travA t <> travA a

{-# INLINE encodePreOpenAfun #-}
encodePreOpenAfun :: forall acc aenv f. EncodeAcc acc -> PreOpenAfun acc aenv f -> Builder
encodePreOpenAfun travA afun =
  let
      {-# INLINE travB #-}
      travB :: forall aenv' a. Arrays a => acc aenv' a -> Builder
      travB b = encodeArraysType (arrays (undefined::a)) <> travA b

      {-# INLINE travL #-}
      travL :: forall aenv' a b. Arrays a => PreOpenAfun acc (aenv',a) b -> Builder
      travL l = encodeArraysType (arrays (undefined::a)) <> encodePreOpenAfun travA l
  in
  case afun of
    Abody b -> intHost $(hashQ "Abody") <> travB b
    Alam  l -> intHost $(hashQ "Alam")  <> travL l


{-# INLINE encodePreBoundary #-}
encodePreBoundary :: forall acc aenv sh e. EncodeAcc acc -> PreBoundary acc aenv (Array sh e) -> Builder
encodePreBoundary _ Wrap          = intHost $(hashQ "Wrap")
encodePreBoundary _ Clamp         = intHost $(hashQ "Clamp")
encodePreBoundary _ Mirror        = intHost $(hashQ "Mirror")
encodePreBoundary _ (Constant c)  = intHost $(hashQ "Constant") <> encodeConst (eltType (undefined::e)) c
encodePreBoundary h (Function f)  = intHost $(hashQ "Function") <> encodePreOpenFun h f

{-# INLINE encodeSliceIndex #-}
encodeSliceIndex :: SliceIndex slix sl co sh -> Builder
encodeSliceIndex SliceNil         = intHost $(hashQ "SliceNil")
encodeSliceIndex (SliceAll r)     = intHost $(hashQ "SliceAll")   <> encodeSliceIndex r
encodeSliceIndex (SliceFixed r)   = intHost $(hashQ "sliceFixed") <> encodeSliceIndex r


-- Scalar expressions
-- ------------------

{-# INLINE encodeOpenExp #-}
encodeOpenExp :: OpenExp env aenv exp -> Builder
encodeOpenExp = encodePreOpenExp encodeOpenAcc

{-# INLINE encodePreOpenExp #-}
encodePreOpenExp :: forall acc env aenv exp. EncodeAcc acc -> PreOpenExp acc env aenv exp -> Builder
encodePreOpenExp travA exp =
  let
      {-# INLINE travE #-}
      travE :: forall env' aenv' e. Elt e => PreOpenExp acc env' aenv' e -> Builder
      travE e =  encodeTupleType (eltType (undefined::e)) <> encodePreOpenExp travA e

      {-# INLINE travF #-}
      travF :: PreOpenFun acc env' aenv' f -> Builder
      travF = encodePreOpenFun travA

      {-# INLINE nacl #-}
      nacl :: Elt exp => Builder
      nacl = encodeTupleType (eltType (undefined::exp))
  in
  case exp of
    Let bnd body                -> intHost $(hashQ "Let")         <> travE bnd <> travE body
    Var ix                      -> intHost $(hashQ "Var")         <> nacl <> encodeIdx ix
    Tuple t                     -> intHost $(hashQ "Tuple")       <> nacl <> encodeTuple travA t
    Prj i e                     -> intHost $(hashQ "Prj")         <> nacl <> encodeTupleIdx i <> travE e -- XXX: here multiplied nacl by hashTupleIdx
    Const c                     -> intHost $(hashQ "Const")       <> encodeConst (eltType (undefined::exp)) c
    Undef                       -> intHost $(hashQ "Undef")
    IndexAny                    -> intHost $(hashQ "IndexAny")    <> nacl
    IndexNil                    -> intHost $(hashQ "IndexNil")
    IndexCons sh sz             -> intHost $(hashQ "IndexCons")   <> travE sh <> travE sz
    IndexHead sl                -> intHost $(hashQ "IndexHead")   <> travE sl
    IndexTail sl                -> intHost $(hashQ "IndexTail")   <> travE sl
    IndexSlice spec ix sh       -> intHost $(hashQ "IndexSlice")  <> travE ix <> travE sh <> encodeSliceIndex spec
    IndexFull  spec ix sl       -> intHost $(hashQ "IndexFull")   <> travE ix <> travE sl <> encodeSliceIndex spec
    ToIndex sh i                -> intHost $(hashQ "ToIndex")     <> travE sh <> travE i
    FromIndex sh i              -> intHost $(hashQ "FromIndex")   <> travE sh <> travE i
    Cond c t e                  -> intHost $(hashQ "Cond")        <> travE c  <> travE t  <> travE e
    While p f x                 -> intHost $(hashQ "While")       <> travF p  <> travF f  <> travE x
    PrimApp f x                 -> intHost $(hashQ "PrimApp")     <> encodePrimFun f <> travE x
    PrimConst c                 -> intHost $(hashQ "PrimConst")   <> encodePrimConst c
    Index a ix                  -> intHost $(hashQ "Index")       <> travA a  <> travE ix
    LinearIndex a ix            -> intHost $(hashQ "LinearIndex") <> travA a  <> travE ix
    Shape a                     -> intHost $(hashQ "Shape")       <> travA a
    ShapeSize sh                -> intHost $(hashQ "ShapeSize")   <> travE sh
    Intersect sa sb             -> intHost $(hashQ "Intersect")   <> travE sa <> travE sb
    Union sa sb                 -> intHost $(hashQ "Union")       <> travE sa <> travE sb
    Foreign _ f e               -> intHost $(hashQ "Foreign")     <> travF f  <> travE e
    Coerce e                    -> intHost $(hashQ "Coerce")      <> travE e


{-# INLINE encodePreOpenFun #-}
encodePreOpenFun :: forall acc env aenv f. EncodeAcc acc -> PreOpenFun acc env aenv f -> Builder
encodePreOpenFun travA fun =
  let
      travB :: forall env' aenv' e. Elt e => PreOpenExp acc env' aenv' e -> Builder
      travB b = encodeTupleType (eltType (undefined::e)) <> encodePreOpenExp travA b

      travL :: forall env' aenv' a b. Elt a => PreOpenFun acc (env',a) aenv' b -> Builder
      travL l = encodeTupleType (eltType (undefined::a)) <> encodePreOpenFun travA l
  in
  case fun of
    Body b -> intHost $(hashQ "Body") <> travB b
    Lam l  -> intHost $(hashQ "Lam")  <> travL l

{-# INLINE encodeTuple #-}
encodeTuple :: EncodeAcc acc -> Tuple (PreOpenExp acc env aenv) e -> Builder
encodeTuple _ NilTup        = intHost $(hashQ "NilTup")
encodeTuple h (SnocTup t e) = intHost $(hashQ "SnocTup") <> encodeTuple h t <> encodePreOpenExp h e


{-# INLINE encodeConst #-}
encodeConst :: TupleType t -> t -> Builder
encodeConst TypeRunit         ()    = mempty
encodeConst (TypeRscalar t)   c     = encodeScalarConst t c
encodeConst (TypeRpair ta tb) (a,b) = encodeConst ta a <> encodeConst tb b

{-# INLINE encodeScalarConst #-}
encodeScalarConst :: ScalarType t -> t -> Builder
encodeScalarConst (SingleScalarType t) = encodeSingleConst t
encodeScalarConst (VectorScalarType t) = encodeVectorConst t

{-# INLINE encodeSingleConst #-}
encodeSingleConst :: SingleType t -> t -> Builder
encodeSingleConst (NumSingleType t)    = encodeNumConst t
encodeSingleConst (NonNumSingleType t) = encodeNonNumConst t

{-# INLINE encodeVectorConst #-}
encodeVectorConst :: VectorType t -> t -> Builder
encodeVectorConst (Vector2Type t) (V2 a b)     = intHost $(hashQ "V2") <> encodeSingleConst t a <> encodeSingleConst t b
encodeVectorConst (Vector3Type t) (V3 a b c)   = intHost $(hashQ "V3") <> encodeSingleConst t a <> encodeSingleConst t b <> encodeSingleConst t c
encodeVectorConst (Vector4Type t) (V4 a b c d) = intHost $(hashQ "V4") <> encodeSingleConst t a <> encodeSingleConst t b <> encodeSingleConst t c <> encodeSingleConst t d
encodeVectorConst (Vector8Type t) (V8 a b c d e f g h) =
  intHost $(hashQ "V8") <> encodeSingleConst t a <> encodeSingleConst t b <> encodeSingleConst t c <> encodeSingleConst t d
                        <> encodeSingleConst t e <> encodeSingleConst t f <> encodeSingleConst t g <> encodeSingleConst t h
encodeVectorConst (Vector16Type t) (V16 a b c d e f g h i j k l m n o p) =
  intHost $(hashQ "V16") <> encodeSingleConst t a <> encodeSingleConst t b <> encodeSingleConst t c <> encodeSingleConst t d
                         <> encodeSingleConst t e <> encodeSingleConst t f <> encodeSingleConst t g <> encodeSingleConst t h
                         <> encodeSingleConst t i <> encodeSingleConst t j <> encodeSingleConst t k <> encodeSingleConst t l
                         <> encodeSingleConst t m <> encodeSingleConst t n <> encodeSingleConst t o <> encodeSingleConst t p

{-# INLINE encodeNonNumConst #-}
encodeNonNumConst :: NonNumType t -> t -> Builder
encodeNonNumConst TypeBool{}   x          = intHost $(hashQ "Bool")   <> word8 (fromBool x)
encodeNonNumConst TypeChar{}   x          = intHost $(hashQ "Char")   <> charUtf8 x
encodeNonNumConst TypeCSChar{} (CSChar x) = intHost $(hashQ "CSChar") <> int8 x
encodeNonNumConst TypeCUChar{} (CUChar x) = intHost $(hashQ "CUChar") <> word8 x
encodeNonNumConst TypeCChar{}  (CChar  x) = intHost $(hashQ "CChar")  <> $( case isSigned (undefined::CChar) of
                                                                              True  -> [e| int8  |]
                                                                              False -> [e| word8 |] ) x

{-# INLINE fromBool #-}
fromBool :: Bool -> Word8
fromBool True  = 1
fromBool False = 0

{-# INLINE encodeNumConst #-}
encodeNumConst :: NumType t -> t -> Builder
encodeNumConst (IntegralNumType t) = encodeIntegralConst t
encodeNumConst (FloatingNumType t) = encodeFloatingConst t

{-# INLINE encodeIntegralConst #-}
encodeIntegralConst :: IntegralType t -> t -> Builder
encodeIntegralConst TypeInt{}     x           = intHost $(hashQ "Int")     <> intHost x
encodeIntegralConst TypeInt8{}    x           = intHost $(hashQ "Int8")    <> int8 x
encodeIntegralConst TypeInt16{}   x           = intHost $(hashQ "Int16")   <> int16Host x
encodeIntegralConst TypeInt32{}   x           = intHost $(hashQ "Int32")   <> int32Host x
encodeIntegralConst TypeInt64{}   x           = intHost $(hashQ "Int64")   <> int64Host x
encodeIntegralConst TypeWord{}    x           = intHost $(hashQ "Word")    <> wordHost x
encodeIntegralConst TypeWord8{}   x           = intHost $(hashQ "Word8")   <> word8 x
encodeIntegralConst TypeWord16{}  x           = intHost $(hashQ "Word16")  <> word16Host x
encodeIntegralConst TypeWord32{}  x           = intHost $(hashQ "Word32")  <> word32Host x
encodeIntegralConst TypeWord64{}  x           = intHost $(hashQ "Word64")  <> word64Host x
encodeIntegralConst TypeCShort{}  (CShort x)  = intHost $(hashQ "CShort")  <> int16Host x
encodeIntegralConst TypeCUShort{} (CUShort x) = intHost $(hashQ "CUShort") <> word16Host x
encodeIntegralConst TypeCInt{}    (CInt x)    = intHost $(hashQ "CInt")    <> int32Host x
encodeIntegralConst TypeCUInt{}   (CUInt x)   = intHost $(hashQ "CUInt")   <> word32Host x
encodeIntegralConst TypeCLLong{}  (CLLong x)  = intHost $(hashQ "CLLong")  <> int64Host x
encodeIntegralConst TypeCULLong{} (CULLong x) = intHost $(hashQ "CULLong") <> word64Host x
encodeIntegralConst TypeCLong{}   (CLong x)   = intHost $(hashQ "CLong")   <> $( case finiteBitSize (undefined::CLong) of
                                                                                   32 -> [e| int32Host |]
                                                                                   64 -> [e| int64Host |]
                                                                                   _  -> error "I don't know what architecture I am" ) x
encodeIntegralConst TypeCULong{}  (CULong x)  = intHost $(hashQ "CULong")  <> $( case finiteBitSize (undefined::CULong) of
                                                                                   32 -> [e| word32Host |]
                                                                                   64 -> [e| word64Host |]
                                                                                   _  -> error "I don't know what architecture I am" ) x

{-# INLINE encodeFloatingConst #-}
encodeFloatingConst :: FloatingType t -> t -> Builder
encodeFloatingConst TypeHalf{}    (Half (CUShort x)) = intHost $(hashQ "Half")    <> word16Host x
encodeFloatingConst TypeFloat{}   x                  = intHost $(hashQ "Float")   <> floatHost x
encodeFloatingConst TypeDouble{}  x                  = intHost $(hashQ "Double")  <> doubleHost x
encodeFloatingConst TypeCFloat{}  (CFloat x)         = intHost $(hashQ "CFloat")  <> floatHost x
encodeFloatingConst TypeCDouble{} (CDouble x)        = intHost $(hashQ "CDouble") <> doubleHost x

{-# INLINE encodePrimConst #-}
encodePrimConst :: PrimConst c -> Builder
encodePrimConst (PrimMinBound t)  = intHost $(hashQ "PrimMinBound") <> encodeBoundedType t
encodePrimConst (PrimMaxBound t)  = intHost $(hashQ "PrimMaxBound") <> encodeBoundedType t
encodePrimConst (PrimPi t)        = intHost $(hashQ "PrimPi")       <> encodeFloatingType t

{-# INLINE encodePrimFun #-}
encodePrimFun :: PrimFun f -> Builder
encodePrimFun (PrimAdd a)                = intHost $(hashQ "PrimAdd")                <> encodeNumType a
encodePrimFun (PrimSub a)                = intHost $(hashQ "PrimSub")                <> encodeNumType a
encodePrimFun (PrimMul a)                = intHost $(hashQ "PrimMul")                <> encodeNumType a
encodePrimFun (PrimNeg a)                = intHost $(hashQ "PrimNeg")                <> encodeNumType a
encodePrimFun (PrimAbs a)                = intHost $(hashQ "PrimAbs")                <> encodeNumType a
encodePrimFun (PrimSig a)                = intHost $(hashQ "PrimSig")                <> encodeNumType a
encodePrimFun (PrimQuot a)               = intHost $(hashQ "PrimQuot")               <> encodeIntegralType a
encodePrimFun (PrimRem a)                = intHost $(hashQ "PrimRem")                <> encodeIntegralType a
encodePrimFun (PrimQuotRem a)            = intHost $(hashQ "PrimQuotRem")            <> encodeIntegralType a
encodePrimFun (PrimIDiv a)               = intHost $(hashQ "PrimIDiv")               <> encodeIntegralType a
encodePrimFun (PrimMod a)                = intHost $(hashQ "PrimMod")                <> encodeIntegralType a
encodePrimFun (PrimDivMod a)             = intHost $(hashQ "PrimDivMod")             <> encodeIntegralType a
encodePrimFun (PrimBAnd a)               = intHost $(hashQ "PrimBAnd")               <> encodeIntegralType a
encodePrimFun (PrimBOr a)                = intHost $(hashQ "PrimBOr")                <> encodeIntegralType a
encodePrimFun (PrimBXor a)               = intHost $(hashQ "PrimBXor")               <> encodeIntegralType a
encodePrimFun (PrimBNot a)               = intHost $(hashQ "PrimBNot")               <> encodeIntegralType a
encodePrimFun (PrimBShiftL a)            = intHost $(hashQ "PrimBShiftL")            <> encodeIntegralType a
encodePrimFun (PrimBShiftR a)            = intHost $(hashQ "PrimBShiftR")            <> encodeIntegralType a
encodePrimFun (PrimBRotateL a)           = intHost $(hashQ "PrimBRotateL")           <> encodeIntegralType a
encodePrimFun (PrimBRotateR a)           = intHost $(hashQ "PrimBRotateR")           <> encodeIntegralType a
encodePrimFun (PrimPopCount a)           = intHost $(hashQ "PrimPopCount")           <> encodeIntegralType a
encodePrimFun (PrimCountLeadingZeros a)  = intHost $(hashQ "PrimCountLeadingZeros")  <> encodeIntegralType a
encodePrimFun (PrimCountTrailingZeros a) = intHost $(hashQ "PrimCountTrailingZeros") <> encodeIntegralType a
encodePrimFun (PrimFDiv a)               = intHost $(hashQ "PrimFDiv")               <> encodeFloatingType a
encodePrimFun (PrimRecip a)              = intHost $(hashQ "PrimRecip")              <> encodeFloatingType a
encodePrimFun (PrimSin a)                = intHost $(hashQ "PrimSin")                <> encodeFloatingType a
encodePrimFun (PrimCos a)                = intHost $(hashQ "PrimCos")                <> encodeFloatingType a
encodePrimFun (PrimTan a)                = intHost $(hashQ "PrimTan")                <> encodeFloatingType a
encodePrimFun (PrimAsin a)               = intHost $(hashQ "PrimAsin")               <> encodeFloatingType a
encodePrimFun (PrimAcos a)               = intHost $(hashQ "PrimAcos")               <> encodeFloatingType a
encodePrimFun (PrimAtan a)               = intHost $(hashQ "PrimAtan")               <> encodeFloatingType a
encodePrimFun (PrimSinh a)               = intHost $(hashQ "PrimSinh")               <> encodeFloatingType a
encodePrimFun (PrimCosh a)               = intHost $(hashQ "PrimCosh")               <> encodeFloatingType a
encodePrimFun (PrimTanh a)               = intHost $(hashQ "PrimTanh")               <> encodeFloatingType a
encodePrimFun (PrimAsinh a)              = intHost $(hashQ "PrimAsinh")              <> encodeFloatingType a
encodePrimFun (PrimAcosh a)              = intHost $(hashQ "PrimAcosh")              <> encodeFloatingType a
encodePrimFun (PrimAtanh a)              = intHost $(hashQ "PrimAtanh")              <> encodeFloatingType a
encodePrimFun (PrimExpFloating a)        = intHost $(hashQ "PrimExpFloating")        <> encodeFloatingType a
encodePrimFun (PrimSqrt a)               = intHost $(hashQ "PrimSqrt")               <> encodeFloatingType a
encodePrimFun (PrimLog a)                = intHost $(hashQ "PrimLog")                <> encodeFloatingType a
encodePrimFun (PrimFPow a)               = intHost $(hashQ "PrimFPow")               <> encodeFloatingType a
encodePrimFun (PrimLogBase a)            = intHost $(hashQ "PrimLogBase")            <> encodeFloatingType a
encodePrimFun (PrimAtan2 a)              = intHost $(hashQ "PrimAtan2")              <> encodeFloatingType a
encodePrimFun (PrimTruncate a b)         = intHost $(hashQ "PrimTruncate")           <> encodeFloatingType a <> encodeIntegralType b
encodePrimFun (PrimRound a b)            = intHost $(hashQ "PrimRound")              <> encodeFloatingType a <> encodeIntegralType b
encodePrimFun (PrimFloor a b)            = intHost $(hashQ "PrimFloor")              <> encodeFloatingType a <> encodeIntegralType b
encodePrimFun (PrimCeiling a b)          = intHost $(hashQ "PrimCeiling")            <> encodeFloatingType a <> encodeIntegralType b
encodePrimFun (PrimIsNaN a)              = intHost $(hashQ "PrimIsNaN")              <> encodeFloatingType a
encodePrimFun (PrimIsInfinite a)         = intHost $(hashQ "PrimIsInfinite")         <> encodeFloatingType a
encodePrimFun (PrimLt a)                 = intHost $(hashQ "PrimLt")                 <> encodeSingleType a
encodePrimFun (PrimGt a)                 = intHost $(hashQ "PrimGt")                 <> encodeSingleType a
encodePrimFun (PrimLtEq a)               = intHost $(hashQ "PrimLtEq")               <> encodeSingleType a
encodePrimFun (PrimGtEq a)               = intHost $(hashQ "PrimGtEq")               <> encodeSingleType a
encodePrimFun (PrimEq a)                 = intHost $(hashQ "PrimEq")                 <> encodeSingleType a
encodePrimFun (PrimNEq a)                = intHost $(hashQ "PrimNEq")                <> encodeSingleType a
encodePrimFun (PrimMax a)                = intHost $(hashQ "PrimMax")                <> encodeSingleType a
encodePrimFun (PrimMin a)                = intHost $(hashQ "PrimMin")                <> encodeSingleType a
encodePrimFun (PrimFromIntegral a b)     = intHost $(hashQ "PrimFromIntegral")       <> encodeIntegralType a <> encodeNumType b
encodePrimFun (PrimToFloating a b)       = intHost $(hashQ "PrimToFloating")         <> encodeNumType a      <> encodeFloatingType b
encodePrimFun PrimLAnd                   = intHost $(hashQ "PrimLAnd")
encodePrimFun PrimLOr                    = intHost $(hashQ "PrimLOr")
encodePrimFun PrimLNot                   = intHost $(hashQ "PrimLNot")
encodePrimFun PrimOrd                    = intHost $(hashQ "PrimOrd")
encodePrimFun PrimChr                    = intHost $(hashQ "PrimChr")
encodePrimFun PrimBoolToInt              = intHost $(hashQ "PrimBoolToInt")


{-# INLINE encodeTupleType #-}
encodeTupleType :: TupleType t -> Builder
encodeTupleType TypeRunit       = intHost $(hashQ "TypeRunit")
encodeTupleType (TypeRscalar t) = intHost $(hashQ "TypeRscalar") <> encodeScalarType t
encodeTupleType (TypeRpair a b) = intHost $(hashQ "TypeRpair")   <> encodeTupleType a <> intHost (depthTypeR a)
                                                                 <> encodeTupleType b <> intHost (depthTypeR b)

{-# INLINE depthTypeR #-}
depthTypeR :: TupleType t -> Int
depthTypeR TypeRunit       = 0
depthTypeR TypeRscalar{}   = 1
depthTypeR (TypeRpair a b) = depthTypeR a + depthTypeR b

{-# INLINE encodeScalarType #-}
encodeScalarType :: ScalarType t -> Builder
encodeScalarType (SingleScalarType t) = intHost $(hashQ "SingleScalarType") <> encodeSingleType t
encodeScalarType (VectorScalarType t) = intHost $(hashQ "VectorScalarType") <> encodeVectorType t

{-# INLINE encodeSingleType #-}
encodeSingleType :: SingleType t -> Builder
encodeSingleType (NumSingleType t)    = intHost $(hashQ "NumSingleType")    <> encodeNumType t
encodeSingleType (NonNumSingleType t) = intHost $(hashQ "NonNumSingleType") <> encodeNonNumType t

{-# INLINE encodeVectorType #-}
encodeVectorType :: VectorType t -> Builder
encodeVectorType (Vector2Type t)  = intHost $(hashQ "Vector2Type") <> encodeSingleType t
encodeVectorType (Vector3Type t)  = intHost $(hashQ "Vector3Type") <> encodeSingleType t
encodeVectorType (Vector4Type t)  = intHost $(hashQ "Vector4Type") <> encodeSingleType t
encodeVectorType (Vector8Type t)  = intHost $(hashQ "Vector8Type") <> encodeSingleType t
encodeVectorType (Vector16Type t) = intHost $(hashQ "Vector16Type") <> encodeSingleType t

{-# INLINE encodeBoundedType #-}
encodeBoundedType :: BoundedType t -> Builder
encodeBoundedType (IntegralBoundedType t) = intHost $(hashQ "IntegralBoundedType") <> encodeIntegralType t
encodeBoundedType (NonNumBoundedType t)   = intHost $(hashQ "NonNumBoundedType")   <> encodeNonNumType t

{-# INLINE encodeNonNumType #-}
encodeNonNumType :: NonNumType t -> Builder
encodeNonNumType TypeBool{}   = intHost $(hashQ "Bool")
encodeNonNumType TypeChar{}   = intHost $(hashQ "Char")
encodeNonNumType TypeCChar{}  = intHost $(hashQ "CChar")
encodeNonNumType TypeCSChar{} = intHost $(hashQ "CSChar")
encodeNonNumType TypeCUChar{} = intHost $(hashQ "CUChar")

{-# INLINE encodeNumType #-}
encodeNumType :: NumType t -> Builder
encodeNumType (IntegralNumType t) = intHost $(hashQ "IntegralNumType") <> encodeIntegralType t
encodeNumType (FloatingNumType t) = intHost $(hashQ "FloatingNumType") <> encodeFloatingType t

{-# INLINE encodeIntegralType #-}
encodeIntegralType :: IntegralType t -> Builder
encodeIntegralType TypeInt{}     = intHost $(hashQ "Int")
encodeIntegralType TypeInt8{}    = intHost $(hashQ "Int8")
encodeIntegralType TypeInt16{}   = intHost $(hashQ "Int16")
encodeIntegralType TypeInt32{}   = intHost $(hashQ "Int32")
encodeIntegralType TypeInt64{}   = intHost $(hashQ "Int64")
encodeIntegralType TypeWord{}    = intHost $(hashQ "Word")
encodeIntegralType TypeWord8{}   = intHost $(hashQ "Word8")
encodeIntegralType TypeWord16{}  = intHost $(hashQ "Word16")
encodeIntegralType TypeWord32{}  = intHost $(hashQ "Word32")
encodeIntegralType TypeWord64{}  = intHost $(hashQ "Word64")
encodeIntegralType TypeCShort{}  = intHost $(hashQ "CShort")
encodeIntegralType TypeCUShort{} = intHost $(hashQ "CUShort")
encodeIntegralType TypeCInt{}    = intHost $(hashQ "CInt")
encodeIntegralType TypeCUInt{}   = intHost $(hashQ "CUInt")
encodeIntegralType TypeCLong{}   = intHost $(hashQ "CLong")
encodeIntegralType TypeCULong{}  = intHost $(hashQ "CULong")
encodeIntegralType TypeCLLong{}  = intHost $(hashQ "CLLong")
encodeIntegralType TypeCULLong{} = intHost $(hashQ "CULLong")

{-# INLINE encodeFloatingType #-}
encodeFloatingType :: FloatingType t -> Builder
encodeFloatingType TypeHalf{}    = intHost $(hashQ "Half")
encodeFloatingType TypeFloat{}   = intHost $(hashQ "Float")
encodeFloatingType TypeDouble{}  = intHost $(hashQ "Double")
encodeFloatingType TypeCFloat{}  = intHost $(hashQ "CFloat")
encodeFloatingType TypeCDouble{} = intHost $(hashQ "CDouble")