Help.hs

{-# 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

-- * Type 'Reader'
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'
type Result d = Tree.Forest (DocNode d)

defResult :: Monoid d => Result d
defResult = mempty

-- ** Type 'DocNode'
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)

-- * Type 'Help'
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 (Semigroup d, IsString d) => IsString (Help d e s a) where
	fromString "" = Help $ \_ro -> Nothing
	fromString s  = Help $ \_ro -> Just $ fromString s
instance Show (Help Doc.Term e s a) where
	show = TL.unpack . Doc.textTerm . textHelp
-}
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)
-- * Type 'PermHelp'
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