{- 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 . -} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Haddock.Backends.Org ( ppOrg ) 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 ( HasOccName , isValOcc , nameModule_maybe , nameOccName , occName ) 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 Haddock.Utils ( writeUtf8File ) import Prelude hiding ( (<>) ) import System.Directory import System.FilePath 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) idPathSep :: String idPathSep = "/" -- The main function ppOrg :: String -> Maybe String -> FilePath -> Maybe (Doc RdrName) -> [Interface] -> IO () ppOrg title pkgStr odir mbPrologue ifaces = let org = orgToString $ fromOrgDocument $ toOrgDocument title mbPrologue (fromMaybe "" (cleanPkgStr <$> pkgStr)) ifaces in createDirectoryIfMissing True odir >> writeUtf8File (odir (fromMaybe "haddock" (cleanPkgStr <$> pkgStr) <.> "org")) org 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] (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] (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 valOrTyp :: HasOccName n => n -> String valOrTyp name = if isValOcc (occName name) then "v" else "t" idPathTarget :: Module -> DocName -> String idPathTarget mdl name = "file:" ++ (cleanPkgStr $ unitString $ moduleUnit mdl) ++ ".org::#" ++ intercalate idPathSep [moduleString mdl, valOrTyp name, docNameToString name] idPathNoPkg :: HasOccName n => String -> n -> String idPathNoPkg mdl name = intercalate idPathSep [mdl, valOrTyp name, occNameString (occName name)] cIdPaths :: ModPath -> DocName -> Properties cIdPaths (_, mdl) name = cIdsProp [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 ((\assoc -> ppFamilyDecl assoc False emptyDoc subdocs path (level + 1)) . unLoc ) tcdATs ++ concatMap ((\sig -> ppSig sig emptyDoc subdocs path (level + 1)) . unLoc) tcdSigs -- type family ... where -- TODO: handle infix ppTyClDecl (FamDecl _ familyDecl) docs subdocs path level = ppFamilyDecl familyDecl True docs subdocs path level ppFamilyDecl :: FamilyDecl DocNameI -> Bool -> DocForDecl DocName -> SubDocs -> ModPath -> Int -> [OrgBlock] ppFamilyDecl (FamilyDecl _ info@(ClosedTypeFamily mbEqns) TopLevel (L _ name) tyvars _fixity (L _ resSig) mbInj) isFamDecl docs subdocs path level = Heading level ( ppFamilyInfo info isFamDecl ++ [Whitespace, Plain $ docNameToDoc name, Whitespace] ++ ppLHsQTyVars tyvars ++ ppFamilyResultSig resSig ++ maybe [] ppLInjectivityAnn mbInj ++ [plaintext " where"] ) (cIdPaths path name) : (if isFamDecl then ppDocForDecl docs (Just level) else maybe [] (`ppDocForDecl` (Just level)) (lookup name subdocs) ) ++ concatMap (\x -> ppLTyFamInstEqn x subdocs path (level + 1)) (fromMaybe [] mbEqns) ppFamilyDecl (FamilyDecl _ info TopLevel (L _ name) tyvars _fixity (L _ resSig) mbInj) isFamDecl docs subdocs path level = Heading level ( ppFamilyInfo info isFamDecl ++ [Whitespace, Plain $ docNameToDoc name, Whitespace] ++ ppLHsQTyVars tyvars ++ ppFamilyResultSig resSig ++ maybe [] ppLInjectivityAnn mbInj ) (cIdPaths path name) : (if isFamDecl then ppDocForDecl docs (Just level) else maybe [] (`ppDocForDecl` (Just level)) (lookup name subdocs) ) ppFamilyDecl _ _ docs _ _ level = unimpHeading "FamilyDecl" level : ppDocForDecl docs (Just level) ppFamilyInfo :: FamilyInfo DocNameI -> Bool -> [OrgInline] ppFamilyInfo info isFamDecl = dataOrType : family where dataOrType = case info of DataFamily -> plaintext "data" _ -> plaintext "type" family = if isFamDecl then [plaintext " family"] else [] 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 -> [OrgInline] ppFamilyResultSig (KindSig _ (L _ x)) = [Whitespace, plaintext "::", Whitespace] ++ ppHsType x ppFamilyResultSig (NoSig{}) = [] ppFamilyResultSig (TyVarSig _ x) = [Whitespace, plaintext "=", 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 _ ctxt (L _ body)) i = (ppMbLHsContext (Just ctxt), []) : 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 _ ctxt (L _ body)) = interNotNull [Whitespace] [ppMbLHsContext (Just ctxt), 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 _ promo (L _ lTy) (L _ docName) (L _ rTy)) = intercalate [Whitespace] [ppHsType lTy, ppPromoted promo ++ 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 (idPathTarget mdl docName)) [Plain $ docNameToDoc docName]] ppDocName docName@(Undocumented name) = case nameModule_maybe name of Nothing -> [Plain $ docNameToDoc docName] Just mdl -> ppDocName (Documented name mdl) ppMO :: (ModuleName, OccName) -> [OrgInline] ppMO (mdl, occ) = [ Link (text $ "#" ++ idPathNoPkg (moduleNameString 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