Adding org backend.

3 files changed, 1582 insertions, 220 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..cdd95d42
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Org.hs
@@ -0,0 +1,1016 @@
+{-# 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 =
+  headingPlainTextCId title pkgId packageLevel
+    : 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     = headingPlainTextCId mdl (pkg ++ "." ++ mdl) modLevel
+    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
+
+-- 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
+
+hackageUrl :: String -> String -> String -> Bool -> String
+-- module should be of the form GHC-Hs-Decls instead of GHC.Hs.Decls
+hackageUrl pkg mdl id isSub =
+  "https://hackage.haskell.org/package/"
+    ++ pkg
+    ++ "/docs/"
+    ++ mdl
+    ++ ".html#"
+    ++ if isSub then "v" else "t" ++ ":" ++ id
+
+-- * 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..81f2add5
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Org/Types.hs
@@ -0,0 +1,237 @@
+{-# 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)]
+
+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 "]"]
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index 78bfe1a1..e9fd0c5d 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -12,53 +12,56 @@
 --
 -- Definition of the command line interface of Haddock.
 -----------------------------------------------------------------------------
-module Haddock.Options (
-  parseHaddockOpts,
-  Flag(..),
-  Visibility(..),
-  getUsage,
-  optTitle,
-  outputDir,
-  optContentsUrl,
-  optIndexUrl,
-  optCssFile,
-  optSourceCssFile,
-  sourceUrls,
-  wikiUrls,
-  baseUrl,
-  optParCount,
-  optDumpInterfaceFile,
-  optShowInterfaceFile,
-  optLaTeXStyle,
-  optMathjax,
-  qualification,
-  sinceQualification,
-  verbosity,
-  ghcFlags,
-  reexportFlags,
-  readIfaceArgs,
-  optPackageName,
-  optPackageVersion,
-  modulePackageInfo,
-  ignoredSymbols
-) where
-
-
-import qualified Data.Char as Char
-import           Data.Version
+module Haddock.Options
+  ( parseHaddockOpts
+  , Flag(..)
+  , Visibility(..)
+  , getUsage
+  , optTitle
+  , outputDir
+  , optContentsUrl
+  , optIndexUrl
+  , optCssFile
+  , optSourceCssFile
+  , sourceUrls
+  , wikiUrls
+  , baseUrl
+  , optParCount
+  , optDumpInterfaceFile
+  , optShowInterfaceFile
+  , optLaTeXStyle
+  , optMathjax
+  , qualification
+  , sinceQualification
+  , verbosity
+  , ghcFlags
+  , reexportFlags
+  , readIfaceArgs
+  , optPackageName
+  , optPackageVersion
+  , modulePackageInfo
+  , ignoredSymbols
+  ) where
+
+
 import           Control.Applicative
+import qualified Data.Char                     as Char
+import           Data.Version
+import           GHC                            ( Module
+                                                , moduleUnit
+                                                )
 import           GHC.Data.FastString
-import           GHC ( Module, moduleUnit )
 import           GHC.Unit.State
 import           Haddock.Types
 import           Haddock.Utils
 import           System.Console.GetOpt
-import qualified Text.ParserCombinators.ReadP as RP
+import qualified Text.ParserCombinators.ReadP  as RP
 
 
 data Flag
   = Flag_BuiltInThemes
   | Flag_CSS String
+  | Flag_Org
 --  | Flag_DocBook
   | Flag_ReadInterface String
   | Flag_DumpInterface String
@@ -120,119 +123,231 @@ data Flag
 
 options :: Bool -> [OptDescr Flag]
 options backwardsCompat =
-  [
-    Option ['B']  []     (ReqArg Flag_GhcLibDir "DIR")
-      "path to a GHC lib dir, to override the default path",
-    Option ['o']  ["odir"]     (ReqArg Flag_OutputDir "DIR")
-      "directory in which to put the output files",
-    Option ['l']  ["lib"]         (ReqArg Flag_Lib "DIR")
-      "location of Haddock's auxiliary files",
-    Option ['i'] ["read-interface"] (ReqArg Flag_ReadInterface "FILE")
-      "read an interface from FILE",
-    Option ['D']  ["dump-interface"] (ReqArg Flag_DumpInterface "FILE")
-      "write the resulting interface to FILE",
-    Option []     ["show-interface"] (ReqArg Flag_ShowInterface "FILE")
-      "print the interface in a human readable form",
+  [ Option ['B']
+           []
+           (ReqArg Flag_GhcLibDir "DIR")
+           "path to a GHC lib dir, to override the default path"
+  , Option ['o']
+           ["odir"]
+           (ReqArg Flag_OutputDir "DIR")
+           "directory in which to put the output files"
+  , Option ['l']
+           ["lib"]
+           (ReqArg Flag_Lib "DIR")
+           "location of Haddock's auxiliary files"
+  , Option ['i']
+           ["read-interface"]
+           (ReqArg Flag_ReadInterface "FILE")
+           "read an interface from FILE"
+  , Option ['D']
+           ["dump-interface"]
+           (ReqArg Flag_DumpInterface "FILE")
+           "write the resulting interface to FILE"
+  , Option []
+           ["show-interface"]
+           (ReqArg Flag_ShowInterface "FILE")
+           "print the interface in a human readable form"
+  ,
 --    Option ['S']  ["docbook"]  (NoArg Flag_DocBook)
 --  "output in DocBook XML",
-    Option ['h']  ["html"]     (NoArg Flag_Html)
-      "output in HTML (XHTML 1.0)",
-    Option []  ["latex"]  (NoArg Flag_LaTeX) "use experimental LaTeX rendering",
-    Option []  ["latex-style"]  (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE",
-    Option []  ["mathjax"]  (ReqArg Flag_Mathjax "URL") "URL FOR mathjax",
-    Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output",
-    Option []  ["hoogle"]     (NoArg Flag_Hoogle)
-      "output for Hoogle; you may want --package-name and --package-version too",
-    Option [] ["quickjump"] (NoArg Flag_QuickJumpIndex)
-      "generate an index for interactive documentation navigation",
-    Option [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource)
-      "generate highlighted and hyperlinked source code (for use with --html)",
-    Option [] ["source-css"] (ReqArg Flag_SourceCss "FILE")
-      "use custom CSS file instead of default one in hyperlinked source",
-    Option []  ["source-base"]   (ReqArg Flag_SourceBaseURL "URL")
-      "URL for a source code link on the contents\nand index pages",
-    Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"])
-      (ReqArg Flag_SourceModuleURL "URL")
-      "URL for a source code link for each module\n(using the %{FILE} or %{MODULE} vars)",
-    Option []  ["source-entity"]  (ReqArg Flag_SourceEntityURL "URL")
-      "URL for a source code link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)",
-    Option []  ["source-entity-line"] (ReqArg Flag_SourceLEntityURL "URL")
-      "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.",
-    Option []  ["comments-base"]   (ReqArg Flag_WikiBaseURL "URL")
-      "URL for a comments link on the contents\nand index pages",
-    Option [] ["base-url"] (ReqArg Flag_BaseURL "URL")
-      "Base URL for static assets (eg. css, javascript, json files etc.).\nWhen given statis assets will not be copied.",
-    Option []  ["comments-module"]  (ReqArg Flag_WikiModuleURL "URL")
-      "URL for a comments link for each module\n(using the %{MODULE} var)",
-    Option []  ["comments-entity"]  (ReqArg Flag_WikiEntityURL "URL")
-      "URL for a comments link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)",
-    Option ['c']  ["css", "theme"] (ReqArg Flag_CSS "PATH")
-      "the CSS file or theme directory to use for HTML output",
-    Option []  ["built-in-themes"] (NoArg Flag_BuiltInThemes)
-      "include all the built-in haddock themes",
-    Option ['p']  ["prologue"] (ReqArg Flag_Prologue "FILE")
-      "file containing prologue text",
-    Option ['t']  ["title"]    (ReqArg Flag_Heading "TITLE")
-      "page heading",
-    Option ['q']  ["qual"] (ReqArg Flag_Qualification "QUAL")
-      "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'aliased'",
-    Option ['?']  ["help"]  (NoArg Flag_Help)
-      "display this help and exit",
-    Option ['V']  ["version"]  (NoArg Flag_Version)
-      "output version information and exit",
-    Option []  ["compatible-interface-versions"]  (NoArg Flag_CompatibleInterfaceVersions)
-      "output compatible interface file versions and exit",
-    Option []  ["interface-version"]  (NoArg Flag_InterfaceVersion)
-      "output interface file version and exit",
-    Option []  ["bypass-interface-version-check"] (NoArg Flag_BypassInterfaceVersonCheck)
-      "bypass the interface file version check (dangerous)",
-    Option ['v']  ["verbosity"]  (ReqArg Flag_Verbosity "VERBOSITY")
-      "set verbosity level",
-    Option [] ["use-contents"] (ReqArg Flag_UseContents "URL")
-      "use a separately-generated HTML contents page",
-    Option [] ["gen-contents"] (NoArg Flag_GenContents)
-      "generate an HTML contents from specified\ninterfaces",
-    Option [] ["use-index"] (ReqArg Flag_UseIndex "URL")
-      "use a separately-generated HTML index",
-    Option [] ["gen-index"] (NoArg Flag_GenIndex)
-      "generate an HTML index from specified\ninterfaces",
-    Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports)
-      "behave as if all modules have the\nignore-exports attribute",
-    Option [] ["hide"] (ReqArg Flag_HideModule "MODULE")
-      "behave as if MODULE has the hide attribute",
-    Option [] ["show"] (ReqArg Flag_ShowModule "MODULE")
-      "behave as if MODULE does not have the hide attribute",
-    Option [] ["show-all"] (NoArg Flag_ShowAllModules)
-      "behave as if not modules have the hide attribute",
-    Option [] ["show-extensions"] (ReqArg Flag_ShowExtensions "MODULE")
-      "behave as if MODULE has the show-extensions attribute",
-    Option [] ["optghc"] (ReqArg Flag_OptGhc "OPTION")
-      "option to be forwarded to GHC",
-    Option []  ["ghc-version"]  (NoArg Flag_GhcVersion)
-      "output GHC version in numeric format",
-    Option []  ["print-ghc-path"]  (NoArg Flag_PrintGhcPath)
-      "output path to GHC binary",
-    Option []  ["print-ghc-libdir"]  (NoArg Flag_PrintGhcLibDir)
-      "output GHC lib dir",
-    Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings",
-    Option [] ["no-tmp-comp-dir"] (NoArg Flag_NoTmpCompDir)
-      "do not re-direct compilation output to a temporary directory",
-    Option [] ["pretty-html"] (NoArg Flag_PrettyHtml)
-      "generate html with newlines and indenting (for use with --html)",
-    Option [] ["no-print-missing-docs"] (NoArg Flag_NoPrintMissingDocs)
-      "don't print information about any undocumented entities",
-    Option []  ["reexport"] (ReqArg Flag_Reexport "MOD")
-      "reexport the module MOD, adding it to the index",
-    Option [] ["package-name"] (ReqArg Flag_PackageName "NAME")
-      "name of the package being documented",
-    Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION")
-      "version of the package being documented in usual x.y.z.w format",
-    Option []  ["since-qual"] (ReqArg Flag_SinceQualification "QUAL")
-      "package qualification of @since, one of\n'always' (default) or 'only-external'",
-    Option [] ["ignore-link-symbol"] (ReqArg Flag_IgnoreLinkSymbol "SYMBOL")
-      "name of a symbol which does not trigger a warning in case of link issue",
-    Option ['j'] [] (OptArg (\count -> Flag_ParCount (fmap read count)) "n")
-      "load modules in parallel"
+    Option ['h'] ["html"]  (NoArg Flag_Html)  "output in HTML (XHTML 1.0)"
+  , Option ['O'] ["org"]   (NoArg Flag_Org)   "output in Org"
+  , Option []    ["latex"] (NoArg Flag_LaTeX) "use experimental LaTeX rendering"
+  , Option []
+           ["latex-style"]
+           (ReqArg Flag_LaTeXStyle "FILE")
+           "provide your own LaTeX style in FILE"
+  , Option [] ["mathjax"] (ReqArg Flag_Mathjax "URL") "URL FOR mathjax"
+  , Option ['U']
+           ["use-unicode"]
+           (NoArg Flag_UseUnicode)
+           "use Unicode in HTML output"
+  , Option
+    []
+    ["hoogle"]
+    (NoArg Flag_Hoogle)
+    "output for Hoogle; you may want --package-name and --package-version too"
+  , Option []
+           ["quickjump"]
+           (NoArg Flag_QuickJumpIndex)
+           "generate an index for interactive documentation navigation"
+  , Option
+    []
+    ["hyperlinked-source"]
+    (NoArg Flag_HyperlinkedSource)
+    "generate highlighted and hyperlinked source code (for use with --html)"
+  , Option []
+           ["source-css"]
+           (ReqArg Flag_SourceCss "FILE")
+           "use custom CSS file instead of default one in hyperlinked source"
+  , Option []
+           ["source-base"]
+           (ReqArg Flag_SourceBaseURL "URL")
+           "URL for a source code link on the contents\nand index pages"
+  , Option
+    ['s']
+    (if backwardsCompat then ["source", "source-module"] else ["source-module"])
+    (ReqArg Flag_SourceModuleURL "URL")
+    "URL for a source code link for each module\n(using the %{FILE} or %{MODULE} vars)"
+  , Option
+    []
+    ["source-entity"]
+    (ReqArg Flag_SourceEntityURL "URL")
+    "URL for a source code link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)"
+  , Option
+    []
+    ["source-entity-line"]
+    (ReqArg Flag_SourceLEntityURL "URL")
+    "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices."
+  , Option []
+           ["comments-base"]
+           (ReqArg Flag_WikiBaseURL "URL")
+           "URL for a comments link on the contents\nand index pages"
+  , Option
+    []
+    ["base-url"]
+    (ReqArg Flag_BaseURL "URL")
+    "Base URL for static assets (eg. css, javascript, json files etc.).\nWhen given statis assets will not be copied."
+  , Option
+    []
+    ["comments-module"]
+    (ReqArg Flag_WikiModuleURL "URL")
+    "URL for a comments link for each module\n(using the %{MODULE} var)"
+  , Option
+    []
+    ["comments-entity"]
+    (ReqArg Flag_WikiEntityURL "URL")
+    "URL for a comments link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)"
+  , Option ['c']
+           ["css", "theme"]
+           (ReqArg Flag_CSS "PATH")
+           "the CSS file or theme directory to use for HTML output"
+  , Option []
+           ["built-in-themes"]
+           (NoArg Flag_BuiltInThemes)
+           "include all the built-in haddock themes"
+  , Option ['p']
+           ["prologue"]
+           (ReqArg Flag_Prologue "FILE")
+           "file containing prologue text"
+  , Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE") "page heading"
+  , Option
+    ['q']
+    ["qual"]
+    (ReqArg Flag_Qualification "QUAL")
+    "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'aliased'"
+  , Option ['?'] ["help"] (NoArg Flag_Help) "display this help and exit"
+  , Option ['V']
+           ["version"]
+           (NoArg Flag_Version)
+           "output version information and exit"
+  , Option []
+           ["compatible-interface-versions"]
+           (NoArg Flag_CompatibleInterfaceVersions)
+           "output compatible interface file versions and exit"
+  , Option []
+           ["interface-version"]
+           (NoArg Flag_InterfaceVersion)
+           "output interface file version and exit"
+  , Option []
+           ["bypass-interface-version-check"]
+           (NoArg Flag_BypassInterfaceVersonCheck)
+           "bypass the interface file version check (dangerous)"
+  , Option ['v']
+           ["verbosity"]
+           (ReqArg Flag_Verbosity "VERBOSITY")
+           "set verbosity level"
+  , Option []
+           ["use-contents"]
+           (ReqArg Flag_UseContents "URL")
+           "use a separately-generated HTML contents page"
+  , Option []
+           ["gen-contents"]
+           (NoArg Flag_GenContents)
+           "generate an HTML contents from specified\ninterfaces"
+  , Option []
+           ["use-index"]
+           (ReqArg Flag_UseIndex "URL")
+           "use a separately-generated HTML index"
+  , Option []
+           ["gen-index"]
+           (NoArg Flag_GenIndex)
+           "generate an HTML index from specified\ninterfaces"
+  , Option []
+           ["ignore-all-exports"]
+           (NoArg Flag_IgnoreAllExports)
+           "behave as if all modules have the\nignore-exports attribute"
+  , Option []
+           ["hide"]
+           (ReqArg Flag_HideModule "MODULE")
+           "behave as if MODULE has the hide attribute"
+  , Option []
+           ["show"]
+           (ReqArg Flag_ShowModule "MODULE")
+           "behave as if MODULE does not have the hide attribute"
+  , Option []
+           ["show-all"]
+           (NoArg Flag_ShowAllModules)
+           "behave as if not modules have the hide attribute"
+  , Option []
+           ["show-extensions"]
+           (ReqArg Flag_ShowExtensions "MODULE")
+           "behave as if MODULE has the show-extensions attribute"
+  , Option []
+           ["optghc"]
+           (ReqArg Flag_OptGhc "OPTION")
+           "option to be forwarded to GHC"
+  , Option []
+           ["ghc-version"]
+           (NoArg Flag_GhcVersion)
+           "output GHC version in numeric format"
+  , Option []
+           ["print-ghc-path"]
+           (NoArg Flag_PrintGhcPath)
+           "output path to GHC binary"
+  , Option []
+           ["print-ghc-libdir"]
+           (NoArg Flag_PrintGhcLibDir)
+           "output GHC lib dir"
+  , Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings"
+  , Option []
+           ["no-tmp-comp-dir"]
+           (NoArg Flag_NoTmpCompDir)
+           "do not re-direct compilation output to a temporary directory"
+  , Option []
+           ["pretty-html"]
+           (NoArg Flag_PrettyHtml)
+           "generate html with newlines and indenting (for use with --html)"
+  , Option []
+           ["no-print-missing-docs"]
+           (NoArg Flag_NoPrintMissingDocs)
+           "don't print information about any undocumented entities"
+  , Option []
+           ["reexport"]
+           (ReqArg Flag_Reexport "MOD")
+           "reexport the module MOD, adding it to the index"
+  , Option []
+           ["package-name"]
+           (ReqArg Flag_PackageName "NAME")
+           "name of the package being documented"
+  , Option []
+           ["package-version"]
+           (ReqArg Flag_PackageVersion "VERSION")
+           "version of the package being documented in usual x.y.z.w format"
+  , Option
+    []
+    ["since-qual"]
+    (ReqArg Flag_SinceQualification "QUAL")
+    "package qualification of @since, one of\n'always' (default) or 'only-external'"
+  , Option
+    []
+    ["ignore-link-symbol"]
+    (ReqArg Flag_IgnoreLinkSymbol "SYMBOL")
+    "name of a symbol which does not trigger a warning in case of link issue"
+  , Option ['j']
+           []
+           (OptArg (\count -> Flag_ParCount (fmap read count)) "n")
+           "load modules in parallel"
   ]
 
 
@@ -240,23 +355,22 @@ getUsage :: IO String
 getUsage = do
   prog <- getProgramName
   return $ usageInfo (usageHeader prog) (options False)
-  where
-    usageHeader :: String -> String
-    usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n"
+ where
+  usageHeader :: String -> String
+  usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n"
 
 
 parseHaddockOpts :: [String] -> IO ([Flag], [String])
-parseHaddockOpts params =
-  case getOpt Permute (options True) params  of
-    (flags, args, []) -> return (flags, args)
-    (_, _, errors)    -> do
-      usage <- getUsage
-      throwE (concat errors ++ usage)
+parseHaddockOpts params = case getOpt Permute (options True) params of
+  (flags, args, []    ) -> return (flags, args)
+  (_    , _   , errors) -> do
+    usage <- getUsage
+    throwE (concat errors ++ usage)
 
 optPackageVersion :: [Flag] -> Maybe Data.Version.Version
 optPackageVersion flags =
   let ver = optLast [ v | Flag_PackageVersion v <- flags ]
-  in ver >>= fmap fst . optLast . RP.readP_to_S parseVersion
+  in  ver >>= fmap fst . optLast . RP.readP_to_S parseVersion
 
 optPackageName :: [Flag] -> Maybe PackageName
 optPackageName flags =
@@ -264,17 +378,15 @@ optPackageName flags =
 
 
 optTitle :: [Flag] -> Maybe String
-optTitle flags =
-  case [str | Flag_Heading str <- flags] of
-    [] -> Nothing
-    (t:_) -> Just t
+optTitle flags = case [ str | Flag_Heading str <- flags ] of
+  []      -> Nothing
+  (t : _) -> Just t
 
 
 outputDir :: [Flag] -> FilePath
-outputDir flags =
-  case [ path | Flag_OutputDir path <- flags ] of
-    []    -> "."
-    paths -> last paths
+outputDir flags = case [ path | Flag_OutputDir path <- flags ] of
+  []    -> "."
+  paths -> last paths
 
 
 optContentsUrl :: [Flag] -> Maybe String
@@ -291,23 +403,26 @@ optCssFile flags = optLast [ str | Flag_CSS str <- flags ]
 optSourceCssFile :: [Flag] -> Maybe FilePath
 optSourceCssFile flags = optLast [ str | Flag_SourceCss str <- flags ]
 
-sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String)
+sourceUrls
+  :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String)
 sourceUrls flags =
