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