Symantic/CLI/Help.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module 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 Symantic.CLI.Sym
  16 import qualified 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 Permutation (Help d e t) = PermHelp d e t
 132 instance Plain.Doc d => Sym_Permutation (Help d) where
 133         runPermutation (PermHelp h ps) = Help h $ runPermutation $ Compose ps
 134         toPermutation (Help h p) = PermHelp h $ getCompose $ toPermutation p
 135         toPermutationWithDefault d (Help h p) = PermHelp h $ getCompose $ toPermutationWithDefault d p
 136         f <<$>>      Help h p  = PermHelp h $ getCompose $ f<<$>>p
 137         f <<$        Help h p  = PermHelp h $ getCompose $ f<<$p
 138         f <<$?>> (a, Help h p) = PermHelp h $ getCompose $ f<<$?>>(a,p)
 139         f <<$?   (a, Help h p) = PermHelp h $ getCompose $ f<<$?  (a,p)
 140         f <<$*>>     Help h p  = PermHelp h $ getCompose $ f<<$*>>p
 141         f <<$:>>     Help h p  = PermHelp h $ getCompose $ f<<$:>>p
 142         PermHelp hl pl <<|>>      Help hr pr  = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|>>pr
 143         PermHelp hl pl <<|        Help hr pr  = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|pr
 144         PermHelp hl pl <<|?>> (a, Help hr pr) = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|?>>(a,pr)
 145         PermHelp hl pl <<|?   (a, Help hr pr) = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|?(a,pr)
 146         PermHelp hl pl <<|*>>     Help hr pr  = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|*>>pr
 147         PermHelp hl pl <<|:>>     Help hr pr  = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|:>>pr
 148 instance Plain.Doc d => Sym_Rule (Help d) where
 149         rule n (Help h p) =
 150                 Help (\ro ->
 151                         pure $
 152                         Tree.Node (Indented
 153                          (reader_command_indent ro)
 154                          (Doc.newline <> Doc.newline) $
 155                                 ref<>" ::= "<>Plain.runPlain p' (reader_plain ro)) $
 156                         maybeToList (pure . Leaf Doc.empty <$> reader_help ro) <>
 157                         h ro{reader_help=Nothing}
 158                  ) p'
 159                 where
 160                 p' = rule n p
 161                 ref =
 162                         Doc.bold $
 163                         Doc.between (Doc.charH '<') (Doc.charH '>') $
 164                         Doc.magentaer $
 165                         Doc.stringH n
 166 instance Plain.Doc d => Sym_Option (Help d) where
 167         var n f = Help mempty (var n f)
 168         tag n = Help mempty (tag n)
 169         opt n (Help _h p) =
 170                 Help (\ro ->
 171                         case reader_help ro of
 172                          Nothing ->
 173                                 if reader_option_empty ro
 174                                 then
 175                                         pure $ pure $ Leaf Doc.newline $ Doc.bold $
 176                                         Plain.runPlain p' (reader_plain ro)
 177                                 else []
 178                          Just msg ->
 179                                 pure $
 180                                 Tree.Node
 181                                  (BreakableFill
 182                                          (reader_option_indent ro)
 183                                          Doc.newline
 184                                          (Doc.bold $ Plain.runPlain p' (reader_plain ro) <> Doc.space)) $
 185                                 pure $ pure $ Leaf Doc.empty msg
 186                  ) p'
 187                 where p' = opt n p
 188 instance Plain.Doc d => Sym_Help d (Help d) where
 189         help msg (Help h p) = Help
 190          (\ro -> h ro{reader_help=Just msg})
 191          (Symantic.CLI.Sym.help msg p)
 192 instance Plain.Doc d => Sym_Command (Help d) where
 193         main n (Help h p) =
 194                 Help (\ro ->
 195                         pure $
 196                         Tree.Node (Indented 0
 197                                  (Doc.newline <> Doc.newline) $
 198                                  Plain.runPlain p' (reader_plain ro) <>
 199                                         maybe Doc.empty
 200                                          (\d -> Doc.newline <> Doc.newline <> d <> Doc.newline)
 201                                          (reader_help ro)
 202                          ) $
 203                         h ro{reader_help=Nothing}
 204                  ) p'
 205                 where p' = main n p
 206         command n (Help h p) =
 207                 Help (\ro ->
 208                         pure $
 209                         Tree.Node
 210                          (Indented
 211                                  (reader_command_indent ro)
 212                                  (Doc.newline <> Doc.newline) $
 213                                         ref<>" ::= " <>
 214                                         Plain.runPlain p' (reader_plain ro) <>
 215                                         maybe Doc.empty
 216                                          ( (<> Doc.newline)
 217                                          . Doc.incrIndent (reader_command_indent ro)
 218                                          . (Doc.newline <>) )
 219                                          (reader_help ro)
 220                          ) $
 221                         h ro{reader_help=Nothing}
 222                  ) p'
 223                 where
 224                 p' = command n p
 225                 ref =
 226                         Doc.bold $
 227                         Doc.between (Doc.charH '<') (Doc.charH '>') $
 228                         Doc.magentaer $
 229                         Doc.stringH n
 230 instance Plain.Doc d => Sym_Exit (Help d) where
 231         exit e = Help mempty $ exit e