{-# LANGUAGE OverloadedStrings #-}
module Language.Symantic.CLI.Help where
import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Functor.Compose (Compose(..))
import Data.Maybe (Maybe(..), maybeToList, maybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import qualified Language.Symantic.Document.Term as Doc
import Data.Tree as Tree
import Language.Symantic.CLI.Sym
import qualified Language.Symantic.CLI.Plain as Plain
data Reader d
= Reader
{ reader_help :: Maybe d
, reader_command_indent :: Doc.Indent
, reader_option_indent :: Doc.Indent
, reader_plain :: Plain.Reader d
, reader_option_empty :: Bool
}
defReader :: Doc.Textable d => Reader d
defReader = Reader
{ reader_help = Nothing
, reader_command_indent = 2
, reader_option_indent = 15
, reader_plain = Plain.defReader
, reader_option_empty = False
}
type Result d = Tree.Forest (DocNode d)
defResult :: Monoid d => Result d
defResult = mempty
data DocNode d
= Leaf
{ docNodeSep :: d
, docNode :: d
}
| Indented
{ docNodeIndent :: Doc.Indent
, docNodeSep :: d
, docNode :: d
}
| BreakableFill
{ docNodeIndent :: Doc.Indent
, docNodeSep :: d
, docNode :: d
}
docTree ::
Monoid d =>
Doc.Textable d =>
Doc.Indentable d =>
Tree (DocNode d) -> d
docTree (Tree.Node n []) = docNode n
docTree (Tree.Node n ts) =
case n of
Leaf{} -> docNode n
Indented ind _sep d -> d <> Doc.incrIndent ind (Doc.newline <> docTrees ts)
BreakableFill ind _sep d -> Doc.breakableFill ind d <> (Doc.align $ docTrees ts)
docTrees ::
Monoid d =>
Doc.Textable d =>
Doc.Indentable d =>
Tree.Forest (DocNode d) -> d
docTrees [] = Doc.empty
docTrees [t] = docTree t
docTrees (t0:ts) =
docTree t0 <> mconcat ((\t@(Tree.Node n _ns) -> docNodeSep n <> docTree t) <$> ts)
data Help d e t a
= Help
{ help_result :: Reader d -> Result d
, help_plain :: Plain.Plain d e t a
}
runHelp :: Monoid d => Doc.Indentable d => Doc.Textable d => Help d e t a -> d
runHelp h = docTrees $ help_result h defReader
textHelp :: Plain.Doc d => Reader d -> Help d e t a -> d
textHelp def (Help h _p) = docTrees $ h def
coerceHelp :: Help d e s a -> Help d e t b
coerceHelp Help{help_plain, ..} = Help
{ help_plain = Plain.coercePlain help_plain
, ..
}
instance Doc.Textable d => Semigroup (Help d e s a) where
Help hx px <> Help hy py = Help (hx<>hy) (px<>py)
instance (Doc.Textable d, Monoid d) => Monoid (Help d e s a) where
mempty = Help mempty mempty
mappend = (<>)
instance Plain.Doc d => Sym_Fun (Help d) where
f <$$> Help h p = Help h (f<$$>p)
instance Plain.Doc d => Sym_App (Help d) where
value a = Help mempty (value a)
end = Help mempty end
Help hf pf <**> Help hx px = Help (hf<>hx) (pf<**>px)
instance Plain.Doc d => Sym_Alt (Help d) where
Help hl pl <||> Help hr pr = Help (hl<>hr) (pl<||>pr)
try (Help h p) = Help h (try p)
choice hs = Help (mconcat $ help_result <$> hs) (choice (help_plain <$> hs))
option a (Help h p) = Help h (option a p)
instance Plain.Doc d => Sym_AltApp (Help d) where
many (Help h p) = Help h (many p)
some (Help h p) = Help h (many p)
data PermHelp d e t a
= PermHelp (Reader d -> Result d)
[Plain.Plain d e t a]
type instance Perm (Help d e t) = PermHelp d e t
instance Plain.Doc d => Sym_Interleaved (Help d) where
interleaved (PermHelp h ps) = Help h $ interleaved $ Compose ps
f <<$>> Help h p = PermHelp h $ getCompose $ f<<$>>p
f <<$?>> (a, Help h p) = PermHelp h $ getCompose $ f<<$?>>(a,p)
f <<$*>> Help h p = PermHelp h $ getCompose $ f<<$*>>p
PermHelp hl pl <<|>> Help hr pr = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|>>pr
PermHelp hl pl <<|?>> (a, Help hr pr) = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|?>>(a,pr)
PermHelp hl pl <<|*>> Help hr pr = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|*>>pr
instance Plain.Doc d => Sym_Rule (Help d) where
rule n (Help h p) =
Help (\ro ->
pure $
Tree.Node (Indented
(reader_command_indent ro)
(Doc.newline <> Doc.newline) $
ref<>" ::= "<>Plain.runPlain p' (reader_plain ro)) $
maybeToList (pure . Leaf Doc.empty <$> reader_help ro) <>
h ro{reader_help=Nothing}
) p'
where
p' = rule n p
ref =
Doc.bold $
Doc.between (Doc.charH '<') (Doc.charH '>') $
Doc.magentaer $
Doc.stringH n
instance Plain.Doc d => Sym_Option (Help d) where
var n f = Help mempty (var n f)
tag n = Help mempty (tag n)
opt n (Help _h p) =
Help (\ro ->
case reader_help ro of
Nothing ->
if reader_option_empty ro
then
pure $ pure $ Leaf Doc.newline $ Doc.bold $
Plain.runPlain p' (reader_plain ro)
else []
Just msg ->
pure $
Tree.Node
(BreakableFill
(reader_option_indent ro)
Doc.newline
(Doc.bold $ Plain.runPlain p' (reader_plain ro) <> Doc.space)) $
pure $ pure $ Leaf Doc.empty msg
) p'
where p' = opt n p
instance Plain.Doc d => Sym_Help d (Help d) where
help msg (Help h p) = Help
(\ro -> h ro{reader_help=Just msg})
(Language.Symantic.CLI.Sym.help msg p)
instance Plain.Doc d => Sym_Command (Help d) where
main n (Help h p) =
Help (\ro ->
pure $
Tree.Node (Indented 0
(Doc.newline <> Doc.newline) $
Plain.runPlain p' (reader_plain ro) <>
maybe Doc.empty
(\d -> Doc.newline <> Doc.newline <> d <> Doc.newline)
(reader_help ro)
) $
h ro{reader_help=Nothing}
) p'
where p' = main n p
command n (Help h p) =
Help (\ro ->
pure $
Tree.Node
(Indented
(reader_command_indent ro)
(Doc.newline <> Doc.newline) $
ref<>" ::= " <>
Plain.runPlain p' (reader_plain ro) <>
maybe Doc.empty
( (<> Doc.newline)
. Doc.incrIndent (reader_command_indent ro)
. (Doc.newline <>) )
(reader_help ro)
) $
h ro{reader_help=Nothing}
) p'
where
p' = command n p
ref =
Doc.bold $
Doc.between (Doc.charH '<') (Doc.charH '>') $
Doc.magentaer $
Doc.stringH n
instance Plain.Doc d => Sym_Exit (Help d) where
exit e = Help mempty $ exit e