{-# 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
[Capture ann] -> ShowS
Capture ann -> String
(Int -> Capture ann -> ShowS)
-> (Capture ann -> String)
-> ([Capture ann] -> ShowS)
-> Show (Capture ann)
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 :: (a -> b) -> Capture a -> Capture b
fmap a -> b
f (Many [Capture a]
xs) = [Capture b] -> Capture b
forall ann. [Capture ann] -> Capture ann
Many ([Capture b] -> Capture b) -> [Capture b] -> Capture b
forall a b. (a -> b) -> a -> b
$ (Capture a -> Capture b) -> [Capture a] -> [Capture b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> Capture a -> Capture b
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) = b -> Capture b -> Capture b
forall ann. ann -> Capture ann -> Capture ann
Ann (a -> b
f a
a) (Capture b -> Capture b) -> Capture b -> Capture b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> Capture a -> Capture 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) = Any -> Capture b
forall ann. Any -> Capture ann
Value Any
x
    fmap a -> b
f (Missing Any
x) = Any -> Capture b
forall ann. Any -> Capture ann
Missing Any
x
    fmap a -> b
f (Ctor Any
x [Capture a]
xs) = Any -> [Capture b] -> Capture b
forall ann. Any -> [Capture ann] -> Capture ann
Ctor Any
x ([Capture b] -> Capture b) -> [Capture b] -> Capture b
forall a b. (a -> b) -> a -> b
$ (Capture a -> Capture b) -> [Capture a] -> [Capture b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> Capture a -> Capture b
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 :: Capture ann -> Any
fromCapture (Many (Capture ann
x:[Capture ann]
_)) = Capture ann -> Any
forall ann. Capture ann -> Any
fromCapture Capture ann
x
fromCapture (Ann ann
_ Capture ann
x) = Capture ann -> Any
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 :: Capture ann -> Capture ann
defaultMissing Capture ann
x = State [(Any, String, Capture ann)] (Capture ann)
-> [(Any, String, Capture ann)] -> Capture ann
forall s a. State s a -> s -> a
evalState (Maybe Any
-> Maybe String
-> Capture ann
-> State [(Any, String, Capture ann)] (Capture ann)
forall (m :: * -> *) ann.
Monad m =>
Maybe Any
-> Maybe String
-> Capture ann
-> StateT [(Any, String, Capture ann)] m (Capture ann)
f Maybe Any
forall a. Maybe a
Nothing Maybe String
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) = ([Capture ann] -> Capture ann)
-> StateT [(Any, String, Capture ann)] m [Capture ann]
-> StateT [(Any, String, Capture ann)] m (Capture ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Capture ann] -> Capture ann
forall ann. [Capture ann] -> Capture ann
Many (StateT [(Any, String, Capture ann)] m [Capture ann]
 -> StateT [(Any, String, Capture ann)] m (Capture ann))
-> StateT [(Any, String, Capture ann)] m [Capture ann]
-> StateT [(Any, String, Capture ann)] m (Capture ann)
forall a b. (a -> b) -> a -> b
$ (Capture ann
 -> StateT [(Any, String, Capture ann)] m (Capture ann))
-> [Capture ann]
-> StateT [(Any, String, Capture ann)] m [Capture ann]
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) = (Capture ann -> Capture ann)
-> StateT [(Any, String, Capture ann)] m (Capture ann)
-> StateT [(Any, String, Capture ann)] m (Capture ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ann -> Capture ann -> Capture ann
forall ann. ann -> Capture ann -> Capture ann
Ann ann
a) (StateT [(Any, String, Capture ann)] m (Capture ann)
 -> StateT [(Any, String, Capture ann)] m (Capture ann))
-> StateT [(Any, String, Capture ann)] m (Capture ann)
-> StateT [(Any, String, Capture ann)] m (Capture ann)
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) = Capture ann -> StateT [(Any, String, Capture ann)] m (Capture ann)
forall (m :: * -> *) a. Monad m => a -> m a
return (Capture ann
 -> StateT [(Any, String, Capture ann)] m (Capture ann))
