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

try1 :: a -> Either SomeException a
try1 :: forall a. a -> Either SomeException a
try1 = forall a. IO a -> a
unsafePerformIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => IO a -> IO (Either e a)
try forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Show a => a -> FieldName
show 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 forall a b. (Typeable a, Typeable b) => a -> Maybe b
D.cast a
x of
    Just a
y -> a
y
    ~(Just a
y) -> forall a. HasCallStack => FieldName -> a
error forall a b. (a -> b) -> a -> b
$ FieldName
"Data.Generics.Any.fromAny: Failed to extract any, got " forall a. [a] -> [a] -> [a]
++
                         forall a. Show a => a -> FieldName
show (forall a. Typeable a => a -> TypeRep
D.typeOf a
x) forall a. [a] -> [a] -> [a]
++ FieldName
", wanted " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FieldName
show (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) = 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) = forall a. Data a => a -> Constr
D.toConstr a
x

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

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

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

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

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

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

typeName :: Any -> String
typeName :: Any -> FieldName
typeName = forall a. Show a => a -> FieldName
show 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> Constr
toConstr

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

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


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


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

          field :: Data d => State [Any] d
          field :: forall d. Data d => State [Any] d
field = do [Any]
cs <- forall (m :: * -> *) s. Monad m => StateT s m s
get
                     if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Any]
cs then forall {a}. a
err else do
                         forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail [Any]
cs
                         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Typeable a => Any -> a
fromAny forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [Any]
cs

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


ctors :: Any -> [CtorName]
ctors :: Any -> [FieldName]
ctors = forall a b. (a -> b) -> [a] -> [b]
map Constr -> FieldName
showConstr forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataType -> [Constr]
dataTypeConstrs 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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length 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 = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => FieldName -> a
error forall a b. (a -> b) -> a -> b
$ FieldName
"getField: Could not find field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FieldName
show FieldName
lbl) forall a b. (a -> b) -> a -> b
$
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FieldName
lbl forall a b. (a -> b) -> a -> b
$ 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FieldName]
fs = forall a. HasCallStack => FieldName -> a
error forall a b. (a -> b) -> a -> b
$ FieldName
"setField: Could not find field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FieldName
show FieldName
lbl
    | Bool
otherwise = Any -> [Any] -> Any
recompose Any
parent forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\FieldName
f Any
c -> if FieldName
f 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