Repository : ssh://darcs.haskell.org//srv/darcs/haddock2 On branch : master
http://hackage.haskell.org/trac/ghc/changeset/3582c02b75b4a71c048226317b2f2f926f974719 >--------------------------------------------------------------- commit 3582c02b75b4a71c048226317b2f2f926f974719 Author: Ian Lynagh <[email protected]> Date: Thu Jun 9 15:48:45 2011 +0100 Follow Src{Span,Loc} changes in GHC >--------------------------------------------------------------- src/Haddock/Backends/Xhtml/Layout.hs | 4 +++- src/Haddock/Backends/Xhtml/Utils.hs | 9 +++++++-- src/Haddock/GhcUtils.hs | 4 ++-- src/Haddock/Lex.x | 19 +++++++++++++------ 4 files changed, 25 insertions(+), 11 deletions(-) diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs index 295af30..b4538e8 100644 --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -202,5 +202,7 @@ topDeclElem ((_,_,sourceMap), (_,_,maybe_wiki_url)) loc name html = -- Name must be documented, otherwise we wouldn't get here Documented n mdl = name - fname = unpackFS (srcSpanFile loc) + fname = case loc of + RealSrcSpan l -> unpackFS (srcSpanFile l) + UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan" diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs index 10f9e76..a802228 100644 --- a/src/Haddock/Backends/Xhtml/Utils.hs +++ b/src/Haddock/Backends/Xhtml/Utils.hs @@ -36,7 +36,7 @@ import Data.Maybe import Text.XHtml hiding ( name, title, p, quote ) import qualified Text.XHtml as XHtml -import GHC ( SrcSpan, srcSpanStartLine, Name ) +import GHC ( SrcSpan(..), srcSpanStartLine, Name ) import Module ( Module ) import Name ( getOccString, nameOccName, isValOcc ) @@ -58,7 +58,12 @@ spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url line = case maybe_loc of Nothing -> "" - Just span_ -> show $ srcSpanStartLine span_ + Just span_ -> + case span_ of + RealSrcSpan span__ -> + show $ srcSpanStartLine span__ + UnhelpfulSpan _ -> + error "spliceURL UnhelpfulSpan" run "" = "" run ('%':'M':rest) = mdl ++ run rest diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs index 9c5090a..8cf411e 100644 --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -152,11 +152,11 @@ reL :: a -> Located a reL = L undefined -instance Foldable Located where +instance Foldable (GenLocated l) where foldMap f (L _ x) = f x -instance Traversable Located where +instance Traversable (GenLocated l) where mapM f (L l x) = (return . L l) =<< f x diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x index 436cb10..4cd6f85 100644 --- a/src/Haddock/Lex.x +++ b/src/Haddock/Lex.x @@ -28,6 +28,7 @@ import StringBuffer import RdrName import SrcLoc import DynFlags +import FastString import Data.Char import Numeric @@ -178,22 +179,28 @@ begin sc = \_ _ _ cont _ -> cont sc ident :: Action ident pos str sc cont dflags = - case strToHsQNames dflags id of + case strToHsQNames dflags loc id of Just names -> (TokIdent names, pos) : cont sc Nothing -> (TokString str, pos) : cont sc where id = init (tail str) - -strToHsQNames :: DynFlags -> String -> Maybe [RdrName] -strToHsQNames dflags str0 = + -- TODO: Get the real filename here. Maybe we should just be + -- using GHC SrcLoc's ourself? + filename = mkFastString "<unknown file>" + loc = case pos of + AlexPn _ line col -> + mkRealSrcLoc filename line col + +strToHsQNames :: DynFlags -> RealSrcLoc -> String -> Maybe [RdrName] +strToHsQNames dflags loc str0 = #if MIN_VERSION_ghc(7,1,0) let buffer = stringToStringBuffer str0 #else let buffer = unsafePerformIO (stringToStringBuffer str0) #endif #if MIN_VERSION_ghc(6,13,0) - pstate = mkPState dflags buffer noSrcLoc + pstate = mkPState dflags buffer loc #else - pstate = mkPState buffer noSrcLoc dflags + pstate = mkPState buffer loc dflags #endif result = unP parseIdentifier pstate in case result of _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
