--- /dev/null
+../HLint.hs
\ No newline at end of file
{-# LANGUAGE OverloadedStrings #-}
-module Language.Symantic.CLI.Write.Help where
+module Language.Symantic.CLI.Help where
import Control.Applicative (Applicative(..))
import Data.Bool
-import Data.Function (($))
+import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Functor.Compose (Compose(..))
-import Data.Maybe (Maybe(..))
+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.Write.Plain as Plain
+import qualified Language.Symantic.CLI.Plain as Plain
-- * Type 'Reader'
data Reader d
= Reader
- { reader_help :: Maybe d -- ^ Current help.
- -- , reader_define :: Bool -- ^ Whether to print a definition, or not.
- -- , reader_or :: d
+ { reader_help :: Maybe d
, reader_command_indent :: Doc.Indent
, reader_option_indent :: Doc.Indent
, reader_plain :: Plain.Reader d
defReader :: Doc.Textable d => Reader d
defReader = Reader
{ reader_help = Nothing
- -- , reader_define = True
- -- , reader_or = Doc.stringH " | "
, reader_command_indent = 2
- , reader_option_indent = 20
+ , reader_option_indent = 15
, reader_plain = Plain.defReader
, reader_option_empty = False
}
-- * Type 'Result'
-type Result d = [d]
+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_plain :: Plain.Plain d e t a
}
-runHelp :: Monoid d => Doc.Textable d => Help d e t a -> d
-runHelp h = Doc.catV $ help_result h defReader
+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) =
- let res = h def in
- Doc.catV res
+textHelp def (Help h _p) = docTrees $ h def
coerceHelp :: Help d e s a -> Help d e t b
coerceHelp Help{help_plain, ..} = Help
rule n (Help h p) =
Help (\ro ->
pure $
- Doc.breakableFill 4 (ref<>" ::= "<> Plain.runPlain p' (reader_plain ro)) <>
- Doc.align (Doc.catV (h ro{reader_help=Nothing}))
+ 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.textH n)
+ 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 (Help _h p) = Help mempty (var n p)
- string = Help mempty string
+ 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 $ Doc.bold (Plain.runPlain p' (reader_plain ro))
+ then
+ pure $ pure $ Leaf Doc.newline $ Doc.bold $
+ Plain.runPlain p' (reader_plain ro)
else []
Just msg ->
pure $
- Doc.breakableFill (reader_option_indent ro)
- (Doc.bold $ Plain.runPlain p' (reader_plain ro) <>
- Doc.spaces 2) <>
- Doc.align msg
+ 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
instance Plain.Doc d => Sym_Command (Help d) where
main n (Help h p) =
Help (\ro ->
- [ Plain.runPlain p' (reader_plain ro) <>
- (case reader_help ro of
- Nothing -> Doc.empty
- Just msg ->
- Doc.incrIndent (reader_command_indent ro) $
- Doc.newline <> msg)
- , Doc.catV $ h ro{reader_help=Nothing}
- ]
+ 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 $
- let d = ref<>" ::= "<>Plain.runPlain p' (reader_plain ro) in
- case h ro{reader_help=Nothing} of
- [] -> d
- hs ->
- Doc.breakableFill 4 d <>
- Doc.align (Doc.catV hs)
+ 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.stringH n)
+ 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 OverloadedStrings #-}
-module Language.Symantic.CLI.Write.Plain where
+module Language.Symantic.CLI.Plain where
import Data.Bool
import Data.Function (($), (.))
data Reader d
= Reader
{ reader_op :: (Infix, Side) -- ^ Parent operator.
- -- , reader_help :: Maybe d -- ^ Current help.
, reader_define :: Bool -- ^ Whether to print a definition, or not.
, reader_or :: d
- -- , reader_command_indent :: Doc.Indent
- -- , reader_option_indent :: Doc.Indent
}
defReader :: Doc.Textable d => Reader d
defReader = Reader
{ reader_op = (infixN0, SideL)
- -- , reader_help = Nothing
, reader_define = True
, reader_or = Doc.stringH " | "
- -- , reader_command_indent = 2
- -- , reader_option_indent = 20
}
pairIfNeeded :: Doc d => Reader d -> Infix -> d -> d
then runPlain p ro{reader_define=False}
else ref
where
- ref = Doc.bold $ Doc.between (Doc.charH '<') (Doc.charH '>') (Doc.textH n)
+ ref =
+ Doc.bold $
+ Doc.between (Doc.charH '<') (Doc.charH '>') $
+ Doc.magentaer $
+ Doc.stringH n
instance Doc d => Sym_Option (Plain d) where
- var n _r = fromString $ "<"<>n<>">"
- string = fromString "<string>"
+ 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
ro{reader_define = False}
else ref
where
- ref = Doc.bold $ Doc.between (Doc.charH '<') (Doc.charH '>') (Doc.stringH n)
+ 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
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Symantic.CLI.Read where
--- import Control.Monad.Trans.Class (MonadTrans(..))
--- import Data.Char (Char)
--- import Data.Default.Class (Default(..))
--- import qualified Control.Monad.Trans.State as S
import Control.Applicative (Applicative(..), Alternative(..))
import Control.Arrow ((***))
import Control.Monad (Monad(..), MonadPlus(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Text.Show (Show(..))
-import qualified Control.Monad.Trans.Reader as R
import qualified Data.List as List
import qualified Data.Set as Set
import qualified Text.Megaparsec as P
showArg (Arg a@('-':_)) = a
showArg (Arg a) = "\""<>a<>"\""
--- * Type 'Reader'
-newtype Reader
- = Reader
- { reader_var :: Name
- }
-
-defReader :: Reader
-defReader = Reader
- { reader_var = ""
- }
-
-- * Type 'Parser'
newtype Parser e s a
- = Parser { unParser :: R.ReaderT Reader (P.Parsec (ErrorRead e) Args) 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
( Just $ P.Tokens $ pure t
, Set.singleton $ P.Tokens $ pure expected )
instance Sym_Option Parser where
- var n (Parser p) = Parser $ R.local (\ro -> ro{reader_var = n}) p
- string = do
- name <- Parser $ R.asks reader_var
+ var n f = do
let check = Right
- let expected | List.null name = Arg "<string>"
- | otherwise = Arg $ "<"<>name<>">"
- unArg <$> P.token check (Just expected)
+ 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 ()
-- * Type 'ErrorRead'
newtype ErrorRead e
= ErrorRead e
- deriving (Functor, Show)
+ 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
showErrorComponent = show
readArgs :: Parser e s a -> Args -> Either (P.ParseError (P.Token Args) (ErrorRead e)) a
-readArgs p = P.runParser ((`R.runReaderT` defReader) $ unParser $ p <* end) ""
+readArgs p = P.runParser (unParser $ p <* end) ""
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 Data.Text (Text)
import Text.Show (Show)
-- * @Arg@ types
(<<|?>>) :: 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
+ (<<$) :: 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
type family Perm (repr:: * -> *) = (r :: * -> *) | r -> repr
-- * Class 'Sym_Rule'
class Sym_Rule repr where
- rule :: {-Show a =>-} Text -> repr e t a -> repr e t{-(ArgRule t)-} a
+ rule :: String -> repr e t a -> repr e t a
-- rule _n = id
-- * Class 'Sym_Command'
class Sym_Command repr where
-- * Class 'Sym_Option'
class Sym_AltApp repr => Sym_Option repr where
opt :: OptionName -> repr e s a -> repr e ArgOption a
- var :: Name -> repr e ArgValue a -> repr e ArgValue a
- string :: repr e ArgValue String
+ var :: Name -> (String -> Either e a) -> repr e ArgValue a
tag :: String -> repr e ArgValue ()
-- int :: repr e ArgValue Int
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
resolver: lts-10.5
packages:
- '.'
-- location: '../localization'
- extra-dep: true
- location: '../symantic-document'
extra-dep: true
-- PVP: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
-version: 0.0.0.20180401
+version: 0.0.0.20180410
category: Data Structures
synopsis: Library for Command Line Interface (CLI)
description: Symantics for CLI.
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
- Language.Symantic.CLI.Write.Help
- Language.Symantic.CLI.Write.Plain
- -- Language.Symantic.CLI.Test
default-language: Haskell2010
default-extensions:
FlexibleContexts
sourcephile / git / haskell / symantic.git / commitdiff