Differentiate between TH splices (line-links) and regular names

This adds a new type of source code link, to a specific line rather than
a specific declaration/name - this is used to link to the location of a
TH splice that defines a certain name.

Rather hefty changes throughout and still one unresolved issue (the line
URLs aren't parsed from the third form of --read-interface which means
they're currently restricted to same-interface links). Not sure if
this issue is really worth all the hassle, especially since we could
just use line links in general.

This commit also contains some cleanup/clarification of the types in
Haddock.Backends.Xhtml.Decl and shortens some overlong lines in the
process. Notably, the Bool parameter was replaced by a Unicode type
synonym to help clarify its presence in type signatures.

11 files changed, 182 insertions, 140 deletions

diff --git a/src/Haddock.hs b/src/Haddock.hs
index cc7e7842..e4c7fdc0 100644
--- a/src/Haddock.hs
+++ b/src/Haddock.hs
@@ -242,9 +242,11 @@ render dflags flags qual ifaces installedIfaces srcMap = do
     pkgStr           = Just (packageIdString pkgId)
     (pkgName,pkgVer) = modulePackageInfo pkgMod
 
-    (srcBase, srcModule, srcEntity) = sourceUrls flags
+    (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
     srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) srcEntity
-    sourceUrls' = (srcBase, srcModule, srcMap')
+    -- TODO: Get these from the interface files as with srcMap
+    srcLMap' = maybe Map.empty (\path -> Map.singleton pkgId path) srcLEntity
+    sourceUrls' = (srcBase, srcModule, srcMap', srcLMap')
 
   libDir   <- getHaddockLibDir flags
   prologue <- getPrologue dflags flags
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index dbce787f..6405861d 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -110,7 +110,7 @@ operator x = x
 -- How to print each export
 
 ppExport :: DynFlags -> ExportItem Name -> [String]
-ppExport dflags (ExportDecl decl dc subdocs _ _) = ppDocumentation dflags (fst dc) ++ f (unL decl)
+ppExport dflags (ExportDecl decl dc subdocs _ _ _) = ppDocumentation dflags (fst dc) ++ f (unL decl)
     where
         f (TyClD d@DataDecl{})  = ppData dflags d subdocs
         f (TyClD d@SynDecl{})   = ppSynonym dflags d
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index e6108ab6..6535b24e 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -177,7 +177,7 @@ string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
 
 
 exportListItem :: ExportItem DocName -> LaTeX
-exportListItem (ExportDecl decl _doc subdocs _insts _fixities)
+exportListItem (ExportDecl decl _doc subdocs _insts _fixities _splice)
   = sep (punctuate comma . map ppDocBinder $ declNames decl) <>
      case subdocs of
        [] -> empty
@@ -212,7 +212,7 @@ processExports (e : es) =
 
 isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)
 isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t))))
-                        (Documentation Nothing Nothing, argDocs) _ _ _)
+                        (Documentation Nothing Nothing, argDocs) _ _ _ _)
   | Map.null argDocs = Just (map unLoc lnames, t)
 isSimpleSig _ = Nothing
 
@@ -225,7 +225,7 @@ isExportModule _ = Nothing
 processExport :: ExportItem DocName -> LaTeX
 processExport (ExportGroup lev _id0 doc)
   = ppDocGroup lev (docToLaTeX doc)
-processExport (ExportDecl decl doc subdocs insts fixities)
+processExport (ExportDecl decl doc subdocs insts fixities _splice)
   = ppDecl decl doc insts subdocs fixities
 processExport (ExportNoDecl y [])
   = ppDocName y
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 4eda68f6..5e728108 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -130,9 +130,9 @@ headHtml docTitle miniPage themes =
 
 
 srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
-srcButton (Just src_base_url, _, _) Nothing =
+srcButton (Just src_base_url, _, _, _) Nothing =
   Just (anchor ! [href src_base_url] << "Source")
-srcButton (_, Just src_module_url, _) (Just iface) =
+srcButton (_, Just src_module_url, _, _) (Just iface) =
   let url = spliceURL (Just $ ifaceOrigFilename iface)
                       (Just $ ifaceMod iface) Nothing Nothing src_module_url
    in Just (anchor ! [href url] << "Source")
@@ -533,7 +533,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
 
     -- todo: if something has only sub-docs, or fn-args-docs, should
     -- it be measured here and thus prevent omitting the synopsis?
