Language/Symantic/CLI/Help.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Language.Symantic.CLI.Help where
   3
   4 import Control.Applicative (Applicative(..))
   5 import Data.Bool
   6 import Data.Function (($), (.))
   7 import Data.Functor ((<$>))
   8 import Data.Functor.Compose (Compose(..))
   9 import Data.Maybe (Maybe(..), maybeToList, maybe)
  10 import Data.Monoid (Monoid(..))
  11 import Data.Semigroup (Semigroup(..))
  12 import qualified Language.Symantic.Document.Term as Doc
  13 import Data.Tree as Tree
  14
  15 import Language.Symantic.CLI.Sym
  16 import qualified Language.Symantic.CLI.Plain as Plain
  17
  18 -- * Type 'Reader'
  19 data Reader d
  20  =   Reader
  21  {   reader_help           :: Maybe d
  22  ,   reader_command_indent :: Doc.Indent
  23  ,   reader_option_indent  :: Doc.Indent
  24  ,   reader_plain          :: Plain.Reader d
  25  ,   reader_option_empty   :: Bool
  26  }
  27
  28 defReader :: Doc.Textable d => Reader d
  29 defReader = Reader
  30  { reader_help           = Nothing
  31  , reader_command_indent = 2
  32  , reader_option_indent  = 15
  33  , reader_plain          = Plain.defReader
  34  , reader_option_empty   = False
  35  }
  36
  37 -- * Type 'Result'
  38 type Result d = Tree.Forest (DocNode d)
  39
  40 defResult :: Monoid d => Result d
  41 defResult = mempty
  42
  43 -- ** Type 'DocNode'
  44 data DocNode d
  45  =   Leaf
  46      { docNodeSep    :: d
  47      , docNode       :: d
  48      }
  49  |   Indented
  50      { docNodeIndent :: Doc.Indent
  51      , docNodeSep    :: d
  52      , docNode       :: d
  53      }
  54  |   BreakableFill
  55      { docNodeIndent :: Doc.Indent
  56      , docNodeSep    :: d
  57      , docNode       :: d
  58      }
  59
  60 docTree ::
  61  Monoid d =>
  62  Doc.Textable d =>
  63  Doc.Indentable d =>
  64  Tree (DocNode d) -> d
  65 docTree (Tree.Node n []) = docNode n
  66 docTree (Tree.Node n ts) =
  67         case n of
  68          Leaf{} -> docNode n
  69          Indented      ind _sep d -> d <> Doc.incrIndent ind (Doc.newline <> docTrees ts)
  70          BreakableFill ind _sep d -> Doc.breakableFill ind d <> (Doc.align $ docTrees ts)
  71
  72 docTrees ::
  73  Monoid d =>
  74  Doc.Textable d =>
  75  Doc.Indentable d =>
  76  Tree.Forest (DocNode d) -> d
  77 docTrees [] = Doc.empty
  78 docTrees [t] = docTree t
  79 docTrees (t0:ts) =
  80         docTree t0 <> mconcat ((\t@(Tree.Node n _ns) -> docNodeSep n <> docTree t) <$> ts)
  81
  82 -- * Type 'Help'
  83 data Help d e t a
  84  =   Help
  85  {   help_result :: Reader d -> Result d
  86  ,   help_plain  :: Plain.Plain d e t a
  87  }
  88
  89 runHelp :: Monoid d => Doc.Indentable d => Doc.Textable d => Help d e t a -> d
  90 runHelp h = docTrees $ help_result h defReader
  91
  92 textHelp :: Plain.Doc d => Reader d -> Help d e t a -> d
  93 textHelp def (Help h _p) = docTrees $ h def
  94
  95 coerceHelp :: Help d e s a -> Help d e t b
  96 coerceHelp Help{help_plain, ..} = Help
  97  { help_plain = Plain.coercePlain help_plain
  98  , ..
  99  }
 100
 101 instance Doc.Textable d => Semigroup (Help d e s a) where
 102         Help hx px <> Help hy py = Help (hx<>hy) (px<>py)
 103 instance (Doc.Textable d, Monoid d) => Monoid (Help d e s a) where
 104         mempty  = Help mempty mempty
 105         mappend = (<>)
 106 {-
 107 instance (Semigroup d, IsString d) => IsString (Help d e s a) where
 108         fromString "" = Help $ \_ro -> Nothing
 109         fromString s  = Help $ \_ro -> Just $ fromString s
 110 instance Show (Help Doc.Term e s a) where
 111         show = TL.unpack . Doc.textTerm . textHelp
 112 -}
 113 instance Plain.Doc d => Sym_Fun (Help d) where
 114         f <$$> Help h p = Help h (f<$$>p)
 115 instance Plain.Doc d => Sym_App (Help d) where
 116         value a = Help mempty (value a)
 117         end     = Help mempty end
 118         Help hf pf <**> Help hx px = Help (hf<>hx) (pf<**>px)
 119 instance Plain.Doc d => Sym_Alt (Help d) where
 120         Help hl pl <||> Help hr pr = Help (hl<>hr) (pl<||>pr)
 121         try (Help h p) = Help h (try p)
 122         choice hs = Help (mconcat $ help_result <$> hs) (choice (help_plain <$> hs))
 123         option a (Help h p) = Help h (option a p)
 124 instance Plain.Doc d => Sym_AltApp (Help d) where
 125         many (Help h p) = Help h (many p)
 126         some (Help h p) = Help h (many p)
 127 -- * Type 'PermHelp'
 128 data PermHelp d e t a
 129  =   PermHelp (Reader d -> Result d)
 130               [Plain.Plain d e t a]
 131 type instance Perm (Help d e t) = PermHelp d e t
 132 instance Plain.Doc d => Sym_Interleaved (Help d) where
 133         interleaved (PermHelp h ps) = Help h $ interleaved $ Compose ps
 134         f <<$>>      Help h p       = PermHelp h $ getCompose $ f<<$>>p
 135         f <<$?>> (a, Help h p)      = PermHelp h $ getCompose $ f<<$?>>(a,p)
 136         f <<$*>>     Help h p       = PermHelp h $ getCompose $ f<<$*>>p
 137         PermHelp hl pl <<|>>      Help hr pr  = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|>>pr
 138         PermHelp hl pl <<|?>> (a, Help hr pr) = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|?>>(a,pr)
 139         PermHelp hl pl <<|*>>     Help hr pr  = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|*>>pr
 140 instance Plain.Doc d => Sym_Rule (Help d) where
 141         rule n (Help h p) =
 142                 Help (\ro ->
 143                         pure $
 144                         Tree.Node (Indented
 145                          (reader_command_indent ro)
 146                          (Doc.newline <> Doc.newline) $
 147                                 ref<>" ::= "<>Plain.runPlain p' (reader_plain ro)) $
 148                         maybeToList (pure . Leaf Doc.empty <$> reader_help ro) <>
 149                         h ro{reader_help=Nothing}
 150                  ) p'
 151                 where
 152                 p' = rule n p
 153                 ref =
 154                         Doc.bold $
 155                         Doc.between (Doc.charH '<') (Doc.charH '>') $
 156                         Doc.magentaer $
 157                         Doc.stringH n
 158 instance Plain.Doc d => Sym_Option (Help d) where
 159         var n f = Help mempty (var n f)
 160         tag n = Help mempty (tag n)
 161         opt n (Help _h p) =
 162                 Help (\ro ->
 163                         case reader_help ro of
 164                          Nothing ->
 165                                 if reader_option_empty ro
 166                                 then
 167                                         pure $ pure $ Leaf Doc.newline $ Doc.bold $
 168                                         Plain.runPlain p' (reader_plain ro)
 169                                 else []
 170                          Just msg ->
 171                                 pure $
 172                                 Tree.Node
 173                                  (BreakableFill
 174                                          (reader_option_indent ro)
 175                                          Doc.newline
 176                                          (Doc.bold $ Plain.runPlain p' (reader_plain ro) <> Doc.space)) $
 177                                 pure $ pure $ Leaf Doc.empty msg
 178                  ) p'
 179                 where p' = opt n p
 180 instance Plain.Doc d => Sym_Help d (Help d) where
 181         help msg (Help h p) = Help
 182          (\ro -> h ro{reader_help=Just msg})
 183          (Language.Symantic.CLI.Sym.help msg p)
 184 instance Plain.Doc d => Sym_Command (Help d) where
 185         main n (Help h p) =
 186                 Help (\ro ->
 187                         pure $
 188                         Tree.Node (Indented 0
 189                                  (Doc.newline <> Doc.newline) $
 190                                  Plain.runPlain p' (reader_plain ro) <>
 191                                         maybe Doc.empty
 192                                          (\d -> Doc.newline <> Doc.newline <> d <> Doc.newline)
 193                                          (reader_help ro)
 194                          ) $
 195                         h ro{reader_help=Nothing}
 196                  ) p'
 197                 where p' = main n p
 198         command n (Help h p) =
 199                 Help (\ro ->
 200                         pure $
 201                         Tree.Node
 202                          (Indented
 203                                  (reader_command_indent ro)
 204                                  (Doc.newline <> Doc.newline) $
 205                                         ref<>" ::= " <>
 206                                         Plain.runPlain p' (reader_plain ro) <>
 207                                         maybe Doc.empty
 208                                          ( (<> Doc.newline)
 209                                          . Doc.incrIndent (reader_command_indent ro)
 210                                          . (Doc.newline <>) )
 211                                          (reader_help ro)
 212                          ) $
 213                         h ro{reader_help=Nothing}
 214                  ) p'
 215                 where
 216                 p' = command n p
 217                 ref =
 218                         Doc.bold $
 219                         Doc.between (Doc.charH '<') (Doc.charH '>') $
 220                         Doc.magentaer $
 221                         Doc.stringH n
 222 instance Plain.Doc d => Sym_Exit (Help d) where
 223         exit e = Help mempty $ exit e