module Happstack.Data.IxSet (module Happstack.Data.IxSet,
module Ix)
where
import qualified Happstack.Data.IxSet.Ix as Ix
import Happstack.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 Happstack.Util.Common
import Control.Monad.Reader
import Language.Haskell.TH as TH
import Happstack.Util.TH
import Happstack.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 = contain . safePut . toList
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)
_ -> error "unexpected match"
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 :: t -> ()
noCalcs _ = ()
inferIxSet :: String -> TH.Name -> TH.Name -> [TH.Name] -> Q [Dec]
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 "unexpected match"
names = map tyVarBndrToName binders
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 binders (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) binders ixType
return $ [i, ixType']
_ -> error "unexpected match"
#if MIN_VERSION_template_haskell(2,4,0)
tyVarBndrToName (PlainTV nm) = nm
tyVarBndrToName (KindedTV nm _) = nm
#else
tyVarBndrToName = id
#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
update _ _ = error "unexpected match"
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 _ = error "unexpected match"
toSet' :: Ord a => [Ix a] -> Set a
toSet' (Ix ix:_) = Map.fold Set.union Set.empty ix
toSet' [] = Set.empty
toSet' _ = error "unexpected match"
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 = fromSet . Set.fromList
size :: Ord a => IxSet a -> Int
size = Set.size . toSet
toList :: Ord a => IxSet a -> [a]
toList = Set.toList . toSet
toList' :: Ord a => [Ix a] -> [a]
toList' = Set.toList . toSet'
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
null :: IxSet a -> Bool
null (IxSet (Ix ix:_)) = Map.null ix
null (ISet lst) = List.null lst
null (IxSet []) = True
null _ = error "IxSet.null: unexpected match"
(&&&) :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a
(&&&) = intersection
(|||) :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a
(|||) = union
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
(@<) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> k -> IxSet a
ix @< v = getLT v ix
(@>) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> k -> IxSet a
ix @> v = getGT v ix
(@<=) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> k -> IxSet a
ix @<= v = getLTE v ix
(@>=) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> k -> IxSet a
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
(@>=<) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> (k, k) -> IxSet a
ix @>=< (v1,v2) = getLT v2 $ getGTE v1 ix
(@><=) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> (k, k) -> IxSet a
ix @><= (v1,v2) = getLTE v2 $ getGT v1 ix
(@>=<=) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> (k, k) -> IxSet a
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
(@*) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> [k] -> IxSet a
ix @* list = foldr intersection empty $ map (ix @=) list
getEQ :: (Indexable a b, Data a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getEQ = getOrd EQ
getLT :: (Indexable a b, Data a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getLT = getOrd LT
getGT :: (Indexable a b, Data a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getGT = getOrd GT
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)
collect _ = error "unexpected match"
f = mapSnd Set.toList . Map.toList
groupBy _ = error "unexpected match"
rGroupBy :: (Typeable k, Typeable t) => IxSet t -> [(k, [t])]
rGroupBy = reverse . groupBy
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 = concatMap (Set.toList . snd) $ Map.toList lt'
gt = concatMap (Set.toList . snd) $ Map.toList gt'
eq = maybe [] Set.toList eq'
collect _ = error "unexpected match"
getOrd _ _ _ = error "unexpected match"
instance (Show a,Indexable a b,Data a,Ord a) => Monoid (IxSet a) where
mempty=empty
mappend = union