{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE DerivingStrategies #-}

-- | Functions to parse and display Haddock HTML
module Docs.CLI.Haddock
  ( Html
  , HtmlPage
  , Declaration(..)
  , Module(..)
  , Package(..)
  , parseHtmlDocument
  , parseModuleDocs
  , parsePackageDocs
  , sourceLinks
  , fileInfo
  , HasCompletion(..)

  -- general html utils
  , innerString
  , prettyHtml
  , numbered
  , parseHoogleHtml
  , link
  )
  where

import Docs.CLI.Types

import Data.Bifunctor (first)
import Data.List.Extra (unescapeHTML)
import Data.Foldable (fold)
import Control.Monad (foldM)
import Data.Maybe (fromMaybe, mapMaybe, listToMaybe, fromJust)
import Data.List hiding (groupBy)
import Data.List.Extra (breakOn)
import Data.Maybe (isJust)
import Data.Char (isSpace)
import Data.Text (Text)
import Data.Set (Set)
import Data.ByteString.Lazy (ByteString)

import qualified Data.ByteString.Lazy as LB
import qualified Data.Text.Encoding as Text

import qualified Text.HTML.DOM as Html
import qualified Text.XML as Xml
import qualified Data.Text as Text
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Text.PrettyPrint.ANSI.Leijen as P

-- | An html element
newtype Html = Html Xml.Element
  deriving newtype (Int -> Html -> ShowS
[Html] -> ShowS
Html -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Html] -> ShowS
$cshowList :: [Html] -> ShowS
show :: Html -> String
$cshow :: Html -> String
showsPrec :: Int -> Html -> ShowS
$cshowsPrec :: Int -> Html -> ShowS
Show, Html -> Html -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Html -> Html -> Bool
$c/= :: Html -> Html -> Bool
== :: Html -> Html -> Bool
$c== :: Html -> Html -> Bool
Eq)

-- | The root of an html page
newtype HtmlPage = HtmlPage Xml.Element

-- | An exported declaration
data Declaration = Declaration
  { Declaration -> Set Text
dAnchors    :: Set Anchor
  , Declaration -> Text
dAnchor     :: Anchor -- ^ Main declaration anchor
  , Declaration -> Html
dSignature  :: Html
  , Declaration -> Html
dSignatureExpanded :: Html -- ^ Signature with argument documentation, if available.
  , Declaration -> [Html]
dContent    :: [Html]
  , Declaration -> ModuleUrl
dModuleUrl  :: ModuleUrl
  , Declaration -> DeclUrl
dDeclUrl    :: DeclUrl
  , Declaration -> String
dCompletion :: String
  -- ^ string to be used when selecting this declaration with tab completion
  }

data Module = Module
  { Module -> String
mTitle        :: String
  , Module -> Maybe Html
mDescription  :: Maybe Html
  , Module -> [Declaration]
mDeclarations :: [Declaration]
  , Module -> ModuleUrl
mUrl          :: ModuleUrl
  }

data Package = Package
  { Package -> String
pTitle       :: String
  , Package -> Maybe String
pSubTitle    :: Maybe String
  , Package -> Html
pDescription :: Html
  , Package -> Maybe Html
pReadme      :: Maybe Html
  , Package -> [(String, Html)]
pProperties  :: [(String, Html)]
  , Package -> [String]
pModules     :: [String]
  , Package -> PackageUrl
pUrl         :: PackageUrl
  }

-- | Types that can be selected with tab completion
class HasCompletion a where
  completion :: a -> String

instance HasCompletion a => HasCompletion (NonEmpty.NonEmpty a) where
  completion :: NonEmpty a -> String
completion = forall a. HasCompletion a => a -> String
completion forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NonEmpty.head

instance HasCompletion String where
  completion :: ShowS
completion = forall a. a -> a
id

instance HasCompletion Declaration where
  completion :: Declaration -> String
completion = Declaration -> String
dCompletion

instance HasCompletion Module where
  completion :: Module -> String
completion = Module -> String
mTitle

instance HasCompletion Package where
  completion :: Package -> String
completion = Package -> String
pTitle

parseHtmlDocument :: ByteString -> HtmlPage
parseHtmlDocument :: ByteString -> HtmlPage
parseHtmlDocument = Element -> HtmlPage
HtmlPage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document -> Element
Xml.documentRoot forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Document
Html.parseLBS

parseHoogleHtml :: String -> Html
parseHoogleHtml :: String -> Html
parseHoogleHtml
  = Element -> Html
Html
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document -> Element
Xml.documentRoot
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Document
Html.parseLBS
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LB.fromStrict
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\String
v -> String
"<div>" forall a. Semigroup a => a -> a -> a
<> String
v forall a. Semigroup a => a -> a -> a
<> String
"</div>")

pageContent :: HasUrl url => String -> url -> [a] -> a
pageContent :: forall url a. HasUrl url => String -> url -> [a] -> a
pageContent String
ty url
from [a]
parsed =
  case [a]
parsed of
    [a
x] -> a
x
    []  -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Unable to parse page as "forall a. Semigroup a => a -> a -> a
<> String
what
    [a]
_   -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Ambiguous parse for "forall a. Semigroup a => a -> a -> a
<> String
what
    where
      what :: String
what = String
ty forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. HasUrl a => a -> String
getUrl url
from

parseModuleDocs :: ModuleUrl -> HtmlPage -> Module
parseModuleDocs :: ModuleUrl -> HtmlPage -> Module
parseModuleDocs ModuleUrl
murl (HtmlPage Element
root) = forall url a. HasUrl url => String -> url -> [a] -> a
pageContent String
"moduleDocs" ModuleUrl
murl forall a b. (a -> b) -> a -> b
$ do
  Element
