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

try1 :: a -> Either SomeException a
try1 :: 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 -> String
show = TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> (Any -> TypeRep) -> Any -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> TypeRep
typeOf

fromAny :: Typeable a => Any -> a
fromAny :: 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) -> String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Data.Generics.Any.fromAny: Failed to extract any, got " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                         TypeRep -> String
forall a. Show a => a -> String
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
D.typeOf a
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", wanted " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
D.typeOf a
y)


cast :: Typeable a => Any -> Maybe a
cast :: 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 -> String
typeShell = String -> String
tyconUQname (String -> String) -> (Any -> String) -> Any -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> String
typeShellFull

typeShellFull :: Any -> String
typeShellFull :: Any -> String
typeShellFull = TyCon -> String
tyConName (TyCon -> String) -> (Any -> TyCon) -> Any -> String
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 -> String
typeName = TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> (Any -> TypeRep) -> Any -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> TypeRep
typeOf

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

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

fields :: Any -> [String]
fields :: Any -> [String]
fields = Constr -> [String]
constrFields (Constr -> [String]) -> (Any -> Constr) -> Any -> [String]
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 -> String -> Any
compose0 Any
x String
c | (SomeException -> Bool)
-> (String -> Bool) -> Either SomeException String -> 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) (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
c) (Either SomeException String -> Bool)
-> Either SomeException String -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Either SomeException String
forall a. a -> Either SomeException a
try1 (String -> Either SomeException String)
-> String -> Either SomeException String
forall a b. (a -> b) -> a -> b
$ Any -> String
ctor Any
x = Any
x
compose0 (Any a
x) String
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 -> String -> Maybe Constr
readConstr (a -> DataType
forall a. Data a => a -> DataType
D.dataTypeOf a
x) String
c
          err :: a
err = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Data.Generics.Any: Undefined field inside compose0, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Any -> String
forall a. Show a => a -> String
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 :: State [Any] 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 = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Data.Generics.Any.recompose: Incorrect number of children to recompose, " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        Any -> String
ctor (a -> Any
forall d. Data d => d -> Any
Any a
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Any -> String
forall a. Show a => a -> String
show (a -> Any
forall d. Data d => d -> Any
Any a
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
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) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        String
", got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Any] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Any]
cs)


ctors :: Any -> [CtorName]
ctors :: Any -> [String]
ctors = (Constr -> String) -> [Constr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Constr -> String
showConstr ([Constr] -> [String]) -> (Any -> [Constr]) -> Any -> [String]
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 -> (String, [Any])
decompose Any
x = (Any -> String
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 -> String -> [Any] -> Any
compose Any
t String
c [Any]
xs = Any -> [Any] -> Any
recompose (Any -> String -> Any
compose0 Any
t String
c) [Any]
xs


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

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


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