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 Data.Maybe
import Control.Applicative
import Control.Monad => qualified join
import System.CommandLine
import Text

:: Opt a
	= BinaryFlag (a -> a) (a -> a)
	| Flags [(String, ([String] a -> (MaybeError [String] (a, [String]))))]
	| Positionals [String a -> (MaybeError [String] a)]
	| SubParsers [(String, Opt 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 (appSnd $ (\f s->fm (appFst to) o f s o fr)) 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

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

combine sel app p s t = p s (sel t) >>= \l->pure (app (const l) t)
combine` sel app p s t = p s (sel t) >>= \(l, as)->pure ((app (const l) t), as)

ar0 s f as = Ok o flip tuple as o f

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
	//Child is a boolean
	BinaryFlag set unset = mapF $ Flags [(gfd_name, ar0 gfd_name set), ("no-" +++ gfd_name, ar0 ("no-" +++ gfd_name) unset)]
	//Child is a basic value or a tuple
	Positionals ps = mapF $ Flags [(gfd_name, ptoarg ps)]
	//Child is another record, make the arguments ddstyle TODO
	Flags x = mapF (Flags x)
	//Child is a subparser
	x = abort "Subparsers not supported"
where
	mapF :: ((m a) -> m (FIELD a)) | bifmap m
	mapF = bifmap (\(FIELD a)->a) FIELD

	ptoarg [p] [] i = Error ["Not enough arguments for " +++ gfd_name]
	ptoarg [p:ps] [a:as] i = p a i >>= ptoarg ps as
	ptoarg [] as i = Ok (i, as)
gopt{|PAIR|} l r = case (l, r) of
	(Positionals pl, Positionals pr)
		= Positionals
			$  map (combine PFst appPFst) pl
			++ map (combine PSnd appPSnd) pr
	(Flags fl, Flags fr)
		= Flags
			$  map (appSnd $ combine` PFst appPFst) fl
			++ map (appSnd $ combine` PSnd appPSnd) fr
where
	appPFst f (PAIR x y) = PAIR (f x) y
	appPSnd f (PAIR x y) = PAIR x (f y)
	PFst (PAIR x y) = x
	PSnd (PAIR x y) = y
gopt{|UNIT|} = Positionals []
gopt{|CONS of {gcd_name}|} c = bifmap (\(CONS a)->a) CONS $ SubParsers [(gcd_name, c)]
gopt{|EITHER|} l r = case (l, r) of
	(SubParsers sl, SubParsers sr)
		= SubParsers
			$  map (appSnd $ bifmap (\(LEFT a)->a) LEFT) sl
			++ map (appSnd $ bifmap (\(RIGHT a)->a) RIGHT) sr
gopt{|(,)|} l r = case (l, r) of
	(Positionals pl, Positionals pr)
		= Positionals
			$  map (combine fst appFst) pl
			++ map (combine snd appSnd) pr
gopt{|(,,)|} f s t = case (f, s, t) of
	(Positionals pf, Positionals ps, Positionals pt)
		= Positionals
			$  map (combine fst3 appFst3) pf
			++ map (combine snd3 appSnd3) ps
			++ map (combine thd3 appThd3) pt

consPrint (Positionals x) = "Positionals"
consPrint (BinaryFlag x _) = "BinaryFlag"
consPrint (Flags x) = "Flags"
consPrint (SubParsers x) = "SubParsers"
		
parseOpts :: (Opt a) [String] a -> MaybeError [String] (a, [String])
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 (SubParsers ps) [arg:args] a = case find (\(l,p)->l==arg) ps of
	Nothing = Error ["Unrecognized subcommand"]
	Just (l, p) = parseOpts p args a
parseOpts (SubParsers ps) [] a = Error ["One of these subcommands required: " +++ join ", " (map fst ps)]
parseOpts (Flags fs) [arg:args] a
	| not (startsWith "--" arg) = Ok (a, [arg:args])
	= case find (\(l,p)->"--" +++ l == arg) fs of
		Nothing = Error ["Unrecognized option: " +++ arg]
		Just (l, p) = p args a >>= \(a, args)->parseOpts (Flags fs) args a
parseOpts _ args a = Ok (a, args)

:: T =
	{ field  :: (Int,Int)
	, field2 :: String
	, t2 :: C
	}
:: T2 = {f :: Int}
:: C = A Int | B | C
//:: T2 = T Int Int
derive bimap Opt, [], (,), MaybeError
derive gopt T, T2, C

Start w
# ([argv0:args], w) = getCommandLine w
= parseOpts t args B//{field=(0, 0),field2="",t2=A}

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