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.CommandLine

:: Opt a
	= BinaryFlag (a -> a) (a -> a)
	| Flags [(String, Flag a)]
	| Positionals [String a -> (MaybeError [String] a)]
	| SubParsers [(String, Opt a)]

:: Flag a
	= Flag (a -> a)
	| Arg (String a -> (MaybeError [String] a))

class bifmap m :: (a -> b) (b -> a) (m b) -> m a
instance bifmap Opt
where
	bifmap fr to (BinaryFlag set unset) = BinaryFlag (to o set o fr) (to o unset o fr)
	//bifmap fr to (Flags fs) = Flags $ map (bifmap fr to) fs
	bifmap fr to (Positionals fs) = Positionals $ map (fmap $ \f->fm to o f o fr) fs
	bifmap fr to (SubParsers sp) = SubParsers $ map (appSnd (bifmap fr to)) sp
instance bifmap Flag
where
	bifmap fr to (Flag f) = Flag (to o f o fr)
	bifmap fr to (Arg f) = Arg (\s->fm to o f s o fr)

fm f (Ok a) = Ok (f a)
fm f (Error e) = Error e

generic gopt a :: Opt a
gopt{|Bool|} = BinaryFlag (const True) (const False)
gopt{|Int|} = Positionals [\s _->if (and [isDigit c\\c<-:s]) (Ok $ toInt s) (Error ["Not an integer"])]
gopt{|Char|} = Positionals [\s _->if (size s == 1) (Ok s.[0]) (Error ["Not a single character"])]
gopt{|String|} = Positionals [\s _->Ok s]
gopt{|RECORD|} f = bifmap (\(RECORD a)->a) RECORD f
gopt{|OBJECT|} f = bifmap (\(OBJECT a)->a) OBJECT f
gopt{|FIELD of {gfd_name}|} f = case f of
	BinaryFlag set unset = Flags [(gfd_name, mapF (Flag set)), ("no-" +++ gfd_name, mapF (Flag unset))]
	Positionals [p] = Flags [(gfd_name, mapF (Arg p))]
	x = mapF f
where
	mapF :: ((m a) -> m (FIELD a)) | bifmap m
	mapF = bifmap (\(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 (Positionals [p:ps]) [] a = Error [toString (length [p:ps]) +++ " positional arguments required"]
parseOpts (Positionals [p:ps]) [arg:args] a = p arg a >>= parseOpts (Positionals ps) args
//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  :: Bool
//	, field2 :: String
	}
//:: T2 = T Int Int
derive bimap Opt, [], (,), MaybeError, Flag
derive gopt T

Start w
# ([argv0:args], w) = getCommandLine w
= t

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