Argument.hs

module System.Console.Argument
  (
    Type (Type,parser,name,defaultValue)
  
  , option
  
  , optional
  , string
  , boolean
  , directory
  , file
  , device
  , natural
  , integer
  ) where


import           Data.Char      (toLower)
import           Data.List.HT   (viewR)
import qualified Data.Map              as Map
import qualified System.Console.GetOpt as GetOpt
import qualified Text.Parsec.Extra     as P


data Type a
  = Type
  {
    parser       :: String -> String -> Either String a
  , name         :: String
  , defaultValue :: Maybe a
  }

instance Functor Type where
  fmap f t = t { parser = ((.) . (.)) (fmap f) (parser t), defaultValue = fmap f (defaultValue t) }

option :: (a -> s) -> [Char] -> [String] -> Type a -> String -> GetOpt.OptDescr (Either String s)
option inj short long t description = case defaultValue t of
  Nothing -> GetOpt.Option short long (GetOpt.ReqArg                         (fmap inj . parser t (name t)) (name t)) description
  Just a  -> GetOpt.Option short long (GetOpt.OptArg (maybe (Right $ inj a) $ fmap inj . parser t (name t)) (name t)) description

-- Common argument types

optional :: a -> Type a -> Type a
optional x t = t { defaultValue = Just x }

string :: Type String
string = Type (const Right) "STRING" Nothing

boolean :: Type Bool
boolean = Type
  {
    name    = "BOOL"
  , parser  = \ _ y -> maybe (e y) Right . flip Map.lookup m . map toLower $ y
  , defaultValue = Just True
  }
 where
  m = Map.fromList [("1",True),("0",False),("true",True),("false",False)]
  e y = Left $ "Argument " ++ show y ++ " could not be recognised as a boolean."

natural :: Type Integer
natural = Type { name = "INT (natural)", parser = const (P.parseM P.natural ""), defaultValue = Nothing }

integer :: Type Integer
integer = Type { name = "INT", parser = const (P.parseM P.integer ""), defaultValue = Nothing }

directory :: Type FilePath
directory = Type { name = "DIR", parser = const (Right . stripTrailingSlash), defaultValue = Nothing }
 where
  stripTrailingSlash x = case viewR x of
    Nothing       -> ""
    Just (i,l)
      | l == '/'  -> i
      | otherwise -> x

file :: Type FilePath
file = string { name = "FILE" }

device :: Type FilePath
device = string { name = "DEVICE" }