49 lines
1.3 KiB
Haskell
49 lines
1.3 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
|
|
module CryptoID.TH where
|
|
|
|
import ClassyPrelude
|
|
|
|
import Language.Haskell.TH
|
|
|
|
import Data.CryptoID.Class.ImplicitNamespace
|
|
import Data.UUID.Types (UUID)
|
|
import Data.Binary (Binary(..))
|
|
import Data.Binary.SerializationLength
|
|
|
|
import Data.CaseInsensitive (CI)
|
|
import System.FilePath (FilePath)
|
|
|
|
import Database.Persist.Sql (toSqlKey, fromSqlKey)
|
|
|
|
|
|
decCryptoIDs :: [Name] -> DecsQ
|
|
decCryptoIDs = fmap concat . mapM decCryptoID
|
|
where
|
|
decCryptoID :: Name -> DecsQ
|
|
decCryptoID n@(conT -> t) = do
|
|
instances <- [d|
|
|
instance Binary $(t) where
|
|
get = $(varE 'toSqlKey) <$> get
|
|
put = put . $(varE 'fromSqlKey)
|
|
instance HasFixedSerializationLength $(t) where
|
|
type SerializationLength $(t) = SerializationLength Int64
|
|
|
|
type instance CryptoIDNamespace a $(t) = $(litT $ strTyLit ns)
|
|
|]
|
|
|
|
synonyms <- mapM cryptoIDSyn
|
|
[ (ConT ''UUID, "UUID")
|
|
, (ConT ''CI `AppT` ConT ''FilePath, "FileName")
|
|
]
|
|
|
|
return $ concat
|
|
[ instances
|
|
, synonyms
|
|
]
|
|
where
|
|
ns = (\nb -> fromMaybe nb $ stripSuffix "Id" nb) $ nameBase n
|
|
cryptoIDSyn (ct, str) = tySynD (mkName $ "Crypto" ++ str ++ ns) [] $ conT ''CryptoID `appT` return ct `appT` t
|