Ticket #4834: ghc_new_monad_hierarchy.dpatch

5 patches for repository http://darcs.haskell.org/ghc:

Wed Dec  8 15:40:50 CET 2010  Bas van Dijk <v.dijk.bas@gmail.com>
  * Added (<>) = mappend to compiler/utils/Util.hs
  This is going to be used for joining SDocs and for splicing AGraphs.

Wed Dec  8 15:54:57 CET 2010  Bas van Dijk <v.dijk.bas@gmail.com>
  * Make SDoc an abstract newtype and add a Monoid instance for it
  The (<>) combinator of SDocs is removed and replaced by the 
  more general (<>) = mappend combinator from Util.

Wed Dec  8 16:39:06 CET 2010  Bas van Dijk <v.dijk.bas@gmail.com>
  * Add a Monoid instance for AGraph and remove the <*> splice operator
  Instead of <*>, the (<>) = mappend operator is now used to splice AGraphs.
  This change is needed because <*> clashes with the Applicative apply operator <*>, 
  which is probably going to be exported from the Prelude 
  when the new Monad hierarchy is going through.

Wed Dec  8 20:13:19 CET 2010  Bas van Dijk <v.dijk.bas@gmail.com>
  * Add Functor and Applicative instances for all monads in ghc

Sun Dec 12 00:50:20 CET 2010  Bas van Dijk <v.dijk.bas@gmail.com>
  * Require happy >= 1.18.7
  happy-1.18.7 generates needed Functor and Applicative instances for HappyIdentity

New patches:

[Added (<>) = mappend to compiler/utils/Util.hs
Bas van Dijk <v.dijk.bas@gmail.com>**20101208144050
 Ignore-this: 47df9db594b5a32f7387ad381461a111
 This is going to be used for joining SDocs and for splicing AGraphs.
] {
hunk ./compiler/utils/Util.lhs 9
 \begin{code}
 -- | Highly random utility functions
 module Util (
+        (<>),
+
         -- * Flags dependent on the compiler build
         ghciSupported, debugIsOn, ghciTablesNextToCode, isDynamicGhcLib,
         isWindowsHost, isWindowsTarget, isDarwinTarget,
hunk ./compiler/utils/Util.lhs 115
 import Data.Ord         ( comparing )
 import Data.Bits
 import Data.Word
+import Data.Monoid      ( Monoid(mappend) )
 import qualified Data.IntMap as IM
 
 infixr 9 `thenCmp`
hunk ./compiler/utils/Util.lhs 119
+
+infixr 3 <>
+
+(<>) :: Monoid m => m -> m -> m
+(<>) = mappend
+
 \end{code}
 
 %************************************************************************
}
[Make SDoc an abstract newtype and add a Monoid instance for it
Bas van Dijk <v.dijk.bas@gmail.com>**20101208145457
 Ignore-this: 200f03a71406cb6a0c4679ee987bf1b
 The (<>) combinator of SDocs is removed and replaced by the 
 more general (<>) = mappend combinator from Util.
] {
hunk ./compiler/basicTypes/Module.lhs 261
 pprModule :: Module -> SDoc
 pprModule mod@(Module p n)  = pprPackagePrefix p mod <> pprModuleName n
 
-pprPackagePrefix :: PackageId -> Module -> PprStyle -> Pretty.Doc
+pprPackagePrefix :: PackageId -> Module -> SDoc
 pprPackagePrefix p mod = getPprStyle doc
  where
    doc sty
hunk ./compiler/main/DynFlags.hs 755
 
         log_action = \severity srcSpan style msg ->
                         case severity of
-                          SevOutput -> printOutput (msg style)
-                          SevInfo   -> printErrs (msg style)
-                          SevFatal  -> printErrs (msg style)
+                          SevOutput -> printOutput (runSDoc msg style)
+                          SevInfo   -> printErrs (runSDoc msg style)
+                          SevFatal  -> printErrs (runSDoc msg style)
                           _         -> do 
                                 hPutChar stderr '\n'
hunk ./compiler/main/DynFlags.hs 760
-                                printErrs ((mkLocMessage srcSpan msg) style)
+                                printErrs (runSDoc (mkLocMessage srcSpan msg) style)
                      -- careful (#2302): printErrs prints in UTF-8, whereas
                      -- converting to string first and using hPutStr would
                      -- just emit the low 8 bits of each unicode char.
hunk ./compiler/main/ErrUtils.lhs 70
   -- would look strange.  Better to say explicitly "<no location info>".
 
 printError :: SrcSpan -> Message -> IO ()
-printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle)
+printError span msg = printErrs $ runSDoc (mkLocMessage span msg) defaultErrStyle
 
 
 -- -----------------------------------------------------------------------------
hunk ./compiler/nativeGen/AsmCodeGen.lhs 485
                | otherwise
                = Pretty.empty
 
-       doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
+       doPpr lbl = (lbl, Pretty.render $ runSDoc (pprCLabel lbl) astyle)
        astyle = mkCodeStyle AsmStyle
 
 
hunk ./compiler/typecheck/TcRnMonad.lhs 1127
 failIfM msg
   = do         { env <- getLclEnv
        ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
-       ; liftIO (printErrs (full_msg defaultErrStyle))
+       ; liftIO (printErrs (runSDoc full_msg defaultErrStyle))
        ; failM }
 
 --------------------
hunk ./compiler/typecheck/TcRnMonad.lhs 1162
                    ; return Nothing }
        }}
   where
-    print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle))
+    print_errs sdoc = liftIO (printErrs (runSDoc sdoc defaultErrStyle))
 
 forkM :: SDoc -> IfL a -> IfL a
 forkM doc thing_inside
hunk ./compiler/utils/Outputable.lhs 19
 
         -- * Pretty printing combinators
        SDoc,
+        runSDoc,
        docToSDoc,
        interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr,
        empty, nest,
hunk ./compiler/utils/Outputable.lhs 77
 import qualified Pretty
 import Pretty          ( Doc, Mode(..) )
 import Panic
+import Util             ( (<>) )
 
 import Data.Char
 import qualified Data.Map as M
hunk ./compiler/utils/Outputable.lhs 83
 import qualified Data.IntMap as IM
 import Data.Word
+import Data.Monoid      ( Monoid(..) )
 import System.IO       ( Handle, stderr, stdout, hFlush )
 import System.FilePath
 
hunk ./compiler/utils/Outputable.lhs 224
 %************************************************************************
 
 \begin{code}
-type SDoc = PprStyle -> Doc
+newtype SDoc = SDoc {runSDoc :: PprStyle -> Doc}
+
+instance Monoid SDoc where
+    mempty = empty
+    d1 `mappend` d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty)
+    -- ^ Join two 'SDoc' together horizontally without a gap
 
 withPprStyle :: PprStyle -> SDoc -> SDoc
hunk ./compiler/utils/Outputable.lhs 232
-withPprStyle sty d _sty' = d sty
+withPprStyle sty d = SDoc $ \_ -> runSDoc d sty
 
 withPprStyleDoc :: PprStyle -> SDoc -> Doc
hunk ./compiler/utils/Outputable.lhs 235
-withPprStyleDoc sty d = d sty
+withPprStyleDoc sty d = runSDoc d sty
 
 pprDeeper :: SDoc -> SDoc
hunk ./compiler/utils/Outputable.lhs 238
-pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
-pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
-pprDeeper d other_sty              = d other_sty
+pprDeeper d = SDoc $ \sty -> case sty of
+  (PprUser _ (PartWay 0)) -> Pretty.text "..."
+  (PprUser q (PartWay n)) -> runSDoc d (PprUser q (PartWay (n-1)))
+  other_sty               -> runSDoc d other_sty
 
 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
 -- Truncate a list that list that is longer than the current depth
hunk ./compiler/utils/Outputable.lhs 245
-pprDeeperList f ds (PprUser q (PartWay n))
-  | n==0      = Pretty.text "..."
-  | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
-  where
-    go _ [] = []
-    go i (d:ds) | i >= n    = [text "...."]
-               | otherwise = d : go (i+1) ds
+pprDeeperList f ds = SDoc work
+    where
+      work (PprUser q (PartWay n))
+        | n==0      = Pretty.text "..."
+        | otherwise = runSDoc (f (go 0 ds)) (PprUser q (PartWay (n-1)))
+        where
+          go _ [] = []
+          go i (d:ds) | i >= n    = [text "...."]
+                     | otherwise = d : go (i+1) ds
 
hunk ./compiler/utils/Outputable.lhs 255
-pprDeeperList f ds other_sty
-  = f ds other_sty
+      work other_sty
+        = runSDoc (f ds) other_sty
 
 pprSetDepth :: Depth -> SDoc -> SDoc
hunk ./compiler/utils/Outputable.lhs 259
-pprSetDepth depth  doc (PprUser q _) = doc (PprUser q depth)
-pprSetDepth _depth doc other_sty     = doc other_sty
+pprSetDepth depth doc = SDoc $ \sty -> case sty of
+  PprUser q _ -> runSDoc doc (PprUser q depth)
+  other_sty   -> runSDoc doc other_sty
 
 getPprStyle :: (PprStyle -> SDoc) -> SDoc
hunk ./compiler/utils/Outputable.lhs 264
-getPprStyle df sty = df sty sty
+getPprStyle df = SDoc $ \sty -> runSDoc (df sty) sty
 \end{code}
 
 \begin{code}
hunk ./compiler/utils/Outputable.lhs 297
 userStyle _other        = False
 
 ifPprDebug :: SDoc -> SDoc       -- Empty for non-debug style
-ifPprDebug d sty@PprDebug = d sty
-ifPprDebug _ _           = Pretty.empty
+ifPprDebug d = SDoc $ \sty -> case sty of
+                                PprDebug -> runSDoc d sty
+                                _        -> Pretty.empty
 \end{code}
 
 \begin{code}
hunk ./compiler/utils/Outputable.lhs 306
 -- Unused [7/02 sof]
 printSDoc :: SDoc -> PprStyle -> IO ()
 printSDoc d sty = do
-  Pretty.printDoc PageMode stdout (d sty)
+  Pretty.printDoc PageMode stdout (runSDoc d sty)
   hFlush stdout
 
 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
hunk ./compiler/utils/Outputable.lhs 323
 
 hPrintDump :: Handle -> SDoc -> IO ()
 hPrintDump h doc = do
-   Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
+   Pretty.printDoc PageMode h (runSDoc better_doc defaultDumpStyle)
    hFlush h
  where
    better_doc = doc $$ blankLine
hunk ./compiler/utils/Outputable.lhs 329
 
 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
-printForUser handle unqual doc 
-  = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
+printForUser handle unqual doc
+  = Pretty.printDoc PageMode handle (runSDoc doc (mkUserStyle unqual AllTheWay))
 
 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
 printForUserPartWay handle d unqual doc
hunk ./compiler/utils/Outputable.lhs 334
-  = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
+  = Pretty.printDoc PageMode handle (runSDoc doc (mkUserStyle unqual (PartWay d)))
 
 -- printForC, printForAsm do what they sound like
 printForC :: Handle -> SDoc -> IO ()
hunk ./compiler/utils/Outputable.lhs 338
-printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
+printForC handle doc = Pretty.printDoc LeftMode handle (runSDoc doc (PprCode CStyle))
 
 printForAsm :: Handle -> SDoc -> IO ()
hunk ./compiler/utils/Outputable.lhs 341
-printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
+printForAsm handle doc = Pretty.printDoc LeftMode handle (runSDoc doc (PprCode AsmStyle))
 
 pprCode :: CodeStyle -> SDoc -> SDoc
 pprCode cs d = withPprStyle (PprCode cs) d
hunk ./compiler/utils/Outputable.lhs 353
 -- However, Doc *is* an instance of Show
 -- showSDoc just blasts it out as a string
 showSDoc :: SDoc -> String
-showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle)
+showSDoc d = Pretty.showDocWith PageMode (runSDoc d defaultUserStyle)
 
 -- This shows an SDoc, but on one line only. It's cheaper than a full
 -- showSDoc, designed for when we're getting results like "Foo.bar"
hunk ./compiler/utils/Outputable.lhs 359
 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
 showSDocOneLine :: SDoc -> String
-showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle)
+showSDocOneLine d = Pretty.showDocWith PageMode (runSDoc d defaultUserStyle)
 
 showSDocForUser :: PrintUnqualified -> SDoc -> String
hunk ./compiler/utils/Outputable.lhs 362
-showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
+showSDocForUser unqual doc = show (runSDoc doc (mkUserStyle unqual AllTheWay))
 
 showSDocUnqual :: SDoc -> String
 -- Only used in the gruesome isOperator
hunk ./compiler/utils/Outputable.lhs 366
-showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
+showSDocUnqual d = show (runSDoc d (mkUserStyle neverQualify AllTheWay))
 
 showsPrecSDoc :: Int -> SDoc -> ShowS
hunk ./compiler/utils/Outputable.lhs 369
-showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
+showsPrecSDoc p d = showsPrec p (runSDoc d defaultUserStyle)
 
 showSDocDump :: SDoc -> String
hunk ./compiler/utils/Outputable.lhs 372
-showSDocDump d = Pretty.showDocWith PageMode (d PprDump)
+showSDocDump d = Pretty.showDocWith PageMode (runSDoc d PprDump)
 
 showSDocDumpOneLine :: SDoc -> String
hunk ./compiler/utils/Outputable.lhs 375
-showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump)
+showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (runSDoc d PprDump)
 
 showSDocDebug :: SDoc -> String
hunk ./compiler/utils/Outputable.lhs 378
-showSDocDebug d = show (d PprDebug)
+showSDocDebug d = show (runSDoc d PprDebug)
 
 showPpr :: Outputable a => a -> String
 showPpr = showSDoc . ppr
hunk ./compiler/utils/Outputable.lhs 386
 
 \begin{code}
 docToSDoc :: Doc -> SDoc
-docToSDoc d = \_ -> d
+docToSDoc d = SDoc $ \_ -> d
 
 empty    :: SDoc
 char     :: Char       -> SDoc
hunk ./compiler/utils/Outputable.lhs 399
 double   :: Double     -> SDoc
 rational :: Rational   -> SDoc
 
-empty _sty      = Pretty.empty
-char c _sty     = Pretty.char c
-text s _sty     = Pretty.text s
-ftext s _sty    = Pretty.ftext s
-ptext s _sty    = Pretty.ptext s
-int n _sty      = Pretty.int n
-integer n _sty  = Pretty.integer n
-float n _sty    = Pretty.float n
-double n _sty   = Pretty.double n
-rational n _sty = Pretty.rational n
+empty    = docToSDoc $ Pretty.empty
+char     = docToSDoc . Pretty.char
+text     = docToSDoc . Pretty.text
+ftext    = docToSDoc . Pretty.ftext
+ptext    = docToSDoc . Pretty.ptext
+int      = docToSDoc . Pretty.int
+integer  = docToSDoc . Pretty.integer
+float    = docToSDoc . Pretty.float
+double   = docToSDoc . Pretty.double
+rational = docToSDoc . Pretty.rational
 
 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
 
hunk ./compiler/utils/Outputable.lhs 412
-parens d sty       = Pretty.parens (d sty)
-braces d sty       = Pretty.braces (d sty)
-brackets d sty     = Pretty.brackets (d sty)
-doubleQuotes d sty = Pretty.doubleQuotes (d sty)
-angleBrackets d    = char '<' <> d <> char '>'
+parens        d = SDoc $ Pretty.parens       . runSDoc d
+braces        d = SDoc $ Pretty.braces       . runSDoc d
+brackets      d = SDoc $ Pretty.brackets     . runSDoc d
+doubleQuotes  d = SDoc $ Pretty.doubleQuotes . runSDoc d
+angleBrackets d = char '<' <> d <> char '>'
 
 cparen :: Bool -> SDoc -> SDoc
hunk ./compiler/utils/Outputable.lhs 419
-
-cparen b d sty       = Pretty.cparen b (d sty)
+cparen b d = SDoc $ Pretty.cparen b . runSDoc d
 
 -- quotes encloses something in single quotes...
 -- but it omits them if the thing ends in a single quote
hunk ./compiler/utils/Outputable.lhs 424
 -- so that we don't get `foo''.  Instead we just have foo'.