-    has_doc (ExportDecl _ (Documentation mDoc mWarning, _) _ _ _) = isJust mDoc || isJust mWarning
+    has_doc (ExportDecl _ (Documentation mDoc mWarning, _) _ _ _ _) = isJust mDoc || isJust mWarning
     has_doc (ExportNoDecl _ _) = False
     has_doc (ExportModule _) = False
     has_doc _ = True
@@ -578,7 +578,7 @@ miniSynopsis mdl iface unicode qual =
 
 processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName
                        -> [Html]
-processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts _fixities) =
+processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts _fixities _splice) =
   ((divTopDecl <<).(declElem <<)) <$> case decl0 of
     TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
         (FamDecl decl)    -> [ppTyFamHeader True False decl unicode qual]
@@ -648,11 +648,11 @@ numberSectionHeadings = go 1
 
 processExport :: Bool -> LinksInfo -> Bool -> Qualification
               -> ExportItem DocName -> Maybe Html
-processExport _ _ _ _ (ExportDecl (L _ (InstD _)) _ _ _ _) = Nothing -- Hide empty instances
+processExport _ _ _ _ (ExportDecl (L _ (InstD _)) _ _ _ _ _) = Nothing -- Hide empty instances
 processExport summary _ _ qual (ExportGroup lev id0 doc)
   = nothingIf summary $ groupHeading lev id0 << docToHtml qual doc
-processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities)
-  = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs unicode qual
+processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice)
+  = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual
 processExport summary _ _ qual (ExportNoDecl y [])
   = processDeclOneLiner summary $ ppDocName qual Prefix True y
 processExport summary _ _ qual (ExportNoDecl y subs)
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 20db5df1..5cc86d48 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -39,31 +39,33 @@ import Name
 
 ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
        -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
-       -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification -> Html
-ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs unicode qual = case decl of
-  TyClD (FamDecl d)         -> ppTyFam summ False links instances fixities loc mbDoc d unicode qual
-  TyClD d@(DataDecl {})     -> ppDataDecl summ links instances fixities subdocs loc mbDoc d unicode qual
-  TyClD d@(SynDecl {})      -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d unicode qual
-  TyClD d@(ClassDecl {})    -> ppClassDecl summ links instances fixities loc mbDoc subdocs d unicode qual
-  SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities unicode qual
+       -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html
+ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
+  TyClD (FamDecl d)         -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
+  TyClD d@(DataDecl {})     -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual
+  TyClD d@(SynDecl {})      -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
+  TyClD d@(ClassDecl {})    -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
+  SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual
   SigD (PatSynSig lname args ty prov req) ->
-      ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities unicode qual
-  ForD d                         -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities unicode qual
+      ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities splice unicode qual
+  ForD d                         -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
   InstD _                        -> noHtml
   _                              -> error "declaration not supported by ppDecl"
 
 
 ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
              [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] ->
-             Bool -> Qualification -> Html
-ppLFunSig summary links loc doc lnames lty fixities unicode qual =
-  ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities unicode qual
+             Splice -> Unicode -> Qualification -> Html
+ppLFunSig summary links loc doc lnames lty fixities splice unicode qual =
+  ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities
+           splice unicode qual
 
 ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
             [DocName] -> HsType DocName -> [(DocName, Fixity)] ->
-            Bool -> Qualification -> Html
-ppFunSig summary links loc doc docnames typ fixities unicode qual =
-  ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ) unicode qual
+            Splice -> Unicode -> Qualification -> Html
+ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
+  ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ)
+            splice unicode qual
   where
     pp_typ = ppType unicode qual typ
 
@@ -71,18 +73,20 @@ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
              Located DocName ->
              HsPatSynDetails (LHsType DocName) -> LHsType DocName ->
              LHsContext DocName -> LHsContext DocName -> [(DocName, Fixity)] ->
-             Bool -> Qualification -> Html
-ppLPatSig summary links loc doc lname args typ prov req fixities unicode qual =
-    ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) fixities unicode qual
+             Splice -> Unicode -> Qualification -> Html
+ppLPatSig summary links loc doc lname args typ prov req fixities splice unicode qual =
+    ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ)
+             (unLoc prov) (unLoc req) fixities splice unicode qual
 
 ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
             DocName ->
             HsPatSynDetails (HsType DocName) -> HsType DocName ->
             HsContext DocName -> HsContext DocName -> [(DocName, Fixity)] ->
-            Bool -> Qualification -> Html
-ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities unicode qual
+            Splice -> Unicode -> Qualification -> Html
+ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities
+         splice unicode qual
   | summary = pref1
