{-# 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 :: SchemaDoc d => HelpInh d -> Help d f k -> d
runHelp def (Help h _p) = runHelpNodes def (h def) <> Doc.newline

docHelp :: SchemaDoc d => Doc.Indentable d => SchemaDoc 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 :: SchemaDoc 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 :: SchemaDoc 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 :: SchemaDoc 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 SchemaDoc d => Functor (Help d f) where
	f <$$> Help h s = Help h (f<$$>s)
-}
instance SchemaDoc d => App (Help d) where
        Help hf pf <.> Help hx px = Help (hf<>hx) (pf<.>px)
instance SchemaDoc 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 SchemaDoc 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 SchemaDoc d => AltApp (Help d) where
        many0 (Help h s) = Help h (many0 s)
        many1 (Help h s) = Help h (many1 s)
instance SchemaDoc d => CLI_Var (Help d) where
        type VarConstraint (Help d) a = ()
        var' n  = Help mempty (var' n)
instance SchemaDoc d => CLI_Constant (Help d) where
        constant n a = Help mempty (constant n a)
        just a       = Help mempty (just a)
        nothing      = Help mempty nothing
instance SchemaDoc 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.fillOrBreak (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 SchemaDoc 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 =
                                let ind = helpInh_command_indent inh in
                                (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 (Doc.spaces ind) ind
                                 ((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 SchemaDoc d => CLI_Tag (Help d) where
        type TagConstraint (Help d) a = ()
        tag 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.fillOrBreak (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 = tag n s
        endOpts = Help mempty endOpts
instance SchemaDoc 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 =
                                let ind = helpInh_command_indent inh in
                                Schema.runSchema schema (helpInh_schema inh)
                                <> (if null ts {- \|| not (helpInh_full inh)-} then mempty else Doc.newline)
                                <> Doc.incrIndent (Doc.spaces ind) ind
                                 ((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 =
                                let ind = helpInh_command_indent inh in
                                ref<>Doc.space<>"::= "
                                <> Schema.runSchema schema (helpInh_schema inh)
                                <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
                                <> Doc.incrIndent (Doc.spaces ind) ind
                                 ((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 SchemaDoc 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 SchemaDoc 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 SchemaDoc 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)