module Type.Serialize.Base
(Serialize, encode, serializeType, serializeTypeAsHash, serializeTypeAsHash_) where
import Type.Spine.TH (tyConSignature)
import Type.Spine.Stage0 (kTypeG)
import Type.Digits (toDigits, toDigits_, fixed, flexible, exactly)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import qualified Data.Hash as H
import qualified Data.Serialize as V
import qualified Data.ByteString as BS
type family Serialize a
encode :: V.Serialize a => a -> Type
encode = toDigits_ (BS.foldl' ((. fixed) . (++)) []) . V.encode
serializeType :: Name -> Q [Dec]
serializeType n@(Name (occString -> occ)
(NameG _ (pkgString -> pkg) (modString -> mod))) = do
(ks, k) <- tyConSignature n
let qk = kTypeG $ foldr ArrowK k ks
uid = (occ, mod, pkg)
base128 = return .
toDigits (exactly 3 . take 3 . flexible) (H.asWord64 $ H.hash uid) .
encode $ uid
(:[]) `fmap` tySynInstD ''Serialize [qk `appT` conT n] base128
serializeType n = fail $ "serializeType expects a global name: " ++ show n
serializeTypeAsHash :: Name -> Q [Dec]
serializeTypeAsHash n = do
(ks, k) <- tyConSignature n
serializeTypeAsHash_ n ks k
serializeTypeAsHash_ :: Name -> [Kind] -> Kind -> Q [Dec]
serializeTypeAsHash_ n@(Name (occString -> occ)
(NameG _ (pkgString -> pkg) (modString -> mod))) ks k = do
let qk = kTypeG $ foldr ArrowK k ks
uid = (occ, mod, pkg)
base128 = return . toDigits_ flexible . H.asWord64 . H.hash $ uid
(:[]) `fmap` tySynInstD ''Serialize [qk `appT` conT n] base128
serializeTypeAsHash_ n _ _ = fail $ "serializeTypeAsHash expects a global name: " ++ show n
tvb_kind (PlainTV _) = StarK
tvb_kind (KindedTV _ k) = k