Generate Python docstrings from docs

nirum.cabal

@@ -41,6 +41,7 @@ library
                  ,     Nirum.Constructs.TypeExpression
                  ,     Nirum.Docs
                  ,     Nirum.Docs.Html
+                 ,     Nirum.Docs.ReStructuredText
                  ,     Nirum.Package
                  ,     Nirum.Package.Metadata
                  ,     Nirum.Package.ModuleSet
@@ -117,6 +118,7 @@ test-suite spec
                ,       Nirum.Constructs.TypeExpressionSpec
                ,       Nirum.DocsSpec
                ,       Nirum.Docs.HtmlSpec
+                 ,     Nirum.Docs.ReStructuredTextSpec
                ,       Nirum.Package.MetadataSpec
                ,       Nirum.Package.ModuleSetSpec
                ,       Nirum.PackageSpec

src/Nirum/Constructs/Declaration.hs

@@ -1,18 +1,25 @@
-module Nirum.Constructs.Declaration ( Declaration
-                                    , annotations
-                                    , docs
-                                    , name
+{-# LANGUAGE DefaultSignatures #-}
+module Nirum.Constructs.Declaration ( Declaration (annotations, name)
+                                    , Documented (docs, docsBlock)
                                     ) where
 
 import Nirum.Constructs (Construct)
 import Nirum.Constructs.Annotation (AnnotationSet, lookupDocs)
-import Nirum.Constructs.Docs (Docs)
+import Nirum.Constructs.Docs (Docs, toBlock)
 import Nirum.Constructs.Name (Name)
+import Nirum.Docs (Block)
 
--- 'Construct' which has its own unique 'name' and can has its 'docs'.
-class Construct a => Declaration a where
+class Documented a where
+    -- | The docs of the construct.
+    docs :: a -> Maybe Docs
+    default docs :: Declaration a => a -> Maybe Docs
+    docs = lookupDocs . annotations
+
+    -- | The parsed docs tree.
+    docsBlock :: a -> Maybe Block
+    docsBlock = fmap toBlock . docs
+
+-- Construct which has its own unique 'name' and can has its 'docs'.
+class (Construct a, Documented a) => Declaration a where
     name :: a -> Name
     annotations :: a -> AnnotationSet
-
-docs :: Declaration a => a -> Maybe Docs
-docs = lookupDocs . annotations

src/Nirum/Constructs/Module.hs

@@ -13,8 +13,9 @@ import Text.InterpolatedString.Perl6 (q)
 
 import Nirum.Constructs (Construct (toCode))
 import Nirum.Constructs.Annotation (empty)
-import Nirum.Constructs.Docs (Docs)
+import Nirum.Constructs.Declaration (Documented (docs))
 import qualified Nirum.Constructs.DeclarationSet as DS
+import Nirum.Constructs.Docs (Docs)
 import Nirum.Constructs.Identifier (Identifier)
 import Nirum.Constructs.ModulePath (ModulePath)
 import Nirum.Constructs.TypeDeclaration ( JsonType (Boolean, Number, String)
@@ -72,6 +73,9 @@ instance Construct Module where
                           _ -> True
                     ]
 
+instance Documented Module where
+    docs (Module _ docs') = docs'
+
 imports :: Module -> M.Map ModulePath (S.Set Identifier)
 imports (Module decls _) =
     M.fromListWith S.union [(p, [i]) | Import p i _ <- DS.toList decls]

src/Nirum/Constructs/Service.hs

@@ -13,7 +13,9 @@ import qualified Data.Text as T
 
 import Nirum.Constructs (Construct (toCode))
 import Nirum.Constructs.Annotation (AnnotationSet, empty, lookupDocs)
-import Nirum.Constructs.Declaration (Declaration (annotations, name), docs)
+import Nirum.Constructs.Declaration ( Declaration (annotations, name)
+                                    , Documented (docs)
+                                    )
 import Nirum.Constructs.Docs (Docs, toCodeWithPrefix)
 import Nirum.Constructs.DeclarationSet (DeclarationSet, toList)
 import Nirum.Constructs.Name (Name)
@@ -32,6 +34,8 @@ instance Construct Parameter where
                  , toCodeWithPrefix "\n" (docs p)
                  ]
 
+instance Documented Parameter
+
 instance Declaration Parameter where
     name (Parameter name' _ _) = name'
     annotations (Parameter _ _ anno') = anno'
@@ -86,6 +90,8 @@ instance Construct Method where
                         , "\n"
                         ]
 
+instance Documented Method
+
 instance Declaration Method where
     name = methodName
     annotations = methodAnnotations

src/Nirum/Constructs/TypeDeclaration.hs

@@ -62,7 +62,9 @@ import qualified Data.Text as T
 
 import Nirum.Constructs (Construct (toCode))
 import Nirum.Constructs.Annotation as A (AnnotationSet, empty, lookupDocs)
-import Nirum.Constructs.Declaration (Declaration (annotations, name), docs)
+import Nirum.Constructs.Declaration ( Declaration (annotations, name)
+                                    , Documented (docs)
+                                    )
 import Nirum.Constructs.Docs (Docs (Docs), toCodeWithPrefix)
 import Nirum.Constructs.DeclarationSet (DeclarationSet, null', toList)
 import Nirum.Constructs.Identifier (Identifier)
@@ -93,6 +95,8 @@ instance Construct EnumMember where
                                              , toCodeWithPrefix "\n" (docs e)
                                              ]
 
+instance Documented EnumMember
+
 instance Declaration EnumMember where
     name (EnumMember name' _) = name'
     annotations (EnumMember _ anno') = anno'
@@ -115,6 +119,8 @@ instance Construct Field where
                  , toCodeWithPrefix "\n" (docs field)
                  ]
 
+instance Documented Field
+
 instance Declaration Field where
     name (Field name' _ _) = name'
     annotations (Field _ _ anno') = anno'
@@ -136,6 +142,8 @@ instance Construct Tag where
       where
         fieldsCode = T.intercalate " " $ map toCode $ toList fields'
 
+instance Documented Tag
+
 instance Declaration Tag where
     name (Tag name' _ _) = name'
     annotations (Tag _ _ anno') = anno'
@@ -260,6 +268,8 @@ instance Construct TypeDeclaration where
                                                , ");\n"
                                                ]
 
+instance Documented TypeDeclaration
+
 instance Declaration TypeDeclaration where
     name TypeDeclaration { typename = name' } = name'
     name ServiceDeclaration { serviceName = name' } = name'

src/Nirum/Docs/ReStructuredText.hs

@@ -0,0 +1,138 @@
+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
+module Nirum.Docs.ReStructuredText (ReStructuredText, render) where
+
+import qualified Data.Text as T
+import Text.InterpolatedString.Perl6 (qq)
+
+import Nirum.Docs
+
+type ReStructuredText = T.Text
+
+renderInline :: Inline -> ReStructuredText
+renderInline (Text t) = escape t
+renderInline SoftLineBreak = "\n"
+renderInline HardLineBreak = "\n"
+renderInline (HtmlInline html) = [qq|:raw:`$html`|]
+renderInline (Code code') = [qq|``{code'}``|]
+renderInline (Emphasis inlines) = [qq|*{escape $ bareText inlines}*|]
+renderInline (Strong inlines) = [qq|**{escape $ bareText inlines}**|]
+renderInline (Image url title)
+  | T.null title = T.concat ["\n\n.. image:: ", url, "\n\n"]
+  | otherwise = T.concat ["\n\n.. image:: ", url, "\n   :alt: ", title, "\n\n"]
+renderInline (Link url _ inlines)
+  | length images < length inlines = [qq|`{escape $ bareText inlines} <$url>`_|]
+  | otherwise = T.replace "\n\n\n\n" "\n\n" $ T.concat [image i | i <- images]
+  where
+    images :: [(T.Text, T.Text)]
+    images = [(url', title) | Image url' title <- inlines]
+    image :: (T.Text, T.Text) -> ReStructuredText
+    image (url', title)
+     | T.null title = T.concat [ "\n\n.. image:: ", url', "\n   :target: "
+                               , url, "\n\n"
+                               ]
+     | otherwise = T.concat ["\n\n.. image:: ", url', "\n   :alt: ", title
+                            , "\n   :target: ", url, "\n\n"]
+
+bareText :: [Inline] -> T.Text
+bareText inlines =
+    T.concat $ map t inlines
+  where
+    t :: Inline -> T.Text
+    t (Text t') = t'
+    t SoftLineBreak = "\n"
+    t HardLineBreak = "\n"
+    t (HtmlInline _) = ""
+    t (Code code') = code'
+    t (Emphasis inlines') = bareText inlines'
+    t (Strong inlines') = bareText inlines'
+    t (Link _ _ inlines') = bareText inlines'
+    t (Image _ _) = ""
+
+escape :: T.Text -> ReStructuredText
+escape = T.concatMap escapeChar
+
+escapeChar :: Char -> Html
+escapeChar '\\' = "\\\\"
+escapeChar ':' = "\\:"
+escapeChar '`' = "\\`"
+escapeChar '.' = "\\."
+escapeChar c = T.singleton c
+
+renderInlines :: [Inline] -> ReStructuredText
+renderInlines inlines =
+    T.concat $ prependBar $ map renderInline inlines
+  where
+    useLineblocks :: Bool
+    useLineblocks = not $ null [i | i@HardLineBreak <- inlines]
+    prependBar :: [ReStructuredText] -> [ReStructuredText]
+    prependBar ts = if useLineblocks then "| " : ts else ts
+
+indent :: T.Text -> ReStructuredText -> ReStructuredText
+indent spaces =
+    T.intercalate "\n" . map indent' . T.lines
+  where
+    indent' :: T.Text -> T.Text
+    indent' line
+      | T.null line = T.empty
+      | otherwise = spaces `T.append` line
+
+indent2 :: ReStructuredText -> ReStructuredText
+indent2 = indent "  "
+
+indent3 :: ReStructuredText -> ReStructuredText
+indent3 = indent "   "
+
+indent4 :: ReStructuredText -> ReStructuredText
+indent4 = indent "    "
+
+renderBlock :: Block -> ReStructuredText
+renderBlock (Document blocks) = renderBlocks blocks `T.snoc` '\n'
+renderBlock ThematicBreak = "----------"
+renderBlock (Paragraph inlines) = renderInlines inlines
+renderBlock (BlockQuote blocks) = indent4 (renderBlocks blocks)
+renderBlock (HtmlBlock html) =
+    T.concat [ ".. raw:: html\n\n"
+             , indent3 html
+             ]
+renderBlock (CodeBlock lang code') =
+    T.concat [ if T.null lang then "::" else [qq|.. code:: $lang|]
+             , "\n\n"
+             , indent3 code'
+             ]
+renderBlock (Heading level inlines) =
+    T.concat [text, "\n", T.pack [hChar | _ <- [1 .. (T.length text)]]]
+  where
+    text :: ReStructuredText
+    text = renderInlines inlines
+    hChar :: Char
+    hChar = case level of
+        H1 -> '='
+        H2 -> '-'
+        H3 -> '~'
+        H4 -> '`'
+        H5 -> '.'
+        H6 -> '\''
+renderBlock (List BulletList (TightItemList items)) =
+    T.intercalate "\n" [[qq|- {renderInlines i}|] | i <- items]
+renderBlock (List BulletList (LooseItemList items)) =
+    T.intercalate "\n\n" [ [qq|- {T.drop 2 $ indent2 $ renderBlocks i}|]
+                         | i <- items
+                         ]
+renderBlock (List (OrderedList startNum _) (TightItemList items)) =
+    T.intercalate "\n" [ [qq|$n. {renderInlines i}|]
+                       | (n, i) <- indexed startNum items
+                       ]
+renderBlock (List (OrderedList startNum _) (LooseItemList items)) =
+    T.intercalate "\n\n" [ [qq|$n. {T.drop 3 $ indent3 $ renderBlocks i}|]
+                         | (n, i) <- indexed startNum items
+                         ]
+
+indexed :: Enum i => i -> [a] -> [(i, a)]
+indexed _ [] = []
+indexed start (x : xs) = (start, x) : indexed (succ start) xs
+
+renderBlocks :: [Block] -> ReStructuredText
+renderBlocks = T.intercalate "\n\n" . map renderBlock
+
+render :: Block -> ReStructuredText
+render = renderBlock

src/Nirum/Package.hs

@@ -30,10 +30,10 @@ import qualified Data.Set as S
 import System.Directory (doesDirectoryExist, listDirectory)
 import System.FilePath ((</>))
 
-import Nirum.Constructs.Docs (Docs)
 import qualified Nirum.Constructs.DeclarationSet as DS
 import Nirum.Constructs.Identifier (Identifier)
 import qualified Nirum.Constructs.Module as Mod
+import Nirum.Constructs.Declaration (Documented (docs))
 import Nirum.Constructs.ModulePath (ModulePath, fromFilePath)
 import Nirum.Constructs.TypeDeclaration ( Type
                                         , TypeDeclaration ( Import
@@ -149,8 +149,8 @@ findInBoundModule valueWhenExist valueWhenNotExist
 types :: Target t => BoundModule t -> DS.DeclarationSet TypeDeclaration
 types = findInBoundModule Mod.types DS.empty
 
-docs :: Target t => BoundModule t -> Maybe Docs
-docs = findInBoundModule Mod.docs Nothing
+instance Target t => Documented (BoundModule t) where
+    docs = findInBoundModule Mod.docs Nothing
 
 data TypeLookup = Missing
                 | Local Type

src/Nirum/Parser.hs

@@ -427,6 +427,7 @@ tag = do
             char ')'
             return f
         Nothing -> return empty
+    spaces
     docs' <- optional $ do
         d <- docs <?> "union tag docs"
         spaces