X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=gopt%2Fgopt.icl;fp=gopt%2Fgopt.icl;h=0000000000000000000000000000000000000000;hb=4b62b5d397d86147e393c05b3083af74a3a0c4af;hp=09089ab2354dfdd5dde24f6a0239f98a111b4d8e;hpb=e5305ee9d4290e1aa803a2e62a14f32e5cd29782;p=clean-tests.git

diff --git a/gopt/gopt.icl b/gopt/gopt.icl
deleted file mode 100644
index 09089ab..0000000
--- a/gopt/gopt.icl
+++ /dev/null
@@ -1,166 +0,0 @@
-module gopt
-
-import StdEnv, StdGeneric
-
-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, 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 (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)
-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
-//generic gopt a :: Opt a
-gopt{|Bool|} = BinaryFlag (const True) (const False)
-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)]
-	//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
-	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) (\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 [] as i = Ok (i, as)
-gopt{|PAIR|} l r = case (l, r) of
-	(Positionals pl, Positionals pr)
-		= Positionals
-			$  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)
-	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 (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 (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 :: [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) = 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)->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, 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
-//= pHelp opt
-= parseOpts args {field=(0, 0),field2="",t2=A 4}
-
-opt :: Opt T
-opt = gopt{|*|}