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 (HelpNode_Command, _) 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 = maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) in
 186                         let d =
 187                                 Doc.breakfill (helpInh_tag_indent inh)
 188                                  (Doc.bold (Doc.green (Doc.from (Doc.Word n)))
 189                                         <> Doc.space)
 190                                 <> (if null ts then mempty else Doc.space)
 191                                 <> Doc.align (runHelpNodes inh ts)
 192                                 in
 193                         [ Tree.Node (HelpNode_Env, d) ts ]
 194                  ) schema
 195                 where schema = env' n
 196 instance Docable d => CLI_Command (Help d) where
 197         -- type CommandConstraint (Help d) a = ()
 198         command n (Help h s) =
 199                 Help (\inh ->
 200                         let ts =
 201                                 (if helpInh_full inh
 202                                 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
 203                                 else []) <>
 204                                 h inh
 205                                  { helpInh_message      = Nothing
 206                                  , helpInh_command_rule = True
 207                                  } in
 208                         let d =
 209                                 (if not (null n) && helpInh_command_rule inh then ref<>Doc.space<>"::= " else mempty)
 210                                 <> Schema.runSchema schema (helpInh_schema inh)
 211                                 <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
 212                                 <> Doc.incrIndent (helpInh_command_indent inh)
 213                                  ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
 214                         in
 215                         [ Tree.Node (HelpNode_Command, d) ts ]
 216                  ) schema
 217                 where
 218                 schema = command n s
 219                 ref =
 220                         Doc.bold $
 221                         Doc.angles $
 222                         Doc.magentaer $
 223                         Doc.from (Doc.Word n)
 224 instance Docable d => CLI_Tag (Help d) where
 225         type TagConstraint (Help d) a = ()
 226         tagged n (Help h s) =
 227                 Help (\inh ->
 228                         if (isJust (helpInh_message inh)
 229                         || helpInh_helpless_options inh)
 230                         && helpInh_full inh
 231                         then
 232                                 let ts =
 233                                         maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) <>
 234                                         h inh{helpInh_message=Nothing} in
 235                                 let d =
 236                                         Doc.breakfill (helpInh_tag_indent inh)
 237                                          (Doc.bold $
 238                                                 Schema.runSchema schema (helpInh_schema inh)
 239                                                 <> Doc.space) -- FIXME: space is not always needed
 240                                         <> (if null ts then mempty else Doc.space)
 241                                         <> Doc.align (runHelpNodes inh ts)
 242                                         in
 243                                 [ Tree.Node (HelpNode_Tag, d) ts ]
 244                         else []
 245                  ) schema
 246                 where schema = tagged n s
 247         endOpts = Help mempty endOpts
 248 instance Docable d => CLI_Help (Help d) where
 249         type HelpConstraint (Help d) d' = d ~ d'
 250         help msg (Help h s) = Help
 251          (\inh -> h inh{helpInh_message=Just msg})
 252          (help msg s)
 253         program n (Help h s) =
 254                 Help (\inh ->
 255                         let ts =
 256                                 (if helpInh_full inh
 257                                 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
 258                                 else []) <>
 259                                 h inh
 260                                  { helpInh_message      = Nothing
 261                                  , helpInh_command_rule = True
 262                                  } in
 263                         let d =
 264                                 Schema.runSchema schema (helpInh_schema inh)
 265                                 <> (if null ts {-|| not (helpInh_full inh)-} then mempty else Doc.newline)
 266                                 <> Doc.incrIndent
 267                                  (helpInh_command_indent inh)
 268                                  ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
 269                         in
 270                         [ Tree.Node (HelpNode_Rule, d) ts ]
 271                  ) schema
 272                 where
 273                 schema = program n s
 274         rule n (Help h s) =
 275                 Help (\inh ->
 276                         let ts =
 277                                 (if helpInh_full inh
 278                                 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
 279                                 else []) <>
 280                                 h inh
 281                                  { helpInh_message      = Nothing
 282                                  , helpInh_command_rule = True
 283                                  } in
 284                         let d =
 285                                 ref<>Doc.space<>"::= "
 286                                 <> Schema.runSchema schema (helpInh_schema inh)
 287                                 <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
 288                                 <> Doc.incrIndent
 289                                  (helpInh_command_indent inh)
 290                                  ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
 291                         in
 292                         [ Tree.Node (HelpNode_Rule, d) ts ]
 293                  ) schema
 294                 where
 295                 schema = rule n s
 296                 ref =
 297                         Doc.bold $
 298                         Doc.angles $
 299                         Doc.magentaer $
 300                         Doc.from (Doc.Word n)
 301 type HelpResponseArgs = SchemaResponseArgs
 302 instance Docable d => CLI_Response (Help d) where
 303         type ResponseConstraint (Help d) a = () -- ResponseConstraint (Schema d)
 304         type ResponseArgs (Help d) a = SchemaResponseArgs a -- ResponseArgs (Schema d) a
 305         type Response (Help d) = () -- Response (Schema d)
 306         response' ::
 307          forall a repr.
 308          repr ~ Help d =>
 309          ResponseConstraint repr a =>
 310          repr (ResponseArgs repr a)
 311               (Response repr)
 312         response' = Help mempty $ response' @(Schema d) @a
 313
 314 {-
 315 instance Docable d => Sym_AltApp (Help d) where
 316         many (Help h s) = Help h (many s)
 317         some (Help h s) = Help h (many s)
 318 -}
 319
 320 -- * Type 'HelpPerm'
 321 data HelpPerm d k a
 322  =   HelpPerm (HelpInh d -> HelpResult d)
 323               (SchemaPerm d k a)
 324 instance Functor (HelpPerm d k) where
 325         f`fmap`HelpPerm h ps = HelpPerm h (f<$>ps)
 326 instance Applicative (HelpPerm d k) where
 327         pure a = HelpPerm mempty (pure a)
 328         HelpPerm fh f <*> HelpPerm xh x =
 329                 HelpPerm (fh<>xh) (f<*>x)
 330 instance Docable d => CLI_Help (HelpPerm d) where
 331         type HelpConstraint (HelpPerm d) d' = d ~ d'
 332         help msg (HelpPerm h s) = HelpPerm
 333          (\inh -> h inh{helpInh_message=Just msg})
 334          (help msg s)
 335         program n (HelpPerm h s) = HelpPerm
 336          (help_result $ program n (Help h (runPermutation s)))
 337          (rule n s)
 338         rule n (HelpPerm h s) = HelpPerm
 339          (help_result $ rule n (Help h (runPermutation s)))
 340          (rule n s)