diff --git a/src/Data/TypeHash.hs b/src/Data/TypeHash.hs --- a/src/Data/TypeHash.hs +++ b/src/Data/TypeHash.hs @@ -4,16 +4,19 @@ -- -- 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 expected 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 a subtype of another. If one type is a subtype of --- another it means that, e.g., @read . show@ will correctly between the types. --- (Caveat @read . show@ is only guaranteed to work with named fields.) +-- check if one type is convertible to another in various ways. -- --- The type hash uses a cryptographic hash and can only be used to test equality. -module Data.TypeHash(TypeCode, typeCode, convertibleTo, TypeHash, typeHash) where +-- 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 @@ -50,8 +53,8 @@ let tn = show $ fullTypeOf x in case dataTypeRep $ dataTypeOf x of AlgRep cs | tn `notElem` tns -> - Data { typeName = tn, constrs = map (gConstr (tn:tns) x) cs } - _ -> Name { typeName = tn } -- Use type name for tryly abstract types. + Data { typeName = tn, constrs = 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, @@ -81,25 +84,53 @@ -- -- These are mostly what you'd expect from sums and products. -- --- | Is the first type (code) as subtype of the second, i.e., --- can the first type be converted to the second. -convertibleTo :: TypeCode -> TypeCode -> Bool -convertibleTo (TypeCode t1) (TypeCode t2) = subType [] t1 t2 +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 :: TypeNameMap -> Type -> Type -> Bool +subType :: How -> TypeNameMap -> Type -> Type -> Bool --subType r t1 t2 | trace ("subtype " ++ show (r, t1, t2)) False = undefined -subType r (Name n1) (Name n2) = maybe (n1 == n2) (== n2) $ lookup n1 r -subType _ (Name {}) (Data {}) = False -subType _ (Data {}) (Name {}) = False -subType r (Data n1 [(_, fs1)]) (Data n2 [(_,fs2)]) = all (subField ((n1, n2):r) fs1) fs2 -subType r (Data n1 cs1) (Data n2 cs2) = all (subConstructor ((n1, n2):r) cs2) cs1 +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 :: TypeNameMap -> [Constructor] -> Constructor -> Bool ---subConstructor r cs2 c1 | trace ("subConstructor " ++ show (c1, cs2)) False = undefined -subConstructor r cs2 (n1, fs1) = maybe False (all (subField r fs1)) $ lookup n1 cs2 +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 -subField :: TypeNameMap -> [Field] -> Field -> Bool ---subField r fs1 f | trace ("subField " ++ show (f, fs1)) False = undefined -subField r fs1 (f2, t2) = maybe False (\ t1 -> subType r t1 t2) $ lookup f2 fs1 +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 diff --git a/typehash.cabal b/typehash.cabal --- a/typehash.cabal +++ b/typehash.cabal @@ -1,5 +1,5 @@ Name: typehash -Version: 1.2.0.0 +Version: 1.3.0.0 License: BSD3 Author: Lennart Augustsson Maintainer: Lennart Augustsson @@ -11,5 +11,5 @@ The hash takes both actual type names and type structure into account. This is useful for checking the type of persisted values. Hs-Source-Dirs: src -Build-Depends: base, mtl, bytestring, pureMD5 +Build-Depends: base < 4, mtl, bytestring, pureMD5 Exposed-modules: Data.TypeHash