summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authordefanor <defanor@uberspace.net>2017-12-19 07:58:16 +0300
committerdefanor <defanor@uberspace.net>2017-12-19 07:58:16 +0300
commit62aa7bb8ba54c2a0f480e122c46d967f2102dac5 (patch)
treefeb437122a2f4148795571187912ef00ed787987
parent16a3509836691ff9a43a0a8920d615ba91f8a74f (diff)
Reorganize the modules
-rw-r--r--Coalpit.hs470
-rw-r--r--Coalpit/Core.hs466
-rw-r--r--Coalpit/DSV.hs17
-rw-r--r--coalpit.cabal3
4 files changed, 486 insertions, 470 deletions
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 <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(..)
+ -- * 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 <defanor@uberspace.net>
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