Help.hs

{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
module Symantic.CLI.Help where

import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Foldable (null)
import Data.Function (($), (.))
import Data.Functor (Functor(..), (<$>))
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Text.Show (Show(..))
import Data.Tree as Tree
import qualified Symantic.Document as Doc

import Symantic.CLI.API
import Symantic.CLI.Schema as Schema

-- * Type 'Help'
data Help d f k
 =   Help
 {   help_result :: HelpInh d -> HelpResult d
     -- ^ The 'HelpResult' of the current symantic.
 ,   help_schema :: Schema d f k
     -- ^ The 'Schema' of the current symantic.
 }

runHelp :: Docable d => HelpInh d -> Help d f k -> d
runHelp def (Help h _p) = runHelpNodes def (h def) <> Doc.newline

docHelp :: Docable d => Doc.Indentable d => Docable d => Help d f k -> d
docHelp = runHelp defHelpInh

coerceHelp :: Help d f k -> Help d f' k'
coerceHelp Help{help_schema, ..} = Help
 { help_schema = Schema.coerceSchema help_schema
 , ..
 }

-- ** Type 'HelpInh'
-- | Configuration inherited top-down.
data HelpInh d
 =   HelpInh
 {   helpInh_message :: !(Maybe d)
     -- ^ The message inherited from 'help's.
 ,   helpInh_command_indent :: !Doc.Indent
     -- ^ 'Doc.Indent'ation for 'command's.
 ,   helpInh_tag_indent :: !Doc.Indent
     -- ^ 'Doc.Indent'ation for 'Tag's.
 ,   helpInh_schema :: !(SchemaInh d)
     -- ^ The inherited 'SchemaInh' for 'runSchema'.
 ,   helpInh_helpless_options :: !Bool
     -- ^ Whether to include options without help in the listing.
 ,   helpInh_command_rule :: !Bool
     -- ^ Whether to print the name of the rule.
 ,   helpInh_full :: !Bool
     -- ^ Whether to print full help.
 }

defHelpInh :: Docable d => HelpInh d
defHelpInh = HelpInh
 { helpInh_message          = Nothing
 , helpInh_command_indent   = 2
 , helpInh_tag_indent       = 16
 , helpInh_schema           = defSchemaInh
 , helpInh_helpless_options = False
 , helpInh_command_rule     = False
 , helpInh_full             = True
 }

-- ** Type 'HelpResult'
type HelpResult d = Tree.Forest (HelpNode, d)

defHelpResult :: Monoid d => HelpResult d
defHelpResult = mempty

-- *** Type 'HelpNode'
data HelpNode
 =   HelpNode_Message
 |   HelpNode_Rule
 |   HelpNode_Command
 |   HelpNode_Tag
 |   HelpNode_Env
 deriving Show

runHelpNode ::
 Monoid d =>
 Docable d =>
 Tree (HelpNode, d) -> d
runHelpNode (Tree.Node (_n,d) _ts) = d

-- | Introduce 'Doc.newline' according to the 'HelpNode's
-- put next to each others.
runHelpNodes ::
 Monoid d =>
 Docable d =>
 HelpInh d ->
 Tree.Forest (HelpNode, d) -> d
runHelpNodes _inh [] = mempty
runHelpNodes inh ( t0@(Tree.Node _ t0s)
                 : t1@(Tree.Node (HelpNode_Command, _) _) : ts ) =
	runHelpNode t0 <>
	Doc.newline <>
	(if null t0s || not (helpInh_full inh) then mempty else Doc.newline) <>
	runHelpNodes inh (t1:ts)
runHelpNodes inh ( t0@(Tree.Node (HelpNode_Tag, _) _)
                 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
	runHelpNode t0 <>
	Doc.newline <>
	runHelpNodes inh (t1:ts)
runHelpNodes inh ( t0@(Tree.Node (HelpNode_Rule, _) t0s)
                 : t1@(Tree.Node (_, _) _) : ts ) =
	runHelpNode t0 <>
	Doc.newline <>
	(if null t0s || not (helpInh_full inh) then mempty else Doc.newline) <>
	runHelpNodes inh (t1:ts)
runHelpNodes inh ( t0@(Tree.Node (HelpNode_Message, _) _)
                 : t1 : ts ) =
	runHelpNode t0 <>
	Doc.newline <>
	Doc.newline <>
	runHelpNodes inh (t1:ts)
runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
	runHelpNode t0 <>
	Doc.newline <>
	Doc.newline <>
	runHelpNodes inh (t1:ts)
runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
	runHelpNode t0 <>
	Doc.newline <>
	Doc.newline <>
	runHelpNodes inh (t1:ts)
runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Rule, _) _) : ts ) =
	runHelpNode t0 <>
	Doc.newline <>
	runHelpNodes inh (t1:ts)