-quotes d sty = case show pp_d of
+quotes d = SDoc $ \sty ->
+           let pp_d = runSDoc d sty
+           in case show pp_d of
                 ('\'' : _) -> pp_d
                 _other     -> Pretty.quotes pp_d
hunk ./compiler/utils/Outputable.lhs 429
-            where
-              pp_d = d sty
 
 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
 darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
hunk ./compiler/utils/Outputable.lhs 433
 
-blankLine _sty = Pretty.ptext (sLit "")
-dcolon _sty    = Pretty.ptext (sLit "::")
-arrow  _sty    = Pretty.ptext (sLit "->")
-darrow _sty    = Pretty.ptext (sLit "=>")
-semi _sty      = Pretty.semi
-comma _sty     = Pretty.comma
-colon _sty     = Pretty.colon
-equals _sty    = Pretty.equals
-space _sty     = Pretty.space
-underscore     = char '_'
-dot           = char '.'
-lparen _sty    = Pretty.lparen
-rparen _sty    = Pretty.rparen
-lbrack _sty    = Pretty.lbrack
-rbrack _sty    = Pretty.rbrack
-lbrace _sty    = Pretty.lbrace
-rbrace _sty    = Pretty.rbrace
+blankLine  = docToSDoc $ Pretty.ptext (sLit "")
+dcolon     = docToSDoc $ Pretty.ptext (sLit "::")
+arrow      = docToSDoc $ Pretty.ptext (sLit "->")
+darrow     = docToSDoc $ Pretty.ptext (sLit "=>")
+semi       = docToSDoc $ Pretty.semi
+comma      = docToSDoc $ Pretty.comma
+colon      = docToSDoc $ Pretty.colon
+equals     = docToSDoc $ Pretty.equals
+space      = docToSDoc $ Pretty.space
+underscore = char '_'
+dot       = char '.'
+lparen     = docToSDoc $ Pretty.lparen
+rparen     = docToSDoc $ Pretty.rparen
+lbrack     = docToSDoc $ Pretty.lbrack
+rbrack     = docToSDoc $ Pretty.rbrack
+lbrace     = docToSDoc $ Pretty.lbrace
+rbrace     = docToSDoc $ Pretty.rbrace
 
 nest :: Int -> SDoc -> SDoc
 -- ^ Indent 'SDoc' some specified amount
hunk ./compiler/utils/Outputable.lhs 453
-(<>) :: SDoc -> SDoc -> SDoc
--- ^ Join two 'SDoc' together horizontally without a gap
 (<+>) :: SDoc -> SDoc -> SDoc
 -- ^ Join two 'SDoc' together horizontally with a gap between them
 ($$) :: SDoc -> SDoc -> SDoc
hunk ./compiler/utils/Outputable.lhs 461
 ($+$) :: SDoc -> SDoc -> SDoc
 -- ^ Join two 'SDoc' together vertically
 
-nest n d sty    = Pretty.nest n (d sty)
-(<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 sty)
-(<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
-($$) d1 d2 sty  = (Pretty.$$)  (d1 sty) (d2 sty)
-($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
+nest n d    = SDoc $ \sty -> Pretty.nest n (runSDoc d sty)
+(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>)  (runSDoc d1 sty) (runSDoc d2 sty)
+($$)  d1 d2 = SDoc $ \sty -> (Pretty.$$)   (runSDoc d1 sty) (runSDoc d2 sty)
+($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$)  (runSDoc d1 sty) (runSDoc d2 sty)
 
 hcat :: [SDoc] -> SDoc
 -- ^ Concatenate 'SDoc' horizontally
hunk ./compiler/utils/Outputable.lhs 482
 fcat :: [SDoc] -> SDoc
 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
 
-
-hcat ds sty = Pretty.hcat [d sty | d <- ds]
-hsep ds sty = Pretty.hsep [d sty | d <- ds]
-vcat ds sty = Pretty.vcat [d sty | d <- ds]
-sep ds sty  = Pretty.sep  [d sty | d <- ds]
-cat ds sty  = Pretty.cat  [d sty | d <- ds]
-fsep ds sty = Pretty.fsep [d sty | d <- ds]
-fcat ds sty = Pretty.fcat [d sty | d <- ds]
+hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds]
+hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds]
+vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds]
+sep  ds = SDoc $ \sty -> Pretty.sep  [runSDoc d sty | d <- ds]
+cat  ds = SDoc $ \sty -> Pretty.cat  [runSDoc d sty | d <- ds]
+fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds]
+fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds]
 
 hang :: SDoc  -- ^ The header
       -> Int  -- ^ Amount to indent the hung body
hunk ./compiler/utils/Outputable.lhs 494
       -> SDoc -- ^ The hung body, indented and placed below the header
       -> SDoc
-hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
+hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
 
 punctuate :: SDoc   -- ^ The punctuation
           -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
hunk ./compiler/utils/Outputable.lhs 814
 
 pprPanicFastInt :: String -> SDoc -> FastInt
 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
-pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
+pprPanicFastInt heading pretty_msg = panicFastInt (show (runSDoc doc PprDebug))
                             where
                               doc = text heading <+> pretty_msg
 
hunk ./compiler/utils/Outputable.lhs 820
 
 pprAndThen :: (String -> a) -> String -> SDoc -> a
-pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
+pprAndThen cont heading pretty_msg = cont (show (runSDoc doc PprDebug))
     where
      doc = sep [text heading, nest 4 pretty_msg]
 
hunk ./compiler/utils/Outputable.lhs 828
 -- ^ Panic with an assertation failure, recording the given file and line number.
 -- Should typically be accessed with the ASSERT family of macros
 assertPprPanic file line msg
-  = panic (show (doc PprDebug))
+  = panic (show (runSDoc doc PprDebug))
   where
     doc = sep [hsep[text "ASSERT failed! file", 
                           text file, 
hunk ./compiler/utils/Outputable.lhs 841
 warnPprTrace _     _file _line _msg x | opt_NoDebugOutput = x
 warnPprTrace False _file _line _msg x = x
 warnPprTrace True   file  line  msg x
-  = trace (show (doc defaultDumpStyle)) x
+  = trace (show (runSDoc doc defaultDumpStyle)) x
   where
     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
               msg]
}
[Add a Monoid instance for AGraph and remove the <*> splice operator
Bas van Dijk <v.dijk.bas@gmail.com>**20101208153906
 Ignore-this: fe944f0b230eafde5bdf6e3f38da4450
 Instead of <*>, the (<>) = mappend operator is now used to splice AGraphs.
 This change is needed because <*> clashes with the Applicative apply operator <*>, 
 which is probably going to be exported from the Prelude 
 when the new Monad hierarchy is going through.
] {
hunk ./compiler/cmm/CmmBuildInfoTables.hs 581
     load_tso <- newTemp gcWord -- TODO FIXME NOW
     let suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
         resumeThread  = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread")))
-        suspend = mkStore (CmmReg spReg) (CmmLit (CmmBlock infotable)) <*>
-                  saveThreadState <*>
-                  caller_save <*>
+        suspend = mkStore (CmmReg spReg) (CmmLit (CmmBlock infotable)) <>
+                  saveThreadState <>
+                  caller_save <>
                   mkUnsafeCall (ForeignTarget suspendThread
                                   (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint]))
                     -- XXX Not sure if the size of the CmmInt is correct
hunk ./compiler/cmm/CmmBuildInfoTables.hs 590
                     [id] [CmmReg (CmmGlobal BaseReg), CmmLit (CmmInt (fromIntegral (fromEnum interruptible)) wordWidth)]
         resume = mkUnsafeCall (ForeignTarget resumeThread
                                   (ForeignConvention CCallConv [AddrHint] [AddrHint]))
-                    [new_base] [CmmReg (CmmLocal id)] <*>
+                    [new_base] [CmmReg (CmmLocal id)] <>
                  -- Assign the result to BaseReg: we
                  -- might now have a different Capability!
hunk ./compiler/cmm/CmmBuildInfoTables.hs 593
-                 mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
-                 caller_load <*>
+                 mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <>
+                 caller_load <>
                  loadThreadState load_tso
     Graph tail' blocks' <-
hunk ./compiler/cmm/CmmBuildInfoTables.hs 597
-      liftUniq (graphOfAGraph (suspend <*> mkMiddle m <*> resume <*> mkZTail tail))
+      liftUniq (graphOfAGraph (suspend <> mkMiddle m <> resume <> mkZTail tail))
     return (state {s_blocks = s_blocks state `plusBlockEnv` blocks'}, tail')
 lowerSafeForeignCall _ _ _ = panic "lowerSafeForeignCall was passed something else"
hunk ./compiler/cmm/CmmCvt.hs 36
 toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = 
            let (offset, entry) = mkEntry id NativeNodeCall args in
            do g <- labelAGraph id $
-                     entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
+                     entry <> mkStmts ss <> foldr addBlock emptyAGraph other_blocks
               return ((offset, Nothing), g)
   where addBlock (BasicBlock id ss) g =
hunk ./compiler/cmm/CmmCvt.hs 39
-          mkLabel id <*> mkStmts ss <*> g
+          mkLabel id <> mkStmts ss <> g
         updfr_sz = 0 -- panic "upd frame size lost in cmm conversion"
hunk ./compiler/cmm/CmmCvt.hs 41
-        mkStmts (CmmNop        : ss)  = mkNop        <*> mkStmts ss 
-        mkStmts (CmmComment s  : ss)  = mkComment s  <*> mkStmts ss
-        mkStmts (CmmAssign l r : ss)  = mkAssign l r <*> mkStmts ss
-        mkStmts (CmmStore  l r : ss)  = mkStore  l r <*> mkStmts ss
+        mkStmts (CmmNop        : ss)  = mkNop        <> mkStmts ss
+        mkStmts (CmmComment s  : ss)  = mkComment s  <> mkStmts ss
+        mkStmts (CmmAssign l r : ss)  = mkAssign l r <> mkStmts ss
+        mkStmts (CmmStore  l r : ss)  = mkStore  l r <> mkStmts ss
         mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe _) CmmMayReturn : ss) =
             mkCall f (conv', conv') (map hintlessCmm res) (map hintlessCmm args) updfr_sz
hunk ./compiler/cmm/CmmCvt.hs 47
-            <*> mkStmts ss 
+            <> mkStmts ss
               where conv' = Foreign (ForeignConvention conv [] []) -- JD: DUBIOUS
         mkStmts (CmmCall (CmmPrim {}) _ _ (CmmSafe _) _ : _) =
             panic "safe call to a primitive CmmPrim CallishMachOp"
hunk ./compiler/cmm/CmmCvt.hs 54
         mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) =
                       mkUnsafeCall (convert_target f res args)
                        (strip_hints res) (strip_hints args)
-                      <*> mkStmts ss
+                      <> mkStmts ss
         mkStmts (CmmCondBranch e l : fbranch) =
             mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch)
         mkStmts (last : []) = mkLast last
hunk ./compiler/cmm/CmmProcPointZ.hs 333
            = case lookupBlockEnv protos id of
                Just (Protocol c fs _area) ->
                  do LGraph _ blocks <-
-                      lgraphOfAGraph (mkLabel id <*> copyInSlot c fs <*> mkZTail t)
+                      lgraphOfAGraph (mkLabel id <> copyInSlot c fs <> mkZTail t)
                     return (map snd $ blockEnvToList blocks)
                Nothing -> return [b]
            | otherwise = return [b]
hunk ./compiler/cmm/CmmSpillReload.hs 271
             in  if isEmptyUniqSet used then Nothing
                 else Just $ reloadTail used tail
         reloadTail regset t = foldl rel t $ uniqSetToList regset
-          where rel t r = mkMiddle (reload r) <*> t
+          where rel t r = mkMiddle (reload r) <> t
 
 
 insertLateReloads :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
hunk ./compiler/cmm/CmmStackLayout.hs 489
             if elemSlot liveSlots subarea then rst
             else let store = mkStore (CmmStackSlot a off)
                                      (stackStubExpr (widthFromBytes w))
