{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
module Symantic.CLI.Layout where
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
data Layout d f k = Layout
{ layoutSchema :: Schema d f k
, layoutHelp :: [d]
, 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
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 <$>)
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.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) []) 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
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
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
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 => 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_Single d [d]
| LayoutNode_List [d] [(d, [d])]
| LayoutNode_Forest d [d] (Tree.Forest (LayoutNode d))
deriving (Show)