runHelpNodes inh (t:ts) = runHelpNode t <> runHelpNodes inh ts

instance Semigroup d => Semigroup (Help d f k) where
	Help hx px <> Help hy py = Help (hx<>hy) (px<>py)
instance Monoid d => Monoid (Help d f k) 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 . runHelp
instance Docable d => Functor (Help d f) where
	f <$$> Help h s = Help h (f<$$>s)
-}
instance Docable d => App (Help d) where
	Help hf pf <.> Help hx px = Help (hf<>hx) (pf<.>px)
instance Docable d => Alt (Help d) where
	Help hl pl <!> Help hr pr = Help (hl<>hr) (pl<!>pr)
	Help hl pl `alt` Help hr pr = Help (hl<>hr) (pl`alt`pr)
	opt (Help h s) = Help h (opt s)
	{-
	try (Help h s) = Help h (try s)
	choice hs = Help (mconcat $ help_result <$> hs) (choice (help_schema <$> hs))
	option a (Help h s) = Help h (option a s)
	-}
instance Docable d => Permutable (Help d) where
	type Permutation (Help d) = HelpPerm d
	runPermutation (HelpPerm h s) = Help h $ runPermutation s
	toPermutation   (Help h s) = HelpPerm h $ toPermutation s
	toPermDefault a (Help h s) = HelpPerm h $ toPermDefault a s
instance Pro (Help d) where
	dimap a2b b2a (Help h s) = Help h $ dimap a2b b2a s
instance Docable d => AltApp (Help d) where
	many0 (Help h s) = Help h (many0 s)
	many1 (Help h s) = Help h (many1 s)
instance Docable d => CLI_Var (Help d) where
	type VarConstraint (Help d) a = ()
	var' n  = Help mempty (var' n)
	just a  = Help mempty (just a)
	nothing = Help mempty nothing
instance Docable d => CLI_Env (Help d) where
	type EnvConstraint (Help d) a = ()
	env' n =
		Help (\inh ->
			let ts =
				if helpInh_full inh
				then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
				else [] in
			let d =
				Doc.breakfill (helpInh_tag_indent inh)
				 (Doc.bold (Doc.green (Doc.from (Doc.Word n)))
					<> Doc.space)
				<> (if null ts then mempty else Doc.space)
				<> Doc.align (runHelpNodes inh ts)
				in
			[ Tree.Node (HelpNode_Env, d) ts ]
		 ) schema
		where schema = env' n
instance Docable d => CLI_Command (Help d) where
	-- type CommandConstraint (Help d) a = ()
	command n (Help h s) =
		Help (\inh ->
			let ts =
				(if helpInh_full inh
				then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
				else []) <>
				h inh
				 { helpInh_message      = Nothing
				 , helpInh_command_rule = True
				 } in
			let d =
				(if not (null n) && helpInh_command_rule inh
				then ref<>Doc.space<>"::= " else mempty)
				<> Schema.runSchema schema (helpInh_schema inh)
				<> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
				<> Doc.incrIndent (helpInh_command_indent inh)
				 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
			in
			[ Tree.Node (HelpNode_Command, d) ts ]
		 ) schema
		where
		schema = command n s
		ref =
			Doc.bold $
			Doc.angles $
			Doc.magentaer $
			Doc.from (Doc.Word n)
