diff --git a/Symantic/CLI.hs b/Symantic/CLI.hs --- a/Symantic/CLI.hs +++ b/Symantic/CLI.hs @@ -3,8 +3,10 @@ , module Symantic.CLI.Parser , module Symantic.CLI.Schema , module Symantic.CLI.Help + , module Symantic.CLI.Layout ) where import Symantic.CLI.API import Symantic.CLI.Parser import Symantic.CLI.Schema import Symantic.CLI.Help +import Symantic.CLI.Layout diff --git a/Symantic/CLI/Help.hs b/Symantic/CLI/Help.hs --- a/Symantic/CLI/Help.hs +++ b/Symantic/CLI/Help.hs @@ -27,10 +27,10 @@ -- ^ The 'Schema' of the current symantic. } -runHelp :: Docable d => HelpInh d -> Help d f k -> d +runHelp :: SchemaDoc d => HelpInh d -> Help d f k -> d runHelp def (Help h _p) = runHelpNodes def (h def) <> Doc.newline -docHelp :: Docable d => Doc.Indentable d => Docable d => Help d f k -> d +docHelp :: SchemaDoc d => Doc.Indentable d => SchemaDoc d => Help d f k -> d docHelp = runHelp defHelpInh coerceHelp :: Help d f k -> Help d f' k' @@ -59,7 +59,7 @@ -- ^ Whether to print full help. } -defHelpInh :: Docable d => HelpInh d +defHelpInh :: SchemaDoc d => HelpInh d defHelpInh = HelpInh { helpInh_message = Nothing , helpInh_command_indent = 2 @@ -85,19 +85,12 @@ | HelpNode_Env deriving Show -runHelpNode :: - Monoid d => - Docable d => - Tree (HelpNode, d) -> d +runHelpNode :: SchemaDoc d => Tree (HelpNode, d) -> d runHelpNode (Tree.Node (_n,d) _ts) = d -- | Introduce 'Doc.newline' according to the 'HelpNode's -- put next to each others. -runHelpNodes :: - Monoid d => - Docable d => - HelpInh d -> - Tree.Forest (HelpNode, d) -> d +runHelpNodes :: SchemaDoc d => HelpInh d -> Tree.Forest (HelpNode, d) -> d runHelpNodes _inh [] = mempty runHelpNodes inh ( t0@(Tree.Node _ t0s) : t1@(Tree.Node (HelpNode_Command, _) _) : ts ) = @@ -149,12 +142,12 @@ fromString s = Help $ \_ro -> Just $ fromString s instance Show (Help Doc.Term e s a) where show = TL.unpack . Doc.textTerm . runHelp -instance Docable d => Functor (Help d f) where +instance SchemaDoc d => Functor (Help d f) where f <$$> Help h s = Help h (f<$$>s) -} -instance Docable d => App (Help d) where +instance SchemaDoc d => App (Help d) where Help hf pf <.> Help hx px = Help (hf<>hx) (pf<.>px) -instance Docable d => Alt (Help d) where +instance SchemaDoc d => Alt (Help d) where Help hl pl Help hr pr = Help (hl<>hr) (plpr) Help hl pl `alt` Help hr pr = Help (hl<>hr) (pl`alt`pr) opt (Help h s) = Help h (opt s) @@ -163,22 +156,22 @@ choice hs = Help (mconcat $ help_result <$> hs) (choice (help_schema <$> hs)) option a (Help h s) = Help h (option a s) -} -instance Docable d => Permutable (Help d) where +instance SchemaDoc d => Permutable (Help d) where type Permutation (Help d) = HelpPerm d runPermutation (HelpPerm h s) = Help h $ runPermutation s toPermutation (Help h s) = HelpPerm h $ toPermutation s toPermDefault a (Help h s) = HelpPerm h $ toPermDefault a s instance Pro (Help d) where dimap a2b b2a (Help h s) = Help h $ dimap a2b b2a s -instance Docable d => AltApp (Help d) where +instance SchemaDoc d => AltApp (Help d) where many0 (Help h s) = Help h (many0 s) many1 (Help h s) = Help h (many1 s) -instance Docable d => CLI_Var (Help d) where +instance SchemaDoc d => CLI_Var (Help d) where type VarConstraint (Help d) a = () var' n = Help mempty (var' n) just a = Help mempty (just a) nothing = Help mempty nothing -instance Docable d => CLI_Env (Help d) where +instance SchemaDoc d => CLI_Env (Help d) where type EnvConstraint (Help d) a = () env' n = Help (\inh -> @@ -187,7 +180,7 @@ then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) else [] in let d = - Doc.breakfill (helpInh_tag_indent inh) + Doc.fillOrBreak (helpInh_tag_indent inh) (Doc.bold (Doc.green (Doc.from (Doc.Word n))) <> Doc.space) <> (if null ts then mempty else Doc.space) @@ -196,7 +189,7 @@ [ Tree.Node (HelpNode_Env, d) ts ] ) schema where schema = env' n -instance Docable d => CLI_Command (Help d) where +instance SchemaDoc d => CLI_Command (Help d) where -- type CommandConstraint (Help d) a = () command n (Help h s) = Help (\inh -> @@ -209,11 +202,12 @@ , helpInh_command_rule = True } in let d = + let ind = helpInh_command_indent inh in (if not (null n) && helpInh_command_rule inh then ref<>Doc.space<>"::= " else mempty) <> Schema.runSchema schema (helpInh_schema inh) <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline) - <> Doc.incrIndent (helpInh_command_indent inh) + <> Doc.incrIndent (Doc.spaces ind) ind ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts) in [ Tree.Node (HelpNode_Command, d) ts ] @@ -225,7 +219,7 @@ Doc.angles $ Doc.magentaer $ Doc.from (Doc.Word n) -instance Docable d => CLI_Tag (Help d) where +instance SchemaDoc d => CLI_Tag (Help d) where type TagConstraint (Help d) a = () tagged n (Help h s) = Help (\inh -> @@ -237,7 +231,7 @@ maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) <> h inh{helpInh_message=Nothing} in let d = - Doc.breakfill (helpInh_tag_indent inh) + Doc.fillOrBreak (helpInh_tag_indent inh) (Doc.bold $ Schema.runSchema schema (helpInh_schema inh) <> Doc.space) -- FIXME: space is not always needed @@ -249,7 +243,7 @@ ) schema where schema = tagged n s endOpts = Help mempty endOpts -instance Docable d => CLI_Help (Help d) where +instance SchemaDoc d => CLI_Help (Help d) where type HelpConstraint (Help d) d' = d ~ d' help msg (Help h s) = Help (\inh -> h inh{helpInh_message=Just msg}) @@ -265,10 +259,10 @@ , helpInh_command_rule = True } in let d = + let ind = helpInh_command_indent inh in Schema.runSchema schema (helpInh_schema inh) <> (if null ts {-|| not (helpInh_full inh)-} then mempty else Doc.newline) - <> Doc.incrIndent - (helpInh_command_indent inh) + <> Doc.incrIndent (Doc.spaces ind) ind ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts) in [ Tree.Node (HelpNode_Rule, d) ts ] @@ -286,11 +280,11 @@ , helpInh_command_rule = True } in let d = + let ind = helpInh_command_indent inh in ref<>Doc.space<>"::= " <> Schema.runSchema schema (helpInh_schema inh) <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline) - <> Doc.incrIndent - (helpInh_command_indent inh) + <> Doc.incrIndent (Doc.spaces ind) ind ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts) in [ Tree.Node (HelpNode_Rule, d) ts ] @@ -303,7 +297,7 @@ Doc.magentaer $ Doc.from (Doc.Word n) type HelpResponseArgs = SchemaResponseArgs -instance Docable d => CLI_Response (Help d) where +instance SchemaDoc d => CLI_Response (Help d) where type ResponseConstraint (Help d) a = () -- ResponseConstraint (Schema d) type ResponseArgs (Help d) a = SchemaResponseArgs a -- ResponseArgs (Schema d) a type Response (Help d) = () -- Response (Schema d) @@ -316,7 +310,7 @@ response' = Help mempty $ response' @(Schema d) @a {- -instance Docable d => Sym_AltApp (Help d) where +instance SchemaDoc d => Sym_AltApp (Help d) where many (Help h s) = Help h (many s) some (Help h s) = Help h (many s) -} @@ -331,7 +325,7 @@ pure a = HelpPerm mempty (pure a) HelpPerm fh f <*> HelpPerm xh x = HelpPerm (fh<>xh) (f<*>x) -instance Docable d => CLI_Help (HelpPerm d) where +instance SchemaDoc d => CLI_Help (HelpPerm d) where type HelpConstraint (HelpPerm d) d' = d ~ d' help msg (HelpPerm h s) = HelpPerm (\inh -> h inh{helpInh_message=Just msg}) diff --git a/Symantic/CLI/Layout.hs b/Symantic/CLI/Layout.hs new file mode 100644 --- /dev/null +++ b/Symantic/CLI/Layout.hs @@ -0,0 +1,264 @@ +{-# 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 = lsrs + 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) diff --git a/Symantic/CLI/Parser.hs b/Symantic/CLI/Parser.hs --- a/Symantic/CLI/Parser.hs +++ b/Symantic/CLI/Parser.hs @@ -105,7 +105,6 @@ P.Label label -> NonEmpty.toList label P.EndOfInput -> "end of input" - instance Functor (Parser e d f) where a2b`fmap`Parser x = Parser $ (a2b <$>) <$> x instance Applicative (Parser e d f) where @@ -262,24 +261,47 @@ instance Outputable Int instance Outputable Integer instance Outputable Natural +instance Outputable Char where + output c = IO.putStr [c] instance Outputable String where output = IO.putStr instance Outputable Text.Text where output = Text.putStr instance Outputable TL.Text where output = TL.putStr -instance Outputable (Doc.AnsiText (Doc.Plain TLB.Builder)) where +instance Outputable (Doc.Plain TLB.Builder) where output = TL.putStr . TLB.toLazyText . - Doc.runPlain . - Doc.runAnsiText -instance Outputable (IO.Handle, Doc.AnsiText (Doc.Plain TLB.Builder)) where - output (h,d) = + Doc.runPlain + +-- ** Type 'OnHandle' +data OnHandle a = OnHandle IO.Handle a +instance IOType a => IOType (OnHandle a) where + ioType = ioType @a +instance Outputable (OnHandle ()) where + output _ = return () +instance Outputable (OnHandle Bool) where + output (OnHandle h a) = IO.hPrint h a +instance Outputable (OnHandle Int) where + output (OnHandle h a) = IO.hPrint h a +instance Outputable (OnHandle Integer) where + output (OnHandle h a) = IO.hPrint h a +instance Outputable (OnHandle Natural) where + output (OnHandle h a) = IO.hPrint h a +instance Outputable (OnHandle Char) where + output (OnHandle h c) = IO.hPutStr h [c] +instance Outputable (OnHandle String) where + output (OnHandle h a) = IO.hPutStr h a +instance Outputable (OnHandle Text.Text) where + output (OnHandle h a) = Text.hPutStr h a +instance Outputable (OnHandle TL.Text) where + output (OnHandle h a) = TL.hPutStr h a +instance Outputable (OnHandle (Doc.Plain TLB.Builder)) where + output (OnHandle h d) = TL.hPutStr h $ TLB.toLazyText $ - Doc.runPlain $ - Doc.runAnsiText d + Doc.runPlain d -- * Class 'IOType' -- | Like a MIME type but for input/output of a CLI. @@ -290,14 +312,15 @@ instance IOType () instance IOType Bool +instance IOType Char instance IOType Int instance IOType Integer instance IOType Natural instance IOType String instance IOType Text.Text instance IOType TL.Text -instance IOType (Doc.AnsiText (Doc.Plain TLB.Builder)) -instance IOType (IO.Handle, Doc.AnsiText (Doc.Plain TLB.Builder)) +instance IOType (Doc.Plain TLB.Builder) +instance IOType (IO.Handle, Doc.Plain TLB.Builder) -- * Class 'FromSegment' class FromSegment a where diff --git a/Symantic/CLI/Schema.hs b/Symantic/CLI/Schema.hs --- a/Symantic/CLI/Schema.hs +++ b/Symantic/CLI/Schema.hs @@ -31,17 +31,14 @@ runSchema :: Monoid d => Schema d f k -> SchemaInh d -> d runSchema (Schema s) = fromMaybe mempty . s -docSchema :: Monoid d => Docable d => Schema d f k -> d +docSchema :: Monoid d => SchemaDoc d => Schema d f k -> d docSchema s = runSchema s defSchemaInh coerceSchema :: Schema d f k -> Schema d f' k' coerceSchema Schema{..} = Schema{..} --- ** Type 'Doc' -type Doc = Doc.AnsiText (Doc.Plain TLB.Builder) - --- ** Class 'Docable' -type Docable d = +-- ** Class 'SchemaDoc' +type SchemaDoc d = ( Semigroup d , Monoid d , IsString d @@ -64,16 +61,16 @@ , schemaInh_or :: d } -defSchemaInh :: Docable d => SchemaInh d +defSchemaInh :: SchemaDoc d => SchemaInh d defSchemaInh = SchemaInh { schemaInh_op = (infixN0, SideL) , schemaInh_define = True , schemaInh_or = docOrH } -pairIfNeeded :: Docable d => SchemaInh d -> Infix -> d -> d -pairIfNeeded SchemaInh{..} op = - if needsParenInfix schemaInh_op op +pairIfNeeded :: SchemaDoc d => (Infix, Side) -> Infix -> d -> d +pairIfNeeded opInh op = + if needsParenInfix opInh op then Doc.align . Doc.parens else id @@ -85,12 +82,11 @@ instance (Semigroup d, IsString d) => IsString (Schema d f k) where fromString "" = Schema $ \_inh -> Nothing fromString s = Schema $ \_inh -> Just $ fromString s -instance Show (Schema Doc a k) where +instance Show (Schema (Doc.Plain TLB.Builder) a k) where show = TL.unpack . TLB.toLazyText . Doc.runPlain . - Doc.runAnsiText . docSchema docOrH, docOrV :: Doc.Spaceable d => Doc.From (Doc.Word Char) d => d @@ -98,56 +94,67 @@ docOrV = Doc.newline <> Doc.from (Doc.Word '|') <> Doc.space {- -instance Docable d => Functor (Schema d f) where +instance SchemaDoc d => Functor (Schema d f) where _f `fmap` Schema x = Schema $ \inh -> - pairIfNeeded inh op <$> + pairIfNeeded (schemaInh_op inh) op <$> x inh{schemaInh_op=(op, SideR)} where op = infixB SideL 10 -} -instance Docable d => App (Schema d) where +instance SchemaDoc d => App (Schema d) where Schema f <.> Schema x = Schema $ \inh -> - case (f inh{schemaInh_op=(op, SideL)}, x inh{schemaInh_op=(op, SideR)}) of - (Nothing, Nothing) -> Nothing - (Just f', Nothing) -> Just f' - (Nothing, Just x') -> Just x' - (Just f', Just x') -> Just $ pairIfNeeded inh op $ f' <> Doc.space <> x' + case f inh{schemaInh_op=(op, SideL)} of + Nothing -> x inh{schemaInh_op=(op, SideR)} + Just fd -> + case x inh{schemaInh_op=(op, SideR)} of + Nothing -> Just fd + Just xd -> Just $ + pairIfNeeded (schemaInh_op inh) op $ + fd <> Doc.space <> xd where op = infixB SideL 10 -instance Docable d => Alt (Schema d) where - lp rp = Schema $ \inh -> - case (unSchema lp inh, unSchema rp inh) of +instance SchemaDoc d => Alt (Schema d) where + l r = Schema $ \inh -> + -- NOTE: first try to see if both sides are 'Just', + -- otherwise does not change the inherited operator context. + case (unSchema l inh, unSchema r inh) of (Nothing, Nothing) -> Nothing - (Just lp', Nothing) -> Just lp' - (Nothing, Just rp') -> Just rp' + (Just ld, Nothing) -> Just ld + (Nothing, Just rd) -> Just rd (Just{}, Just{}) -> Just $ if needsParenInfix (schemaInh_op inh) op then + -- NOTE: when parenthesis are needed + -- first try to fit the alternative on a single line, + -- otherwise align them on multiple lines. Doc.breakalt (Doc.parens $ -- Doc.withBreakable Nothing $ - runSchema lp inh + runSchema l inh { schemaInh_op=(op, SideL) , schemaInh_or=docOrH } <> docOrH <> - runSchema rp inh + runSchema r inh { schemaInh_op=(op, SideR) , schemaInh_or=docOrH }) (Doc.align $ Doc.parens $ Doc.space <> - runSchema lp inh + runSchema l inh { schemaInh_op=(op, SideL) , schemaInh_or=docOrV } <> docOrV <> - runSchema rp inh + runSchema r inh { schemaInh_op=(op, SideR) , schemaInh_or=docOrV } <> Doc.newline) else - runSchema lp inh{schemaInh_op=(op, SideL)} <> + -- NOTE: when parenthesis are NOT needed + -- just concat alternatives using the inherited separator + -- (either horizontal or vertical). + runSchema l inh{schemaInh_op=(op, SideL)} <> schemaInh_or inh <> - runSchema rp inh{schemaInh_op=(op, SideR)} + runSchema r inh{schemaInh_op=(op, SideR)} where op = infixB SideL 2 alt x y = coerceSchema $ coerceSchema x coerceSchema y opt s = Schema $ \inh -> Just $ @@ -156,18 +163,19 @@ where op = infixN0 instance Pro (Schema d) where dimap _a2b _b2a = coerceSchema -instance Docable d => AltApp (Schema d) where +instance SchemaDoc d => AltApp (Schema d) where many0 s = Schema $ \inh -> Just $ runSchema s inh{schemaInh_op=(op, SideL)}<>"*" where op = infixN 10 many1 s = Schema $ \inh -> Just $ - runSchema s inh{schemaInh_op=(op, SideL)}<>"..." + runSchema s inh{schemaInh_op=(op, SideL)}<>"+" where op = infixN 10 -instance Docable d => CLI_Command (Schema d) where +instance SchemaDoc d => CLI_Command (Schema d) where -- type CommandConstraint (Schema d) a = () command n s = Schema $ \inh -> Just $ if schemaInh_define inh || List.null n then + Doc.align $ runSchema (fromString n <.> coerceSchema s) inh{schemaInh_define = False} @@ -178,18 +186,18 @@ Doc.angles $ Doc.magentaer $ Doc.from (Doc.Word n) -instance Docable d => CLI_Var (Schema d) where +instance SchemaDoc d => CLI_Var (Schema d) where type VarConstraint (Schema d) a = () var' n = Schema $ \_inh -> Just $ Doc.underline $ Doc.from $ Doc.Word n just _ = Schema $ \_inh -> Nothing nothing = Schema $ \_inh -> Nothing -instance Docable d => CLI_Env (Schema d) where +instance SchemaDoc d => CLI_Env (Schema d) where type EnvConstraint (Schema d) a = () env' _n = Schema $ \_inh -> Nothing -- NOTE: environment variables are not shown in the schema, -- only in the help. -instance Docable d => CLI_Tag (Schema d) where +instance SchemaDoc d => CLI_Tag (Schema d) where type TagConstraint (Schema d) a = () tagged n r = Schema $ \inh -> unSchema (prefix n <.> r) inh @@ -199,7 +207,7 @@ TagShort s -> fromString ['-', s] TagLong l -> fromString ("--"<>l) endOpts = Schema $ \_inh -> Just $ Doc.brackets "--" -instance Docable d => CLI_Help (Schema d) where +instance SchemaDoc d => CLI_Help (Schema d) where type HelpConstraint (Schema d) d' = d ~ d' help _msg = id program n s = Schema $ \inh -> Just $ @@ -217,7 +225,7 @@ Doc.magentaer $ Doc.from (Doc.Word n) data SchemaResponseArgs a -instance Docable d => CLI_Response (Schema d) where +instance SchemaDoc d => CLI_Response (Schema d) where type ResponseConstraint (Schema d) a = () type ResponseArgs (Schema d) a = SchemaResponseArgs a type Response (Schema d) = () @@ -225,50 +233,42 @@ -- ** Type 'SchemaPerm' data SchemaPerm d k a = SchemaPerm - { schemaPerm_finalizer :: forall b c. Schema d (b->c) c -> Schema d (b->c) c + { schemaPerm_finalizer :: forall b c. + Schema d (b->c) c -> + Schema d (b->c) c -- ^ Used to implement 'rule'. , schemaPerm_alternatives :: [Schema d (a->k) k] -- ^ Collect alternatives for rendering them all at once in 'runPermutation'. } instance Functor (SchemaPerm d k) where - _f`fmap`SchemaPerm w ps = SchemaPerm w (coerceSchema <$> ps) + _f`fmap`SchemaPerm fin ps = SchemaPerm fin (coerceSchema <$> ps) instance Applicative (SchemaPerm d k) where pure _a = SchemaPerm id mempty - SchemaPerm fd w <*> SchemaPerm fx x = - SchemaPerm (fd . fx) $ (coerceSchema <$> w) <> (coerceSchema <$> x) -instance Docable d => Permutable (Schema d) where + SchemaPerm fd f <*> SchemaPerm fx x = + SchemaPerm (fd . fx) $ (coerceSchema <$> f) <> (coerceSchema <$> x) +instance SchemaDoc d => Permutable (Schema d) where type Permutation (Schema d) = SchemaPerm d - runPermutation (SchemaPerm w ps) = + runPermutation (SchemaPerm fin ps) = case ps of - [] -> w $ Schema $ \_inh -> Nothing - [Schema s] -> w $ Schema s - _ -> w $ Schema $ \inh -> Just $ - -- pairIfNeeded inh op $ - Doc.align $ + [] -> fin $ Schema $ \_inh -> Nothing + _ -> fin $ Schema $ \inh -> Just $ Doc.intercalate Doc.breakspace $ catMaybes $ (<$> ps) $ \(Schema s) -> s inh { schemaInh_op=(op, SideL) , schemaInh_or=docOrH } - where op = infixN 10 + where op = infixN 10 toPermutation = SchemaPerm id . pure toPermDefault _a s = SchemaPerm id $ pure $ Schema $ \inh -> Just $ if needsParenInfix (schemaInh_op inh) op then - Doc.breakalt - (Doc.brackets $ - -- Doc.withBreakable Nothing $ - runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH}) - (Doc.align $ - Doc.brackets $ - Doc.space <> - runSchema s inh{schemaInh_op=(op, SideL)} <> - Doc.newline) + Doc.brackets $ + runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH} else runSchema s inh{schemaInh_op=(op, SideL)} where op = infixN0 -instance Docable d => CLI_Help (SchemaPerm d) where +instance SchemaDoc d => CLI_Help (SchemaPerm d) where type HelpConstraint (SchemaPerm d) d' = d ~ d' help _msg = id - program n (SchemaPerm w ps) = SchemaPerm (program n . w) ps - rule n (SchemaPerm w ps) = SchemaPerm (rule n . w) ps + program n (SchemaPerm fin ps) = SchemaPerm (program n . fin) ps + rule n (SchemaPerm fin ps) = SchemaPerm (rule n . fin) ps diff --git a/symantic-cli.cabal b/symantic-cli.cabal --- a/symantic-cli.cabal +++ b/symantic-cli.cabal @@ -2,7 +2,7 @@ -- PVP: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 2.2.4.20190701 +version: 2.3.2.20190711 category: System, CLI, Options, Parsing synopsis: Symantics for parsing and documenting a CLI description: @@ -38,6 +38,7 @@ Symantic.CLI.Help Symantic.CLI.Parser Symantic.CLI.Schema + Symantic.CLI.Layout default-language: Haskell2010 default-extensions: FlexibleContexts @@ -62,6 +63,6 @@ base >= 4.10 && < 5 , containers >= 0.5 , megaparsec >= 7.0 - , symantic-document >= 1.1.1 + , symantic-document >= 1.5 , text >= 1.2 , transformers >= 0.5