symantic-cli/Language/Symantic/CLI/Write/Help.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Language.Symantic.CLI.Write.Help where
   3
   4 import Control.Applicative (Applicative(..))
   5 import Data.Bool
   6 import Data.Function (($))
   7 import Data.Functor ((<$>))
   8 import Data.Functor.Compose (Compose(..))
   9 import Data.Maybe (Maybe(..))
  10 import Data.Monoid (Monoid(..))
  11 import Data.Semigroup (Semigroup(..))
  12 import qualified Language.Symantic.Document.Term as Doc
  13
  14 import Language.Symantic.CLI.Sym
  15 import qualified Language.Symantic.CLI.Write.Plain as Plain
  16
  17 -- * Type 'Reader'
  18 data Reader d
  19  =   Reader
  20  {   reader_help           :: Maybe d -- ^ Current help.
  21  -- ,   reader_define         :: Bool    -- ^ Whether to print a definition, or not.
  22  -- ,   reader_or             :: d
  23  ,   reader_command_indent :: Doc.Indent
  24  ,   reader_option_indent  :: Doc.Indent
  25  ,   reader_plain          :: Plain.Reader d
  26  ,   reader_option_empty   :: Bool
  27  }
  28
  29 defReader :: Doc.Textable d => Reader d
  30 defReader = Reader
  31  { reader_help           = Nothing
  32  -- , reader_define         = True
  33  -- , reader_or             = Doc.stringH " | "
  34  , reader_command_indent = 2
  35  , reader_option_indent  = 20
  36  , reader_plain          = Plain.defReader
  37  , reader_option_empty   = False
  38  }
  39
  40 -- * Type 'Result'
  41 type Result d = [d]
  42
  43 defResult :: Monoid d => Result d
  44 defResult = mempty
  45
  46 -- * Type 'Help'
  47 data Help d e t a
  48  =   Help
  49  {   help_result :: Reader d -> Result d
  50  ,   help_plain  :: Plain.Plain d e t a
  51  }
  52
  53 runHelp :: Monoid d => Doc.Textable d => Help d e t a -> d
  54 runHelp h = Doc.catV $ help_result h defReader
  55
  56 textHelp :: Plain.Doc d => Reader d -> Help d e t a -> d
  57 textHelp def (Help h _p) =
  58         let res = h def in
  59         Doc.catV res
  60
  61 coerceHelp :: Help d e s a -> Help d e t b
  62 coerceHelp Help{help_plain, ..} = Help
  63  { help_plain = Plain.coercePlain help_plain
  64  , ..
  65  }
  66
  67 instance Doc.Textable d => Semigroup (Help d e s a) where
  68         Help hx px <> Help hy py = Help (hx<>hy) (px<>py)
  69 instance (Doc.Textable d, Monoid d) => Monoid (Help d e s a) where
  70         mempty  = Help mempty mempty
  71         mappend = (<>)
  72 {-
  73 instance (Semigroup d, IsString d) => IsString (Help d e s a) where
  74         fromString "" = Help $ \_ro -> Nothing
  75         fromString s  = Help $ \_ro -> Just $ fromString s
  76 instance Show (Help Doc.Term e s a) where
  77         show = TL.unpack . Doc.textTerm . textHelp
  78 -}
  79 instance Plain.Doc d => Sym_Fun (Help d) where
  80         f <$$> Help h p = Help h (f<$$>p)
  81 instance Plain.Doc d => Sym_App (Help d) where
  82         value a = Help mempty (value a)
  83         end     = Help mempty end
  84         Help hf pf <**> Help hx px = Help (hf<>hx) (pf<**>px)
  85 instance Plain.Doc d => Sym_Alt (Help d) where
  86         Help hl pl <||> Help hr pr = Help (hl<>hr) (pl<||>pr)
  87         try (Help h p) = Help h (try p)
  88         choice hs = Help (mconcat $ help_result <$> hs) (choice (help_plain <$> hs))
  89         option a (Help h p) = Help h (option a p)
  90 instance Plain.Doc d => Sym_AltApp (Help d) where
  91         many (Help h p) = Help h (many p)
  92         some (Help h p) = Help h (many p)
  93 -- * Type 'PermHelp'
  94 data PermHelp d e t a
  95  =   PermHelp (Reader d -> Result d)
  96               [Plain.Plain d e t a]
  97 type instance Perm (Help d e t) = PermHelp d e t
  98 instance Plain.Doc d => Sym_Interleaved (Help d) where
  99         interleaved (PermHelp h ps) = Help h $ interleaved $ Compose ps
 100         f <<$>>      Help h p       = PermHelp h $ getCompose $ f<<$>>p
 101         f <<$?>> (a, Help h p)      = PermHelp h $ getCompose $ f<<$?>>(a,p)
 102         f <<$*>>     Help h p       = PermHelp h $ getCompose $ f<<$*>>p
 103         PermHelp hl pl <<|>>      Help hr pr  = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|>>pr
 104         PermHelp hl pl <<|?>> (a, Help hr pr) = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|?>>(a,pr)
 105         PermHelp hl pl <<|*>>     Help hr pr  = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|*>>pr
 106 instance Plain.Doc d => Sym_Rule (Help d) where
 107         rule n (Help h p) =
 108                 Help (\ro ->
 109                         pure $
 110                         Doc.breakableFill 4 (ref<>" ::= "<> Plain.runPlain p' (reader_plain ro)) <>
 111                         Doc.align (Doc.catV (h ro{reader_help=Nothing}))
 112                  ) p'
 113                 where
 114                 p' = rule n p
 115                 ref = Doc.bold $ Doc.between (Doc.charH '<') (Doc.charH '>') (Doc.textH n)
 116 instance Plain.Doc d => Sym_Option (Help d) where
 117         var n (Help _h p) = Help mempty (var n p)
 118         string = Help mempty string
 119         tag n = Help mempty (tag n)
 120         opt n (Help _h p) =
 121                 Help (\ro ->
 122                         case reader_help ro of
 123                          Nothing ->
 124                                 if reader_option_empty ro
 125                                 then pure $ Doc.bold (Plain.runPlain p' (reader_plain ro))
 126                                 else []
 127                          Just msg ->
 128                                 pure $
 129                                 Doc.breakableFill (reader_option_indent ro)
 130                                  (Doc.bold $ Plain.runPlain p' (reader_plain ro) <>
 131                                         Doc.spaces 2) <>
 132                                 Doc.align msg
 133                  ) p'
 134                 where p' = opt n p
 135 instance Plain.Doc d => Sym_Help d (Help d) where
 136         help msg (Help h p) = Help
 137          (\ro -> h ro{reader_help=Just msg})
 138          (Language.Symantic.CLI.Sym.help msg p)
 139 instance Plain.Doc d => Sym_Command (Help d) where
 140         main n (Help h p) =
 141                 Help (\ro ->
 142                         [ Plain.runPlain p' (reader_plain ro) <>
 143                                 (case reader_help ro of
 144                                  Nothing -> Doc.empty
 145                                  Just msg ->
 146                                         Doc.incrIndent (reader_command_indent ro) $
 147                                         Doc.newline <> msg)
 148                         , Doc.catV $ h ro{reader_help=Nothing}
 149                         ]
 150                  ) p'
 151                 where p' = main n p
 152         command n (Help h p) =
 153                 Help (\ro ->
 154                         pure $
 155                         let d = ref<>" ::= "<>Plain.runPlain p' (reader_plain ro) in
 156                         case h ro{reader_help=Nothing} of
 157                          [] -> d
 158                          hs ->
 159                                 Doc.breakableFill 4 d <>
 160                                 Doc.align (Doc.catV hs)
 161                  ) p'
 162                 where
 163                 p' = command n p
 164                 ref = Doc.bold $ Doc.between (Doc.charH '<') (Doc.charH '>') (Doc.stringH n)
 165 instance Plain.Doc d => Sym_Exit (Help d) where
 166         exit e = Help mempty $ exit e