body    <- forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"body" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
tag) forall a b. (a -> b) -> a -> b
$ Element -> [Element]
children Element
root
  Element
content <- forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"content" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
id_) forall a b. (a -> b) -> a -> b
$ Element -> [Element]
children Element
body
  let mtitle :: Maybe Element
mtitle = do
        Element
h <- forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"module-header" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
id_) (Element -> [Element]
children Element
content)
        forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"caption" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
class_) (Element -> [Element]
children Element
h)
      mdescription :: Maybe Element
mdescription = forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"description" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
id_) (Element -> [Element]
children Element
content)
  Element
interface <- forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"interface" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
id_) (Element -> [Element]
children Element
content)
  let title :: String
title = Text -> String
Text.unpack forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Element -> Text
innerText Maybe Element
mtitle
  forall (m :: * -> *) a. Monad m => a -> m a
return Module
    { mTitle :: String
mTitle = String
title
    , mDescription :: Maybe Html
mDescription = Element -> Html
Html forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Element
mdescription
    , mDeclarations :: [Declaration]
mDeclarations = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (ModuleUrl -> Html -> Maybe Declaration
parseDeclaration ModuleUrl
murl forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Html
Html) forall a b. (a -> b) -> a -> b
$ Element -> [Element]
children Element
interface
    , mUrl :: ModuleUrl
mUrl = ModuleUrl
murl
    }

noBullets :: Text
noBullets :: Text
noBullets = Text
"hcli-no-bullets"

parseDeclaration :: ModuleUrl -> Html -> Maybe Declaration
parseDeclaration :: ModuleUrl -> Html -> Maybe Declaration
parseDeclaration ModuleUrl
moduleUrl (Html Element
el) = do
  Element
decl <- forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"top" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
class_) [Element
el]
  ([Element
sigHead], [Element]
elements) <- forall (m :: * -> *) a. Monad m => a -> m a
return
    forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall a. Eq a => a -> a -> Bool
is Text
"src" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
class_) forall a b. (a -> b) -> a -> b
$ Element -> [Element]
children Element
decl
  (Maybe Element
argsDocs, [Element]
content) <- forall (m :: * -> *) a. Monad m => a -> m a
return
    forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. [a] -> Maybe a
listToMaybe
    forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall a. Eq a => a -> a -> Bool
is Text
argumentsDocsClass forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
class_) [Element]
elements

  -- we ignore declarations without anchors
  Text
anchor <- forall a. [a] -> Maybe a
listToMaybe (Element -> [Text]
anchors Element
sigHead)

  let
      args :: [Element]
args = case Maybe Element
argsDocs of
        Just Element
ds -> forall a. (a -> [a]) -> (a -> Bool) -> a -> [a]
findDeep Element -> [Element]
children (forall a. Eq a => a -> a -> Bool
is Text
"src" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
class_) Element
ds
        Maybe Element
Nothing -> []

      signature :: Element
signature = Text -> Element -> Element
asTag Text
"div"
        forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Element -> Element -> Element
mergeNodes (Element -> Element
removeTrailingSpaces forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Element -> Maybe Element
removeInvisible Element
sigHead)
        forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Element -> Element
removeLeadingSpaces forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Element
addTrailingSpace) [Element]
args

      signatureExpanded :: Element
signatureExpanded = forall a. a -> Maybe a -> a
fromMaybe Element
signature forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ do
        Element
argsTable <- forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"table"forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
tag) forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Element -> [Element]
children Maybe Element
argsDocs
        return Element
sigHead
          { elementNodes :: [Node]
Xml.elementNodes =
              Element -> [Node]
Xml.elementNodes Element
sigHead forall a. Semigroup a => a -> a -> a
<>
                [ Element -> Node
Xml.NodeElement Element
lineBreak
                , Element -> Node
Xml.NodeElement forall a b. (a -> b) -> a -> b
$ Text -> Element -> Element
setClass Text
noBullets Element
argsTable
                ]
          }

  forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
    { dAnchors :: Set Text
dAnchors = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ Element -> [Text]
anchors Element
el
    , dAnchor :: Text
dAnchor = Text
anchor
    , dSignature :: Html
dSignature = Element -> Html
Html Element
signature
    , dSignatureExpanded :: Html
dSignatureExpanded = Element -> Html
Html Element
signatureExpanded
    , dContent :: [Html]
dContent = Element -> Html
Html forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Element]
content
    , dModuleUrl :: ModuleUrl
dModuleUrl = ModuleUrl
moduleUrl
    , dDeclUrl :: DeclUrl
dDeclUrl = ModuleUrl -> Text -> DeclUrl
DeclUrl ModuleUrl
moduleUrl Text
anchor
    , dCompletion :: String
dCompletion = Text -> String
Text.unpack forall a b. (a -> b) -> a -> b
$ Element -> Text
innerText Element
signature
    }
  where
    argumentsDocsClass :: Text
argumentsDocsClass = Text
"subs arguments"

    lineBreak :: Element
lineBreak = Name -> Map Name Text -> [Node] -> Element
Xml.Element (Text -> Maybe Text -> Maybe Text -> Name
Xml.Name Text
"br" forall a. Maybe a
Nothing forall a. Maybe a
Nothing) forall a. Monoid a => a
mempty []

    removeInvisible :: Element -> Maybe Element
removeInvisible =
      (Node -> Maybe Node) -> Element -> Maybe Element
filterDeep forall a b. (a -> b) -> a -> b
$ \Node
node -> case Node
node of
        Xml.NodeElement Element
e
          | Element -> Text
