content: {-# LANGUAGE AllowAmbiguousTypes  #-}
  {-# LANGUAGE DefaultSignatures    #-}
  {-# LANGUAGE FlexibleContexts     #-}
  {-# LANGUAGE FlexibleInstances    #-}
  {-# LANGUAGE KindSignatures       #-}
  {-# LANGUAGE ScopedTypeVariables  #-}
  {-# LANGUAGE TemplateHaskell      #-}
  {-# LANGUAGE TypeApplications     #-}
  {-# LANGUAGE TypeOperators        #-}
  {-# OPTIONS_HADDOCK hide #-}
  -- |
  -- Module      : Data.Array.Accelerate.Sugar.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.Sugar.Tag
    where
  
  import Data.Array.Accelerate.Representation.Tag
  
  import Data.Bits
  import Data.Kind
  import Language.Haskell.TH.Extra                                    hiding ( Type )
  
  import GHC.Generics
  
  
  -- | The numeric 'TAG' values corresponding to the constructors of the type @t@.
  --
  -- TODO: These tags are intended to be equal to the tags generated by
  -- 'tagsR' from 'Elt'. (This is currently not programmatically checked.)
  -- These should also be equal to the tags for sum-type patterns generated
  -- using TemplateHaskell (which is also not programmatically checked).
  --
  class Tagged t where
    -- | The numeric 'TAG' values corresponding to the constructors of the
    -- type. The constructors are identified by their name as a String.
    tags :: [(String, TAG)]
  
    default tags :: GTagged (Rep t) => [(String, TAG)]
    tags = gtags @(Rep t) 0
  
  
  class GTagged (f :: Type -> Type) where
    gtags :: TAG -> [(String, TAG)]
  
  instance GTagged a => GTagged (D1 c a) where
    gtags = gtags @a
  
  instance Constructor c => GTagged (C1 c a) where
    gtags k = [ (conName (undefined :: D1 c a ()), k) ]
  
  instance (GTagged a, GTagged b) => GTagged (a :+: b) where
    gtags k =
      let as = gtags @a k
          bs = gtags @b k
       in
       map (\(x,y) -> (x,         y `shiftL` 1)   ) as ++
       map (\(x,y) -> (x, setBit (y `shiftL` 1) 0)) bs
  
  instance Tagged ()
  instance Tagged Bool
  instance Tagged Ordering
  instance Tagged (Maybe a)
  instance Tagged (Either a b)
  
  runQ $ do
    let
        mkTuple :: Int -> Q Dec
        mkTuple n =
          let xs  = [ mkName ('x' : show i) | i <- [0 .. n-1] ]
              ts  = map varT xs
              res = tupT ts
          in
          instanceD (return []) [t| Tagged $res |] []
    --
    mapM mkTuple [2..16]
  
  