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