getopt-generics (empty) → 0.1

raw patch · 5 files changed

+294/−0 lines, 5 filesdep +basedep +generics-sopdep +getopt-genericssetup-changed

Dependencies added: base, generics-sop, getopt-generics, hspec, safe, silently

Files

• LICENSE +30/−0
• Setup.hs +3/−0
• getopt-generics.cabal +50/−0
• src/System/Console/GetOpt/Generics.hs +210/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,30 @@+Copyright (c) 2014, Zalora South East Asia Pte Ltd++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.++    * Neither the name of Zalora South East Asia Pte Ltd nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++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.

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,50 @@+name: getopt-generics+version: 0.1+category: Console, System+synopsis: Simple command line argument parsing+description:+  "getopt-generics" tries to make it very simple to create command line+  interfaces. Users just specify a simple data type (and derive some type+  classes for that type) and "getopt-generics" creates a command line argument+  parser.+license: BSD3+license-file: LICENSE+author: Linh Nguyen, Sönke Hahn+copyright: Zalora South East Asia Pte Ltd+maintainer: linh.nguyen@zalora.com, soenke.hahn@zalora.com++cabal-version: >= 1.8+build-type: Simple++library+  hs-source-dirs:+    src+  ghc-options:+    -Wall -fno-warn-name-shadowing+  exposed-modules:+    System.Console.GetOpt.Generics+  build-depends:+      base == 4.*+    , generics-sop+    , safe++test-suite spec+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    test, examples+  ghc-options:+    -Wall -threaded -fno-warn-name-shadowing -O0 -pgmL markdown-unlit+  main-is:+    Spec.hs+  build-depends:+      base == 4.*+    , getopt-generics+    , generics-sop++    , hspec+    , silently++source-repository head+  type:     git+  location: git://github.com/zalora/getopt-generics