-  | otherwise = topDeclElem links loc [docname] (ppFixities fixities qual <=> pref1)
+  | otherwise = topDeclElem links loc splice [docname] (ppFixities fixities qual <=> pref1)
                 +++ docSection qual doc
   where
     pref1 = hsep [ toHtml "pattern"
@@ -103,14 +107,15 @@ ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities un
 
 ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
              [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) ->
-             Bool -> Qualification -> Html
-ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) unicode qual =
+             Splice -> Unicode -> Qualification -> Html
+ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
+          splice unicode qual =
   ppTypeOrFunSig summary links loc docnames typ doc
     ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode
     , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames
     , dcolon unicode
     )
-    unicode qual
+    splice unicode qual
   where
     occnames = map (nameOccName . getName) docnames
     addFixities html
@@ -119,11 +124,12 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) unicode q
 
 
 ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName
-               -> DocForDecl DocName -> (Html, Html, Html) -> Bool -> Qualification -> Html
-ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) unicode qual
+               -> DocForDecl DocName -> (Html, Html, Html)
+               -> Splice -> Unicode -> Qualification -> Html
+ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual
   | summary = pref1
-  | Map.null argDocs = topDeclElem links loc docnames pref1 +++ docSection qual doc
-  | otherwise = topDeclElem links loc docnames pref2 +++
+  | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection qual doc
+  | otherwise = topDeclElem links loc splice docnames pref2 +++
       subArguments qual (do_args 0 sep typ) +++ docSection qual doc
   where
     argDoc n = Map.lookup n argDocs
@@ -171,20 +177,24 @@ tyvarNames = map getName . hsLTyVarNames
 
 
 ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
-      -> ForeignDecl DocName -> [(DocName, Fixity)] -> Bool -> Qualification -> Html
-ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities unicode qual
-  = ppFunSig summary links loc doc [name] typ fixities unicode qual
-ppFor _ _ _ _ _ _ _ _ = error "ppFor"
+      -> ForeignDecl DocName -> [(DocName, Fixity)]
+      -> Splice -> Unicode -> Qualification -> Html
+ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities
+      splice unicode qual
+  = ppFunSig summary links loc doc [name] typ fixities splice unicode qual
+ppFor _ _ _ _ _ _ _ _ _ = error "ppFor"
 
 
 -- we skip type patterns for now
-ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool
-        -> Qualification -> Html
+ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan
+        -> DocForDecl DocName -> TyClDecl DocName
+        -> Splice -> Unicode -> Qualification -> Html
 ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
                                                 , tcdRhs = ltype })
-        unicode qual
+        splice unicode qual
   = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
-                   (fixs <=> full, fixs <=> hdr, spaceHtml +++ equals) unicode qual
+                   (fixs <=> full, fixs <=> hdr, spaceHtml +++ equals)
+                   splice unicode qual
   where
     hdr  = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
     full = hdr <+> equals <+> ppLType unicode qual ltype
@@ -192,7 +202,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars
     fixs
       | summary   = noHtml
       | otherwise = ppFixities fixities qual
-ppTySyn _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
+ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
 
 
 ppTypeSig :: Bool -> [OccName] -> Html  -> Bool -> Html
@@ -211,9 +221,11 @@ ppTyName = ppName Prefix
 --------------------------------------------------------------------------------
 
 
-ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Bool -> Qualification -> Html
+ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName
+              -> Unicode -> Qualification -> Html
 ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
-                                               , fdKindSig = mkind }) unicode qual =
+                                               , fdKindSig = mkind })
+              unicode qual =
   (case info of
      OpenTypeFamily
        | associated -> keyword "type"
@@ -234,8 +246,8 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
 
 ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] ->
            [(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->
-           FamilyDecl DocName -> Bool -> Qualification -> Html
-ppTyFam summary associated links instances fixities loc doc decl unicode qual
+           FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html
+ppTyFam summary associated links instances fixities loc doc decl splice unicode qual
 
   | summary   = ppTyFamHeader True associated decl unicode qual
   | otherwise = header_ +++ docSection qual doc +++ instancesBit
@@ -243,7 +255,7 @@ ppTyFam summary associated links instances fixities loc doc decl unicode qual
   where
     docname = unLoc $ fdLName decl
 
-    header_ = topDeclElem links loc [docname] $
+    header_ = topDeclElem links loc splice [docname] $
       ppFixities fixities qual <=> ppTyFamHeader summary associated decl unicode qual
 
     instancesBit
@@ -267,9 +279,9 @@ ppTyFam summary associated links instances fixities loc doc decl unicode qual
 
 
 ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName
-            -> [(DocName, Fixity)] -> Bool -> Qualification -> Html
-ppAssocType summ links doc (L loc decl) fixities unicode qual =
-   ppTyFam summ True links [] fixities loc (fst doc) decl unicode qual
+            -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html
+ppAssocType summ links doc (L loc decl) fixities splice unicode qual =
+   ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual
 
 
 --------------------------------------------------------------------------------
@@ -293,7 +305,8 @@ ppDataBinderWithVars summ decl =
 
 
 -- | Print an application of a DocName and two lists of HsTypes (kinds, types)
-ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> Qualification -> Html
+ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName]
+               -> Unicode -> Qualification -> Html
 ppAppNameTypes n ks ts unicode qual =
     ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual)
 
