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