{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE FlexibleContexts #-}

module Network.TypedProtocol.Documentation.Html
where

import Control.Monad
import Data.Maybe
import qualified Documentation.Haddock.Parser as Haddock
import qualified Documentation.Haddock.Types as Haddock
import Text.Blaze.Html5 (Html, (!))
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
import Text.Printf
import Data.Word
import qualified Data.Knob as Knob
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64 as Base64
import System.IO.Unsafe (unsafePerformIO)
import System.IO (IOMode (..))

import Network.TypedProtocol.Documentation.Types
import Network.TypedProtocol.Documentation.GraphViz

import Data.SerDoc.Info
import Data.SerDoc.Class

renderDescriptions :: [Description] -> Html
renderDescriptions :: [Description] -> MarkupM ()
renderDescriptions = (Description -> MarkupM ()) -> [Description] -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Description -> MarkupM ()) -> [Description] -> MarkupM ())
-> (Description -> MarkupM ()) -> [Description] -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ \(Description [[Char]]
h) -> do
    let ([DocH () [Char]]
docs :: [Haddock.DocH () String]) =
          ([Char] -> DocH () [Char]) -> [[Char]] -> [DocH () [Char]]
forall a b. (a -> b) -> [a] -> [b]
map (DocH () Identifier -> DocH () [Char]
forall mod. DocH mod Identifier -> DocH mod [Char]
Haddock.toRegular (DocH () Identifier -> DocH () [Char])
-> ([Char] -> DocH () Identifier) -> [Char] -> DocH () [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaDoc () Identifier -> DocH () Identifier
forall mod id. MetaDoc mod id -> DocH mod id
Haddock._doc (MetaDoc () Identifier -> DocH () Identifier)
-> ([Char] -> MetaDoc () Identifier)
-> [Char]
-> DocH () Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Char] -> [Char] -> MetaDoc () Identifier
forall mod. Maybe [Char] -> [Char] -> MetaDoc mod Identifier
Haddock.parseParas Maybe [Char]
forall a. Maybe a
Nothing) [[Char]]
h
    (DocH () [Char] -> MarkupM ()) -> [DocH () [Char]] -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\DocH () [Char]
doc -> MarkupM () -> MarkupM ()
H.p (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"haddock" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ DocH () [Char] -> MarkupM ()
forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock DocH () [Char]
doc) [DocH () [Char]]
docs

