Avoid making Either String an instance of Monad in the Haddock parser

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 03ad6de..dd92677 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -483,7 +483,10 @@ setGlobalTypeScope session ids
 -- Parsing Haddock comments
 
 parseHaddockComment :: String -> Either String (HsDoc RdrName)
-parseHaddockComment string = parseHaddockParagraphs (tokenise string)
+parseHaddockComment string = 
+  case parseHaddockParagraphs (tokenise string) of
+    MyLeft x  -> Left x
+    MyRight x -> Right x
 
 -- -----------------------------------------------------------------------------
 -- Loading the program

diff --git a/compiler/parser/HaddockParse.y b/compiler/parser/HaddockParse.y
index e23b4ee..e3f45f9 100644 (file)
--- a/compiler/parser/HaddockParse.y
+++ b/compiler/parser/HaddockParse.y
@@ -6,7 +6,11 @@
 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
-module HaddockParse (parseHaddockParagraphs, parseHaddockString) where
+module HaddockParse (
+  parseHaddockParagraphs, 
+  parseHaddockString, 
+  MyEither(..)
+) where
 
 import {-# SOURCE #-} HaddockLex
 import HsSyn
@@ -31,7 +35,7 @@ import RdrName
        PARA    { TokPara }
        STRING  { TokString $$ }
 
-%monad { Either String }
+%monad { MyEither String }
 
 %name parseHaddockParagraphs  doc
 %name parseHaddockString seq
@@ -94,16 +98,17 @@ strings  :: { String }
        | STRING strings        { $1 ++ $2 }
 
 {
-happyError :: [Token] -> Either String a
-happyError toks = 
---  Left ("parse error in doc string: "  ++ show (take 3 toks))
-  Left ("parse error in doc string")
-
--- Either monad (we can't use MonadError because GHC < 5.00 has
--- an older incompatible version).
-instance Monad (Either String) where
-       return        = Right
-       Left  l >>= _ = Left l
-       Right r >>= k = k r
-       fail msg      = Left msg
+happyError :: [Token] -> MyEither String a
+happyError toks = MyLeft ("parse error in doc string")
+
+-- We don't want to make an instance for Either String,
+-- since every user of the GHC API would get that instance
+
+data MyEither a b = MyLeft a | MyRight b
+
+instance Monad (MyEither String) where
+       return          = MyRight
+       MyLeft  l >>= _ = MyLeft l
+       MyRight r >>= k = k r
+       fail msg        = MyLeft msg
 }

diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs
index 124d542..abc31e1 100644 (file)
--- a/compiler/parser/HaddockUtils.hs
+++ b/compiler/parser/HaddockUtils.hs
@@ -47,8 +47,8 @@ parseModuleHeader str0 =
          Nothing -> Right Nothing                                                               
          Just description -> case parseHaddockString . tokenise $ description of                       
 
-            Left mess -> Left ("Cannot parse Description: " ++ mess)                            
-            Right doc -> Right (Just doc)                                                       
+            MyLeft mess -> Left ("Cannot parse Description: " ++ mess)                            
+            MyRight doc -> Right (Just doc)                                                       
    in                                                                                           
       case description1 of                                                                      
          Left mess -> Left mess                                                                 

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 8adc381..8256b4d 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1840,35 +1840,35 @@ commas :: { Int }
 
 docnext :: { LHsDoc RdrName }
   : DOCNEXT {% case parseHaddockParagraphs (tokenise (getDOCNEXT $1)) of {
-      Left  err -> parseError (getLoc $1) err;
-      Right doc -> return (L1 doc) } }
+      MyLeft  err -> parseError (getLoc $1) err;
+      MyRight doc -> return (L1 doc) } }
 
 docprev :: { LHsDoc RdrName }
   : DOCPREV {% case parseHaddockParagraphs (tokenise (getDOCPREV $1)) of {
-      Left  err -> parseError (getLoc $1) err;
-      Right doc -> return (L1 doc) } }
+      MyLeft  err -> parseError (getLoc $1) err;
+      MyRight doc -> return (L1 doc) } }
 
 docnamed :: { Located (String, (HsDoc RdrName)) }
   : DOCNAMED {%
       let string = getDOCNAMED $1 
           (name, rest) = break isSpace string
       in case parseHaddockParagraphs (tokenise rest) of {
-        Left  err -> parseError (getLoc $1) err;
-        Right doc -> return (L1 (name, doc)) } }
+        MyLeft  err -> parseError (getLoc $1) err;
+        MyRight doc -> return (L1 (name, doc)) } }
 
 docsection :: { Located (n, HsDoc RdrName) }
   : DOCSECTION {% let (n, doc) = getDOCSECTION $1 in
         case parseHaddockString (tokenise doc) of {
-      Left  err -> parseError (getLoc $1) err;
-      Right doc -> return (L1 (n, doc)) } }
+      MyLeft  err -> parseError (getLoc $1) err;
+      MyRight doc -> return (L1 (n, doc)) } }
 
 moduleheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }                                    
         : DOCNEXT {% let string = getDOCNEXT $1 in
                case parseModuleHeader string of {                       
                  Right (str, info) ->                                  
                    case parseHaddockParagraphs (tokenise str) of {               
-                     Left err -> parseError (getLoc $1) err;                    
-                     Right doc -> return (info, Just doc);          
+                     MyLeft err -> parseError (getLoc $1) err;                    
+                     MyRight doc -> return (info, Just doc);          
                    };                                             
                  Left err -> parseError (getLoc $1) err
             }  }