@@ -324,28 +337,28 @@ ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts)
 -------------------------------------------------------------------------------
 
 
-ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool
+ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode
                               -> Qualification -> Html
 ppLContext        = ppContext        . unLoc
 ppLContextNoArrow = ppContextNoArrow . unLoc
 
 
-ppContextNoArrow :: HsContext DocName -> Bool -> Qualification -> Html
+ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html
 ppContextNoArrow []  _       _     = noHtml
 ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual
 
 
-ppContextNoLocs :: [HsType DocName] -> Bool -> Qualification -> Html
+ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html
 ppContextNoLocs []  _       _     = noHtml
 ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual
     <+> darrow unicode
 
 
-ppContext :: HsContext DocName -> Bool -> Qualification -> Html
+ppContext :: HsContext DocName -> Unicode -> Qualification -> Html
 ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
 
 
-ppHsContext :: [HsType DocName] -> Bool -> Qualification-> Html
+ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html
 ppHsContext []  _       _     = noHtml
 ppHsContext [p] unicode qual = ppCtxType unicode qual p
 ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
@@ -358,7 +371,7 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
 
 ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
            -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]
-           -> Bool -> Qualification -> Html
+           -> Unicode -> Qualification -> Html
 ppClassHdr summ lctxt n tvs fds unicode qual =
   keyword "class"
   <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml)
@@ -366,7 +379,7 @@ ppClassHdr summ lctxt n tvs fds unicode qual =
   <+> ppFds fds unicode qual
 
 
-ppFds :: [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html
+ppFds :: [Located ([DocName], [DocName])] -> Unicode -> Qualification -> Html
 ppFds fds unicode qual =
   if null fds then noHtml else
         char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
@@ -375,22 +388,22 @@ ppFds fds unicode qual =
         ppVars = hsep . map (ppDocName qual Prefix True)
 
 ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan
-                 -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification
-                 -> Html
+                 -> [(DocName, DocForDecl DocName)]
+                 -> Splice -> Unicode -> Qualification -> Html
 ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs
                                           , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc
-    subdocs unicode qual =
+    subdocs splice unicode qual =
   if null sigs && null ats
-    then (if summary then id else topDeclElem links loc [nm]) hdr
-    else (if summary then id else topDeclElem links loc [nm]) (hdr <+> keyword "where")
+    then (if summary then id else topDeclElem links loc splice [nm]) hdr
+    else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where")
       +++ shortSubDecls
           (
-            [ ppAssocType summary links doc at [] unicode qual | at <- ats
+            [ ppAssocType summary links doc at [] splice unicode qual | at <- ats
               , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ]  ++
 
                 -- ToDo: add associated type defaults
 
-            [ ppFunSig summary links loc doc names typ [] unicode qual
+            [ ppFunSig summary links loc doc names typ [] splice unicode qual
               | L _ (TypeSig lnames (L _ typ)) <- sigs
               , let doc = lookupAnySubdoc (head names) subdocs
                     names = map unLoc lnames ]
@@ -401,24 +414,25 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
   where
     hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual
     nm  = unLoc lname
-ppShortClassDecl _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
 
 
 
 ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)]
             -> SrcSpan -> Documentation DocName
             -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName
-            -> Bool -> Qualification -> Html
+            -> Splice -> Unicode -> Qualification -> Html
 ppClassDecl summary links instances fixities loc d subdocs
         decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars
-                        , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) unicode qual
-  | summary = ppShortClassDecl summary links decl loc subdocs unicode qual
+                        , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats })
+            splice unicode qual
+  | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual
   | otherwise = classheader +++ docSection qual d
                   +++ atBit +++ methodBit  +++ instancesBit
   where
     classheader
-      | null lsigs = topDeclElem links loc [nm] (fixs <=> hdr unicode qual)
-      | otherwise  = topDeclElem links loc [nm] (fixs <=> hdr unicode qual <+> keyword "where")
+      | null lsigs = topDeclElem links loc splice [nm] (fixs <=> hdr unicode qual)
+      | otherwise  = topDeclElem links loc splice [nm] (fixs <=> hdr unicode qual <+> keyword "where")
 
     -- Only the fixity relevant to the class header
     fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual
