From 8739a6bd59f562bb550c915f1d2b2a327b748572 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Fri, 17 Jun 2011 19:10:29 +0100 Subject: Fix build --- src/Haddock/Backends/Xhtml.hs | 2 +- src/Haddock/Backends/Xhtml/Decl.hs | 2 +- src/Haddock/Backends/Xhtml/Layout.hs | 4 +++- src/Haddock/Backends/Xhtml/Utils.hs | 9 +++++++-- src/Haddock/GhcUtils.hs | 4 ++-- src/Haddock/Interface/Create.hs | 2 +- src/Haddock/Lex.x | 17 ++++++++++++----- src/Haddock/Types.hs | 1 - 8 files changed, 27 insertions(+), 14 deletions(-) (limited to 'src') diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index d3d3c79c..600a5362 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -571,7 +571,7 @@ processForMiniSynopsis mdl unicode _ (ExportDecl (L _loc decl0) _doc _ _insts) = _ -> [] processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = [groupTag lvl << docToHtml qual txt] -processForMiniSynopsis _ _ _ = [] +processForMiniSynopsis _ _ _ _ = [] ppNameMini :: Module -> OccName -> Html diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index bd93ac25..add926ab 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -58,7 +58,7 @@ ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [DocName] -> HsType DocName -> Bool Qualification -> Html + [DocName] -> HsType DocName -> Bool -> Qualification -> Html ppFunSig summary links loc doc docnames typ unicode qual = ppTypeOrFunSig summary links loc docnames typ doc ( ppTypeSig summary occnames typ unicode qual diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs index 91eac9c6..bdd5ac78 100644 --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -204,5 +204,7 @@ topDeclElem ((_,_,sourceMap), (_,_,maybe_wiki_url)) loc names html = Documented n mdl = head names -- FIXME: is it ok to simply take the first 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 c250f5eb..7ba6d5f4 100644 --- a/src/Haddock/Backends/Xhtml/Utils.hs +++ b/src/Haddock/Backends/Xhtml/Utils.hs @@ -37,7 +37,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 ) @@ -59,7 +59,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 597ed123..f79acd94 100644 --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -179,11 +179,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/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 78c73c09..f9d72bd0 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -682,7 +682,7 @@ moduleExports :: Module -- ^ Module A -> IfaceMap -- ^ Already created interfaces -> InstIfaceMap -- ^ Interfaces in other packages -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items -moduleExports thisMod expMod dflags gre exports decls ifaceMap instIfaceMap +moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap | m == thisMod = liftErrMsg $ fullContentsOfThisModule dflags gre decls | otherwise = case Map.lookup m ifaceMap of diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x index 2f0b4cd3..17267656 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,19 +179,25 @@ 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 "" + 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 - pstate = mkPState dflags buffer noSrcLoc + pstate = mkPState dflags buffer loc result = unP parseIdentifier pstate in case result of POk _ name -> Just [unLoc name] diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index db8a3198..d82e3efd 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -26,7 +26,6 @@ import Data.Typeable import Data.Map (Map) import qualified Data.Map as Map import GHC hiding (NoLink) -import Name ----------------------------------------------------------------------------- -- cgit v1.2.3