From 6c7b41cc2b24f533697a62bf1843507ae043fc97 Mon Sep 17 00:00:00 2001
From: Ian Lynagh <igloo@earth.li>
Date: Thu, 24 Jan 2008 14:18:00 +0000
Subject: [PATCH] Fix the build Work around various problems caused by some of
 the monadification patches not being applied.

---
 compiler/basicTypes/UniqSupply.lhs |   28 +++++++++++++++++++++++++---
 compiler/deSugar/DsGRHSs.lhs       |    6 ++----
 compiler/ghci/RtClosureInspect.hs  |    2 +-
 compiler/rename/RnEnv.lhs          |   23 ++++++++++++++++++++++-
 compiler/rename/RnExpr.lhs         |   22 ++++++++++++++++++++++
 compiler/rename/RnSource.lhs       |   21 +++++++++++++++++++++
 compiler/specialise/SpecConstr.lhs |    1 +
 compiler/stranal/WorkWrap.lhs      |    1 +
 compiler/typecheck/TcHsSyn.lhs     |   15 +++++++++++++++
 compiler/utils/State.hs            |    2 +-
 10 files changed, 111 insertions(+), 10 deletions(-)

diff --git a/compiler/basicTypes/UniqSupply.lhs b/compiler/basicTypes/UniqSupply.lhs
index 2599d8d..7bd84b3 100644
--- a/compiler/basicTypes/UniqSupply.lhs
+++ b/compiler/basicTypes/UniqSupply.lhs
@@ -20,11 +20,14 @@ module UniqSupply (
 	UniqSM,		-- type: unique supply monad
 	initUs, initUs_,
 	lazyThenUs, lazyMapUs,
-	module MonadUtils, mapAndUnzipM,
+	mapAndUnzipM,
 	MonadUnique(..),
 
 	mkSplitUniqSupply,
-	splitUniqSupply, listSplitUniqSupply
+	splitUniqSupply, listSplitUniqSupply,
+
+    -- Deprecated:
+    getUniqueUs, getUs, returnUs, thenUs, mapUs
   ) where
 
 #include "HsVersions.h"