@@ -428,13 +442,13 @@ ppClassDecl summary links instances fixities loc d subdocs
     hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
 
     -- ToDo: add assocatied typ defaults
-    atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs unicode qual
+    atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual
                       | at <- ats
                       , let n = unL . fdLName $ unL at
                             doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs
                             subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]
 
-    methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs unicode qual
+    methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual
                            | L _ (TypeSig lnames (L _ typ)) <- lsigs
                            , let doc = lookupAnySubdoc (head names) subdocs
                                  subfixs = [ f | n <- names
@@ -447,10 +461,10 @@ ppClassDecl summary links instances fixities loc d subdocs
 
     instancesBit = ppInstances instances nm unicode qual
 
-ppClassDecl _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
 
 
-ppInstances :: [DocInstance DocName] -> DocName -> Bool -> Qualification -> Html
+ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html
 ppInstances instances baseName unicode qual
   = subInstances qual instName (map instDecl instances)
   where
@@ -476,7 +490,7 @@ lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
 
 
 -- TODO: print contexts
-ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
+ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html
 ppShortDataDecl summary dataInst dataDecl unicode qual
 
   | [] <- cons = dataHeader
@@ -504,9 +518,10 @@ ppShortDataDecl summary dataInst dataDecl unicode qual
 
 ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] ->
               [(DocName, DocForDecl DocName)] ->
-              SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool ->
-              Qualification -> Html
-ppDataDecl summary links instances fixities subdocs loc doc dataDecl unicode qual
+              SrcSpan -> Documentation DocName -> TyClDecl DocName ->
+              Splice -> Unicode -> Qualification -> Html
+ppDataDecl summary links instances fixities subdocs loc doc dataDecl
+           splice unicode qual
 
   | summary   = ppShortDataDecl summary False dataDecl unicode qual
   | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit
@@ -516,7 +531,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl unicode qua
     cons      = dd_cons (tcdDataDefn dataDecl)
     resTy     = (con_res . unLoc . head) cons
 
-    header_ = topDeclElem links loc [docname] (fix
+    header_ = topDeclElem links loc splice [docname] (fix
              <=> ppDataHeader summary dataDecl unicode qual <+> whereBit)
 
     fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual
@@ -537,7 +552,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl unicode qua
 
 
 
-ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Qualification -> Html
+ppShortConstr :: Bool -> ConDecl DocName -> Unicode -> Qualification -> Html
 ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
   where
     (cHead,cBody,cFoot) = ppShortConstrParts summary con unicode qual
@@ -545,7 +560,7 @@ ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
 
 -- returns three pieces: header, body, footer so that header & footer can be
 -- incorporated into the declaration
-ppShortConstrParts :: Bool -> ConDecl DocName -> Bool -> Qualification -> (Html, Html, Html)
+ppShortConstrParts :: Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html)
 ppShortConstrParts summary con unicode qual = case con_res con of
   ResTyH98 -> case con_details con of
     PrefixCon args ->
@@ -591,7 +606,7 @@ ppShortConstrParts summary con unicode qual = case con_res con of
 
 
 -- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool
+ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode
             -> Qualification -> Html
 ppConstrHdr forall_ tvs ctxt unicode qual
  = (if null tvs then noHtml else ppForall)
@@ -605,7 +620,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual
 
 
 ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]
-                   -> Bool -> Qualification -> LConDecl DocName -> SubDecl
+                   -> Unicode -> Qualification -> LConDecl DocName -> SubDecl
 ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart)
  where
     decl = case con_res con of
@@ -653,7 +668,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field
     mkFunTy a b = noLoc (HsFunTy a b)
 
 
-ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> Qualification
+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
                   -> ConDeclField DocName ->  SubDecl
 ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =
   (ppBinder False (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype,
@@ -664,7 +679,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =
     mbDoc = lookup name subdocs >>= combineDocumentation . fst
 
 
-ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html
+ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html
 ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)
   = ppBinder summary (nameOccName . getName $ name)
     <+> dcolon unicode <+> ppLType unicode qual ltype
@@ -672,7 +687,7 @@ ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)
 
 -- | Print the LHS of a data\/newtype declaration.
 -- Currently doesn't handle 'data instance' decls or kind signatures
-ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
+ppDataHeader :: Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html
 ppDataHeader summary decl@(DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd
                                                                , dd_ctxt = ctxt } })
              unicode qual
@@ -725,31 +740,31 @@ maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
                                | otherwise            = p
 
 
