diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,15 @@ +0.2.2 +===== + + * Supported user-defined `Reader` errors. (https://github.com/supki/envparse/pull/4) + + * Widened the range of GHC versions to test the library with from 7.6–7.8 to 7.6–HEAD. + +0.2.2 +===== + + * Added `helpDoc`, a `Parser` pretty-printer for use in error messages. + 0.2.1 ===== diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014-2015, Matvey Aksenov +Copyright (c) 2014-2016, Matvey Aksenov All rights reserved. diff --git a/envparse.cabal b/envparse.cabal --- a/envparse.cabal +++ b/envparse.cabal @@ -1,5 +1,5 @@ name: envparse -version: 0.2.2 +version: 0.3.0 synopsis: Parse environment variables description: Here's a simple example of a program that uses @envparse@'s parser: @@ -19,7 +19,7 @@ main :: IO () main = do - Hello { name, quiet } <- hello + Hello {name, quiet} <- hello unless quiet $ putStrLn (\"Hello, \" ++ name ++ \"!\") @ @@ -45,7 +45,7 @@ NAME is unset @ homepage: https://supki.github.io/envparse -license: BSD2 +license: BSD3 license-file: LICENSE author: Matvey Aksenov maintainer: matvey.aksenov@gmail.com @@ -53,10 +53,12 @@ category: System build-type: Simple cabal-version: >= 1.10 +tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3 extra-source-files: README.markdown CHANGELOG.markdown example/Main.hs + example/CustomError.hs source-repository head type: git @@ -65,7 +67,7 @@ source-repository this type: git location: https://github.com/supki/envparse - tag: 0.2.2 + tag: 0.3.0 library default-language: @@ -78,6 +80,7 @@ exposed-modules: Env other-modules: + Env.Error Env.Free Env.Help Env.Parse diff --git a/example/CustomError.hs b/example/CustomError.hs new file mode 100644 --- /dev/null +++ b/example/CustomError.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +-- | Greetings for $NAMES +-- +-- @ +-- % NAME=a5579150 COUNT=0 runhaskell -isrc example/Main.hs +-- ... +-- COUNT must be > 0, but is 0 +-- % NAME=a5579150 COUNT=3 runhaskell -isrc example/Main.hs +-- Hello, foo! +-- Hello, foo! +-- Hello, foo! +module Main (main) where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>), (<*>)) +#endif +import Control.Monad (replicateM_) +import Env +import Text.Printf (printf) + + +data Hello = Hello { name :: String, count :: Int } + +main :: IO () +main = do + Hello {name, count} <- hello + replicateM_ count $ + putStrLn ("Hello, " ++ name ++ "!") + +hello :: IO Hello +hello = Env.parse (header "envparse example" . handleError customErrorHandler) $ Hello + <$> var nonempty "NAME" (help "Target for the greeting") + <*> var (positive <=< auto) "COUNT" (help "How many times to greet?") + +customErrorHandler :: ErrorHandler CustomError +customErrorHandler name err = + case err of + NonPositive n -> + Just (printf " %s must be > 0, but is %d" name n) + _ -> + defaultErrorHandler name err + +positive :: Int -> Either CustomError Int +positive n + | n <= 0 = + Left (NonPositive n) + | otherwise = + return n + +data CustomError + = NonPositive Int + | EnvError Error + +-- * Boilerplate + +instance AsUnset CustomError where + unset = + EnvError unset + tryUnset err = + case err of + EnvError err' -> tryUnset err' + _ -> Nothing + +instance AsEmpty CustomError where + empty = + EnvError empty + tryEmpty err = + case err of + EnvError err' -> tryEmpty err' + _ -> Nothing + +instance AsUnread CustomError where + unread = + EnvError . unread + tryUnread err = + case err of + EnvError err' -> tryUnread err' + _ -> Nothing diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} -- | Greetings for $NAME -- @@ -9,16 +10,18 @@ -- @ module Main (main) where +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>), (<*>)) +#endif import Control.Monad (unless) import Env data Hello = Hello { name :: String, quiet :: Bool } - main :: IO () main = do - Hello { name, quiet } <- hello + Hello {name, quiet} <- hello unless quiet $ putStrLn ("Hello, " ++ name ++ "!") diff --git a/src/Env.hs b/src/Env.hs --- a/src/Env.hs +++ b/src/Env.hs @@ -11,13 +11,13 @@ -- data Hello = Hello { name :: String, quiet :: Bool } -- -- hello :: IO Hello --- hello = Env.'parse' ('header' \"envparse example\") $ +-- hello = Env.'parse' ('Help.header' \"envparse example\") $ -- Hello \<$\> 'var' ('str' <=< 'nonempty') \"NAME\" ('help' \"Target for the greeting\") -- \<*\> 'switch' \"QUIET\" ('help' \"Whether to actually print the greeting\") -- -- main :: IO () -- main = do --- Hello { name, quiet } <- hello +-- Hello {name, quiet} <- hello -- unless quiet $ -- putStrLn (\"Hello, \" ++ name ++ \"!\") -- @ @@ -47,10 +47,13 @@ , parseOr , Parser , Mod - , Info - , header - , desc - , footer + , Help.Info + , Help.header + , Help.desc + , Help.footer + , Help.handleError + , Help.ErrorHandler + , Help.defaultErrorHandler , prefixed , var , Var @@ -65,14 +68,14 @@ , Flag , HasHelp , help - , helpDoc + , Help.helpDoc + , Error(..) + , Error.AsUnset(..) + , Error.AsEmpty(..) + , Error.AsUnread(..) -- * Re-exports -- $re-exports - , pure, (<$>), (<*>), (*>), (<*), optional - , empty, (<|>) - , (<=<), (>=>) - , (<>), mempty, mconcat - , asum + , optional, (<=<), (>=>), (<>), asum -- * Testing -- $testing , parsePure @@ -82,15 +85,18 @@ import Control.Monad ((>=>), (<=<)) import Data.Foldable (asum) #if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (Monoid(..)) -#endif +import Data.Monoid (Monoid(..), (<>)) +#else import Data.Monoid ((<>)) +#endif import System.Environment (getEnvironment) import System.Exit (exitFailure) import qualified System.IO as IO -import Env.Help (helpInfo, helpDoc) +import qualified Env.Help as Help import Env.Parse +import Env.Error (Error) +import qualified Env.Error as Error -- $re-exports -- External functions that may be useful to the consumer of the library @@ -99,32 +105,26 @@ -- Utilities to test—without dabbling in IO—that your parsers do -- what you want them to do - -- | Parse the environment or die -- -- Prints the help text and exits with @EXIT_FAILURE@ on encountering a parse error. -- -- @ --- >>> parse ('header' \"env-parse 0.2.0\") ('var' 'str' \"USER\" ('def' \"nobody\")) +-- >>> parse ('Help.header' \"env-parse 0.2.0\") ('var' 'str' \"USER\" ('def' \"nobody\")) -- @ -parse :: Mod Info a -> Parser a -> IO a -parse m = fmap (either (\_ -> error "absurd") id) . parseOr die m +parse :: (Help.Info Error -> Help.Info e) -> Parser e a -> IO a +parse m = + fmap (either (\_ -> error "absurd") id) . parseOr die m -- | Try to parse the environment -- -- Use this if simply dying on failure (the behavior of 'parse') is inadequate for your needs. -parseOr :: (String -> IO a) -> Mod Info b -> Parser b -> IO (Either a b) -parseOr f m p = traverseLeft f . parsePure m p =<< getEnvironment +parseOr :: (String -> IO a) -> (Help.Info Error -> Help.Info e) -> Parser e b -> IO (Either a b) +parseOr f g p = + traverseLeft (f . Help.helpInfo (g Help.defaultInfo) p) . parsePure p =<< getEnvironment die :: String -> IO a die m = do IO.hPutStrLn IO.stderr m; exitFailure - --- | Try to parse a pure environment -parsePure :: Mod Info a -> Parser a -> [(String, String)] -> Either String a -parsePure (Mod f) p = mapLeft (helpInfo (f defaultInfo) p) . static p - -mapLeft :: (a -> b) -> Either a t -> Either b t -mapLeft f = either (Left . f) Right traverseLeft :: Applicative f => (a -> f b) -> Either a t -> f (Either b t) traverseLeft f = either (fmap Left . f) (pure . Right) diff --git a/src/Env/Error.hs b/src/Env/Error.hs new file mode 100644 --- /dev/null +++ b/src/Env/Error.hs @@ -0,0 +1,64 @@ +-- | This module contains an extensible error infrastructure. +-- +-- Each kind of errors gets a separate type class which encodes +-- a 'Prism' (roughly a getter and a constructor). The 'Reader's, then, +-- have the constraints for precisely the set of errors they can return. +module Env.Error + ( Error(..) + , AsUnset(..) + , AsEmpty(..) + , AsUnread(..) + ) where + + +-- | The type of errors returned by @envparse@'s 'Reader's. These fall into 3 +-- categories: +-- +-- * Variables that are unset in the environment. +-- * Variables whose value is empty. +-- * Variables whose value cannot be parsed using the 'Read' instance. +data Error + = UnsetError + | EmptyError + | UnreadError String + deriving (Show, Eq) + +-- | The class of types that contain and can be constructed from +-- the error returned from parsing unset variables. +class AsUnset e where + unset :: e + tryUnset :: e -> Maybe () + +instance AsUnset Error where + unset = UnsetError + tryUnset err = + case err of + UnsetError -> Just () + _ -> Nothing + +-- | The class of types that contain and can be constructed from +-- the error returned from parsing variables whose value is empty. +class AsEmpty e where + empty :: e + tryEmpty :: e -> Maybe () + +instance AsEmpty Error where + empty = EmptyError + tryEmpty err = + case err of + EmptyError -> Just () + _ -> Nothing + +-- | The class of types that contain and can be constructed from +-- the error returned from parsing variable whose value cannot +-- be parsed using the 'Read' instance. +class AsUnread e where + unread :: String -> e + tryUnread :: e -> Maybe String + +instance AsUnread Error where + unread = UnreadError + tryUnread err = + case err of + UnreadError msg -> Just msg + _ -> Nothing diff --git a/src/Env/Help.hs b/src/Env/Help.hs --- a/src/Env/Help.hs +++ b/src/Env/Help.hs @@ -2,35 +2,46 @@ module Env.Help ( helpInfo , helpDoc + , Info + , ErrorHandler + , defaultInfo + , defaultErrorHandler + , header + , desc + , footer + , handleError ) where +import Data.Foldable (asum) import qualified Data.List as List import qualified Data.Map as Map -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, mapMaybe) import Data.Ord (comparing) +import Env.Error (Error) +import qualified Env.Error as Error import Env.Free -import Env.Parse +import Env.Parse hiding (Mod) -helpInfo :: Info a -> Parser b -> [Error] -> String -helpInfo Info { infoHeader, infoDesc, infoFooter } p errors = +helpInfo :: Info e -> Parser e b -> [(String, e)] -> String +helpInfo Info {infoHeader, infoDesc, infoFooter, infoHandleError} p errors = List.intercalate "\n\n" $ catMaybes [ infoHeader , fmap (List.intercalate "\n" . splitWords 50) infoDesc , Just (helpDoc p) , fmap (List.intercalate "\n" . splitWords 50) infoFooter - ] ++ helpErrors errors + ] ++ helpErrors infoHandleError errors --- | A pretty-printed list of recognized environment variables suitable for usage messages. -helpDoc :: Parser a -> String +-- | A pretty-printed list of recognized environment variables suitable for usage messages +helpDoc :: Parser e a -> String helpDoc p = List.intercalate "\n" ("Available environment variables:\n" : helpParserDoc p) -helpParserDoc :: Parser a -> [String] +helpParserDoc :: Parser e a -> [String] helpParserDoc = concat . Map.elems . foldAlt (\v -> Map.singleton (varfName v) (helpVarfDoc v)) . unParser -helpVarfDoc :: VarF a -> [String] +helpVarfDoc :: VarF e a -> [String] helpVarfDoc VarF { varfName, varfHelp, varfHelpDef } = case varfHelp of Nothing -> [indent 2 varfName] @@ -43,21 +54,6 @@ where k = length varfName t = maybe h (\s -> h ++ " (default: " ++ s ++")") varfHelpDef -helpErrors :: [Error] -> [String] -helpErrors [] = [] -helpErrors fs = - [ "Parsing errors:" - , List.intercalate "\n" (map helpError (List.sortBy (comparing varName) fs)) - ] - -helpError :: Error -> String -helpError (ParseError n e) = " " ++ n ++ " cannot be parsed: " ++ e -helpError (ENoExistError n) = " " ++ n ++ " is unset" - -varName :: Error -> String -varName (ParseError n _) = n -varName (ENoExistError n) = n - splitWords :: Int -> String -> [String] splitWords n = go [] 0 . words where @@ -74,3 +70,65 @@ indent :: Int -> String -> String indent n s = replicate n ' ' ++ s + +helpErrors :: ErrorHandler e -> [(String, e)] -> [String] +helpErrors _ [] = [] +helpErrors handler fs = + [ "Parsing errors:" + , List.intercalate "\n" (mapMaybe (uncurry handler) (List.sortBy (comparing varName) fs)) + ] + +-- | Parser's metadata +data Info e = Info + { infoHeader :: Maybe String + , infoDesc :: Maybe String + , infoFooter :: Maybe String + , infoHandleError :: ErrorHandler e + } + +-- | Given a variable name and an error value, try to produce a useful error message +type ErrorHandler e = String -> e -> Maybe String + +defaultInfo :: Info Error +defaultInfo = Info + { infoHeader = Nothing + , infoDesc = Nothing + , infoFooter = Nothing + , infoHandleError = defaultErrorHandler + } + +-- | Set the help text header (it usually includes the application's name and version) +header :: String -> Info e -> Info e +header h i = i {infoHeader=Just h} + +-- | Set the short description +desc :: String -> Info e -> Info e +desc h i = i {infoDesc=Just h} + +-- | Set the help text footer (it usually includes examples) +footer :: String -> Info e -> Info e +footer h i = i {infoFooter=Just h} + +-- | An error handler +handleError :: ErrorHandler e -> Info x -> Info e +handleError handler i = i {infoHandleError=handler} + +-- | The default error handler +defaultErrorHandler :: (Error.AsUnset e, Error.AsEmpty e, Error.AsUnread e) => ErrorHandler e +defaultErrorHandler name err = + asum [handleUnsetError name err, handleEmptyError name err, handleUnreadError name err] + +handleUnsetError :: Error.AsUnset e => ErrorHandler e +handleUnsetError name = + fmap (\() -> indent 2 (name ++ " is unset")) . Error.tryUnset + +handleEmptyError :: Error.AsEmpty e => ErrorHandler e +handleEmptyError name = + fmap (\() -> indent 2 (name ++ " is empty")) . Error.tryEmpty + +handleUnreadError :: Error.AsUnread e => ErrorHandler e +handleUnreadError name = + fmap (\val -> indent 2 (name ++ " has value " ++ val ++ " that cannot be parsed")) . Error.tryUnread + +varName :: (String, e) -> String +varName (n, _) = n diff --git a/src/Env/Parse.hs b/src/Env/Parse.hs --- a/src/Env/Parse.hs +++ b/src/Env/Parse.hs @@ -1,18 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} module Env.Parse ( Parser(..) , VarF(..) - , static - , Error(..) + , parsePure , Mod(..) - , Info(..) - , defaultInfo - , header - , desc - , footer , prefixed , var , Var(..) @@ -31,6 +26,7 @@ ) where import Control.Applicative +import Control.Monad ((<=<)) import Data.Map (Map) import qualified Data.Map as Map #if __GLASGOW_HASKELL__ < 710 @@ -39,71 +35,68 @@ import Data.String (IsString(..)) import Env.Free +import qualified Env.Error as Error import Env.Val -static :: Parser b -> [(String, String)] -> Either [Error] b -static (Parser p) (Map.fromList -> env) = +-- | Try to parse a pure environment +parsePure :: Parser e b -> [(String, String)] -> Either [(String, e)] b +parsePure (Parser p) (Map.fromList -> env) = toEither (runAlt go p) where - go v = maybe id (\d x -> x <|> pure d) (varfDef v) (fromEither (readVar v =<< lookupVar v env)) - -lookupVar :: VarF a -> Map String String -> Either [Error] String -lookupVar v = note [ENoExistError (varfName v)] . Map.lookup (varfName v) - -readVar :: VarF a -> String -> Either [Error] a -readVar v = mapLeft (pure . ParseError (varfName v)) . varfReader v + go v = maybe id (\d x -> x <|> pure d) (varfDef v) (fromEither (readVar v env)) -note :: a -> Maybe b -> Either a b -note a = maybe (Left a) Right +readVar :: VarF e a -> Map String String -> Either [(String, e)] a +readVar VarF {varfName, varfReader} = + mapLeft (pure . (\err -> (varfName, err))) . varfReader varfName mapLeft :: (a -> b) -> Either a t -> Either b t -mapLeft f = either (Left . f) Right +mapLeft f = + either (Left . f) Right -- | An environment parser -newtype Parser a = Parser { unParser :: Alt VarF a } +newtype Parser e a = Parser { unParser :: Alt (VarF e) a } deriving (Functor) -instance Applicative Parser where +instance Applicative (Parser e) where pure = Parser . pure Parser f <*> Parser x = Parser (f <*> x) -instance Alternative Parser where +instance Alternative (Parser e) where empty = Parser empty Parser f <|> Parser x = Parser (f <|> x) -- | The string to prepend to the name of every declared environment variable -prefixed :: String -> Parser a -> Parser a +prefixed :: String -> Parser e a -> Parser e a prefixed pre = Parser . hoistAlt (\v -> v { varfName = pre ++ varfName v }) . unParser -data Error - = ParseError String String - | ENoExistError String - deriving (Show, Eq) - -data VarF a = VarF +data VarF e a = VarF { varfName :: String - , varfReader :: Reader a + , varfReader :: String -> Map String String -> Either e a , varfHelp :: Maybe String , varfDef :: Maybe a , varfHelpDef :: Maybe String } deriving (Functor) -- | An environment variable's value parser. Use @(<=<)@ and @(>=>)@ to combine these -type Reader a = String -> Either String a +type Reader e a = String -> Either e a +lookupVar :: Error.AsUnset e => String -> Map String String -> Either e String +lookupVar name = + maybe (Left Error.unset) Right . Map.lookup name + -- | Parse a particular variable from the environment -- -- @ -- >>> var 'str' \"EDITOR\" ('def' \"vim\" <> 'helpDef' show) -- @ -var :: Reader a -> String -> Mod Var a -> Parser a +var :: Error.AsUnset e => Reader e a -> String -> Mod Var a -> Parser e a var r n (Mod f) = Parser . liftAlt $ VarF { varfName = n - , varfReader = r + , varfReader = \name -> r <=< lookupVar name , varfHelp = varHelp , varfDef = varDef , varfHelpDef = varHelpDef <*> varDef @@ -116,12 +109,13 @@ -- -- /Note:/ this parser never fails. flag - :: a -- ^ default value + :: forall e a. (Error.AsUnset e, Error.AsEmpty e) + => a -- ^ default value -> a -- ^ active value - -> String -> Mod Flag a -> Parser a + -> String -> Mod Flag a -> Parser e a flag f t n (Mod g) = Parser . liftAlt $ VarF { varfName = n - , varfReader = Right . either (const f) (const t) . (nonempty :: Reader String) + , varfReader = \name -> Right . either (const f) (const t) . (nonempty :: Reader e String) <=< lookupVar name , varfHelp = flagHelp , varfDef = Just f , varfHelpDef = Nothing @@ -132,20 +126,20 @@ -- | A simple boolean 'flag' -- -- /Note:/ the same caveats apply. -switch :: String -> Mod Flag Bool -> Parser Bool +switch :: (Error.AsUnset e, Error.AsEmpty e) => String -> Mod Flag Bool -> Parser e Bool switch = flag False True -- | The trivial reader -str :: IsString s => Reader s +str :: IsString s => Reader e s str = Right . fromString -- | The reader that accepts only non-empty strings -nonempty :: IsString s => Reader s -nonempty = fmap fromString . go where go [] = Left "a non-empty string is expected"; go xs = Right xs +nonempty :: (Error.AsEmpty e, IsString s) => Reader e s +nonempty = fmap fromString . go where go [] = Left Error.empty; go xs = Right xs -- | The reader that uses the 'Read' instance of the type -auto :: Read a => Reader a -auto = \s -> case reads s of [(v, "")] -> Right v; _ -> Left (show s ++ " is an invalid value") +auto :: (Error.AsUnread e, Read a) => Reader e a +auto = \s -> case reads s of [(v, "")] -> Right v; _ -> Left (Error.unread (show s)) {-# ANN auto "HLint: ignore Redundant lambda" #-} @@ -157,32 +151,6 @@ mempty = Mod id mappend (Mod f) (Mod g) = Mod (g . f) - --- | Parser's metadata -data Info a = Info - { infoHeader :: Maybe String - , infoDesc :: Maybe String - , infoFooter :: Maybe String - } - -defaultInfo :: Info a -defaultInfo = Info - { infoHeader = Nothing - , infoDesc = Nothing - , infoFooter = Nothing - } - --- | A help text header (it usually includes an application name and version) -header :: String -> Mod Info a -header h = Mod (\i -> i { infoHeader = Just h }) - --- | A short program description -desc :: String -> Mod Info a -desc h = Mod (\i -> i { infoDesc = Just h }) - --- | A help text footer (it usually includes examples) -footer :: String -> Mod Info a -footer h = Mod (\i -> i { infoFooter = Just h }) -- | Environment variable metadata