-                 in case rst of Nothing -> Just (mkMiddle m <*> store)
-                                Just g  -> Just (g <*> store)
+                 in case rst of Nothing -> Just (mkMiddle m <> store)
+                                Just g  -> Just (g <> store)
hunk ./compiler/cmm/MkZipCfg.hs 3
 {-# LANGUAGE ScopedTypeVariables #-}
 module MkZipCfg
-    ( AGraph, (<*>), catAGraphs
+    ( AGraph, (<>), catAGraphs
     , freshBlockId
     , emptyAGraph, withFreshLabel, withUnique
     , mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo
hunk ./compiler/cmm/MkZipCfg.hs 22
 import Util
 
 import Prelude hiding (zip, unzip, last)
+import Data.Monoid    (Monoid(..))
 
 #include "HsVersions.h"
 
hunk ./compiler/cmm/MkZipCfg.hs 39
   * Last nodes (e.g. if b then goto L1 else goto L2)
 
 The constructors mkLabel, mkMiddle, and mkLast build single-node
-AGraphs of the indicated type.  The composition operator <*> glues
+AGraphs of the indicated type.  The composition operator <> glues
 AGraphs together in sequence (in constant time).
 
 For example:
hunk ./compiler/cmm/MkZipCfg.hs 57
 
 A 'AGraph m l' is simply an abstract version of a 'Graph m l' from
 module 'ZipCfg'.  The only difference is that the 'AGraph m l'
-supports a constant-time splicing operation, written infix <*>.
+supports a constant-time splicing operation, written infix <>.
 That splicing operation, together with the constructor functions in
 this module (and with 'labelAGraph'), is the recommended way to build
 large graphs.  Each construction or splice has constant cost, and to
hunk ./compiler/cmm/MkZipCfg.hs 96
   * A AGraph may be turned into a LGraph in time linear in the number
     of nodes and O(N log N) in the number of basic blocks.
 
-  * Two AGraphs may be spliced in constant time by writing  g1 <*> g2
+  * Two AGraphs may be spliced in constant time by writing  g1 <> g2
 
 There are two rules for splicing, depending on whether the left-hand
 graph falls through.  If it does, the rule is as follows:
hunk ./compiler/cmm/MkZipCfg.hs 106
         |                      |                          |      
        / \                    / \                        / \
       /   \                  /   \                      /   \
-     |  X  |      <*>       |  Y  |           =        |  X  |   
+     |  X  |      <>        |  Y  |           =        |  X  |   
       \   /                  \   /                      \   /    
        \ /                    \_/                        \ /     
         |                      |                          |          
hunk ./compiler/cmm/MkZipCfg.hs 133
         |                      |                          |      
        / \                    / \                        / \
       /   \                  /   \                      /   \
-     |  X  |      <*>       |  Y  |           =        |  X  |   
+     |  X  |      <>        |  Y  |           =        |  X  |   
       \   /                  \   /                      \   /    
        \_/                    \_/                        \_/     
                                |                                    
hunk ./compiler/cmm/MkZipCfg.hs 157
 
 -}
 
-infixr 3 <*>
-(<*>) :: AGraph m l -> AGraph m l -> AGraph m l
-
 catAGraphs :: [AGraph m l] -> AGraph m l
 
 -- | A graph is built up by splicing together graphs each containing a
hunk ./compiler/cmm/MkZipCfg.hs 163
 -- single node (where a label is considered a 'first' node.  The empty
 -- graph is a left and right unit for splicing.  All of the AGraph
 -- constructors (even complex ones like 'mkIfThenElse', as well as the
--- splicing operation <*>, are constant-time operations.
+-- splicing operation <>, are constant-time operations.
 
 emptyAGraph :: AGraph m l
 mkLabel     :: (LastNode l) => BlockId -> AGraph m l -- graph contains the label
hunk ./compiler/cmm/MkZipCfg.hs 186
 -- sitting to the side out-of-line.
 --
 -- Example:  mkMiddle (x = 3)
---           <*> outOfLine (mkLabel L <*> ...stuff...)
---           <*> mkMiddle (y = x)
+--           <> outOfLine (mkLabel L <> ...stuff...)
+--           <> mkMiddle (y = x)
 -- Control will flow directly from x=3 to y=x;
 -- the block starting with L is "on the side".
 --
hunk ./compiler/cmm/MkZipCfg.hs 191
--- N.B. algebraically forall g g' : g <*> outOfLine g' == outOfLine g' <*> g
+-- N.B. algebraically forall g g' : g <> outOfLine g' == outOfLine g' <> g
 
 
 
hunk ./compiler/cmm/MkZipCfg.hs 207
 -- goto on truth or falsehood.
 --
 --     mkIfThenElse mk_cond then else
---     = (mk_cond L1 L2) <*> L1: then <*> goto J
---                       <*> L2: else <*> goto J
---       <*> J:
+--     = (mk_cond L1 L2) <> L1: then <> goto J
+--                       <> L2: else <> goto J
+--       <> J:
 --
 -- where L1, L2, J are fresh
 
hunk ./compiler/cmm/MkZipCfg.hs 251
 newtype AGraph m l = AGraph (Graph m l -> UniqSM (Graph m l))
   -- an AGraph is a monadic function from a successor Graph to a new Graph
 
-AGraph f1 <*> AGraph f2 = AGraph f 
-    where f g = f2 g >>= f1 -- note right associativity
+instance Monoid (AGraph m l) where
+    mempty = emptyAGraph
+
+    AGraph f1 `mappend` AGraph f2 = AGraph f
+        where f g = f2 g >>= f1 -- note right associativity
+
+    mconcat = catAGraphs
 
hunk ./compiler/cmm/MkZipCfg.hs 259
-catAGraphs = foldr (<*>) emptyAGraph
+catAGraphs = foldr (<>) emptyAGraph
 
 emptyAGraph = AGraph return
 
hunk ./compiler/cmm/MkZipCfg.hs 323
     withFreshLabel "end of if"     $ \endif ->
     withFreshLabel "start of then" $ \tid ->
     withFreshLabel "start of else" $ \fid ->
-        cbranch tid fid <*>
-        mkLabel tid <*> tbranch <*> mkBranch endif <*>
-        mkLabel fid <*> fbranch <*>
+        cbranch tid fid <>
+        mkLabel tid <> tbranch <> mkBranch endif <>
+        mkLabel fid <> fbranch <>
         mkLabel endif
 
 mkWhileDo cbranch body = 
hunk ./compiler/cmm/MkZipCfg.hs 333
   withFreshLabel "loop head" $ \head ->
   withFreshLabel "end while" $ \endwhile ->
      -- Forrest Baskett's while-loop layout
-     mkBranch test <*> mkLabel head <*> body
-                   <*> mkLabel test <*> cbranch head endwhile
-                   <*> mkLabel endwhile
+     mkBranch test <> mkLabel head <> body
+                   <> mkLabel test <> cbranch head endwhile
+                   <> mkLabel endwhile
 
 -- | Bleat if the insertion of a last node will create unreachable code
 note_this_code_becomes_unreachable ::
hunk ./compiler/cmm/MkZipCfgCmm.hs 13
          , mkJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch, mkReturn
          , mkReturnSimple, mkComment, copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
          , mkEntry, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
-  , (<*>), catAGraphs, mkLabel, mkBranch
+  , (<>), catAGraphs, mkLabel, mkBranch
   , emptyAGraph, withFreshLabel, withUnique, outOfLine
   , lgraphOfAGraph, graphOfAGraph, labelAGraph
   , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, CmmStackInfo
hunk ./compiler/cmm/MkZipCfgCmm.hs 100
 mkCmmIfThen e tbranch
   = withFreshLabel "end of if"     $ \endif ->
     withFreshLabel "start of then" $ \tid ->
-    mkCbranch e tid endif <*>
-    mkLabel tid   <*> tbranch <*> mkBranch endif <*>
+    mkCbranch e tid endif <>
+    mkLabel tid   <> tbranch <> mkBranch endif <>
     mkLabel endif
 
 
hunk ./compiler/cmm/MkZipCfgCmm.hs 115
 -- NEED A COMPILER-DEBUGGING FLAG HERE
 -- Sanity check: any value assigned to a pointer must be non-zero.
 -- If it's 0, cause a crash immediately.
-mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r
+mkAssign l r = if opt_StubDeadValues then assign l r <> check l else assign l r
   where assign l r = mkMiddle (MidAssign l r)
         check (CmmGlobal _) = mkNop
         check l@(CmmLocal reg) = -- if a ptr arg is NULL, cause a crash!
hunk ./compiler/cmm/MkZipCfgCmm.hs 168
 copyIn oflow conv area formals =
   foldr ci (init_offset, mkNop) args'
   where ci (reg, RegisterParam r) (n, ms) =
-          (n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms)
+          (n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <> ms)
         ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
         init_offset = widthInBytes wordWidth -- infotable
         args  = assignArgumentsPos conv localRegType formals
hunk ./compiler/cmm/MkZipCfgCmm.hs 179
 -- Copy-in one arg, using overflow space if needed.
 oneCopyOflowI, oneCopySlotI :: SlotCopier
 oneCopyOflowI area (reg, off) (n, ms) =
-  (max n off, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) <*> ms)
+  (max n off, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) <> ms)
   where ty = localRegType reg
 
 -- Copy-in one arg, using spill slots if needed -- used for calling conventions at
hunk ./compiler/cmm/MkZipCfgCmm.hs 185
 -- a procpoint that is not a return point. The offset is irrelevant here...
 oneCopySlotI _ (reg, _) (n, ms) =
-  (n, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) <*> ms)
+  (n, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) <> ms)
   where ty = localRegType reg
         w  = widthInBytes (typeWidth ty)
 
hunk ./compiler/cmm/MkZipCfgCmm.hs 235
                 (ByteOff -> Last) -> CmmAGraph
 lastWithArgs transfer area conv actuals updfr_off last =
   let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
-  mkMiddles copies <*> mkLast (last outArgs)
+  mkMiddles copies <> mkLast (last outArgs)
 
 -- The area created for the jump and return arguments is the same area as the
 -- procedure entry.
hunk ./compiler/cmm/MkZipCfgCmm.hs 269
         (off, copyin) = copyInOflow retConv area results
         copyout = lastWithArgs Call area callConv actuals updfr_off 
                                (toCall f (Just k) updfr_off off)
-    in (copyout <*> mkLabel k <*> copyin)
+    in (copyout <> mkLabel k <> copyin)
hunk ./compiler/codeGen/StgCmm.hs 241
     mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
     check_already_done retId updfr_sz
      = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
-                      (mkLabel retId <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop
-       <*>     -- Set mod_reg to 1 to record that we've been here
+                      (mkLabel retId <> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop
+       <>      -- Set mod_reg to 1 to record that we've been here
            mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))
 
                     -- The return-code pops the work stack by 
hunk ./compiler/codeGen/StgCmm.hs 249
                     -- incrementing Sp, and then jumps to the popped item
     ret_e updfr_sz = CmmLoad (CmmStackSlot (CallArea Old) updfr_sz) gcWord
     ret_code updfr_sz = mkJump (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)
-      -- mkAssign spReg (cmmRegOffW spReg 1) <*>
+      -- mkAssign spReg (cmmRegOffW spReg 1) <>
       -- mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] updfr_sz
 
     pop_ret_loc updfr_sz = updfr_sz - widthInBytes (typeWidth bWord)
hunk ./compiler/codeGen/StgCmmBind.hs 97
 cgBind (StgNonRec name rhs)
   = do { ((info, init), body) <- getCodeR $ cgRhs name rhs
         ; addBindC (cg_id info) info
-        ; emit (init <*> body) }
+        ; emit (init <> body) }
 
 cgBind (StgRec pairs)
   = do { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits -> 
hunk ./compiler/codeGen/StgCmmBind.hs 104
                do { addBindsC $ fst new_binds_inits -- avoid premature deconstruction
                   ; liftM unzip $ listFCs [ cgRhs b e | (b,e) <- pairs ] })
        ; addBindsC new_binds
-       ; emit (catAGraphs inits <*> body) }
+       ; emit (catAGraphs inits <> body) }
 
 {- Recursive let-bindings are tricky.
    Consider the following pseudocode:
hunk ./compiler/codeGen/StgCmmBind.hs 616
 
        -- Overwrite the closure with a (static) indirection 
        -- to the newly-allocated black hole
-  ; emit (mkStore (cmmRegOffW nodeReg off_indirectee) (CmmReg (CmmLocal hp_rel)) <*>
+  ; emit (mkStore (cmmRegOffW nodeReg off_indirectee) (CmmReg (CmmLocal hp_rel)) <>
          mkStore (CmmReg nodeReg) ind_static_info)
 
   ; return hp_rel }
hunk ./compiler/codeGen/StgCmmExpr.hs 122
 cgLetNoEscapeRhs join_id local_cc bndr rhs =
   do { (info, rhs_body) <- getCodeR $ cgLetNoEscapeRhsBody local_cc bndr rhs 
      ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info
-     ; emit (outOfLine $ mkLabel bid <*> rhs_body <*> mkBranch join_id)
+     ; emit (outOfLine $ mkLabel bid <> rhs_body <> mkBranch join_id)
      ; return info
      }
 
hunk ./compiler/codeGen/StgCmmExpr.hs 323
        ; withSequel (AssignTo [idToReg (NonVoid v)] False) (cgExpr scrut)
        ; restoreCurrentCostCentre mb_cc
        ; emit $ mkComment $ mkFastString "should be unreachable code"
-       ; emit $ withFreshLabel "l" (\l -> mkLabel l <*> mkBranch l)}
+       ; emit $ withFreshLabel "l" (\l -> mkLabel l <> mkBranch l)}
 
 cgCase scrut bndr srt alt_type alts 
   = -- the general case
hunk ./compiler/codeGen/StgCmmExpr.hs 496
 cgLneJump blk_id lne_regs args -- Join point; discard sequel
   = do { cmm_args <- getNonVoidArgAmodes args
        ; emit (mkMultiAssign lne_regs cmm_args
-               <*> mkBranch blk_id) }
+               <> mkBranch blk_id) }
     
 cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode ()
 cgTailCall fun_id fun_info args = do
hunk ./compiler/codeGen/StgCmmForeign.hs 176
 saveThreadState =
   -- CurrentTSO->sp = Sp;
   mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
-  <*> closeNursery
+  <> closeNursery
   -- and save the current cost centre stack in the TSO when profiling:
hunk ./compiler/codeGen/StgCmmForeign.hs 178
-  <*> if opt_SccProfilingOn then
+  <> if opt_SccProfilingOn then
        mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
       else mkNop
 
hunk ./compiler/codeGen/StgCmmHeap.hs 443
   = withFreshLabel "gc" $ \ loop_id ->
     withFreshLabel "gc" $ \ gc_id   ->
       mkLabel loop_id 
-      <*> (let hpCheck = if alloc == 0 then mkNop
-                         else mkAssign hpReg bump_hp <*>
-                              mkCmmIfThen hp_oflo (save_alloc <*> mkBranch gc_id)
+      <>  (let hpCheck = if alloc == 0 then mkNop
+                         else mkAssign hpReg bump_hp <>
+                              mkCmmIfThen hp_oflo (save_alloc <> mkBranch gc_id)
            in if checkStack then
                 mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck
               else hpCheck)
hunk ./compiler/codeGen/StgCmmHeap.hs 449
-      <*> mkComment (mkFastString "outOfLine should follow:")
-      <*> outOfLine (mkLabel gc_id 
-                     <*> mkComment (mkFastString "outOfLine here")
-                     <*> do_gc
-                     <*> mkBranch loop_id)
+      <> mkComment (mkFastString "outOfLine should follow:")
+      <> outOfLine (mkLabel gc_id
+                     <> mkComment (mkFastString "outOfLine here")
+                     <> do_gc
+                     <> mkBranch loop_id)
                -- Test for stack pointer exhaustion, then
                -- bump heap pointer, and test for heap exhaustion
                -- Note that we don't move the heap pointer unless the 
hunk ./compiler/codeGen/StgCmmLayout.hs 184
   = do call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps
        emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (ppr fun) ++
                                         " with pat " ++ showSDoc (ftext rts_fun))
-       emit (mkAssign nodeReg fun <*> call)
+       emit (mkAssign nodeReg fun <> call)
   where
     (rts_fun, arity) = slowCallPattern reps
 
hunk ./compiler/codeGen/StgCmmMonad.hs 287
 -- Add code blocks from the latter to the former
 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
 s1 `addCodeBlocksFrom` s2
-  = s1 { cgs_stmts = cgs_stmts s1 <*> cgs_stmts s2,
+  = s1 { cgs_stmts = cgs_stmts s1 <> cgs_stmts s2,
         cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }
 
 
hunk ./compiler/codeGen/StgCmmMonad.hs 593
 emit :: CmmAGraph -> FCode ()
 emit ag
   = do { state <- getState
-       ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } }
+       ; setState $ state { cgs_stmts = cgs_stmts state <> ag } }
 
 emitData :: Section -> [CmmStatic] -> FCode ()
 emitData sect lits
