{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
module Data.Universe.Some.TH (
DeriveUniverseSome (..),
universeSomeQ,
) where
import Control.Monad (forM, mapM, unless)
import Data.Some (Some (..))
import Data.Universe.Class (Universe (..))
import Data.Universe.Some (UniverseSome (..))
import Data.Universe.Helpers (interleave, (<+*+>))
import Language.Haskell.TH
import Language.Haskell.TH.Datatype
class DeriveUniverseSome a where
deriveUniverseSome :: a -> DecsQ
instance DeriveUniverseSome a => DeriveUniverseSome [a] where
deriveUniverseSome a = fmap concat (mapM deriveUniverseSome a)
instance DeriveUniverseSome a => DeriveUniverseSome (Q a) where
deriveUniverseSome a = deriveUniverseSome =<< a
instance DeriveUniverseSome Name where
deriveUniverseSome name = do
di <- reifyDatatype name
let DatatypeInfo { datatypeContext = ctxt
, datatypeName = parentName
, datatypeVars = vars0
, datatypeVariant = variant
, datatypeCons = cons
} = di
case safeUnsnoc vars0 of
Nothing -> fail "Datatype should have at least one type variable"
Just (vars, var) -> do
varNames <- forM vars $ \v -> case v of
#if MIN_VERSION_template_haskell(2,8,0)
SigT (VarT n) StarT -> newName "x"
#else
SigT (VarT n) StarK -> newName "x"
#endif
_ -> fail "Only arguments of kind Type are supported"
#if MIN_VERSION_template_haskell(2,10,0)
let constrs :: [TypeQ]
constrs = map (\n -> conT ''Universe `appT` varT n) varNames
#else
let constrs :: [PredQ]
constrs = map (\n -> classP ''Universe [varT n]) varNames
#endif
let typ = foldl (\c n -> c `appT` varT n) (conT parentName) varNames
i <- instanceD (cxt constrs) (conT ''UniverseSome `appT` typ)
[ instanceDecFor di
]
return [i]
instanceDecFor :: DatatypeInfo -> Q Dec
instanceDecFor di = valD (varP 'universeSome) (normalB $ universeSomeQ' di) []
instance DeriveUniverseSome Dec where
#if MIN_VERSION_template_haskell(2,11,0)
deriveUniverseSome (InstanceD overlaps c classHead []) = do
let instanceFor = InstanceD overlaps c classHead
#else
deriveUniverseSome (InstanceD c classHead []) = do
let instanceFor = InstanceD c classHead
#endif
case classHead of
ConT u `AppT` t | u == ''UniverseSome -> do
name <- headOfType t
di <- reifyDatatype name
i <- fmap instanceFor $ mapM id
[ instanceDecFor di
]
return [i]
_ -> fail $ "deriveUniverseSome: expected an instance head like `UniverseSome (C a b ...)`, got " ++ show classHead
deriveUniverseSome _ = fail "deriveUniverseSome: expected an empty instance declaration"
universeSomeQ :: Name -> ExpQ
universeSomeQ name = reifyDatatype name >>= universeSomeQ'
universeSomeQ' :: DatatypeInfo -> Q Exp
universeSomeQ' di = do
let DatatypeInfo { datatypeContext = ctxt
, datatypeName = parentName
, datatypeVars = vars0
, datatypeVariant = variant
, datatypeCons = cons
} = di
unless (null ctxt) $ fail "Datatype context is not empty"
case safeUnsnoc vars0 of
Nothing -> fail "Datatype should have at least one type variable"
Just (vars, var) -> do
let universe' = [| universe |]
let uap = [| (<+*+>) |]
let interleave' = [| interleave |]
#if MIN_VERSION_dependent_sum(0,5,0)
let mapSome' = [| map Some |]
#else
let mapSome' = [| map This |]
#endif
let sums = map (universeForCon mapSome' universe' uap) cons
interleave' `appE` listE sums
where
universeForCon mapSome' universe' uap ci =
let con = listE [ conE (constructorName ci) ]
nargs = length (constructorFields ci)
conArgs = foldl (\f x -> infixE (Just f) uap (Just universe')) con (replicate nargs universe')
in mapSome' `appE` conArgs
headOfType :: Type -> Q Name
headOfType (AppT t _) = headOfType t
headOfType (VarT n) = return n
headOfType (ConT n) = return n
headOfType t = fail $ "headOfType: " ++ show t
safeUnsnoc :: [a] -> Maybe ([a], a)
safeUnsnoc xs = case reverse xs of
[] -> Nothing
(y:ys) -> Just (reverse ys, y)