Symantic/CLI/Help.hs

   1 {-# LANGUAGE InstanceSigs #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
   4 module Symantic.CLI.Help where
   5
   6 import Control.Applicative (Applicative(..))
   7 import Data.Bool
   8 import Data.Foldable (null)
   9 import Data.Function (($), (.))
  10 import Data.Functor (Functor(..), (<$>))
  11 import Data.Maybe (Maybe(..), maybe, isJust)
  12 import Data.Monoid (Monoid(..))
  13 import Data.Semigroup (Semigroup(..))
  14 import Text.Show (Show(..))
  15 import Data.Tree as Tree
  16 import qualified Symantic.Document as Doc
  17
  18 import Symantic.CLI.API
  19 import Symantic.CLI.Schema as Schema
  20
  21 -- * Type 'Help'
  22 data Help d f k
  23  =   Help
  24  {   help_result :: HelpInh d -> HelpResult d
  25      -- ^ The 'HelpResult' of the current symantic.
  26  ,   help_schema :: Schema d f k
  27      -- ^ The 'Schema' of the current symantic.
  28  }
  29
  30 runHelp :: Docable d => HelpInh d -> Help d f k -> d
  31 runHelp def (Help h _p) = runHelpNodes def (h def) <> Doc.newline
  32
  33 docHelp :: Docable d => Doc.Indentable d => Docable d => Help d f k -> d
  34 docHelp = runHelp defHelpInh
  35
  36 coerceHelp :: Help d f k -> Help d f' k'
  37 coerceHelp Help{help_schema, ..} = Help
  38  { help_schema = Schema.coerceSchema help_schema
  39  , ..
  40  }
  41
  42 -- ** Type 'HelpInh'
  43 -- | Configuration inherited top-down.
  44 data HelpInh d
  45  =   HelpInh
  46  {   helpInh_message :: !(Maybe d)
  47      -- ^ The message inherited from 'help's.
  48  ,   helpInh_command_indent :: !Doc.Indent
  49      -- ^ 'Doc.Indent'ation for 'command's.
  50  ,   helpInh_tag_indent :: !Doc.Indent
  51      -- ^ 'Doc.Indent'ation for 'Tag's.
  52  ,   helpInh_schema :: !(SchemaInh d)
  53      -- ^ The inherited 'SchemaInh' for 'runSchema'.
  54  ,   helpInh_helpless_options :: !Bool
  55      -- ^ Whether to include options without help in the listing.
  56  ,   helpInh_command_rule :: !Bool
  57      -- ^ Whether to print the name of the rule.
  58  ,   helpInh_full :: !Bool
  59      -- ^ Whether to print full help.
  60  }
  61
  62 defHelpInh :: Docable d => HelpInh d
  63 defHelpInh = HelpInh
  64  { helpInh_message          = Nothing
  65  , helpInh_command_indent   = 2
  66  , helpInh_tag_indent       = 16
  67  , helpInh_schema           = defSchemaInh
  68  , helpInh_helpless_options = False
  69  , helpInh_command_rule     = False
  70  , helpInh_full             = True
  71  }
  72
  73 -- ** Type 'HelpResult'
  74 type HelpResult d = Tree.Forest (HelpNode, d)
  75
  76 defHelpResult :: Monoid d => HelpResult d
  77 defHelpResult = mempty
  78
  79 -- *** Type 'HelpNode'
  80 data HelpNode
  81  =   HelpNode_Message
  82  |   HelpNode_Rule
  83  |   HelpNode_Command
  84  |   HelpNode_Tag
  85  |   HelpNode_Env
  86  deriving Show
  87
  88 runHelpNode ::
  89  Monoid d =>
  90  Docable d =>
  91  Tree (HelpNode, d) -> d
  92 runHelpNode (Tree.Node (n,d) _ts) = d -- "[" <> Doc.stringH (show n) <> "]" <> d
  93
  94 -- | Introduce 'Doc.newline' according to the 'HelpNode's
  95 -- put next to each others.
  96 runHelpNodes ::
  97  Monoid d =>
  98  Docable d =>
  99  HelpInh d ->
 100  Tree.Forest (HelpNode, d) -> d
 101 runHelpNodes inh [] = mempty
 102 runHelpNodes inh ( t0@(Tree.Node _ t0s)
 103                  : t1@(Tree.Node (HelpNode_Command, _) _) : ts ) =
 104         runHelpNode t0 <>
 105         Doc.newline <>
 106         (if null t0s || not (helpInh_full inh) then mempty else Doc.newline) <>
 107         runHelpNodes inh (t1:ts)
 108 runHelpNodes inh ( t0@(Tree.Node (HelpNode_Tag, _) _)
 109                  : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
 110         runHelpNode t0 <>
 111         Doc.newline <>
 112         runHelpNodes inh (t1:ts)
 113 runHelpNodes inh ( t0@(Tree.Node (HelpNode_Rule, _) t0s)
 114                  : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
 115         runHelpNode t0 <>
 116         Doc.newline <>
 117         (if null t0s || not (helpInh_full inh) then mempty else Doc.newline) <>
 118         runHelpNodes inh (t1:ts)
 119 runHelpNodes inh ( t0@(Tree.Node (HelpNode_Env, _) _)
 120                  : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
 121         runHelpNode t0 <>
 122         Doc.newline <>
 123         runHelpNodes inh (t1:ts)
 124 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
 125         runHelpNode t0 <>
 126         Doc.newline <>
 127         Doc.newline <>
 128         runHelpNodes inh (t1:ts)
 129 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
 130         runHelpNode t0 <>
 131         Doc.newline <>
 132         Doc.newline <>
 133         runHelpNodes inh (t1:ts)
 134 runHelpNodes inh ( t0@(Tree.Node (HelpNode_Message, _) _)
 135                  : t1 : ts ) =
 136         runHelpNode t0 <>
 137         Doc.newline <>
 138         Doc.newline <>
 139         runHelpNodes inh (t1:ts)
 140 runHelpNodes inh (t:ts) = runHelpNode t <> runHelpNodes inh ts
 141
 142 instance Semigroup d => Semigroup (Help d f k) where
 143         Help hx px <> Help hy py = Help (hx<>hy) (px<>py)
 144 instance Monoid d => Monoid (Help d f k) where
 145         mempty  = Help mempty mempty
 146         mappend = (<>)
 147 {-
 148 instance (Semigroup d, IsString d) => IsString (Help d e s a) where
 149         fromString "" = Help $ \_ro -> Nothing
 150         fromString s  = Help $ \_ro -> Just $ fromString s
 151 instance Show (Help Doc.Term e s a) where
 152         show = TL.unpack . Doc.textTerm . runHelp
 153 instance Docable d => Functor (Help d f) where
 154         f <$$> Help h s = Help h (f<$$>s)
 155 -}
 156 instance Docable d => App (Help d) where
 157         Help hf pf <.> Help hx px = Help (hf<>hx) (pf<.>px)
 158 instance Docable d => Alt (Help d) where
 159         Help hl pl <!> Help hr pr = Help (hl<>hr) (pl<!>pr)
 160         opt (Help h s) = Help h (opt s)
 161         {-
 162         try (Help h s) = Help h (try s)
 163         choice hs = Help (mconcat $ help_result <$> hs) (choice (help_schema <$> hs))
 164         option a (Help h s) = Help h (option a s)
 165         -}
 166 instance Docable d => Permutable (Help d) where
 167         type Permutation (Help d) = HelpPerm d
 168         runPermutation (HelpPerm h s) = Help h $ runPermutation s
 169         toPermutation   (Help h s) = HelpPerm h $ toPermutation s
 170         toPermDefault a (Help h s) = HelpPerm h $ toPermDefault a s
 171 instance Pro (Help d) where
 172         dimap a2b b2a (Help h s) = Help h $ dimap a2b b2a s
 173 instance Docable d => AltApp (Help d) where
 174         many0 (Help h s) = Help h (many0 s)
 175         many1 (Help h s) = Help h (many1 s)
 176 instance Docable d => CLI_Var (Help d) where
 177         type VarConstraint (Help d) a = ()
 178         var' n  = Help mempty (var' n)
 179         just a  = Help mempty (just a)
 180         nothing = Help mempty nothing
 181 instance Docable d => CLI_Env (Help d) where
 182         type EnvConstraint (Help d) a = ()
 183         env' n =
 184                 Help (\inh ->
 185                         let ts =
 186                                 if helpInh_full inh
 187                                 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
 188                                 else [] in
 189                         let d =
 190                                 Doc.breakfill (helpInh_tag_indent inh)
 191                                  (Doc.bold (Doc.green (Doc.from (Doc.Word n)))
 192                                         <> Doc.space)
 193                                 <> (if null ts then mempty else Doc.space)
 194                                 <> Doc.align (runHelpNodes inh ts)
 195                                 in
 196                         [ Tree.Node (HelpNode_Env, d) ts ]
 197                  ) schema
 198                 where schema = env' n
 199 instance Docable d => CLI_Command (Help d) where
 200         -- type CommandConstraint (Help d) a = ()
 201         command n (Help h s) =
 202                 Help (\inh ->
 203                         let ts =
 204                                 (if helpInh_full inh
 205                                 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
 206                                 else []) <>
 207                                 h inh
 208                                  { helpInh_message      = Nothing
 209                                  , helpInh_command_rule = True
 210                                  } in
 211                         let d =
 212                                 (if not (null n) && helpInh_command_rule inh
 213                                 then ref<>Doc.space<>"::= " else mempty)
 214                                 <> Schema.runSchema schema (helpInh_schema inh)
 215                                 <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
 216                                 <> Doc.incrIndent (helpInh_command_indent inh)
 217                                  ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
 218                         in
 219                         [ Tree.Node (HelpNode_Command, d) ts ]
 220                  ) schema
 221                 where
 222                 schema = command n s
 223                 ref =
 224                         Doc.bold $
 225                         Doc.angles $
 226                         Doc.magentaer $
 227                         Doc.from (Doc.Word n)
 228 instance Docable d => CLI_Tag (Help d) where
 229         type TagConstraint (Help d) a = ()
 230         tagged n (Help h s) =
 231                 Help (\inh ->
 232                         if (isJust (helpInh_message inh)
 233                         || helpInh_helpless_options inh)
 234                         && helpInh_full inh
 235                         then
 236                                 let ts =
 237                                         maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) <>
 238                                         h inh{helpInh_message=Nothing} in
 239                                 let d =
 240                                         Doc.breakfill (helpInh_tag_indent inh)
 241                                          (Doc.bold $
 242                                                 Schema.runSchema schema (helpInh_schema inh)
 243                                                 <> Doc.space) -- FIXME: space is not always needed
 244                                         <> (if null ts then mempty else Doc.space)
 245                                         <> Doc.align (runHelpNodes inh ts)
 246                                         in
 247                                 [ Tree.Node (HelpNode_Tag, d) ts ]
 248                         else []
 249                  ) schema
 250                 where schema = tagged n s
 251         endOpts = Help mempty endOpts
 252 instance Docable d => CLI_Help (Help d) where
 253         type HelpConstraint (Help d) d' = d ~ d'
 254         help msg (Help h s) = Help
 255          (\inh -> h inh{helpInh_message=Just msg})
 256          (help msg s)
 257         program n (Help h s) =
 258                 Help (\inh ->
 259                         let ts =
 260                                 (if helpInh_full inh
 261                                 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
 262                                 else []) <>
 263                                 h inh
 264                                  { helpInh_message      = Nothing
 265                                  , helpInh_command_rule = True
 266                                  } in
 267                         let d =
 268                                 Schema.runSchema schema (helpInh_schema inh)
 269                                 <> (if null ts {-|| not (helpInh_full inh)-} then mempty else Doc.newline)
 270                                 <> Doc.incrIndent
 271                                  (helpInh_command_indent inh)
 272                                  ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
 273                         in
 274                         [ Tree.Node (HelpNode_Rule, d) ts ]
 275                  ) schema
 276                 where
 277                 schema = program n s
 278         rule n (Help h s) =
 279                 Help (\inh ->
 280                         let ts =
 281                                 (if helpInh_full inh
 282                                 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
 283                                 else []) <>
 284                                 h inh
 285                                  { helpInh_message      = Nothing
 286                                  , helpInh_command_rule = True
 287                                  } in
 288                         let d =
 289                                 ref<>Doc.space<>"::= "
 290                                 <> Schema.runSchema schema (helpInh_schema inh)
 291                                 <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
 292                                 <> Doc.incrIndent
 293                                  (helpInh_command_indent inh)
 294                                  ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
 295                         in
 296                         [ Tree.Node (HelpNode_Rule, d) ts ]
 297                  ) schema
 298                 where
 299                 schema = rule n s
 300                 ref =
 301                         Doc.bold $
 302                         Doc.angles $
 303                         Doc.magentaer $
 304                         Doc.from (Doc.Word n)
 305 type HelpResponseArgs = SchemaResponseArgs
 306 instance Docable d => CLI_Response (Help d) where
 307         type ResponseConstraint (Help d) a = () -- ResponseConstraint (Schema d)
 308         type ResponseArgs (Help d) a = SchemaResponseArgs a -- ResponseArgs (Schema d) a
 309         type Response (Help d) = () -- Response (Schema d)
 310         response' ::
 311          forall a repr.
 312          repr ~ Help d =>
 313          ResponseConstraint repr a =>
 314          repr (ResponseArgs repr a)
 315               (Response repr)
 316         response' = Help mempty $ response' @(Schema d) @a
 317
 318 {-
 319 instance Docable d => Sym_AltApp (Help d) where
 320         many (Help h s) = Help h (many s)
 321         some (Help h s) = Help h (many s)
 322 -}
 323
 324 -- * Type 'HelpPerm'
 325 data HelpPerm d k a
 326  =   HelpPerm (HelpInh d -> HelpResult d)
 327               (SchemaPerm d k a)
 328 instance Functor (HelpPerm d k) where
 329         f`fmap`HelpPerm h ps = HelpPerm h (f<$>ps)
 330 instance Applicative (HelpPerm d k) where
 331         pure a = HelpPerm mempty (pure a)
 332         HelpPerm fh f <*> HelpPerm xh x =
 333                 HelpPerm (fh<>xh) (f<*>x)
 334 instance Docable d => CLI_Help (HelpPerm d) where
 335         type HelpConstraint (HelpPerm d) d' = d ~ d'
 336         help msg (HelpPerm h s) = HelpPerm
 337          (\inh -> h inh{helpInh_message=Just msg})
 338          (help msg s)
 339         program n (HelpPerm h s) = HelpPerm
 340          (help_result $ program n (Help h (runPermutation s)))
 341          (rule n s)
 342         rule n (HelpPerm h s) = HelpPerm
 343          (help_result $ rule n (Help h (runPermutation s)))
 344          (rule n s)