module UHC.Util.ScopeMapGam
( SGam
, emptySGam
, sgamFilterMapEltAccumWithKey, sgamMapEltWithKey, sgamMapThr, sgamMap
, sgamPop, sgamTop
, sgamPushNew, sgamPushGam
, sgamMetaLevSingleton, sgamSingleton
, sgamUnionWith, sgamUnion
, sgamPartitionEltWithKey, sgamPartitionWithKey
, sgamUnzip
, sgamAlterDupOnTop
, sgamLookupMetaLevDup
, sgamToAssocDupL, sgamFromAssocDupL
, sgamNoDups
, MetaLev
, metaLevVal
)
where
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Maybe
import Data.List
import UHC.Util.VarMp
import UHC.Util.Utils
import UHC.Util.AssocL
import Data.Typeable (Typeable)
import Data.Generics (Data)
import UHC.Util.Serialize
import Control.Monad
type Scp = [Int]
data SGamElt v
= SGamElt
{ sgeScpId :: !Int
, sgeVal :: v
}
deriving (Typeable, Data)
type SMap k v = VarMp' k [SGamElt v]
emptySMap :: SMap k v
emptySMap = emptyVarMp
data SGam k v
= SGam
{ sgScpId :: !Int
, sgScp :: !Scp
, sgMap :: SMap k v
}
deriving (Typeable, Data)
mkSGam :: SMap k v -> SGam k v
mkSGam = SGam 0 [0]
emptySGam :: SGam k v
emptySGam = mkSGam emptySMap
instance Show (SGam k v) where
show _ = "SGam"
inScp :: Scp -> Int -> Bool
inScp = flip elem
sgameltInScp :: Scp -> SGamElt v -> Bool
sgameltInScp scp = inScp scp . sgeScpId
sgameltPartitionInScp :: Scp -> [SGamElt v] -> ([SGamElt v], [SGamElt v], [v'] -> [v'] -> [v'])
sgameltPartitionInScp scp = partitionAndRebuild (sgameltInScp scp)
sgameltFilterInScp :: Scp -> [SGamElt v] -> [SGamElt v]
sgameltFilterInScp scp = filter (sgameltInScp scp)
sgameltMapInScp :: Scp -> (v -> v) -> [SGamElt v] -> [SGamElt v]
sgameltMapInScp scp f = map (\e -> if sgameltInScp scp e then e {sgeVal = f (sgeVal e)} else e)
sgameltGetFilterInScp :: Scp -> (v -> v') -> [SGamElt v] -> [v']
sgameltGetFilterInScp scp f es = [ f (sgeVal e) | e <- es, sgameltInScp scp e ]
mapFilterInScp' :: Ord k => Scp -> ([SGamElt v] -> [SGamElt v]) -> SMap k v -> SMap k v
mapFilterInScp' scp f m
= varmpMapMaybe (\es -> maybeNull Nothing (Just . f) $ sgameltFilterInScp scp es) m
mapFilterInScp :: Ord k => Scp -> (SGamElt v -> SGamElt v) -> SMap k v -> SMap k v
mapFilterInScp scp f m
= mapFilterInScp' scp (map f) m
sgamFilterInScp :: Ord k => SGam k v -> SGam k v
sgamFilterInScp g@(SGam {sgScp = scp, sgMap = m})
= g {sgMap = mapFilterInScp scp id m}
sgamFilterMapEltAccumWithKey
:: (Ord k')
=> (k -> SGamElt v -> Bool)
-> (k -> SGamElt v -> acc -> (k',SGamElt v',acc))
-> (k -> SGamElt v -> acc -> acc)
-> acc -> SGam k v -> (SGam k' v',acc)
sgamFilterMapEltAccumWithKey p fyes fno a g
= (g {sgMap = mkVarMp m'},a')
where (m,_) = varmpAsMap (sgMap g)
(m',a') = Map.foldrWithKey
(\k es ma@(m,a)
-> foldr (\e (m,a)
-> if p k e
then let (k',e',a') = fyes k e a
in (Map.insertWith (++) k' [e'] m,a')
else (m,fno k e a)
) ma
$ sgameltFilterInScp (sgScp g) es
) (Map.empty,a) m
sgamMapEltWithKey :: (Ord k,Ord k') => (k -> SGamElt v -> (k',SGamElt v')) -> SGam k v -> SGam k' v'
sgamMapEltWithKey f g
= g'
where (g',_) = sgamFilterMapEltAccumWithKey (\_ _ -> True) (\k e a -> let (k',e') = f k e in (k',e',a)) undefined () g
sgamMapThr :: (Ord k,Ord k') => ((k,v) -> t -> ((k',v'),t)) -> t -> SGam k v -> (SGam k' v',t)
sgamMapThr f thr g = sgamFilterMapEltAccumWithKey (\_ _ -> True) (\k e thr -> let ((k',v'),thr') = f (k,sgeVal e) thr in (k',e {sgeVal = v'},thr')) undefined thr g
sgamMap :: (Ord k,Ord k') => ((k,v) -> (k',v')) -> SGam k v -> SGam k' v'
sgamMap f g = sgamMapEltWithKey (\k e -> let (k',v') = f (k,sgeVal e) in (k',e {sgeVal = v'})) g
sgamMetaLevSingleton :: MetaLev -> k -> v -> SGam k v
sgamMetaLevSingleton mlev k v = mkSGam (varmpMetaLevSingleton mlev k [SGamElt 0 v])
sgamSingleton :: k -> v -> SGam k v
sgamSingleton = sgamMetaLevSingleton metaLevVal
sgamUnionWith :: Ord k => Maybe (v -> [v] -> [v]) -> SGam k v -> SGam k v -> SGam k v
sgamUnionWith cmb g1@(SGam {sgScp = scp1, sgMap = m1}) g2@(SGam {sgScp = scp2@(hscp2:_), sgMap = m2})
= g2 {sgMap = varmpUnionWith cmb' m1' m2}
where m1' = mapFilterInScp scp1 (\e -> e {sgeScpId = hscp2}) m1
cmb' = maybe (++)
(\c -> \l1 l2 -> concat
[ map (SGamElt scp) $ foldr c [] $ map sgeVal g
| g@(SGamElt {sgeScpId = scp} : _) <- groupSortOn sgeScpId $ l1 ++ l2
]
)
cmb
sgamUnion :: Ord k => SGam k v -> SGam k v -> SGam k v
sgamUnion = sgamUnionWith Nothing
sgamPartitionEltWithKey :: Ord k => (k -> SGamElt v -> Bool) -> SGam k v -> (SGam k v,SGam k v)
sgamPartitionEltWithKey p g
= (g1, SGam (sgScpId g1) (sgScp g1) m2)
where (g1,m2) = sgamFilterMapEltAccumWithKey p (\k e a -> (k,e,a)) (\k e a -> varmpInsertWith (++) k [e] a) emptySMap g
sgamPartitionWithKey :: Ord k => (k -> v -> Bool) -> SGam k v -> (SGam k v,SGam k v)
sgamPartitionWithKey p = sgamPartitionEltWithKey (\k e -> p k (sgeVal e))
sgamUnzip :: Ord k => SGam k (v1,v2) -> (SGam k v1,SGam k v2)
sgamUnzip g
= (g1, g1 {sgMap = m2})
where (g1,m2) = sgamFilterMapEltAccumWithKey (\_ _ -> True) (\k e@(SGamElt {sgeVal = (v1,v2)}) m -> (k,e {sgeVal = v1},varmpInsertWith (++) k [e {sgeVal = v2}] m)) undefined emptySMap g
sgamPop :: Ord k => SGam k v -> (SGam k v, SGam k v)
sgamPop g@(SGam {sgMap = m, sgScpId = scpId, sgScp = scp@(hscp:tscp)})
= (SGam scpId [hscp] m, SGam scpId tscp m)
sgamTop :: Ord k => SGam k v -> SGam k v
sgamTop g
= fst $ sgamPop g
sgamPushNew :: SGam k v -> SGam k v
sgamPushNew g
= g {sgScpId = si, sgScp = si : sgScp g}
where si = sgScpId g + 1
sgamPushGam :: Ord k => SGam k v -> SGam k v -> SGam k v
sgamPushGam g1 g2 = g1 `sgamUnion` sgamPushNew g2
sgamAlterDupOnTop :: Ord k => (Maybe v -> Maybe v) -> k -> SGam k v -> SGam k v
sgamAlterDupOnTop f k g@(SGam {sgMap = m, sgScp = scp@(hscp:_)})
= g {sgMap = varmpAlter alt k m}
where alt Nothing = fmap (\v -> [SGamElt hscp v]) $ f Nothing
alt (Just vs) = if null vs' then Nothing else Just vs'
where (inscp,leave,mk) = sgameltPartitionInScp scp vs
vs' = catMaybes $ mk (map (\e -> fmap (\v -> e {sgeVal = v}) $ f $ Just $ sgeVal e) inscp) (map Just leave)
sgamLookupMetaLevDup :: Ord k => MetaLev -> k -> SGam k v -> Maybe [v]
sgamLookupMetaLevDup mlev k g@(SGam {sgMap = m, sgScpId = scpId, sgScp = scp})
= case varlookupWithMetaLev mlev k m of
Just es | not (null vs)
-> Just vs
where vs = sgameltGetFilterInScp scp id es
_ -> Nothing
sgamToAssocDupL :: Ord k => SGam k v -> AssocL k [v]
sgamToAssocDupL g@(SGam {sgScp = scp, sgMap = m})
= varmpToAssocL $ varmpMap (map sgeVal) $ sgMap $ sgamFilterInScp g
sgamFromAssocDupL :: Ord k => AssocL k [v] -> SGam k v
sgamFromAssocDupL l
= mkSGam m
where m = varmpMap (map (SGamElt 0)) $ assocLToVarMp l
sgamNoDups :: Ord k => SGam k v -> SGam k v
sgamNoDups g@(SGam {sgScp = scp, sgMap = m})
= g {sgMap = mapFilterInScp' scp (\(e:_) -> [e]) m}
instance (Serialize v) => Serialize (SGamElt v) where
sput (SGamElt a b) = sput a >> sput b
sget = liftM2 SGamElt sget sget
instance (Ord k, Serialize k, Serialize v) => Serialize (SGam k v) where
sput (SGam a b c) = sput a >> sput b >> sput c
sget = liftM3 SGam sget sget sget