Base.hs

{-# LANGUAGE TemplateHaskell, TypeFamilies, ViewPatterns #-}

{- |

Module      :  Type.Serialize.Base
Copyright   :  (c) The University of Kansas 2011
License     :  BSD3

Maintainer  :  nicolas.frisby@gmail.com
Stability   :  experimental
Portability :  see LANGUAGE pragmas (... GHC)

Type-level serialization (i.e. type -> @type-digit@ type-level numeral).

-}
module Type.Serialize.Base
  (Serialize, encode, serializeType, 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




-- | @Serialize@ maps a type to its unique type-level serialization.
type family Serialize a

-- | Encode uses the @cereal@ package serializer to encode the value and then
-- uses @type-digits@ to reflect it as a type-level numeral.
encode :: V.Serialize a => a -> Type
encode = toDigits_ (BS.foldl' ((. fixed) . (++)) []) . V.encode

-- | Generates the @Serialize@ instance corresponding to the serialization of
-- the type constructor's globally unique name (i.e. TH's @NameG@).
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@ can result in very large types, so we prefer the
-- @data-hash@ hash of the @NameG@'s serialization.
serializeTypeAsHash :: Name -> Q [Dec]
serializeTypeAsHash 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_ flexible . H.asWord64 . H.hash $ uid
  (:[]) `fmap` tySynInstD ''Serialize [qk `appT` conT n] base128

tvb_kind (PlainTV _) = StarK
tvb_kind (KindedTV _ k) = k