-ppLType, ppLParendType, ppLFunLhType :: Bool -> Qualification
+ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification
                                      -> Located (HsType DocName) -> Html
 ppLType       unicode qual y = ppType unicode qual (unLoc y)
 ppLParendType unicode qual y = ppParendType unicode qual (unLoc y)
 ppLFunLhType  unicode qual y = ppFunLhType unicode qual (unLoc y)
 
 
-ppType, ppCtxType, ppParendType, ppFunLhType :: Bool -> Qualification
+ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification
                                              -> HsType DocName -> Html
 ppType       unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual
 ppCtxType    unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual
 ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual
 ppFunLhType  unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual
 
-ppLKind :: Bool -> Qualification-> LHsKind DocName -> Html
+ppLKind :: Unicode -> Qualification-> LHsKind DocName -> Html
 ppLKind unicode qual y = ppKind unicode qual (unLoc y)
 
-ppKind :: Bool -> Qualification-> HsKind DocName -> Html
+ppKind :: Unicode -> Qualification-> HsKind DocName -> Html
 ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
 
 -- Drop top-level for-all type variables in user style
 -- since they are implicit in Haskell
 
 ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
-         -> Located (HsContext DocName) -> Bool -> Qualification -> Html
+         -> Located (HsContext DocName) -> Unicode -> Qualification -> Html
 ppForAll expl tvs cxt unicode qual
   | show_forall = forall_part <+> ppLContext cxt unicode qual
   | otherwise   = ppLContext cxt unicode qual
@@ -759,11 +774,11 @@ ppForAll expl tvs cxt unicode qual
     forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
 
 
-ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Qualification -> Html
+ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html
 ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
 
 
-ppr_mono_ty :: Int -> HsType DocName -> Bool -> Qualification -> Html
+ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html
 ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual
   = maybeParen ctxt_prec pREC_FUN $
     hsep [ppForAll expl tvs ctxt unicode qual, ppr_mono_lty pREC_TOP ty unicode qual]
@@ -814,7 +829,7 @@ ppr_tylit (HsNumTy n) = toHtml (show n)
 ppr_tylit (HsStrTy s) = toHtml (show s)
 
 
-ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Qualification -> Html
+ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html
 ppr_fun_ty ctxt_prec ty1 ty2 unicode qual
   = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual
         p2 = ppr_mono_lty pREC_TOP ty2 unicode qual
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index 9a0e461d..dfcda473 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -190,11 +190,15 @@ declElem = paragraph ! [theclass "src"]
 
 -- a box for top level documented names
 -- it adds a source and wiki link at the right hand side of the box
-topDeclElem :: LinksInfo -> SrcSpan -> [DocName] -> Html -> Html
-topDeclElem ((_,_,sourceMap), (_,_,maybe_wiki_url)) loc names html =
+topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html
+topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html =
     declElem << (srcLink <+> wikiLink <+> html)
-  where srcLink =
-          case Map.lookup origPkg sourceMap of
+  where srcLink = let nameUrl = Map.lookup origPkg sourceMap
+                      lineUrl = Map.lookup origPkg lineMap
+                      mUrl | splice    = lineUrl
+                                         -- Use the lineUrl as a backup
+                           | otherwise = maybe lineUrl Just nameUrl in
+          case mUrl of
             Nothing  -> noHtml
             Just url -> let url' = spliceURL (Just fname) (Just origMod)
                                                (Just n) (Just loc) url
diff --git a/src/Haddock/Backends/Xhtml/Types.hs b/src/Haddock/Backends/Xhtml/Types.hs
index 7bff0eb1..122861c3 100644
--- a/src/Haddock/Backends/Xhtml/Types.hs
+++ b/src/Haddock/Backends/Xhtml/Types.hs
@@ -12,7 +12,9 @@
 -----------------------------------------------------------------------------
 module Haddock.Backends.Xhtml.Types (
   SourceURLs, WikiURLs,
-  LinksInfo
+  LinksInfo,
+  Splice,
+  Unicode,
 ) where
 
 
@@ -21,9 +23,15 @@ import GHC
 
 
 -- the base, module and entity URLs for the source code and wiki links.
-type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageId FilePath)
+type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageId FilePath, Map PackageId FilePath)
 type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath)
 
 
 -- The URL for source and wiki links
 type LinksInfo = (SourceURLs, WikiURLs)
