gendocs (empty) → 0.1.0.0

raw patch · 11 files changed

+483/−0 lines, 11 filesdep +aesondep +aeson-prettydep +basesetup-changed

Dependencies added: aeson, aeson-pretty, base, bytestring, gendocs, safe, text

Files

• LICENSE +30/−0
• README.md +104/−0
• Setup.hs +2/−0
• gendocs.cabal +45/−0
• src/Data/Docs.hs +14/−0
• src/Data/Docs/Docs.hs +73/−0
• src/Data/Docs/Sample.hs +15/−0
• src/Data/Docs/Selectors.hs +43/−0
• src/Data/Docs/ToMarkdown.hs +132/−0
• src/Data/Docs/TypeName.hs +23/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,30 @@+Copyright Sean Hess (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Sean Hess nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,104 @@+Generate interface documentation for your types++Example+-------++    {-# LANGUAGE OverloadedStrings #-}+    {-# LANGUAGE DeriveGeneric #-}+    {-# LANGUAGE GeneralizedNewtypeDeriving #-}+    module Example where++    import Data.Aeson (ToJSON)+    import Data.Proxy (Proxy(..))+    import Data.Docs (markdown, Docs(..), Sample(..), genDocs)+    import Data.Text (Text)+    import qualified Data.Text as Text+    import GHC.Generics (Generic)++    data Person = Person+        { name :: Text+        , age :: Age+        , hobbies :: [Hobby]+        } deriving (Show, Eq, Generic)+    instance ToJSON Person+    instance Docs Person+    instance Sample Person where+        sample _ = Person+          { name = "Bob"+          , age = sample (Proxy :: Proxy Age)+          , hobbies = [Haskell, Friends]+          }++    newtype Age = Age Int+        deriving (Show, Eq, Generic)+    instance ToJSON Age+    instance Docs Age where+        docs = genDocs "Age in years"+    instance Sample Age where+        sample _ = Age 31+        samples _ = [Age 31, Age 24]++    data Hobby = Haskell | Friends | Movies+        deriving (Show, Eq, Generic, Enum, Bounded)+    instance ToJSON Hobby+    instance Docs Hobby+    instance Sample Hobby where+        sample _ = Haskell+        allValues _ = [minBound..]++    doc :: IO ()+    doc = do+        putStrLn $ Text.unpack json++    json :: Text+    json = Text.intercalate "\n\n\n" $+      [ markdown (Proxy :: Proxy Person)+      , markdown (Proxy :: Proxy Age)+      , markdown (Proxy :: Proxy Hobby)+      ]++This generates the following output++    Person+    ---------------------++    | Field   | Type              |+    |---------|-------------------|+    | name    | [Text](#text)     |+    | age     | [Age](#age)       |+    | hobbies | [[Hobby]](#hobby) |++    ```+    {+        "age": 31,+        "hobbies": [+            "Haskell",+            "Friends"+        ],+        "name": "Bob"+    }+    ```+++    Age+    ---------------------++    Age in years++    ```+    31+    ```+++    Hobby+    ---------------------++    | Values    |+    |-----------|+    | "Haskell" |+    | "Friends" |+    | "Movies"  |++    ```+    "Haskell"+    ```

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,45 @@+name:                gendocs+version:             0.1.0.0+synopsis:            Library for generating interface documentation from types+description:         Please see README.md+homepage:            https://github.com/seanhess/gendocs#readme+license:             BSD3+license-file:        LICENSE+author:              Sean Hess+maintainer:          seanhess@gmail.com+copyright:           Orbital Labs+category:            Web+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:+      Data.Docs+    , Data.Docs.Docs+    , Data.Docs.ToMarkdown+    , Data.Docs.Sample+    , Data.Docs.Selectors+    , Data.Docs.TypeName+  build-depends:+      base >= 4.7 && < 5+    , aeson+    , aeson-pretty+    , bytestring+    , safe+    , text+  default-language:    Haskell2010++test-suite gendocs-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , gendocs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/seanhess/gendocs

@@ -0,0 +1,14 @@+module Data.Docs+  ( Documentation(..)+  , Field(..)+  , Docs(..)+  , genDocs+  , genValues+  , genFields+  , Sample(..)+  , markdown+  ) where++import Data.Docs.Docs+import Data.Docs.Sample+import Data.Docs.ToMarkdown (markdown)

@@ -0,0 +1,73 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}++module Data.Docs.Docs+  ( Documentation(..)+  , Field(..)+  , Docs(..)+  , genDocs+  , genValues+  , genFields+  ) where++import Data.Text (Text, pack)+import qualified Data.Text as T+import Data.Docs.TypeName (GTypeName)+import qualified Data.Docs.TypeName as TypeName+import Data.Docs.Selectors (Selectors(..))+import Data.Data (Proxy(..), TypeRep)+import GHC.Generics (Generic, Rep)+++-- | Can generate documentation for type+class Docs a where+    docs :: Proxy a -> Documentation+    default docs :: (Generic a, GTypeName (Rep a), Selectors (Rep a)) => Proxy a -> Documentation+    docs = genDocs ""+++type FieldName = Text+type TypeName = Text++-- | Documentation for a given type+data Documentation = Documentation+    { typeName :: TypeName+    , fields :: [Field]+    , description :: Text+    } deriving (Show, Eq)++-- | Documentation for a record field+data Field = Field+    { fieldName :: FieldName+    , fieldType :: TypeName+    , isRequired :: Bool+    } deriving (Show, Eq)+++-- | Create documentation for a type with only a description+genDocs :: forall a. (Generic a, GTypeName (Rep a), Selectors (Rep a)) => Text -> Proxy a -> Documentation+genDocs d p = Documentation+    { typeName = pack $ TypeName.typeName p+    , description = d+    , fields = genFields p+    }+++genFields :: forall a. (Selectors (Rep a)) => Proxy a -> [Field]+genFields _ = map (uncurry toField . selectorToText) $ selectors (Proxy :: Proxy (Rep a))+++genValues :: forall a. (Enum a, Bounded a, Show a) => Proxy a -> [Text]+genValues _ = map (pack . show) ([minBound..] :: [a])+++selectorToText :: (String, TypeRep) -> (Text, [Text])+selectorToText (s, t) = (pack s, T.words $ pack $ show t)+++toField :: Text -> [Text] -> Field+toField s ("Maybe":t) = Field s (T.concat t) False+toField s t = Field s (T.concat t) True

@@ -0,0 +1,15 @@+-- a list type is annoying++module Data.Docs.Sample where++import Data.Proxy (Proxy)++class Sample a where+    sample :: Proxy a -> a++    samples :: Proxy a -> [a]+    samples p = [sample p]++    -- | If the values are bounded (an enum), list all of them+    allValues :: Proxy a -> [a]+    allValues _ = []

@@ -0,0 +1,43 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Data.Docs.Selectors where++import Data.Data (Proxy(..), TypeRep, Typeable, typeOf)+import GHC.Generics++-- data Record = Record { recordId :: Int32, recordName :: Text }+--   deriving (Generic)+-- selectors (Proxy :: Proxy (Rep Record))++class Selectors rep where+  selectors :: Proxy rep -> [(String, TypeRep)]++instance Selectors f => Selectors (M1 D x f) where+  selectors _ = selectors (Proxy :: Proxy f)++instance Selectors f => Selectors (M1 C x f) where+  selectors _ = selectors (Proxy :: Proxy f)++-- instance Selectors f => Selectors (C1 C x f) where+--   selectors _ = selectors (Proxy :: Proxy f)++instance (Selector s, Typeable t) => Selectors (M1 S s (K1 R t)) where+  selectors _ =+    let sel = selName (undefined :: M1 S s (K1 R t) ())+        typ = typeOf (undefined :: t)+    in if not (null sel)+      then [( sel , typ )]+      else []++instance (Selectors a, Selectors b) => Selectors (a :*: b) where+  selectors _ = selectors (Proxy :: Proxy a) ++ selectors (Proxy :: Proxy b)++-- | We don't really want to deal with sum types+instance (Selectors a, Selectors b) => Selectors (a :+: b) where+  selectors _ = selectors (Proxy :: Proxy a) ++ selectors (Proxy :: Proxy b)++instance Selectors U1 where+  selectors _ = []

@@ -0,0 +1,132 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.Docs.ToMarkdown where++import Data.Aeson (ToJSON, toJSON, Value, encode)+import Data.Aeson.Encode.Pretty (encodePretty', defConfig, Config(..))+import Data.Char (isAlphaNum)+import Data.Data (Proxy(..))+import Data.Docs.Docs (Documentation(..), Field(..), Docs(..))+import Data.Docs.Sample (Sample(..))+import qualified Data.List as List+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.ByteString.Lazy as BSL+import Data.Monoid ((<>))+import Data.Maybe (fromMaybe)+import Safe (maximumDef, headMay)++-- | Generate markdown documentation+markdown :: (ToJSON a, Docs a, Sample a) => Proxy a -> Text+markdown p =+  let d = docs p+      s = sample p+      vs =  allValues p+  in Text.intercalate "\n\n" $ map (Text.intercalate "\n") $ filter (not . List.null)+  [ header d+  , desc (description d)+  , fieldTable (fields d)+  , valuesTable (map toJSON vs)+  , example s+  ]++desc :: Text -> [Text]+desc "" = []+desc d = [d]++header :: Documentation -> [Text]+header d =+  [ typeName d+  , "---------------------"+  ]++example :: ToJSON a => a -> [Text]+example a =+  [ "```"+  , Text.decodeUtf8 $ BSL.toStrict $ encodePretty' conf a+  , "```"+  ]+  where+    conf = defConfig { confCompare = compare }+++type URL = Text++link :: Text -> URL -> Text+link t u =+    "[" <> t <> "](" <> u <> ")"++anchor :: Text -> Text -> Text+anchor t n = link t $ "#" <> (Text.filter isAlphaNum $ Text.toLower n)+++fieldTable :: [Field] -> [Text]+fieldTable [] = []+fieldTable fs =+  table ["Field", "Type", ""] (map row fs)+  where+    row f =+      [ fieldName f+      , anchor (fieldType f) (fieldType f)+      , opInfo f+      ]+    opInfo f =+      if isRequired f+        then ""+        else "(optional)"+++valuesTable :: [Value] -> [Text]+valuesTable [] = []+valuesTable vs =+  table ["Values"] (map row vs)+  where+    row t = [ Text.decodeUtf8 $ BSL.toStrict $ encode t ]+++-- | Tables++type CellWidth = Int+++cellWidth :: [Text] -> Int+cellWidth ts = maximumDef 0 (map Text.length ts)+++table :: [Text] -> [[Text]] -> [Text]+table hs rs =+  let jr = List.transpose $ map justifyColumn $ filter nonEmptyCol $ List.transpose (hs : rs) :: [[Text]]+      hs' = fromMaybe [] $ headMay jr :: [Text]+      rs' = drop 1 jr+  in mconcat [ tableHeader hs', map tableRow rs' ]+  where+    nonEmptyCol = not . all Text.null . List.drop 1++      -- calculate the column width for a column+++justifyColumn :: [Text] -> [Text]+justifyColumn ts =+  let w = maximumDef 0 (map Text.length ts)+  in map (Text.justifyLeft w ' ') ts++++tableHeader :: [Text] -> [Text]+tableHeader ts =+  [tableRow ts, sepRow ts]+++tableRow :: [Text] -> Text+tableRow ts =+  mconcat ["| ", Text.intercalate " | " ts, " |"]+  where+++sepRow :: [Text] -> Text+sepRow ts =+  mconcat ["|-", Text.intercalate "-|-" (map sepCell ts), "-|"]+  where+    sepCell t = Text.replicate (Text.length t) "-"++

@@ -0,0 +1,23 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Docs.TypeName+  ( typeName+  , GTypeName(gtypename)+  ) where++import Data.Data (Proxy(..))+import GHC.Generics+++-- | Get the typename for anything that has a simple one. https://gist.github.com/nh2/1a03b7873dbed348ef64fe536028776d++typeName :: forall a. (Generic a, GTypeName (Rep a)) => Proxy a -> String+typeName _proxy = gtypename (from (undefined :: a))++class GTypeName f where+  gtypename :: f a -> String++instance (Datatype c) => GTypeName (M1 i c f) where+  gtypename m = datatypeName m

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"