{-# 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 :: [Char] -> Maybe Int
readTupleType [Char]
x | [Char]
"(" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
x Bool -> Bool -> Bool
&& [Char]
")" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
x Bool -> Bool -> Bool
&& (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') [Char]
y = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
y
                | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing
    where y :: [Char]
y = [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
init ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
tail [Char]
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 -> [Char]
show = SomeTypeRep -> [Char]
forall a. Show a => a -> [Char]
show (SomeTypeRep -> [Char]) -> (Any -> SomeTypeRep) -> Any -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> SomeTypeRep
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) -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"Data.Generics.Any.fromAny: Failed to extract any, got " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                         SomeTypeRep -> [Char]
forall a. Show a => a -> [Char]
show (a -> SomeTypeRep
forall a. Typeable a => a -> SomeTypeRep
D.typeOf a
x) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", wanted " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SomeTypeRep -> [Char]
forall a. Show a => a -> [Char]
show (a -> SomeTypeRep
forall a. Typeable a => a -> SomeTypeRep
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 -> SomeTypeRep
typeOf (Any a
x) = a -> SomeTypeRep
forall a. Typeable a => a -> SomeTypeRep
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 -> [Char]
typeShell = [Char] -> [Char]
tyconUQname ([Char] -> [Char]) -> (Any -> [Char]) -> Any -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> [Char]
typeShellFull

typeShellFull :: Any -> String
typeShellFull :: Any -> [Char]
typeShellFull = TyCon -> [Char]
tyConName (TyCon -> [Char]) -> (Any -> TyCon) -> Any -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeTypeRep -> TyCon
typeRepTyCon (SomeTypeRep -> TyCon) -> (Any -> SomeTypeRep) -> Any -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> SomeTypeRep
typeOf

typeName :: Any -> String
typeName :: Any -> [Char]
typeName = SomeTypeRep -> [Char]
forall a. Show a => a -> [Char]
show (SomeTypeRep -> [Char]) -> (Any -> SomeTypeRep) -> Any -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> SomeTypeRep
typeOf

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

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

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


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


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

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


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