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
133
134
135
136
137
138
139
|
{-# LANGUAGE ExistentialQuantification #-}
module Data.Generics.Any where
import Control.Exception
import Control.Monad.Trans.State
import qualified Data.Data as D
import Data.Data hiding (toConstr, typeOf, dataTypeOf)
import Data.List
import Data.Maybe
import System.IO.Unsafe
type CtorName = String
type FieldName = String
readTupleType :: String -> Maybe Int
readTupleType x | "(" `isPrefixOf` x && ")" `isSuffixOf` x && all (== ',') y = Just $ length y
| otherwise = Nothing
where y = init $ tail x
try1 :: a -> Either SomeException a
try1 = unsafePerformIO . try . evaluate
---------------------------------------------------------------------
-- BASIC TYPES
-- | Any value, with a Data dictionary.
data Any = forall a . Data a => Any a
type AnyT t = Any
instance Show Any where
show = show . typeOf
fromAny :: Typeable a => Any -> a
fromAny (Any x) = case D.cast x of
Just y -> y
~(Just y) -> error $ "Data.Generics.Any.fromAny: Failed to extract any, got " ++
show (D.typeOf x) ++ ", wanted " ++ show (D.typeOf y)
cast :: Typeable a => Any -> Maybe a
cast (Any x) = D.cast x
---------------------------------------------------------------------
-- SYB COMPATIBILITY
toConstr :: Any -> Constr
toConstr (Any x) = D.toConstr x
typeOf :: Any -> TypeRep
typeOf (Any x) = D.typeOf x
dataTypeOf :: Any -> DataType
dataTypeOf (Any x) = D.dataTypeOf x
isAlgType :: Any -> Bool
isAlgType = D.isAlgType . dataTypeOf
---------------------------------------------------------------------
-- TYPE STUFF
typeShell :: Any -> String
typeShell = tyconUQname . typeShellFull
typeShellFull :: Any -> String
typeShellFull = tyConName . typeRepTyCon . typeOf
typeName :: Any -> String
typeName = show . typeOf
---------------------------------------------------------------------
-- ANY PRIMITIVES
ctor :: Any -> CtorName
ctor = showConstr . toConstr
fields :: Any -> [String]
fields = constrFields . toConstr
children :: Any -> [Any]
children (Any x) = gmapQ Any x
compose0 :: Any -> CtorName -> Any
compose0 x c | either (const False) (== c) $ try1 $ ctor x = x
compose0 (Any x) c = Any $ fromConstrB err y `asTypeOf` x
where Just y = readConstr (D.dataTypeOf x) c
err = error $ "Data.Generics.Any: Undefined field inside compose0, " ++ c ++ " :: " ++ show (Any x)
recompose :: Any -> [Any] -> Any
recompose (Any x) cs | null s = Any $ res `asTypeOf` x
| otherwise = err
where (res,s) = runState (fromConstrM field $ D.toConstr x) cs
field :: Data d => State [Any] d
field = do cs <- get
if null cs then err else do
put $ tail cs
return $ fromAny $ head cs
err = error $ "Data.Generics.Any.recompose: Incorrect number of children to recompose, " ++
ctor (Any x) ++ " :: " ++ show (Any x) ++ ", expected " ++ show (arity $ Any x) ++
", got " ++ show (length cs)
ctors :: Any -> [CtorName]
ctors = map showConstr . dataTypeConstrs . dataTypeOf
---------------------------------------------------------------------
-- DERIVED FUNCTIONS
decompose :: Any -> (CtorName,[Any])
decompose x = (ctor x, children x)
arity = length . children
compose :: Any -> CtorName -> [Any] -> Any
compose t c xs = recompose (compose0 t c) xs
---------------------------------------------------------------------
-- FIELD UTILITIES
getField :: FieldName -> Any -> Any
getField lbl x = fromMaybe (error $ "getField: Could not find field " ++ show lbl) $
lookup lbl $ zip (fields x) (children x)
setField :: (FieldName,Any) -> Any -> Any
setField (lbl,child) parent
| lbl `notElem` fs = error $ "setField: Could not find field " ++ show lbl
| otherwise = recompose parent $ zipWith (\f c -> if f == lbl then child else c) fs cs
where
fs = fields parent
cs = children parent
|
