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 UHC.Util.Serialize
import Control.Monad
type Scp = [Int]
data SGamElt v
= SGamElt
{ sgeScpId :: !Int
, sgeVal :: v
}
deriving (Typeable, Generic)
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, Generic)
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 :: Ord k => MetaLev -> k -> v -> SGam k v
sgamMetaLevSingleton mlev k v = mkSGam (varlookupSingletonWithMetaLev mlev k [SGamElt 0 v])
sgamSingleton :: Ord k => 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
instance (Ord k, Serialize k, Serialize v) => Serialize (SGam k v) where