diff --git a/src/Nirum/Targets/Docs.hs b/src/Nirum/Targets/Docs.hs index 0b22365..e4412ed 100644 --- a/src/Nirum/Targets/Docs.hs +++ b/src/Nirum/Targets/Docs.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedLists, QuasiQuotes, TypeFamilies #-} +{-# LANGUAGE QuasiQuotes, TypeFamilies #-} module Nirum.Targets.Docs ( Docs , blockToHtml , makeFilePath @@ -9,14 +9,17 @@ module Nirum.Targets.Docs ( Docs import Data.Maybe (mapMaybe) import GHC.Exts (IsList (fromList, toList)) +import qualified Data.ByteString as BS import Data.ByteString.Lazy (toStrict) import qualified Text.Email.Parser as E import Data.Map.Strict (Map, union) import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8) +import qualified Data.Text.Lazy as TL +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import System.FilePath (()) import Text.Blaze (ToMarkup (preEscapedToMarkup)) import Text.Blaze.Html.Renderer.Utf8 (renderHtml) +import Text.Cassius (cassius, renderCss) import Text.Hamlet (Html, shamlet) import Nirum.Constructs (Construct (toCode)) @@ -72,8 +75,8 @@ makeUri modulePath' = T.intercalate "/" $ map toNormalizedText (toList modulePath') ++ ["index.html"] -layout :: ToMarkup m => Package Docs -> m -> Html -> Html -layout Package { metadata = md } title body = [shamlet| +layout :: ToMarkup m => Package Docs -> Int -> m -> Html -> Html +layout Package { metadata = md } dirDepth title body = [shamlet| $doctype 5 @@ -82,11 +85,12 @@ $doctype 5 $forall Author { name = name' } <- authors md + #{body} |] typeExpression :: BoundModule Docs -> TE.TypeExpression -> Html -typeExpression _ expr = [shamlet|#{typeExpr expr}|] +typeExpression _ expr = [shamlet|#{typeExpr expr}|] where typeExpr :: TE.TypeExpression -> Html typeExpr expr' = [shamlet| @@ -104,9 +108,10 @@ $case expr' |] module' :: BoundModule Docs -> Html -module' docsModule = layout pkg path $ [shamlet| +module' docsModule = layout pkg depth path $ [shamlet| $maybe tit <- title -

#{path} — #{tit} +

#{path} +

#{tit} $nothing

#{path} $forall (ident, decl) <- types' @@ -114,10 +119,12 @@ module' docsModule = layout pkg path $ [shamlet| #{typeDecl docsModule ident decl} |] where + docsModulePath :: ModulePath + docsModulePath = modulePath docsModule pkg :: Package Docs pkg = boundPackage docsModule path :: T.Text - path = toCode $ modulePath docsModule + path = toCode docsModulePath types' :: [(Identifier, TD.TypeDeclaration)] types' = [ (facialName $ DE.name decl, decl) | decl <- DES.toList $ types docsModule @@ -126,11 +133,13 @@ module' docsModule = layout pkg path $ [shamlet| _ -> True ] mod' :: Maybe Module - mod' = resolveModule (modulePath docsModule) pkg + mod' = resolveModule docsModulePath pkg title :: Maybe Html title = do m <- mod' moduleTitle m + depth :: Int + depth = length $ toList docsModulePath blockToHtml :: Block -> Html blockToHtml b = preEscapedToMarkup $ render b @@ -138,24 +147,30 @@ blockToHtml b = preEscapedToMarkup $ render b typeDecl :: BoundModule Docs -> Identifier -> TD.TypeDeclaration -> Html typeDecl mod' ident tc@TD.TypeDeclaration { TD.type' = TD.Alias cname } = [shamlet| -

type #{toNormalizedText ident} +

+ type + #{toNormalizedText ident} + = + #{typeExpression mod' cname} $maybe d <- docsBlock tc -

#{blockToHtml d} -

= #{typeExpression mod' cname} + #{blockToHtml d} |] typeDecl mod' ident tc@TD.TypeDeclaration { TD.type' = TD.UnboxedType innerType } = [shamlet| -

unboxed #{toNormalizedText ident} +

+ unboxed + #{toNormalizedText ident} (#{typeExpression mod' innerType}) $maybe d <- docsBlock tc -

#{blockToHtml d} -