class_ Element
e forall a. Eq a => a -> a -> Bool
== Text
"selflink" -> forall a. Maybe a
Nothing
        Node
_ -> forall a. a -> Maybe a
Just Node
node

    asTag :: Text -> Element -> Element
asTag Text
t Element
e = Element
e
      { elementName :: Name
Xml.elementName =
          (Element -> Name
Xml.elementName Element
e) { nameLocalName :: Text
Xml.nameLocalName = Text
t }
      }

    setClass :: Text -> Element -> Element
setClass Text
name Element
e = Element
e
      { elementAttributes :: Map Name Text
Xml.elementAttributes =
          forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
            (Text -> Maybe Text -> Maybe Text -> Name
Xml.Name Text
"class" forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
            Text
name
            (Element -> Map Name Text
Xml.elementAttributes Element
e)
      }


    mergeNodes :: Element -> Element -> Element
mergeNodes Element
e1 Element
e2 = Element
e2
      { elementNodes :: [Node]
Xml.elementNodes = Element -> [Node]
Xml.elementNodes Element
e1 forall a. Semigroup a => a -> a -> a
<> Element -> [Node]
Xml.elementNodes Element
e2
      }

    addTrailingSpace :: Element -> Element
addTrailingSpace Element
e = Element
e
      { elementNodes :: [Node]
Xml.elementNodes = Element -> [Node]
Xml.elementNodes Element
e forall a. Semigroup a => a -> a -> a
<> [Text -> Node
Xml.NodeContent Text
" " ]
      }

    removeTrailingSpaces :: Element -> Element
removeTrailingSpaces Element
e = Element
res
      where Xml.NodeElement Element
res = forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Bool -> [Node] -> (Bool, [Node])
rm Bool
False [Element -> Node
Xml.NodeElement Element
e]

    rm :: Bool -> [Node] -> (Bool, [Node])
rm Bool
True [Node]
xs = (Bool
True, [Node]
xs)
    rm Bool
False [] = (Bool
False, [])
    rm Bool
False (Node
x:[Node]
xs) = case Node
x of
      Xml.NodeInstruction Instruction
_ -> Bool -> [Node] -> (Bool, [Node])
rm Bool
False [Node]
xs
      Xml.NodeContent Text
txt -> (Bool
True, Text -> Node
Xml.NodeContent ((Char -> Bool) -> Text -> Text
Text.dropWhileEnd Char -> Bool
isSpace Text
txt) forall a. a -> [a] -> [a]
: [Node]
xs)
      Xml.NodeComment Text
_ -> Bool -> [Node] -> (Bool, [Node])
rm Bool
False [Node]
xs
      Xml.NodeElement Element
e ->
        let (Bool
removed, [Node]
nodes') = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ Bool -> [Node] -> (Bool, [Node])
rm Bool
False forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ Element -> [Node]
Xml.elementNodes Element
e
            e' :: Node
e' = Element -> Node
Xml.NodeElement Element
e { elementNodes :: [Node]
Xml.elementNodes = [Node]
nodes' }
        in
        if Bool
removed
          then (Bool
True, Node
e'forall a. a -> [a] -> [a]
:[Node]
xs)
          else (Node
e'forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> [Node] -> (Bool, [Node])
rm Bool
False [Node]
xs

    removeLeadingSpaces :: Element -> Element
removeLeadingSpaces Element
e = Element
res
      where Xml.NodeElement Element
res = forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Bool -> [Node] -> (Bool, [Node])
rmLeading Bool
False [Element -> Node
Xml.NodeElement Element
e]

    rmLeading :: Bool -> [Node] -> (Bool, [Node])
rmLeading Bool
True [Node]
xs = (Bool
True, [Node]
xs)
    rmLeading Bool
False [] = (Bool
False, [])
    rmLeading Bool
False (Node
x:[Node]
xs) = case Node
x of
      Xml.NodeInstruction Instruction
_ -> Bool -> [Node] -> (Bool, [Node])
rmLeading Bool
False [Node]
xs
      Xml.NodeContent Text
txt -> (Bool
True, Text -> Node
Xml.NodeContent ((Char -> Bool) -> Text -> Text
Text.dropWhile Char -> Bool
isSpace Text
txt) forall a. a -> [a] -> [a]
: [Node]
xs)
      Xml.NodeComment Text
_ -> Bool -> [Node] -> (Bool, [Node])
rmLeading Bool
False [Node]
xs
      Xml.NodeElement Element
e ->
        let (Bool
removed, [Node]
nodes') = Bool -> [Node] -> (Bool, [Node])
rmLeading Bool
False forall a b. (a -> b) -> a -> b
$ Element -> [Node]
Xml.elementNodes Element
e
            e' :: Node
e' = Element -> Node
Xml.NodeElement Element
e { elementNodes :: [Node]
Xml.elementNodes = [Node]
nodes' }
        in
        if Bool
removed
          then (Bool
True, Node
e'forall a. a -> [a] -> [a]
:[Node]
xs)
          else (Node
e'forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> [Node] -> (Bool, [Node])
rmLeading Bool
False [Node]
xs

parsePackageDocs :: PackageUrl -> HtmlPage -> Package
parsePackageDocs :: PackageUrl -> HtmlPage -> Package
parsePackageDocs PackageUrl
url (HtmlPage Element
root) = forall url a. HasUrl url => String -> url -> [a] -> a
pageContent String
"packageDocs" PackageUrl
url forall a b. (a -> b) -> a -> b
$ do
  Element
body        <- forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"body" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
tag) (Element -> [Element]
children Element
root)
  Element
content     <- forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"content" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
id_) (Element -> [Element]
children Element
body)
  Element
heading     <- forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"h1" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
tag) (Element -> [Element]
children Element
content)
  Element
title       <- forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"a" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
tag) (Element -> [Element]
children Element
heading)
  Element
description <- (Element -> Bool) -> Element -> [Element]
findRec (forall a. Eq a => a -> a -> Bool
is Text
"description" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
id_) Element
content
  Element
moduleList  <- (Element -> Bool) -> Element -> [Element]
findRec (forall a. Eq a => a -> a -> Bool
is Text
"modules" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
id_) Element
content
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"module-list" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
id_) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Element]
children
  let
    readme :: Maybe Element
readme = forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"readme-container" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
id_) (Element -> [Element]
children Element
content)
        forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"embedded-author-content" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