renderHaddock :: Haddock.DocH mod String -> Html
renderHaddock :: forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock DocH mod [Char]
Haddock.DocEmpty = MarkupM ()
forall a. Monoid a => a
mempty
renderHaddock (Haddock.DocAppend DocH mod [Char]
a DocH mod [Char]
b) = DocH mod [Char] -> MarkupM ()
forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock DocH mod [Char]
a MarkupM () -> MarkupM () -> MarkupM ()
forall a. Semigroup a => a -> a -> a
<> DocH mod [Char] -> MarkupM ()
forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock DocH mod [Char]
b
renderHaddock (Haddock.DocString [Char]
str) = [Char] -> MarkupM ()
H.string [Char]
str
renderHaddock (Haddock.DocParagraph DocH mod [Char]
a) = MarkupM () -> MarkupM ()
H.p (DocH mod [Char] -> MarkupM ()
forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock DocH mod [Char]
a)
renderHaddock (Haddock.DocIdentifier [Char]
i) = MarkupM () -> MarkupM ()
H.span (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"identifier" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string [Char]
i
renderHaddock (Haddock.DocIdentifierUnchecked mod
_) = MarkupM () -> MarkupM ()
H.span (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"unchecked" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ MarkupM ()
"**unchecked**"
renderHaddock (Haddock.DocModule (Haddock.ModLink [Char]
label Maybe (DocH mod [Char])
_)) = MarkupM () -> MarkupM ()
H.span (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"module" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string [Char]
label
renderHaddock (Haddock.DocWarning DocH mod [Char]
a) = MarkupM () -> MarkupM ()
H.div (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"warning" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ DocH mod [Char] -> MarkupM ()
forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock DocH mod [Char]
a
renderHaddock (Haddock.DocEmphasis DocH mod [Char]
a) = MarkupM () -> MarkupM ()
H.em (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ DocH mod [Char] -> MarkupM ()
forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock DocH mod [Char]
a
renderHaddock (Haddock.DocMonospaced DocH mod [Char]
a) = MarkupM () -> MarkupM ()
H.code (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ DocH mod [Char] -> MarkupM ()
forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock DocH mod [Char]
a
renderHaddock (Haddock.DocBold DocH mod [Char]
a) = MarkupM () -> MarkupM ()
H.strong (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ DocH mod [Char] -> MarkupM ()
forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock DocH mod [Char]
a
renderHaddock (Haddock.DocUnorderedList [DocH mod [Char]]
items) = MarkupM () -> MarkupM ()
H.ul (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [DocH mod [Char]] -> (DocH mod [Char] -> MarkupM ()) -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocH mod [Char]]
items ((DocH mod [Char] -> MarkupM ()) -> MarkupM ())
-> (DocH mod [Char] -> MarkupM ()) -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ \DocH mod [Char]
item -> MarkupM () -> MarkupM ()
H.li (DocH mod [Char] -> MarkupM ()
forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock DocH mod [Char]
item)
renderHaddock (Haddock.DocOrderedList [(Int, DocH mod [Char])]
items) = MarkupM () -> MarkupM ()
H.ol (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [(Int, DocH mod [Char])]
-> ((Int, DocH mod [Char]) -> MarkupM ()) -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Int, DocH mod [Char])]
items (((Int, DocH mod [Char]) -> MarkupM ()) -> MarkupM ())
-> ((Int, DocH mod [Char]) -> MarkupM ()) -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ \(Int
_, DocH mod [Char]
item) -> MarkupM () -> MarkupM ()
H.li (DocH mod [Char] -> MarkupM ()
forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock DocH mod [Char]
item)
renderHaddock (Haddock.DocDefList [(DocH mod [Char], DocH mod [Char])]
items) =
  MarkupM () -> MarkupM ()
H.dl (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [(DocH mod [Char], DocH mod [Char])]
-> ((DocH mod [Char], DocH mod [Char]) -> MarkupM ()) -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(DocH mod [Char], DocH mod [Char])]
items (((DocH mod [Char], DocH mod [Char]) -> MarkupM ()) -> MarkupM ())
-> ((DocH mod [Char], DocH mod [Char]) -> MarkupM ()) -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ \(DocH mod [Char]
title, DocH mod [Char]
body) ->
    MarkupM () -> MarkupM ()
H.div (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
      MarkupM () -> MarkupM ()
H.dt (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ DocH mod [Char] -> MarkupM ()
forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock DocH mod [Char]
title
      MarkupM () -> MarkupM ()
H.dd (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ DocH mod [Char] -> MarkupM ()
forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock DocH mod [Char]
body
renderHaddock (Haddock.DocCodeBlock DocH mod [Char]
a) = MarkupM () -> MarkupM ()
H.code (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ DocH mod [Char] -> MarkupM ()
forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock DocH mod [Char]
a
renderHaddock (Haddock.DocHyperlink (Haddock.Hyperlink [Char]
url Maybe (DocH mod [Char])
a)) =
  MarkupM () -> MarkupM ()
H.a (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.href ([Char] -> AttributeValue
H.stringValue [Char]
url) (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ MarkupM ()
-> (DocH mod [Char] -> MarkupM ())
-> Maybe (DocH mod [Char])
-> MarkupM ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> MarkupM ()
H.string [Char]
url) DocH mod [Char] -> MarkupM ()
forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock Maybe (DocH mod [Char])
a
renderHaddock (Haddock.DocPic (Haddock.Picture [Char]
url Maybe [Char]
title)) =
  MarkupM () -> MarkupM ()
H.div (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"omitted" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe [Char] -> ([Char] -> MarkupM ()) -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe [Char]
title (MarkupM () -> MarkupM ()
H.p (MarkupM () -> MarkupM ())
-> ([Char] -> MarkupM ()) -> [Char] -> MarkupM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> MarkupM ()
H.string)
    MarkupM () -> MarkupM ()
H.p (MarkupM () -> MarkupM ())
-> ([Char] -> MarkupM ()) -> [Char] -> MarkupM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> MarkupM ()
H.string ([Char] -> MarkupM ()) -> [Char] -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char]
url
renderHaddock (Haddock.DocMathInline [Char]
str) = MarkupM () -> MarkupM ()
H.span (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"math" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string [Char]
str
renderHaddock (Haddock.DocMathDisplay [Char]
str) = MarkupM () -> MarkupM ()
H.div (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"math" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string [Char]
str
renderHaddock (Haddock.DocAName [Char]
str) = MarkupM () -> MarkupM ()
H.span (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"aname" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string [Char]
str
renderHaddock (Haddock.DocProperty [Char]
str) = MarkupM () -> MarkupM ()
H.span (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"property" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string [Char]
str
renderHaddock (Haddock.DocExamples [Example]
examples) =
  [Example] -> (Example -> MarkupM ()) -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Example]
examples ((Example -> MarkupM ()) -> MarkupM ())
-> (Example -> MarkupM ()) -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ \(Haddock.Example [Char]
expr [[Char]]
results) -> do
    MarkupM () -> MarkupM ()
H.div (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"example" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
      MarkupM () -> MarkupM ()
H.code (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"expr" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string [Char]
expr
      MarkupM () -> MarkupM ()
H.code (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"result" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
        [[Char]] -> ([Char] -> MarkupM ()) -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
results (([Char] -> MarkupM ()) -> MarkupM ())
-> ([Char] -> MarkupM ()) -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ \[Char]
resultLine -> do
          [Char] -> MarkupM ()
H.string [Char]
resultLine
          MarkupM ()
H.br
renderHaddock (Haddock.DocHeader (Haddock.Header Int
level DocH mod [Char]
a)) = do
  let h :: MarkupM () -> MarkupM ()
h = case Int
level of
            Int
1 -> MarkupM () -> MarkupM ()
H.h1
            Int
2 -> MarkupM () -> MarkupM ()
H.h2
            Int
3 -> MarkupM () -> MarkupM ()
H.h3
            Int
4 -> MarkupM () -> MarkupM ()
H.h4
            Int
5 -> MarkupM () -> MarkupM ()
H.h5
            Int
_ -> MarkupM () -> MarkupM ()
H.h6
  MarkupM () -> MarkupM ()
h (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ DocH mod [Char] -> MarkupM ()
forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock DocH mod [Char]
a
renderHaddock (Haddock.DocTable (Haddock.Table [TableRow (DocH mod [Char])]
headerRows [TableRow (DocH mod [Char])]
bodyRows)) = do
  MarkupM () -> MarkupM ()
H.table (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
    MarkupM () -> MarkupM ()
H.thead (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
      [TableRow (DocH mod [Char])]
-> (TableRow (DocH mod [Char]) -> MarkupM ()) -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TableRow (DocH mod [Char])]
headerRows ((TableRow (DocH mod [Char]) -> MarkupM ()) -> MarkupM ())
-> (TableRow (DocH mod [Char]) -> MarkupM ()) -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ \TableRow (DocH mod [Char])
row -> do
        MarkupM () -> MarkupM ()
H.tr (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
          [TableCell (DocH mod [Char])]
-> (TableCell (DocH mod [Char]) -> MarkupM ()) -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (TableRow (DocH mod [Char]) -> [TableCell (DocH mod [Char])]
forall id. TableRow id -> [TableCell id]
Haddock.tableRowCells TableRow (DocH mod [Char])
row) ((TableCell (DocH mod [Char]) -> MarkupM ()) -> MarkupM ())
-> (TableCell (DocH mod [Char]) -> MarkupM ()) -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ \(Haddock.TableCell Int
colspan Int
rowspan DocH mod [Char]
body) -> do
            MarkupM () -> MarkupM ()
H.th (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.colspan (Int -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Int
colspan)
                 (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.rowspan (Int -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Int
rowspan)
                 (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ DocH mod [Char] -> MarkupM ()
forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock DocH mod [Char]
body
    MarkupM () -> MarkupM ()
H.tbody (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
      [TableRow (DocH mod [Char])]
-> (TableRow (DocH mod [Char]) -> MarkupM ()) -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TableRow (DocH mod [Char])]
bodyRows ((TableRow (DocH mod [Char]) -> MarkupM ()) -> MarkupM ())
-> (TableRow (DocH mod [Char]) -> MarkupM ()) -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ \TableRow (DocH mod [Char])
row -> do
        MarkupM () -> MarkupM ()
H.tr (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
          [TableCell (DocH mod [Char])]
-> (TableCell (DocH mod [Char]) -> MarkupM ()) -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (TableRow (DocH mod [Char]) -> [TableCell (DocH mod [Char])]
forall id. TableRow id -> [TableCell id]
Haddock.tableRowCells TableRow (DocH mod [Char])
row) ((TableCell (DocH mod [Char]) -> MarkupM ()) -> MarkupM ())
-> (TableCell (DocH mod [Char]) -> MarkupM ()) -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ \(Haddock.TableCell Int
colspan Int
rowspan DocH mod [Char]
body) -> do
            MarkupM () -> MarkupM ()
H.td (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.colspan (Int -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Int
colspan)
                 (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.rowspan (Int -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Int
rowspan)
                 (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ DocH mod [Char] -> MarkupM ()
forall mod. DocH mod [Char] -> MarkupM ()
renderHaddock DocH mod [Char]
body

data TOC a = TOC a [TOC a]
  deriving (Int -> TOC a -> ShowS
[TOC a] -> ShowS
TOC a -> [Char]
(Int -> TOC a -> ShowS)
-> (TOC a -> [Char]) -> ([TOC a] -> ShowS) -> Show (TOC a)
forall a. Show a => Int -> TOC a -> ShowS
forall a. Show a => [TOC a] -> ShowS
forall a. Show a => TOC a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> TOC a -> ShowS
showsPrec :: Int -> TOC a -> ShowS
$cshow :: forall a. Show a => TOC a -> [Char]
show :: TOC a -> [Char]
$cshowList :: forall a. Show a => [TOC a] -> ShowS
showList :: [TOC a] -> ShowS
Show, TOC a -> TOC a -> Bool
(TOC a -> TOC a -> Bool) -> (TOC a -> TOC a -> Bool) -> Eq (TOC a)
forall a. Eq a => TOC a -> TOC a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => TOC a -> TOC a -> Bool
== :: TOC a -> TOC a -> Bool
$c/= :: forall a. Eq a => TOC a -> TOC a -> Bool
/= :: TOC a -> TOC a -> Bool
Eq, Eq (TOC a)
Eq (TOC a) =>
(TOC a -> TOC a -> Ordering)
-> (TOC a -> TOC a -> Bool)
-> (TOC a -> TOC a -> Bool)
-> (TOC a -> TOC a -> Bool)
-> (TOC a -> TOC a -> Bool)
-> (TOC a -> TOC a -> TOC a)
-> (TOC a -> TOC a -> TOC a)
-> Ord (TOC a)
TOC a -> TOC a -> Bool
TOC a -> TOC a -> Ordering
TOC a -> TOC a -> TOC a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (TOC a)
forall a. Ord a => TOC a -> TOC a -> Bool
forall a. Ord a => TOC a -> TOC a -> Ordering
forall a. Ord a => TOC a -> TOC a -> TOC a
$ccompare :: forall a. Ord a => TOC a -> TOC a -> Ordering
compare :: TOC a -> TOC a -> Ordering
$c< :: forall a. Ord a => TOC a -> TOC a -> Bool
< :: TOC a -> TOC a -> Bool
$c<= :: forall a. Ord a => TOC a -> TOC a -> Bool
<= :: TOC a -> TOC a -> Bool
$c> :: forall a. Ord a => TOC a -> TOC a -> Bool
> :: TOC a -> TOC a -> Bool
$c>= :: forall a. Ord a => TOC a -> TOC a -> Bool
>= :: TOC a -> TOC a -> Bool
$cmax :: forall a. Ord a => TOC a -> TOC a -> TOC a
max :: TOC a -> TOC a -> TOC a
$cmin :: forall a. Ord a => TOC a -> TOC a -> TOC a
min :: TOC a -> TOC a -> TOC a
Ord)

renderTOC :: TOC (String, String) -> Html
renderTOC :: TOC ([Char], [Char]) -> MarkupM ()
renderTOC (TOC ([Char]
label, [Char]
href) [TOC ([Char], [Char])]
children) = do
  MarkupM () -> MarkupM ()
H.section (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"toc" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
    MarkupM () -> MarkupM ()
H.a (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.href ([Char] -> AttributeValue
H.stringValue ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
"#" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
href) (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string [Char]
label
    [TOC ([Char], [Char])]
-> (TOC ([Char], [Char]) -> MarkupM ()) -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TOC ([Char], [Char])]
children TOC ([Char], [Char]) -> MarkupM ()
renderTOC

stateID :: String -> String -> String
stateID :: [Char] -> ShowS
stateID [Char]
protoName [Char]
stateName = [Char]
protoName [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"_state_" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
stateName

stateTOC :: String -> String -> TOC (String, String)
stateTOC :: [Char] -> [Char] -> TOC ([Char], [Char])
stateTOC [Char]
protoName [Char]
stateName = ([Char], [Char]) -> [TOC ([Char], [Char])] -> TOC ([Char], [Char])
forall a. a -> [TOC a] -> TOC a
TOC ([Char]
stateName, [Char] -> ShowS
stateID [Char]
protoName [Char]
stateName) []

renderState :: String -> [MessageDescription codec] -> (StateRef, [Description], AgencyID) -> Html
renderState :: forall codec.
[Char]
-> [MessageDescription codec]
-> (StateRef, [Description], AgencyID)
-> MarkupM ()
renderState [Char]
_ [MessageDescription codec]
_ (StateRef
AnyState, [Description]
_, AgencyID
_) =
  () -> MarkupM ()
forall a. a -> MarkupM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
renderState [Char]
protoName [MessageDescription codec]
msgs (State [Char]
stateName, [Description]
descriptions, AgencyID
agency) =
  MarkupM () -> MarkupM ()
H.div (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"state" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
    MarkupM () -> MarkupM ()
H.h3 (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.id ([Char] -> AttributeValue
H.stringValue ([Char] -> ShowS
stateID [Char]
protoName [Char]
stateName)) (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string [Char]
stateName
    [Description] -> MarkupM ()
renderDescriptions [Description]
descriptions
    MarkupM () -> MarkupM ()
H.p (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
      MarkupM ()
"Agency: "
      case AgencyID
agency of
        AgencyID
ClientAgencyID -> MarkupM () -> MarkupM ()
H.strong (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"client-agency" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ MarkupM ()
"client"
        AgencyID
ServerAgencyID -> MarkupM () -> MarkupM ()
H.strong (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"server-agency" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ MarkupM ()
"server"
        AgencyID
NobodyAgencyID -> MarkupM () -> MarkupM ()
H.strong (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"nobody-agency" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ MarkupM ()
"nobody"
    Bool -> MarkupM () -> MarkupM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([MessageDescription codec] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MessageDescription codec]
messagesFromHere) (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
      MarkupM () -> MarkupM ()
H.h4 MarkupM ()
"Messages from here:"
      MarkupM () -> MarkupM ()
H.ul (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
        [MessageDescription codec]
-> (MessageDescription codec -> MarkupM ()) -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [MessageDescription codec]
messagesFromHere ((MessageDescription codec -> MarkupM ()) -> MarkupM ())
-> (MessageDescription codec -> MarkupM ()) -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ \MessageDescription codec
msg -> do
          MarkupM () -> MarkupM ()
H.li (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
            MarkupM () -> MarkupM ()
H.strong (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$
              MarkupM () -> MarkupM ()
H.a (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.href ([Char] -> AttributeValue
H.stringValue ([Char]
"#" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> ShowS
messageID [Char]
protoName (MessageDescription codec -> [Char]
forall codec. MessageDescription codec -> [Char]
messageName MessageDescription codec
msg))) (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string (MessageDescription codec -> [Char]
forall codec. MessageDescription codec -> [Char]
messageName MessageDescription codec
msg)
            MarkupM ()
" (to "
            [Char] -> StateRef -> MarkupM ()
formatStateRef [Char]
protoName (MessageDescription codec -> StateRef
forall codec. MessageDescription codec -> StateRef
messageToState MessageDescription codec
msg)
            MarkupM ()
")"
    Bool -> MarkupM () -> MarkupM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([MessageDescription codec] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MessageDescription codec]
messagesToHere) (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
      MarkupM () -> MarkupM ()
H.h4 MarkupM ()
"Messages to here:"
      MarkupM () -> MarkupM ()
H.ul (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
        [MessageDescription codec]
-> (MessageDescription codec -> MarkupM ()) -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [MessageDescription codec]
messagesToHere ((MessageDescription codec -> MarkupM ()) -> MarkupM ())
-> (MessageDescription codec -> MarkupM ()) -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ \MessageDescription codec
msg -> do
          MarkupM () -> MarkupM ()
H.li (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
            MarkupM () -> MarkupM ()
H.strong (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$
              MarkupM () -> MarkupM ()
H.a (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.href ([Char] -> AttributeValue
H.stringValue ([Char]
"#" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> ShowS
messageID [Char]
protoName (MessageDescription codec -> [Char]
forall codec. MessageDescription codec -> [Char]
messageName MessageDescription codec
msg))) (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string (MessageDescription codec -> [Char]
forall codec. MessageDescription codec -> [Char]
messageName MessageDescription codec
msg)
            MarkupM ()
" (from "
            [Char] -> StateRef -> MarkupM ()
formatStateRef [Char]
protoName (MessageDescription codec -> StateRef
forall codec. MessageDescription codec -> StateRef
messageFromState MessageDescription codec
msg)
            MarkupM ()
")"
  where
    messagesFromHere :: [MessageDescription codec]
messagesFromHere = (MessageDescription codec -> Bool)
-> [MessageDescription codec] -> [MessageDescription codec]
forall a. (a -> Bool) -> [a] -> [a]
filter (([Char] -> StateRef -> Bool
matchState [Char]
stateName) (StateRef -> Bool)
-> (MessageDescription codec -> StateRef)
-> MessageDescription codec
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessageDescription codec -> StateRef
forall codec. MessageDescription codec -> StateRef
messageFromState) [MessageDescription codec]
msgs
    messagesToHere :: [MessageDescription codec]
messagesToHere = (MessageDescription codec -> Bool)
-> [MessageDescription codec] -> [MessageDescription codec]
forall a. (a -> Bool) -> [a] -> [a]
filter (([Char] -> StateRef -> Bool
matchState [Char]
stateName) (StateRef -> Bool)
-> (MessageDescription codec -> StateRef)
-> MessageDescription codec
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessageDescription codec -> StateRef
forall codec. MessageDescription codec -> StateRef
messageToState) [MessageDescription codec]
msgs

    matchState :: String -> StateRef -> Bool
    matchState :: [Char] -> StateRef -> Bool
matchState [Char]
_ StateRef
AnyState = Bool
True
    matchState [Char]
a (State [Char]
b) = [Char]
a [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
b

formatStateRef :: String -> StateRef -> Html
formatStateRef :: [Char] -> StateRef -> MarkupM ()
formatStateRef [Char]
_ StateRef
AnyState =
  MarkupM () -> MarkupM ()
H.span MarkupM ()
"any state"
formatStateRef [Char]
protoName (State [Char]
name) =
  MarkupM () -> MarkupM ()
H.a (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.href ([Char] -> AttributeValue
H.stringValue ([Char]
"#" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> ShowS
stateID [Char]
protoName [Char]
name)) (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string [Char]
name

messageID :: String -> String -> String
messageID :: [Char] -> ShowS
messageID [Char]
protoName [Char]
msgName = [Char]
protoName [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"_message_" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
msgName

messageTOC :: String -> MessageDescription codec -> TOC (String, String)
messageTOC :: forall codec.
[Char] -> MessageDescription codec -> TOC ([Char], [Char])
messageTOC [Char]
protoName MessageDescription codec
msg =
  ([Char], [Char]) -> [TOC ([Char], [Char])] -> TOC ([Char], [Char])
forall a. a -> [TOC a] -> TOC a
TOC (MessageDescription codec -> [Char]
forall codec. MessageDescription codec -> [Char]
messageName MessageDescription codec
msg, [Char] -> ShowS
messageID [Char]
protoName (MessageDescription codec -> [Char]
forall codec. MessageDescription codec -> [Char]
messageName MessageDescription codec
msg)) []

formatFieldSize :: FieldSize -> String
formatFieldSize :: FieldSize -> [Char]
formatFieldSize (FixedSize Int
n) = Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
formatFieldSize (VarSize [Char]
var) = [Char]
var
formatFieldSize FieldSize
UnknownSize = [Char]
"VARIABLE"
formatFieldSize FieldSize
EnumSize = [Char]
"ENUM"
formatFieldSize (RangeSize FieldSize
lo FieldSize
hi) = [Char]
"(" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldSize -> [Char]
formatFieldSize FieldSize
lo [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" .. " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldSize -> [Char]
formatFieldSize FieldSize
hi [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"
formatFieldSize (BinopSize FieldSizeBinop
FSPlus FieldSize
a FieldSize
b) = [Char]
"(" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldSize -> [Char]
formatFieldSize FieldSize
a [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" + " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldSize -> [Char]
formatFieldSize FieldSize
b [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"
formatFieldSize (BinopSize FieldSizeBinop
FSMul FieldSize
a FieldSize
b) = [Char]
"(" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldSize -> [Char]
formatFieldSize FieldSize
a [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" * " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldSize -> [Char]
formatFieldSize FieldSize
b [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"
formatFieldSize (BinopSize FieldSizeBinop
FSMax FieldSize
a FieldSize
b) = [Char]
"MAX(" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldSize -> [Char]
formatFieldSize FieldSize
a [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
", " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldSize -> [Char]
formatFieldSize FieldSize
b [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"
formatFieldSize (BinopSize FieldSizeBinop
FSMin FieldSize
a FieldSize
b) = [Char]
"MIN(" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldSize -> [Char]
formatFieldSize FieldSize
a [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
", " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldSize -> [Char]
formatFieldSize FieldSize
b [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"

renderMessage :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))
              => String -> MessageDescription codec -> Html
renderMessage :: forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
[Char] -> MessageDescription codec -> MarkupM ()
renderMessage [Char]
protoName MessageDescription codec
msg =
  MarkupM () -> MarkupM ()
H.div (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"message" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
    MarkupM () -> MarkupM ()
H.h3 (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.id ([Char] -> AttributeValue
H.stringValue ([Char] -> ShowS
messageID [Char]
protoName (MessageDescription codec -> [Char]
forall codec. MessageDescription codec -> [Char]
messageName MessageDescription codec
msg))) (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string (MessageDescription codec -> [Char]
forall codec. MessageDescription codec -> [Char]
messageName MessageDescription codec
msg)
    [Description] -> MarkupM ()
renderDescriptions (MessageDescription codec -> [Description]
forall codec. MessageDescription codec -> [Description]
messageDescription MessageDescription codec
msg)
    MarkupM () -> MarkupM ()
H.h4 (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ MarkupM ()
"State Transition"
    MarkupM () -> MarkupM ()
H.p (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
      [Char] -> StateRef -> MarkupM ()
formatStateRef [Char]
protoName (MessageDescription codec -> StateRef
forall codec. MessageDescription codec -> StateRef
messageFromState MessageDescription codec
msg)
      MarkupM ()
" -> "
      [Char] -> StateRef -> MarkupM ()
formatStateRef [Char]
protoName (MessageDescription codec -> StateRef
forall codec. MessageDescription codec -> StateRef
messageToState MessageDescription codec
msg)
    Bool -> MarkupM () -> MarkupM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([[Char]] -> Bool) -> [[Char]] -> Bool
forall a b. (a -> b) -> a -> b
$ MessageDescription codec -> [[Char]]
forall codec. MessageDescription codec -> [[Char]]
messagePayload MessageDescription codec
msg) (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
      MarkupM () -> MarkupM ()
H.h4 MarkupM ()
"Payload"
      MarkupM () -> MarkupM ()
H.ul (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
        [[Char]] -> ([Char] -> MarkupM ()) -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (MessageDescription codec -> [[Char]]
forall codec. MessageDescription codec -> [[Char]]
messagePayload MessageDescription codec
msg) (([Char] -> MarkupM ()) -> MarkupM ())
-> ([Char] -> MarkupM ()) -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ MarkupM () -> MarkupM ()
H.li (MarkupM () -> MarkupM ())
-> ([Char] -> MarkupM ()) -> [Char] -> MarkupM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> MarkupM ()
H.string
    MarkupM () -> MarkupM ()
H.h4 MarkupM ()
"Serialization Format"
    FieldInfo codec -> MarkupM ()
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> MarkupM ()
fieldSpecToHTML (MessageDescription codec -> FieldInfo codec
forall codec. MessageDescription codec -> FieldInfo codec
messageInfo MessageDescription codec
msg)
  
protocolTOC :: ProtocolDescription codec -> TOC (String, String)
protocolTOC :: forall codec. ProtocolDescription codec -> TOC ([Char], [Char])
protocolTOC ProtocolDescription codec
proto =
  let protoName :: [Char]
protoName = ProtocolDescription codec -> [Char]
forall codec. ProtocolDescription codec -> [Char]
protocolName ProtocolDescription codec
proto
  in
    ([Char], [Char]) -> [TOC ([Char], [Char])] -> TOC ([Char], [Char])
forall a. a -> [TOC a] -> TOC a
TOC ([Char]
protoName, [Char]
protoName)
      [ ([Char], [Char]) -> [TOC ([Char], [Char])] -> TOC ([Char], [Char])
forall a. a -> [TOC a] -> TOC a
TOC ([Char]
"States", [Char]
protoName [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"_states")
        [ [Char] -> [Char] -> TOC ([Char], [Char])
stateTOC [Char]
protoName [Char]
stateName | (State [Char]
stateName, [Description]
_, AgencyID
_) <- ProtocolDescription codec -> [(StateRef, [Description], AgencyID)]
forall codec.
ProtocolDescription codec -> [(StateRef, [Description], AgencyID)]
protocolStates ProtocolDescription codec
proto ]
      , ([Char], [Char]) -> [TOC ([Char], [Char])] -> TOC ([Char], [Char])
forall a. a -> [TOC a] -> TOC a
TOC ([Char]
"Messages", [Char]
protoName [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"_messages")
        [ [Char] -> MessageDescription codec -> TOC ([Char], [Char])
forall codec.
[Char] -> MessageDescription codec -> TOC ([Char], [Char])
messageTOC [Char]
protoName MessageDescription codec
msg | MessageDescription codec
msg <- ProtocolDescription codec -> [MessageDescription codec]
forall codec.
ProtocolDescription codec -> [MessageDescription codec]
protocolMessages ProtocolDescription codec
proto ]
      ]

protocolToSvgMem :: ProtocolDescription codec -> ByteString
protocolToSvgMem :: forall codec. ProtocolDescription codec -> ByteString
protocolToSvgMem ProtocolDescription codec
proto = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ do
  k <- ByteString -> IO Knob
forall (m :: * -> *). MonadIO m => ByteString -> m Knob
Knob.newKnob ByteString
""
  Knob.withFileHandle k "unknown" WriteMode $ \Handle
h ->
    ProtocolDescription codec -> Handle -> IO ()
forall codec. ProtocolDescription codec -> Handle -> IO ()
hProtocolToSVG ProtocolDescription codec
proto Handle
h
  Knob.getContents k

renderDiagramSvg :: ProtocolDescription codec -> Html
renderDiagramSvg :: forall codec. ProtocolDescription codec -> MarkupM ()
renderDiagramSvg ProtocolDescription codec
proto = do
  let protoSvg :: ByteString
protoSvg = ProtocolDescription codec -> ByteString
forall codec. ProtocolDescription codec -> ByteString
protocolToSvgMem ProtocolDescription codec
proto
      uri :: ByteString
uri = ByteString
"data:image/svg+xml;base64," ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
Base64.encode ByteString
protoSvg
  MarkupM ()
H.img MarkupM () -> Attribute -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.src (ByteString -> AttributeValue
H.unsafeByteStringValue ByteString
uri)
        MarkupM () -> Attribute -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"state-diagram"

renderProtocol :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))
               => ProtocolDescription codec -> Html
renderProtocol :: forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
ProtocolDescription codec -> MarkupM ()
renderProtocol ProtocolDescription codec
proto = do
  let protoName :: [Char]
protoName = ProtocolDescription codec -> [Char]
forall codec. ProtocolDescription codec -> [Char]
protocolName ProtocolDescription codec
proto
      msgs :: [MessageDescription codec]
msgs = ProtocolDescription codec -> [MessageDescription codec]
forall codec.
ProtocolDescription codec -> [MessageDescription codec]
protocolMessages ProtocolDescription codec
proto
  MarkupM () -> MarkupM ()
H.section (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"protocol" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
    MarkupM () -> MarkupM ()
H.h1 (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.id ([Char] -> AttributeValue
H.stringValue [Char]
protoName) (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string [Char]
protoName
    MarkupM ()
"Version ID: "
    MarkupM () -> MarkupM ()
H.code (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string (ProtocolDescription codec -> [Char]
forall codec. ProtocolDescription codec -> [Char]
protocolIdentifier ProtocolDescription codec
proto)
    [Description] -> MarkupM ()
renderDescriptions (ProtocolDescription codec -> [Description]
forall codec. ProtocolDescription codec -> [Description]
protocolDescription ProtocolDescription codec
proto)
    MarkupM () -> MarkupM ()
H.section (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
      MarkupM () -> MarkupM ()
H.h2 (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.id ([Char] -> AttributeValue
H.stringValue ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
protoName [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"_state_diagram") (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ MarkupM ()
"State Diagram"
      ProtocolDescription codec -> MarkupM ()
forall codec. ProtocolDescription codec -> MarkupM ()
renderDiagramSvg ProtocolDescription codec
proto
    MarkupM () -> MarkupM ()
H.section (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
      MarkupM () -> MarkupM ()
H.h2 (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.id ([Char] -> AttributeValue
H.stringValue ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
protoName [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"_states") (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ MarkupM ()
"States"
      [()] -> ()
forall a. Monoid a => [a] -> a
mconcat ([()] -> ()) -> MarkupM [()] -> MarkupM ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((StateRef, [Description], AgencyID) -> MarkupM ())
-> [(StateRef, [Description], AgencyID)] -> MarkupM [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Char]
-> [MessageDescription codec]
-> (StateRef, [Description], AgencyID)
-> MarkupM ()
forall codec.
[Char]
-> [MessageDescription codec]
-> (StateRef, [Description], AgencyID)
-> MarkupM ()
renderState [Char]
protoName [MessageDescription codec]
msgs) (ProtocolDescription codec -> [(StateRef, [Description], AgencyID)]
forall codec.
ProtocolDescription codec -> [(StateRef, [Description], AgencyID)]
protocolStates ProtocolDescription codec
proto)
    MarkupM () -> MarkupM ()
H.section (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
      MarkupM () -> MarkupM ()
H.h2 (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.id ([Char] -> AttributeValue
H.stringValue ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
protoName [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"_messages") (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ MarkupM ()
"Messages"
      [()] -> ()
forall a. Monoid a => [a] -> a
mconcat ([()] -> ()) -> MarkupM [()] -> MarkupM ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MessageDescription codec -> MarkupM ())
-> [MessageDescription codec] -> MarkupM [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Char] -> MessageDescription codec -> MarkupM ()
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
[Char] -> MessageDescription codec -> MarkupM ()
renderMessage [Char]
protoName) [MessageDescription codec]
msgs

fieldSpecToHTML :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))
                => FieldInfo codec -> Html
fieldSpecToHTML :: forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> MarkupM ()
fieldSpecToHTML FieldInfo codec
fi = do
  [[Char]] -> ([Char] -> MarkupM ()) -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (FieldInfo codec -> [[Char]]
forall codec. FieldInfo codec -> [[Char]]
fieldSpecAnnotations FieldInfo codec
fi) (MarkupM () -> MarkupM ()
H.p (MarkupM () -> MarkupM ())
-> ([Char] -> MarkupM ()) -> [Char] -> MarkupM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> MarkupM ()
H.string)
  MarkupM () -> Maybe (MarkupM ()) -> MarkupM ()
forall a. a -> Maybe a -> a
fromMaybe MarkupM ()
"" (Maybe (MarkupM ()) -> MarkupM ())
-> Maybe (MarkupM ()) -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ FieldInfo codec -> Maybe (MarkupM ())
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> Maybe (MarkupM ())
subfieldsToHTML ([Char] -> [([Char], FieldInfo codec)] -> FieldInfo codec
forall codec.
[Char] -> [([Char], FieldInfo codec)] -> FieldInfo codec
compoundField [Char]
"" [([Char]
"", FieldInfo codec
fi)])

fieldSpecAnnotations :: FieldInfo codec -> [String]
fieldSpecAnnotations :: forall codec. FieldInfo codec -> [[Char]]
fieldSpecAnnotations (AnnField [Char]
ann FieldInfo codec
fi) =
  [Char]
ann [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: FieldInfo codec -> [[Char]]
forall codec. FieldInfo codec -> [[Char]]
fieldSpecAnnotations FieldInfo codec
fi
fieldSpecAnnotations FieldInfo codec
_ = []

subfieldsToHTML :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))
                => FieldInfo codec -> Maybe Html
subfieldsToHTML :: forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> Maybe (MarkupM ())
subfieldsToHTML (AnnField [Char]
_ FieldInfo codec
fi) =
  FieldInfo codec -> Maybe (MarkupM ())
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> Maybe (MarkupM ())
subfieldsToHTML FieldInfo codec
fi
subfieldsToHTML (AliasField AliasFieldInfo codec
afi) =
  FieldInfo codec -> Maybe (MarkupM ())
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> Maybe (MarkupM ())
subfieldsToHTML (AliasFieldInfo codec -> FieldInfo codec
forall codec. AliasFieldInfo codec -> FieldInfo codec
aliasFieldTarget AliasFieldInfo codec
afi)
subfieldsToHTML (CompoundField CompoundFieldInfo codec
cfi) = MarkupM () -> Maybe (MarkupM ())
forall a. a -> Maybe a
Just (MarkupM () -> Maybe (MarkupM ()))
-> MarkupM () -> Maybe (MarkupM ())
forall a b. (a -> b) -> a -> b
$ do
  MarkupM () -> MarkupM ()
H.table (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
    (SubfieldInfo codec -> MarkupM ())
-> [SubfieldInfo codec] -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SubfieldInfo codec -> MarkupM ()
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
SubfieldInfo codec -> MarkupM ()
subfieldToHtmlTR (CompoundFieldInfo codec -> [SubfieldInfo codec]
forall codec. CompoundFieldInfo codec -> [SubfieldInfo codec]
compoundFieldSubfields CompoundFieldInfo codec
cfi)
subfieldsToHTML FieldInfo codec
_ = Maybe (MarkupM ())
forall a. Maybe a
Nothing

fieldTypeToHtml :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))
                => FieldInfo codec -> Html
fieldTypeToHtml :: forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> MarkupM ()
fieldTypeToHtml (AnnField [Char]
_ FieldInfo codec
fi) =
  FieldInfo codec -> MarkupM ()
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> MarkupM ()
fieldTypeToHtml FieldInfo codec
fi
fieldTypeToHtml (AliasField AliasFieldInfo codec
fi) = do
  MarkupM () -> MarkupM ()
H.strong (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string (AliasFieldInfo codec -> [Char]
forall codec. AliasFieldInfo codec -> [Char]
aliasFieldName AliasFieldInfo codec
fi)
  MarkupM ()
H.br
  MarkupM () -> MarkupM ()
H.em MarkupM ()
"This type is an alias for: "
  FieldInfo codec -> MarkupM ()
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> MarkupM ()
fieldTypeToHtml (AliasFieldInfo codec -> FieldInfo codec
forall codec. AliasFieldInfo codec -> FieldInfo codec
aliasFieldTarget AliasFieldInfo codec
fi)
fieldTypeToHtml (ListField ListFieldInfo codec
fi) = do
  MarkupM () -> MarkupM ()
H.strong (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
    MarkupM ()
"["
    [Char] -> MarkupM ()
H.string (FieldInfo codec -> [Char]
forall codec. FieldInfo codec -> [Char]
shortFieldType (ListFieldInfo codec -> FieldInfo codec
forall codec. ListFieldInfo codec -> FieldInfo codec
listElemInfo ListFieldInfo codec
fi))
    MarkupM ()
"]"
  MarkupM ()
H.br
  MarkupM () -> MarkupM ()
H.em (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ MarkupM ()
"#items: "
  [Char] -> MarkupM ()
H.string ([Char] -> MarkupM ()) -> [Char] -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ FieldSize -> [Char]
formatFieldSize (FieldSize -> [Char]) -> FieldSize -> [Char]
forall a b. (a -> b) -> a -> b
$ ListFieldInfo codec -> FieldSize
forall codec. ListFieldInfo codec -> FieldSize
listSize ListFieldInfo codec
fi
  MarkupM ()
H.br
  MarkupM () -> MarkupM ()
H.em (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ MarkupM ()
"item type: "
  FieldInfo codec -> MarkupM ()
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> MarkupM ()
fieldTypeToHtml (ListFieldInfo codec -> FieldInfo codec
forall codec. ListFieldInfo codec -> FieldInfo codec
listElemInfo ListFieldInfo codec
fi)
  MarkupM ()
-> (MarkupM () -> MarkupM ()) -> Maybe (MarkupM ()) -> MarkupM ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MarkupM ()
"" (MarkupM ()
H.br MarkupM () -> MarkupM () -> MarkupM ()
forall a. Semigroup a => a -> a -> a
<>) (Maybe (MarkupM ()) -> MarkupM ())
-> Maybe (MarkupM ()) -> MarkupM ()
forall a b. (a -> b) -> a -> b
$
    FieldInfo codec -> Maybe (MarkupM ())
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> Maybe (MarkupM ())
subfieldsToHTML (ListFieldInfo codec -> FieldInfo codec
forall codec. ListFieldInfo codec -> FieldInfo codec
listElemInfo ListFieldInfo codec
fi)
fieldTypeToHtml (ChoiceField ChoiceFieldInfo codec
fi) = do
  MarkupM () -> MarkupM ()
H.em MarkupM ()
"Choice"
  let choiceLabel :: MarkupM ()
choiceLabel = case ChoiceFieldInfo codec -> ChoiceCondition
forall codec. ChoiceFieldInfo codec -> ChoiceCondition
choiceCondition ChoiceFieldInfo codec
fi of
        IndexField [Char]
ref -> [Char] -> MarkupM ()
H.string [Char]
ref
        IndexFlag [Char]
ref Word32
mask -> [Char] -> MarkupM ()
H.string [Char]
ref MarkupM () -> MarkupM () -> MarkupM ()
forall a. Semigroup a => a -> a -> a
<> MarkupM ()
" & " MarkupM () -> MarkupM () -> MarkupM ()
forall a. Semigroup a => a -> a -> a
<> [Char] -> MarkupM ()
H.string ([Char] -> Word32 -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"0x%04x" Word32
mask)
  MarkupM () -> MarkupM ()
H.table (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
    MarkupM () -> MarkupM ()
H.tr (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
      MarkupM () -> MarkupM ()
H.th MarkupM ()
choiceLabel
      MarkupM () -> MarkupM ()
H.th MarkupM ()
"size"
      MarkupM () -> MarkupM ()
H.th MarkupM ()
"type"
    [MarkupM ()] -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([MarkupM ()] -> MarkupM ()) -> [MarkupM ()] -> MarkupM ()
forall a b. (a -> b) -> a -> b
$
          [ MarkupM () -> MarkupM ()
H.tr (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
              MarkupM () -> MarkupM ()
H.td (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"choice-value" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n)
              MarkupM () -> MarkupM ()
H.td (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"field-size" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
                [Char] -> MarkupM ()
H.string ([Char] -> MarkupM ()) -> [Char] -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ FieldSize -> [Char]
formatFieldSize (FieldInfo codec -> FieldSize
forall codec.
(Codec codec, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> FieldSize
fieldSize FieldInfo codec
optInfo)
              MarkupM () -> MarkupM ()
H.td (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
                FieldInfo codec -> MarkupM ()
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> MarkupM ()
fieldTypeToHtml FieldInfo codec
optInfo
                MarkupM () -> Maybe (MarkupM ()) -> MarkupM ()
forall a. a -> Maybe a -> a
fromMaybe MarkupM ()
"" (Maybe (MarkupM ()) -> MarkupM ())
-> Maybe (MarkupM ()) -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ FieldInfo codec -> Maybe (MarkupM ())
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> Maybe (MarkupM ())
subfieldsToHTML FieldInfo codec
optInfo
          | (Int
n :: Int, FieldInfo codec
optInfo) <- [Int] -> [FieldInfo codec] -> [(Int, FieldInfo codec)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0,Int
1..] (ChoiceFieldInfo codec -> [FieldInfo codec]
forall codec. ChoiceFieldInfo codec -> [FieldInfo codec]
choiceFieldAlternatives ChoiceFieldInfo codec
fi)
          ]
fieldTypeToHtml (EnumField EnumFieldInfo
fi) = do
  MarkupM () -> MarkupM ()
H.strong (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string (EnumFieldInfo -> [Char]
enumFieldType EnumFieldInfo
fi)
  MarkupM () -> MarkupM ()
H.em MarkupM ()
" (enum)"
  MarkupM () -> MarkupM ()
H.table (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
    MarkupM () -> MarkupM ()
H.tr (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
      MarkupM () -> MarkupM ()
H.th MarkupM ()
"value"
      MarkupM () -> MarkupM ()
H.th MarkupM ()
"name"
    [MarkupM ()] -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([MarkupM ()] -> MarkupM ()) -> [MarkupM ()] -> MarkupM ()
forall a b. (a -> b) -> a -> b
$
        [ MarkupM () -> MarkupM ()
H.tr (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
            MarkupM () -> MarkupM ()
H.td (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"enum-value" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
val)
            MarkupM () -> MarkupM ()
H.td (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string [Char]
name
        | (Int
val, [Char]
name) <- EnumFieldInfo -> [(Int, [Char])]
enumFieldValues EnumFieldInfo
fi
        ]
fieldTypeToHtml (SumField SumFieldInfo codec
fi) = do
  MarkupM () -> MarkupM ()
H.strong (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string (SumFieldInfo codec -> [Char]
forall codec. SumFieldInfo codec -> [Char]
sumFieldType SumFieldInfo codec
fi)
  MarkupM () -> MarkupM ()
H.em MarkupM ()
" (union)"
  case SumFieldInfo codec -> [([Char], FieldInfo codec)]
forall codec. SumFieldInfo codec -> [([Char], FieldInfo codec)]
sumFieldAlternatives SumFieldInfo codec
fi of
    [([Char]
_name, FieldInfo codec
sfi)] ->
      MarkupM () -> MarkupM ()
H.div (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ FieldInfo codec -> MarkupM ()
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> MarkupM ()
fieldTypeToHtml FieldInfo codec
sfi
    [([Char], FieldInfo codec)]
sfis ->
      MarkupM () -> MarkupM ()
H.table (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
        MarkupM () -> MarkupM ()
H.tr (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
          MarkupM () -> MarkupM ()
H.th MarkupM ()
"name"
          MarkupM () -> MarkupM ()
H.th MarkupM ()
"value"
        [MarkupM ()] -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([MarkupM ()] -> MarkupM ()) -> [MarkupM ()] -> MarkupM ()
forall a b. (a -> b) -> a -> b
$
            [ MarkupM () -> MarkupM ()
H.tr (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
                MarkupM () -> MarkupM ()
H.td (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string [Char]
name
                MarkupM () -> MarkupM ()
H.td (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"sum-value" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ FieldInfo codec -> MarkupM ()
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> MarkupM ()
fieldTypeToHtml FieldInfo codec
sfi
            | ([Char]
name, FieldInfo codec
sfi) <- [([Char], FieldInfo codec)]
sfis
            ]
fieldTypeToHtml FieldInfo codec
fi =
  MarkupM () -> MarkupM ()
H.strong (MarkupM () -> MarkupM ())
-> (FieldInfo codec -> MarkupM ()) -> FieldInfo codec -> MarkupM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> MarkupM ()
H.string ([Char] -> MarkupM ())
-> (FieldInfo codec -> [Char]) -> FieldInfo codec -> MarkupM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo codec -> [Char]
forall codec. HasInfo codec Word32 => FieldInfo codec -> [Char]
fieldType (FieldInfo codec -> MarkupM ()) -> FieldInfo codec -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ FieldInfo codec
fi

subfieldToHtmlTR :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))
                 => SubfieldInfo codec -> Html
subfieldToHtmlTR :: forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
SubfieldInfo codec -> MarkupM ()
subfieldToHtmlTR SubfieldInfo codec
sfi =
  case FieldInfo codec -> Maybe (MarkupM ())
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> Maybe (MarkupM ())
subfieldsToHTML (SubfieldInfo codec -> FieldInfo codec
forall codec. SubfieldInfo codec -> FieldInfo codec
subfieldInfo SubfieldInfo codec
sfi) of
    Maybe (MarkupM ())
Nothing -> do
      MarkupM () -> MarkupM ()
H.tr (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
        MarkupM () -> MarkupM ()
H.th (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.colspan AttributeValue
"2" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string (SubfieldInfo codec -> [Char]
forall codec. SubfieldInfo codec -> [Char]
subfieldName SubfieldInfo codec
sfi)
      MarkupM () -> MarkupM ()
H.tr (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
        MarkupM () -> MarkupM ()
H.td (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"field-size" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string ([Char] -> MarkupM ()) -> [Char] -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ FieldSize -> [Char]
formatFieldSize (FieldInfo codec -> FieldSize
forall codec.
(Codec codec, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> FieldSize
fieldSize (SubfieldInfo codec -> FieldInfo codec
forall codec. SubfieldInfo codec -> FieldInfo codec
subfieldInfo SubfieldInfo codec
sfi))
        MarkupM () -> MarkupM ()
H.td (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ FieldInfo codec -> MarkupM ()
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> MarkupM ()
fieldTypeToHtml (SubfieldInfo codec -> FieldInfo codec
forall codec. SubfieldInfo codec -> FieldInfo codec
subfieldInfo SubfieldInfo codec
sfi)
    Just MarkupM ()
sfiHtml -> do
      MarkupM () -> MarkupM ()
H.tr (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
        MarkupM () -> MarkupM ()
H.th (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.colspan AttributeValue
"2" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MarkupM ()
H.string (SubfieldInfo codec -> [Char]
forall codec. SubfieldInfo codec -> [Char]
subfieldName SubfieldInfo codec
sfi)
      MarkupM () -> MarkupM ()
H.tr (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
        MarkupM () -> MarkupM ()
H.td (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.rowspan AttributeValue
"2" (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"field-size" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
          [Char] -> MarkupM ()
H.string ([Char] -> MarkupM ()) -> [Char] -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ FieldSize -> [Char]
formatFieldSize (FieldInfo codec -> FieldSize
forall codec.
(Codec codec, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> FieldSize
fieldSize (SubfieldInfo codec -> FieldInfo codec
forall codec. SubfieldInfo codec -> FieldInfo codec
subfieldInfo SubfieldInfo codec
sfi))
        MarkupM () -> MarkupM ()
H.td (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.colspan AttributeValue
"2" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ FieldInfo codec -> MarkupM ()
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
FieldInfo codec -> MarkupM ()
fieldTypeToHtml (SubfieldInfo codec -> FieldInfo codec
forall codec. SubfieldInfo codec -> FieldInfo codec
subfieldInfo SubfieldInfo codec
sfi)
      MarkupM () -> MarkupM ()
H.tr (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
        MarkupM () -> MarkupM ()
H.td (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.colspan AttributeValue
"2" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ MarkupM ()
sfiHtml

wrapDocument :: Html -> Html
wrapDocument :: MarkupM () -> MarkupM ()
wrapDocument MarkupM ()
body = do
  MarkupM ()
H.docType
  MarkupM () -> MarkupM ()
H.html (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
    MarkupM () -> MarkupM ()
H.head (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
      MarkupM () -> MarkupM ()
H.style (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
        MarkupM ()
"html { font-family: sans-serif; }"
        MarkupM ()
"body { max-width: 60rem; margin-left: auto; margin-right: auto; padding: 1rem; }"
        MarkupM ()
"h1 { font-size: 3rem; }"
        MarkupM ()
"h2 { font-size: 2rem; }"
        MarkupM ()
"h3 { font-size: 1.5rem; }"
        MarkupM ()
"h4 { font-size: 1.25rem; }"
        MarkupM ()
"h5 { font-size: 1.1rem; }"
        MarkupM ()
"h6 { font-size: 1rem; }"
        MarkupM ()
"div.state, div.message {"
        MarkupM ()
" background-color: #EEE;"
        MarkupM ()
" padding: 0.125rem 1rem; "
        MarkupM ()
" margin: 1rem 0 1rem 0;"
        MarkupM ()
"}"
        MarkupM ()
"table { "
        MarkupM ()
"border-collapse: collapse;"
        MarkupM ()
"margin-top: 0.25rem;"
        MarkupM ()
"margin-bottom: 0.25rem;"
        MarkupM ()
"}"
        MarkupM ()
"table td, table th {"
        MarkupM ()
"  border: solid 1px black;"
        MarkupM ()
"  text-align: left;"
        MarkupM ()
"  vertical-align: top;"
        MarkupM ()
"  padding: 0.25rem;"
        MarkupM ()
"  background-color: white; "
        MarkupM ()
"}"
        MarkupM ()
"table th {"
        MarkupM ()
"  background-color: #DDD"
        MarkupM ()
"}"
        MarkupM ()
".choice-value,"
        MarkupM ()
".enum-value,"
        MarkupM ()
".field-size {"
        MarkupM ()
"  text-align: right;"
        MarkupM ()
"  width: 4rem;"
        MarkupM ()
"}"
        MarkupM ()
".toc>.toc {"
        MarkupM ()
"  padding-left: 2rem;"
        MarkupM ()
"}"
        MarkupM ()
".state-diagram {"
        MarkupM ()
"  padding: 2rem;"
        MarkupM ()
"  width: 60%;"
        MarkupM ()
"}"
        MarkupM ()
".client-agency {"
        MarkupM ()
"  color: brown;"
        MarkupM ()
"}"
        MarkupM ()
".server-agency {"
        MarkupM ()
"  color: blue;"
        MarkupM ()
"}"
    MarkupM () -> MarkupM ()
H.body MarkupM ()
body

renderProtocolDescriptions :: (HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec))
                           => [ProtocolDescription codec] -> Html
renderProtocolDescriptions :: forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
[ProtocolDescription codec] -> MarkupM ()
renderProtocolDescriptions [ProtocolDescription codec]
protos =
  [MarkupM ()] -> MarkupM ()
forall a. Monoid a => [a] -> a
mconcat ([MarkupM ()] -> MarkupM ()) -> [MarkupM ()] -> MarkupM ()
forall a b. (a -> b) -> a -> b
$
    MarkupM ()
tocHtml MarkupM () -> [MarkupM ()] -> [MarkupM ()]
forall a. a -> [a] -> [a]
: [MarkupM ()]
protoHtmls
  where
    tocHtml :: MarkupM ()
tocHtml = MarkupM () -> MarkupM ()
H.div (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.class_ AttributeValue
"toc-master" (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
                MarkupM () -> MarkupM ()
H.h1 MarkupM ()
"Table Of Contents"
                TOC ([Char], [Char]) -> MarkupM ()
renderTOC (TOC ([Char], [Char]) -> MarkupM ())
-> TOC ([Char], [Char]) -> MarkupM ()
forall a b. (a -> b) -> a -> b
$
                  ([Char], [Char]) -> [TOC ([Char], [Char])] -> TOC ([Char], [Char])
forall a. a -> [TOC a] -> TOC a
TOC ([Char]
"Protocols", [Char]
"") ([TOC ([Char], [Char])] -> TOC ([Char], [Char]))
-> [TOC ([Char], [Char])] -> TOC ([Char], [Char])
forall a b. (a -> b) -> a -> b
$
                  (ProtocolDescription codec -> TOC ([Char], [Char]))
-> [ProtocolDescription codec] -> [TOC ([Char], [Char])]
forall a b. (a -> b) -> [a] -> [b]
map ProtocolDescription codec -> TOC ([Char], [Char])
forall codec. ProtocolDescription codec -> TOC ([Char], [Char])
protocolTOC [ProtocolDescription codec]
protos
    protoHtmls :: [MarkupM ()]
protoHtmls = (ProtocolDescription codec -> MarkupM ())
-> [ProtocolDescription codec] -> [MarkupM ()]
forall a b. (a -> b) -> [a] -> [b]
map ProtocolDescription codec -> MarkupM ()
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
ProtocolDescription codec -> MarkupM ()
renderProtocol [ProtocolDescription codec]
protos