GetOpt.hs

{-# LANGUAGE MultiParamTypeClasses
  , FunctionalDependencies
  , TypeSynonymInstances
  , FlexibleInstances
  , Arrows
  #-}
module Util.Args.GetOpt ( GetOpt(..)
                        , Switch(..)
                        , DynOpt(..)
                        , StaticOpt(..)
                        ) where

import Util.Args.ArgArrow (ArgArrow, askArgs, addKnownArg)
import Util.Args.ArgDescr (DefaultValue(..), ArgDescr(..))
import Util.Args.RawArgs (Args(..))
import Data.Maybe (fromMaybe)
import Control.Arrow (returnA)

-- getOpt method takes a cli option description and returns at runtime value for that option.
-- it also statically records information about such option (and uses it to generate usage)
class GetOpt a b | a -> b where
    getOpt :: a -> ArgArrow () b

-- description of a cli switch, getOpt-ing it will return True if it's present
-- in cli args and False otherwise
data Switch =
    Switch { switchName  :: String     -- switch long name (e.g. 'verbose' for '--verbose')
           , switchHelp  :: String     -- human readable switch description (used for usage msg)
           , switchShort :: Maybe Char -- optional short version of this switch
                                      -- (e.g. 'v' for '-v')
           }

instance GetOpt Switch Bool where
    getOpt descr = proc () -> do
      addKnownArg [SwitchDescr (switchName descr)
                               (switchHelp descr)
                               (switchShort descr)] -< ()
      args <- askArgs -< ()
      let longSwitchStatus = switchName descr `elem` switches args
          switchStatus = case switchShort descr of
                           Nothing -> longSwitchStatus
                           Just c  -> longSwitchStatus || c `elem` shortSwitches args
      returnA -< switchStatus

-- description of a key,value cli argument, that if not present,
-- defaults to a value returned by some dynamic process
-- getOpt-ing it will return Just its value if it's present in cli args,
-- otherwise Nothing
data DynOpt =
    DynOpt { dynOptName        :: String -- key name (e.g. 'foo' for '--foo=bar')
           , dynOptTemplate    :: String -- help template for value
                                        -- (e.g. 'PATH' for --binary=PATH)
           , dynOptDescription :: String -- human readable description of a process
                                        -- that will provide default value
                                        -- (e.g. 'current directory')
           , dynOptHelp        :: String -- human readable switch description
                                        -- (used for usage msg)
           }

instance GetOpt DynOpt (Maybe String) where
    getOpt descr = proc () -> do
      addKnownArg [ValArg (dynOptName descr)
                          (dynOptTemplate descr)
                          (DynValue $ dynOptDescription descr)
                          (dynOptHelp descr)] -< ()
      args <- askArgs -< ()
      returnA -< lookup (dynOptName descr) $ valArgs args

-- description of a key,value cli argument, that if not present,
-- defaults to an explicit value
-- getOpt-ing it will return String with its value if it's present in cli args,
-- otherwise default value is returned
data StaticOpt =
    StaticOpt { staticOptName     :: String -- key name (e.g. 'foo' for '--foo=bar')
              , staticOptTemplate :: String -- help template for value
                                           -- (e.g. 'PATH' for --binary=PATH)
              , staticOptDefault  :: String -- default value for this argument
              , staticOptHelp     :: String -- human readable switch description
                                           -- (used for usage msg)
              }

instance GetOpt StaticOpt String where
    getOpt descr = proc () -> do
      addKnownArg [ValArg (staticOptName descr)
                          (staticOptTemplate descr)
                          (DynValue $ staticOptDefault descr)
                          (staticOptHelp descr)] -< ()
      args <- askArgs -< ()
      returnA -< fromMaybe (staticOptDefault descr)
                          $ lookup (staticOptName descr)
                          $ valArgs args