summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordefanor <defanor@uberspace.net>2017-12-03 21:06:35 +0300
committerdefanor <defanor@uberspace.net>2017-12-03 21:06:35 +0300
commit8218779504205227f0ea70d0c91270ff504d67a6 (patch)
treec4addbd50786d3d6e0327489c562cc08786d4e59
parent2dfe2f8648a6748234514bcd9d61e5e1a1d1fb72 (diff)
downloadcoalpit-8218779504205227f0ea70d0c91270ff504d67a6.zip
coalpit-8218779504205227f0ea70d0c91270ff504d67a6.tar.gz
coalpit-8218779504205227f0ea70d0c91270ff504d67a6.tar.bz2
Add more instances
-rw-r--r--Coalpit.hs67
-rw-r--r--Example.hs2
-rw-r--r--README.md3
-rw-r--r--test/Test.hs36
4 files changed, 83 insertions, 25 deletions
diff --git a/Coalpit.hs b/Coalpit.hs
index e00350c..d05cc7c 100644
--- a/Coalpit.hs
+++ b/Coalpit.hs
@@ -31,6 +31,7 @@ module Coalpit (
, Parser
, Args(..)
, pS
+ , readArg
) where
import Data.List
@@ -242,34 +243,44 @@ instance (ToArgs a) => GToArgs (K1 i a) where
gToArgs m (K1 x) = toArgs m x
--- Basic types
+-- Common types
-instance ArgParser Int where
- argParser _ = do
- x <- token Right Nothing
- case reads x of
- [(n, "")] -> pure n
- _ -> fail "Failed to read an Int"
+-- | Reads an argument using its 'Read' instance.
+readArg :: Read a => Parser a
+readArg = do
+ x <- token Right Nothing
+ case reads x of
+ [(n, "")] -> pure n
+ _ -> fail $ "Failed to read: " ++ x
+instance ArgParser Int where
+ argParser _ = readArg
instance ToArgs Int where
toArgs _ i = [show i]
-instance {-#OVERLAPPING#-} ArgParser String where
- argParser _ = token Right Nothing
+instance ArgParser Integer where
+ argParser _ = readArg
+instance ToArgs Integer where
+ toArgs _ i = [show i]
-instance {-#OVERLAPPING#-} ToArgs String where
- toArgs _ i = [i]
+instance ArgParser Rational where
+ argParser _ = readArg
+instance ToArgs Rational where
+ toArgs _ i = [show i]
instance ArgParser Double where
- argParser _ = do
- x <- token Right Nothing
- case reads x of
- [(n, "")] -> pure n
- _ -> fail $ "Failed to read a Double: " ++ x
-
+ argParser _ = readArg
instance ToArgs Double where
toArgs _ i = [show i]
+instance {-#OVERLAPPING#-} ArgParser String where
+ argParser _ = token Right Nothing
+instance {-#OVERLAPPING#-} ToArgs String where
+ toArgs _ i = [i]
+
+instance ArgParser Bool
+instance ToArgs Bool
+
instance ArgParser a => ArgParser (Maybe a)
instance ToArgs a => ToArgs (Maybe a)
@@ -278,3 +289,25 @@ instance ToArgs a => ToArgs [a]
instance (ArgParser a, ArgParser b) => ArgParser (Either a b)
instance (ToArgs a, ToArgs b) => ToArgs (Either a b)
+
+-- | Expects a dot.
+instance ArgParser () where
+ argParser _ = pS (char '.') *> pure ()
+-- | Shows a dot.
+instance ToArgs () where
+ toArgs _ () = ["."]
+
+instance (ArgParser a, ArgParser b) => ArgParser (a, b)
+instance (ToArgs a, ToArgs b) => ToArgs (a, b)
+
+instance (ArgParser a, ArgParser b, ArgParser c) => ArgParser (a, b, c)
+instance (ToArgs a, ToArgs b, ToArgs c) => ToArgs (a, b, c)
+
+instance (ArgParser a, ArgParser b, ArgParser c, ArgParser d) =>
+ ArgParser (a, b, c, d)
+instance (ToArgs a, ToArgs b, ToArgs c, ToArgs d) => ToArgs (a, b, c, d)
+
+instance (ArgParser a, ArgParser b, ArgParser c, ArgParser d, ArgParser e) =>
+ ArgParser (a, b, c, d, e)
+instance (ToArgs a, ToArgs b, ToArgs c, ToArgs d, ToArgs e) =>
+ ToArgs (a, b, c, d, e)
diff --git a/Example.hs b/Example.hs
index 9f48024..4784aa2 100644
--- a/Example.hs
+++ b/Example.hs
@@ -1,4 +1,6 @@
{-# LANGUAGE DeriveGeneric #-}
+module Main where
+
import GHC.Generics
import Coalpit
diff --git a/README.md b/README.md
index e46037d..6992749 100644
--- a/README.md
+++ b/README.md
@@ -15,7 +15,8 @@ e.g.
but the aim here is to handle more or less arbitrary types.
Warning: it is currently possible to run into ambiguity by defining a
-recursive structure with optional named elements.
+recursive structure with optional named elements. Unit type can be
+used to avoid that, see the `RecursiveRecordMaybe` test.
Not production-ready yet, merely a prototype.
diff --git a/test/Test.hs b/test/Test.hs
index 5002263..4589f04 100644
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -26,16 +26,16 @@ data Record = Record { maybeInt :: Maybe Int
, maybeDouble :: Maybe Double
, str :: String
, listOfStrings :: [String]
- , maybeListOfNumbers :: Maybe [Int]
+ , maybeListOfNumbers :: Maybe [Integer]
, otherString :: String
} deriving (Generic, Eq, Show)
instance ArgParser Record
instance ToArgs Record
instance Arbitrary Record where arbitrary = genericArbitraryU
-data Sum = Foo Int
- | Bar
- | Baz String Double
+data Sum = Foo Int Bool
+ | Bar
+ | Baz (String, (Double, Integer), Rational)
deriving (Generic, Eq, Show)
instance ArgParser Sum
instance ToArgs Sum
@@ -70,13 +70,33 @@ instance ToArgs NestedRecord
instance Arbitrary NestedRecord where arbitrary = genericArbitraryU
data NestedSum = NestedFoo Record
- | NestedBar Sum Basic Nested
- | NestedBaz (Polymorphic Int Double)
- deriving (Generic, Eq, Show)
+ | NestedBar Sum Basic Nested
+ | NestedBaz (Polymorphic Int Double)
+ deriving (Generic, Eq, Show)
instance ArgParser NestedSum
instance ToArgs NestedSum
instance Arbitrary NestedSum where arbitrary = genericArbitraryU
+data RecursiveRecordMaybe = RecursiveRecordMaybe
+ { rrm :: Maybe RecursiveRecordMaybe
+ , record :: Maybe Record
+ , guard :: ()
+ } deriving (Generic, Eq, Show)
+instance ArgParser RecursiveRecordMaybe
+instance ToArgs RecursiveRecordMaybe
+instance Arbitrary RecursiveRecordMaybe where arbitrary = genericArbitraryU
+
+data RecursiveRecordMaybe2 = RecursiveRecordMaybe2
+ { record1' :: Maybe Record
+ , rrm' :: Maybe RecursiveRecordMaybe2
+ , record2' :: Maybe Record
+ , guard' :: ()
+ } deriving (Generic, Eq, Show)
+instance ArgParser RecursiveRecordMaybe2
+instance ToArgs RecursiveRecordMaybe2
+instance Arbitrary RecursiveRecordMaybe2 where arbitrary = genericArbitraryU
+
+
printAndParse :: (ArgParser a, ToArgs a, Eq a)
=> Proxy a -> a -> Bool
printAndParse _ r = Right r == fromArgs defMod (toArgs defMod r)
@@ -104,4 +124,6 @@ qcProps = testGroup "Quickcheck properties"
, mkTest (Proxy :: Proxy Recursive) "Recursive"
, mkTest (Proxy :: Proxy NestedRecord) "NestedRecord"
, mkTest (Proxy :: Proxy NestedSum) "NestedSum"
+ , mkTest (Proxy :: Proxy RecursiveRecordMaybe) "RecursiveRecordMaybe"
+ , mkTest (Proxy :: Proxy RecursiveRecordMaybe2) "RecursiveRecordMaybe2"
]