path: root/haddock-api/src/Haddock/Backends/Org.hs

{-
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 #-}
{-# 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 _ 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 (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