packages feed

envparse (empty) → 0.1.0

raw patch · 11 files changed

+628/−0 lines, 11 filesdep +basedep +containersdep +hspecsetup-changed

Dependencies added: base, containers, hspec

Files

+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2014, Matvey Aksenov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.markdown view
@@ -0,0 +1,10 @@+envparse+========+[![Hackage](https://budueba.com/hackage/envparse)](https://hackage.haskell.org/package/envparse)+[![Build Status](https://secure.travis-ci.org/supki/envparse.png?branch=master)](https://travis-ci.org/supki/envparse)++[optparse-applicative][0], but for environment variables++See `example/Main.hs` for an executable example++  [0]: https://hackage.haskell.org/package/optparse-applicative
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ envparse.cabal view
@@ -0,0 +1,74 @@+name:                envparse+version:             0.1.0+synopsis:            Parse environment variables+description:+  Here's a simple example+  .+  @+  module Main (main) where+  .+  import Control.Monad (unless)+  import Env+  .+  data Hello = Hello &#x7b; name :: String, quiet :: Bool &#x7d;+  .+  hello :: IO Hello+  hello = Env.parse (header \"envparse example\") $+  &#x20; Hello \<$\> var (str <=< nonempty) \"NAME\"  (help \"Target for the greeting\")+  &#x20;       \<*\> switch                 \"QUIET\" (help \"Whether to actually print the greeting\")+  &#x20;+  main :: IO ()+  main = do+  &#x20; Hello &#x7b; name, quiet &#x7d; <- hello+  &#x20; unless quiet $+  &#x20;   putStrLn (\"Hello, \" ++ name ++ \"!\")+  @+homepage:            http://example.com/+license:             BSD2+license-file:        LICENSE+author:              Matvey Aksenov+maintainer:          matvey.aksenov@gmail.com+copyright:           2014 Matvey Aksenov+category:            System+build-type:          Simple+cabal-version:       >= 1.10+extra-source-files:+  README.markdown+  example/Main.hs++source-repository head+  type:     git+  location: https://github.com/supki/envparse++library+  default-language:+    Haskell2010+  build-depends:+      base       >= 4.6 && < 5+    , containers+  hs-source-dirs:+    src+  exposed-modules:+    Env+  other-modules:+    Env.Free+    Env.Help+    Env.Parse+    Env.Val+  ghc-options:+    -Wall++test-suite spec+  default-language:+    Haskell2010+  type:+    exitcode-stdio-1.0+  build-depends:+      base       >= 4.6 && < 5+    , containers+    , hspec+  hs-source-dirs:+    src+    test+  main-is:+    Spec.hs
+ example/Main.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE NamedFieldPuns #-}+-- | Greetings for $NAME+--+-- @+-- % NAME=a5579150 runhaskell -isrc example/Main.hs+-- Hello, a5579150!+-- % NAME=a5579150 QUIET=1 runhaskell -isrc example/Main.hs+-- %+-- @+module Main (main) where++import Control.Monad (unless)+import Env+++data Hello = Hello { name :: String, quiet :: Bool }+++main :: IO ()+main = do+  Hello { name, quiet } <- hello+  unless quiet $+    putStrLn ("Hello, " ++ name ++ "!")++hello :: IO Hello+hello = Env.parse (header "envparse example") $+  Hello <$> var (str <=< nonempty) "NAME" (help "Target for the greeting")+        <*> switch "QUIET" (help "Whether to actually print the greeting")
+ src/Env.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE Safe #-}+-- | Here's a simple example+--+-- @+-- module Main (main) where+--+-- import Control.Monad (unless)+-- import Env+--+-- data Hello = Hello { name :: String, quiet :: Bool }+--+-- hello :: IO Hello+-- hello = 'Env.parse' ('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+--   unless quiet $+--     putStrLn (\"Hello, \" ++ name ++ \"!\")+-- @+module Env+  ( parse+  , Parser+  , Mod+  , Info+  , header+  , desc+  , footer+  , var+  , Var+  , Reader+  , str+  , nonempty+  , auto+  , def+  , helpDef+  , flag+  , switch+  , Flag+  , HasHelp+  , help+  -- * Re-exports+  -- $re-exports+  , pure, (<$>), (<*>), (*>), (<*), optional+  , empty, (<|>)+  , (<=<), (>=>)+  , (<>), mempty, mconcat+  , asum+  -- * Testing+  -- $testing+  , parseTest+  ) where++import           Control.Applicative+import           Control.Monad ((>=>), (<=<))+import           Data.Foldable (asum)+import           Data.Monoid (Monoid(..), (<>))+import           System.Environment (getEnvironment)+import           System.Exit (exitFailure)+import qualified System.IO as IO++import           Env.Help (helpDoc)+import           Env.Parse++-- $re-exports+-- External functions that may be useful to the consumer of the library++-- $testing+-- Utilities to test—without dabbling in IO—that your parsers do+-- what you want them to do+++-- | Parse the environment+--+-- Prints the help text and exits with @EXIT_FAILURE@ if it encounters a parse error+--+-- @+-- >>> parse ('header' \"env-parse 0.1.0\") ('var' 'str' \"USER\" ('def' \"nobody\"))+-- @+parse :: Mod Info a -> Parser a -> IO a+parse i p = either (die . helpDoc i p) return . static p =<< getEnvironment++die :: String -> IO a+die m = do IO.hPutStrLn IO.stderr m; exitFailure++-- | Parse a static environment+parseTest :: Parser a -> [(String, String)] -> Maybe a+parseTest p = hush . static p++hush :: Either a b -> Maybe b+hush = either (const Nothing) Just
+ src/Env/Free.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- @Alt F@ is the free 'Alternative' functor on @F@+module Env.Free+  ( Alt(..)+  , liftAlt+  , runAlt+  , foldAlt+  ) where++import Control.Applicative (Applicative(..), Alternative(..))+import Data.Monoid (Monoid(..))+++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+  Fun  :: f a -> Alt f a++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 (Fun a)   = Fun (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 = Fun++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 (Fun x)   = u x++foldAlt :: Monoid p => (forall a. f a -> p) -> Alt f b -> p+foldAlt f = unMon . runAlt (Mon . f)+++-- | 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/Help.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE NamedFieldPuns #-}+module Env.Help+  ( helpDoc+  ) where++import           Data.List (intercalate)+import qualified Data.Map as Map+import           Data.Maybe (catMaybes)+import           Data.Monoid ((<>))++import           Env.Free+import           Env.Parse+++helpDoc :: Mod Info a -> Parser a -> [Error] -> String+helpDoc (Mod f) p fs = intercalate "\n\n" . catMaybes $+  [ infoHeader+  , fmap (intercalate "\n" . splitWords 50) infoDesc+  , Just "Available environment variables:"+  , Just (intercalate "\n" (helpParserDoc p))+  , fmap (intercalate "\n" . splitWords 50) infoFooter+  ] ++ map Just (helpFailuresDoc fs)+ where+  Info { infoHeader, infoDesc, infoFooter } = f defaultInfo++helpParserDoc :: Parser a -> [String]+helpParserDoc = concat . Map.elems . foldAlt (\v -> Map.singleton (varfName v) (helpVarfDoc v)) . unParser++helpVarfDoc :: VarF 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++helpFailuresDoc :: [Error] -> [String]+helpFailuresDoc [] = []+helpFailuresDoc fs = ["Parsing errors:", intercalate "\n" (map helpFailureDoc fs)]++helpFailureDoc :: Error -> String+helpFailureDoc (ParseError n e)  = "  " ++ n ++ " cannot be parsed: " ++ e+helpFailureDoc (ENoExistError n) = "  " ++ n ++ " is missing"++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
+ src/Env/Parse.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE NamedFieldPuns #-}+module Env.Parse+  ( Parser(..)+  , VarF(..)+  , static+  , Error(..)+  , Mod(..)+  , Info(..)+  , defaultInfo+  , header+  , desc+  , footer+  , var+  , Var(..)+  , defaultVar+  , Reader+  , str+  , nonempty+  , auto+  , def+  , helpDef+  , flag+  , switch+  , Flag+  , HasHelp+  , help+  ) where++import           Control.Applicative+import           Data.Map (Map)+import qualified Data.Map as Map+import           Data.Monoid (Monoid(..))+import           Data.String (IsString(..))++import           Env.Free+import           Env.Val+++static :: Parser a -> [(String, String)] -> Either [Error] a+static (Parser p) xs = toEither (runAlt go p)+ where+  go v = maybe id (\d x -> x <|> pure d) (varfDef v) (fromEither (readVar v =<< lookupVar v ys))++  ys = Map.fromList xs++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++note :: a -> Maybe b -> Either a b+note a = maybe (Left a) Right++mapLeft :: (a -> b) -> Either a t -> Either b t+mapLeft f = either (Left . f) Right+++-- | An environment parser+newtype Parser a = Parser { unParser :: Alt VarF a }+    deriving (Functor)++instance Applicative Parser where+  pure = Parser . pure+  Parser f <*> Parser x = Parser (f <*> x)++instance Alternative Parser where+  empty = Parser empty+  Parser f <|> Parser x = Parser (f <|> x)+++data Error+  = ParseError String String+  | ENoExistError String+    deriving (Show, Eq)++data VarF a = VarF+  { varfName    :: String+  , varfReader  :: Reader 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++-- | Parse a particular variable from the environment+--+-- @+-- >>> var 'str' \"EDITOR\" ('def' \"vim\" <> 'helpDef' show)+-- @+var :: Reader a -> String -> Mod Var a -> Parser a+var r n (Mod f) = Parser . liftAlt $ VarF+  { varfName    = n+  , varfReader  = r+  , 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 a+flag f t n (Mod g) = Parser . liftAlt $ VarF+  { varfName    = n+  , varfReader  = Right . either (const f) (const t) . (nonempty :: Reader String)+  , varfHelp    = flagHelp+  , varfDef     = Just f+  , varfHelpDef = Nothing+  }+ where+  Flag { flagHelp } = g defaultFlag++-- | A simple boolean 'flag'+--+-- /Note:/ the same caveats apply.+switch :: String -> Mod Flag Bool -> Parser Bool+switch = flag False True++-- | The trivial reader+str :: IsString s => Reader 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++-- | 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")+{-# ANN auto "HLint: ignore Redundant lambda" #-}+++-- | 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)+++-- | 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+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 the help text+helpDef :: (a -> String) -> Mod Var a+helpDef d = Mod (\v -> v { varHelpDef = Just d })+++-- | 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 view
@@ -0,0 +1,36 @@+{-# LANGUAGE DeriveFunctor #-}+module Env.Val+  ( Val(..)+  , fromEither+  , toEither+  ) where++import Control.Applicative+import Data.Monoid (Monoid(..), (<>))+++-- | An isomorphic to 'Either' type 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/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}