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
|
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
UndecidableInstances, ExistentialQuantification,
ScopedTypeVariables #-}
-- TypeVal.hs: dependent types, here we come!
module TypeVal where
-- The functional dependency is necessary to get ghc to accept
-- some of the instances below. Is this a bug?
class TypeVal a t | t -> a where
-- typeToVal should ignore its argument.
typeToVal :: t -> a
data Wrapper a = forall t . (TypeVal a t) => Wrapper t
instance Show a => Show (Wrapper a) where
show x = "valToType " ++ show (getValue x)
class ValToType a where
valToType :: a -> Wrapper a
getValue :: Wrapper a -> a
getValue (Wrapper p) = case p of {(_::t) -> typeToVal (undefined::t)}
-- Instances of ValToType for standard types. This would also be a
-- straightforward compiler extension for the general case.
---- ValToType Bool
data TRUE = Dummy1
instance TypeVal Bool TRUE where typeToVal = const True
data FALSE = Dummy2
instance TypeVal Bool FALSE where typeToVal = const False
instance ValToType Bool where
valToType True = Wrapper (undefined :: TRUE)
valToType False = Wrapper (undefined :: FALSE)
---- ValToType Int, ValToType Integer
data Zero = Dummy3
instance TypeVal Integer Zero where typeToVal = const 0
data Succ n = Dummy4
instance (TypeVal Integer n) => TypeVal Integer (Succ n)
where typeToVal = const (typeToVal (undefined :: n) + 1)
data Pred n = Dummy5
instance (TypeVal Integer n) => TypeVal Integer (Pred n)
where typeToVal = const (typeToVal (undefined :: n) - 1)
data Dbl n = Dummy6
instance (TypeVal Integer n) => TypeVal Integer (Dbl n)
where typeToVal = const (typeToVal (undefined :: n) * 2)
instance ValToType Integer where
valToType n | n == 0 = Wrapper (undefined :: Zero)
| even n =
case valToType (div n 2) of {Wrapper x ->
case x of {(_ :: t) ->
Wrapper (undefined :: Dbl t)}}
| n > 0 =
case valToType (n-1) of {Wrapper x ->
case x of {(_ :: t) ->
Wrapper (undefined :: Succ t)}}
| n < 1 =
case valToType (n+1) of {Wrapper x ->
case x of {(_ :: t) ->
Wrapper (undefined :: Pred t)}}
--- ValToType (a,b)
--- Doesn't work. Perhaps a bug in ghc?
--- Don't need it yet, anyway.
--instance (TypeVal a1 t1, TypeVal a2 t2) => TypeVal (a1,a2) (t1,t2)
-- where typeToVal (x,y) = (typeToVal x, typeToVal y)
--instance (ValToType a, ValToType b) => ValToType (a,b) where
-- valToType (a,b) = case valToType a of {x ->
-- case valToType b of {y ->
-- Wrapper (x,y)}}
data NIL a = Dummy20
instance TypeVal [a] (NIL a)
where typeToVal = const []
data CONS t r = Dummy21
instance (TypeVal [a] r, TypeVal a t) => TypeVal [a] (CONS t r)
where typeToVal = const (typeToVal (undefined::t):typeToVal (undefined::r))
instance (ValToType a) => ValToType [a] where
valToType [] = Wrapper (undefined::NIL a)
valToType (x:xs) = case valToType x of {Wrapper x' ->
case x' of {(_::xt) ->
case valToType xs of {Wrapper xs' ->
case xs' of {(_::xst) ->
Wrapper (undefined::CONS xt xst)}}}}
|
