Layout.hs

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

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.
 , unLayout     :: 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

-- ** 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 <$>)

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_Tags ds -> (<$> ds) $ \(mh,sch) ->
		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_Help mh sch ->
		[ Doc.align $
			case mh of
			 [] -> Doc.whiter sch
			 _ | not full -> Doc.whiter sch
			 h -> Doc.whiter sch <> Doc.newline <> Doc.justify (Doc.catV h)
		]
	) <> 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_Help (lh<>rh) $ docSchema sch) 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_Help [] mempty{-FIXME-}) ts]
		xm inh
		where sch = opt xs
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_Help (layoutInh_message inh)
				 $ Doc.magentaer $ docSchema $ command n nothing
				 ) ts
			]
		xm inh
		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
	tagged n (Layout xs xh xm) = Layout (tagged n xs) xh $ \inh -> do
		modify' $ \k -> \case
		 Nothing -> k Nothing
		 Just ts -> k $ Just
			[ Tree.Node
			 ( LayoutNode_Tags [
				 ( layoutInh_message inh
				 , docSchema (tagged n nothing)
				 )
				]
			 ) ts
			]
		xm inh
	endOpts = Layout sch [] $ \_inh -> do
		modify' $ \k -> \case
		 Nothing -> k Nothing
		 Just ts -> k $ Just [Tree.Node (LayoutNode_Help [] $ 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_Help [] $ docSchema sch) ts]
		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_Help [] $ 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 'LayoutPerm'
data LayoutPerm d k a = LayoutPerm
 { layoutPerm_help :: [d]
 , layoutPerm_elem :: LayoutInh d -> [([d], 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, 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 (LayoutNode_Tags (ps inh)) ts]
		where
		sch = runPermutation $ SchemaPerm id []
	toPermutation (Layout xl xh _xm) = LayoutPerm [] $ \inh ->
		[(layoutInh_message inh <> xh, docSchema xl)]
	toPermDefault _a (Layout xl xh _xm) = LayoutPerm [] $ \inh ->
		[(layoutInh_message inh <> xh, Doc.brackets (docSchema xl))]
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_Help [d] d
 |   LayoutNode_Tags [([d], d)]
 deriving (Show)