From 2dfe2f8648a6748234514bcd9d61e5e1a1d1fb72 Mon Sep 17 00:00:00 2001 From: defanor Date: Sun, 3 Dec 2017 19:06:33 +0300 Subject: Refactor Add annotations, fix -Wall warnings, lint, etc. --- Coalpit.hs | 92 ++++++++++++++++++++++++++++++++++++++++++++--------------- Example.hs | 10 ++----- coalpit.cabal | 15 ++++------ test/Test.hs | 6 ++-- 4 files changed, 81 insertions(+), 42 deletions(-) diff --git a/Coalpit.hs b/Coalpit.hs index 2e5167c..e00350c 100644 --- a/Coalpit.hs +++ b/Coalpit.hs @@ -1,3 +1,16 @@ +{- | +Description : Command-line options parsing and printing +Maintainer : defanor +Stability : unstable +Portability : non-portable (uses GHC extensions) + +Coalpit is a library for building "command-line program interfaces": +the goal is to get interfaces between programs quickly and easily, +while keeping them language-agnostic and more user- and shell +scripting-friendly than JSON and similar formats. + +-} + {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DefaultSignatures #-} @@ -5,25 +18,42 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -module Coalpit where +module Coalpit ( + -- * Core classes + ArgParser(..) + , ToArgs(..) + -- * Utility functions + , fromArgs + -- * Modifiers + , Modifiers(..) + , defMod + -- * Parsing helpers + , Parser + , Args(..) + , pS + ) where import Data.List import GHC.Generics import Text.Megaparsec import Text.Megaparsec.Char -import Data.Maybe import Data.Char import Data.Proxy import Data.Semigroup -import Data.Either +-- | Command-line arguments wrapper, used to avoid an orphan 'Stream' +-- instance. +newtype Args = Args [String] + +-- | Advances by one token. advance :: Pos -> SourcePos -> t -> SourcePos -advance width (SourcePos n l c) t = SourcePos n l (c <> pos1) +advance _ (SourcePos n l c) _ = SourcePos n l (c <> pos1) -instance Stream [String] where - type Token [String] = String - type Tokens [String] = [String] +-- | A list of strings (command-line arguments) stream. +instance Stream Args where + type Token Args = String + type Tokens Args = [String] tokenToChunk Proxy = pure tokensToChunk Proxy = id chunkToTokens Proxy = id @@ -31,32 +61,41 @@ instance Stream [String] where chunkEmpty Proxy = null advance1 Proxy = advance advanceN Proxy w = foldl' (advance w) - take1_ [] = Nothing - take1_ (t:ts) = Just (t, ts) - takeN_ n s - | n <= 0 = Just ([], s) + take1_ (Args []) = Nothing + take1_ (Args (t:ts)) = Just (t, Args ts) + takeN_ n (Args s) + | n <= 0 = Just ([], Args s) | null s = Nothing - | otherwise = Just (splitAt n s) - takeWhile_ = span + | otherwise = Just (take n s, Args (drop n s)) + takeWhile_ f (Args s) = (takeWhile f s, Args (dropWhile f s)) -type Parser = Parsec String [String] +-- | Command-line arguments parser. +type Parser = Parsec String Args -pS :: Parsec String String a -> Parsec String [String] a +-- | Applies a String parser to a single argument. +pS :: Parsec String String a -> Parsec String Args a pS p = try $ do x <- token Right Nothing case parse p "argument" x of Left e -> fail $ show e - Right x -> pure x + Right x' -> pure x' +-- | Name modifiers. data Modifiers = Modifiers { conNameMod :: String -> String - , selNameMod :: String -> String } + -- ^ Constructor name modifier. + , selNameMod :: String -> String + -- ^ Record selector name modifier. + } +-- | Default modifiers. defMod :: Modifiers defMod = Modifiers (map toLower) (("--" ++) . map toLower) + -- Core classes +-- | Arguments parser class. class ArgParser a where argParser :: Modifiers -> Parser a default argParser :: (Generic a, GArgParser (Rep a)) => Modifiers -> Parser a @@ -65,6 +104,13 @@ class ArgParser a where class GArgParser f where gArgParser :: Modifiers -> Parser (f a) +-- | Parses arguments. +fromArgs :: ArgParser a => Modifiers -> [String] -> Either String a +fromArgs m args = case parse (argParser m) "arguments" (Args args) of + Left err -> Left $ show err + Right x -> Right x + +-- | Arguments serializer class. class ToArgs a where toArgs :: Modifiers -> a -> [String] default toArgs :: (Generic a, GToArgs (Rep a)) => Modifiers -> a -> [String] @@ -171,20 +217,20 @@ instance {-#OVERLAPPING#-} -- Constructors -instance (GArgParser a, Constructor c) => GArgParser (C1 c a) where +instance (GArgParser a) => GArgParser (C1 c a) where gArgParser m = M1 <$> gArgParser m -instance (GToArgs a, Constructor c) => GToArgs (C1 c a) where - gToArgs m c@(M1 x) = gToArgs m x +instance (GToArgs a) => GToArgs (C1 c a) where + gToArgs m (M1 x) = gToArgs m x -- Data types -instance (GArgParser a, Datatype c) => GArgParser (D1 c a) where +instance (GArgParser a) => GArgParser (D1 c a) where gArgParser m = M1 <$> gArgParser m -instance (GToArgs a, Datatype c) => GToArgs (D1 c a) where - gToArgs m d@(M1 x) = gToArgs m x +instance (GToArgs a) => GToArgs (D1 c a) where + gToArgs m (M1 x) = gToArgs m x -- Constraints and such diff --git a/Example.hs b/Example.hs index 9230d97..9f48024 100644 --- a/Example.hs +++ b/Example.hs @@ -1,9 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} - -module Main where - import GHC.Generics -import Text.Megaparsec import Coalpit data FooArgs = FooArgs { arg1 :: Int @@ -28,10 +24,10 @@ instance ToArgs Input main :: IO () main = do let val = Input { something = Nothing - , fooBar = Just (Foo (FooArgs { arg1 = 1 - , arg2 = "a string"})) + , fooBar = Just (Foo FooArgs { arg1 = 1 + , arg2 = "a string"}) , fooBar2 = Bar} args = toArgs defMod val print val print args - print $ parse (argParser defMod :: Parser Input) "test" args + print (fromArgs defMod args :: Either String Input) diff --git a/coalpit.cabal b/coalpit.cabal index 91e175a..dcf8b43 100644 --- a/coalpit.cabal +++ b/coalpit.cabal @@ -1,37 +1,34 @@ --- Initial coalpit.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - name: coalpit -version: 0.1.0.0 --- synopsis: --- description: +version: 0.1.0.1 +synopsis: Command-line options parsing and printing license: BSD3 license-file: LICENSE author: defanor maintainer: defanor@uberspace.net --- copyright: category: Console build-type: Simple extra-source-files: ChangeLog.md , Example.hs , README.md cabal-version: >=1.10 +tested-with: GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.1 library exposed-modules: Coalpit - other-extensions: TemplateHaskell, FlexibleInstances build-depends: base >= 4.9 && < 5 , megaparsec >= 6.2 && < 7 default-language: Haskell2010 + ghc-options: -Wall test-suite test-coalpit + default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Test.hs build-depends: base >= 4.9 && < 5 - , megaparsec >= 6.2 && < 7 , 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 28d67ee..5002263 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} -import Text.Megaparsec import GHC.Generics import Generic.Random import Test.Tasty @@ -78,9 +77,9 @@ instance ArgParser NestedSum instance ToArgs NestedSum instance Arbitrary NestedSum where arbitrary = genericArbitraryU -printAndParse :: (ArgParser a, ToArgs a, Eq a, Show a, Arbitrary a) +printAndParse :: (ArgParser a, ToArgs a, Eq a) => Proxy a -> a -> Bool -printAndParse _ r = Right r == parse (argParser defMod) "test" (toArgs defMod r) +printAndParse _ r = Right r == fromArgs defMod (toArgs defMod r) mkTest :: (ArgParser a, ToArgs a, Eq a, Show a, Arbitrary a) => Proxy a -> String -> TestTree @@ -89,6 +88,7 @@ mkTest p n = QC.testProperty ("id == parse . print for " ++ n) (printAndParse p) main :: IO () main = travisTestReporter defaultConfig [] qcProps +qcProps :: TestTree qcProps = testGroup "Quickcheck properties" [ mkTest (Proxy :: Proxy Basic) "Basic" , mkTest (Proxy :: Proxy WithLists) "WithLists" -- cgit v1.2.3