X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=gopt%2Fgopt.icl;h=09089ab2354dfdd5dde24f6a0239f98a111b4d8e;hb=a213c291ff305325434a46262c9ec97e04cb829e;hp=6db49368513634514bfe84d0617eade2003465aa;hpb=42099428d4defde7cb94bb15cd89b35d5761f63d;p=clean-tests.git

diff --git a/gopt/gopt.icl b/gopt/gopt.icl
index 6db4936..09089ab 100644
--- a/gopt/gopt.icl
+++ b/gopt/gopt.icl
@@ -1,6 +1,6 @@
 module gopt
 
-import StdGeneric, StdOverloaded, StdClass, StdArray, StdChar, StdBool, StdList, StdMisc, StdFunc, StdTuple, StdString
+import StdEnv, StdGeneric
 
 import Data.List
 import Data.Error
@@ -16,7 +16,7 @@ import Text
 :: Opt a
 	= BinaryFlag (a -> a) (a -> a)
 	| Flags [(String, ([String] a -> (MaybeError [String] (a, [String]))))]
-	| Positionals [String a -> (MaybeError [String] a)]
+	| Positionals [(String, String a -> (MaybeError [String] a))]
 	| SubParsers [(String, Opt a)]
 
 class bifmap m :: (a -> b) (b -> a) (m b) -> m a
@@ -24,7 +24,7 @@ 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 (Positionals fs) = Positionals $ map (appSnd $ 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)
@@ -35,13 +35,14 @@ 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
+generic gopt a *! :: Opt a
+//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{|Int|} = Positionals [("INT", \s _->if (and [isDigit c\\c<-:s]) (Ok $ toInt s) (Error ["Not an integer"]))]
+gopt{|Char|} = Positionals [("CHAR", \s _->if (size s == 1) (Ok s.[0]) (Error ["Not a single character"]))]
+gopt{|String|} = Positionals [("STRING", \s _->Ok s)]
+gopt{|RECORD|} f = bifmap (\(RECORD a)->a) (\x->RECORD x) f
+gopt{|OBJECT|} f = bifmap (\(OBJECT a)->a) (\x->OBJECT x) 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)]
@@ -50,23 +51,25 @@ gopt{|FIELD of {gfd_name}|} f = case f of
 	//Child is another record, make the arguments ddstyle TODO
 	Flags x = mapF (Flags x)
 	//Child is a subparser
+	SubParsers ps = mapF (Flags [(gfd_name, pOpts (SubParsers ps))])
 	x = abort "Subparsers not supported"
 where
 	mapF :: ((m a) -> m (FIELD a)) | bifmap m
-	mapF = bifmap (\(FIELD a)->a) FIELD
+	mapF = bifmap (\(FIELD a)->a) (\x->FIELD x)
 
 	ptoarg [p] [] i = Error ["Not enough arguments for " +++ gfd_name]
-	ptoarg [p:ps] [a:as] i = p a i >>= ptoarg ps as
+	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
+			$  map (appSnd $ combine PFst appPFst) pl
+			++ map (appSnd $ combine PSnd appPSnd) pr
 	(Flags fl, Flags fr)
 		= Flags
 			$  map (appSnd $ combine` PFst appPFst) fl
 			++ map (appSnd $ combine` PSnd appPSnd) fr
+	(x, y) = abort $ "gopt{|PAIR|}: " +++ consPrint x +++ " " +++ consPrint y
 where
 	appPFst f (PAIR x y) = PAIR (f x) y
 	appPSnd f (PAIR x y) = PAIR x (f y)
@@ -82,48 +85,82 @@ gopt{|EITHER|} l r = case (l, r) of
 gopt{|(,)|} l r = case (l, r) of
 	(Positionals pl, Positionals pr)
 		= Positionals
-			$  map (combine fst appFst) pl
-			++ map (combine snd appSnd) pr
+			$  map (appSnd $ combine fst appFst) pl
+			++ map (appSnd $ 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
+			$  map (appSnd $ combine fst3 appFst3) pf
+			++ map (appSnd $ combine snd3 appSnd3) ps
+			++ map (appSnd $ 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
+
+parseOpts :: [String] a -> MaybeError [String] (a, [String]) | gopt{|*|} a
+parseOpts args a = pOpts gopt{|*|} args a
+
+pOpts :: (Opt a) [String] a -> MaybeError [String] (a, [String])
+pOpts (Positionals [p:ps]) [] a = Error [toString (length [p:ps]) +++ " positional arguments required"]
+pOpts (Positionals [p:ps]) [arg:args] a = (snd p) arg a >>= pOpts (Positionals ps) args
+pOpts (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
+	Just (l, p) = pOpts p args a
+pOpts (SubParsers ps) [] a = Error ["One of these subcommands required: " +++ join ", " (map fst ps)]
+pOpts (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)
+		Just (l, p) = p args a >>= \(a, args)->pOpts (Flags fs) args a
+pOpts (BinaryFlag yes no) args a
+	= pOpts (Positionals [("BOOL", \s v->
+		if (s == "True")
+			(Ok (yes v))
+			(if (s == "False")
+				(Ok (no v))
+				(Error ["Not True or False"])
+			)
+	)]) args a
+pOpts t args a = Ok (a, args)
+
+pHelp :: (Opt a) -> [String]
+pHelp (Positionals []) = []
+pHelp (Positionals [(i, _):ps]) = [i, " ":pHelp $ Positionals ps]
+pHelp (SubParsers ps) =
+	flatten
+	[[n, " ":pHelp opt] ++ ["\n"]
+	\\(n, opt)<-ps
+	]
+pHelp (Flags fs) =
+	["Flags\n"
+	:
+		flatten
+		[["--",f, "\n"]
+		\\(f, p)<-fs
+		]
+	]
 
 :: 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
+:: T2 = {f :: Int, f2 :: Bool}
+:: C = A Int | B | C Bool
+
+:: ADT
+	= ADT1
+	| ADT2 Int String
+
+derive binumap Opt, [], (,), MaybeError
+derive gopt T, T2, ADT, C
 
 Start w
 # ([argv0:args], w) = getCommandLine w
-= parseOpts t args B//{field=(0, 0),field2="",t2=A}
+//= pHelp opt
+= parseOpts args {field=(0, 0),field2="",t2=A 4}
 
-t :: Opt C
-t = gopt{|*|}
+opt :: Opt T
+opt = gopt{|*|}