Initial

CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for optparse-invertible
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

Example.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import           Data.Functor.Compose (getCompose)
+import           Data.Maybe
+import           Data.Text            (Text, pack)
+import           Options.Invertible
+
+data Example = Example
+    { optFoo :: Int
+    , optBar :: Bool
+    , optBaz :: Maybe Bool
+    , optXyz :: String
+    , optLst :: [Int]
+    , optDef :: String
+    } deriving Show
+
+
+exampleParser :: Parser' Example Example
+exampleParser = Example
+    <$> (  option "foo" (pure . shown . optFoo) auto (help "The foo")
+       <|> option "lol" (pure . shown . optFoo) auto (help "The LOL")
+        )
+    <*> flag "bar" False True (help "Das Bar")
+    <*> (optional $
+            option "baz"
+                   (maybeToList . fmap shown . optBaz)
+                   auto
+                   (help "Bazzz"))
+    <*> argument (pure . pack . optXyz) str (metavar "FILE")
+    <*> (many $ option "lst" (map shown . optLst) auto (help "some ints"))
+    <*> option "def" (pure . pack . optDef) str (value "default value")
+  where
+    shown :: Show a => a -> Text
+    shown = pack . show
+
+main :: IO ()
+main = do
+    (unparsed, ex) <- execParser pinfo
+    print (ex :: Example)
+    print $ fromInverse unparsed ex
+    print $ fromInverse unparsed ex { optFoo = 666 }
+  where
+    pinfo = info (getCompose exampleParser) briefDesc

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2019, Kim Altintop
+
+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 Kim Altintop 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.

cabal.project

@@ -0,0 +1 @@
+packages: optparse-invertible.cabal

optparse-invertible.cabal

@@ -0,0 +1,57 @@
+cabal-version:       2.4
+name:                optparse-invertible
+version:             0.1.0.0
+synopsis:            Invertible syntax for optparse-applicative
+homepage:            https://github.com/kim/optparse-invertible
+bug-reports:         https://github.com/kim/optparse-invertible/issues
+license:             BSD-3-Clause
+license-file:        LICENSE
+author:              Kim Altintop
+maintainer:          kim.altintop@gmail.com
+copyright:           (c) 2019 Kim Altintop
+-- category:
+
+extra-source-files:
+    README.md
+    CHANGELOG.md
+
+library
+    exposed-modules:
+        Data.Option
+        Options.Invertible
+
+    build-depends:
+        base
+      , containers
+      , formatting
+      , mtl
+      , optparse-applicative
+      , product-profunctors
+      , profunctors
+      , text
+
+    ghc-options:
+        -Wall
+        -Wcompat
+        -Wincomplete-uni-patterns
+        -Wincomplete-record-updates
+        -Wredundant-constraints
+        -fno-print-expanded-synonyms
+        -funbox-small-strict-fields
+
+    default-extensions:
+        BangPatterns
+        DeriveFunctor
+        DeriveGeneric
+        LambdaCase
+        MultiWayIf
+        NamedFieldPuns
+        RecordWildCards
+        StandaloneDeriving
+        StrictData
+        TupleSections
+        TypeApplications
+        ViewPatterns
+
+    hs-source-dirs:      src
+    default-language:    Haskell2010

src/Data/Option.hs

