summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordefanor <defanor@uberspace.net>2017-12-03 14:24:28 +0300
committerdefanor <defanor@uberspace.net>2017-12-03 14:26:30 +0300
commit6f2785c9d8bc38c13f5102c085c2fe87d21b8f8a (patch)
treeb266de63c3b0dc705d108240785fedec1d7227b3
parent15f63061dd9308e223077d718db0fce85366538f (diff)
downloadcoalpit-6f2785c9d8bc38c13f5102c085c2fe87d21b8f8a.zip
coalpit-6f2785c9d8bc38c13f5102c085c2fe87d21b8f8a.tar.gz
coalpit-6f2785c9d8bc38c13f5102c085c2fe87d21b8f8a.tar.bz2
Add tests
-rw-r--r--Coalpit.hs19
-rw-r--r--Example.hs21
-rw-r--r--README.md3
-rw-r--r--coalpit.cabal17
-rw-r--r--test/Test.hs107
5 files changed, 159 insertions, 8 deletions
diff --git a/Coalpit.hs b/Coalpit.hs
index a252691..2e5167c 100644
--- a/Coalpit.hs
+++ b/Coalpit.hs
@@ -1,7 +1,6 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -155,11 +154,11 @@ instance (GToArgs a, Selector c) => GToArgs (S1 c a) where
instance {-#OVERLAPPING#-}
(ArgParser a, Selector c) => GArgParser (S1 c (Rec0 (Maybe a))) where
- gArgParser m = do
+ gArgParser m =
case selName (undefined :: S1 c (Rec0 (Maybe a)) f) of
"" -> M1 <$> gArgParser m
name -> do
- x <- optional $ (pS (string (selNameMod m name))) *> argParser m
+ x <- optional $ pS (string (selNameMod m name)) *> argParser m
pure $ M1 $ K1 x
instance {-#OVERLAPPING#-}
@@ -200,19 +199,27 @@ instance (ToArgs a) => GToArgs (K1 i a) where
-- Basic types
instance ArgParser Int where
- argParser _ = pS $ read <$> some digitChar
+ argParser _ = do
+ x <- token Right Nothing
+ case reads x of
+ [(n, "")] -> pure n
+ _ -> fail "Failed to read an Int"
instance ToArgs Int where
toArgs _ i = [show i]
instance {-#OVERLAPPING#-} ArgParser String where
- argParser _ = pS $ many anyChar
+ argParser _ = token Right Nothing
instance {-#OVERLAPPING#-} ToArgs String where
toArgs _ i = [i]
instance ArgParser Double where
- argParser _ = pS $ read <$> some (digitChar <|> char '.')
+ argParser _ = do
+ x <- token Right Nothing
+ case reads x of
+ [(n, "")] -> pure n
+ _ -> fail $ "Failed to read a Double: " ++ x
instance ToArgs Double where
toArgs _ i = [show i]
diff --git a/Example.hs b/Example.hs
index 4df7ae9..1811fc4 100644
--- a/Example.hs
+++ b/Example.hs
@@ -36,3 +36,24 @@ main = do
print val
print a
print $ parse (argParser defMod :: Parser Wrap) "test" a
+
+
+data Record = Record { maybeInt :: Maybe Int
+ , maybeDouble :: Maybe Double
+ , str :: String
+ , listOfStrings :: [String]
+ , maybeListOfNumbers :: Maybe [Int]
+ , otherString :: String
+ } deriving (Generic, Eq, Show)
+instance ArgParser Record
+instance ToArgs Record
+
+
+data NestedRecursiveRecord =
+ NestedRecursiveRecord { record1 :: Maybe Record
+ , recursiveRecord :: Maybe NestedRecursiveRecord
+ , record2 :: Maybe Record
+ } deriving (Generic, Eq, Show)
+instance ArgParser NestedRecursiveRecord
+instance ToArgs NestedRecursiveRecord
+
diff --git a/README.md b/README.md
index f31d8c5..f941909 100644
--- a/README.md
+++ b/README.md
@@ -20,4 +20,7 @@ architectures. Described in more detail in
the
[command-line program interface](https://defanor.uberspace.net/notes/command-line-program-interface.html) note.
+Warning: it is currently possible to run into ambiguity by defining a
+recursive structure with optional named elements.
+
Far from production-ready yet, merely a prototype.
diff --git a/coalpit.cabal b/coalpit.cabal
index 31e2831..0578897 100644
--- a/coalpit.cabal
+++ b/coalpit.cabal
@@ -26,6 +26,19 @@ executable coalpit-example
library
exposed-modules: Coalpit
other-extensions: TemplateHaskell, FlexibleInstances
- build-depends: base >=4.9 && <4.10
- , megaparsec >= 6.2.0
+ build-depends: base >= 4.9 && < 5
+ , megaparsec >= 6.2 && < 7
default-language: Haskell2010
+
+test-suite test-coalpit
+ type: exitcode-stdio-1.0
+ hs-source-dirs: test
+ main-is: Test.hs
+ build-depends: base >= 4.9 && < 5
+ , megaparsec >= 6.2 && < 7
+ , QuickCheck >= 2.10 && < 3
+ , generic-random >= 1 && < 2
+ , tasty >= 0.12 && < 1
+ , tasty-quickcheck >= 0.9 && < 1
+ , tasty-travis >= 0.2 && < 1
+ , coalpit
diff --git a/test/Test.hs b/test/Test.hs
new file mode 100644
index 0000000..28d67ee
--- /dev/null
+++ b/test/Test.hs
@@ -0,0 +1,107 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+import Text.Megaparsec
+import GHC.Generics
+import Generic.Random
+import Test.Tasty
+import Test.Tasty.QuickCheck as QC
+import Data.Proxy
+import Test.Tasty.Travis
+
+import Coalpit
+
+
+data Basic = Basic Int String Double
+ deriving (Generic, Eq, Show)
+instance ArgParser Basic
+instance ToArgs Basic
+instance Arbitrary Basic where arbitrary = genericArbitraryU
+
+data WithLists = WithLists [Int] [String] [Double]
+ deriving (Generic, Eq, Show)
+instance ArgParser WithLists
+instance ToArgs WithLists
+instance Arbitrary WithLists where arbitrary = genericArbitraryU
+
+data Record = Record { maybeInt :: Maybe Int
+ , maybeDouble :: Maybe Double
+ , str :: String
+ , listOfStrings :: [String]
+ , maybeListOfNumbers :: Maybe [Int]
+ , 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
+ deriving (Generic, Eq, Show)
+instance ArgParser Sum
+instance ToArgs Sum
+instance Arbitrary Sum where arbitrary = genericArbitraryU
+
+data Nested = Nested Record Basic WithLists Sum
+ deriving (Generic, Eq, Show)
+instance ArgParser Nested
+instance ToArgs Nested
+instance Arbitrary Nested where arbitrary = genericArbitraryU
+
+data Polymorphic a b = Polymorphic (Maybe a) [b] (Either a b)
+ deriving (Generic, Eq, Show)
+instance (ArgParser a, ArgParser b) => ArgParser (Polymorphic a b)
+instance (ToArgs a, ToArgs b) => ToArgs (Polymorphic a b)
+instance (Arbitrary a, Arbitrary b) => Arbitrary (Polymorphic a b) where
+ arbitrary = genericArbitraryU
+
+data Recursive = RecursiveA
+ | RecursiveB Recursive
+ deriving (Generic, Eq, Show)
+instance ArgParser Recursive
+instance ToArgs Recursive
+instance Arbitrary Recursive where arbitrary = genericArbitraryU
+
+data NestedRecord = NestedRecord { record1 :: Maybe Record
+ , record2 :: Maybe Record
+ , record3 :: Maybe Record
+ } deriving (Generic, Eq, Show)
+instance ArgParser NestedRecord
+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)
+instance ArgParser NestedSum
+instance ToArgs NestedSum
+instance Arbitrary NestedSum where arbitrary = genericArbitraryU
+
+printAndParse :: (ArgParser a, ToArgs a, Eq a, Show a, Arbitrary a)
+ => Proxy a -> a -> Bool
+printAndParse _ r = Right r == parse (argParser defMod) "test" (toArgs defMod r)
+
+mkTest :: (ArgParser a, ToArgs a, Eq a, Show a, Arbitrary a)
+ => Proxy a -> String -> TestTree
+mkTest p n = QC.testProperty ("id == parse . print for " ++ n) (printAndParse p)
+
+main :: IO ()
+main = travisTestReporter defaultConfig [] qcProps
+
+qcProps = testGroup "Quickcheck properties"
+ [ mkTest (Proxy :: Proxy Basic) "Basic"
+ , mkTest (Proxy :: Proxy WithLists) "WithLists"
+ , mkTest (Proxy :: Proxy Record) "Record"
+ , mkTest (Proxy :: Proxy Sum) "Sum"
+ , mkTest (Proxy :: Proxy Nested) "Nested"
+ , mkTest (Proxy :: Proxy (Polymorphic Int Double))
+ "Polymorphic Int Double"
+ , mkTest (Proxy :: Proxy (Polymorphic Basic Record))
+ "Polymorphic Basic Record"
+ , mkTest (Proxy :: Proxy (Polymorphic Nested (Polymorphic Basic Sum)))
+ "Polymorphic Nested (Polymorphic Basic Sum)"
+ , mkTest (Proxy :: Proxy Recursive) "Recursive"
+ , mkTest (Proxy :: Proxy NestedRecord) "NestedRecord"
+ , mkTest (Proxy :: Proxy NestedSum) "NestedSum"
+ ]