(#{typeExpression mod' innerType}) + #{blockToHtml d} |] typeDecl _ ident tc@TD.TypeDeclaration { TD.type' = TD.EnumType members } = [shamlet| -

enum #{toNormalizedText ident} +

+ enum + #{toNormalizedText ident} $maybe d <- docsBlock tc -

#{blockToHtml d} + #{blockToHtml d}

$forall decl <- DES.toList members
#{nameText $ DE.name decl} @@ -165,33 +180,33 @@ typeDecl _ ident |] typeDecl mod' ident tc@TD.TypeDeclaration { TD.type' = TD.RecordType fields } = [shamlet| -

record #{toNormalizedText ident} +

+ record + #{toNormalizedText ident} $maybe d <- docsBlock tc -

#{blockToHtml d} -

- $forall fieldDecl@(TD.Field _ fieldType _) <- DES.toList fields -
#{nameText $ DE.name fieldDecl} -
#{typeExpression mod' fieldType} - $maybe d <- docsBlock fieldDecl -
#{blockToHtml d} + #{blockToHtml d} + $forall fieldDecl@(TD.Field _ fieldType _) <- DES.toList fields +

+ #{typeExpression mod' fieldType} + #{nameText $ DE.name fieldDecl} + $maybe d <- docsBlock fieldDecl + #{blockToHtml d} |] typeDecl mod' ident tc@TD.TypeDeclaration { TD.type' = TD.UnionType tags } = [shamlet|

union #{toNormalizedText ident} $maybe d <- docsBlock tc -

#{blockToHtml d} + #{blockToHtml d} $forall tagDecl@(TD.Tag _ fields _) <- DES.toList tags -

- #{nameText $ DE.name tagDecl} +

#{nameText $ DE.name tagDecl} $maybe d <- docsBlock tagDecl -

#{blockToHtml d} -

- $forall fieldDecl@(TD.Field _ fieldType _) <- DES.toList fields -
- #{nameText $ DE.name fieldDecl} -
#{typeExpression mod' fieldType} - $maybe d <- docsBlock fieldDecl -
#{blockToHtml d} + #{blockToHtml d} + $forall fieldDecl@(TD.Field _ fieldType _) <- DES.toList fields +

+ #{typeExpression mod' fieldType} + #{nameText $ DE.name fieldDecl} + $maybe d <- docsBlock fieldDecl + #{blockToHtml d} |] typeDecl _ ident TD.TypeDeclaration { TD.type' = TD.PrimitiveType {} } = [shamlet| @@ -202,23 +217,28 @@ typeDecl mod' ident [shamlet|

service #{toNormalizedText ident} $maybe d <- docsBlock tc -

#{blockToHtml d} - $forall methodDecl@(S.Method _ ps ret err _) <- DES.toList methods + #{blockToHtml d} + $forall md@(S.Method _ ps ret err _) <- DES.toList methods

- #{nameText $ DE.name methodDecl}() - → - #{typeExpression mod' ret} - $maybe d <- docsBlock methodDecl -

#{blockToHtml d} - $maybe errType <- err -

#{typeExpression mod' errType} -

- $forall paramDecl@(S.Parameter _ paramType _) <- DES.toList ps -
- #{nameText $ DE.name paramDecl} -
#{typeExpression mod' paramType} - $maybe d <- docsBlock paramDecl -
#{blockToHtml d} + #{nameText $ DE.name md}( + + $forall pd@(S.Parameter _ pt _) <- DES.toList ps + #{typeExpression mod' pt} #{nameText $ DE.name pd} + ) + $maybe d <- docsBlock md + #{blockToHtml d} +
+
returns: +
#{typeExpression mod' ret} + $maybe errType <- err +
raises: +
#{typeExpression mod' errType} + $forall paramDecl@(S.Parameter _ paramType _) <- DES.toList ps + $maybe d <- docsBlock paramDecl +

+ #{typeExpression mod' paramType} + #{nameText $ DE.name paramDecl}: + #{blockToHtml d} |] typeDecl _ _ TD.Import {} = error ("It shouldn't happen; please report it to Nirum's bug tracker:\n" ++ @@ -241,15 +261,16 @@ showKind TD.Import {} = "import" contents :: Package Docs -> Html contents pkg@Package { metadata = md , modules = ms - } = layout pkg ("Package docs" :: T.Text) [shamlet| + } = layout pkg 0 ("Package docs" :: T.Text) [shamlet|

Modules -