Docs

examples/builtins.nrm

@@ -1,4 +1,5 @@
-# Introducing built-in types.
+# Introducing built-in types
+# ==========================
 
 record number-types (
     bigint a,

examples/package.toml

@@ -2,6 +2,3 @@ version = "0.3.0"
 
 [targets.python]
 name = "nirum-examples"
-
-[targets.dummy]
-# for unit test

examples/shapes.nrm

@@ -1,4 +1,5 @@
-# Module consists zero or more type declarations.
+# Module consists zero or more type declarations
+# ==============================================
 
 unboxed offset (float64);
 # The key difference between unboxed type and reocrd type consisting of a single

nirum.cabal

@@ -39,16 +39,22 @@ library
                  ,     Nirum.Constructs.Service
                  ,     Nirum.Constructs.TypeDeclaration
                  ,     Nirum.Constructs.TypeExpression
+                 ,     Nirum.Docs
+                 ,     Nirum.Docs.Html
                  ,     Nirum.Package
                  ,     Nirum.Package.Metadata
                  ,     Nirum.Package.ModuleSet
                  ,     Nirum.Parser
                  ,     Nirum.Targets
+                 ,     Nirum.Targets.Docs
                  ,     Nirum.Targets.List
                  ,     Nirum.Targets.Python
                  ,     Nirum.Version
   build-depends:       base                     >=4.7     && <5
+               ,       blaze-html               >=0.8.1.3 && <0.9
+               ,       blaze-markup             >=0.7.1.1 && <0.8
                ,       bytestring
+               ,       cmark                    >=0.5     && <0.6
                ,       containers               >=0.5.6.2 && <0.6
                ,       cmdargs                  >=0.10.14 && <0.11
                ,       directory                >=1.2.5   && <1.4
@@ -62,6 +68,7 @@ library
                ,       parsec
                        -- only for dealing with htoml's ParserError
                ,       semver                   >=0.3.0   && <1.0
+               ,       shakespeare              >=2.0.12  && <2.1
                ,       template-haskell         >=2.11    && <3
                ,       text                     >=0.9.1.0 && <1.3
                ,       unordered-containers
@@ -109,6 +116,8 @@ test-suite spec
                ,       Nirum.Constructs.ServiceSpec
                ,       Nirum.Constructs.TypeDeclarationSpec
                ,       Nirum.Constructs.TypeExpressionSpec
+               ,       Nirum.DocsSpec
+               ,       Nirum.Docs.HtmlSpec
                ,       Nirum.Package.MetadataSpec
                ,       Nirum.Package.ModuleSetSpec
                ,       Nirum.PackageSpec

src/Nirum/Constructs/Docs.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Nirum.Constructs.Docs ( Docs (Docs)
                              , annotationDocsName
+                             , title
+                             , toBlock
                              , toCode
                              , toCodeWithPrefix
                              , toText
@@ -12,13 +14,25 @@ import qualified Data.Text as T
 
 import Nirum.Constructs (Construct (toCode))
 import Nirum.Constructs.Identifier (Identifier)
+import Nirum.Docs (Block (Document, Heading), parse)
 
 annotationDocsName :: Identifier
 annotationDocsName = "docs"
 
 -- | Docstring for constructs.
 newtype Docs = Docs T.Text deriving (Eq, Ord, Show)
 
+-- | Convert the docs to a tree.
+toBlock :: Docs -> Block
+toBlock (Docs docs') = parse docs'
+
+-- | Gets the heading title of the module if it has any title.
+title :: Docs -> Maybe Block
+title docs =
+    case toBlock docs of
+        Document (firstBlock@Heading {} : _) -> Just firstBlock
+        _ -> Nothing
+
 -- | Convert the docs to text.
 toText :: Docs -> T.Text
 toText (Docs docs') = docs'

src/Nirum/Docs.hs

@@ -0,0 +1,184 @@
+module Nirum.Docs ( Block ( BlockQuote
+                          , CodeBlock
+                          , Document
+                          , Heading
+                          , HtmlBlock
+                          , List
+                          , Paragraph
+                          , ThematicBreak
+                          , infoString
+                          , code
+                          )
+                  , HeadingLevel (H1, H2, H3, H4, H5, H6)
+                  , Html
+                  , Inline ( Code
+                           , Emphasis
+                           , HardLineBreak
+                           , HtmlInline
+                           , Image
+                           , Link
+                           , SoftLineBreak
+                           , Strong
+                           , Text
+                           , imageTitle
+                           , imageUrl
+                           , linkContents
+                           , linkTitle
+                           , linkUrl
+                           )
+                  , ItemList (LooseItemList, TightItemList)
+                  , ListType (BulletList, OrderedList, startNumber, delimiter)
+                  , ListDelimiter (Parenthesis, Period)
+                  , LooseItem
+                  , TightItem
+                  , Title
+                  , Url
+                  , filterReferences
+                  , headingLevelFromInt
+                  , headingLevelInt
+                  , parse
+                  ) where
+
+import Data.String (IsString (fromString))
+
+import qualified CMark as M
+import qualified Data.Text as T
+
+type Url = T.Text
+type Title = T.Text
+type Html = T.Text
+
+-- | The level of heading.
+-- See also: http://spec.commonmark.org/0.25/#atx-heading
+data HeadingLevel = H1 | H2 | H3 | H4 | H5 | H6 deriving (Eq, Ord, Show)
+
+headingLevelFromInt :: Int -> HeadingLevel
+headingLevelFromInt 2 = H2
+headingLevelFromInt 3 = H3
+headingLevelFromInt 4 = H4
+headingLevelFromInt 5 = H5
+headingLevelFromInt i = if i > 5 then H6 else H1
+
+headingLevelInt :: HeadingLevel -> Int
+headingLevelInt H1 = 1
+headingLevelInt H2 = 2
+headingLevelInt H3 = 3
+headingLevelInt H4 = 4
+headingLevelInt H5 = 5
+headingLevelInt H6 = 6
+
+-- | Whether a list is a bullet list or an ordered list.
+-- See also: http://spec.commonmark.org/0.25/#of-the-same-type
+data ListType = BulletList
+              | OrderedList { startNumber :: Int
+                            , delimiter :: ListDelimiter
+                            }
+              deriving (Eq, Ord, Show)
+
+-- | Whether ordered list markers are followed by period (@.@) or
+-- parenthesis (@)@).
+-- See also: http://spec.commonmark.org/0.25/#ordered-list-marker
+data ListDelimiter = Period | Parenthesis deriving (Eq, Ord, Show)
+
+data Block = Document [Block]
+           | ThematicBreak
+           | Paragraph [Inline]
+           | BlockQuote [Block]
+           | HtmlBlock Html
+           | CodeBlock { infoString :: T.Text, code :: T.Text }
+           | Heading HeadingLevel [Inline]
+           | List ListType ItemList
+           deriving (Eq, Ord, Show)
+
+data ItemList = LooseItemList [LooseItem]
+              | TightItemList [TightItem]
+              deriving (Eq, Ord, Show)
+
+type LooseItem = [Block]
+
+type TightItem = [Inline]
+
+data Inline
+    = Text T.Text
+    | SoftLineBreak -- | See also:
+                    -- http://spec.commonmark.org/0.25/#soft-line-breaks
+    | HardLineBreak -- | See also:
+                    -- http://spec.commonmark.org/0.25/#hard-line-breaks
+    | HtmlInline Html
+    | Code T.Text
+    | Emphasis [Inline]
+    | Strong [Inline]
+    | Link { linkUrl :: Url, linkTitle :: Title, linkContents :: [Inline] }
+    | Image { imageUrl :: Url, imageTitle :: Title }
+    deriving (Eq, Ord, Show)
+
+parse :: T.Text -> Block
+parse =
+    transBlock . M.commonmarkToNode [M.optNormalize, M.optSmart]
+  where
+    transBlock :: M.Node -> Block
+    transBlock n@(M.Node _ nodeType children) =
+        case nodeType of
+            M.DOCUMENT -> Document blockChildren
+            M.THEMATIC_BREAK -> ThematicBreak
+            M.PARAGRAPH -> Paragraph inlineChildren
+            M.BLOCK_QUOTE -> BlockQuote blockChildren
+            M.HTML_BLOCK rawHtml -> HtmlBlock rawHtml
+            M.CUSTOM_BLOCK _ _ -> error $ "custom block is unsupported: " ++ n'
+            M.CODE_BLOCK info codeText -> CodeBlock info codeText
+            M.HEADING lv -> Heading (headingLevelFromInt lv) inlineChildren
+            M.LIST (M.ListAttributes listType' tight start delim) ->
+                List (case listType' of
+                          M.BULLET_LIST -> BulletList
+                          M.ORDERED_LIST ->
+                              OrderedList start $
+                                          case delim of
+                                              M.PERIOD_DELIM -> Period
+                                              M.PAREN_DELIM -> Parenthesis
+                     ) $
+                     if tight
+                        then TightItemList $ map stripParagraph listItems
+                        else LooseItemList $ map (map transBlock) listItems
+            _ -> error $ "expected block, but got inline: " ++ n'
+      where
+        blockChildren :: [Block]
+        blockChildren = map transBlock children
+        inlineChildren :: [Inline]
+        inlineChildren = map transInline children
+        listItems :: [[M.Node]]
+        listItems = [nodes | (M.Node _ M.ITEM nodes) <- children]
+        stripParagraph :: [M.Node] -> [Inline]
+        stripParagraph [M.Node _ M.PARAGRAPH nodes] = map transInline nodes
+        stripParagraph ns = error $ "expected a paragraph, but got " ++ show ns
+        n' :: String
+        n' = show n
+    transInline :: M.Node -> Inline
+    transInline n@(M.Node _ nodeType childNodes) =
+        case nodeType of
+            M.TEXT text -> Text text
+            M.SOFTBREAK -> SoftLineBreak
+            M.LINEBREAK -> HardLineBreak
+            M.HTML_INLINE rawHtml -> HtmlInline rawHtml
+            M.CODE code' -> Code code'
+            M.EMPH -> Emphasis children
+            M.STRONG -> Strong children
+            M.LINK url title -> Link url title children
+            M.IMAGE url title -> Image url title
+            _ -> error $ "expected inline, but got block: " ++ show n
+      where
+        children :: [Inline]
+        children = map transInline childNodes
+
+instance IsString Block where
+    fromString = parse . T.pack
+
+instance IsString Inline where
+    fromString = Text . T.pack
+
+-- | Replace all 'Link' and 'Image' nodes with normal 'Text' nodes.
+filterReferences :: [Inline] -> [Inline]
+filterReferences [] = []
+filterReferences (Image { imageTitle = t } : ix) = Text t : filterReferences ix
+filterReferences (Link { linkContents = children } : ix) =
+    children ++ filterReferences ix
+filterReferences (i : ix) = i : filterReferences ix

src/Nirum/Docs/Html.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
+module Nirum.Docs.Html (render, renderInline, renderInlines, renderBlock) where
+
+import qualified Data.Text as T
+import Text.InterpolatedString.Perl6 (qq)
+
+import Nirum.Docs
+
+renderInline :: Inline -> Html
+renderInline (Text t) = escape t
+renderInline SoftLineBreak = "\n"
+renderInline HardLineBreak = "<br>"
+renderInline (HtmlInline html) = html
+renderInline (Code code') = [qq|<code>{escape code'}</code>|]
+renderInline (Emphasis inlines) = [qq|<em>{renderInlines inlines}</em>|]
+renderInline (Strong inlines) = [qq|<strong>{renderInlines inlines}</strong>|]
+renderInline (Link url title inlines) =
+    let body = renderInlines inlines
+    in
+        if T.null title
+            then [qq|<a href="{escape url}">$body</a>|]
+            else [qq|<a href="{escape url}" title="{escape title}">$body</a>|]
+renderInline (Image url title) =
+    if T.null title
+        then [qq|<img src="{escape url}">|]
+        else [qq|<img src="{escape url}" title="{escape title}">|]
+
+escape :: T.Text -> Html
+escape = T.concatMap escapeChar
+
+escapeChar :: Char -> Html
+escapeChar '&' = "&amp;"
+escapeChar '"' = "&quot;"
+escapeChar '<' = "&lt;"
+escapeChar '>' = "&gt;"
+escapeChar c = T.singleton c
+
+renderInlines :: [Inline] -> Html
+renderInlines = T.concat . map renderInline
+
+renderBlock :: Block -> Html
+renderBlock (Document blocks) = renderBlocks blocks `T.snoc` '\n'
+renderBlock ThematicBreak = "<hr>"
+renderBlock (Paragraph inlines) = [qq|<p>{renderInlines inlines}</p>|]
+renderBlock (BlockQuote blocks) =
+    [qq|<blockquote>{renderBlocks blocks}</blockquotes>|]
+renderBlock (HtmlBlock html) = html
+renderBlock (CodeBlock lang code') =
+    if T.null lang
+    then [qq|<pre><code>$code'</code></pre>|]
+    else [qq|<pre><code class="language-$lang">$code'</code></pre>|]
+renderBlock (Heading level inlines) =
+    let lv = headingLevelInt level
+    in [qq|<h$lv>{renderInlines inlines}</h$lv>|]
+renderBlock (List listType itemList) =
+    let liList = case itemList of
+                     TightItemList items ->
+                         [ [qq|<li>{renderInlines item}</li>|]
+                         | item <- items
+                         ]
+                     LooseItemList items ->
+                         [ [qq|<li>{renderBlocks item}</li>|]
+                         | item <- items
+                         ]
+        tag = case listType of
+                  BulletList -> "ul" :: T.Text
+                  OrderedList { startNumber = 1 } -> "ol"
+                  OrderedList { startNumber = startNumber' } ->
+                      [qq|ol start="$startNumber'"|]
+        nl = '\n'
+        liListT = T.intercalate "\n" liList
+    in [qq|<$tag>$nl$liListT$nl</$tag>|]
+
+renderBlocks :: [Block] -> Html
+renderBlocks = T.intercalate "\n" . map renderBlock
+
+render :: Block -> Html
+render = renderBlock

src/Nirum/Package/Metadata.hs

@@ -170,8 +170,11 @@ parseMetadata metadataPath' tomlText = do
         Right t -> Right t
     version' <- versionField "version" table
     authors' <- authorsField "authors" table
-    targets <- tableField "targets" table
+    targets <- case tableField "targets" table of
+        Left (FieldError _) -> Right HM.empty
+        otherwise' -> otherwise'
     targetTable <- case tableField targetName' targets of
+        Left (FieldError _) -> Right HM.empty
         Left e -> Left $ prependMetadataErrorField "targets" e
         otherwise' -> otherwise'
     target' <- case parseTarget targetTable of

src/Nirum/Targets.hs

@@ -37,6 +37,7 @@ import Nirum.Package.Metadata ( Metadata (Metadata, target)
                               , TargetName
                               )
 import Nirum.Targets.List (targetProxyMapQ)
+import Nirum.Targets.Docs ()
 import Nirum.Targets.Python ()
 
 data BuildError = TargetNameError TargetName