-  (optLast [str | Flag_SourceBaseURL    str <- flags]
-  ,optLast [str | Flag_SourceModuleURL  str <- flags]
-  ,optLast [str | Flag_SourceEntityURL  str <- flags]
-  ,optLast [str | Flag_SourceLEntityURL str <- flags])
+  ( optLast [ str | Flag_SourceBaseURL str <- flags ]
+  , optLast [ str | Flag_SourceModuleURL str <- flags ]
+  , optLast [ str | Flag_SourceEntityURL str <- flags ]
+  , optLast [ str | Flag_SourceLEntityURL str <- flags ]
+  )
 
 
 wikiUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)
 wikiUrls flags =
-  (optLast [str | Flag_WikiBaseURL   str <- flags]
-  ,optLast [str | Flag_WikiModuleURL str <- flags]
-  ,optLast [str | Flag_WikiEntityURL str <- flags])
+  ( optLast [ str | Flag_WikiBaseURL str <- flags ]
+  , optLast [ str | Flag_WikiModuleURL str <- flags ]
+  , optLast [ str | Flag_WikiEntityURL str <- flags ]
+  )
 
 
 baseUrl :: [Flag] -> Maybe String
-baseUrl flags = optLast [str | Flag_BaseURL str <- flags]
+baseUrl flags = optLast [ str | Flag_BaseURL str <- flags ]
 
 optDumpInterfaceFile :: [Flag] -> Maybe FilePath
 optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ]