class_) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Element]
children

    subTitle :: Maybe Element
subTitle = forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"small" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
tag) (Element -> [Element]
children Element
heading)

    properties :: [(String, Html)]
properties = do
      Element
wrapper <- forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"properties" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
id_) (Element -> [Element]
children Element
content)
             forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"table" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
tag) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Element]
children
             forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"tbody" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
tag) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Element]
children
      Element
prop    <- forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
is Text
"tr" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
tag) (Element -> [Element]
children Element
wrapper)
      String
ptitle  <-
        forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [String]
uninterestingProps)
        forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ShowS
unescapeHTML forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
innerText)
        forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"th" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
tag) (Element -> [Element]
children Element
prop)
      Element
pdesc <- forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"td" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
tag) (Element -> [Element]
children Element
prop)
      return (String
ptitle, Element -> Html
Html Element
pdesc)

    modules :: [Text]
modules = Element -> Text
innerText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element -> Bool) -> Element -> [Element]
findRec (forall a. Eq a => a -> a -> Bool
is Text
"module" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
class_) Element
moduleList
  return Package
    { pTitle :: String
pTitle = Text -> String
Text.unpack forall a b. (a -> b) -> a -> b
$ Element -> Text
innerText Element
title
    , pSubTitle :: Maybe String
pSubTitle = Text -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
innerText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Element
subTitle
    , pDescription :: Html
pDescription = Element -> Html
Html Element
description
    , pReadme :: Maybe Html
pReadme = Element -> Html
Html forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Element
readme
    , pProperties :: [(String, Html)]
pProperties = [(String, Html)]
properties
    , pModules :: [String]
pModules = Text -> String
Text.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
modules
    , pUrl :: PackageUrl
pUrl = PackageUrl
url
    }
  where
    -- Properties that are not interesting for the command line
    uninterestingProps :: [String]
uninterestingProps = [String
"Your Rating", String
"Change log"]

-- | postorder traversal returning elements that match a predicate.
-- If the predicate is matched, the element's children are not explored
findRec :: (Xml.Element -> Bool) -> Xml.Element -> [Xml.Element]
findRec :: (Element -> Bool) -> Element -> [Element]
findRec Element -> Bool
test Element
root = [Element] -> [Element] -> [Element]
go [Element
root] []
  where
    go :: [Element] -> [Element] -> [Element]
go [] [Element]
acc = [Element]
acc
    go (Element
el:[Element]
siblings) [Element]
acc
      | Element -> Bool
test Element
el = Element
el forall a. a -> [a] -> [a]
: [Element] -> [Element] -> [Element]
go [Element]
siblings [Element]
acc
      | Bool
otherwise = [Element] -> [Element] -> [Element]
go (Element -> [Element]
children Element
el) ([Element] -> [Element] -> [Element]
go [Element]
siblings [Element]
acc)

-- | Find one. Fail otherwise.
findM :: (MonadFail m, Foldable t) => (a -> Bool) -> t a -> m a
findM :: forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM a -> Bool
f t a
xs = do
  Just a
a <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find a -> Bool
f t a
xs
  forall (m :: * -> *) a. Monad m => a -> m a
return a
a

is :: Eq a => a -> a -> Bool
is :: forall a. Eq a => a -> a -> Bool
is = forall a. Eq a => a -> a -> Bool
(==)

children :: Xml.Element -> [Xml.Element]
children :: Element -> [Element]
children Element
element =
  [ Element
n | Xml.NodeElement Element
n <- Element -> [Node]
Xml.elementNodes Element
element ]

tag :: Xml.Element -> Text
tag :: Element -> Text
tag = Name -> Text
Xml.nameLocalName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Name
Xml.elementName

id_ :: Xml.Element -> Text
id_ :: Element -> Text
id_ = Text -> Element -> Text
attr Text
"id"

class_ :: Xml.Element -> Text
class_ :: Element -> Text
class_ = Text -> Element -> Text
attr Text
"class"

attr :: Text -> Xml.Element -> Text
attr :: Text -> Element -> Text
attr Text
name =
  forall a. a -> Maybe a -> a
fromMaybe Text
""
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> Maybe Text -> Maybe Text -> Name
Xml.Name Text
name forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Map Name Text
Xml.elementAttributes

innerString :: Html -> String
innerString :: Html -> String
innerString (Html Element
el) = Text -> String
Text.unpack (Element -> Text
innerText Element
el)

innerText :: Xml.Element -> Text
innerText :: Element -> Text
innerText Element
el = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Element -> [Node]
Xml.elementNodes Element
el) forall a b. (a -> b) -> a -> b
$ \case
  Xml.NodeElement Element
e -> Element -> Text
innerText Element
e
  Xml.NodeInstruction Instruction
_ -> forall a. Monoid a => a
mempty
  -- TODO make this more performant
  Xml.NodeContent Text
