Initial commit

LICENSE

@@ -0,0 +1,24 @@
+Copyright (c) 2016 Gabriel Gonzalez
+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 Gabriel Gonzalez 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.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

optparse-generic.cabal

@@ -0,0 +1,31 @@
+Name: optparse-generic
+Version: 1.0.0
+Cabal-Version: >=1.8.0.2
+Build-Type: Simple
+License: BSD3
+License-File: LICENSE
+Copyright: 2016 Gabriel Gonzalez
+Author: Gabriel Gonzalez
+Maintainer: Gabriel439@gmail.com
+Bug-Reports: https://github.com/Gabriel439/Haskell-Optparse-Generic-Library/issues
+Synopsis: Auto-generate a command-line parser for your datatype
+Description: This library auto-generates an @optparse-applicative@-compatible
+    @Parser@ from any data type that derives the @Generic@ interface.
+    .
+    See the documentation in "Options.Generic" for an example of how to use
+    this library
+Category: System
+Source-Repository head
+    Type: git
+    Location: https://github.com/Gabriel439/Haskell-Optparse-Generic-Library
+
+Library
+    Hs-Source-Dirs: src
+    Build-Depends:
+        base                 >= 4.6     && < 5   ,
+        system-filepath      >= 0.3.1   && < 0.5 ,
+        text                               < 1.3 ,
+        transformers         >= 0.2.0.0 && < 0.6 ,
+        optparse-applicative >= 0.11.0  && < 0.13
+    Exposed-Modules: Options.Generic
+    GHC-Options: -O2 -Wall

src/Options/Generic.hs

