content: {-# 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 Show
  
  instance Functor Capture where
      fmap f (Many xs) = Many $ map (fmap f) xs
      fmap f (Ann a x) = Ann (f a) $ fmap f x
      fmap f (Value x) = Value x
      fmap f (Missing x) = Missing x
      fmap f (Ctor x xs) = Ctor x $ map (fmap f) xs
  
  
  -- | Return the value inside a capture.
  fromCapture :: Capture ann -> Any
  fromCapture (Many (x:_)) = fromCapture x
  fromCapture (Ann _ x) = fromCapture x
  fromCapture (Value x) = x
  fromCapture (Missing x) = x
  fromCapture (Ctor x _) = x
  
  
  -- | Remove all Missing values by using any previous instances as default values
  defaultMissing :: Capture ann -> Capture ann
  defaultMissing x = evalState (f Nothing Nothing x) []
      where
          f ctor field (Many xs) = fmap Many $ mapM (f ctor field) xs
          f ctor field (Ann a x) = fmap (Ann a) $ f ctor field x
          f ctor field (Value x) = return $ Value x
          f (Just ctor) (Just field) (Missing x) = do
              s <- get
              return $ head $
                  [x2 | (ctor2,field2,x2) <- s, typeOf ctor == typeOf ctor2, field == field2] ++
                  err ("missing value encountered, no field for " ++ field ++ " (of type " ++ show x ++ ")")
          f _ _ (Missing x) = err $ "missing value encountered, but not as a field (of type " ++ show x ++ ")"
          f _ _ (Ctor x xs) | length (fields x) == length xs = do
              ys <- zipWithM (g x) (fields x) xs
              return $ Ctor (recompose x $ map fromCapture ys) ys
          f _ _ (Ctor x xs) = fmap (Ctor x) $ mapM (f Nothing Nothing) xs
  
          g ctor field x = do
              y <- f (Just ctor) (Just field) x
              modify ((ctor,field,y):)
              return y
  
          err x = error $ "System.Console.CmdArgs.Annotate.defaultMissing, " ++ 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 = unsafePerformIO $ newIORef []
  
  push = modifyIORef ref (Left id :)
  pop = do x:xs <- readIORef ref; writeIORef ref xs; return x
  change f = modifyIORef ref $ \x -> case x of Left g : rest -> f g : rest ; _ -> error "Internal error in Capture"
  add f = change $ \x -> Left $ x . f
  set x = change $ \f -> Right $ f x
  
  
  -- | Collapse multiple values in to one.
  {-# NOINLINE many #-}
  many :: Data val => [val] -> val
  many xs = unsafePerformIO $ do
      ys <- mapM (force . Any) xs
      set $ Many ys
      return $ head xs
  
  
  {-# NOINLINE addAnn #-}
  addAnn :: (Data val, Data ann) => val -> ann -> val
  addAnn x y = unsafePerformIO $ do
      add (Ann $ Any y)
      evaluate x
      return 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 x = unsafePerformIO $ fmap (fmap fromAny) $ force $ Any x
  
  
  force :: Any -> IO (Capture Any)
  force x@(Any xx) = do
      push
      res <- try $ evaluate xx
      y <- pop
      case y of
          _ | Left (_ :: RecConError) <- res -> return $ Missing x
          Right r -> return r
          Left f | not $ isAlgType x -> return $ f $ Value x
                 | otherwise -> do
              cs <- mapM force $ children x
              return $ f $ Ctor x 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
  (&=) x y = addAnn (id_ x) (id_ y)
  
  {-# INLINE id_ #-}
  id_ :: a -> a
  id_ x = case unit of () -> x
      where unit = reverse "" `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
  (+=) = flip AAnn
  
  -- | Collapse many annotated values in to one.
  many_ :: [Annotate a] -> Annotate a
  many_ = AMany
  
  -- | Lift a pure value to an annotation.
  atom :: Data val => val -> Annotate ann
  atom = AAtom . 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 b = ACtor (Any a) b
  
  -- | Capture the annotations from an annotated value.
  capture_ :: Show a => Annotate a -> Capture a
  capture_ (AAnn a x) = Ann a (capture_ x)
  capture_ (AMany xs) = Many (map capture_ xs)
  capture_ (AAtom x) = Value x
  capture_ (_ := c) = Value $ Any c
  capture_ (_ :=+ c) = Many $ map capture_ c
  capture_ (ACtor x xs)
      | not $ null rep = error $ "Some fields got repeated under " ++ show x ++ "." ++ ctor x ++ ": " ++ show rep
      | otherwise = Ctor x2 xs2
      where
          x2 = recompose x $ map fromCapture xs2
          xs2 = [fromMaybe (Missing c) $ lookup i is | let is = zip inds $ map capture_ xs, (i,c) <- zip [0..] $ children x]
          inds = zipWith fromMaybe [0..] $ map (fieldIndex x) xs
          rep = inds \\ nub inds
  
  
  fieldIndex :: Any -> Annotate a -> Maybe Int
  fieldIndex ctor (AAnn a x) = fieldIndex ctor x
  fieldIndex ctor (f := _) = fieldIndex ctor (f :=+ [])
  fieldIndex ctor (f :=+ _) | isJust res = res
                            | otherwise = error $ "Couldn't resolve field for " ++ show ctor
      where c = recompose ctor [Any $ throwInt i `asTypeOf` x | (i,Any x) <- zip [0..] (children ctor)]
            res = catchInt $ f $ fromAny c
  fieldIndex _ _ = Nothing
  
  
  
  data ExceptionInt = ExceptionInt Int deriving (Show, Typeable)
  instance Exception ExceptionInt
  
  
  throwInt :: Int -> a
  throwInt i = throw (ExceptionInt i)
  
  
  {-# NOINLINE catchInt #-}
  catchInt :: a -> Maybe Int
  catchInt x = unsafePerformIO $ do
      y <- try (evaluate x)
      return $ case y of
          Left (ExceptionInt z) -> Just z
          _ -> Nothing
  