txt -> String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ ShowS
unescapeHTML forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
txt
  Xml.NodeComment Text
_ -> forall a. Monoid a => a
mempty

anchors :: Xml.Element -> [Anchor]
anchors :: Element -> [Text]
anchors Element
el = [Text] -> [Text]
f forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Element -> [Text]
anchors (Element -> [Element]
children Element
el)
  where
    f :: [Text] -> [Text]
f = if Element -> Bool
isAnchor Element
el then (Element -> Text
id_ Element
el forall a. a -> [a] -> [a]
:) else forall a. a -> a
id

    isAnchor :: Element -> Bool
isAnchor Element
e =
      Element -> Text
class_ Element
e forall a. Eq a => a -> a -> Bool
== Text
"def" Bool -> Bool -> Bool
&&
      (Text -> Text -> Bool
Text.isPrefixOf Text
"t:" (Element -> Text
id_ Element
e) Bool -> Bool -> Bool
|| Text -> Text -> Bool
Text.isPrefixOf Text
"v:" (Element -> Text
id_ Element
e))

sourceLinks :: ModuleUrl -> HtmlPage -> [(Anchor, SourceLink)]
sourceLinks :: ModuleUrl -> HtmlPage -> [(Text, SourceLink)]
sourceLinks (ModuleUrl String
murl) (HtmlPage Element
root) = do
  Element
body        <- forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
is Text
"body" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
tag) forall a b. (a -> b) -> a -> b
$ Element -> [Element]
children Element
root
  Element
content     <- forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
is Text
"content" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
id_) forall a b. (a -> b) -> a -> b
$ Element -> [Element]
children Element
body
  Element
interface   <- forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
is Text
"interface" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
id_) forall a b. (a -> b) -> a -> b
$ Element -> [Element]
children Element
content
  Element
declaration <- forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
is Text
"top" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
class_) forall a b. (a -> b) -> a -> b
$ Element -> [Element]
children Element
interface

  Element
signature  <- forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"src" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
class_) forall a b. (a -> b) -> a -> b
$ Element -> [Element]
children Element
declaration
  String
url <- forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
toSourceUrl forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Element -> Text
attr Text
"href")
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"Source" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
innerText)
    forall a b. (a -> b) -> a -> b
$ Element -> [Element]
children Element
signature
  Text
srcAnchor <- forall (m :: * -> *). MonadFail m => String -> m Text
takeAnchor String
url
  let surl :: SourceLink
surl = String -> Text -> SourceLink
SourceLink (ShowS
dropAnchor String
url) Text
srcAnchor

  let constructors :: [Element]
constructors = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
is Text
"subs constructors" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
class_) forall a b. (a -> b) -> a -> b
$ Element -> [Element]
children Element
declaration
  Text
anchor <- forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Element -> [Text]
anchors (Element
signature forall a. a -> [a] -> [a]
: [Element]
constructors)
  return (Text
anchor, SourceLink
surl)
  where
    parent :: ShowS
parent = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'/') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

    toSourceUrl :: Text -> String
toSourceUrl Text
relativeUrl = ShowS
parent String
murl forall a. Semigroup a => a -> a -> a
<> String
"/" forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
relativeUrl

-- ================================
-- Displaying Haddock's Html
-- ================================

class IsHtml a where
  toElement :: a -> Xml.Element

instance IsHtml Html where
  toElement :: Html -> Element
toElement (Html Element
e) = Element
e

instance IsHtml HtmlPage where
  toElement :: HtmlPage -> Element
toElement (HtmlPage Element
p) = Element
p

-- | Render Haddock's Html
prettyHtml :: IsHtml html => html -> P.Doc
prettyHtml :: forall html. IsHtml html => html -> Doc
prettyHtml = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Text)] -> Element -> Maybe Doc
unXMLElement [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsHtml a => a -> Element
toElement
  where
    unXMLElement :: [(Text, Text)] -> Element -> Maybe Doc
unXMLElement [(Text, Text)]
stack Element
e = [(Text, Text)] -> Element -> Doc -> Maybe Doc
style [(Text, Text)]
stack' Element
e forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(Text, Text)] -> Element -> Maybe [Doc]
unXMLChildren [(Text, Text)]
stack' Element
e
      where stack' :: [(Text, Text)]
stack' = (Element -> Text
tag Element
e, Element -> Text
class_ Element
e)forall a. a -> [a] -> [a]
:[(Text, Text)]
stack
    unXMLChildren :: [(Text, Text)] -> Element -> Maybe [Doc]
unXMLChildren [(Text, Text)]
stack Element
e =
      case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([(Text, Text)] -> Node -> Maybe Doc
unXMLNode [(Text, Text)]
stack) (Element -> [Node]
Xml.elementNodes Element
e) of
        [] -> forall a. a -> Maybe a
Just [] -- TODO does this break stuff?
        [Doc]
xs -> forall a. a -> Maybe a
Just [Doc]
xs
    unXMLNode :: [(Text, Text)] -> Node -> Maybe Doc
unXMLNode [(Text, Text)]
stack = \case
      Xml.NodeInstruction Instruction
_ -> forall a. Maybe a
Nothing
      Xml.NodeContent Text
txt | Text -> Bool
Text.null Text
txt -> forall a. Maybe a
Nothing
      Xml.NodeContent Text
txt -> forall a. a -> Maybe a
Just
        forall a b. (a -> b) -> a -> b
$ ([Doc] -> [Doc]) -> String -> Doc
docwords forall a. a -> a
id
        forall a b. (a -> b) -> a -> b
$ ShowS
unescapeHTML
        forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
txt
      Xml.NodeComment Text
_ -> forall a. Maybe a
Nothing
      Xml.NodeElement Element
