module gopt

import StdGeneric, StdOverloaded, StdClass, StdArray, StdChar, StdBool, StdList, StdMisc, StdFunc, StdTuple, StdString

import Data.List
import Data.Error
import Data.Func
import Data.Functor
import Data.Tuple
import Control.Applicative
import Control.Monad
import System.GetOpt
import System.CommandLine
//	= NoArg                   a         // ^   no argument expected
//    | ReqArg (String       -> a) String // ^   option requires argument
//    | OptArg ((Maybe String) -> a) String // ^   optional argument
//
:: Opt a
	= Positionals [ArgDescr (a -> *(MaybeError [String] a))]
	| Flag (a -> a) (a -> a)
	| Options [OptDescr (a -> *(MaybeError [String] a))]

//tr fr to (NoArg fa) = NoArg (fm to o fa o fr)

tr fr to (NoArg fa) = NoArg \a->case fa (fr a) of
	Ok a = Ok (to a)
	Error e = Error e
tr fr to (ReqArg fa t) = ReqArg (\s a->case fa s (fr a) of
	Ok a = Ok (to a)
	Error e = Error e) t
tr fr to (OptArg fa t) = OptArg (\ms a->case fa ms (fr a) of
	Ok a = Ok (to a)
	Error e = Error e) t

generic gopt a :: Opt a
gopt{|Bool|} = Flag (const True) (const False)
gopt{|Int|} = Positionals [ReqArg (\s _->if (and [isDigit c\\c<-:s]) (Ok $ toInt s) (Error ["Not an integer"])) "INT"]
gopt{|Char|} = Positionals [ReqArg (\s _->if (size s == 1) (Ok s.[0]) (Error ["Not a single character"])) "CHAR"]
gopt{|String|} = Positionals [ReqArg (\s _->Ok s) "STRING"]
gopt{|RECORD|} f = case f of
	Flag set unset = Flag (\(RECORD a)->RECORD (set a)) (\(RECORD a)->RECORD (unset a))
	Options opts = Options $ map (\(Option s l f h)->(Option s l (tr (\(RECORD a)->a) RECORD f) h)) opts
	Positionals p = Positionals (map (tr (\(RECORD a)->a) RECORD) p)
gopt{|FIELD of {gfd_name}|} f = case f of
	Flag set unset = Options
		[Option [] [gfd_name] (mapF (NoArg $ Ok o set)) ""
		,Option [] ["no-" +++ gfd_name] (mapF (NoArg $ Ok o unset)) ""
		]
	Positionals [p] = Options
		[Option [] [gfd_name] (mapF p) ""]
where
	mapF = tr (\(FIELD a)->a) FIELD
gopt{|Maybe|} (Positionals [ReqArg f d]) = Positionals
		[OptArg (\ms _ ->case ms of
			Nothing = Ok Nothing
				// Is this necessary
			Just s = case f s undef of
				Ok a = Ok (Just a)
				Error e = Error e
		) d]
gopt{|PAIR|} fx fg = case (fx, fg) of
	(Options as, Options bs) = Options $
		[Option s r (topair (\(PAIR l r)->l) (\(PAIR _ r) l->PAIR l r) f) d\\(Option s r f d)<-as]
		++ [Option s r (topair (\(PAIR l r)->r) (\(PAIR l _) r->PAIR l r) f) d\\(Option s r f d)<-bs]
topair fr to (NoArg fa) = NoArg \a->case fa (fr a) of
		Ok na = Ok (to a na)
		Error e = Error e
topair fr to (ReqArg fa d) = ReqArg (\s a->case fa s (fr a) of
		Ok na = Ok (to a na)
		Error e = Error e) d
topair fr to (OptArg fa d) = OptArg (\s a->case fa s (fr a) of
		Ok na = Ok (to a na)
		Error e = Error e) d

parseOpts :: (Opt a) [String] a -> MaybeError [String] a
parseOpts (Options opts) args i
	# (transformers, positionals, errors) = getOpt Permute [helpopt:opts] args
	| not (errors =: []) = Error [usageInfo "" [helpopt:opts]:errors]
	= case folder transformers i of
		Error e = Error [usageInfo "" [helpopt:opts]:e]
		Ok a = Ok a
parseOpts _ _ i = Ok i

helpopt = Option [] ["help"] (NoArg \a->Error []) ""

folder [] i = Ok i
folder [tr:trs] i = tr i >>= folder trs

:: T =
	{ field  :: Maybe Int
	, field2 :: String
	}
derive bimap Opt, [], (,),OptDescr, ArgDescr, MaybeError
derive gopt T

Start w
# ([argv0:args], w) = getCommandLine w
= parseOpts t args { field = Just 42, field2 = ""}

t :: Opt T
t = gopt{|*|}