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