TypeHash.hs

{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
-- | Produce a /hash/ for a type that is unique for that type.
-- The hash takes both actual type names and type structure into account.
--
-- The purpose of the hash of a type is to be able to store the type
-- of a persisted value together with the value.
-- By comparing the type hash of a persisted value and the hash of expected type
-- we can know if the persistened value is of the correct type.
--
-- The type hash uses a cryptographic hash and can only be used to test equality.
--
-- The type code preserves the exact structure of the type and can be used to
-- check if one type is convertible to another in various ways.
-- 
-- This module uses the reflection offered by 'Typeable' and 'Data' to extract
-- the information.
module Data.TypeHash(TypeCode, typeCode,
		     convertibleIso, convertibleWithReadShow, convertibleWithJSON,
                     TypeHash, typeHash) where
import Data.Char(isAlpha)
import Control.Monad.State
import Data.Generics
import Data.Binary
import Data.Digest.Pure.MD5(MD5Digest, md5)
import Data.ByteString.Lazy(pack)

--import Debug.Trace

-- | Type codes.
newtype TypeCode = TypeCode Type
    deriving (Eq, Ord, Typeable, Data, Show)

-- | Turn the type of the value into a type code.
typeCode :: (Data a) => a -> TypeCode
typeCode = TypeCode . gType []

-- | Type hash.
newtype TypeHash = TypeHash String
    deriving (Eq, Ord, Typeable, Data, Show, Read, Binary)

-- | Turn the type of the value into a type hash.
typeHash :: (Data a) => a -> TypeHash
typeHash = TypeHash . show . md5 . pack . map (fromIntegral . fromEnum) . show . gType []

data Type
    = Name { typeName :: String }            -- Abstract type, or recursive reference
    | Data { typeName :: String, dconstrs :: [Constructor] }
    deriving (Eq, Ord, Show, Typeable, Data)
type Constructor = (String, [Field])
type Field = (String, Type)  -- a unique number is used for missing field names

gType :: (Data a) => [String] -> a -> Type
gType tns x =
    let tn = show $ fullTypeOf x
    in  case dataTypeRep $ dataTypeOf x of
        AlgRep cs | tn `notElem` tns ->
             Data { typeName = tn, dconstrs = map (gConstr (tn:tns) x) cs }
        _ -> Name { typeName = tn } -- Use type name for truly abstract types and recursive types.

gConstr :: (Data a) => [String] -> a -> Constr -> (String, [Field])
gConstr tns x c = (showConstr c,
                   zip fs (reverse $ execState (fromConstrM f c `asTypeOf` return x) []))
  where fs = constrFields c ++ [ show i | i <- [0::Int ..] ]
        f :: forall d . (Data d) => State [Type] d
        f = do modify (gType tns (undefined :: d) :); return undefined

-- Replace unqualified type name by qualified type name.
-- XXX Only does it on the top level, because I don't know how to get deeper.
fullTypeOf :: (Data a) => a -> TypeRep
fullTypeOf a | not $ isAlpha $ head $ tyConString $ typeRepTyCon $ ta = ta
	     | otherwise = mkTyConApp (mkTyCon $ dataTypeName $ dataTypeOf a)
                                      (typeRepArgs ta)
  where ta = typeOf a

------------

-- Check if a type is upwards compatible with another type, i.e., if it is a subtype.
-- S is a subtype of T if
--  S has the same or more constructors than T.  Constructor order does not matter,
--    but the constructor arguments must be subtypes again.
--  If S and T both have a single constructor, their names may differ.
--  A constructor with fields is a subtype if it has fewer or the same fields.
--    Field order does not matter, but the field types must be subtypes again.
--  Only the names of (concrete) types have changed.
--
-- These are mostly what you'd expect from sums and products.
--

data How = Iso | ReadShow | JSON
    deriving (Eq)

-- | Are the types strongly isomorphic, only allows change of type names.
convertibleIso :: TypeCode -> TypeCode -> Bool
convertibleIso (TypeCode t1) (TypeCode t2) = subType Iso [] t1 t2

-- | Can @read . show@ convert the first type to the second?
-- Allows changing type names,
-- allows permuting and\/or adding constructors to the new type,
-- also allows permuting named fields of a constructor.
convertibleWithReadShow :: TypeCode -> TypeCode -> Bool
convertibleWithReadShow (TypeCode t1) (TypeCode t2) = subType ReadShow [] t1 t2

-- | Can the generic JSON serializer and deserializer convert the first type to the second.
-- Allows changing type names,
-- allows permuting and\/or adding constructors to the new type,
-- also allows permuting and\/or deleting named fields of a constructor.
-- Furhermore, allows types with a single constructor to change constructor name.
convertibleWithJSON :: TypeCode -> TypeCode -> Bool
convertibleWithJSON (TypeCode t1) (TypeCode t2) = subType JSON [] t1 t2

type TypeNameMap = [(String, String)]

subType :: How -> TypeNameMap -> Type -> Type -> Bool
--subType r t1 t2 | trace ("subtype " ++ show (r, t1, t2)) False = undefined
subType h    r (Name n1)            (Name n2)           = maybe (n1 == n2) (== n2) $ lookup n1 r
subType _    _ (Name {})            (Data {})           = False
subType _    _ (Data {})            (Name {})           = False
subType Iso  r (Data n1 cs1)        (Data n2 cs2)       = isoConstructor ((n1, n2):r) cs1 cs2
subType JSON r (Data n1 [(_, fs1)]) (Data n2 [(_,fs2)]) = all (subField JSON ((n1, n2):r) fs1) fs2
subType h    r (Data n1 cs1)        (Data n2 cs2)       = all (subConstructor h ((n1, n2):r) cs2) cs1

subConstructor :: How -> TypeNameMap -> [Constructor] -> Constructor -> Bool
--subConstructor _ r cs2 c1 | trace ("subConstructor " ++ show (c1, cs2)) False = undefined
subConstructor h r cs2 (n1, fs1) =
    maybe False (\ fs2 -> (h==JSON || length fs1==length fs2) && all (subField h r fs1) fs2) $
    lookup n1 cs2

isoConstructor :: TypeNameMap -> [Constructor] -> [Constructor] -> Bool
isoConstructor r cs1 cs2 = length cs1 == length cs2 &&
    and (zipWith (\ (c1, fs1) (c2, fs2) -> c1 == c2 && length fs1 == length fs2 &&
    		  and (zipWith (\ (f1, t1) (f2, t2) -> f1 == f2 && subType Iso r t1 t2) fs1 fs2))
		 cs1 cs2)
    

subField :: How -> TypeNameMap -> [Field] -> Field -> Bool
--subField _ r fs1 f | trace ("subField " ++ show (f, fs1)) False = undefined
subField h r fs1 (f2, t2) = maybe False (\ t1 -> subType h r t1 t2) $ lookup f2 fs1