{-# 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 (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. [a] -> [a]
init (FieldName -> FieldName) -> FieldName -> FieldName
forall a b. (a -> b) -> a -> b
$ FieldName -> FieldName
forall a. [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]
gmapQ 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 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 (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 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 [Any]
cs <- StateT [Any] Identity [Any]
forall (m :: * -> *) s. Monad m => StateT s m s
get
                     if [Any] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Any]
cs then State [Any] d
forall {a}. a
err else do
                         [Any] -> StateT [Any] Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put ([Any] -> StateT [Any] Identity ())
-> [Any] -> StateT [Any] Identity ()
forall a b. (a -> b) -> a -> b
$ [Any] -> [Any]
forall a. [a] -> [a]
tail [Any]
cs
                         d -> State [Any] d
forall (m :: * -> *) a. Monad m => a -> m a
return (d -> State [Any] d) -> d -> State [Any] d
forall a b. (a -> b) -> a -> b
$ Any -> d
forall a. Typeable a => Any -> a
fromAny (Any -> d) -> Any -> d
forall a b. (a -> b) -> a -> b
$ [Any] -> Any
forall a. [a] -> a
head [Any]
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 (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 (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