@@ -32,6 +35,9 @@ module UniqSupply (
 import Unique
 import FastTypes
 
+import MonadUtils
+import Control.Monad
+import Control.Monad.Fix
 #if __GLASGOW_HASKELL__ >= 607
 import GHC.IOBase (unsafeDupableInterleaveIO)
 #else
@@ -112,6 +118,16 @@ instance Monad UniqSM where
   (>>=) = thenUs
   (>>)  = thenUs_
 
+instance Functor UniqSM where
+    fmap f (USM x) = USM (\us -> case x us of
+                                 (r, us') -> (f r, us'))
+
+instance Applicative UniqSM where
+    pure = returnUs
+    (USM f) <*> (USM x) = USM $ \us -> case f us of 
+                            (ff, us')  -> case x us' of 
+                              (xx, us'') -> (ff xx, us'')
+
 -- the initUs function also returns the final UniqSupply; initUs_ drops it
 initUs :: UniqSupply -> UniqSM a -> (a,UniqSupply)
 initUs init_us m = case unUSM m init_us of { (r,us) -> (r,us) }
@@ -176,6 +192,13 @@ getUniqueUs = USM (\us -> case splitUniqSupply us of
 getUniquesUs :: UniqSM [Unique]
 getUniquesUs = USM (\us -> case splitUniqSupply us of
 			      (us1,us2) -> (uniqsFromSupply us1, us2))
+
+mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
+mapUs f []     = returnUs []
+mapUs f (x:xs)
+  = f x         `thenUs` \ r  ->
+    mapUs f xs  `thenUs` \ rs ->
+    returnUs (r:rs)
 \end{code}
 
 \begin{code}
@@ -189,5 +212,4 @@ lazyMapUs f (x:xs)
   = f x             `lazyThenUs` \ r  ->
     lazyMapUs f xs  `lazyThenUs` \ rs ->
     returnUs (r:rs)
-
 \end{code}
diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs
index db5cc0c..70a3724 100644
--- a/compiler/deSugar/DsGRHSs.lhs
+++ b/compiler/deSugar/DsGRHSs.lhs
@@ -33,8 +33,6 @@ import PrelNames
 import Name
 import SrcLoc
 
-import Control.Monad ((>=>))
-
 \end{code}
 
 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
@@ -142,11 +140,11 @@ isTrueLHsExpr (L _ (HsVar v)) |  v `hasKey` otherwiseIdKey
                                       = Just return
 	-- trueDataConId doesn't have the same unique as trueDataCon
 isTrueLHsExpr (L loc (HsTick    ix frees e))
-    | Just ticks <- isTrueLHsExpr e   = Just (ticks >=> mkTickBox ix frees)
+    | Just ticks <- isTrueLHsExpr e   = Just (\x -> ticks x >>= mkTickBox ix frees)
    -- This encodes that the result is constant True for Hpc tick purposes;
    -- which is specifically what isTrueLHsExpr is trying to find out.
 isTrueLHsExpr (L loc (HsBinTick ixT _ e))
-    | Just ticks <- isTrueLHsExpr e   = Just (ticks >=> mkTickBox ixT [])
+    | Just ticks <- isTrueLHsExpr e   = Just (\x -> ticks x >>= mkTickBox ixT [])
 isTrueLHsExpr (L _ (HsPar e))         = isTrueLHsExpr e
 isTrueLHsExpr other = Nothing
 \end{code}
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index db8930a..b5d67cf 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -73,7 +73,7 @@ import Panic
 
 import GHC.Arr          ( Array(..) )
 import GHC.Exts
-import GHC.IOBase
+import GHC.IOBase ( IO(IO) )
 
 import Control.Monad
 import Data.Maybe
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 2909af3..801dda8 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -70,9 +70,30 @@ import Util
 import Maybes
 import ListSetOps	( removeDups )
 import List		( nubBy )
-import Monad		( when )
 import DynFlags
 import FastString
+import Control.Monad
+\end{code}
+
+\begin{code}
+-- XXX
+thenM :: Monad a => a b -> (b -> a c) -> a c
+thenM = (>>=)
+
+thenM_ :: Monad a => a b -> a c -> a c
+thenM_ = (>>)
+
+returnM :: Monad m => a -> m a
+returnM = return
+
+mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
+mappM = mapM
+
+mappM_ :: (Monad m) => (a -> m b) -> [a] -> m ()
+mappM_ = mapM_
+
+checkM :: Monad m => Bool -> m () -> m ()
+checkM = unless
 \end{code}
 
 %*********************************************************
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 176fdb4..d6a8713 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -64,9 +64,31 @@ import SrcLoc		( Located(..), unLoc, getLoc, noLoc )
 import FastString
 
 import List		( unzip4 )
+import Control.Monad
 \end{code}
 
 
+\begin{code}
+-- XXX
+thenM :: Monad a => a b -> (b -> a c) -> a c
+thenM = (>>=)
+
+thenM_ :: Monad a => a b -> a c -> a c
+thenM_ = (>>)
+
+returnM :: Monad m => a -> m a
+returnM = return
+
+mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
+mappM = mapM
+
+mappM_ :: (Monad m) => (a -> m b) -> [a] -> m ()
+mappM_ = mapM_
+
+checkM :: Monad m => Bool -> m () -> m ()
+checkM = unless
+\end{code}
+
 %************************************************************************
 %*									*
 \subsubsection{Expressions}
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 1cb2223..8847f3b 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -59,6 +59,27 @@ import ListSetOps    (findDupsEq, mkLookupFun)
 import Control.Monad
 \end{code}
 
+\begin{code}
+-- XXX
+thenM :: Monad a => a b -> (b -> a c) -> a c
+thenM = (>>=)
+
+thenM_ :: Monad a => a b -> a c -> a c
+thenM_ = (>>)
+
+returnM :: Monad m => a -> m a
+returnM = return
+
+mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
+mappM = mapM
+
+mappM_ :: (Monad m) => (a -> m b) -> [a] -> m ()
+mappM_ = mapM_
+
+checkM :: Monad m => Bool -> m () -> m ()
+checkM = unless
+\end{code}
+
 @rnSourceDecl@ `renames' declarations.
 It simultaneously performs dependency analysis and precedence parsing.
 It also does the following error checks:
diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index d9903ee..f0648cc 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -47,6 +47,7 @@ import UniqSupply
 import Outputable
 import FastString
 import UniqFM
+import MonadUtils
 \end{code}
 
 -----------------------------------------------------
diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs
index 3af7e2d..a6f9bed 100644
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.lhs
@@ -40,6 +40,7 @@ import DynFlags
 import WwLib
 import Util		( lengthIs, notNull )
 import Outputable
+import MonadUtils
 \end{code}
 
 We take Core bindings whose binders have:
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index df6c50a..7bb1d5e 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -59,6 +59,21 @@ import Bag
 import Outputable
 \end{code}
 
+\begin{code}
+-- XXX
+thenM :: Monad a => a b -> (b -> a c) -> a c
+thenM = (>>=)
+
+thenM_ :: Monad a => a b -> a c -> a c
+thenM_ = (>>)
+
+returnM :: Monad m => a -> m a
+returnM = return
+
+mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
+mappM = mapM
+\end{code}
+
 
 %************************************************************************
 %*									*
diff --git a/compiler/utils/State.hs b/compiler/utils/State.hs
index b8fcaa1..0b6a285 100644
--- a/compiler/utils/State.hs
+++ b/compiler/utils/State.hs
@@ -1,5 +1,5 @@
 
-module State where
+module State (module State, mapAccumLM {- XXX hack -}) where
 
 import MonadUtils
 
-- 
1.7.10.4