@@ -327,31 +442,30 @@ optParCount flags = optLast [ n | Flag_ParCount n <- flags ]
 qualification :: [Flag] -> Either String QualOption
 qualification flags =
   case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of
-      []             -> Right OptNoQual
-      ["none"]       -> Right OptNoQual
-      ["full"]       -> Right OptFullQual
-      ["local"]      -> Right OptLocalQual
-      ["relative"]   -> Right OptRelativeQual
-      ["aliased"]    -> Right OptAliasedQual
-      [arg]          -> Left $ "unknown qualification type " ++ show arg
-      _:_            -> Left "qualification option given multiple times"
+    []            -> Right OptNoQual
+    [ "none"    ] -> Right OptNoQual
+    [ "full"    ] -> Right OptFullQual
+    [ "local"   ] -> Right OptLocalQual
+    [ "relative"] -> Right OptRelativeQual
+    [ "aliased" ] -> Right OptAliasedQual
+    [ arg       ] -> Left $ "unknown qualification type " ++ show arg
+    _ :         _ -> Left "qualification option given multiple times"
 
 sinceQualification :: [Flag] -> Either String SinceQual
 sinceQualification flags =
   case map (map Char.toLower) [ str | Flag_SinceQualification str <- flags ] of
-      []             -> Right Always
-      ["always"]     -> Right Always
-      ["external"]   -> Right External
-      [arg]          -> Left $ "unknown since-qualification type " ++ show arg
-      _:_            -> Left "since-qualification option given multiple times"
+    []            -> Right Always
+    [ "always"  ] -> Right Always
+    [ "external"] -> Right External
+    [ arg       ] -> Left $ "unknown since-qualification type " ++ show arg
+    _ :         _ -> Left "since-qualification option given multiple times"
 
 verbosity :: [Flag] -> Verbosity