@@ -0,0 +1,207 @@
+{-# LANGUAGE DefaultSignatures          #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+
+-- | Example use of this library:
+--
+-- > {-# LANGUAGE DeriveGeneric     #-}
+-- > {-# LANGUAGE OverloadedStrings #-}
+-- > 
+-- > import Turtle
+-- > import Options.Generic
+-- > 
+-- > data Example = Go { foo :: Int, bar :: Double, baz :: Int }
+-- >     deriving (Generic, Show)
+-- > 
+-- > instance ParseRecord Example
+-- > 
+-- > main = do
+-- >     x <- options "Test program" parser
+-- >     print (x :: Example)
+--
+-- This produces a program with one sub-command (named @Go@)
+
+module Options.Generic (
+    -- * Parsers
+      getRecord
+    , ParseField(..)
+    , ParseRecord(..)
+
+    -- * Re-exports
+    , Generic
+    ) where
+
+import Control.Applicative
+import Control.Monad.IO.Class (MonadIO(..))
+import Data.Monoid
+import Data.String (IsString(..))
+import Data.Text (Text)
+import Data.Typeable (Typeable)
+import Data.Void (Void)
+import Filesystem.Path (FilePath)
+import GHC.Generics
+import Prelude hiding (FilePath)
+import Options.Applicative (Parser, ReadM)
+
+import qualified Data.Text
+import qualified Data.Typeable
+import qualified Filesystem.Path.CurrentOS
+import qualified Options.Applicative       as Options
+import qualified Options.Applicative.Types as Options
+import qualified Text.Read
+
+data Proxy a = Proxy
+
+auto :: Read a => ReadM a
+auto = do
+    s <- Options.readerAsk
+    case Text.Read.readMaybe s of
+        Just x  -> return x
+        Nothing -> Options.readerAbort Options.ShowHelpText
+
+{-| A class for all types that can be parsed from a single option or argument on
+    the command line
+
+    `parseField` has a default implementation for any type that implements
+    `Read` and you can derive `Read` for many types
+
+    `metavar` has a default implementation for any type that implements
+    `Typeable` and you can derive `Typeable` for any type if you enable the
+    @DeriveDataTypeable@ language extension
+-}
+class ParseField a where
+    parseField :: ReadM a
+    default parseField :: Read a => ReadM a
+    parseField = auto
+
+    metavar :: proxy a -> Text
+    default metavar :: Typeable a => proxy a -> Text
+    metavar proxy = Data.Text.pack (show (Data.Typeable.typeRep proxy))
+
+instance ParseField Integer
+
+instance ParseField Bool
+instance ParseField Char
+instance ParseField Double
+instance ParseField Float
+instance ParseField Int
+instance ParseField Ordering
+instance ParseField ()
+instance ParseField Any where
+    parseField = fmap Any parseField
+    metavar  _ = "Bool"
+instance ParseField All where
+    parseField = fmap All parseField
+    metavar  _ = "Bool"
+instance ParseField Void
+instance ParseField Text where
+    parseField = fmap Data.Text.pack Options.str
+instance ParseField FilePath where
+    parseField = fmap Filesystem.Path.CurrentOS.decodeString Options.str
+
+newtype Unnamed a = Unnamed { getUnnamed :: a }
+
+{-| A class for types that can be parsed from the command line
+
+    This class has a default implementation for any type that implements
+    `Generic` and you can derive `Generic` for many types by enabling the
+    @DeriveGeneric@ language extension
+-}
+class ParseRecord a where
+    parseRecord :: Parser a
+    default parseRecord :: (Generic a, GenericParseRecord (Rep a)) => Parser a
+    parseRecord = fmap GHC.Generics.to genericParseRecord
+
+instance ParseField a => ParseRecord (Unnamed a) where
+    parseRecord = Options.helper <*> fmap Unnamed p
+      where
+        p = Options.argument parseField
+                (Options.metavar (Data.Text.unpack (metavar p)))
+
+-- TODO: Why is there no `Generic` instance for `Integer`?
+instance ParseRecord Bool
+instance ParseRecord Char where
+    parseRecord = fmap getUnnamed parseRecord
+instance ParseRecord Double where
+    parseRecord = fmap getUnnamed parseRecord
+instance ParseRecord Float where
+    parseRecord = fmap getUnnamed parseRecord
+instance ParseRecord Int where
+    parseRecord = fmap getUnnamed parseRecord
+instance ParseRecord Ordering
+instance ParseRecord ()
+
+-- TODO: Add flag names
+class GenericParseRecord f where
+    genericParseRecord :: Parser (f p)
+
+instance GenericParseRecord U1 where
+    genericParseRecord = pure U1
+
+instance (GenericParseRecord f, GenericParseRecord g) => GenericParseRecord (f :+: g) where
+    genericParseRecord = fmap L1 genericParseRecord <|> fmap R1 genericParseRecord
+
+instance (GenericParseRecord f, GenericParseRecord g) => GenericParseRecord (f :*: g) where
+    genericParseRecord = liftA2 (:*:) genericParseRecord genericParseRecord
+
+instance GenericParseRecord V1 where
+    genericParseRecord = empty
+
+instance (Selector s, ParseField a) => GenericParseRecord (M1 S s (K1 i a)) where
+    genericParseRecord = do
+        let m :: M1 i s f a
+            m = undefined
+
+        let p :: Proxy a
+            p = Proxy
+
+        let name = selName m
+
+        let parser = case name of
+                "" ->
+                    Options.argument parseField
+                        (Options.metavar (Data.Text.unpack (metavar p)))
+                         
+                _  ->
+                    Options.option parseField
+                        (   Options.metavar (Data.Text.unpack (metavar p))
+                        <>  Options.long name
+                        )
+        fmap (M1 . K1) parser
+
+instance (Constructor c, GenericParseRecord f) => GenericParseRecord (M1 C c f) where
+    genericParseRecord = do
+        let m :: M1 i c f a
+            m = undefined
+
+        let name = conName m
+
+        let info = Options.info genericParseRecord mempty
+
+        let subparserFields =
+                   Options.command name info
+                <> Options.metavar name
+
+        fmap M1 (Options.subparser subparserFields)
+
+instance GenericParseRecord f => GenericParseRecord (M1 D c f) where
+    genericParseRecord = fmap M1 (Options.helper <*> genericParseRecord)
+
+{-| A brief description of what your program does
+
+    This description will appear in the header of the @--help@ output
+-}
+newtype Description = Description { getDescription :: Text }
+    deriving (IsString)
+
+getRecord :: (MonadIO io, ParseRecord a) => Description -> io a
+getRecord desc = liftIO (Options.execParser info)
+  where
+    header = Options.header (Data.Text.unpack (getDescription desc))
+
+    info = Options.info parseRecord header

stack.yaml

@@ -0,0 +1,3 @@
+resolver: lts-5.3
+packages:
+- .