content: {-# 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
  