-verbosity flags =
-  case [ str | Flag_Verbosity str <- flags ] of
-    []  -> Normal
-    x:_ -> case parseVerbosity x of
-      Left e -> throwE e
-      Right v -> v
+verbosity flags = case [ str | Flag_Verbosity str <- flags ] of
+  []    -> Normal
+  x : _ -> case parseVerbosity x of
+    Left  e -> throwE e
+    Right v -> v
 
 ignoredSymbols :: [Flag] -> [String]
 ignoredSymbols flags = [ symbol | Flag_IgnoreLinkSymbol symbol <- flags ]
@@ -367,26 +481,21 @@ data Visibility = Visible | Hidden
 
 readIfaceArgs :: [Flag] -> [(DocPaths, Visibility, FilePath)]
 readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]
-  where
-    parseIfaceOption :: String -> (DocPaths, Visibility, FilePath)
-    parseIfaceOption str =
-      case break (==',') str of
-        (fpath, ',':rest) ->
-          case break (==',') rest of
-            (src, ',':rest') ->
-              let src' = case src of
-                    "" -> Nothing
-                    _  -> Just src
-              in
-              case break (==',') rest' of
-                (visibility, ',':file) | visibility == "hidden" ->
-                  ((fpath, src'), Hidden, file)
-                                       | otherwise ->
-                  ((fpath, src'), Visible, file)
-                (file, _) ->
-                  ((fpath, src'), Visible, file)
-            (file, _) -> ((fpath, Nothing), Visible, file)
-        (file, _) -> (("", Nothing), Visible, file)
+ where
+  parseIfaceOption :: String -> (DocPaths, Visibility, FilePath)
+  parseIfaceOption str = case break (== ',') str of
+    (fpath, ',' : rest) -> case break (== ',') rest of
+      (src, ',' : rest') ->
+        let src' = case src of
+              "" -> Nothing
+              _  -> Just src
+        in  case break (== ',') rest' of
+              (visibility, ',' : file)
+                | visibility == "hidden" -> ((fpath, src'), Hidden, file)
+                | otherwise              -> ((fpath, src'), Visible, file)
+              (file, _) -> ((fpath, src'), Visible, file)
+      (file, _) -> ((fpath, Nothing), Visible, file)
+    (file, _) -> (("", Nothing), Visible, file)
 
 
 -- | Like 'listToMaybe' but returns the last element instead of the first.
@@ -401,16 +510,16 @@ optLast xs = Just (last xs)
 --
 -- The @--package-name@ and @--package-version@ Haddock flags allow the user to
 -- specify this information manually and it is returned here if present.
-modulePackageInfo :: UnitState
-                  -> [Flag] -- ^ Haddock flags are checked as they may contain
+modulePackageInfo
+  :: UnitState
+  -> [Flag] -- ^ Haddock flags are checked as they may contain
                             -- the package name or version provided by the user
                             -- which we prioritise
-                  -> Maybe Module
-                  -> (Maybe PackageName, Maybe Data.Version.Version)
+  -> Maybe Module
+  -> (Maybe PackageName, Maybe Data.Version.Version)
 modulePackageInfo _unit_state _flags Nothing = (Nothing, Nothing)
 modulePackageInfo unit_state flags (Just modu) =
-  ( optPackageName flags    <|> fmap unitPackageName pkgDb
+  ( optPackageName flags <|> fmap unitPackageName pkgDb
   , optPackageVersion flags <|> fmap unitPackageVersion pkgDb
   )
-  where
-    pkgDb = lookupUnit unit_state (moduleUnit modu)
+  where pkgDb = lookupUnit unit_state (moduleUnit modu)