diff options
| -rw-r--r-- | ChangeLog.md | 7 | ||||
| -rw-r--r-- | Coalpit.hs | 606 | ||||
| -rw-r--r-- | Coalpit/Core.hs | 491 | ||||
| -rw-r--r-- | Coalpit/DSV.hs | 59 | ||||
| -rw-r--r-- | Coalpit/Parsing.hs | 90 | ||||
| -rw-r--r-- | README.md | 81 | ||||
| -rw-r--r-- | coalpit.cabal | 19 | ||||
| -rw-r--r-- | examples/Basic.hs | 16 | ||||
| -rw-r--r-- | examples/Pipes.hs | 67 | ||||
| -rw-r--r-- | test/Test.hs | 33 |
10 files changed, 618 insertions, 851 deletions
diff --git a/ChangeLog.md b/ChangeLog.md index 239d0b7..bf356ee 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 @@ Stability : unstable 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. +-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} -== Example +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 -@ -\{\-\# 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 +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) --} +-- | 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) -module Coalpit ( module Coalpit.Core - , module Coalpit.DSV - ) where +-- | 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) + +-- | 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. + } + +-- | 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 + +-- | Parse a single record from a string. +fromDSV :: Coalpit a => Options -> String -> Either String a +fromDSV opt str = parseDSV (coalpitParser opt) str + +-- | 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" -import Coalpit.Core -import Coalpit.DSV +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) diff --git a/Coalpit/Core.hs b/Coalpit/Core.hs deleted file mode 100644 index e166af9..0000000 --- a/Coalpit/Core.hs +++ /dev/null @@ -1,491 +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))) - - --- 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) diff --git a/Coalpit/DSV.hs b/Coalpit/DSV.hs deleted file mode 100644 index 890399d..0000000 --- a/Coalpit/DSV.hs +++ /dev/null @@ -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) diff --git a/Coalpit/Parsing.hs b/Coalpit/Parsing.hs deleted file mode 100644 index f8fe8fc..0000000 --- a/Coalpit/Parsing.hs +++ /dev/null @@ -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,10 +13,6 @@ 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 @@ -30,60 +26,45 @@ Input { something = Nothing , 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) ``` diff --git a/coalpit.cabal b/coalpit.cabal index e3248a1..d064d84 100644 --- a/coalpit.cabal +++ b/coalpit.cabal @@ -1,7 +1,7 @@ name: coalpit -version: 0.1.1.0 -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 @@ 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 +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 @@ test-suite test-coalpit 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 diff --git a/examples/Basic.hs b/examples/Basic.hs index 13ee95d..60306ca 100644 --- a/examples/Basic.hs +++ b/examples/Basic.hs @@ -24,10 +24,10 @@ main = do , 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 @@ data Test = Test { foo :: [Int], bar :: Maybe String } 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]] diff --git a/examples/Pipes.hs b/examples/Pipes.hs deleted file mode 100644 index b1096e3..0000000 --- a/examples/Pipes.hs +++ /dev/null @@ -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 diff --git a/test/Test.hs b/test/Test.hs index b8d4121..f8476d7 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -5,11 +5,9 @@ import Generic.Random (genericArbitraryU) 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 @@ 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) +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 @@ variousTypes f = 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 |