@@ -0,0 +1,210 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeSynonymInstances  #-}++++module System.Console.GetOpt.Generics (+  withArguments,+  Option(..),+ ) where++import           Control.Applicative+import           Data.List+import           Data.Monoid (Monoid, mempty)+import           Generics.SOP+import           Safe+import           System.Console.GetOpt+import           System.Environment+import           System.Exit+import           System.IO++withArguments :: forall a . (Generic a, HasDatatypeInfo a, All2 Option (Code a)) =>+  (a -> IO ()) -> IO ()+withArguments action = do+  args <- getArgs+  case parseArgs args of+    Right (Right a) -> action a+    Left noAction -> noAction+    Right (Left errs) -> do+      mapM_ (hPutStrLn stderr) errs+      exitWith $ ExitFailure 1++parseArgs :: forall a . (Generic a, HasDatatypeInfo a, All2 Option (Code a)) =>+  [String] -> Either (IO ()) (Either [String] a)+parseArgs args = case datatypeInfo (Proxy :: Proxy a) of+    ADT typeName _ (constructorInfo :* Nil) ->+      case constructorInfo of+        (Record _ fields) -> processFields args fields+        Constructor{} ->+          err typeName "constructors without field labels"+        Infix{} ->+          err typeName "infix constructors"+    ADT typeName _ Nil ->+      err typeName "empty data types"+    ADT typeName _ (_ :* _ :* _) ->+      err typeName "sum-types"+    Newtype _ _ (Record _ fields) ->+      processFields args fields+    Newtype typeName _ (Constructor _) ->+      err typeName "constructors without field labels"+  where+    err typeName message =+      Right $ Left ["getopt-generics doesn't support " ++ message ++ " (" ++ typeName ++ ")."]++processFields :: forall a xs . (Generic a, Code a ~ '[xs], SingI xs, All Option xs) =>+  [String] -> NP FieldInfo xs -> Either (IO ()) (Either [String] a)+processFields args fields =+  helpWrapper args fields $+  fmap (to . SOP . Z) $+  case getOpt Permute (mkOptDescrs fields) args of+    (options, arguments, parseErrors) ->+      let result :: Either [String] (NP I xs) =+            collectErrors $ project options (mkEmptyArguments fields)+          allErrors =+            parseErrors +++            map mkUnknownArgumentError arguments +++            ignoreRight result+      in case allErrors of+        [] -> result+        _ -> Left allErrors+  where+    mkUnknownArgumentError :: String -> String+    mkUnknownArgumentError arg = "unknown argument: " ++ arg++    ignoreRight :: Monoid e => Either e o -> e+    ignoreRight = either id (const mempty)++mkOptDescrs :: forall xs . All Option xs =>+  NP FieldInfo xs -> [OptDescr (NS FieldState xs)]+mkOptDescrs fields =+  map toOptDescr $ sumList $ npMap mkOptDescr fields++newtype OptDescrE a = OptDescrE (OptDescr (FieldState a))++mkOptDescr :: forall a . Option a => FieldInfo a -> OptDescrE a+mkOptDescr (FieldInfo name) = OptDescrE $ Option [] [name] toOption ""++toOptDescr :: NS OptDescrE xs -> OptDescr (NS FieldState xs)+toOptDescr (Z (OptDescrE a)) = fmap Z a+toOptDescr (S a) = fmap S (toOptDescr a)++mkEmptyArguments :: forall xs . (SingI xs, All Option xs) =>+  NP FieldInfo xs -> NP FieldState xs+mkEmptyArguments fields = case (sing :: Sing xs, fields) of+  (SNil, Nil) -> Nil+  (SCons, FieldInfo name :* r) ->+    emptyOption name :* mkEmptyArguments r+  _ -> uninhabited "mkEmpty"+++-- * showing help?++helpWrapper :: (All Option xs) =>+  [String] -> NP FieldInfo xs -> a -> Either (IO ()) a+helpWrapper args fields a =+    case getOpt Permute [helpOption] args of+      ([], _, _) -> Right a+      (() : _, _, _) -> Left $ do+        progName <- getProgName+        let header = progName+        putStrLn (usageInfo header (mkOptDescrs fields))+  where+    helpOption = Option ['h'] ["help"] (NoArg ()) "show help and exit"+++-- * helper functions for NS and NP++collectErrors :: NP FieldState xs -> Either [String] (NP I xs)+collectErrors np = case np of+  Nil -> Right Nil+  (a :* r) -> case (a, collectErrors r) of+    (Success a, Right r) -> Right (I a :* r)+    (ParseErrors errs, r) -> Left (errs ++ either id (const []) r)+    (Unset err, r) -> Left (err : either id (const []) r)+    (Success _, Left errs) -> Left errs++npMap :: (All Option xs) => (forall a . Option a => f a -> g a) -> NP f xs -> NP g xs+npMap _ Nil = Nil+npMap f (a :* r) = f a :* npMap f r++sumList :: NP f xs -> [NS f xs]+sumList Nil = []+sumList (a :* r) = Z a : map S (sumList r)++project :: (SingI xs, All Option xs) =>+  [NS FieldState xs] -> NP FieldState xs -> NP FieldState xs+project sums empty =+    foldl' inner empty sums+  where+    inner :: (All Option xs) =>+      NP FieldState xs -> NS FieldState xs -> NP FieldState xs+    inner (a :* r) (Z b) = combine a b :* r+    inner (a :* r) (S rSum) = a :* inner r rSum+    inner Nil _ = uninhabited "project"++impossible :: String -> a+impossible name = error ("System.Console.GetOpt.Generics." ++ name ++ ": This should never happen!")++uninhabited :: String -> a+uninhabited = impossible++-- * possible field types++data FieldState a+  = Unset String+  | ParseErrors [String]+  | Success a+  deriving (Functor)++class Option a where+  toOption :: ArgDescr (FieldState a)+  emptyOption :: String -> FieldState a+  accumulate :: a -> a -> a+  accumulate _ x = x++combine :: Option a => FieldState a -> FieldState a -> FieldState a+combine _ (Unset _) = impossible "combine"+combine (ParseErrors e) (ParseErrors f) = ParseErrors (e ++ f)+combine (ParseErrors e) _ = ParseErrors e+combine (Unset _) x = x+combine (Success _) (ParseErrors e) = ParseErrors e+combine (Success a) (Success b) = Success (accumulate a b)++instance Option Bool where+  toOption = NoArg (Success True)+  emptyOption _ = Success False++instance Option String where+  toOption = ReqArg Success "string"+  emptyOption flagName = Unset+    ("missing option: --" ++ flagName ++ "=string")++instance Option (Maybe String) where+  toOption = ReqArg (Success . Just) "string (optional)"+  emptyOption _ = Success Nothing++instance Option [String] where+  toOption = ReqArg (Success . pure) "strings (multiple possible)"+  emptyOption _ = Success []+  accumulate = (++)++parseInt :: String -> FieldState Int+parseInt s = maybe (ParseErrors ["not an integer: " ++ s]) Success $ readMay s++instance Option Int where+  toOption = ReqArg parseInt "integer"+  emptyOption flagName = Unset+    ("missing option: --" ++ flagName ++ "=int")++instance Option (Maybe Int) where+  toOption = ReqArg (fmap Just . parseInt) "integer (optional)"+  emptyOption _ = Success Nothing

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}