From: Julien Moutinho Date: Tue, 26 May 2020 03:33:32 +0000 (+0200) Subject: remove tabs and move to src/ X-Git-Url: https://git.sourcephile.fr/haskell/symantic-cli.git/commitdiff_plain remove tabs and move to src/ --- diff --git a/Symantic/CLI/API.hs b/Symantic/CLI/API.hs deleted file mode 100644 index 3f6763b..0000000 --- a/Symantic/CLI/API.hs +++ /dev/null @@ -1,314 +0,0 @@ -{-# 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 diff --git a/Symantic/CLI/Help.hs b/Symantic/CLI/Help.hs deleted file mode 100644 index f186855..0000000 --- a/Symantic/CLI/Help.hs +++ /dev/null @@ -1,340 +0,0 @@ -{-# 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) (plpr) - 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) diff --git a/Symantic/CLI/Layout.hs b/Symantic/CLI/Layout.hs deleted file mode 100644 index f2c8380..0000000 --- a/Symantic/CLI/Layout.hs +++ /dev/null @@ -1,348 +0,0 @@ -{-# 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 = lsrs - Layout ls lh lm `alt` Layout rs rh rm = - (Layout ls lh lm Layout rs rh rm) - {layoutSchema=sch} - where sch = ls`alt`rs - opt (Layout xs xh xm) = Layout sch xh $ \inh -> do - modify' $ \k -> \case - Nothing -> k Nothing - Just _ts -> k $ Just [Tree.Node (LayoutNode_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) diff --git a/Symantic/CLI/Parser.hs b/Symantic/CLI/Parser.hs deleted file mode 100644 index a92bdaf..0000000 --- a/Symantic/CLI/Parser.hs +++ /dev/null @@ -1,711 +0,0 @@ -{-# 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]" diff --git a/Symantic/CLI/Schema.hs b/Symantic/CLI/Schema.hs deleted file mode 100644 index 23f8f4b..0000000 --- a/Symantic/CLI/Schema.hs +++ /dev/null @@ -1,315 +0,0 @@ -{-# 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 diff --git a/Symantic/CLI/Test.hs b/Symantic/CLI/Test.hs deleted file mode 100644 index af28388..0000000 --- a/Symantic/CLI/Test.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# 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 diff --git a/Symantic/CLI.hs b/src/Symantic/CLI.hs similarity index 100% rename from Symantic/CLI.hs rename to src/Symantic/CLI.hs diff --git a/src/Symantic/CLI/API.hs b/src/Symantic/CLI/API.hs new file mode 100644 index 0000000..5e5722a --- /dev/null +++ b/src/Symantic/CLI/API.hs @@ -0,0 +1,314 @@ +{-# 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 diff --git a/Symantic/CLI/Fixity.hs b/src/Symantic/CLI/Fixity.hs similarity index 80% rename from Symantic/CLI/Fixity.hs rename to src/Symantic/CLI/Fixity.hs index 8cd67ee..df8c9a2 100644 --- a/Symantic/CLI/Fixity.hs +++ b/src/Symantic/CLI/Fixity.hs @@ -52,30 +52,30 @@ infixN5 = infixN 5 -- 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 diff --git a/Symantic/CLI/HLint.hs b/src/Symantic/CLI/HLint.hs similarity index 100% rename from Symantic/CLI/HLint.hs rename to src/Symantic/CLI/HLint.hs diff --git a/src/Symantic/CLI/Help.hs b/src/Symantic/CLI/Help.hs new file mode 100644 index 0000000..8394a90 --- /dev/null +++ b/src/Symantic/CLI/Help.hs @@ -0,0 +1,340 @@ +{-# 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) (plpr) + 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) diff --git a/src/Symantic/CLI/Layout.hs b/src/Symantic/CLI/Layout.hs new file mode 100644 index 0000000..bbd898d --- /dev/null +++ b/src/Symantic/CLI/Layout.hs @@ -0,0 +1,348 @@ +{-# 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 = lsrs + Layout ls lh lm `alt` Layout rs rh rm = + (Layout ls lh lm Layout rs rh rm) + {layoutSchema=sch} + where sch = ls`alt`rs + opt (Layout xs xh xm) = Layout sch xh $ \inh -> do + modify' $ \k -> \case + Nothing -> k Nothing + Just _ts -> k $ Just [Tree.Node (LayoutNode_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) diff --git a/src/Symantic/CLI/Parser.hs b/src/Symantic/CLI/Parser.hs new file mode 100644 index 0000000..b9bb44e --- /dev/null +++ b/src/Symantic/CLI/Parser.hs @@ -0,0 +1,712 @@ +{-# 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]" diff --git a/src/Symantic/CLI/Schema.hs b/src/Symantic/CLI/Schema.hs new file mode 100644 index 0000000..e6ab26b --- /dev/null +++ b/src/Symantic/CLI/Schema.hs @@ -0,0 +1,315 @@ +{-# 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 diff --git a/Symantic/HLint.hs b/src/Symantic/HLint.hs similarity index 100% rename from Symantic/HLint.hs rename to src/Symantic/HLint.hs diff --git a/symantic-cli.cabal b/symantic-cli.cabal index 3331b04..7f55069 100644 --- a/symantic-cli.cabal +++ b/symantic-cli.cabal @@ -32,6 +32,7 @@ Source-Repository head type: git Library + hs-source-dirs: src exposed-modules: Symantic.CLI Symantic.CLI.API @@ -58,7 +59,6 @@ Library -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -fno-warn-tabs -- -fhide-source-paths build-depends: base >= 4.10 && < 5