{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -Wall #-} module Data.GMap.ListMap (-- * ListMap type ListMap ) where import Prelude hiding (foldr,map,filter,lookup) import Data.GMap import Data.Typeable import qualified Data.Foldable as F import qualified Data.Monoid as M import Data.Maybe hiding (mapMaybe) import GHC.Base hiding (map) import qualified Text.Read as R (Read(..),Lexeme(..),parens,prec,lexP,readListPrecDefault) import qualified Data.List as L -------------------------------------------------------------------------------------------- -- Map Type for lists and various helper functions -- -------------------------------------------------------------------------------------------- -- | The 'Map' type for keys of form @'Map' map k => [k]@. data ListMap map k a = Empt -- Empty special, never appears in non-empty ListMap! | BraF ![k] a !(map (ListMap map k a)) -- Full branch, tail map may be empty or singleton | BraE ![k] !(map (ListMap map k a)) -- Empty branch, no empty or singletons allowed. -- Invariants are: -- * Tail maps must not contain 'Empt' ListMap elements. -- * The tail map of a 'BraE' node must contain at least 2 entries. -- (Empty and singleton tail maps are degenerate cases which are normalised appropriately.) -- Smart constructor for BraE. Ensures tail is not empty or singleton map. braE :: Map map k => [k] -> map (ListMap map k a) -> ListMap map k a braE ks mp = case status mp of None -> Empt One _ Empt -> error "braE: Empty ListMap in tail map." One k (BraF ks' a mp') -> BraF (ks ++ k:ks') a mp' One k (BraE ks' mp') -> BraE (ks ++ k:ks') mp' Many -> BraE ks mp -- | ListMap is an instance of Map. instance Map map k => Map (ListMap map k) [k] where empty = emptyListMap singleton = singletonListMap pair = pairListMap nonEmpty = nonEmptyListMap status = statusListMap addSize = addSizeListMap lookup = lookupListMap lookupCont = lookupContListMap alter = alterListMap insertWith = insertWithListMap insertWith' = insertWithListMap' insertMaybe = insertMaybeListMap -- fromAssocsWith = fromAssocsWithListMap -- fromAssocsMaybe = fromAssocsMaybeListMap delete = deleteListMap adjustWith = adjustWithListMap adjustWith' = adjustWithListMap' adjustMaybe = adjustMaybeListMap venn = vennListMap venn' = vennListMap' vennMaybe = vennMaybeListMap -- disjointUnion = disjointUnionListMap union = unionListMap union' = unionListMap' unionMaybe = unionMaybeListMap intersection = intersectionListMap intersection' = intersectionListMap' intersectionMaybe = intersectionMaybeListMap difference = differenceListMap differenceMaybe = differenceMaybeListMap isSubsetOf = isSubsetOfListMap isSubmapOf = isSubmapOfListMap map = mapListMap map' = mapListMap' mapMaybe = mapMaybeListMap mapWithKey = mapWithKeyListMap mapWithKey' = mapWithKeyListMap' filter = filterListMap foldKeys = foldKeysListMap foldElems = foldElemsListMap foldAssocs = foldAssocsListMap foldKeys' = foldKeysListMap' foldElems' = foldElemsListMap' foldAssocs' = foldAssocsListMap' foldElemsUInt = foldElemsUIntListMap valid = validListMap instance OrderedMap map k => OrderedMap (ListMap map k) [k] where compareKey = compareKeyListMap fromAssocsAscWith = fromAssocsAscWithListMap fromAssocsDescWith = fromAssocsDescWithListMap fromAssocsAscMaybe = fromAssocsAscMaybeListMap fromAssocsDescMaybe = fromAssocsDescMaybeListMap foldElemsAsc = foldElemsAscListMap foldElemsDesc = foldElemsDescListMap foldKeysAsc = foldKeysAscListMap foldKeysDesc = foldKeysDescListMap foldAssocsAsc = foldAssocsAscListMap foldAssocsDesc = foldAssocsDescListMap foldElemsAsc' = foldElemsAscListMap' foldElemsDesc' = foldElemsDescListMap' foldKeysAsc' = foldKeysAscListMap' foldKeysDesc' = foldKeysDescListMap' foldAssocsAsc' = foldAssocsAscListMap' foldAssocsDesc' = foldAssocsDescListMap' -- Strict ++ infixr 5 +!+ (+!+) :: [a] -> [a] -> [a] [] +!+ ys = ys (x:xs) +!+ ys = let xs' = xs +!+ ys in xs' `seq` x:xs' {- (not used currently) xs +!+ [] = xs xs +!+ ys = f xs where f [] = ys f (x:xs') = let xs'' = f xs' in xs'' `seq` x:xs'' -} -- Local Utility for reverse join: revTo xs ys = (reverse xs) ++ ys revTo :: [a] -> [a] -> [a] revTo [] ys = ys revTo (x:xs) ys = revTo xs (x:ys) -- Take the first N elements of a list. -- Gives an error if list is not long enough to do this! takeN :: Int# -> [k] -> [k] takeN 0# _ = [] takeN _ [] = error "Data.GMap.ListMap.takeN: List is too short." takeN n (k:ks) = let ks_ = takeN (n -# 1#) ks in ks_ `seq` k:ks_ -- Return type of the match function -- Do we need the Int# in Sfx and Sfy constructors ?? data Match map k a = Mat -- Input lists match and have same length (I.E. they are identical) | Frk Int# (ListMap map k a -> ListMap map k a -> map (ListMap map k a)) [k] [k] -- n f xs ys | Sfx Int# k [k] -- Input lists match but xs has remaining non-empty suffix -- n x xs | Sfy Int# k [k] -- Input lists match but ys has remaining non-empty suffix -- n y ys -- Try to match two lists of keys match :: Map map k => [k] -> [k] -> Match map k a match xs0 ys0 = m 0# xs0 ys0 where m _ [] [] = Mat m n [] (y:ys) = Sfy n y ys m n (x:xs) [] = Sfx n x xs m n (x:xs) (y:ys) = case pair x y of Just f -> Frk n (\mpa mpb -> mpa `seq` mpb `seq` f mpa mpb) xs ys Nothing -> m ((n) +# 1#) xs ys -- x == y -- Common error message associated with (supposedly) sorted associations lists. -- Can be caused by improper sorting (including duplicate keys) badAssocs :: String badAssocs = "Data.GMap.ListMap: Bad sorted association List." -------------------------------------------------------------------------------------------- -- | See 'Map' class method 'empty'. emptyListMap :: ListMap map k a emptyListMap = Empt {-# INLINE emptyListMap #-} -- | See 'Map' class method 'singleton'. singletonListMap :: Map map k => [k] -> a -> ListMap map k a singletonListMap ks a = BraF ks a empty {-# INLINE singletonListMap #-} -- | See 'Map' class method 'pair'. pairListMap :: Map map k => [k] -> [k] -> Maybe (a -> a -> ListMap map k a) pairListMap xs0 ys0 = pr 0# xs0 ys0 where pr _ [] [] = Nothing pr _ [] (y:ys) = Just (\ax ay -> BraF xs0 ax (singleton y (BraF ys ay empty))) pr _ (x:xs) [] = Just (\ax ay -> BraF ys0 ay (singleton x (BraF xs ax empty))) pr n (x:xs) (y:ys) = case pair x y of Just f -> Just (\ax ay -> BraE (takeN n xs0) (f (BraF xs ax empty) (BraF ys ay empty))) Nothing -> pr ((n) +# 1#) xs ys -- | See 'Map' class method 'nonEmpty'. nonEmptyListMap :: ListMap map k a -> Maybe (ListMap map k a) nonEmptyListMap Empt = Nothing nonEmptyListMap lmp = Just lmp {-# INLINE nonEmptyListMap #-} -- | See 'Map' class method 'status'. statusListMap :: Map map k => ListMap map k a -> Status [k] a statusListMap Empt = None statusListMap (BraF ks a mp) = if (isEmpty mp) then (One ks a) else Many statusListMap (BraE _ _ ) = Many {-# INLINE statusListMap #-} -- | See 'Map' class method 'addSize'. addSizeListMap :: Map map k => ListMap map k a -> Int# -> Int# addSizeListMap Empt n = n addSizeListMap (BraF _ _ mp) n = foldElemsUInt addSizeListMap ((n) +# 1#) mp addSizeListMap (BraE _ mp) n = foldElemsUInt addSizeListMap n mp -- | See 'Map' class method 'lookup'. lookupListMap :: Map map k => [k] -> ListMap map k a -> Maybe a lookupListMap ks0 lmp0 = lmb ks0 lmp0 where lmb _ Empt = Nothing ------------------------------ lmb ks (BraF ks' a mp) = pre ks ks' where pre [] [] = Just a pre [] (_:_ ) = Nothing pre (x:xs) [] = case lookup x mp of Just lmp -> lmb xs lmp Nothing -> Nothing pre (x:xs) (y:ys) = if x == y then pre xs ys else Nothing ------------------------------ lmb ks (BraE ks' mp) = pre ks ks' where pre [] _ = Nothing pre (x:xs) [] = case lookup x mp of Just lmp -> lmb xs lmp Nothing -> Nothing pre (x:xs) (y:ys) = if x == y then pre xs ys else Nothing ------------------------------ -- | See 'Map' class method 'lookupCont'. lookupContListMap :: Map map k => (a -> Maybe b) -> [k] -> ListMap map k a -> Maybe b -- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap) lookupContListMap j ks0 lmp0 = lmb ks0 lmp0 where lmb _ Empt = Nothing ------------------------------ lmb ks (BraF ks' a mp) = pre ks ks' where pre [] [] = j a pre [] (_:_ ) = Nothing pre (x:xs) [] = lookupCont (lmb xs) x mp pre (x:xs) (y:ys) = if x == y then pre xs ys else Nothing ------------------------------ lmb ks (BraE ks' mp) = pre ks ks' where pre [] _ = Nothing pre (x:xs) [] = lookupCont (lmb xs) x mp pre (x:xs) (y:ys) = if x == y then pre xs ys else Nothing ------------------------------ -- | See 'Map' class method 'delete'. deleteListMap :: Map map k => [k] -> ListMap map k a -> ListMap map k a deleteListMap = adjustMaybeListMap (const Nothing) {-# INLINE deleteListMap #-} -- | See 'Map' class method 'adjustWith'. adjustWithListMap :: Map map k => (a -> a) -> [k] -> ListMap map k a -> ListMap map k a -- N.B. One day we will have a more efficient implementation of this adjustWithListMap f ks0 lmp0 = dmb ks0 lmp0 where dmb _ Empt = Empt ------------------------------ dmb ks bf@(BraF ks' a mp) = pre ks ks' where pre [] [] = BraF ks' (f a) mp pre [] (_:_ ) = bf pre (x:xs) [] = BraF ks' a (adjustWith (\lmp -> dmb xs lmp) x mp) pre (x:xs) (y:ys) = if x == y then pre xs ys else bf ------------------------------ dmb ks be@(BraE ks' mp) = pre ks ks' where pre [] _ = be pre (x:xs) [] = braE ks' (adjustWith (\lmp -> dmb xs lmp) x mp) pre (x:xs) (y:ys) = if x == y then pre xs ys else be ------------------------------ -- | See 'Map' class method 'adjustWith''. adjustWithListMap' :: Map map k => (a -> a) -> [k] -> ListMap map k a -> ListMap map k a -- N.B. One day we will have a more efficient implementation of this adjustWithListMap' f ks0 lmp0 = dmb ks0 lmp0 where dmb _ Empt = Empt ------------------------------ dmb ks bf@(BraF ks' a mp) = pre ks ks' where pre [] [] = let newElem = f a in newElem `seq` BraF ks' newElem mp pre [] (_:_ ) = bf pre (x:xs) [] = BraF ks' a (adjustWith' (\lmp -> dmb xs lmp) x mp) pre (x:xs) (y:ys) = if x == y then pre xs ys else bf ------------------------------ dmb ks be@(BraE ks' mp) = pre ks ks' where pre [] _ = be pre (x:xs) [] = braE ks' (adjustWith' (\lmp -> dmb xs lmp) x mp) pre (x:xs) (y:ys) = if x == y then pre xs ys else be ------------------------------ -- | See 'Map' class method 'adjustMaybe'. adjustMaybeListMap :: Map map k => (a -> Maybe a) -> [k] -> ListMap map k a -> ListMap map k a -- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap) adjustMaybeListMap f ks0 lmp0 = dmb ks0 lmp0 where dmb _ Empt = Empt ------------------------------ dmb ks bf@(BraF ks' a mp) = pre ks ks' where pre [] [] = case f a of Just a' -> BraF ks' a' mp Nothing -> braE ks' mp pre [] (_:_ ) = bf pre (x:xs) [] = BraF ks' a (adjustMaybe (\lmp -> nonEmptyListMap (dmb xs lmp)) x mp) pre (x:xs) (y:ys) = if x == y then pre xs ys else bf ------------------------------ dmb ks be@(BraE ks' mp) = pre ks ks' where pre [] _ = be pre (x:xs) [] = braE ks' (adjustMaybe (\lmp -> nonEmptyListMap (dmb xs lmp)) x mp) pre (x:xs) (y:ys) = if x == y then pre xs ys else be ------------------------------ -- | See 'Map' class method 'venn'. vennListMap :: Map map k => (a -> b -> c) -> ListMap map k a -> ListMap map k b -> (ListMap map k a, ListMap map k c, ListMap map k b) vennListMap f lmp0 lmp1 = v lmp0 lmp1 where appendStem ys y (BraF xs a mpx) = BraF (ys +!+ y:xs) a mpx appendStem ys y (BraE xs mpx) = BraE (ys +!+ y:xs) mpx appendStem _ _ Empt = Empt ------------------------------------------ replace k m mp = alter' (const (nonEmpty m)) k mp ------------------------------------------ vennInner mpx mpy = (leftDiff,inter,rightDiff) where leftDiff = disjointUnion mpl (mapMaybe (\(l,_,_) -> nonEmpty l) mpi) inter = mapMaybe (\(_,i,_) -> nonEmpty i) mpi rightDiff = disjointUnion mpr (mapMaybe (\(_,_,r) -> nonEmpty r) mpi) (mpl,mpi,mpr) = venn' (venn f) mpx mpy -- NB use of venn' ------------------------------------------ v Empt lmpy = (Empt,Empt,lmpy) v lmpx Empt = (lmpx,Empt,Empt) ------------------------------------------ v lmpx@(BraF xs0 a mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where m [] [] = (braE xs0 leftDiff ,BraF xs0 (f a b) inter ,braE xs0 rightDiff) where (leftDiff,inter,rightDiff) = vennInner mpx mpy m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy) Just lmpb -> case v (BraF xs a mpx) lmpb of (_,Empt,_) -> (lmpx,Empt,lmpy) (_,i ,r) -> (difference (BraF xs0 a mpx) (appendStem ys0 x i) ,appendStem ys0 x i ,BraF ys0 b (replace x r mpy)) m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy) Just lmpa -> case v lmpa (BraF ys b mpy) of (_,Empt,_) -> (lmpx,Empt,lmpy) (l,i ,_) -> (BraF xs0 a (replace y l mpx) ,appendStem xs0 y i ,difference (BraF ys0 b mpy) (appendStem xs0 y i)) m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy) ------------------------------------------ v lmpx@(BraF xs0 a mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where m [] [] = (BraF xs0 a leftDiff ,braE xs0 inter ,braE xs0 rightDiff) where (leftDiff,inter,rightDiff) = vennInner mpx mpy m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy) Just lmpb -> case v (BraF xs a mpx) lmpb of (_,Empt,_) -> (lmpx,Empt,lmpy) (_,i ,r) -> (difference (BraF xs0 a mpx) (appendStem ys0 x i) ,appendStem ys0 x i ,BraE ys0 (replace x r mpy)) m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy) Just lmpa -> case v lmpa (BraE ys mpy) of (_,Empt,_) -> (lmpx,Empt,lmpy) (l,i ,_) -> (BraF xs0 a (replace y l mpx) ,appendStem xs0 y i ,difference (BraE ys0 mpy) (appendStem xs0 y i)) m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy) ------------------------------------------ v lmpx@(BraE xs0 mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where m [] [] = (braE xs0 leftDiff ,braE xs0 inter ,BraF xs0 b rightDiff) where (leftDiff,inter,rightDiff) = vennInner mpx mpy m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy) Just lmpb -> case v (BraE xs mpx) lmpb of (_,Empt,_) -> (lmpx,Empt,lmpy) (_,i ,r) -> (difference (BraE xs0 mpx) (appendStem ys0 x i) ,appendStem ys0 x i ,BraF ys0 b (replace x r mpy)) m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy) Just lmpa -> case v lmpa (BraF ys b mpy) of (_,Empt,_) -> (lmpx,Empt,lmpy) (l,i ,_) -> (BraE xs0 (replace y l mpx) ,appendStem xs0 y i ,difference (BraF ys0 b mpy) (appendStem xs0 y i)) m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy) ------------------------------------------ v lmpx@(BraE xs0 mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where m [] [] = (braE xs0 leftDiff ,braE xs0 inter ,braE xs0 rightDiff) where (leftDiff,inter,rightDiff) = vennInner mpx mpy m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy) Just lmpb -> case v (BraE xs mpx) lmpb of (_,Empt,_) -> (lmpx,Empt,lmpy) (_,i ,r) -> (difference (BraE xs0 mpx) (appendStem ys0 x i) ,appendStem ys0 x i ,BraE ys0 (replace x r mpy)) m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy) Just lmpa -> case v lmpa (BraE ys mpy) of (_,Empt,_) -> (lmpx,Empt,lmpy) (l,i ,_) -> (BraE xs0 (replace y l mpx) ,appendStem xs0 y i ,difference (BraE ys0 mpy) (appendStem xs0 y i)) m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy) ------------------------------------------ -- | See 'Map' class method 'venn''. vennListMap' :: Map map k => (a -> b -> c) -> ListMap map k a -> ListMap map k b -> (ListMap map k a, ListMap map k c, ListMap map k b) vennListMap' f lmp0 lmp1 = v lmp0 lmp1 where appendStem ys y (BraF xs a mpx) = BraF (ys +!+ y:xs) a mpx appendStem ys y (BraE xs mpx) = BraE (ys +!+ y:xs) mpx appendStem _ _ Empt = Empt ------------------------------------------ replace k m mp = alter' (const (nonEmpty m)) k mp ------------------------------------------ vennInner mpx mpy = (leftDiff,inter,rightDiff) where leftDiff = disjointUnion mpl (mapMaybe (\(l,_,_) -> nonEmpty l) mpi) inter = mapMaybe (\(_,i,_) -> nonEmpty i) mpi rightDiff = disjointUnion mpr (mapMaybe (\(_,_,r) -> nonEmpty r) mpi) (mpl,mpi,mpr) = venn' (venn' f) mpx mpy ------------------------------------------ v Empt lmpy = (Empt,Empt,lmpy) v lmpx Empt = (lmpx,Empt,Empt) ------------------------------------------ v lmpx@(BraF xs0 a mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where m [] [] = (braE xs0 leftDiff ,let c = f a b in c `seq` BraF xs0 c inter ,braE xs0 rightDiff) where (leftDiff,inter,rightDiff) = vennInner mpx mpy m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy) Just lmpb -> case v (BraF xs a mpx) lmpb of (_,Empt,_) -> (lmpx,Empt,lmpy) (_,i ,r) -> (difference (BraF xs0 a mpx) (appendStem ys0 x i) ,appendStem ys0 x i ,BraF ys0 b (replace x r mpy)) m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy) Just lmpa -> case v lmpa (BraF ys b mpy) of (_,Empt,_) -> (lmpx,Empt,lmpy) (l,i ,_) -> (BraF xs0 a (replace y l mpx) ,appendStem xs0 y i ,difference (BraF ys0 b mpy) (appendStem xs0 y i)) m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy) ------------------------------------------ v lmpx@(BraF xs0 a mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where m [] [] = (BraF xs0 a leftDiff ,braE xs0 inter ,braE xs0 rightDiff) where (leftDiff,inter,rightDiff) = vennInner mpx mpy m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy) Just lmpb -> case v (BraF xs a mpx) lmpb of (_,Empt,_) -> (lmpx,Empt,lmpy) (_,i ,r) -> (difference (BraF xs0 a mpx) (appendStem ys0 x i) ,appendStem ys0 x i ,BraE ys0 (replace x r mpy)) m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy) Just lmpa -> case v lmpa (BraE ys mpy) of (_,Empt,_) -> (lmpx,Empt,lmpy) (l,i ,_) -> (BraF xs0 a (replace y l mpx) ,appendStem xs0 y i ,difference (BraE ys0 mpy) (appendStem xs0 y i)) m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy) ------------------------------------------ v lmpx@(BraE xs0 mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where m [] [] = (braE xs0 leftDiff ,braE xs0 inter ,BraF xs0 b rightDiff) where (leftDiff,inter,rightDiff) = vennInner mpx mpy m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy) Just lmpb -> case v (BraE xs mpx) lmpb of (_,Empt,_) -> (lmpx,Empt,lmpy) (_,i ,r) -> (difference (BraE xs0 mpx) (appendStem ys0 x i) ,appendStem ys0 x i ,BraF ys0 b (replace x r mpy)) m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy) Just lmpa -> case v lmpa (BraF ys b mpy) of (_,Empt,_) -> (lmpx,Empt,lmpy) (l,i ,_) -> (BraE xs0 (replace y l mpx) ,appendStem xs0 y i ,difference (BraF ys0 b mpy) (appendStem xs0 y i)) m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy) ------------------------------------------ v lmpx@(BraE xs0 mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where m [] [] = (braE xs0 leftDiff ,braE xs0 inter ,braE xs0 rightDiff) where (leftDiff,inter,rightDiff) = vennInner mpx mpy m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy) Just lmpb -> case v (BraE xs mpx) lmpb of (_,Empt,_) -> (lmpx,Empt,lmpy) (_,i ,r) -> (difference (BraE xs0 mpx) (appendStem ys0 x i) ,appendStem ys0 x i ,BraE ys0 (replace x r mpy)) m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy) Just lmpa -> case v lmpa (BraE ys mpy) of (_,Empt,_) -> (lmpx,Empt,lmpy) (l,i ,_) -> (BraE xs0 (replace y l mpx) ,appendStem xs0 y i ,difference (BraE ys0 mpy) (appendStem xs0 y i)) m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy) ------------------------------------------ -- | See 'Map' class method 'vennMaybe'. vennMaybeListMap :: Map map k => (a -> b -> Maybe c) -> ListMap map k a -> ListMap map k b -> (ListMap map k a, ListMap map k c, ListMap map k b) vennMaybeListMap f lmp0 lmp1 = v lmp0 lmp1 where appendStem ys y (BraF xs a mpx) = BraF (ys +!+ y:xs) a mpx appendStem ys y (BraE xs mpx) = BraE (ys +!+ y:xs) mpx appendStem _ _ Empt = Empt ------------------------------------------ replace k m mp = alter' (const (nonEmpty m)) k mp ------------------------------------------ vennInner mpx mpy = (leftDiff,inter,rightDiff) where leftDiff = disjointUnion mpl (mapMaybe (\(l,_,_) -> nonEmpty l) mpi) inter = mapMaybe (\(_,i,_) -> nonEmpty i) mpi rightDiff = disjointUnion mpr (mapMaybe (\(_,_,r) -> nonEmpty r) mpi) (mpl,mpi,mpr) = venn (vennMaybe f) mpx mpy ------------------------------------------ v Empt lmpy = (Empt,Empt,lmpy) v lmpx Empt = (lmpx,Empt,Empt) ------------------------------------------ v lmpx@(BraF xs0 a mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where m [] [] = (braE xs0 leftDiff ,case f a b of Nothing -> braE xs0 inter Just c -> BraF xs0 c inter ,braE xs0 rightDiff) where (leftDiff,inter,rightDiff) = vennInner mpx mpy m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy) Just lmpb -> case v (BraF xs a mpx) lmpb of (_,Empt,_) -> (lmpx,Empt,lmpy) (_,i ,r) -> (difference (BraF xs0 a mpx) (appendStem ys0 x i) ,appendStem ys0 x i ,BraF ys0 b (replace x r mpy)) m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy) Just lmpa -> case v lmpa (BraF ys b mpy) of (_,Empt,_) -> (lmpx,Empt,lmpy) (l,i ,_) -> (BraF xs0 a (replace y l mpx) ,appendStem xs0 y i ,difference (BraF ys0 b mpy) (appendStem xs0 y i)) m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy) ------------------------------------------ v lmpx@(BraF xs0 a mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where m [] [] = (BraF xs0 a leftDiff ,braE xs0 inter ,braE xs0 rightDiff) where (leftDiff,inter,rightDiff) = vennInner mpx mpy m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy) Just lmpb -> case v (BraF xs a mpx) lmpb of (_,Empt,_) -> (lmpx,Empt,lmpy) (_,i ,r) -> (difference (BraF xs0 a mpx) (appendStem ys0 x i) ,appendStem ys0 x i ,BraE ys0 (replace x r mpy)) m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy) Just lmpa -> case v lmpa (BraE ys mpy) of (_,Empt,_) -> (lmpx,Empt,lmpy) (l,i ,_) -> (BraF xs0 a (replace y l mpx) ,appendStem xs0 y i ,difference (BraE ys0 mpy) (appendStem xs0 y i)) m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy) ------------------------------------------ v lmpx@(BraE xs0 mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where m [] [] = (braE xs0 leftDiff ,braE xs0 inter ,BraF xs0 b rightDiff) where (leftDiff,inter,rightDiff) = vennInner mpx mpy m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy) Just lmpb -> case v (BraE xs mpx) lmpb of (_,Empt,_) -> (lmpx,Empt,lmpy) (_,i ,r) -> (difference (BraE xs0 mpx) (appendStem ys0 x i) ,appendStem ys0 x i ,BraF ys0 b (replace x r mpy)) m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy) Just lmpa -> case v lmpa (BraF ys b mpy) of (_,Empt,_) -> (lmpx,Empt,lmpy) (l,i ,_) -> (BraE xs0 (replace y l mpx) ,appendStem xs0 y i ,difference (BraF ys0 b mpy) (appendStem xs0 y i)) m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy) ------------------------------------------ v lmpx@(BraE xs0 mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where m [] [] = (braE xs0 leftDiff ,braE xs0 inter ,braE xs0 rightDiff) where (leftDiff,inter,rightDiff) = vennInner mpx mpy m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy) Just lmpb -> case v (BraE xs mpx) lmpb of (_,Empt,_) -> (lmpx,Empt,lmpy) (_,i ,r) -> (difference (BraE xs0 mpx) (appendStem ys0 x i) ,appendStem ys0 x i ,BraE ys0 (replace x r mpy)) m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy) Just lmpa -> case v lmpa (BraE ys mpy) of (_,Empt,_) -> (lmpx,Empt,lmpy) (l,i ,_) -> (BraE xs0 (replace y l mpx) ,appendStem xs0 y i ,difference (BraE ys0 mpy) (appendStem xs0 y i)) m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy) ------------------------------------------ -- | See 'Map' class method 'union'. unionListMap :: Map map k => (a -> a -> a) -> ListMap map k a -> ListMap map k a -> ListMap map k a unionListMap f lmp0 lmp1 = u lmp0 lmp1 where u Empt lmp = lmp u lmp Empt = lmp ------------------------------------------ u (BraF xs0 ax mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of Mat -> BraF xs0 (f ax ay) (union' u mpx mpy) -- N.B. Use of strict union' Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraF xs ax mpx) (BraF ys ay mpy)) Sfx _ x xs -> BraF ys0 ay (insertWith' f' x braFx mpy) -- N.B. Use of strict insertWith' where f' lmp = u braFx lmp braFx = BraF xs ax mpx Sfy _ y ys -> BraF xs0 ax (insertWith' f' y braFy mpx) -- N.B. Use of strict insertWith' where f' lmp = u lmp braFy braFy = BraF ys ay mpy ------------------------------------------ u (BraF xs0 ax mpx) (BraE ys0 mpy) = case match xs0 ys0 of Mat -> BraF xs0 ax (union' u mpx mpy) -- N.B. Use of strict union' Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraF xs ax mpx) (BraE ys mpy)) Sfx _ x xs -> BraE ys0 (insertWith' f' x braFx mpy) -- N.B. Use of strict insertWith' where f' lmp = u braFx lmp braFx = BraF xs ax mpx Sfy _ y ys -> BraF xs0 ax (insertWith' f' y braEy mpx) -- N.B. Use of strict insertWith' where f' lmp = u lmp braEy braEy = BraE ys mpy ------------------------------------------ u (BraE xs0 mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of Mat -> BraF xs0 ay (union' u mpx mpy) -- N.B. Use of strict union' Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraE xs mpx) (BraF ys ay mpy)) Sfx _ x xs -> BraF ys0 ay (insertWith' f' x braEx mpy) -- N.B. Use of strict insertWith' where f' lmp = u braEx lmp braEx = BraE xs mpx Sfy _ y ys -> BraE xs0 (insertWith' f' y braFy mpx) -- N.B. Use of strict insertWith' where f' lmp = u lmp braFy braFy = BraF ys ay mpy ------------------------------------------ u (BraE xs0 mpx) (BraE ys0 mpy) = case match xs0 ys0 of Mat -> BraE xs0 (union' u mpx mpy) -- N.B. Use of strict union' Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraE xs mpx) (BraE ys mpy)) Sfx _ x xs -> BraE ys0 (insertWith' f' x braEx mpy) -- N.B. Use of strict insertWith' where f' lmp = u braEx lmp braEx = BraE xs mpx Sfy _ y ys -> BraE xs0 (insertWith' f' y braEy mpx) -- N.B. Use of strict insertWith' where f' lmp = u lmp braEy braEy = BraE ys mpy ------------------------------------------ -- | See 'Map' class method 'union''. unionListMap' :: Map map k => (a -> a -> a) -> ListMap map k a -> ListMap map k a -> ListMap map k a unionListMap' f lmp0 lmp1 = u lmp0 lmp1 where u Empt lmp = lmp u lmp Empt = lmp ------------------------------------------ u (BraF xs0 ax mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of Mat -> let a = f ax ay in a `seq` BraF xs0 a (union' u mpx mpy) -- N.B. Use of strict union' Frk n f' xs ys -> BraE (takeN n xs0) (left `seq` right `seq` f' left right) where left = BraF xs ax mpx right = BraF ys ay mpy Sfx _ x xs -> BraF ys0 ay (insertWith' f' x braFx mpy) -- N.B. Use of strict insertWith' where f' lmp = u braFx lmp braFx = BraF xs ax mpx Sfy _ y ys -> BraF xs0 ax (insertWith' f' y braFy mpx) -- N.B. Use of strict insertWith' where f' lmp = u lmp braFy braFy = BraF ys ay mpy ------------------------------------------ u (BraF xs0 ax mpx) (BraE ys0 mpy) = case match xs0 ys0 of Mat -> BraF xs0 ax (union' u mpx mpy) -- N.B. Use of strict union' Frk n f' xs ys -> BraE (takeN n xs0) (left `seq` f' left right) where left = BraF xs ax mpx right = BraE ys mpy Sfx _ x xs -> BraE ys0 (insertWith' f' x braFx mpy) -- N.B. Use of strict insertWith' where f' lmp = u braFx lmp braFx = BraF xs ax mpx Sfy _ y ys -> BraF xs0 ax (insertWith' f' y braEy mpx) -- N.B. Use of strict insertWith' where f' lmp = u lmp braEy braEy = BraE ys mpy ------------------------------------------ u (BraE xs0 mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of Mat -> BraF xs0 ay (union' u mpx mpy) -- N.B. Use of strict union' Frk n f' xs ys -> BraE (takeN n xs0) (right `seq` f' left right) where left = BraE xs mpx right = BraF ys ay mpy Sfx _ x xs -> BraF ys0 ay (insertWith' f' x braEx mpy) -- N.B. Use of strict insertWith' where f' lmp = u braEx lmp braEx = BraE xs mpx Sfy _ y ys -> BraE xs0 (insertWith' f' y braFy mpx) -- N.B. Use of strict insertWith' where f' lmp = u lmp braFy braFy = BraF ys ay mpy ------------------------------------------ u (BraE xs0 mpx) (BraE ys0 mpy) = case match xs0 ys0 of Mat -> BraE xs0 (union' u mpx mpy) -- N.B. Use of strict union' Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraE xs mpx) (BraE ys mpy)) Sfx _ x xs -> BraE ys0 (insertWith' f' x braEx mpy) -- N.B. Use of strict insertWith' where f' lmp = u braEx lmp braEx = BraE xs mpx Sfy _ y ys -> BraE xs0 (insertWith' f' y braEy mpx) -- N.B. Use of strict insertWith' where f' lmp = u lmp braEy braEy = BraE ys mpy ------------------------------------------ -- | See 'Map' class method 'unionMaybe'. unionMaybeListMap :: Map map k => (a -> a -> Maybe a) -> ListMap map k a -> ListMap map k a -> ListMap map k a unionMaybeListMap f lmp0 lmp1 = u lmp0 lmp1 where uNE lmpx lmpy = nonEmptyListMap (u lmpx lmpy) -- unionMaybe can yield empty maps !! ------------------------------------------ u Empt lmp = lmp u lmp Empt = lmp ------------------------------------------ u (BraF xs0 ax mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of Mat -> case f ax ay of Just a -> BraF xs0 a (unionMaybe' uNE mpx mpy) Nothing -> braE xs0 (unionMaybe' uNE mpx mpy) -- N.B Use of braE, not BraE !! Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraF xs ax mpx) (BraF ys ay mpy)) Sfx _ x xs -> BraF ys0 ay (insertMaybe' f' x braFx mpy) where f' lmp = uNE braFx lmp braFx = BraF xs ax mpx Sfy _ y ys -> BraF xs0 ax (insertMaybe' f' y braFy mpx) where f' lmp = uNE lmp braFy braFy = BraF ys ay mpy ------------------------------------------ u (BraF xs0 ax mpx) (BraE ys0 mpy) = case match xs0 ys0 of Mat -> BraF xs0 ax (unionMaybe' uNE mpx mpy) Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraF xs ax mpx) (BraE ys mpy)) Sfx _ x xs -> braE ys0 (insertMaybe' f' x braFx mpy) -- N.B Use of braE, not BraE !! where f' lmp = uNE braFx lmp braFx = BraF xs ax mpx Sfy _ y ys -> BraF xs0 ax (insertMaybe' f' y braEy mpx) where f' lmp = uNE lmp braEy braEy = BraE ys mpy ------------------------------------------ u (BraE xs0 mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of Mat -> BraF xs0 ay (unionMaybe' uNE mpx mpy) Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraE xs mpx) (BraF ys ay mpy)) Sfx _ x xs -> BraF ys0 ay (insertMaybe' f' x braEx mpy) where f' lmp = uNE braEx lmp braEx = BraE xs mpx Sfy _ y ys -> braE xs0 (insertMaybe' f' y braFy mpx) -- N.B Use of braE, not BraE !! where f' lmp = uNE lmp braFy braFy = BraF ys ay mpy ------------------------------------------ u (BraE xs0 mpx) (BraE ys0 mpy) = case match xs0 ys0 of Mat -> braE xs0 (unionMaybe' uNE mpx mpy) -- N.B Use of braE, not BraE !! Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraE xs mpx) (BraE ys mpy)) Sfx _ x xs -> braE ys0 (insertMaybe' f' x braEx mpy) -- N.B Use of braE, not BraE !! where f' lmp = uNE braEx lmp braEx = BraE xs mpx Sfy _ y ys -> braE xs0 (insertMaybe' f' y braEy mpx) -- N.B Use of braE, not BraE !! where f' lmp = uNE lmp braEy braEy = BraE ys mpy ------------------------------------------ -- | See 'Map' class method 'intersection'. intersectionListMap :: Map map k => (a -> b -> c) -> ListMap map k a -> ListMap map k b -> ListMap map k c intersectionListMap f lmp0 lmp1 = i lmp0 lmp1 where iNE lmpx lmpy = nonEmptyListMap (i lmpx lmpy) -- intersection can yield empty maps !! ------------------------------------------ i Empt _ = Empt i _ Empt = Empt ------------------------------------------ i (BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where m [] [] = BraF xs0 (f a b) (intersectionMaybe iNE mpx mpy) m (x:xs) [] = case lookup x mpy of Nothing -> Empt Just lmpb -> case i (BraF xs a mpx) lmpb of Empt -> Empt BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = case lookup y mpx of Nothing -> Empt Just lmpa -> case i lmpa (BraF ys b mpy) of Empt -> Empt BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz m (x:xs) (y:ys) = if x == y then m xs ys else Empt ------------------------------------------ i (BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where m [] [] = braE xs0 (intersectionMaybe iNE mpx mpy) -- Note use of braE! m (x:xs) [] = case lookup x mpy of Nothing -> Empt Just lmpb -> case i (BraF xs a mpx) lmpb of Empt -> Empt BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = case lookup y mpx of Nothing -> Empt Just lmpa -> case i lmpa (BraE ys mpy) of Empt -> Empt BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz m (x:xs) (y:ys) = if x == y then m xs ys else Empt ------------------------------------------ i (BraE xs0 mpx) (BraF ys0 b mpy) = m xs0 ys0 where m [] [] = braE xs0 (intersectionMaybe iNE mpx mpy) -- Note use of braE! m (x:xs) [] = case lookup x mpy of Nothing -> Empt Just lmpb -> case i (BraE xs mpx) lmpb of Empt -> Empt BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = case lookup y mpx of Nothing -> Empt Just lmpa -> case i lmpa (BraF ys b mpy) of Empt -> Empt BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz m (x:xs) (y:ys) = if x == y then m xs ys else Empt ------------------------------------------ i (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where m [] [] = braE xs0 (intersectionMaybe iNE mpx mpy) -- Note use of braE! m (x:xs) [] = case lookup x mpy of Nothing -> Empt Just lmpb -> case i (BraE xs mpx) lmpb of Empt -> Empt BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = case lookup y mpx of Nothing -> Empt Just lmpa -> case i lmpa (BraE ys mpy) of Empt -> Empt BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz m (x:xs) (y:ys) = if x == y then m xs ys else Empt ------------------------------------------ -- | See 'Map' class method 'intersection''. intersectionListMap' :: Map map k => (a -> b -> c) -> ListMap map k a -> ListMap map k b -> ListMap map k c intersectionListMap' f lmp0 lmp1 = i lmp0 lmp1 where iNE lmpx lmpy = nonEmptyListMap (i lmpx lmpy) -- intersection can yield empty maps !! ------------------------------------------ i Empt _ = Empt i _ Empt = Empt ------------------------------------------ i (BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where m [] [] = let c = f a b in c `seq` BraF xs0 c (intersectionMaybe iNE mpx mpy) m (x:xs) [] = case lookup x mpy of Nothing -> Empt Just lmpb -> case i (BraF xs a mpx) lmpb of Empt -> Empt BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = case lookup y mpx of Nothing -> Empt Just lmpa -> case i lmpa (BraF ys b mpy) of Empt -> Empt BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz m (x:xs) (y:ys) = if x == y then m xs ys else Empt ------------------------------------------ i (BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where m [] [] = braE xs0 (intersectionMaybe iNE mpx mpy) -- Note use of braE! m (x:xs) [] = case lookup x mpy of Nothing -> Empt Just lmpb -> case i (BraF xs a mpx) lmpb of Empt -> Empt BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = case lookup y mpx of Nothing -> Empt Just lmpa -> case i lmpa (BraE ys mpy) of Empt -> Empt BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz m (x:xs) (y:ys) = if x == y then m xs ys else Empt ------------------------------------------ i (BraE xs0 mpx) (BraF ys0 b mpy) = m xs0 ys0 where m [] [] = braE xs0 (intersectionMaybe iNE mpx mpy) -- Note use of braE! m (x:xs) [] = case lookup x mpy of Nothing -> Empt Just lmpb -> case i (BraE xs mpx) lmpb of Empt -> Empt BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = case lookup y mpx of Nothing -> Empt Just lmpa -> case i lmpa (BraF ys b mpy) of Empt -> Empt BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz m (x:xs) (y:ys) = if x == y then m xs ys else Empt ------------------------------------------ i (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where m [] [] = braE xs0 (intersectionMaybe iNE mpx mpy) -- Note use of braE! m (x:xs) [] = case lookup x mpy of Nothing -> Empt Just lmpb -> case i (BraE xs mpx) lmpb of Empt -> Empt BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = case lookup y mpx of Nothing -> Empt Just lmpa -> case i lmpa (BraE ys mpy) of Empt -> Empt BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz m (x:xs) (y:ys) = if x == y then m xs ys else Empt ------------------------------------------ -- | See 'Map' class method 'intersectionMaybe'. intersectionMaybeListMap :: Map map k => (a -> b -> Maybe c) -> ListMap map k a -> ListMap map k b -> ListMap map k c intersectionMaybeListMap f lmp0 lmp1 = i lmp0 lmp1 where iNE lmpx lmpy = nonEmptyListMap (i lmpx lmpy) -- intersection can yield empty maps !! ------------------------------------------ i Empt _ = Empt i _ Empt = Empt ------------------------------------------ i (BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where m [] [] = case f a b of Just c -> BraF xs0 c (intersectionMaybe' iNE mpx mpy) Nothing -> braE xs0 (intersectionMaybe' iNE mpx mpy) -- Note use of braE! m (x:xs) [] = case lookup x mpy of Nothing -> Empt Just lmpb -> case i (BraF xs a mpx) lmpb of Empt -> Empt BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = case lookup y mpx of Nothing -> Empt Just lmpa -> case i lmpa (BraF ys b mpy) of Empt -> Empt BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz m (x:xs) (y:ys) = if x == y then m xs ys else Empt ------------------------------------------ i (BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where m [] [] = braE xs0 (intersectionMaybe' iNE mpx mpy) -- Note use of braE! m (x:xs) [] = case lookup x mpy of Nothing -> Empt Just lmpb -> case i (BraF xs a mpx) lmpb of Empt -> Empt BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = case lookup y mpx of Nothing -> Empt Just lmpa -> case i lmpa (BraE ys mpy) of Empt -> Empt BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz m (x:xs) (y:ys) = if x == y then m xs ys else Empt ------------------------------------------ i (BraE xs0 mpx) (BraF ys0 b mpy) = m xs0 ys0 where m [] [] = braE xs0 (intersectionMaybe' iNE mpx mpy) -- Note use of braE! m (x:xs) [] = case lookup x mpy of Nothing -> Empt Just lmpb -> case i (BraE xs mpx) lmpb of Empt -> Empt BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = case lookup y mpx of Nothing -> Empt Just lmpa -> case i lmpa (BraF ys b mpy) of Empt -> Empt BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz m (x:xs) (y:ys) = if x == y then m xs ys else Empt ------------------------------------------ i (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where m [] [] = braE xs0 (intersectionMaybe' iNE mpx mpy) -- Note use of braE! m (x:xs) [] = case lookup x mpy of Nothing -> Empt Just lmpb -> case i (BraE xs mpx) lmpb of Empt -> Empt BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = case lookup y mpx of Nothing -> Empt Just lmpa -> case i lmpa (BraE ys mpy) of Empt -> Empt BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz m (x:xs) (y:ys) = if x == y then m xs ys else Empt ------------------------------------------ -- | See 'Map' class method 'difference'. differenceListMap :: Map map k => ListMap map k a -> ListMap map k b -> ListMap map k a differenceListMap lmp0 lmp1 = d lmp0 lmp1 where dNE lmpx lmpy = nonEmptyListMap (d lmpx lmpy) -- difference can yield empty maps !! ------------------------------------------ d Empt _ = Empt d lmpx Empt = lmpx ------------------------------------------ d lmpx@(BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where m [] [] = braE xs0 (differenceMaybe' dNE mpx mpy) -- Note use of braE! m (x:xs) [] = case lookup x mpy of Nothing -> lmpx Just lmpb -> case d (BraF xs a mpx) lmpb of Empt -> Empt BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = BraF xs0 a (adjustMaybe' (\lmpa -> dNE lmpa (BraF ys b mpy)) y mpx) m (x:xs) (y:ys) = if x==y then m xs ys else lmpx ------------------------------------------ d lmpx@(BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where m [] [] = BraF xs0 a (differenceMaybe' dNE mpx mpy) m (x:xs) [] = case lookup x mpy of Nothing -> lmpx Just lmpb -> case d (BraF xs a mpx) lmpb of Empt -> Empt BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = BraF xs0 a (adjustMaybe' (\lmpa -> dNE lmpa (BraE ys mpy)) y mpx) m (x:xs) (y:ys) = if x==y then m xs ys else lmpx ------------------------------------------ d lmpx@(BraE xs0 mpx) (BraF ys0 b mpy) = m xs0 ys0 where m [] [] = braE xs0 (differenceMaybe' dNE mpx mpy) -- Note use of braE! m (x:xs) [] = case lookup x mpy of Nothing -> lmpx Just lmpb -> case d (BraE xs mpx) lmpb of Empt -> Empt BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = braE xs0 (adjustMaybe' (\lmpa -> dNE lmpa (BraF ys b mpy)) y mpx) -- Note use of braE! m (x:xs) (y:ys) = if x==y then m xs ys else lmpx ------------------------------------------ d lmpx@(BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where m [] [] = braE xs0 (differenceMaybe' dNE mpx mpy) -- Note use of braE! m (x:xs) [] = case lookup x mpy of Nothing -> lmpx Just lmpb -> case d (BraE xs mpx) lmpb of Empt -> Empt BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = braE xs0 (adjustMaybe' (\lmpa -> dNE lmpa (BraE ys mpy)) y mpx) -- Note use of braE! m (x:xs) (y:ys) = if x==y then m xs ys else lmpx ------------------------------------------ -- | See 'Map' class method 'differenceMaybe'. differenceMaybeListMap :: Map map k => (a -> b -> Maybe a) -> ListMap map k a -> ListMap map k b -> ListMap map k a differenceMaybeListMap f lmp0 lmp1 = d lmp0 lmp1 where dNE lmpx lmpy = nonEmptyListMap (d lmpx lmpy) -- difference can yield empty maps !! ------------------------------------------ d Empt _ = Empt d lmpx Empt = lmpx ------------------------------------------ d lmpx@(BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where m [] [] = case f a b of Nothing -> braE xs0 (differenceMaybe' dNE mpx mpy) -- Note use of braE! Just a' -> BraF xs0 a' (differenceMaybe' dNE mpx mpy) m (x:xs) [] = case lookup x mpy of Nothing -> lmpx Just lmpb -> case d (BraF xs a mpx) lmpb of Empt -> Empt BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = BraF xs0 a (adjustMaybe' (\lmpa -> dNE lmpa (BraF ys b mpy)) y mpx) m (x:xs) (y:ys) = if x==y then m xs ys else lmpx ------------------------------------------ d lmpx@(BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where m [] [] = BraF xs0 a (differenceMaybe' dNE mpx mpy) m (x:xs) [] = case lookup x mpy of Nothing -> lmpx Just lmpb -> case d (BraF xs a mpx) lmpb of Empt -> Empt BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = BraF xs0 a (adjustMaybe' (\lmpa -> dNE lmpa (BraE ys mpy)) y mpx) m (x:xs) (y:ys) = if x==y then m xs ys else lmpx ------------------------------------------ d lmpx@(BraE xs0 mpx) (BraF ys0 b mpy) = m xs0 ys0 where m [] [] = braE xs0 (differenceMaybe' dNE mpx mpy) -- Note use of braE! m (x:xs) [] = case lookup x mpy of Nothing -> lmpx Just lmpb -> case d (BraE xs mpx) lmpb of Empt -> Empt BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = braE xs0 (adjustMaybe' (\lmpa -> dNE lmpa (BraF ys b mpy)) y mpx) -- Note use of braE! m (x:xs) (y:ys) = if x==y then m xs ys else lmpx ------------------------------------------ d lmpx@(BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where m [] [] = braE xs0 (differenceMaybe' dNE mpx mpy) -- Note use of braE! m (x:xs) [] = case lookup x mpy of Nothing -> lmpx Just lmpb -> case d (BraE xs mpx) lmpb of Empt -> Empt BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz m [] (y:ys) = braE xs0 (adjustMaybe' (\lmpa -> dNE lmpa (BraE ys mpy)) y mpx) -- Note use of braE! m (x:xs) (y:ys) = if x==y then m xs ys else lmpx ------------------------------------------ -- | See 'Map' class method 'isSubsetOf'. isSubsetOfListMap :: Map map k => ListMap map k a -> ListMap map k b -> Bool -- This is basically finding out if (differenceListMap lmp0 lmp1 == Empt) -- If so, lmp0 is a submap of lmp1. ------------------------------------------ isSubsetOfListMap Empt _ = True isSubsetOfListMap _ Empt = False ------------------------------------------ isSubsetOfListMap (BraF xs0 a mpx) (BraF ys0 _ mpy) = m xs0 ys0 where m [] [] = isSubmapOf isSubsetOfListMap mpx mpy m (x:xs) [] = case lookup x mpy of Nothing -> False Just lmpb -> isSubsetOfListMap (BraF xs a mpx) lmpb m [] (_:_ ) = False m (x:xs) (y:ys) = if x==y then m xs ys else False ------------------------------------------ isSubsetOfListMap (BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where m [] [] = False m (x:xs) [] = case lookup x mpy of Nothing -> False Just lmpb -> isSubsetOfListMap (BraF xs a mpx) lmpb m [] (_:_ ) = False m (x:xs) (y:ys) = if x==y then m xs ys else False ------------------------------------------ isSubsetOfListMap (BraE xs0 mpx) (BraF ys0 _ mpy) = m xs0 ys0 where m [] [] = isSubmapOf isSubsetOfListMap mpx mpy m (x:xs) [] = case lookup x mpy of Nothing -> False Just lmpb -> isSubsetOfListMap (BraE xs mpx) lmpb m [] (_:_ ) = False -- mpx must contain at least 2 entries m (x:xs) (y:ys) = if x==y then m xs ys else False ------------------------------------------ isSubsetOfListMap (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where m [] [] = isSubmapOf isSubsetOfListMap mpx mpy m (x:xs) [] = case lookup x mpy of Nothing -> False Just lmpb -> isSubsetOfListMap (BraE xs mpx) lmpb m [] (_:_ ) = False -- mpx must contain at least 2 entries m (x:xs) (y:ys) = if x==y then m xs ys else False ------------------------------------------ -- | See 'Map' class method 'isSubmapOf'. isSubmapOfListMap :: Map map k => (a -> b -> Bool) -> ListMap map k a -> ListMap map k b -> Bool isSubmapOfListMap p lmp0 lmp1 = d lmp0 lmp1 where ------------------------------------------ d Empt _ = True d _ Empt = False ------------------------------------------ d (BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where m [] [] = if p a b then isSubmapOf d mpx mpy else False m (x:xs) [] = case lookup x mpy of Nothing -> False Just lmpb -> d (BraF xs a mpx) lmpb m [] (_:_ ) = False m (x:xs) (y:ys) = if x==y then m xs ys else False ------------------------------------------ d (BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where m [] [] = False m (x:xs) [] = case lookup x mpy of Nothing -> False Just lmpb -> d (BraF xs a mpx) lmpb m [] (_:_ ) = False m (x:xs) (y:ys) = if x==y then m xs ys else False ------------------------------------------ d (BraE xs0 mpx) (BraF ys0 _ mpy) = m xs0 ys0 where m [] [] = isSubmapOf d mpx mpy m (x:xs) [] = case lookup x mpy of Nothing -> False Just lmpb -> d (BraE xs mpx) lmpb m [] (_:_ ) = False -- mpx must contain at least 2 entries m (x:xs) (y:ys) = if x==y then m xs ys else False ------------------------------------------ d (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where m [] [] = isSubmapOf d mpx mpy m (x:xs) [] = case lookup x mpy of Nothing -> False Just lmpb -> d (BraE xs mpx) lmpb m [] (_:_ ) = False -- mpx must contain at least 2 entries m (x:xs) (y:ys) = if x==y then m xs ys else False ------------------------------------------ -- | See 'Map' class method 'alter'. alterListMap :: Map map k => (Maybe a -> Maybe a) -> [k] -> ListMap map k a -> ListMap map k a -- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap) alterListMap f xs0 lmp0 = iw xs0 lmp0 where iwNE xs (Just lmp) = nonEmptyListMap (iw xs lmp) -- alter can yield empty maps !! iwNE xs Nothing = nonEmptyListMap (iw xs empty) ------------------------------ iw xs Empt = case (f Nothing) of Just ax -> BraF xs ax empty Nothing -> Empt ------------------------------ iw xs m@(BraF ys ay mp) = case match xs ys of Mat -> case (f (Just ay)) of -- xs == ys Just ax -> BraF ys ax mp Nothing -> braE ys mp -- N.B. Use of braE, not BraE Frk n f' xs' ys' -> case (f Nothing) of Just ax -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraF ys' ay mp)) Nothing -> m Sfy _ y' ys' -> case (f Nothing) of Just ax -> BraF xs ax (singleton y' (BraF ys' ay mp)) Nothing -> m Sfx _ x' xs' -> BraF ys ay (alter (iwNE xs') x' mp) ------------------------------ iw xs m@(BraE ys mp) = case match xs ys of Mat -> case (f Nothing) of Just ax -> BraF ys ax mp -- xs == ys Nothing -> m Frk n f' xs' ys' -> case (f Nothing) of Just ax -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraE ys' mp)) Nothing -> m Sfy _ y' ys' -> case (f Nothing) of Just ax -> BraF xs ax (singleton y' (BraE ys' mp)) Nothing -> m Sfx _ x' xs' -> braE ys (alter (iwNE xs') x' mp) -- N.B. Use of braE, not BraE ------------------------------ -- | See 'Map' class method 'insertWith'. insertWithListMap :: Map map k => (a -> a) -> [k] -> a -> ListMap map k a -> ListMap map k a -- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap) -- N.B We always use the Strict insertWith' method here! insertWithListMap f xs0 ax lmp0 = iw xs0 lmp0 where iw xs Empt = BraF xs ax empty ------------------------------ iw xs (BraF ys ay mp) = case match xs ys of Mat -> BraF ys (f ay) mp -- xs == ys Frk n f' xs' ys' -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraF ys' ay mp)) Sfy _ y' ys' -> BraF xs ax (singleton y' (BraF ys' ay mp)) Sfx _ x' xs' -> BraF ys ay (insertWith' (iw xs') x' (BraF xs' ax empty) mp) ------------------------------ iw xs (BraE ys mp) = case match xs ys of Mat -> BraF ys ax mp -- xs == ys Frk n f' xs' ys' -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraE ys' mp)) Sfy _ y' ys' -> BraF xs ax (singleton y' (BraE ys' mp)) Sfx _ x' xs' -> BraE ys (insertWith' (iw xs') x' (BraF xs' ax empty) mp) ------------------------------ -- | See 'Map' class method 'insertWith'''. insertWithListMap' :: Map map k => (a -> a) -> [k] -> a -> ListMap map k a -> ListMap map k a -- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap) -- N.B We always use the Stricter insertWith'' method here! insertWithListMap' f xs0 ax lmp0 = iw xs0 lmp0 where iw xs Empt = ax `seq` BraF xs ax empty ------------------------------ iw xs (BraF ys ay mp) = case match xs ys of Mat -> let ay' = f ay in ay' `seq` BraF ys ay' mp -- xs == ys Frk n f' xs' ys' -> ax `seq` BraE (takeN n ys) (f' (BraF xs' ax empty) (BraF ys' ay mp)) Sfy _ y' ys' -> ax `seq` BraF xs ax (singleton y' (BraF ys' ay mp)) Sfx _ x' xs' -> BraF ys ay (insertWith' (iw xs') x' (ax `seq` (BraF xs' ax empty)) mp) -- N.B.!! ------------------------------ iw xs (BraE ys mp) = case match xs ys of Mat -> ax `seq` BraF ys ax mp -- xs == ys Frk n f' xs' ys' -> ax `seq` BraE (takeN n ys) (f' (BraF xs' ax empty) (BraE ys' mp)) Sfy _ y' ys' -> ax `seq` BraF xs ax (singleton y' (BraE ys' mp)) Sfx _ x' xs' -> BraE ys (insertWith' (iw xs') x' (ax `seq` (BraF xs' ax empty)) mp) -- N.B.!! ------------------------------ -- | See 'Map' class method 'insertMaybe'. insertMaybeListMap :: Map map k => (a -> Maybe a) -> [k] -> a -> ListMap map k a -> ListMap map k a -- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap) insertMaybeListMap f xs0 ax lmp0 = iw xs0 lmp0 where iwNE xs lmp = nonEmptyListMap (iw xs lmp) -- insertMaybe can yield empty maps !! ------------------------------ iw xs Empt = BraF xs ax empty ------------------------------ iw xs (BraF ys ay mp) = case match xs ys of Mat -> case f ay of -- xs == ys Just ay' -> BraF ys ay' mp Nothing -> braE ys mp -- N.B. Use of braE, not BraE Frk n f' xs' ys' -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraF ys' ay mp)) Sfy _ y' ys' -> BraF xs ax (singleton y' (BraF ys' ay mp)) Sfx _ x' xs' -> BraF ys ay (insertMaybe (iwNE xs') x' (BraF xs' ax empty) mp) ------------------------------ iw xs (BraE ys mp) = case match xs ys of Mat -> BraF ys ax mp -- xs == ys Frk n f' xs' ys' -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraE ys' mp)) Sfy _ y' ys' -> BraF xs ax (singleton y' (BraE ys' mp)) Sfx _ x' xs' -> braE ys (insertMaybe (iwNE xs') x' (BraF xs' ax empty) mp) -- N.B. Use of braE, not BraE ------------------------------ -- | See 'Map' class method 'foldElems'. foldElemsListMap :: Map map k => (a -> b -> b) -> b -> ListMap map k a -> b foldElemsListMap f b0 lmp0 = fld lmp0 b0 where fld Empt b = b fld (BraF _ a mp) b = f a (foldElems fld b mp) fld (BraE _ mp) b = foldElems fld b mp -- | See 'Map' class method 'foldKeys'. foldKeysListMap :: Map map k => ([k] -> b -> b) -> b -> ListMap map k a -> b foldKeysListMap f b0 lmp0 = fld [] lmp0 b0 where fld _ Empt b = b fld rks (BraF ks _ mp) b = f (revTo rks ks) (foldAssocs f' b mp) where f' k lmp b' = fld (k : revTo ks rks) lmp b' fld rks (BraE ks mp) b = foldAssocs f' b mp where f' k lmp b' = fld (k : revTo ks rks) lmp b' -- | See 'Map' class method 'foldAssocs'. foldAssocsListMap :: Map map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b foldAssocsListMap f b0 lmp0 = fld [] lmp0 b0 where fld _ Empt b = b fld rks (BraF ks a mp) b = f (revTo rks ks) a (foldAssocs f' b mp) where f' k lmp b' = fld (k : revTo ks rks) lmp b' fld rks (BraE ks mp) b = foldAssocs f' b mp where f' k lmp b' = fld (k : revTo ks rks) lmp b' -- | See 'Map' class method 'foldElems''. foldElemsListMap' :: Map map k => (a -> b -> b) -> b -> ListMap map k a -> b foldElemsListMap' f b0 lmp0 = fld lmp0 b0 where fld Empt b = b fld (BraF _ a mp) b = let b' = foldElems' fld b mp in b' `seq` f a b' fld (BraE _ mp) b = foldElems' fld b mp -- | See 'Map' class method 'foldKeys''. foldKeysListMap' :: Map map k => ([k] -> b -> b) -> b -> ListMap map k a -> b foldKeysListMap' f b0 lmp0 = fld [] lmp0 b0 where fld _ Empt b = b fld rks (BraF ks _ mp) b = b'' `seq` f (revTo rks ks) b'' where f' k lmp b' = fld (k : revTo ks rks) lmp b' b'' = foldAssocs' f' b mp fld rks (BraE ks mp) b = foldAssocs' f' b mp where f' k lmp b' = fld (k : revTo ks rks) lmp b' -- | See 'Map' class method 'foldAssocs''. foldAssocsListMap' :: Map map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b foldAssocsListMap' f b0 lmp0 = fld [] lmp0 b0 where fld _ Empt b = b fld rks (BraF ks a mp) b = b'' `seq` f (revTo rks ks) a b'' where f' k lmp b' = fld (k : revTo ks rks) lmp b' b'' = foldAssocs' f' b mp fld rks (BraE ks mp) b = foldAssocs' f' b mp where f' k lmp b' = fld (k : revTo ks rks) lmp b' ------------------------------------------------------------------------------------------ -- Group an ordered list of assocs according to which part of the map they will form clump :: (Eq a) => [([a], b)] -> [a] -> ([b], [(a, [([a], b)])]) clump as prefix = if null nonNulls then (L.map snd nulls, []) else (L.map snd nulls, clumps' [(k',c' [])]) -- 'currentClump' and 'clumps' are list building continuations to preserve order of 'as' where f (currentKey,currentClump,clumps) (key,tl) = if key == currentKey then (currentKey, currentClump . (tl:), clumps ) else (key, (tl:), clumps . ((currentKey,currentClump []):) ) (nulls,nonNulls) = L.partition (null . fst) $ L.map (\(k,a) -> (fromJust $ L.stripPrefix prefix k,a)) as rest = L.map (\(k:ks,a) -> (k,(ks,a))) nonNulls (k',c',clumps') = L.foldl' f (fst $ head rest,id,id) rest commonPrefix :: (Eq a) => [([a], b)] -> [a] commonPrefix as = common (fst $ head as) (fst $ last as) where common [] _ = [] common _ [] = [] common (ka:kas) (kb:kbs) = if ka == kb then ka : common kas kbs else [] fromAssocsAscWithListMap :: OrderedMap map k => (a -> a -> a) -> [([k],a)] -> ListMap map k a fromAssocsAscWithListMap _ [] = emptyListMap fromAssocsAscWithListMap f as = case nulls of [] -> braE prefix (fromAssocsAsc innerAs) _ -> BraF prefix (L.foldl1' f nulls) (fromAssocsAsc innerAs) where (nulls,clumps) = clump as prefix prefix = commonPrefix as innerAs = L.map (\(k,as') -> (k,fromAssocsAscWith f as')) clumps -- NB Shouldnt have any repeated keys in 'innerAs' if 'as' is ordered fromAssocsDescWithListMap :: OrderedMap map k => (a -> a -> a) -> [([k],a)] -> ListMap map k a fromAssocsDescWithListMap _ [] = emptyListMap fromAssocsDescWithListMap f as = case nulls of [] -> braE prefix (fromAssocsDesc innerAs) _ -> BraF prefix (L.foldl1' f nulls) (fromAssocsDesc innerAs) where (nulls,clumps) = clump as prefix prefix = commonPrefix as innerAs = L.map (\(k,as') -> (k,fromAssocsDescWith f as')) clumps -- NB Shouldnt have any repeated keys in 'innerAs' if 'as' is ordered fromAssocsAscMaybeListMap :: OrderedMap map k => (a -> a -> Maybe a) -> [([k],a)] -> ListMap map k a fromAssocsAscMaybeListMap _ [] = emptyListMap fromAssocsAscMaybeListMap f as = case L.foldl' insNull Nothing nulls of Nothing -> braE prefix (fromAssocsAsc innerAs) Just a -> BraF prefix a (fromAssocsAsc innerAs) where insNull Nothing b = Just b insNull (Just a) b = f a b (nulls,clumps) = clump as prefix prefix = commonPrefix as innerAs = catMaybes $ L.map (\(k,as') -> do mp <- nonEmpty $ fromAssocsAscMaybe f as'; return (k,mp)) clumps -- NB Shouldnt have any repeated keys in 'innerAs' if 'as' is ordered fromAssocsDescMaybeListMap :: OrderedMap map k => (a -> a -> Maybe a) -> [([k],a)] -> ListMap map k a fromAssocsDescMaybeListMap _ [] = emptyListMap fromAssocsDescMaybeListMap f as = case L.foldl' insNull Nothing nulls of Nothing -> braE prefix (fromAssocsDesc innerAs) Just a -> BraF prefix a (fromAssocsDesc innerAs) where insNull Nothing b = Just b insNull (Just a) b = f a b (nulls,clumps) = clump as prefix prefix = commonPrefix as innerAs = catMaybes $ L.map (\(k,as') -> do mp <- nonEmpty $ fromAssocsDescMaybe f as'; return (k,mp)) clumps -- NB Shouldnt have any repeated keys in 'innerAs' if 'as' is ordered -- | See 'Map' class method 'foldElemsAsc'. foldElemsAscListMap :: OrderedMap map k => (a -> b -> b) -> b -> ListMap map k a -> b foldElemsAscListMap f b0 lmp0 = fld lmp0 b0 where fld Empt b = b fld (BraF _ a mp) b = f a (foldElemsAsc fld b mp) fld (BraE _ mp) b = foldElemsAsc fld b mp -- | See 'Map' class method 'foldElemsDesc'. foldElemsDescListMap :: OrderedMap map k => (a -> b -> b) -> b -> ListMap map k a -> b foldElemsDescListMap f b0 lmp0 = fld lmp0 b0 where fld Empt b = b fld (BraF _ a mp) b = foldElemsDesc fld (f a b) mp fld (BraE _ mp) b = foldElemsDesc fld b mp -- | See 'Map' class method 'foldKeysAsc'. foldKeysAscListMap :: OrderedMap map k => ([k] -> b -> b) -> b -> ListMap map k a -> b foldKeysAscListMap f b0 lmp0 = fld [] lmp0 b0 where fld _ Empt b = b fld rks (BraF ks _ mp) b = f (revTo rks ks) (foldAssocsAsc f' b mp) where f' k lmp b' = fld (k : revTo ks rks) lmp b' fld rks (BraE ks mp) b = foldAssocsAsc f' b mp where f' k lmp b' = fld (k : revTo ks rks) lmp b' -- | See 'Map' class method 'foldKeysDesc'. foldKeysDescListMap :: OrderedMap map k => ([k] -> b -> b) -> b -> ListMap map k a -> b foldKeysDescListMap f b0 lmp0 = fld [] lmp0 b0 where fld _ Empt b = b fld rks (BraF ks _ mp) b = foldAssocsDesc f' (f (revTo rks ks) b) mp where f' k lmp b' = fld (k : revTo ks rks) lmp b' fld rks (BraE ks mp) b = foldAssocsDesc f' b mp where f' k lmp b' = fld (k : revTo ks rks) lmp b' -- | See 'Map' class method 'foldAssocsAsc'. foldAssocsAscListMap :: OrderedMap map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b foldAssocsAscListMap f b0 lmp0 = fld [] lmp0 b0 where fld _ Empt b = b fld rks (BraF ks a mp) b = f (revTo rks ks) a (foldAssocsAsc f' b mp) where f' k lmp b' = fld (k : revTo ks rks) lmp b' fld rks (BraE ks mp) b = foldAssocsAsc f' b mp where f' k lmp b' = fld (k : revTo ks rks) lmp b' -- | See 'Map' class method 'foldAssocsDesc'. foldAssocsDescListMap :: OrderedMap map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b foldAssocsDescListMap f b0 lmp0 = fld [] lmp0 b0 where fld _ Empt b = b fld rks (BraF ks a mp) b = foldAssocsDesc f' (f (revTo rks ks) a b) mp where f' k lmp b' = fld (k : revTo ks rks) lmp b' fld rks (BraE ks mp) b = foldAssocsDesc f' b mp where f' k lmp b' = fld (k : revTo ks rks) lmp b' -- | See 'Map' class method 'foldElemsAsc''. foldElemsAscListMap' :: OrderedMap map k => (a -> b -> b) -> b -> ListMap map k a -> b foldElemsAscListMap' f b0 lmp0 = fld lmp0 b0 where fld Empt b = b fld (BraF _ a mp) b = let b' = foldElemsAsc' fld b mp in b' `seq` f a b' fld (BraE _ mp) b = foldElemsAsc' fld b mp -- | See 'Map' class method 'foldElemsDesc''. foldElemsDescListMap' :: OrderedMap map k => (a -> b -> b) -> b -> ListMap map k a -> b foldElemsDescListMap' f b0 lmp0 = fld lmp0 b0 where fld Empt b = b fld (BraF _ a mp) b = let b' = f a b in b' `seq` foldElemsDesc' fld b' mp fld (BraE _ mp) b = foldElemsDesc' fld b mp -- | See 'Map' class method 'foldKeysAsc''. foldKeysAscListMap' :: OrderedMap map k => ([k] -> b -> b) -> b -> ListMap map k a -> b foldKeysAscListMap' f b0 lmp0 = fld [] lmp0 b0 where fld _ Empt b = b fld rks (BraF ks _ mp) b = b'' `seq` f (revTo rks ks) b'' where f' k lmp b' = fld (k : revTo ks rks) lmp b' b'' = foldAssocsAsc' f' b mp fld rks (BraE ks mp) b = foldAssocsAsc' f' b mp where f' k lmp b' = fld (k : revTo ks rks) lmp b' -- | See 'Map' class method 'foldKeysDesc''. foldKeysDescListMap' :: OrderedMap map k => ([k] -> b -> b) -> b -> ListMap map k a -> b foldKeysDescListMap' f b0 lmp0 = fld [] lmp0 b0 where fld _ Empt b = b fld rks (BraF ks _ mp) b = b'' `seq` foldAssocsDesc' f' b'' mp where f' k lmp b' = fld (k : revTo ks rks) lmp b' b'' = f (revTo rks ks) b fld rks (BraE ks mp) b = foldAssocsDesc' f' b mp where f' k lmp b' = fld (k : revTo ks rks) lmp b' -- | See 'Map' class method 'foldAssocsAsc''. foldAssocsAscListMap' :: OrderedMap map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b foldAssocsAscListMap' f b0 lmp0 = fld [] lmp0 b0 where fld _ Empt b = b fld rks (BraF ks a mp) b = b'' `seq` f (revTo rks ks) a b'' where f' k lmp b' = fld (k : revTo ks rks) lmp b' b'' = foldAssocsAsc' f' b mp fld rks (BraE ks mp) b = foldAssocsAsc' f' b mp where f' k lmp b' = fld (k : revTo ks rks) lmp b' -- | See 'Map' class method 'foldAssocsDesc''. foldAssocsDescListMap' :: OrderedMap map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b foldAssocsDescListMap' f b0 lmp0 = fld [] lmp0 b0 where fld _ Empt b = b fld rks (BraF ks a mp) b = b'' `seq` foldAssocsDesc' f' b'' mp where f' k lmp b' = fld (k : revTo ks rks) lmp b' b'' = f (revTo rks ks) a b fld rks (BraE ks mp) b = foldAssocsDesc' f' b mp where f' k lmp b' = fld (k : revTo ks rks) lmp b' -- | See 'Map' class method 'foldElemsUInt'. foldElemsUIntListMap :: Map map k => (a -> Int# -> Int#) -> Int# -> ListMap map k a -> Int# foldElemsUIntListMap f n0 lmp0 = fld lmp0 n0 where fld Empt n = n fld (BraF _ a mp) n = foldElemsUInt fld (f a n) mp fld (BraE _ mp) n = foldElemsUInt fld n mp -- | See 'Map' class method 'map'. mapListMap :: Map map k => (a -> b) -> ListMap map k a -> ListMap map k b mapListMap _ Empt = Empt mapListMap f (BraF ks a mp) = BraF ks (f a) (map' (mapListMap f) mp) -- Note use of strict map' mapListMap f (BraE ks mp) = BraE ks (map' (mapListMap f) mp) -- Note use of strict map' -- | See 'Map' class method 'map''. mapListMap' :: Map map k => (a -> b) -> ListMap map k a -> ListMap map k b mapListMap' _ Empt = Empt mapListMap' f (BraF ks a mp) = let b = f a in b `seq` BraF ks b (map' (mapListMap' f) mp) -- Note use of strict map' mapListMap' f (BraE ks mp) = BraE ks (map' (mapListMap' f) mp) -- Note use of strict map' -- | See 'Map' class method 'mapMaybe'. mapMaybeListMap :: Map map k => (a -> Maybe b) -> ListMap map k a -> ListMap map k b mapMaybeListMap _ Empt = Empt mapMaybeListMap f (BraF ks a mp) = let mp' = mapMaybe (\lmp -> nonEmptyListMap (mapMaybeListMap f lmp)) mp in case f a of Just b -> BraF ks b mp' Nothing -> braE ks mp' mapMaybeListMap f (BraE ks mp) = let mp' = mapMaybe (\lmp -> nonEmptyListMap (mapMaybeListMap f lmp)) mp in braE ks mp' -- | See 'Map' class method 'mapWithKey'. mapWithKeyListMap :: Map map k => ([k] -> a -> b) -> ListMap map k a -> ListMap map k b mapWithKeyListMap f mp = mwk id mp where mwk _ Empt = Empt mwk kcont (BraF ks a mp') = BraF ks (f (kcont ks) a) (mapWithKey' f' mp') -- Note use of strict mapWithKey' where f' k lmp = mwk (kcont . (ks++) . (k:)) lmp mwk kcont (BraE ks mp') = BraE ks (mapWithKey' f' mp') -- Note use of strict mapWithKey' where f' k lmp = mwk (kcont . (ks++) . (k:)) lmp -- | See 'Map' class method 'mapWithKey''. mapWithKeyListMap' :: Map map k => ([k] -> a -> b) -> ListMap map k a -> ListMap map k b mapWithKeyListMap' f mp = mwk id mp where mwk _ Empt = Empt mwk kcont (BraF ks a mp') = let b = f (kcont ks) a in b `seq` BraF ks b (mapWithKey' f' mp') -- Note use of strict mapWithKey' where f' k lmp = mwk (kcont . (ks++) . (k:)) lmp mwk kcont (BraE ks mp') = BraE ks (mapWithKey' f' mp') -- Note use of strict mapWithKey' where f' k lmp = mwk (kcont . (ks++) . (k:)) lmp -- | See 'Map' class method 'mapMaybe'. filterListMap :: Map map k => (a -> Bool) -> ListMap map k a -> ListMap map k a filterListMap p lmp0 = flt lmp0 where flt Empt = Empt flt (BraF ks a mp) = let mp' = mapMaybe (\lmp -> nonEmptyListMap (flt lmp)) mp in if p a then BraF ks a mp' else braE ks mp' flt (BraE ks mp) = let mp' = mapMaybe (\lmp -> nonEmptyListMap (flt lmp)) mp in braE ks mp' -- | See 'Map' class method 'valid'. validListMap :: Map map k => ListMap map k a -> Maybe String validListMap Empt = Nothing validListMap lmp = validListMap' lmp -- Disallows Empt validListMap' :: Map map k => ListMap map k a -> Maybe String validListMap' Empt = Just "ListMap: Non-empty map contains Empt node." -- Empty and singleton sub-maps are OK validListMap' (BraF _ _ mp) = case valid mp of Nothing -> foldElems valAccum Nothing mp Just s -> Just ("ListMap:" ++ s) -- Empty and singleton sub-maps are invalid validListMap' (BraE _ mp) = case valid mp of Nothing -> case status mp of None -> Just ("ListMap: Empty branch map in BraE node.") One _ _ -> Just ("ListMap: Singleton branch map in BraE node.") Many -> foldElems valAccum Nothing mp Just s -> Just ("ListMap:" ++ s) -- Accumulating valid (does not accept empty ListMaps) valAccum :: Map map k => ListMap map k a -> Maybe String -> Maybe String valAccum lmp Nothing = validListMap' lmp valAccum _ just = just -- | See 'Map' class method 'compareKey. compareKeyListMap :: OrderedMap map k => ListMap map k a -> [k] -> [k] -> Ordering compareKeyListMap _ [] [] = EQ compareKeyListMap _ _ [] = GT compareKeyListMap _ [] _ = LT compareKeyListMap mp (x:xs) (y:ys) = case (compareKey (innerMap mp) x y) of GT -> GT EQ -> compareKeyListMap mp xs ys LT -> LT where innerMap :: ListMap map k a -> map a innerMap _ = undefined -------------------------------------------------------------------------- -- OTHER INSTANCES -- -------------------------------------------------------------------------- -------- -- Eq -- -------- -- Needs -fallow-undecidable-instances instance (Eq k, Eq a, Eq (map (ListMap map k a))) => Eq (ListMap map k a) where Empt == Empt = True BraF ks0 a0 mp0 == BraF ks1 a1 mp1 = (ks0==ks1) && (a0==a1) && (mp0==mp1) BraE ks0 mp0 == BraE ks1 mp1 = (ks0==ks1) && (mp0==mp1) _ == _ = False --------- -- Ord -- --------- -- Needs -fallow-undecidable-instances instance (Map map k, Ord k, Ord a, Ord (map (ListMap map k a))) => Ord (ListMap map k a) where compare Empt Empt = EQ compare Empt _ = LT compare _ Empt = GT ----------------------- compare (BraF xs0 ax mpx) (BraF ys0 ay mpy) = m xs0 ys0 where m [] [] = case compare ax ay of LT -> LT EQ -> compare mpx mpy GT -> GT m (_:_ ) [] = GT m [] (_:_ ) = LT m (x:xs) (y:ys) = case compare x y of LT -> LT EQ -> m xs ys GT -> GT ----------------------- compare (BraF xs0 ax mpx) (BraE ys0 mpy) = m xs0 ys0 where m [] _ = LT m (x:xs) [] = let sx = singleton x (BraF xs ax mpx) in sx `seq` compare sx mpy m (x:xs) (y:ys) = case compare x y of LT -> LT EQ -> m xs ys GT -> GT ----------------------- compare (BraE xs0 mpx) (BraF ys0 ay mpy) = m xs0 ys0 where m _ [] = GT m [] (y:ys) = let sy = singleton y (BraF ys ay mpy) in sy `seq` compare mpx sy m (x:xs) (y:ys) = case compare x y of LT -> LT EQ -> m xs ys GT -> GT ----------------------- compare (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where m [] [] = compare mpx mpy m (x:xs) [] = let sx = singleton x (BraE xs mpx) in sx `seq` compare sx mpy m [] (y:ys) = let sy = singleton y (BraE ys mpy) in sy `seq` compare mpx sy m (x:xs) (y:ys) = case compare x y of LT -> LT EQ -> m xs ys GT -> GT ----------------------- ---------- -- Show -- ---------- instance (Map map k, Show k, Show a) => Show (ListMap map k a) where showsPrec d mp = showParen (d > 10) $ showString "fromAssocs " . shows (assocs mp) ---------- -- Read -- ---------- instance (Map map k, R.Read k, R.Read a) => R.Read (ListMap map k a) where readPrec = R.parens $ R.prec 10 $ do R.Ident "fromAssocs" <- R.lexP xs <- R.readPrec return (fromAssocs xs) readListPrec = R.readListPrecDefault ------------------------ -- Typeable/Typeable1 -- ------------------------ instance (Typeable1 map,Typeable k) => Typeable1 (ListMap map k) where typeOf1 mp = mkTyConApp (mkTyCon "Data.GMap.ListMap.ListMap") [typeOf1 m, typeOf k] where BraF [k] _ m = mp -- This is just to get types for k & m !! -------------- instance (Typeable1 (ListMap map k), Typeable a) => Typeable (ListMap map k a) where typeOf = typeOfDefault ------------- -- Functor -- ------------- instance Map map k => Functor (ListMap map k) where -- fmap :: (a -> b) -> ListMap map k a -> ListMap map k b fmap = mapListMap -- The lazy version ----------------- -- Data.Monoid -- ----------------- instance (Map map k, M.Monoid a) => M.Monoid (ListMap map k a) where -- mempty :: ListMap map k a mempty = emptyListMap -- mappend :: ListMap map k a -> ListMap map k a -> ListMap map k a mappend map0 map1 = unionListMap M.mappend map0 map1 -- mconcat :: [ListMap map k a] -> ListMap map k a mconcat maps = L.foldr (unionListMap M.mappend) emptyListMap maps ------------------- -- Data.Foldable -- ------------------- instance Map map k => F.Foldable (ListMap map k) where -- fold :: Monoid m => ListMap map k m -> m fold mp = foldElemsListMap M.mappend M.mempty mp -- foldMap :: Monoid m => (a -> m) -> ListMap map k a -> m foldMap f mp = foldElemsListMap (\a b -> M.mappend (f a) b) M.mempty mp -- foldr :: (a -> b -> b) -> b -> ListMap map k a -> b foldr f b0 mp = foldElemsListMap f b0 mp -- foldl :: (a -> b -> a) -> a -> ListMap map k b -> a foldl f b0 mp = foldElemsListMap (flip f) b0 mp {- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists. -- foldr1 :: (a -> a -> a) -> ListMap map k a -> a foldr1 = undefined -- foldl1 :: (a -> a -> a) -> ListMap map k a -> a foldl1 = undefined -}