Base.hs

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

{- |

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 where

import Type.Digits (Digit, 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 :: k) :: Digit

-- | 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_data :: Name -> Q [Dec]
serializeType_data = serializeType_ ConT

serializeType_pro :: Name -> Q [Dec]
serializeType_pro = serializeType_ PromotedT

serializeType_ inj n@(Name (occString -> occ)
                     (NameG _ (pkgString -> pkg) (modString -> mod))) =
  let uid = (occ, mod, pkg)
      base128 = toDigits (exactly 3 . take 3 . flexible) (H.asWord64 $ H.hash uid) .
                encode $ uid
  in return [TySynInstD ''Serialize [inj n] base128]
serializeType_ _ n = fail $ "serializeType expects a global name: " ++ show n

-- | @serializeType@ can result in very large types, so we prefer the
-- @data-hash@ hash of the @NameG@'s serialization.
serializeTypeAsHash_data :: Name -> Q [Dec]
serializeTypeAsHash_data = serializeTypeAsHash_ ConT

serializeTypeAsHash_pro :: Name -> Q [Dec]
serializeTypeAsHash_pro = serializeTypeAsHash_ PromotedT

serializeTypeAsHash_ inj n@(Name (occString -> occ)
                (NameG _ (pkgString -> pkg) (modString -> mod))) =
  let uid = (occ, mod, pkg)
      base128 = toDigits_ flexible . H.asWord64 . H.hash $ uid
  in return [TySynInstD ''Serialize [inj n] base128]
serializeTypeAsHash_ _ n = fail $ "serializeTypeAsHash expects a global name: " ++ show n