{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
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 ( ($), error, concat )
class ToFloating a b where
toFloating :: (Num a, Floating b) => Exp a -> Exp b
$(runQ $ do
let
digItOut :: Name -> Q [Name]
digItOut name = do
#if __GLASGOW_HASKELL__ < 800
TyConI (DataD _ _ _ cons _) <- reify name
#else
TyConI (DataD _ _ _ _ cons _) <- reify name
#endif
let
dig (NormalC _ [(_, AppT (ConT n) (VarT _))]) = digItOut n
#if __GLASGOW_HASKELL__ < 800
dig (ForallC _ _ (NormalC _ [(_, AppT (ConT _) (ConT n))])) = return [n]
#else
dig (GadtC _ _ (AppT (ConT _) (ConT n))) = return [n]
#endif
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 "mkToFloating"))) []
in
instanceD (return []) (return ty) [return dec]
as <- digItOut ''NumType
bs <- digItOut ''FloatingType
sequence [ thToFloating a b | a <- as, b <- bs ]
)