{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
-- | 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 expected value
-- we can know if the persistened value is of the correct type.
--
-- The current implementation is not really a hash, but a string representation
-- of the type structure.
module Data.TypeHash where
import Data.Char(isAlpha)
import Control.Monad.State
import Data.Generics

-- | The type of a hashed type.
newtype TypeHash = TypeHash String
    deriving (Eq, Ord, Typeable, Data, Show, Read)

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

data Type
    = Name { typeName :: String }            -- Abstract type, or recursive reference
    | Data { typeName :: String, constrs :: [(String, [Field])] }
    deriving (Eq, Ord, Show)

type Field = (String, Type)  -- a "_" string 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, constrs = 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 ++ repeat "_"
        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