diff options
| -rw-r--r-- | Coalpit.hs | 67 | ||||
| -rw-r--r-- | Example.hs | 2 | ||||
| -rw-r--r-- | README.md | 3 | ||||
| -rw-r--r-- | test/Test.hs | 36 |
4 files changed, 83 insertions, 25 deletions
@@ -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) @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} +module Main where + import GHC.Generics import Coalpit @@ -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" ] |