module HAppS.Data.IxSet (module HAppS.Data.IxSet,
module Ix)
where
import qualified HAppS.Data.IxSet.Ix as Ix
import HAppS.Data.IxSet.Ix (Ix(Ix))
import Data.Generics hiding (GT)
import Data.Dynamic
import Data.Maybe
import Data.Monoid
import Data.List (partition)
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import HAppS.Util.Common
import Control.Monad.Reader
import Language.Haskell.TH as TH
import HAppS.Util.TH
import HAppS.State
import HAppS.Data
import qualified Data.Generics.SYB.WithClass.Basics as SYBWC
data IxSet a = ISet [a] | IxSet [Ix a]
deriving (Data, Typeable)
instance Version (IxSet a)
instance (Serialize a, Ord a, Data a, Indexable a b) => Serialize (IxSet a) where
putCopy ixset = contain $ safePut (toList ixset)
getCopy = contain $ liftM fromList safeGet
instance (SYBWC.Data ctx a, SYBWC.Sat (ctx (IxSet a)), SYBWC.Sat (ctx [a]),
Indexable a b, Data a, Ord a)
=> SYBWC.Data ctx (IxSet a) where
gfoldl _ f z (IxSet x) = z fromList `f` toList' x
gfoldl _ f z (ISet x) = z ISet `f` x
toConstr _ (ISet _) = iSetConstr
toConstr _ (IxSet _) = ixSetConstr
gunfold _ k z c = case SYBWC.constrIndex c of
1 -> k (z ISet)
2 -> k (z fromList)
dataTypeOf _ _ = ixSetDataType
iSetConstr :: SYBWC.Constr
iSetConstr = SYBWC.mkConstr ixSetDataType "ISet" [] SYBWC.Prefix
ixSetConstr :: SYBWC.Constr
ixSetConstr = SYBWC.mkConstr ixSetDataType "IxSet" [] SYBWC.Prefix
ixSetDataType :: SYBWC.DataType
ixSetDataType = SYBWC.mkDataType "IxSet" [iSetConstr, ixSetConstr]
instance (Indexable a b, Data a, Ord a, Default a) => Default (IxSet a) where
defaultValue = ISet []
instance (Ord a,Show a) => Show (IxSet a) where show = show . toSet
instance (Ord a,Read a,Data a,Indexable a b) => Read (IxSet a) where
readsPrec n = mapFst fromSet . readsPrec n
class (Data b) => Indexable a b | a->b where
empty :: IxSet a
calcs :: a->b
noCalcs x = ()
inferIxSet :: String -> TH.Name -> TH.Name -> [TH.Name] -> Q [Dec]
#ifndef __HADDOCK__
inferIxSet ixset typeName calName entryPoints
= do calInfo <- reify calName
typeInfo <- reify typeName
let (context,names) = case typeInfo of
TyConI (DataD context _ names _ _) -> (context,names)
TyConI (NewtypeD context _ names _ _) -> (context,names)
TyConI (TySynD _ names _) -> ([],names)
typeCon = foldl appT (conT typeName) (map varT names)
case calInfo of
VarI _ t _ _ ->
let calType = getCalType t
getCalType (ForallT names _ t') = getCalType t'
getCalType (AppT (AppT ArrowT _) t') = t'
getCalType t' = error ("Unexpected type: " ++ pprint t')
mkEntryPoint n = appE (conE 'Ix) (sigE (varE 'Map.empty) (forallT names (return context) $
appT (appT (conT ''Map) (conT n)) (appT (conT ''Set) typeCon)))
in do i <- instanceD' (return context) (appT (appT (conT ''Indexable) typeCon) (return calType))
[d| empty :: IxSet a
empty = IxSet $(listE (map mkEntryPoint entryPoints))
calcs :: a -> b
calcs = $(varE calName) |]
let ixType = appT (conT ''IxSet) typeCon
ixType' <- tySynD (mkName ixset) names ixType
return $ [i, ixType']
#endif
flatten :: (Typeable a, Data a) => a -> [Dynamic]
flatten x = case cast x of
Just y -> [toDyn (y :: String)]
Nothing -> toDyn x : concat (gmapQ flatten x)
type IndexOp =
forall k a. (Ord k,Ord a) => k -> a -> Map k (Set a) -> Map k (Set a)
change :: (Data a, Ord a,Data b,Indexable a b) =>
IndexOp -> a -> IxSet a -> IxSet a
change op x (ISet as) = change op x $ fromList as
change op x (IxSet indices) =
IxSet $ update indices $ flatten (x,calcs x)
where
update [] _ = []
update _ [] = []
update (Ix index:is) dyns = Ix index':update is dyns'
where
keyType = typeOf ((undefined :: Map key (Set a) -> key) index)
(ds,dyns') = partition (\d->dynTypeRep d == keyType) dyns
ii dkey = op (fromJust $ fromDynamic dkey) x
index' = foldr ii index ds
insert :: (Data a, Ord a,Data b,Indexable a b) => a -> IxSet a -> IxSet a
insert = change Ix.insert
delete :: (Data a, Ord a,Data b,Indexable a b) => a -> IxSet a -> IxSet a
delete = change Ix.delete
updateIx :: (Indexable a b, Ord a, Data a, Typeable k)
=> k -> a -> IxSet a -> IxSet a
updateIx i new ixset = insert new $
maybe ixset (flip delete ixset) $
getOne $ ixset @= i
toSet :: Ord a => IxSet a -> Set a
toSet (IxSet (Ix ix:_)) = Map.fold Set.union Set.empty ix
toSet (IxSet []) = Set.empty
toSet (ISet lst) = Set.fromList lst
toSet' :: Ord a => [Ix a] -> Set a
toSet' (Ix ix:_) = Map.fold Set.union Set.empty ix
toSet' [] = Set.empty
fromSet :: (Indexable a b, Ord a, Data a) => Set a -> IxSet a
fromSet set = Set.fold insert empty set
fromSet' :: (Indexable a b, Ord a, Data a) => Set a -> IxSet a
fromSet' set = Set.fold insert empty set
fromList :: (Indexable a b, Ord a, Data a) => [a] -> IxSet a
fromList list = fromSet $ Set.fromList list
size :: Ord a => IxSet a -> Int
size x = Set.size $ toSet x
toList :: Ord a => IxSet a -> [a]
toList x = Set.toList $ toSet x
toList' :: Ord a => [Ix a] -> [a]
toList' x = Set.toList $ toSet' x
getOne :: Ord a => IxSet a -> Maybe a
getOne ixset = case toList ixset of
[x] -> Just x
_ -> Nothing
getOneOr :: Ord a => a -> IxSet a -> a
getOneOr def = fromMaybe def . getOne
(&&&) :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a
x1 &&& x2 = intersection x1 x2
(|||) :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a
x1 ||| x2 = union x1 x2
infixr 5 &&&
infixr 5 |||
union :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a
union x1 x2 = fromSet $ Set.union (toSet x1) (toSet x2)
intersection :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a
intersection x1 x2 = fromSet $ Set.intersection (toSet x1) (toSet x2)
(@=), (@<), (@>), (@<=), (@>=)
:: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> k -> IxSet a
ix @= v = getEQ v ix
ix @< v = getLT v ix
ix @> v = getGT v ix
ix @<= v = getLTE v ix
ix @>= v = getGTE v ix
(@><), (@>=<), (@><=), (@>=<=)
:: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> (k, k) -> IxSet a
ix @>< (v1,v2) = getLT v2 $ getGT v1 ix
ix @>=< (v1,v2) = getLT v2 $ getGTE v1 ix
ix @><= (v1,v2) = getLTE v2 $ getGT v1 ix
ix @>=<= (v1,v2) = getLTE v2 $ getGTE v1 ix
(@+), (@*)
:: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> [k] -> IxSet a
ix @+ list = foldr union empty $ map (ix @=) list
ix @* list = foldr intersection empty $ map (ix @=) list
getEQ :: (Indexable a b, Data a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getEQ v ix = getOrd EQ v ix
getLT :: (Indexable a b, Data a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getLT v ix = getOrd LT v ix
getGT :: (Indexable a b, Data a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getGT v ix = getOrd GT v ix
getLTE :: (Indexable a b, Data a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getLTE v ix = let ix2 = (getLT v ix) in union ix2 $ getEQ v ix
getGTE :: (Indexable a b, Data a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getGTE v ix = let ix2 = (getOrd GT v ix) in union ix2 $ getEQ v ix
getRange :: (Indexable a b, Typeable k, Ord a, Data a)
=> k -> k -> IxSet a -> IxSet a
getRange k1 k2 ixset = intersection (getGTE k1 ixset) (getLT k2 ixset)
groupBy::(Typeable k,Typeable t) => IxSet t -> [(k, [t])]
groupBy (IxSet indices) = collect indices
where
collect [] = []
collect (Ix index:is) = maybe (collect is) f (fromDynamic $ toDyn index)
f = mapSnd Set.toList . Map.toList
rGroupBy x = reverse $ groupBy x
getOrd :: (Indexable a b, Ord a, Data a, Typeable k)
=> Ordering -> k -> IxSet a -> IxSet a
getOrd ord v (IxSet indices) = collect indices
where
v' = toDyn v
collect [] = empty
collect (Ix index:is) = maybe (collect is) f $ fromDynamic v'
where
f v'' = foldr insert empty $
case ord of
LT -> lt
GT -> gt
EQ -> eq
where
(lt',eq',gt')=Map.splitLookup v'' index
lt = concat $ map (Set.toList . snd) $ Map.toList lt'
gt = concat $ map (Set.toList . snd) $ Map.toList gt'
eq = maybe [] Set.toList eq'
instance (Show a,Indexable a b,Data a,Ord a) => Monoid (IxSet a) where
mempty=empty
mappend = union