{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
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
data Layout d f k = Layout
{ layoutSchema :: Schema d f k
, layoutHelp :: [d]
, 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
newtype LayoutInh d = LayoutInh
{ layoutInh_message :: [d]
}
defLayoutInh :: LayoutInh d
defLayoutInh = LayoutInh
{ layoutInh_message = []
}
type LayoutState d = Diff (Tree.Forest (LayoutNode d))
type Diff a = Maybe a -> Maybe a
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) 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
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
data LayoutNode d
= LayoutNode_Help [d] d
| LayoutNode_Tags [([d], d)]
deriving (Show)