+
+-- Whether something is a splice or not
+type Splice = Bool
+
+-- Whether unicode syntax is to be used
+type Unicode = Bool
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 37d0fe7d..e23e9922 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -55,6 +55,7 @@ createInterface tm flags modMap instIfaceMap = do
 
   let ms             = pm_mod_summary . tm_parsed_module $ tm
       mi             = moduleInfo tm
+      L _ hsm        = parsedSource tm
       !safety        = modInfoSafe mi
       mdl            = ms_mod ms
       dflags         = ms_hspp_opts ms
@@ -85,6 +86,8 @@ createInterface tm flags modMap instIfaceMap = do
       (decls, _) = unzip declsWithDocs
       localInsts = filter (nameIsLocalOrFrom mdl) $  map getName instances
                                                   ++ map getName fam_instances
+      -- Locations of all TH splices
+      splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
 
   maps@(!docMap, !argMap, !subMap, !declMap, _) <-
     liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs
@@ -98,8 +101,8 @@ createInterface tm flags modMap instIfaceMap = do
 
   let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
 
-  exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls maps fixMap exports
-                   instIfaceMap dflags
+  exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls
+                   maps fixMap splices exports instIfaceMap dflags
 
   let !visibleNames = mkVisibleNames maps exportItems opts
 
@@ -477,15 +480,16 @@ mkExportItems
   -> [LHsDecl Name]
   -> Maps
   -> FixMap
+  -> [SrcSpan]          -- splice locations
   -> Maybe [IE Name]
   -> InstIfaceMap
   -> DynFlags
   -> ErrMsgGhc [ExportItem Name]
 mkExportItems
   modMap thisMod warnings gre exportedNames decls
-  maps@(docMap, argMap, subMap, declMap, instMap) fixMap optExports instIfaceMap dflags =
+  maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =
   case optExports of
-    Nothing -> fullModuleContents dflags warnings gre maps fixMap decls
+    Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
     Just exports -> liftM concat $ mapM lookupExport exports
   where
     lookupExport (IEVar x)             = declWith x
@@ -493,7 +497,7 @@ mkExportItems
     lookupExport (IEThingAll t)        = declWith t
     lookupExport (IEThingWith t _)     = declWith t
     lookupExport (IEModuleContents m)  =
-      moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap
+      moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
     lookupExport (IEGroup lev docStr)  = liftErrMsg $
       ifDoc (processDocString dflags gre docStr)
             (\doc -> return [ ExportGroup lev "" doc ])
@@ -516,9 +520,9 @@ mkExportItems
     declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
     declWith t =
       case findDecl t of
-        ([L _ (ValD _)], (doc, _)) -> do
+        ([L l (ValD _)], (doc, _)) -> do
           -- Top-level binding without type signature