hunk ./compiler/codeGen/StgCmmMonad.hs 608
   = do  { us <- newUniqSupply
         ; let (uniq, us') = takeUniqFromSupply us
               (offset, entry) = mkEntry (mkBlockId uniq) conv args
-              blks = initUs_ us' $ lgraphOfAGraph $ entry <*> blocks
+              blks = initUs_ us' $ lgraphOfAGraph $ entry <> blocks
         ; let proc_block = CmmProc info lbl args ((offset, Just initUpdFrameOff), blks)
         ; state <- getState
         ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
hunk ./compiler/codeGen/StgCmmUtils.hs 576
          = withUnique          $ \u -> 
            let (to_tmp, from_tmp) = split u first_stmt
            in mk_graph to_tmp
-              <*> unscramble rest
-              <*> mk_graph from_tmp
+              <> unscramble rest
+              <> mk_graph from_tmp
 
        split :: Unique -> Stmt -> (Stmt, Stmt)
        split uniq (reg, rhs)
hunk ./compiler/codeGen/StgCmmUtils.hs 640
     mk_switch tag_expr' (sortLe le branches) mb_deflt 
              lo_tag hi_tag via_C
          -- Sort the branches before calling mk_switch
-    <*> mkLabel join_lbl
+    <> mkLabel join_lbl
 
   where
     (t1,_) `le` (t2,_) = t1 <= t2
hunk ./compiler/codeGen/StgCmmUtils.hs 795
     label_code join_lbl deflt          $ \ deflt ->
     label_branches join_lbl branches   $ \ branches ->
     mk_lit_switch scrut' deflt (sortLe le branches)
-    <*> mkLabel join_lbl
+    <> mkLabel join_lbl
   where
     le (t1,_) (t2,_) = t1 <= t2
 
hunk ./compiler/codeGen/StgCmmUtils.hs 854
 --  [L: code; goto J] fun L
 label_code join_lbl code thing_inside
   = withFreshLabel "switch"    $ \lbl -> 
-    outOfLine (mkLabel lbl <*> code <*> mkBranch join_lbl)
-    <*> thing_inside lbl
+    outOfLine (mkLabel lbl <> code <> mkBranch join_lbl)
+    <> thing_inside lbl
  
 
 --------------
hunk ./compiler/codeGen/StgCmmUtils.hs 864
   | isTrivialCmmExpr e = thing_inside e
   | otherwise          = withTemp (cmmExprType e)      $ \ lreg ->
                         let reg = CmmLocal lreg in 
-                        mkAssign reg e <*> thing_inside (CmmReg reg)
+                        mkAssign reg e <> thing_inside (CmmReg reg)
 
 withTemp :: CmmType -> (LocalReg -> CmmAGraph) -> CmmAGraph
 withTemp rep thing_inside
}
[Add Functor and Applicative instances for all monads in ghc
Bas van Dijk <v.dijk.bas@gmail.com>**20101208191319
 Ignore-this: 477a43806c6f8eeb6a09688b8a183c5d
] {
hunk ./compiler/basicTypes/UniqSupply.lhs 117
 -- | A monad which just gives the ability to obtain 'Unique's
 newtype UniqSM result = USM { unUSM :: UniqSupply -> (result, UniqSupply) }
 
-instance Monad UniqSM where
-  return = returnUs
-  (>>=) = thenUs
-  (>>)  = thenUs_
-
 instance Functor UniqSM where
hunk ./compiler/basicTypes/UniqSupply.lhs 118
-    fmap f (USM x) = USM (\us -> case x us of
-                                 (r, us') -> (f r, us'))
+  fmap   = fmapUs
 
 instance Applicative UniqSM where
hunk ./compiler/basicTypes/UniqSupply.lhs 121
-    pure = returnUs
-    (USM f) <*> (USM x) = USM $ \us -> case f us of
-                            (ff, us')  -> case x us' of
-                              (xx, us'') -> (ff xx, us'')
+  pure   = returnUs
+  (<*>)  = apUs
+  (*>)   = thenUs_
+
+instance Monad UniqSM where
+  (>>=)  = thenUs
+  return = pure
+  (>>)   = (*>)
 
 -- | Run the 'UniqSM' action, returning the final 'UniqSupply'
 initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)
hunk ./compiler/basicTypes/UniqSupply.lhs 138
 initUs_ :: UniqSupply -> UniqSM a -> a
 initUs_ init_us m = case unUSM m init_us of { (r, _) -> r }
 
+{-# INLINE fmapUs #-}
+{-# INLINE apUs #-}
 {-# INLINE thenUs #-}
 {-# INLINE lazyThenUs #-}
 {-# INLINE returnUs #-}
hunk ./compiler/basicTypes/UniqSupply.lhs 151
 instance MonadFix UniqSM where
     mfix m = USM (\us -> let (r,us') = unUSM (m r) us in (r,us'))
 
+fmapUs :: (a -> b) -> UniqSM a -> UniqSM b
+fmapUs f usmx = USM $ \us -> case unUSM usmx us of
+                               (r, us') -> (f r, us')
+
+apUs :: UniqSM (a -> b) -> UniqSM a -> UniqSM b
+apUs usmf usmx = USM $ \us -> case unUSM usmf us of
+                                (f, us') -> unUSM (fmap f usmx) us'
+
 thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
 thenUs (USM expr) cont
   = USM (\us -> case (expr us) of
hunk ./compiler/cmm/CmmLint.hs 27
 import Constants
 import FastString
 
+import Control.Applicative (Applicative(..))
 import Control.Monad
 import Data.Maybe
 
hunk ./compiler/cmm/CmmLint.hs 166
 
 newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
 
+instance Functor CmmLint where
+  fmap f m = CmmLint $ case unCL m of
+                         Left  e -> Left e
+                         Right a -> Right (f a)
+
+instance Applicative CmmLint where
+  pure a = CmmLint $ Right a
+  mf <*> mx = CmmLint $ case unCL mf of
+                          Left  e -> Left e
+                          Right f -> unCL (fmap f mx)
+
 instance Monad CmmLint where
hunk ./compiler/cmm/CmmLint.hs 178
-  CmmLint m >>= k = CmmLint $ case m of 
-                               Left e -> Left e
-                               Right a -> unCL (k a)
-  return a = CmmLint (Right a)
+  m >>= k = CmmLint $ case unCL m of
+                       Left  e -> Left e
+                       Right a -> unCL (k a)
+  return = pure
 
 cmmLintErr :: SDoc -> CmmLint a
 cmmLintErr msg = CmmLint (Left msg)
hunk ./compiler/cmm/CmmTx.hs 3
 module CmmTx where
 
+import Control.Applicative (Applicative(..))
+
 data ChangeFlag = NoChange | SomeChange
 
 type Tx a    = a -> TxRes a
hunk ./compiler/cmm/CmmTx.hs 57
 instance Functor TxRes where
   fmap f (TxRes ch a) = TxRes ch (f a)
 
+instance Applicative TxRes where
+    pure = TxRes NoChange
+    TxRes NoChange   f <*> TxRes ch x = TxRes ch         (f x)
+    TxRes SomeChange f <*> TxRes _  x = TxRes SomeChange (f x)
+
 instance Monad TxRes where
hunk ./compiler/cmm/CmmTx.hs 63
-    return = TxRes NoChange
+    return = pure
     (TxRes NoChange a) >>= k = k a
     (TxRes SomeChange a) >>= k = let (TxRes _ a') = k a in TxRes SomeChange a'
hunk ./compiler/cmm/DFMonad.hs 23
 import Outputable
 import UniqSupply
 
+import Control.Applicative ( Applicative(..) )
 {-
 
 A dataflow monad maintains a mapping from BlockIds to dataflow facts,
hunk ./compiler/cmm/DFMonad.hs 69
                          , df_facts_change :: !ChangeFlag
                          }
 
-newtype DFM' m fact a = DFM' (DataflowLattice fact -> DFState fact
-                                                   -> m (a, DFState  fact))
+newtype DFM' m fact a = DFM' {unDFM' :: DataflowLattice fact -> DFState fact
+                                                             -> m (a, DFState  fact)}
 type DFM fact a = DFM' FuelMonad fact a
 
 
hunk ./compiler/cmm/DFMonad.hs 189
 graphWasRewritten :: DFM f ChangeFlag
 graphWasRewritten = DFM' f
     where f _ s = return (df_rewritten s, s)
-                    
+
+instance Monad m => Functor (DFM' m f) where
+  fmap f d  = DFM' $ \l s -> do (a, s') <- unDFM' d l s
+                                s' `seq` return (f a, s')
+
+instance Monad m => Applicative (DFM' m f) where
+  pure a    = DFM' $ \_ s -> return (a, s)
+  df <*> dx = DFM' $ \l s -> do (f, s') <- unDFM' df l s
+                                s' `seq` unDFM' (fmap f dx) l s'
+
 instance Monad m => Monad (DFM' m f) where
hunk ./compiler/cmm/DFMonad.hs 200
-  DFM' f >>= k = DFM' (\l s -> do (a, s') <- f l s
-                                  s' `seq` case k a of DFM' f' -> f' l s')
-  return a = DFM' (\_ s -> return (a, s))
+  d >>= k   = DFM' $ \l s -> do (a, s') <- unDFM' d l s
+                                s' `seq` unDFM' (k a) l s'
+  return = pure
  -- The `seq` is essential to ensure that entire passes of the dataflow engine 
  -- aren't postponed in a thunk. By making the sequence strict in the state,
  -- we ensure that each action in the monad is executed immediately, preventing
hunk ./compiler/cmm/OptimizationFuel.hs 26
 --import GHC.Exts (State#)
 import Panic
 import Data.IORef
+import Control.Applicative (Applicative(..))
 import Control.Monad
 import StaticFlags (opt_Fuel)
 import UniqSupply
hunk ./compiler/cmm/OptimizationFuel.hs 78
 #endif
 
 data FuelState = FuelState { fs_fuellimit :: OptimizationFuel, fs_lastpass :: String }
-newtype FuelMonad a = FuelMonad (FuelState -> UniqSM (a, FuelState))
+newtype FuelMonad a = FuelMonad {runFuel :: FuelState -> UniqSM (a, FuelState)}
 
 fuelConsumingPass :: String -> FuelConsumer a -> FuelMonad a
 fuelConsumingPass name f = do fuel <- fuelRemaining
hunk ./compiler/cmm/OptimizationFuel.hs 96
        writeIORef (fuel_ref fs) fuel'
        return a
 
+instance Functor FuelMonad where
+  fmap f m  = FuelMonad $ fmap (\(x, s') -> (f x, s')) . runFuel m
+
+instance Applicative FuelMonad where
+  pure a    = FuelMonad $ \s -> pure (a, s)
+  mf <*> mx = FuelMonad $ \s -> do (f, s') <- runFuel mf s
+                                   runFuel (fmap f mx) s'
+
 instance Monad FuelMonad where
hunk ./compiler/cmm/OptimizationFuel.hs 105
-  FuelMonad f >>= k = FuelMonad (\s -> do (a, s') <- f s
-                                          let FuelMonad f' = k a in (f' s'))
-  return a = FuelMonad (\s -> return (a, s))
+  m >>= k  = FuelMonad $ \s -> do (a, s') <- runFuel m s
+                                  runFuel (k a) s'
+  return   = pure
 
 instance MonadUnique FuelMonad where
     getUniqueSupplyM = liftUniq getUniqueSupplyM
hunk ./compiler/cmm/PprC.hs 62
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Word
+import Control.Applicative (Applicative(..))
 
 import Data.Array.ST
 import Control.Monad.ST
hunk ./compiler/cmm/PprC.hs 909
 type TEState = (UniqSet LocalReg, Map CLabel ())
 newtype TE a = TE { unTE :: TEState -> (a, TEState) }
 
+instance Functor TE where
+  fmap f m  = TE $ \s -> case unTE m s of (a, s') -> (f a, s')
+
+instance Applicative TE where
+  pure a    = TE $ \s -> (a, s)
+  mf <*> mx = TE $ \s -> case unTE mf s of (f, s') -> unTE (fmap f mx) s'
+
 instance Monad TE where
hunk ./compiler/cmm/PprC.hs 917
-   TE m >>= k  = TE $ \s -> case m s of (a, s') -> unTE (k a) s'
-   return a    = TE $ \s -> (a, s)
+   m >>= k  = TE $ \s -> case unTE m s of (a, s') -> unTE (k a) s'
+   return   = pure
 
 te_lbl :: CLabel -> TE ()
 te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls))
hunk ./compiler/codeGen/CgExtCode.hs 51
 import UniqFM
 import Unique
 
+import Control.Applicative ( Applicative(..) )
 
 -- | The environment contains variable definitions or blockids.
 data Named     
hunk ./compiler/codeGen/CgExtCode.hs 74
 
 type ExtCode = ExtFCode ()
 
+mapExtFC :: (a -> b) -> ExtFCode a -> ExtFCode b
+mapExtFC f c = EC $ \e s -> fmap (\(s', x) -> (s', f x)) $ unEC c e s
+
+apExtFC :: ExtFCode (a -> b) -> ExtFCode a -> ExtFCode b
+apExtFC cf cx = EC $ \e s -> do (s', f) <- unEC cf e s
+                                unEC (fmap f cx) e s'
+
 returnExtFC :: a -> ExtFCode a
 returnExtFC a  = EC $ \_ s -> return (s, a)
 
hunk ./compiler/codeGen/CgExtCode.hs 85
 thenExtFC :: ExtFCode a -> (a -> ExtFCode b) -> ExtFCode b
-thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
+thenExtFC c k = EC $ \e s -> do (s', r) <- unEC c e s
+                                unEC (k r) e s'
+
+instance Functor ExtFCode where
+  fmap = mapExtFC
+
+instance Applicative ExtFCode where
+  pure  = returnExtFC
+  (<*>) = apExtFC
 
 instance Monad ExtFCode where
   (>>=) = thenExtFC
hunk ./compiler/codeGen/CgExtCode.hs 97
-  return = returnExtFC
+  return = pure
 
 
 -- | Takes the variable decarations and imports from the monad
hunk ./compiler/codeGen/CgMonad.lhs 79
 import UniqSupply
 import Outputable
 
+import Control.Applicative ( Applicative(..) )
 import Control.Monad
 import Data.List
 
hunk ./compiler/codeGen/CgMonad.lhs 372
 %************************************************************************
 
 \begin{code}
-newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
+newtype FCode a = FCode {unFC :: CgInfoDownwards -> CgState -> (a, CgState)}
 type Code       = FCode ()
 
hunk ./compiler/codeGen/CgMonad.lhs 375
+instance Functor FCode where
+        fmap   = mapFC
+
+instance Applicative FCode where
+        pure   = returnFC
+        (<*>)  = apFC
+
 instance Monad FCode where
hunk ./compiler/codeGen/CgMonad.lhs 383
-       (>>=) = thenFC
-       return = returnFC
+       (>>=)  = thenFC
+       return = pure
 
hunk ./compiler/codeGen/CgMonad.lhs 386
+{-# INLINE mapFC #-}
+{-# INLINE apFC #-}
 {-# INLINE thenC #-}
 {-# INLINE thenFC #-}
 {-# INLINE returnFC #-}
hunk ./compiler/codeGen/CgMonad.lhs 403
              (res, _) -> return res
        }
 
+mapFC :: (a -> b) -> FCode a -> FCode b
+mapFC f fcx =
+    FCode (\info_down state ->
+               let (result, new_state) = unFC fcx info_down state
+               in (f result, new_state))
+
+apFC :: FCode (a -> b) -> FCode a -> FCode b
+apFC fcf fcx =
+    FCode (\info_down state ->
+               let (f, new_state) = unFC fcf info_down state
+               in unFC (fmap f fcx) info_down new_state)
+
 returnFC :: a -> FCode a
 returnFC val = FCode (\_ state -> (val, state))
 \end{code}
hunk ./compiler/codeGen/StgCmmMonad.hs 70
 import FastString(sLit)
 import Outputable
 
+import Control.Applicative ( Applicative(..) )
 import Control.Monad
 import Data.List
 import Prelude hiding( sequence )
hunk ./compiler/codeGen/StgCmmMonad.hs 84
 --     The FCode monad and its types
 --------------------------------------------------------
 
-newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
+newtype FCode a = FCode {runFCode :: CgInfoDownwards -> CgState -> (a, CgState)}
+
+instance Functor FCode where
+        fmap   = mapFC
+
+instance Applicative FCode where
+        pure   = returnFC
+        (<*>)  = apFC
 
 instance Monad FCode where
hunk ./compiler/codeGen/StgCmmMonad.hs 94
-       (>>=) = thenFC
-       return = returnFC
+       (>>=)  = thenFC
+       return = pure
 
 {-# INLINE thenC #-}
hunk ./compiler/codeGen/StgCmmMonad.hs 98
+{-# INLINE mapFC #-}
+{-# INLINE apFC #-}
 {-# INLINE thenFC #-}
 {-# INLINE returnFC #-}
 
hunk ./compiler/codeGen/StgCmmMonad.hs 110
              (res, _) -> return res
        }
 
+mapFC :: (a -> b) -> FCode a -> FCode b
+mapFC f c = FCode $ \info_down state ->
+            let (val, new_state) = runFCode c info_down state
+            in (f val, new_state)
+
+apFC :: FCode (a -> b) -> FCode a -> FCode b
+apFC cf cx = FCode $ \info_down state ->
+             let (f, new_state) = runFCode cf info_down state
+             in runFCode (fmap f cx) info_down new_state
+
 returnFC :: a -> FCode a
hunk ./compiler/codeGen/StgCmmMonad.hs 121
-returnFC val = FCode (\_info_down state -> (val, state))
+returnFC val = FCode $ \_info_down state -> (val, state)
 
 thenC :: FCode () -> FCode a -> FCode a
 thenC (FCode m) (FCode k) = 
hunk ./compiler/codeGen/StgCmmMonad.hs 145
 mapCs = mapM_
 
 thenFC :: FCode a -> (a -> FCode c) -> FCode c
-thenFC (FCode m) k = FCode (
-       \info_down state ->
-               let 
-                       (m_result, new_state) = m info_down state
-                       (FCode kcode) = k m_result
-               in 
-                       kcode info_down new_state
-       )
+thenFC c k = FCode $ \info_down state ->
+             let (val, new_state) = runFCode c info_down state
+             in runFCode (k val) info_down new_state
 
 listFCs :: [FCode a] -> FCode [a]
 listFCs = Prelude.sequence
hunk ./compiler/coreSyn/CoreLint.lhs 42
 import Outputable
 import FastString
 import Util
+import Control.Applicative (Applicative(..))
 import Control.Monad
 import Data.Maybe
 \end{code}
hunk ./compiler/coreSyn/CoreLint.lhs 855
 Here we substitute 'ty' for 'a' in 'body', on the fly.
 -}
 
+instance Functor LintM where
+  fmap f m = LintM $ \ loc subst errs ->
+                       let (res, errs') = unLintM m loc subst errs
+                       in (fmap f res, errs')
+
+instance Applicative LintM where
+  pure x    = LintM $ \ _ _ errs -> (Just x, errs)
+  mf <*> mx = LintM $ \ loc subst errs ->
+                        let (res, errs') = unLintM mf loc subst errs
+                        in case res of
+                             Just f -> unLintM (fmap f mx) loc subst errs'
+                             Nothing -> (Nothing, errs')
+
 instance Monad LintM where
hunk ./compiler/coreSyn/CoreLint.lhs 869
-  return x = LintM (\ _   _     errs -> (Just x, errs))
+  return   = pure
   fail err = failWithL (text err)
   m >>= k  = LintM (\ loc subst errs -> 
                        let (res, errs') = unLintM m loc subst errs in
hunk ./compiler/coreSyn/MkExternalCore.lhs 31
 import DynFlags
 import FastString
 
+import Control.Applicative (Applicative(..))
 import Data.Char
 import System.IO
 
hunk ./compiler/coreSyn/MkExternalCore.lhs 48
  | otherwise
  = return ()
 
--- Reinventing the Reader monad; whee.
-newtype CoreM a = CoreM (CoreState -> (CoreState, a))
+-- Reinventing the State monad; whee.
+newtype CoreM a = CoreM {unCore :: CoreState -> (CoreState, a)}
 type CoreState = Module
hunk ./compiler/coreSyn/MkExternalCore.lhs 51
+
+instance Functor CoreM where
+  fmap f m  = CoreM $ \s -> case unCore m s of
+                              (s', x) -> (s', f x)
+
+instance Applicative CoreM where
+  pure x    = CoreM $ \s -> (s, x)
+  mf <*> mx = CoreM $ \s -> case unCore mf s of
+                              (s', f) -> unCore (fmap f mx) s'
+
 instance Monad CoreM where
hunk ./compiler/coreSyn/MkExternalCore.lhs 62
-  (CoreM m) >>= f = CoreM (\ s -> case m s of
-                                    (s',r) -> case f r of
-                                                CoreM f' -> f' s')
-  return x = CoreM (\ s -> (s, x))
+  m >>= f   = CoreM $ \s -> case unCore m s of
+                              (s', r) -> unCore (f r) s'
+  return = pure
 runCoreM :: CoreM a -> CoreState -> a
 runCoreM (CoreM f) s = snd $ f s
 ask :: CoreM CoreState
hunk ./compiler/deSugar/Coverage.lhs 39
 import Data.HashTable   ( hashString )
 import Data.Map (Map)
 import qualified Data.Map as Map
+import Control.Applicative ( Applicative(..) )
 \end{code}
 
 
hunk ./compiler/deSugar/Coverage.lhs 607
         -- a combination of a state monad (TickTransState) and a writer
         -- monad (FreeVars).
 
+instance Functor TM where
+  fmap f tm = TM $ \env st -> case unTM tm env st of
+                               (r, fv, st1) -> (f r, fv, st1)
+
+instance Applicative TM where
+  pure a      = TM $ \ _  st -> (a, noFVs, st)
+  tmf <*> tmx = TM $ \env st -> case unTM tmf env st of
+                                 (f, fv1, st1) ->
+                                      case unTM tmx env st1 of
+                                        (r, fv2, st2) -> (f r, fv1 `plusOccEnv` fv2, st2)
+
 instance Monad TM where
hunk ./compiler/deSugar/Coverage.lhs 619
-  return a = TM $ \ _env st -> (a,noFVs,st)
-  (TM m) >>= k = TM $ \ env st -> 
-                               case m env st of
-                                 (r1,fv1,st1) -> 
-                                     case unTM (k r1) env st1 of
-                                       (r2,fv2,st2) -> 
-                                          (r2, fv1 `plusOccEnv` fv2, st2)
+  return  = pure
+  m >>= k = TM $ \env st -> case unTM m env st of
+                             (r1, fv1, st1) ->
+                                  case unTM (k r1) env st1 of
+                                    (r2, fv2, st2) ->
+                                        (r2, fv1 `plusOccEnv` fv2, st2)
 
 -- getState :: TM TickTransState
 -- getState = TM $ \ env st -> (st, noFVs, st)
hunk ./compiler/ghci/ByteCodeGen.lhs 67
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified FiniteMap as Map
+import Control.Applicative ( Applicative(..) )
 
 -- -----------------------------------------------------------------------------
 -- Generating byte code for a complete module 
hunk ./compiler/ghci/ByteCodeGen.lhs 1506
         breakArray :: BreakArray        -- array of breakpoint flags 
         }
 
-newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
+newtype BcM r = BcM {unBc :: BcM_State -> IO (BcM_State, r)}
 
 ioToBc :: IO a -> BcM a
 ioToBc io = BcM $ \st -> do 
hunk ./compiler/ghci/ByteCodeGen.lhs 1519
    where
    breakArray = modBreaks_flags modBreaks
 
+mapBc :: (a -> b) -> BcM a -> BcM b
+mapBc f bc = BcM $ \st -> fmap (\(st1, x) -> (st1, f x)) $ unBc bc st
+
+apBc :: BcM (a -> b) -> BcM a -> BcM b
+apBc bcf bcx = BcM $ \st -> do (st1, f) <- unBc bcf st
+                               unBc (fmap f bcx) st1
+
 thenBc :: BcM a -> (a -> BcM b) -> BcM b
hunk ./compiler/ghci/ByteCodeGen.lhs 1527
-thenBc (BcM expr) cont = BcM $ \st0 -> do
-  (st1, q) <- expr st0
+thenBc bc cont = BcM $ \st0 -> do
+  (st1, q) <- unBc bc st0
   let BcM k = cont q 
   (st2, r) <- k st1
   return (st2, r)
hunk ./compiler/ghci/ByteCodeGen.lhs 1534
 
 thenBc_ :: BcM a -> BcM b -> BcM b
-thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
-  (st1, _) <- expr st0
-  (st2, r) <- cont st1
+thenBc_ bc1 bc2 = BcM $ \st0 -> do
+  (st1, _) <- unBc bc1 st0
+  (st2, r) <- unBc bc2 st1
   return (st2, r)
 
 returnBc :: a -> BcM a
hunk ./compiler/ghci/ByteCodeGen.lhs 1542
 returnBc result = BcM $ \st -> (return (st, result))
 
+instance Functor BcM where
+  fmap   = mapBc
+
+instance Applicative BcM where
+  pure   = returnBc
+  (<*>)  = apBc
+  (*>)   = thenBc_
+
 instance Monad BcM where
hunk ./compiler/ghci/ByteCodeGen.lhs 1551
-  (>>=) = thenBc
-  (>>)  = thenBc_
-  return = returnBc
+  (>>=)  = thenBc
+  (>>)   = (*>)
+  return = pure
 
 emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
 emitBc bco
hunk ./compiler/ghci/ByteCodeItbls.lhs 33
 import Util
 import Outputable
 
+import Control.Applicative ( Applicative(..) )
 import Foreign
 import Foreign.C
 import Foreign.C.String
hunk ./compiler/ghci/ByteCodeItbls.lhs 400
 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
 fieldSz sel x = sizeOf (sel x)
 
-newtype State s m a = State (s -> m (s, a))
+newtype State s m a = State {unState :: s -> m (s, a)}
+
+instance Functor m => Functor (State s m) where
+  fmap f m = State $ fmap (\(s', x) -> (s', f x)) . unState m
+
+instance (Functor m, Applicative m, Monad m) => Applicative (State s m) where
+  pure a    = State $ \s -> pure (s, a)
+  mf <*> mx = State $ \s -> unState mf s >>= \(s', f) -> unState (fmap f mx) s'
 
 instance Monad m => Monad (State s m) where
   return a      = State (\s -> return (s, a))
hunk ./compiler/hsSyn/Convert.lhs 35
 import FastString
 import Outputable
 
+import Control.Applicative ( Applicative (..) )
 import Control.Monad( unless )
 
 import Language.Haskell.TH as TH hiding (sigP)
hunk ./compiler/hsSyn/Convert.lhs 81
 -- In particular, we want it on binding locations, so that variables bound in
 -- the spliced-in declarations get a location that at least relates to the splice point
 
+instance Functor CvtM where
+  fmap f m  = CvtM $ fmap f . unCvtM m
+
+instance Applicative CvtM where
+  pure x    = CvtM $ \_   -> pure x
+  mf <*> mx = CvtM $ \loc -> case unCvtM mf loc of
+                               Left err -> Left err
+                               Right f  -> unCvtM (fmap f mx) loc
+
 instance Monad CvtM where
hunk ./compiler/hsSyn/Convert.lhs 91
-  return x       = CvtM $ \_   -> Right x
-  (CvtM m) >>= k = CvtM $ \loc -> case m loc of
-                                   Left err -> Left err
-                                   Right v  -> unCvtM (k v) loc
+  return    = pure
+  m >>= k   = CvtM $ \loc -> case unCvtM m loc of
+                              Left err -> Left err
+                              Right v  -> unCvtM (k v) loc
 
 initCvt :: SrcSpan -> CvtM a -> Either Message a
 initCvt loc (CvtM m) = m loc
hunk ./compiler/main/CmdLineParser.hs 30
 import SrcLoc
 
 import Data.List
+import Control.Applicative (Applicative(..))
+import Control.Monad (ap)
 
 --------------------------------------------------------
 --        The Flag and OptKind types
hunk ./compiler/main/CmdLineParser.hs 72
                               -> Errs -> Warns
                               -> m (Errs, Warns, a) }
 
+instance Functor m => Functor (EwM m) where
+  fmap f m = EwM $ \l e w -> fmap (\(e', w', x) -> (e', w', f x)) $ unEwM m l e w
+
+instance (Applicative m, Monad m) => Applicative (EwM m) where
+  pure v     = EwM $ \_ e w -> pure (e, w, v)
+  mf <*> mx  = EwM $ \l e w -> do (e', w', f) <- unEwM mf l e w
+                                  unEwM (fmap f mx) l e' w'
+
 instance Monad m => Monad (EwM m) where
hunk ./compiler/main/CmdLineParser.hs 81
-  (EwM f) >>= k = EwM (\l e w -> do { (e', w', r) <- f l e w 
-                                    ; unEwM (k r) l e' w' })
+  m >>= k = EwM $ \l e w -> do (e', w', r) <- unEwM m l e w
+                               unEwM (k r) l e' w'
   return v = EwM (\_ e w -> return (e, w, v))
 
 setArg :: Located String -> EwM m a -> EwM m a
hunk ./compiler/main/CmdLineParser.hs 113
 
 newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
 
+instance Functor (CmdLineP s) where
+    fmap f m = CmdLineP $ \s -> let
+                (x, s') = runCmdLine m s
+                in (f x, s')
+
+instance Applicative (CmdLineP s) where
+    pure a = CmdLineP $ \s -> (a, s)
+    mf <*> mx  = CmdLineP $ \s -> let (f, s') = runCmdLine mf s
+                                  in runCmdLine (fmap f mx) s'
+
 instance Monad (CmdLineP s) where
hunk ./compiler/main/CmdLineParser.hs 124
-        return a = CmdLineP $ \s -> (a, s)
+        return   = pure
         m >>= k  = CmdLineP $ \s -> let
                 (a, s') = runCmdLine m s
                 in runCmdLine (k a) s'
hunk ./compiler/main/GhcMonad.hs 31
 import ErrUtils
 
 import Data.IORef
+import Control.Applicative ( Applicative(..) )
 
 -- -----------------------------------------------------------------------------
 -- | A monad that has all the features needed by GHC API calls.
hunk ./compiler/main/GhcMonad.hs 101
 instance Functor Ghc where
   fmap f m = Ghc $ \s -> f `fmap` unGhc m s
 
+instance Applicative Ghc where
+  pure a    = Ghc $ \_ -> return a
+  mf <*> mx = Ghc $ \s -> unGhc mf s <*> unGhc mx s
+
 instance Monad Ghc where
hunk ./compiler/main/GhcMonad.hs 106
-  return a = Ghc $ \_ -> return a
+  return   = pure
   m >>= g  = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s
 
 instance MonadIO Ghc where
hunk ./compiler/main/GhcMonad.hs 161
 instance Functor m => Functor (GhcT m) where
   fmap f m = GhcT $ \s -> f `fmap` unGhcT m s
 
-instance Monad m => Monad (GhcT m) where
+instance Applicative m => Applicative (GhcT m) where
+  pure x    = GhcT $ \_ -> pure x
+  mf <*> mx = GhcT $ \s -> unGhcT mf s <*> unGhcT mx s
+
+instance (Monad m) => Monad (GhcT m) where
   return x = GhcT $ \_ -> return x
   m >>= k  = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s
 
hunk ./compiler/main/HscMain.lhs 149
 import Exception
 -- import MonadUtils
 
+import Control.Applicative ( Applicative(..) )
 import Control.Monad
 -- import System.IO
 import Data.IORef
hunk ./compiler/main/HscMain.lhs 196
 -- -----------------------------------------------------------------------------
 -- The Hsc monad: collecting warnings
 
-newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
+newtype Hsc a = Hsc {unHsc :: HscEnv -> WarningMessages -> IO (a, WarningMessages)}
+
+instance Functor Hsc where
+  fmap f m  = Hsc $ \e w -> fmap (\(x, w1) -> (f x, w1)) $ unHsc m e w
+
+instance Applicative Hsc where
+  pure a    = Hsc $ \_ w -> pure (a, w)
+  mf <*> mx = Hsc $ \e w -> do (f, w1) <- unHsc mf e w
+                               unHsc (fmap f mx) e w1
 
 instance Monad Hsc where
hunk ./compiler/main/HscMain.lhs 207
-  return a = Hsc $ \_ w -> return (a, w)
-  Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w
-                                 case k a of
-                                    Hsc k' -> k' e w1
+  return    = pure
+  m >>= k   = Hsc $ \e w -> do (a, w1) <- unHsc m e w
+                               unHsc (k a) e w1
 
 instance MonadIO Hsc where
   liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)
hunk ./compiler/main/TidyPgm.lhs 49
 import Util
 import FastString
 
+import Control.Applicative ( Applicative(..) )
 import Data.List       ( sortBy )
 import Data.IORef      ( IORef, readIORef, writeIORef )
 \end{code}
hunk ./compiler/main/TidyPgm.lhs 755
 run (DFFV m) = case m emptyVarSet [] of
                  (set,ids,_) -> (set,ids)
 
-newtype DFFV a = DFFV (VarSet -> [Var] -> (VarSet,[Var],a))
+newtype DFFV a = DFFV {unDFFV :: VarSet -> [Var] -> (VarSet,[Var],a)}
+
+instance Functor DFFV where
+  fmap f m  = DFFV $ \set ids ->
+                      case unDFFV m set ids of
+                        (set', ids', x) -> (set', ids', f x)
+
+instance Applicative DFFV where
+  pure a    = DFFV $ \set ids -> (set, ids, a)
+  mf <*> mx = DFFV $ \set ids ->
+                      case unDFFV mf set ids of
+                        (set', ids', f) -> unDFFV (fmap f mx) set' ids'
 
 instance Monad DFFV where
hunk ./compiler/main/TidyPgm.lhs 769
-  return a = DFFV $ \set ids -> (set, ids, a)
-  (DFFV m) >>= k = DFFV $ \set ids ->
-    case m set ids of
-       (set',ids',a) -> case k a of
-                          DFFV f -> f set' ids' 
+  return    = pure
+  m >>= k   = DFFV $ \set ids ->
+                      case unDFFV m set ids of
+                        (set',ids',a) -> unDFFV (k a) set' ids'
 
 insert :: Var -> DFFV ()
 insert v = DFFV $ \ set ids  -> case () of 
hunk ./compiler/nativeGen/AsmCodeGen.lhs 96
 
 import Data.List
 import Data.Maybe
+import Control.Applicative (Applicative(..))
 import Control.Monad
 import System.IO
 
hunk ./compiler/nativeGen/AsmCodeGen.lhs 740
   blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
   return $ CmmProc info lbl params (ListGraph blocks')
 
-newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
+newtype CmmOptM a = CmmOptM {runCmmOptM :: ([CLabel], DynFlags) -> (# a, [CLabel] #)}
+
+instance Functor CmmOptM where
+  fmap f m  = CmmOptM $ \(imports, dflags) ->
+                case runCmmOptM m (imports, dflags) of
+                  (# x, imports' #) -> (# f x, imports' #)
+
+instance Applicative CmmOptM where
+  pure x    = CmmOptM $ \(imports, _) -> (# x, imports #)
+  mf <*> mx = CmmOptM $ \(imports, dflags) ->
+                case runCmmOptM mf (imports, dflags) of
+                  (# f, imports' #) -> runCmmOptM (fmap f mx) (imports', dflags)
 
 instance Monad CmmOptM where
hunk ./compiler/nativeGen/AsmCodeGen.lhs 754
-  return x = CmmOptM $ \(imports, _) -> (# x,imports #)
-  (CmmOptM f) >>= g =
-    CmmOptM $ \(imports, dflags) ->
-                case f (imports, dflags) of
-                  (# x, imports' #) ->
-                    case g x of
-                      CmmOptM g' -> g' (imports', dflags)
+  return    = pure
+  m >>= k   = CmmOptM $ \(imports, dflags) ->
+                case runCmmOptM m (imports, dflags) of
+                  (# x, imports' #) -> runCmmOptM (k x) (imports', dflags)
 
 addImportCmmOpt :: CLabel -> CmmOptM ()
 addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #)
hunk ./compiler/nativeGen/NCGMonad.hs 32
   
 #include "HsVersions.h"
 
+import Control.Applicative (Applicative(..))
+
 import Reg
 import Size
 import TargetReg
hunk ./compiler/nativeGen/NCGMonad.hs 66
 initNat init_st m 
        = case unNat m init_st of { (r,st) -> (r,st) }
 
+instance Functor NatM where
+  fmap   = mapNat
+
+instance Applicative NatM where
+  pure   = returnNat
+  (<*>)  = apNat
 
 instance Monad NatM where
hunk ./compiler/nativeGen/NCGMonad.hs 74
-  (>>=) = thenNat
-  return = returnNat
+  (>>=)  = thenNat
+  return = pure
+
+mapNat :: (a -> b) -> NatM a -> NatM b
+mapNat f expr
+    = NatM $ \st -> case unNat expr st of
+                      (x, st') -> (f x, st')
 
hunk ./compiler/nativeGen/NCGMonad.hs 82
+apNat :: NatM (a -> b) -> NatM a -> NatM b
+apNat nf nx
+    = NatM $ \st -> case unNat nf st of
+                      (f, st') -> unNat (fmap f nx) st'
 
 thenNat :: NatM a -> (a -> NatM b) -> NatM b
 thenNat expr cont
hunk ./compiler/nativeGen/NCGMonad.hs 89
-       = NatM $ \st -> case unNat expr st of
-                       (result, st') -> unNat (cont result) st'
+    = NatM $ \st -> case unNat expr st of
+                     (result, st') -> unNat (cont result) st'
 
 returnNat :: a -> NatM a
 returnNat result 
hunk ./compiler/nativeGen/NCGMonad.hs 94
-       = NatM $ \st ->  (result, st)
+    = NatM $ \st ->  (result, st)
 
 mapAccumLNat :: (acc -> x -> NatM (acc, y))
                 -> acc
hunk ./compiler/nativeGen/RegAlloc/Linear/State.hs 32
 )
 where
 
+import Control.Applicative (Applicative(..))
+
 import RegAlloc.Linear.Stats
 import RegAlloc.Linear.StackMap
 import RegAlloc.Linear.Base
hunk ./compiler/nativeGen/RegAlloc/Linear/State.hs 45
 import Unique
 import UniqSupply
 
+instance Functor RegM where
+  fmap f m = RegM $ \s -> case unReg m s of
+                            (# s', x #) -> (# s', f x #)
+
+instance Applicative RegM where
+  pure a   = RegM $ \s -> (# s, a #)
+  m <*> n  = RegM $ \s -> case unReg m s of
+                            (# s', f #) -> unReg (fmap f n) s'
 
 -- | The RegM Monad
 instance Monad RegM where
hunk ./compiler/nativeGen/RegAlloc/Linear/State.hs 56
-  m >>= k   =  RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
-  return a  =  RegM $ \s -> (# s, a #)
+  m >>= k  = RegM $ \s -> case unReg m s of
+                            (# s', a #) -> unReg (k a) s'
+  return   = pure
 
 
 -- | Run a computation in the RegM register allocator monad.
hunk ./compiler/parser/Lexer.x 73
 import BasicTypes      ( InlineSpec(..), RuleMatchInfo(..) )
 import Util            ( readRational )
 
+import Control.Applicative (Applicative(..))
 import Control.Monad
 import Data.Bits
 import Data.Char
hunk ./compiler/parser/Lexer.x 1544
 
 newtype P a = P { unP :: PState -> ParseResult a }
 
+instance Functor ParseResult where
+  fmap f (POk s x)          = POk s (f x)
+  fmap _ (PFailed span err) = PFailed span err
+
+instance Functor P where
+  fmap   = mapP
+
+instance Applicative P where
+  pure   = returnP
+  (<*>)  = apP
+
 instance Monad P where
hunk ./compiler/parser/Lexer.x 1556
-  return = returnP
-  (>>=) = thenP
-  fail = failP
+  return = pure
+  (>>=)  = thenP
+  fail   = failP
+
+mapP :: (a -> b) -> P a -> P b
+mapP f p = P $ fmap f . unP p
+
+apP :: P (a -> b) -> P a -> P b
+apP pf px = P $ \s -> case unP pf s of
+                        POk s1 f -> unP (fmap f px) s1
+                        PFailed span err -> PFailed span err
 
 returnP :: a -> P a
 returnP a = a `seq` (P $ \s -> POk s a)
hunk ./compiler/profiling/SCCfinal.lhs 43
 import ListSetOps       ( removeDups )
 import Outputable
 import DynFlags
+
+import Control.Applicative ( Applicative(..) )
 \end{code}
 
 \begin{code}
hunk ./compiler/profiling/SCCfinal.lhs 325
                  -> (CollectedCCs, result)
     }
 
+instance Functor MassageM where
+    fmap   = mapMM
+
+instance Applicative MassageM where
+    pure   = pureMM
+    (<*>)  = apMM
+    (*>)   = thenMM_
+
 instance Monad MassageM where
hunk ./compiler/profiling/SCCfinal.lhs 334
-    return x = MassageM (\_ _ _ _ ccs -> (ccs, x))
-    (>>=) = thenMM
-    (>>)  = thenMM_
+    return = pure
+    (>>=)  = thenMM
+    (>>)   = (*>)
 
 -- the initMM function also returns the final CollectedCCs
 
hunk ./compiler/profiling/SCCfinal.lhs 347
 
 initMM mod_name init_us (MassageM m) = m mod_name noCCS init_us emptyVarSet ([],[],[])
 
+mapMM :: (a -> b) -> MassageM a -> MassageM b
+mapMM f m = MassageM $ \mod scope_cc us ids ccs ->
+            case unMassageM m mod scope_cc us ids ccs of
+              (ccs2, result) -> (ccs2, f result)
+
+apMM :: MassageM (a -> b) -> MassageM a -> MassageM b
+apMM mf mx = MassageM $ \mod scope_cc us ids ccs ->
+             case splitUniqSupply us of
+               (s1, s2) ->
+                   case unMassageM mf mod scope_cc s1 ids ccs of
+                     (ccs2, f) -> unMassageM (fmap f mx) mod scope_cc s2 ids ccs2
+
+pureMM :: a -> MassageM a
+pureMM x = MassageM $ \_ _ _ _ ccs -> (ccs, x)
+
 thenMM  :: MassageM a -> (a -> MassageM b) -> MassageM b
 thenMM_ :: MassageM a -> (MassageM b) -> MassageM b
 
hunk ./compiler/rename/RnPat.lhs 55
 import SrcLoc
 import FastString
 import Literal         ( inCharRange )
+import Control.Applicative ( Applicative(.. ) )
 import Control.Monad   ( when )
 \end{code}
 
hunk ./compiler/rename/RnPat.lhs 92
                                             -> RnM (r, FreeVars) }
        -- See Note [CpsRn monad]
 
+instance Functor CpsRn where
+  fmap f m  = CpsRn $ \k -> unCpsRn m $ k . f
+
+instance Applicative CpsRn where
+  pure x    = CpsRn $ \k -> k x
+  mf <*> mx = CpsRn $ \k -> unCpsRn mf $ \f -> unCpsRn (fmap f mx) k
+
 instance Monad CpsRn where
hunk ./compiler/rename/RnPat.lhs 100
-  return x = CpsRn (\k -> k x)
-  (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))
+  return    = pure
+  m >>= c   = CpsRn $ \k -> unCpsRn m $ \v -> unCpsRn (c v) k
 
 runCps :: CpsRn a -> RnM (a, FreeVars)
 runCps (CpsRn m) = m (\r -> return (r, emptyFVs))
hunk ./compiler/simplCore/SimplMonad.lhs 30
 import DynFlags                ( DynFlags )
 import CoreMonad
 import FastString
+
+import Control.Applicative ( Applicative(..) )
 \end{code}
 
 %************************************************************************
hunk ./compiler/simplCore/SimplMonad.lhs 68
   where
     env = STE { st_flags = dflags, st_rules = rules, st_fams = fam_envs }
 
+{-# INLINE mapSmpl #-}
+{-# INLINE apSmpl #-}
+{-# INLINE returnSmpl #-}
 {-# INLINE thenSmpl #-}
 {-# INLINE thenSmpl_ #-}
hunk ./compiler/simplCore/SimplMonad.lhs 73
-{-# INLINE returnSmpl #-}
+
+instance Functor SimplM where
+   fmap   = mapSmpl
+
+instance Applicative SimplM where
+   pure   = returnSmpl
+   (<*>)  = apSmpl
+   (*>)   = thenSmpl_
 
 instance Monad SimplM where
hunk ./compiler/simplCore/SimplMonad.lhs 83
-   (>>)   = thenSmpl_
    (>>=)  = thenSmpl
hunk ./compiler/simplCore/SimplMonad.lhs 84
-   return = returnSmpl
+   (>>)   = (*>)
+   return = pure
+
+mapSmpl :: (a -> b) -> SimplM a -> SimplM b
+mapSmpl f s = SM $ \st_env us0 sc0 ->
+                case unSM s st_env us0 sc0 of
+                  (x, us1, sc1) -> (f x, us1, sc1)
+
+apSmpl :: SimplM (a -> b) -> SimplM a -> SimplM b
+apSmpl sf sx = SM $ \st_env us0 sc0 ->
+                 case unSM sf st_env us0 sc0 of
+                   (f, us1, sc1) -> unSM (fmap f sx) st_env us1 sc1
 
 returnSmpl :: a -> SimplM a
hunk ./compiler/simplCore/SimplMonad.lhs 98
-returnSmpl e = SM (\_st_env us sc -> (e, us, sc))
+returnSmpl e = SM $ \_st_env us sc -> (e, us, sc)
 
 thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
hunk ./compiler/simplCore/SimplMonad.lhs 101
-thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
+thenSmpl m k = SM $ \st_env us0 sc0 ->
+                case (unSM m st_env us0 sc0) of
+                  (m_result, us1, sc1) -> unSM (k m_result) st_env us1 sc1
 
hunk ./compiler/simplCore/SimplMonad.lhs 105
-thenSmpl m k 
-  = SM (\ st_env us0 sc0 ->
-         case (unSM m st_env us0 sc0) of 
-               (m_result, us1, sc1) -> unSM (k m_result) st_env us1 sc1 )
-
-thenSmpl_ m k 
-  = SM (\st_env us0 sc0 ->
-        case (unSM m st_env us0 sc0) of 
-               (_, us1, sc1) -> unSM k st_env us1 sc1)
+thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
+thenSmpl_ m k = SM $ \st_env us0 sc0 ->
+                 case (unSM m st_env us0 sc0) of
+                   (_, us1, sc1) -> unSM k st_env us1 sc1
 
 -- TODO: this specializing is not allowed
 -- {-# SPECIALIZE mapM         :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
hunk ./compiler/stgSyn/CoreToStg.lhs 39
 import Util
 import ForeignCall
 import PrimOp           ( PrimCall(..) )
+
+import Control.Applicative ( Applicative(..) )
 \end{code}
 
 %************************************************************************
hunk ./compiler/stgSyn/CoreToStg.lhs 923
 
 
 
+{-# INLINE mapLne #-}
+{-# INLINE apLne #-}
 {-# INLINE thenLne #-}
 {-# INLINE returnLne #-}
 
hunk ./compiler/stgSyn/CoreToStg.lhs 928
+mapLne :: (a -> b) -> LneM a -> LneM b
+mapLne f l = LneM $ \env lvs_cont -> f $ unLneM l env lvs_cont
+
+apLne :: LneM (a -> b) -> LneM a -> LneM b
+apLne lf lx = LneM $ \env lvs_cont -> unLneM lf env lvs_cont $
+                                        unLneM lx env lvs_cont
+
 returnLne :: a -> LneM a
 returnLne e = LneM $ \_ _ -> e
 
hunk ./compiler/stgSyn/CoreToStg.lhs 942
 thenLne m k = LneM $ \env lvs_cont
   -> unLneM (k (unLneM m env lvs_cont)) env lvs_cont
 
+instance Functor LneM where
+    fmap   = mapLne
+
+instance Applicative LneM where
+    pure   = returnLne
+    (<*>)  = apLne
+
 instance Monad LneM where
hunk ./compiler/stgSyn/CoreToStg.lhs 950
-    return = returnLne
+    return = pure
     (>>=)  = thenLne
 
 instance MonadFix LneM where
hunk ./compiler/stgSyn/StgLint.lhs 30
 import SrcLoc
 import Outputable
 import FastString
+import Control.Applicative ( Applicative(..) )
 import Control.Monad
 \end{code}
 
hunk ./compiler/stgSyn/StgLint.lhs 323
         Just (vcat (punctuate blankLine (bagToList errs)))
     }
 
+instance Functor LintM where
+    fmap = mapL
+
+instance Applicative LintM where
+    pure a = LintM $ \_loc _scope errs -> (a, errs)
+    (<*>)  = apL
+    (*>)   = thenL_
+
 instance Monad LintM where
hunk ./compiler/stgSyn/StgLint.lhs 332
-    return a = LintM $ \_loc _scope errs -> (a, errs)
-    (>>=) = thenL
-    (>>)  = thenL_
+    return = pure
+    (>>=)  = thenL
+    (>>)   = (*>)
+
+mapL :: (a -> b) -> LintM a -> LintM b
+mapL f l = LintM $ \loc scope errs
+  -> case unLintM l loc scope errs of
+      (x, errs') -> (f x, errs')
+
+apL :: LintM (a -> b) -> LintM a -> LintM b
+apL lf lx = LintM $ \loc scope errs
+  -> case unLintM lf loc scope errs of
+      (f, errs') -> unLintM (fmap f lx) loc scope errs'
 
 thenL :: LintM a -> (a -> LintM b) -> LintM b
 thenL m k = LintM $ \loc scope errs
hunk ./compiler/typecheck/TcSMonad.lhs 117
 
 import TcRnTypes
 
+import Control.Applicative (Applicative(..))
 import Control.Monad
 import Data.IORef
 \end{code}
hunk ./compiler/typecheck/TcSMonad.lhs 491
 newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } 
 
 instance Functor TcS where
-  fmap f m = TcS $ fmap f . unTcS m
+  fmap f m  = TcS $ fmap f . unTcS m
+
+instance Applicative TcS where
+  pure x    = TcS $ \_ -> pure x
+  mf <*> mx = TcS $ \ebs -> unTcS mf ebs <*> unTcS mx ebs
 
 instance Monad TcS where 
hunk ./compiler/typecheck/TcSMonad.lhs 498
-  return x  = TcS (\_ -> return x) 
-  fail err  = TcS (\_ -> fail err) 
-  m >>= k   = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
+  return    = pure
+  fail err  = TcS $ \_ -> fail err
+  m >>= k   = TcS $ \ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs
 
 -- Basic functionality 
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
hunk ./compiler/types/Unify.lhs 22
 
 #include "HsVersions.h"
 
+import Control.Applicative(Applicative(..))
+
 import Var
 import VarEnv
 import VarSet
hunk ./compiler/types/Unify.lhs 602
 newtype UM a = UM { unUM :: (TyVar -> BindFlag)
                         -> MaybeErr Message a }
 
+instance Functor UM where
+  fmap f m  = UM $ fmap f . unUM m
+
+instance Applicative UM where
+  pure a    = UM $ \_   -> pure a
+  mf <*> mx = UM $ \tvs -> unUM mf tvs <*> unUM mx tvs
+
 instance Monad UM where
hunk ./compiler/types/Unify.lhs 610
-  return a = UM (\_tvs -> Succeeded a)
-  fail s   = UM (\_tvs -> Failed (text s))
-  m >>= k  = UM (\tvs -> case unUM m tvs of
-                          Failed err -> Failed err
-                          Succeeded v  -> unUM (k v) tvs)
+  return a  = UM $ \_   -> Succeeded a
+  fail s    = UM $ \_   -> Failed (text s)
+  m >>= k   = UM $ \tvs -> case unUM m tvs of
+                            Failed err  -> Failed err
+                             Succeeded v -> unUM (k v) tvs
 
 initUM :: (TyVar -> BindFlag) -> UM a -> MaybeErr Message a
 initUM badtvs um = unUM um badtvs
hunk ./compiler/utils/Maybes.lhs 25
     ) where
 
 import Data.Maybe
+import Control.Applicative (Applicative(..), liftA2)
 
 infixr 4 `orElse`
 \end{code}
hunk ./compiler/utils/Maybes.lhs 103
 instance Functor m => Functor (MaybeT m) where
   fmap f x = MaybeT $ fmap (fmap f) $ runMaybeT x
 
+instance (Applicative m) => Applicative (MaybeT m) where
+  pure = MaybeT . pure . Just
+  mf <*> mx = MaybeT $ liftA2 (<*>) (runMaybeT mf) (runMaybeT mx)
+
 instance Monad m => Monad (MaybeT m) where
   return = MaybeT . return . Just
   x >>= f = MaybeT $ runMaybeT x >>= maybe (return Nothing) (runMaybeT . f)
hunk ./compiler/utils/Maybes.lhs 124
 \begin{code}
 data MaybeErr err val = Succeeded val | Failed err
 
+instance Functor (MaybeErr err) where
+  fmap f (Succeeded v) = Succeeded (f v)
+  fmap _ (Failed e)    = Failed e
+
+instance Applicative (MaybeErr err) where
+  pure v = Succeeded v
+  Succeeded f <*> m = fmap f m
+  Failed e    <*> _ = Failed e
+
 instance Monad (MaybeErr err) where
   return v = Succeeded v
   Succeeded v >>= k = k v
hunk ./compiler/utils/MonadUtils.hs 55
 -------------------------------------------------------------------------------
 
 newtype ID a = ID a
+
+instance Functor ID where
+  fmap f (ID x) = ID (f x)
+
+instance Applicative ID where
+  pure x        = ID x
+  ID f <*> ID x = ID (f x)
+  _     *> y    = y
+
 instance Monad ID where
hunk ./compiler/utils/MonadUtils.hs 65
-  return x     = ID x
+  return       = pure
   (ID x) >>= f = f x
   _ >> y       = y
   fail s       = panic s
hunk ./compiler/vectorise/Vectorise/Monad/Base.hs 31
 import DsMonad
 import Outputable
        
+import Control.Applicative ( Applicative(..) )
 
 -- The Vectorisation Monad ----------------------------------------------------
 -- | Vectorisation can either succeed with new envionment and a value,
hunk ./compiler/vectorise/Vectorise/Monad/Base.hs 39
 data VResult a 
        = Yes GlobalEnv LocalEnv a | No
 
+instance Functor VResult where
+  fmap f (Yes genv lenv x) = Yes genv lenv (f x)
+  fmap _ No                = No
+
 newtype VM a 
        = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }
 
hunk ./compiler/vectorise/Vectorise/Monad/Base.hs 46
+instance Functor VM where
+  fmap f vm = VM $ \bi genv lenv -> fmap (fmap f) $ runVM vm bi genv lenv
+
+instance Applicative VM where
+  pure x = VM $ \_  genv lenv -> pure $ Yes genv lenv x
+  vmf <*> vmx = VM $ \bi genv lenv -> do
+                          r <- runVM vmf bi genv lenv
+                          case r of
+                            Yes genv' lenv' f -> runVM (fmap f vmx) bi genv' lenv'
+                            No                -> pure No
+
 instance Monad VM where
hunk ./compiler/vectorise/Vectorise/Monad/Base.hs 58
-  return x   = VM $ \_  genv lenv -> return (Yes genv lenv x)
+  return = pure
   VM p >>= f = VM $ \bi genv lenv -> do
                                       r <- p bi genv lenv
                                       case r of
hunk ./ghc/GhciMonad.hs 39
 import System.CPUTime
 import System.Environment
 import System.IO
+import Control.Applicative ( Applicative(..) )
 import Control.Monad as Monad
 import GHC.Exts
 
hunk ./ghc/GhciMonad.hs 148
 startGHCi :: GHCi a -> GHCiState -> Ghc a
 startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
 
-instance Monad GHCi where
-  (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
-  return a  = GHCi $ \_ -> return a
-
 instance Functor GHCi where
hunk ./ghc/GhciMonad.hs 149
-    fmap f m = m >>= return . f
+  fmap f m  = GHCi $ \s -> fmap f $ unGHCi m s
+
+instance Applicative GHCi where
+  pure a    = GHCi $ \_ -> pure a
+  mf <*> mx = GHCi $ \s -> unGHCi mf s <*> unGHCi mx s
+
+instance Monad GHCi where
+  m >>= k   = GHCi $ \s -> unGHCi m s >>= \a -> unGHCi (k a) s
+  return    = pure
 
 ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a
 ghciHandleGhcException = handleGhcException
hunk ./utils/ghc-pkg/Main.hs 35
 import Data.Maybe
 
 import Data.Char ( isSpace, toLower )
+import Control.Applicative ( Applicative(..) )
 import Control.Monad
 import System.Directory ( doesDirectoryExist, getDirectoryContents,
                           doesFileExist, renameFile, removeFile )
hunk ./utils/ghc-pkg/Main.hs 1167
 
 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
 
+instance Functor Validate where
+   fmap f v  = V $ fmap (\(x, es, ws) -> (f x, es, ws)) $ runValidate v
+
+instance Applicative Validate where
+   pure a    = V $ pure (a, [], [])
+   vf <*> vx = V $ do (f, es,  ws)  <- runValidate vf
+                      (x, es', ws') <- runValidate vx
+                      return (f x, es++es', ws++ws')
+
 instance Monad Validate where
hunk ./utils/ghc-pkg/Main.hs 1177
-   return a = V $ return (a, [], [])
-   m >>= k = V $ do
-      (a, es, ws) <- runValidate m
-      (b, es', ws') <- runValidate (k a)
-      return (b,es++es',ws++ws')
+   return    = pure
+   m >>= k   = V $ do (a, es, ws) <- runValidate m
+                      (b, es', ws') <- runValidate (k a)
+                      return (b,es++es',ws++ws')
 
 verror :: Force -> String -> Validate ()
 verror f s = V (return ((),[(f,s)],[]))
}
[Require happy >= 1.18.7
Bas van Dijk <v.dijk.bas@gmail.com>**20101211235020
 Ignore-this: 1114def3677767bda3c7692e86990498
 happy-1.18.7 generates needed Functor and Applicative instances for HappyIdentity
] hunk ./aclocal.m4 345
 ])
 if test ! -f compiler/parser/Parser.hs || test ! -f compiler/cmm/CmmParse.hs || test ! -f compiler/parser/ParserCore.hs
 then
-    FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.16],
-      [AC_MSG_ERROR([Happy version 1.16 or later is required to compile GHC.])])[]
+    FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.18.7],
+      [AC_MSG_ERROR([Happy version 1.18.7 or later is required to compile GHC.])])[]
 fi
 HappyVersion=$fptools_cv_happy_version;
 AC_SUBST(HappyVersion)

Context:

[Fix Trac #4534: renamer bug
simonpj@microsoft.com**20101210084530
 Ignore-this: 8163bfa3a56344cfe89ad17c62e9655d
   
 The renamer wasn't attaching the right used-variables to a
 TransformStmt constructor.
 
 The real modification is in RnExpr; the rest is just
 pretty-printing and white space.
] 
[White space only
simonpj@microsoft.com**20101210084255
 Ignore-this: 3fcf8a4fc8c15052c379a135951d53ea
] 
[Comments only
simonpj@microsoft.com**20101210084116
 Ignore-this: 55bb1de129b1c9513751885eaa84b884
] 
[Make the case-to-let transformation a little less eager
simonpj@microsoft.com**20101208172251
 Ignore-this: 55eaa1b5753af31aeb32ec792cb6b662
 
 See Note [Case elimination: lifted case].
 Thanks to Roman for identifying this case.
] 
[warning fix: don't redefine BLOCKS_PER_MBLOCK
Simon Marlow <marlowsd@gmail.com>**20101210094002
 Ignore-this: cadba57f1c38f5e2af1de37d0a79c7ee
] 
[Only reset the event log if logging is turned on (addendum to #4512)
Simon Marlow <marlowsd@gmail.com>**20101210093951
 Ignore-this: c9f85f0de2b11a37337672fba59aecc6
] 
[allocate enough room for the longer filename (addendum to #4512)
Simon Marlow <marlowsd@gmail.com>**20101210093906
 Ignore-this: 270dc0219d98f1e0f9e006102ade7087
] 
[Fix Windows build: move rtsTimerSignal to the POSIX-only section
Simon Marlow <marlowsd@gmail.com>**20101210090045
 Ignore-this: aa1844b70b9f1a44447787c4bbe10d44
] 
[Default the value of -dppr-cols when the static flags aren't initialised yet
Ben Lippmeier <benl@ouroborus.net>**20101210060154
 Ignore-this: 4cea29085ef904f379a8829714c9e180
 If GHC's command line options are bad then the options parser uses the
 pretty printer before the -dppr-cols flag has been read.
] 
[Defensify naked read in LLVM mangler
Ben Lippmeier <benl@ouroborus.net>**20101210045922
 Ignore-this: 1373f597863851bd03e7a7254558ed04
] 
[Formatting only
Ben Lippmeier <benl@ouroborus.net>**20101210042600
 Ignore-this: 20bbcd95c70b59094d0bb8a63e459103
] 
[Always ppr case alts on separate lines
Ben Lippmeier <benl@ouroborus.net>**20101208070508
 Ignore-this: 7e2edd57a61427621aeb254aef84f0f7
] 
[Add -dppr-colsN to set width of dumps
Ben Lippmeier <benl@ouroborus.net>**20101208070245
 Ignore-this: edc64fee6c373b895bb80b83b549ce1a
] 
[Add -dppr-case-as-let to print "strict lets" as actual lets
Ben Lippmeier <benl@ouroborus.net>**20101208065548
 Ignore-this: eb1d122dbd73b5263cae3a9f8259a838
] 
[Suppress more info with -dsuppress-idinfo
Ben Lippmeier <benl@ouroborus.net>**20101208063037
 Ignore-this: 5e8213d7b8d2905e245917aa3e83efc5
] 
[Implement -dsuppress-type-signatures
Ben Lippmeier <benl@ouroborus.net>**20101208062814
 Ignore-this: 34dbefe5f8d7fe58ecb26d6a748d1c71
] 
[Add more suppression flags
Ben Lippmeier <benl@ouroborus.net>**20101208020723
 Ignore-this: b010ba9789a2fde6b815f33494fcc23c
  -dsuppress-all
  -dsuppress-type-applications
  -dsuppress-idinfo
] 
[fix ticket number (#4505)
Simon Marlow <marlowsd@gmail.com>**20101209120404
 Ignore-this: 5769c5ce2a8d69d62d977a9ae138ec23
] 
[fix warnings
Simon Marlow <marlowsd@gmail.com>**20101209115844
 Ignore-this: ffff37feb2abbfc5bd12940c7007c208
] 
[Catch too-large allocations and emit an error message (#4505)
Simon Marlow <marlowsd@gmail.com>**20101209114005
 Ignore-this: c9013ab63dd0bd62ea045060528550c6
 
 This is a temporary measure until we fix the bug properly (which is
 somewhat tricky, and we think might be easier in the new code
 generator).
 
 For now we get:
 
 ghc-stage2: sorry! (unimplemented feature or known bug)
   (GHC version 7.1 for i386-unknown-linux):
         Trying to allocate more than 1040384 bytes.
 
 See: http://hackage.haskell.org/trac/ghc/ticket/4550
 Suggestion: read data from a file instead of having large static data
 structures in the code.
] 
[Export the value of the signal used by scheduler (#4504)
Dmitry Astapov <dastapov@gmail.com>**20101208183755
 Ignore-this: 427bf8c2469283fc7a6f759440d07d87
] 
[Tweak the "sorry" message a bit
Simon Marlow <marlowsd@gmail.com>**20101208163212
 Ignore-this: aa1ce5bc3c27111548204b740572efbe
 
 -              "sorry! (this is work in progress)\n"
 +              "sorry! (unimplemented feature or known bug)\n"
] 
[:unset settings support
Boris Lykah <lykahb@gmail.com>**20101123190132
 Ignore-this: 5e97c99238f5d2394592858c34c004d
 Added support for settings [args, prog, prompt, editor and stop].
 Now :unset supports the same set of options as :set.
] 
[Fix Windows memory freeing: add a check for fb == NULL; fixes trac #4506
Ian Lynagh <igloo@earth.li>**20101208152349
 Also added a few comments, and a load of code got indented 1 level deeper.
] 
[Fixes for #4512: EventLog.c - provides ability to terminate event logging, Schedule.c - uses them in forkProcess.
Dmitry Astapov <dastapov@gmail.com>**20101203133950
 Ignore-this: 2da7f215d6c22708a18291a416ba8881
] 
[Fix up TcInstDcls
simonpj@microsoft.com**20101203180758
 Ignore-this: 9311aeb4ee67c799704afec90b5982d0
 
 I really don't know how this module got left out of my last
 patch, namely
   Thu Dec  2 12:35:47 GMT 2010  simonpj@microsoft.com
   * Re-jig simplifySuperClass (again)
 
 I suggest you don't pull either the patch above, or this
 one, unless you really have to.  I'm not fully confident
 that it works properly yet.  Ran out of time. Sigh.
] 
[Make CPPFLAGS variables, as well as CFLAGS and LDFLAGS
Ian Lynagh <igloo@earth.li>**20101207010033
 Ignore-this: 2fc1ca1422aae1988d0fe1d29a8485d9
 This fixes the "does unsetenv return void" test in the unix package on
 OS X, if I tell it to make 10.4-compatible binaries. The test uses
 CPPFLAGS but not CFLAGS, so it thought it returned int (as it was
 in 10.5-mode), but the C compiler (using CFLAGS, so in 10.4 mode)
 thought it returned void.
 
 I also added CONF_LD_OPTS_STAGE$3 to the list of things in LDFLAGS,
 which looks like an accidental ommission.
] 
[Add a configure message
Ian Lynagh <igloo@earth.li>**20101206215201] 
[Link even programs containing no Haskell modules with GHC
Ian Lynagh <igloo@earth.li>**20101206203329
 I don't remember why we made it use gcc instead, but going back to
 using ghc doesn't seem to break anything, and should fix the build
 on OS X 10.6.
] 
[Correct the stage that the includes/ tools are built in
Ian Lynagh <igloo@earth.li>**20101206203125] 
[Tweak the cleaning of inplace/; fixes trac #4320
Ian Lynagh <igloo@earth.li>**20101205212048] 
[Close .ghci files after reading them; fixes trac #4487
Ian Lynagh <igloo@earth.li>**20101205205301] 
[Fix the behaviour of :history for ticks surrounding top level functions
pepeiborra@gmail.com**20101203202346
 Ignore-this: 8059d4859c52c0c9a235b937cb8cde1d
] 
[Don't warn of duplicate exports in case of module exports.
Michal Terepeta <michal.terepeta@gmail.com>**20101127212116
 Ignore-this: ea225d517826f971c400bbb68d1405b8
 
 But only when the module exports refer to different modules.
 See ticket #4478.
] 
[Fix whitespace/layout in RnNames.
Michal Terepeta <michal.terepeta@gmail.com>**20101030171303
 Ignore-this: 707a7955fc4fc51683cc5a1dfe57f93
] 
[Tell gcc to support back to OS X 10.5
Ian Lynagh <igloo@earth.li>**20101203201558
 Ignore-this: f02d70e5b9cce50137981c6cb2b62a18
] 
[Make RelaxedLayout off by default
Ian Lynagh <igloo@earth.li>**20101202140808
 I suspect this is a vary rarely used extension to the official layout
 rule.
] 
[throwTo: report the why_blocked value in the barf()
Simon Marlow <marlowsd@gmail.com>**20101203094840
 Ignore-this: 3b167c581be1c51dfe3586cc6359e1d0
] 
[handle ThreadMigrating in throwTo() (#4811)
Simon Marlow <marlowsd@gmail.com>**20101203094818
 Ignore-this: 8ef8cb7fd3b50a27f83c29968131d461
 If a throwTo targets a thread that has just been created with
 forkOnIO, then it is possible the exception strikes while the thread
 is still in the process of migrating.  throwTo() didn't handle this
 case, but it's fairly straightforward.
] 
[removeThreadFromQueue: stub out the link field before returning (#4813)
Simon Marlow <marlowsd@gmail.com>**20101202160838
 Ignore-this: 653ae17bc1120d7f4130da94665002a1
] 
[small tidyup
Simon Marlow <marlowsd@gmail.com>**20101126140620
 Ignore-this: 70b1d5ed4c81a7b29dd5980a2d84aae1
] 
[Fix a recomp bug: make classes/datatypes depend directly on DFuns (#4469)
Simon Marlow <marlowsd@gmail.com>**20101202122349
 Ignore-this: 61c765583bb1d97caa88cf9b4f45b87c
 And remove the old mechanism of recording dfun uses separately,
 because it didn't work.
 
 This wiki page describes recompilation avoidance and fingerprinting.
 I'll update it to describe the new method and what went wrong with the
 old method:
 
 http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
] 
[make a panic message more informative and suggest -dcore-lint (see #4534)
Simon Marlow <marlowsd@gmail.com>**20101201151706
 Ignore-this: 2a10761925d6f9f52675948baa30f7a
] 
[Re-jig simplifySuperClass (again)
simonpj@microsoft.com**20101202123547
 Ignore-this: fe4062b8988258f6748ebd8fbd6515b5
 
 This fixes the current loop in T3731, and will fix other
 reported loops.  The loops show up when we are generating
 evidence for superclasses in an instance declaration.
 
 The trick is to make the "self" dictionary simplifySuperClass
 depend *explicitly* on the superclass we are currently trying
 to build.  See Note [Dependencies in self dictionaries] in TcSimplify.
 
 That in turn means that EvDFunApp needs a dependency-list, used
 when chasing dependencies in isGoodRecEv.
] 
[A little refactoring (remove redundant argument passed to isGoodRecEv)
simonpj@microsoft.com**20101202123110
 Ignore-this: e517c5c12109a230f08dafb4d1e386df
] 
[Make rebindable if-then-else a little more permissive
simonpj@microsoft.com**20101202122540
 Ignore-this: ddb552cfe307607b42d1e4baf4e3bf21
 
 See Note [Rebindable syntax for if].  Fixes Trac #4798.
 Thanks to Nils Schweinsberg <mail@n-sch.de>
] 
[Improve error message (Trac #4799)
simonpj@microsoft.com**20101202102706
 Ignore-this: d9896e4d182936de1f256c820b96a8cf
] 
[Fix a nasty bug in RULE matching: Trac #4814
simonpj@microsoft.com**20101202102618
 Ignore-this: ba058ad46a02bd2faf3a14de93fd19c6
 
 See Note [Matching lets], which explains it all in detail.
 It took me a day to think of a nice way to fix the bug,
 but I think the result is quite respectable. Subtle, though.
] 
[Rename -XPArr to -XParallelArrays
Ben Lippmeier <benl@ouroborus.net>**20101130075415
 Ignore-this: 21b37680a7f25800d1200b59ad0b6b39
] 
[FIX #1845 (unconditional relative branch out of range)
pho@cielonegro.org**20101130143014
 Ignore-this: df234bd8ad937104c455656fe3c33732
 
 Don't use mmap on powerpc-apple-darwin as mmap doesn't support
 reallocating but we need to allocate jump islands just after each
 object images. Otherwise relative branches to jump islands can fail
 due to 24-bits displacement overflow.
] 
[rts/Linker.c (loadArchive):
pho@cielonegro.org**20101130142700
 Ignore-this: bc84f9369ce5c2d289440701b7a3a2ab
 
 This routine should be aware of Mach-O misalignment of malloc'ed memory regions.
] 
[rts/Linker.c (machoGetMisalignment):
pho@cielonegro.org**20101130123355
 Ignore-this: 75425600049efd587e9873578e26392f
 
 Use fseek(3) instead of rewind(3) to move the file position indicator back to the initial position. Otherwise we can't use this function in loadArchive().
] 
[rts/Linker.c (ocFlushInstructionCache):
pho@cielonegro.org**20101130121425
 Ignore-this: 1e2c207e4b1d17387617ec5d645204b7
 
 I found this function causes a segfault when ocAllocateSymbolExtras() has allocated a separate memory region for jump islands.
] 
[Remove NewQualifiedOperators
Ian Lynagh <igloo@earth.li>**20101201181117
 The extension was rejected by Haskell', and deprecated in 7.0.
] 
[fix ref to utils/ext-core, which moved to Hackage (extcore package)
Simon Marlow <marlowsd@gmail.com>**20101201092147
 Ignore-this: 272a7daaa335ef60bcc645db70b4d68b
] 
[fix floating-point/FFI section: fenv is C99, not POSIX
Simon Marlow <marlowsd@gmail.com>**20101201092119
 Ignore-this: ce8b3edd428e4f77691dd739b5b4ae73
] 
[Fixed some 'unused vars' warnings
keller@cse.unsw.edu.au**20101130013425
 Ignore-this: 35790d443faa23b87e4ba442e62376a3
] 
[vectScalarLam handles int, float, and double now
keller@cse.unsw.edu.au**20101129231043
 Ignore-this: 6d67bdc8dd8577184040e791e6f3d0
] 
[Handling of lets, letrec and case when checking if a lambda expr needs to be vectorised
keller@cse.unsw.edu.au**20101115051225
 Ignore-this: 1db6ed63d7b3f6d093e019322b407ff7
] 
[Document the behaviour of fenv.h functions with GHC (#4391)
Simon Marlow <marlowsd@gmail.com>**20101126125336
 Ignore-this: bc4eab49428d567505a28add6fed90f1
] 
[Remove the no-ghci-lib warning in ghc-pkg
Ian Lynagh <igloo@earth.li>**20101127235805
 GHCi libs are no longer necessary, as we can use the .a or .so versions
 instead.
] 
[Add GNU-variant support to the .a parser, and other improvements/tidyups
Ian Lynagh <igloo@earth.li>**20101127223945] 
[Re-indent only
Ian Lynagh <igloo@earth.li>**20101127191646] 
[Improve linker debugging for archive files
Ian Lynagh <igloo@earth.li>**20101127190907] 
[Always enable the archive-loading code
Ian Lynagh <igloo@earth.li>**20101127173000
 If the GHCi .o lib doesn't exist, load the .a instead
] 
[Inherit the ForceSpecConstr flag in non-recursive nested bindings
Roman Leshchinskiy <rl@cse.unsw.edu.au>**20101127125025
 Ignore-this: 401391eae25cefcb4afaba2e357decc1
 
 This makes sure that join points are fully specialised in loops which are
 marked as ForceSpecConstr.
] 
[Document -ddump-rule-firings and -ddump-rule-rewrites
Roman Leshchinskiy <rl@cse.unsw.edu.au>**20101127123528
 Ignore-this: beade2efe0cd767c0ce9d4f45a3380ba
] 
[New flag -dddump-rule-rewrites
Roman Leshchinskiy <rl@cse.unsw.edu.au>**20101127122022
 Ignore-this: c0ef5b8a199fbd1ef020258d2cde85a3
 
 Now, -ddump-rule-firings only shows the names of the rules that fired (it would
 show "before" and "after" with -dverbose-core2core previously) and
 -ddump-rule-rewrites always shows the "before" and "after" bits, even without
 -dverbose-core2core.
] 
[Acutally, wild-card variables *can* have occurrences
simonpj@microsoft.com**20101126162409
 Ignore-this: 544bffed75eeccef03a1097f98524eea
 
 This patch removes the Lint test, and comments why
] 
[Tidy up the handling of wild-card binders, and make Lint check it
simonpj@microsoft.com**20101126133210
 Ignore-this: 9e0be9f7867d53046ee5b0e478a0f433
 
 See Note [WildCard binders] in SimplEnv.  Spotted by Roman.
] 
[Substitution should just substitute, not optimise
simonpj@microsoft.com**20101125172356
 Ignore-this: 657628d9b6796ceb5f915c43d56e4a06
 
 This was causing Trac #4524, by optimising
      (e |> co)  to   e
 on the LHS of a rule.  Result, the template variable
 'co' wasn't bound any more.
 
 Now that substition doesn't optimise, it seems sensible to call
 simpleOptExpr rather than substExpr when substituting in the
 RHS of rules.  Not a big deal either way.
] 
[Make SpecConstr "look through" identity coercions
simonpj@microsoft.com**20101125172138
 Ignore-this: c1cc585ed890a7702c33987e971e0af6
] 
[Comment only
simonpj@microsoft.com**20101125172011
 Ignore-this: 3c7be8791badd00dcca9610ebb8981d1
] 
[White space only
simonpj@microsoft.com**20101101080748
 Ignore-this: f7133fc6b22ae263c6672543a8534a6f
] 
[Keep a maximum of 6 spare worker threads per Capability (#4262)
Simon Marlow <marlowsd@gmail.com>**20101125135729
 Ignore-this: a020786569656bf2f3a1717b65d463bd
] 
[Unicide OtherNumber category should be allowed in identifiers (#4373)
Simon Marlow <marlowsd@gmail.com>**20101115095444
 Ignore-this: e331b6ddb17550163ee91bd283348800
] 
[vectoriser: fix warning
Ben Lippmeier <benl@ouroborus.net>**20101126044036
 Ignore-this: e1a66bb405bf2f3f56b42c3b13fd4bf3
] 
[vectoriser: fix warning
Ben Lippmeier <benl@ouroborus.net>**20101126042950
 Ignore-this: df8dd25bcfb3946c2974b13953a2f2c7
] 
[vectoriser: take class directly from the instance tycon
Ben Lippmeier <benl@ouroborus.net>**20101126042900
 Ignore-this: 626a416717a5a059f39e53f4ec95fc66
] 
[vectoriser: comments only
Ben Lippmeier <benl@ouroborus.net>**20101125073201
 Ignore-this: 8846ea8895307083bd1ebbc5d7fb1c5
] 
[vectoriser: follow changes in mkClass
Ben Lippmeier <benl@ouroborus.net>**20101125062349
 Ignore-this: d5018cc022686d4272e126ca9a12283a
] 
[vectoriser: tracing wibbles
Ben Lippmeier <benl@ouroborus.net>**20101125062332
 Ignore-this: c2024d8f03bc03bee2851f4f1c139fd5
] 
[mkDFunUnfolding wants the type of the dfun to be a PredTy
benl@ouroborus.net**20100914062939
 Ignore-this: 7aa6e6b140746184cf00355b50c83b66
] 
[vectoriser: fix conflicts
Ben Lippmeier <benl@ouroborus.net>**20101125060904
 Ignore-this: cc3decab1affada8629ca3818b76b3bf
] 
[Comments and formatting only
benl@ouroborus.net**20100914062903
 Ignore-this: b0fc25f0952cafd56cc25353936327d4
] 
[Comments and formatting to type environment vectoriser
benl@ouroborus.net**20100909080405
 Ignore-this: ab8549d53f845c9d82ed9a525fda3906
] 
[Don't mix implicit and explicit layout
Ian Lynagh <igloo@earth.li>**20101124231514] 
[Whitespace only
Ian Lynagh <igloo@earth.li>**20101124230655] 
[Separate NondecreasingIndentation out into its own extension
Ian Lynagh <igloo@earth.li>**20101124220507] 
[Add another GHC layout rule relaxation to RelaxedLayout
Ian Lynagh <igloo@earth.li>**20101124205957] 
[Remove an unused build system variable: GhcDir
Ian Lynagh <igloo@earth.li>**20101124140455] 
[Remove unused build system variable: GhcHasEditline
Ian Lynagh <igloo@earth.li>**20101124140415] 
[Remove unused variables from the build system: HBC, NHC, MKDEPENDHS
Ian Lynagh <igloo@earth.li>**20101124140052] 
[Remove references to Haskell 98
Ian Lynagh <igloo@earth.li>**20101123233536
 They are no longer right, as we have Haskell' generating new Haskell
 standards.
] 
[Tweak a configure test
Ian Lynagh <igloo@earth.li>**20101123170621] 
[Add a configure test for the visibility hidden attribute
Ian Lynagh <igloo@earth.li>**20101123170541] 
[sanity: fix places where we weren't filling fresh memory with 0xaa
Simon Marlow <marlowsd@gmail.com>**20101029092843
 Ignore-this: 2cb18f7f5afcaf33371aeffce67e218f
] 
[Just some alpha renaming
Ian Lynagh <igloo@earth.li>**20101121144455
 Ignore-this: d5e807c5470840efc199e29f7d50804c
] 
[Fix bug #3165 (:history throws irrefutable pattern failed)
pepeiborra@gmail.com**20101115223623
 Ignore-this: 73edf56e502b4d0385bc044133b27946
 
 I ran across this bug and took the time to fix it, closing
 a long time due TODO in InteractiveEval.hs
 
 Instead of looking around to find the enclosing declaration
 of a tick, this patch makes use of the information already collected during the
 coverage desugaring phase
] 
[For bindists, build ghc-pwd with stage 1
Ian Lynagh <igloo@earth.li>**20101121183520
 Ignore-this: a3b5c8b78c81ec1b6d5fbf23da346ff5
 rather then the bootstrapping compiler. This fixes problems where the
 bootstrapping compiler dynamically links against libraries not on the
 target machine.
] 
[Makefile tweak
Ian Lynagh <igloo@earth.li>**20101121183342
 Ignore-this: cd55a2819c1a5fd36da1bc7a75d2ded1
] 
[Fix a makefile include ordering sanity check
Ian Lynagh <igloo@earth.li>**20101121174916
 Ignore-this: d0bdd41c4b618944d04ecb4f54fdd0f1
] 
[Add an extension for GHC's layout-rule relaxations
Ian Lynagh <igloo@earth.li>**20101120215340
 Still TODO: Add the other relaxation (#1060) and update the alternative
 layout rule to use the extension.
] 
[Tweak the bindist configure.ac.in
Ian Lynagh <igloo@earth.li>**20101120173735] 
[configure.ac tweaks
Ian Lynagh <igloo@earth.li>**20101120170245] 
[When testing the bindist, tell it where gcc is
Ian Lynagh <igloo@earth.li>**20101120155920
 The location isn't baked into the bindist, as it may differ from
 machine to machine.
] 
[Comments only
simonpj@microsoft.com**20101119100153
 Ignore-this: 7abd5d965ea805770449d6f8dadbb921
] 
[ForceSpecConstr now forces specialisation even for arguments which aren't scrutinised
Roman Leshchinskiy <rl@cse.unsw.edu.au>**20101118212839
 Ignore-this: db45721d29a694e53746f8b76513efa4
] 
[Move the superclass generation to the canonicaliser
simonpj@microsoft.com**20101118120533
 Ignore-this: 5e0e525402a240b709f2b8104c1682b2
 
 Doing superclass generation in the canonicaliser (rather than
 TcInteract) uses less code, and is generally more efficient.
 
 See Note [Adding superclasses] in TcCanonical.
 
 Fixes Trac #4497.
] 
[Fix the generation of in-scope variables for IfaceLint check
simonpj@microsoft.com**20101118090057
 Ignore-this: bbcdba61ddf89d07fe69ca99c2017e3f
] 
[Comments only
simonpj@microsoft.com**20101118090034
 Ignore-this: fa2936d35a0f7be4e4535ea9e2b7bf7b
] 
[Omit bogus test for -XDeriveFunctor
simonpj@microsoft.com**20101118090028
 Ignore-this: a534243011809ebbb788b910961601c5
 
 It was duplicated in the case of 'deriving( Functor )'
 and wrong for 'deriving( Foldable )'
] 
[Improve error message on advice from a user
simonpj@microsoft.com**20101118085306
 Ignore-this: bd4f3858ff24e602e985288f27d536f3
 
 See Trac #4499
] 
[TAG 2010-11-18
Ian Lynagh <igloo@earth.li>**20101118011554
 Ignore-this: ccadbe7fadd1148d2ee3caa8c8821ec5
] 
Patch bundle hash:
58498bfbdf308f6f10f2944769ff382993bf971d