diff options
| -rw-r--r-- | Coalpit.hs | 19 | ||||
| -rw-r--r-- | Example.hs | 21 | ||||
| -rw-r--r-- | README.md | 3 | ||||
| -rw-r--r-- | coalpit.cabal | 17 | ||||
| -rw-r--r-- | test/Test.hs | 107 |
5 files changed, 159 insertions, 8 deletions
@@ -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] @@ -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 + @@ -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" + ] |