    {-# 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 :: FieldName -> Maybe Int
    readTupleType FieldName
    x | FieldName
    "(" FieldName -> FieldName -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` FieldName
    x Bool -> Bool -> Bool
    && FieldName
    ")" FieldName -> FieldName -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isSuffixOf` FieldName
    x Bool -> Bool -> Bool
    && (Char -> Bool) -> FieldName -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    ',') FieldName
    y = Int -> Maybe Int
    forall a. a -> Maybe a
    Just (Int -> Maybe Int) -> Int -> Maybe Int
    forall a b. (a -> b) -> a -> b
    $ FieldName -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length FieldName
    y
                    | Bool
    otherwise = Maybe Int
    forall a. Maybe a
    Nothing
        where y :: FieldName
    y = FieldName -> FieldName
    forall a. HasCallStack => [a] -> [a]
    init (FieldName -> FieldName) -> FieldName -> FieldName
    forall a b. (a -> b) -> a -> b
    $ FieldName -> FieldName
    forall a. HasCallStack => [a] -> [a]
    tail FieldName
    x

    try1 :: a -> Either SomeException a
    try1 :: forall a. a -> Either SomeException a
    try1 = IO (Either SomeException a) -> Either SomeException a
    forall a. IO a -> a
    unsafePerformIO (IO (Either SomeException a) -> Either SomeException a)
    -> (a -> IO (Either SomeException a))
    -> a
    -> Either SomeException a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . IO a -> IO (Either SomeException a)
    forall e a. Exception e => IO a -> IO (Either e a)
    try (IO a -> IO (Either SomeException a))
    -> (a -> IO a) -> a -> IO (Either SomeException a)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> IO a
    forall a. a -> IO a
    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 :: Any -> FieldName
    show = TypeRep -> FieldName
    forall a. Show a => a -> FieldName
    show (TypeRep -> FieldName) -> (Any -> TypeRep) -> Any -> FieldName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Any -> TypeRep
    typeOf

    fromAny :: Typeable a => Any -> a
    fromAny :: forall a. Typeable a => Any -> a
    fromAny (Any a
    x) = case a -> Maybe a
    forall a b. (Typeable a, Typeable b) => a -> Maybe b
    D.cast a
    x of
        Just a
    y -> a
    y
        ~(Just a
    y) -> FieldName -> a
    forall a. HasCallStack => FieldName -> a
    error (FieldName -> a) -> FieldName -> a
    forall a b. (a -> b) -> a -> b
    $ FieldName
    "Data.Generics.Any.fromAny: Failed to extract any, got " FieldName -> FieldName -> FieldName
    forall a. [a] -> [a] -> [a]
    ++
                             TypeRep -> FieldName
    forall a. Show a => a -> FieldName
    show (a -> TypeRep
    forall a. Typeable a => a -> TypeRep
    D.typeOf a
    x) FieldName -> FieldName -> FieldName
    forall a. [a] -> [a] -> [a]
    ++ FieldName
    ", wanted " FieldName -> FieldName -> FieldName
    forall a. [a] -> [a] -> [a]
    ++ TypeRep -> FieldName
    forall a. Show a => a -> FieldName
    show (a -> TypeRep
    forall a. Typeable a => a -> TypeRep
    D.typeOf a
    y)

    cast :: Typeable a => Any -> Maybe a
    cast :: forall a. Typeable a => Any -> Maybe a
    cast (Any a
    x) = a -> Maybe a
    forall a b. (Typeable a, Typeable b) => a -> Maybe b
    D.cast a
    x

    ---------------------------------------------------------------------
    -- SYB COMPATIBILITY

    toConstr :: Any -> Constr
    toConstr :: Any -> Constr
    toConstr (Any a
    x) = a -> Constr
    forall a. Data a => a -> Constr
    D.toConstr a
    x

    typeOf :: Any -> TypeRep
    typeOf :: Any -> TypeRep
    typeOf (Any a
    x) = a -> TypeRep
    forall a. Typeable a => a -> TypeRep
    D.typeOf a
    x

    dataTypeOf :: Any -> DataType
    dataTypeOf :: Any -> DataType
    dataTypeOf (Any a
    x) = a -> DataType
    forall a. Data a => a -> DataType
    D.dataTypeOf a
    x

    isAlgType :: Any -> Bool
    isAlgType :: Any -> Bool
    isAlgType = DataType -> Bool
    D.isAlgType (DataType -> Bool) -> (Any -> DataType) -> Any -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Any -> DataType
    dataTypeOf

    ---------------------------------------------------------------------
    -- TYPE STUFF

    typeShell :: Any -> String
    typeShell :: Any -> FieldName
    typeShell = FieldName -> FieldName
    tyconUQname (FieldName -> FieldName) -> (Any -> FieldName) -> Any -> FieldName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Any -> FieldName
    typeShellFull

    typeShellFull :: Any -> String
    typeShellFull :: Any -> FieldName
    typeShellFull = TyCon -> FieldName
    tyConName (TyCon -> FieldName) -> (Any -> TyCon) -> Any -> FieldName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TypeRep -> TyCon
    typeRepTyCon (TypeRep -> TyCon) -> (Any -> TypeRep) -> Any -> TyCon
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Any -> TypeRep
    typeOf

    typeName :: Any -> String
    typeName :: Any -> FieldName
    typeName = TypeRep -> FieldName
    forall a. Show a => a -> FieldName
    show (TypeRep -> FieldName) -> (Any -> TypeRep) -> Any -> FieldName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Any -> TypeRep
    typeOf

    ---------------------------------------------------------------------
    -- ANY PRIMITIVES

    ctor :: Any -> CtorName
    ctor :: Any -> FieldName
    ctor = Constr -> FieldName
    showConstr (Constr -> FieldName) -> (Any -> Constr) -> Any -> FieldName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Any -> Constr
    toConstr

    fields :: Any -> [String]
    fields :: Any -> [FieldName]
    fields = Constr -> [FieldName]
    constrFields (Constr -> [FieldName]) -> (Any -> Constr) -> Any -> [FieldName]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Any -> Constr
    toConstr

    children :: Any -> [Any]
    children :: Any -> [Any]
    children (Any a
    x) = (forall d. Data d => d -> Any) -> a -> [Any]
    forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
    forall u. (forall d. Data d => d -> u) -> a -> [u]
    gmapQ d -> Any
    forall d. Data d => d -> Any
    Any a
    x

    compose0 :: Any -> CtorName -> Any
    compose0 :: Any -> FieldName -> Any
    compose0 Any
    x FieldName
    c | (SomeException -> Bool)
    -> (FieldName -> Bool) -> Either SomeException FieldName -> Bool
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either (Bool -> SomeException -> Bool
    forall a b. a -> b -> a
    const Bool
    False) (FieldName -> FieldName -> Bool
    forall a. Eq a => a -> a -> Bool
    == FieldName
    c) (Either SomeException FieldName -> Bool)
    -> Either SomeException FieldName -> Bool
    forall a b. (a -> b) -> a -> b
    $ FieldName -> Either SomeException FieldName
    forall a. a -> Either SomeException a
    try1 (FieldName -> Either SomeException FieldName)
    -> FieldName -> Either SomeException FieldName
    forall a b. (a -> b) -> a -> b
    $ Any -> FieldName
    ctor Any
    x = Any
    x
    compose0 (Any a
    x) FieldName
    c = a -> Any
    forall d. Data d => d -> Any
    Any (a -> Any) -> a -> Any
    forall a b. (a -> b) -> a -> b
    $ (forall d. Data d => d) -> Constr -> a
    forall a. Data a => (forall d. Data d => d) -> Constr -> a
    fromConstrB d
    forall {a}. a
    forall d. Data d => d
    err Constr
    y a -> a -> a
    forall a. a -> a -> a
    `asTypeOf` a
    x
        where Just Constr
    y = DataType -> FieldName -> Maybe Constr
    readConstr (a -> DataType
    forall a. Data a => a -> DataType
    D.dataTypeOf a
    x) FieldName
    c
              err :: a
    err = FieldName -> a
    forall a. HasCallStack => FieldName -> a
    error (FieldName -> a) -> FieldName -> a
    forall a b. (a -> b) -> a -> b
    $ FieldName
    "Data.Generics.Any: Undefined field inside compose0, " FieldName -> FieldName -> FieldName
    forall a. [a] -> [a] -> [a]
    ++ FieldName
    c FieldName -> FieldName -> FieldName
    forall a. [a] -> [a] -> [a]
    ++ FieldName
    " :: " FieldName -> FieldName -> FieldName
    forall a. [a] -> [a] -> [a]
    ++ Any -> FieldName
    forall a. Show a => a -> FieldName
    show (a -> Any
    forall d. Data d => d -> Any
    Any a
    x)

    recompose :: Any -> [Any] -> Any
    recompose :: Any -> [Any] -> Any
    recompose (Any a
    x) [Any]
    cs | [Any] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Any]
    s = a -> Any
    forall d. Data d => d -> Any
    Any (a -> Any) -> a -> Any
    forall a b. (a -> b) -> a -> b
    $ a
    res a -> a -> a
    forall a. a -> a -> a
    `asTypeOf` a
    x
                         | Bool
    otherwise = Any
    forall {a}. a
    err
        where (a
    res,[Any]
    s) = State [Any] a -> [Any] -> (a, [Any])
    forall s a. State s a -> s -> (a, s)
    runState ((forall d. Data d => StateT [Any] Identity d)
    -> Constr -> State [Any] a
    forall (m :: * -> *) a.
    (Monad m, Data a) =>
    (forall d. Data d => m d) -> Constr -> m a
    fromConstrM State [Any] d
    forall d. Data d => StateT [Any] Identity d
    field (Constr -> State [Any] a) -> Constr -> State [Any] a
    forall a b. (a -> b) -> a -> b
    $ a -> Constr
    forall a. Data a => a -> Constr
    D.toConstr a
    x) [Any]
    cs

              field :: Data d => State [Any] d
              field :: forall d. Data d => StateT [Any] Identity d
    field = do cs <- StateT [Any] Identity [Any]
    forall (m :: * -> *) s. Monad m => StateT s m s
    get
                         if null cs then err else do
                             put $ tail cs
                             return $ fromAny $ head cs

              err :: a
    err = FieldName -> a
    forall a. HasCallStack => FieldName -> a
    error (FieldName -> a) -> FieldName -> a
    forall a b. (a -> b) -> a -> b
    $ FieldName
    "Data.Generics.Any.recompose: Incorrect number of children to recompose, " FieldName -> FieldName -> FieldName
    forall a. [a] -> [a] -> [a]
    ++
                            Any -> FieldName
    ctor (a -> Any
    forall d. Data d => d -> Any
    Any a
    x) FieldName -> FieldName -> FieldName
    forall a. [a] -> [a] -> [a]
    ++ FieldName
    " :: " FieldName -> FieldName -> FieldName
    forall a. [a] -> [a] -> [a]
    ++ Any -> FieldName
    forall a. Show a => a -> FieldName
    show (a -> Any
    forall d. Data d => d -> Any
    Any a
    x) FieldName -> FieldName -> FieldName
    forall a. [a] -> [a] -> [a]
    ++ FieldName
    ", expected " FieldName -> FieldName -> FieldName
    forall a. [a] -> [a] -> [a]
    ++ Int -> FieldName
    forall a. Show a => a -> FieldName
    show (Any -> Int
    arity (Any -> Int) -> Any -> Int
    forall a b. (a -> b) -> a -> b
    $ a -> Any
    forall d. Data d => d -> Any
    Any a
    x) FieldName -> FieldName -> FieldName
    forall a. [a] -> [a] -> [a]
    ++
                            FieldName
    ", got " FieldName -> FieldName -> FieldName
    forall a. [a] -> [a] -> [a]
    ++ Int -> FieldName
    forall a. Show a => a -> FieldName
    show ([Any] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Any]
    cs)

    ctors :: Any -> [CtorName]
    ctors :: Any -> [FieldName]
    ctors = (Constr -> FieldName) -> [Constr] -> [FieldName]
    forall a b. (a -> b) -> [a] -> [b]
    map Constr -> FieldName
    showConstr ([Constr] -> [FieldName])
    -> (Any -> [Constr]) -> Any -> [FieldName]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DataType -> [Constr]
    dataTypeConstrs (DataType -> [Constr]) -> (Any -> DataType) -> Any -> [Constr]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Any -> DataType
    dataTypeOf

    ---------------------------------------------------------------------
    -- DERIVED FUNCTIONS

    decompose :: Any -> (CtorName,[Any])
    decompose :: Any -> (FieldName, [Any])
    decompose Any
    x = (Any -> FieldName
    ctor Any
    x, Any -> [Any]
    children Any
    x)

    arity :: Any -> Int
    arity = [Any] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length ([Any] -> Int) -> (Any -> [Any]) -> Any -> Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Any -> [Any]
    children

    compose :: Any -> CtorName -> [Any] -> Any
    compose :: Any -> FieldName -> [Any] -> Any
    compose Any
    t FieldName
    c [Any]
    xs = Any -> [Any] -> Any
    recompose (Any -> FieldName -> Any
    compose0 Any
    t FieldName
    c) [Any]
    xs

    ---------------------------------------------------------------------
    -- FIELD UTILITIES

    getField :: FieldName -> Any -> Any
    getField :: FieldName -> Any -> Any
    getField FieldName
    lbl Any
    x = Any -> Maybe Any -> Any
    forall a. a -> Maybe a -> a
    fromMaybe (FieldName -> Any
    forall a. HasCallStack => FieldName -> a
    error (FieldName -> Any) -> FieldName -> Any
    forall a b. (a -> b) -> a -> b
    $ FieldName
    "getField: Could not find field " FieldName -> FieldName -> FieldName
    forall a. [a] -> [a] -> [a]
    ++ FieldName -> FieldName
    forall a. Show a => a -> FieldName
    show FieldName
    lbl) (Maybe Any -> Any) -> Maybe Any -> Any
    forall a b. (a -> b) -> a -> b
    $
        FieldName -> [(FieldName, Any)] -> Maybe Any
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup FieldName
    lbl ([(FieldName, Any)] -> Maybe Any)
    -> [(FieldName, Any)] -> Maybe Any
    forall a b. (a -> b) -> a -> b
    $ [FieldName] -> [Any] -> [(FieldName, Any)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip (Any -> [FieldName]
    fields Any
    x) (Any -> [Any]
    children Any
    x)

    setField :: (FieldName,Any) -> Any -> Any
    setField :: (FieldName, Any) -> Any -> Any
    setField (FieldName
    lbl,Any
    child) Any
    parent
        | FieldName
    lbl FieldName -> [FieldName] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` [FieldName]
    fs = FieldName -> Any
    forall a. HasCallStack => FieldName -> a
    error (FieldName -> Any) -> FieldName -> Any
    forall a b. (a -> b) -> a -> b
    $ FieldName
    "setField: Could not find field " FieldName -> FieldName -> FieldName
    forall a. [a] -> [a] -> [a]
    ++ FieldName -> FieldName
    forall a. Show a => a -> FieldName
    show FieldName
    lbl
        | Bool
    otherwise = Any -> [Any] -> Any
    recompose Any
    parent ([Any] -> Any) -> [Any] -> Any
    forall a b. (a -> b) -> a -> b
    $ (FieldName -> Any -> Any) -> [FieldName] -> [Any] -> [Any]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\FieldName
    f Any
    c -> if FieldName
    f FieldName -> FieldName -> Bool
    forall a. Eq a => a -> a -> Bool
    == FieldName
    lbl then Any
    child else Any
    c) [FieldName]
    fs [Any]
    cs
        where
            fs :: [FieldName]
    fs = Any -> [FieldName]
    fields Any
    parent
            cs :: [Any]
    cs = Any -> [Any]
    children Any
    parent