Commit a8f81106 authored by ralf's avatar ralf

[project @ 2004-11-08 12:17:27 by ralf]

Testsuite works fine for today's HEAD.
Added a nice reflective programming example.
See getC.*
parent dee603f0
......@@ -23,7 +23,7 @@ ghci:
gmake TEST_HC=${stage2} WAY=ghci
# Should probably be reused from somewhere else
clean:
myclean:
find . -depth -name "core" -exec rm -rf \{\} \;
find . -depth -name "Main" -exec rm -rf \{\} \;
find . -depth -name "*~" -exec rm -rf \{\} \;
......
test('newtype', normal, compile_and_run, [''])
test('datatype', normal, compile_and_run, [''])
test('encode', normal, compile, [''])
test('encode', omit_ways(['opt','optasm']), compile, [''])
test('ext', normal, compile, [''])
test('getC', normal, compile_and_run, [''])
test('where', normal, compile_and_run, [''])
test('gmapQ-assoc', normal, compile_and_run, [''])
test('nested-datatypes', normal, compile_and_run, [''])
......
{-# OPTIONS -fglasgow-exts #-}
{-# OPTIONS -fallow-undecidable-instances #-}
{-# OPTIONS -fallow-overlapping-instances #-}
{-
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
main = do
print $ isC T1a (T1a 1 "foo") -- typechecks, returns True
print $ isC T1a (T1b "foo" 1) -- typechecks, returns False
print $ isC T3 (T3 42) -- works for strict data too
-- print $ isC T2b (T1b "foo" 1) -- must not typecheck
--
-- 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 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 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
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment