%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[FiniteMap]{An implementation of finite maps}
\end{display}
The code is SPECIALIZEd to various highly-desirable types (e.g., Id)
-near the end (only \tr{#ifdef COMPILING_GHC}).
+near the end.
\begin{code}
-#ifdef COMPILING_GHC
-#include "HsVersions.h"
-#define IF_NOT_GHC(a) {--}
-#else
-#define ASSERT(e) {--}
-#define IF_NOT_GHC(a) a
-#define COMMA ,
-#define _tagCmp compare
-#define _LT LT
-#define _GT GT
-#define _EQ EQ
-#endif
-
-#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)/* NB NB NB */
-#define OUTPUTABLE_key , Outputable key
-#else
-#define OUTPUTABLE_key {--}
-#endif
module FiniteMap (
FiniteMap, -- abstract type
addToFM_C,
addListToFM,
addListToFM_C,
- IF_NOT_GHC(delFromFM COMMA)
+ delFromFM,
delListFromFM,
plusFM,
intersectFM,
intersectFM_C,
- mapFM, filterFM,
+ mapFM, filterFM,
sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM,
fmToList, keysFM, eltsFM
-#ifdef COMPILING_GHC
, bagToFM
- , SYN_IE(FiniteSet), emptySet, mkSet, isEmptySet
- , elementOf, setToList, union, minusSet
-#endif
+
) where
-IMPORT_DELOOPER(SpecLoop)
-#if defined(USE_FAST_STRINGS)
-import FastString
+#include "HsVersions.h"
+#define IF_NOT_GHC(a) {--}
+
+#if defined(DEBUG_FINITEMAPS)/* NB NB NB */
+#define OUTPUTABLE_key , Outputable key
+#else
+#define OUTPUTABLE_key {--}
#endif
+
+import {-# SOURCE #-} Name ( Name )
+import GlaExts
+import FastString
import Maybes
import Bag ( Bag, foldrBag )
-import Outputable ( Outputable(..) )
-import PprStyle ( PprStyle )
-import Pretty ( SYN_IE(Pretty), PrettyRep )
-
-#ifdef COMPILING_GHC
+import Outputable
-# if ! OMIT_NATIVE_CODEGEN
+#if ! OMIT_NATIVE_CODEGEN
# define IF_NCG(a) a
-# else
+#else
# define IF_NCG(a) {--}
-# endif
#endif
+
-- SIGH: but we use unboxed "sizes"...
#if __GLASGOW_HASKELL__
#define IF_GHC(a,b) a
unitFM :: key -> elt -> FiniteMap key elt
listToFM :: (Ord key OUTPUTABLE_key) => [(key,elt)] -> FiniteMap key elt
-- In the case of duplicates, the last is taken
-#ifdef COMPILING_GHC
bagToFM :: (Ord key OUTPUTABLE_key) => Bag (key,elt) -> FiniteMap key elt
-- In the case of duplicates, who knows which is taken
-#endif
-- ADDING AND DELETING
-- Throws away any previous binding
addListToFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt
-- Combines with previous binding
+ -- The combining fn goes (old -> new -> new)
addToFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
-> FiniteMap key elt -> key -> elt
-> FiniteMap key elt
-- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2
intersectFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-intersectFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt2)
- -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt2
+intersectFM_C :: (Ord key OUTPUTABLE_key) => (elt1 -> elt2 -> elt3)
+ -> FiniteMap key elt1 -> FiniteMap key elt2 -> FiniteMap key elt3
-- MAPPING, FOLDING, FILTERING
foldFM :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
filterFM :: (Ord key OUTPUTABLE_key) => (key -> elt -> Bool)
-> FiniteMap key elt -> FiniteMap key elt
+
-- INTERROGATING
sizeFM :: FiniteMap key elt -> Int
isEmptyFM :: FiniteMap key elt -> Bool
listToFM = addListToFM emptyFM
-#ifdef COMPILING_GHC
bagToFM = foldrBag (\(k,v) fm -> addToFM fm k v) emptyFM
-#endif
\end{code}
%************************************************************************
addToFM_C combiner EmptyFM key elt = unitFM key elt
addToFM_C combiner (Branch key elt size fm_l fm_r) new_key new_elt
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp new_key key of
- _LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r
- _GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)
- _EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r
-#else
- | new_key < key = mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r
- | new_key > key = mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)
- | otherwise = Branch new_key (combiner elt new_elt) size fm_l fm_r
-#endif
+ = case compare new_key key of
+ LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r
+ GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)
+ EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r
addListToFM fm key_elt_pairs = addListToFM_C (\ old new -> new) fm key_elt_pairs
\begin{code}
delFromFM EmptyFM del_key = emptyFM
delFromFM (Branch key elt size fm_l fm_r) del_key
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp del_key key of
- _GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key)
- _LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r
- _EQ -> glueBal fm_l fm_r
-#else
- | del_key > key
- = mkBalBranch key elt fm_l (delFromFM fm_r del_key)
-
- | del_key < key
- = mkBalBranch key elt (delFromFM fm_l del_key) fm_r
-
- | key == del_key
- = glueBal fm_l fm_r
-#endif
+ = case compare del_key key of
+ GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key)
+ LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r
+ EQ -> glueBal fm_l fm_r
delListFromFM fm keys = foldl delFromFM fm keys
\end{code}
-- It's worth doing plusFM specially, because we don't need
-- to do the lookup in fm1.
+-- FM2 over-rides FM1.
plusFM EmptyFM fm2 = fm2
plusFM fm1 EmptyFM = fm1
lookupFM EmptyFM key = Nothing
lookupFM (Branch key elt _ fm_l fm_r) key_to_find
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp key_to_find key of
- _LT -> lookupFM fm_l key_to_find
- _GT -> lookupFM fm_r key_to_find
- _EQ -> Just elt
-#else
- | key_to_find < key = lookupFM fm_l key_to_find
- | key_to_find > key = lookupFM fm_r key_to_find
- | otherwise = Just elt
-#endif
+ = case compare key_to_find key of
+ LT -> lookupFM fm_l key_to_find
+ GT -> lookupFM fm_r key_to_find
+ EQ -> Just elt
key `elemFM` fm
= case (lookupFM fm key) of { Nothing -> False; Just elt -> True }
mkBranch which key elt fm_l fm_r
= --ASSERT( left_ok && right_ok && balance_ok )
-#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)
+#if defined(DEBUG_FINITEMAPS)
if not ( left_ok && right_ok && balance_ok ) then
- pprPanic ("mkBranch:"++show which) (ppAboves [ppr PprDebug [left_ok, right_ok, balance_ok],
- ppr PprDebug key,
- ppr PprDebug fm_l,
- ppr PprDebug fm_r])
+ pprPanic ("mkBranch:"++show which) (vcat [ppr [left_ok, right_ok, balance_ok],
+ ppr key,
+ ppr fm_l,
+ ppr fm_r])
else
#endif
let
-- if sizeFM result <= 8 then
result
-- else
--- pprTrace ("mkBranch:"++(show which)) (ppr PprDebug result) (
+-- pprTrace ("mkBranch:"++(show which)) (ppr result) (
-- result
-- )
where
splitLT EmptyFM split_key = emptyFM
splitLT (Branch key elt _ fm_l fm_r) split_key
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp split_key key of
- _LT -> splitLT fm_l split_key
- _GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key)
- _EQ -> fm_l
-#else
- | split_key < key = splitLT fm_l split_key
- | split_key > key = mkVBalBranch key elt fm_l (splitLT fm_r split_key)
- | otherwise = fm_l
-#endif
+ = case compare split_key key of
+ LT -> splitLT fm_l split_key
+ GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key)
+ EQ -> fm_l
splitGT EmptyFM split_key = emptyFM
splitGT (Branch key elt _ fm_l fm_r) split_key
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp split_key key of
- _GT -> splitGT fm_r split_key
- _LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r
- _EQ -> fm_r
-#else
- | split_key > key = splitGT fm_r split_key
- | split_key < key = mkVBalBranch key elt (splitGT fm_l split_key) fm_r
- | otherwise = fm_r
-#endif
+ = case compare split_key key of
+ GT -> splitGT fm_r split_key
+ LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r
+ EQ -> fm_r
findMin :: FiniteMap key elt -> (key,elt)
findMin (Branch key elt _ EmptyFM _) = (key,elt)
%************************************************************************
\begin{code}
-#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)
+#if defined(DEBUG_FINITEMAPS)
instance (Outputable key) => Outputable (FiniteMap key elt) where
- ppr sty fm = pprX sty fm
+ ppr fm = pprX fm
-pprX sty EmptyFM = ppChar '!'
-pprX sty (Branch key elt sz fm_l fm_r)
- = ppBesides [ppLparen, pprX sty fm_l, ppSP,
- ppr sty key, ppSP, ppInt (IF_GHC(I# sz, sz)), ppSP,
- pprX sty fm_r, ppRparen]
+pprX EmptyFM = char '!'
+pprX (Branch key elt sz fm_l fm_r)
+ = parens (hcat [pprX fm_l, space,
+ ppr key, space, int (IF_GHC(I# sz, sz)), space,
+ pprX fm_r])
+#else
+-- and when not debugging the package itself...
+instance (Outputable key, Outputable elt) => Outputable (FiniteMap key elt) where
+ ppr fm = ppr (fmToList fm)
#endif
-#ifndef COMPILING_GHC
+#if 0
instance (Eq key, Eq elt) => Eq (FiniteMap key elt) where
fm_1 == fm_2 = (sizeFM fm_1 == sizeFM fm_2) && -- quick test
(fmToList fm_1 == fmToList fm_2)
%************************************************************************
%* *
-\subsection{FiniteSets---a thin veneer}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef COMPILING_GHC
-
-type FiniteSet key = FiniteMap key ()
-emptySet :: FiniteSet key
-mkSet :: (Ord key OUTPUTABLE_key) => [key] -> FiniteSet key
-isEmptySet :: FiniteSet key -> Bool
-elementOf :: (Ord key OUTPUTABLE_key) => key -> FiniteSet key -> Bool
-minusSet :: (Ord key OUTPUTABLE_key) => FiniteSet key -> FiniteSet key -> FiniteSet key
-setToList :: FiniteSet key -> [key]
-union :: (Ord key OUTPUTABLE_key) => FiniteSet key -> FiniteSet key -> FiniteSet key
-
-emptySet = emptyFM
-mkSet xs = listToFM [ (x, ()) | x <- xs]
-isEmptySet = isEmptyFM
-elementOf = elemFM
-minusSet = minusFM
-setToList = keysFM
-union = plusFM
-
-#endif
-\end{code}
-
-%************************************************************************
-%* *
\subsection{Efficiency pragmas for GHC}
%* *
%************************************************************************
\tr{Uniques}, for dastardly efficiency reasons.
\begin{code}
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ && !defined(REALLY_HASKELL_1_3)
+#if __GLASGOW_HASKELL__ && !defined(REALLY_HASKELL_1_3)
{-# SPECIALIZE addListToFM
:: FiniteMap (FAST_STRING, FAST_STRING) elt -> [((FAST_STRING, FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
#-}
-#endif {- compiling for GHC -}
+#endif {- compiling with ghc and have specialiser -}
\end{code}