[commit: haddock2] master: Follow Src{Span, Loc} changes in GHC (3582c02)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/haddock2

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/3582c02b75b4a71c048226317b2f2f926f974719

>---------------------------------------------------------------

commit 3582c02b75b4a71c048226317b2f2f926f974719
Author: Ian Lynagh <igloo at earth.li>
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