From: Mart Lubbers <mart@martlubbers.net>
Date: Tue, 29 May 2018 14:24:30 +0000 (+0200)
Subject: up
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=42099428d4defde7cb94bb15cd89b35d5761f63d;p=clean-tests.git

up
---

diff --git a/gopt/gopt.icl b/gopt/gopt.icl
index dd66154..6db4936 100644
--- a/gopt/gopt.icl
+++ b/gopt/gopt.icl
@@ -7,35 +7,34 @@ import Data.Error
 import Data.Func
 import Data.Functor
 import Data.Tuple
+import Data.Maybe
 import Control.Applicative
-import Control.Monad
+import Control.Monad => qualified join
 import System.CommandLine
+import Text
 
 :: Opt a
 	= BinaryFlag (a -> a) (a -> a)
-	| Flags [(String, Flag a)]
+	| Flags [(String, ([String] a -> (MaybeError [String] (a, [String]))))]
 	| 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 (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
-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
 
+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"])]
@@ -44,61 +43,87 @@ 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
+	//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
-//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
+
+	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 (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
-//
+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  :: Bool
-//	, field2 :: String
+	{ field  :: (Int,Int)
+	, field2 :: String
+	, t2 :: C
 	}
+:: T2 = {f :: Int}
+:: C = A Int | B | C
 //:: T2 = T Int Int
-derive bimap Opt, [], (,), MaybeError, Flag
-derive gopt T
+derive bimap Opt, [], (,), MaybeError
+derive gopt T, T2, C
 
 Start w
 # ([argv0:args], w) = getCommandLine w
-= t
+= parseOpts t args B//{field=(0, 0),field2="",t2=A}
 
-t :: Opt T
+t :: Opt C
 t = gopt{|*|}