packages feed

envparse 0.3.3 → 0.4

raw patch · 16 files changed

+733/−555 lines, 16 filesdep +textdep ~base

Dependencies added: text

Dependency ranges changed: base

Files

CHANGELOG.markdown view
@@ -1,3 +1,17 @@+0.4+===++  * Supported GHC 8.0.1.++  * On GHC 7.8 and newer, as a secutiry measure, all declared variables are unset by the end of+    a successful parse.  If you want to keep the variable in the environment, use the `keep` modifier.+    (https://github.com/supki/envparse/pull/7)++0.3.4+=====++  * Added `splitOn`.+ 0.3.3 =====
envparse.cabal view
@@ -1,5 +1,5 @@ name:                envparse-version:             0.3.3+version:             0.4 synopsis:            Parse environment variables description:   Here's a simple example of a program that uses @envparse@'s parser:@@ -53,7 +53,7 @@ category:            System build-type:          Simple cabal-version:       >= 1.10-tested-with:         GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3+tested-with:         GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 extra-source-files:   README.markdown   CHANGELOG.markdown@@ -69,7 +69,7 @@ source-repository this   type:     git   location: https://github.com/supki/envparse-  tag:      0.3.3+  tag:      0.4  library   default-language:@@ -82,15 +82,14 @@     src   exposed-modules:     Env+    Env.Internal.Error+    Env.Internal.Free+    Env.Internal.Help+    Env.Internal.Val+    Env.Internal.Parser   if impl(ghc >= 7.10)     exposed-modules:       Env.Generic-  other-modules:-    Env.Error-    Env.Free-    Env.Help-    Env.Parse-    Env.Val   ghc-options:     -Wall @@ -104,6 +103,7 @@       >= 4.6 && < 5     , containers     , hspec+    , text   hs-source-dirs:     src     test@@ -112,5 +112,6 @@   other-modules:     EnvSpec     Env.GenericSpec+    Env.Internal.ParserSpec   ghc-options:     -Wall
src/Env.hs view
@@ -60,6 +60,7 @@   , Reader   , str   , nonempty+  , splitOn   , auto   , def   , helpDef@@ -68,6 +69,8 @@   , Flag   , HasHelp   , help+  , HasKeep+  , keep   , Help.helpDoc   , Error(..)   , Error.AsUnset(..)@@ -83,20 +86,23 @@  import           Control.Applicative import           Control.Monad ((>=>), (<=<))-import           Data.Foldable (asum)+import           Data.Foldable (asum, for_) #if __GLASGOW_HASKELL__ < 710 import           Data.Monoid (Monoid(..), (<>)) #else import           Data.Monoid ((<>)) #endif import           System.Environment (getEnvironment)+#if __GLASGOW_HASKELL__ >= 708+import           System.Environment (unsetEnv)+#endif import           System.Exit (exitFailure) import qualified System.IO as IO -import qualified Env.Help as Help-import           Env.Parse-import           Env.Error (Error)-import qualified Env.Error as Error+import qualified Env.Internal.Help as Help+import           Env.Internal.Parser+import           Env.Internal.Error (Error)+import qualified Env.Internal.Error as Error  -- $re-exports -- External functions that may be useful to the consumer of the library@@ -120,11 +126,18 @@ -- -- Use this if simply dying on failure (the behavior of 'parse') is inadequate for your needs. 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+parseOr onFailure helpMod parser = do+  b <- fmap (parsePure parser) getEnvironment+#if __GLASGOW_HASKELL__ >= 708+  for_ b $ \_ ->+    eachUnsetVar parser unsetEnv+#endif+  traverseLeft (onFailure . Help.helpInfo (helpMod Help.defaultInfo) parser) b  die :: String -> IO a-die m = do IO.hPutStrLn IO.stderr m; exitFailure+die m =+  do IO.hPutStrLn IO.stderr m; exitFailure  traverseLeft :: Applicative f => (a -> f b) -> Either a t -> f (Either b t)-traverseLeft f = either (fmap Left . f) (pure . Right)+traverseLeft f =+  either (fmap Left . f) (pure . Right)
− src/Env/Error.hs 
@@ -1,64 +0,0 @@--- | 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
− src/Env/Free.hs 
@@ -1,89 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}--- | @Alt F@ is the free 'Alternative' functor on @F@-module Env.Free-  ( Alt(..)-  , liftAlt-  , runAlt-  , foldAlt-  , hoistAlt-  -- * Debug-  , inspect-  ) where--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (Applicative(..))-#endif-import Control.Applicative (Alternative(..))-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid (Monoid(..))-#endif---data Alt f a where-  Nope :: Alt f a-  Pure :: a -> Alt f a-  Ap   :: Alt f (a -> b) -> Alt f a -> Alt f b-  Alt  :: Alt f a -> Alt f a -> Alt f a-  Lift :: f a -> Alt f a---- | Print the free structure-inspect :: Alt f a -> String-inspect Nope      = "Nope"-inspect (Pure _)  = "Pure _"-inspect (Ap f x)  = concat ["(", inspect f, ") <*> (", inspect x, ")"]-inspect (Alt x y) = concat ["(", inspect x, ") <|> (", inspect y, ")"]-inspect (Lift _)  = "Lift _"--instance Functor f => Functor (Alt f) where-  fmap _ Nope      = Nope-  fmap f (Pure a)  = Pure (f a)-  fmap f (Ap a v)  = Ap (fmap (f .) a) v-  fmap f (Alt a b) = Alt (fmap f a) (fmap f b)-  fmap f (Lift a)  = Lift (fmap f a)--instance Functor f => Applicative (Alt f) where-  pure = Pure-  (<*>) = Ap--instance Functor f => Alternative (Alt f) where-  empty = Nope-  (<|>) = Alt---liftAlt :: f a -> Alt f a-liftAlt = Lift--runAlt :: forall f g a. Alternative g => (forall x. f x -> g x) -> Alt f a -> g a-runAlt u = go where-  go  :: Alt f b -> g b-  go Nope      = empty-  go (Pure a)  = pure a-  go (Ap f x)  = go f <*> go x-  go (Alt s t) = go s <|> go t-  go (Lift x)  = u x--foldAlt :: Monoid p => (forall a. f a -> p) -> Alt f b -> p-foldAlt f = unMon . runAlt (Mon . f)--hoistAlt :: forall f g b. Functor g => (forall a. f a -> g a) -> Alt f b -> Alt g b-hoistAlt nat = runAlt (Lift . nat)----- | The 'Alternative' functor induced by the 'Monoid'-newtype Mon m a = Mon-  { unMon :: m-  } deriving (Show, Eq)--instance Functor (Mon m) where-  fmap _ (Mon a) = Mon a--instance Monoid m => Applicative (Mon m) where-  pure _ = Mon mempty-  Mon x <*> Mon y = Mon (mappend x y)--instance Monoid m => Alternative (Mon m) where-  empty = Mon mempty-  Mon x <|> Mon y = Mon (mappend x y)
src/Env/Generic.hs view
@@ -1,6 +1,10 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveTraversable #-}+#if __GLASGOW_HASKELL__ < 800+{-# LANGUAGE ExplicitNamespaces #-}+#endif {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-}@@ -91,7 +95,11 @@ module Env.Generic   ( Record(..)   , Field(..)+#if __GLASGOW_HASKELL__ < 800   , (?)(..)+#else+  , type (?)(..)+#endif   , G.Generic   ) where @@ -138,7 +146,7 @@     fmap G.M1 . gr  -- Constant values are converted to 'Env.Parser's using their 'Field' instance.-instance (Env.AsUnset e, Field e a) => GRecord e (G.K1 i a) where+instance Field e a => GRecord e (G.K1 i a) where   gr State {stateVar} =     fmap G.K1 (field stateVar Nothing) @@ -158,7 +166,17 @@   gr x =     fmap G.L1 (gr x) <|> fmap G.R1 (gr x) +#if __GLASGOW_HASKELL__ < 800+type family Type x :: ConType where+  Type G.NoSelector = 'Plain+  Type x = 'Record++data ConType = Plain | Record+ instance (G.Selector c, Type c ~ 'Record, GRecord e a) => GRecord e (G.S1 c a) where+#else+instance (G.Selector c, c ~ 'G.MetaSel ('Just x1) x2 x3 x4, GRecord e a) => GRecord e (G.S1 c a) where+#endif   gr state@State {statePrefix, stateCon} =     fmap G.M1 (gr state {stateVar=statePrefix ++ suffix})    where@@ -179,12 +197,6 @@   go2 "" = ""   go2 (l:u:xs) | Char.isLower l && Char.isUpper u = l : '_' : u : go2 xs   go2 (x:xs) = x : go2 xs--type family Type x :: ConType where-  Type G.NoSelector = 'Plain-  Type x = 'Record--data ConType = Plain | Record  -- | Given a @Field e a@ instance, a value of the type @a@ can be parsed from an environment variable. -- If the parsing fails, a value of an error type @e@ is returned.
− src/Env/Help.hs 
@@ -1,134 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-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, mapMaybe)-import           Data.Ord (comparing)--import           Env.Error (Error)-import qualified Env.Error as Error-import           Env.Free-import           Env.Parse hiding (Mod)---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 infoHandleError errors---- | 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 e a -> [String]-helpParserDoc = concat . Map.elems . foldAlt (\v -> Map.singleton (varfName v) (helpVarfDoc v)) . unParser--helpVarfDoc :: VarF e a -> [String]-helpVarfDoc VarF { varfName, varfHelp, varfHelpDef } =-  case varfHelp of-    Nothing -> [indent 2 varfName]-    Just h-      | k > 15    -> indent 2 varfName : map (indent 25) (splitWords 30 t)-      | otherwise ->-          case zipWith indent (23 - k : repeat 25) (splitWords 30 t) of-            (x : xs) -> (indent 2 varfName ++ x) : xs-            []       -> [indent 2 varfName]-     where k = length varfName-           t = maybe h (\s -> h ++ " (default: " ++ s ++")") varfHelpDef--splitWords :: Int -> String -> [String]-splitWords n = go [] 0 . words- where-  go acc _ [] = prep acc-  go acc k (w : ws)-    | k + z < n = go (w : acc) (k + z) ws-    | z > n     = prep acc ++ case splitAt n w of (w', w'') -> w' : go [] 0 (w'' : ws)-    | otherwise = prep acc ++ go [w] z ws-   where-    z = length w--  prep []  = []-  prep acc = [unwords (reverse acc)]--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
+ src/Env/Internal/Error.hs view
@@ -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.Internal.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
+ src/Env/Internal/Free.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | @Alt F@ is the free 'Alternative' functor on @F@+module Env.Internal.Free+  ( Alt(..)+  , liftAlt+  , runAlt+  , foldAlt+  , hoistAlt+  -- * Debug+  , inspect+  ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative (Applicative(..))+#endif+import Control.Applicative (Alternative(..))+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid (Monoid(..))+#endif+++data Alt f a where+  Nope :: Alt f a+  Pure :: a -> Alt f a+  Ap   :: Alt f (a -> b) -> Alt f a -> Alt f b+  Alt  :: Alt f a -> Alt f a -> Alt f a+  Lift :: f a -> Alt f a++-- | Print the free structure+inspect :: Alt f a -> String+inspect Nope      = "Nope"+inspect (Pure _)  = "Pure _"+inspect (Ap f x)  = concat ["(", inspect f, ") <*> (", inspect x, ")"]+inspect (Alt x y) = concat ["(", inspect x, ") <|> (", inspect y, ")"]+inspect (Lift _)  = "Lift _"++instance Functor f => Functor (Alt f) where+  fmap _ Nope      = Nope+  fmap f (Pure a)  = Pure (f a)+  fmap f (Ap a v)  = Ap (fmap (f .) a) v+  fmap f (Alt a b) = Alt (fmap f a) (fmap f b)+  fmap f (Lift a)  = Lift (fmap f a)++instance Functor f => Applicative (Alt f) where+  pure = Pure+  (<*>) = Ap++instance Functor f => Alternative (Alt f) where+  empty = Nope+  (<|>) = Alt+++liftAlt :: f a -> Alt f a+liftAlt = Lift++runAlt :: forall f g a. Alternative g => (forall x. f x -> g x) -> Alt f a -> g a+runAlt u = go where+  go  :: Alt f b -> g b+  go Nope      = empty+  go (Pure a)  = pure a+  go (Ap f x)  = go f <*> go x+  go (Alt s t) = go s <|> go t+  go (Lift x)  = u x++foldAlt :: Monoid p => (forall a. f a -> p) -> Alt f b -> p+foldAlt f =+  unMon . runAlt (Mon . f)++hoistAlt :: forall f g b. Functor g => (forall a. f a -> g a) -> Alt f b -> Alt g b+hoistAlt nat =+  runAlt (Lift . nat)+++-- | The 'Alternative' functor induced by the 'Monoid'+newtype Mon m a = Mon+  { unMon :: m+  } deriving (Show, Eq)++instance Functor (Mon m) where+  fmap _ (Mon a) = Mon a++instance Monoid m => Applicative (Mon m) where+  pure _ = Mon mempty+  Mon x <*> Mon y = Mon (mappend x y)++instance Monoid m => Alternative (Mon m) where+  empty = Mon mempty+  Mon x <|> Mon y = Mon (mappend x y)
+ src/Env/Internal/Help.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE NamedFieldPuns #-}+module Env.Internal.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, mapMaybe)+import           Data.Ord (comparing)++import           Env.Internal.Error (Error)+import qualified Env.Internal.Error as Error+import           Env.Internal.Free+import           Env.Internal.Parser hiding (Mod)+++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 infoHandleError errors++-- | 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 e a -> [String]+helpParserDoc =+  concat . Map.elems . foldAlt (\v -> Map.singleton (varfName v) (helpVarfDoc v)) . unParser++helpVarfDoc :: VarF e a -> [String]+helpVarfDoc VarF {varfName, varfHelp, varfHelpDef} =+  case varfHelp of+    Nothing -> [indent 2 varfName]+    Just h+      | k > 15    -> indent 2 varfName : map (indent 25) (splitWords 30 t)+      | otherwise ->+          case zipWith indent (23 - k : repeat 25) (splitWords 30 t) of+            (x : xs) -> (indent 2 varfName ++ x) : xs+            []       -> [indent 2 varfName]+     where k = length varfName+           t = maybe h (\s -> h ++ " (default: " ++ s ++")") varfHelpDef++splitWords :: Int -> String -> [String]+splitWords n =+  go [] 0 . words+ where+  go acc _ [] = prep acc+  go acc k (w : ws)+    | k + z < n = go (w : acc) (k + z) ws+    | z > n     = prep acc ++ case splitAt n w of (w', w'') -> w' : go [] 0 (w'' : ws)+    | otherwise = prep acc ++ go [w] z ws+   where+    z = length w++  prep []  = []+  prep acc = [unwords (reverse acc)]++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
+ src/Env/Internal/Parser.hs view
@@ -0,0 +1,271 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}+module Env.Internal.Parser+  ( Parser(..)+  , VarF(..)+  , parsePure+  , eachUnsetVar+  , Mod(..)+  , prefixed+  , var+  , Var(..)+  , defaultVar+  , Reader+  , str+  , nonempty+  , splitOn+  , auto+  , def+  , helpDef+  , showDef+  , flag+  , switch+  , Flag+  , HasHelp+  , help+  , HasKeep+  , keep+  ) where++import           Control.Applicative+import           Control.Arrow (left)+import           Control.Monad ((<=<))+import           Data.Foldable (for_)+import           Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Set as Set+#if __GLASGOW_HASKELL__ < 710+import           Data.Monoid (Monoid(..))+#endif+import           Data.String (IsString(..))++import           Env.Internal.Free+import qualified Env.Internal.Error as Error+import           Env.Internal.Val+++-- | Try to parse a pure environment+parsePure :: Parser e a -> [(String, String)] -> Either [(String, e)] a+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 env))++eachUnsetVar :: Applicative m => Parser e a -> (String -> m b) -> m ()+eachUnsetVar Parser {unParser} =+  for_ (foldAlt (\VarF {varfKeep, varfName} -> if varfKeep then Set.empty else Set.singleton varfName) unParser)++readVar :: VarF e a -> Map String String -> Either [(String, e)] a+readVar VarF {varfName, varfReader} =+  left (pure . (\err -> (varfName, err))) . varfReader varfName+++-- | An environment parser+newtype Parser e a = Parser { unParser :: Alt (VarF e) a }+    deriving (Functor)++instance Applicative (Parser e) where+  pure =+    Parser . pure+  Parser f <*> Parser x =+    Parser (f <*> x)++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 e a -> Parser e a+prefixed pre =+  Parser . hoistAlt (\v -> v {varfName=pre ++ varfName v}) . unParser+++data VarF e a = VarF+  { varfName    :: String+  , varfReader  :: String -> Map String String -> Either e a+  , varfHelp    :: Maybe String+  , varfDef     :: Maybe a+  , varfHelpDef :: Maybe String+  , varfKeep    :: Bool+  } deriving (Functor)++liftVarF :: VarF e a -> Parser e a+liftVarF =+  Parser . liftAlt++-- | An environment variable's value parser. Use @(<=<)@ and @(>=>)@ to combine these+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 :: Error.AsUnset e => Reader e a -> String -> Mod Var a -> Parser e a+var r n (Mod f) =+  liftVarF $ VarF+    { varfName    = n+    , varfReader  = \name -> r <=< lookupVar name+    , varfHelp    = varHelp+    , varfDef     = varDef+    , varfHelpDef = varHelpDef <*> varDef+    , varfKeep    = varKeep+    }+ where+  Var {varHelp, varDef, varHelpDef, varKeep} = f defaultVar++-- | A flag that takes the active value if the environment variable+-- is set and non-empty and the default value otherwise+--+-- /Note:/ this parser never fails.+flag+  :: a -- ^ default value+  -> a -- ^ active value+  -> String -> Mod Flag a -> Parser e a+flag f t n (Mod g) =+  liftVarF $ VarF+    { varfName    = n+    , varfReader  = \name env ->+        pure $ case (nonempty :: Reader Error.Error String) =<< lookupVar name env of+          Left  _ -> f+          Right _ -> t+    , varfHelp    = flagHelp+    , varfDef     = Just f+    , varfHelpDef = Nothing+    , varfKeep    = flagKeep+    }+ where+  Flag {flagHelp, flagKeep} = g defaultFlag++-- | A simple boolean 'flag'+--+-- /Note:/ this parser never fails.+switch :: String -> Mod Flag Bool -> Parser e Bool+switch =+  flag False True++-- | The trivial reader+str :: IsString s => Reader e s+str =+  Right . fromString++-- | The reader that accepts only non-empty strings+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 :: (Error.AsUnread e, Read a) => Reader e a+auto s =+  case reads s of [(v, "")] -> Right v; _ -> Left (Error.unread (show s))++-- | The reader that splits a string into a list of strings consuming the separator.+splitOn :: Char -> Reader e [String]+splitOn sep = Right . go+ where+  go [] = []+  go xs = go' xs++  go' xs =+    case break (== sep) xs of+      (ys, []) ->+        ys : []+      (ys, _ : zs) ->+        ys : go' zs+++-- | This represents a modification of the properties of a particular 'Parser'.+-- Combine them using the 'Monoid' instance.+newtype Mod t a = Mod (t a -> t a)++instance Monoid (Mod t a) where+  mempty = Mod id+  mappend (Mod f) (Mod g) = Mod (g . f)++-- | Environment variable metadata+data Var a = Var+  { varHelp    :: Maybe String+  , varHelpDef :: Maybe (a -> String)+  , varDef     :: Maybe a+  , varKeep    :: Bool+  }++defaultVar :: Var a+defaultVar = Var+  { varHelp    = Nothing+  , varDef     = Nothing+  , varHelpDef = Nothing+  , varKeep    = defaultKeep+  }++defaultKeep :: Bool+defaultKeep = False++-- | The default value of the variable+--+-- /Note:/ specifying it means the parser won't ever fail.+def :: a -> Mod Var a+def d =+  Mod (\v -> v {varDef=Just d})++-- | Flag metadata+data Flag a = Flag+  { flagHelp   :: Maybe String+  , flagKeep   :: Bool+  }++defaultFlag :: Flag a+defaultFlag = Flag+  { flagHelp = Nothing+  , flagKeep = defaultKeep+  }++-- | Show the default value of the variable in help.+helpDef :: (a -> String) -> Mod Var a+helpDef d =+  Mod (\v -> v {varHelpDef=Just d})++-- | Use the 'Show' instance to show the default value of the variable in help.+showDef :: Show a => Mod Var a+showDef =+  helpDef show+++-- | A class of things that can have a help message attached to them+class HasHelp t where+  setHelp :: String -> t a -> t a++instance HasHelp Var where+  setHelp h v = v {varHelp=Just h}++instance HasHelp Flag where+  setHelp h v = v {flagHelp=Just h}++-- | Attach help text to the variable+help :: HasHelp t => String -> Mod t a+help =+  Mod . setHelp++-- | A class of things that can be still kept in an environment when the+-- parsing has been completed.+class HasKeep t where+  setKeep :: t a -> t a++instance HasKeep Var where+  setKeep v = v {varKeep=True}++instance HasKeep Flag where+  setKeep v = v {flagKeep=True}++-- | Keep a variable.+keep :: HasKeep t => Mod t a+keep =+  Mod setKeep
+ src/Env/Internal/Val.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+module Env.Internal.Val+  ( Val(..)+  , fromEither+  , toEither+  ) where++import Control.Applicative+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid (Monoid(..))+#endif+import Data.Monoid ((<>))+++-- | A type isomorphic to 'Either' with the accumulating 'Applicative' instance.+data Val e a+  = Err e+  | Ok  a+    deriving (Functor, Show, Eq)++instance Monoid e => Applicative (Val e) where+  pure = Ok++  Err e <*> Err e' = Err (e <> e')+  Err e <*> _      = Err e+  _     <*> Err e' = Err e'+  Ok  f <*> Ok  a  = Ok (f a)++instance Monoid e => Alternative (Val e) where+  empty = Err mempty++  Err _ <|> Ok x = Ok x+  x     <|> _    = x++fromEither :: Either e a -> Val e a+fromEither =+  either Err Ok++toEither :: Val e a -> Either e a+toEither x =+  case x of Err e -> Left e; Ok a -> Right a
− src/Env/Parse.hs 
@@ -1,203 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}-module Env.Parse-  ( Parser(..)-  , VarF(..)-  , parsePure-  , Mod(..)-  , prefixed-  , var-  , Var(..)-  , defaultVar-  , Reader-  , str-  , nonempty-  , auto-  , def-  , helpDef-  , showDef-  , flag-  , switch-  , Flag-  , HasHelp-  , help-  ) where--import           Control.Applicative-import           Control.Arrow (left)-import           Control.Monad ((<=<))-import           Data.Map (Map)-import qualified Data.Map as Map-#if __GLASGOW_HASKELL__ < 710-import           Data.Monoid (Monoid(..))-#endif-import           Data.String (IsString(..))--import           Env.Free-import qualified Env.Error as Error-import           Env.Val----- | 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 env))--readVar :: VarF e a -> Map String String -> Either [(String, e)] a-readVar VarF {varfName, varfReader} =-  left (pure . (\err -> (varfName, err))) . varfReader varfName----- | An environment parser-newtype Parser e a = Parser { unParser :: Alt (VarF e) a }-    deriving (Functor)--instance Applicative (Parser e) where-  pure = Parser . pure-  Parser f <*> Parser x = Parser (f <*> x)--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 e a -> Parser e a-prefixed pre =-  Parser . hoistAlt (\v -> v { varfName = pre ++ varfName v }) . unParser---data VarF e a = VarF-  { varfName    :: String-  , 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 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 :: Error.AsUnset e => Reader e a -> String -> Mod Var a -> Parser e a-var r n (Mod f) = Parser . liftAlt $ VarF-  { varfName    = n-  , varfReader  = \name -> r <=< lookupVar name-  , varfHelp    = varHelp-  , varfDef     = varDef-  , varfHelpDef = varHelpDef <*> varDef-  }- where-  Var { varHelp, varDef, varHelpDef } = f defaultVar---- | A flag that takes the active value if the environment variable--- is set and non-empty and the default value otherwise------ /Note:/ this parser never fails.-flag-  :: a -- ^ default value-  -> a -- ^ active value-  -> String -> Mod Flag a -> Parser e a-flag f t n (Mod g) = Parser . liftAlt $ VarF-  { varfName    = n-  , varfReader  = \name env ->-      pure $ case (nonempty :: Reader Error.Error String) =<< lookupVar name env of-        Left  _ -> f-        Right _ -> t-  , varfHelp    = flagHelp-  , varfDef     = Just f-  , varfHelpDef = Nothing-  }- where-  Flag { flagHelp } = g defaultFlag---- | A simple boolean 'flag'------ /Note:/ this parser never fails.-switch :: String -> Mod Flag Bool -> Parser e Bool-switch = flag False True---- | The trivial reader-str :: IsString s => Reader e s-str = Right . fromString---- | The reader that accepts only non-empty strings-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 :: (Error.AsUnread e, Read a) => Reader e a-auto s = case reads s of [(v, "")] -> Right v; _ -> Left (Error.unread (show s))----- | This represents a modification of the properties of a particular 'Parser'.--- Combine them using the 'Monoid' instance.-newtype Mod t a = Mod (t a -> t a)--instance Monoid (Mod t a) where-  mempty = Mod id-  mappend (Mod f) (Mod g) = Mod (g . f)---- | Environment variable metadata-data Var a = Var-  { varHelp    :: Maybe String-  , varHelpDef :: Maybe (a -> String)-  , varDef     :: Maybe a-  }--defaultVar :: Var a-defaultVar = Var-  { varHelp    = Nothing-  , varDef     = Nothing-  , varHelpDef = Nothing-  }---- | The default value of the variable------ /Note:/ specifying it means the parser won't ever fail.-def :: a -> Mod Var a-def d = Mod (\v -> v { varDef = Just d })---- | Flag metadata-data Flag a = Flag-  { flagHelp   :: Maybe String-  }--defaultFlag :: Flag a-defaultFlag = Flag { flagHelp = Nothing }---- | Show the default value of the variable in help.-helpDef :: (a -> String) -> Mod Var a-helpDef d = Mod (\v -> v { varHelpDef = Just d })---- | Use the 'Show' instance to show the default value of the variable in help.-showDef :: Show a => Mod Var a-showDef =-  helpDef show----- | A class of things that can have a help message attached to them-class HasHelp t where-  setHelp :: String -> t a -> t a--instance HasHelp Var where-  setHelp h v = v { varHelp = Just h }--instance HasHelp Flag where-  setHelp h v = v { flagHelp = Just h }---- | Attach help text to the variable-help :: HasHelp t => String -> Mod t a-help = Mod . setHelp
− src/Env/Val.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-module Env.Val-  ( Val(..)-  , fromEither-  , toEither-  ) where--import Control.Applicative-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid (Monoid(..))-#endif-import Data.Monoid ((<>))----- | A type isomorphic to 'Either' with the accumulating 'Applicative' instance.-data Val e a-  = Err e-  | Ok  a-    deriving (Functor, Show, Eq)--instance Monoid e => Applicative (Val e) where-  pure = Ok--  Err e <*> Err e' = Err (e <> e')-  Err e <*> _      = Err e-  _     <*> Err e' = Err e'-  Ok  f <*> Ok  a  = Ok (f a)--instance Monoid e => Alternative (Val e) where-  empty = Err mempty--  Err _ <|> Ok x = Ok x-  x     <|> _    = x--fromEither :: Either e a -> Val e a-fromEither = either Err Ok--toEither :: Val e a -> Either e a-toEither x = case x of Err e -> Left e; Ok a -> Right a
+ test/Env/Internal/ParserSpec.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}+module Env.Internal.ParserSpec (spec) where++import Control.Monad ((<=<))+import Data.Text (Text)+import Test.Hspec++import Env.Internal.Error (Error)+import Env.Internal.Parser+++spec :: Spec+spec = do+  describe "str" $ do+    it "works with String" $+      str "foo" `shouldBe` ok ("foo" :: String)++    it "works with Text" $+      str "foo" `shouldBe` ok ("foo" :: Text)++  describe "splitOn" $ do+    it "splits the string on a separator character" $+      splitOn ',' "1,2,3" `shouldBe` ok ["1", "2", "3"]++    it "splits the empty string into the empty list" $+      splitOn ',' "" `shouldBe` ok []++    it "creates an extra element for leading and trailing separators" $+      splitOn ',' ",2," `shouldBe` ok ["", "2", ""]++    it "is nicely composable " $+      (mapM auto <=< splitOn ',') "1,2,3" `shouldBe` ok ([1, 2, 3] :: [Int])++ok :: a -> Either Error a+ok = Right
test/EnvSpec.hs view
@@ -9,6 +9,9 @@ import           Data.Monoid (mempty) #endif import           Prelude hiding (pi)+#if __GLASGOW_HASKELL__ >= 708+import           System.Environment (lookupEnv, setEnv)+#endif import           Test.Hspec import           Text.Read (readMaybe) @@ -82,6 +85,31 @@         p (prefixed "pre" (prefixed "pro" (var str "morphism" mempty)))        `shouldBe`         Just "zygohistomorphic"++#if __GLASGOW_HASKELL__ >= 708+    it "unsets parsed variables" $ do+      setEnv "FOO" "4"+      setEnv "BAR" "7"+      parse (header "hi") (liftA2 (+) (var auto "FOO" (help "a")) (var auto "BAR" (help "b"))) `shouldReturn` (11 :: Int)+      lookupEnv "FOO" `shouldReturn` Nothing+      lookupEnv "BAR" `shouldReturn` Nothing++    context "some variables are marked as kept" $+      it "does not unset them" $ do+        setEnv "FOO" "4"+        setEnv "BAR" "7"+        parse (header "hi") (liftA2 (+) (var auto "FOO" (help "a" <> keep)) (var auto "BAR" (help "b"))) `shouldReturn` (11 :: Int)+        lookupEnv "FOO" `shouldReturn` Just "4"+        lookupEnv "BAR" `shouldReturn` Nothing++    context "parsing fails" $+      it "does not unset any variables" $ do+        setEnv "FOO" "4"+        setEnv "BAR" "bar"+        parse (header "hi") (liftA2 (+) (var auto "FOO" (help "a" <> keep)) (var auto "BAR" (help "b"))) `shouldThrow` anyException+        lookupEnv "FOO" `shouldReturn` Just "4"+        lookupEnv "BAR" `shouldReturn` Just "bar"+#endif   greaterThan5 :: AsUnread e => Reader e Int