coalpit (empty) → 0.1.1.0
raw patch · 12 files changed
+1146/−0 lines, 12 filesdep +basedep +coalpitdep +generic-randomsetup-changed
Dependencies added: base, coalpit, generic-random, megaparsec, network-uri, scientific, tasty, tasty-quickcheck, tasty-travis, time
Files
- ChangeLog.md +10/−0
- Coalpit.hs +65/−0
- Coalpit/Core.hs +491/−0
- Coalpit/DSV.hs +59/−0
- Coalpit/Parsing.hs +90/−0
- LICENSE +30/−0
- README.md +91/−0
- Setup.hs +2/−0
- coalpit.cabal +51/−0
- examples/Basic.hs +45/−0
- examples/Pipes.hs +67/−0
- test/Test.hs +145/−0
+ ChangeLog.md view
@@ -0,0 +1,10 @@+# Revision history for coalpit++## 0.1.1.0 -- 2018-01-03++Complete rewriting and first Hackage release.+++## 0.1.0.0 -- 2016-11-24++A prototype.
+ Coalpit.hs view
@@ -0,0 +1,65 @@+{- |+Description : Command-line options and DSV parsing and printing+Maintainer : defanor <defanor@uberspace.net>+Stability : unstable+Portability : non-portable (uses GHC extensions)++Coalpit is a library for building "command-line program interfaces":+the goal is to get interfaces between programs quickly and easily,+while keeping them language-agnostic and more user- and shell+scripting-friendly than JSON and similar formats.+++== Example++@+\{\-\# LANGUAGE DeriveGeneric, DeriveAnyClass \#\-\}+import GHC.Generics+import Data.Proxy+import System.Environment+import Coalpit++data Foo = Foo { bar :: Maybe Int+ , baz :: String+ } deriving (Show, Generic, 'Coalpit')++main :: IO ()+main = do+ args <- getArgs+ case 'fromArgs' 'defOpt' args of+ Left err -> do+ putStrLn err+ putStrLn $ "Usage: " ++ 'usageString' 'defOpt' (Proxy :: Proxy Foo)+ Right x -> do+ print (x :: Foo)+ print $ 'toArgs' 'defOpt' x+ putStrLn $ showDSV defOpt x+ print ('readDSV' 'defOpt' $ 'showDSV' 'defOpt' x :: Either String Foo)+@++Then, in a shell:++> $ ./Example 'a string'+> Foo {bar = Nothing, baz = "a string"}+> ["a string"]+> "a string"+> Right (Foo {bar = Nothing, baz = "a string"})+> $ ./Example --bar 42 'a string'+> Foo {bar = Just 42, baz = "a string"}+> ["--bar","42","a string"]+> --bar 42 "a string"+> Right (Foo {bar = Just 42, baz = "a string"})+> $ ./Example --bar foo+> arguments:1:3:+> Failed to read: foo+>+> Usage: [--bar INT] STRING++-}++module Coalpit ( module Coalpit.Core+ , module Coalpit.DSV+ ) where++import Coalpit.Core+import Coalpit.DSV
+ Coalpit/Core.hs view
@@ -0,0 +1,491 @@+{- |+Module : Coalpit.Core+Description : Core Coalpit definitions+Maintainer : defanor <defanor@uberspace.net>+Stability : unstable+Portability : non-portable (uses GHC extensions)++The 'Coalpit' class with instances, a few functions to work with it,+and 'Options' are defined here.+-}++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Coalpit.Core ( Coalpit(..)+ , fromArgs+ -- * Usage+ , Usage(..)+ , usage+ , usageString+ -- * Options+ , Options(..)+ , defOpt+ ) where++import GHC.Generics+import Text.Megaparsec+import Text.Megaparsec.Char+import Data.Char (toLower)+import Data.Proxy (Proxy(..))+import qualified Data.List.NonEmpty as NE+import Data.Word (Word8, Word16, Word32, Word64)+import Numeric.Natural (Natural)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Time.Clock (DiffTime, NominalDiffTime, UniversalTime, UTCTime)+import Data.Time.Format ( TimeLocale, formatTime+ , iso8601DateFormat, defaultTimeLocale)+import Data.Time.Calendar (Day)+import Data.Time.LocalTime (TimeOfDay, LocalTime, ZonedTime)+import Data.Scientific (Scientific, FPFormat(..), formatScientific, scientificP)+import Text.ParserCombinators.ReadP (readP_to_S)+import Data.Complex (Complex)+import Data.Version (Version, parseVersion, showVersion)+import System.Exit (ExitCode)+import Network.URI (URI, parseURIReference, uriToString)++import Coalpit.Parsing++-- | Usage description: can be translated into help messages or+-- documentation formats.+data Usage = UConstructor String+ -- ^ Data constructor.+ | URecursive String+ -- ^ Constructor of a recursive data structure (its second+ -- appearance in the tree).+ | USelector String Usage+ -- ^ Record selector.+ | UOptional Usage+ -- ^ Optional element.+ | USum Usage Usage+ -- ^ Sum.+ | UProduct Usage Usage+ -- ^ Product.+ | UUnit+ -- ^ Unit.+ | UType String+ -- ^ Type name, e.g. \"INT\".+ deriving (Show)++-- | Printing and parsing options.+data Options = Options { fieldSeparator :: Char+ -- ^ DSV field separator ('showDSV',+ -- 'readDSV').+ , conNameMod :: String -> String+ -- ^ Constructor name modifier.+ , selNameMod :: String -> String+ -- ^ Record selector name modifier.+ , alwaysUseSelName :: Bool+ -- ^ Add record selector name always, not just+ -- for optional arguments.+ , omitNamedOptions :: Bool+ -- ^ Omit named Maybe values to indicate+ -- 'Nothing'.+ , timeLocale :: TimeLocale+ , dateFormat :: String+ -- ^ See "Data.Time.Format".+ , timeFormat :: String+ , dateTimeFormat :: String+ , scientificFormat :: FPFormat+ , scientificDecimals :: Maybe Int+ , uriUserInfo :: String -> String+ -- ^ Used to map userinfo parts of URIs.+ }++-- | Default options.+defOpt :: Options+defOpt = Options ' ' (map toLower) (("--" ++) . map toLower) False True+ defaultTimeLocale (iso8601DateFormat Nothing) "%H:%M:%S"+ (iso8601DateFormat (Just "%H:%M:%S")) Generic Nothing id++-- | Parses arguments.+fromArgs :: Coalpit a => Options -> [String] -> Either String a+fromArgs opt args = case parse (argParser opt) "arguments" (map CLArg args) of+ Left err -> Left $ parseErrorPretty err+ Right x -> Right x++-- | Composes 'Usage' description.+usage :: Coalpit a => Options -> Proxy a -> Usage+usage opt = argHelper opt []++-- | Composes a usage string.+usageString :: Coalpit a => Options -> Proxy a -> String+usageString opt = usageToString . usage opt++-- | Translates 'Usage' into a string, used by 'usageString'.+usageToString :: Usage -> String+usageToString (UConstructor c) = c+usageToString (URecursive c) = c ++ "..."+usageToString (USelector s u) = s ++ " " ++ usageToString u+usageToString (UOptional u) = "[" ++ usageToString u ++ "]"+usageToString (USum ul ur) = concat [ "("+ , usageToString ul+ , " | "+ , usageToString ur+ , ")"]+usageToString (UProduct u1 UUnit) = usageToString u1+usageToString (UProduct u1 u2) = usageToString u1 ++ " " ++ usageToString u2+usageToString UUnit = ""+usageToString (UType t) = t+++-- | Coalpit class: parsing, printing, usage strings.+class Coalpit a where+ argParser :: Options -> Parser a+ default argParser :: (Generic a, GCoalpit (Rep a)) => Options -> Parser a+ argParser opt = to <$> gArgParser opt++ toArgs :: Options -> a -> [String]+ default toArgs :: (Generic a, GCoalpit (Rep a)) => Options -> a -> [String]+ toArgs opt a = gToArgs opt (from a)++ argHelper :: Options -> [String] -> Proxy a -> Usage+ default argHelper :: (GCoalpit (Rep a))+ => Options -> [String] -> Proxy a -> Usage+ argHelper opt path Proxy = gArgHelper opt path (Proxy :: Proxy (Rep a p))++class GCoalpit a where+ gArgParser :: Options -> Parser (a p)+ gToArgs :: Options -> a p -> [String]+ gArgHelper :: Options -> [String] -> Proxy (a p) -> Usage+++-- Units+instance GCoalpit U1 where+ gArgParser _ = pure U1+ gToArgs _ U1 = []+ gArgHelper _ _ (Proxy :: Proxy (U1 f)) = UUnit+++-- Products+instance (GCoalpit a, GCoalpit b) => GCoalpit (a :*: b) where+ gArgParser opt = (:*:) <$> gArgParser opt <*> gArgParser opt+ gToArgs opt (x :*: y) = gToArgs opt x ++ gToArgs opt y+ gArgHelper opt path (Proxy :: Proxy ((a :*: b) p)) =+ UProduct (gArgHelper opt path (Proxy :: Proxy (a p)))+ (gArgHelper opt path (Proxy :: Proxy (b p)))+++-- Sums++-- | Handles recursive constructors.+handleRecCon :: GCoalpit a+ => String+ -- ^ Constructor name+ -> Options+ -> [String]+ -> Proxy (a p)+ -> Usage+handleRecCon nameA opt path (Proxy :: Proxy (a p)) =+ let n = conNameMod opt nameA+ in if nameA `elem` path+ then URecursive n+ else UProduct (UConstructor n)+ (gArgHelper opt (nameA : path) (Proxy :: Proxy (a p)))++instance (Constructor conA, GCoalpit a, GCoalpit (b :+: c)) =>+ GCoalpit ((b :+: c) :+: C1 conA a) where+ gArgParser opt =+ L1 <$> gArgParser opt+ <|>+ R1 <$> (pS (string (conNameMod opt $ conName (undefined :: C1 conA a p)))+ *> gArgParser opt)+ gToArgs opt (L1 x) = gToArgs opt x+ gToArgs opt (R1 x) = conNameMod opt (conName x) : gToArgs opt x+ gArgHelper opt path (Proxy :: Proxy (((b :+: c) :+: C1 conA a) p)) =+ let nameA = conName (undefined :: C1 conA f p)+ in USum (gArgHelper opt path (Proxy :: Proxy ((b :+: c) p)))+ (handleRecCon nameA opt path (Proxy :: Proxy (a p)))++instance (Constructor conA, GCoalpit a, GCoalpit (b :+: c)) =>+ GCoalpit (C1 conA a :+: (b :+: c)) where+ gArgParser opt =+ L1 <$> (pS (string (conNameMod opt $ conName (undefined :: C1 conA a p)))+ *> gArgParser opt)+ <|>+ R1 <$> gArgParser opt+ gToArgs opt (L1 x) = conNameMod opt (conName x) : gToArgs opt x+ gToArgs opt (R1 x) = gToArgs opt x+ gArgHelper opt path (Proxy :: Proxy ((C1 conA a :+: (b :+: c)) p)) =+ let nameA = conName (undefined :: C1 conA a p)+ in USum (handleRecCon nameA opt path (Proxy :: Proxy (a p)))+ (gArgHelper opt path (Proxy :: Proxy ((b :+: c) p)))++instance (Constructor conA, Constructor conB, GCoalpit a, GCoalpit b) =>+ GCoalpit (C1 conA a :+: C1 conB b) where+ gArgParser opt =+ L1 <$> (pS (string (conNameMod opt $+ conName (undefined :: C1 conA a p)))+ *> gArgParser opt)+ <|>+ R1 <$> (pS (string (conNameMod opt $+ conName (undefined :: C1 conB b p)))+ *> gArgParser opt)+ gToArgs opt (L1 x) = conNameMod opt (conName x) : gToArgs opt x+ gToArgs opt (R1 x) = conNameMod opt (conName x) : gToArgs opt x+ gArgHelper opt path (Proxy :: Proxy ((C1 conA a :+: C1 conB b) p)) =+ let nameA = conName (undefined :: C1 conA a p)+ nameB = conName (undefined :: C1 conB b p)+ in USum (handleRecCon nameA opt path (Proxy :: Proxy (a p)))+ (handleRecCon nameB opt path (Proxy :: Proxy (b p)))+++-- Record Selectors++parseS1 :: (GCoalpit a) => String -> Options -> Parser (S1 selA a p)+parseS1 nameA opt =+ let sName = case (nameA, alwaysUseSelName opt) of+ ("", _) -> pure ()+ (_, False) -> pure ()+ (_, True) -> pS (string (selNameMod opt nameA)) >> pure ()+ in M1 <$> (sName *> gArgParser opt)++printS1 :: (GCoalpit a, Selector selA) => Options -> S1 selA a p -> [String]+printS1 opt sel@(M1 x) = case (selName sel, alwaysUseSelName opt) of+ ("", _) -> gToArgs opt x+ (_, False) -> gToArgs opt x+ (name, True) -> selNameMod opt name : gToArgs opt x++helpS1 :: (GCoalpit a)+ => String -> Options -> [String] -> Proxy (S1 selA a p) -> Usage+helpS1 nameA opt path (Proxy :: Proxy (S1 selA a p)) =+ case (nameA, alwaysUseSelName opt) of+ ("", _) -> gArgHelper opt path (Proxy :: Proxy (a p))+ (_, False) -> gArgHelper opt path (Proxy :: Proxy (a p))+ (_, True) -> USelector (selNameMod opt nameA)+ (gArgHelper opt path (Proxy :: Proxy (a p)))++instance (GCoalpit a, Selector selA) => GCoalpit (S1 selA a) where+ gArgParser = parseS1 (selName (undefined :: S1 selA a p))+ gToArgs = printS1+ gArgHelper = helpS1 (selName (undefined :: S1 selA a p))++-- Optional arguments+instance {-#OVERLAPPING#-}+ (Coalpit a, Coalpit (Maybe a), Selector selA) =>+ GCoalpit (S1 selA (Rec0 (Maybe a))) where+ gArgParser opt =+ let nameA = selName (undefined :: S1 selA (Rec0 (Maybe a)) p)+ in case (omitNamedOptions opt, null nameA) of+ (True, True) -> M1 <$> gArgParser opt+ (True, False) ->+ M1 . K1+ <$> optional (pS (string (selNameMod opt nameA)) *> argParser opt)+ _ -> parseS1 nameA opt+ gToArgs opt sel@(M1 (K1 x))+ | omitNamedOptions opt = case (selName sel, x) of+ ("", _) -> toArgs opt x+ (_, Nothing) -> []+ (nameA, Just x') -> selNameMod opt nameA : toArgs opt x'+ | otherwise = printS1 opt sel+ gArgHelper opt path (Proxy :: Proxy (S1 selA (Rec0 (Maybe a)) p)) =+ let nameA = selName (undefined :: S1 selA (Rec0 (Maybe a)) p)+ in case (omitNamedOptions opt, null nameA) of+ (True, True) -> gArgHelper opt path (Proxy :: Proxy (Rec0 (Maybe a) p))+ (True, False) -> UOptional $ USelector (selNameMod opt nameA)+ (gArgHelper opt path (Proxy :: Proxy (Rec0 a p)))+ _ -> helpS1 nameA opt path (Proxy :: Proxy (S1 selA (Rec0 (Maybe a)) p))+++-- Constructors++instance (GCoalpit a) => GCoalpit (C1 conA a) where+ gArgParser = fmap M1 . gArgParser+ gToArgs opt (M1 x) = gToArgs opt x+ gArgHelper opt path (Proxy :: Proxy (C1 conA a p)) =+ gArgHelper opt path (Proxy :: Proxy (a p))++-- Data types+instance (GCoalpit a) => GCoalpit (D1 conA a) where+ gArgParser = fmap M1 . gArgParser+ gToArgs opt (M1 x) = gToArgs opt x+ gArgHelper opt path (Proxy :: Proxy (D1 conA a p)) =+ gArgHelper opt path (Proxy :: Proxy (a p))++-- Constraints and such+instance (Coalpit a) => GCoalpit (K1 i a) where+ gArgParser = fmap K1 . argParser+ gToArgs opt (K1 x) = toArgs opt x+ gArgHelper opt path (Proxy :: Proxy (K1 x a p)) =+ argHelper opt path (Proxy :: Proxy a)+++-- Common types++instance Coalpit Int where+ argParser _ = readArg+ toArgs _ i = [show i]+ argHelper _ _ _ = UType "INT"++instance Coalpit Integer where+ argParser _ = readArg+ toArgs _ i = [show i]+ argHelper _ _ _ = UType "INTEGER"++instance Coalpit Word8 where+ argParser _ = readArg+ toArgs _ i = [show i]+ argHelper _ _ _ = UType "WORD8"++instance Coalpit Word16 where+ argParser _ = readArg+ toArgs _ i = [show i]+ argHelper _ _ _ = UType "WORD16"++instance Coalpit Word32 where+ argParser _ = readArg+ toArgs _ i = [show i]+ argHelper _ _ _ = UType "WORD32"++instance Coalpit Word64 where+ argParser _ = readArg+ toArgs _ i = [show i]+ argHelper _ _ _ = UType "WORD64"++instance Coalpit Int8 where+ argParser _ = readArg+ toArgs _ i = [show i]+ argHelper _ _ _ = UType "INT8"++instance Coalpit Int16 where+ argParser _ = readArg+ toArgs _ i = [show i]+ argHelper _ _ _ = UType "INT16"++instance Coalpit Int32 where+ argParser _ = readArg+ toArgs _ i = [show i]+ argHelper _ _ _ = UType "INT32"++instance Coalpit Int64 where+ argParser _ = readArg+ toArgs _ i = [show i]+ argHelper _ _ _ = UType "INT64"++instance Coalpit Natural where+ argParser _ = readArg+ toArgs _ i = [show i]+ argHelper _ _ _ = UType "NATURAL"++instance Coalpit Rational where+ argParser _ = readArg+ toArgs _ i = [show i]+ argHelper _ _ _ = UType "RATIONAL"++instance Coalpit Double where+ argParser _ = readArg+ toArgs _ i = [show i]+ argHelper _ _ _ = UType "DOUBLE"++instance Coalpit Float where+ argParser _ = readArg+ toArgs _ i = [show i]+ argHelper _ _ _ = UType "FLOAT"++instance Coalpit Char where+ argParser _ = readArg+ toArgs _ c = [show c]+ argHelper _ _ _ = UType "CHAR"++instance {-#OVERLAPPING#-} Coalpit String where+ argParser _ = token (Right . unArg) Nothing+ toArgs _ i = [i]+ argHelper _ _ _ = UType "STRING"++instance Coalpit Scientific where+ argParser _ = try $ do+ x <- token (Right . unArg) Nothing+ case reverse $ readP_to_S scientificP x of+ (n, ""):_ -> pure n+ _ -> fail $ "Failed to read a scientific number: " ++ x+ toArgs opt n = [formatScientific+ (scientificFormat opt) (scientificDecimals opt) n]+ argHelper _ _ _ = UType "SCIENTIFIC"++instance Coalpit Version where+ argParser _ = try $ do+ x <- token (Right . unArg) Nothing+ case reverse $ readP_to_S parseVersion x of+ (v, ""):_ -> pure v+ _ -> fail $ "Failed to read a version: " ++ x+ toArgs _ v = [showVersion v]+ argHelper _ _ _ = UType "VERSION"++-- | An URI reference (absolute or relative).+instance Coalpit URI where+ argParser _ = try $ do+ x <- token (Right . unArg) Nothing+ maybe (fail $ "Failed to parse URI: " ++ x) pure (parseURIReference x)+ toArgs opt u = [uriToString (uriUserInfo opt) u ""]+ argHelper _ _ _ = UType "URI"+++-- | Uses 'dateTimeFormat'.+instance Coalpit UTCTime where+ argParser opt = pTime (timeLocale opt) (dateTimeFormat opt)+ toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]+ argHelper _ _ _ = UType "UTC_TIME"++-- | Uses 'dateTimeFormat'.+instance Coalpit ZonedTime where+ argParser opt = pTime (timeLocale opt) (dateTimeFormat opt)+ toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]+ argHelper _ _ _ = UType "ZONED_TIME"++-- | Uses 'dateTimeFormat'.+instance Coalpit LocalTime where+ argParser opt = pTime (timeLocale opt) (dateTimeFormat opt)+ toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]+ argHelper _ _ _ = UType "LOCAL_TIME"++-- | Uses 'dateTimeFormat'.+instance Coalpit UniversalTime where+ argParser opt = pTime (timeLocale opt) (dateTimeFormat opt)+ toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]+ argHelper _ _ _ = UType "UNIVERSAL_TIME"++-- | Uses 'timeFormat'.+instance Coalpit TimeOfDay where+ argParser opt = pTime (timeLocale opt) (timeFormat opt)+ toArgs opt t = [formatTime (timeLocale opt) (timeFormat opt) t]+ argHelper _ _ _ = UType "TIME_OF_DAY"++-- | Uses 'dateFormat'.+instance Coalpit Day where+ argParser opt = pTime (timeLocale opt) (dateFormat opt)+ toArgs opt t = [formatTime (timeLocale opt) (dateFormat opt) t]+ argHelper _ _ _ = UType "DAY"++-- | Converts to/from 'Scientific'.+instance Coalpit NominalDiffTime where+ argParser opt = fromRational . toRational+ <$> (argParser opt :: Parser Scientific)+ toArgs opt = toArgs opt .+ (fromRational . toRational :: NominalDiffTime -> Scientific)+ argHelper _ _ _ = UType "NOMINAL_DIFF_TIME"++-- | Converts to/from 'Scientific'.+instance Coalpit DiffTime where+ argParser opt = fromRational . toRational+ <$> (argParser opt :: Parser Scientific)+ toArgs opt = toArgs opt .+ (fromRational . toRational :: DiffTime -> Scientific)+ argHelper _ _ _ = UType "DIFF_TIME"+++instance Coalpit ()+instance Coalpit Bool+instance Coalpit Ordering+instance Coalpit ExitCode+instance Coalpit a => Coalpit (Complex a)+instance Coalpit a => Coalpit (Maybe a)+instance Coalpit a => Coalpit [a]+instance Coalpit a => Coalpit (NE.NonEmpty a)+instance (Coalpit a, Coalpit b) => Coalpit (Either a b)+instance (Coalpit a, Coalpit b) => Coalpit (a, b)+instance (Coalpit a, Coalpit b, Coalpit c) => Coalpit (a, b, c)+instance (Coalpit a, Coalpit b, Coalpit c, Coalpit d) => Coalpit (a, b, c, d)
+ Coalpit/DSV.hs view
@@ -0,0 +1,59 @@+{- |+Module : Coalpit.DSV+Description : DSV printing and parsing+Maintainer : defanor <defanor@uberspace.net>+Stability : unstable+Portability : non-portable (uses GHC extensions)++This module provides functions for DSV printing and parsing.+-}++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}++module Coalpit.DSV (showDSV, readDSV) where++import Data.List+import Text.Megaparsec+import Text.Megaparsec.Char+import Data.Void++import Coalpit.Core+++composeDSVLine :: Char -> [String] -> String+composeDSVLine fs = intercalate [fs] . map escapeVal+ where+ escapeVal :: String -> String+ -- not great, but will do for now+ escapeVal s = let inner = show s+ in if fs `elem` inner+ then inner+ else init $ tail inner++pStr :: Char -> Parsec Void String String+pStr fs = do+ s <- try (between (char '"') (char '"')+ (concat <$> many (string "\\\\"+ <|> string "\\\""+ <|> pure <$> notChar '"')))+ <|> many (notChar fs)+ case reads (concat ["\"", s, "\""]) of+ [(str, "")] -> pure str+ other -> fail $ "Failed to read a string: " ++ show other ++ "(" ++ s ++ ")"++pDSVLine :: Char -> Parsec Void String [String]+pDSVLine fs = pStr fs `sepBy` char fs++parseDSVLine :: Char -> String -> Either String [String]+parseDSVLine fs l = case parse (pDSVLine fs) "line" l of+ Left err -> Left $ parseErrorPretty err+ Right x -> Right x++-- | Shows values in DSV format.+showDSV :: Coalpit a => Options -> a -> String+showDSV opt = composeDSVLine (fieldSeparator opt) . toArgs opt++-- | Reads values from DSV format.+readDSV :: Coalpit a => Options -> String -> Either String a+readDSV opt = (>>= fromArgs opt) . parseDSVLine (fieldSeparator opt)
+ Coalpit/Parsing.hs view
@@ -0,0 +1,90 @@+{- |+Module : Coalpit.Parsing+Description : Argument parsing facilities+Maintainer : defanor <defanor@uberspace.net>+Stability : unstable+Portability : non-portable (uses GHC extensions)++This module provides functions useful for argument parsing.+-}++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}++module Coalpit.Parsing ( Parser+ , CLArg(..)+ , pS+ , readArg+ , pTime+ ) where++import Text.Megaparsec+import Data.Proxy (Proxy(..))+import Data.Time.Format (TimeLocale, ParseTime, readSTime)+import Data.Void (Void)+import qualified Data.List.NonEmpty as NE+import Data.List (foldl')+import Data.Semigroup ((<>))++-- | Command-line argument wrapper, used to avoid orphan ShowToken+-- String and Stream [String] instances.+newtype CLArg = CLArg { unArg :: String }+ deriving (Ord, Eq)++-- | Advances by one token.+advance :: Pos -> SourcePos -> t -> SourcePos+advance _ (SourcePos n l c) _ = SourcePos n l (c <> pos1)++-- | A list of strings (command-line arguments) stream.+instance Stream [CLArg] where+ type Token [CLArg] = CLArg+ type Tokens [CLArg] = [CLArg]+ tokenToChunk Proxy = pure+ tokensToChunk Proxy = id+ chunkToTokens Proxy = id+ chunkLength Proxy = length+ chunkEmpty Proxy = null+ advance1 Proxy = advance+ advanceN Proxy w = foldl' (advance w)+ take1_ [] = Nothing+ take1_ (t:ts) = Just (t, ts)+ takeN_ n s+ | n <= 0 = Just ([], s)+ | null s = Nothing+ | otherwise = Just (splitAt n s)+ takeWhile_ = span++instance ShowToken CLArg where+ showTokens xs = concat $ NE.map unArg xs++-- | Command-line arguments parser.+type Parser = Parsec Void [CLArg]++-- | Applies a String parser to a single argument.+pS :: Parsec Void String a -> Parsec Void [CLArg] a+pS p = try $ do+ x <- token (Right . unArg) Nothing+ case parse p "argument" x of+ Left e -> fail $ show e+ Right x' -> pure x'++-- | Reads an argument using its 'Read' instance.+readArg :: Read a => Parser a+readArg = do+ x <- token (Right . unArg) Nothing+ case reads x of+ [(n, "")] -> pure n+ _ -> fail $ "Failed to read: " ++ x++-- | Parses a time argument.+pTime :: ParseTime a+ => TimeLocale+ -- ^ Options, to read 'timeLocale' from.+ -> String+ -- ^ Time format to use.+ -> Parser a+pTime tl tf = try $ do+ x <- token (Right . unArg) Nothing+ case readSTime False tl tf x of+ [(t, "")] -> pure t+ _ -> fail "Failed to parse time"
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016-2018, defanor++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of defanor nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,91 @@+# Coalpit++Coalpit is a library for+building+[command-line program interfaces](https://defanor.uberspace.net/notes/command-line-program-interface.html):+the goal is to get interfaces between programs quickly and easily,+while keeping them language-agnostic and more user- and shell+scripting-friendly than JSON and similar formats.++Given a type, it derives instances to print and parse it as+command-line arguments or DSVs, as well as to compose usage+instructions. The resulting deserialization wouldn't be as nice as+that of+e.g.+[optparse-generic](https://hackage.haskell.org/package/optparse-generic),+but the aim here is to handle more or less arbitrary types.++Warning: it is possible to run into ambiguity by defining a recursive+structure with optional named elements while using default options.+`omitNamedOptions` can be disabled to avoid that.+++## Example++An example is available in `examples/Basic.hs`. Given the following+Haskell value:++```haskell+Input { something = Nothing+ , fooBar = Just (Foo (FooArgs { arg1 = 1+ , arg2 = "a string"}))+ , fooBar2 = Bar}+```++With the default options, its serialized version should look like+this:++```haskell+["--foobar","foo","1","a string","bar"]+```++What would look like this in a shell:++```sh+--foobar foo 1 'a string' bar+```++And its usage string -- like this:++```+[--something STRING] [--foobar (foo INT STRING | bar)] (foo INT STRING | bar)+```++More verbose versions can be produced and parsed with+`alwaysUseSelName = True` and/or `omitNamedOptions = False`:++```sh+--foobar foo --arg1 1 --arg2 'a string' --foobar2 bar+nothing just foo 1 'a string' bar+--something nothing --foobar just foo --arg1 1 --arg2 'a string' --foobar2 bar+```++And here is output of the `help` function from the same file, with all+the (alwaysUseSelName, omitNamedOptions) combinations:++```+(True,True)+--foo : 1 : 2 : 3 [] --bar "a string"+--foo ([] | : INT ([] | :...)) [--bar STRING]+(True,True)+--foo : 1 : 2 : 3 []+--foo ([] | : INT ([] | :...)) [--bar STRING]+(True,False)+--foo : 1 : 2 : 3 [] --bar just "a string"+--foo ([] | : INT ([] | :...)) --bar (nothing | just STRING)+(True,False)+--foo : 1 : 2 : 3 [] --bar nothing+--foo ([] | : INT ([] | :...)) --bar (nothing | just STRING)+(False,True)+: 1 : 2 : 3 [] --bar "a string"+([] | : INT ([] | :...)) [--bar STRING]+(False,True)+: 1 : 2 : 3 []+([] | : INT ([] | :...)) [--bar STRING]+(False,False)+: 1 : 2 : 3 [] just "a string"+([] | : INT ([] | :...)) (nothing | just STRING)+(False,False)+: 1 : 2 : 3 [] nothing+([] | : INT ([] | :...)) (nothing | just STRING)+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ coalpit.cabal view
@@ -0,0 +1,51 @@+name: coalpit+version: 0.1.1.0+synopsis: Command-line options and DSV parsing and printing+description: This library generates parsers and printers for+ given data types, in the form of command-line+ arguments or DSVs – so that they can be used to+ quickly get program interfaces via a shared+ library, while being suitable for scripting and+ as user interfaces.+license: BSD3+license-file: LICENSE+author: defanor+maintainer: defanor@uberspace.net+category: Console+build-type: Simple+extra-source-files: ChangeLog.md+ , README.md+ , examples/Basic.hs+ , examples/Pipes.hs+cabal-version: >=1.10+tested-with: GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.1, GHC == 8.2.2+bug-reports: https://github.com/defanor/coalpit/issues+source-repository head+ type: git+ location: https://git.uberspace.net/coalpit++library+ exposed-modules: Coalpit+ , Coalpit.Core+ , Coalpit.DSV+ , Coalpit.Parsing+ build-depends: base >= 4.9 && < 5+ , megaparsec >= 6.2 && < 7+ , scientific >= 0.3 && < 1+ , time >= 1.6 && < 2+ , network-uri >= 2.6 && < 3+ default-language: Haskell2010+ ghc-options: -Wall++test-suite test-coalpit+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Test.hs+ build-depends: base >= 4.9 && < 5+ , coalpit+ , generic-random >= 1 && < 2+ , tasty >= 0.12 && < 1+ , tasty-quickcheck >= 0.9 && < 1+ , tasty-travis >= 0.2 && < 1+ ghc-options: -Wall -Wno-unused-top-binds
+ examples/Basic.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+module Main where++import GHC.Generics+import Coalpit+import Data.Proxy++data FooArgs = FooArgs { arg1 :: Int+ , arg2 :: String+ } deriving (Show, Generic, Coalpit)++data FooBar = Foo FooArgs+ | Bar+ deriving (Show, Generic, Coalpit)++data Input = Input { something :: Maybe String+ , fooBar :: Maybe FooBar+ , fooBar2 :: FooBar+ } deriving (Show, Generic, Coalpit)++main :: IO ()+main = do+ let val = Input { something = Nothing+ , fooBar = Just (Foo FooArgs { arg1 = 1+ , arg2 = "a string"})+ , fooBar2 = Bar}+ args = toArgs defOpt val+ print val+ print args+ print (fromArgs defOpt args :: Either String Input)++data Test = Test { foo :: [Int], bar :: Maybe String }+ deriving (Show, Generic, Coalpit)++help :: IO ()+help = do+ mapM_ (\(o, x, y) -> print o >> putStrLn x >> putStrLn y) $+ [ let opts = defOpt { alwaysUseSelName = ausn+ , omitNamedOptions = ono }+ in ( (ausn, ono)+ , showDSV opts (Test [1,2,3] vals)+ , usageString opts (Proxy :: Proxy Test))+ | ausn <- [True, False]+ , ono <- [True, False]+ , vals <- [Just "a string", Nothing]]
+ examples/Pipes.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables, DeriveGeneric,+ DeriveAnyClass #-}++module Coalpit.IO (runMain, runMain', handleErrors) where++import Data.Proxy (Proxy(..))+import System.Environment (getProgName, getArgs)+import Control.Monad.IO.Class (MonadIO, liftIO)+import System.Exit (die)+import System.IO (hPutStrLn, stderr)+import Pipes ((>->), Pipe, yield, await, lift, runEffect)+import Control.Monad (mapM_, forever)+import qualified Pipes.Prelude as PP+import Coalpit.Core (Coalpit, fromArgs, defOpt, usage)+import Coalpit.DSV (readDSV, showDSV)+import GHC.Generics++-- | Runs a given action on each 'Left' value, embedding that action's+-- result into the data stream.+handleErrors :: MonadIO m => (e -> m [a]) -> Pipe (Either e a) a m ()+handleErrors e = forever $ do+ v <- await+ case v of+ Left err -> do+ vs <- lift $ e err+ mapM_ yield vs+ Right x -> yield x++-- | Runs a given 'Pipe' between input producer and output consumer.+-- Prints an error and usage instructions if it fails to parse the+-- arguments, and passes the input through 'handleErrors'.+runMain :: forall m a i o. (MonadIO m, Coalpit a, Coalpit i, Coalpit o)+ => (String -> m [i])+ -- ^ An action to run on error (see 'handleErrors').+ -> (a -> Pipe i o m ())+ -- ^ Main function.+ -> m ()+runMain e f = do+ pn <- liftIO getProgName+ let u = Prelude.concat [ "Usage: ", pn, " "+ , usageString defOpt (Proxy :: Proxy a)]+ args <- liftIO getArgs+ a <- either (liftIO . die . (++ u)) pure $ fromArgs defOpt args+ runEffect $+ PP.stdinLn+ >-> PP.map (readDSV defOpt)+ >-> handleErrors e+ >-> f a+ >-> PP.map (showDSV defOpt)+ >-> PP.stdoutLn++-- | Same as 'runMain', but just prints errors into 'stderr'.+runMain' :: forall m a i o. (MonadIO m, Coalpit a, Coalpit i, Coalpit o)+ => (a -> Pipe i o m ())+ -- ^ Main function.+ -> m ()+runMain' = runMain (\e -> liftIO $ hPutStrLn stderr e >> pure [])+++data Args = Args { arg1 :: Maybe Int, arg2 :: Double }+ deriving (Generic, Coalpit)+data Input = Input Double deriving (Generic, Coalpit)+data Output = Foo Double | Bar deriving (Generic, Coalpit)++main :: IO ()+main = runMain' $ \a -> PP.mapM $ \(Input i) ->+ pure $ Foo $ maybe (arg2 a) fromIntegral (arg1 a) + i
+ test/Test.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, RankNTypes #-}++import GHC.Generics+import Generic.Random+import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Data.Proxy+import Test.Tasty.Travis+import Data.Word+import Data.Int+import Data.Complex+import Data.Either++import Coalpit+++data Basic = Basic Int String Double+ deriving (Generic, Eq, Show, Coalpit)+instance Arbitrary Basic where arbitrary = genericArbitraryU++data WithLists = WithLists [Int] [String] [Double]+ deriving (Generic, Eq, Show, Coalpit)+instance Arbitrary WithLists where arbitrary = genericArbitraryU++data Record = Record { maybeInt :: Maybe Int+ , maybeDouble :: Maybe Double+ , str :: String+ , listOfStrings :: [String]+ , maybeNonEmptyListOfNumbers :: Maybe [Integer]+ , otherString :: String+ } deriving (Generic, Eq, Show, Coalpit)+instance Arbitrary Record where arbitrary = genericArbitraryU++data Sum = Foo Int Bool+ | Bar+ | Baz (Int8, (Complex Float, Word16), Rational)+ deriving (Generic, Eq, Show, Coalpit)+instance Arbitrary Sum where arbitrary = genericArbitraryU++data Nested = Nested Record Basic WithLists Sum+ deriving (Generic, Eq, Show, Coalpit)+instance Arbitrary Nested where arbitrary = genericArbitraryU++data Polymorphic a b = Polymorphic (Maybe a) (Either a b)+ deriving (Generic, Eq, Show)+instance (Coalpit a, Coalpit b) => Coalpit (Polymorphic a b)+instance (Arbitrary a, Arbitrary b) => Arbitrary (Polymorphic a b) where+ arbitrary = genericArbitraryU++data Recursive = RecursiveA+ | RecursiveB Recursive+ deriving (Generic, Eq, Show, Coalpit)+instance Arbitrary Recursive where arbitrary = genericArbitraryU++data NestedRecord = NestedRecord { record1 :: Maybe Record+ , record2 :: Maybe Record+ , record3 :: Maybe Record+ } deriving (Generic, Eq, Show, Coalpit)+instance Arbitrary NestedRecord where arbitrary = genericArbitraryU++data NestedSum = NestedFoo Record+ | NestedBar Sum Basic Nested+ | NestedBaz (Polymorphic Char Double)+ deriving (Generic, Eq, Show, Coalpit)+instance Arbitrary NestedSum where arbitrary = genericArbitraryU++data RecursiveRecordMaybe = RecursiveRecordMaybe+ { rrm :: Maybe RecursiveRecordMaybe+ , record :: Maybe Record+ , guard :: Word8+ } deriving (Generic, Eq, Show, Coalpit)+instance Arbitrary RecursiveRecordMaybe where arbitrary = genericArbitraryU++data RecursiveRecordMaybe2 = RecursiveRecordMaybe2+ { record1' :: Maybe Record+ , rrm' :: Maybe (Maybe RecursiveRecordMaybe2)+ , record2' :: Maybe Record+ , guard' :: Word8+ } deriving (Generic, Eq, Show, Coalpit)+instance Arbitrary RecursiveRecordMaybe2 where arbitrary = genericArbitraryU++data RecordStrings = RecordStrings+ { s1 :: String+ , s2 :: String+ , s3 :: String+ } deriving (Generic, Eq, Show, Coalpit)+instance Arbitrary RecordStrings where arbitrary = genericArbitraryU++printAndParse :: (Coalpit a, Eq a)+ => Options -> Proxy a -> a -> Bool+printAndParse opt _ r = Right r == fromArgs opt (toArgs opt r)++printAndParseDSV :: (Coalpit a, Eq a)+ -- It would take a long time to test with [a], so+ -- just repeating it 0--2 times.+ => Options -> Proxy a -> (a, Int) -> Bool+printAndParseDSV opt _ (x, n) =+ let xs = (replicate (n `mod` 3) x)+ in xs == (rights . map (readDSV opt) . lines . unlines . map (showDSV opt) $ xs)+++variousTypes :: (forall a. (Coalpit a, Eq a, Show a, Arbitrary a) =>+ Proxy a -> String -> TestTree)+ -> [TestTree]+variousTypes f =+ [ f (Proxy :: Proxy Basic) "Basic"+ , f (Proxy :: Proxy WithLists) "WithLists"+ , f (Proxy :: Proxy Record) "Record"+ , f (Proxy :: Proxy Sum) "Sum"+ , f (Proxy :: Proxy Nested) "Nested"+ , f (Proxy :: Proxy (Polymorphic Int Double)) "Polymorphic Int Double"+ , f (Proxy :: Proxy (Polymorphic Basic Record)) "Polymorphic Basic Record"+ , f (Proxy :: Proxy (Polymorphic Nested (Polymorphic Basic Sum)))+ "Polymorphic Nested (Polymorphic Basic Sum)"+ , f (Proxy :: Proxy Recursive) "Recursive"+ , f (Proxy :: Proxy NestedRecord) "NestedRecord"+ , f (Proxy :: Proxy NestedSum) "NestedSum"+ , f (Proxy :: Proxy RecursiveRecordMaybe) "RecursiveRecordMaybe"+ , f (Proxy :: Proxy RecursiveRecordMaybe2) "RecursiveRecordMaybe2"+ , f (Proxy :: Proxy RecordStrings) "RecordStrings"+ ]++variousOptions :: (Options -> [TestTree]) -> [TestTree]+variousOptions tt =+ [ testGroup (concat [ "alwaysUseSelName = ", show ausn+ , ", omitNamedOptions = ", show ono])+ (tt defOpt { alwaysUseSelName = ausn+ , omitNamedOptions = ono })+ | ausn <- [True, False]+ , ono <- [True, False]+ ]++qcProps :: TestTree+qcProps = testGroup "Quickcheck properties"+ [ testGroup "Right == fromArgs opt . toArgs opt"+ (variousOptions $ \opt ->+ variousTypes $ \p n -> QC.testProperty n (printAndParse opt p))+ , testGroup+ "id == rights . map (readDSV opt) . lines . unlines . map (showDSV opt)"+ (variousOptions $ \opt ->+ variousTypes $ \p n -> QC.testProperty n (printAndParseDSV opt p))+ ]++main :: IO ()+main = travisTestReporter defaultConfig [] qcProps