summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordefanor <defanor@uberspace.net>2017-12-16 11:14:08 +0300
committerdefanor <defanor@uberspace.net>2017-12-16 11:14:08 +0300
commit10958faa61301446a980ea93cb2e77287b51a225 (patch)
treeb5e111b0bed3278c8d783f0490e88037ed6d1bd5
parentfa15e16722ece1b429a6f45d6f57d77e528fe825 (diff)
downloadcoalpit-10958faa61301446a980ea93cb2e77287b51a225.zip
coalpit-10958faa61301446a980ea93cb2e77287b51a225.tar.gz
coalpit-10958faa61301446a980ea93cb2e77287b51a225.tar.bz2
Add more instances
Numeric and date/time types.
-rw-r--r--Coalpit.hs151
-rw-r--r--coalpit.cabal4
-rw-r--r--test/Test.hs8
3 files changed, 157 insertions, 6 deletions
diff --git a/Coalpit.hs b/Coalpit.hs
index 381e7be..3efd73f 100644
--- a/Coalpit.hs
+++ b/Coalpit.hs
@@ -83,6 +83,15 @@ import Data.Proxy
import Data.Semigroup
import Data.Void
import qualified Data.List.NonEmpty as NE
+import Data.Word
+import Numeric.Natural
+import Data.Int
+import Data.Time.Clock
+import Data.Time.Format
+import Data.Time.Calendar
+import Data.Time.LocalTime
+import Data.Scientific
+import Text.ParserCombinators.ReadP (readP_to_S)
-- | Command-line argument wrapper, used to avoid orphan ShowToken
@@ -139,11 +148,20 @@ data Options = Options { conNameMod :: String -> String
, 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
}
-- | 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
-- | Coalpit class: parsing, printing, usage strings.
class Coalpit a where
@@ -375,6 +393,51 @@ instance Coalpit Integer where
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]
@@ -385,22 +448,106 @@ instance Coalpit Double where
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"
+
+
+pTime :: ParseTime a => Options -> String -> Parser a
+pTime opt tf = try $ do
+ x <- token (Right . unArg) Nothing
+ case readSTime False (timeLocale opt) tf x of
+ [(t, "")] -> pure t
+ _ -> fail "Failed to parse time"
+
+timeArg :: FormatTime t => Options -> String -> t -> [String]
+timeArg opt tf t = [formatTime (timeLocale opt) tf t]
+
+-- | Uses 'dateTimeFormat'.
+instance Coalpit UTCTime where
+ argParser opt = pTime opt (dateTimeFormat opt)
+ toArgs opt = timeArg opt (dateTimeFormat opt)
+ argHelper _ _ _ = "UTC_TIME"
+
+-- | Uses 'dateTimeFormat'.
+instance Coalpit ZonedTime where
+ argParser opt = pTime opt (dateTimeFormat opt)
+ toArgs opt = timeArg opt (dateTimeFormat opt)
+ argHelper _ _ _ = "ZONED_TIME"
+
+-- | Uses 'dateTimeFormat'.
+instance Coalpit LocalTime where
+ argParser opt = pTime opt (dateTimeFormat opt)
+ toArgs opt = timeArg opt (dateTimeFormat opt)
+ argHelper _ _ _ = "LOCAL_TIME"
+
+-- | Uses 'dateTimeFormat'.
+instance Coalpit UniversalTime where
+ argParser opt = pTime opt (dateTimeFormat opt)
+ toArgs opt = timeArg opt (dateTimeFormat opt)
+ argHelper _ _ _ = "UNIVERSAL_TIME"
+
+-- | Uses 'timeFormat'.
+instance Coalpit TimeOfDay where
+ argParser opt = pTime opt (timeFormat opt)
+ toArgs opt = timeArg opt (timeFormat opt)
+ argHelper _ _ _ = "TIME_OF_DAY"
+
+-- | Uses 'dateFormat'.
+instance Coalpit Day where
+ argParser opt = pTime opt (dateFormat opt)
+ toArgs opt = timeArg opt (dateFormat opt)
+ 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 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)
-instance (Coalpit a, Coalpit b, Coalpit c, Coalpit d, Coalpit e) =>
- Coalpit (a, b, c, d, e)
diff --git a/coalpit.cabal b/coalpit.cabal
index b093652..f8b9cd6 100644
--- a/coalpit.cabal
+++ b/coalpit.cabal
@@ -26,6 +26,8 @@ library
exposed-modules: Coalpit
build-depends: base >= 4.9 && < 5
, megaparsec >= 6.2 && < 7
+ , scientific >= 0.3 && < 1
+ , time >= 1.6 && < 2
default-language: Haskell2010
ghc-options: -Wall
@@ -35,9 +37,9 @@ test-suite test-coalpit
hs-source-dirs: test
main-is: Test.hs
build-depends: base >= 4.9 && < 5
+ , coalpit
, generic-random >= 1 && < 2
, tasty >= 0.12 && < 1
, tasty-quickcheck >= 0.9 && < 1
, tasty-travis >= 0.2 && < 1
- , coalpit
ghc-options: -Wall -Wno-unused-top-binds
diff --git a/test/Test.hs b/test/Test.hs
index 9b92993..4d965c9 100644
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -6,6 +6,8 @@ import Test.Tasty
import Test.Tasty.QuickCheck as QC
import Data.Proxy
import Test.Tasty.Travis
+import Data.Word
+import Data.Int
import Coalpit
@@ -22,14 +24,14 @@ data Record = Record { maybeInt :: Maybe Int
, maybeDouble :: Maybe Double
, str :: String
, listOfStrings :: [String]
- , maybeListOfNumbers :: Maybe [Integer]
+ , maybeNonEmptyListOfNumbers :: Maybe [Integer]
, otherString :: String
} deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary Record where arbitrary = genericArbitraryU
data Sum = Foo Int Bool
| Bar
- | Baz (String, (Double, Integer), Rational)
+ | Baz (Int8, (Float, Word16), Rational)
deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary Sum where arbitrary = genericArbitraryU
@@ -56,7 +58,7 @@ instance Arbitrary NestedRecord where arbitrary = genericArbitraryU
data NestedSum = NestedFoo Record
| NestedBar Sum Basic Nested
- | NestedBaz (Polymorphic Int Double)
+ | NestedBaz (Polymorphic Char Double)
deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary NestedSum where arbitrary = genericArbitraryU