# define IF_NOT_GHC(a) {--}
#else
# define panic error
-# define TAG_ _CMP_TAG
-# define LT_ _LT
-# define EQ_ _EQ
-# define GT_ _GT
+# define TAG_ Ordering
+# define LT_ LT
+# define EQ_ EQ
+# define GT_ GT
+# define _LT LT
+# define _EQ EQ
+# define _GT GT
# define GT__ _
-# define tagCmp_ _tagCmp
+# define tagCmp_ compare
+# define _tagCmp compare
# define FAST_STRING String
# define ASSERT(x) {-nothing-}
# define IF_NOT_GHC(a) a
tagCmp_,
TAG_(..),
#endif
+ -- The Eager monad
+ SYN_IE(Eager), thenEager, returnEager, mapEager, appEager, runEager,
+
-- general list processing
IF_NOT_GHC(forall COMMA exists COMMA)
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
zipLazy,
mapAndUnzip, mapAndUnzip3,
nOfThem, lengthExceeds, isSingleton,
- startsWith, endsWith,
#if defined(COMPILING_GHC)
+ startsWith, endsWith,
isIn, isn'tIn,
#endif
-- association lists
- assoc,
+ assoc, assocUsing, assocDefault, assocDefaultUsing,
-- duplicate handling
hasNoDups, equivClasses, runs, removeDups,
mapAccumL, mapAccumR, mapAccumB,
-- comparisons
+#if defined(COMPILING_GHC)
Ord3(..), thenCmp, cmpList,
- IF_NOT_GHC(cmpString COMMA)
- cmpPString,
+ cmpPString, FAST_STRING,
+#else
+ cmpString,
+#endif
-- pairs
IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
-- error handling
#if defined(COMPILING_GHC)
, panic, panic#, pprPanic, pprPanic#, pprError, pprTrace
- , assertPanic
+ , assertPanic, assertPprPanic
#endif {- COMPILING_GHC -}
) where
CHK_Ubiq() -- debugging consistency check
IMPORT_1_3(List(zipWith4))
+import Pretty
-import Pretty
+#else
+import List(zipWith4)
#endif
infixr 9 `thenCmp`
%************************************************************************
%* *
+\subsection{The Eager monad}
+%* *
+%************************************************************************
+
+The @Eager@ monad is just an encoding of continuation-passing style,
+used to allow you to express "do this and then that", mainly to avoid
+space leaks. It's done with a type synonym to save bureaucracy.
+
+\begin{code}
+type Eager ans a = (a -> ans) -> ans
+
+runEager :: Eager a a -> a
+runEager m = m (\x -> x)
+
+appEager :: Eager ans a -> (a -> ans) -> ans
+appEager m cont = m cont
+
+thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
+thenEager m k cont = m (\r -> k r cont)
+
+returnEager :: a -> Eager ans a
+returnEager v cont = cont v
+
+mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
+mapEager f [] = returnEager []
+mapEager f (x:xs) = f x `thenEager` \ y ->
+ mapEager f xs `thenEager` \ ys ->
+ returnEager (y:ys)
+\end{code}
+
+%************************************************************************
+%* *
\subsection[Utils-version-support]{Functions to help pre-1.2 versions of (non-Glasgow) Haskell}
%* *
%************************************************************************
startsWith [] str = Just str
startsWith (c:cs) (s:ss)
= if c /= s then Nothing else startsWith cs ss
-startWith _ [] = Nothing
+startsWith _ [] = Nothing
endsWith cs ss
= case (startsWith (reverse cs) (reverse ss)) of
See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@.
\begin{code}
-assoc :: (Eq a) => String -> [(a, b)] -> a -> b
+assoc :: (Eq a) => String -> [(a, b)] -> a -> b
+assocDefault :: (Eq a) => b -> [(a, b)] -> a -> b
+assocUsing :: (a -> a -> Bool) -> String -> [(a, b)] -> a -> b
+assocDefaultUsing :: (a -> a -> Bool) -> b -> [(a, b)] -> a -> b
+
+assocDefaultUsing eq deflt ((k,v) : rest) key
+ | k `eq` key = v
+ | otherwise = assocDefaultUsing eq deflt rest key
+
+assocDefaultUsing eq deflt [] key = deflt
-assoc crash_msg lst key
- = if (null res)
- then panic ("Failed in assoc: " ++ crash_msg)
- else head res
- where res = [ val | (key', val) <- lst, key == key']
+assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
+assocDefault deflt list key = assocDefaultUsing (==) deflt list key
+assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
\end{code}
%************************************************************************
cmpString [] ys = LT_
cmpString xs [] = GT_
+#ifdef COMPILING_GHC
cmpString _ _ = panic# "cmpString"
+#else
+cmpString _ _ = error "cmpString"
+#endif
\end{code}
\begin{code}
cmpPString :: FAST_STRING -> FAST_STRING -> TAG_
cmpPString x y
- = case (_tagCmp x y) of { _LT -> LT_ ; _EQ -> EQ_ ; _GT -> GT_ }
+ = case (tagCmpFS x y) of { _LT -> LT_ ; _EQ -> EQ_ ; _GT -> GT_ }
\end{code}
%************************************************************************
++ "Please report it as a compiler bug "
++ "to glasgow-haskell-bugs@dcs.gla.ac.uk.\n\n" )
-pprPanic heading pretty_msg = panic (heading++(ppShow 80 pretty_msg))
-pprError heading pretty_msg = error (heading++(ppShow 80 pretty_msg))
-#if __GLASGOW_HASKELL__ >= 200
-pprTrace heading pretty_msg = GHCbase.trace (heading++(ppShow 80 pretty_msg))
+pprPanic heading pretty_msg = panic (heading++ " " ++ (show pretty_msg))
+pprError heading pretty_msg = error (heading++ " " ++ (show pretty_msg))
+#if __GLASGOW_HASKELL__ == 201
+pprTrace heading pretty_msg = GHCbase.trace (heading++" "++(show pretty_msg))
+#elif __GLASGOW_HASKELL__ >= 202
+pprTrace heading pretty_msg = GlaExts.trace (heading++" "++(show pretty_msg))
#else
-pprTrace heading pretty_msg = trace (heading++(ppShow 80 pretty_msg))
+pprTrace heading pretty_msg = trace (heading++" "++(show pretty_msg))
#endif
-- #-versions because panic can't return an unboxed int, and that's
panic# :: String -> TAG_
panic# s = case (panic s) of () -> EQ_
-pprPanic# heading pretty_msg = panic# (heading++(ppShow 80 pretty_msg))
+pprPanic# heading pretty_msg = panic# (heading++(show pretty_msg))
assertPanic :: String -> Int -> a
assertPanic file line = panic ("ASSERT failed! file "++file++", line "++show line)
+assertPprPanic :: String -> Int -> Doc -> a
+assertPprPanic file line msg
+ = panic (show (sep [hsep[text "ASSERT failed! file",
+ text file,
+ text "line", int line],
+ msg]))
+
#endif {- COMPILING_GHC -}
\end{code}
projects / ghc-hetmet.git / blobdiff