{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell       #-}
-- |
-- Module      : Data.Array.Accelerate.Classes.ToFloating
-- Copyright   : [2016..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.Classes.ToFloating (

  ToFloating(..),

) where

import Data.Array.Accelerate.Smart
import Data.Array.Accelerate.Type

import Data.Array.Accelerate.Classes.Floating
import Data.Array.Accelerate.Classes.Num

import Language.Haskell.TH                                          hiding ( Exp )
import Control.Monad
import Prelude                                                      hiding ( Num, Floating )


-- | Accelerate lacks an arbitrary-precision 'Prelude.Rational' type, which the
-- standard 'Prelude.realToFrac' uses as an intermediate value when coercing
-- to floating-point types. Instead, we use this class to capture a direct
-- coercion between two types.
--
class ToFloating a b where
  -- | General coercion to floating types
  toFloating :: (Num a, Floating b) => Exp a -> Exp b

-- instance (Elt a, Elt b, IsNum a, IsFloating b) => ToFloating a b where
--   toFloating = mkToFloating

-- Generate standard instances explicitly. See also: 'FromIntegral'.
--
$(runQ $ do
    let
        -- Get all the types that our dictionaries reify
        digItOut :: Name -> Q [Name]
        digItOut name = do
          TyConI (DataD _ _ _ _ cons _) <- reify name
          let
            -- This is what a constructor such as IntegralNumType will be reified
            -- as prior to GHC 8.4...
            dig (NormalC _ [(_, AppT (ConT n) (VarT _))])               = digItOut n
            -- ...but this is what IntegralNumType will be reified as on GHC 8.4
            -- and later, after the changes described in
            -- https://ghc.haskell.org/trac/ghc/wiki/Migration/8.4#TemplateHaskellreificationchangesforGADTs
            dig (ForallC _ _ (GadtC _ [(_, AppT (ConT n) (VarT _))] _)) = digItOut n
            dig (GadtC _ _ (AppT (ConT _) (ConT n)))                    = return [n]
            dig _ = error "Unexpected case generating ToFloating instances"
            --
          concat `fmap` mapM dig cons

        thToFloating :: Name -> Name -> Q Dec
        thToFloating a b =
          let
              ty  = AppT (AppT (ConT (mkName "ToFloating")) (ConT a)) (ConT b)
              dec = ValD (VarP (mkName "toFloating")) (NormalB (VarE (mkName f))) []
              f | a == b    = "id"
                | otherwise = "mkToFloating"
          in
          instanceD (return []) (return ty) [return dec]
    --
    as <- digItOut ''NumType
    bs <- digItOut ''FloatingType
    sequence [ thToFloating a b | a <- as, b <- bs ]
 )