From 1168a37f6bfad3d7025ecb21b9917799937936f3 Mon Sep 17 00:00:00 2001 From: David Waern Date: Wed, 14 Nov 2007 20:40:50 +0000 Subject: [PATCH] Avoid making Either String an instance of Monad in the Haddock parser --- compiler/main/GHC.hs | 5 ++++- compiler/parser/HaddockParse.y | 33 +++++++++++++++++++-------------- compiler/parser/HaddockUtils.hs | 4 ++-- compiler/parser/Parser.y.pp | 20 ++++++++++---------- 4 files changed, 35 insertions(+), 27 deletions(-) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 03ad6de..dd92677 100644 --- 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 --- 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 --- 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 --- 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 } } -- 1.7.10.4