typehash 1.2.0.0 → 1.3.0.0
raw patch · 2 files changed
+57/−26 lines, 2 filesdep ~base
Dependency ranges changed: base
Files
- src/Data/TypeHash.hs +55/−24
- typehash.cabal +2/−2
src/Data/TypeHash.hs view
@@ -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
typehash.cabal view
@@ -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