{-# LANGUAGE PatternGuards, ScopedTypeVariables, ExistentialQuantification, DeriveDataTypeable #-} -- | 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