-> Capture ann
-> StateT [(Any, String, Capture ann)] m (Capture ann)
forall a b. (a -> b) -> a -> b
$ Any -> Capture ann
forall ann. Any -> Capture ann
Value Any
x
        f (Just Any
ctor) (Just String
field) (Missing Any
x) = do
            [(Any, String, Capture ann)]
s <- StateT [(Any, String, Capture ann)] m [(Any, String, Capture ann)]
forall (m :: * -> *) s. Monad m => StateT s m s
get
            Capture ann -> StateT [(Any, String, Capture ann)] m (Capture ann)
forall (m :: * -> *) a. Monad m => a -> m a
return (Capture ann
 -> StateT [(Any, String, Capture ann)] m (Capture ann))
-> Capture ann
-> StateT [(Any, String, Capture ann)] m (Capture ann)
forall a b. (a -> b) -> a -> b
$ [Capture ann] -> Capture ann
forall a. [a] -> a
head ([Capture ann] -> Capture ann) -> [Capture ann] -> Capture ann
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 TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Any -> TypeRep
typeOf Any
ctor2, String
field String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
field2] [Capture ann] -> [Capture ann] -> [Capture ann]
forall a. [a] -> [a] -> [a]
++
                String -> [Capture ann]
forall a. String -> a
err (String
"missing value encountered, no field for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
field String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (of type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Any -> String
forall a. Show a => a -> String
show Any
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")")
        f Maybe Any
_ Maybe String
_ (Missing Any
x) = String -> StateT [(Any, String, Capture ann)] m (Capture ann)
forall a. String -> a
err (String -> StateT [(Any, String, Capture ann)] m (Capture ann))
-> String -> StateT [(Any, String, Capture ann)] m (Capture ann)
forall a b. (a -> b) -> a -> b
$ String
"missing value encountered, but not as a field (of type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Any -> String
forall a. Show a => a -> String
show Any
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
        f Maybe Any
_ Maybe String
_ (Ctor Any
x [Capture ann]
xs) | [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Any -> [String]
fields Any
x) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Capture ann] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Capture ann]
xs = do
            [Capture ann]
ys <- (String
 -> Capture ann
 -> StateT [(Any, String, Capture ann)] m (Capture ann))
-> [String]
-> [Capture ann]
-> StateT [(Any, String, Capture ann)] m [Capture ann]
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
            Capture ann -> StateT [(Any, String, Capture ann)] m (Capture ann)
forall (m :: * -> *) a. Monad m => a -> m a
return (Capture ann
 -> StateT [(Any, String, Capture ann)] m (Capture ann))
-> Capture ann
-> StateT [(Any, String, Capture ann)] m (Capture ann)
forall a b. (a -> b) -> a -> b
$ Any -> [Capture ann] -> Capture ann
forall ann. Any -> [Capture ann] -> Capture ann
Ctor (Any -> [Any] -> Any
recompose Any
x ([Any] -> Any) -> [Any] -> Any
forall a b. (a -> b) -> a -> b
$ (Capture ann -> Any) -> [Capture ann] -> [Any]
forall a b. (a -> b) -> [a] -> [b]
map Capture ann -> Any
forall ann. Capture ann -> Any
fromCapture [Capture ann]
ys) [Capture ann]
ys
        f Maybe Any
_ Maybe String
_ (Ctor Any
x [Capture ann]
xs) = ([Capture ann] -> Capture ann)
-> StateT [(Any, String, Capture ann)] m [Capture ann]
-> StateT [(Any, String, Capture ann)] m (Capture ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Any -> [Capture ann] -> Capture ann
forall ann. Any -> [Capture ann] -> Capture ann
Ctor Any
x) (StateT [(Any, String, Capture ann)] m [Capture ann]
 -> StateT [(Any, String, Capture ann)] m (Capture ann))
-> StateT [(Any, String, Capture ann)] m [Capture ann]
-> StateT [(Any, String, Capture ann)] m (Capture ann)
forall a b. (a -> b) -> a -> b
$ (Capture ann
 -> StateT [(Any, String, Capture ann)] m (Capture ann))
