git.iko.soy/gogol
on ce42607 help sign in
gogol/gen/src/Gen/Types/Help.hs
92 lines 2.3 kB history raw
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedStrings #-}
4-- Module : Gen.Types.Help
5-- Copyright : (c) 2015-2016 Brendan Hay
6-- License : Mozilla Public License, v. 2.0.
7-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
8-- Stability : provisional
9-- Portability : non-portable (GHC extensions)
11module Gen.Types.Help
12 ( Help
13 , Desc (..)
14 , Below (..)
15 , rawHelpText
16 ) where
18import Data.Aeson
19import Data.Char (isSpace)
20import Data.String
21import Data.Text (Text)
22import qualified Data.Text as Text
23import Text.Pandoc
24import Text.Pandoc.Pretty
26data Help
27 = Help [Help]
28 | Pan Pandoc
29 | Raw Text
30 deriving (Eq)
32instance Monoid Help where
33 mempty = Help []
34 mappend x y =
35 case (x, y) of
36 (Help a, Help b) -> Help (a <> b)
37 (Pan a, Pan b) -> Pan (a <> b)
38 (Raw a, Raw b) -> Raw (a <> b)
39 (Help a, b) -> Help (a <> [b])
40 (a, Help b) -> Help (a : b)
41 (a, b) -> Help [a, b]
43-- | Empty Show instance to avoid verbose debugging output.
44instance Show Help where
45 show = const mempty
47instance IsString Help where
48 fromString = rawHelpText . fromString
50rawHelpText :: Text -> Help
51rawHelpText = Raw
53instance FromJSON Help where
54 parseJSON = withText "help" $
55 either (fail . show) pure
56 . fmap Pan
57 . readHtml def
58 . Text.unpack
60instance ToJSON Help where
61 toJSON = toJSON
62 . mappend "-- |"
63 . Text.map f
64 . Text.drop 2
65 . wrap "-- "
66 . flatten
67 where
68 f '@' = '\''
69 f x = x
71data Desc = Desc !Int Help
73instance ToJSON Desc where
74 toJSON (Desc n h) = toJSON . wrap (replicate n ' ') $ flatten h
76data Below = Below !Int Help
78instance ToJSON Below where
79 toJSON (Below n h) = toJSON . wrap (replicate n ' ' <> "-- ") $ flatten h
81flatten :: Help -> String
82flatten = \case
83 Help xs -> foldMap flatten xs
84 Pan d -> writeHaddock def d
85 Raw t -> Text.unpack t
87wrap :: String -> String -> Text
88wrap sep =
89 Text.dropWhileEnd isSpace
90 . render (Just 76)
91 . prefixed sep
92 . fromString