e -> [(Text, Text)] -> Element -> Maybe Doc
unXMLElement [(Text, Text)]
stack Element
e

    docwords :: ([Doc] -> [Doc]) -> String -> Doc
docwords [Doc] -> [Doc]
f [] = [Doc] -> Doc
P.fillCat ([Doc] -> [Doc]
f [])
    docwords [Doc] -> [Doc]
f (Char
x:String
xs)
      | Char -> Bool
isSpace Char
x = ([Doc] -> [Doc]) -> String -> Doc
docwords ([Doc] -> [Doc]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc
P.space forall a. a -> [a] -> [a]
:)) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
xs
    docwords [Doc] -> [Doc]
f String
xs = ([Doc] -> [Doc]) -> String -> Doc
docwords ([Doc] -> [Doc]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Doc
P.text String
w forall a. a -> [a] -> [a]
:)) String
ys
      where (String
w, String
ys) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace String
xs

    -- | given an element, style its children
    style :: [(Text, Text)] -> Element -> Doc -> Maybe Doc
style [(Text, Text)]
stack Element
e Doc
m = [(Text, Text)] -> Element -> Doc -> Maybe Doc
classStyle [(Text, Text)]
stack Element
e Doc
m  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(Text, Text)] -> Element -> Doc -> Maybe Doc
tagStyle [(Text, Text)]
stack Element
e

    classStyle :: [(Text, Text)] -> Element -> Doc -> Maybe Doc
classStyle [(Text, Text)]
stack Element
e = case Element -> Text
class_ Element
e of
      Text
""                  -> forall a. a -> Maybe a
Just
      -- layout
      Text
"doc"               -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc -> Doc
P.nest Int
2
      Text
"subs methods"      -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc -> Doc
P.nest Int
2
      Text
"subs instances"    -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc -> Doc
P.nest Int
2
      Text
"subs constructors" -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc -> Doc
P.nest Int
2
      -- a declaration wrapper
      Text
"top"               -> forall a b. a -> b -> a
const
                              forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => a -> a -> a
mappend Doc
P.hardline forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
P.vsep
                              forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([(Text, Text)] -> Element -> Maybe Doc
unXMLElement [(Text, Text)]
stack) (Element -> [Element]
children Element
e)
      -- style
      Text
"caption"           | Text -> Bool
underClass Text
"subs fields" -> forall {b} {a}. b -> Maybe a
hide
                          | Bool
otherwise ->  forall a. a -> Maybe a
Just
      Text
"name"              -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
P.dullgreen
      Text
"def"               -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
P.dullgreen
      Text
"fixity"            -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
P.black
      -- invisible
      Text
"link"              -> forall {b} {a}. b -> Maybe a
hide
      Text
"selflink"          -> forall {b} {a}. b -> Maybe a
hide
      -- modify
      Text
"module-header"     -> forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> Element -> Maybe Doc
unXMLElement [(Text, Text)]
stack forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"caption" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
class_) (Element -> [Element]
children Element
e)
      Text
_                   -> forall a. a -> Maybe a
Just
      where
        underClass :: Text -> Bool
underClass Text
v = Text
v forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Text, Text)]
stack


    tagStyle :: [(Text, Text)] -> Element -> Doc -> Maybe Doc
tagStyle [(Text, Text)]
stack Element
e = case Element -> Text
tag Element
e of
       Text
"h1"      -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
linebreak forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => a -> a -> a
mappend (String -> Doc
P.text String
"# ")
       Text
"h2"      -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
linebreak forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => a -> a -> a
mappend (String -> Doc
P.text String
"## ")
       Text
"h3"      -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
linebreak forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => a -> a -> a
mappend (String -> Doc
P.text String
"### ")
       Text
"h4"      -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
linebreak forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => a -> a -> a
mappend (String -> Doc
P.text String
"#### ")
       Text
"h5"      -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
linebreak forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => a -> a -> a
mappend (String -> Doc
P.text String
"##### ")
       Text
"h6"      -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
linebreak forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => a -> a -> a
mappend (String -> Doc
P.text String
"###### ")
       Text
"tt"      -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
P.green
       Text
"pre"     -> forall a b. a -> b -> a
const
                      forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc -> Doc
P.nest Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
linebreak forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
P.vsep
                      forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
P.black forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
P.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack)
                      forall a b. (a -> b) -> a -> b
$ Text -> [Text]
Text.lines
                      forall a b. (a -> b) -> a -> b
$ Element -> Text
innerText Element
e
       Text
"code"    -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
P.black
       Text
"a"       -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
link
       Text
"b"       -> forall a. a -> Maybe a
Just
       Text
"p"       -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
linebreak
       Text
"br"      -> forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Doc
P.hardline
       Text
"dt"      -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
linebreak
       Text
"dd"      -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
linebreak
       Text
"summary" -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
linebreak
       Text
"ol"      -> forall a b. a -> b -> a
const
                    forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
linebreak forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
P.vsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> [Doc]
numbered
                    forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([(Text, Text)] -> Element -> Maybe Doc
unXMLElement [(Text, Text)]
stack) (Element -> [Element]
children Element
e)
       Text
"ul"      -> forall a b. a -> b -> a
const
                    forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
linebreak
                    forall a b. (a -> b) -> a -> b