-> [Capture ann]
-> StateT [(Any, String, Capture ann)] m [Capture ann]
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
forall a. Maybe a
Nothing Maybe String
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 (Any -> Maybe Any
forall a. a -> Maybe a
Just Any
ctor) (String -> Maybe String
forall a. a -> Maybe a
Just String
field) Capture ann
x
            ([(Any, String, Capture ann)] -> [(Any, String, Capture ann)])
-> StateT [(Any, String, Capture ann)] m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((Any
ctor,String
field,Capture ann
y)(Any, String, Capture ann)
-> [(Any, String, Capture ann)] -> [(Any, String, Capture ann)]
forall a. a -> [a] -> [a]
:)
            Capture ann -> StateT [(Any, String, Capture ann)] m (Capture ann)
forall (m :: * -> *) a. Monad m => a -> m a
return Capture ann
y

        err :: String -> a
err String
x = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"System.Console.CmdArgs.Annotate.defaultMissing, " String -> ShowS
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 = IO (IORef [Either (Capture Any -> Capture Any) (Capture Any)])
-> IORef [Either (Capture Any -> Capture Any) (Capture Any)]
forall a. IO a -> a
unsafePerformIO (IO (IORef [Either (Capture Any -> Capture Any) (Capture Any)])
 -> IORef [Either (Capture Any -> Capture Any) (Capture Any)])
-> IO (IORef [Either (Capture Any -> Capture Any) (Capture Any)])
-> IORef [Either (Capture Any -> Capture Any) (Capture Any)]
forall a b. (a -> b) -> a -> b
$ [Either (Capture Any -> Capture Any) (Capture Any)]
-> IO (IORef [Either (Capture Any -> Capture Any) (Capture Any)])
forall a. a -> IO (IORef a)
newIORef []