instance Docable d => CLI_Tag (Help d) where
	type TagConstraint (Help d) a = ()
	tagged n (Help h s) =
		Help (\inh ->
			if (isJust (helpInh_message inh)
			|| helpInh_helpless_options inh)
			&& helpInh_full inh
			then
				let ts =
					maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) <>
					h inh{helpInh_message=Nothing} in
				let d =
					Doc.breakfill (helpInh_tag_indent inh)
					 (Doc.bold $
						Schema.runSchema schema (helpInh_schema inh)
						<> Doc.space) -- FIXME: space is not always needed
					<> (if null ts then mempty else Doc.space)
					<> Doc.align (runHelpNodes inh ts)
					in
				[ Tree.Node (HelpNode_Tag, d) ts ]
			else []
		 ) schema
		where schema = tagged n s
	endOpts = Help mempty endOpts
instance Docable d => CLI_Help (Help d) where
	type HelpConstraint (Help d) d' = d ~ d'
	help msg (Help h s) = Help
	 (\inh -> h inh{helpInh_message=Just msg})
	 (help msg s)
	program n (Help h s) =
		Help (\inh ->
			let ts =
				(if helpInh_full inh
				then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
				else []) <>
				h inh
				 { helpInh_message      = Nothing
				 , helpInh_command_rule = True
				 } in
			let d =
				Schema.runSchema schema (helpInh_schema inh)
				<> (if null ts {-|| not (helpInh_full inh)-} then mempty else Doc.newline)
				<> Doc.incrIndent
				 (helpInh_command_indent inh)
				 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
			in
			[ Tree.Node (HelpNode_Rule, d) ts ]
		 ) schema
		where
		schema = program n s
	rule n (Help h s) =
		Help (\inh ->
			let ts =
				(if helpInh_full inh
				then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
				else []) <>
				h inh
				 { helpInh_message      = Nothing
				 , helpInh_command_rule = True
				 } in
			let d =
				ref<>Doc.space<>"::= "
				<> Schema.runSchema schema (helpInh_schema inh)
				<> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
				<> Doc.incrIndent
				 (helpInh_command_indent inh)
				 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
			in
			[ Tree.Node (HelpNode_Rule, d) ts ]
		 ) schema
		where
		schema = rule n s
		ref =
			Doc.bold $
			Doc.angles $
			Doc.magentaer $
			Doc.from (Doc.Word n)
type HelpResponseArgs = SchemaResponseArgs
instance Docable d => CLI_Response (Help d) where
	type ResponseConstraint (Help d) a = () -- ResponseConstraint (Schema d)
	type ResponseArgs (Help d) a = SchemaResponseArgs a -- ResponseArgs (Schema d) a
	type Response (Help d) = () -- Response (Schema d)
	response' ::
	 forall a repr.
	 repr ~ Help d =>
	 ResponseConstraint repr a =>
	 repr (ResponseArgs repr a)
	      (Response repr)
	response' = Help mempty $ response' @(Schema d) @a

{-
instance Docable d => Sym_AltApp (Help d) where
	many (Help h s) = Help h (many s)
	some (Help h s) = Help h (many s)
-}

-- * Type 'HelpPerm'
data HelpPerm d k a
 =   HelpPerm (HelpInh d -> HelpResult d)
              (SchemaPerm d k a)
instance Functor (HelpPerm d k) where
	f`fmap`HelpPerm h ps = HelpPerm h (f<$>ps)
instance Applicative (HelpPerm d k) where
	pure a = HelpPerm mempty (pure a)
	HelpPerm fh f <*> HelpPerm xh x =
		HelpPerm (fh<>xh) (f<*>x)
instance Docable d => CLI_Help (HelpPerm d) where
	type HelpConstraint (HelpPerm d) d' = d ~ d'
	help msg (HelpPerm h s) = HelpPerm
	 (\inh -> h inh{helpInh_message=Just msg})
	 (help msg s)
	program n (HelpPerm h s) = HelpPerm
	 (help_result $ program n (Help h (runPermutation s)))
	 (rule n s)
	rule n (HelpPerm h s) = HelpPerm
	 (help_result $ rule n (Help h (runPermutation s)))
	 (rule n s)