$ (if Text -> Bool
underClass Text
"subs fields"
                        then Doc -> Doc -> Doc -> [Doc] -> Doc
P.encloseSep
                              (Int -> Doc -> Doc
P.fill Int
2 Doc
P.lbrace)
                              (Doc
P.hardline forall a. Semigroup a => a -> a -> a
<> Doc
P.rbrace)
                              (Int -> Doc -> Doc
P.fill Int
2 Doc
P.comma)
                        else [Doc] -> Doc
P.vsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Doc -> Doc
bullet
                      )
                    forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([(Text, Text)] -> Element -> Maybe Doc
unXMLElement [(Text, Text)]
stack) (Element -> [Element]
children Element
e)
       Text
"td"      | Element -> Bool
isInstanceDetails Element
e -> forall {b} {a}. b -> Maybe a
hide
                 | Bool
otherwise -> forall a. a -> Maybe a
Just
       Text
"table"   -> let
                        punctuate :: Doc -> Doc
punctuate =
                          if Text -> Bool
underClass Text
noBullets
                            then Int -> Doc -> Doc
P.indent Int
2
                            else Doc -> Doc
bullet
                    in
                    forall a b. a -> b -> a
const
                    forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
.  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Monoid a => a -> a -> a
mappend Doc
P.hardline forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
P.vsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Doc -> Doc
punctuate
                    forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([(Text, Text)] -> Element -> Maybe Doc
unXMLElement [(Text, Text)]
stack)
                    forall a b. (a -> b) -> a -> b
$ [Element] -> [Element]
joinSubsections (Element -> [Element]
children Element
e)
       -- don't show instance details
       Text
_         -> forall a. a -> Maybe a
Just
      where
        underClass :: Text -> Bool
underClass Text
v = Text
v forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Text, Text)]
stack

    isInstanceDetails :: Element -> Bool
isInstanceDetails Element
e = Element -> Bool
isSubsection Element
e Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust (forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"details" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
tag) (Element -> [Element]
children Element
e))
    linebreak :: Doc -> Doc
linebreak Doc
doc = Doc
P.hardline forall a. Semigroup a => a -> a -> a
<> Doc
doc forall a. Semigroup a => a -> a -> a
<> Doc
P.hardline
    hide :: b -> Maybe a
hide = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
    isSubsection :: Element -> Bool
isSubsection Element
e = Element -> Text
tag Element
e forall a. Eq a => a -> a -> Bool
== Text
"td" Bool -> Bool -> Bool
&& Text -> Element -> Text
attr Text
"colspan" Element
e forall a. Eq a => a -> a -> Bool
== Text
"2"

    -- Haddock has a pattern of using a row with colspan=2 to store content
    -- that is a subsection of the previous row. Here we bundle these two rows
    -- together.
    joinSubsections :: [Element] -> [Element]
joinSubsections [] = []
    joinSubsections [Element
x] = [Element
x]
    joinSubsections (Element
a:Element
b:[Element]
xs)
      | Just Element
_ <- forall (m :: * -> *) (t :: * -> *) a.
(MonadFail m, Foldable t) =>
(a -> Bool) -> t a -> m a
findM (forall a. Eq a => a -> a -> Bool
is Text
"2" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Element -> Text
attr Text
"colspan") (Element -> [Element]
children Element
b) =
        [Element] -> [Element]
joinSubsections (Element
a { elementNodes :: [Node]
Xml.elementNodes = Element -> [Node]
Xml.elementNodes Element
a forall a. [a] -> [a] -> [a]
++ Element -> [Node]
Xml.elementNodes Element
b } forall a. a -> [a] -> [a]
: [Element]
xs)
      | Bool
otherwise = Element
aforall a. a -> [a] -> [a]
:[Element] -> [Element]
joinSubsections (Element
bforall a. a -> [a] -> [a]
:[Element]
xs)

-- | Convert an html page into a src file and inform of line
-- number of SourceLink
fileInfo :: SourceLink -> HtmlPage -> FileInfo
fileInfo :: SourceLink -> HtmlPage -> FileInfo
fileInfo s :: SourceLink
s@(SourceLink String
url Text
anchor) (HtmlPage Element
root) = forall url a. HasUrl url => String -> url -> [a] -> a
pageContent String
"fileInfo" SourceLink
s forall a b. (a -> b) -> a -> b
$ do
  Element
body <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Element -> Element
removeAnnotations forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
is Text
"body" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
tag) forall a b. (a -> b) -> a -> b
$ Element -> [Element]
children Element
root
  return $ String -> Maybe Int -> Text -> FileInfo
FileInfo String
filename (Text -> Element -> Maybe Int
anchorLine Text
anchor Element
body) (Element -> Text
innerText Element
body)
  where
    removeAnnotations :: Xml.Element -> Xml.Element
    removeAnnotations :: Element -> Element
removeAnnotations Element
el = Element
el
      { elementNodes :: [Node]
Xml.elementNodes = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Node -> [Node] -> [Node]
go [] (Element -> [Node]
Xml.elementNodes Element
el)
      }
      where
        go :: Xml.Node -> [Xml.Node] -> [Xml.Node]
        go :: Node -> [Node] -> [Node]
go = \case
          Xml.NodeInstruction Instruction
_ -> forall a. a -> a
id
          Xml.NodeContent Text
txt   -> (Text -> Node
Xml.NodeContent Text
txt forall a. a -> [a] -> [a]
:)
          Xml.NodeComment Text
_     -> forall a. a -> a
id
          Xml.NodeElement Element
e
            | Element -> Bool
isAnnotation Element
e -> forall a. a -> a
id
            | Bool
otherwise      -> (Element -> Node
Xml.NodeElement (Element -> Element
removeAnnotations Element
e) forall a. a -> [a] -> [a]
:)

        -- Annotations provide hover information in the browser.
        -- It is not useful in the command-line
        isAnnotation :: Element -> Bool
