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
  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 (_, _) _) : 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_Message, _) _)
 120                  : t1 : ts ) =
 121         runHelpNode t0 <>
 122         Doc.newline <>
 123         Doc.newline <>
 124         runHelpNodes inh (t1:ts)
 125 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
 126         runHelpNode t0 <>
 127         Doc.newline <>
 128         Doc.newline <>
 129         runHelpNodes inh (t1:ts)
 130 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
 131         runHelpNode t0 <>
 132         Doc.newline <>
 133         Doc.newline <>
 134         runHelpNodes inh (t1:ts)
 135 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Rule, _) _) : ts ) =
 136         runHelpNode t0 <>
 137         Doc.newline <>
 138         runHelpNodes inh (t1:ts)
 139 runHelpNodes inh (t:ts) = runHelpNode t <> runHelpNodes inh ts
 140
 141 instance Semigroup d => Semigroup (Help d f k) where
 142         Help hx px <> Help hy py = Help (hx<>hy) (px<>py)
 143 instance Monoid d => Monoid (Help d f k) where
 144         mempty  = Help mempty mempty
 145         mappend = (<>)
 146 {-
 147 instance (Semigroup d, IsString d) => IsString (Help d e s a) where
 148         fromString "" = Help $ \_ro -> Nothing
 149         fromString s  = Help $ \_ro -> Just $ fromString s
 150 instance Show (Help Doc.Term e s a) where
 151         show = TL.unpack . Doc.textTerm . runHelp
 152 instance Docable d => Functor (Help d f) where
 153         f <$$> Help h s = Help h (f<$$>s)
 154 -}
 155 instance Docable d => App (Help d) where
 156         Help hf pf <.> Help hx px = Help (hf<>hx) (pf<.>px)
 157 instance Docable d => Alt (Help d) where
 158         Help hl pl <!> Help hr pr = Help (hl<>hr) (pl<!>pr)
 159         opt (Help h s) = Help h (opt s)
 160         {-
 161         try (Help h s) = Help h (try s)
 162         choice hs = Help (mconcat $ help_result <$> hs) (choice (help_schema <$> hs))
 163         option a (Help h s) = Help h (option a s)
 164         -}
 165 instance Docable d => Permutable (Help d) where
 166         type Permutation (Help d) = HelpPerm d
 167         runPermutation (HelpPerm h s) = Help h $ runPermutation s
 168         toPermutation   (Help h s) = HelpPerm h $ toPermutation s
 169         toPermDefault a (Help h s) = HelpPerm h $ toPermDefault a s
 170 instance Pro (Help d) where
 171         dimap a2b b2a (Help h s) = Help h $ dimap a2b b2a s
 172 instance Docable d => AltApp (Help d) where
 173         many0 (Help h s) = Help h (many0 s)
 174         many1 (Help h s) = Help h (many1 s)
 175 instance Docable d => CLI_Var (Help d) where
 176         type VarConstraint (Help d) a = ()
 177         var' n  = Help mempty (var' n)
 178         just a  = Help mempty (just a)
 179         nothing = Help mempty nothing
 180 instance Docable d => CLI_Env (Help d) where
 181         type EnvConstraint (Help d) a = ()
 182         env' n =
 183                 Help (\inh ->
 184                         let ts =
 185                                 if helpInh_full inh
 186                                 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
 187                                 else [] in
 188                         let d =
 189                                 Doc.breakfill (helpInh_tag_indent inh)
 190                                  (Doc.bold (Doc.green (Doc.from (Doc.Word n)))
 191                                         <> Doc.space)
 192                                 <> (if null ts then mempty else Doc.space)
 193                                 <> Doc.align (runHelpNodes inh ts)
 194                                 in
 195                         [ Tree.Node (HelpNode_Env, d) ts ]
 196                  ) schema
 197                 where schema = env' n
 198 instance Docable d => CLI_Command (Help d) where
 199         -- type CommandConstraint (Help d) a = ()
 200         command n (Help h s) =
 201                 Help (\inh ->
 202                         let ts =
 203                                 (if helpInh_full inh
 204                                 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
 205                                 else []) <>
 206                                 h inh
 207                                  { helpInh_message      = Nothing
 208                                  , helpInh_command_rule = True
 209                                  } in
 210                         let d =
 211                                 (if not (null n) && helpInh_command_rule inh
 212                                 then ref<>Doc.space<>"::= " else mempty)
 213                                 <> Schema.runSchema schema (helpInh_schema inh)
 214                                 <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
 215                                 <> Doc.incrIndent (helpInh_command_indent inh)
 216                                  ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
 217                         in
 218                         [ Tree.Node (HelpNode_Command, d) ts ]
 219                  ) schema
 220                 where
 221                 schema = command n s
 222                 ref =
 223                         Doc.bold $
 224                         Doc.angles $
 225                         Doc.magentaer $
 226                         Doc.from (Doc.Word n)
 227 instance Docable d => CLI_Tag (Help d) where
 228         type TagConstraint (Help d) a = ()
 229         tagged n (Help h s) =
 230                 Help (\inh ->
 231                         if (isJust (helpInh_message inh)
 232                         || helpInh_helpless_options inh)
 233                         && helpInh_full inh
 234                         then
 235                                 let ts =
 236                                         maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) <>
 237                                         h inh{helpInh_message=Nothing} in
 238                                 let d =
 239                                         Doc.breakfill (helpInh_tag_indent inh)
 240                                          (Doc.bold $
 241                                                 Schema.runSchema schema (helpInh_schema inh)
 242                                                 <> Doc.space) -- FIXME: space is not always needed
 243                                         <> (if null ts then mempty else Doc.space)
 244                                         <> Doc.align (runHelpNodes inh ts)
 245                                         in
 246                                 [ Tree.Node (HelpNode_Tag, d) ts ]
 247                         else []
 248                  ) schema
 249                 where schema = tagged n s
 250         endOpts = Help mempty endOpts
 251 instance Docable d => CLI_Help (Help d) where
 252         type HelpConstraint (Help d) d' = d ~ d'
 253         help msg (Help h s) = Help
 254          (\inh -> h inh{helpInh_message=Just msg})
 255          (help msg s)
 256         program n (Help h s) =
 257                 Help (\inh ->
 258                         let ts =
 259                                 (if helpInh_full inh
 260                                 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
 261                                 else []) <>
 262                                 h inh
 263                                  { helpInh_message      = Nothing
 264                                  , helpInh_command_rule = True
 265                                  } in
 266                         let d =
 267                                 Schema.runSchema schema (helpInh_schema inh)
 268                                 <> (if null ts {-|| not (helpInh_full inh)-} then mempty else Doc.newline)
 269                                 <> Doc.incrIndent
 270                                  (helpInh_command_indent inh)
 271                                  ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
 272                         in
 273                         [ Tree.Node (HelpNode_Rule, d) ts ]
 274                  ) schema
 275                 where
 276                 schema = program n s
 277         rule n (Help h s) =
 278                 Help (\inh ->
 279                         let ts =
 280                                 (if helpInh_full inh
 281                                 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
 282                                 else []) <>
 283                                 h inh
 284                                  { helpInh_message      = Nothing
 285                                  , helpInh_command_rule = True
 286                                  } in
 287                         let d =
 288                                 ref<>Doc.space<>"::= "
 289                                 <> Schema.runSchema schema (helpInh_schema inh)
 290                                 <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
 291                                 <> Doc.incrIndent
 292                                  (helpInh_command_indent inh)
 293                                  ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
 294                         in
 295                         [ Tree.Node (HelpNode_Rule, d) ts ]
 296                  ) schema
 297                 where
 298                 schema = rule n s
 299                 ref =
 300                         Doc.bold $
 301                         Doc.angles $
 302                         Doc.magentaer $
 303                         Doc.from (Doc.Word n)
 304 type HelpResponseArgs = SchemaResponseArgs
 305 instance Docable d => CLI_Response (Help d) where
 306         type ResponseConstraint (Help d) a = () -- ResponseConstraint (Schema d)
 307         type ResponseArgs (Help d) a = SchemaResponseArgs a -- ResponseArgs (Schema d) a
 308         type Response (Help d) = () -- Response (Schema d)
 309         response' ::
 310          forall a repr.
 311          repr ~ Help d =>
 312          ResponseConstraint repr a =>
 313          repr (ResponseArgs repr a)
 314               (Response repr)
 315         response' = Help mempty $ response' @(Schema d) @a
 316
 317 {-
 318 instance Docable d => Sym_AltApp (Help d) where
 319         many (Help h s) = Help h (many s)
 320         some (Help h s) = Help h (many s)
 321 -}
 322
 323 -- * Type 'HelpPerm'
 324 data HelpPerm d k a
 325  =   HelpPerm (HelpInh d -> HelpResult d)
 326               (SchemaPerm d k a)
 327 instance Functor (HelpPerm d k) where
 328         f`fmap`HelpPerm h ps = HelpPerm h (f<$>ps)
 329 instance Applicative (HelpPerm d k) where
 330         pure a = HelpPerm mempty (pure a)
 331         HelpPerm fh f <*> HelpPerm xh x =
 332                 HelpPerm (fh<>xh) (f<*>x)
 333 instance Docable d => CLI_Help (HelpPerm d) where
 334         type HelpConstraint (HelpPerm d) d' = d ~ d'
 335         help msg (HelpPerm h s) = HelpPerm
 336          (\inh -> h inh{helpInh_message=Just msg})
 337          (help msg s)
 338         program n (HelpPerm h s) = HelpPerm
 339          (help_result $ program n (Help h (runPermutation s)))
 340          (rule n s)
 341         rule n (HelpPerm h s) = HelpPerm
 342          (help_result $ rule n (Help h (runPermutation s)))
 343          (rule n s)