{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
module Symantic.CLI.Layout where

-- TODO: remove when debugging is done
import Prelude (Char, String, putStr)
import Symantic.Document (runPlain)
import Data.Maybe (fromJust)
import Data.Text (Text)

import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..), (>>))
import Control.Monad.Trans.State.Strict
import Data.Bool
import Data.Function (($), (.), id)
import Data.Functor (Functor(..), (<$>))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Tree (Tree(..), Forest)
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Tree as Tree
import qualified Symantic.Document as Doc

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

-- * Type 'Layout'
data Layout d f k = Layout
 { layoutSchema :: Schema d f k
   -- ^ Synthetized (bottom-up) 'Schema'.
   -- Useful for complex grammar rules or 'alt'ernatives associated
   -- to the left of a 'response'.
 , layoutHelp   :: [d]
   -- ^ Synthetized (bottom-up) 'help'.
   -- Useful in 'LayoutPerm' to merge nested 'help'
   -- and nesting 'help' of the permutation.
 , layoutMonad  :: LayoutInh d -> State (LayoutState d) ()
 }

runLayout :: LayoutDoc d => Bool -> Layout d f k -> d
runLayout full (Layout _s _h l) =
        runLayoutForest full $
        fromMaybe [] $
        ($ (Just [])) $
        (`execState`id) $
        l defLayoutInh

coerceLayout :: Layout d f k -> Layout d f' k'
coerceLayout (Layout s h l) = Layout (coerceSchema s) h l

instance Semigroup d => Semigroup (Layout d f k) where
        Layout xs xh xm <> Layout ys yh ym =
                Layout (xs<>ys) (xh<>yh) $ \inh ->
                        xm inh >> ym inh

-- ** Type 'LayoutInh'
newtype LayoutInh d = LayoutInh
 { layoutInh_message :: {-!-}[d]
 }

defLayoutInh :: LayoutInh d
defLayoutInh = LayoutInh
 { layoutInh_message = []
 }

-- ** Type 'LayoutState'
type LayoutState d = Diff (Tree.Forest (LayoutNode d))

-- ** Type 'Diff'
-- | A continuation-passing-style constructor,
-- (each constructor prepending something),
-- augmented with 'Maybe' to change the prepending
-- according to what the following parts are.
-- Used in '<!>' and 'alt' to know if branches
-- lead to at least one route (ie. contain at least one 'response').
type Diff a = Maybe a -> Maybe a

-- ** Type 'LayoutDoc'
type LayoutDoc d =
 ( SchemaDoc d
 , Doc.Justifiable d
 )

runLayoutForest :: LayoutDoc d => Bool -> Forest (LayoutNode d) -> d
runLayoutForest full = (<> Doc.newline) . Doc.catV . (runLayoutTree full <$>)

runLayoutForest' :: LayoutDoc d => Bool -> Forest (LayoutNode d) -> d
runLayoutForest' full = Doc.catV . (runLayoutTree full <$>)

runLayoutTree :: LayoutDoc d => Bool -> Tree (LayoutNode d) -> d
runLayoutTree full =
        -- Doc.setIndent mempty 0 .
        Doc.catV . runLayoutNode full

