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