aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r--haddock-api/src/Haddock/Backends/Org.hs1040
-rw-r--r--haddock-api/src/Haddock/Backends/Org/Types.hs260
2 files changed, 1300 insertions, 0 deletions
diff --git a/haddock-api/src/Haddock/Backends/Org.hs b/haddock-api/src/Haddock/Backends/Org.hs
new file mode 100644
index 00000000..9d02d0db
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Org.hs
@@ -0,0 +1,1040 @@
+{-
+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
diff --git a/haddock-api/src/Haddock/Backends/Org/Types.hs b/haddock-api/src/Haddock/Backends/Org/Types.hs
new file mode 100644
index 00000000..9e3534c3
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Org/Types.hs
@@ -0,0 +1,260 @@
+{-
+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 DeriveDataTypeable, DeriveGeneric, FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Haddock.Backends.Org.Types where
+
+import Data.Char ( isSpace )
+import Data.List ( dropWhileEnd
+ , intercalate
+ )
+import Data.Map ( Map )
+import GHC.Utils.Ppr ( ($$)
+ , (<+>)
+ , (<>)
+ , Doc
+ , Mode(..)
+ , brackets
+ , empty
+ , fullRender
+ , hang
+ , hcat
+ , hsep
+ , punctuate
+ , text
+ , txtPrinter
+ , vcat
+ )
+import Prelude hiding ( (<>) )
+
+-- * Some consts
+defListSep :: Doc
+defListSep = text "::"
+
+unorderedBullet, orderedBullet :: String
+unorderedBullet = "-"
+orderedBullet = "."
+
+colons :: Doc -> Doc
+colons doc = text ":" <> doc <> text ":"
+
+-- * Document, Sections and Headings
+
+data OrgDocument = OrgDocument
+ { oDKeywords :: Map String Doc
+ , oDBlocks :: [OrgBlock]
+ }
+ deriving Show
+
+-- todo: handle keywords
+
+type Properties = [(String, String)]
+
+-- * Blocks
+
+-- | Org block. Like a Pandoc Block.
+data OrgBlock
+ = Heading Int [OrgInline] Properties
+ | PlainList ListType [[OrgBlock]]
+ | DefList [DefListItem]
+ | Paragraph [OrgInline]
+ | Table [[[OrgInline]]] [[[OrgInline]]]
+ | SrcBlock Doc
+ | MathDisplay Doc
+ | Example Doc Doc -- expression and result
+ deriving (Show)
+
+-- Lists
+
+data ListType = Ordered | Unordered
+ deriving (Show)
+
+type DefListItem = ([OrgInline], [OrgBlock])
+
+-- * Inlines
+
+-- | Objects (inline elements). Derived from Pandoc's Inline.
+data OrgInline
+ = Plain Doc
+ | Italic [OrgInline]
+ | Bold [OrgInline]
+ | Code Doc
+ | Link Doc [OrgInline]
+ | Anchor Doc
+ | Whitespace
+ | MathInline Doc
+ deriving (Show)
+
+-- * From Org elements to Doc
+
+fromOrgDocument :: OrgDocument -> Doc
+fromOrgDocument (OrgDocument _ blocks) = fromOrgBlocks blocks <> text "\n"
+
+fromOrgBlock :: OrgBlock -> Doc
+fromOrgBlock (Heading level inlines props) = hang
+ (text (replicate level '*') <+> fromOrgInlines inlines)
+ (level + 1)
+ (fromOrgProperties props)
+fromOrgBlock (Paragraph inlines) = fromOrgInlines inlines
+fromOrgBlock (SrcBlock code) =
+ -- The \n followed by <> code makes indentation work, given the code has no indent
+ vcat [text "#+begin_src haskell\n" <> code, text "#+end_src"]
+fromOrgBlock (DefList defs) = vcat $ map
+ (\(term, def) -> fromOrgListItem
+ unorderedBullet
+ (prependInlinesToBlocks (term ++ [Whitespace, plaintext "::", Whitespace])
+ def
+ )
+ )
+ defs
+fromOrgBlock (PlainList Unordered items) =
+ vcat $ map (uncurry fromOrgListItem) (zip (repeat unorderedBullet) items)
+fromOrgBlock (PlainList Ordered items) = vcat $ map
+ (uncurry fromOrgListItem)
+ (zip (map ((++ orderedBullet) . show) [1 ..]) items)
+fromOrgBlock (Example expr res) =
+ (fromOrgBlock (SrcBlock expr)) $$ (text "#+RESULTS:") $$ res
+fromOrgBlock (MathDisplay doc) = doc
+fromOrgBlock (Table header body) =
+ vcat (map fromOrgTableRow header) $$ tableRule len $$ vcat
+ (map fromOrgTableRow body)
+ where
+ len = case header of
+ [] -> case body of
+ [] -> 0
+ h : _ -> length h
+ h : _ -> length h
+
+tableRule :: Int -> Doc
+tableRule n =
+ text "|" <> hcat (punctuate (text "|") (replicate n (text "-"))) <> text "|"
+
+fromOrgTableRow :: [[OrgInline]] -> Doc
+fromOrgTableRow row =
+ text "|" <+> hsep (punctuate (text "|") (map fromOrgInlines row)) <+> text "|"
+
+prependInlinesToBlock :: [OrgInline] -> OrgBlock -> [OrgBlock]
+prependInlinesToBlock [] block = [block]
+prependInlinesToBlock _ (Heading _ _ _) =
+ error "Prepending inlines to a heading!"
+prependInlinesToBlock is (Paragraph is') = [Paragraph (is ++ is')]
+prependInlinesToBlock is block = [Paragraph is, block]
+
+prependInlinesToBlocks :: [OrgInline] -> [OrgBlock] -> [OrgBlock]
+prependInlinesToBlocks is [] = [Paragraph is]
+prependInlinesToBlocks is (h : t) = prependInlinesToBlock is h ++ t
+
+fromOrgProperties :: Properties -> Doc
+fromOrgProperties props | null props = empty
+fromOrgProperties props =
+ colons (text "PROPERTIES")
+ $$ vcat (map (\(prop, value) -> colons (text prop) <+> text value) props)
+ $$ colons (text "END")
+
+fromOrgBlocks :: [OrgBlock] -> Doc
+fromOrgBlocks = vcat . punctuate (text "\n") . map fromOrgBlock
+
+fromOrgBlocksTight :: [OrgBlock] -> Doc
+fromOrgBlocksTight = vcat . map fromOrgBlock
+
+fromOrgListItem :: String -> [OrgBlock] -> Doc
+fromOrgListItem _ [] = empty
+fromOrgListItem bullet (hd : rest) = hang (text bullet <+> fromOrgBlock hd)
+ (length bullet + 1)
+ (fromOrgBlocksTight rest)
+
+fromOrgInline :: OrgInline -> Doc
+fromOrgInline (Plain doc ) = doc
+fromOrgInline (Code doc ) = text "~" <> doc <> text "~"
+fromOrgInline (Link target label) = brackets $ brackets target <> if null label
+ then empty
+ else brackets (fromOrgInlines label)
+fromOrgInline (Bold inlines) = text "*" <> fromOrgInlines inlines <> text "*"
+fromOrgInline (Italic inlines) = text "/" <> fromOrgInlines inlines <> text "/"
+fromOrgInline (Anchor doc ) = text "<<" <> doc <> text ">>"
+fromOrgInline Whitespace = text " "
+fromOrgInline (MathInline doc) = text "\\(" <+> doc <+> text "\\)"
+
+fromOrgInlines :: [OrgInline] -> Doc
+fromOrgInlines = hcat . map fromOrgInline
+
+-- * To string
+
+orgToString :: Doc -> String
+orgToString = fullRender (PageMode True) 0 1 txtPrinter ""
+
+-- * Utilities for creating org elements
+
+cIdProp :: String -> Properties
+cIdProp cid = [("CUSTOM_ID", cid)]
+
+hackageProp :: String -> Properties
+hackageProp url = [("Hackage", url)]
+
+cIdsProp :: [String] -> Properties
+cIdsProp cids = map (\cid -> ("CUSTOM_ID", cid)) cids
+
+plaintext :: String -> OrgInline
+plaintext = Plain . text . unfill
+
+unfill :: String -> String
+unfill "" = ""
+unfill s =
+ let
+ xs = lines s
+ preStripped = head xs : map (dropWhile isSpace) (tail xs)
+ stripped =
+ map (dropWhileEnd isSpace) (init preStripped) ++ [last preStripped]
+ in
+ unwords stripped
+
+fixLeadingStar :: String -> String
+fixLeadingStar =
+ intercalate "\n"
+ . map
+ (\line ->
+ if not (null line) && head line == '*' then ' ' : line else line
+ )
+ . lines
+
+headingPlainText :: String -> Int -> OrgBlock
+headingPlainText title level = Heading level [plaintext title] []
+
+headingPlainTextCId :: String -> String -> Int -> OrgBlock
+headingPlainTextCId title cid level =
+ Heading level [plaintext title] (cIdProp cid)
+
+singleHeadingPlainText :: String -> Int -> [OrgBlock]
+singleHeadingPlainText title level = [headingPlainText title level]
+
+singleHeadingPlain :: Doc -> Int -> [OrgBlock]
+singleHeadingPlain title level = [Heading level [Plain title] []]
+
+singleHeadingPlainCId :: Doc -> String -> Int -> [OrgBlock]
+singleHeadingPlainCId title cid level =
+ [Heading level [Plain title] (cIdProp cid)]
+
+orgParens :: [OrgInline] -> [OrgInline]
+orgParens xs = plaintext "(" : xs ++ [plaintext ")"]
+
+orgBrackets :: [OrgInline] -> [OrgInline]
+orgBrackets xs = plaintext "[" : xs ++ [plaintext "]"]
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 20:58:40 +0000