symantic-cli 0.0.0.20180410 → 2.0.0.20190615
raw patch · 13 files changed
+1662/−851 lines, 13 filesdep −megaparsecdep ~symantic-document
Dependencies removed: megaparsec
Dependency ranges changed: symantic-document
Files
- Language/Symantic/CLI.hs +0/−4
- Language/Symantic/CLI/Fixity.hs +0/−91
- Language/Symantic/CLI/Help.hs +0/−223
- Language/Symantic/CLI/Plain.hs +0/−214
- Language/Symantic/CLI/Read.hs +0/−163
- Language/Symantic/CLI/Sym.hs +0/−135
- Symantic/CLI/API.hs +270/−0
- Symantic/CLI/Fixity.hs +91/−0
- Symantic/CLI/Help.hs +340/−0
- Symantic/CLI/Parser.hs +663/−0
- Symantic/CLI/Schema.hs +273/−0
- stack.yaml +2/−2
- symantic-cli.cabal +23/−19
− Language/Symantic/CLI.hs
@@ -1,4 +0,0 @@-module Language.Symantic.CLI- ( module Language.Symantic.CLI.Sym- ) where-import Language.Symantic.CLI.Sym
− Language/Symantic/CLI/Fixity.hs
@@ -1,91 +0,0 @@-module Language.Symantic.CLI.Fixity where--import Data.Bool-import Data.Eq (Eq(..))-import Data.Function ((.))-import Data.Int (Int)-import Data.Maybe (Maybe(..))-import Data.Ord (Ord(..))-import Text.Show (Show(..))-import qualified Data.Bool as Bool---- * Type 'Fixity'-data Fixity- = Fixity1 Unifix- | Fixity2 Infix- deriving (Eq, Show)---- ** Type 'Unifix'-data Unifix- = Prefix { unifix_prece :: Precedence }- | Postfix { unifix_prece :: Precedence }- deriving (Eq, Show)---- ** Type 'Infix'-data Infix- = Infix- { infix_assoc :: Maybe Associativity- , infix_prece :: Precedence- } deriving (Eq, Show)--infixL :: Precedence -> Infix-infixL = Infix (Just AssocL)--infixR :: Precedence -> Infix-infixR = Infix (Just AssocR)--infixB :: Side -> Precedence -> Infix-infixB = Infix . Just . AssocB--infixN :: Precedence -> Infix-infixN = Infix Nothing--infixN0 :: Infix-infixN0 = infixN 0--infixN5 :: Infix-infixN5 = infixN 5---- | Given 'Precedence' and 'Associativity' of its parent operator,--- and the operand 'Side' it is in,--- return whether an 'Infix' operator--- 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---- * Type 'Precedence'-type Precedence = Int---- ** Class 'PrecedenceOf'-class PrecedenceOf a where- precedence :: a -> Precedence-instance PrecedenceOf Fixity where- precedence (Fixity1 uni) = precedence uni- precedence (Fixity2 inf) = precedence inf-instance PrecedenceOf Unifix where- precedence = unifix_prece-instance PrecedenceOf Infix where- precedence = infix_prece---- * Type 'Associativity'-data Associativity- = AssocL -- ^ Associate to the left: @a ¹ b ² c == (a ¹ b) ² c@- | AssocR -- ^ Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@- | AssocB Side -- ^ Associate to both sides, but to 'Side' when reading.- deriving (Eq, Show)---- ** Type 'Side'-data Side- = SideL -- ^ Left- | SideR -- ^ Right- deriving (Eq, Show)
− Language/Symantic/CLI/Help.hs
@@ -1,223 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Language.Symantic.CLI.Help where--import Control.Applicative (Applicative(..))-import Data.Bool-import Data.Function (($), (.))-import Data.Functor ((<$>))-import Data.Functor.Compose (Compose(..))-import Data.Maybe (Maybe(..), maybeToList, maybe)-import Data.Monoid (Monoid(..))-import Data.Semigroup (Semigroup(..))-import qualified Language.Symantic.Document.Term as Doc-import Data.Tree as Tree--import Language.Symantic.CLI.Sym-import qualified Language.Symantic.CLI.Plain as Plain---- * Type 'Reader'-data Reader d- = Reader- { reader_help :: Maybe d- , reader_command_indent :: Doc.Indent- , reader_option_indent :: Doc.Indent- , reader_plain :: Plain.Reader d- , reader_option_empty :: Bool- }--defReader :: Doc.Textable d => Reader d-defReader = Reader- { reader_help = Nothing- , reader_command_indent = 2- , reader_option_indent = 15- , reader_plain = Plain.defReader- , reader_option_empty = False- }---- * Type 'Result'-type Result d = Tree.Forest (DocNode d)--defResult :: Monoid d => Result d-defResult = mempty---- ** Type 'DocNode'-data DocNode d- = Leaf- { docNodeSep :: d- , docNode :: d- }- | Indented- { docNodeIndent :: Doc.Indent- , docNodeSep :: d- , docNode :: d- }- | BreakableFill- { docNodeIndent :: Doc.Indent- , docNodeSep :: d- , docNode :: d- }--docTree ::- Monoid d =>- Doc.Textable d =>- Doc.Indentable d =>- Tree (DocNode d) -> d-docTree (Tree.Node n []) = docNode n-docTree (Tree.Node n ts) =- case n of- Leaf{} -> docNode n- Indented ind _sep d -> d <> Doc.incrIndent ind (Doc.newline <> docTrees ts)- BreakableFill ind _sep d -> Doc.breakableFill ind d <> (Doc.align $ docTrees ts)--docTrees ::- Monoid d =>- Doc.Textable d =>- Doc.Indentable d =>- Tree.Forest (DocNode d) -> d-docTrees [] = Doc.empty-docTrees [t] = docTree t-docTrees (t0:ts) =- docTree t0 <> mconcat ((\t@(Tree.Node n _ns) -> docNodeSep n <> docTree t) <$> ts)---- * Type 'Help'-data Help d e t a- = Help- { help_result :: Reader d -> Result d- , help_plain :: Plain.Plain d e t a- }--runHelp :: Monoid d => Doc.Indentable d => Doc.Textable d => Help d e t a -> d-runHelp h = docTrees $ help_result h defReader--textHelp :: Plain.Doc d => Reader d -> Help d e t a -> d-textHelp def (Help h _p) = docTrees $ h def--coerceHelp :: Help d e s a -> Help d e t b-coerceHelp Help{help_plain, ..} = Help- { help_plain = Plain.coercePlain help_plain- , ..- }--instance Doc.Textable d => Semigroup (Help d e s a) where- Help hx px <> Help hy py = Help (hx<>hy) (px<>py)-instance (Doc.Textable d, Monoid d) => Monoid (Help d e s a) 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 . textHelp--}-instance Plain.Doc d => Sym_Fun (Help d) where- f <$$> Help h p = Help h (f<$$>p)-instance Plain.Doc d => Sym_App (Help d) where- value a = Help mempty (value a)- end = Help mempty end- Help hf pf <**> Help hx px = Help (hf<>hx) (pf<**>px)-instance Plain.Doc d => Sym_Alt (Help d) where- Help hl pl <||> Help hr pr = Help (hl<>hr) (pl<||>pr)- try (Help h p) = Help h (try p)- choice hs = Help (mconcat $ help_result <$> hs) (choice (help_plain <$> hs))- option a (Help h p) = Help h (option a p)-instance Plain.Doc d => Sym_AltApp (Help d) where- many (Help h p) = Help h (many p)- some (Help h p) = Help h (many p)--- * Type 'PermHelp'-data PermHelp d e t a- = PermHelp (Reader d -> Result d)- [Plain.Plain d e t a]-type instance Perm (Help d e t) = PermHelp d e t-instance Plain.Doc d => Sym_Interleaved (Help d) where- interleaved (PermHelp h ps) = Help h $ interleaved $ Compose ps- f <<$>> Help h p = PermHelp h $ getCompose $ f<<$>>p- f <<$?>> (a, Help h p) = PermHelp h $ getCompose $ f<<$?>>(a,p)- f <<$*>> Help h p = PermHelp h $ getCompose $ f<<$*>>p- PermHelp hl pl <<|>> Help hr pr = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|>>pr- PermHelp hl pl <<|?>> (a, Help hr pr) = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|?>>(a,pr)- PermHelp hl pl <<|*>> Help hr pr = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|*>>pr-instance Plain.Doc d => Sym_Rule (Help d) where- rule n (Help h p) =- Help (\ro ->- pure $- Tree.Node (Indented- (reader_command_indent ro)- (Doc.newline <> Doc.newline) $- ref<>" ::= "<>Plain.runPlain p' (reader_plain ro)) $- maybeToList (pure . Leaf Doc.empty <$> reader_help ro) <>- h ro{reader_help=Nothing}- ) p'- where- p' = rule n p- ref =- Doc.bold $- Doc.between (Doc.charH '<') (Doc.charH '>') $- Doc.magentaer $- Doc.stringH n-instance Plain.Doc d => Sym_Option (Help d) where- var n f = Help mempty (var n f)- tag n = Help mempty (tag n)- opt n (Help _h p) =- Help (\ro ->- case reader_help ro of- Nothing ->- if reader_option_empty ro- then- pure $ pure $ Leaf Doc.newline $ Doc.bold $- Plain.runPlain p' (reader_plain ro)- else []- Just msg ->- pure $- Tree.Node- (BreakableFill- (reader_option_indent ro)- Doc.newline- (Doc.bold $ Plain.runPlain p' (reader_plain ro) <> Doc.space)) $- pure $ pure $ Leaf Doc.empty msg- ) p'- where p' = opt n p-instance Plain.Doc d => Sym_Help d (Help d) where- help msg (Help h p) = Help- (\ro -> h ro{reader_help=Just msg})- (Language.Symantic.CLI.Sym.help msg p)-instance Plain.Doc d => Sym_Command (Help d) where- main n (Help h p) =- Help (\ro ->- pure $- Tree.Node (Indented 0- (Doc.newline <> Doc.newline) $- Plain.runPlain p' (reader_plain ro) <>- maybe Doc.empty- (\d -> Doc.newline <> Doc.newline <> d <> Doc.newline)- (reader_help ro)- ) $- h ro{reader_help=Nothing}- ) p'- where p' = main n p- command n (Help h p) =- Help (\ro ->- pure $- Tree.Node- (Indented- (reader_command_indent ro)- (Doc.newline <> Doc.newline) $- ref<>" ::= " <>- Plain.runPlain p' (reader_plain ro) <>- maybe Doc.empty- ( (<> Doc.newline)- . Doc.incrIndent (reader_command_indent ro)- . (Doc.newline <>) )- (reader_help ro)- ) $- h ro{reader_help=Nothing}- ) p'- where- p' = command n p- ref =- Doc.bold $- Doc.between (Doc.charH '<') (Doc.charH '>') $- Doc.magentaer $- Doc.stringH n-instance Plain.Doc d => Sym_Exit (Help d) where- exit e = Help mempty $ exit e
− Language/Symantic/CLI/Plain.hs
@@ -1,214 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Language.Symantic.CLI.Plain where--import Data.Bool-import Data.Function (($), (.))-import Data.Functor ((<$>))-import Data.Functor.Compose (Compose(..))-import Data.Maybe (Maybe(..), fromMaybe, catMaybes)-import Data.Monoid (Monoid(..))-import Data.Semigroup (Semigroup(..))-import Data.String (String, IsString(..))-import Text.Show (Show(..))-import qualified Data.Text.Lazy as TL-import qualified Language.Symantic.Document.Term as Doc-import qualified Language.Symantic.Document.Term.IO as DocIO--import Language.Symantic.CLI.Sym-import Language.Symantic.CLI.Fixity---- * Class 'Doc'-class- ( IsString d- , Semigroup d- , Monoid d- , Doc.Textable d- , Doc.Indentable d- , Doc.Breakable d- , Doc.Colorable d- , Doc.Decorable d- ) =>- Doc d-instance Doc Doc.Term-instance Doc DocIO.TermIO--words :: Doc.Textable d => Doc.Breakable d => String -> d-words m = Doc.breakableSpaces $ Doc.string <$> Doc.words m---- * Type 'Reader'--- | Constructed top-down-data Reader d- = Reader- { reader_op :: (Infix, Side) -- ^ Parent operator.- , reader_define :: Bool -- ^ Whether to print a definition, or not.- , reader_or :: d- }--defReader :: Doc.Textable d => Reader d-defReader = Reader- { reader_op = (infixN0, SideL)- , reader_define = True- , reader_or = Doc.stringH " | "- }--pairIfNeeded :: Doc d => Reader d -> Infix -> d -> d-pairIfNeeded Reader{..} op d =- if needsParenInfix reader_op op- then Doc.align $ Doc.between (Doc.charH '(') (Doc.charH ')') d- else d---- * Type 'Plain'-newtype Plain d e t a- = Plain { unPlain :: Reader d -> Maybe d }--runPlain :: Monoid d => Plain d e t a -> Reader d -> d-runPlain (Plain p) = fromMaybe mempty . p--coercePlain :: Plain d e t a -> Plain d e u b-coercePlain Plain{..} = Plain{..}--textPlain :: Monoid d => Doc.Textable d => Plain d e t a -> d-textPlain p = runPlain p defReader--instance Semigroup d => Semigroup (Plain d e t a) where- Plain x <> Plain y = Plain $ x <> y-instance (Semigroup d, Monoid d) => Monoid (Plain d e t a) where- mempty = Plain mempty- mappend = (<>)-instance (Semigroup d, IsString d) => IsString (Plain d e t a) where- fromString "" = Plain $ \_ro -> Nothing- fromString s = Plain $ \_ro -> Just $ fromString s-instance Show (Plain Doc.Term e t a) where- show = TL.unpack . Doc.textTerm . textPlain-instance Doc d => Sym_Fun (Plain d) where- _f <$$> Plain x = Plain $ \ro ->- pairIfNeeded ro op <$>- x ro{reader_op=(op, SideR)}- where- op = infixB SideL 10-instance Doc d => Sym_App (Plain d) where- value _ = Plain $ \_ro -> Nothing- end = Plain $ \_ro -> Nothing- Plain f <**> Plain x = Plain $ \ro ->- case (f ro{reader_op=(op, SideL)}, x ro{reader_op=(op, SideR)}) of- (Nothing, Nothing) -> Nothing- (Just f', Nothing) -> Just f'- (Nothing, Just x') -> Just x'- (Just f', Just x') -> Just $ pairIfNeeded ro op $ f' <> Doc.space <> x'- where- op = infixB SideL 10-instance Doc d => Sym_Alt (Plain d) where- lp <||> rp = Plain $ \ro ->- Just $- if needsParenInfix (reader_op ro) op- then- Doc.ifBreak- (Doc.align $- Doc.between (Doc.charH '(') (Doc.charH ')') $- Doc.space <>- runPlain lp ro{reader_op=(op, SideL), reader_or=Doc.newline<>Doc.charH '|'<>Doc.space} <>- Doc.newline <>- Doc.stringH "| " <>- runPlain rp ro{reader_op=(op, SideR), reader_or=Doc.newline<>Doc.charH '|'<>Doc.space} <>- Doc.newline)- (Doc.between (Doc.charH '(') (Doc.charH ')') $- Doc.withBreakable Nothing $- runPlain lp ro{reader_op=(op, SideL), reader_or=Doc.stringH " | "} <>- Doc.stringH " | " <>- runPlain rp ro{reader_op=(op, SideR), reader_or=Doc.stringH " | "})- else- runPlain lp ro{reader_op=(op, SideL)} <>- reader_or ro <>- runPlain rp ro{reader_op=(op, SideR)}- where op = infixB SideL 2- try p = p- choice [] = "<none>"- choice [p] = p- choice l@(_:_) = Plain $ \ro -> Just $- pairIfNeeded ro op $- Doc.foldWith ("\n| " <>) $- (($ ro{reader_op=(op, SideL)}) . runPlain) <$> l- where op = infixB SideL 2- option _a p = Plain $ \ro -> Just $- if needsParenInfix (reader_op ro) op- then- Doc.ifBreak- (Doc.align $- Doc.between (Doc.charH '[') (Doc.charH ']') $- Doc.space <>- runPlain p ro{reader_op=(op, SideL)} <>- Doc.newline)- (Doc.between (Doc.charH '[') (Doc.charH ']') $- Doc.withBreakable Nothing $- runPlain p ro{reader_op=(op, SideL), reader_or=Doc.stringH " | "})- else- runPlain p ro{reader_op=(op, SideL)}- where op = infixN0-instance Doc d => Sym_AltApp (Plain d) where- many p = Plain $ \ro -> Just $- runPlain p ro{reader_op=(op, SideL)}<>"*"- where op = infixN 10- some p = Plain $ \ro -> Just $- runPlain p ro{reader_op=(op, SideL)}<>"+"- where op = infixN 10-type instance Perm (Plain d e t) = Compose [] (Plain d e t)-instance Doc d => Sym_Interleaved (Plain d) where- interleaved (Compose []) = "<none>"- interleaved (Compose [Plain p]) = Plain p- interleaved (Compose l@(_:_)) = Plain $ \ro -> Just $- -- pairIfNeeded ro op $- Doc.align $- Doc.foldWith Doc.breakableSpace $- catMaybes $- (\(Plain p) ->- p ro- { reader_op=(op, SideL)- , reader_or=Doc.stringH " | " }- ) <$> l- where op = infixN 10- _f <<$>> Plain p = Compose [Plain p]- _f <<$?>> (_, Plain p) = Compose [coercePlain $ optional $ Plain p]- _f <<$*>> Plain p = Compose [coercePlain $ many $ Plain p]- Compose ws <<|>> Plain p = Compose $ coercePlain <$> ws <> [Plain p]- Compose ws <<|?>> (_, Plain p) = Compose $ coercePlain <$> ws <> [coercePlain $ optional $ Plain p]- Compose ws <<|*>> Plain p = Compose $ coercePlain <$> ws <> [coercePlain $ many $ Plain p]-instance Doc d => Sym_Rule (Plain d) where- rule n p = Plain $ \ro -> Just $- if reader_define ro- then runPlain p ro{reader_define=False}- else ref- where- ref =- Doc.bold $- Doc.between (Doc.charH '<') (Doc.charH '>') $- Doc.magentaer $- Doc.stringH n-instance Doc d => Sym_Option (Plain d) where- var n _f = Plain $ \_ro -> Just $ Doc.between (Doc.charH '<') (Doc.charH '>') (Doc.string n)- tag = fromString- opt n r = Plain $ \ro ->- unPlain (prefix n <**> coercePlain r) ro- where- prefix = \case- OptionName s l -> prefix (OptionNameShort s)<>"|"<>prefix (OptionNameLong l)- OptionNameShort s -> fromString ['-', s]- OptionNameLong l -> fromString ("--"<>l)-instance Doc d => Sym_Command (Plain d) where- main n r = Plain $ \ro -> Just $- if reader_define ro- then- runPlain- (fromString n <**> coercePlain r)- ro{reader_define = False}- else ref- where- ref =- Doc.bold $- Doc.between (Doc.charH '<') (Doc.charH '>') $- Doc.magentaer $- Doc.stringH n- command = main-instance Doc d => Sym_Help d (Plain d) where- help _msg p = p-instance Doc d => Sym_Exit (Plain d) where- exit _ = Plain $ \_ro -> Nothing
− Language/Symantic/CLI/Read.hs
@@ -1,163 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Language.Symantic.CLI.Read where--import Control.Applicative (Applicative(..), Alternative(..))-import Control.Arrow ((***))-import Control.Monad (Monad(..), MonadPlus(..))-import Data.Bool-import Data.Either (Either(..))-import Data.Eq (Eq(..))-import Data.Foldable (Foldable(..))-import Data.Function (($), (.))-import Data.Functor (Functor(..), (<$>))-import Data.Maybe (Maybe(..))-import Data.Monoid (Monoid(..))-import Data.Ord (Ord(..), Ordering(..))-import Data.Semigroup (Semigroup(..))-import Data.String (String)-import Text.Show (Show(..))-import qualified Data.List as List-import qualified Data.Set as Set-import qualified Text.Megaparsec as P-import qualified Text.Megaparsec.Perm as P--import Language.Symantic.CLI.Sym as Sym---- * Type 'Arg'-newtype Arg = Arg { unArg :: String }- deriving (Eq, Ord, Show)---- * Type 'Args'-newtype Args = Args { unArgs :: [Arg] }- deriving (Eq, Ord, Show, Semigroup, Monoid)-instance P.Stream Args where- type Token Args = Arg- type Tokens Args = Args- tokenToChunk _s = Args . pure- tokensToChunk _s = Args- chunkToTokens _s = unArgs- chunkLength _s = List.length . unArgs- chunkEmpty _s = List.null . unArgs- advance1 _s _ind (P.SourcePos n l c) _ = P.SourcePos n l (c <> P.pos1)- advanceN s ind pos = foldl' (P.advance1 s ind) pos . unArgs- take1_ as =- case unArgs as of- [] -> Nothing- t:ts -> Just (t, Args ts)- takeN_ n as | n <= 0 = Just (Args [], as)- | null (unArgs as) = Nothing- | otherwise = Just $ (Args *** Args) $ List.splitAt n $ unArgs as- takeWhile_ f = (Args *** Args) . List.span f . unArgs-instance P.ShowToken Arg where- showTokens toks =- List.intercalate ", " $ toList $ showArg <$> toks- where- showArg :: Arg -> String- showArg (Arg a@('-':_)) = a- showArg (Arg a) = "\""<>a<>"\""---- * Type 'Parser'-newtype Parser e s a- = Parser { unParser :: P.Parsec (ErrorRead e) Args a }- deriving (Functor, Applicative, Alternative, Monad, MonadPlus, P.MonadParsec (ErrorRead e) Args)--coerceParser :: Parser e s a -> Parser e t a-coerceParser = Parser . unParser--instance Sym_Fun Parser where- f <$$> Parser a = Parser $ f <$> a-instance Sym_App Parser where- value = Parser . pure- end = Parser P.eof- Parser f <**> Parser a = Parser $ f <*> a-instance Sym_Alt Parser where- (<||>) = (P.<|>)- optional = P.optional- option = P.option- choice = P.choice- try = P.try-instance Sym_AltApp Parser where- many = P.many- some = P.some-type instance Perm (Parser e s) = P.PermParser Args (Parser e s)-instance Sym_Interleaved Parser where- interleaved = P.makePermParser- (<<$>>) = (P.<$$>)- (<<|>>) = (P.<||>)- (<<$?>>) = (P.<$?>)- (<<|?>>) = (P.<|?>)- f <<$*>> a = f P.<$?> ([],P.some a)- f <<|*>> a = f P.<|?> ([],P.some a)-instance Sym_Command Parser where- main = command- command n p = P.token check (Just expected) *> coerceParser p- where- expected = Arg n- check a | a == expected = Right ()- check t = Left- ( Just $ P.Tokens $ pure t- , Set.singleton $ P.Tokens $ pure expected )-instance Sym_Option Parser where- var n f = do- let check = Right- let expected | List.null n = Arg "<string>"- | otherwise = Arg $ "<"<>n<>">"- Arg arg <- P.token check (Just expected)- case f arg of- Right a -> return a- Left err -> P.customFailure $ ErrorRead err- tag n = do- let expected = Arg n- let check t | t == expected = Right ()- | otherwise = Left ( Just $ P.Tokens $ pure t- , Set.singleton $ P.Tokens $ pure expected )- P.token check (Just expected)- opt n p =- (*> coerceParser p) $- case n of- OptionNameLong l ->- P.token (checkLong l) (Just $ expectedLong l)- OptionNameShort s ->- P.token (checkShort s) (Just $ expectedShort s)- OptionName s l ->- P.token (checkShort s) (Just $ expectedShort s) <|>- P.token (checkLong l) (Just $ expectedLong l)- where- expectedShort s = Arg ['-', s]- checkShort s a | a == expectedShort s = Right ()- checkShort s t = Left- ( Just $ P.Tokens $ pure t- , Set.singleton $ P.Tokens $ pure $ expectedShort s)- expectedLong l = Arg $ "--"<>l- checkLong l a | a == expectedLong l = Right ()- checkLong l t = Left- ( Just $ P.Tokens $ pure t- , Set.singleton $ P.Tokens $ pure $ expectedLong l)-instance Sym_Help d Parser where- help _msg p = p-instance Sym_Rule Parser where- rule _n = coerceParser-instance Sym_Exit Parser where- exit e =- Parser $- P.fancyFailure $ Set.singleton $- P.ErrorCustom $ ErrorRead e---- * Type 'ErrorRead'-newtype ErrorRead e- = ErrorRead e- deriving (Functor)-instance Show e => Show (ErrorRead e) where- showsPrec p (ErrorRead e) = showsPrec p e-instance Eq (ErrorRead a) where- _==_ = True-instance Ord (ErrorRead a) where- _`compare`_ = EQ-instance Show e => P.ShowErrorComponent (ErrorRead e) where- showErrorComponent = show--readArgs :: Parser e s a -> Args -> Either (P.ParseError (P.Token Args) (ErrorRead e)) a-readArgs p = P.runParser (unParser $ p <* end) ""
− Language/Symantic/CLI/Sym.hs
@@ -1,135 +0,0 @@-{-# LANGUAGE TypeFamilyDependencies #-}-module Language.Symantic.CLI.Sym where--import Data.Bool-import Data.Char (Char)-import Data.Either (Either(..))-import Data.Eq (Eq)-import Data.Function (($), (.), const, id)-import Data.Functor ((<$>))-import Data.Maybe (Maybe(..), catMaybes)-import Data.Ord (Ord(..))-import Data.String (String)-import Text.Show (Show)---- * @Arg@ types--- | Types to type the symantics:--- eg. to segregate options from commands.-data ArgCommand-data ArgOption-data ArgValue-data ArgRule t---- * Type 'Name'-type Name = String---- * Class 'Sym_Fun'-class Sym_Fun repr where- (<$$>) :: (a -> b) -> repr e t a -> repr e t b- (<$$) :: a -> repr e t b -> repr e t a- (<$$) = (<$$>) . const- ($$>) :: repr e t b -> a -> repr e t a- r $$> a = const a <$$> r--- * Class 'Sym_App'-class Sym_Fun repr => Sym_App repr where- value :: a -> repr e ArgValue a- (<**>) :: repr e t (a -> b) -> repr e u a -> repr e u b- (**>) :: repr e t a -> repr e u b -> repr e u b- a **> b = id <$$ a <**> b- (<**) :: repr e t a -> repr e u b -> repr e u a- a <** b = const <$$> a <**> b- end :: repr e t ()--- * Class 'Sym_Alt'-class Sym_Fun repr => Sym_Alt repr where- (<||>) :: repr e t a -> repr e t a -> repr e t a- choice :: [repr e t a] -> repr e t a- optional :: repr e t a -> repr e t (Maybe a)- optional a = option Nothing (Just <$$> a)- option :: a -> repr e t a -> repr e t a- try :: repr e t a -> repr e t a--- * Class 'Sym_AltApp'-class (Sym_Alt repr, Sym_App repr) => Sym_AltApp repr where- many :: repr e t a -> repr e t [a]- some :: repr e t a -> repr e t [a]- -- default intermany :: (Sym_Alt repr, Sym_App repr) => [repr e t a] -> repr e t [a]- intermany :: [repr e t a] -> repr e t [a]- intermany = many . choice . (try <$>)--- * Class 'Sym_Interleaved'-class Sym_Interleaved repr where- interleaved :: Perm (repr e t) a -> repr e t a- (<<$>>) :: (a -> b) -> repr e t a -> Perm (repr e t) b- (<<$?>>) :: (a -> b) -> (a, repr e t a) -> Perm (repr e t) b- (<<$*>>) :: ([a] -> b) -> repr e t a -> Perm (repr e t) b- (<<|>>) :: Perm (repr e t) (a -> b) -> repr e t a -> Perm (repr e t) b- (<<|?>>) :: Perm (repr e t) (a -> b) -> (a, repr e t a) -> Perm (repr e t) b- (<<|*>>) :: Perm (repr e t) ([a] -> b) -> repr e t a -> Perm (repr e t) b- - (<<$) :: a -> repr e t b -> Perm (repr e t) a- (<<$) = (<<$>>) . const- (<<$?) :: a -> (b, repr e t b) -> Perm (repr e t) a- a <<$? b = const a <<$?>> b- {- NOTE: cannot be done without and instance:- - Functor (P.PermParser s m)- (<<|) :: Functor (Perm (repr e t)) => Perm (repr e t) a -> repr e t b -> Perm (repr e t) a- (<<|?) :: Functor (Perm (repr e t)) => Perm (repr e t) a -> (b, repr e t b) -> Perm (repr e t) a- a <<| b = (const <$> a) <<|>> b- a <<|? b = (const <$> a) <<|?>> b- -}-infixl 4 <$$>-infixl 4 <**>-infixl 3 <||>-infixl 2 <<$>>, <<$?>>, <<$*>>-infixl 1 <<|>>, <<|?>>, <<|*>>--- ** Type family 'Perm'-type family Perm (repr:: * -> *) = (r :: * -> *) | r -> repr--- * Class 'Sym_Rule'-class Sym_Rule repr where- rule :: String -> repr e t a -> repr e t a- -- rule _n = id--- * Class 'Sym_Command'-class Sym_Command repr where- main :: Name -> repr e t a -> repr e ArgCommand a- command :: Name -> repr e t a -> repr e ArgCommand a--- * Class 'Sym_Option'-class Sym_AltApp repr => Sym_Option repr where- opt :: OptionName -> repr e s a -> repr e ArgOption a- var :: Name -> (String -> Either e a) -> repr e ArgValue a- tag :: String -> repr e ArgValue ()- -- int :: repr e ArgValue Int- - long :: Name -> repr e ArgValue a -> repr e ArgOption a- short :: Char -> repr e ArgValue a -> repr e ArgOption a- flag :: OptionName -> (Bool, repr e ArgOption Bool)- endOpt :: repr e ArgOption ()- string :: Name -> repr e ArgValue String- long = opt . OptionNameLong- short = opt . OptionNameShort- flag n = (False,) $ opt n $ value True- endOpt = option () $ opt (OptionNameLong "") $ value ()- string n = var n Right--- ** Type 'OptionName'-data OptionName- = OptionName Char Name- | OptionNameLong Name- | OptionNameShort Char- deriving (Eq, Show)-instance Ord OptionName where- x`compare`y =- catMaybes [longOf x, shortOf x]- `compare`- catMaybes [longOf y, shortOf y]- where- longOf = \case- OptionName _s l -> Just l- OptionNameLong l -> Just l- OptionNameShort _s -> Nothing- shortOf = \case- OptionName s _l -> Just [s]- OptionNameLong _l -> Nothing- OptionNameShort s -> Just [s]--- * Class 'Sym_Help'-class Sym_Help d repr where- help :: d -> repr e t a -> repr e t a--- * Class 'Sym_Exit'-class Sym_Exit repr where- exit :: e -> repr e t ()
+ Symantic/CLI/API.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE UndecidableInstances #-} -- for type instance defaults+module Symantic.CLI.API where++import Control.Applicative (Applicative(..), Alternative(..))+import Control.Monad (Monad(..))+import Data.Bool+import Data.Char (Char)+import Data.Eq (Eq)+import Data.Function (($), (.), id)+import Data.Int (Int)+import Data.Kind (Constraint)+import Data.Maybe (Maybe(..), maybe)+import Data.Monoid (Monoid)+import Data.String (String)+import Data.Text (Text)+import Text.Show (Show)+import Data.Functor (Functor(..), (<$>))++-- * 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+ -- Trans defaults+ default (<!>) ::+ Trans repr =>+ Alt (UnTrans repr) =>+ repr a k -> repr b k -> repr (a:!:b) k+ x <!> y = noTrans (unTrans x <!> unTrans y)+ opt :: repr (a->k) k -> repr (Maybe a->k) k+infixr 3 <!>++-- ** 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+ 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+ -- 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 <?>++-- * 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+ just :: a -> repr (a->k) k+ nothing :: repr 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+ default just ::+ Trans repr =>+ CLI_Var (UnTrans repr) =>+ a -> repr (a->k) k+ default nothing ::+ Trans repr =>+ CLI_Var (UnTrans repr) =>+ repr k k+ var' = noTrans . var'+ just = noTrans . just+ nothing = noTrans nothing++-- | 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_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)++-- * Class 'CLI_Tag'+class (App repr, Permutable repr, CLI_Var repr) => CLI_Tag repr where+ type TagConstraint repr a :: Constraint+ tagged :: Tag -> repr f k -> repr f k+ endOpts :: repr k k+ + -- tagged n = (tag n <.>)+ short :: TagConstraint repr a => Char -> repr (a->k) k -> Permutation repr k a+ short n = toPermutation . tagged (TagShort n)+ long :: TagConstraint repr a => Name -> repr (a->k) k -> Permutation repr k a+ long n = toPermutation . tagged (TagLong n)+ + option :: TagConstraint repr a => a -> repr (a->k) k -> Permutation repr k a+ option = toPermDefault+ flag :: TagConstraint repr Bool => Tag -> Permutation repr k Bool+ flag n = toPermDefault False $ tagged n $ just True+ shortOpt :: TagConstraint repr a => Char -> a -> repr (a->k) k -> Permutation repr k a+ shortOpt n a = toPermDefault a . tagged (TagShort n)+ longOpt :: TagConstraint repr a => Name -> a -> repr (a->k) k -> Permutation repr k a+ longOpt n a = toPermDefault a . tagged (TagLong n)+ + -- Trans defaults+ type TagConstraint repr a = TagConstraint (UnTrans repr) a+ default tagged ::+ Trans repr =>+ CLI_Tag (UnTrans repr) =>+ Tag -> repr f k -> repr f k+ default endOpts ::+ Trans repr =>+ CLI_Tag (UnTrans repr) =>+ repr k k+ tagged n = noTrans . tagged 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
+ Symantic/CLI/Fixity.hs view
@@ -0,0 +1,91 @@+module Symantic.CLI.Fixity where++import Data.Bool+import Data.Eq (Eq(..))+import Data.Function ((.))+import Data.Int (Int)+import Data.Maybe (Maybe(..))+import Data.Ord (Ord(..))+import Text.Show (Show(..))+import qualified Data.Bool as Bool++-- * Type 'Fixity'+data Fixity+ = Fixity1 Unifix+ | Fixity2 Infix+ deriving (Eq, Show)++-- ** Type 'Unifix'+data Unifix+ = Prefix { unifix_prece :: Precedence }+ | Postfix { unifix_prece :: Precedence }+ deriving (Eq, Show)++-- ** Type 'Infix'+data Infix+ = Infix+ { infix_assoc :: Maybe Associativity+ , infix_prece :: Precedence+ } deriving (Eq, Show)++infixL :: Precedence -> Infix+infixL = Infix (Just AssocL)++infixR :: Precedence -> Infix+infixR = Infix (Just AssocR)++infixB :: Side -> Precedence -> Infix+infixB = Infix . Just . AssocB++infixN :: Precedence -> Infix+infixN = Infix Nothing++infixN0 :: Infix+infixN0 = infixN 0++infixN5 :: Infix+infixN5 = infixN 5++-- | Given 'Precedence' and 'Associativity' of its parent operator,+-- and the operand 'Side' it is in,+-- return whether an 'Infix' operator+-- 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++-- * Type 'Precedence'+type Precedence = Int++-- ** Class 'PrecedenceOf'+class PrecedenceOf a where+ precedence :: a -> Precedence+instance PrecedenceOf Fixity where+ precedence (Fixity1 uni) = precedence uni+ precedence (Fixity2 inf) = precedence inf+instance PrecedenceOf Unifix where+ precedence = unifix_prece+instance PrecedenceOf Infix where+ precedence = infix_prece++-- * Type 'Associativity'+data Associativity+ = AssocL -- ^ Associate to the left: @a ¹ b ² c == (a ¹ b) ² c@+ | AssocR -- ^ Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@+ | AssocB Side -- ^ Associate to both sides, but to 'Side' when reading.+ deriving (Eq, Show)++-- ** Type 'Side'+data Side+ = SideL -- ^ Left+ | SideR -- ^ Right+ deriving (Eq, Show)
+ Symantic/CLI/Help.hs view
@@ -0,0 +1,340 @@+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-} -- for DocFrom (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 :: Docable d => HelpInh d -> Help d f k -> d+runHelp def (Help h _p) = runHelpNodes def (h def) <> Doc.newline++docHelp :: Docable d => Doc.Indentable d => Docable d => Help d f k -> d+docHelp = 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 :: Docable 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 ::+ Monoid d =>+ Docable d =>+ Tree (HelpNode, d) -> d+runHelpNode (Tree.Node (n,d) _ts) = d -- "[" <> Doc.stringH (show n) <> "]" <> d++-- | Introduce 'Doc.newline' according to the 'HelpNode's+-- put next to each others.+runHelpNodes ::+ Monoid d =>+ Docable d =>+ HelpInh d ->+ Tree.Forest (HelpNode, d) -> d+runHelpNodes inh [] = mempty+runHelpNodes inh ( t0@(Tree.Node (HelpNode_Command, _) 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 (HelpNode_Env, _) _) : 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_Env, _) _)+ : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =+ runHelpNode t0 <>+ 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@(Tree.Node (HelpNode_Message, _) _)+ : t1 : ts ) =+ runHelpNode t0 <>+ Doc.newline <>+ 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 Docable d => Functor (Help d f) where+ f <$$> Help h s = Help h (f<$$>s)+-}+instance Docable d => App (Help d) where+ Help hf pf <.> Help hx px = Help (hf<>hx) (pf<.>px)+instance Docable d => Alt (Help d) where+ Help hl pl <!> Help hr pr = Help (hl<>hr) (pl<!>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 Docable d => Permutable (Help d) where+ type Permutation (Help d) = HelpPerm d+ runPermutation (HelpPerm h s) = Help h $ runPermutation s+ toPermutation (Help h s) = HelpPerm h $ toPermutation s+ toPermDefault a (Help h s) = HelpPerm h $ toPermDefault a s+instance Pro (Help d) where+ dimap a2b b2a (Help h s) = Help h $ dimap a2b b2a s+instance Docable d => AltApp (Help d) where+ many0 (Help h s) = Help h (many0 s)+ many1 (Help h s) = Help h (many1 s)+instance Docable d => CLI_Var (Help d) where+ type VarConstraint (Help d) a = ()+ var' n = Help mempty (var' n)+ just a = Help mempty (just a)+ nothing = Help mempty nothing+instance Docable d => CLI_Env (Help d) where+ type EnvConstraint (Help d) a = ()+ env' n =+ Help (\inh ->+ let ts = maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) in+ let d =+ Doc.breakfill (helpInh_tag_indent inh)+ (Doc.bold (Doc.green (Doc.docFrom (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 Docable 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 =+ (if not (null n) && helpInh_command_rule inh then ref<>Doc.space<>"::= " else mempty)+ <> Schema.runSchema schema (helpInh_schema inh)+ <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)+ <> Doc.incrIndent (helpInh_command_indent inh)+ ((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.docFrom (Doc.Word n)+instance Docable d => CLI_Tag (Help d) where+ type TagConstraint (Help d) a = ()+ tagged 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.breakfill (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 = tagged n s+ endOpts = Help mempty endOpts+instance Docable 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 =+ Schema.runSchema schema (helpInh_schema inh)+ <> (if null ts {-|| not (helpInh_full inh)-} then mempty else Doc.newline)+ <> Doc.incrIndent+ (helpInh_command_indent inh)+ ((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 =+ ref<>Doc.space<>"::= "+ <> Schema.runSchema schema (helpInh_schema inh)+ <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)+ <> Doc.incrIndent+ (helpInh_command_indent inh)+ ((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.docFrom (Doc.Word n)+type HelpResponseArgs = SchemaResponseArgs+instance Docable 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 Docable 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 Docable 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)
+ Symantic/CLI/Parser.hs view
@@ -0,0 +1,663 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+module Symantic.CLI.Parser where++import Control.Applicative (Applicative(..), Alternative(..), optional, many, some)+import Control.Arrow (first)+import Control.Monad (Monad(..), join, sequence, unless)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Except (ExceptT(..),throwE,runExceptT)+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.Function (($), (.), id, const)+import Data.Functor (Functor(..), (<$>))+import Data.Functor.Identity (Identity(..))+import Data.Int (Int)+import Data.Map.Strict (Map)+import Data.Maybe (Maybe(..), maybe)+import Data.Monoid (Monoid(..))+import Data.Ord (Ord(..))+import Data.Semigroup (Semigroup(..))+import Data.String (String)+import System.Environment (lookupEnv)+import System.IO (IO)+import Text.Read (readEither)+import Text.Show (Show(..), ShowS, showString, showParen)+import Type.Reflection as Reflection+import qualified Data.List as List+import qualified Data.Text.Lazy.IO as TL+import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Map.Merge.Strict as Map+import qualified Data.Map.Strict as Map+import qualified Symantic.Document as Doc+import qualified System.IO as IO+-- import qualified Debug.Trace as Debug++import Symantic.CLI.API++-- * Type 'Parser'+newtype Parser d f k = Parser+ { unParser :: StateT ParserState+ (ParserCheckT [ParserError] IO)+ (f -> k) -- Reader f k+ }+instance Functor (Parser d f) where+ a2b`fmap`Parser x = Parser $ (a2b <$>) <$> x+instance Applicative (Parser d f) where+ pure = Parser . pure . const+ Parser f <*> Parser x = Parser $ (<*>) <$> f <*> x+instance Alternative (Parser d f) where+ empty = Parser $ do+ StateT $ \st ->+ throwE $ Fail st [ParserError_Alt]+ Parser x <|> Parser y = Parser $+ StateT $ \st -> do+ lift (runExceptT (runStateT x st)) >>= \case+ Left xe | FailFatal{} <- xe -> throwE xe+ | otherwise ->+ lift (runExceptT (runStateT y st)) >>= \case+ Left ye -> throwE (xe<>ye)+ Right yr -> ExceptT $ return $ Right yr+ Right xr ->+ return xr+instance Permutable (Parser d) where+ type Permutation (Parser d) = ParserPerm d (Parser d)+ runPermutation (ParserPerm ma p) = Parser $ do+ u2p <- unParser $ optional p+ unParser $+ case u2p () of+ Nothing -> maybe empty (Parser . return) ma+ Just perm -> runPermutation perm+ 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)++parser ::+ -- d ~ String => -- dummy d+ Router (Parser d) handlers (Response (Router (Parser d))) ->+ handlers ->+ [Arg] -> IO ()+parser api handlers args = do+ lrApp <-+ runExceptT $ runStateT+ (unParser $ unTrans $ router api)+ ParserState+ { parserState_args = args+ }+ case lrApp of+ Left err -> IO.print err+ Right (app, _st) -> unResponseParser $ app handlers++-- | Helper to parse the current argument.+popArg ::+ ParserError ->+ (Arg ->+ StateT ParserState (ParserCheckT [ParserError] IO) a) ->+ StateT ParserState (ParserCheckT [ParserError] IO) a+popArg errEnd f = do+ st <- get+ case parserState_args st of+ [] -> lift $ throwE $ Fail st [errEnd]+ curr:next -> do+ lift (lift (runExceptT (runStateT (f curr) (ParserState next)))) >>= \case+ Left err -> lift $ throwE err+ Right (a,st') -> do+ put st'+ return a++-- ** Type 'Arg'+data Arg+ = ArgTagShort Char+ | ArgTagLong Name+ | ArgSegment Segment+ deriving (Eq,Show)++parseArgs :: [String] -> [Arg]+parseArgs 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]++-- ** Type 'ParserState'+newtype ParserState = ParserState+ { parserState_args :: [Arg]+ } deriving (Show)++-- ** Type 'Router'+type ParserCheckT e = ExceptT (Fail e)++-- ** Type 'ParserError'+data ParserError+ = ParserError_Alt -- ^ When there is no alternative.+ | ParserError_Arg { expectedArg :: Name, gotArg :: Maybe Arg }+ | ParserError_Env { expectedEnv :: Name, gotEnv :: Maybe String }+ | ParserError_Tag { expectedTag :: Tag, gotArg :: Maybe Arg }+ | ParserError_Cmd { expectedCmd :: [Name], gotCmd :: Maybe Arg }+ | ParserError_Var { expectedVar :: Name, gotVar :: Maybe Arg }+ | ParserError_End { gotEnd :: Arg }+ deriving (Eq,Show)++-- *** Type 'RouteResult'+type RouteResult e = Either (Fail e)++-- *** Type 'Fail'+data Fail e+ = Fail ParserState e -- ^ Keep trying other paths.+ | FailFatal !ParserState !e -- ^ Don't try other paths.+ deriving (Show)+failState :: Fail e -> ParserState+failState (Fail st _) = st+failState (FailFatal st _) = st+failError :: Fail e -> e+failError (Fail _st e) = e+failError (FailFatal _st e) = e+instance Semigroup e => Semigroup (Fail e) where+ Fail _ x <> Fail st y = Fail st (x<>y)+ FailFatal _ x <> Fail st _y = FailFatal st (x{-<>y-})+ Fail _ _x <> FailFatal st y = FailFatal st ({-x<>-}y)+ FailFatal _ x <> FailFatal st y = FailFatal st (x<>y)+instance Monoid e => Monoid (Fail e) where+ mempty = Fail (ParserState []) mempty+ mappend = (<>)++-- * Class 'FromSegment'+class FromSegment a where+ fromSegment :: Segment -> Either String a+instance FromSegment String where+ fromSegment = Right+instance FromSegment Int where+ fromSegment = readEither+instance FromSegment Bool where+ fromSegment = readEither++-- ** Type 'ParserPerm'+data ParserPerm d repr k a = ParserPerm+ { permutation_result :: !(Maybe ((a->k)->k))+ , permutation_parser :: repr () (ParserPerm d repr k a)+ }++instance (App repr, Functor (repr ())) => Functor (ParserPerm d repr k) where+ a2b `fmap` ParserPerm a ma = ParserPerm+ ((\a2k2k b2k -> a2k2k $ b2k . a2b) <$> a)+ ((a2b `fmap`) `fmap` ma)+instance (App repr, Functor (repr ()), Alternative (repr ())) => Applicative (ParserPerm d repr k) where+ pure a = ParserPerm (Just ($ a)) empty+ lhs@(ParserPerm f ma2b) <*> rhs@(ParserPerm x ma) =+ ParserPerm a (lhsAlt <|> rhsAlt)+ where+ a =+ (\a2b2k2k a2k2k -> \b2k ->+ a2b2k2k $ \a2b -> a2k2k (b2k . a2b)+ ) <$> f <*> x+ lhsAlt = (<*> rhs) <$> ma2b+ rhsAlt = (lhs <*>) <$> ma+instance CLI_Help repr => CLI_Help (ParserPerm d repr) where+ type HelpConstraint (ParserPerm d repr) d' = HelpConstraint (Parser d) d'+ program _n = id+ rule _n = id++noTransParserPerm ::+ Trans repr =>+ Functor (UnTrans repr ()) =>+ ParserPerm d (UnTrans repr) k a -> ParserPerm d repr k a+noTransParserPerm (ParserPerm a ma) = ParserPerm a (noTrans $ noTransParserPerm <$> ma)++unTransParserPerm ::+ Trans repr =>+ Functor (UnTrans repr ()) =>+ ParserPerm d repr k a -> ParserPerm 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 d repr k c -> ParserPerm d repr k c+hoistParserPerm f (ParserPerm a ma) =+ ParserPerm a (hoistParserPerm f <$> f ma)++instance App (Parser d) where+ Parser x <.> Parser y = Parser $+ x >>= \a2b -> (. a2b) <$> y+instance Alt (Parser d) where+ Parser x <!> Parser y = Parser $+ StateT $ \st -> do+ lift (runExceptT (runStateT x st)) >>= \case+ Left xe | FailFatal{} <- xe -> throwE xe+ | otherwise ->+ lift (runExceptT (runStateT y st)) >>= \case+ Left ye -> throwE (xe<>ye)+ Right yr -> ExceptT $ return $ Right $+ first (\b2k (_a:!:b) -> b2k b) yr+ Right xr ->+ return $ first (\a2k (a:!:_b) -> a2k a) xr+ opt (Parser x) = Parser $ do+ st <- get+ lift (lift (runExceptT $ runStateT x st)) >>= \case+ Left err -> return ($ Nothing)+ Right (a,st') -> do+ put st'+ return (mapCont Just a)+instance AltApp (Parser d) where+ many0 (Parser x) = Parser $ concatCont <$> many x+ many1 (Parser x) = Parser $ concatCont <$> some x+instance Pro (Parser d) where+ dimap a2b _b2a (Parser r) = Parser $ (\k b2k -> k (b2k . a2b)) <$> r+instance CLI_Command (Parser d) where+ -- type CommandConstraint (Parser d) a = ()+ command "" x = x+ command n x = commands $ Map.singleton n x+instance CLI_Var (Parser d) where+ type VarConstraint (Parser d) a = FromSegment a+ var' :: forall a k. VarConstraint (Parser d) a => Name -> Parser d (a->k) k+ var' name = Parser $ do+ popArg (ParserError_Var name Nothing) $ \curr -> do+ st@ParserState{..} <- get+ case curr of+ ArgSegment seg ->+ case fromSegment seg of+ Left err -> lift $ throwE $ Fail st [ParserError_Var name (Just curr)]+ Right a -> return ($ a)+ _ -> lift $ throwE $ Fail st [ParserError_Var name (Just curr)]+ just a = Parser $ return ($ a)+ nothing = Parser $ return id+instance CLI_Env (Parser d) where+ type EnvConstraint (Parser d) a = FromSegment a+ env' :: forall a k. EnvConstraint (Parser d) a => Name -> Parser d (a->k) k+ env' name = Parser $ do+ st <- get+ lift (lift (lookupEnv name)) >>= \case+ Nothing -> lift $ throwE $ Fail st [ParserError_Env name Nothing]+ Just raw ->+ case fromSegment raw of+ Left err -> lift $ throwE $ Fail st [ParserError_Env name (Just raw)]+ Right a -> return ($ a)++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)++instance CLI_Tag (Parser d) where+ type TagConstraint (Parser d) a = ()+ tagged name p = Parser $ do+ popArg (ParserError_Tag name Nothing) $ \curr -> do+ st <- get+ case lookupTag curr name of+ False -> lift $ throwE $ Fail st [ParserError_Tag name (Just curr)]+ True ->+ lift (lift (runExceptT (runStateT (unParser p) st))) >>= \case+ Left (Fail st' e) -> lift $ throwE $ FailFatal st' e+ Left e -> lift $ throwE e+ Right (a,st') -> do+ put st'+ return a+ where+ 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+ popArg (ParserError_Tag (TagLong "") Nothing) $ \curr -> do+ st@ParserState{..} <- get+ case curr of+ ArgTagLong "" -> return id+ _ -> return id -- TODO: raise an error and use option?++-- ** Type 'ParserResponse'+newtype ParserResponse = ParserResponse { unResponseParser :: IO () }+-- ** Type 'ParserResponseArgs'+newtype ParserResponseArgs a = ParserResponseArgs (IO a)+ deriving (Functor,Applicative,Monad)++instance CLI_Response (Parser d) where+ type ResponseConstraint (Parser d) a = Outputable a+ type ResponseArgs (Parser d) a = ParserResponseArgs a+ type Response (Parser d) = ParserResponse+ response' = Parser $ do+ st <- get+ unless (List.null $ parserState_args st) $ do+ lift $ throwE $ Fail st [ParserError_End $+ List.head $ parserState_args st]+ return $ \(ParserResponseArgs io) ->+ ParserResponse $ io >>= output++-- * 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 String where+ output = IO.putStrLn++instance Outputable (Doc.AnsiText (Doc.Plain TLB.Builder)) where+ output =+ TL.putStr .+ TLB.toLazyText .+ Doc.runPlain .+ Doc.runAnsiText++{-+instance Outputable (Doc.Reorg Doc.Term) where+ output = TL.hPutStrLn IO.stdout . Doc.textTerm+instance Outputable (Doc.Reorg DocIO.TermIO) where+ output = DocIO.runTermIO IO.stdout+instance Outputable (IO.Handle, (Doc.Reorg DocIO.TermIO)) where+ output = uncurry DocIO.runTermIO+-}++-- * 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 String+instance IOType (Doc.AnsiText (Doc.Plain TLB.Builder))+{-+instance IOType (Doc.Reorg Doc.Term) where+instance IOType (Doc.Reorg DocIO.TermIO) where+instance IOType (IO.Handle, Doc.Reorg DocIO.TermIO)+-}++instance CLI_Help (Parser d) where+ type HelpConstraint (Parser d) d' = d ~ d'+ help _msg = id+ program _n = id+ rule _n = id+++-- ** Class 'CLI_Routing'+class CLI_Routing repr where+ commands :: Map Name (repr a k) -> repr a k+ -- taggeds :: TagConstraint repr a => Map (Either Char Name) (repr (a -> k) k) -> repr (a -> k) k+instance CLI_Routing (Parser d) where+ commands cmds = Parser $ do+ st@ParserState{..} <- get+ let exp = Map.keys cmds+ popArg (ParserError_Cmd exp Nothing) $ \curr ->+ case curr of+ ArgSegment cmd ->+ case Map.lookup cmd cmds of+ Nothing -> lift $ throwE $ Fail st [ParserError_Cmd exp (Just curr)]+ Just x -> unParser x+ _ -> lift $ throwE $ Fail st [ParserError_Cmd exp (Just curr)]+ {-+ taggeds ms = Parser $ do+ st@ParserState{..} <- get+ case parserState_args of+ [] -> lift $ throwE $ Fail st [ParserError "empty path segment"]+ curr:next ->+ case lookupTag curr of+ Nothing -> lift $ throwE $ Fail st [ParserError $ "expected: "<>fromString (show (Map.keys ms))<>" but got: "<>fromString (show curr)]+ Just x -> do+ put st{parserState_args=next}+ unParser x+ where+ lookupTag (ArgTagShort x) = Map.lookup (Left x) ms+ lookupTag (ArgTagLong x) = Map.lookup (Right x) ms+ lookupTag _ = Nothing+ -}++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) -> Router repr a k+ -- | Represent 'tagged'.+ Router_Tagged :: Tag -> Router repr f k -> Router repr f k+ -- | Represent 'taggeds'.+ {-+ Router_Taggeds :: TagConstraint repr a =>+ Map (Either Char Name) (Router repr (a -> k) k) ->+ Router repr (a -> k) 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 Functor (Router (Parser d) f) where+ a2b`fmap`x = noTrans (a2b <$> unTrans x)+instance Applicative (Router (Parser d) f) where+ pure = noTrans . pure+ f <*> x = noTrans (unTrans f <*> unTrans x)+instance Alternative (Router (Parser d) f) where+ empty = noTrans empty+ f <|> x = noTrans (unTrans f <|> unTrans x)+instance Permutable (Router (Parser d)) where+ type Permutation (Router (Parser d)) = ParserPerm d (Router (Parser d))+ runPermutation = noTrans . runPermutation . unTransParserPerm+ toPermutation = noTransParserPerm . toPermutation . unTrans+ toPermDefault a = noTransParserPerm . toPermDefault a . unTrans+instance (repr ~ Parser d) => Show (Router repr a b) where+ showsPrec p = \case+ Router_Any{} -> showString "X"+ Router_Commands ms -> showParen (p>=10) $ showString "Commands [" . go (Map.toList ms) . 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_Command n os x -> showString n . showString " " . showsPrec 10 (permutation_parser os) . showString " " . showsPrec p x+ Router_Tagged n x -> showsPrec 10 n . showString " " . showsPrec p x+ {-+ Router_Taggeds ms -> showParen (p>=10) $+ showString "taggeds [" . go (Map.toList ms) . showString "]"+ where+ go :: forall h k. [(Either Char Name, 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_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 Trans (Router (Parser d)) where+ type UnTrans (Router (Parser d)) = Parser 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_Command n os x) = command n (unTransParserPerm os) (unTrans x)+ unTrans (Router_Commands ms) = commands (unTrans <$> ms)+ unTrans (Router_Tagged n x) = tagged n (unTrans x)+ -- unTrans (Router_Taggeds ms) = taggeds (unTrans <$> ms)+ unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x)++instance App (Router (Parser d)) where+ (<.>) = Router_App+instance Alt (Router (Parser d)) where+ (<!>) = Router_Alt+instance Pro (Router (Parser d))+instance repr ~ (Parser d) => CLI_Command (Router repr) where+ -- command = Router_Command+ command "" x = x+ command n x = Router_Commands $ Map.singleton n x+instance CLI_Var (Router (Parser d))+instance CLI_Env (Router (Parser d))+instance CLI_Tag (Router (Parser d)) where+ tagged = Router_Tagged+instance CLI_Help (Router (Parser 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 CLI_Response (Router (Parser d))+instance CLI_Routing (Router (Parser d)) where+ -- taggeds = Router_Taggeds+ commands = Router_Commands++router ::+ repr ~ Parser d =>+ Router repr a b -> Router repr a b+router = {-debug1 "router" $-} \case+ x@Router_Any{} -> x+ -- Router_Command n os x -> Router_Command n (hoistParserPerm router os) (router x)+ Router_Tagged n x -> Router_Tagged n (router x)+ {-+ Router_Tagged n x -> Router_Taggeds $+ case n of+ Tag c s -> Map.fromList [(Left c, r), (Right s, r)]+ TagShort c -> Map.singleton (Left c) r+ TagLong s -> Map.singleton (Right s) r+ where r = router x+ -}+ {-+ Router_Taggeds xs `Router_App` Router_Taggeds ys ->+ Router_Taggeds $ router <$> (xs <> ys)+ -}+ Router_Alt x y -> router x`router_Alt`router y+ Router_Commands xs -> Router_Commands $ router <$> xs+ -- Router_Taggeds xs -> Router_Taggeds $ router <$> xs+ 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)+ -- Router_Merge x -> Router_Merge (router x)++-- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.+router_Alt ::+ repr ~ Parser 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.+ {- NOTE: useless because 'command' is already a 'Router_Commands'.+ go (Router_Command x xo xt) (Router_Command y yo yt) =+ Map.singleton x (router (runPermutation xo <.> xt))+ `router_Commands`+ Map.singleton y (router (runPermutation yo <.> yt))+ go (Router_Command x xo xt) (Router_Commands ys) =+ Map.singleton x (router (runPermutation xo <.> xt))+ `router_Commands` ys+ go (Router_Commands xs) (Router_Command y yo yt) =+ xs `router_Commands`+ Map.singleton y (router (runPermutation yo <.> yt))+ -}+ go (Router_Commands xs) (Router_Commands ys) =+ xs`router_Commands`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 d =>+ Map Segment (Router repr a k) ->+ Map Segment (Router repr b k) ->+ Router repr (a:!:b) k+router_Commands xs ys =+ -- 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.+ Router_Commands $+ Map.merge+ (Map.traverseMissing $ const $ \case+ Router_Union u r ->+ return $ Router_Union (\(x:!:_y) -> u x) r+ r -> return $ Router_Union (\(x:!:_y) -> x) r)+ (Map.traverseMissing $ const $ \case+ Router_Union u r ->+ return $ Router_Union (\(_x:!:y) -> u y) r+ r -> return $ Router_Union (\(_x:!:y) -> y) r)+ (Map.zipWithAMatched $ const $ \case+ Router_Union xu xr -> \case+ Router_Union yu yr ->+ return $ Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr+ yr ->+ return $ Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr+ xr -> \case+ Router_Union yu yr ->+ return $ Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr+ yr -> return $ xr`router_Alt`yr)+ xs ys++{-+debug0 :: Show a => String -> a -> a+debug0 n a = Debug.trace (" {"<>n<>": "<>show a) a+debug1 :: Show a => Show b => String -> (a->b) -> (a->b)+debug1 n a2b a = Debug.trace ("} "<>n<>": r: "<>show b) b+ where b = a2b $ Debug.trace ("{ "<>n<>": a: "<>show a) a+debug2 :: Show a => Show b => Show c => String -> (a->b->c) -> (a->b->c)+debug2 n a2b2c a b = Debug.trace ("} "<>n<>": r: "<>show c) c+ where+ b2c = a2b2c $ Debug.trace ("{ "<>n<>": a: "<>show a) a+ c = b2c $ Debug.trace (n<>": b: "<>show b) b+-}
+ Symantic/CLI/Schema.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-} -- for DocFrom (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 => Docable d => Schema d f k -> d+docSchema s = runSchema s defSchemaInh++coerceSchema :: Schema d f k -> Schema d f' k'+coerceSchema Schema{..} = Schema{..}++-- ** Type 'Doc'+type Doc = Doc.AnsiText (Doc.Plain TLB.Builder)++-- ** Class 'Docable'+type Docable d =+ ( Semigroup d+ , Monoid d+ , IsString d+ , Doc.Colorable16 d+ , Doc.Decorable d+ , Doc.Spaceable d+ , Doc.Indentable d+ , Doc.Wrappable d+ , Doc.DocFrom (Doc.Word Char) d+ , Doc.DocFrom (Doc.Word Text) d+ , Doc.DocFrom (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+ }++defSchemaInh :: Docable d => SchemaInh d+defSchemaInh = SchemaInh+ { schemaInh_op = (infixN0, SideL)+ , schemaInh_define = True+ , schemaInh_or = docOrH+ }++pairIfNeeded :: Docable d => SchemaInh d -> Infix -> d -> d+pairIfNeeded SchemaInh{..} op =+ if needsParenInfix schemaInh_op op+ 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 a k) where+ show =+ TL.unpack .+ TLB.toLazyText .+ Doc.runPlain .+ Doc.runAnsiText .+ docSchema++docOrH, docOrV :: Doc.Spaceable d => Doc.DocFrom (Doc.Word Char) d => d+docOrH = Doc.space <> Doc.docFrom (Doc.Word '|') <> Doc.space+docOrV = Doc.newline <> Doc.docFrom (Doc.Word '|') <> Doc.space++{-+instance Docable d => Functor (Schema d f) where+ _f `fmap` Schema x = Schema $ \inh ->+ pairIfNeeded inh op <$>+ x inh{schemaInh_op=(op, SideR)}+ where+ op = infixB SideL 10+-}+instance Docable d => App (Schema d) where+ Schema f <.> Schema x = Schema $ \inh ->+ case (f inh{schemaInh_op=(op, SideL)}, x inh{schemaInh_op=(op, SideR)}) of+ (Nothing, Nothing) -> Nothing+ (Just f', Nothing) -> Just f'+ (Nothing, Just x') -> Just x'+ (Just f', Just x') -> Just $ pairIfNeeded inh op $ f' <> Doc.space <> x'+ where+ op = infixB SideL 10+instance Docable d => Alt (Schema d) where+ lp <!> rp = Schema $ \inh ->+ case (unSchema lp inh, unSchema rp inh) of+ (Nothing, Nothing) -> Nothing+ (Just lp', Nothing) -> Just lp'+ (Nothing, Just rp') -> Just rp'+ (Just{}, Just{}) -> Just $+ if needsParenInfix (schemaInh_op inh) op+ then+ Doc.breakalt+ (Doc.parens $+ -- Doc.withBreakable Nothing $+ runSchema lp inh+ { schemaInh_op=(op, SideL)+ , schemaInh_or=docOrH } <>+ docOrH <>+ runSchema rp inh+ { schemaInh_op=(op, SideR)+ , schemaInh_or=docOrH })+ (Doc.align $+ Doc.parens $+ Doc.space <>+ runSchema lp inh+ { schemaInh_op=(op, SideL)+ , schemaInh_or=docOrV } <>+ docOrV <>+ runSchema rp inh+ { schemaInh_op=(op, SideR)+ , schemaInh_or=docOrV } <>+ Doc.newline)+ else+ runSchema lp inh{schemaInh_op=(op, SideL)} <>+ schemaInh_or inh <>+ runSchema rp inh{schemaInh_op=(op, SideR)}+ where op = infixB SideL 2+ opt s = Schema $ \inh -> Just $+ Doc.brackets $+ runSchema s inh{schemaInh_op=(op, SideL)}+ where op = infixN0+instance Pro (Schema d) where+ dimap _a2b _b2a = coerceSchema+instance Docable d => AltApp (Schema d) where+ many0 s = Schema $ \inh -> Just $+ runSchema s inh{schemaInh_op=(op, SideL)}<>"*"+ where op = infixN 10+ many1 s = Schema $ \inh -> Just $+ runSchema s inh{schemaInh_op=(op, SideL)}<>"..."+ where op = infixN 10+instance Docable 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+ runSchema+ (fromString n <.> coerceSchema s)+ inh{schemaInh_define = False}+ else ref+ where+ ref =+ Doc.bold $+ Doc.angles $+ Doc.magentaer $+ Doc.docFrom (Doc.Word n)+instance Docable d => CLI_Var (Schema d) where+ type VarConstraint (Schema d) a = ()+ var' n = Schema $ \_inh -> Just $+ Doc.underline $ Doc.docFrom $ Doc.Word n+ just _ = Schema $ \_inh -> Nothing+ nothing = Schema $ \_inh -> Nothing+instance Docable d => CLI_Env (Schema d) where+ type EnvConstraint (Schema d) a = ()+ env' n = Schema $ \_inh -> Nothing+ -- NOTE: environment variables are not shown in the schema,+ -- only in the help.+instance Docable d => CLI_Tag (Schema d) where+ type TagConstraint (Schema d) a = ()+ tagged 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 Docable 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.docFrom (Doc.Word n)+data SchemaResponseArgs a+instance Docable 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 '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 w ps = SchemaPerm w (coerceSchema <$> ps)+instance Applicative (SchemaPerm d k) where+ pure _a = SchemaPerm id mempty+ SchemaPerm fd w <*> SchemaPerm fx x =+ SchemaPerm (fd . fx) $ (coerceSchema <$> w) <> (coerceSchema <$> x)+instance Docable d => Permutable (Schema d) where+ type Permutation (Schema d) = SchemaPerm d+ runPermutation (SchemaPerm w ps) =+ case ps of+ [] -> w $ Schema $ \_inh -> Nothing+ [Schema s] -> w $ Schema s+ _ -> w $ Schema $ \inh -> Just $+ -- pairIfNeeded inh op $+ Doc.align $+ 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.breakalt+ (Doc.brackets $+ -- Doc.withBreakable Nothing $+ runSchema s inh{schemaInh_op=(op, SideL), schemaInh_or=docOrH})+ (Doc.align $+ Doc.brackets $+ Doc.space <>+ runSchema s inh{schemaInh_op=(op, SideL)} <>+ Doc.newline)+ else+ runSchema s inh{schemaInh_op=(op, SideL)}+ where op = infixN0+instance Docable d => CLI_Help (SchemaPerm d) where+ type HelpConstraint (SchemaPerm d) d' = d ~ d'+ help _msg = id+ program n (SchemaPerm w ps) = SchemaPerm (program n . w) ps+ rule n (SchemaPerm w ps) = SchemaPerm (rule n . w) ps
stack.yaml view
@@ -1,6 +1,6 @@-resolver: lts-12.8+resolver: lts-13.19 packages: - '.' - location: '../symantic-document' extra-dep: true-+extra-deps:
symantic-cli.cabal view
@@ -2,10 +2,14 @@ -- PVP: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.0.0.20180410-category: Data Structures-synopsis: Library for Command Line Interface (CLI)-description: Symantics for CLI.+version: 2.0.0.20190615+category: +synopsis: Symantics for parsing and documenting a CLI+description:+ An extensible, typed and embedded Domain-Specific Language (DSL)+ to build Command Line Interface (CLI)+ using a write-an-API-then-derive-code-from-it approach.+ The derivations currently implemented are for parsing arguments or printing help. extra-doc-files: license: GPL-3 license-file: COPYING@@ -16,24 +20,23 @@ -- homepage: build-type: Simple-cabal-version: >= 1.18-tested-with: GHC==8.4.3+cabal-version: 1.24+tested-with: GHC==8.6.4 extra-source-files: stack.yaml extra-tmp-files: Source-Repository head- location: git://git.autogeree.net/symantic+ location: git://git.autogeree.net/symantic-cli type: git Library exposed-modules:- Language.Symantic.CLI- Language.Symantic.CLI.Fixity- Language.Symantic.CLI.Help- Language.Symantic.CLI.Plain- Language.Symantic.CLI.Read- Language.Symantic.CLI.Sym+ Symantic.CLI.API+ Symantic.CLI.Fixity+ Symantic.CLI.Help+ Symantic.CLI.Parser+ Symantic.CLI.Schema default-language: Haskell2010 default-extensions: FlexibleContexts@@ -45,7 +48,9 @@ RecordWildCards ScopedTypeVariables TupleSections+ TypeApplications TypeFamilies+ TypeOperators ghc-options: -Wall -Wincomplete-uni-patterns@@ -53,9 +58,8 @@ -fno-warn-tabs -- -fhide-source-paths build-depends:- base >= 4.10 && < 5- , containers >= 0.5- , text >= 1.2- , transformers >= 0.5- , megaparsec >= 6.3- , symantic-document+ base >= 4.10 && < 5+ , containers >= 0.5+ , symantic-document >= 0.2+ , text >= 1.2+ , transformers >= 0.5