{-# LANGUAGE OverloadedStrings #-}
module Language.Symantic.CLI.Write.Help where

import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Function (($))
import Data.Functor ((<$>))
import Data.Functor.Compose (Compose(..))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import qualified Language.Symantic.Document.Term as Doc

import Language.Symantic.CLI.Sym
import qualified Language.Symantic.CLI.Write.Plain as Plain

-- * Type 'Reader'
data Reader d
 =   Reader
 {   reader_help           :: Maybe d -- ^ Current help.
 -- ,   reader_define         :: Bool    -- ^ Whether to print a definition, or not.
 -- ,   reader_or             :: 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_define         = True
 -- , reader_or             = Doc.stringH " | "
 , reader_command_indent = 2
 , reader_option_indent  = 20
 , reader_plain          = Plain.defReader
 , reader_option_empty   = False
 }

-- * Type 'Result'
type Result d = [d]

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

-- * 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.Textable d => Help d e t a -> d
runHelp h = Doc.catV $ help_result h defReader

textHelp :: Plain.Doc d => Reader d -> Help d e t a -> d
textHelp def (Help h _p) =
	let res = h def in
	Doc.catV res

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 $
			Doc.breakableFill 4 (ref<>" ::= "<> Plain.runPlain p' (reader_plain ro)) <>
			Doc.align (Doc.catV (h ro{reader_help=Nothing}))
		 ) p'
		where
		p' = rule n p
		ref = Doc.bold $ Doc.between (Doc.charH '<') (Doc.charH '>') (Doc.textH n)
instance Plain.Doc d => Sym_Option (Help d) where
	var n (Help _h p) = Help mempty (var n p)
	string = Help mempty string
	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 $ Doc.bold (Plain.runPlain p' (reader_plain ro))
				else []
			 Just msg ->
				pure $
				Doc.breakableFill (reader_option_indent ro)
				 (Doc.bold $ Plain.runPlain p' (reader_plain ro) <>
					Doc.spaces 2) <>
				Doc.align 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 ->
			[ Plain.runPlain p' (reader_plain ro) <>
				(case reader_help ro of
				 Nothing -> Doc.empty
				 Just msg ->
					Doc.incrIndent (reader_command_indent ro) $
					Doc.newline <> msg)
			, Doc.catV $ h ro{reader_help=Nothing}
			]
		 ) p'
		where p' = main n p
	command n (Help h p) =
		Help (\ro ->
			pure $
			let d = ref<>" ::= "<>Plain.runPlain p' (reader_plain ro) in
			case h ro{reader_help=Nothing} of
			 [] -> d
			 hs ->
				Doc.breakableFill 4 d <>
				Doc.align (Doc.catV hs)
		 ) p'
		where
		p' = command n p
		ref = Doc.bold $ Doc.between (Doc.charH '<') (Doc.charH '>') (Doc.stringH n)
instance Plain.Doc d => Sym_Exit (Help d) where
	exit e = Help mempty $ exit e