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)
newtype TypeCode = TypeCode Type
deriving (Eq, Ord, Typeable, Data, Show)
typeCode :: (Data a) => a -> TypeCode
typeCode = TypeCode . gType []
newtype TypeHash = TypeHash String
deriving (Eq, Ord, Typeable, Data, Show, Read, Binary)
typeHash :: (Data a) => a -> TypeHash
typeHash = TypeHash . show . md5 . pack . map (fromIntegral . fromEnum) . show . gType []
data Type
= Name { typeName :: String }
| Data { typeName :: String, dconstrs :: [Constructor] }
deriving (Eq, Ord, Show, Typeable, Data)
type Constructor = (String, [Field])
type Field = (String, Type)
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 }
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
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
data How = Iso | ReadShow | JSON
deriving (Eq)
convertibleIso :: TypeCode -> TypeCode -> Bool
convertibleIso (TypeCode t1) (TypeCode t2) = subType Iso [] t1 t2
convertibleWithReadShow :: TypeCode -> TypeCode -> Bool
convertibleWithReadShow (TypeCode t1) (TypeCode t2) = subType ReadShow [] t1 t2
convertibleWithJSON :: TypeCode -> TypeCode -> Bool
convertibleWithJSON (TypeCode t1) (TypeCode t2) = subType JSON [] t1 t2
type TypeNameMap = [(String, String)]
subType :: How -> TypeNameMap -> Type -> Type -> Bool
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 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 h r fs1 (f2, t2) = maybe False (\ t1 -> subType h r t1 t2) $ lookup f2 fs1