push :: IO ()
push = IORef [Either (Capture Any -> Capture Any) (Capture Any)]
-> ([Either (Capture Any -> Capture Any) (Capture Any)]
    -> [Either (Capture Any -> Capture Any) (Capture Any)])
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [Either (Capture Any -> Capture Any) (Capture Any)]
ref ((Capture Any -> Capture Any)
-> Either (Capture Any -> Capture Any) (Capture Any)
forall a b. a -> Either a b
Left Capture Any -> Capture Any
forall a. a -> a
id Either (Capture Any -> Capture Any) (Capture Any)
-> [Either (Capture Any -> Capture Any) (Capture Any)]
-> [Either (Capture Any -> Capture Any) (Capture Any)]
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 <- IORef [Either (Capture Any -> Capture Any) (Capture Any)]
-> IO [Either (Capture Any -> Capture Any) (Capture Any)]
forall a. IORef a -> IO a
readIORef IORef [Either (Capture Any -> Capture Any) (Capture Any)]
ref; IORef [Either (Capture Any -> Capture Any) (Capture Any)]
-> [Either (Capture Any -> Capture Any) (Capture Any)] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [Either (Capture Any -> Capture Any) (Capture Any)]
ref [Either (Capture Any -> Capture Any) (Capture Any)]
xs; Either (Capture Any -> Capture Any) (Capture Any)
-> IO (Either (Capture Any -> Capture Any) (Capture Any))
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 = IORef [Either (Capture Any -> Capture Any) (Capture Any)]
-> ([Either (Capture Any -> Capture Any) (Capture Any)]
    -> [Either (Capture Any -> Capture Any) (Capture Any)])
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [Either (Capture Any -> Capture Any) (Capture Any)]
ref (([Either (Capture Any -> Capture Any) (Capture Any)]
  -> [Either (Capture Any -> Capture Any) (Capture Any)])
 -> IO ())
-> ([Either (Capture Any -> Capture Any) (Capture Any)]
    -> [Either (Capture Any -> Capture Any) (Capture Any)])
-> IO ()
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 Either (Capture Any -> Capture Any) (Capture Any)
-> [Either (Capture Any -> Capture Any) (Capture Any)]
-> [Either (Capture Any -> Capture Any) (Capture Any)]
forall a. a -> [a] -> [a]
: [Either (Capture Any -> Capture Any) (Capture Any)]
rest ; [Either (Capture Any -> Capture Any) (Capture Any)]
_ -> String -> [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 (((Capture Any -> Capture Any)
  -> Either (Capture Any -> Capture Any) (Capture Any))
 -> IO ())
-> ((Capture Any -> Capture Any)
    -> Either (Capture Any -> Capture Any) (Capture Any))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Capture Any -> Capture Any
x -> (Capture Any -> Capture Any)
-> Either (Capture Any -> Capture Any) (Capture Any)
forall a b. a -> Either a b
Left ((Capture Any -> Capture Any)
 -> Either (Capture Any -> Capture Any) (Capture Any))
-> (Capture Any -> Capture Any)
-> Either (Capture Any -> Capture Any) (Capture Any)
forall a b. (a -> b) -> a -> b
$ Capture Any -> Capture Any
x (Capture Any -> Capture Any)
-> (Capture Any -> Capture Any) -> Capture Any -> Capture Any
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 (((Capture Any -> Capture Any)
  -> Either (Capture Any -> Capture Any) (Capture Any))
 -> IO ())
-> ((Capture Any -> Capture Any)
    -> Either (Capture Any -> Capture Any) (Capture Any))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Capture Any -> Capture Any
f -> Capture Any -> Either (Capture Any -> Capture Any) (Capture Any)
forall a b. b -> Either a b
Right (Capture Any -> Either (Capture Any -> Capture Any) (Capture Any))
-> Capture Any -> Either (Capture Any -> Capture Any) (Capture Any)
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 :: [val] -> val
many [val]
xs = IO val -> val
forall a. IO a -> a
unsafePerformIO (IO val -> val) -> IO val -> val
forall a b. (a -> b) -> a -> b
$ do
    [Capture Any]
ys <- (val -> IO (Capture Any)) -> [val] -> IO [Capture Any]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Any -> IO (Capture Any)
force (Any -> IO (Capture Any))
-> (val -> Any) -> val -> IO (Capture Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. val -> Any
forall a. Data a => a -> Any
Any) [val]
xs
    Capture Any -> IO ()
set (Capture Any -> IO ()) -> Capture Any -> IO ()
forall a b. (a -> b) -> a -> b
$ [Capture Any] -> Capture Any
forall ann. [Capture ann] -> Capture ann
Many [Capture Any]
ys
    val -> IO val
forall (m :: * -> *) a. Monad m => a -> m a
return (val -> IO val) -> val -> IO val
forall a b. (a -> b) -> a -> b
$ [val] -> val
forall a. [a] -> a
head [val]
xs


{-# NOINLINE addAnn #-}
addAnn :: (Data val, Data ann) => val -> ann -> val
addAnn :: val -> ann -> val
addAnn val
x ann
y = IO val -> val
forall a. IO a -> a
unsafePerformIO (IO val -> val) -> IO val -> val
forall a b. (a -> b) -> a -> b
$ do
    (Capture Any -> Capture Any) -> IO ()
add (Any -> Capture Any -> Capture Any
forall ann. ann -> Capture ann -> Capture ann
Ann (Any -> Capture Any -> Capture Any)
-> Any -> Capture Any -> Capture Any
forall a b. (a -> b) -> a -> b
$ ann -> Any
forall a. Data a => a -> Any
Any ann
y)
    val -> IO val
forall a. a -> IO a
evaluate val
x
    val -> IO val
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 :: val -> Capture ann
capture val
x = IO (Capture ann) -> Capture ann
forall a. IO a -> a
unsafePerformIO (IO (Capture ann) -> Capture ann)
-> IO (Capture ann) -> Capture ann
forall a b. (a -> b) -> a -> b
$ (Capture Any -> Capture ann)
-> IO (Capture Any) -> IO (Capture ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Any -> ann) -> Capture Any -> Capture ann
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Any -> ann
forall a. Typeable a => Any -> a
fromAny) (IO (Capture Any) -> IO (Capture ann))
-> IO (Capture Any) -> IO (Capture ann)
forall a b. (a -> b) -> a -> b
$ Any -> IO (Capture Any)
force (Any -> IO (Capture Any)) -> Any -> IO (Capture Any)
forall a b. (a -> b) -> a -> b
$ val -> Any
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 <- IO a -> IO (Either RecConError a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO a -> IO (Either RecConError a))
-> IO a -> IO (Either RecConError a)
forall a b. (a -> b) -> a -> b
$ a -> IO a
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 -> Capture Any -> IO (Capture Any)
forall (m :: * -> *) a. Monad m => a -> m a
return (Capture Any -> IO (Capture Any))
-> Capture Any -> IO (Capture Any)
forall a b. (a -> b) -> a -> b
$ Any -> Capture Any
forall ann. Any -> Capture ann
Missing Any
x
        Right Capture Any
r -> Capture Any -> IO (Capture Any)
forall (m :: * -> *) a. Monad m => a -> m a
return Capture Any
r
        Left Capture Any -> Capture Any
f | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Any -> Bool
isAlgType Any
x -> Capture Any -> IO (Capture Any)
forall (m :: * -> *) a. Monad m => a -> m a
return (Capture Any -> IO (Capture Any))
-> Capture Any -> IO (Capture Any)
forall a b. (a -> b) -> a -> b
$ Capture Any -> Capture Any
f (Capture Any -> Capture Any) -> Capture Any -> Capture Any
forall a b. (a -> b) -> a -> b
$ Any -> Capture Any
forall ann. Any -> Capture ann
Value Any
x
               | Bool
otherwise -> do
            [Capture Any]
cs <- (Any -> IO (Capture Any)) -> [Any] -> IO [Capture Any]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Any -> IO (Capture Any)
force ([Any] -> IO [Capture Any]) -> [Any] -> IO [Capture Any]
forall a b. (a -> b) -> a -> b
$ Any -> [Any]
children Any
x
            Capture Any -> IO (Capture Any)
forall (m :: * -> *) a. Monad m => a -> m a
return (Capture Any -> IO (Capture Any))
-> Capture Any -> IO (Capture Any)
forall a b. (a -> b) -> a -> b
$ Capture Any -> Capture Any
f (Capture Any -> Capture Any) -> Capture Any -> Capture Any
forall a b. (a -> b) -> a -> b
$ Any -> [Capture Any] -> Capture Any
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
&= :: val -> ann -> val
(&=) val
x ann
y = val -> ann -> val
forall val ann. (Data val, Data ann) => val -> ann -> val
addAnn (val -> val
forall a. a -> a
id_ val
x) (ann -> ann
forall a. a -> a
id_ ann
y)

{-# INLINE id_ #-}
id_ :: a -> a
id_ :: a -> a
id_ a
x = case ()
unit of () -> a
x
    where unit :: ()
unit = ShowS
forall a. [a] -> [a]
reverse String
"" String -> () -> ()
`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
+= :: Annotate ann -> ann -> Annotate ann
(+=) = (ann -> Annotate ann -> Annotate ann)
-> Annotate ann -> ann -> Annotate ann
forall a b c. (a -> b -> c) -> b -> a -> c
flip ann -> Annotate ann -> Annotate ann
forall ann. ann -> Annotate ann -> Annotate ann
AAnn

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

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


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



data ExceptionInt = ExceptionInt Int deriving (Int -> ExceptionInt -> ShowS
[ExceptionInt] -> ShowS
ExceptionInt -> String
(Int -> ExceptionInt -> ShowS)
-> (ExceptionInt -> String)
-> ([ExceptionInt] -> ShowS)
-> Show ExceptionInt
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 :: Int -> a
throwInt Int
i = ExceptionInt -> a
forall a e. Exception e => e -> a
throw (Int -> ExceptionInt
ExceptionInt Int
i)


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