{-# LANGUAGE PatternGuards, ScopedTypeVariables, ExistentialQuantification, DeriveDataTypeable #-}
{-# OPTIONS_GHC -O0 #-}

-- | This module captures annotations on a value, and builds a 'Capture' value.
--   This module has two ways of writing annotations:
--
--   /Impure/: The impure method of writing annotations is susceptible to over-optimisation by GHC
--   - sometimes @\{\-\# OPTIONS_GHC -fno-cse \#\-\}@ will be required.
--
--   /Pure/: The pure method is more verbose, and lacks some type safety.
--
--   As an example of the two styles:
--
-- > data Foo = Foo {foo :: Int, bar :: Int}
--
--   @ impure = 'capture' $ Foo {foo = 12, bar = 'many' [1 '&=' \"inner\", 2]} '&=' \"top\"@
--
--   @ pure = 'capture_' $ 'record' Foo{} [foo := 12, bar :=+ ['atom' 1 '+=' \"inner\", 'atom' 2]] '+=' \"top\"@
--
--   Both evaluate to:
--
-- > Capture (Ann "top") (Ctor (Foo 12 1) [Value 12, Many [Ann "inner" (Value 1), Value 2]]
module System.Console.CmdArgs.Annotate(
    -- * Capture framework
    Capture(..), Any(..), fromCapture, defaultMissing,
    -- * Impure
    capture, many, (&=),
    -- * Pure
    capture_, many_, (+=), atom, record, Annotate((:=),(:=+))
    ) where

import Control.Monad
import Control.Monad.Trans.State
import Data.Data(Data,Typeable)
import Data.List
import Data.Maybe
import Data.IORef
import System.IO.Unsafe
import Control.Exception
import Data.Generics.Any

infixl 2 &=, +=
infix 3 :=


-- | The result of capturing some annotations.
data Capture ann
    = Many [Capture ann] -- ^ Many values collapsed ('many' or 'many_')
    | Ann ann (Capture ann) -- ^ An annotation attached to a value ('&=' or '+=')
    | Value Any -- ^ A value (just a value, or 'atom')
    | Missing Any -- ^ A missing field (a 'RecConError' exception, or missing from 'record')
    | Ctor Any [Capture ann] -- ^ A constructor (a constructor, or 'record')
      deriving Int -> Capture ann -> ShowS
forall ann. Show ann => Int -> Capture ann -> ShowS
forall ann. Show ann => [Capture ann] -> ShowS
forall ann. Show ann => Capture ann -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Capture ann] -> ShowS
$cshowList :: forall ann. Show ann => [Capture ann] -> ShowS
show :: Capture ann -> String
$cshow :: forall ann. Show ann => Capture ann -> String
showsPrec :: Int -> Capture ann -> ShowS
$cshowsPrec :: forall ann. Show ann => Int -> Capture ann -> ShowS
Show

instance Functor Capture where
    fmap :: forall a b. (a -> b) -> Capture a -> Capture b
fmap a -> b
f (Many [Capture a]
xs) = forall ann. [Capture ann] -> Capture ann
Many forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [Capture a]
xs
    fmap a -> b
f (Ann a
a Capture a
x) = forall ann. ann -> Capture ann -> Capture ann
Ann (a -> b
f a
a) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Capture a
x
    fmap a -> b
f (Value Any
x) = forall ann. Any -> Capture ann
Value Any
x
    fmap a -> b
f (Missing Any
x) = forall ann. Any -> Capture ann
Missing Any
x
    fmap a -> b
f (Ctor Any
x [Capture a]
xs) = forall ann. Any -> [Capture ann] -> Capture ann
Ctor Any
x forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [Capture a]
xs


-- | Return the value inside a capture.
fromCapture :: Capture ann -> Any
fromCapture :: forall ann. Capture ann -> Any
fromCapture (Many (Capture ann
x:[Capture ann]
_)) = forall ann. Capture ann -> Any
fromCapture Capture ann
x
fromCapture (Ann ann
_ Capture ann
x) = forall ann. Capture ann -> Any
fromCapture Capture ann
x
fromCapture (Value Any
x) = Any
x
fromCapture (Missing Any
x) = Any
x
fromCapture (Ctor Any
x [Capture ann]
_) = Any
x


-- | Remove all Missing values by using any previous instances as default values
defaultMissing :: Capture ann -> Capture ann
defaultMissing :: forall ann. Capture ann -> Capture ann
defaultMissing Capture ann
x = forall s a. State s a -> s -> a
evalState (forall {m :: * -> *} {ann}.
Monad m =>
Maybe Any
-> Maybe String
-> Capture ann
-> StateT [(Any, String, Capture ann)] m (Capture ann)
f forall a. Maybe a
Nothing forall a. Maybe a
Nothing Capture ann
x) []
    where
        f :: Maybe Any
-> Maybe String
-> Capture ann
-> StateT [(Any, String, Capture ann)] m (Capture ann)
f Maybe Any
ctor Maybe String
field (Many [Capture ann]
xs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ann. [Capture ann] -> Capture ann
Many forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe Any
-> Maybe String
-> Capture ann
-> StateT [(Any, String, Capture ann)] m (Capture ann)
f Maybe Any
ctor Maybe String
field) [Capture ann]
xs
        f Maybe Any
ctor Maybe String
field (Ann ann
a Capture ann
x) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall ann. ann -> Capture ann -> Capture ann
Ann ann
a) forall a b. (a -> b) -> a -> b
$ Maybe Any
-> Maybe String
-> Capture ann
-> StateT [(Any, String, Capture ann)] m (Capture ann)
f Maybe Any
ctor Maybe String
field Capture ann
x
        f Maybe Any
ctor Maybe String
field (Value Any
x) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall ann. Any -> Capture ann
Value Any
x
        f (Just Any
ctor) (Just String
field) (Missing Any
x) = do
            [(Any, String, Capture ann)]
s <- forall (m :: * -> *) s. Monad m => StateT s m s
get
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$
                [Capture ann
x2 | (Any
ctor2,String
field2,Capture ann
x2) <- [(Any, String, Capture ann)]
s, Any -> TypeRep
typeOf Any
ctor forall a. Eq a => a -> a -> Bool
== Any -> TypeRep
typeOf Any
ctor2, String
field forall a. Eq a => a -> a -> Bool
== String
field2] forall a. [a] -> [a] -> [a]
++
                forall {a}. String -> a
err (String
"missing value encountered, no field for " forall a. [a] -> [a] -> [a]
++ String
field forall a. [a] -> [a] -> [a]
++ String
" (of type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Any
x forall a. [a] -> [a] -> [a]
++ String
")")
        f Maybe Any
_ Maybe String
_ (Missing Any
x) = forall {a}. String -> a
err forall a b. (a -> b) -> a -> b
$ String
"missing value encountered, but not as a field (of type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Any
x forall a. [a] -> [a] -> [a]
++ String
")"
        f Maybe Any
_ Maybe String
_ (Ctor Any
x [Capture ann]
xs) | forall (t :: * -> *) a. Foldable t => t a -> Int
length (Any -> [String]
fields Any
x) forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Capture ann]
xs = do
            [Capture ann]
ys <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Any
-> String
-> Capture ann
-> StateT [(Any, String, Capture ann)] m (Capture ann)
g Any
x) (Any -> [String]
fields Any
x) [Capture ann]
xs
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall ann. Any -> [Capture ann] -> Capture ann
Ctor (Any -> [Any] -> Any
recompose Any
x forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall ann. Capture ann -> Any
fromCapture [Capture ann]
ys) [Capture ann]
ys
        f Maybe Any
_ Maybe String
_ (Ctor Any
x [Capture ann]
xs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall ann. Any -> [Capture ann] -> Capture ann
Ctor Any
x) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe Any
-> Maybe String
-> Capture ann
-> StateT [(Any, String, Capture ann)] m (Capture ann)
f forall a. Maybe a
Nothing forall a. Maybe a
Nothing) [Capture ann]
xs

        g :: Any
-> String
-> Capture ann
-> StateT [(Any, String, Capture ann)] m (Capture ann)
g Any
ctor String
field Capture ann
x = do
            Capture ann
y <- Maybe Any
-> Maybe String
-> Capture ann
-> StateT [(Any, String, Capture ann)] m (Capture ann)
f (forall a. a -> Maybe a
Just Any
ctor) (forall a. a -> Maybe a
Just String
field) Capture ann
x
            forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((Any
ctor,String
field,Capture ann
y)forall a. a -> [a] -> [a]
:)
            forall (m :: * -> *) a. Monad m => a -> m a
return Capture ann
y

        err :: String -> a
err String
x = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"System.Console.CmdArgs.Annotate.defaultMissing, " forall a. [a] -> [a] -> [a]
++ String
x

---------------------------------------------------------------------
-- IMPURE BIT

-- test = show $ capture $ many [Just ((66::Int) &= P 1 &= P 2), Nothing &= P 8] &= P 3

{-
Notes On Purity
---------------

There is a risk that things that are unsafe will be inlined. That can generally be
removed by NOININE on everything.

There is also a risk that things get commoned up. For example:

foo = trace "1" 1
bar = trace "1" 1
main = do
    evaluate foo
    evaluate bar

Will print "1" only once, since foo and bar share the same pattern. However, if
anything in the value is a lambda they are not seen as equal. We exploit this by
defining const_ and id_ as per this module.

Now anything wrapped in id_ looks different from anything else.
-}


{-
The idea is to keep a stack of either continuations, or values
If you encounter 'many' you become a value
If you encounter '&=' you increase the continuation
-}

{-# NOINLINE ref #-}
ref :: IORef [Either (Capture Any -> Capture Any) (Capture Any)]
ref :: IORef [Either (Capture Any -> Capture Any) (Capture Any)]
ref = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []

push :: IO ()
push = forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [Either (Capture Any -> Capture Any) (Capture Any)]
ref (forall a b. a -> Either a b
Left forall a. a -> a
id forall a. a -> [a] -> [a]
:)
pop :: IO (Either (Capture Any -> Capture Any) (Capture Any))
pop = do Either (Capture Any -> Capture Any) (Capture Any)
x:[Either (Capture Any -> Capture Any) (Capture Any)]
xs <- forall a. IORef a -> IO a
readIORef IORef [Either (Capture Any -> Capture Any) (Capture Any)]
ref; forall a. IORef a -> a -> IO ()
writeIORef IORef [Either (Capture Any -> Capture Any) (Capture Any)]
ref [Either (Capture Any -> Capture Any) (Capture Any)]
xs; forall (m :: * -> *) a. Monad m => a -> m a
return Either (Capture Any -> Capture Any) (Capture Any)
x
change :: ((Capture Any -> Capture Any)
 -> Either (Capture Any -> Capture Any) (Capture Any))
-> IO ()
change (Capture Any -> Capture Any)
-> Either (Capture Any -> Capture Any) (Capture Any)
f = forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [Either (Capture Any -> Capture Any) (Capture Any)]
ref forall a b. (a -> b) -> a -> b
$ \[Either (Capture Any -> Capture Any) (Capture Any)]
x -> case [Either (Capture Any -> Capture Any) (Capture Any)]
x of Left Capture Any -> Capture Any
g : [Either (Capture Any -> Capture Any) (Capture Any)]
rest -> (Capture Any -> Capture Any)
-> Either (Capture Any -> Capture Any) (Capture Any)
f Capture Any -> Capture Any
g forall a. a -> [a] -> [a]
: [Either (Capture Any -> Capture Any) (Capture Any)]
rest ; [Either (Capture Any -> Capture Any) (Capture Any)]
_ -> forall a. HasCallStack => String -> a
error String
"Internal error in Capture"
add :: (Capture Any -> Capture Any) -> IO ()
add Capture Any -> Capture Any
f = ((Capture Any -> Capture Any)
 -> Either (Capture Any -> Capture Any) (Capture Any))
-> IO ()
change forall a b. (a -> b) -> a -> b
$ \Capture Any -> Capture Any
x -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Capture Any -> Capture Any
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. Capture Any -> Capture Any
f
set :: Capture Any -> IO ()
set Capture Any
x = ((Capture Any -> Capture Any)
 -> Either (Capture Any -> Capture Any) (Capture Any))
-> IO ()
change forall a b. (a -> b) -> a -> b
$ \Capture Any -> Capture Any
f -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Capture Any -> Capture Any
f Capture Any
x


-- | Collapse multiple values in to one.
{-# NOINLINE many #-}
many :: Data val => [val] -> val
many :: forall val. Data val => [val] -> val
many [val]
xs = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    [Capture Any]
ys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Any -> IO (Capture Any)
force forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Data a => a -> Any
Any) [val]
xs
    Capture Any -> IO ()
set forall a b. (a -> b) -> a -> b
$ forall ann. [Capture ann] -> Capture ann
Many [Capture Any]
ys
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [val]
xs


{-# NOINLINE addAnn #-}
addAnn :: (Data val, Data ann) => val -> ann -> val
addAnn :: forall val ann. (Data val, Data ann) => val -> ann -> val
addAnn val
x ann
y = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    (Capture Any -> Capture Any) -> IO ()
add (forall ann. ann -> Capture ann -> Capture ann
Ann forall a b. (a -> b) -> a -> b
$ forall a. Data a => a -> Any
Any ann
y)
    forall a. a -> IO a
evaluate val
x
    forall (m :: * -> *) a. Monad m => a -> m a
return val
x


-- | Capture a value. Note that if the value is evaluated
--   more than once the result may be different, i.e.
--
-- > capture x /= capture x
{-# NOINLINE capture #-}
capture :: (Data val, Data ann) => val -> Capture ann
capture :: forall val ann. (Data val, Data ann) => val -> Capture ann
capture val
x = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Typeable a => Any -> a
fromAny) forall a b. (a -> b) -> a -> b
$ Any -> IO (Capture Any)
force forall a b. (a -> b) -> a -> b
$ forall a. Data a => a -> Any
Any val
x


force :: Any -> IO (Capture Any)
force :: Any -> IO (Capture Any)
force x :: Any
x@(Any a
xx) = do
    IO ()
push
    Either RecConError a
res <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate a
xx
    Either (Capture Any -> Capture Any) (Capture Any)
y <- IO (Either (Capture Any -> Capture Any) (Capture Any))
pop
    case Either (Capture Any -> Capture Any) (Capture Any)
y of
        Either (Capture Any -> Capture Any) (Capture Any)
_ | Left (RecConError
_ :: RecConError) <- Either RecConError a
res -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall ann. Any -> Capture ann
Missing Any
x
        Right Capture Any
r -> forall (m :: * -> *) a. Monad m => a -> m a
return Capture Any
r
        Left Capture Any -> Capture Any
f | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Any -> Bool
isAlgType Any
x -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Capture Any -> Capture Any
f forall a b. (a -> b) -> a -> b
$ forall ann. Any -> Capture ann
Value Any
x
               | Bool
otherwise -> do
            [Capture Any]
cs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Any -> IO (Capture Any)
force forall a b. (a -> b) -> a -> b
$ Any -> [Any]
children Any
x
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Capture Any -> Capture Any
f forall a b. (a -> b) -> a -> b
$ forall ann. Any -> [Capture ann] -> Capture ann
Ctor Any
x [Capture Any]
cs


-- | Add an annotation to a value.
--
--   It is recommended that anyone making use of this function redefine
--   it with a more restrictive type signature to control the type of the
--   annotation (the second argument). Any redefinitions of this function
--   should add an INLINE pragma, to reduce the chance of incorrect
--   optimisations.
{-# INLINE (&=) #-}
(&=) :: (Data val, Data ann) => val -> ann -> val
&= :: forall val ann. (Data val, Data ann) => val -> ann -> val
(&=) val
x ann
y = forall val ann. (Data val, Data ann) => val -> ann -> val
addAnn (forall a. a -> a
id_ val
x) (forall a. a -> a
id_ ann
y)

{-# INLINE id_ #-}
id_ :: a -> a
id_ :: forall a. a -> a
id_ a
x = case ()
unit of () -> a
x
    where unit :: ()
unit = forall a. [a] -> [a]
reverse String
"" seq :: forall a b. a -> b -> b
`seq` ()


---------------------------------------------------------------------
-- PURE PART

-- | This type represents an annotated value. The type of the underlying value is not specified.
data Annotate ann
    = forall c f . (Data c, Data f) => (c -> f) := f -- ^ Construct a field, @fieldname := value@.
    | forall c f . (Data c, Data f) => (c -> f) :=+ [Annotate ann] -- ^ Add annotations to a field.
    | AAnn ann (Annotate ann)
    | AMany [Annotate ann]
    | AAtom Any
    | ACtor Any [Annotate ann]
      deriving Typeable
      -- specifically DOES NOT derive Data, to avoid people accidentally including it


-- | Add an annotation to a value.
(+=) :: Annotate ann -> ann -> Annotate ann
+= :: forall ann. Annotate ann -> ann -> Annotate ann
(+=) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ann. ann -> Annotate ann -> Annotate ann
AAnn

-- | Collapse many annotated values in to one.
many_ :: [Annotate a] -> Annotate a
many_ :: forall a. [Annotate a] -> Annotate a
many_ = forall a. [Annotate a] -> Annotate a
AMany

-- | Lift a pure value to an annotation.
atom :: Data val => val -> Annotate ann
atom :: forall val ann. Data val => val -> Annotate ann
atom = forall ann. Any -> Annotate ann
AAtom forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Data a => a -> Any
Any

-- | Create a constructor/record. The first argument should be
--   the type of field, the second should be a list of fields constructed
--   originally defined by @:=@ or @:=+@.
--
--   This operation is not type safe, and may raise an exception at runtime
--   if any field has the wrong type or label.
record :: Data a => a -> [Annotate ann] -> Annotate ann
record :: forall a ann. Data a => a -> [Annotate ann] -> Annotate ann
record a
a [Annotate ann]
b = forall ann. Any -> [Annotate ann] -> Annotate ann
ACtor (forall a. Data a => a -> Any
Any a
a) [Annotate ann]
b

-- | Capture the annotations from an annotated value.
capture_ :: Show a => Annotate a -> Capture a
capture_ :: forall a. Show a => Annotate a -> Capture a
capture_ (AAnn a
a Annotate a
x) = forall ann. ann -> Capture ann -> Capture ann
Ann a
a (forall a. Show a => Annotate a -> Capture a
capture_ Annotate a
x)
capture_ (AMany [Annotate a]
xs) = forall ann. [Capture ann] -> Capture ann
Many (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => Annotate a -> Capture a
capture_ [Annotate a]
xs)
capture_ (AAtom Any
x) = forall ann. Any -> Capture ann
Value Any
x
capture_ (c -> f
_ := f
c) = forall ann. Any -> Capture ann
Value forall a b. (a -> b) -> a -> b
$ forall a. Data a => a -> Any
Any f
c
capture_ (c -> f
_ :=+ [Annotate a]
c) = forall ann. [Capture ann] -> Capture ann
Many forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => Annotate a -> Capture a
capture_ [Annotate a]
c
capture_ (ACtor Any
x [Annotate a]
xs)
    | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
rep = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Some fields got repeated under " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Any
x forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ Any -> String
ctor Any
x forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Int]
rep
    | Bool
otherwise = forall ann. Any -> [Capture ann] -> Capture ann
Ctor Any
x2 [Capture a]
xs2
    where
        x2 :: Any
x2 = Any -> [Any] -> Any
recompose Any
x forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall ann. Capture ann -> Any
fromCapture [Capture a]
xs2
        xs2 :: [Capture a]
xs2 = [forall a. a -> Maybe a -> a
fromMaybe (forall ann. Any -> Capture ann
Missing Any
c) forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
i [(Int, Capture a)]
is | let is :: [(Int, Capture a)]
is = forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
inds forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => Annotate a -> Capture a
capture_ [Annotate a]
xs, (Int
i,Any
c) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] forall a b. (a -> b) -> a -> b
$ Any -> [Any]
children Any
x]
        inds :: [Int]
inds = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. a -> Maybe a -> a
fromMaybe [Int
0..] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Any -> Annotate a -> Maybe Int
fieldIndex Any
x) [Annotate a]
xs
        rep :: [Int]
rep = [Int]
inds forall a. Eq a => [a] -> [a] -> [a]
\\ forall a. Eq a => [a] -> [a]
nub [Int]
inds


fieldIndex :: Any -> Annotate a -> Maybe Int
fieldIndex :: forall a. Any -> Annotate a -> Maybe Int
fieldIndex Any
ctor (AAnn a
a Annotate a
x) = forall a. Any -> Annotate a -> Maybe Int
fieldIndex Any
ctor Annotate a
x
fieldIndex Any
ctor (c -> f
f := f
_) = forall a. Any -> Annotate a -> Maybe Int
fieldIndex Any
ctor (c -> f
f forall ann c f.
(Data c, Data f) =>
(c -> f) -> [Annotate ann] -> Annotate ann
:=+ [])
fieldIndex Any
ctor (c -> f
f :=+ [Annotate a]
_) | forall a. Maybe a -> Bool
isJust Maybe Int
res = Maybe Int
res
                          | Bool
otherwise = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Couldn't resolve field for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Any
ctor
    where c :: Any
c = Any -> [Any] -> Any
recompose Any
ctor [forall a. Data a => a -> Any
Any forall a b. (a -> b) -> a -> b
$ forall a. Int -> a
throwInt Int
i forall a. a -> a -> a
`asTypeOf` a
x | (Int
i,Any a
x) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (Any -> [Any]
children Any
ctor)]
          res :: Maybe Int
res = forall a. a -> Maybe Int
catchInt forall a b. (a -> b) -> a -> b
$ c -> f
f forall a b. (a -> b) -> a -> b
$ forall a. Typeable a => Any -> a
fromAny Any
c
fieldIndex Any
_ Annotate a
_ = forall a. Maybe a
Nothing



data ExceptionInt = ExceptionInt Int deriving (Int -> ExceptionInt -> ShowS
[ExceptionInt] -> ShowS
ExceptionInt -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExceptionInt] -> ShowS
$cshowList :: [ExceptionInt] -> ShowS
show :: ExceptionInt -> String
$cshow :: ExceptionInt -> String
showsPrec :: Int -> ExceptionInt -> ShowS
$cshowsPrec :: Int -> ExceptionInt -> ShowS
Show, Typeable)
instance Exception ExceptionInt


throwInt :: Int -> a
throwInt :: forall a. Int -> a
throwInt Int
i = forall a e. Exception e => e -> a
throw (Int -> ExceptionInt
ExceptionInt Int
i)


{-# NOINLINE catchInt #-}
catchInt :: a -> Maybe Int
catchInt :: forall a. a -> Maybe Int
catchInt a
x = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    Either ExceptionInt a
y <- forall e a. Exception e => IO a -> IO (Either e a)
try (forall a. a -> IO a
evaluate a
x)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either ExceptionInt a
y of
        Left (ExceptionInt Int
z) -> forall a. a -> Maybe a
Just Int
z
        Either ExceptionInt a
_ -> forall a. Maybe a
Nothing