module Data.Radius.Attribute.TH (
unsafeTypedNumberSetTemplate,
) where
import Control.Applicative ((<$>), pure)
import Data.Char (toLower)
import qualified Data.Set as Set
import Language.Haskell.TH
(Name, nameBase, mkName, Q, Type, Exp, Dec,
sigD, valD, varP, normalB, conE, varE, listE)
import Data.Radius.Attribute.Pair
(TypedNumber, unsafeTypedNumber, TypedNumberSet)
varNameFromDCon :: Name -> Name
varNameFromDCon = mkName . d . nameBase where
d (c:cs) = toLower c : cs
d [] = []
unsafeTypedNumberTemplate :: Maybe (Q Type) -> Q Type -> Q Exp -> Name -> Q ([Dec], Name)
unsafeTypedNumberTemplate mayVsaType valueType abstConE conName = do
let varName = varNameFromDCon conName
sig <- sigD varName $
maybe
[t| forall a . Ord a => TypedNumber a $valueType |]
(\vsaTy -> [t| TypedNumber $vsaTy $valueType |])
mayVsaType
val <- valD
(varP varName)
(normalB [| unsafeTypedNumber ($abstConE $(conE conName)) |])
[]
pure ([sig, val], varName)
unsafeTypedNumberSetTemplate :: String
-> Maybe (Q Type)
-> Q Type
-> [(Q Exp, [Name])]
-> Q [Dec]
unsafeTypedNumberSetTemplate setVarStr mayVsaType valueType conPairs = do
decPairs <-
concat <$> sequence
[ mapM (unsafeTypedNumberTemplate mayVsaType valueType abstConE) conNames
| (abstConE, conNames) <- conPairs]
let setVarName = mkName setVarStr
setSig <- sigD setVarName $
maybe
[t| forall a . Ord a => TypedNumberSet a $(valueType) |]
(\vsaTy -> [t| TypedNumberSet $vsaTy $(valueType) |])
mayVsaType
setVal <- valD
(varP setVarName)
(normalB [| Set.fromList $(listE [varE n | (_, n) <- decPairs]) |])
[]
pure $ setSig : setVal : concat [ decs | (decs, _) <- decPairs ]