module Info.Info( T, Info(..), Entry(..), HasInfo(..), Info.Info.lookup, Info.Info.lookupTyp, insertWith, insert, limit, maybeInsert, singleton, member, delete, fetch, extend, empty, infoMap, infoMapM ) where import Data.Dynamic import Data.Generics import Data.Monoid import Monad import qualified Data.List as List import GenUtil import Util.HasSize -- extensible type indexed product type T = Info data Entry = Entry { entryThing :: Dynamic, entryString :: String, entryType :: TypeRep } instance Eq Entry where a == b = entryType a == entryType b instance Show Entry where showsPrec _ x = showString (entryString x) instance Ord Entry where compare a b = compare (show $ entryType a) (show $ entryType b) newtype Info = Info [Entry] deriving(HasSize,Typeable) -- the Eq and Ord instances for info make them all seem equivalent. instance Eq Info where _ == _ = True instance Ord Info where compare _ _ = EQ instance Show Info where show (Info ds) = show (sortUnder (show . entryType) ds) instance Data Info where toConstr = undefined dataTypeOf = undefined instance Monoid Info where mempty = empty mappend (Info as) (Info bs) = Info (List.union as bs) class HasInfo a where getInfo :: a -> Info modifyInfo :: (Info -> Info) -> a -> a instance HasInfo Info where getInfo = id modifyInfo f x = f x lookupTyp :: forall a . Typeable a => a -> Info -> Maybe a lookupTyp a = f where f (Info mp) = g mp typ = typeOf (undefined :: a) g [] = Nothing g (x:xs) | entryType x == typ = fromDynamic (entryThing x) g (_:xs) = g xs lookup :: forall a m . (Monad m,Typeable a) => Info -> m a lookup = maybe (fail $ "Info: could not find: " ++ show typ) return . f where typ = typeOf (undefined :: a) f = lookupTyp (undefined :: a) insertWith :: (Show a,Typeable a) => (a -> a -> a) -> a -> Info -> Info insertWith f newx (Info mp) = Info (g mp) where g [] = [newEntry newx] g (x:xs) | entryType x == typ = newEntry (f newx (fromDyn (entryThing x) (error "can't happen"))):xs | otherwise = x:g xs typ = typeOf newx newEntry :: (Typeable a,Show a) => a -> Entry newEntry x = Entry { entryThing = toDyn x, entryString = show x, entryType = typeOf x } insert :: (Show a,Typeable a) => a -> Info -> Info insert newx (Info nfo) = Info $ newEntry newx:f nfo where f [] = [] f (x:xs) | entryType x == typ = xs | otherwise = x:f xs typ = typeOf newx maybeInsert :: (Show a, Typeable a) => Maybe a -> Info -> Info maybeInsert Nothing = id maybeInsert (Just x) = insert x singleton :: (Show a,Typeable a) => a -> Info singleton x = insert x empty infoMapM :: (Typeable a, Typeable b, Show b, Monad m) => (a -> m b) -> Info -> m Info infoMapM f i = case Info.Info.lookup i of Just x -> do n <- f x return (insert n (delete x i)) Nothing -> return i infoMap :: (Typeable a, Typeable b, Show b) => (a -> b) -> Info -> Info infoMap f i = case Info.Info.lookup i of Just x -> insert (f x) (delete x i) Nothing -> i delete :: (Typeable a) => a -> Info -> Info delete x info = deleteTyp (typeOf x) info deleteTyp :: TypeRep -> Info -> Info deleteTyp typ (Info mp) = Info (f mp) where f [] = [] f (x:xs) | entryType x == typ = xs | otherwise = x:f xs limit :: [TypeRep] -> Info -> Info limit trs (Info mp) = Info (f mp) where f (x:xs) | entryType x `elem` trs = x:f xs | otherwise = f xs f [] = [] fetch :: (Monoid a, Typeable a) => Info -> a fetch info = maybe mempty id (Info.Info.lookup info) member :: (Typeable a) => a -> Info -> Bool member x (Info s) = f s where typ = typeOf x f [] = False f (x:xs) | entryType x == typ = True | otherwise = f xs extend :: (Show a,Monoid a, Typeable a) => a -> Info -> Info extend x info = insertWith mappend x info empty :: Info empty = Info []