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

import Data.Array.Accelerate.Type

import Language.Haskell.TH.Extra


-- | The type of the runtime value used to distinguish constructor
-- alternatives in a sum type.
--
type TAG = Word8

-- | This structure both witnesses the layout of our representation types
-- (as TupR does) and represents a complete path of pattern matching
-- through this type. It indicates which fields of the structure represent
-- the union tags (TagRtag) or store undefined values (TagRundef).
--
-- The function 'eltTags' produces all valid paths through the type. For
-- example the type '(Bool,Bool)' produces the following:
--
--   ghci> putStrLn . unlines . map show $ eltTags @(Bool,Bool)
--   (((),(0#,())),(0#,()))     -- (False, False)
--   (((),(0#,())),(1#,()))     -- (False, True)
--   (((),(1#,())),(0#,()))     -- (True, False)
--   (((),(1#,())),(1#,()))     -- (True, True)
--
data TagR a where
  TagRunit   :: TagR ()
  TagRsingle :: ScalarType a -> TagR a
  TagRundef  :: ScalarType a -> TagR a
  TagRtag    :: TAG -> TagR a -> TagR (TAG, a)
  TagRpair   :: TagR a -> TagR b -> TagR (a, b)

instance Show (TagR a) where
  show :: TagR a -> String
show TagR a
TagRunit         = String
"()"
  show TagRsingle{}     = String
"."
  show TagRundef{}      = String
"undef"
  show (TagRtag TAG
v TagR a
t)    = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TAG -> String
forall a. Show a => a -> String
show TAG
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"#," String -> ShowS
forall a. [a] -> [a] -> [a]
++ TagR a -> String
forall a. Show a => a -> String
show TagR a
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
  show (TagRpair TagR a
ta TagR b
tb) = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TagR a -> String
forall a. Show a => a -> String
show TagR a
ta String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ TagR b -> String
forall a. Show a => a -> String
show TagR b
tb String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

rnfTag :: TagR a -> ()
rnfTag :: forall a. TagR a -> ()
rnfTag TagR a
TagRunit         = ()
rnfTag (TagRsingle ScalarType a
t)   = ScalarType a -> ()
forall t. ScalarType t -> ()
rnfScalarType ScalarType a
t
rnfTag (TagRundef ScalarType a
t)    = ScalarType a -> ()
forall t. ScalarType t -> ()
rnfScalarType ScalarType a
t
rnfTag (TagRtag TAG
v TagR a
t)    = TAG
v TAG -> () -> ()
forall a b. a -> b -> b
`seq` TagR a -> ()
forall a. TagR a -> ()
rnfTag TagR a
t
rnfTag (TagRpair TagR a
ta TagR b
tb) = TagR a -> ()
forall a. TagR a -> ()
rnfTag TagR a
ta () -> () -> ()
forall a b. a -> b -> b
`seq` TagR b -> ()
forall a. TagR a -> ()
rnfTag TagR b
tb

liftTag :: TagR a -> CodeQ (TagR a)
liftTag :: forall a. TagR a -> CodeQ (TagR a)
liftTag TagR a
TagRunit         = [|| TagR ()
TagRunit ||]
liftTag (TagRsingle ScalarType a
t)   = [|| ScalarType a -> TagR a
forall a. ScalarType a -> TagR a
TagRsingle $$(ScalarType a -> CodeQ (ScalarType a)
forall t. ScalarType t -> CodeQ (ScalarType t)
liftScalarType ScalarType a
t) ||]
liftTag (TagRundef ScalarType a
t)    = [|| ScalarType a -> TagR a
forall a. ScalarType a -> TagR a
TagRundef $$(ScalarType a -> CodeQ (ScalarType a)
forall t. ScalarType t -> CodeQ (ScalarType t)
liftScalarType ScalarType a
t) ||]
liftTag (TagRtag TAG
v TagR a
t)    = [|| TAG -> TagR a -> TagR (TAG, a)
forall a. TAG -> TagR a -> TagR (TAG, a)
TagRtag TAG
v $$(TagR a -> CodeQ (TagR a)
forall a. TagR a -> CodeQ (TagR a)
liftTag TagR a
t) ||]
liftTag (TagRpair TagR a
ta TagR b
tb) = [|| TagR a -> TagR b -> TagR (a, b)
forall a b. TagR a -> TagR b -> TagR (a, b)
TagRpair $$(TagR a -> CodeQ (TagR a)
forall a. TagR a -> CodeQ (TagR a)
liftTag TagR a
ta) $$(TagR b -> CodeQ (TagR b)
forall a. TagR a -> CodeQ (TagR a)
liftTag TagR b
tb) ||]