{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- Reifying a data type:
-- representing a data type as a graph term
-- We present a general data type reification using Data.Data,
-- which is at the core of the generic programming framework SYB.
-- Data.Data and the related Data.Typeable are part of the GHC base.
-- As an illustration of our approach we answer
-- Wadler's and Clayden's questions.
module TypeReflFull where
import Data.Data
import System.Time (Month(..)) -- used in Anthony Clayden's question
import Prelude hiding (succ)
-- In this general problem, we are not given any value of the type
-- to reify. For an algebraic data type, we have to find out
-- all its variants, that is, all its constructors, and their
-- arguments. Finding out the arguments of a data constructor
-- is a challenge: Data.Data offers no built-in facility for that
-- purpose.
-- First, we convert a type to a tree that describes it
-- Actually, it is a graph because the type can be recursive.
data TRepTree = TData TRep [TCon] | BackRef TypeRep
deriving Show
-- (shallow) description of a data type
data TRep = forall a. Data a => TRep a
instance Show TRep where
-- show (TRep x) = show . dataTypeName . dataTypeOf $ x
show (TRep x) = show . typeOf $ x
-- A description of a data constructor, with all its arguments.
-- We stress that Data.Data.Constr tells only the name (and the index)
-- of a data constructor -- but not its arguments.
data TCon = TCon Constr [TRepTree] -- a data constructor and its args
deriving Show
-- gunfold needs the type constructor defining the context of
-- unfolding. We use two such constructors below: CCList for
-- determining the arguments of a constructor and CTTree for
-- determining the graph of a data type
newtype CTTree a = CTTree TRepTree deriving Show
newtype CCList a = CCList [TRepTree] deriving Show
-- To detect loops, we keep track of the types we have already seen
type SeenTypes = [TypeRep]
-- The user may wish to treat certain types as primitives and
-- avoid traversing them
type IgnoreTypes = [TypeRep]
describe_ctor :: Data a => IgnoreTypes -> SeenTypes -> Constr -> CCList a
describe_ctor ignore seen = gunfold branch empty
where
branch :: forall r b. Data b => CCList (b -> r) -> CCList r
branch (CCList n) = let CTTree n1 = describe_type' ignore seen :: CTTree b
in CCList (n1:n)
empty :: r -> CCList r
empty _ = CCList [] -- Leaf of the type tree
describe_type' :: forall a. Data a => IgnoreTypes -> SeenTypes -> CTTree a
describe_type' ignore seen = check seen (typeOf (undefined::a))
where
check seen trep | trep `elem` ignore = CTTree (TData (TRep (undefined::a)) [])
check seen trep | trep `elem` seen = CTTree (BackRef trep)
check seen trep =
CTTree (TData (TRep (undefined::a)) $
map (make_tcon (trep:seen)) (ctors (undefined :: a)))
ctors :: forall a. Data a => a -> [Constr] -- all constructors of a data type
ctors x = let dt = dataTypeOf x
in case dataTypeRep dt of
(AlgRep ctrs) -> ctrs
_ -> []
make_tcon seen ctor =
let CCList lst = describe_ctor ignore seen ctor :: CCList a in
TCon ctor (reverse lst)
describe_type :: forall a. Data a => IgnoreTypes -> a -> TRepTree
describe_type ignore _ = tree
where
CTTree tree = describe_type' ignore [] :: CTTree a
-- ------------------------------------------------------------------------
-- Tests
t1 = describe_type [] ([] :: [(Maybe Char, Bool)])
{-
TData [((Maybe Char),Bool)]
[TCon [] [],
TCon (:)
[TData ((Maybe Char),Bool)
[TCon (,)
[TData Maybe Char [TCon Nothing [], TCon Just [TData Char []]],
TData Bool [TCon False [],TCon True []]]],
BackRef [((Maybe Char),Bool)]]]
-}
t2 = describe_type [] (Left (1,True):: Either (Int,Bool) String)
{-
TData Either (Int,Bool) [Char]
[TCon Left
[TData (Int,Bool) [TCon (,) [TData Int [],
TData Bool [TCon False [],TCon True []]]]],
TCon Right [TData [Char] [TCon [] [],
TCon (:) [TData Char [],BackRef [Char]]]]]
-}
-- Now we treat String as primitive
t2' = describe_type [typeOf ""] (Left (1,True):: Either (Int,Bool) String)
{-
TData Either (Int,Bool) [Char]
[TCon Left
[TData (Int,Bool) [TCon (,) [TData Int [],
TData Bool [TCon False [],TCon True []]]]],
TCon Right [TData [Char] []]]
-}
-- ------------------------------------------------------------------------
-- Answering Wadler's question
-- Philip Wadler (in Aug 2011) has posed a question about type introspection
-- ``whether the information about types could be turned into a graph
-- and manipulated as such''
-- Specifically:
-- Given a type, does it contain any substructures of recursive type?
-- Given a type, if it is not recursive, what is it's maximum depth?
-- (E.g., Pair Int (Either Int Int) has depth 3.)
-- This file shows that the questions can be answered using SYB,
-- specifically, Data.Data.
-- We show the code that computes the depth of a data type
-- and a depth of the specific variant of a data type.
-- The code works for all types for which Data.Data instance exist.
-- For recursive types, the code reports the infinite depth.
-- Sample data types
data Pair a b = Pair a b deriving Data
deriving instance Typeable2 Pair
-- Non-recursive data type
data T1 = T1 (Pair Int (Either Int Int))
deriving (Typeable, Data)
-- Recursive data type
data T2 = F1 T1 | F2 (Pair T1 [T1]) | F3 (Pair T1 T2)
deriving (Typeable, Data)
tt1 = describe_type [] (undefined::T1)
{-
TData T1 [TCon T1 [TData Pair Int (Either Int Int)
[TCon Pair
[TData Int [],
TData Either Int Int [TCon Left [TData Int []],
TCon Right [TData Int []]]]]]]
-}
-- An Int with the positive Infinity
data IntW = Infinity | I Int deriving (Eq, Show)
instance Ord IntW where
compare Infinity Infinity = EQ
compare Infinity x = GT
compare x Infinity = LT
compare (I x) (I y) = compare x y
succ :: IntW -> IntW
succ Infinity = Infinity
succ (I x) = I (x+1)
depth_type :: Data a => IgnoreTypes -> a -> IntW
depth_type ignore x = traverse (describe_type ignore x)
where
traverse (TData _ ctors) = succ $ maximum' (map depth_ctor ctors)
traverse (BackRef _) = Infinity
depth_ctor (TCon _ args) = maximum' (map traverse args)
maximum' [] = I 0
maximum' lst = maximum lst
td1 = depth_type [] $ T1 (Pair 1 (Left 2))
-- I 4
td2 = depth_type [] (undefined::T1)
-- I 4
td21 = depth_type [] (Nothing:: Maybe T1)
-- I 5
td22 = depth_type [] (undefined:: (T1, Maybe T1))
-- I 6
td23 = depth_type [] (undefined:: ((Int,T1), Maybe T1))
-- I 6
td24 = depth_type [] (undefined:: ((Int,T1), [T1]))
-- Infinity (List is a recursive data type)
-- depth_type [] $ (F2 (Pair (T1 (Pair 1 (Left 2))) []))
-- (I 6)
td3 = depth_type [] (undefined::T2)
-- Infinity
td4 = depth_type [typeOf (undefined::[T1]), typeOf (undefined::(Pair T1 T2))]
(undefined::T2)
-- I 6
-- ------------------------------------------------------------------------
-- Another example of (data)type introspection
-- Anthony Clayden (Oct-Nov 2013) posed a question of describing
-- all newtypes within a complex data type. A newtype is defined
-- as an algebraic data type with exactly one variant whose
-- data constructor has exactly one argument.
-- Sample newtypes
-- (The application area is databases)
newtype Name = Name String
deriving (Typeable, Data)
newtype Age = AgeD Int
deriving (Typeable, Data)
newtype Salary a = SalaryD (Maybe a)
deriving (Typeable, Data)
newtype Birthday = BD (Int,Month,Int)
deriving (Typeable, Data)
deriving instance Data Month
deriving instance Typeable Month
type DBType = [(Name,Age,Birthday,Salary Float)]
-- tests
tdb1 = describe_type [] (undefined::Name)
{-
TData Name [TCon Name [TData [Char] [TCon [] [],TCon (:) [TData Char [],BackRef [Char]]]]]
-}
-- Treat String as a primitive type
tdb1' = describe_type [typeOf (undefined::String)] (undefined::Name)
{-
TData Name [TCon Name [TData [Char] []]]
-}
tdb2 = describe_type [] ([] :: [Age])
{-
TData [Age] [TCon [] [],
TCon (:) [TData Age [TCon AgeD [TData Int []]],BackRef [Age]]]
-}
-- pretty-printing is left as an exercise to the reader
-- Now we can solve Anthony Clayden: pick up all newtype descriptions
-- The first component describes the type of the newtype,
-- the second, the data constructor, and the third -- the type
-- of the argument
type NTDescription = (TypeRep,Constr,TypeRep)
-- The first argument may be undefined
newtypes_of :: Data a => a -> [NTDescription]
newtypes_of x = go (describe_type [] x)
where
go (BackRef _) = []
go (TData t [TCon ctor [arg]]) = [(trep t,ctor,tdata arg)]
go (TData _ ctors) = concatMap go_con ctors
go_con (TCon _ args) = concatMap go args
trep (TRep x) = typeOf x
tdata (BackRef x) = x
tdata (TData t _) = trep t
nt1 = newtypes_of (undefined::Age)
-- [(Age,AgeD,Int)]
nt2 = newtypes_of (undefined::[Age])
-- [(Age,AgeD,Int)]
nt3 = newtypes_of ([]::[Name])
-- [(Name,Name,[Char])]
nd = newtypes_of ([]::DBType)
{-
[(Name,Name,[Char]),(Age,AgeD,Int),
(Birthday,BD,(Int,Month,Int)),(Salary Float,SalaryD,Maybe Float)]
-}
-- How to cut the traversal of a data type
-- and so permit the result of newtypes_of to be itself
-- examinable (subject to newtypes_of).
-- This self-reflection is higly desirable if we use
-- types to represent data base schemas. Because a data base
-- schema should itself be a relation.
{-
Anthony Clayden cited:
From: http://en.wikipedia.org/wiki/Codd%27s_12_rules
Rule 4: Active online catalog based on the relational model:
"The system must support an online, inline, relational catalog that is
accessible to authorized users by means of their regular query
language. That is, users must be able to access the database's
structure (catalog) using the same query language that they use to
access the database's data."
-}
data DTM a = DontTraverseMe a | Nada deriving (Show)
-- The argument of DTM doesn't have to be Typeable
instance Typeable (DTM a) where
typeOf _ = mkTyConApp (mkTyCon3 "" "TypeReflFull" "DTM") []
-- There is no requirement that the argument of DontTraverseMe
-- must be an instance of Data
instance Data (DTM a) where
gfoldl k z x = z x -- the default implementation
gunfold k z c = z Nada
dataTypeOf _ = mkNoRepType "DTM"
toConstr = error "nobody should call this for NoRep data type"
newtype AttrType a = AttrType a deriving (Data, Show, Typeable)
newtype AttrCtor a = AttrCtor a deriving (Data, Show, Typeable)
newtype AttrRepr a = AttrRepr a deriving (Data, Show, Typeable)
nd1 = map (\ (x,y,z) -> (AttrType $ DontTraverseMe x,
AttrCtor $ DontTraverseMe y,
AttrRepr $ DontTraverseMe z))
(newtypes_of ([] :: DBType))
-- now, the result of newtypes_of, nd1, can itself be examined.
ndd = newtypes_of ([] `asTypeOf` nd1)
{-
[(AttrType DTM,AttrType,DTM),
(AttrCtor DTM,AttrCtor,DTM),(AttrRepr DTM,AttrRepr,DTM)]
-}