@@ -0,0 +1,220 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE TypeFamilies          #-}
+
+module Data.Option
+    ( Cmd     (..)
+    , Opt     (..)
+    , SomeOpt (..)
+    , Var
+    , Sh      (..)
+    , Op      (..)
+
+    , Eval
+    , EvalError
+    , runEval
+
+    , evalCmd
+    , evalOpt
+    , evalSomeOpt
+    , evalSh
+    , evalShInt
+    , evalArith
+    )
+where
+
+import           Control.Monad.Except
+import           Control.Monad.Reader
+import           Data.List                  (intersperse)
+import           Data.Proxy                 (Proxy (..))
+import           Data.String                (IsString (..))
+import           Data.Text                  (Text)
+import qualified Data.Text                  as Text
+import qualified Data.Text.Lazy.Builder     as Build
+import qualified Data.Text.Lazy.Builder.Int as Build
+import qualified Data.Text.Read             as Read
+import           Data.Typeable              (TypeRep, Typeable, typeOf, typeRep)
+import           Formatting.Buildable       (Buildable (..))
+
+
+data Cmd a = Cmd FilePath [Opt a]
+    deriving (Eq, Ord, Show, Read, Functor)
+
+instance Buildable a => Buildable (Cmd a) where
+    build (Cmd exe opts) =
+        mconcat . intersperse " " $ Build.fromString exe : map build opts
+
+
+data Opt a where
+    Flag :: Text      -> Opt a
+    Arg  :: Text      -> Opt a
+    Opt  :: Text -> a -> Opt a
+
+deriving instance Eq   a => Eq   (Opt a)
+deriving instance Ord  a => Ord  (Opt a)
+deriving instance Show a => Show (Opt a)
+deriving instance Read a => Read (Opt a)
+
+deriving instance Functor Opt
+
+instance Buildable a => Buildable (Opt a) where
+    build = \case
+        Flag f   -> "--" <> Build.fromText f
+        Opt  n v -> "--" <> Build.fromText n <> "=" <> build v
+        Arg  a   -> Build.fromText a
+
+
+data SomeOpt where
+    ShOpt  :: Opt (Sh a) -> SomeOpt
+    LitOpt :: Opt Text   -> SomeOpt
+
+
+newtype Var = Var Text
+    deriving (Eq, Ord, Show, Read)
+
+instance IsString Var where
+    fromString = Var . fromString
+
+instance Buildable Var where
+    build (Var x) = Build.fromText x
+
+
+data Sh a where
+    ShNum  :: Int  -> Sh Int
+    ShStr  :: Text -> Sh Text
+    ShVar  :: Var  -> Sh Var
+    ShEval :: Sh a -> Sh (Sh a)
+
+    ShCmd  :: Typeable a => Cmd a -> Sh (Cmd a)
+
+    ShArith
+        :: ( Show      a
+           , Show      b
+           , Buildable a
+           , Buildable b
+           )
+        => Op
+        -> Sh a
+        -> Sh b
+        -> Sh Int
+
+deriving instance Show a => Show (Sh a)
+
+instance Buildable a => Buildable (Sh a) where
+    build = \case
+        ShNum   x      -> Build.decimal x
+        ShStr   x      -> Build.fromText x
+        ShVar   x      -> "${" <> build x <> "}"
+        ShCmd   cmd    -> build cmd
+        ShEval  sh     -> "$(" <> build sh <> ")"
+        ShArith op a b -> "$((" <> build a <> build op <> build b <> "))"
+
+
+data Op = Add | Sub | Mul | Div
+    deriving (Eq, Ord, Enum, Show, Read)
+
+instance IsString Op where
+    fromString = \case
+        "+" -> Add
+        "-" -> Sub
+        "*" -> Mul
+        "/" -> Div
+        x   -> error $ "Unkown arithmetic operator: " <> x
+
+instance Buildable Op where
+    build = \case
+        Add -> "+"
+        Sub -> "-"
+        Mul -> "*"
+        Div -> "/"
+
+
+data EvalEnv = EvalEnv
+    { eeVars :: Var -> Maybe Text
+    , eeCmds :: forall a. Cmd a -> Maybe Text
+    }
+
+data EvalError
+    = UnsetVariable  Var
+    | UnknownCommand TypeRep
+    | CastError      TypeRep TypeRep
+    deriving Show
+
+type Eval a = ExceptT EvalError (Reader EvalEnv) a
+
+runEval
+    :: (Var -> Maybe Text)
+    -> (forall x. Cmd x -> Maybe Text)
+    -> Eval a
+    -> Either EvalError a
+runEval vs cs = flip runReader (EvalEnv vs cs) . runExceptT
+
+evalCmd :: Cmd (Sh a) -> Eval (Cmd Text)
+evalCmd (Cmd exe opts) = Cmd exe <$> traverse evalOpt opts
+
+evalOpt :: Opt (Sh a) -> Eval (Opt Text)
+evalOpt = \case
+    Flag x   -> pure $ Flag x
+    Arg  x   -> pure $ Arg  x
+    Opt  k v -> evalSh v >>= \case
+        ShStr x -> pure $ Opt k x
+
+evalSomeOpt :: SomeOpt -> Eval (Opt Text)
+evalSomeOpt = \case
+    ShOpt  x -> evalOpt x
+    LitOpt x -> pure x
+
+evalSh :: Sh a -> Eval (Sh Text)
+evalSh = \case
+    ShVar   x      -> ShStr <$> lookupVar x
+    ShCmd   x      -> ShStr <$> runCmd    x
+    ShEval  x      -> evalSh x
+    ShArith op a b ->
+        evalSh . ShNum =<<
+            evalArith op <$> evalShInt a <*> evalShInt b
+    ShNum   x      -> pure . ShStr $ Text.pack (show x)
+    ShStr   x      -> pure $ ShStr x
+  where
+    lookupVar :: Var -> Eval Text
+    lookupVar x = do
+        vars <- asks eeVars
+        note (UnsetVariable x) $ vars x
+
+    runCmd :: Typeable x => Cmd x -> Eval Text
+    runCmd x = do
+        cmds <- asks eeCmds
+        note (UnknownCommand (typeOf x)) $ cmds x
+
+evalShInt :: Sh a -> Eval Int
+evalShInt sh = evalSh sh >>= cast >>= int
+  where
+    int :: Sh Int -> Eval Int
+    int = \case
+        ShNum   x      -> pure x
+        ShArith op a b -> evalArith op <$> evalShInt a <*> evalShInt b
+
+    cast :: Sh Text -> Eval (Sh Int)
+    cast (ShStr x) =
+        case Read.signed Read.decimal x of
+            Right (i, "") -> pure $ ShNum i
+            _             -> throwError $ CastError tyFrom tyTo
+      where
+        tyFrom = typeRep (Proxy @(Sh Text))
+        tyTo   = typeRep (Proxy @Int)
+
+evalArith :: Op -> Int -> Int -> Int
+evalArith Add = (+)
+evalArith Sub = (-)
+evalArith Mul = (*)
+evalArith Div = div
+
+--------------------------------------------------------------------------------
+
+note :: MonadError e m => e -> Maybe a -> m a
+note _ (Just a) = pure a
+note e Nothing  = throwError e