Layout.hs

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