From 62aa7bb8ba54c2a0f480e122c46d967f2102dac5 Mon Sep 17 00:00:00 2001 From: defanor Date: Tue, 19 Dec 2017 07:58:16 +0300 Subject: Reorganize the modules --- Coalpit.hs | 470 +------------------------------------------------------- Coalpit/Core.hs | 466 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ Coalpit/DSV.hs | 17 +- coalpit.cabal | 3 +- 4 files changed, 486 insertions(+), 470 deletions(-) create mode 100644 Coalpit/Core.hs diff --git a/Coalpit.hs b/Coalpit.hs index a0a7ac2..27df1bb 100644 --- a/Coalpit.hs +++ b/Coalpit.hs @@ -57,471 +57,9 @@ Then, in a shell: -} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} +module Coalpit ( module Coalpit.Core + , module Coalpit.DSV + ) where -module Coalpit ( - -- * Core class - Coalpit(..) - -- * Utility functions - , fromArgs - , usage - , showDSV - , readDSV - -- * 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 +import Coalpit.Core import Coalpit.DSV - - --- | 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 - --- | 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 -> String - default argHelper :: (GCoalpit (Rep a)) - => Options -> [String] -> Proxy a -> String - 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) -> String - --- | 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 a usage string. -usage :: Coalpit a => Options -> Proxy a -> String -usage opt = argHelper opt [] - --- | Shows values in DSV format. -showDSV :: Coalpit a => Options -> [a] -> String -showDSV opt = composeDSV (fieldSeparator opt) . map (toArgs opt) - --- | Reads values from DSV format. -readDSV :: Coalpit a => Options -> String -> [Either String a] -readDSV opt = map (>>= fromArgs opt) . parseDSV (fieldSeparator opt) - - --- Units -instance GCoalpit U1 where - gArgParser _ = pure U1 - gToArgs _ U1 = [] - gArgHelper _ _ (Proxy :: Proxy (U1 f)) = "" - - --- 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)) = - concat [ 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) - -> String -handleRecCon nameA opt path (Proxy :: Proxy (a p)) = conNameMod opt nameA - ++ if nameA `elem` path - then "..." - else case gArgHelper opt (nameA : path) (Proxy :: Proxy (a p)) of - "" -> "" - s -> ' ' : s - -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 concat [ "(" - , 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 concat [ "(" - , 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 concat [ "(" - , 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) -> String -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) -> concat [ 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, 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) -> concat [ "[" - , 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 _ _ _ = "INT" - -instance Coalpit Integer where - argParser _ = readArg - toArgs _ i = [show i] - argHelper _ _ _ = "INTEGER" - -instance Coalpit Word8 where - argParser _ = readArg - toArgs _ i = [show i] - argHelper _ _ _ = "WORD8" - -instance Coalpit Word16 where - argParser _ = readArg - toArgs _ i = [show i] - argHelper _ _ _ = "WORD16" - -instance Coalpit Word32 where - argParser _ = readArg - toArgs _ i = [show i] - argHelper _ _ _ = "WORD32" - -instance Coalpit Word64 where - argParser _ = readArg - toArgs _ i = [show i] - argHelper _ _ _ = "WORD64" - -instance Coalpit Int8 where - argParser _ = readArg - toArgs _ i = [show i] - argHelper _ _ _ = "INT8" - -instance Coalpit Int16 where - argParser _ = readArg - toArgs _ i = [show i] - argHelper _ _ _ = "INT16" - -instance Coalpit Int32 where - argParser _ = readArg - toArgs _ i = [show i] - argHelper _ _ _ = "INT32" - -instance Coalpit Int64 where - argParser _ = readArg - toArgs _ i = [show i] - argHelper _ _ _ = "INT64" - -instance Coalpit Natural where - argParser _ = readArg - toArgs _ i = [show i] - argHelper _ _ _ = "NATURAL" - -instance Coalpit Rational where - argParser _ = readArg - toArgs _ i = [show i] - argHelper _ _ _ = "RATIONAL" - -instance Coalpit Double where - argParser _ = readArg - toArgs _ i = [show i] - argHelper _ _ _ = "DOUBLE" - -instance Coalpit Float where - argParser _ = readArg - toArgs _ i = [show i] - argHelper _ _ _ = "FLOAT" - -instance Coalpit Char where - argParser _ = readArg - toArgs _ c = [show c] - argHelper _ _ _ = "CHAR" - -instance {-#OVERLAPPING#-} Coalpit String where - argParser _ = token (Right . unArg) Nothing - toArgs _ i = [i] - argHelper _ _ _ = "STRING" - --- | A dot ("."). -instance Coalpit () where - argParser _ = pS (char '.') *> pure () - toArgs _ () = ["."] - argHelper _ _ _ = "." - -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 _ _ _ = "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 _ _ _ = "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 _ _ _ = "URI" - - --- | Uses 'dateTimeFormat'. -instance Coalpit UTCTime where - argParser opt = pTime (timeLocale opt) (dateTimeFormat opt) - toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t] - argHelper _ _ _ = "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 _ _ _ = "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 _ _ _ = "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 _ _ _ = "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 _ _ _ = "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 _ _ _ = "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 _ _ _ = "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 _ _ _ = "DIFF_TIME" - - -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/Core.hs b/Coalpit/Core.hs new file mode 100644 index 0000000..3e84b23 --- /dev/null +++ b/Coalpit/Core.hs @@ -0,0 +1,466 @@ +{- | +Module : Coalpit.Core +Description : Core Coalpit definitions +Maintainer : defanor +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(..) + -- * Utility functions + , fromArgs + , usage + -- * 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 + +-- | 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 a usage string. +usage :: Coalpit a => Options -> Proxy a -> String +usage opt = argHelper opt [] + +-- | 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 -> String + default argHelper :: (GCoalpit (Rep a)) + => Options -> [String] -> Proxy a -> String + 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) -> String + + +-- Units +instance GCoalpit U1 where + gArgParser _ = pure U1 + gToArgs _ U1 = [] + gArgHelper _ _ (Proxy :: Proxy (U1 f)) = "" + + +-- 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)) = + concat [ 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) + -> String +handleRecCon nameA opt path (Proxy :: Proxy (a p)) = conNameMod opt nameA + ++ if nameA `elem` path + then "..." + else case gArgHelper opt (nameA : path) (Proxy :: Proxy (a p)) of + "" -> "" + s -> ' ' : s + +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 concat [ "(" + , 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 concat [ "(" + , 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 concat [ "(" + , 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) -> String +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) -> concat [ 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) -> concat [ "[" + , 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 _ _ _ = "INT" + +instance Coalpit Integer where + argParser _ = readArg + toArgs _ i = [show i] + argHelper _ _ _ = "INTEGER" + +instance Coalpit Word8 where + argParser _ = readArg + toArgs _ i = [show i] + argHelper _ _ _ = "WORD8" + +instance Coalpit Word16 where + argParser _ = readArg + toArgs _ i = [show i] + argHelper _ _ _ = "WORD16" + +instance Coalpit Word32 where + argParser _ = readArg + toArgs _ i = [show i] + argHelper _ _ _ = "WORD32" + +instance Coalpit Word64 where + argParser _ = readArg + toArgs _ i = [show i] + argHelper _ _ _ = "WORD64" + +instance Coalpit Int8 where + argParser _ = readArg + toArgs _ i = [show i] + argHelper _ _ _ = "INT8" + +instance Coalpit Int16 where + argParser _ = readArg + toArgs _ i = [show i] + argHelper _ _ _ = "INT16" + +instance Coalpit Int32 where + argParser _ = readArg + toArgs _ i = [show i] + argHelper _ _ _ = "INT32" + +instance Coalpit Int64 where + argParser _ = readArg + toArgs _ i = [show i] + argHelper _ _ _ = "INT64" + +instance Coalpit Natural where + argParser _ = readArg + toArgs _ i = [show i] + argHelper _ _ _ = "NATURAL" + +instance Coalpit Rational where + argParser _ = readArg + toArgs _ i = [show i] + argHelper _ _ _ = "RATIONAL" + +instance Coalpit Double where + argParser _ = readArg + toArgs _ i = [show i] + argHelper _ _ _ = "DOUBLE" + +instance Coalpit Float where + argParser _ = readArg + toArgs _ i = [show i] + argHelper _ _ _ = "FLOAT" + +instance Coalpit Char where + argParser _ = readArg + toArgs _ c = [show c] + argHelper _ _ _ = "CHAR" + +instance {-#OVERLAPPING#-} Coalpit String where + argParser _ = token (Right . unArg) Nothing + toArgs _ i = [i] + argHelper _ _ _ = "STRING" + +-- | A dot ("."). +instance Coalpit () where + argParser _ = pS (char '.') *> pure () + toArgs _ () = ["."] + argHelper _ _ _ = "." + +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 _ _ _ = "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 _ _ _ = "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 _ _ _ = "URI" + + +-- | Uses 'dateTimeFormat'. +instance Coalpit UTCTime where + argParser opt = pTime (timeLocale opt) (dateTimeFormat opt) + toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t] + argHelper _ _ _ = "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 _ _ _ = "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 _ _ _ = "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 _ _ _ = "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 _ _ _ = "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 _ _ _ = "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 _ _ _ = "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 _ _ _ = "DIFF_TIME" + + +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 index f11f830..4940843 100644 --- a/Coalpit/DSV.hs +++ b/Coalpit/DSV.hs @@ -1,23 +1,25 @@ {- | Module : Coalpit.DSV -Description : Argument parsing facilities +Description : DSV printing and parsing Maintainer : defanor Stability : unstable Portability : non-portable (uses GHC extensions) -This module provides functions useful for argument parsing. +This module provides functions for DSV printing and parsing. -} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} -module Coalpit.DSV (composeDSV, parseDSV) where +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 @@ -63,3 +65,12 @@ parseDSV fs = map parseLine . lines parseLine 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 = composeDSV (fieldSeparator opt) . map (toArgs opt) + +-- | Reads values from DSV format. +readDSV :: Coalpit a => Options -> String -> [Either String a] +readDSV opt = map (>>= fromArgs opt) . parseDSV (fieldSeparator opt) diff --git a/coalpit.cabal b/coalpit.cabal index 3b8f664..1d91ea7 100644 --- a/coalpit.cabal +++ b/coalpit.cabal @@ -25,8 +25,9 @@ source-repository head library exposed-modules: Coalpit - , Coalpit.Parsing + , Coalpit.Core , Coalpit.DSV + , Coalpit.Parsing build-depends: base >= 4.9 && < 5 , megaparsec >= 6.2 && < 7 , scientific >= 0.3 && < 1 -- cgit v1.2.3