isAnnotation Element
e = Element -> Text
class_ Element
e forall a. Eq a => a -> a -> Bool
== Text
"annottext"

    filename :: String
filename
      = (forall a. Semigroup a => a -> a -> a
<> String
".hs")
      forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c forall a. Eq a => a -> a -> Bool
== Char
'/' then Char
'-' else Char
c)
      forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst
      forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> ([a], [a])
breakOn String
".html"
      forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd
      forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> ([a], [a])
breakOn String
"src/" String
url

-- | File line where the tag is
anchorLine :: Anchor -> Xml.Element -> Maybe Int
anchorLine :: Text -> Element -> Maybe Int
anchorLine Text
anchor
  = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> Maybe a
Just (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Node] -> Either Int Int
anchorNodes Int
0
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Node]
Xml.elementNodes
  where
    anchorNodes :: Int -> [Xml.Node] -> Either Int Int
    anchorNodes :: Int -> [Node] -> Either Int Int
anchorNodes Int
n = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Int -> Node -> Either Int Int
anchorNode Int
n

    anchorNode :: Int -> Xml.Node -> Either Int Int -- anchor line or total lines
    anchorNode :: Int -> Node -> Either Int Int
anchorNode Int
n = \case
      Xml.NodeInstruction Instruction
_ -> forall a b. b -> Either a b
Right Int
n
      Xml.NodeContent Text
txt -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Int
n forall a. Num a => a -> a -> a
+ Text -> Text -> Int
Text.count Text
"\n" Text
txt
      Xml.NodeComment Text
_ -> forall a b. b -> Either a b
Right Int
n
      Xml.NodeElement Element
e ->
        if Text -> Element -> Text
attr Text
"name" Element
e forall a. Eq a => a -> a -> Bool
== Text
anchor Bool -> Bool -> Bool
|| Element -> Text
id_ Element
e forall a. Eq a => a -> a -> Bool
== Text
anchor
          then forall a b. a -> Either a b
Left Int
n
          else Int -> [Node] -> Either Int Int
anchorNodes Int
n (Element -> [Node]
Xml.elementNodes Element
e)

-- | Traverse an acyclic graph depth-first and return list of nodes that
-- satisfy a predicate in postorder.
-- The children of notes that satisfy a predicate will not be checked.
findDeep :: forall a. (a -> [a]) -> (a -> Bool) -> a -> [a]
findDeep :: forall a. (a -> [a]) -> (a -> Bool) -> a -> [a]
findDeep a -> [a]
next a -> Bool
test a
root = a -> [a] -> [a]
go a
root []
  where
    go :: a -> [a] -> [a]
    go :: a -> [a] -> [a]
go a
x [a]
acc
      | a -> Bool
test a
x = a
x forall a. a -> [a] -> [a]
: [a]
acc
      | Bool
otherwise = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> [a] -> [a]
go [a]
acc (a -> [a]
next a
x)

filterDeep :: (Xml.Node -> Maybe Xml.Node) -> Xml.Element -> Maybe Xml.Element
filterDeep :: (Node -> Maybe Node) -> Element -> Maybe Element
filterDeep Node -> Maybe Node
test Element
el = Node -> Element
unNodeElement forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
(([a] -> [a]) -> a -> a) -> (a -> Maybe a) -> a -> Maybe a
transform ([Node] -> [Node]) -> Node -> Node
f Node -> Maybe Node
test (Element -> Node
Xml.NodeElement Element
el)
  where
    unNodeElement :: Node -> Element
unNodeElement (Xml.NodeElement Element
e) = Element
e
    unNodeElement Node
_ = forall a. HasCallStack => String -> a
error String
"unNodeElement"

    f :: ([Node] -> [Node]) -> Node -> Node
f [Node] -> [Node]
g Node
node = case Node
node of
      Xml.NodeElement Element
e -> Element -> Node
Xml.NodeElement Element
e { elementNodes :: [Node]
Xml.elementNodes = [Node] -> [Node]
g forall a b. (a -> b) -> a -> b
$ Element -> [Node]
Xml.elementNodes Element
e }
      Node
_ -> Node
node

-- We can impement filter with this, but not find.
transform :: forall a
  .  (([a] -> [a]) -> a -> a) -- ^ apply transformation to children
  -> (a -> Maybe a)           -- ^ transform one element
  -> a
  -> Maybe a
transform :: forall a.
(([a] -> [a]) -> a -> a) -> (a -> Maybe a) -> a -> Maybe a
transform ([a] -> [a]) -> a -> a
overChildren a -> Maybe a
test = a -> Maybe a
go
  where
    go :: a -> Maybe a
    go :: a -> Maybe a
go a
x = ([a] -> [a]) -> a -> a
overChildren (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe a -> Maybe a
go) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe a
test a
x

-- =================================
-- Pretty priting
-- =================================

numbered :: [P.Doc] -> [P.Doc]
numbered :: [Doc] -> [Doc]
numbered = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Doc -> Doc
f [Int
1..]
  where
    f :: Int -> Doc -> Doc
f Int
n Doc
s = Int -> Doc -> Doc
P.fill Int
2 (Doc -> Doc
P.blue forall a b. (a -> b) -> a -> b
$ Int -> Doc
P.int Int
n) Doc -> Doc -> Doc
P.<+> Doc -> Doc
P.align Doc
s

bullet :: P.Doc -> P.Doc
bullet :: Doc -> Doc
bullet Doc
doc = Int -> Doc -> Doc
P.fill Int
2 (Char -> Doc
P.char Char
'-') forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
P.align Doc
doc

link :: P.Doc -> P.Doc
link :: Doc -> Doc
link = Doc -> Doc
P.dullcyan