{-
Copyright (C) 2022 Yuchen Pei.
This file is part of haddorg-api.
This file is free software: you can redistribute it and/or modify it
under the terms of the GNU Affero General Public License as published
by the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This file is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Affero General Public License for more details.
You should have received a copy of the GNU Affero General Public
License along with this file. If not, see
<https://www.gnu.org/licenses/>.
-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Haddock.Backends.Org
( ppOrg
, cleanPkgStr
) where
import Control.Monad.State.Strict ( State
, evalState
, get
, put
)
import Data.List ( intercalate
, intersperse
, isSuffixOf
, singleton
, sortOn
)
import Data.Map ( (!?)
, toList
)
import qualified Data.Map as M
( empty
, map
, null
)
import Data.Maybe ( fromMaybe )
import Documentation.Haddock.Markup ( markup
, plainMarkup
)
import GHC ( ConDecl(..)
, ConDeclField(..)
, FamEqn(..)
, FamilyDecl(..)
, FamilyInfo(..)
, FamilyResultSig(..)
, FieldOcc(..)
, ForeignDecl(..)
, GenLocated(..)
, HsArg(..)
, HsConDeclGADTDetails(..)
, HsConDeclH98Details
, HsConDetails(..)
, HsDataDefn(..)
, HsDecl(..)
, HsForAllTelescope(..)
, HsOuterSigTyVarBndrs
, HsOuterTyVarBndrs(..)
, HsScaled(..)
, HsSigType(..)
, HsTupleSort(..)
, HsTyLit(..)
, HsTyVarBndr(..)
, HsType(..)
, InjectivityAnn(..)
, LHsContext
, LHsKind
, LHsQTyVars(..)
, LHsTyVarBndr
, LHsType
, LInjectivityAnn
, LTyFamInstEqn
, ModuleName
, Name
, NewOrData(..)
, RdrName
, Sig(..)
, TyClDecl(..)
, dropWildCards
, getName
, hsIPNameFS
, hsQTvExplicit
, moduleNameString
, unLoc
)
import GHC.Data.FastString ( unpackFS )
import GHC.Types.Basic ( PromotionFlag(..)
, TopLevelFlag(..)
)
import GHC.Types.Name ( isDataConName
, nameModule_maybe
, nameOccName
)
import GHC.Types.Name.Occurrence ( OccName
, occNameString
)
import GHC.Unit.Types ( GenModule(..)
, Module
, unitString
)
import GHC.Utils.Outputable ( showPprUnsafe )
import qualified GHC.Utils.Ppr as Pretty
import GHC.Utils.Ppr ( (<+>)
, (<>)
, comma
, hsep
, punctuate
, text
)
import Haddock.Backends.Org.Types
import Haddock.GhcUtils ( Precedence(..)
, hsLTyVarNameI
, moduleString
, reparenTypePrec
)
import Haddock.Types ( Doc
, DocForDecl
, DocH(..)
, DocInstance
, DocName(..)
, DocNameI
, Documentation(..)
, ExportItem(..)
, FnArgsDoc
, Header(..)
, Hyperlink(..)
, InstHead(..)
, InstType(..)
, Interface(..)
, MDoc
, MetaDoc(..)
, ModLink(..)
, Picture(..)
, TableCell(..)
, TableRow(..)
, Wrap(..)
, showWrapped
)
import qualified Haddock.Types as HT
( Example(..)
, Table(..)
)
import Prelude hiding ( (<>) )
type PDoc = Pretty.Doc
type ModPath = (String, String) -- (package, module)
type SubDocs = [(DocName, DocForDecl DocName)]
packageLevel, modLevel :: Int
packageLevel = 1
modLevel = 2
-- prefix for unimplemented and error
unimp, docError :: String -> String
unimp = ("UNIMP$" ++)
docError = ("ERROR$" ++)
unimpHeading :: String -> Int -> OrgBlock
unimpHeading thing level = headingPlainText (unimp thing) level
emptyDoc :: DocForDecl DocName
emptyDoc = (Documentation Nothing Nothing, M.empty)
-- The main function
ppOrg :: String -> Maybe (Doc RdrName) -> String -> [Interface] -> String
ppOrg title mbPrologue pkgId = orgToString . fromOrgDocument . toOrgDocument
title
mbPrologue
(cleanPkgStr pkgId)
toOrgDocument
:: String -> Maybe (Doc RdrName) -> String -> [Interface] -> OrgDocument
toOrgDocument title mbPrologue pkgId ifaces =
OrgDocument M.empty (processPackage title mbPrologue pkgId ifaces)
processPackage
:: String -> Maybe (Doc RdrName) -> String -> [Interface] -> [OrgBlock]
processPackage title mbPrologue pkgId ifaces =
Heading packageLevel
[plaintext title]
(cIdProp pkgId ++ hackageProp (hackagePackageUrl pkgId))
: Paragraph [plaintext $ maybe [] removeMarkup' mbPrologue]
: concatMap processModule (sortOn ifaceMod ifaces)
processModule :: Interface -> [OrgBlock]
processModule iface =
let
mdl = moduleString $ ifaceMod iface
pkg = cleanPkgStr $ unitString $ moduleUnit $ ifaceMod iface
path = (pkg, mdl)
heading = Heading
modLevel
[plaintext mdl]
(cIdProp (pkg ++ "." ++ mdl) ++ hackageProp (hackageModuleUrl pkg mdl))
description = ppDocumentation (ifaceRnDoc iface) (Just modLevel)
exported =
evalState (mapM (processExport path) (ifaceRnExportItems iface)) modLevel
++ [ ppDocInsts
(ifaceRnOrphanInstances iface)
"Orphan Instances"
(modLevel + 1)
]
in
heading : description ++ concat exported
processExport :: ModPath -> ExportItem DocNameI -> State Int [OrgBlock]
-- TODO: handle bundled patterns, fixities and splice
processExport path (ExportDecl (L _ decl) _pats docs subdocs insts _fixities _splice)
= do
baseLevel <- get
return $ ppHsDecl decl insts docs subdocs path (baseLevel + 1)
processExport _ (ExportNoDecl _ _ ) = error "ExportNoDecl"
processExport _ (ExportGroup offset _ label) = do
put $ modLevel + offset
return $ ppDocBlock (DocHeader (Header (modLevel + offset) label)) (Just 0)
processExport _ (ExportDoc mDoc) = return $ ppMDoc mDoc (Just modLevel)
processExport _ (ExportModule mdl ) = do
baseLevel <- get
return
[ Heading
(baseLevel + 1)
[plaintext "module", Whitespace, Link (text (moduleString mdl)) []]
[]
]
-- * To Org elements
-- ** Documentation to Org elements
ppFnArgsDoc :: FnArgsDoc DocName -> [OrgBlock]
ppFnArgsDoc aDoc = if M.null aDoc
then []
else ((`ppDoc` Nothing) . DocParagraph . DocString) "Arguments (in order):"
++ ((`ppDoc` Nothing) . DocOrderedList . toList . M.map _doc) aDoc
ppDocumentation :: Documentation DocName -> Maybe Int -> [OrgBlock]
ppDocumentation (Documentation (Just mdoc) _) minLevel = ppMDoc mdoc minLevel
ppDocumentation _ _ = []
ppMDoc :: MDoc DocName -> Maybe Int -> [OrgBlock]
ppMDoc (MetaDoc _ doc) = ppDoc doc
ppDoc :: Doc DocName -> Maybe Int -> [OrgBlock]
ppDoc x l = if isBlock x then ppDocBlock x l else [Paragraph $ ppDocInline x]
ppDocBlock :: Doc DocName -> Maybe Int -> [OrgBlock]
ppDocBlock x _ | not (isBlock x) = ppDocBlock (DocParagraph x) Nothing
ppDocBlock DocEmpty _ = []
ppDocBlock (DocAppend x y ) l = ppDocBlock x l ++ ppDocBlock y l
ppDocBlock (DocParagraph x) _ = [Paragraph (ppDocInline x)]
ppDocBlock (DocUnorderedList docs) _ =
[PlainList Unordered $ (`ppDocBlock` Nothing) <$> docs]
ppDocBlock (DocOrderedList items) _ =
[PlainList Ordered (map ((`ppDocBlock` Nothing) . snd) items)]
ppDocBlock (DocDefList pairs) _ =
[ DefList
$ (\(term, def) -> (ppDocInline term, ppDocBlock def Nothing))
<$> pairs
]
ppDocBlock (DocCodeBlock doc) _ =
[SrcBlock $ text $ fixLeadingStar $ removeMarkup doc]
ppDocBlock (DocMathDisplay x) _ = [MathDisplay (text x)]
ppDocBlock (DocExamples examples) _ =
(\(HT.Example expr res) -> Example
(text (fixLeadingStar expr))
(text $ fixLeadingStar $ intercalate "\n" res)
)
<$> examples
ppDocBlock (DocHeader (Header level label)) (Just l) =
[Heading (level + l) (ppDocInline label) []]
ppDocBlock (DocTable (HT.Table hRows bRows)) _ = ppTable hRows bRows
ppDocBlock doc _ = [Paragraph [plaintext $ unimp "ppDocBlock: " ++ show doc]]
ppDocInline :: Doc DocName -> [OrgInline]
ppDocInline x | isBlock x = [plaintext $ docError "BLOCK_IN_INLINE" ++ show x]
ppDocInline (DocAppend x y ) = ppDocInline x ++ ppDocInline y
ppDocInline (DocString x) = [plaintext x]
ppDocInline (DocIdentifier x) = ppWrapped ppDocName x
ppDocInline (DocIdentifierUnchecked x) = ppWrapped ppMO x
ppDocInline (DocModule (ModLink modName mbModLabel)) =
[Link (text modName) (maybe [] ppDocInline mbModLabel)]
ppDocInline (DocWarning x) = [plaintext $ unimp $ "DocWarning: " ++ show x]
ppDocInline (DocEmphasis x) = [Italic $ ppDocInline x]
ppDocInline (DocMonospaced x) = [Code $ text $ removeMarkup x]
ppDocInline (DocBold x) = [Bold $ ppDocInline x]
ppDocInline (DocHyperlink (Hyperlink url label)) =
[Link (text url) (maybe [] ppDocInline label)]
ppDocInline (DocPic (Picture url mbTitle)) =
[Link (text url) (maybe [] (singleton . plaintext) mbTitle)]
ppDocInline (DocAName x) = [Anchor (text x)]
ppDocInline (DocMathInline x) = [MathInline (text x)]
ppDocInline (DocProperty x) = [plaintext x]
ppDocInline doc = [plaintext $ unimp "ppDocInline: " ++ show doc]
-- *** Handling tables
-- current coordinates, colspan and rowspan coordinates
type SpanState = ((Int, Int), [(Int, Int)], [(Int, Int)])
emptySpanState :: SpanState
emptySpanState = ((0, 0), [], [])
-- marks for cells connected with colspan and rowspan
leftSym, upSym :: Bool -> String
leftSym True = "<"
leftSym False = ""
upSym True = "^"
upSym False = ""
ppTable :: [TableRow (Doc DocName)] -> [TableRow (Doc DocName)] -> [OrgBlock]
ppTable header body =
[ Table (evalState (ppTable' header) emptySpanState)
(evalState (ppTable' body) emptySpanState)
]
ppTable' :: [TableRow (Doc DocName)] -> State SpanState [[[OrgInline]]]
ppTable' [] = return []
ppTable' (TableRow cells : rest) = do
cur <- ppTableRow' cells
rest' <- ppTable' rest
return $ cur : rest'
-- handle a table row, tracking colspans and rowspans
ppTableRow' :: [TableCell (Doc DocName)] -> State SpanState [[OrgInline]]
ppTableRow' [] = return []
ppTableRow' (TableCell colspan rowspan doc : rest) = do
((x, y), colspans, rowspans) <- get
let
left = (not . null) colspans && (x, y) `elem` colspans
up = (not . null) rowspans && (x, y) `elem` rowspans
content = if left || up
then [plaintext (leftSym left ++ upSym up)]
else ppDocInline doc
newColspans = if left
then colspans
else colspans ++ map (\i -> (x, y + i)) [1 .. colspan - 1]
newRowspans = if up
then rowspans
else rowspans ++ map (\i -> (x + i, y)) [1 .. rowspan - 1]
extraLeft = if null rest
then length (takeWhile (`elem` newColspans) (map (x, ) [y + 1 ..]))
else 0
extraUp = if null rest
then length (takeWhile (`elem` newRowspans) (map (x, ) [y + 1 ..]))
else 0
n = max extraLeft extraUp
lefts = replicate extraLeft True ++ replicate (n - extraLeft) False
ups = replicate extraUp True ++ replicate (n - extraUp) False
extra = zipWith (\l u -> [plaintext (leftSym l ++ upSym u)]) lefts ups
newCoord = if null rest then (x + 1, 0) else (x, y + 1)
put (newCoord, newColspans, newRowspans)
rest' <- ppTableRow' rest
return $ content : extra ++ rest'
-- ** AST to Org elements
ppHsDecl
:: HsDecl DocNameI
-> [DocInstance DocNameI]
-> DocForDecl DocName
-> SubDocs
-> ModPath
-> Int
-> [OrgBlock]
ppHsDecl (TyClD _ decl) insts docs subdocs path level =
ppTyClDecl decl docs subdocs path level
++ ppDocInsts insts "Instances:" (level + 1)
ppHsDecl (SigD _ sig) _ docs subdocs path level =
ppSig sig docs subdocs path level
ppHsDecl (ForD _ for) _ docs _ path level = ppForeignDecl for docs path level
ppHsDecl _ _ docs _ _ level =
unimpHeading "HsDecl" level : ppDocForDecl docs (Just level)
ppForeignDecl
:: ForeignDecl DocNameI -> DocForDecl DocName -> ModPath -> Int -> [OrgBlock]
ppForeignDecl (ForeignImport _ (L _ name) (L _ sigType) _) docs path level =
Heading level
(Plain (docNameToDoc name) : plaintext " :: " : ppHsSigType sigType)
(cIdPaths path name)
: ppDocForDecl docs (Just level)
ppForeignDecl _ docs _ level =
unimpHeading "ForeignDecl" level : ppDocForDecl docs (Just level)
ppDocInsts :: [DocInstance DocNameI] -> String -> Int -> [OrgBlock]
ppDocInsts [] _ _ = []
ppDocInsts insts heading level =
[headingPlainText heading level, PlainList Unordered (map ppDocInst insts)]
ppDocInst :: DocInstance DocNameI -> [OrgBlock]
ppDocInst (InstHead clsName types (ClassInst {..}), mbMdoc, _docName, _mbMod) =
prependInlinesToBlocks
( interNotNull
[Whitespace]
[ ppContext clsiCtx
, ppDocName clsName
, intercalate [Whitespace]
(map (ppHsType . reparenTypePrec PREC_CON) types)
]
++ if mbMDocHasDoc mbMdoc
then
[Whitespace, plaintext "::", Whitespace]
else
[]
)
(maybe [] (`ppMDoc` Nothing) mbMdoc)
ppDocInst (InstHead clsName types (TypeInst mbRhs), mbMdoc, _docName, _mbMod) =
prependInlinesToBlocks
( plaintext "type "
: ppDocName clsName
++ [Whitespace]
++ intercalate [Whitespace]
(map (ppHsType . reparenTypePrec PREC_CON) types)
++ maybe
[]
(\ty -> plaintext " = " : ppHsType (reparenTypePrec PREC_TOP ty))
mbRhs
++ if mbMDocHasDoc mbMdoc
then [Whitespace, plaintext "::", Whitespace]
else []
)
(maybe [] (`ppMDoc` Nothing) mbMdoc)
-- TODO: add decl
ppDocInst (InstHead clsName types (DataInst _decl), mbMdoc, _docName, _mbMod) =
prependInlinesToBlocks
( plaintext "data "
: ppDocName clsName
++ [Whitespace]
++ intercalate [Whitespace]
(map (ppHsType . reparenTypePrec PREC_CON) types)
++ if mbMDocHasDoc mbMdoc
then [Whitespace, plaintext "::", Whitespace]
else []
)
(maybe [] (`ppMDoc` Nothing) mbMdoc)
mbMDocHasDoc :: Maybe (MDoc DocName) -> Bool
mbMDocHasDoc Nothing = False
mbMDocHasDoc (Just (MetaDoc _ DocEmpty)) = False
mbMDocHasDoc _ = True
parensIfMany :: [a] -> [OrgInline] -> [OrgInline]
parensIfMany xs org = if length xs > 1 then orgParens org else org
dcSuffix :: DocName -> String
dcSuffix name = if isDataConName (getName name) then ":dc" else ""
idPath :: ModPath -> DocName -> String
idPath (pkg, mdl) name =
pkg ++ "." ++ mdl ++ "." ++ docNameToString name ++ dcSuffix name
idPath' :: Module -> DocName -> String
idPath' mdl name =
idPath (cleanPkgStr $ unitString $ moduleUnit mdl, moduleString mdl) name
idPathNoPkg :: String -> DocName -> String
idPathNoPkg mdl name = mdl ++ "." ++ docNameToString name ++ dcSuffix name
cIdPaths :: ModPath -> DocName -> Properties
cIdPaths path@(_, mdl) name = cIdsProp [idPath path name, idPathNoPkg mdl name]
ppTyClDecl
:: TyClDecl DocNameI
-> DocForDecl DocName
-> SubDocs
-> ModPath
-> Int
-> [OrgBlock]
-- data T a b
-- newtype T a b
-- TODO: handle fixity
ppTyClDecl (DataDecl _ (L _ name) tcdTyVars _ defn@(HsDataDefn { dd_ND = nd, dd_cons = cons })) docs subdocs path level
= [ Heading
level
( Plain
((ppNewOrData nd) <+> (docNameToDoc name) <+> hsep
(ppName <$> tyvarNames tcdTyVars)
)
: if gadt then [plaintext " where"] else []
)
(cIdPaths path name)
]
++ ppDocForDecl docs (Just level)
++ ppDataDefn defn subdocs path (level + 1)
where
gadt = case cons of
[] -> False
L _ ConDeclGADT{} : _ -> True
_ -> False
ppTyClDecl (DataDecl{}) docs _ _ level =
unimpHeading "DataDecl" level : ppDocForDecl docs (Just level)
-- type T a b
ppTyClDecl (SynDecl _ (L _ name) tcdTyVars _fixity (L _ rhs)) docs _ path level
= [ Heading
level
( intersperse
Whitespace
( [plaintext "type", Plain $ docNameToDoc name]
++ map (Plain . ppName) (tyvarNames tcdTyVars)
++ [Plain $ text "= "]
)
++ ppHsType rhs
)
(cIdPaths path name)
]
++ ppDocForDecl docs (Just level)
-- class
ppTyClDecl (ClassDecl {..}) docs subdocs path level =
[ Heading
level
(interNotNull
[Whitespace]
[ [plaintext "class"]
, ppMbLHsContext tcdCtxt
, (singleton . Plain . docNameToDoc . unLoc) tcdLName
, intersperse Whitespace (map (Plain . ppName) (tyvarNames tcdTyVars))
]
)
(cIdPaths path (unLoc tcdLName))
]
++ ppDocForDecl docs (Just level)
-- TODO: do we need an aDoc here instead of M.empty?
-- TODO: handle default sigs
++ concatMap
((\sig -> ppSig sig emptyDoc subdocs path (level + 1)) . unLoc)
tcdSigs
-- type family ... where
-- TODO: handle infix
ppTyClDecl (FamDecl _ (FamilyDecl _ (ClosedTypeFamily mbEqns) TopLevel (L _ name) tyvars _fixity (L _ resSig) mbInj)) docs subdocs path level
= Heading
level
( [plaintext "type family ", Plain $ docNameToDoc name, Whitespace]
++ ppLHsQTyVars tyvars
++ ppFamilyResultSig resSig "="
++ maybe [] ppLInjectivityAnn mbInj
++ [plaintext " where"]
)
(cIdPaths path name)
: ppDocForDecl docs (Just level)
++ concatMap (\x -> ppLTyFamInstEqn x subdocs path (level + 1))
(fromMaybe [] mbEqns)
-- data family
-- type family
-- DataFamily or OpenTypeFamily
ppTyClDecl (FamDecl _ (FamilyDecl _ info TopLevel (L _ name) tyvars _fixity (L _ resSig) mbInj)) docs _ path level
= Heading
level
( [pre, Plain $ docNameToDoc name, Whitespace]
++ ppLHsQTyVars tyvars
++ ppFamilyResultSig resSig op
++ maybe [] ppLInjectivityAnn mbInj
)
(cIdPaths path name)
: ppDocForDecl docs (Just level)
where
pre = case info of
DataFamily -> plaintext "data family "
OpenTypeFamily -> plaintext "type family "
op = case info of
DataFamily -> "::"
_ -> "="
ppTyClDecl (FamDecl{}) docs _ _ level =
unimpHeading "FamDecl" level : ppDocForDecl docs (Just level)
ppLTyFamInstEqn
:: LTyFamInstEqn DocNameI -> SubDocs -> ModPath -> Int -> [OrgBlock]
ppLTyFamInstEqn (L _ (FamEqn _ (L _ name) _ tyPats _fixity rhs)) subdocs _ level
= Heading
level
(interNotNull
[Whitespace]
[ ppDocName name
, intercalate [Whitespace] (map ppHsArg tyPats)
, [plaintext "="]
, ppLHsType (reparenTypePrec PREC_TOP <$> rhs)
]
)
[]
: maybe [] (`ppDocForDecl` (Just level)) (lookup name subdocs)
ppHsArg :: HsArg (LHsType DocNameI) (LHsKind DocNameI) -> [OrgInline]
ppHsArg (HsValArg ty) = ppLHsType (reparenTypePrec PREC_CON <$> ty)
ppHsArg _ = [plaintext $ unimp "HsArg"]
ppLInjectivityAnn :: LInjectivityAnn DocNameI -> [OrgInline]
ppLInjectivityAnn (L _ (InjectivityAnn _ (L _ l) rs)) =
[ plaintext " | "
, Plain $ docNameToDoc l
, plaintext " -> "
, Plain $ hsep $ map (docNameToDoc . unLoc) rs
]
ppLInjectivityAnn _ = [plaintext $ unimp "LInjectivityAnn"]
ppFamilyResultSig :: FamilyResultSig DocNameI -> String -> [OrgInline]
ppFamilyResultSig (KindSig _ (L _ x)) op =
[Whitespace, plaintext op, Whitespace] ++ ppHsType x
ppFamilyResultSig (NoSig{}) _ = []
ppFamilyResultSig (TyVarSig _ x) op =
[Whitespace, plaintext op, Whitespace] ++ ppLHsTyVarBndr x
ppDataDefn :: HsDataDefn DocNameI -> SubDocs -> ModPath -> Int -> [OrgBlock]
ppDataDefn (HsDataDefn _ _ _ _ _ cons _derivs) subdocs path level =
concatMap ((\con -> ppConDecl con subdocs path level) . unLoc) cons
ppDataDefn _ _ _ level = [unimpHeading "DataDecl" level]
ppConDecl :: ConDecl DocNameI -> SubDocs -> ModPath -> Int -> [OrgBlock]
-- T1 a Int
-- TODO: handle infix
ppConDecl (ConDeclH98 _ (L _ docName) _forall exTvs mbCtxt args _) subdocs path level
= Heading
level
(interNotNull
[Whitespace]
[ ppForAll exTvs
, ppMbLHsContext mbCtxt
, [Plain (docNameToDoc docName)]
, prefixOnly
]
)
(cIdPaths path docName)
: case lookup docName subdocs of
Just (doc, aDoc) ->
prefixWithDocs aDoc ++ ppDocumentation doc (Just level)
Nothing -> []
++ ppConDeclRecCon args subdocs path (level + 1)
where
prefixOnly = case args of
PrefixCon _ args' -> interNotNull [Whitespace] (map ppHsScaled args')
RecCon _ -> [plaintext "{"]
_ -> []
prefixWithDocs :: FnArgsDoc DocName -> [OrgBlock]
prefixWithDocs aDoc = if M.null aDoc
then []
else case args of
PrefixCon _ args' ->
[ Paragraph [plaintext "Arguments:"]
, DefList
(map (\(i, arg) -> (ppHsScaled arg, ppADoc aDoc i)) (zip [1 ..] args')
)
]
_ -> ppFnArgsDoc aDoc
-- TODO: handle con_bndrs and con_mb_cxt
ppConDecl (ConDeclGADT _ names _ _ args resTy _) subdocs path level =
[ Heading
level
( interNotNull
[Whitespace]
[ intersperse (Plain $ text ", ")
(map (Plain . docNameToDoc . unLoc) names)
, [plaintext "::"]
]
++ [Whitespace]
++ ppConDeclGADTDetailsPrefix args resTy
)
(concatMap (cIdPaths path . unLoc) names)
]
++ maybe []
(`ppDocForDecl` (Just level))
(lookup (unLoc $ head names) subdocs)
++ ppConDeclGADTDetailsRec args resTy subdocs path (level + 1)
ppForAll :: [LHsTyVarBndr a DocNameI] -> [OrgInline]
ppForAll [] = []
ppForAll xs =
intercalate [Whitespace] ([plaintext "forall"] : map ppLHsTyVarBndr xs)
++ [plaintext "."]
ppConDeclGADTDetailsPrefix
:: HsConDeclGADTDetails DocNameI -> LHsType DocNameI -> [OrgInline]
ppConDeclGADTDetailsPrefix (PrefixConGADT args) resTy =
intercalate [plaintext " -> "] (map ppHsScaled args ++ [ppLHsType resTy])
ppConDeclGADTDetailsPrefix (RecConGADT{}) _ = [plaintext "{"]
ppConDeclGADTDetailsRec
:: HsConDeclGADTDetails DocNameI
-> LHsType DocNameI
-> SubDocs
-> ModPath
-> Int
-> [OrgBlock]
ppConDeclGADTDetailsRec (RecConGADT (L _ args)) resTy subdocs path level =
concatMap (\arg -> ppConDeclField (unLoc arg) subdocs path level) args
++ [Heading level (plaintext "} -> " : ppLHsType resTy) []]
ppConDeclGADTDetailsRec _ _ _ _ _ = []
ppConDeclRecCon
:: HsConDeclH98Details DocNameI -> SubDocs -> ModPath -> Int -> [OrgBlock]
ppConDeclRecCon (RecCon (L _ args)) subdocs path level =
concatMap (\arg -> ppConDeclField (unLoc arg) subdocs path level) args
ppConDeclRecCon _ _ _ _ = []
ppConDeclField
:: ConDeclField DocNameI -> SubDocs -> ModPath -> Int -> [OrgBlock]
ppConDeclField (ConDeclField _ names (L _ ty) _) subdocs path level =
[ Heading
level
(interNotNull
[Whitespace]
[ intersperse
(Plain $ text ", ")
(map (Plain . docNameToDoc . fieldOccDocName . unLoc) names)
, [plaintext "::"]
, ppHsType ty
]
)
(concatMap (cIdPaths path . fieldOccDocName . unLoc) names)
]
++ maybe [] (`ppDocForDecl` (Just level)) (lookup docName subdocs)
where docName = (fieldOccDocName . unLoc . head) names
fieldOccDocName :: FieldOcc DocNameI -> DocName
fieldOccDocName (FieldOcc docName _) = docName
fieldOccDocName _ = error "FieldOccDocName"
-- TODO: handle linear types
ppHsScaled :: HsScaled DocNameI (LHsType DocNameI) -> [OrgInline]
ppHsScaled (HsScaled _ (L _ ty)) = ppHsType ty
ppSig
:: Sig DocNameI
-> DocForDecl DocName
-> SubDocs
-> ModPath
-> Int
-> [OrgBlock]
-- toplevel decl e.g. f :: Int -> String
ppSig (TypeSig _ lhs rhs) (doc, aDoc) _ path level =
Heading
level
( [ Plain (hsep $ punctuate comma $ docNameToDoc . unLoc <$> lhs)
, Whitespace
, plaintext "::"
, Whitespace
]
++ (ppHsSigType hsSig)
)
(concatMap (cIdPaths path . unLoc) lhs)
: (if M.null aDoc then [] else ppHsSigTypeDoc hsSig aDoc)
++ ppDocumentation doc (Just level)
where hsSig = unLoc (dropWildCards rhs)
-- class method decl
ppSig (ClassOpSig _ _ names (L _ sigType)) _ subdocs path level =
[ Heading
level
( [ Plain (hsep $ punctuate comma $ docNameToDoc . unLoc <$> names)
, Whitespace
, plaintext "::"
, Whitespace
]
++ ppHsSigType sigType
)
(concatMap (cIdPaths path . unLoc) names)
]
++ case lookup (unLoc (head names)) subdocs of
Just (doc, aDoc) ->
(if M.null aDoc then [] else ppHsSigTypeDoc sigType aDoc)
++ ppDocumentation doc (Just level)
Nothing -> []
ppSig (PatSynSig _ names (L _ hsSig)) (doc, aDoc) _ path level =
Heading
level
( [ plaintext "pattern "
, Plain (hsep $ punctuate comma $ docNameToDoc . unLoc <$> names)
, Whitespace
, plaintext "::"
, Whitespace
]
++ (ppHsSigType hsSig)
)
(concatMap (cIdPaths path . unLoc) names)
: (if M.null aDoc then [] else ppHsSigTypeDoc hsSig aDoc)
++ ppDocumentation doc (Just level)
-- TODO: every class's sigs start with a MinimalSig
ppSig (MinimalSig{}) _ _ _ _ = []
ppSig _ _ _ _ level = [headingPlainText (unimp "Sig") level]
ppNewOrData :: NewOrData -> PDoc
ppNewOrData NewType = text "newtype"
ppNewOrData DataType = text "data"
ppHsSigType :: HsSigType DocNameI -> [OrgInline]
ppHsSigType (HsSig _ bndrs (L _ ty)) = interNotNull
[Whitespace]
[ppHsOuterSigTyVarBndrs bndrs, ppHsType (reparenTypePrec PREC_TOP ty)]
ppHsOuterSigTyVarBndrs :: HsOuterSigTyVarBndrs DocNameI -> [OrgInline]
ppHsOuterSigTyVarBndrs bndrs = case bndrs of
HsOuterExplicit _ tyVarBndrs -> ppForAll tyVarBndrs
_ -> []
ppHsSigTypeDoc :: HsSigType DocNameI -> FnArgsDoc DocName -> [OrgBlock]
ppHsSigTypeDoc (HsSig _ bndrs (L _ ty)) adoc =
[Paragraph [plaintext "Arguments:"], DefList (forall ++ ppHsTypeDoc ty 0)]
where
ppHsTypeDoc :: HsType DocNameI -> Int -> [DefListItem]
ppHsTypeDoc (HsFunTy _ _ (L _ lTy) (L _ rTy)) i =
ppHsTypeDoc lTy i ++ ppHsTypeDoc rTy (i + 1)
ppHsTypeDoc (HsQualTy _ mbCtxt (L _ body)) i =
(ppMbLHsContext mbCtxt, []) : ppHsTypeDoc body i
ppHsTypeDoc (HsForAllTy _ tele (L _ body)) i =
(ppHsForAllTelescope tele ++ [plaintext "."], []) : ppHsTypeDoc body i
ppHsTypeDoc typ i = [(ppHsType typ, ppADoc adoc i)]
forall = case ppHsOuterSigTyVarBndrs bndrs of
[] -> []
is -> [(is, [])]
ppDocForDecl :: DocForDecl DocName -> Maybe Int -> [OrgBlock]
ppDocForDecl (doc, adoc) l = ppFnArgsDoc adoc ++ ppDocumentation doc l
ppADoc :: FnArgsDoc DocName -> Int -> [OrgBlock]
ppADoc adoc i = case adoc !? i of
Nothing -> []
Just mdoc -> ppMDoc mdoc Nothing
ppHsType :: HsType DocNameI -> [OrgInline]
-- e.g. -> forall d. d
ppHsType (HsForAllTy _ tele (L _ body)) =
ppHsForAllTelescope tele ++ [plaintext ".", Whitespace] ++ ppHsType body
-- e.g. forall a. Ord a => a
ppHsType (HsQualTy _ mbCtxt (L _ body)) =
interNotNull [Whitespace] [ppMbLHsContext mbCtxt, ppHsType body]
-- e.g. Bool
ppHsType (HsTyVar _ promo (L _ docName)) =
ppPromoted promo ++ ppDocName docName
-- e.g. IO ()
ppHsType (HsAppTy _ (L _ lTy) (L _ rTy)) =
ppHsType lTy ++ [Whitespace] ++ ppHsType rTy
ppHsType (HsAppKindTy _ _ _) = [plaintext $ unimp "HsAppKindTy"]
ppHsType (HsFunTy _ _ (L _ lTy) (L _ rTy)) =
ppHsType lTy ++ [Whitespace, plaintext "->", Whitespace] ++ ppHsType rTy
-- e.g. [a]
ppHsType (HsListTy _ (L _ ty) ) = orgBrackets $ ppHsType ty
-- e.g. ()
-- e.g. (a, b)
ppHsType (HsTupleTy _ sort tys) = orgParens $ maybeUnbox $ intercalate
[plaintext ",", Whitespace]
(ppHsType . unLoc <$> tys)
where
maybeUnbox = case sort of
HsUnboxedTuple -> orgUnbox
HsBoxedOrConstraintTuple -> id
-- e.g. (# a | b #)
ppHsType (HsSumTy _ tys) =
orgParens . orgUnbox $ intercalate [plaintext " | "] (map ppLHsType tys)
ppHsType (HsOpTy _ (L _ lTy) (L _ docName) (L _ rTy)) =
intercalate [Whitespace] [ppHsType lTy, ppDocName docName, ppHsType rTy]
-- e.g. (a -> a)
ppHsType (HsParTy _ (L _ t)) = orgParens $ ppHsType t
-- e.g. ?callStack :: CallStack
ppHsType (HsIParamTy _ (L _ name) ty) =
(plaintext $ '?' : unpackFS (hsIPNameFS name))
: plaintext " :: "
: ppLHsType ty
ppHsType (HsStarTy _ _) = [plaintext "*"]
-- e.g. (a :: k)
ppHsType (HsKindSig _ (L _ t) (L _ k)) =
ppHsType t ++ [plaintext " :: "] ++ ppHsType k
ppHsType (HsSpliceTy _ _ ) = [plaintext $ unimp "HsSpliceTy"]
-- e.g. -> a -- ^ Second argument
-- The third arg in docty is HsDocString
ppHsType (HsDocTy _ (L _ t) _ ) = ppHsType t
ppHsType (HsBangTy _ _ (L _ ty) ) = plaintext "!" : ppHsType ty
ppHsType (HsRecTy _ _ ) = [plaintext $ unimp "HsRecTy"]
-- TODO: is it possible that promo is NotPromoted? If so what is the difference
-- from a vanilla list (cf ExplicitTuple does not have a promo flag)?
ppHsType (HsExplicitListTy _ promo tys) = ppPromoted promo
++ orgBrackets (intercalate [plaintext ", "] (map ppLHsType tys))
ppHsType (HsExplicitTupleTy _ tys) =
plaintext "'" : orgParens (intercalate [plaintext ", "] (map ppLHsType tys))
ppHsType (HsTyLit _ lit) = [plaintext $ shown]
where
shown = case lit of
HsNumTy _ x -> show x
HsStrTy _ x -> show x
HsCharTy _ x -> show x
ppHsType (HsWildCardTy _) = [plaintext "_"]
ppHsType _ = [plaintext $ unimp "HsType"]
ppLHsType :: LHsType DocNameI -> [OrgInline]
ppLHsType (L _ x) = ppHsType x
ppMbLHsContext :: Maybe (LHsContext DocNameI) -> [OrgInline]
ppMbLHsContext = maybe [] (ppContext . map unLoc . unLoc)
ppContext :: [HsType DocNameI] -> [OrgInline]
ppContext [] = []
ppContext ctx =
parensIfMany ctx (intercalate [plaintext ",", Whitespace] (map ppHsType ctx))
++ [Whitespace, plaintext "=>"]
ppPromoted :: PromotionFlag -> [OrgInline]
ppPromoted flag = case flag of
NotPromoted -> []
IsPromoted -> [plaintext "'"]
ppDocName :: DocName -> [OrgInline]
ppDocName docName@(Documented _ mdl) =
[Link (text "#" <> text (idPath' mdl docName)) [Plain $ docNameToDoc docName]]
ppDocName docName@(Undocumented name) = case nameModule_maybe name of
Nothing -> [Plain $ docNameToDoc docName]
Just mdl -> ppDocName (Documented name mdl)
-- TODO: determine whether it's a subordinate based on NameSpace
ppMO :: (ModuleName, OccName) -> [OrgInline]
ppMO (mdl, occ) =
[ Link (text $ "#" ++ moToString (mdl, occ))
[plaintext $ moToString (mdl, occ)]
]
ppHsForAllTelescope :: HsForAllTelescope DocNameI -> [OrgInline]
ppHsForAllTelescope (HsForAllInvis _ bndrs) =
intercalate [Whitespace] ([plaintext "forall"] : map ppLHsTyVarBndr bndrs)
ppHsForAllTelescope _ = [plaintext $ unimp "HsForAllTelescope"]
ppLHsTyVarBndr :: LHsTyVarBndr a DocNameI -> [OrgInline]
ppLHsTyVarBndr (L _ x) = ppHsTyVarBndr x
ppHsTyVarBndr :: HsTyVarBndr a DocNameI -> [OrgInline]
ppHsTyVarBndr (UserTyVar _ _ (L _ docName)) = [Plain $ docNameToDoc docName]
ppHsTyVarBndr (KindedTyVar _ _ (L _ docName) (L _ ty)) =
orgParens $ Plain (docNameToDoc docName) : plaintext " :: " : ppHsType ty
ppOccName :: OccName -> PDoc
ppOccName = text . occNameString
ppName :: Name -> PDoc
ppName = ppOccName . nameOccName
docNameToDoc :: DocName -> PDoc
docNameToDoc = ppName . getName
docNameToString :: DocName -> String
docNameToString = occNameString . nameOccName . getName
ppWrapped :: (a -> [OrgInline]) -> Wrap a -> [OrgInline]
ppWrapped p (Unadorned n) = p n
ppWrapped p (Parenthesized n) = orgParens $ p n
ppWrapped p (Backticked n) = plaintext "`" : p n ++ [plaintext "`"]
wrapDocNameToString :: Wrap DocName -> String
wrapDocNameToString = showWrapped docNameToString
wrapMOToString :: Wrap (ModuleName, OccName) -> String
wrapMOToString = showWrapped moToString
moToString :: (ModuleName, OccName) -> String
moToString (mdl, occ) = moduleNameString mdl ++ "." ++ occNameString occ
removeMarkup :: Doc DocName -> String
removeMarkup = markup (plainMarkup wrapMOToString wrapDocNameToString)
removeMarkup' :: Doc RdrName -> String
removeMarkup' = markup (plainMarkup wrapMOToString (showWrapped showPprUnsafe))
orgUnbox :: [OrgInline] -> [OrgInline]
orgUnbox xs = interNotNull [Whitespace] [[plaintext "#"], xs, [plaintext "#"]]
-- * Utilities
interNotNull :: [a] -> [[a]] -> [a]
interNotNull xs = intercalate xs . filter (not . null)
tyvarNames :: LHsQTyVars DocNameI -> [Name]
tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit
ppLHsQTyVars :: LHsQTyVars DocNameI -> [OrgInline]
ppLHsQTyVars (HsQTvs _ bndrs) =
intercalate [Whitespace] (map ppLHsTyVarBndr bndrs)
ppLHsQTyVars _ = [plaintext $ unimp "LHsQTyVars"]
isBlock :: DocH mod id -> Bool
isBlock DocEmpty = True
isBlock (DocAppend x y ) = isBlock x || isBlock y
isBlock (DocString _) = False
isBlock (DocParagraph _) = True
isBlock (DocIdentifier _) = False
isBlock (DocIdentifierUnchecked _) = False
isBlock (DocModule _) = False
isBlock (DocWarning _) = False
isBlock (DocEmphasis _) = False
isBlock (DocMonospaced _) = False
isBlock (DocBold _) = False
isBlock (DocUnorderedList _) = True
isBlock (DocOrderedList _) = True
isBlock (DocDefList _) = True
isBlock (DocCodeBlock _) = True
isBlock (DocHyperlink _) = False
isBlock (DocPic _) = False
isBlock (DocMathInline _) = False
isBlock (DocMathDisplay _) = True
isBlock (DocAName _) = False
isBlock (DocProperty _) = False
isBlock (DocExamples _) = True
isBlock (DocHeader _) = True
isBlock (DocTable _) = True
cleanPkgStr :: String -> String
cleanPkgStr = removeHash . removeInplace
removeInplace :: String -> String
removeInplace s | isSuffixOf "-inplace" s = take (length s - 8) s
removeInplace s = s
-- A silly heuristic that removes the last 65 chars if the string is longer than 65 chars
-- useful for removing hash from a unit id string like
-- sqlite-simple-0.4.18.2-fe5243655374e8f6ef336683926e98123d2de2f3265d2b935e0897c09586970b
removeHash :: String -> String
removeHash s | length s > 65 = take (length s - 65) s
removeHash s = s
hackagePackageUrl :: String -> String
hackagePackageUrl pkg = "https://hackage.haskell.org/package/" ++ pkg
hackageModuleUrl :: String -> String -> String
hackageModuleUrl pkg mdl =
hackagePackageUrl pkg ++ "/docs/" ++ dotsToDashes mdl ++ ".html"
where dotsToDashes = map (\c -> if c == '.' then '-' else c)
-- * Orphan instances for show
instance Show DocName where
show = showPprUnsafe
instance Show OccName where
show = showPprUnsafe