1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}
# if __GLASGOW_HASKELL__ <= 708
{-# LANGUAGE OverlappingInstances #-}
#endif
module GetC (tests) where
import Test.Tasty.HUnit
{-
Ralf Laemmel, 5 November 2004
Joe Stoy suggested the idiom to test for the outermost constructor.
Given is a term t
and a constructor f (say the empty constructor application).
isC f t returns True if the outermost constructor of t is f.
isC f t returns False otherwise.
Modulo type checking, i.e., the data type of f and t must be the same.
If not, we want to see a type error, of course.
-}
import Data.Typeable -- to cast t's subterms, which will be reused for f.
import Data.Generics -- to access t's subterms and constructors.
-- Some silly data types
data T1 = T1a Int String | T1b String Int deriving (Typeable, Data)
data T2 = T2a Int Int | T2b String String deriving (Typeable, Data)
data T3 = T3 !Int deriving (Typeable, Data)
-- Test cases
tests = show [ isC T1a (T1a 1 "foo") -- typechecks, returns True
, isC T1a (T1b "foo" 1) -- typechecks, returns False
, isC T3 (T3 42)] -- works for strict data too
@=? output
-- err = show $ isC T2b (T1b "foo" 1) -- must not typecheck
output = show [True,False,True]
--
-- We look at a datum a.
-- We look at a constructor function f.
-- The class GetT checks that f constructs data of type a.
-- The class GetC computes maybe the constructor ...
-- ... if the subterms of the datum at hand fit for f.
-- Finally we compare the constructors.
--
isC :: (Data a, GetT f a, GetC f) => f -> a -> Bool
isC f t = maybe False ((==) (toConstr t)) con
where
kids = gmapQ ExTypeable t -- homogenify subterms in list for reuse
con = getC f kids -- compute constructor from constructor application
--
-- We prepare for a list of kids using existential envelopes.
-- We could also just operate on TypeReps for non-strict datatypes.
--
data ExTypeable = forall a. Typeable a => ExTypeable a
unExTypeable (ExTypeable a) = cast a
--
-- Compute the result type of a function type.
-- Beware: the TypeUnify constraint causes headache.
-- We can't have GetT t t because the FD will be violated then.
-- We can't omit the FD because unresolvable overlapping will hold then.
--
class GetT f t | f -> t -- FD is optional
instance GetT g t => GetT (x -> g) t
instance {-# OVERLAPPABLE #-} TypeUnify t t' => GetT t t'
--
-- Obtain the constructor if term can be completed
--
class GetC f
where
getC :: f -> [ExTypeable] -> Maybe Constr
instance (Typeable x, GetC g) => GetC (x -> g)
where
getC _ [] = Nothing
getC (f::x->g) (h:t)
=
do
(x::x) <- unExTypeable h
getC (f x) t
instance {-# OVERLAPPABLE #-} Data t => GetC t
where
getC y [] = Just $ toConstr y
getC _ (_:_) = Nothing
--
-- Type unification; we could try this:
-- class TypeUnify a b | a -> b, b -> a
-- instance TypeUnify a a
--
-- However, if the instance is placed in the present module,
-- then type improvement would inline this instance. Sigh!!!
--
-- So we need type unification with type improvement blocker
-- The following solution works with GHC for ages.
-- Other solutions; see the HList paper.
--
class TypeUnify a b | a -> b, b -> a
class TypeUnify' x a b | x a -> b, x b -> a
class TypeUnify'' x a b | x a -> b, x b -> a
instance TypeUnify' () a b => TypeUnify a b
instance TypeUnify'' x a b => TypeUnify' x a b
instance TypeUnify'' () a a
|
