diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/HaddockDB.hs | 18 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 109 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker.hs | 64 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 185 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 204 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 189 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs | 85 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs | 68 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 21 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml.hs | 3 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 173 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 12 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 89 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 21 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Themes.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 31 |
16 files changed, 1154 insertions, 120 deletions
diff --git a/haddock-api/src/Haddock/Backends/HaddockDB.hs b/haddock-api/src/Haddock/Backends/HaddockDB.hs index 1c248bfb..0bdc9057 100644 --- a/haddock-api/src/Haddock/Backends/HaddockDB.hs +++ b/haddock-api/src/Haddock/Backends/HaddockDB.hs @@ -40,7 +40,7 @@ ppIfaces mods where do_mod (Module mod, iface) = text "<sect1 id=\"sec-" <> text mod <> text "\">" - $$ text "<title><literal>" + $$ text "<title><literal>" <> text mod <> text "</literal></title>" $$ text "<indexterm><primary><literal>" @@ -50,10 +50,10 @@ ppIfaces mods $$ vcat (map (do_export mod) (eltsFM (iface_decls iface))) $$ text "</variablelist>" $$ text "</sect1>" - + do_export mod decl | (nm:_) <- declBinders decl = text "<varlistentry id=" <> ppLinkId mod nm <> char '>' - $$ text "<term><literal>" + $$ text "<term><literal>" <> do_decl decl <> text "</literal></term>" $$ text "<listitem>" @@ -63,11 +63,11 @@ ppIfaces mods $$ text "</varlistentry>" do_export _ _ = empty - do_decl (HsTypeSig _ [nm] ty _) + do_decl (HsTypeSig _ [nm] ty _) = ppHsName nm <> text " :: " <> ppHsType ty do_decl (HsTypeDecl _ nm args ty _) = hsep ([text "type", ppHsName nm ] - ++ map ppHsName args + ++ map ppHsName args ++ [equals, ppHsType ty]) do_decl (HsNewTypeDecl loc ctx nm args con drv _) = hsep ([text "data", ppHsName nm] -- data, not newtype @@ -87,7 +87,7 @@ ppHsConstr :: HsConDecl -> Doc ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) = ppHsName name <> (braces . hsep . punctuate comma . map ppField $ fieldList) -ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = +ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = hsep (ppHsName name : map ppHsBangType typeList) ppField (HsFieldDecl ns ty doc) @@ -100,7 +100,7 @@ ppHsBangType (HsUnBangedTy ty) = ppHsType ty ppHsContext :: HsContext -> Doc ppHsContext [] = empty -ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> +ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> hsep (map ppHsAType b)) context) ppHsType :: HsType -> Doc @@ -109,7 +109,7 @@ ppHsType (HsForAllType Nothing context htype) = ppHsType (HsForAllType (Just tvs) [] htype) = hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype]) ppHsType (HsForAllType (Just tvs) context htype) = - hsep (text "forall" : map ppHsName tvs ++ text "." : + hsep (text "forall" : map ppHsName tvs ++ text "." : ppHsContext context : text "=>" : [ppHsType htype]) ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b] ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t] @@ -135,7 +135,7 @@ ppHsQName (UnQual str) = ppHsName str ppHsQName n@(Qual (Module mod) str) | n == unit_con_name = ppHsName str | isSpecial str = ppHsName str - | otherwise + | otherwise = text "<link linkend=" <> ppLinkId mod str <> char '>' <> ppHsName str <> text "</link>" diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index e73192ed..a9bc9a8b 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -15,12 +15,15 @@ module Haddock.Backends.Hoogle ( ppHoogle ) where - +import BasicTypes (OverlapFlag(..), OverlapMode(..)) +import InstEnv (ClsInst(..)) import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) + import GHC import Outputable +import NameSet import Data.Char import Data.List @@ -88,18 +91,22 @@ dropComment (x:xs) = x : dropComment xs dropComment [] = [] -out :: Outputable a => DynFlags -> a -> String -out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr +outWith :: Outputable a => (SDoc -> String) -> a -> [Char] +outWith p = f . unwords . map (dropWhile isSpace) . lines . p . ppr where f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs f (x:xs) = x : f xs f [] = [] +out :: Outputable a => DynFlags -> a -> String +out dflags = outWith $ showSDocUnqual dflags operator :: String -> String operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" operator x = x +commaSeparate :: Outputable a => DynFlags -> [a] -> String +commaSeparate dflags = showSDocUnqual dflags . interpp'SP --------------------------------------------------------------------- -- How to print each export @@ -108,38 +115,84 @@ ppExport :: DynFlags -> ExportItem Name -> [String] ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemMbDoc = (dc, _) , expItemSubDocs = subdocs + , expItemFixities = fixities } = ppDocumentation dflags dc ++ f decl where f (TyClD d@DataDecl{}) = ppData dflags d subdocs f (TyClD d@SynDecl{}) = ppSynonym dflags d - f (TyClD d@ClassDecl{}) = ppClass dflags d - f (ForD (ForeignImport name typ _ _)) = pp_sig dflags [name] (hsSigType typ) - f (ForD (ForeignExport name typ _ _)) = pp_sig dflags [name] (hsSigType typ) - f (SigD sig) = ppSig dflags sig + f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs + f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)] + f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)] + f (SigD sig) = ppSig dflags sig ++ ppFixities f _ = [] + + ppFixities = concatMap (ppFixity dflags) fixities ppExport _ _ = [] +ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String] +ppSigWithDoc dflags (TypeSig names sig) subdocs + = concatMap mkDocSig names + where + mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n) + ++ [pp_sig dflags names (hsSigWcType sig)] + + getDoc :: Located Name -> [Documentation Name] + getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs) + +ppSigWithDoc _ _ _ = [] ppSig :: DynFlags -> Sig Name -> [String] -ppSig dflags (TypeSig names sig) = pp_sig dflags names (hsSigWcType sig) -ppSig _ _ = [] +ppSig dflags x = ppSigWithDoc dflags x [] -pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> [String] -pp_sig dflags names (L _ typ) - = [operator prettyNames ++ " :: " ++ outHsType dflags typ] - where - prettyNames = intercalate ", " $ map (out dflags) names +pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> String +pp_sig dflags names (L _ typ) = + operator prettyNames ++ " :: " ++ outHsType dflags typ + where + prettyNames = intercalate ", " $ map (out dflags) names -- note: does not yet output documentation for class methods -ppClass :: DynFlags -> TyClDecl Name -> [String] -ppClass dflags x = out dflags x{tcdSigs=[]} : - concatMap (ppSig dflags . unL . add_ctxt) (tcdSigs x) - where - add_ctxt = addClassContext (tcdName x) (tyClDeclTyVars x) +ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] +ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods + where -ppInstance :: DynFlags -> ClsInst -> [String] -ppInstance dflags x = [dropComment $ out dflags x] + ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl + ppSig' = flip (ppSigWithDoc dflags) subdocs + add_ctxt = addClassContext (tcdName decl) (tyClDeclTyVars decl) + + ppTyFams + | null $ tcdATs decl = "" + | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat + [ map ppr (tcdATs decl) + , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl) + ] + + whereWrapper elems = vcat' + [ text "where" <+> lbrace + , nest 4 . vcat . map (<> semi) $ elems + , rbrace + ] + + tyFamEqnToSyn :: TyFamDefltEqn Name -> TyClDecl Name + tyFamEqnToSyn tfe = SynDecl + { tcdLName = tfe_tycon tfe + , tcdTyVars = tfe_pats tfe + , tcdRhs = tfe_rhs tfe + , tcdFVs = emptyNameSet + } + + +ppInstance :: DynFlags -> ClsInst -> [String] +ppInstance dflags x = + [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls] + where + -- As per #168, we don't want safety information about the class + -- in Hoogle output. The easiest way to achieve this is to set the + -- safety information to a state where the Outputable instance + -- produces no output which means no overlap and unsafe (or [safe] + -- is generated). + cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap mempty + , isSafeOverlap = False } } ppSynonym :: DynFlags -> TyClDecl Name -> [String] ppSynonym dflags x = [out dflags x] @@ -181,7 +234,10 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} apps = foldl1 (\x y -> reL $ HsAppTy x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) - name = out dflags $ map unL $ getConNames con + + -- We print the constructors as comma-separated list. See GHC + -- docs for con_names on why it is a list to begin with. + name = commaSeparate dflags . map unL $ getConNames con resType = apps $ map (reL . HsTyVar . reL) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] @@ -195,6 +251,10 @@ ppCtor dflags _dat subdocs con@ConDeclGADT {} name = out dflags $ map unL $ getConNames con +ppFixity :: DynFlags -> (Name, Fixity) -> [String] +ppFixity dflags (name, fixity) = [out dflags (FixitySig [noLoc name] fixity)] + + --------------------------------------------------------------------- -- DOCUMENTATION @@ -323,3 +383,8 @@ escape = concatMap f f '>' = ">" f '&' = "&" f x = [x] + + +-- | Just like 'vcat' but uses '($+$)' instead of '($$)'. +vcat' :: [SDoc] -> SDoc +vcat' = foldr ($+$) empty diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs new file mode 100644 index 00000000..248a8a54 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -0,0 +1,64 @@ +module Haddock.Backends.Hyperlinker + ( ppHyperlinkedSource + , module Haddock.Backends.Hyperlinker.Types + , module Haddock.Backends.Hyperlinker.Utils + ) where + + +import Haddock.Types +import Haddock.Backends.Hyperlinker.Renderer +import Haddock.Backends.Hyperlinker.Types +import Haddock.Backends.Hyperlinker.Utils + +import Text.XHtml hiding ((</>)) + +import Data.Maybe +import System.Directory +import System.FilePath + + +-- | Generate hyperlinked source for given interfaces. +-- +-- Note that list of interfaces should also contain interfaces normally hidden +-- when generating documentation. Otherwise this could lead to dead links in +-- produced source. +ppHyperlinkedSource :: FilePath -- ^ Output directory + -> FilePath -- ^ Resource directory + -> Maybe FilePath -- ^ Custom CSS file path + -> Bool -- ^ Flag indicating whether to pretty-print HTML + -> SrcMap -- ^ Paths to sources + -> [Interface] -- ^ Interfaces for which we create source + -> IO () +ppHyperlinkedSource outdir libdir mstyle pretty srcs ifaces = do + createDirectoryIfMissing True srcdir + let cssFile = fromMaybe (defaultCssFile libdir) mstyle + copyFile cssFile $ srcdir </> srcCssFile + copyFile (libdir </> "html" </> highlightScript) $ + srcdir </> highlightScript + mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces + where + srcdir = outdir </> hypSrcDir + +-- | Generate hyperlinked source for particular interface. +ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMap -> Interface + -> IO () +ppHyperlinkedModuleSource srcdir pretty srcs iface = + case ifaceTokenizedSrc iface of + Just tokens -> writeFile path . html . render' $ tokens + Nothing -> return () + where + render' = render (Just srcCssFile) (Just highlightScript) srcs + html = if pretty then renderHtml else showHtml + path = srcdir </> hypSrcModuleFile (ifaceMod iface) + +-- | Name of CSS file in output directory. +srcCssFile :: FilePath +srcCssFile = "style.css" + +-- | Name of highlight script in output and resource directory. +highlightScript :: FilePath +highlightScript = "highlight.js" + +-- | Path to default CSS file. +defaultCssFile :: FilePath -> FilePath +defaultCssFile libdir = libdir </> "html" </> "solarized.css" diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs new file mode 100644 index 00000000..1f396df5 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + + +module Haddock.Backends.Hyperlinker.Ast (enrich) where + + +import Haddock.Syb +import Haddock.Backends.Hyperlinker.Types + +import qualified GHC + +import Control.Applicative +import Data.Data +import Data.Maybe + + +-- | Add more detailed information to token stream using GHC API. +enrich :: GHC.RenamedSource -> [Token] -> [RichToken] +enrich src = + map $ \token -> RichToken + { rtkToken = token + , rtkDetails = enrichToken token detailsMap + } + where + detailsMap = concatMap ($ src) + [ variables + , types + , decls + , binds + , imports + ] + +-- | A map containing association between source locations and "details" of +-- this location. +-- +-- For the time being, it is just a list of pairs. However, looking up things +-- in such structure has linear complexity. We cannot use any hashmap-like +-- stuff because source locations are not ordered. In the future, this should +-- be replaced with interval tree data structure. +type DetailsMap = [(GHC.SrcSpan, TokenDetails)] + +lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails +lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst) + +enrichToken :: Token -> DetailsMap -> Maybe TokenDetails +enrichToken (Token typ _ spn) dm + | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm +enrichToken _ _ = Nothing + +-- | Obtain details map for variables ("normally" used identifiers). +variables :: GHC.RenamedSource -> DetailsMap +variables = + everything (<|>) (var `combine` rec) + where + var term = case cast term of + (Just (GHC.L sspan (GHC.HsVar name))) -> + pure (sspan, RtkVar (GHC.unLoc name)) + (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) -> + pure (sspan, RtkVar name) + _ -> empty + rec term = case cast term of + Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.Name) _) -> + pure (sspan, RtkVar name) + _ -> empty + +-- | Obtain details map for types. +types :: GHC.RenamedSource -> DetailsMap +types = + everything (<|>) ty + where + ty term = case cast term of + (Just (GHC.L sspan (GHC.HsTyVar name))) -> + pure (sspan, RtkType (GHC.unLoc name)) + _ -> empty + +-- | Obtain details map for identifier bindings. +-- +-- That includes both identifiers bound by pattern matching or declared using +-- ordinary assignment (in top-level declarations, let-expressions and where +-- clauses). +binds :: GHC.RenamedSource -> DetailsMap +binds = + everything (<|>) (fun `combine` pat `combine` tvar) + where + fun term = case cast term of + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) -> + pure (sspan, RtkBind name) + _ -> empty + pat term = case cast term of + (Just (GHC.L sspan (GHC.VarPat name))) -> + pure (sspan, RtkBind (GHC.unLoc name)) + (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> + [(sspan, RtkVar name)] ++ everything (<|>) rec recs + (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) -> + pure (sspan, RtkBind name) + _ -> empty + rec term = case cast term of + (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) -> + pure (sspan, RtkVar name) + _ -> empty + tvar term = case cast term of + (Just (GHC.L sspan (GHC.UserTyVar name))) -> + pure (sspan, RtkBind (GHC.unLoc name)) + (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) -> + pure (sspan, RtkBind name) + _ -> empty + +-- | Obtain details map for top-level declarations. +decls :: GHC.RenamedSource -> DetailsMap +decls (group, _, _, _) = concatMap ($ group) + [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds + , everything (<|>) fun . GHC.hs_valds + , everything (<|>) (con `combine` ins) + ] + where + typ (GHC.L _ t) = case t of + GHC.DataDecl name _ _ _ -> pure . decl $ name + GHC.SynDecl name _ _ _ -> pure . decl $ name + GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam + GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs + fun term = case cast term of + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) + | GHC.isExternalName name -> pure (sspan, RtkDecl name) + _ -> empty + con term = case cast term of + (Just cdcl) -> + map decl (GHC.con_names cdcl) ++ everything (<|>) fld cdcl + Nothing -> empty + ins term = case cast term of + (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst + (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) -> + pure . tyref $ GHC.tfe_tycon eqn + _ -> empty + fld term = case cast term of + Just (field :: GHC.ConDeclField GHC.Name) + -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field + Nothing -> empty + sig (GHC.L _ (GHC.TypeSig names _)) = map decl names + sig _ = [] + decl (GHC.L sspan name) = (sspan, RtkDecl name) + tyref (GHC.L sspan name) = (sspan, RtkType name) + +-- | Obtain details map for import declarations. +-- +-- This map also includes type and variable details for items in export and +-- import lists. +imports :: GHC.RenamedSource -> DetailsMap +imports src@(_, imps, _, _) = + everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps + where + ie term = case cast term of + (Just (GHC.IEVar v)) -> pure $ var v + (Just (GHC.IEThingAbs t)) -> pure $ typ t + (Just (GHC.IEThingAll t)) -> pure $ typ t + (Just (GHC.IEThingWith t _ vs _fls)) -> + [typ t] ++ map var vs + _ -> empty + typ (GHC.L sspan name) = (sspan, RtkType name) + var (GHC.L sspan name) = (sspan, RtkVar name) + imp idecl | not . GHC.ideclImplicit $ idecl = + let (GHC.L sspan name) = GHC.ideclName idecl + in Just (sspan, RtkModule name) + imp _ = Nothing + +-- | Check whether token stream span matches GHC source span. +-- +-- Currently, it is implemented as checking whether "our" span is contained +-- in GHC span. The reason for that is because GHC span are generally wider +-- and may spread across couple tokens. For example, @(>>=)@ consists of three +-- tokens: @(@, @>>=@, @)@, but GHC source span associated with @>>=@ variable +-- contains @(@ and @)@. Similarly, qualified identifiers like @Foo.Bar.quux@ +-- are tokenized as @Foo@, @.@, @Bar@, @.@, @quux@ but GHC source span +-- associated with @quux@ contains all five elements. +matches :: Span -> GHC.SrcSpan -> Bool +matches tspan (GHC.RealSrcSpan aspan) + | saspan <= stspan && etspan <= easpan = True + where + stspan = (posRow . spStart $ tspan, posCol . spStart $ tspan) + etspan = (posRow . spEnd $ tspan, posCol . spEnd $ tspan) + saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan) + easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan) +matches _ _ = False diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs new file mode 100644 index 00000000..e206413e --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -0,0 +1,204 @@ +module Haddock.Backends.Hyperlinker.Parser (parse) where + + +import Data.Char +import Data.List +import Data.Maybe + +import Haddock.Backends.Hyperlinker.Types + + +-- | Turn source code string into a stream of more descriptive tokens. +-- +-- Result should retain original file layout (including comments, whitespace, +-- etc.), i.e. the following "law" should hold: +-- +-- @concat . map 'tkValue' . 'parse' = id@ +parse :: String -> [Token] +parse = tokenize . tag . chunk + +-- | Split raw source string to more meaningful chunks. +-- +-- This is the initial stage of tokenization process. Each chunk is either +-- a comment (including comment delimiters), a whitespace string, preprocessor +-- macro (and all its content until the end of a line) or valid Haskell lexeme. +chunk :: String -> [String] +chunk [] = [] +chunk str@(c:_) + | isSpace c = + let (space, mcpp, rest) = spanSpaceOrCpp str + in [space] ++ maybeToList mcpp ++ chunk rest +chunk str + | "--" `isPrefixOf` str = chunk' $ spanToNewline str + | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str + | otherwise = case lex str of + (tok:_) -> chunk' tok + [] -> [str] + where + chunk' (c, rest) = c:(chunk rest) + +-- | Split input to "first line" string and the rest of it. +-- +-- Ideally, this should be done simply with @'break' (== '\n')@. However, +-- Haskell also allows line-unbreaking (or whatever it is called) so things +-- are not as simple and this function deals with that. +spanToNewline :: String -> (String, String) +spanToNewline [] = ([], []) +spanToNewline ('\\':'\n':str) = + let (str', rest) = spanToNewline str + in ('\\':'\n':str', rest) +spanToNewline str@('\n':_) = ("", str) +spanToNewline (c:str) = + let (str', rest) = spanToNewline str + in (c:str', rest) + +-- | Split input to whitespace string, (optional) preprocessor directive and +-- the rest of it. +-- +-- Again, using something like @'span' 'isSpace'@ would be nice to chunk input +-- to whitespace. The problem is with /#/ symbol - if it is placed at the very +-- beginning of a line, it should be recognized as preprocessor macro. In any +-- other case, it is ordinary Haskell symbol and can be used to declare +-- operators. Hence, while dealing with whitespace we also check whether there +-- happens to be /#/ symbol just after a newline character - if that is the +-- case, we begin treating the whole line as preprocessor macro. +spanSpaceOrCpp :: String -> (String, Maybe String, String) +spanSpaceOrCpp ('\n':'#':str) = + let (str', rest) = spanToNewline str + in ("\n", Just $ '#':str', rest) +spanSpaceOrCpp (c:str') + | isSpace c = + let (space, mcpp, rest) = spanSpaceOrCpp str' + in (c:space, mcpp, rest) +spanSpaceOrCpp str = ("", Nothing, str) + +-- | Split input to comment content (including delimiters) and the rest. +-- +-- Again, some more logic than simple 'span' is required because of Haskell +-- comment nesting policy. +chunkComment :: Int -> String -> (String, String) +chunkComment _ [] = ("", "") +chunkComment depth ('{':'-':str) = + let (c, rest) = chunkComment (depth + 1) str + in ("{-" ++ c, rest) +chunkComment depth ('-':'}':str) + | depth == 1 = ("-}", str) + | otherwise = + let (c, rest) = chunkComment (depth - 1) str + in ("-}" ++ c, rest) +chunkComment depth (e:str) = + let (c, rest) = chunkComment depth str + in (e:c, rest) + +-- | Assign source location for each chunk in given stream. +tag :: [String] -> [(Span, String)] +tag = + reverse . snd . foldl aux (Position 1 1, []) + where + aux (pos, cs) str = + let pos' = foldl move pos str + in (pos', (Span pos pos', str):cs) + move pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 } + move pos _ = pos { posCol = posCol pos + 1 } + +-- | Turn unrecognised chunk stream to more descriptive token stream. +tokenize :: [(Span, String)] -> [Token] +tokenize = + map aux + where + aux (sp, str) = Token + { tkType = classify str + , tkValue = str + , tkSpan = sp + } + +-- | Classify given string as appropriate Haskell token. +-- +-- This method is based on Haskell 98 Report lexical structure description: +-- https://www.haskell.org/onlinereport/lexemes.html +-- +-- However, this is probably far from being perfect and most probably does not +-- handle correctly all corner cases. +classify :: String -> TokenType +classify str + | "--" `isPrefixOf` str = TkComment + | "{-#" `isPrefixOf` str = TkPragma + | "{-" `isPrefixOf` str = TkComment +classify str@(c:_) + | isSpace c = TkSpace + | isDigit c = TkNumber + | c `elem` special = TkSpecial + | str `elem` glyphs = TkGlyph + | all (`elem` symbols) str = TkOperator + | c == '#' = TkCpp + | c == '"' = TkString + | c == '\'' = TkChar +classify str + | str `elem` keywords = TkKeyword + | isIdentifier str = TkIdentifier + | otherwise = TkUnknown + +keywords :: [String] +keywords = + [ "as" + , "case" + , "class" + , "data" + , "default" + , "deriving" + , "do" + , "else" + , "hiding" + , "if" + , "import" + , "in" + , "infix" + , "infixl" + , "infixr" + , "instance" + , "let" + , "module" + , "newtype" + , "of" + , "qualified" + , "then" + , "type" + , "where" + , "forall" + , "family" + , "mdo" + ] + +glyphs :: [String] +glyphs = + [ ".." + , ":" + , "::" + , "=" + , "\\" + , "|" + , "<-" + , "->" + , "@" + , "~" + , "~#" + , "=>" + , "-" + , "!" + ] + +special :: [Char] +special = "()[]{},;`" + +-- TODO: Add support for any Unicode symbol or punctuation. +-- source: http://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators +symbols :: [Char] +symbols = "!#$%&*+./<=>?@\\^|-~:" + +isIdentifier :: String -> Bool +isIdentifier (s:str) + | (isLower' s || isUpper s) && all isAlphaNum' str = True + where + isLower' c = isLower c || c == '_' + isAlphaNum' c = isAlphaNum c || c == '_' || c == '\'' +isIdentifier _ = False diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs new file mode 100644 index 00000000..15793f0c --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE RecordWildCards #-} + + +module Haddock.Backends.Hyperlinker.Renderer (render) where + + +import Haddock.Backends.Hyperlinker.Types +import Haddock.Backends.Hyperlinker.Utils + +import qualified GHC +import qualified Name as GHC +import qualified Unique as GHC + +import System.FilePath.Posix ((</>)) + +import Data.List +import Data.Maybe +import Data.Monoid +import qualified Data.Map as Map + +import Text.XHtml (Html, HtmlAttr, (!)) +import qualified Text.XHtml as Html + + +type StyleClass = String + + +render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken] + -> Html +render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens + + +data TokenGroup + = GrpNormal Token + | GrpRich TokenDetails [Token] + + +-- | Group consecutive tokens pointing to the same element. +-- +-- We want to render qualified identifiers as one entity. For example, +-- @Bar.Baz.foo@ consists of 5 tokens (@Bar@, @.@, @Baz@, @.@, @foo@) but for +-- better user experience when highlighting and clicking links, these tokens +-- should be regarded as one identifier. Therefore, before rendering we must +-- group consecutive elements pointing to the same 'GHC.Name' (note that even +-- dot token has it if it is part of qualified name). +groupTokens :: [RichToken] -> [TokenGroup] +groupTokens [] = [] +groupTokens ((RichToken tok Nothing):rest) = (GrpNormal tok):(groupTokens rest) +groupTokens ((RichToken tok (Just det)):rest) = + let (grp, rest') = span same rest + in (GrpRich det (tok:(map rtkToken grp))):(groupTokens rest') + where + same (RichToken _ (Just det')) = det == det' + same _ = False + + +body :: SrcMap -> [RichToken] -> Html +body srcs tokens = + Html.body . Html.pre $ hypsrc + where + hypsrc = mconcat . map (tokenGroup srcs) . groupTokens $ tokens + + +header :: Maybe FilePath -> Maybe FilePath -> Html +header mcss mjs + | isNothing mcss && isNothing mjs = Html.noHtml +header mcss mjs = + Html.header $ css mcss <> js mjs + where + css Nothing = Html.noHtml + css (Just cssFile) = Html.thelink Html.noHtml ! + [ Html.rel "stylesheet" + , Html.thetype "text/css" + , Html.href cssFile + ] + js Nothing = Html.noHtml + js (Just scriptFile) = Html.script Html.noHtml ! + [ Html.thetype "text/javascript" + , Html.src scriptFile + ] + + +tokenGroup :: SrcMap -> TokenGroup -> Html +tokenGroup _ (GrpNormal tok@(Token { .. })) + | tkType == TkSpace = renderSpace (posRow . spStart $ tkSpan) tkValue + | otherwise = tokenSpan tok ! attrs + where + attrs = [ multiclass . tokenStyle $ tkType ] +tokenGroup srcs (GrpRich det tokens) = + externalAnchor det . internalAnchor det . hyperlink srcs det $ content + where + content = mconcat . map (richToken det) $ tokens + + +richToken :: TokenDetails -> Token -> Html +richToken det tok = + tokenSpan tok ! [ multiclass style ] + where + style = (tokenStyle . tkType) tok ++ richTokenStyle det + + +tokenSpan :: Token -> Html +tokenSpan = Html.thespan . Html.toHtml . tkValue + + +richTokenStyle :: TokenDetails -> [StyleClass] +richTokenStyle (RtkVar _) = ["hs-var"] +richTokenStyle (RtkType _) = ["hs-type"] +richTokenStyle _ = [] + +tokenStyle :: TokenType -> [StyleClass] +tokenStyle TkIdentifier = ["hs-identifier"] +tokenStyle TkKeyword = ["hs-keyword"] +tokenStyle TkString = ["hs-string"] +tokenStyle TkChar = ["hs-char"] +tokenStyle TkNumber = ["hs-number"] +tokenStyle TkOperator = ["hs-operator"] +tokenStyle TkGlyph = ["hs-glyph"] +tokenStyle TkSpecial = ["hs-special"] +tokenStyle TkSpace = [] +tokenStyle TkComment = ["hs-comment"] +tokenStyle TkCpp = ["hs-cpp"] +tokenStyle TkPragma = ["hs-pragma"] +tokenStyle TkUnknown = [] + +multiclass :: [StyleClass] -> HtmlAttr +multiclass = Html.theclass . intercalate " " + +externalAnchor :: TokenDetails -> Html -> Html +externalAnchor (RtkDecl name) content = + Html.anchor content ! [ Html.name $ externalAnchorIdent name ] +externalAnchor _ content = content + +internalAnchor :: TokenDetails -> Html -> Html +internalAnchor (RtkBind name) content = + Html.anchor content ! [ Html.name $ internalAnchorIdent name ] +internalAnchor _ content = content + +externalAnchorIdent :: GHC.Name -> String +externalAnchorIdent = hypSrcNameUrl + +internalAnchorIdent :: GHC.Name -> String +internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique + +hyperlink :: SrcMap -> TokenDetails -> Html -> Html +hyperlink srcs details = case rtkName details of + Left name -> + if GHC.isInternalName name + then internalHyperlink name + else externalNameHyperlink srcs name + Right name -> externalModHyperlink srcs name + +internalHyperlink :: GHC.Name -> Html -> Html +internalHyperlink name content = + Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] + +externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html +externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of + Just SrcLocal -> Html.anchor content ! + [ Html.href $ hypSrcModuleNameUrl mdl name ] + Just (SrcExternal path) -> Html.anchor content ! + [ Html.href $ path </> hypSrcModuleNameUrl mdl name ] + Nothing -> content + where + mdl = GHC.nameModule name + +externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html +externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of + Just SrcLocal -> Html.anchor content ! + [ Html.href $ hypSrcModuleUrl' name ] + Just (SrcExternal path) -> Html.anchor content ! + [ Html.href $ path </> hypSrcModuleUrl' name ] + Nothing -> content + + +renderSpace :: Int -> String -> Html +renderSpace _ [] = Html.noHtml +renderSpace line ('\n':rest) = mconcat + [ Html.thespan . Html.toHtml $ "\n" + , lineAnchor (line + 1) + , renderSpace (line + 1) rest + ] +renderSpace line space = + let (hspace, rest) = span (/= '\n') space + in (Html.thespan . Html.toHtml) hspace <> renderSpace line rest + + +lineAnchor :: Int -> Html +lineAnchor line = Html.anchor Html.noHtml ! [ Html.name $ hypSrcLineUrl line ] diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs new file mode 100644 index 00000000..5f4dbc8c --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -0,0 +1,85 @@ +module Haddock.Backends.Hyperlinker.Types where + + +import qualified GHC + +import Data.Map (Map) +import qualified Data.Map as Map + + +data Token = Token + { tkType :: TokenType + , tkValue :: String + , tkSpan :: Span + } + +data Position = Position + { posRow :: !Int + , posCol :: !Int + } + +data Span = Span + { spStart :: Position + , spEnd :: Position + } + +data TokenType + = TkIdentifier + | TkKeyword + | TkString + | TkChar + | TkNumber + | TkOperator + | TkGlyph + | TkSpecial + | TkSpace + | TkComment + | TkCpp + | TkPragma + | TkUnknown + deriving (Show, Eq) + + +data RichToken = RichToken + { rtkToken :: Token + , rtkDetails :: Maybe TokenDetails + } + +data TokenDetails + = RtkVar GHC.Name + | RtkType GHC.Name + | RtkBind GHC.Name + | RtkDecl GHC.Name + | RtkModule GHC.ModuleName + deriving (Eq) + + +rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName +rtkName (RtkVar name) = Left name +rtkName (RtkType name) = Left name +rtkName (RtkBind name) = Left name +rtkName (RtkDecl name) = Left name +rtkName (RtkModule name) = Right name + + +-- | Path for making cross-package hyperlinks in generated sources. +-- +-- Used in 'SrcMap' to determine whether module originates in current package +-- or in an external package. +data SrcPath + = SrcExternal FilePath + | SrcLocal + +-- | Mapping from modules to cross-package source paths. +-- +-- This mapping is actually a pair of maps instead of just one map. The reason +-- for this is because when hyperlinking modules in import lists we have no +-- 'GHC.Module' available. On the other hand, we can't just use map with +-- 'GHC.ModuleName' as indices because certain modules may have common name +-- but originate in different packages. Hence, we use both /rich/ and /poor/ +-- versions, where the /poor/ is just projection of /rich/ one cached in pair +-- for better performance. +type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath) + +mkSrcMap :: Map GHC.Module SrcPath -> SrcMap +mkSrcMap srcs = (srcs, Map.mapKeys GHC.moduleName srcs) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs new file mode 100644 index 00000000..9de4a03d --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -0,0 +1,68 @@ +module Haddock.Backends.Hyperlinker.Utils + ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile' + , hypSrcModuleUrl, hypSrcModuleUrl' + , hypSrcNameUrl + , hypSrcLineUrl + , hypSrcModuleNameUrl, hypSrcModuleLineUrl + , hypSrcModuleUrlFormat + , hypSrcModuleNameUrlFormat, hypSrcModuleLineUrlFormat + ) where + + +import Haddock.Backends.Xhtml.Utils + +import GHC +import FastString +import System.FilePath.Posix ((</>)) + + +hypSrcDir :: FilePath +hypSrcDir = "src" + +hypSrcModuleFile :: Module -> FilePath +hypSrcModuleFile = hypSrcModuleFile' . moduleName + +hypSrcModuleFile' :: ModuleName -> FilePath +hypSrcModuleFile' mdl = spliceURL' + Nothing (Just mdl) Nothing Nothing moduleFormat + +hypSrcModuleUrl :: Module -> String +hypSrcModuleUrl = hypSrcModuleFile + +hypSrcModuleUrl' :: ModuleName -> String +hypSrcModuleUrl' = hypSrcModuleFile' + +hypSrcNameUrl :: Name -> String +hypSrcNameUrl name = spliceURL + Nothing Nothing (Just name) Nothing nameFormat + +hypSrcLineUrl :: Int -> String +hypSrcLineUrl line = spliceURL + Nothing Nothing Nothing (Just spn) lineFormat + where + loc = mkSrcLoc nilFS line 1 + spn = mkSrcSpan loc loc + +hypSrcModuleNameUrl :: Module -> Name -> String +hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name + +hypSrcModuleLineUrl :: Module -> Int -> String +hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line + +hypSrcModuleUrlFormat :: String +hypSrcModuleUrlFormat = hypSrcDir </> moduleFormat + +hypSrcModuleNameUrlFormat :: String +hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat + +hypSrcModuleLineUrlFormat :: String +hypSrcModuleLineUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ lineFormat + +moduleFormat :: String +moduleFormat = "%{MODULE}.html" + +nameFormat :: String +nameFormat = "%{NAME}" + +lineFormat :: String +lineFormat = "line-%{LINE}" diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index e9cc3f83..ab6bb41c 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.LaTeX @@ -24,10 +25,9 @@ import qualified Pretty import GHC import OccName import Name ( nameOccName ) -import RdrName ( rdrNameOcc, mkRdrUnqual ) +import RdrName ( rdrNameOcc ) import FastString ( unpackFS, unpackLitString, zString ) import Outputable ( panic) -import PrelNames ( mkUnboundName ) import qualified Data.Map as Map import System.Directory @@ -528,14 +528,14 @@ ppDocInstances unicode (i : rest) (is, rest') = spanWith isUndocdInstance rest isUndocdInstance :: DocInstance a -> Maybe (InstHead a) -isUndocdInstance (i,Nothing) = Just i +isUndocdInstance (i,Nothing,_) = Just i isUndocdInstance _ = Nothing -- | Print a possibly commented instance. The instance header is printed inside -- an 'argBox'. The comment is printed to the right of the box in normal comment -- style. ppDocInstance :: Bool -> DocInstance DocName -> LaTeX -ppDocInstance unicode (instHead, doc) = +ppDocInstance unicode (instHead, doc, _) = declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc) @@ -544,12 +544,13 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead ppInstHead :: Bool -> InstHead DocName -> LaTeX -ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode -ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type" - <+> ppAppNameTypes n ks ts unicode - <+> maybe empty (\t -> equals <+> ppType unicode t) rhs -ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) = - error "data instances not supported by --latex yet" +ppInstHead unicode (InstHead {..}) = case ihdInstType of + ClassInst ctx _ _ _ -> ppContextNoLocs ctx unicode <+> typ + TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs + DataInst _ -> error "data instances not supported by --latex yet" + where + typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode + tibody = maybe empty (\t -> equals <+> ppType unicode t) lookupAnySubdoc :: (Eq name1) => name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 31757eeb..1554a33c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -36,7 +36,6 @@ import Haddock.GhcUtils import Control.Monad ( when, unless ) import Data.Char ( toUpper ) -import Data.Functor ( (<$>) ) import Data.List ( sortBy, groupBy, intercalate, isPrefixOf ) import Data.Maybe import System.FilePath hiding ( (</>) ) @@ -547,7 +546,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual synopsis | no_doc_at_all = noHtml | otherwise - = divSynposis $ + = divSynopsis $ paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++ shortDeclList ( mapMaybe (processExport True linksInfo unicode qual) exports diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index d54f4e16..49149b8c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -1,4 +1,6 @@ {-# LANGUAGE TransformListComp #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Html.Decl @@ -18,7 +20,6 @@ module Haddock.Backends.Xhtml.Decl ( tyvarNames ) where - import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Layout import Haddock.Backends.Xhtml.Names @@ -28,7 +29,6 @@ import Haddock.GhcUtils import Haddock.Types import Haddock.Doc (combineDocumentation) -import Control.Applicative import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe @@ -38,8 +38,7 @@ import GHC import GHC.Exts import Name import BooleanFormula -import RdrName ( rdrNameOcc, mkRdrUnqual ) -import PrelNames ( mkUnboundName ) +import RdrName ( rdrNameOcc ) ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] @@ -220,11 +219,32 @@ ppTyName :: Name -> Html ppTyName = ppName Prefix +ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan + -> [DocName] -> HsType DocName + -> Html +ppSimpleSig links splice unicode qual loc names typ = + topDeclElem' names $ ppTypeSig True occNames ppTyp unicode + where + topDeclElem' = topDeclElem links loc splice + ppTyp = ppType unicode qual typ + occNames = map getOccName names + + -------------------------------------------------------------------------------- -- * Type families -------------------------------------------------------------------------------- +ppFamilyInfo :: Bool -> FamilyInfo DocName -> Html +ppFamilyInfo assoc OpenTypeFamily + | assoc = keyword "type" + | otherwise = keyword "type family" +ppFamilyInfo assoc DataFamily + | assoc = keyword "data" + | otherwise = keyword "data family" +ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family" + + ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Unicode -> Qualification -> Html ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info @@ -243,18 +263,25 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info ) <+> ppFamDeclBinderWithVars summary d <+> - - (case result of - NoSig -> noHtml - KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind - TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr - ) <+> + ppResultSig result unicode qual <+> (case injectivity of Nothing -> noHtml Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn ) +ppResultSig :: FamilyResultSig DocName -> Unicode -> Qualification -> Html +ppResultSig result unicode qual = case result of + NoSig -> noHtml + KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind + TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr + +ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName + -> Html +ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) = + ppFamilyInfo True pfdInfo <+> + ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+> + ppResultSig (unLoc pfdKindSig) unicode qual ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) = @@ -282,7 +309,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode = subEquations qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns | otherwise - = ppInstances instances docname unicode qual + = ppInstances links (OriginFamily docname) instances splice unicode qual -- Individual equation of a closed type family ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs @@ -291,6 +318,18 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode <+> equals <+> ppType unicode qual (unLoc rhs) , Nothing, [] ) + + +ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification + -> PseudoFamilyDecl DocName + -> Html +ppPseudoFamilyDecl links splice unicode qual + decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) = + wrapper $ ppPseudoFamilyHeader unicode qual decl + where + wrapper = topDeclElem links loc splice [name] + + -------------------------------------------------------------------------------- -- * Associated Types -------------------------------------------------------------------------------- @@ -450,6 +489,8 @@ ppClassDecl summary links instances fixities loc d subdocs | otherwise = classheader +++ docSection Nothing qual d +++ minimalBit +++ atBit +++ methodBit +++ instancesBit where + sigs = map unLoc lsigs + classheader | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) @@ -480,10 +521,10 @@ ppClassDecl summary links instances fixities loc d subdocs -- there are different subdocs for different names in a single -- type signature? - minimalBit = case [ s | L _ (MinimalSig _ (L _ s)) <- lsigs ] of + minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == - sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns] + sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method @@ -503,31 +544,93 @@ ppClassDecl summary links instances fixities loc d subdocs where wrap | p = parens | otherwise = id ppMinimal p (Parens x) = ppMinimal p (unLoc x) - instancesBit = ppInstances instances nm unicode qual + instancesBit = ppInstances links (OriginClass nm) instances + splice unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" -ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html -ppInstances instances baseName unicode qual - = subInstances qual instName (map instDecl instances) +ppInstances :: LinksInfo + -> InstOrigin DocName -> [DocInstance DocName] + -> Splice -> Unicode -> Qualification + -> Html +ppInstances links origin instances splice unicode qual + = subInstances qual instName links True (zipWith instDecl [1..] instances) + -- force Splice = True to use line URLs + where + instName = getOccString origin + instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) + instDecl no (inst, mdoc, loc) = + ((ppInstHead links splice unicode qual mdoc origin no inst), loc) + + +ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification + -> Maybe (MDoc DocName) + -> InstOrigin DocName -> Int -> InstHead DocName + -> SubDecl +ppInstHead links splice unicode qual mdoc origin no ihd@(InstHead {..}) = + case ihdInstType of + ClassInst { .. } -> + ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ + , mdoc + , [subInstDetails iid ats sigs] + ) + where + iid = instanceId origin no ihd + sigs = ppInstanceSigs links splice unicode qual clsiSigs + ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys + TypeInst rhs -> + (ptype, mdoc, []) + where + ptype = keyword "type" <+> typ <+> prhs + prhs = maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs + DataInst dd -> + (pdata, mdoc, []) + where + pdata = keyword "data" <+> typ <+> pdecl + pdecl = ppShortDataDecl False True dd unicode qual + where + typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual + + +ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification + -> [PseudoFamilyDecl DocName] + -> [Html] +ppInstanceAssocTys links splice unicode qual = + map ppFamilyDecl' where - instName = getOccString $ getName baseName - instDecl :: DocInstance DocName -> SubDecl - instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, []) - instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual - <+> ppAppNameTypes n ks ts unicode qual - instHead (n, ks, ts, TypeInst rhs) = keyword "type" - <+> ppAppNameTypes n ks ts unicode qual - <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs - instHead (n, ks, ts, DataInst dd) = keyword "data" - <+> ppAppNameTypes n ks ts unicode qual - <+> ppShortDataDecl False True dd unicode qual + ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual + + +ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification + -> [Sig DocName] + -> [Html] +ppInstanceSigs links splice unicode qual sigs = do + TypeSig lnames typ <- sigs + let names = map unLoc lnames + L loc rtyp = get_type typ + return $ ppSimpleSig links splice unicode qual loc names rtyp + where + get_type = hswc_body . hsib_body + lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n +instanceId :: InstOrigin DocName -> Int -> InstHead DocName -> String +instanceId origin no ihd = concat + [ qual origin + , ":" ++ getOccString origin + , ":" ++ (occNameString . getOccName . ihdClsName) ihd + , ":" ++ show no + ] + where + qual (OriginClass _) = "ic" + qual (OriginData _) = "id" + qual (OriginFamily _) = "if" + + ------------------------------------------------------------------------------- -- * Data & newtype declarations ------------------------------------------------------------------------------- @@ -595,7 +698,8 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl (map unLoc (getConNames (unLoc c)))) fixities ] - instancesBit = ppInstances instances docname unicode qual + instancesBit = ppInstances links (OriginData docname) instances + splice unicode qual @@ -862,8 +966,8 @@ ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}" -- placeholder in the signature, which is followed by the field -- declarations. ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys +ppr_mono_ty _ (HsExplicitListTy _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys +ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual @@ -878,7 +982,12 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual where - ppr_op = ppLDocName qual Infix op + -- `(:)` is valid in type signature only as constructor to promoted list + -- and needs to be quoted in code so we explicitly quote it here too. + ppr_op + | (getOccString . getName . unLoc) op == ":" = promoQuote ppr_op' + | otherwise = ppr_op' + ppr_op' = ppLDocName qual Infix op ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual -- = parens (ppr_mono_lty pREC_TOP ty) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 96d734eb..3fe74a82 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -19,8 +19,6 @@ module Haddock.Backends.Xhtml.DocMarkup ( docElement, docSection, docSection_, ) where -import Control.Applicative ((<$>)) - import Data.List import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils @@ -64,7 +62,10 @@ parHtmlMarkup qual insertAnchors ppId = Markup { then anchor ! [href url] << fromMaybe url mLabel else toHtml $ fromMaybe url mLabel, - markupAName = \aname -> namedAnchor aname << "", + markupAName = \aname + -> if insertAnchors + then namedAnchor aname << "" + else noHtml, markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)), markupProperty = pre . toHtml, markupExample = examplesToHtml, @@ -160,8 +161,9 @@ hackMarkup fmt' h' = UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) CollapsingHeader (Header lvl titl) par n nm -> let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n - col' = collapseControl id_ True "caption" - instTable = (thediv ! collapseSection id_ False [] <<) + expanded = False + col' = collapseControl id_ expanded "caption" + instTable = (thediv ! collapseSection id_ expanded [] <<) lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6] getHeader = fromMaybe caption (lookup lvl lvs) subCaption = getHeader ! col' << markup fmt titl diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index f1f109c5..d24ed9c4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -14,7 +14,7 @@ module Haddock.Backends.Xhtml.Layout ( miniBody, divPackageHeader, divContent, divModuleHeader, divFooter, - divTableOfContents, divDescription, divSynposis, divInterface, + divTableOfContents, divDescription, divSynopsis, divInterface, divIndex, divAlphabet, divModuleList, sectionName, @@ -31,7 +31,7 @@ module Haddock.Backends.Xhtml.Layout ( subConstructors, subEquations, subFields, - subInstances, + subInstances, subInstHead, subInstDetails, subMethods, subMinimal, @@ -44,7 +44,6 @@ import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.Types import Haddock.Utils (makeAnchorId) - import qualified Data.Map as Map import Text.XHtml hiding ( name, title, p, quote ) @@ -77,7 +76,7 @@ nonEmptySectionName c divPackageHeader, divContent, divModuleHeader, divFooter, - divTableOfContents, divDescription, divSynposis, divInterface, + divTableOfContents, divDescription, divSynopsis, divInterface, divIndex, divAlphabet, divModuleList :: Html -> Html @@ -87,7 +86,7 @@ divModuleHeader = sectionDiv "module-header" divFooter = sectionDiv "footer" divTableOfContents = sectionDiv "table-of-contents" divDescription = sectionDiv "description" -divSynposis = sectionDiv "synopsis" +divSynopsis = sectionDiv "synopsis" divInterface = sectionDiv "interface" divIndex = sectionDiv "index" divAlphabet = sectionDiv "alphabet" @@ -128,14 +127,12 @@ divSubDecls cssClass captionName = maybe noHtml wrap subDlist :: Qualification -> [SubDecl] -> Maybe Html subDlist _ [] = Nothing -subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv +subDlist qual decls = Just $ ulist << map subEntry decls where subEntry (decl, mdoc, subs) = - dterm ! [theclass "src"] << decl - +++ - docElement ddef << (fmap (docToHtml Nothing qual) mdoc +++ subs) - - clearDiv = thediv ! [ theclass "clear" ] << noHtml + li << + (define ! [theclass "src"] << decl +++ + docElement thediv << (fmap (docToHtml Nothing qual) mdoc +++ subs)) subTable :: Qualification -> [SubDecl] -> Maybe Html @@ -149,6 +146,22 @@ subTable qual decls = Just $ table << aboves (concatMap subRow decls) : map (cell . (td <<)) subs +-- | Sub table with source information (optional). +subTableSrc :: Qualification -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Maybe Html +subTableSrc _ _ _ [] = Nothing +subTableSrc qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) + where + subRow ((decl, mdoc, subs),L loc dn) = + (td ! [theclass "src clearfix"] << + (thespan ! [theclass "inst-left"] << decl) + <+> linkHtml loc dn + <-> + docElement td << fmap (docToHtml Nothing qual) mdoc + ) + : map (cell . (td <<)) subs + linkHtml loc@(RealSrcSpan _) dn = links lnks loc splice dn + linkHtml _ _ = noHtml + subBlock :: [Html] -> Maybe Html subBlock [] = Nothing subBlock hs = Just $ toHtml hs @@ -174,17 +187,43 @@ subEquations :: Qualification -> [SubDecl] -> Html subEquations qual = divSubDecls "equations" "Equations" . subTable qual +-- | Generate sub table for instance declarations, with source subInstances :: Qualification -> String -- ^ Class name, used for anchor generation - -> [SubDecl] -> Html -subInstances qual nm = maybe noHtml wrap . instTable + -> LinksInfo -> Bool + -> [(SubDecl,Located DocName)] -> Html +subInstances qual nm lnks splice = maybe noHtml wrap . instTable where wrap = (subSection <<) . (subCaption +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual + instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice subSection = thediv ! [theclass "subs instances"] subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" id_ = makeAnchorId $ "i:" ++ nm + +subInstHead :: String -- ^ Instance unique id (for anchor generation) + -> Html -- ^ Header content (instance name and type) + -> Html +subInstHead iid hdr = + expander noHtml <+> hdr + where + expander = thespan ! collapseControl (instAnchorId iid) False "instance" + + +subInstDetails :: String -- ^ Instance unique id (for anchor generation) + -> [Html] -- ^ Associated type contents + -> [Html] -- ^ Method contents (pretty-printed signatures) + -> Html +subInstDetails iid ats mets = + section << (subAssociatedTypes ats <+> subMethods mets) + where + section = thediv ! collapseSection (instAnchorId iid) False "inst-details" + + +instAnchorId :: String -> String +instAnchorId iid = makeAnchorId $ "i:" ++ iid + + subMethods :: [Html] -> Html subMethods = divSubDecls "methods" "Methods" . subBlock @@ -200,12 +239,19 @@ 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 -> Bool -> [DocName] -> Html -> Html -topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html = - declElem << (html <+> srcLink <+> wikiLink) +topDeclElem lnks loc splice names html = + declElem << (html <+> (links lnks loc splice $ head names)) + -- FIXME: is it ok to simply take the first name? + +-- | Adds a source and wiki link at the right hand side of the box. +-- Name must be documented, otherwise we wouldn't get here. +links :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html +links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice (Documented n mdl) = + (srcLink <+> wikiLink) where srcLink = let nameUrl = Map.lookup origPkg sourceMap lineUrl = Map.lookup origPkg lineMap mUrl | splice = lineUrl - -- Use the lineUrl as a backup + -- Use the lineUrl as a backup | otherwise = maybe lineUrl Just nameUrl in case mUrl of Nothing -> noHtml @@ -227,10 +273,7 @@ topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names htm origMod = nameModule n origPkg = moduleUnitId origMod - -- Name must be documented, otherwise we wouldn't get here - Documented n mdl = head names - -- FIXME: is it ok to simply take the first name? - fname = case loc of - RealSrcSpan l -> unpackFS (srcSpanFile l) - UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan" + RealSrcSpan l -> unpackFS (srcSpanFile l) + UnhelpfulSpan _ -> error "links: UnhelpfulSpan" +links _ _ _ _ = noHtml diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs index cf12da40..c69710d1 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -110,16 +110,21 @@ ppName notation name = wrapInfix notation (getOccName name) $ toHtml (getOccStri ppBinder :: Bool -> OccName -> Html --- The Bool indicates whether we are generating the summary, in which case --- the binder will be a link to the full definition. -ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' Prefix n -ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"] - << ppBinder' Prefix n +ppBinder = ppBinderWith Prefix ppBinderInfix :: Bool -> OccName -> Html -ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' Infix n -ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"] - << ppBinder' Infix n +ppBinderInfix = ppBinderWith Infix + +ppBinderWith :: Notation -> Bool -> OccName -> Html +-- 'isRef' indicates whether this is merely a reference from another part of +-- the documentation or is the actual definition; in the latter case, we also +-- set the 'id' and 'class' attributes. +ppBinderWith notation isRef n = + linkedAnchor name ! attributes << ppBinder' notation n + where + name = nameAnchorId n + attributes | isRef = [] + | otherwise = [identifier name, theclass "def"] ppBinder' :: Notation -> OccName -> Html ppBinder' notation n = wrapInfix notation n $ ppOccName n diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs index 79b093ec..10d6ab10 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs @@ -18,7 +18,6 @@ module Haddock.Backends.Xhtml.Themes ( import Haddock.Options -import Control.Applicative import Control.Monad (liftM) import Data.Char (toLower) import Data.Either (lefts, rights) @@ -206,4 +205,3 @@ liftEither f = either Left (Right . f) concatEither :: [Either a [b]] -> Either a [b] concatEither = liftEither concat . sequenceEither - diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index cbcbbd6d..98ff4007 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -14,14 +14,14 @@ module Haddock.Backends.Xhtml.Utils ( renderToString, namedAnchor, linkedAnchor, - spliceURL, + spliceURL, spliceURL', groupId, (<+>), (<=>), char, keyword, punctuate, braces, brackets, pabrackets, parens, parenList, ubxParenList, - arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, + arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote, hsep, vcat, @@ -29,7 +29,6 @@ module Haddock.Backends.Xhtml.Utils ( ) where -import Haddock.GhcUtils import Haddock.Utils import Data.Maybe @@ -38,18 +37,31 @@ import Text.XHtml hiding ( name, title, p, quote ) import qualified Text.XHtml as XHtml import GHC ( SrcSpan(..), srcSpanStartLine, Name ) -import Module ( Module ) +import Module ( Module, ModuleName, moduleName, moduleNameString ) import Name ( getOccString, nameOccName, isValOcc ) +-- | Replace placeholder string elements with provided values. +-- +-- Used to generate URL for customized external paths, usually provided with +-- @--source-module@, @--source-entity@ and related command-line arguments. +-- +-- >>> spliceURL Nothing mmod mname Nothing "output/%{MODULE}.hs#%{NAME}" +-- "output/Foo.hs#foo" spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> Maybe SrcSpan -> String -> String -spliceURL maybe_file maybe_mod maybe_name maybe_loc = run +spliceURL mfile mmod = spliceURL' mfile (moduleName <$> mmod) + + +-- | Same as 'spliceURL' but takes 'ModuleName' instead of 'Module'. +spliceURL' :: Maybe FilePath -> Maybe ModuleName -> Maybe GHC.Name -> + Maybe SrcSpan -> String -> String +spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run where file = fromMaybe "" maybe_file mdl = case maybe_mod of Nothing -> "" - Just m -> moduleString m + Just m -> moduleNameString m (name, kind) = case maybe_name of @@ -138,6 +150,11 @@ quote :: Html -> Html quote h = char '`' +++ h +++ '`' +-- | Promoted type quote (e.g. @'[a, b]@, @'(a, b, c)@). +promoQuote :: Html -> Html +promoQuote h = char '\'' +++ h + + parens, brackets, pabrackets, braces :: Html -> Html parens h = char '(' +++ h +++ char ')' brackets h = char '[' +++ h +++ char ']' @@ -203,7 +220,7 @@ collapseSection id_ state classes = [ identifier sid, theclass cs ] collapseToggle :: String -> [HtmlAttr] collapseToggle id_ = [ strAttr "onclick" js ] where js = "toggleSection('" ++ id_ ++ "')"; - + -- | Attributes for an area that toggles a collapsed area, -- and displays a control. collapseControl :: String -> Bool -> String -> [HtmlAttr] |