1{-# LANGUAGE ExistentialQuantification #-}
2
3module Data.Generics.Any where
4
5import Control.Exception
6import Control.Monad.Trans.State
7import qualified Data.Data as D
8import Data.Data hiding (toConstr, typeOf, dataTypeOf)
9import Data.List
10import Data.Maybe
11import System.IO.Unsafe
12
13
14type CtorName = String
15type FieldName = String
16
17
18readTupleType :: String -> Maybe Int
19readTupleType x | "(" `isPrefixOf` x && ")" `isSuffixOf` x && all (== ',') y = Just $ length y
20                | otherwise = Nothing
21    where y = init $ tail x
22
23try1 :: a -> Either SomeException a
24try1 = unsafePerformIO . try . evaluate
25
26---------------------------------------------------------------------
27-- BASIC TYPES
28
29-- | Any value, with a Data dictionary.
30data Any = forall a . Data a => Any a
31
32type AnyT t = Any
33
34instance Show Any where
35    show = show . typeOf
36
37fromAny :: Typeable a => Any -> a
38fromAny (Any x) = case D.cast x of
39    Just y -> y
40    ~(Just y) -> error $ "Data.Generics.Any.fromAny: Failed to extract any, got " ++
41                         show (D.typeOf x) ++ ", wanted " ++ show (D.typeOf y)
42
43
44cast :: Typeable a => Any -> Maybe a
45cast (Any x) = D.cast x
46
47---------------------------------------------------------------------
48-- SYB COMPATIBILITY
49
50toConstr :: Any -> Constr
51toConstr (Any x) = D.toConstr x
52
53typeOf :: Any -> TypeRep
54typeOf (Any x) = D.typeOf x
55
56dataTypeOf :: Any -> DataType
57dataTypeOf (Any x) = D.dataTypeOf x
58
59isAlgType :: Any -> Bool
60isAlgType = D.isAlgType . dataTypeOf
61
62---------------------------------------------------------------------
63-- TYPE STUFF
64
65typeShell :: Any -> String
66typeShell = tyconUQname . typeShellFull
67
68typeShellFull :: Any -> String
69typeShellFull = tyConName . typeRepTyCon . typeOf
70
71typeName :: Any -> String
72typeName = show . typeOf
73
74---------------------------------------------------------------------
75-- ANY PRIMITIVES
76
77ctor :: Any -> CtorName
78ctor = showConstr . toConstr
79
80fields :: Any -> [String]
81fields = constrFields . toConstr
82
83children :: Any -> [Any]
84children (Any x) = gmapQ Any x
85
86
87compose0 :: Any -> CtorName -> Any
88compose0 x c | either (const False) (== c) $ try1 $ ctor x = x
89compose0 (Any x) c = Any $ fromConstrB err y `asTypeOf` x
90    where Just y = readConstr (D.dataTypeOf x) c
91          err = error $ "Data.Generics.Any: Undefined field inside compose0, " ++ c ++ " :: " ++ show (Any x)
92
93
94recompose :: Any -> [Any] -> Any
95recompose (Any x) cs | null s = Any $ res `asTypeOf` x
96                     | otherwise = err
97    where (res,s) = runState (fromConstrM field $ D.toConstr x) cs
98
99          field :: Data d => State [Any] d
100          field = do cs <- get
101                     if null cs then err else do
102                         put $ tail cs
103                         return $ fromAny $ head cs
104
105          err = error $ "Data.Generics.Any.recompose: Incorrect number of children to recompose, " ++
106                        ctor (Any x) ++ " :: " ++ show (Any x) ++ ", expected " ++ show (arity $ Any x) ++
107                        ", got " ++ show (length cs)
108
109
110ctors :: Any -> [CtorName]
111ctors = map showConstr . dataTypeConstrs . dataTypeOf
112
113---------------------------------------------------------------------
114-- DERIVED FUNCTIONS
115
116decompose :: Any -> (CtorName,[Any])
117decompose x = (ctor x, children x)
118
119arity = length . children
120
121compose :: Any -> CtorName -> [Any] -> Any
122compose t c xs = recompose (compose0 t c) xs
123
124
125---------------------------------------------------------------------
126-- FIELD UTILITIES
127
128getField :: FieldName -> Any -> Any
129getField lbl x = fromMaybe (error $ "getField: Could not find field " ++ show lbl) $
130    lookup lbl $ zip (fields x) (children x)
131
132
133setField :: (FieldName,Any) -> Any -> Any
134setField (lbl,child) parent
135    | lbl `notElem` fs = error $ "setField: Could not find field " ++ show lbl
136    | otherwise = recompose parent $ zipWith (\f c -> if f == lbl then child else c) fs cs
137    where
138        fs = fields parent
139        cs = children parent
140