+++ /dev/null
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE TypeFamilyDependencies #-}
-{-# LANGUAGE UndecidableInstances #-} -- for type instance defaults
-module Symantic.CLI.API where
-
-import Data.Bool
-import Data.Char (Char)
-import Data.Eq (Eq)
-import Data.Function (($), (.), id)
-import Data.Kind (Constraint)
-import Data.Maybe (Maybe(..), fromJust)
-import Data.String (String, IsString(..))
-import Text.Show (Show)
-
--- * Class 'App'
-class App repr where
- (<.>) :: repr a b -> repr b c -> repr a c
- -- Trans defaults
- default (<.>) ::
- Trans repr =>
- App (UnTrans repr) =>
- repr a b -> repr b c -> repr a c
- x <.> y = noTrans (unTrans x <.> unTrans y)
-infixr 4 <.>
-
--- * Class 'Alt'
-class Alt repr where
- (<!>) :: repr a k -> repr b k -> repr (a:!:b) k
- alt :: repr a k -> repr a k -> repr a k
- opt :: repr (a->k) k -> repr (Maybe a->k) k
- -- Trans defaults
- default (<!>) ::
- Trans repr =>
- Alt (UnTrans repr) =>
- repr a k -> repr b k -> repr (a:!:b) k
- default alt ::
- Trans repr =>
- Alt (UnTrans repr) =>
- repr a k -> repr a k -> repr a k
- default opt ::
- Trans repr =>
- Alt (UnTrans repr) =>
- repr (a->k) k -> repr (Maybe a->k) k
- x <!> y = noTrans (unTrans x <!> unTrans y)
- x `alt` y = noTrans (unTrans x `alt` unTrans y)
- opt = noTrans . opt . unTrans
--- NOTE: yes infixr, not infixl like <|>,
--- in order to run left-most checks first.
-infixr 3 <!>
-infixr 3 `alt`
-
--- ** Type (':!:')
--- | Like @(,)@ but @infixr@.
-data (:!:) a b = a:!:b
-infixr 3 :!:
-
--- * Class 'Pro'
-class Pro repr where
- dimap :: (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
- -- Trans defaults
- default dimap ::
- Trans repr =>
- Pro (UnTrans repr) =>
- (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
- dimap a2b b2a = noTrans . dimap a2b b2a . unTrans
-
--- * Class 'AltApp'
-class AltApp repr where
- many0 :: repr (a->k) k -> repr ([a]->k) k
- many1 :: repr (a->k) k -> repr ([a]->k) k
- -- Trans defaults
- default many0 ::
- Trans repr =>
- AltApp (UnTrans repr) =>
- repr (a->k) k -> repr ([a]->k) k
- default many1 ::
- Trans repr =>
- AltApp (UnTrans repr) =>
- repr (a->k) k -> repr ([a]->k) k
- many0 = noTrans . many0 . unTrans
- many1 = noTrans . many1 . unTrans
-
--- * Class 'Permutable'
-class Permutable repr where
- -- NOTE: Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
- type Permutation (repr:: * -> * -> *) = (r :: * -> * -> *) | r -> repr
- type Permutation repr = Permutation (UnTrans repr)
- runPermutation :: Permutation repr k a -> repr (a->k) k
- toPermutation :: repr (a->k) k -> Permutation repr k a
- toPermDefault :: a -> repr (a->k) k -> Permutation repr k a
-
--- | Convenient wrapper to omit a 'runPermutation'.
---
--- @
--- opts '<?>' next = 'runPermutation' opts '<.>' next
--- @
-(<?>) ::
- App repr => Permutable repr =>
- Permutation repr b a -> repr b c -> repr (a->b) c
-opts <?> next = runPermutation opts <.> next
-infixr 4 <?>
-
--- * Class 'Sequenceable'
-class Sequenceable repr where
- -- NOTE: Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
- type Sequence (repr:: * -> * -> *) = (r :: * -> * -> *) | r -> repr
- type Sequence repr = Sequence (UnTrans repr)
- runSequence :: Sequence repr k a -> repr (a->k) k
- toSequence :: repr (a->k) k -> Sequence repr k a
-
--- * Type 'Name'
-type Name = String
-
--- * Type 'Segment'
-type Segment = String
-
--- * Class 'CLI_Command'
-class CLI_Command repr where
- command :: Name -> repr a k -> repr a k
-
--- * Class 'CLI_Var'
-class CLI_Var repr where
- type VarConstraint repr a :: Constraint
- var' :: VarConstraint repr a => Name -> repr (a->k) k
- -- Trans defaults
- type VarConstraint repr a = VarConstraint (UnTrans repr) a
- default var' ::
- Trans repr =>
- CLI_Var (UnTrans repr) =>
- VarConstraint (UnTrans repr) a =>
- Name -> repr (a->k) k
- var' = noTrans . var'
-
--- | Like 'var'' but with the type variable @(a)@ first instead or @(repr)@
--- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
-var ::
- forall a k repr.
- CLI_Var repr =>
- VarConstraint repr a =>
- Name -> repr (a->k) k
-var = var'
-{-# INLINE var #-}
-
--- * Class 'CLI_Var'
-class CLI_Constant repr where
- constant :: Segment -> a -> repr (a->k) k
- just :: a -> repr (a->k) k
- nothing :: repr k k
- default constant ::
- Trans repr =>
- CLI_Constant (UnTrans repr) =>
- Segment -> a -> repr (a->k) k
- default just ::
- Trans repr =>
- CLI_Constant (UnTrans repr) =>
- a -> repr (a->k) k
- default nothing ::
- Trans repr =>
- CLI_Constant (UnTrans repr) =>
- repr k k
- constant s = noTrans . constant s
- just = noTrans . just
- nothing = noTrans nothing
-
--- * Class 'CLI_Env'
-class CLI_Env repr where
- type EnvConstraint repr a :: Constraint
- env' :: EnvConstraint repr a => Name -> repr (a->k) k
- -- Trans defaults
- type EnvConstraint repr a = EnvConstraint (UnTrans repr) a
- default env' ::
- Trans repr =>
- CLI_Env (UnTrans repr) =>
- EnvConstraint (UnTrans repr) a =>
- Name -> repr (a->k) k
- env' = noTrans . env'
-
--- | Like 'env'' but with the type enviable @(a)@ first instead or @(repr)@
--- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
-env ::
- forall a k repr.
- CLI_Env repr =>
- EnvConstraint repr a =>
- Name -> repr (a->k) k
-env = env'
-{-# INLINE env #-}
-
--- ** Type 'Tag'
-data Tag
- = Tag Char Name
- | TagLong Name
- | TagShort Char
- deriving (Eq, Show)
-instance IsString Tag where
- fromString = \case
- [c] -> TagShort c
- c:'|':cs -> Tag c cs
- cs -> TagLong cs
-
--- * Class 'CLI_Tag'
-class (App repr, Permutable repr, CLI_Constant repr) => CLI_Tag repr where
- type TagConstraint repr a :: Constraint
- tag :: Tag -> repr f k -> repr f k
- -- tag n = (tag n <.>)
- endOpts :: repr k k
-
- flag :: TagConstraint repr Bool => Tag -> Permutation repr k Bool
- flag n = toPermDefault False $ tag n $ just True
-
- optionalTag ::
- TagConstraint repr a => AltApp repr => Alt repr => Pro repr =>
- Tag -> repr (a->k) k -> Permutation repr k (Maybe a)
- optionalTag n = toPermDefault Nothing . tag n . dimap Just fromJust
-
- defaultTag ::
- TagConstraint repr a =>
- Tag -> a -> repr (a->k) k -> Permutation repr k a
- defaultTag n a = toPermDefault a . tag n
-
- requiredTag ::
- TagConstraint repr a =>
- Tag -> repr (a->k) k -> Permutation repr k a
- requiredTag n = toPermutation . tag n
-
- many0Tag ::
- TagConstraint repr a => AltApp repr =>
- Tag -> repr (a->k) k -> Permutation repr k [a]
- many0Tag n = toPermDefault [] . many1 . tag n
- many1Tag ::
- TagConstraint repr a => AltApp repr =>
- Tag -> repr (a->k) k -> Permutation repr k [a]
- many1Tag n = toPermutation . many1 . tag n
-
- -- Trans defaults
- type TagConstraint repr a = TagConstraint (UnTrans repr) a
- default tag ::
- Trans repr =>
- CLI_Tag (UnTrans repr) =>
- Tag -> repr f k -> repr f k
- default endOpts ::
- Trans repr =>
- CLI_Tag (UnTrans repr) =>
- repr k k
- tag n = noTrans . tag n . unTrans
- endOpts = noTrans endOpts
-
--- * Class 'CLI_Response'
-class CLI_Response repr where
- type ResponseConstraint repr a :: Constraint
- type ResponseArgs repr a :: * -- = (r:: *) | r -> a
- type Response repr :: *
- response' ::
- ResponseConstraint repr a =>
- repr (ResponseArgs repr a)
- (Response repr)
- -- Trans defaults
- type ResponseConstraint repr a = ResponseConstraint (UnTrans repr) a
- type ResponseArgs repr a = ResponseArgs (UnTrans repr) a
- type Response repr = Response (UnTrans repr)
- default response' ::
- forall a.
- Trans repr =>
- CLI_Response (UnTrans repr) =>
- ResponseConstraint (UnTrans repr) a =>
- ResponseArgs repr a ~ ResponseArgs (UnTrans repr) a =>
- Response repr ~ Response (UnTrans repr) =>
- repr (ResponseArgs repr a)
- (Response repr)
- response' = noTrans (response' @_ @a)
-
-response ::
- forall a repr.
- CLI_Response repr =>
- ResponseConstraint repr a =>
- repr (ResponseArgs repr a)
- (Response repr)
-response = response' @repr @a
-{-# INLINE response #-}
-
--- * Class 'CLI_Help'
-class CLI_Help repr where
- type HelpConstraint repr d :: Constraint
- help :: HelpConstraint repr d => d -> repr f k -> repr f k
- help _msg = id
- program :: Name -> repr f k -> repr f k
- rule :: Name -> repr f k -> repr f k
- -- Trans defaults
- type HelpConstraint repr d = HelpConstraint (UnTrans repr) d
- default program ::
- Trans repr =>
- CLI_Help (UnTrans repr) =>
- Name -> repr f k -> repr f k
- default rule ::
- Trans repr =>
- CLI_Help (UnTrans repr) =>
- Name -> repr f k -> repr f k
- program n = noTrans . program n . unTrans
- rule n = noTrans . rule n . unTrans
-infixr 0 `help`
-
--- * Type 'Trans'
-class Trans repr where
- -- | The @(repr)@esentation that @(repr)@ 'Trans'forms.
- type UnTrans repr :: * -> * -> *
- -- | Lift the underlying @(repr)@esentation to @(repr)@.
- -- Useful to define a combinator that does nothing in a 'Trans'formation.
- noTrans :: UnTrans repr a b -> repr a b
- -- | Unlift a @(repr)@esentation. Useful when a 'Trans'formation
- -- combinator needs to access the 'UnTrans'formed @(repr)@esentation,
- -- or at the end to get the underlying 'UnTrans'formed @(repr)@esentation
- -- from the inferred @(repr)@ value (eg. in 'server').
- unTrans :: repr a b -> UnTrans repr a b
+++ /dev/null
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
-module Symantic.CLI.Help where
-
-import Control.Applicative (Applicative(..))
-import Data.Bool
-import Data.Foldable (null)
-import Data.Function (($), (.))
-import Data.Functor (Functor(..), (<$>))
-import Data.Maybe (Maybe(..), maybe, isJust)
-import Data.Monoid (Monoid(..))
-import Data.Semigroup (Semigroup(..))
-import Text.Show (Show(..))
-import Data.Tree as Tree
-import qualified Symantic.Document as Doc
-
-import Symantic.CLI.API
-import Symantic.CLI.Schema as Schema
-
--- * Type 'Help'
-data Help d f k
- = Help
- { help_result :: HelpInh d -> HelpResult d
- -- ^ The 'HelpResult' of the current symantic.
- , help_schema :: Schema d f k
- -- ^ The 'Schema' of the current symantic.
- }
-
-runHelp :: SchemaDoc d => HelpInh d -> Help d f k -> d
-runHelp def (Help h _p) = runHelpNodes def (h def) <> Doc.newline
-
-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'
-coerceHelp Help{help_schema, ..} = Help
- { help_schema = Schema.coerceSchema help_schema
- , ..
- }
-
--- ** Type 'HelpInh'
--- | Configuration inherited top-down.
-data HelpInh d
- = HelpInh
- { helpInh_message :: !(Maybe d)
- -- ^ The message inherited from 'help's.
- , helpInh_command_indent :: !Doc.Indent
- -- ^ 'Doc.Indent'ation for 'command's.
- , helpInh_tag_indent :: !Doc.Indent
- -- ^ 'Doc.Indent'ation for 'Tag's.
- , helpInh_schema :: !(SchemaInh d)
- -- ^ The inherited 'SchemaInh' for 'runSchema'.
- , helpInh_helpless_options :: !Bool
- -- ^ Whether to include options without help in the listing.
- , helpInh_command_rule :: !Bool
- -- ^ Whether to print the name of the rule.
- , helpInh_full :: !Bool
- -- ^ Whether to print full help.
- }
-
-defHelpInh :: SchemaDoc d => HelpInh d
-defHelpInh = HelpInh
- { helpInh_message = Nothing
- , helpInh_command_indent = 2
- , helpInh_tag_indent = 16
- , helpInh_schema = defSchemaInh
- , helpInh_helpless_options = False
- , helpInh_command_rule = False
- , helpInh_full = True
- }
-
--- ** Type 'HelpResult'
-type HelpResult d = Tree.Forest (HelpNode, d)
-
-defHelpResult :: Monoid d => HelpResult d
-defHelpResult = mempty
-
--- *** Type 'HelpNode'
-data HelpNode
- = HelpNode_Message
- | HelpNode_Rule
- | HelpNode_Command
- | HelpNode_Tag
- | HelpNode_Env
- deriving Show
-
-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 :: SchemaDoc d => HelpInh d -> Tree.Forest (HelpNode, d) -> d
-runHelpNodes _inh [] = mempty
-runHelpNodes inh ( t0@(Tree.Node _ t0s)
- : t1@(Tree.Node (HelpNode_Command, _) _) : ts ) =
- runHelpNode t0 <>
- Doc.newline <>
- (if null t0s || not (helpInh_full inh) then mempty else Doc.newline) <>
- runHelpNodes inh (t1:ts)
-runHelpNodes inh ( t0@(Tree.Node (HelpNode_Tag, _) _)
- : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
- runHelpNode t0 <>
- Doc.newline <>
- runHelpNodes inh (t1:ts)
-runHelpNodes inh ( t0@(Tree.Node (HelpNode_Rule, _) t0s)
- : t1@(Tree.Node (_, _) _) : ts ) =
- runHelpNode t0 <>
- Doc.newline <>
- (if null t0s || not (helpInh_full inh) then mempty else Doc.newline) <>
- runHelpNodes inh (t1:ts)
-runHelpNodes inh ( t0@(Tree.Node (HelpNode_Message, _) _)
- : t1 : ts ) =
- runHelpNode t0 <>
- Doc.newline <>
- Doc.newline <>
- runHelpNodes inh (t1:ts)
-runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
- runHelpNode t0 <>
- Doc.newline <>
- Doc.newline <>
- runHelpNodes inh (t1:ts)
-runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
- runHelpNode t0 <>
- Doc.newline <>
- Doc.newline <>
- runHelpNodes inh (t1:ts)
-runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Rule, _) _) : ts ) =
- runHelpNode t0 <>
- Doc.newline <>
- runHelpNodes inh (t1:ts)
-runHelpNodes inh (t:ts) = runHelpNode t <> runHelpNodes inh ts
-
-instance Semigroup d => Semigroup (Help d f k) where
- Help hx px <> Help hy py = Help (hx<>hy) (px<>py)
-instance Monoid d => Monoid (Help d f k) where
- mempty = Help mempty mempty
- mappend = (<>)
-{-
-instance (Semigroup d, IsString d) => IsString (Help d e s a) where
- fromString "" = Help $ \_ro -> Nothing
- fromString s = Help $ \_ro -> Just $ fromString s
-instance Show (Help Doc.Term e s a) where
- show = TL.unpack . Doc.textTerm . runHelp
-instance SchemaDoc d => Functor (Help d f) where
- f <$$> Help h s = Help h (f<$$>s)
--}
-instance SchemaDoc d => App (Help d) where
- Help hf pf <.> Help hx px = Help (hf<>hx) (pf<.>px)
-instance SchemaDoc d => Alt (Help d) where
- Help hl pl <!> Help hr pr = Help (hl<>hr) (pl<!>pr)
- Help hl pl `alt` Help hr pr = Help (hl<>hr) (pl`alt`pr)
- opt (Help h s) = Help h (opt s)
- {-
- try (Help h s) = Help h (try s)
- choice hs = Help (mconcat $ help_result <$> hs) (choice (help_schema <$> hs))
- option a (Help h s) = Help h (option a s)
- -}
-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 SchemaDoc d => AltApp (Help d) where
- many0 (Help h s) = Help h (many0 s)
- many1 (Help h s) = Help h (many1 s)
-instance SchemaDoc d => CLI_Var (Help d) where
- type VarConstraint (Help d) a = ()
- var' n = Help mempty (var' n)
-instance SchemaDoc d => CLI_Constant (Help d) where
- constant n a = Help mempty (constant n a)
- just a = Help mempty (just a)
- nothing = Help mempty nothing
-instance SchemaDoc d => CLI_Env (Help d) where
- type EnvConstraint (Help d) a = ()
- env' n =
- Help (\inh ->
- let ts =
- if helpInh_full inh
- then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
- else [] in
- let d =
- 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)
- <> Doc.align (runHelpNodes inh ts)
- in
- [ Tree.Node (HelpNode_Env, d) ts ]
- ) schema
- where schema = env' n
-instance SchemaDoc d => CLI_Command (Help d) where
- -- type CommandConstraint (Help d) a = ()
- command n (Help h s) =
- Help (\inh ->
- let ts =
- (if helpInh_full inh
- then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
- else []) <>
- h inh
- { helpInh_message = Nothing
- , 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 (Doc.spaces ind) ind
- ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
- in
- [ Tree.Node (HelpNode_Command, d) ts ]
- ) schema
- where
- schema = command n s
- ref =
- Doc.bold $
- Doc.angles $
- Doc.magentaer $
- Doc.from (Doc.Word n)
-instance SchemaDoc d => CLI_Tag (Help d) where
- type TagConstraint (Help d) a = ()
- tag n (Help h s) =
- Help (\inh ->
- if (isJust (helpInh_message inh)
- || helpInh_helpless_options inh)
- && helpInh_full inh
- then
- let ts =
- maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) <>
- h inh{helpInh_message=Nothing} in
- let d =
- Doc.fillOrBreak (helpInh_tag_indent inh)
- (Doc.bold $
- Schema.runSchema schema (helpInh_schema inh)
- <> Doc.space) -- FIXME: space is not always needed
- <> (if null ts then mempty else Doc.space)
- <> Doc.align (runHelpNodes inh ts)
- in
- [ Tree.Node (HelpNode_Tag, d) ts ]
- else []
- ) schema
- where schema = tag n s
- endOpts = Help mempty endOpts
-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})
- (help msg s)
- program n (Help h s) =
- Help (\inh ->
- let ts =
- (if helpInh_full inh
- then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
- else []) <>
- h inh
- { helpInh_message = Nothing
- , 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 (Doc.spaces ind) ind
- ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
- in
- [ Tree.Node (HelpNode_Rule, d) ts ]
- ) schema
- where
- schema = program n s
- rule n (Help h s) =
- Help (\inh ->
- let ts =
- (if helpInh_full inh
- then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
- else []) <>
- h inh
- { helpInh_message = Nothing
- , 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 (Doc.spaces ind) ind
- ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
- in
- [ Tree.Node (HelpNode_Rule, d) ts ]
- ) schema
- where
- schema = rule n s
- ref =
- Doc.bold $
- Doc.angles $
- Doc.magentaer $
- Doc.from (Doc.Word n)
-type HelpResponseArgs = SchemaResponseArgs
-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)
- response' ::
- forall a repr.
- repr ~ Help d =>
- ResponseConstraint repr a =>
- repr (ResponseArgs repr a)
- (Response repr)
- response' = Help mempty $ response' @(Schema d) @a
-
-{-
-instance SchemaDoc d => Sym_AltApp (Help d) where
- many (Help h s) = Help h (many s)
- some (Help h s) = Help h (many s)
--}
-
--- * Type 'HelpPerm'
-data HelpPerm d k a
- = HelpPerm (HelpInh d -> HelpResult d)
- (SchemaPerm d k a)
-instance Functor (HelpPerm d k) where
- f`fmap`HelpPerm h ps = HelpPerm h (f<$>ps)
-instance Applicative (HelpPerm d k) where
- pure a = HelpPerm mempty (pure a)
- HelpPerm fh f <*> HelpPerm xh x =
- HelpPerm (fh<>xh) (f<*>x)
-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})
- (help msg s)
- program n (HelpPerm h s) = HelpPerm
- (help_result $ program n (Help h (runPermutation s)))
- (rule n s)
- rule n (HelpPerm h s) = HelpPerm
- (help_result $ rule n (Help h (runPermutation s)))
- (rule n s)
+++ /dev/null
-{-# 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(..), 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.
- , 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
-
--- ** 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 <$>)
-
-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.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_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) []{-FIXME-}) 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 ->
- maybe [] (\sch -> [(Doc.brackets sch, layoutInh_message inh <> xh)]) $
- unSchema xl defSchemaInh
-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
- {-
- runSequence (LayoutSeq s h ps) = Layout sch h $ \inh -> do
- modify' $ \k -> \case
- Nothing -> k Nothing
- Just ts -> k $ Just [Tree.Node nod mempty]
- -- where nod = LayoutNode_List (layoutInh_message inh) (ps inh{layoutInh_message=[]})
- where
- nod = LayoutNode_Forest mempty {-(docSchema sch)-}
- (layoutInh_message inh) (gs <> ts)
- gs = (<$> ps inh{layoutInh_message=[]}) $ \(d,ds) ->
- Tree.Node (LayoutNode_Single d ds) mempty
-
- where sch = runSequence s
- toSequence (Layout s h _m) = LayoutSeq (toSequence s) h $ \inh ->
- [(docSchema s, layoutInh_message inh <> h)]
- -}
-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 = [(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 = [(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
-
--- ** Type 'LayoutSeq'
-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
-
--- ** Type 'LayoutPerm'
-data LayoutPerm d k a = LayoutPerm
- { layoutPerm_help :: [d]
- , layoutPerm_alts :: LayoutInh d -> [(d, {-help-}[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
-
--- ** Type 'LayoutNode'
-data LayoutNode d
- = LayoutNode_Single d {-help-}[d]
- | LayoutNode_List [d] [(d, {-help-}[d])]
- | LayoutNode_Forest d [d] (Tree.Forest (LayoutNode d))
- deriving (Show)
+++ /dev/null
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE GADTs #-} -- for Router
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-} -- for hoistParserPerm (which is no longer used)
-module Symantic.CLI.Parser where
-
-import Control.Applicative (Applicative(..), Alternative(..), optional, many, some)
-import Control.Monad (Monad(..), join, sequence, forM_, void)
-import Control.Monad.Trans.Class (MonadTrans(..))
-import Control.Monad.Trans.State (StateT(..),evalState,get,put)
-import Data.Bool
-import Data.Char (Char)
-import Data.Either (Either(..))
-import Data.Eq (Eq(..))
-import Data.Foldable (null, toList)
-import Data.Function (($), (.), id, const)
-import Data.Functor (Functor(..), (<$>), ($>))
-import Data.Functor.Identity (Identity(..))
-import Data.Int (Int)
-import Data.List.NonEmpty (NonEmpty(..))
-import Data.Map.Strict (Map)
-import Data.Maybe (Maybe(..), maybe, isNothing)
-import Data.Ord (Ord(..))
-import Data.Proxy (Proxy(..))
-import Data.Semigroup (Semigroup(..))
-import Data.String (String)
-import Numeric.Natural (Natural)
-import Prelude (Integer, Num(..), error)
-import System.Environment (lookupEnv)
-import System.IO (IO)
-import Text.Read (Read, readEither)
-import Text.Show (Show(..), ShowS, showString, showParen)
-import Type.Reflection as Reflection
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as BSL
-import qualified Data.List as List
-import qualified Data.List.NonEmpty as NonEmpty
-import qualified Data.Map.Merge.Strict as Map
-import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
-import qualified System.Exit as System
-import qualified Data.Text as Text
-import qualified Data.Text.IO as Text
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Builder as TLB
-import qualified Data.Text.Lazy.IO as TL
-import qualified Symantic.Document as Doc
-import qualified System.IO as IO
-import qualified Text.Megaparsec as P
-
-import Symantic.CLI.API
-
--- * Type 'Parser'
-newtype Parser e d f k = Parser
- { unParser :: P.ParsecT e [Arg] IO (f->k) -- Reader f k
- }
-
-parser ::
- P.ShowErrorComponent e =>
- Router (Parser e d) handlers (Response (Router (Parser e d))) ->
- handlers ->
- [Arg] -> IO ()
-parser api handlers args = do
- P.runParserT
- (unParser $ unTrans $ router api)
- "" args >>= \case
- Left err ->
- forM_ (P.bundleErrors err) $ \e -> do
- IO.putStr $
- "Error parsing the command at argument #" <>
- show (P.errorOffset e + 1) <> ":\n" <>
- parseErrorTextPretty e
- System.exitWith (System.ExitFailure 2)
- Right app -> unResponseParser $ app handlers
-
--- | Rewrite 'P.parseErrorTextPretty' to keep 'Ord' of 'Arg'.
-parseErrorTextPretty ::
- forall s e.
- (P.Stream s, P.ShowErrorComponent e) =>
- P.ParseError s e -> String
-parseErrorTextPretty (P.TrivialError _ us ps) =
- if isNothing us && Set.null ps
- then "unknown parse error\n"
- else
- messageItemsPretty "unexpected "
- (showErrorItem pxy <$> Set.toAscList (maybe Set.empty Set.singleton us)) <>
- messageItemsPretty "expecting "
- (showErrorItem pxy <$> Set.toAscList ps)
- where pxy = Proxy :: Proxy s
-parseErrorTextPretty err = P.parseErrorTextPretty err
-
-messageItemsPretty :: String -> [String] -> String
-messageItemsPretty prefix ts
- | null ts = ""
- | otherwise = prefix <> (orList . NonEmpty.fromList) ts <> "\n"
-
-orList :: NonEmpty String -> String
-orList (x:|[]) = x
-orList (x:|[y]) = x <> " or " <> y
-orList xs = List.intercalate ", " (NonEmpty.init xs) <> ", or " <> NonEmpty.last xs
-
-showErrorItem :: P.Stream s => Proxy s -> P.ErrorItem (P.Token s) -> String
-showErrorItem pxy = \case
- P.Tokens ts -> P.showTokens pxy ts
- 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
- pure = Parser . pure . const
- Parser f <*> Parser x = Parser $ (<*>) <$> f <*> x
-instance Ord e => Alternative (Parser e d f) where
- empty = Parser empty
- Parser x <|> Parser y = Parser $ x <|> y
-instance Ord e => Sequenceable (Parser e d) where
- type Sequence (Parser e d) = ParserSeq e d
- runSequence = unParserSeq
- toSequence = ParserSeq
-instance Ord e => Permutable (Parser e d) where
- type Permutation (Parser e d) = ParserPerm e d (Parser e d)
- runPermutation (ParserPerm ma p) = Parser $ do
- u2p <- unParser $ optional p
- unParser $
- case u2p () of
- Just perm -> runPermutation perm
- Nothing ->
- maybe
- (Parser $ P.token (const Nothing) Set.empty)
- -- NOTE: Not 'empty' here so that 'P.TrivialError'
- -- has the unexpected token.
- (Parser . return) ma
- toPermutation (Parser x) =
- ParserPerm Nothing
- (Parser $ (\a () -> ParserPerm (Just a) empty) <$> x)
- toPermDefault a (Parser x) =
- ParserPerm (Just ($ a))
- (Parser $ (\d () -> ParserPerm (Just d) empty) <$> x)
-instance App (Parser e d) where
- Parser x <.> Parser y = Parser $
- x >>= \a2b -> (. a2b) <$> y
-instance Ord e => Alt (Parser e d) where
- Parser x <!> Parser y = Parser $
- (\a2k (a:!:_b) -> a2k a) <$> P.try x <|>
- (\b2k (_a:!:b) -> b2k b) <$> y
- Parser x `alt` Parser y = Parser $ P.try x <|> y
- opt (Parser x) = Parser $
- mapCont Just <$> P.try x
-instance Ord e => AltApp (Parser e d) where
- many0 (Parser x) = Parser $ concatCont <$> many x
- many1 (Parser x) = Parser $ concatCont <$> some x
-instance Pro (Parser e d) where
- dimap a2b _b2a (Parser r) = Parser $ (\k b2k -> k (b2k . a2b)) <$> r
-instance Ord e => CLI_Command (Parser e d) where
- -- type CommandConstraint (Parser e d) a = ()
- command "" x = x
- command n x = commands Map.empty (Map.singleton n x)
-instance Ord e => CLI_Tag (Parser e d) where
- type TagConstraint (Parser e d) a = ()
- tag name p = Parser $ P.try $ do
- void $ (`P.token` exp) $ \tok ->
- if lookupTag tok name
- then Just tok
- else Nothing
- unParser p
- where
- exp =
- case name of
- TagShort t -> Set.singleton $ P.Tokens $ pure $ ArgTagShort t
- TagLong t -> Set.singleton $ P.Tokens $ pure $ ArgTagLong t
- Tag s l -> Set.fromList
- [ P.Tokens $ pure $ ArgTagShort s
- , P.Tokens $ pure $ ArgTagLong l
- ]
- lookupTag (ArgTagShort x) (TagShort y) = x == y
- lookupTag (ArgTagShort x) (Tag y _) = x == y
- lookupTag (ArgTagLong x) (TagLong y) = x == y
- lookupTag (ArgTagLong x) (Tag _ y) = x == y
- lookupTag _ _ = False
- endOpts = Parser $ do
- (`P.token` exp) $ \case
- ArgTagLong "" -> Just id
- _ -> Nothing
- where
- exp = Set.singleton $ P.Tokens $ pure $ ArgTagLong ""
-instance Ord e => CLI_Var (Parser e d) where
- type VarConstraint (Parser e d) a = (IOType a, FromSegment a)
- var' :: forall a k. VarConstraint (Parser e d) a => Name -> Parser e d (a->k) k
- var' name = Parser $ do
- seg <- (`P.token` expName) $ \case
- ArgSegment seg -> Just seg
- _ -> Nothing
- lift (fromSegment seg) >>= \case
- Left err -> P.failure got expType
- where
- got = Just $ P.Tokens $ pure $ ArgSegment seg
- expType = Set.singleton $ P.Label $ NonEmpty.fromList $
- "<"<>name<>"> to be of type "<>ioType @a
- <> case err of
- "Prelude.read: no parse" -> ""
- "" -> ""
- _ -> ": "<>err
- Right a -> return ($ a)
- where
- expName = Set.singleton $ P.Label $ NonEmpty.fromList $ "<"<>name<>">"
-instance Ord e => CLI_Constant (Parser e d) where
- constant "" a = just a
- constant c a = commands Map.empty (Map.singleton c (just a))
- just a = Parser $ return ($ a)
- nothing = Parser $ return id
-instance Ord e => CLI_Env (Parser e d) where
- type EnvConstraint (Parser e d) a = (IOType a, FromSegment a)
- env' :: forall a k. EnvConstraint (Parser e d) a => Name -> Parser e d (a->k) k
- env' name = Parser $
- lift (lookupEnv name) >>= \case
- Nothing -> P.failure got exp
- where
- got = Nothing
- exp = Set.singleton $ P.Label $ NonEmpty.fromList $ "${"<>name<>"}"
- Just val ->
- lift (fromSegment val) >>= \case
- Right a -> return ($ a)
- Left err -> P.failure got exp
- where
- got = Just $ P.Tokens $ pure $ ArgEnv name val
- exp = Set.singleton $ P.Label $ NonEmpty.fromList $
- "${"<>name<>"} to be of type "<>ioType @a
- <> case err of
- "Prelude.read: no parse" -> ""
- "" -> ""
- _ -> ": "<>err
-instance Ord e => CLI_Response (Parser e d) where
- type ResponseConstraint (Parser e d) a = Outputable a
- type ResponseArgs (Parser e d) a = ParserResponseArgs a
- type Response (Parser e d) = ParserResponse
- response' = Parser $
- P.eof $> \({-ParserResponseArgs-} io) ->
- ParserResponse $ io >>= output
-instance Ord e => CLI_Help (Parser e d) where
- type HelpConstraint (Parser e d) d' = d ~ d'
- help _msg = id
- program n = Parser . P.label n . unParser
- rule n = Parser . P.label n . unParser
-
-concatCont :: [(a->k)->k] -> ([a]->k)->k
-concatCont = List.foldr (consCont (:)) ($ [])
-
-consCont :: (a->b->c) -> ((a->k)->k) -> ((b->k)->k) -> (c->k)->k
-consCont ab2c a2k2k b2k2k = \c2k -> a2k2k $ \a -> b2k2k $ \b -> c2k (ab2c a b)
-
-mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k)
-mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b)
-
--- ** Type 'ParserResponse'
-newtype ParserResponse = ParserResponse { unResponseParser :: IO () }
--- ** Type 'ParserResponseArgs'
-type ParserResponseArgs = IO
-
--- * Class 'Outputable'
--- | Output of a CLI.
-class IOType a => Outputable a where
- output :: a -> IO ()
- default output :: Show a => a -> IO ()
- output = IO.print
-
-instance Outputable () where
- output = return
-instance Outputable Bool
-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 BS.ByteString where
- output = BS.putStr
-instance Outputable BSL.ByteString where
- output = BSL.putStr
-instance Outputable (Doc.Plain TLB.Builder) where
- output =
- TL.putStr .
- TLB.toLazyText .
- Doc.runPlain
-
--- ** Type 'OnHandle'
-data OnHandle a = OnHandle IO.Handle a
-instance Functor OnHandle where
- fmap f (OnHandle h a) = OnHandle h (f 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 BS.ByteString) where
- output (OnHandle h a) = BS.hPutStr h a
-instance Outputable (OnHandle BSL.ByteString) where
- output (OnHandle h a) = BSL.hPutStr h a
-instance Outputable (OnHandle (Doc.Plain TLB.Builder)) where
- output (OnHandle h d) =
- TL.hPutStr h $
- TLB.toLazyText $
- Doc.runPlain d
-instance
- ( Outputable a
- , Reflection.Typeable a
- ) => Outputable (Maybe a) where
- output = \case
- Nothing -> System.exitWith (System.ExitFailure 1)
- Just a -> output a
-instance
- ( Reflection.Typeable e
- , Reflection.Typeable a
- , Outputable (OnHandle e)
- , Outputable a
- ) => Outputable (Either e a) where
- output = \case
- Left e -> do
- output (OnHandle IO.stderr e)
- System.exitWith (System.ExitFailure 1)
- Right a -> output a
-
--- * Class 'IOType'
--- | Like a MIME type but for input/output of a CLI.
-class IOType a where
- ioType :: String
- default ioType :: Reflection.Typeable a => String
- ioType = show (Reflection.typeRep @a)
-
-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 BS.ByteString
-instance IOType BSL.ByteString
-instance IOType (Doc.Plain TLB.Builder)
-instance Reflection.Typeable a => IOType (Maybe a)
-instance (Reflection.Typeable e, Reflection.Typeable a) => IOType (Either e a)
-
--- * Class 'FromSegment'
-class FromSegment a where
- fromSegment :: Segment -> IO (Either String a)
- default fromSegment :: Read a => Segment -> IO (Either String a)
- fromSegment = return . readEither
-instance FromSegment String where
- fromSegment = return . Right
-instance FromSegment Text.Text where
- fromSegment = return . Right . Text.pack
-instance FromSegment TL.Text where
- fromSegment = return . Right . TL.pack
-instance FromSegment Bool
-instance FromSegment Int
-instance FromSegment Integer
-instance FromSegment Natural
-
--- ** Type 'ParserSeq'
--- | Lift a 'Parser' to something working with 'Functor' and 'Applicative'.
--- Used to gather collected values into a single one,
--- which is for instance needed for using 'many0' on multiple 'var's.
-newtype ParserSeq e d k a = ParserSeq
- { unParserSeq :: Parser e d (a->k) k }
-instance Functor (ParserSeq e d k) where
- a2b `fmap` ParserSeq (Parser x) = ParserSeq $ Parser $ merge <$> x
- where merge = \a2k2k b2k -> a2k2k $ b2k . a2b
-instance Applicative (ParserSeq e d k) where
- pure a = ParserSeq $ Parser $ pure ($ a)
- ParserSeq (Parser f) <*> ParserSeq (Parser x) =
- ParserSeq $ Parser $ merge <$> f <*> x
- where merge a2b2k2k a2k2k b2k =
- a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
-
--- ** Type 'ParserPerm'
-data ParserPerm e d repr k a = ParserPerm
- { permutation_result :: !(Maybe ((a->k)->k))
- , permutation_parser :: repr () (ParserPerm e d repr k a)
- }
-
-instance (App repr, Functor (repr ())) => Functor (ParserPerm e d repr k) where
- a2b `fmap` ParserPerm a ma =
- ParserPerm (merge <$> a) ((a2b `fmap`) `fmap` ma)
- where merge = \a2k2k b2k -> a2k2k $ b2k . a2b
-instance (App repr, Functor (repr ()), Alternative (repr ())) =>
- Applicative (ParserPerm e d repr k) where
- pure a = ParserPerm (Just ($ a)) empty
- lhs@(ParserPerm f ma2b) <*> rhs@(ParserPerm x ma) =
- ParserPerm a (lhsAlt <|> rhsAlt)
- where
- a = merge <$> f <*> x
- lhsAlt = (<*> rhs) <$> ma2b
- rhsAlt = (lhs <*>) <$> ma
- merge a2b2k2k a2k2k b2k =
- a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
-instance CLI_Help repr => CLI_Help (ParserPerm e d repr) where
- type HelpConstraint (ParserPerm e d repr) d' = HelpConstraint (Parser e d) d'
- program _n = id
- rule _n = id
-
-noTransParserPerm ::
- Trans repr =>
- Functor (UnTrans repr ()) =>
- ParserPerm e d (UnTrans repr) k a -> ParserPerm e d repr k a
-noTransParserPerm (ParserPerm a ma) = ParserPerm a (noTrans $ noTransParserPerm <$> ma)
-
-unTransParserPerm ::
- Trans repr =>
- Functor (UnTrans repr ()) =>
- ParserPerm e d repr k a -> ParserPerm e d (UnTrans repr) k a
-unTransParserPerm (ParserPerm a ma) =
- ParserPerm a (unTransParserPerm <$> unTrans ma)
-
-hoistParserPerm ::
- Functor (repr ()) =>
- (forall a b. repr a b -> repr a b) ->
- ParserPerm e d repr k c -> ParserPerm e d repr k c
-hoistParserPerm f (ParserPerm a ma) =
- ParserPerm a (hoistParserPerm f <$> f ma)
-
--- ** Class 'CLI_Routing'
-class CLI_Routing repr where
- commands :: Map Name (repr a k) -> Map Name (repr a k) -> repr a k
- -- tags :: TagConstraint repr a => Map (Either Char Name) (repr (a -> k) k) -> repr (a -> k) k
-instance Ord e => CLI_Routing (Parser e d) where
- commands preCmds cmds = Parser $
- P.token check exp >>= unParser
- where
- exp = Set.fromList $ P.Tokens . pure . ArgSegment <$> Map.keys cmds
- check = \case
- ArgSegment cmd ->
- Map.lookup cmd cmds <|>
- Map.lookup cmd preCmds
- _ -> Nothing
-
--- * Type 'Router'
-data Router repr a b where
- -- | Lift any @(repr)@ into 'Router', those not useful to segregate
- -- wrt. the 'Trans'formation performed, aka. 'noTrans'.
- Router_Any :: repr a b -> Router repr a b
- -- | Represent 'commands'.
- Router_Commands ::
- Map Name (Router repr a k) ->
- Map Name (Router repr a k) ->
- Router repr a k
- -- | Represent 'tag'.
- Router_Tag :: Tag -> Router repr f k -> Router repr f k
- -- | Represent ('<.>').
- Router_App :: Router repr a b -> Router repr b c -> Router repr a c
- -- | Represent ('<!>').
- Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
- -- | Unify 'Router's which have different 'handlers'.
- -- Useful to put alternative 'Router's in a 'Map' as in 'Router_Commands'.
- Router_Union :: (b->a) -> Router repr a k -> Router repr b k
-
-instance Ord e => Functor (Router (Parser e d) f) where
- a2b`fmap`x = noTrans (a2b <$> unTrans x)
-instance Ord e => Applicative (Router (Parser e d) f) where
- pure = noTrans . pure
- f <*> x = noTrans (unTrans f <*> unTrans x)
-instance Ord e => Alternative (Router (Parser e d) f) where
- empty = noTrans empty
- f <|> x = noTrans (unTrans f <|> unTrans x)
-instance (repr ~ Parser e d) => Show (Router repr a b) where
- showsPrec p = \case
- Router_Any{} -> showString "X"
- Router_Commands _preCmds cmds -> showParen (p>=10) $ showString "Commands [" . go (Map.toList cmds) . showString "]"
- where
- go :: forall h k. [(Segment, Router repr h k)] -> ShowS
- go [] = id
- go ((n, r):xs) =
- (showParen True $ showString (show n<>", ") . showsPrec 0 r) .
- case xs of
- [] -> id
- _ -> showString ", " . go xs
- Router_Tag n x -> showsPrec 10 n . showString " " . showsPrec p x
- Router_App x y -> showParen (p>=4) $ showsPrec 4 x . showString " <.> " . showsPrec 4 y
- Router_Alt x y -> showParen (p>=3) $ showsPrec 3 x . showString " <!> " . showsPrec 3 y
- Router_Union _u x -> showString "Union [" . showsPrec 0 x . showString "]"
-instance Ord e => Trans (Router (Parser e d)) where
- type UnTrans (Router (Parser e d)) = Parser e d
- noTrans = Router_Any
- unTrans (Router_Any x) = x
- unTrans (Router_Alt x y) = unTrans x <!> unTrans y
- unTrans (Router_App x y) = unTrans x <.> unTrans y
- unTrans (Router_Commands preCmds cmds) = commands (unTrans <$> preCmds) (unTrans <$> cmds)
- unTrans (Router_Tag n x) = tag n (unTrans x)
- unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x)
-
-instance Ord e => App (Router (Parser e d)) where
- (<.>) = Router_App
-instance Ord e => Alt (Router (Parser e d)) where
- (<!>) = Router_Alt
- alt x y = Router_Union (\a -> a:!:a) $ Router_Alt x y
-instance Ord e => AltApp (Router (Parser e d))
-instance Ord e => Sequenceable (Router (Parser e d)) where
- type Sequence (Router (Parser e d)) = RouterParserSeq (ParserSeq e d)
- runSequence = noTrans . runSequence . unRouterParserSeq
- toSequence = RouterParserSeq . toSequence . unTrans
-instance Ord e => Permutable (Router (Parser e d)) where
- type Permutation (Router (Parser e d)) = ParserPerm e d (Router (Parser e d))
- runPermutation = noTrans . runPermutation . unTransParserPerm
- toPermutation = noTransParserPerm . toPermutation . unTrans
- toPermDefault a = noTransParserPerm . toPermDefault a . unTrans
-instance Ord e => Pro (Router (Parser e d))
-instance (repr ~ (Parser e d)) => CLI_Command (Router repr) where
- command "" x = x
- command n x =
- let is = List.tail $ List.inits n in
- let (preCmds, cmds) = List.splitAt (List.length is - 1) is in
- Router_Commands
- (Map.fromAscList $ (,x) <$> preCmds)
- (Map.fromAscList $ (,x) <$> cmds)
-instance Ord e => CLI_Var (Router (Parser e d))
-instance Ord e => CLI_Constant (Router (Parser e d))
-instance Ord e => CLI_Env (Router (Parser e d))
-instance Ord e => CLI_Tag (Router (Parser e d)) where
- tag = Router_Tag
-instance CLI_Help (Router (Parser e d)) where
- -- NOTE: set manually (instead of the 'Trans' default 'Router_Any')
- -- to remove them all, since they are useless for 'Parser'
- -- and may prevent patterns to be matched in 'router'.
- help _msg = id
- program _n = id
- rule _n = id
-instance Ord e => CLI_Response (Router (Parser e d))
-instance Ord e => CLI_Routing (Router (Parser e d)) where
- -- tags = Router_Tags
- commands = Router_Commands
-
-router ::
- repr ~ Parser e d =>
- Router repr a b -> Router repr a b
-router = {-debug1 "router" $-} \case
- x@Router_Any{} -> x
- Router_Tag n x -> Router_Tag n (router x)
- Router_Alt x y -> router x`router_Alt`router y
- Router_Commands preCmds cmds ->
- Router_Commands
- (router <$> preCmds)
- (router <$> cmds)
- Router_App xy z ->
- case xy of
- Router_App x y ->
- -- Associate to the right
- Router_App (router x) $
- Router_App (router y) (router z)
- _ -> router xy `Router_App` router z
- Router_Union u x -> Router_Union u (router x)
-
--- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
-router_Alt ::
- repr ~ Parser e d =>
- Router repr a k ->
- Router repr b k ->
- Router repr (a:!:b) k
-router_Alt = {-debug2 "router_Alt"-} go
- where
- -- Merge alternative commands together.
- go (Router_Commands xp xs) (Router_Commands yp ys) =
- Router_Commands
- (router_Commands False xp yp) -- NOTE: conflicting prefixes are dropped.
- (router_Commands True xs ys)
-
- -- Merge left first or right first, depending on which removes 'Router_Alt'.
- go x (y`Router_Alt`z) =
- case x`router_Alt`y of
- Router_Alt x' y' ->
- case y'`router_Alt`z of
- yz@(Router_Alt _y z') ->
- case x'`router_Alt`z' of
- Router_Alt{} -> router x'`Router_Alt`yz
- xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y
- -- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.
- yz -> x'`router_Alt`yz
- xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z
- go (x`Router_Alt`y) z =
- case y`router_Alt`z of
- Router_Alt y' z' ->
- case x`router_Alt`y' of
- xy@(Router_Alt x' _y) ->
- case x'`router_Alt`z' of
- Router_Alt{} -> xy`Router_Alt`router z'
- xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y
- -- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.
- xy -> xy`router_Alt`z'
- yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
-
- -- Merge through 'Router_Union'.
- go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)
- go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)
-
- -- No merging
- go x y = x`Router_Alt`y
-
-router_Commands ::
- repr ~ Parser e d =>
- Bool ->
- Map Segment (Router repr a k) ->
- Map Segment (Router repr b k) ->
- Map Segment (Router repr (a:!:b) k)
-router_Commands allowMerging =
- -- NOTE: a little bit more complex than required
- -- in order to merge 'Router_Union's instead of nesting them,
- -- such that 'unTrans' 'Router_Union' applies them all at once.
- Map.merge
- (Map.mapMissing $ const keepX)
- (Map.mapMissing $ const keepY)
- (Map.zipWithMaybeMatched $ const $ \x y ->
- if allowMerging then Just $ mergeFull x y else Nothing)
- where
- keepX = \case
- Router_Union u r -> Router_Union (\(x:!:_y) -> u x) r
- r -> Router_Union (\(x:!:_y) -> x) r
- keepY = \case
- Router_Union u r -> Router_Union (\(_x:!:y) -> u y) r
- r -> Router_Union (\(_x:!:y) -> y) r
- mergeFull = \case
- Router_Union xu xr -> \case
- Router_Union yu yr -> Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
- yr -> Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
- xr -> \case
- Router_Union yu yr -> Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
- yr -> xr`router_Alt`yr
-
--- ** Type 'RouterParserSeq'
-newtype RouterParserSeq repr k a = RouterParserSeq
- { unRouterParserSeq :: repr k a }
- deriving (Functor, Applicative)
-
--- * Type 'Arg'
-data Arg
- = ArgSegment Segment
- | ArgTagLong Name
- | ArgTagShort Char
- | ArgEnv Name String -- ^ Here only for error reporting.
- deriving (Eq,Ord,Show)
-
-lexer :: [String] -> [Arg]
-lexer ss =
- join $
- (`evalState` False) $
- sequence (f <$> ss)
- where
- f :: String -> StateT Bool Identity [Arg]
- f s = do
- skip <- get
- if skip then return [ArgSegment s]
- else case s of
- '-':'-':[] -> do
- put True
- return [ArgTagLong ""]
- '-':'-':cs -> return [ArgTagLong cs]
- '-':cs@(_:_) -> return $ ArgTagShort <$> cs
- seg -> return [ArgSegment seg]
-
-showArg :: Arg -> String
-showArg = \case
- ArgTagShort t -> '-':[t]
- ArgTagLong t -> '-':'-':t
- ArgSegment seg -> seg
- ArgEnv name val -> name<>"="<>val
-
-showArgs :: [Arg] -> String
-showArgs args = List.intercalate " " $ showArg <$> args
-
-instance P.Stream [Arg] where
- type Token [Arg] = Arg
- type Tokens [Arg] = [Arg]
- tokenToChunk Proxy = pure
- tokensToChunk Proxy = id
- chunkToTokens Proxy = id
- chunkLength Proxy = List.length
- chunkEmpty Proxy = List.null
- take1_ [] = Nothing
- take1_ (t:ts) = Just (t, ts)
- takeN_ n s
- | n <= 0 = Just ([], s)
- | List.null s = Nothing
- | otherwise = Just (List.splitAt n s)
- takeWhile_ = List.span
- showTokens Proxy = showArgs . toList
- -- NOTE: those make no sense when parsing a command line,
- -- and should not be called since 'P.errorBundlePretty' is not used in 'parser'.
- reachOffset = error "BUG: reachOffset must not be used on [Arg]"
- reachOffsetNoLine = error "BUG: reachOffsetNoLine must not be used on [Arg]"
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
-module Symantic.CLI.Schema where
-
-import Control.Applicative (Applicative(..))
-import Data.Bool
-import Data.Char (Char)
-import Data.Function (($), (.), id)
-import Data.Functor (Functor(..), (<$>))
-import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
-import Data.Monoid (Monoid(..))
-import Data.Semigroup (Semigroup(..))
-import Data.String (String, IsString(..))
-import Data.Text (Text)
-import Text.Show (Show(..))
-import qualified Data.List as List
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Builder as TLB
-import qualified Symantic.Document as Doc
-
-import Symantic.CLI.API
-import Symantic.CLI.Fixity
-
--- * Type 'Schema'
-newtype Schema d f k
- = Schema { unSchema :: SchemaInh d -> Maybe d }
-
-runSchema :: Monoid d => Schema d f k -> SchemaInh d -> d
-runSchema (Schema s) = fromMaybe mempty . s
-
-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{..}
-
--- ** Class 'SchemaDoc'
-type SchemaDoc d =
- ( Semigroup d
- , Monoid d
- , IsString d
- , Doc.Colorable16 d
- , Doc.Decorable d
- , Doc.Spaceable d
- , Doc.Indentable d
- , Doc.Wrappable d
- , Doc.From (Doc.Word Char) d
- , Doc.From (Doc.Word Text) d
- , Doc.From (Doc.Word String) d
- )
-
--- ** Type 'SchemaInh'
--- | Inherited top-down.
-data SchemaInh d
- = SchemaInh
- { schemaInh_op :: (Infix, Side) -- ^ Parent operator.
- , schemaInh_define :: Bool -- ^ Whether to print a definition, or not.
- , schemaInh_or :: d -- ^ The separator to use between alternatives.
- }
-
-defSchemaInh :: SchemaDoc d => SchemaInh d
-defSchemaInh = SchemaInh
- { schemaInh_op = (infixN0, SideL)
- , schemaInh_define = True
- , schemaInh_or = docOrH
- }
-
-pairIfNeeded :: SchemaDoc d => (Infix, Side) -> Infix -> d -> d
-pairIfNeeded opInh op =
- if needsParenInfix opInh op
- then Doc.align . Doc.parens
- else id
-
-instance Semigroup d => Semigroup (Schema d f k) where
- Schema x <> Schema y = Schema $ x <> y
-instance (Semigroup d, Monoid d) => Monoid (Schema d f k) where
- mempty = Schema mempty
- mappend = (<>)
-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.Plain TLB.Builder) a k) where
- show =
- TL.unpack .
- TLB.toLazyText .
- Doc.runPlain .
- docSchema
-
-docOrH, docOrV :: Doc.Spaceable d => Doc.From (Doc.Word Char) d => d
-docOrH = Doc.space <> Doc.from (Doc.Word '|') <> Doc.space
-docOrV = Doc.newline <> Doc.from (Doc.Word '|') <> Doc.space
-
-{-
-instance SchemaDoc d => Functor (Schema d f) where
- _f `fmap` Schema x = Schema $ \inh ->
- pairIfNeeded (schemaInh_op inh) op <$>
- x inh{schemaInh_op=(op, SideR)}
- where
- op = infixB SideL 10
--}
-instance SchemaDoc d => App (Schema d) where
- Schema f <.> Schema x = Schema $ \inh ->
- 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 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 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 l inh
- { schemaInh_op=(op, SideL)
- , schemaInh_or=docOrH } <>
- docOrH <>
- runSchema r inh
- { schemaInh_op=(op, SideR)
- , schemaInh_or=docOrH })
- (Doc.align $
- Doc.parens $
- Doc.space <>
- runSchema l inh
- { schemaInh_op=(op, SideL)
- , schemaInh_or=docOrV } <>
- docOrV <>
- runSchema r inh
- { schemaInh_op=(op, SideR)
- , schemaInh_or=docOrV } <>
- Doc.newline)
- else
- -- 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 r inh{schemaInh_op=(op, SideR)}
- where op = infixB SideL 2
- alt x y = coerceSchema $ coerceSchema x <!> coerceSchema y
- opt s = Schema $ \inh -> Just $
- Doc.brackets $
- runSchema s inh{schemaInh_op=(op, SideL)}
- where op = infixN0
-instance SchemaDoc d => Sequenceable (Schema d) where
- type Sequence (Schema d) = SchemaSeq d
- runSequence (SchemaSeq fin ps) =
- case ps of
- [] -> fin $ Schema $ \_inh -> Nothing
- _ -> fin $ Schema $ \inh -> Just $
- pairIfNeeded (schemaInh_op inh) op $
- Doc.intercalate Doc.breakspace $
- catMaybes $ (<$> ps) $ \(Schema s) ->
- s inh
- { schemaInh_op=(op, SideL)
- , schemaInh_or=docOrH }
- where op = infixN 10
- toSequence = SchemaSeq id . pure
-instance SchemaDoc d => Permutable (Schema d) where
- type Permutation (Schema d) = SchemaPerm d
- runPermutation (SchemaPerm fin ps) =
- case ps of
- [] -> fin $ Schema $ \_inh -> Nothing
- _ -> fin $ Schema $ \inh -> Just $
- pairIfNeeded (schemaInh_op inh) op $
- Doc.intercalate Doc.breakspace $
- catMaybes $ (<$> ps) $ \(Schema s) ->
- s inh
- { schemaInh_op=(op, SideL)
- , schemaInh_or=docOrH }
- 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.brackets $
- runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH}
- else
- runSchema s inh{schemaInh_op=(op, SideL)}
- where op = infixN0
-instance Pro (Schema d) where
- dimap _a2b _b2a = coerceSchema
-instance SchemaDoc d => AltApp (Schema d) where
- many0 s = Schema $ \inh -> Just $
- pairIfNeeded (schemaInh_op inh) op $
- runSchema s inh{schemaInh_op=(op, SideL)}<>"*"
- where op = infixN 11
- many1 s = Schema $ \inh -> Just $
- pairIfNeeded (schemaInh_op inh) op $
- runSchema s inh{schemaInh_op=(op, SideL)}<>"+"
- where op = infixN 11
-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}
- else ref
- where
- ref =
- Doc.bold $
- Doc.angles $
- Doc.magentaer $
- Doc.from (Doc.Word n)
-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
-instance SchemaDoc d => CLI_Constant (Schema d) where
- constant c _a = Schema $ \_inh -> Just $
- Doc.from (Doc.Word c)
- just _ = Schema $ \_inh -> Nothing
- nothing = Schema $ \_inh -> Nothing
-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 SchemaDoc d => CLI_Tag (Schema d) where
- type TagConstraint (Schema d) a = ()
- tag n r = Schema $ \inh ->
- unSchema (prefix n <.> r) inh
- where
- prefix = \case
- Tag s l -> prefix (TagShort s)<>"|"<>prefix (TagLong l)
- TagShort s -> fromString ['-', s]
- TagLong l -> fromString ("--"<>l)
- endOpts = Schema $ \_inh -> Just $ Doc.brackets "--"
-instance SchemaDoc d => CLI_Help (Schema d) where
- type HelpConstraint (Schema d) d' = d ~ d'
- help _msg = id
- program n s = Schema $ \inh -> Just $
- runSchema
- (fromString n <.> coerceSchema s)
- inh{schemaInh_define = False}
- rule n s = Schema $ \inh -> Just $
- if schemaInh_define inh
- then runSchema s inh{schemaInh_define=False}
- else ref
- where
- ref =
- Doc.bold $
- Doc.angles $
- Doc.magentaer $
- Doc.from (Doc.Word n)
-data SchemaResponseArgs a
-instance SchemaDoc d => CLI_Response (Schema d) where
- type ResponseConstraint (Schema d) a = ()
- type ResponseArgs (Schema d) a = SchemaResponseArgs a
- type Response (Schema d) = ()
- response' = Schema $ \_inh -> Nothing
-
--- ** Type 'SchemaSeq'
-data SchemaSeq d k a = SchemaSeq
- { schemaSeq_finalizer :: forall b c.
- Schema d (b->c) c ->
- Schema d (b->c) c
- -- ^ Used to implement 'rule'.
- , schemaSeq_alternatives :: [Schema d (a->k) k]
- -- ^ Collect alternatives for rendering them all at once in 'runSequence'.
- }
-instance Functor (SchemaSeq d k) where
- _f`fmap`SchemaSeq fin ps = SchemaSeq fin (coerceSchema <$> ps)
-instance Applicative (SchemaSeq d k) where
- pure _a = SchemaSeq id mempty
- SchemaSeq fd f <*> SchemaSeq fx x =
- SchemaSeq (fd . fx) $ (coerceSchema <$> f) <> (coerceSchema <$> x)
-instance SchemaDoc d => CLI_Help (SchemaSeq d) where
- type HelpConstraint (SchemaSeq d) d' = d ~ d'
- help _msg = id
- program n (SchemaSeq fin ps) = SchemaSeq (program n . fin) ps
- rule n (SchemaSeq fin ps) = SchemaSeq (rule n . fin) ps
-
--- ** Type 'SchemaPerm'
-data SchemaPerm d k a = SchemaPerm
- { 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 fin ps = SchemaPerm fin (coerceSchema <$> ps)
-instance Applicative (SchemaPerm d k) where
- pure _a = SchemaPerm id mempty
- SchemaPerm fd f <*> SchemaPerm fx x =
- SchemaPerm (fd . fx) $ (coerceSchema <$> f) <> (coerceSchema <$> x)
-instance SchemaDoc d => CLI_Help (SchemaPerm d) where
- type HelpConstraint (SchemaPerm d) d' = d ~ d'
- help _msg = id
- program n (SchemaPerm fin ps) = SchemaPerm (program n . fin) ps
- rule n (SchemaPerm fin ps) = SchemaPerm (rule n . fin) ps
+++ /dev/null
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Symantic.CLI.Test where
-
--- import Data.Monoid (Monoid(..))
--- import Data.Ord (Ord(..))
--- import Text.Show (Show(..))
-import Control.Applicative (Applicative(..), Alternative(..))
-import Control.Monad (Monad(..))
-import Data.Bool
-import Data.Ord (Ord(..))
-import Data.Either (Either(..))
-import Data.Function (($), (.))
-import Data.Functor ((<$>))
-import Data.List.NonEmpty (NonEmpty(..))
-import Data.Maybe (Maybe(..))
-import Data.Semigroup (Semigroup(..))
-import Data.String (String)
-import Data.Void (Void)
-import Text.Show (Show(..))
-import Type.Reflection (Typeable)
-import System.IO (IO, print, stderr, putStrLn)
-import System.Environment (getArgs)
-import Data.Int (Int)
-import qualified Data.Set as Set
-import qualified Data.Text.Lazy.IO as TL
-import qualified Symantic.Document.Term as Doc
-import qualified Symantic.Document.Term.IO as DocIO
-import qualified System.IO as IO
-
-import Symantic.CLI
-
-data Opts = Opts
- { opts_git_dir :: String
- , opts_work_tree :: String
- , opts_int :: Int
- } deriving (Show)
-
-api =
- -- rule "main" $
- (rule "OPTIONS" $
- Opts <$> longOpt "git-dir" "GIT_DIR" (var "path")
- <*> longOpt "work-tree" "X" (var "path")
- <*> longOpt "int" 0 (var "name"))
- <?>
- rule "INFOS" (
- api_clone
- <!> api_push
- <!> api_fetch
- <!> api_help
- <!> api_version
- )
-
-help_ d = help (d::DocIO.TermIO)
-
-api_help =
- help_ "print some help" $
- tagged (Tag 'h' "help") nothing
- <.> response @DocIO.TermIO
-
-api_version =
- help_ "print the version" $
- tagged (TagLong "version") nothing
- <.> response @String
-
-api_clone =
- help_ "cloned" $
- command "clone" $
- (Clone <$> longOpt "branch" "master" (var "name"))
- <?> response @(Opts,Clone)
-
-api_push =
- command "push" $
- (Push <$> longOpt "set-upstream" False (just True)
- <*> longOpt "all" False (just True))
- <?> endOpts
- <.> many1 (var @String "refspec")
- <.> response @(Opts,Push,[String])
-
-api_fetch =
- command "fetch" $
- response @Opts
-
-data Clone = Clone String
- deriving (Show)
-data Push = Push Bool Bool
- deriving (Show)
-
-doc0 = DocIO.runTermIO IO.stderr $ plainDoc api
-help0 = DocIO.runTermIO IO.stderr $ helpDoc api
-route_git gitOpts =
- route_clone :!:
- route_push :!:
- route_fetch :!:
- route_help :!:
- route_version
- where
- route_help = return $ helpDoc api
- route_version = return "1.0"
- route_clone (cloneOpts::Clone) =
- return (gitOpts,cloneOpts)
- route_push pushOpts refs =
- return (gitOpts,pushOpts,refs)
- route_fetch =
- return (gitOpts)
-
-instance Typeable (a,b) => IOType (a,b)
-instance Typeable (a,b,c) => IOType (a,b,c)
-instance IOType Opts
-instance (Show (a,b), Typeable (a,b)) => Outputable (a,b)
-instance (Show (a,b,c), Typeable (a,b,c)) => Outputable (a,b,c)
-instance Outputable Opts
-
-parser0 = parser api route_git
-main :: IO ()
-main = do
- args <- getArgs
- putStrLn $ "args: " <> show args
- parser0 $ parseArgs args
--- /dev/null
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE UndecidableInstances #-} -- for type instance defaults
+module Symantic.CLI.API where
+
+import Data.Bool
+import Data.Char (Char)
+import Data.Eq (Eq)
+import Data.Function (($), (.), id)
+import Data.Kind (Constraint)
+import Data.Maybe (Maybe(..), fromJust)
+import Data.String (String, IsString(..))
+import Text.Show (Show)
+
+-- * Class 'App'
+class App repr where
+ (<.>) :: repr a b -> repr b c -> repr a c
+ -- Trans defaults
+ default (<.>) ::
+ Trans repr =>
+ App (UnTrans repr) =>
+ repr a b -> repr b c -> repr a c
+ x <.> y = noTrans (unTrans x <.> unTrans y)
+infixr 4 <.>
+
+-- * Class 'Alt'
+class Alt repr where
+ (<!>) :: repr a k -> repr b k -> repr (a:!:b) k
+ alt :: repr a k -> repr a k -> repr a k
+ opt :: repr (a->k) k -> repr (Maybe a->k) k
+ -- Trans defaults
+ default (<!>) ::
+ Trans repr =>
+ Alt (UnTrans repr) =>
+ repr a k -> repr b k -> repr (a:!:b) k
+ default alt ::
+ Trans repr =>
+ Alt (UnTrans repr) =>
+ repr a k -> repr a k -> repr a k
+ default opt ::
+ Trans repr =>
+ Alt (UnTrans repr) =>
+ repr (a->k) k -> repr (Maybe a->k) k
+ x <!> y = noTrans (unTrans x <!> unTrans y)
+ x `alt` y = noTrans (unTrans x `alt` unTrans y)
+ opt = noTrans . opt . unTrans
+-- NOTE: yes infixr, not infixl like <|>,
+-- in order to run left-most checks first.
+infixr 3 <!>
+infixr 3 `alt`
+
+-- ** Type (':!:')
+-- | Like @(,)@ but @infixr@.
+data (:!:) a b = a:!:b
+infixr 3 :!:
+
+-- * Class 'Pro'
+class Pro repr where
+ dimap :: (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
+ -- Trans defaults
+ default dimap ::
+ Trans repr =>
+ Pro (UnTrans repr) =>
+ (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k
+ dimap a2b b2a = noTrans . dimap a2b b2a . unTrans
+
+-- * Class 'AltApp'
+class AltApp repr where
+ many0 :: repr (a->k) k -> repr ([a]->k) k
+ many1 :: repr (a->k) k -> repr ([a]->k) k
+ -- Trans defaults
+ default many0 ::
+ Trans repr =>
+ AltApp (UnTrans repr) =>
+ repr (a->k) k -> repr ([a]->k) k
+ default many1 ::
+ Trans repr =>
+ AltApp (UnTrans repr) =>
+ repr (a->k) k -> repr ([a]->k) k
+ many0 = noTrans . many0 . unTrans
+ many1 = noTrans . many1 . unTrans
+
+-- * Class 'Permutable'
+class Permutable repr where
+ -- NOTE: Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
+ type Permutation (repr:: * -> * -> *) = (r :: * -> * -> *) | r -> repr
+ type Permutation repr = Permutation (UnTrans repr)
+ runPermutation :: Permutation repr k a -> repr (a->k) k
+ toPermutation :: repr (a->k) k -> Permutation repr k a
+ toPermDefault :: a -> repr (a->k) k -> Permutation repr k a
+
+-- | Convenient wrapper to omit a 'runPermutation'.
+--
+-- @
+-- opts '<?>' next = 'runPermutation' opts '<.>' next
+-- @
+(<?>) ::
+ App repr => Permutable repr =>
+ Permutation repr b a -> repr b c -> repr (a->b) c
+opts <?> next = runPermutation opts <.> next
+infixr 4 <?>
+
+-- * Class 'Sequenceable'
+class Sequenceable repr where
+ -- NOTE: Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
+ type Sequence (repr:: * -> * -> *) = (r :: * -> * -> *) | r -> repr
+ type Sequence repr = Sequence (UnTrans repr)
+ runSequence :: Sequence repr k a -> repr (a->k) k
+ toSequence :: repr (a->k) k -> Sequence repr k a
+
+-- * Type 'Name'
+type Name = String
+
+-- * Type 'Segment'
+type Segment = String
+
+-- * Class 'CLI_Command'
+class CLI_Command repr where
+ command :: Name -> repr a k -> repr a k
+
+-- * Class 'CLI_Var'
+class CLI_Var repr where
+ type VarConstraint repr a :: Constraint
+ var' :: VarConstraint repr a => Name -> repr (a->k) k
+ -- Trans defaults
+ type VarConstraint repr a = VarConstraint (UnTrans repr) a
+ default var' ::
+ Trans repr =>
+ CLI_Var (UnTrans repr) =>
+ VarConstraint (UnTrans repr) a =>
+ Name -> repr (a->k) k
+ var' = noTrans . var'
+
+-- | Like 'var'' but with the type variable @(a)@ first instead or @(repr)@
+-- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
+var ::
+ forall a k repr.
+ CLI_Var repr =>
+ VarConstraint repr a =>
+ Name -> repr (a->k) k
+var = var'
+{-# INLINE var #-}
+
+-- * Class 'CLI_Var'
+class CLI_Constant repr where
+ constant :: Segment -> a -> repr (a->k) k
+ just :: a -> repr (a->k) k
+ nothing :: repr k k
+ default constant ::
+ Trans repr =>
+ CLI_Constant (UnTrans repr) =>
+ Segment -> a -> repr (a->k) k
+ default just ::
+ Trans repr =>
+ CLI_Constant (UnTrans repr) =>
+ a -> repr (a->k) k
+ default nothing ::
+ Trans repr =>
+ CLI_Constant (UnTrans repr) =>
+ repr k k
+ constant s = noTrans . constant s
+ just = noTrans . just
+ nothing = noTrans nothing
+
+-- * Class 'CLI_Env'
+class CLI_Env repr where
+ type EnvConstraint repr a :: Constraint
+ env' :: EnvConstraint repr a => Name -> repr (a->k) k
+ -- Trans defaults
+ type EnvConstraint repr a = EnvConstraint (UnTrans repr) a
+ default env' ::
+ Trans repr =>
+ CLI_Env (UnTrans repr) =>
+ EnvConstraint (UnTrans repr) a =>
+ Name -> repr (a->k) k
+ env' = noTrans . env'
+
+-- | Like 'env'' but with the type enviable @(a)@ first instead or @(repr)@
+-- so it can be passed using 'TypeApplications' without adding a |\@_| for @(repr)@.
+env ::
+ forall a k repr.
+ CLI_Env repr =>
+ EnvConstraint repr a =>
+ Name -> repr (a->k) k
+env = env'
+{-# INLINE env #-}
+
+-- ** Type 'Tag'
+data Tag
+ = Tag Char Name
+ | TagLong Name
+ | TagShort Char
+ deriving (Eq, Show)
+instance IsString Tag where
+ fromString = \case
+ [c] -> TagShort c
+ c:'|':cs -> Tag c cs
+ cs -> TagLong cs
+
+-- * Class 'CLI_Tag'
+class (App repr, Permutable repr, CLI_Constant repr) => CLI_Tag repr where
+ type TagConstraint repr a :: Constraint
+ tag :: Tag -> repr f k -> repr f k
+ -- tag n = (tag n <.>)
+ endOpts :: repr k k
+
+ flag :: TagConstraint repr Bool => Tag -> Permutation repr k Bool
+ flag n = toPermDefault False $ tag n $ just True
+
+ optionalTag ::
+ TagConstraint repr a => AltApp repr => Alt repr => Pro repr =>
+ Tag -> repr (a->k) k -> Permutation repr k (Maybe a)
+ optionalTag n = toPermDefault Nothing . tag n . dimap Just fromJust
+
+ defaultTag ::
+ TagConstraint repr a =>
+ Tag -> a -> repr (a->k) k -> Permutation repr k a
+ defaultTag n a = toPermDefault a . tag n
+
+ requiredTag ::
+ TagConstraint repr a =>
+ Tag -> repr (a->k) k -> Permutation repr k a
+ requiredTag n = toPermutation . tag n
+
+ many0Tag ::
+ TagConstraint repr a => AltApp repr =>
+ Tag -> repr (a->k) k -> Permutation repr k [a]
+ many0Tag n = toPermDefault [] . many1 . tag n
+ many1Tag ::
+ TagConstraint repr a => AltApp repr =>
+ Tag -> repr (a->k) k -> Permutation repr k [a]
+ many1Tag n = toPermutation . many1 . tag n
+
+ -- Trans defaults
+ type TagConstraint repr a = TagConstraint (UnTrans repr) a
+ default tag ::
+ Trans repr =>
+ CLI_Tag (UnTrans repr) =>
+ Tag -> repr f k -> repr f k
+ default endOpts ::
+ Trans repr =>
+ CLI_Tag (UnTrans repr) =>
+ repr k k
+ tag n = noTrans . tag n . unTrans
+ endOpts = noTrans endOpts
+
+-- * Class 'CLI_Response'
+class CLI_Response repr where
+ type ResponseConstraint repr a :: Constraint
+ type ResponseArgs repr a :: * -- = (r:: *) | r -> a
+ type Response repr :: *
+ response' ::
+ ResponseConstraint repr a =>
+ repr (ResponseArgs repr a)
+ (Response repr)
+ -- Trans defaults
+ type ResponseConstraint repr a = ResponseConstraint (UnTrans repr) a
+ type ResponseArgs repr a = ResponseArgs (UnTrans repr) a
+ type Response repr = Response (UnTrans repr)
+ default response' ::
+ forall a.
+ Trans repr =>
+ CLI_Response (UnTrans repr) =>
+ ResponseConstraint (UnTrans repr) a =>
+ ResponseArgs repr a ~ ResponseArgs (UnTrans repr) a =>
+ Response repr ~ Response (UnTrans repr) =>
+ repr (ResponseArgs repr a)
+ (Response repr)
+ response' = noTrans (response' @_ @a)
+
+response ::
+ forall a repr.
+ CLI_Response repr =>
+ ResponseConstraint repr a =>
+ repr (ResponseArgs repr a)
+ (Response repr)
+response = response' @repr @a
+{-# INLINE response #-}
+
+-- * Class 'CLI_Help'
+class CLI_Help repr where
+ type HelpConstraint repr d :: Constraint
+ help :: HelpConstraint repr d => d -> repr f k -> repr f k
+ help _msg = id
+ program :: Name -> repr f k -> repr f k
+ rule :: Name -> repr f k -> repr f k
+ -- Trans defaults
+ type HelpConstraint repr d = HelpConstraint (UnTrans repr) d
+ default program ::
+ Trans repr =>
+ CLI_Help (UnTrans repr) =>
+ Name -> repr f k -> repr f k
+ default rule ::
+ Trans repr =>
+ CLI_Help (UnTrans repr) =>
+ Name -> repr f k -> repr f k
+ program n = noTrans . program n . unTrans
+ rule n = noTrans . rule n . unTrans
+infixr 0 `help`
+
+-- * Type 'Trans'
+class Trans repr where
+ -- | The @(repr)@esentation that @(repr)@ 'Trans'forms.
+ type UnTrans repr :: * -> * -> *
+ -- | Lift the underlying @(repr)@esentation to @(repr)@.
+ -- Useful to define a combinator that does nothing in a 'Trans'formation.
+ noTrans :: UnTrans repr a b -> repr a b
+ -- | Unlift a @(repr)@esentation. Useful when a 'Trans'formation
+ -- combinator needs to access the 'UnTrans'formed @(repr)@esentation,
+ -- or at the end to get the underlying 'UnTrans'formed @(repr)@esentation
+ -- from the inferred @(repr)@ value (eg. in 'server').
+ unTrans :: repr a b -> UnTrans repr a b
-- needs to be enclosed by parenthesis.
needsParenInfix :: (Infix, Side) -> Infix -> Bool
needsParenInfix (po, lr) op =
- infix_prece op < infix_prece po
- || infix_prece op == infix_prece po
- && Bool.not associate
- where
- associate =
- case (lr, infix_assoc po) of
- (_, Just AssocB{}) -> True
- (SideL, Just AssocL) -> True
- (SideR, Just AssocR) -> True
- _ -> False
+ infix_prece op < infix_prece po
+ || infix_prece op == infix_prece po
+ && Bool.not associate
+ where
+ associate =
+ case (lr, infix_assoc po) of
+ (_, Just AssocB{}) -> True
+ (SideL, Just AssocL) -> True
+ (SideR, Just AssocR) -> True
+ _ -> False
-- * Type 'Precedence'
type Precedence = Int
-- ** Class 'PrecedenceOf'
class PrecedenceOf a where
- precedence :: a -> Precedence
+ precedence :: a -> Precedence
instance PrecedenceOf Fixity where
- precedence (Fixity1 uni) = precedence uni
- precedence (Fixity2 inf) = precedence inf
+ precedence (Fixity1 uni) = precedence uni
+ precedence (Fixity2 inf) = precedence inf
instance PrecedenceOf Unifix where
- precedence = unifix_prece
+ precedence = unifix_prece
instance PrecedenceOf Infix where
- precedence = infix_prece
+ precedence = infix_prece
-- * Type 'Associativity'
data Associativity
--- /dev/null
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
+module Symantic.CLI.Help where
+
+import Control.Applicative (Applicative(..))
+import Data.Bool
+import Data.Foldable (null)
+import Data.Function (($), (.))
+import Data.Functor (Functor(..), (<$>))
+import Data.Maybe (Maybe(..), maybe, isJust)
+import Data.Monoid (Monoid(..))
+import Data.Semigroup (Semigroup(..))
+import Text.Show (Show(..))
+import Data.Tree as Tree
+import qualified Symantic.Document as Doc
+
+import Symantic.CLI.API
+import Symantic.CLI.Schema as Schema
+
+-- * Type 'Help'
+data Help d f k
+ = Help
+ { help_result :: HelpInh d -> HelpResult d
+ -- ^ The 'HelpResult' of the current symantic.
+ , help_schema :: Schema d f k
+ -- ^ The 'Schema' of the current symantic.
+ }
+
+runHelp :: SchemaDoc d => HelpInh d -> Help d f k -> d
+runHelp def (Help h _p) = runHelpNodes def (h def) <> Doc.newline
+
+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'
+coerceHelp Help{help_schema, ..} = Help
+ { help_schema = Schema.coerceSchema help_schema
+ , ..
+ }
+
+-- ** Type 'HelpInh'
+-- | Configuration inherited top-down.
+data HelpInh d
+ = HelpInh
+ { helpInh_message :: !(Maybe d)
+ -- ^ The message inherited from 'help's.
+ , helpInh_command_indent :: !Doc.Indent
+ -- ^ 'Doc.Indent'ation for 'command's.
+ , helpInh_tag_indent :: !Doc.Indent
+ -- ^ 'Doc.Indent'ation for 'Tag's.
+ , helpInh_schema :: !(SchemaInh d)
+ -- ^ The inherited 'SchemaInh' for 'runSchema'.
+ , helpInh_helpless_options :: !Bool
+ -- ^ Whether to include options without help in the listing.
+ , helpInh_command_rule :: !Bool
+ -- ^ Whether to print the name of the rule.
+ , helpInh_full :: !Bool
+ -- ^ Whether to print full help.
+ }
+
+defHelpInh :: SchemaDoc d => HelpInh d
+defHelpInh = HelpInh
+ { helpInh_message = Nothing
+ , helpInh_command_indent = 2
+ , helpInh_tag_indent = 16
+ , helpInh_schema = defSchemaInh
+ , helpInh_helpless_options = False
+ , helpInh_command_rule = False
+ , helpInh_full = True
+ }
+
+-- ** Type 'HelpResult'
+type HelpResult d = Tree.Forest (HelpNode, d)
+
+defHelpResult :: Monoid d => HelpResult d
+defHelpResult = mempty
+
+-- *** Type 'HelpNode'
+data HelpNode
+ = HelpNode_Message
+ | HelpNode_Rule
+ | HelpNode_Command
+ | HelpNode_Tag
+ | HelpNode_Env
+ deriving Show
+
+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 :: SchemaDoc d => HelpInh d -> Tree.Forest (HelpNode, d) -> d
+runHelpNodes _inh [] = mempty
+runHelpNodes inh ( t0@(Tree.Node _ t0s)
+ : t1@(Tree.Node (HelpNode_Command, _) _) : ts ) =
+ runHelpNode t0 <>
+ Doc.newline <>
+ (if null t0s || not (helpInh_full inh) then mempty else Doc.newline) <>
+ runHelpNodes inh (t1:ts)
+runHelpNodes inh ( t0@(Tree.Node (HelpNode_Tag, _) _)
+ : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
+ runHelpNode t0 <>
+ Doc.newline <>
+ runHelpNodes inh (t1:ts)
+runHelpNodes inh ( t0@(Tree.Node (HelpNode_Rule, _) t0s)
+ : t1@(Tree.Node (_, _) _) : ts ) =
+ runHelpNode t0 <>
+ Doc.newline <>
+ (if null t0s || not (helpInh_full inh) then mempty else Doc.newline) <>
+ runHelpNodes inh (t1:ts)
+runHelpNodes inh ( t0@(Tree.Node (HelpNode_Message, _) _)
+ : t1 : ts ) =
+ runHelpNode t0 <>
+ Doc.newline <>
+ Doc.newline <>
+ runHelpNodes inh (t1:ts)
+runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
+ runHelpNode t0 <>
+ Doc.newline <>
+ Doc.newline <>
+ runHelpNodes inh (t1:ts)
+runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
+ runHelpNode t0 <>
+ Doc.newline <>
+ Doc.newline <>
+ runHelpNodes inh (t1:ts)
+runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Rule, _) _) : ts ) =
+ runHelpNode t0 <>
+ Doc.newline <>
+ runHelpNodes inh (t1:ts)
+runHelpNodes inh (t:ts) = runHelpNode t <> runHelpNodes inh ts
+
+instance Semigroup d => Semigroup (Help d f k) where
+ Help hx px <> Help hy py = Help (hx<>hy) (px<>py)
+instance Monoid d => Monoid (Help d f k) where
+ mempty = Help mempty mempty
+ mappend = (<>)
+{-
+instance (Semigroup d, IsString d) => IsString (Help d e s a) where
+ fromString "" = Help $ \_ro -> Nothing
+ fromString s = Help $ \_ro -> Just $ fromString s
+instance Show (Help Doc.Term e s a) where
+ show = TL.unpack . Doc.textTerm . runHelp
+instance SchemaDoc d => Functor (Help d f) where
+ f <$$> Help h s = Help h (f<$$>s)
+-}
+instance SchemaDoc d => App (Help d) where
+ Help hf pf <.> Help hx px = Help (hf<>hx) (pf<.>px)
+instance SchemaDoc d => Alt (Help d) where
+ Help hl pl <!> Help hr pr = Help (hl<>hr) (pl<!>pr)
+ Help hl pl `alt` Help hr pr = Help (hl<>hr) (pl`alt`pr)
+ opt (Help h s) = Help h (opt s)
+ {-
+ try (Help h s) = Help h (try s)
+ choice hs = Help (mconcat $ help_result <$> hs) (choice (help_schema <$> hs))
+ option a (Help h s) = Help h (option a s)
+ -}
+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 SchemaDoc d => AltApp (Help d) where
+ many0 (Help h s) = Help h (many0 s)
+ many1 (Help h s) = Help h (many1 s)
+instance SchemaDoc d => CLI_Var (Help d) where
+ type VarConstraint (Help d) a = ()
+ var' n = Help mempty (var' n)
+instance SchemaDoc d => CLI_Constant (Help d) where
+ constant n a = Help mempty (constant n a)
+ just a = Help mempty (just a)
+ nothing = Help mempty nothing
+instance SchemaDoc d => CLI_Env (Help d) where
+ type EnvConstraint (Help d) a = ()
+ env' n =
+ Help (\inh ->
+ let
+ ts =
+ if helpInh_full inh
+ then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
+ else []
+ d =
+ 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)
+ <> Doc.align (runHelpNodes inh ts)
+ in [ Tree.Node (HelpNode_Env, d) ts ]
+ ) schema
+ where schema = env' n
+instance SchemaDoc d => CLI_Command (Help d) where
+ -- type CommandConstraint (Help d) a = ()
+ command n (Help h s) =
+ Help (\inh ->
+ let
+ ts =
+ (if helpInh_full inh
+ then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
+ else []) <>
+ h inh
+ { helpInh_message = Nothing
+ , helpInh_command_rule = True
+ }
+ 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 (Doc.spaces ind) ind
+ ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
+ in [ Tree.Node (HelpNode_Command, d) ts ]
+ ) schema
+ where
+ schema = command n s
+ ref =
+ Doc.bold $
+ Doc.angles $
+ Doc.magentaer $
+ Doc.from (Doc.Word n)
+instance SchemaDoc d => CLI_Tag (Help d) where
+ type TagConstraint (Help d) a = ()
+ tag n (Help h s) =
+ Help (\inh ->
+ if (isJust (helpInh_message inh)
+ || helpInh_helpless_options inh)
+ && helpInh_full inh
+ then
+ let
+ ts =
+ maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) <>
+ h inh{helpInh_message=Nothing}
+ d =
+ Doc.fillOrBreak (helpInh_tag_indent inh)
+ (Doc.bold $
+ Schema.runSchema schema (helpInh_schema inh)
+ <> Doc.space) -- FIXME: space is not always needed
+ <> (if null ts then mempty else Doc.space)
+ <> Doc.align (runHelpNodes inh ts)
+ in [ Tree.Node (HelpNode_Tag, d) ts ]
+ else []
+ ) schema
+ where schema = tag n s
+ endOpts = Help mempty endOpts
+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})
+ (help msg s)
+ program n (Help h s) =
+ Help (\inh ->
+ let
+ ts =
+ (if helpInh_full inh
+ then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
+ else []) <>
+ h inh
+ { helpInh_message = Nothing
+ , helpInh_command_rule = True
+ }
+ 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 (Doc.spaces ind) ind
+ ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
+ in [ Tree.Node (HelpNode_Rule, d) ts ]
+ ) schema
+ where
+ schema = program n s
+ rule n (Help h s) =
+ Help (\inh ->
+ let
+ ts =
+ (if helpInh_full inh
+ then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
+ else []) <>
+ h inh
+ { helpInh_message = Nothing
+ , helpInh_command_rule = True
+ }
+ 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 (Doc.spaces ind) ind
+ ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
+ in [ Tree.Node (HelpNode_Rule, d) ts ]
+ ) schema
+ where
+ schema = rule n s
+ ref =
+ Doc.bold $
+ Doc.angles $
+ Doc.magentaer $
+ Doc.from (Doc.Word n)
+type HelpResponseArgs = SchemaResponseArgs
+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)
+ response' ::
+ forall a repr.
+ repr ~ Help d =>
+ ResponseConstraint repr a =>
+ repr (ResponseArgs repr a)
+ (Response repr)
+ response' = Help mempty $ response' @(Schema d) @a
+
+{-
+instance SchemaDoc d => Sym_AltApp (Help d) where
+ many (Help h s) = Help h (many s)
+ some (Help h s) = Help h (many s)
+-}
+
+-- * Type 'HelpPerm'
+data HelpPerm d k a
+ = HelpPerm (HelpInh d -> HelpResult d)
+ (SchemaPerm d k a)
+instance Functor (HelpPerm d k) where
+ f`fmap`HelpPerm h ps = HelpPerm h (f<$>ps)
+instance Applicative (HelpPerm d k) where
+ pure a = HelpPerm mempty (pure a)
+ HelpPerm fh f <*> HelpPerm xh x =
+ HelpPerm (fh<>xh) (f<*>x)
+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})
+ (help msg s)
+ program n (HelpPerm h s) = HelpPerm
+ (help_result $ program n (Help h (runPermutation s)))
+ (rule n s)
+ rule n (HelpPerm h s) = HelpPerm
+ (help_result $ rule n (Help h (runPermutation s)))
+ (rule n s)
--- /dev/null
+{-# 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(..), 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.
+ , 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
+
+-- ** 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 <$>)
+
+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.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_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) []{-FIXME-}) 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 ->
+ maybe [] (\sch -> [(Doc.brackets sch, layoutInh_message inh <> xh)]) $
+ unSchema xl defSchemaInh
+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
+ {-
+ runSequence (LayoutSeq s h ps) = Layout sch h $ \inh -> do
+ modify' $ \k -> \case
+ Nothing -> k Nothing
+ Just ts -> k $ Just [Tree.Node nod mempty]
+ -- where nod = LayoutNode_List (layoutInh_message inh) (ps inh{layoutInh_message=[]})
+ where
+ nod = LayoutNode_Forest mempty {-(docSchema sch)-}
+ (layoutInh_message inh) (gs <> ts)
+ gs = (<$> ps inh{layoutInh_message=[]}) $ \(d,ds) ->
+ Tree.Node (LayoutNode_Single d ds) mempty
+
+ where sch = runSequence s
+ toSequence (Layout s h _m) = LayoutSeq (toSequence s) h $ \inh ->
+ [(docSchema s, layoutInh_message inh <> h)]
+ -}
+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 = [(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 = [(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
+
+-- ** Type 'LayoutSeq'
+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
+
+-- ** Type 'LayoutPerm'
+data LayoutPerm d k a = LayoutPerm
+ { layoutPerm_help :: [d]
+ , layoutPerm_alts :: LayoutInh d -> [(d, {-help-}[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
+
+-- ** Type 'LayoutNode'
+data LayoutNode d
+ = LayoutNode_Single d {-help-}[d]
+ | LayoutNode_List [d] [(d, {-help-}[d])]
+ | LayoutNode_Forest d [d] (Tree.Forest (LayoutNode d))
+ deriving (Show)
--- /dev/null
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE GADTs #-} -- for Router
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-} -- for hoistParserPerm (which is no longer used)
+module Symantic.CLI.Parser where
+
+import Control.Applicative (Applicative(..), Alternative(..), optional, many, some)
+import Control.Monad (Monad(..), join, sequence, forM_, void)
+import Control.Monad.Trans.Class (MonadTrans(..))
+import Control.Monad.Trans.State (StateT(..),evalState,get,put)
+import Data.Bool
+import Data.Char (Char)
+import Data.Either (Either(..))
+import Data.Eq (Eq(..))
+import Data.Foldable (null, toList)
+import Data.Function (($), (.), id, const)
+import Data.Functor (Functor(..), (<$>), ($>))
+import Data.Functor.Identity (Identity(..))
+import Data.Int (Int)
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Map.Strict (Map)
+import Data.Maybe (Maybe(..), maybe, isNothing)
+import Data.Ord (Ord(..))
+import Data.Proxy (Proxy(..))
+import Data.Semigroup (Semigroup(..))
+import Data.String (String)
+import Numeric.Natural (Natural)
+import Prelude (Integer, Num(..), error)
+import System.Environment (lookupEnv)
+import System.IO (IO)
+import Text.Read (Read, readEither)
+import Text.Show (Show(..), ShowS, showString, showParen)
+import Type.Reflection as Reflection
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.List as List
+import qualified Data.List.NonEmpty as NonEmpty
+import qualified Data.Map.Merge.Strict as Map
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import qualified System.Exit as System
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as TLB
+import qualified Data.Text.Lazy.IO as TL
+import qualified Symantic.Document as Doc
+import qualified System.IO as IO
+import qualified Text.Megaparsec as P
+
+import Symantic.CLI.API
+
+-- * Type 'Parser'
+newtype Parser e d f k = Parser
+ { unParser :: P.ParsecT e [Arg] IO (f->k) -- Reader f k
+ }
+
+parser ::
+ P.ShowErrorComponent e =>
+ Router (Parser e d) handlers (Response (Router (Parser e d))) ->
+ handlers ->
+ [Arg] -> IO ()
+parser api handlers args = do
+ P.runParserT
+ (unParser $ unTrans $ router api)
+ "" args >>= \case
+ Left err ->
+ forM_ (P.bundleErrors err) $ \e -> do
+ IO.putStr $
+ "Error parsing the command at argument #" <>
+ show (P.errorOffset e + 1) <> ":\n" <>
+ parseErrorTextPretty e
+ System.exitWith (System.ExitFailure 2)
+ Right app -> unResponseParser $ app handlers
+
+-- | Rewrite 'P.parseErrorTextPretty' to keep 'Ord' of 'Arg'.
+parseErrorTextPretty ::
+ forall s e.
+ (P.Stream s, P.ShowErrorComponent e) =>
+ P.ParseError s e -> String
+parseErrorTextPretty (P.TrivialError _ us ps) =
+ if isNothing us && Set.null ps
+ then "unknown parse error\n"
+ else
+ messageItemsPretty "unexpected "
+ (showErrorItem pxy <$> Set.toAscList (maybe Set.empty Set.singleton us)) <>
+ messageItemsPretty "expecting "
+ (showErrorItem pxy <$> Set.toAscList ps)
+ where pxy = Proxy :: Proxy s
+parseErrorTextPretty err = P.parseErrorTextPretty err
+
+messageItemsPretty :: String -> [String] -> String
+messageItemsPretty prefix ts
+ | null ts = ""
+ | otherwise = prefix <> (orList . NonEmpty.fromList) ts <> "\n"
+
+orList :: NonEmpty String -> String
+orList (x:|[]) = x
+orList (x:|[y]) = x <> " or " <> y
+orList xs = List.intercalate ", " (NonEmpty.init xs) <> ", or " <> NonEmpty.last xs
+
+showErrorItem :: P.Stream s => Proxy s -> P.ErrorItem (P.Token s) -> String
+showErrorItem pxy = \case
+ P.Tokens ts -> P.showTokens pxy ts
+ 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
+ pure = Parser . pure . const
+ Parser f <*> Parser x = Parser $ (<*>) <$> f <*> x
+instance Ord e => Alternative (Parser e d f) where
+ empty = Parser empty
+ Parser x <|> Parser y = Parser $ x <|> y
+instance Ord e => Sequenceable (Parser e d) where
+ type Sequence (Parser e d) = ParserSeq e d
+ runSequence = unParserSeq
+ toSequence = ParserSeq
+instance Ord e => Permutable (Parser e d) where
+ type Permutation (Parser e d) = ParserPerm e d (Parser e d)
+ runPermutation (ParserPerm ma p) = Parser $ do
+ u2p <- unParser $ optional p
+ unParser $
+ case u2p () of
+ Just perm -> runPermutation perm
+ Nothing ->
+ maybe
+ (Parser $ P.token (const Nothing) Set.empty)
+ -- NOTE: Not 'empty' here so that 'P.TrivialError'
+ -- has the unexpected token.
+ (Parser . return) ma
+ toPermutation (Parser x) =
+ ParserPerm Nothing
+ (Parser $ (\a () -> ParserPerm (Just a) empty) <$> x)
+ toPermDefault a (Parser x) =
+ ParserPerm (Just ($ a))
+ (Parser $ (\d () -> ParserPerm (Just d) empty) <$> x)
+instance App (Parser e d) where
+ Parser x <.> Parser y = Parser $
+ x >>= \a2b -> (. a2b) <$> y
+instance Ord e => Alt (Parser e d) where
+ Parser x <!> Parser y = Parser $
+ (\a2k (a:!:_b) -> a2k a) <$> P.try x <|>
+ (\b2k (_a:!:b) -> b2k b) <$> y
+ Parser x `alt` Parser y = Parser $ P.try x <|> y
+ opt (Parser x) = Parser $
+ mapCont Just <$> P.try x
+instance Ord e => AltApp (Parser e d) where
+ many0 (Parser x) = Parser $ concatCont <$> many x
+ many1 (Parser x) = Parser $ concatCont <$> some x
+instance Pro (Parser e d) where
+ dimap a2b _b2a (Parser r) = Parser $ (\k b2k -> k (b2k . a2b)) <$> r
+instance Ord e => CLI_Command (Parser e d) where
+ -- type CommandConstraint (Parser e d) a = ()
+ command "" x = x
+ command n x = commands Map.empty (Map.singleton n x)
+instance Ord e => CLI_Tag (Parser e d) where
+ type TagConstraint (Parser e d) a = ()
+ tag name p = Parser $ P.try $ do
+ void $ (`P.token` exp) $ \tok ->
+ if lookupTag tok name
+ then Just tok
+ else Nothing
+ unParser p
+ where
+ exp =
+ case name of
+ TagShort t -> Set.singleton $ P.Tokens $ pure $ ArgTagShort t
+ TagLong t -> Set.singleton $ P.Tokens $ pure $ ArgTagLong t
+ Tag s l -> Set.fromList
+ [ P.Tokens $ pure $ ArgTagShort s
+ , P.Tokens $ pure $ ArgTagLong l
+ ]
+ lookupTag (ArgTagShort x) (TagShort y) = x == y
+ lookupTag (ArgTagShort x) (Tag y _) = x == y
+ lookupTag (ArgTagLong x) (TagLong y) = x == y
+ lookupTag (ArgTagLong x) (Tag _ y) = x == y
+ lookupTag _ _ = False
+ endOpts = Parser $ do
+ (`P.token` exp) $ \case
+ ArgTagLong "" -> Just id
+ _ -> Nothing
+ where
+ exp = Set.singleton $ P.Tokens $ pure $ ArgTagLong ""
+instance Ord e => CLI_Var (Parser e d) where
+ type VarConstraint (Parser e d) a = (IOType a, FromSegment a)
+ var' :: forall a k. VarConstraint (Parser e d) a => Name -> Parser e d (a->k) k
+ var' name = Parser $ do
+ seg <- (`P.token` expName) $ \case
+ ArgSegment seg -> Just seg
+ _ -> Nothing
+ lift (fromSegment seg) >>= \case
+ Left err -> P.failure got expType
+ where
+ got = Just $ P.Tokens $ pure $ ArgSegment seg
+ expType = Set.singleton $ P.Label $ NonEmpty.fromList $
+ "<"<>name<>"> to be of type "<>ioType @a
+ <> case err of
+ "Prelude.read: no parse" -> ""
+ "" -> ""
+ _ -> ": "<>err
+ Right a -> return ($ a)
+ where
+ expName = Set.singleton $ P.Label $ NonEmpty.fromList $ "<"<>name<>">"
+instance Ord e => CLI_Constant (Parser e d) where
+ constant "" a = just a
+ constant c a = commands Map.empty (Map.singleton c (just a))
+ just a = Parser $ return ($ a)
+ nothing = Parser $ return id
+instance Ord e => CLI_Env (Parser e d) where
+ type EnvConstraint (Parser e d) a = (IOType a, FromSegment a)
+ env' :: forall a k. EnvConstraint (Parser e d) a => Name -> Parser e d (a->k) k
+ env' name = Parser $
+ lift (lookupEnv name) >>= \case
+ Nothing -> P.failure got exp
+ where
+ got = Nothing
+ exp = Set.singleton $ P.Label $ NonEmpty.fromList $ "${"<>name<>"}"
+ Just val ->
+ lift (fromSegment val) >>= \case
+ Right a -> return ($ a)
+ Left err -> P.failure got exp
+ where
+ got = Just $ P.Tokens $ pure $ ArgEnv name val
+ exp = Set.singleton $ P.Label $ NonEmpty.fromList $
+ "${"<>name<>"} to be of type "<>ioType @a
+ <> case err of
+ "Prelude.read: no parse" -> ""
+ "" -> ""
+ _ -> ": "<>err
+instance Ord e => CLI_Response (Parser e d) where
+ type ResponseConstraint (Parser e d) a = Outputable a
+ type ResponseArgs (Parser e d) a = ParserResponseArgs a
+ type Response (Parser e d) = ParserResponse
+ response' = Parser $
+ P.eof $> \({-ParserResponseArgs-} io) ->
+ ParserResponse $ io >>= output
+instance Ord e => CLI_Help (Parser e d) where
+ type HelpConstraint (Parser e d) d' = d ~ d'
+ help _msg = id
+ program n = Parser . P.label n . unParser
+ rule n = Parser . P.label n . unParser
+
+concatCont :: [(a->k)->k] -> ([a]->k)->k
+concatCont = List.foldr (consCont (:)) ($ [])
+
+consCont :: (a->b->c) -> ((a->k)->k) -> ((b->k)->k) -> (c->k)->k
+consCont ab2c a2k2k b2k2k = \c2k -> a2k2k $ \a -> b2k2k $ \b -> c2k (ab2c a b)
+
+mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k)
+mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b)
+
+-- ** Type 'ParserResponse'
+newtype ParserResponse = ParserResponse { unResponseParser :: IO () }
+-- ** Type 'ParserResponseArgs'
+type ParserResponseArgs = IO
+
+-- * Class 'Outputable'
+-- | Output of a CLI.
+class IOType a => Outputable a where
+ output :: a -> IO ()
+ default output :: Show a => a -> IO ()
+ output = IO.print
+
+instance Outputable () where
+ output = return
+instance Outputable Bool
+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 BS.ByteString where
+ output = BS.putStr
+instance Outputable BSL.ByteString where
+ output = BSL.putStr
+instance Outputable (Doc.Plain TLB.Builder) where
+ output =
+ TL.putStr .
+ TLB.toLazyText .
+ Doc.runPlain
+
+-- ** Type 'OnHandle'
+data OnHandle a = OnHandle IO.Handle a
+instance Functor OnHandle where
+ fmap f (OnHandle h a) = OnHandle h (f 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 BS.ByteString) where
+ output (OnHandle h a) = BS.hPutStr h a
+instance Outputable (OnHandle BSL.ByteString) where
+ output (OnHandle h a) = BSL.hPutStr h a
+instance Outputable (OnHandle (Doc.Plain TLB.Builder)) where
+ output (OnHandle h d) =
+ TL.hPutStr h $
+ TLB.toLazyText $
+ Doc.runPlain d
+instance
+ ( Outputable a
+ , Reflection.Typeable a
+ ) => Outputable (Maybe a) where
+ output = \case
+ Nothing -> System.exitWith (System.ExitFailure 1)
+ Just a -> output a
+instance
+ ( Reflection.Typeable e
+ , Reflection.Typeable a
+ , Outputable (OnHandle e)
+ , Outputable a
+ ) => Outputable (Either e a) where
+ output = \case
+ Left e -> do
+ output (OnHandle IO.stderr e)
+ System.exitWith (System.ExitFailure 1)
+ Right a -> output a
+
+-- * Class 'IOType'
+-- | Like a MIME type but for input/output of a CLI.
+class IOType a where
+ ioType :: String
+ default ioType :: Reflection.Typeable a => String
+ ioType = show (Reflection.typeRep @a)
+
+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 BS.ByteString
+instance IOType BSL.ByteString
+instance IOType (Doc.Plain TLB.Builder)
+instance Reflection.Typeable a => IOType (Maybe a)
+instance (Reflection.Typeable e, Reflection.Typeable a) => IOType (Either e a)
+
+-- * Class 'FromSegment'
+class FromSegment a where
+ fromSegment :: Segment -> IO (Either String a)
+ default fromSegment :: Read a => Segment -> IO (Either String a)
+ fromSegment = return . readEither
+instance FromSegment String where
+ fromSegment = return . Right
+instance FromSegment Text.Text where
+ fromSegment = return . Right . Text.pack
+instance FromSegment TL.Text where
+ fromSegment = return . Right . TL.pack
+instance FromSegment Bool
+instance FromSegment Int
+instance FromSegment Integer
+instance FromSegment Natural
+
+-- ** Type 'ParserSeq'
+-- | Lift a 'Parser' to something working with 'Functor' and 'Applicative'.
+-- Used to gather collected values into a single one,
+-- which is for instance needed for using 'many0' on multiple 'var's.
+newtype ParserSeq e d k a = ParserSeq
+ { unParserSeq :: Parser e d (a->k) k }
+instance Functor (ParserSeq e d k) where
+ a2b `fmap` ParserSeq (Parser x) = ParserSeq $ Parser $ merge <$> x
+ where merge = \a2k2k b2k -> a2k2k $ b2k . a2b
+instance Applicative (ParserSeq e d k) where
+ pure a = ParserSeq $ Parser $ pure ($ a)
+ ParserSeq (Parser f) <*> ParserSeq (Parser x) =
+ ParserSeq $ Parser $ merge <$> f <*> x
+ where
+ merge a2b2k2k a2k2k b2k =
+ a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
+
+-- ** Type 'ParserPerm'
+data ParserPerm e d repr k a = ParserPerm
+ { permutation_result :: !(Maybe ((a->k)->k))
+ , permutation_parser :: repr () (ParserPerm e d repr k a)
+ }
+
+instance (App repr, Functor (repr ())) => Functor (ParserPerm e d repr k) where
+ a2b `fmap` ParserPerm a ma =
+ ParserPerm (merge <$> a) ((a2b `fmap`) `fmap` ma)
+ where merge = \a2k2k b2k -> a2k2k $ b2k . a2b
+instance (App repr, Functor (repr ()), Alternative (repr ())) =>
+ Applicative (ParserPerm e d repr k) where
+ pure a = ParserPerm (Just ($ a)) empty
+ lhs@(ParserPerm f ma2b) <*> rhs@(ParserPerm x ma) =
+ ParserPerm a (lhsAlt <|> rhsAlt)
+ where
+ a = merge <$> f <*> x
+ lhsAlt = (<*> rhs) <$> ma2b
+ rhsAlt = (lhs <*>) <$> ma
+ merge a2b2k2k a2k2k b2k =
+ a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
+instance CLI_Help repr => CLI_Help (ParserPerm e d repr) where
+ type HelpConstraint (ParserPerm e d repr) d' = HelpConstraint (Parser e d) d'
+ program _n = id
+ rule _n = id
+
+noTransParserPerm ::
+ Trans repr =>
+ Functor (UnTrans repr ()) =>
+ ParserPerm e d (UnTrans repr) k a -> ParserPerm e d repr k a
+noTransParserPerm (ParserPerm a ma) = ParserPerm a (noTrans $ noTransParserPerm <$> ma)
+
+unTransParserPerm ::
+ Trans repr =>
+ Functor (UnTrans repr ()) =>
+ ParserPerm e d repr k a -> ParserPerm e d (UnTrans repr) k a
+unTransParserPerm (ParserPerm a ma) =
+ ParserPerm a (unTransParserPerm <$> unTrans ma)
+
+hoistParserPerm ::
+ Functor (repr ()) =>
+ (forall a b. repr a b -> repr a b) ->
+ ParserPerm e d repr k c -> ParserPerm e d repr k c
+hoistParserPerm f (ParserPerm a ma) =
+ ParserPerm a (hoistParserPerm f <$> f ma)
+
+-- ** Class 'CLI_Routing'
+class CLI_Routing repr where
+ commands :: Map Name (repr a k) -> Map Name (repr a k) -> repr a k
+ -- tags :: TagConstraint repr a => Map (Either Char Name) (repr (a -> k) k) -> repr (a -> k) k
+instance Ord e => CLI_Routing (Parser e d) where
+ commands preCmds cmds = Parser $
+ P.token check exp >>= unParser
+ where
+ exp = Set.fromList $ P.Tokens . pure . ArgSegment <$> Map.keys cmds
+ check = \case
+ ArgSegment cmd ->
+ Map.lookup cmd cmds <|>
+ Map.lookup cmd preCmds
+ _ -> Nothing
+
+-- * Type 'Router'
+data Router repr a b where
+ -- | Lift any @(repr)@ into 'Router', those not useful to segregate
+ -- wrt. the 'Trans'formation performed, aka. 'noTrans'.
+ Router_Any :: repr a b -> Router repr a b
+ -- | Represent 'commands'.
+ Router_Commands ::
+ Map Name (Router repr a k) ->
+ Map Name (Router repr a k) ->
+ Router repr a k
+ -- | Represent 'tag'.
+ Router_Tag :: Tag -> Router repr f k -> Router repr f k
+ -- | Represent ('<.>').
+ Router_App :: Router repr a b -> Router repr b c -> Router repr a c
+ -- | Represent ('<!>').
+ Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
+ -- | Unify 'Router's which have different 'handlers'.
+ -- Useful to put alternative 'Router's in a 'Map' as in 'Router_Commands'.
+ Router_Union :: (b->a) -> Router repr a k -> Router repr b k
+
+instance Ord e => Functor (Router (Parser e d) f) where
+ a2b`fmap`x = noTrans (a2b <$> unTrans x)
+instance Ord e => Applicative (Router (Parser e d) f) where
+ pure = noTrans . pure
+ f <*> x = noTrans (unTrans f <*> unTrans x)
+instance Ord e => Alternative (Router (Parser e d) f) where
+ empty = noTrans empty
+ f <|> x = noTrans (unTrans f <|> unTrans x)
+instance (repr ~ Parser e d) => Show (Router repr a b) where
+ showsPrec p = \case
+ Router_Any{} -> showString "X"
+ Router_Commands _preCmds cmds -> showParen (p>=10) $ showString "Commands [" . go (Map.toList cmds) . showString "]"
+ where
+ go :: forall h k. [(Segment, Router repr h k)] -> ShowS
+ go [] = id
+ go ((n, r):xs) =
+ (showParen True $ showString (show n<>", ") . showsPrec 0 r) .
+ case xs of
+ [] -> id
+ _ -> showString ", " . go xs
+ Router_Tag n x -> showsPrec 10 n . showString " " . showsPrec p x
+ Router_App x y -> showParen (p>=4) $ showsPrec 4 x . showString " <.> " . showsPrec 4 y
+ Router_Alt x y -> showParen (p>=3) $ showsPrec 3 x . showString " <!> " . showsPrec 3 y
+ Router_Union _u x -> showString "Union [" . showsPrec 0 x . showString "]"
+instance Ord e => Trans (Router (Parser e d)) where
+ type UnTrans (Router (Parser e d)) = Parser e d
+ noTrans = Router_Any
+ unTrans (Router_Any x) = x
+ unTrans (Router_Alt x y) = unTrans x <!> unTrans y
+ unTrans (Router_App x y) = unTrans x <.> unTrans y
+ unTrans (Router_Commands preCmds cmds) = commands (unTrans <$> preCmds) (unTrans <$> cmds)
+ unTrans (Router_Tag n x) = tag n (unTrans x)
+ unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x)
+
+instance Ord e => App (Router (Parser e d)) where
+ (<.>) = Router_App
+instance Ord e => Alt (Router (Parser e d)) where
+ (<!>) = Router_Alt
+ alt x y = Router_Union (\a -> a:!:a) $ Router_Alt x y
+instance Ord e => AltApp (Router (Parser e d))
+instance Ord e => Sequenceable (Router (Parser e d)) where
+ type Sequence (Router (Parser e d)) = RouterParserSeq (ParserSeq e d)
+ runSequence = noTrans . runSequence . unRouterParserSeq
+ toSequence = RouterParserSeq . toSequence . unTrans
+instance Ord e => Permutable (Router (Parser e d)) where
+ type Permutation (Router (Parser e d)) = ParserPerm e d (Router (Parser e d))
+ runPermutation = noTrans . runPermutation . unTransParserPerm
+ toPermutation = noTransParserPerm . toPermutation . unTrans
+ toPermDefault a = noTransParserPerm . toPermDefault a . unTrans
+instance Ord e => Pro (Router (Parser e d))
+instance (repr ~ (Parser e d)) => CLI_Command (Router repr) where
+ command "" x = x
+ command n x =
+ let is = List.tail $ List.inits n in
+ let (preCmds, cmds) = List.splitAt (List.length is - 1) is in
+ Router_Commands
+ (Map.fromAscList $ (,x) <$> preCmds)
+ (Map.fromAscList $ (,x) <$> cmds)
+instance Ord e => CLI_Var (Router (Parser e d))
+instance Ord e => CLI_Constant (Router (Parser e d))
+instance Ord e => CLI_Env (Router (Parser e d))
+instance Ord e => CLI_Tag (Router (Parser e d)) where
+ tag = Router_Tag
+instance CLI_Help (Router (Parser e d)) where
+ -- NOTE: set manually (instead of the 'Trans' default 'Router_Any')
+ -- to remove them all, since they are useless for 'Parser'
+ -- and may prevent patterns to be matched in 'router'.
+ help _msg = id
+ program _n = id
+ rule _n = id
+instance Ord e => CLI_Response (Router (Parser e d))
+instance Ord e => CLI_Routing (Router (Parser e d)) where
+ -- tags = Router_Tags
+ commands = Router_Commands
+
+router ::
+ repr ~ Parser e d =>
+ Router repr a b -> Router repr a b
+router = {-debug1 "router" $-} \case
+ x@Router_Any{} -> x
+ Router_Tag n x -> Router_Tag n (router x)
+ Router_Alt x y -> router x`router_Alt`router y
+ Router_Commands preCmds cmds ->
+ Router_Commands
+ (router <$> preCmds)
+ (router <$> cmds)
+ Router_App xy z ->
+ case xy of
+ Router_App x y ->
+ -- Associate to the right
+ Router_App (router x) $
+ Router_App (router y) (router z)
+ _ -> router xy `Router_App` router z
+ Router_Union u x -> Router_Union u (router x)
+
+-- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
+router_Alt ::
+ repr ~ Parser e d =>
+ Router repr a k ->
+ Router repr b k ->
+ Router repr (a:!:b) k
+router_Alt = {-debug2 "router_Alt"-} go
+ where
+ -- Merge alternative commands together.
+ go (Router_Commands xp xs) (Router_Commands yp ys) =
+ Router_Commands
+ (router_Commands False xp yp) -- NOTE: conflicting prefixes are dropped.
+ (router_Commands True xs ys)
+
+ -- Merge left first or right first, depending on which removes 'Router_Alt'.
+ go x (y`Router_Alt`z) =
+ case x`router_Alt`y of
+ Router_Alt x' y' ->
+ case y'`router_Alt`z of
+ yz@(Router_Alt _y z') ->
+ case x'`router_Alt`z' of
+ Router_Alt{} -> router x'`Router_Alt`yz
+ xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y
+ -- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.
+ yz -> x'`router_Alt`yz
+ xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z
+ go (x`Router_Alt`y) z =
+ case y`router_Alt`z of
+ Router_Alt y' z' ->
+ case x`router_Alt`y' of
+ xy@(Router_Alt x' _y) ->
+ case x'`router_Alt`z' of
+ Router_Alt{} -> xy`Router_Alt`router z'
+ xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y
+ -- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.
+ xy -> xy`router_Alt`z'
+ yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
+
+ -- Merge through 'Router_Union'.
+ go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)
+ go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)
+
+ -- No merging
+ go x y = x`Router_Alt`y
+
+router_Commands ::
+ repr ~ Parser e d =>
+ Bool ->
+ Map Segment (Router repr a k) ->
+ Map Segment (Router repr b k) ->
+ Map Segment (Router repr (a:!:b) k)
+router_Commands allowMerging =
+ -- NOTE: a little bit more complex than required
+ -- in order to merge 'Router_Union's instead of nesting them,
+ -- such that 'unTrans' 'Router_Union' applies them all at once.
+ Map.merge
+ (Map.mapMissing $ const keepX)
+ (Map.mapMissing $ const keepY)
+ (Map.zipWithMaybeMatched $ const $ \x y ->
+ if allowMerging then Just $ mergeFull x y else Nothing)
+ where
+ keepX = \case
+ Router_Union u r -> Router_Union (\(x:!:_y) -> u x) r
+ r -> Router_Union (\(x:!:_y) -> x) r
+ keepY = \case
+ Router_Union u r -> Router_Union (\(_x:!:y) -> u y) r
+ r -> Router_Union (\(_x:!:y) -> y) r
+ mergeFull = \case
+ Router_Union xu xr -> \case
+ Router_Union yu yr -> Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
+ yr -> Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
+ xr -> \case
+ Router_Union yu yr -> Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
+ yr -> xr`router_Alt`yr
+
+-- ** Type 'RouterParserSeq'
+newtype RouterParserSeq repr k a = RouterParserSeq
+ { unRouterParserSeq :: repr k a }
+ deriving (Functor, Applicative)
+
+-- * Type 'Arg'
+data Arg
+ = ArgSegment Segment
+ | ArgTagLong Name
+ | ArgTagShort Char
+ | ArgEnv Name String -- ^ Here only for error reporting.
+ deriving (Eq,Ord,Show)
+
+lexer :: [String] -> [Arg]
+lexer ss =
+ join $
+ (`evalState` False) $
+ sequence (f <$> ss)
+ where
+ f :: String -> StateT Bool Identity [Arg]
+ f s = do
+ skip <- get
+ if skip then return [ArgSegment s]
+ else case s of
+ '-':'-':[] -> do
+ put True
+ return [ArgTagLong ""]
+ '-':'-':cs -> return [ArgTagLong cs]
+ '-':cs@(_:_) -> return $ ArgTagShort <$> cs
+ seg -> return [ArgSegment seg]
+
+showArg :: Arg -> String
+showArg = \case
+ ArgTagShort t -> '-':[t]
+ ArgTagLong t -> '-':'-':t
+ ArgSegment seg -> seg
+ ArgEnv name val -> name<>"="<>val
+
+showArgs :: [Arg] -> String
+showArgs args = List.intercalate " " $ showArg <$> args
+
+instance P.Stream [Arg] where
+ type Token [Arg] = Arg
+ type Tokens [Arg] = [Arg]
+ tokenToChunk Proxy = pure
+ tokensToChunk Proxy = id
+ chunkToTokens Proxy = id
+ chunkLength Proxy = List.length
+ chunkEmpty Proxy = List.null
+ take1_ [] = Nothing
+ take1_ (t:ts) = Just (t, ts)
+ takeN_ n s
+ | n <= 0 = Just ([], s)
+ | List.null s = Nothing
+ | otherwise = Just (List.splitAt n s)
+ takeWhile_ = List.span
+ showTokens Proxy = showArgs . toList
+ -- NOTE: those make no sense when parsing a command line,
+ -- and should not be called since 'P.errorBundlePretty' is not used in 'parser'.
+ reachOffset = error "BUG: reachOffset must not be used on [Arg]"
+ reachOffsetNoLine = error "BUG: reachOffsetNoLine must not be used on [Arg]"
--- /dev/null
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
+module Symantic.CLI.Schema where
+
+import Control.Applicative (Applicative(..))
+import Data.Bool
+import Data.Char (Char)
+import Data.Function (($), (.), id)
+import Data.Functor (Functor(..), (<$>))
+import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
+import Data.Monoid (Monoid(..))
+import Data.Semigroup (Semigroup(..))
+import Data.String (String, IsString(..))
+import Data.Text (Text)
+import Text.Show (Show(..))
+import qualified Data.List as List
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as TLB
+import qualified Symantic.Document as Doc
+
+import Symantic.CLI.API
+import Symantic.CLI.Fixity
+
+-- * Type 'Schema'
+newtype Schema d f k
+ = Schema { unSchema :: SchemaInh d -> Maybe d }
+
+runSchema :: Monoid d => Schema d f k -> SchemaInh d -> d
+runSchema (Schema s) = fromMaybe mempty . s
+
+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{..}
+
+-- ** Class 'SchemaDoc'
+type SchemaDoc d =
+ ( Semigroup d
+ , Monoid d
+ , IsString d
+ , Doc.Colorable16 d
+ , Doc.Decorable d
+ , Doc.Spaceable d
+ , Doc.Indentable d
+ , Doc.Wrappable d
+ , Doc.From (Doc.Word Char) d
+ , Doc.From (Doc.Word Text) d
+ , Doc.From (Doc.Word String) d
+ )
+
+-- ** Type 'SchemaInh'
+-- | Inherited top-down.
+data SchemaInh d
+ = SchemaInh
+ { schemaInh_op :: (Infix, Side) -- ^ Parent operator.
+ , schemaInh_define :: Bool -- ^ Whether to print a definition, or not.
+ , schemaInh_or :: d -- ^ The separator to use between alternatives.
+ }
+
+defSchemaInh :: SchemaDoc d => SchemaInh d
+defSchemaInh = SchemaInh
+ { schemaInh_op = (infixN0, SideL)
+ , schemaInh_define = True
+ , schemaInh_or = docOrH
+ }
+
+pairIfNeeded :: SchemaDoc d => (Infix, Side) -> Infix -> d -> d
+pairIfNeeded opInh op =
+ if needsParenInfix opInh op
+ then Doc.align . Doc.parens
+ else id
+
+instance Semigroup d => Semigroup (Schema d f k) where
+ Schema x <> Schema y = Schema $ x <> y
+instance (Semigroup d, Monoid d) => Monoid (Schema d f k) where
+ mempty = Schema mempty
+ mappend = (<>)
+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.Plain TLB.Builder) a k) where
+ show =
+ TL.unpack .
+ TLB.toLazyText .
+ Doc.runPlain .
+ docSchema
+
+docOrH, docOrV :: Doc.Spaceable d => Doc.From (Doc.Word Char) d => d
+docOrH = Doc.space <> Doc.from (Doc.Word '|') <> Doc.space
+docOrV = Doc.newline <> Doc.from (Doc.Word '|') <> Doc.space
+
+{-
+instance SchemaDoc d => Functor (Schema d f) where
+ _f `fmap` Schema x = Schema $ \inh ->
+ pairIfNeeded (schemaInh_op inh) op <$>
+ x inh{schemaInh_op=(op, SideR)}
+ where
+ op = infixB SideL 10
+-}
+instance SchemaDoc d => App (Schema d) where
+ Schema f <.> Schema x = Schema $ \inh ->
+ 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 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 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 l inh
+ { schemaInh_op=(op, SideL)
+ , schemaInh_or=docOrH } <>
+ docOrH <>
+ runSchema r inh
+ { schemaInh_op=(op, SideR)
+ , schemaInh_or=docOrH })
+ (Doc.align $
+ Doc.parens $
+ Doc.space <>
+ runSchema l inh
+ { schemaInh_op=(op, SideL)
+ , schemaInh_or=docOrV } <>
+ docOrV <>
+ runSchema r inh
+ { schemaInh_op=(op, SideR)
+ , schemaInh_or=docOrV } <>
+ Doc.newline)
+ else
+ -- 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 r inh{schemaInh_op=(op, SideR)}
+ where op = infixB SideL 2
+ alt x y = coerceSchema $ coerceSchema x <!> coerceSchema y
+ opt s = Schema $ \inh -> Just $
+ Doc.brackets $
+ runSchema s inh{schemaInh_op=(op, SideL)}
+ where op = infixN0
+instance SchemaDoc d => Sequenceable (Schema d) where
+ type Sequence (Schema d) = SchemaSeq d
+ runSequence (SchemaSeq fin ps) =
+ case ps of
+ [] -> fin $ Schema $ \_inh -> Nothing
+ _ -> fin $ Schema $ \inh -> Just $
+ pairIfNeeded (schemaInh_op inh) op $
+ Doc.intercalate Doc.breakspace $
+ catMaybes $ (<$> ps) $ \(Schema s) ->
+ s inh
+ { schemaInh_op=(op, SideL)
+ , schemaInh_or=docOrH }
+ where op = infixN 10
+ toSequence = SchemaSeq id . pure
+instance SchemaDoc d => Permutable (Schema d) where
+ type Permutation (Schema d) = SchemaPerm d
+ runPermutation (SchemaPerm fin ps) =
+ case ps of
+ [] -> fin $ Schema $ \_inh -> Nothing
+ _ -> fin $ Schema $ \inh -> Just $
+ pairIfNeeded (schemaInh_op inh) op $
+ Doc.intercalate Doc.breakspace $
+ catMaybes $ (<$> ps) $ \(Schema s) ->
+ s inh
+ { schemaInh_op=(op, SideL)
+ , schemaInh_or=docOrH }
+ 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.brackets $
+ runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH}
+ else
+ runSchema s inh{schemaInh_op=(op, SideL)}
+ where op = infixN0
+instance Pro (Schema d) where
+ dimap _a2b _b2a = coerceSchema
+instance SchemaDoc d => AltApp (Schema d) where
+ many0 s = Schema $ \inh -> Just $
+ pairIfNeeded (schemaInh_op inh) op $
+ runSchema s inh{schemaInh_op=(op, SideL)}<>"*"
+ where op = infixN 11
+ many1 s = Schema $ \inh -> Just $
+ pairIfNeeded (schemaInh_op inh) op $
+ runSchema s inh{schemaInh_op=(op, SideL)}<>"+"
+ where op = infixN 11
+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}
+ else ref
+ where
+ ref =
+ Doc.bold $
+ Doc.angles $
+ Doc.magentaer $
+ Doc.from (Doc.Word n)
+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
+instance SchemaDoc d => CLI_Constant (Schema d) where
+ constant c _a = Schema $ \_inh -> Just $
+ Doc.from (Doc.Word c)
+ just _ = Schema $ \_inh -> Nothing
+ nothing = Schema $ \_inh -> Nothing
+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 SchemaDoc d => CLI_Tag (Schema d) where
+ type TagConstraint (Schema d) a = ()
+ tag n r = Schema $ \inh ->
+ unSchema (prefix n <.> r) inh
+ where
+ prefix = \case
+ Tag s l -> prefix (TagShort s)<>"|"<>prefix (TagLong l)
+ TagShort s -> fromString ['-', s]
+ TagLong l -> fromString ("--"<>l)
+ endOpts = Schema $ \_inh -> Just $ Doc.brackets "--"
+instance SchemaDoc d => CLI_Help (Schema d) where
+ type HelpConstraint (Schema d) d' = d ~ d'
+ help _msg = id
+ program n s = Schema $ \inh -> Just $
+ runSchema
+ (fromString n <.> coerceSchema s)
+ inh{schemaInh_define = False}
+ rule n s = Schema $ \inh -> Just $
+ if schemaInh_define inh
+ then runSchema s inh{schemaInh_define=False}
+ else ref
+ where
+ ref =
+ Doc.bold $
+ Doc.angles $
+ Doc.magentaer $
+ Doc.from (Doc.Word n)
+data SchemaResponseArgs a
+instance SchemaDoc d => CLI_Response (Schema d) where
+ type ResponseConstraint (Schema d) a = ()
+ type ResponseArgs (Schema d) a = SchemaResponseArgs a
+ type Response (Schema d) = ()
+ response' = Schema $ \_inh -> Nothing
+
+-- ** Type 'SchemaSeq'
+data SchemaSeq d k a = SchemaSeq
+ { schemaSeq_finalizer :: forall b c.
+ Schema d (b->c) c ->
+ Schema d (b->c) c
+ -- ^ Used to implement 'rule'.
+ , schemaSeq_alternatives :: [Schema d (a->k) k]
+ -- ^ Collect alternatives for rendering them all at once in 'runSequence'.
+ }
+instance Functor (SchemaSeq d k) where
+ _f`fmap`SchemaSeq fin ps = SchemaSeq fin (coerceSchema <$> ps)
+instance Applicative (SchemaSeq d k) where
+ pure _a = SchemaSeq id mempty
+ SchemaSeq fd f <*> SchemaSeq fx x =
+ SchemaSeq (fd . fx) $ (coerceSchema <$> f) <> (coerceSchema <$> x)
+instance SchemaDoc d => CLI_Help (SchemaSeq d) where
+ type HelpConstraint (SchemaSeq d) d' = d ~ d'
+ help _msg = id
+ program n (SchemaSeq fin ps) = SchemaSeq (program n . fin) ps
+ rule n (SchemaSeq fin ps) = SchemaSeq (rule n . fin) ps
+
+-- ** Type 'SchemaPerm'
+data SchemaPerm d k a = SchemaPerm
+ { 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 fin ps = SchemaPerm fin (coerceSchema <$> ps)
+instance Applicative (SchemaPerm d k) where
+ pure _a = SchemaPerm id mempty
+ SchemaPerm fd f <*> SchemaPerm fx x =
+ SchemaPerm (fd . fx) $ (coerceSchema <$> f) <> (coerceSchema <$> x)
+instance SchemaDoc d => CLI_Help (SchemaPerm d) where
+ type HelpConstraint (SchemaPerm d) d' = d ~ d'
+ help _msg = id
+ program n (SchemaPerm fin ps) = SchemaPerm (program n . fin) ps
+ rule n (SchemaPerm fin ps) = SchemaPerm (rule n . fin) ps
type: git
Library
+ hs-source-dirs: src
exposed-modules:
Symantic.CLI
Symantic.CLI.API
-Wall
-Wincomplete-uni-patterns
-Wincomplete-record-updates
- -fno-warn-tabs
-- -fhide-source-paths
build-depends:
base >= 4.10 && < 5
sourcephile / git / haskell / symantic-cli.git / commitdiff