Commit 6c7b41cc authored by Ian Lynagh's avatar Ian Lynagh

Fix the build

Work around various problems caused by some of the monadification patches
not being applied.
parent 80ef1f06
...@@ -20,11 +20,14 @@ module UniqSupply ( ...@@ -20,11 +20,14 @@ module UniqSupply (
UniqSM, -- type: unique supply monad UniqSM, -- type: unique supply monad
initUs, initUs_, initUs, initUs_,
lazyThenUs, lazyMapUs, lazyThenUs, lazyMapUs,
module MonadUtils, mapAndUnzipM, mapAndUnzipM,
MonadUnique(..), MonadUnique(..),
mkSplitUniqSupply, mkSplitUniqSupply,
splitUniqSupply, listSplitUniqSupply splitUniqSupply, listSplitUniqSupply,
-- Deprecated:
getUniqueUs, getUs, returnUs, thenUs, mapUs
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -32,6 +35,9 @@ module UniqSupply ( ...@@ -32,6 +35,9 @@ module UniqSupply (
import Unique import Unique
import FastTypes import FastTypes
import MonadUtils
import Control.Monad
import Control.Monad.Fix
#if __GLASGOW_HASKELL__ >= 607 #if __GLASGOW_HASKELL__ >= 607
import GHC.IOBase (unsafeDupableInterleaveIO) import GHC.IOBase (unsafeDupableInterleaveIO)
#else #else
...@@ -112,6 +118,16 @@ instance Monad UniqSM where ...@@ -112,6 +118,16 @@ instance Monad UniqSM where
(>>=) = thenUs (>>=) = thenUs
(>>) = 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 -- the initUs function also returns the final UniqSupply; initUs_ drops it
initUs :: UniqSupply -> UniqSM a -> (a,UniqSupply) initUs :: UniqSupply -> UniqSM a -> (a,UniqSupply)
initUs init_us m = case unUSM m init_us of { (r,us) -> (r,us) } 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 ...@@ -176,6 +192,13 @@ getUniqueUs = USM (\us -> case splitUniqSupply us of
getUniquesUs :: UniqSM [Unique] getUniquesUs :: UniqSM [Unique]
getUniquesUs = USM (\us -> case splitUniqSupply us of getUniquesUs = USM (\us -> case splitUniqSupply us of
(us1,us2) -> (uniqsFromSupply us1, us2)) (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} \end{code}
\begin{code} \begin{code}
...@@ -189,5 +212,4 @@ lazyMapUs f (x:xs) ...@@ -189,5 +212,4 @@ lazyMapUs f (x:xs)
= f x `lazyThenUs` \ r -> = f x `lazyThenUs` \ r ->
lazyMapUs f xs `lazyThenUs` \ rs -> lazyMapUs f xs `lazyThenUs` \ rs ->
returnUs (r:rs) returnUs (r:rs)
\end{code} \end{code}
...@@ -33,8 +33,6 @@ import PrelNames ...@@ -33,8 +33,6 @@ import PrelNames
import Name import Name
import SrcLoc import SrcLoc
import Control.Monad ((>=>))
\end{code} \end{code}
@dsGuarded@ is used for both @case@ expressions and pattern bindings. @dsGuarded@ is used for both @case@ expressions and pattern bindings.
...@@ -142,11 +140,11 @@ isTrueLHsExpr (L _ (HsVar v)) | v `hasKey` otherwiseIdKey ...@@ -142,11 +140,11 @@ isTrueLHsExpr (L _ (HsVar v)) | v `hasKey` otherwiseIdKey
= Just return = Just return
-- trueDataConId doesn't have the same unique as trueDataCon -- trueDataConId doesn't have the same unique as trueDataCon
isTrueLHsExpr (L loc (HsTick ix frees e)) 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; -- This encodes that the result is constant True for Hpc tick purposes;
-- which is specifically what isTrueLHsExpr is trying to find out. -- which is specifically what isTrueLHsExpr is trying to find out.
isTrueLHsExpr (L loc (HsBinTick ixT _ e)) 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 (L _ (HsPar e)) = isTrueLHsExpr e
isTrueLHsExpr other = Nothing isTrueLHsExpr other = Nothing
\end{code} \end{code}
......
...@@ -73,7 +73,7 @@ import Panic ...@@ -73,7 +73,7 @@ import Panic
import GHC.Arr ( Array(..) ) import GHC.Arr ( Array(..) )
import GHC.Exts import GHC.Exts
import GHC.IOBase import GHC.IOBase ( IO(IO) )
import Control.Monad import Control.Monad
import Data.Maybe import Data.Maybe
......
...@@ -70,9 +70,30 @@ import Util ...@@ -70,9 +70,30 @@ import Util
import Maybes import Maybes
import ListSetOps ( removeDups ) import ListSetOps ( removeDups )
import List ( nubBy ) import List ( nubBy )
import Monad ( when )
import DynFlags import DynFlags
import FastString 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} \end{code}
%********************************************************* %*********************************************************
......
...@@ -64,9 +64,31 @@ import SrcLoc ( Located(..), unLoc, getLoc, noLoc ) ...@@ -64,9 +64,31 @@ import SrcLoc ( Located(..), unLoc, getLoc, noLoc )
import FastString import FastString
import List ( unzip4 ) import List ( unzip4 )
import Control.Monad
\end{code} \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} \subsubsection{Expressions}
......
...@@ -59,6 +59,27 @@ import ListSetOps (findDupsEq, mkLookupFun) ...@@ -59,6 +59,27 @@ import ListSetOps (findDupsEq, mkLookupFun)
import Control.Monad import Control.Monad
\end{code} \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. @rnSourceDecl@ `renames' declarations.
It simultaneously performs dependency analysis and precedence parsing. It simultaneously performs dependency analysis and precedence parsing.
It also does the following error checks: It also does the following error checks:
......
...@@ -47,6 +47,7 @@ import UniqSupply ...@@ -47,6 +47,7 @@ import UniqSupply
import Outputable import Outputable
import FastString import FastString
import UniqFM import UniqFM
import MonadUtils
\end{code} \end{code}
----------------------------------------------------- -----------------------------------------------------
......
...@@ -40,6 +40,7 @@ import DynFlags ...@@ -40,6 +40,7 @@ import DynFlags
import WwLib import WwLib
import Util ( lengthIs, notNull ) import Util ( lengthIs, notNull )
import Outputable import Outputable
import MonadUtils
\end{code} \end{code}
We take Core bindings whose binders have: We take Core bindings whose binders have:
......
...@@ -59,6 +59,21 @@ import Bag ...@@ -59,6 +59,21 @@ import Bag
import Outputable import Outputable
\end{code} \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}
%************************************************************************ %************************************************************************
%* * %* *
......
module State where module State (module State, mapAccumLM {- XXX hack -}) where
import MonadUtils import MonadUtils
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment