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 :: SchemaDoc d => HelpInh d -> Help d f k -> d
  31 runHelp def (Help h _p) = runHelpNodes def (h def) <> Doc.newline
  32
  33 docHelp :: SchemaDoc d => Doc.Indentable d => SchemaDoc 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 :: SchemaDoc 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 :: SchemaDoc d => Tree (HelpNode, d) -> d
  89 runHelpNode (Tree.Node (_n,d) _ts) = d
  90
  91 -- | Introduce 'Doc.newline' according to the 'HelpNode's
  92 -- put next to each others.
  93 runHelpNodes :: SchemaDoc d => HelpInh d -> Tree.Forest (HelpNode, d) -> d
  94 runHelpNodes _inh [] = mempty
  95 runHelpNodes inh ( t0@(Tree.Node _ t0s)
  96                  : t1@(Tree.Node (HelpNode_Command, _) _) : ts ) =
  97         runHelpNode t0 <>
  98         Doc.newline <>
  99         (if null t0s || not (helpInh_full inh) then mempty else Doc.newline) <>
 100         runHelpNodes inh (t1:ts)
 101 runHelpNodes inh ( t0@(Tree.Node (HelpNode_Tag, _) _)
 102                  : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
 103         runHelpNode t0 <>
 104         Doc.newline <>
 105         runHelpNodes inh (t1:ts)
 106 runHelpNodes inh ( t0@(Tree.Node (HelpNode_Rule, _) t0s)
 107                  : t1@(Tree.Node (_, _) _) : ts ) =
 108         runHelpNode t0 <>
 109         Doc.newline <>
 110         (if null t0s || not (helpInh_full inh) then mempty else Doc.newline) <>
 111         runHelpNodes inh (t1:ts)
 112 runHelpNodes inh ( t0@(Tree.Node (HelpNode_Message, _) _)
 113                  : t1 : ts ) =
 114         runHelpNode t0 <>
 115         Doc.newline <>
 116         Doc.newline <>
 117         runHelpNodes inh (t1:ts)
 118 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
 119         runHelpNode t0 <>
 120         Doc.newline <>
 121         Doc.newline <>
 122         runHelpNodes inh (t1:ts)
 123 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
 124         runHelpNode t0 <>
 125         Doc.newline <>
 126         Doc.newline <>
 127         runHelpNodes inh (t1:ts)
 128 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Rule, _) _) : ts ) =
 129         runHelpNode t0 <>
 130         Doc.newline <>
 131         runHelpNodes inh (t1:ts)
 132 runHelpNodes inh (t:ts) = runHelpNode t <> runHelpNodes inh ts
 133
 134 instance Semigroup d => Semigroup (Help d f k) where
 135         Help hx px <> Help hy py = Help (hx<>hy) (px<>py)
 136 instance Monoid d => Monoid (Help d f k) where
 137         mempty  = Help mempty mempty
 138         mappend = (<>)
 139 {-
 140 instance (Semigroup d, IsString d) => IsString (Help d e s a) where
 141         fromString "" = Help $ \_ro -> Nothing
 142         fromString s  = Help $ \_ro -> Just $ fromString s
 143 instance Show (Help Doc.Term e s a) where
 144         show = TL.unpack . Doc.textTerm . runHelp
 145 instance SchemaDoc d => Functor (Help d f) where
 146         f <$$> Help h s = Help h (f<$$>s)
 147 -}
 148 instance SchemaDoc d => App (Help d) where
 149         Help hf pf <.> Help hx px = Help (hf<>hx) (pf<.>px)
 150 instance SchemaDoc d => Alt (Help d) where
 151         Help hl pl <!> Help hr pr = Help (hl<>hr) (pl<!>pr)
 152         Help hl pl `alt` Help hr pr = Help (hl<>hr) (pl`alt`pr)
 153         opt (Help h s) = Help h (opt s)
 154         {-
 155         try (Help h s) = Help h (try s)
 156         choice hs = Help (mconcat $ help_result <$> hs) (choice (help_schema <$> hs))
 157         option a (Help h s) = Help h (option a s)
 158         -}
 159 instance SchemaDoc d => Permutable (Help d) where
 160         type Permutation (Help d) = HelpPerm d
 161         runPermutation (HelpPerm h s) = Help h $ runPermutation s
 162         toPermutation   (Help h s) = HelpPerm h $ toPermutation s
 163         toPermDefault a (Help h s) = HelpPerm h $ toPermDefault a s
 164 instance Pro (Help d) where
 165         dimap a2b b2a (Help h s) = Help h $ dimap a2b b2a s
 166 instance SchemaDoc d => AltApp (Help d) where
 167         many0 (Help h s) = Help h (many0 s)
 168         many1 (Help h s) = Help h (many1 s)
 169 instance SchemaDoc d => CLI_Var (Help d) where
 170         type VarConstraint (Help d) a = ()
 171         var' n  = Help mempty (var' n)
 172 instance SchemaDoc d => CLI_Constant (Help d) where
 173         constant n a = Help mempty (constant n a)
 174         just a       = Help mempty (just a)
 175         nothing      = Help mempty nothing
 176 instance SchemaDoc d => CLI_Env (Help d) where
 177         type EnvConstraint (Help d) a = ()
 178         env' n =
 179                 Help (\inh ->
 180                         let ts =
 181                                 if helpInh_full inh
 182                                 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
 183                                 else [] in
 184                         let d =
 185                                 Doc.fillOrBreak (helpInh_tag_indent inh)
 186                                  (Doc.bold (Doc.green (Doc.from (Doc.Word n)))
 187                                         <> Doc.space)
 188                                 <> (if null ts then mempty else Doc.space)
 189                                 <> Doc.align (runHelpNodes inh ts)
 190                                 in
 191                         [ Tree.Node (HelpNode_Env, d) ts ]
 192                  ) schema
 193                 where schema = env' n
 194 instance SchemaDoc d => CLI_Command (Help d) where
 195         -- type CommandConstraint (Help d) a = ()
 196         command n (Help h s) =
 197                 Help (\inh ->
 198                         let ts =
 199                                 (if helpInh_full inh
 200                                 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
 201                                 else []) <>
 202                                 h inh
 203                                  { helpInh_message      = Nothing
 204                                  , helpInh_command_rule = True
 205                                  } in
 206                         let d =
 207                                 let ind = helpInh_command_indent inh in
 208                                 (if not (null n) && helpInh_command_rule inh
 209                                 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 (Doc.spaces ind) ind
 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 SchemaDoc d => CLI_Tag (Help d) where
 225         type TagConstraint (Help d) a = ()
 226         tag 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.fillOrBreak (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 = tag n s
 247         endOpts = Help mempty endOpts
 248 instance SchemaDoc 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                                 let ind = helpInh_command_indent inh in
 265                                 Schema.runSchema schema (helpInh_schema inh)
 266                                 <> (if null ts {- \|| not (helpInh_full inh)-} then mempty else Doc.newline)
 267                                 <> Doc.incrIndent (Doc.spaces ind) ind
 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                                 let ind = helpInh_command_indent inh in
 286                                 ref<>Doc.space<>"::= "
 287                                 <> Schema.runSchema schema (helpInh_schema inh)
 288                                 <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
 289                                 <> Doc.incrIndent (Doc.spaces ind) ind
 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 SchemaDoc 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 SchemaDoc 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 SchemaDoc 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)