-          export <- hiValExportItem dflags t doc $ M.lookup t fixMap
+          export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap
           return [export]
         (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
           let declNames = getMainDeclBinder (unL decl)
@@ -577,7 +581,7 @@ mkExportItems
     mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
     mkExportDecl name decl (doc, subs) = decl'
       where
-        decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities
+        decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False
         mdl = nameModule name
         subs' = filter (isExported . fst) subs
         sub_names = map fst subs'
@@ -608,12 +612,12 @@ hiDecl dflags t = do
     Just x -> return (Just (tyThingToLHsDecl x))
 
 
-hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
-hiValExportItem dflags name doc fixity = do
+hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
+hiValExportItem dflags name doc splice fixity = do
   mayDecl <- hiDecl dflags name
   case mayDecl of
     Nothing -> return (ExportNoDecl name [])
-    Just decl -> return (ExportDecl decl doc [] [] fixities)
+    Just decl -> return (ExportDecl decl doc [] [] fixities splice)
   where
     fixities = case fixity of
       Just f  -> [(name, f)]
@@ -656,9 +660,10 @@ moduleExports :: Module           -- ^ Module A
               -> InstIfaceMap     -- ^ Interfaces in other packages
               -> Maps
               -> FixMap
+              -> [SrcSpan]        -- ^ Locations of all TH splices
               -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
-moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap
-  | m == thisMod = fullModuleContents dflags warnings gre maps fixMap decls
+moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices
+  | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls
   | otherwise =
     case M.lookup m ifaceMap of
       Just iface
@@ -696,9 +701,9 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
 -- (For more information, see Trac #69)
 
 
-fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap
+fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan]
                    -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
-fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap decls =
+fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =
   liftM catMaybes $ mapM mkExportItem (expandSig decls)
   where
     -- A type signature can have multiple names, like:
@@ -721,20 +726,20 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
     mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
       mbDoc <- liftErrMsg $ processDocStringParas dflags gre docStr
       return $ fmap ExportDoc mbDoc
-    mkExportItem (L _ (ValD d))
+    mkExportItem (L l (ValD d))
       | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
           -- Top-level binding without type signature.
           let (doc, _) = lookupDocs name warnings docMap argMap subMap in
-          fmap Just (hiValExportItem dflags name doc $ M.lookup name fixMap)
+          fmap Just (hiValExportItem dflags name doc (l `elem` splices) $ M.lookup name fixMap)
       | otherwise = return Nothing
-    mkExportItem decl@(L _ (InstD d))
+    mkExportItem decl@(L l (InstD d))
       | Just name <- M.lookup (getInstLoc d) instMap =
         let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
-        return $ Just (ExportDecl decl doc subs [] (fixities name subs))
-    mkExportItem decl
-      | name:_ <- getMainDeclBinder (unLoc decl) =
+        return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
+    mkExportItem decl@(L l d)
+      | name:_ <- getMainDeclBinder d =
         let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
-        return $ Just (ExportDecl decl doc subs [] (fixities name subs))
+        return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
       | otherwise = return Nothing
 
     fixities name subs = [ (n,f) | n <- name : map fst subs
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 4bf39dfb..a5cde195 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -477,7 +477,7 @@ renameExportItem item = case item of
   ExportGroup lev id_ doc -> do
     doc' <- renameDoc doc
     return (ExportGroup lev id_ doc')
-  ExportDecl decl doc subs instances fixities -> do
+  ExportDecl decl doc subs instances fixities splice -> do
     decl' <- renameLDecl decl
     doc'  <- renameDocForDecl doc
     subs' <- mapM renameSub subs
@@ -488,7 +488,7 @@ renameExportItem item = case item of
     fixities' <- forM fixities $ \(name, fixity) -> do
       name' <- lookupRn name
       return (name', fixity)
-    return (ExportDecl decl' doc' subs' instances' fixities')
+    return (ExportDecl decl' doc' subs' instances' fixities' splice)
   ExportNoDecl x subs -> do
     x'    <- lookupRn x
     subs' <- mapM lookupRn subs
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 2e10827e..b166de46 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -51,9 +51,10 @@ data Flag
   | Flag_Lib String
   | Flag_OutputDir FilePath
   | Flag_Prologue FilePath
-  | Flag_SourceBaseURL   String
-  | Flag_SourceModuleURL String
-  | Flag_SourceEntityURL String
+  | Flag_SourceBaseURL    String
+  | Flag_SourceModuleURL  String
+  | Flag_SourceEntityURL  String
+  | Flag_SourceLEntityURL String
   | Flag_WikiBaseURL   String
   | Flag_WikiModuleURL String
   | Flag_WikiEntityURL String
@@ -114,6 +115,8 @@ options backwardsCompat =
       "URL for a source code link for each module\n(using the %{FILE} or %{MODULE} vars)",
     Option []  ["source-entity"]  (ReqArg Flag_SourceEntityURL "URL")
       "URL for a source code link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)",
+    Option []  ["source-entity-line"] (ReqArg Flag_SourceLEntityURL "URL")
+      "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.",
     Option []  ["comments-base"]   (ReqArg Flag_WikiBaseURL "URL")
       "URL for a comments link on the contents\nand index pages",
     Option []  ["comments-module"]  (ReqArg Flag_WikiModuleURL "URL")
@@ -216,11 +219,12 @@ optCssFile :: [Flag] -> Maybe FilePath
 optCssFile flags = optLast [ str | Flag_CSS str <- flags ]
 
 
-sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)
+sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String)
 sourceUrls flags =
-  (optLast [str | Flag_SourceBaseURL   str <- flags]
-  ,optLast [str | Flag_SourceModuleURL str <- flags]
-  ,optLast [str | Flag_SourceEntityURL str <- flags])
+  (optLast [str | Flag_SourceBaseURL    str <- flags]
+  ,optLast [str | Flag_SourceModuleURL  str <- flags]
+  ,optLast [str | Flag_SourceEntityURL  str <- flags]
+  ,optLast [str | Flag_SourceLEntityURL str <- flags])
 
 
 wikiUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 24f9e040..179413ea 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -201,6 +201,10 @@ data ExportItem name
 
         -- | Fixity decls relevant to this declaration (including subordinates).
       , expItemFixities :: ![(name, Fixity)]
+
+        -- | Whether the ExportItem is from a TH splice or not, for generating
+        -- the appropriate type of Source link.
+      , expItemSpliced :: !Bool
       }
 
   -- | An exported entity for which we have no documentation (perhaps because it