diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
17 files changed, 1452 insertions, 400 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 fe656a4b..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 @@ -64,7 +67,8 @@ dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) - f (HsForAllTy a b c d e) = HsForAllTy a b c d (g e) + f (HsForAllTy a e) = HsForAllTy a (g e) + f (HsQualTy a e) = HsQualTy a (g e) f (HsBangTy a b) = HsBangTy a (g b) f (HsAppTy a b) = HsAppTy (g a) (g b) f (HsFunTy a b) = HsFunTy (g a) (g b) @@ -81,32 +85,28 @@ outHsType :: OutputableBndr a => DynFlags -> HsType a -> String outHsType dflags = out dflags . dropHsDocTy -makeExplicit :: HsType a -> HsType a -makeExplicit (HsForAllTy _ a b c d) = HsForAllTy Explicit a b c d -makeExplicit x = x - -makeExplicitL :: LHsType a -> LHsType a -makeExplicitL (L src x) = L src (makeExplicit x) - - dropComment :: String -> String dropComment (' ':'-':'-':' ':_) = [] 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 @@ -115,49 +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 _ _)) = ppSig dflags $ TypeSig [name] typ [] - f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] 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 _) - = [operator prettyNames ++ " :: " ++ outHsType dflags typ] - where - prettyNames = intercalate ", " $ map (out dflags) names - typ = case unL sig of - HsForAllTy Explicit a b c d -> HsForAllTy Implicit a b c d - HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d - x -> x -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 -- note: does not yet output documentation for class methods -ppClass :: DynFlags -> TyClDecl Name -> [String] -ppClass dflags x = out dflags x{tcdSigs=[]} : - concatMap (ppSig dflags . addContext . unL) (tcdSigs x) +ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] +ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods where - addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs - addContext (MinimalSig src sig) = MinimalSig src sig - addContext _ = error "expected TypeSig" - f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d - f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t) + ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl + ppSig' = flip (ppSigWithDoc dflags) subdocs - context = nlHsTyConApp (tcdName x) - (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) + 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 $ out dflags x] +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] @@ -184,26 +219,40 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of _ -> [] ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] -ppCtor dflags dat subdocs con - = concatMap (lookupCon dflags subdocs) (con_names con) ++ f (con_details con) +ppCtor dflags dat subdocs con@ConDeclH98 {} + -- AZ:TODO get rid of the concatMap + = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat - [(concatMap (lookupCon dflags subdocs) (cd_fld_names r)) ++ - [out dflags (map unL $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] + [(concatMap (lookupCon dflags subdocs . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) ++ + [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) + funs = foldr1 (\x y -> reL $ HsFunTy x y) apps = foldl1 (\x y -> reL $ HsAppTy x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds) - name = out dflags $ map unL $ con_names con + typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) + + -- 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] + +ppCtor dflags _dat subdocs con@ConDeclGADT {} + = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f + where + f = [typeSig name (hsib_body $ con_type con)] + + typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) + name = out dflags $ map unL $ getConNames con - resType = case con_res con of - ResTyH98 -> apps $ map (reL . HsTyVar) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] - ResTyGADT _ x -> x + +ppFixity :: DynFlags -> (Name, Fixity) -> [String] +ppFixity dflags (name, fixity) = [out dflags (FixitySig [noLoc name] fixity)] --------------------------------------------------------------------- @@ -334,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..e8baae88 --- /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.getConNames 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 c9262c7e..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 @@ -212,9 +213,9 @@ processExports (e : es) = isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t) _)) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } - | Map.null argDocs = Just (map unLoc lnames, t) + | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing @@ -249,8 +250,8 @@ ppDocGroup lev doc = sec lev <> braces doc declNames :: LHsDecl DocName -> [DocName] declNames (L _ decl) = case decl of TyClD d -> [tcdName d] - SigD (TypeSig lnames _ _) -> map unLoc lnames - SigD (PatSynSig lname _ _ _ _) -> [unLoc lname] + SigD (TypeSig lnames _ ) -> map unLoc lnames + SigD (PatSynSig lname _) -> [unLoc lname] ForD (ForeignImport (L _ n) _ _ _) -> [n] ForD (ForeignExport (L _ n) _ _ _) -> [n] _ -> error "declaration not supported by declNames" @@ -292,10 +293,11 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of -- TyClD d@(TySynonym {}) -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now - TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode - SigD (TypeSig lnames (L _ t) _) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode - SigD (PatSynSig lname qtvs prov req ty) -> - ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode + TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode + SigD (TypeSig lnames t) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) + (hsSigWcType t) unicode + SigD (PatSynSig lname ty) -> + ppLPatSig loc (doc, fnArgsDoc) lname ty unicode ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty _ -> error "declaration not supported by ppDecl" @@ -310,8 +312,8 @@ ppTyFam _ _ _ _ _ = ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX -ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode = - ppFunSig loc doc [name] typ unicode +ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode = + ppFunSig loc doc [name] (hsSigType typ) unicode ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -328,7 +330,9 @@ ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode where - hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars) + hdr = hsep (keyword "type" + : ppDocBinder name + : map ppSymName (tyvarNames ltyvars)) full = hdr <+> char '=' <+> ppLType unicode ltype ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" @@ -339,9 +343,9 @@ ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- -ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName +ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocName -> Bool -> LaTeX -ppFunSig loc doc docnames typ unicode = +ppFunSig loc doc docnames (L _ typ) unicode = ppTypeOrFunSig loc docnames typ doc ( ppTypeSig names typ False , hsep . punctuate comma $ map ppSymName names @@ -351,29 +355,17 @@ ppFunSig loc doc docnames typ unicode = names = map getName docnames ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName - -> (HsExplicitFlag, LHsTyVarBndrs DocName) - -> LHsContext DocName -> LHsContext DocName - -> LHsType DocName + -> LHsSigType DocName -> Bool -> LaTeX -ppLPatSig _loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq (L _ ty) unicode +ppLPatSig _loc (doc, _argDocs) (L _ name) ty unicode = declWithDoc pref1 (documentationToLaTeX doc) where pref1 = hsep [ keyword "pattern" , ppDocBinder name , dcolon unicode - , ppLTyVarBndrs expl qtvs unicode - , ctx - , ppType unicode ty + , ppLType unicode (hsSigType ty) ] - ctx = case (ppLContextMaybe lprov unicode, ppLContextMaybe lreq unicode) of - (Nothing, Nothing) -> empty - (Nothing, Just req) -> parens empty <+> darr <+> req <+> darr - (Just prov, Nothing) -> prov <+> darr - (Just prov, Just req) -> prov <+> darr <+> req <+> darr - - darr = darrow unicode - ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) -> Bool -> LaTeX @@ -392,23 +384,15 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs - do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX - do_args n leader (HsForAllTy Explicit _ tvs lctxt ltype) - = decltt leader <-> - decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> - ppLContextNoArrow lctxt unicode) <+> nl $$ - do_largs n (darrow unicode) ltype - - do_args n leader (HsForAllTy Qualified e a lctxt ltype) - = do_args n leader (HsForAllTy Implicit e a lctxt ltype) - do_args n leader (HsForAllTy Implicit _ _ lctxt ltype) - | not (null (unLoc lctxt)) - = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$ - do_largs n (darrow unicode) ltype - -- if we're not showing any 'forall' or class constraints or - -- anything, skip having an empty line for the context. - | otherwise - = do_largs n leader ltype + do_args :: Int -> LaTeX -> HsType DocName -> LaTeX + do_args _n leader (HsForAllTy tvs ltype) + = decltt leader + <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) + <+> ppLType unicode ltype + do_args n leader (HsQualTy lctxt ltype) + = decltt leader + <-> ppLContextNoArrow lctxt unicode <+> nl $$ + do_largs n (darrow unicode) ltype do_args n leader (HsFunTy lt r) = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$ do_largs (n+1) (arrow unicode) r @@ -423,12 +407,12 @@ ppTypeSig nms ty unicode = <+> ppType unicode ty -ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX] -ppTyVars tvs = map ppSymName (tyvarNames tvs) +ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX] +ppTyVars = map (ppSymName . getName . hsLTyVarName) -tyvarNames :: LHsTyVarBndrs DocName -> [Name] -tyvarNames = map getName . hsLTyVarNames +tyvarNames :: LHsQTyVars DocName -> [Name] +tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX @@ -477,12 +461,12 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] + -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) - <+> ppAppDocNameNames summ n (tyvarNames $ tvs) + <+> ppAppDocNameNames summ n (tyvarNames tvs) <+> ppFds fds unicode @@ -520,8 +504,8 @@ ppClassDecl instances loc doc subdocs methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ - vcat [ ppFunSig loc doc names typ unicode - | L _ (TypeSig lnames (L _ typ) _) <- lsigs + vcat [ ppFunSig loc doc names (hsSigWcType typ) unicode + | L _ (TypeSig lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -544,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) @@ -560,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 @@ -591,14 +576,14 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode where cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + resTy = (unLoc . head) cons body = catMaybes [constrBit, doc >>= documentationToLaTeX] (whereBit, leaders) | null cons = (empty,[]) | otherwise = case resTy of - ResTyGADT _ _ -> (decltt (keyword "where"), repeat empty) + ConDeclGADT{} -> (decltt (keyword "where"), repeat empty) _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) constrBit @@ -612,21 +597,85 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX +ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Bool -> LaTeX ppConstrHdr forall tvs ctxt unicode = (if null tvs then empty else ppForall) <+> (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") where ppForall = case forall of - Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " - Qualified -> empty - Implicit -> empty + True -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " + False -> empty + + +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX + -> LConDecl DocName -> LaTeX +ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = + leader <-> + case con_details con of + + PrefixCon args -> + decltt (hsep ((header_ unicode <+> ppOcc) : + map (ppLParendType unicode) args)) + <-> rDoc mbDoc <+> nl + + RecCon (L _ fields) -> + (decltt (header_ unicode <+> ppOcc) + <-> rDoc mbDoc <+> nl) + $$ + doRecordFields fields + + InfixCon arg1 arg2 -> + decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, + ppOcc, + ppLParendType unicode arg2 ]) + <-> rDoc mbDoc <+> nl + + where + doRecordFields fields = + vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) + + + header_ = ppConstrHdr False tyVars context + occ = map (nameOccName . getName . unLoc) $ getConNames con + ppOcc = case occ of + [one] -> ppBinder one + _ -> cat (punctuate comma (map ppBinder occ)) + tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder []) (con_qvars con)) + context = unLoc (fromMaybe (noLoc []) (con_cxt con)) + + -- don't use "con_doc con", in case it's reconstructed from a .hi file, + -- or also because we want Haddock to do the doc-parsing, not GHC. + mbDoc = case getConNames con of + [] -> panic "empty con_names" + (cn:_) -> lookup (unLoc cn) subdocs >>= + fmap _doc . combineDocumentation . fst + +ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) = + leader <-> + doGADTCon (hsib_body $ con_type con) + + where + doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+> + ppLType unicode resTy + ) <-> rDoc mbDoc + + occ = map (nameOccName . getName . unLoc) $ getConNames con + ppOcc = case occ of + [one] -> ppBinder one + _ -> cat (punctuate comma (map ppBinder occ)) + -- don't use "con_doc con", in case it's reconstructed from a .hi file, + -- or also because we want Haddock to do the doc-parsing, not GHC. + mbDoc = case getConNames con of + [] -> panic "empty con_names" + (cn:_) -> lookup (unLoc cn) subdocs >>= + fmap _doc . combineDocumentation . fst +{- old ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX -> LConDecl DocName -> LaTeX -ppSideBySideConstr subdocs unicode leader (L _ con) = +ppSideBySideConstr subdocs unicode leader (L loc con) = leader <-> case con_res con of ResTyH98 -> case con_details con of @@ -660,13 +709,13 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = doRecordFields fields = vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) - doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> hsep [ - ppForAll forall ltvs (con_cxt con) unicode, - ppLType unicode (foldr mkFunTy resTy args) ] + doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> + ppLType unicode (mk_forall $ mk_phi $ + foldr mkFunTy resTy args) ) <-> rDoc mbDoc - header_ = ppConstrHdr forall tyVars context + header_ = ppConstrHdr (con_explicit con) tyVars context occ = map (nameOccName . getName . unLoc) $ con_names con ppOcc = case occ of [one] -> ppBinder one @@ -674,7 +723,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) - forall = con_explicit con + + mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvExplicit ltvs) ty) + | otherwise = ty + mk_phi ty | null context = ty + | otherwise = L loc (HsQualTy (con_cxt con) ty) + -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. mbDoc = case con_names con of @@ -682,16 +736,16 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = (cn:_) -> lookup (unLoc cn) subdocs >>= fmap _doc . combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) - +-} ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX ppSideBySideField subdocs unicode (ConDeclField names ltype _) = - decltt (cat (punctuate comma (map (ppBinder . nameOccName . getName . unL) names)) + decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation - mbDoc = lookup (unL $ head names) subdocs >>= fmap _doc . combineDocumentation . fst + mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX @@ -790,9 +844,6 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc -ppLContextMaybe :: Located (HsContext DocName) -> Bool -> Maybe LaTeX -ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc - ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX ppContextNoLocsMaybe [] _ = Nothing ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode @@ -822,9 +873,10 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) ------------------------------------------------------------------------------- -ppBang :: HsBang -> LaTeX -ppBang HsNoBang = empty -ppBang _ = char '!' -- Unpacked args is an implementation detail, +ppBang :: HsSrcBang -> LaTeX +ppBang (HsSrcBang _ _ SrcStrict) = char '!' +ppBang (HsSrcBang _ _ SrcLazy) = char '~' +ppBang _ = empty tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX @@ -877,33 +929,22 @@ ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Located (HsContext DocName) -> Bool -> LaTeX -ppForAll expl tvs cxt unicode = ppLTyVarBndrs expl tvs unicode <+> ppLContext cxt unicode - -ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Bool -> LaTeX -ppLTyVarBndrs expl tvs unicode - | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) <> dot - | otherwise = empty - where - show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} - ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX -ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode = maybeParen ctxt_prec pREC_FUN $ - hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode] - where ctxt' = case extra of - Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt - Nothing -> ctxt + sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot + , ppr_mono_lty pREC_TOP ty unicode ] +ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode + = maybeParen ctxt_prec pREC_FUN $ + sep [ ppLContext ctxt unicode + , ppr_mono_lty pREC_TOP ty unicode ] ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty -ppr_mono_ty _ (HsTyVar name) _ = ppDocName name +ppr_mono_ty _ (HsTyVar (L _ name)) _ = ppDocName name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) @@ -915,7 +956,6 @@ ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys -ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode = maybeParen ctxt_prec pREC_OP $ @@ -925,7 +965,7 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] -ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode where @@ -939,12 +979,14 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode = ppr_mono_lty ctxt_prec ty unicode -ppr_mono_ty _ HsWildcardTy _ = char '_' +ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_' -ppr_mono_ty _ (HsNamedWildcardTy name) _ = ppDocName name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ = ppDocName name ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u +ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy" + ppr_tylit :: HsTyLit -> Bool -> LaTeX ppr_tylit (HsNumTy _ n) _ = integer n diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 6ef1e863..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 ( (</>) ) @@ -305,7 +304,7 @@ mkNode qual ss p (Node s leaf pkg srcPkg short ts) = htmlModule = thespan ! modAttrs << (cBtn +++ if leaf - then ppModule (mkModule (stringToPackageKey (fromMaybe "" pkg)) + then ppModule (mkModule (stringToUnitId (fromMaybe "" pkg)) (mkModuleName mdl)) else toHtml s ) @@ -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 @@ -584,7 +583,7 @@ processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 (DataDecl{}) -> [keyword "data" <+> b] (SynDecl{}) -> [keyword "type" <+> b] (ClassDecl {}) -> [keyword "class" <+> b] - SigD (TypeSig lnames (L _ _) _) -> + SigD (TypeSig lnames _) -> map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames _ -> [] processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 88aa966c..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,18 +38,20 @@ import GHC import GHC.Exts import Name import BooleanFormula +import RdrName ( rdrNameOcc ) ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] -> [(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 qtvs prov req ty) -> - ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty fixities splice unicode qual + 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 + (hsSigWcType lty) fixities splice unicode qual + SigD (PatSynSig lname ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname + ty 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" @@ -59,26 +61,23 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] -> 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 + ppFunSig summary links loc doc (map unLoc lnames) lty fixities splice unicode qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [DocName] -> HsType DocName -> [(DocName, Fixity)] -> + [DocName] -> LHsType DocName -> [(DocName, Fixity)] -> 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) + ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) splice unicode qual where - pp_typ = ppType unicode qual typ + pp_typ = ppLType unicode qual typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - Located DocName -> - (HsExplicitFlag, LHsTyVarBndrs DocName) -> - LHsContext DocName -> LHsContext DocName -> - LHsType DocName -> + Located DocName -> LHsSigType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq typ fixities splice unicode qual +ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual | summary = pref1 | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual) +++ docSection Nothing qual doc @@ -86,18 +85,9 @@ ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq t pref1 = hsep [ keyword "pattern" , ppBinder summary occname , dcolon unicode - , ppLTyVarBndrs expl qtvs unicode qual - , cxt - , ppLType unicode qual typ + , ppLType unicode qual (hsSigType typ) ] - cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of - (Nothing, Nothing) -> noHtml - (Nothing, Just req) -> parens noHtml <+> darr <+> req <+> darr - (Just prov, Nothing) -> prov <+> darr - (Just prov, Just req) -> prov <+> darr <+> req <+> darr - - darr = darrow unicode occname = nameOccName . getName $ name ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> @@ -131,22 +121,29 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) argDoc n = Map.lookup n argDocs do_largs n leader (L _ t) = do_args n leader t + do_args :: Int -> Html -> HsType DocName -> [SubDecl] - do_args n leader (HsForAllTy _ _ tvs lctxt ltype) - = case unLoc lctxt of - [] -> do_largs n leader' ltype - _ -> (leader' <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) - : do_largs n (darrow unicode) ltype - where leader' = leader <+> ppForAll tvs unicode qual + do_args n leader (HsForAllTy tvs ltype) + = do_largs n leader' ltype + where + leader' = leader <+> ppForAll tvs unicode qual + + do_args n leader (HsQualTy lctxt ltype) + | null (unLoc lctxt) + = do_largs n leader ltype + | otherwise + = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) + : do_largs n (darrow unicode) ltype + do_args n leader (HsFunTy lt r) = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t = [(leader <+> ppType unicode qual t, argDoc n, [])] -ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html +ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = - case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- hsQTvBndrs tvs] of + case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of [] -> noHtml ts -> forallSymbol unicode <+> hsep ts +++ dot where ppKTv n k = parens $ @@ -174,20 +171,19 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge rightEdge = thespan ! [theclass "rightedge"] << noHtml -ppTyVars :: LHsTyVarBndrs DocName -> [Html] -ppTyVars tvs = map ppTyName (tyvarNames tvs) - +ppTyVars :: [LHsTyVarBndr DocName] -> [Html] +ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs -tyvarNames :: LHsTyVarBndrs DocName -> [Name] -tyvarNames = map getName . hsLTyVarNames +tyvarNames :: LHsQTyVars DocName -> [Name] +tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities +ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities splice unicode qual - = ppFunSig summary links loc doc [name] typ fixities splice unicode qual + = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -202,7 +198,8 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) splice unicode qual where - hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) + hdr = hsep ([keyword "type", ppBinder summary occ] + ++ ppTyVars (hsQTvExplicit ltyvars)) full = hdr <+> equals <+> ppLType unicode qual ltype occ = nameOccName . getName $ name fixs @@ -222,15 +219,37 @@ 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 - , fdKindSig = mkind }) + , fdResultSig = L _ result + , fdInjectivityAnn = injectivity }) unicode qual = (case info of OpenTypeFamily @@ -244,12 +263,32 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info ) <+> ppFamDeclBinderWithVars summary d <+> + ppResultSig result unicode qual <+> - (case mkind of - Just kind -> dcolon unicode <+> ppLKind unicode qual kind - Nothing -> noHtml + (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) = + char '|' <+> ppLDocName qual Raw lhs <+> arrow unicode <+> + hsep (map (ppLDocName qual Raw) rhs) + + ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html @@ -270,15 +309,27 @@ 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 - , tfe_pats = HsWB { hswb_cts = ts }} + , tfe_pats = HsIB { hsib_body = ts }} = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual <+> 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 -------------------------------------------------------------------------------- @@ -347,10 +398,6 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc - -ppLContextMaybe :: Located (HsContext DocName) -> Unicode -> Qualification -> Maybe Html -ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc - ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html ppContextNoArrow cxt unicode qual = fromMaybe noHtml $ ppContextNoLocsMaybe (map unLoc cxt) unicode qual @@ -381,7 +428,7 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] + -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" @@ -404,7 +451,7 @@ ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc subdocs splice unicode qual = - if not (any isVanillaLSig sigs) && null ats + if not (any isUserLSig sigs) && null ats 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 False @@ -414,8 +461,9 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc doc names typ [] splice unicode qual - | L _ (TypeSig lnames (L _ typ) _) <- sigs + [ ppFunSig summary links loc doc names (hsSigWcType typ) + [] splice unicode qual + | L _ (TypeSig lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -441,8 +489,10 @@ 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 isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) + | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) -- Only the fixity relevant to the class header @@ -459,8 +509,9 @@ ppClassDecl summary links instances fixities loc d subdocs doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual - | L _ (TypeSig lnames (L _ typ) _) <- lsigs + methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ) + subfixs splice unicode qual + | L _ (ClassOpSig _ lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs subfixs = [ f | n <- names , f@(n',_) <- fixities @@ -470,15 +521,15 @@ 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 _ s) <- lsigs ] of + minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method - And xs : _ | sort [getName n | Var (L _ n) <- xs] == - sort [getName n | L _ (TypeSig ns _ _) <- lsigs, L _ n <- ns] + And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == + sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | L _ (TypeSig ns _ _) <- lsigs, L _ n' <- ns] + [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -488,35 +539,98 @@ ppClassDecl summary links instances fixities loc d subdocs _ -> noHtml ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n - ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs - ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs + ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True . unLoc) fs + ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False . unLoc) fs 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 $ 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 + 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 + 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 ------------------------------------------------------------------------------- @@ -528,11 +642,11 @@ ppShortDataDecl summary dataInst dataDecl unicode qual | [] <- cons = dataHeader - | [lcon] <- cons, ResTyH98 <- resTy, + | [lcon] <- cons, isH98, (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot - | ResTyH98 <- resTy = dataHeader + | isH98 = dataHeader +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons) | otherwise = (dataHeader <+> keyword "where") @@ -546,7 +660,9 @@ ppShortDataDecl summary dataInst dataDecl unicode qual doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + isH98 = case unLoc (head cons) of + ConDeclH98 {} -> True + ConDeclGADT{} -> False ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> @@ -562,7 +678,9 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl where docname = tcdName dataDecl cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + isH98 = case unLoc (head cons) of + ConDeclH98 {} -> True + ConDeclGADT{} -> False header_ = topDeclElem links loc splice [docname] $ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix @@ -571,18 +689,17 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl whereBit | null cons = noHtml - | otherwise = case resTy of - ResTyGADT _ _ -> keyword "where" - _ -> noHtml + | otherwise = if isH98 then noHtml else keyword "where" constrBit = subConstructors qual [ ppSideBySideConstr subdocs subfixs unicode qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) - (map unLoc (con_names (unLoc c)))) fixities + (map unLoc (getConNames (unLoc c)))) fixities ] - instancesBit = ppInstances instances docname unicode qual + instancesBit = ppInstances links (OriginData docname) instances + splice unicode qual @@ -595,8 +712,8 @@ 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 -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html) -ppShortConstrParts summary dataInst con unicode qual = case con_res con of - ResTyH98 -> case con_details con of +ppShortConstrParts summary dataInst con unicode qual = case con of + ConDeclH98{} -> case con_details con of PrefixCon args -> (header_ unicode qual +++ hsep (ppOcc : map (ppLParendType unicode qual) args), noHtml, noHtml) @@ -609,28 +726,15 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of ppOccInfix, ppLParendType unicode qual arg2], noHtml, noHtml) - ResTyGADT _ resTy -> case con_details con of - -- prefix & infix could use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml) - -- display GADT records with the new syntax, - -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b) - -- (except each field gets its own line in docs, to match - -- non-GADT records) - RecCon (L _ fields) -> (ppOcc <+> dcolon unicode <+> - ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{', - doRecordFields fields, - char '}' <+> arrow unicode <+> ppLType unicode qual resTy) - InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) + ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml) where + resTy = hsib_body (con_type con) + doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields)) - doGADTCon args resTy = ppOcc <+> dcolon unicode <+> hsep [ - ppForAllCon forall_ ltvs lcontext unicode qual, - ppLType unicode qual (foldr mkFunTy resTy args) ] header_ = ppConstrHdr forall_ tyVars context - occ = map (nameOccName . getName . unLoc) $ con_names con + occ = map (nameOccName . getName . unLoc) $ getConNames con ppOcc = case occ of [one] -> ppBinder summary one @@ -640,35 +744,34 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of [one] -> ppBinderInfix summary one _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ)) - ltvs = con_qvars con + ltvs = fromMaybe (HsQTvs PlaceHolder []) (con_qvars con) tyVars = tyvarNames ltvs - lcontext = con_cxt con - context = unLoc (con_cxt con) - forall_ = con_explicit con - mkFunTy a b = noLoc (HsFunTy a b) + lcontext = fromMaybe (noLoc []) (con_cxt con) + context = unLoc lcontext + forall_ = False -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode +ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Unicode -> Qualification -> Html ppConstrHdr forall_ tvs ctxt unicode qual = (if null tvs then noHtml else ppForall) +++ - (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual - <+> darrow unicode +++ toHtml " ") + (if null ctxt then noHtml + else ppContextNoArrow ctxt unicode qual + <+> darrow unicode +++ toHtml " ") where - ppForall = case forall_ of - Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". " - Qualified -> noHtml - Implicit -> noHtml - + ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) + <+> toHtml ". " + | otherwise = noHtml ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> Unicode -> Qualification -> LConDecl DocName -> SubDecl -ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) +ppSideBySideConstr subdocs fixities unicode qual (L _ con) + = (decl, mbDoc, fieldPart) where - decl = case con_res con of - ResTyH98 -> case con_details con of + decl = case con of + ConDeclH98{} -> case con_details con of PrefixCon args -> hsep ((header_ +++ ppOcc) : map (ppLParendType unicode qual) args) @@ -682,28 +785,26 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field ppLParendType unicode qual arg2] <+> fixity - ResTyGADT _ resTy -> case con_details con of - -- prefix & infix could also use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> doGADTCon args resTy - cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + ConDeclGADT{} -> doGADTCon resTy + + resTy = hsib_body (con_type con) - fieldPart = case con_details con of + fieldPart = case getConDetails con of RecCon (L _ fields) -> [doRecordFields fields] _ -> [] doRecordFields fields = subFields qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) - doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html - doGADTCon args resTy = ppOcc <+> dcolon unicode - <+> hsep [ppForAllCon forall_ ltvs (con_cxt con) unicode qual, - ppLType unicode qual (foldr mkFunTy resTy args) ] + + doGADTCon :: Located (HsType DocName) -> Html + doGADTCon ty = ppOcc <+> dcolon unicode + -- ++AZ++ make this prepend "{..}" when it is a record style GADT + <+> ppLType unicode qual ty <+> fixity fixity = ppFixities fixities qual header_ = ppConstrHdr forall_ tyVars context unicode qual - occ = map (nameOccName . getName . unLoc) $ con_names con + occ = map (nameOccName . getName . unLoc) $ getConNames con ppOcc = case occ of [one] -> ppBinder False one @@ -713,32 +814,30 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field [one] -> ppBinderInfix False one _ -> hsep (punctuate comma (map (ppBinderInfix False) occ)) - ltvs = con_qvars con - tyVars = tyvarNames (con_qvars con) - context = unLoc (con_cxt con) - forall_ = con_explicit con + tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder []) (con_qvars con)) + context = unLoc (fromMaybe (noLoc []) (con_cxt con)) + forall_ = False -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ head $ con_names con) subdocs >>= + mbDoc = lookup (unLoc $ head $ getConNames con) subdocs >>= combineDocumentation . fst - mkFunTy a b = noLoc (HsFunTy a b) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocName -> SubDecl ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = - (hsep (punctuate comma (map ((ppBinder False) . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, + (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, mbDoc, []) where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation - mbDoc = lookup (unL $ head names) subdocs >>= combineDocumentation . fst + mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html ppShortField summary unicode qual (ConDeclField names ltype _) - = hsep (punctuate comma (map ((ppBinder summary) . nameOccName . getName . unL) names)) + = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype @@ -768,10 +867,10 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- -ppBang :: HsBang -> Html -ppBang HsNoBang = noHtml -ppBang _ = toHtml "!" -- Unpacked args is an implementation detail, - -- so we just show the strictness annotation +ppBang :: HsSrcBang -> Html +ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!" +ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~" +ppBang _ = noHtml tupleParens :: HsTupleSort -> [Html] -> Html @@ -817,52 +916,42 @@ 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 +ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html +ppHsTyVarBndr _ qual (UserTyVar (L _ name)) = + ppDocName qual Raw False name +ppHsTyVarBndr unicode qual (KindedTyVar name kind) = + parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + ppLKind unicode qual kind) + ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) 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 - -ppForAllCon :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Located (HsContext DocName) -> Unicode -> Qualification -> Html -ppForAllCon expl tvs cxt unicode qual = - forall_part <+> ppLContext cxt unicode qual - where - forall_part = ppLTyVarBndrs expl tvs unicode qual - -ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Unicode -> Qualification - -> Html -ppLTyVarBndrs expl tvs unicode _qual - | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot - | otherwise = noHtml - where - show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} - +ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html +ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot 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 -> Unicode -> Qualification -> Html -ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual - = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual - <+> ppr_mono_lty pREC_TOP ty unicode qual - where ctxt' = case extra of - Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt - Nothing -> ctxt +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual + = maybeParen ctxt_prec pREC_FUN $ + ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual + +ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual + = maybeParen ctxt_prec pREC_FUN $ + ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual -- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar name) True _ +ppr_mono_ty _ (HsTyVar (L _ name)) True _ | getOccString (getName name) == "*" = toHtml "★" | getOccString (getName name) == "(->)" = toHtml "(→)" ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty -ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsTyVar (L _ name)) _ q = ppDocName q Prefix True name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) ppr_mono_ty _ (HsKindSig ty kind) u q = @@ -872,11 +961,14 @@ ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TO ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q = maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" +ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}" + -- Can now legally occur in ConDeclGADT, the output here is to provide a + -- 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 _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy" +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 = maybeParen ctxt_prec pREC_CTX $ @@ -886,11 +978,16 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual] -ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual +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) @@ -899,9 +996,9 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual = ppr_mono_lty ctxt_prec ty unicode qual -ppr_mono_ty _ HsWildcardTy _ _ = char '_' +ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' -ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ q = ppDocName q Prefix True name ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n 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 b2c60534..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 @@ -225,12 +271,9 @@ topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names htm -- TODO: do something about type instances. They will point to -- the module defining the type family, which is wrong. origMod = nameModule n - origPkg = modulePackageKey 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? + origPkg = moduleUnitId origMod 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/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs index 3d1db887..d1561791 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs @@ -23,7 +23,7 @@ import GHC -- the base, module and entity URLs for the source code and wiki links. -type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageKey FilePath, Map PackageKey FilePath) +type SourceURLs = (Maybe FilePath, Maybe FilePath, Map UnitId FilePath, Map UnitId FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) 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] |