module Data.IxSet.Typed
(
IxSet,
Indexable(..),
noCalcs,
inferIxSet,
ixSet,
mkEmpty,
ixFun,
ixGen,
IndexOp,
change,
insert,
insertList,
delete,
updateIx,
deleteIx,
fromSet,
fromList,
toSet,
toList,
toAscList,
toDescList,
getOne,
getOneOr,
size,
null,
(&&&),
(|||),
union,
intersection,
(@=),
(@<),
(@>),
(@<=),
(@>=),
(@><),
(@>=<),
(@><=),
(@>=<=),
(@+),
(@*),
getEQ,
getLT,
getGT,
getLTE,
getGTE,
getRange,
groupBy,
groupAscBy,
groupDescBy,
flatten,
flattenWithCalcs,
stats
)
where
import Prelude hiding (null)
import Control.Arrow (first, second)
import Data.Generics (Data, gmapQ)
import qualified Data.IxSet.Typed.Ix as Ix
import Data.IxSet.Typed.Ix (Ix(Ix))
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid(mempty, mappend))
import Data.SafeCopy (SafeCopy(..), contain, safeGet, safePut)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Typeable (Typeable, cast )
import Language.Haskell.TH as TH
import GHC.Exts (Constraint)
data IxSet (ixs :: [*]) (a :: *) where
IxSet :: Set a -> IxList ixs a -> IxSet ixs a
data IxList (ixs :: [*]) (a :: *) where
Nil :: IxList '[] a
(:::) :: Ix ix a -> IxList ixs a -> IxList (ix ': ixs) a
infixr 5 :::
type family All (c :: * -> Constraint) (xs :: [*]) :: Constraint
type instance All c '[] = ()
type instance All c (x ': xs) = (c x, All c xs)
lengthIxList :: forall ixs a. IxList ixs a -> Int
lengthIxList = go 0
where
go :: forall ixs'. Int -> IxList ixs' a -> Int
go !acc Nil = acc
go !acc (_ ::: xs) = go (acc + 1) xs
ixListToList :: All Ord ixs => (forall ix. Ord ix => Ix ix a -> r) -> IxList ixs a -> [r]
ixListToList _ Nil = []
ixListToList f (x ::: xs) = f x : ixListToList f xs
mapIxList :: (All Ord ixs)
=> (forall ix. Ord ix => Ix ix a -> Ix ix a)
-> IxList ixs a -> IxList ixs a
mapIxList _ Nil = Nil
mapIxList f (x ::: xs) = f x ::: mapIxList f xs
zipWithIxList :: (All Ord ixs)
=> (forall ix. Ord ix => Ix ix a -> Ix ix a -> Ix ix a)
-> IxList ixs a -> IxList ixs a -> IxList ixs a
zipWithIxList _ Nil Nil = Nil
zipWithIxList f (x ::: xs) (y ::: ys) = f x y ::: zipWithIxList f xs ys
zipWithIxList _ _ _ = error "Data.IxSet.Typed.zipWithIxList: impossible"
class Ord ix => IsIndexOf (ix :: *) (ixs :: [*]) where
access :: IxList ixs a -> Ix ix a
mapAt :: (All Ord ixs)
=> (Ix ix a -> Ix ix a)
-> (forall ix'. Ord ix' => Ix ix' a -> Ix ix' a)
-> IxList ixs a -> IxList ixs a
instance Ord ix => IsIndexOf ix (ix ': ixs) where
access (x ::: _xs) = x
mapAt fh ft (x ::: xs) = fh x ::: mapIxList ft xs
instance IsIndexOf ix ixs => IsIndexOf ix (ix' ': ixs) where
access (_x ::: xs) = access xs
mapAt fh ft (x ::: xs) = ft x ::: mapAt fh ft xs
ixSet :: MkIxSet ixs ixs a r => Set a -> r
ixSet s = ixSet' (IxSet s)
mkEmpty :: MkIxSet ixs ixs a r => r
mkEmpty = ixSet Set.empty
class MkIxSet ixs ixs' a r | r -> a ixs ixs' where
ixSet' :: (IxList ixs a -> IxSet ixs' a) -> r
instance MkIxSet '[] ixs a (IxSet ixs a) where
ixSet' acc = acc Nil
instance MkIxSet ixs ixs' a r => MkIxSet (ix ': ixs) ixs' a (Ix ix a -> r) where
ixSet' acc ix = ixSet' (\ x -> acc (ix ::: x))
ixFun :: Ord ix => (a -> [ix]) -> Ix ix a
ixFun = Ix Map.empty
ixGen :: forall proxy a ix. (Ord ix, Data a, Typeable ix) => proxy ix -> Ix ix a
ixGen _proxy = ixFun (flatten :: a -> [ix])
instance Indexable ixs a => Eq (IxSet ixs a) where
IxSet a _ == IxSet b _ = a == b
instance Indexable ixs a => Ord (IxSet ixs a) where
compare (IxSet a _) (IxSet b _) = compare a b
instance (Indexable ixs a, SafeCopy a) => SafeCopy (IxSet ixs a) where
putCopy = contain . safePut . toList
getCopy = contain $ fmap fromList safeGet
instance (Indexable ixs a, Show a) => Show (IxSet ixs a) where
showsPrec prec = showsPrec prec . toSet
instance (Indexable ixs a, Read a) => Read (IxSet ixs a) where
readsPrec n = map (first fromSet) . readsPrec n
class (All Ord ixs, Ord a) => Indexable ixs a where
empty :: IxSet ixs a
noCalcs :: t -> ()
noCalcs _ = ()
inferIxSet :: String -> TH.Name -> TH.Name -> [TH.Name] -> Q [Dec]
inferIxSet _ _ _ [] = error "inferIxSet needs at least one index"
inferIxSet ixset typeName calName entryPoints
= do calInfo <- reify calName
typeInfo <- reify typeName
let (context,binders) = case typeInfo of
TyConI (DataD ctxt _ nms _ _) -> (ctxt,nms)
TyConI (NewtypeD ctxt _ nms _ _) -> (ctxt,nms)
TyConI (TySynD _ nms _) -> ([],nms)
_ -> error "IxSet.inferIxSet typeInfo unexpected match"
names = map tyVarBndrToName binders
typeCon = List.foldl' appT (conT typeName) (map varT names)
mkCtx = classP
dataCtxConQ = concat [[mkCtx ''Data [varT name], mkCtx ''Ord [varT name]] | name <- names]
fullContext = do
dataCtxCon <- sequence dataCtxConQ
return (context ++ dataCtxCon)
case calInfo of
VarI _ _t _ _ ->
let
mkEntryPoint n = (conE 'Ix) `appE`
(sigE (varE 'Map.empty) (forallT binders (return context) $
appT (appT (conT ''Map) (conT n))
(appT (conT ''Set) typeCon))) `appE`
(varE 'flattenWithCalcs `appE` varE calName)
mkTypeList :: [TypeQ] -> TypeQ
mkTypeList = foldr (\ x xs -> promotedConsT `appT` x `appT` xs) promotedNilT
typeList :: TypeQ
typeList = mkTypeList (map conT entryPoints)
in do i <- instanceD (fullContext)
(conT ''Indexable `appT` typeList `appT` typeCon)
[valD (varP 'empty) (normalB (appsE ([| mkEmpty |] : map mkEntryPoint entryPoints))) []]
let ixType = conT ''IxSet `appT` typeList `appT` typeCon
ixType' <- tySynD (mkName ixset) binders ixType
return $ [i, ixType']
_ -> error "IxSet.inferIxSet calInfo unexpected match"
tyVarBndrToName :: TyVarBndr -> Name
tyVarBndrToName (PlainTV nm) = nm
tyVarBndrToName (KindedTV nm _) = nm
type SetOp =
forall a. Ord a => a -> Set a -> Set a
type IndexOp =
forall k a. (Ord k,Ord a) => k -> a -> Map k (Set a) -> Map k (Set a)
flatten :: (Typeable a, Data a, Typeable b) => a -> [b]
flatten x = case cast x of
Just y -> case cast (y :: String) of
Just v -> [v]
Nothing -> []
Nothing -> case cast x of
Just v -> v : concat (gmapQ flatten x)
Nothing -> concat (gmapQ flatten x)
flattenWithCalcs :: (Data c,Typeable a, Data a, Typeable b) => (a -> c) -> a -> [b]
flattenWithCalcs calcs x = flatten (x,calcs x)
change :: forall ixs a. (Indexable ixs a) =>
SetOp -> IndexOp -> a -> IxSet ixs a -> IxSet ixs a
change opS opI x (IxSet a indexes) = IxSet (opS x a) v
where
v :: IxList ixs a
v = mapIxList update indexes
update :: forall ix. Ord ix => Ix ix a -> Ix ix a
update (Ix index f) = Ix index' f
where
ds :: [ix]
ds = f x
ii :: forall k. Ord k => Map k (Set a) -> k -> Map k (Set a)
ii m dkey = opI dkey x m
index' :: Map ix (Set a)
index' = List.foldl' ii index ds
insertList :: forall ixs a. (Indexable ixs a)
=> [a] -> IxSet ixs a -> IxSet ixs a
insertList xs (IxSet a indexes) = IxSet (List.foldl' (\ b x -> Set.insert x b) a xs) v
where
v :: IxList ixs a
v = mapIxList update indexes
update :: forall ix. Ord ix => Ix ix a -> Ix ix a
update (Ix index f) = Ix index' f
where
dss :: [(ix, a)]
dss = [(k, x) | x <- xs, k <- f x]
index' :: Map ix (Set a)
index' = Ix.insertList dss index
fromMapOfSets :: forall ixs ix a. (Indexable ixs a, IsIndexOf ix ixs)
=> Map ix (Set a) -> IxSet ixs a
fromMapOfSets partialindex = case empty of
IxSet _ ixs -> IxSet a (mapAt updateh updatet ixs)
where
a :: Set a
a = Set.unions (Map.elems partialindex)
xs :: [a]
xs = Set.toList a
updateh :: Ix ix a -> Ix ix a
updateh (Ix _ f) = Ix ix f
where
dss :: [(ix, a)]
dss = [(k, x) | x <- xs, k <- f x, not (Map.member k partialindex)]
ix :: Map ix (Set a)
ix = Ix.insertList dss partialindex
updatet :: forall ix'. Ord ix' => Ix ix' a -> Ix ix' a
updatet (Ix _ f) = Ix ix f
where
dss :: [(ix', a)]
dss = [(k, x) | x <- xs, k <- f x]
ix :: Map ix' (Set a)
ix = Ix.fromList dss
insert :: Indexable ixs a => a -> IxSet ixs a -> IxSet ixs a
insert = change Set.insert Ix.insert
delete :: Indexable ixs a => a -> IxSet ixs a -> IxSet ixs a
delete = change Set.delete Ix.delete
updateIx :: (Indexable ixs a, IsIndexOf ix ixs, Ord ix)
=> ix -> a -> IxSet ixs a -> IxSet ixs a
updateIx i new ixset = insert new $
maybe ixset (flip delete ixset) $
getOne $ ixset @= i
deleteIx :: (Indexable ixs a, IsIndexOf ix ixs, Ord ix)
=> ix -> IxSet ixs a -> IxSet ixs a
deleteIx i ixset = maybe ixset (flip delete ixset) $
getOne $ ixset @= i
toSet :: Ord a => IxSet ixs a -> Set a
toSet (IxSet a _) = a
fromSet :: (Indexable ixs a) => Set a -> IxSet ixs a
fromSet = fromList . Set.toList
fromList :: (Indexable ixs a) => [a] -> IxSet ixs a
fromList list = insertList list empty
size :: Ord a => IxSet ixs a -> Int
size = Set.size . toSet
toList :: Ord a => IxSet ixs a -> [a]
toList = Set.toList . toSet
toAscList :: forall proxy ix ixs a. IsIndexOf ix ixs => proxy ix -> IxSet ixs a -> [a]
toAscList _ ixset = concatMap snd (groupAscBy ixset :: [(ix, [a])])
toDescList :: forall proxy ix ixs a. IsIndexOf ix ixs => proxy ix -> IxSet ixs a -> [a]
toDescList _ ixset = concatMap snd (groupDescBy ixset :: [(ix, [a])])
getOne :: Ord a => IxSet ixs a -> Maybe a
getOne ixset = case toList ixset of
[x] -> Just x
_ -> Nothing
getOneOr :: Ord a => a -> IxSet ixs a -> a
getOneOr def = fromMaybe def . getOne
null :: IxSet ixs a -> Bool
null (IxSet a _) = Set.null a
(&&&) :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a
(&&&) = intersection
(|||) :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a
(|||) = union
infixr 5 &&&
infixr 5 |||
union :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a
union (IxSet a1 x1) (IxSet a2 x2) =
IxSet (Set.union a1 a2)
(zipWithIxList (\ (Ix a f) (Ix b _) -> Ix (Ix.union a b) f) x1 x2)
intersection :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a
intersection (IxSet a1 x1) (IxSet a2 x2) =
IxSet (Set.intersection a1 a2)
(zipWithIxList (\ (Ix a f) (Ix b _) -> Ix (Ix.intersection a b) f) x1 x2)
(@=) :: (Indexable ixs a, IsIndexOf ix ixs)
=> IxSet ixs a -> ix -> IxSet ixs a
ix @= v = getEQ v ix
(@<) :: (Indexable ixs a, IsIndexOf ix ixs)
=> IxSet ixs a -> ix -> IxSet ixs a
ix @< v = getLT v ix
(@>) :: (Indexable ixs a, IsIndexOf ix ixs)
=> IxSet ixs a -> ix -> IxSet ixs a
ix @> v = getGT v ix
(@<=) :: (Indexable ixs a, IsIndexOf ix ixs)
=> IxSet ixs a -> ix -> IxSet ixs a
ix @<= v = getLTE v ix
(@>=) :: (Indexable ixs a, IsIndexOf ix ixs)
=> IxSet ixs a -> ix -> IxSet ixs a
ix @>= v = getGTE v ix
(@><) :: (Indexable ixs a, IsIndexOf ix ixs)
=> IxSet ixs a -> (ix, ix) -> IxSet ixs a
ix @>< (v1,v2) = getLT v2 $ getGT v1 ix
(@>=<) :: (Indexable ixs a, IsIndexOf ix ixs)
=> IxSet ixs a -> (ix, ix) -> IxSet ixs a
ix @>=< (v1,v2) = getLT v2 $ getGTE v1 ix
(@><=) :: (Indexable ixs a, IsIndexOf ix ixs)
=> IxSet ixs a -> (ix, ix) -> IxSet ixs a
ix @><= (v1,v2) = getLTE v2 $ getGT v1 ix
(@>=<=) :: (Indexable ixs a, IsIndexOf ix ixs)
=> IxSet ixs a -> (ix, ix) -> IxSet ixs a
ix @>=<= (v1,v2) = getLTE v2 $ getGTE v1 ix
(@+) :: (Indexable ixs a, IsIndexOf ix ixs)
=> IxSet ixs a -> [ix] -> IxSet ixs a
ix @+ list = List.foldl' union empty $ map (ix @=) list
(@*) :: (Indexable ixs a, IsIndexOf ix ixs)
=> IxSet ixs a -> [ix] -> IxSet ixs a
ix @* list = List.foldl' intersection ix $ map (ix @=) list
getEQ :: (Indexable ixs a, IsIndexOf ix ixs)
=> ix -> IxSet ixs a -> IxSet ixs a
getEQ = getOrd EQ
getLT :: (Indexable ixs a, IsIndexOf ix ixs)
=> ix -> IxSet ixs a -> IxSet ixs a
getLT = getOrd LT
getGT :: (Indexable ixs a, IsIndexOf ix ixs)
=> ix -> IxSet ixs a -> IxSet ixs a
getGT = getOrd GT
getLTE :: (Indexable ixs a, IsIndexOf ix ixs)
=> ix -> IxSet ixs a -> IxSet ixs a
getLTE = getOrd2 True True False
getGTE :: (Indexable ixs a, IsIndexOf ix ixs)
=> ix -> IxSet ixs a -> IxSet ixs a
getGTE = getOrd2 False True True
getRange :: (Indexable ixs a, IsIndexOf ix ixs)
=> ix -> ix -> IxSet ixs a -> IxSet ixs a
getRange k1 k2 ixset = getGTE k1 (getLT k2 ixset)
groupBy :: forall ix ixs a. IsIndexOf ix ixs => IxSet ixs a -> [(ix, [a])]
groupBy (IxSet _ indexes) = f (access indexes)
where
f :: Ix ix a -> [(ix, [a])]
f (Ix index _) = map (second Set.toList) (Map.toList index)
groupAscBy :: forall ix ixs a. IsIndexOf ix ixs => IxSet ixs a -> [(ix, [a])]
groupAscBy (IxSet _ indexes) = f (access indexes)
where
f :: Ix ix a -> [(ix, [a])]
f (Ix index _) = map (second Set.toAscList) (Map.toAscList index)
groupDescBy :: IsIndexOf ix ixs => IxSet ixs a -> [(ix, [a])]
groupDescBy (IxSet _ indexes) = f (access indexes)
where
f :: Ix ix a -> [(ix, [a])]
f (Ix index _) = map (second Set.toAscList) (Map.toDescList index)
getOrd :: (Indexable ixs a, IsIndexOf ix ixs)
=> Ordering -> ix -> IxSet ixs a -> IxSet ixs a
getOrd LT = getOrd2 True False False
getOrd EQ = getOrd2 False True False
getOrd GT = getOrd2 False False True
getOrd2 :: forall ixs ix a. (Indexable ixs a, IsIndexOf ix ixs)
=> Bool -> Bool -> Bool -> ix -> IxSet ixs a -> IxSet ixs a
getOrd2 inclt inceq incgt v (IxSet _ ixs) = f (access ixs)
where
f :: Ix ix a -> IxSet ixs a
f (Ix index _) = fromMapOfSets result
where
lt', gt' :: Map ix (Set a)
eq' :: Maybe (Set a)
(lt', eq', gt') = Map.splitLookup v index
lt, gt :: Map ix (Set a)
lt = if inclt then lt' else Map.empty
gt = if incgt then gt' else Map.empty
eq :: Maybe (Set a)
eq = if inceq then eq' else Nothing
ltgt :: Map ix (Set a)
ltgt = Map.unionWith Set.union lt gt
result :: Map ix (Set a)
result = case eq of
Just eqset -> Map.insertWith Set.union v eqset ltgt
Nothing -> ltgt
instance (Indexable ixs a) => Monoid (IxSet ixs a) where
mempty = empty
mappend = union
stats :: (Indexable ixs a) => IxSet ixs a -> (Int,Int,Int,Int)
stats (IxSet a ixs) = (no_elements,no_indexes,no_keys,no_values)
where
no_elements = Set.size a
no_indexes = lengthIxList ixs
no_keys = sum (ixListToList (\ (Ix m _) -> Map.size m) ixs)
no_values = sum (ixListToList (\ (Ix m _) -> sum [Set.size s | s <- Map.elems m]) ixs)