summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordefanor <defanor@uberspace.net>2017-12-03 19:06:33 +0300
committerdefanor <defanor@uberspace.net>2017-12-03 19:06:33 +0300
commit2dfe2f8648a6748234514bcd9d61e5e1a1d1fb72 (patch)
treed4a80b112a836c153eefcbd63d25e3eeb02e8d7d
parentac125877105ed69fd0a198a09c331f16124751f3 (diff)
downloadcoalpit-2dfe2f8648a6748234514bcd9d61e5e1a1d1fb72.zip
coalpit-2dfe2f8648a6748234514bcd9d61e5e1a1d1fb72.tar.gz
coalpit-2dfe2f8648a6748234514bcd9d61e5e1a1d1fb72.tar.bz2
Refactor
Add annotations, fix -Wall warnings, lint, etc.
-rw-r--r--Coalpit.hs92
-rw-r--r--Example.hs10
-rw-r--r--coalpit.cabal15
-rw-r--r--test/Test.hs6
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 <defanor@uberspace.net>
+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"