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
|
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
module Polymatch () where
import Data.Typeable
import Data.Generics
-- Representation of kids
kids x = gmapQ Kid x -- get all kids
type Kids = [Kid]
data Kid = forall k. Typeable k => Kid k
-- Build term from a list of kids and the constructor
fromConstrL :: Data a => Kids -> Constr -> Maybe a
fromConstrL l = unIDL . gunfold k z
where
z c = IDL (Just c) l
k (IDL Nothing _) = IDL Nothing undefined
k (IDL (Just f) (Kid x:l)) = IDL f' l
where
f' = case cast x of
(Just x') -> Just (f x')
_ -> Nothing
-- Helper datatype
data IDL x = IDL (Maybe x) Kids
unIDL (IDL mx _) = mx
-- Two sample datatypes
data A = A String deriving (Read, Show, Eq, Data, Typeable)
data B = B String deriving (Read, Show, Eq, Data, Typeable)
-- Mediate between two "left-equal" Either types
f :: (Data a, Data b, Show a, Read b)
=> (a->b) -> Either String a -> Either String b
f g (Right a) = Right $ g a -- conversion really needed
-- f g (Left s) = Left s -- unappreciated conversion
-- f g s = s -- doesn't typecheck
-- f g s = deep_rebuild s -- too expensive
f g s = just (shallow_rebuild s) -- perhaps this is Ok?
-- Get rid of maybies
just = maybe (error "tried, but failed.") id
-- Just mentioned for completeness' sake
deep_rebuild :: (Show a, Read b) => a -> b
deep_rebuild = read . show
-- For the record: it's possible.
shallow_rebuild :: (Data a, Data b) => a -> Maybe b
shallow_rebuild a = b
where
b = fromConstrL (kids a) constr
constr = indexConstr (dataTypeOf b) (constrIndex (toConstr a))
-- Test cases
a2b (A s) = B s -- silly conversion
t1 = f a2b (Left "x") -- prints Left "x"
t2 = f a2b (Right (A "y")) -- prints Right (B "y")
|