runLayoutNode :: LayoutDoc d => Bool -> Tree (LayoutNode d) -> [d]
runLayoutNode full (Tree.Node n ts0) =
        (case n of
         LayoutNode_Single sch mh ->
                [ Doc.align $
                        case mh of
                         [] -> Doc.whiter sch
                         _ | not full -> Doc.whiter sch
                         h -> Doc.whiter sch <> Doc.newline <> Doc.justify (Doc.catV h)
                ]
         LayoutNode_List ns ds ->
                ((if full then ns else []) <>) $
                (<$> ds) $ \(sch, mh) ->
                        case mh of
                         [] ->
                                Doc.whiter sch
                         _ | not full -> Doc.whiter sch
                         h ->
                                Doc.fillOrBreak 15 (Doc.whiter sch) <>
                                        Doc.space <> Doc.align (Doc.justify (Doc.catV h))
         LayoutNode_Forest sch ds ts ->
                [Doc.whiter sch] <>
                (if List.null ds || not full then [] else [Doc.catV ds]) <>
                (if List.null ts then [] else [runLayoutForest' full ts])
        ) <> docSubTrees ts0
        where
        docSubTrees [] = []
        docSubTrees [t] =
                -- "|" :
                shift (Doc.blacker "└──"<>Doc.space)
                      (Doc.spaces 4)
                      (Doc.incrIndent (Doc.spaces 4) 4 <$> runLayoutNode full t)
        docSubTrees (t:ts) =
                -- "|" :
                shift (Doc.blacker "├──"<>Doc.space)
                      (Doc.blacker "│"<>Doc.spaces 3)
                      (Doc.incrIndent (Doc.blacker "│"<>Doc.spaces 3) 4 <$> runLayoutNode full t)
                <> docSubTrees ts

        shift d ds =
                List.zipWith (<>)
                 (d : List.repeat ds)

instance LayoutDoc d => App (Layout d) where
        Layout xs xh xm <.> Layout ys yh ym =
                Layout (xs<.>ys) (xh<>yh) $ \inh ->
                        xm inh >> ym inh
instance LayoutDoc d => Alt (Layout d) where
        Layout ls lh lm <!> Layout rs rh rm = Layout sch [] $ \inh -> do
                k <- get

                put id
                lm inh
                lk <- get

                put id
                rm inh
                rk <- get

                put $
                        case (lk Nothing, rk Nothing) of
                         (Nothing, Nothing) -> \case
                                 Nothing -> k Nothing
                                 Just ts -> k $ Just [Tree.Node (LayoutNode_Single (docSchema sch) (lh<>rh)) ts]
                         (Just lt, Just rt) -> \case
                                 Nothing -> k $ Just (lt<>rt)
                                 Just ts -> k $ Just (lt<>rt<>ts)
                         (Just lt, Nothing) -> \case
                                 Nothing -> k $ Just lt
                                 Just ts -> k $ Just (lt<>ts)
                         (Nothing, Just rt) -> \case
                                 Nothing -> k $ Just rt
                                 Just ts -> k $ Just (rt<>ts)
                where sch = ls<!>rs
        Layout ls lh lm `alt` Layout rs rh rm =
                (Layout ls lh lm <!> Layout rs rh rm)
                 {layoutSchema=sch}
                where sch = ls`alt`rs
        opt (Layout xs xh xm) = Layout sch xh $ \inh -> do
                modify' $ \k -> \case
                 Nothing -> k Nothing
                 Just _ts -> k $ Just [Tree.Node (LayoutNode_Single (docSchema sch) []{-FIXME-}) mempty]
                xm inh
                where sch = opt xs
instance LayoutDoc d => AltApp (Layout d) where
        many0 (Layout xs xh xm) = Layout sch xh $ \inh -> do
                modify' $ \k -> \case
                 Nothing -> k Nothing
                 Just ts -> k $ Just [Tree.Node nod mempty]
                        where nod = LayoutNode_Forest (docSchema sch) (layoutInh_message inh) ts
                xm inh{layoutInh_message=[]}
                where sch = many0 xs
        many1 (Layout xs xh xm) = Layout sch xh $ \inh -> do
                modify' $ \k -> \case
                 Nothing -> k Nothing
                 Just ts -> k $ Just [Tree.Node nod mempty]
                        where nod = LayoutNode_Forest (docSchema sch) (layoutInh_message inh) ts
                xm inh{layoutInh_message=[]}
                where sch = many1 xs
instance (LayoutDoc d, Doc.Justifiable d) => Permutable (Layout d) where
        type Permutation (Layout d) = LayoutPerm d
        runPermutation (LayoutPerm h ps) = Layout sch h $ \inh -> do
                modify' $ \k -> \case
                 Nothing -> k Nothing
                 Just ts -> k $ Just [Tree.Node nod ts]
                        where nod = LayoutNode_List (layoutInh_message inh) (ps inh{layoutInh_message=[]})
                where sch = runPermutation $ SchemaPerm id []
        toPermutation (Layout xl xh _xm) = LayoutPerm [] $ \inh ->
                [(docSchema xl, layoutInh_message inh <> xh)]
        toPermDefault _a (Layout xl xh _xm) = LayoutPerm [] $ \inh ->
                [(Doc.brackets (docSchema xl), layoutInh_message inh <> xh)]
instance (LayoutDoc d, Doc.Justifiable d) => Sequenceable (Layout d) where
        type Sequence (Layout d) = LayoutSeq d
        runSequence (LayoutSeq s h m) = Layout (runSequence s) h m
        toSequence (Layout s h m) = LayoutSeq (toSequence s) h m
        {-
	runSequence (LayoutSeq s h ps) = Layout sch h $ \inh -> do
		modify' $ \k -> \case
		 Nothing -> k Nothing
		 Just ts -> k $ Just [Tree.Node nod mempty]
			-- where nod = LayoutNode_List (layoutInh_message inh) (ps inh{layoutInh_message=[]})
			where
			nod = LayoutNode_Forest mempty {-(docSchema sch)-}
			 (layoutInh_message inh) (gs <> ts)
			gs = (<$> ps inh{layoutInh_message=[]}) $ \(d,ds) ->
				Tree.Node (LayoutNode_Single d ds) mempty
			 
		where sch = runSequence s
	toSequence (Layout s h _m) = LayoutSeq (toSequence s) h $ \inh ->
		[(docSchema s, layoutInh_message inh <> h)]
	-}
instance Pro (Layout d) where
        dimap a2b b2a (Layout s h l) = Layout (dimap a2b b2a s) h l
instance (LayoutDoc d, Doc.From Name d) => CLI_Command (Layout d) where
        command n (Layout xl xh xm) = Layout sch xh $ \inh -> do
                modify' $ \k -> \case
                 Nothing -> k Nothing
                 Just ts -> k $ Just
                        [ Tree.Node
                                 ( LayoutNode_Single
                                         (Doc.magentaer $ docSchema $ command n nothing)
                                         (layoutInh_message inh)
                                 ) ts
                        ]
                xm inh{layoutInh_message=[]}
                where sch = command n xl
instance (LayoutDoc d, Doc.Justifiable d) => CLI_Tag (Layout d) where
        type TagConstraint (Layout d) a = TagConstraint (Schema d) a
        tag n (Layout xs xh xm) = Layout (tag n xs) xh $ \inh -> do
                modify' $ \k -> \case
                 Nothing -> k Nothing
                 Just ts -> k $ Just
                        [ Tree.Node
                         ( LayoutNode_List [] [
                                 ( docSchema (tag n nothing)
                                 , layoutInh_message inh
                                 )
                                ]
                         ) ts
                        ]
                xm inh{layoutInh_message=[]}
        endOpts = Layout sch [] $ \_inh -> do
                modify' $ \k -> \case
                 Nothing -> k Nothing
                 Just ts -> k $ Just [Tree.Node (LayoutNode_Single (docSchema sch) []) ts]
                where sch = endOpts
instance LayoutDoc d => CLI_Var (Layout d) where
        type VarConstraint (Layout d) a = VarConstraint (Schema d) a
        var' n = Layout sch [] $ \inh -> do
                modify' $ \k -> \case
                 Nothing -> k Nothing
                 Just ts -> k $ Just [Tree.Node (LayoutNode_List [] h) ts]
                        where h | List.null (layoutInh_message inh) = []
                                | otherwise = [(docSchema sch, layoutInh_message inh)]
                where sch = var' n
instance LayoutDoc d => CLI_Constant (Layout d) where
        constant c a = Layout sch [] $ \inh -> do
                modify' $ \k -> \case
                 Nothing -> k Nothing
                 Just ts -> k $ Just [Tree.Node (LayoutNode_List [] h) ts]
                        where h | List.null (layoutInh_message inh) = []
                                | otherwise = [(docSchema sch, layoutInh_message inh)]
                where sch = constant c a
        just a  = Layout (just a) [] $ \_inh -> pure ()
        nothing = Layout nothing  [] $ \_inh -> pure ()
instance LayoutDoc d => CLI_Env (Layout d) where
        type EnvConstraint (Layout d) a = EnvConstraint (Schema d) a
        env' n = Layout (env' n) [] $ \_inh -> pure ()
instance LayoutDoc d => CLI_Help (Layout d) where
        type HelpConstraint (Layout d) d' = HelpConstraint (Schema d) d'
        help msg (Layout s _h m) = Layout
         (help msg s) [msg]
         (\inh -> m inh{layoutInh_message=[msg]})
        program n (Layout xl xh xm) = Layout sch xh $ \inh -> do
                modify' $ \k -> \case
                 Nothing -> k Nothing
                 Just ts -> k $ Just
                         [ Tree.Node
                                 (LayoutNode_Single (Doc.magentaer $ docSchema $ program n nothing) [])
                                 ts
                         ]
                xm inh
                where sch = program n xl
        rule _n = id
instance LayoutDoc d => CLI_Response (Layout d) where
        type ResponseConstraint (Layout d) a = ResponseConstraint (Schema d) a
        type ResponseArgs (Layout d) a = ResponseArgs (Schema d) a
        type Response (Layout d) = Response (Schema d)
        response' = Layout response' [] $ \_inh -> do
                modify' $ \k -> \case
                 Nothing -> k $ Just []
                 Just ts -> k $ Just ts

-- ** Type 'LayoutSeq'
data LayoutSeq d k a = LayoutSeq
 {   layoutSeq_schema :: SchemaSeq d k a
 ,   layoutSeq_help  :: [d]
 ,   layoutSeq_monad :: LayoutInh d -> State (LayoutState d) ()
 }
instance Functor (LayoutSeq d k) where
        f`fmap`LayoutSeq s h m = LayoutSeq (f<$>s) h $ \inh -> m inh
instance Applicative (LayoutSeq d k) where
        pure a = LayoutSeq (pure a) [] $ \_inh -> return ()
        LayoutSeq fs fh f <*> LayoutSeq xs xh x =
                LayoutSeq (fs<*>xs) (fh<>xh) $ \inh -> f inh >> x inh
instance LayoutDoc d => CLI_Help (LayoutSeq d) where
        type HelpConstraint (LayoutSeq d) d' = HelpConstraint (SchemaSeq d) d'
        help msg (LayoutSeq s _h m) = LayoutSeq (help msg s) [msg] $ \inh ->
                m inh{layoutInh_message=[msg]}
        program n (LayoutSeq s h m) = LayoutSeq (program n s) h m
        rule    n (LayoutSeq s h m) = LayoutSeq (rule n s) h m

-- ** Type 'LayoutPerm'
data LayoutPerm d k a = LayoutPerm
 {   layoutPerm_help :: [d]
 ,   layoutPerm_elem :: LayoutInh d -> [(d, {-help-}[d])]
 }
instance Functor (LayoutPerm d k) where
        _f`fmap`LayoutPerm h ps = LayoutPerm h $ \inh -> ps inh
instance Applicative (LayoutPerm d k) where
        pure _a = LayoutPerm [] $ \_inh -> []
        LayoutPerm _fh f <*> LayoutPerm _xh x =
                LayoutPerm [] $ \inh -> f inh <> x inh
instance LayoutDoc d => CLI_Help (LayoutPerm d) where
        type HelpConstraint (LayoutPerm d) d' = HelpConstraint (SchemaPerm d) d'
        help msg (LayoutPerm _h m) = LayoutPerm [msg] $ \inh ->
                m inh{layoutInh_message=[msg]}
        program _n = id
        rule    _n = id

-- ** Type 'LayoutNode'
data LayoutNode d
 =   LayoutNode_Single d {-help-}[d]
 |   LayoutNode_List [d] [(d, {-help-}[d])]
 |   LayoutNode_Forest d [d] (Tree.Forest (LayoutNode d))
 deriving (Show)

{-
h0 = putStr $ runPlain $ runLayout True $
	help "TOTO help" $ command "toto" $
		many0 $ runSequence $ ((,)
		 <$> toSequence (help "Question help" $ var @String "Question")
		 <*> toSequence (help "Answer help" $ tag (TagLong "ans") (var @Char "Answer"))
		 )

h1 = putStr $ runPlain $ runLayout True $
	"This command reads and checks."
	`help`
	command "election" $
		api_quests <.>
		response @()
	where
	api_quests =
		("Some questions."::Doc.Plain String)
		`help`
		many0 (runSequence $ (,)
		 <$> toSequence api_quest
		 <*> toSequence api_answers
		 )
	api_quest =
		("A question."::Doc.Plain String)
		`help`
		var @String "QUESTION"
	api_answers =
		("Some answers."::Doc.Plain String)
		`help`
		many0 $ help ("An answer"::Doc.Plain String) (var @String "ANSWER")

h2 = putStr $ runPlain $ runLayout True $
	"This command reads and checks."
	`help`
	command "election" $
		api_quests <.>
		response @()
	where
	api_quests =
		("Some questions."::Doc.Plain String)
		`help`
		many0 api_quest
	api_quest =
		("A question."::Doc.Plain String)
		`help`
		var @String "QUESTION"

h3 = putStr $ runPlain $ runLayout True $
	"This command reads and checks."
	`help`
	command "election" $
		api_quests <.>
		response @()
	where
	api_quests =
		("Some questions."::Doc.Plain String)
		`help`
		many0 (runSequence ((,) <$> toSequence api_quest <*> toSequence api_answers))
		-- many0 api_answers
	api_quest =
		("A question."::Doc.Plain String)
		`help`
		var @String "QUESTION"
	api_answers =
		("Some answers."::Doc.Plain String)
		`help`
		many0 $ help ("An answer"::Doc.Plain String) (var @String "ANSWER")

data AdminElection_Params = AdminElection_Params
 {   adminElection_name         :: Text
 ,   adminElection_description  :: Text
 ,   adminElection_uuid         :: Maybe Text
 ,   adminElection_grades       :: [Text]
 ,   adminElection_defaultGrade :: Maybe Text
 }

helpD d = help (d::Doc.Plain String)
infixr 0 `helpD`

h4 = putStr $ runPlain $ runLayout True $
	"This command reads and checks the trustees' public keys"
	`helpD`
	command "election" $
		rule "PARAMS"
		 (AdminElection_Params
			 <$> api_param_name
			 <*> api_param_description
			 <*> api_option_uuid
			 <*> api_param_grades
			 <*> api_param_defaultGrade
		 )
		<?> api_quests
		<.> response @(Maybe ())
	where
	api_param_name =
		"Name of the election."
		`helpD`
		requiredTag (TagLong "name") $ var "STRING"
	api_param_description =
		"Description of the election."
		`helpD`
		defaultTag (TagLong "description") "" $ var "STRING"
	api_option_uuid =
		"UUID of the election."
		`helpD`
		optionalTag (TagLong "uuid") $ var "UUID"
	api_quests =
		"Some questions."
		`helpD`
		many1 (var @Text "STRING")
	api_param_grades = toPermutation $
		many1 $
			"The grades to evaluate the choices, from the lowest to the highest."
			`helpD`
			tag (TagLong "grade") $
				var @Text "STRING"
	api_param_defaultGrade = toPermDefault Nothing $
		"The grade used when no grade is given by a voter.\n"<>
		"Defaults to the lowest grade."
		`helpD`
			tag (TagLong "default-grade") $
				dimap Just fromJust $
					var @Text "STRING"
-}