coalpit 0.1.1.1 → 0.2.0.0

raw patch · 11 files changed

+614/−862 lines, 11 filesdep +parsecdep −megaparsecdep −tasty-travisdep ~tastysetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: parsec

Dependencies removed: megaparsec, tasty-travis

Dependency ranges changed: tasty

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• Coalpit.hs +551/−47
• Coalpit/Core.hs +0/−504
• Coalpit/DSV.hs +0/−59
• Coalpit/Parsing.hs +0/−90
• README.md +31/−50
• Setup.hs +0/−2
• coalpit.cabal +7/−12
• examples/Basic.hs +7/−9
• examples/Pipes.hs +0/−67
• test/Test.hs +11/−22

@@ -1,5 +1,12 @@ # Revision history for coalpit +## 0.2.0.0  -- 2024-01-26++Switched from Megaparsec to Parsec for more common and stable+dependencies. Now focusing on DSV, and always including constructor+names in order to avoid possible ambiguity.++ ## 0.1.1.0  -- 2018-01-03  Complete rewriting and first Hackage release.

@@ -5,61 +5,565 @@ Portability :  non-portable (uses GHC extensions)  Coalpit is a library for building command-line interfaces: the goal is-to get interfaces quickly and easily, while keeping them-language-agnostic and more user- and shell scripting-friendly than-JSON and similar formats.+to build interfaces quickly and easily (by deriving those), while+keeping them language-agnostic and more user- and shell+scripting-friendly than JSON and similar formats. +-} -== Example+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-} -@-\{\-\# LANGUAGE DeriveGeneric, DeriveAnyClass \#\-\}+module Coalpit ( fromDSV+               , fromDSVList+               , toDSV+               , toDSVList+               , dsvFromList+               , Coalpit(..)+                 -- * Usage+               , usage+               , usageString+               , Usage(..)+                 -- * Options+               , SelNamePolicy(..)+               , Options(..)+               , defOpt+                 -- * Parsing and composition helpers+               , escape+               , pString+               , pFieldSep+               , pRecordSep+               ) where+ import GHC.Generics-import Data.Proxy-import System.Environment-import Coalpit+import Text.Parsec+import Text.Parsec.String+import Data.Char (toLower)+import Data.Proxy (Proxy(..))+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty(..))+import Data.List (intercalate)+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+                        , ParseTime, readSTime)+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) -data Foo = Foo { bar :: Maybe Int-               , baz :: String-               } deriving (Show, Generic, 'Coalpit')+-- | 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 Bool 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) -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)-@+-- | How to handle selector names.+data SelNamePolicy = SNDisable+                   -- ^ Do not parse or print selector names+                   | SNAvoid+                   -- ^ Allow selector names on parsing, but do not+                   -- print them+                   | SNPrefer+                   -- ^ Allow selector names on parsing, print them+                   | SNRequire+                   -- ^ Require selector names on parsing, print them+  deriving (Show, Eq) -Then, in a shell:+-- | Printing and parsing options.+data Options = Options { fieldSeparators :: NonEmpty Char+                       -- ^ Separators between fields+                       , recordSeparators :: NonEmpty Char+                       -- ^ Separators between records (which may+                       -- correspond to lines)+                       , conNameMod :: String -> String+                       -- ^ Constructor name modifier+                       , selNameMod :: String -> String+                       -- ^ Record selector name modifier+                       , selNamePolicy :: SelNamePolicy+                       , 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.+                       } -> $ ./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+-- | Default options.+defOpt :: Options+defOpt = Options (' ' :| ['\t']) ('\n' :| [])+  (map toLower) (("--" ++) . map toLower) SNAvoid+  defaultTimeLocale (iso8601DateFormat Nothing) "%H:%M:%S"+  (iso8601DateFormat (Just "%H:%M:%S")) Generic Nothing id --}+parseDSV :: Parser a -> String -> Either String a+parseDSV p s = case parse p "DSV" s of+  Left err -> Left $ show err+  Right x -> Right x -module Coalpit ( module Coalpit.Core-               , module Coalpit.DSV-               ) where+-- | Parse a single record from a string.+fromDSV :: Coalpit a => Options -> String -> Either String a+fromDSV opt str = parseDSV (coalpitParser opt) str -import Coalpit.Core-import Coalpit.DSV+-- | Parse multiple records from a string.+fromDSVList :: Coalpit a => Options -> String -> Either String [a]+fromDSVList opt str =+  parseDSV (coalpitParser opt `sepEndBy` pRecordSep opt) str++-- | Enquote and escape a string, if it contains any characters that+-- need it.+escape :: Options -> String -> String+escape opt str+  | not (null str) &&+    all (\fs -> not (fs `elem` str))+    ('\\'+     : '\"'+     : NE.toList (fieldSeparators opt)+     ++ NE.toList (recordSeparators opt)) = str+  | otherwise = '"' : escaped str ++ "\""+  where+    escaped :: String -> String+    escaped [] = []+    escaped (c:rest)+      | c `elem` "\\\"" = '\\' : c : escaped rest+      | otherwise = c : escaped rest++-- | Build a record ("line") out of individual strings, escaping those+-- if needed.+dsvFromList :: Options -> [String] -> String+dsvFromList opt l = intercalate [NE.head (fieldSeparators opt)]+                    (map (escape opt) l)++-- | Serialize a value.+toDSV :: Coalpit a => Options -> a -> String+toDSV opt x = dsvFromList opt (coalpitPrint opt x)++-- | Serialize multiple values.+toDSVList :: Coalpit a => Options -> [a] -> String+toDSVList opt l =+  concatMap (\x -> toDSV opt x ++ [NE.head (recordSeparators opt)]) l++-- | Compose 'Usage' description.+usage :: Coalpit a => Options -> Proxy a -> Usage+usage opt = coalpitDescription opt []++-- | Compose a usage string.+usageString :: Coalpit a => Options -> Proxy a -> String+usageString opt = usageToString . usage opt++-- | Translate 'Usage' into a string, used by 'usageString'.+usageToString :: Usage -> String+usageToString (UConstructor c) = c+usageToString (URecursive c) = c ++ "..."+usageToString (USelector False s u) = "[" ++ s ++ "] " ++ usageToString u+usageToString (USelector True 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++-- | Parse a field separator.+pFieldSep :: Options -> Parsec String m ()+pFieldSep opt =+  oneOf (NE.toList $ fieldSeparators opt) *> pure ()++-- | Parse a record (line) separator.+pRecordSep :: Options -> Parsec String m ()+pRecordSep opt =+  choice (eof+          : map (\c -> char c *> pure ())+           (NE.toList $ recordSeparators opt))++-- | Parse a token: either a quoted string or a string without+-- unescaped separators. The opposite of 'escape'.+pString :: Options -> Parsec String m String+pString opt =+  (try (quotedString <?> "quoted string"))+  <|> (unquotedString <?> "unquoted string")+  where+    endChars = NE.toList (fieldSeparators opt)+               ++ NE.toList (recordSeparators opt)+    unquotedString = do+      c <- escapedChar endChars+      s <- manyTill (escapedChar endChars)+        (lookAhead $ eof <|> oneOf endChars *> pure ())+      pure (c:s)+    escapedChar ecs = (char '\\' *> oneOf ('\\' : ecs)) <|> anyChar+    quotedString = char '"'+      *> manyTill (escapedChar "\"") (char '"')++-- | Parses a time argument.+pTime :: ParseTime a => Options -> String -> Parser a+pTime opt tf = try $ do+    x <- pString opt+    case readSTime False (timeLocale opt) tf x of+      [(t, "")] -> pure t+      _ -> fail "Failed to parse time"++-- | Read an argument using its 'Read' instance.+pRead :: Read a => Options -> Parser a+pRead opt = do+  x <- pString opt+  case reads x of+    [(n, "")] -> pure n+    _ -> fail $ "Failed to read: " ++ x++-- | Coalpit class: parsing, printing, usage strings.+class Coalpit a where+  coalpitParser :: Options -> Parser a+  default coalpitParser :: (Generic a, GCoalpit (Rep a)) => Options -> Parser a+  coalpitParser opt = to <$> gCoalpitParser opt++  coalpitPrint :: Options -> a -> [String]+  default coalpitPrint :: (Generic a, GCoalpit (Rep a)) => Options -> a -> [String]+  coalpitPrint opt a = gCoalpitPrint opt (from a)++  coalpitDescription :: Options -> [String] -> Proxy a -> Usage+  default coalpitDescription :: (GCoalpit (Rep a))+                    => Options -> [String] -> Proxy a -> Usage+  coalpitDescription opt path Proxy =+    gCoalpitDescription opt path (Proxy :: Proxy (Rep a p))++class GCoalpit a where+  gCoalpitParser :: Options -> Parser (a p)+  gCoalpitPrint :: Options -> a p -> [String]+  gCoalpitDescription :: Options -> [String] -> Proxy (a p) -> Usage+++-- Units+instance GCoalpit U1 where+  gCoalpitParser _ = pure U1+  gCoalpitPrint _ U1 = []+  gCoalpitDescription _ _ (Proxy :: Proxy (U1 f)) = UUnit+++-- Products+instance (GCoalpit a, GCoalpit b) => GCoalpit (a :*: b) where+  gCoalpitParser opt =+    ((:*:) <$>+     (gCoalpitParser opt <* pFieldSep opt) <*> gCoalpitParser opt)+    <?> "product"+  gCoalpitPrint opt (x :*: y) =+    gCoalpitPrint opt x ++ gCoalpitPrint opt y+  gCoalpitDescription opt path (Proxy :: Proxy ((a :*: b) p)) =+    UProduct (gCoalpitDescription opt path (Proxy :: Proxy (a p)))+    (gCoalpitDescription opt path (Proxy :: Proxy (b p)))+++-- Sums+instance+  (GCoalpit a, GCoalpit b) => GCoalpit (a :+: b) where+  gCoalpitParser opt =+    (try (L1 <$> gCoalpitParser opt))+    <|>+    (R1 <$> gCoalpitParser opt)+  gCoalpitPrint opt (L1 x) = gCoalpitPrint opt x+  gCoalpitPrint opt (R1 x) = gCoalpitPrint opt x+  gCoalpitDescription opt path (Proxy :: Proxy ((a :+: b) p)) =+      USum (gCoalpitDescription opt path (Proxy :: Proxy (a p)))+       (gCoalpitDescription 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, selNamePolicy opt) of+        ("", _) -> pure ()+        (_, SNDisable) -> pure ()+        (_, SNRequire) -> string (selNameMod opt nameA) *> pFieldSep opt+        (_, _) -> optional+          (try $ (string (selNameMod opt nameA)) *> pFieldSep opt)+  in M1 <$> (sName *> gCoalpitParser opt)++printS1 :: (GCoalpit a, Selector selA) => Options -> S1 selA a p -> [String]+printS1 opt sel@(M1 x) = case (selName sel, selNamePolicy opt) of+                           ("", _) -> gCoalpitPrint opt x+                           (_, SNDisable) -> gCoalpitPrint opt x+                           (_, SNAvoid) -> gCoalpitPrint opt x+                           (name, _) -> selNameMod opt name : gCoalpitPrint 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, selNamePolicy opt) of+    ("", _) -> gCoalpitDescription opt path (Proxy :: Proxy (a p))+    (_, SNDisable) -> gCoalpitDescription opt path (Proxy :: Proxy (a p))+    (_, snpol) -> USelector (snpol == SNRequire) (selNameMod opt nameA)+      (gCoalpitDescription opt path (Proxy :: Proxy (a p)))++instance (GCoalpit a, Selector selA) => GCoalpit (S1 selA a) where+  gCoalpitParser = parseS1 (selName (undefined :: S1 selA a p))+  gCoalpitPrint = printS1+  gCoalpitDescription = helpS1 (selName (undefined :: S1 selA a p))++-- Constructors++-- | 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)+          (gCoalpitDescription opt (nameA : path) (Proxy :: Proxy (a p)))++-- A constructor wrapping just a unit: no field separator is required+-- after such a constructor.+instance {-#OVERLAPPING#-} (Constructor conA) => GCoalpit (C1 conA U1) where+  gCoalpitParser opt =+    ((string+       (conNameMod opt $ conName (undefined :: C1 conA U1 w))+       <?> "constructor name"))+    *> (fmap M1 (gCoalpitParser opt))+  gCoalpitPrint opt (M1 x) = conNameMod opt (conName (undefined :: C1 conA U1 w))+                       : gCoalpitPrint opt x+  gCoalpitDescription opt path (Proxy :: Proxy (C1 conA U1 p)) =+    (handleRecCon (conName (undefined :: C1 conA U1 w)) opt path+     (Proxy :: Proxy (U1 p)))++-- A constructor with non-unit children, with a field separator+-- between constructor name and its children.+instance (GCoalpit a, Constructor conA) => GCoalpit (C1 conA a) where+  gCoalpitParser opt =+    ((string+       (conNameMod opt $ conName (undefined :: C1 conA a w))+       <?> "constructor name"))+    *> (pFieldSep opt)+    *> (fmap M1 (gCoalpitParser opt))+  gCoalpitPrint opt (M1 x) = conNameMod opt (conName (undefined :: C1 conA a w))+                       : gCoalpitPrint opt x+  gCoalpitDescription opt path (Proxy :: Proxy (C1 conA a p)) =+    (handleRecCon (conName (undefined :: C1 conA a w)) opt path+     (Proxy :: Proxy (a p)))++-- Data types+instance (GCoalpit a) => GCoalpit (D1 conA a) where+  gCoalpitParser = fmap M1 . gCoalpitParser+  gCoalpitPrint opt (M1 x) = gCoalpitPrint opt x+  gCoalpitDescription opt path (Proxy :: Proxy (D1 conA a p)) =+    gCoalpitDescription opt path (Proxy :: Proxy (a p))++-- Constraints and such+instance (Coalpit a) => GCoalpit (K1 i a) where+  gCoalpitParser = fmap K1 . coalpitParser+  gCoalpitPrint opt (K1 x) = coalpitPrint opt x+  gCoalpitDescription opt path (Proxy :: Proxy (K1 x a p)) =+    coalpitDescription opt path (Proxy :: Proxy a)+++-- Common types++instance Coalpit Int where+  coalpitParser opt = pRead opt+  coalpitPrint _ i = [show i]+  coalpitDescription _ _ _ = UType "INT"++instance Coalpit Integer where+  coalpitParser opt = pRead opt+  coalpitPrint _ i = [show i]+  coalpitDescription _ _ _ = UType "INTEGER"++instance Coalpit Word8 where+  coalpitParser opt = pRead opt+  coalpitPrint _ i = [show i]+  coalpitDescription _ _ _ = UType "WORD8"++instance Coalpit Word16 where+  coalpitParser opt = pRead opt+  coalpitPrint _ i = [show i]+  coalpitDescription _ _ _ = UType "WORD16"++instance Coalpit Word32 where+  coalpitParser opt = pRead opt+  coalpitPrint _ i = [show i]+  coalpitDescription _ _ _ = UType "WORD32"++instance Coalpit Word64 where+  coalpitParser opt = pRead opt+  coalpitPrint _ i = [show i]+  coalpitDescription _ _ _ = UType "WORD64"++instance Coalpit Int8 where+  coalpitParser opt = pRead opt+  coalpitPrint _ i = [show i]+  coalpitDescription _ _ _ = UType "INT8"++instance Coalpit Int16 where+  coalpitParser opt = pRead opt+  coalpitPrint _ i = [show i]+  coalpitDescription _ _ _ = UType "INT16"++instance Coalpit Int32 where+  coalpitParser opt = pRead opt+  coalpitPrint _ i = [show i]+  coalpitDescription _ _ _ = UType "INT32"++instance Coalpit Int64 where+  coalpitParser opt = pRead opt+  coalpitPrint _ i = [show i]+  coalpitDescription _ _ _ = UType "INT64"++instance Coalpit Natural where+  coalpitParser opt = pRead opt+  coalpitPrint _ i = [show i]+  coalpitDescription _ _ _ = UType "NATURAL"++instance Coalpit Rational where+  coalpitParser opt = pRead opt+  coalpitPrint _ i = [show i]+  coalpitDescription _ _ _ = UType "RATIONAL"++instance Coalpit Double where+  coalpitParser opt = pRead opt+  coalpitPrint _ i = [show i]+  coalpitDescription _ _ _ = UType "DOUBLE"++instance Coalpit Float where+  coalpitParser opt = pRead opt+  coalpitPrint _ i = [show i]+  coalpitDescription _ _ _ = UType "FLOAT"++instance Coalpit Char where+  coalpitParser opt = pRead opt+  coalpitPrint _ c = [show c]+  coalpitDescription _ _ _ = UType "CHAR"+++instance {-#OVERLAPPING#-} Coalpit String where+  coalpitParser opt = pString opt+  coalpitPrint _ i = [i]+  coalpitDescription _ _ _ = UType "STRING"++instance Coalpit Scientific where+  coalpitParser opt = try $ do+    x <- pString opt+    case reverse $ readP_to_S scientificP x of+      (n, ""):_ -> pure n+      _ -> fail $ "Failed to read a scientific number: " ++ x+  coalpitPrint opt n = [formatScientific+                  (scientificFormat opt) (scientificDecimals opt) n]+  coalpitDescription _ _ _ = UType "SCIENTIFIC"++instance Coalpit Version where+  coalpitParser opt = try $ do+    x <- pString opt+    case reverse $ readP_to_S parseVersion x of+      (v, ""):_ -> pure v+      _ -> fail $ "Failed to read a version: " ++ x+  coalpitPrint _ v = [showVersion v]+  coalpitDescription _ _ _ = UType "VERSION"+++-- | An URI reference (absolute or relative).+instance Coalpit URI where+  coalpitParser opt = try $ do+    x <- pString opt+    maybe (fail $ "Failed to parse URI: " ++ x) pure (parseURIReference x)+  coalpitPrint opt u = [uriToString (uriUserInfo opt) u ""]+  coalpitDescription _ _ _ = UType "URI"+++-- | Uses 'dateTimeFormat'.+instance Coalpit UTCTime where+  coalpitParser opt = pTime opt (dateTimeFormat opt)+  coalpitPrint opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]+  coalpitDescription _ _ _ = UType "UTC_TIME"++-- | Uses 'dateTimeFormat'.+instance Coalpit ZonedTime where+  coalpitParser opt = pTime opt (dateTimeFormat opt)+  coalpitPrint opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]+  coalpitDescription _ _ _ = UType "ZONED_TIME"++-- | Uses 'dateTimeFormat'.+instance Coalpit LocalTime where+  coalpitParser opt = pTime opt (dateTimeFormat opt)+  coalpitPrint opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]+  coalpitDescription _ _ _ = UType "LOCAL_TIME"++-- | Uses 'dateTimeFormat'.+instance Coalpit UniversalTime where+  coalpitParser opt = pTime opt (dateTimeFormat opt)+  coalpitPrint opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]+  coalpitDescription _ _ _ = UType "UNIVERSAL_TIME"++-- | Uses 'timeFormat'.+instance Coalpit TimeOfDay where+  coalpitParser opt = pTime opt (timeFormat opt)+  coalpitPrint opt t = [formatTime (timeLocale opt) (timeFormat opt) t]+  coalpitDescription _ _ _ = UType "TIME_OF_DAY"++-- | Uses 'dateFormat'.+instance Coalpit Day where+  coalpitParser opt = pTime opt (dateFormat opt)+  coalpitPrint opt t = [formatTime (timeLocale opt) (dateFormat opt) t]+  coalpitDescription _ _ _ = UType "DAY"++-- | Converts to/from 'Scientific'.+instance Coalpit NominalDiffTime where+  coalpitParser opt = fromRational . toRational+                  <$> (coalpitParser opt :: Parser Scientific)+  coalpitPrint opt = coalpitPrint opt .+    (fromRational . toRational :: NominalDiffTime -> Scientific)+  coalpitDescription _ _ _ = UType "NOMINAL_DIFF_TIME"++-- | Converts to/from 'Scientific'.+instance Coalpit DiffTime where+  coalpitParser opt = fromRational . toRational+                  <$> (coalpitParser opt :: Parser Scientific)+  coalpitPrint opt = coalpitPrint opt .+    (fromRational . toRational :: DiffTime -> Scientific)+  coalpitDescription _ _ _ = 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 (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)

@@ -1,504 +0,0 @@-{- |-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)))--instance {-# OVERLAPPABLE #-}-  (GCoalpit a, GCoalpit b) => GCoalpit (a :+: b) where-  gArgParser opt =-    L1 <$> gArgParser opt-    <|>-    R1 <$> gArgParser opt-  gToArgs opt (L1 x) = gToArgs opt x-  gToArgs opt (R1 x) = gToArgs opt x-  gArgHelper opt path (Proxy :: Proxy ((a :+: b) p)) =-    -- let nameA = conName (undefined :: a p)-    -- in-      USum (gArgHelper opt path (Proxy :: Proxy (a p)))-       (gArgHelper 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)

@@ -1,59 +0,0 @@-{- |-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)

@@ -1,90 +0,0 @@-{- |-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"

@@ -13,11 +13,7 @@ [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@@ -30,60 +26,45 @@       , fooBar2 = Bar} ``` -With the default options, its serialized version should look like-this:+Its serialized version with the default options is:  ```haskell-["--foobar","foo","1","a string","bar"]-```--What would look like this in a shell:--```sh---foobar foo 1 'a string' bar+input nothing just foo fooargs 1 "a string" bar ``` -And its usage string -- like this:+And its usage string:  ```-[--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+input [--something] (nothing | just STRING) [--foobar] (nothing | just (foo fooargs [--arg1] INT [--arg2] STRING | bar)) [--foobar2] (foo fooargs [--arg1] INT [--arg2] STRING | bar) ``` -And here is output of the `help` function from the same file, with all-the (alwaysUseSelName, omitNamedOptions) combinations:+Other versions can be produced by varying selector name policy. Below+are triples of a policy, a corresponding example serialization, and an+example usage string (output of the `help` function from the example):  ```-(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)+SNDisable+test : 1 : 2 : 3 [] just "a string"+test ([] | : INT ([] | :...)) (nothing | just STRING)+SNDisable+test : 1 : 2 : 3 [] nothing+test ([] | : INT ([] | :...)) (nothing | just STRING)+SNAvoid+test : 1 : 2 : 3 [] just "a string"+test [--foo] ([] | : INT ([] | :...)) [--bar] (nothing | just STRING)+SNAvoid+test : 1 : 2 : 3 [] nothing+test [--foo] ([] | : INT ([] | :...)) [--bar] (nothing | just STRING)+SNPrefer+test --foo : 1 : 2 : 3 [] --bar just "a string"+test [--foo] ([] | : INT ([] | :...)) [--bar] (nothing | just STRING)+SNPrefer+test --foo : 1 : 2 : 3 [] --bar nothing+test [--foo] ([] | : INT ([] | :...)) [--bar] (nothing | just STRING)+SNRequire+test --foo : 1 : 2 : 3 [] --bar just "a string"+test --foo ([] | : INT ([] | :...)) --bar (nothing | just STRING)+SNRequire+test --foo : 1 : 2 : 3 [] --bar nothing+test --foo ([] | : INT ([] | :...)) --bar (nothing | just STRING) ```

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -1,7 +1,7 @@ name:                coalpit-version:             0.1.1.1-synopsis:            Command-line options and DSV parsing and printing-description:         This library generates parsers and printers for+version:             0.2.0.0+synopsis:            DSV (de)serialization+description:         The 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 CLIs via a shared library, while@@ -16,21 +16,17 @@ 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+tested-with:         GHC == 8.0.1, GHC == 9.0.2 bug-reports:         https://github.com/defanor/coalpit/issues source-repository head   type:     git-  location: https://git.uberspace.net/coalpit+  location: https://github.com/defanor/coalpit  library   exposed-modules:     Coalpit-                     , Coalpit.Core-                     , Coalpit.DSV-                     , Coalpit.Parsing   build-depends:       base >= 4.9 && < 5-                     , megaparsec >= 6.2 && < 7+                     , parsec >= 3 && < 4                      , scientific >= 0.3 && < 1                      , time >= 1.6 && < 2                      , network-uri >= 2.6 && < 3@@ -45,7 +41,6 @@   build-depends:       base >= 4.9 && < 5                      , coalpit                      , generic-random >= 1 && < 2-                     , tasty >= 0.12 && < 1+                     , tasty >= 1 && < 2                      , tasty-quickcheck >= 0.9 && < 1-                     , tasty-travis >= 0.2 && < 1   ghc-options:         -Wall -Wno-unused-top-binds

@@ -24,10 +24,10 @@                   , fooBar = Just (Foo FooArgs { arg1 = 1                                                , arg2 = "a string"})                   , fooBar2 = Bar}-      args = toArgs defOpt val+      dsv = toDSV defOpt val   print val-  print args-  print (fromArgs defOpt args :: Either String Input)+  print dsv+  print (fromDSV defOpt dsv :: Either String Input)  data Test = Test { foo :: [Int], bar :: Maybe String }   deriving (Show, Generic, Coalpit)@@ -35,11 +35,9 @@ 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)+    [ let opts = defOpt { selNamePolicy = snpol }+      in ( snpol+         , toDSV opts (Test [1,2,3] vals)          , usageString opts (Proxy :: Proxy Test))-      | ausn <- [True, False]-      , ono <- [True, False]+      | snpol <- [SNDisable, SNAvoid, SNPrefer, SNRequire]       , vals <- [Just "a string", Nothing]]

@@ -1,67 +0,0 @@-{-# 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

@@ -5,11 +5,9 @@ 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 @@ -88,16 +86,11 @@  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)+printAndParse opt _ r = Right r == fromDSV opt (toDSV opt r) +printAndParseList :: (Coalpit a, Eq a)+                  => Options -> Proxy a -> [a] -> Bool+printAndParseList opt _ l = Right l == fromDSVList opt (toDSVList opt l)  variousTypes :: (forall a. (Coalpit a, Eq a, Show a, Arbitrary a) =>                   Proxy a -> String -> TestTree)@@ -122,24 +115,20 @@  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]+  [ testGroup (concat [ "selNamePolicy = ", show snpol ])+    (tt defOpt { selNamePolicy = snpol })+  | snpol <- [SNDisable, SNAvoid, SNPrefer, SNRequire]   ]  qcProps :: TestTree qcProps = testGroup "Quickcheck properties"-  [ testGroup "Right == fromArgs opt . toArgs opt"+  [ testGroup "Right == fromDSV opt . toDSV opt"     (variousOptions $ \opt ->         variousTypes $ \p n -> QC.testProperty n (printAndParse opt p))-  , testGroup-    "id == rights . map (readDSV opt) . lines . unlines . map (showDSV opt)"+  , testGroup "Right == fromDSVList opt . toDSVList opt"     (variousOptions $ \opt ->-        variousTypes $ \p n -> QC.testProperty n (printAndParseDSV opt p))+        variousTypes $ \p n -> QC.testProperty n (printAndParseList opt p))   ]  main :: IO ()-main = travisTestReporter defaultConfig [] qcProps+main = defaultMain qcProps