--- /dev/null
+implementation module DynamicEditor
+
+import StdMisc, Data.Tuple, Text, Data.Maybe
+from StdFunc import seq, flip
+from Data.Tuple import appFst
+import iTasks, iTasks.UI.Definition, iTasks.UI.Editor.Common, iTasks.UI.Editor.Modifiers
+import qualified Data.Map as Map
+from Data.Func import $
+import Util
+from Data.List import zip3, intersperse
+import Data.Functor
+
+:: DynamicCons =
+ { consId :: !DynamicConsId
+ , label :: !String
+ , builder :: !DynamicConsBuilder
+ , showIfOnlyChoice :: !Bool
+ }
+
+(<<@@@) infixl 2 :: !DynamicCons !DynamicConsOption -> DynamicCons
+(<<@@@) cons HideIfOnlyChoice = {cons & showIfOnlyChoice = False}
+
+(@@@>>) infixr 2 :: !DynamicConsOption !DynamicCons -> DynamicCons
+(@@@>>) opt cons = cons <<@@@ opt
+
+functionCons :: !String !String !a -> DynamicCons | TC a
+functionCons consId label func = functionConsDyn consId label (dynamic func)
+
+functionConsDyn :: !String !String !Dynamic -> DynamicCons
+functionConsDyn consId label func = { consId = consId
+ , label = label
+ , builder = FunctionCons func
+ , showIfOnlyChoice = True
+ }
+
+listCons :: !String !String !([a] -> b) -> DynamicCons | TC a & TC b
+listCons consId label func = listConsDyn consId label (dynamic func)
+
+listConsDyn :: !String !String !Dynamic -> DynamicCons
+listConsDyn consId label func = { consId = consId
+ , label = label
+ , builder = ListCons func
+ , showIfOnlyChoice = True
+ }
+
+customEditorCons :: !String !String !(Editor a) -> DynamicCons | TC, JSONEncode{|*|}, JSONDecode{|*|}, gText{|*|} a
+customEditorCons consId label editor = { consId = consId
+ , label = label
+ , builder = CustomEditorCons editor
+ , showIfOnlyChoice = True
+ }
+
+// TODO: don't use aborts here
+toValue :: !(DynamicEditor a) !(DynamicEditorValue a) -> a | TC a
+toValue (DynamicEditor dynEditor) (DynamicEditorValue cid val) = case toValue` (cid, val) of
+ (v :: a^) = v
+ _ = abort "corrupt dynamic editor value"
+where
+ toValue` :: !(!DynamicConsId, !DEVal) -> Dynamic
+ toValue` (cid, val) = case val of
+ DEApplication args = case cons.builder of
+ FunctionCons fbuilder = toValueFunc fbuilder args
+ ListCons lbuilder = toValueList lbuilder args
+ _ = abort "corrupt dynamic editor value"
+ DEJSONValue json = case cons.builder of
+ CustomEditorCons editor = toValueGen editor json
+ _ = abort "corrupt dynamic editor value"
+ where
+ (cons, _) = consWithId cid dynEditor
+
+ toValueFunc :: !Dynamic ![(!DynamicConsId, !DEVal)] -> Dynamic
+ toValueFunc v [] = v
+ toValueFunc f [x : xs] = case (f, toValue` x) of
+ (f :: a -> b, x :: a) = toValueFunc (dynamic (f x)) xs
+ _ = abort "corrupt dynamic editor value"
+
+ toValueGen :: (Editor a) !JSONNode -> Dynamic | JSONDecode{|*|}, TC a
+ toValueGen editor json = dynamic (fromJSON` editor json)
+ where
+ fromJSON` :: (Editor a) !JSONNode -> a | JSONDecode{|*|} a
+ fromJSON` _ json = fromMaybe (abort "corrupt dynamic editor value") $ fromJSON json
+
+ toValueList :: !Dynamic ![(!DynamicConsId, !DEVal)] -> Dynamic
+ toValueList (f :: [a] -> b) [] = dynamic (f [])
+ toValueList f args=:[fst : _] = case (f, toValue` fst) of
+ (g :: [a] -> b, _ :: a) -> dynamic (g $ fromDynList [toValue` val \\ val <- args])
+ _ -> abort "corrupt dynamic editor value"
+ toValueList _ _ = abort "corrupt dynamic editor value"
+
+ fromDynList :: ![Dynamic] -> [a] | TC a
+ fromDynList dyns = fromDynList` dyns []
+ where
+ fromDynList` [] acc = reverse acc
+ fromDynList` [(a :: a^) : dyns] acc = fromDynList` dyns [a:acc]
+ fromDynList` _ _ = abort "corrupt dynamic editor value"
+
+dynEditorValToString :: !(DynamicEditor a) !(DynamicEditorValue a) -> String
+dynEditorValToString (DynamicEditor dynEditor) (DynamicEditorValue cid val) =
+ concat $ reverse $ dynEditorValToString` (cid, val) []
+where
+ dynEditorValToString` :: !(!DynamicConsId, !DEVal) ![String] -> [String]
+ dynEditorValToString` (cid, val) accum = case val of
+ DEApplication args = case cons.builder of
+ FunctionCons fbuilder = foldl (flip dynEditorValToString`)
+ [" ", cons.DynamicCons.label : accum]
+ args
+ ListCons lbuilder
+ # listElStrs = flatten $ intersperse [" ", cons.DynamicCons.label] $
+ (\arg -> dynEditorValToString` arg []) <$> reverse args
+ = listElStrs ++ [" "] ++ accum
+ _ = abort "corrupt dynamic editor value"
+ DEJSONValue json = case cons.builder of
+ CustomEditorCons editor = [ " ", toStringGen editor json
+ , " ", cons.DynamicCons.label
+ : accum
+ ]
+ _ = abort "corrupt dynamic editor value"
+ where
+ (cons, _) = consWithId cid dynEditor
+
+ toStringGen :: (Editor a) !JSONNode -> String | gText{|*|}, JSONDecode{|*|} a
+ toStringGen editor json = toSingleLineText $ fromJSON` editor json
+ where
+ fromJSON` :: (Editor a) !JSONNode -> a | JSONDecode{|*|} a
+ fromJSON` _ json = fromMaybe (abort "corrupt dynamic editor value") $ fromJSON json
+
+derive class iTask DynamicEditorValue, DEVal
+
+:: E = E.a: E (Editor (DynamicEditorValue a))
+:: ConsType = Function | List | CustomEditor
+
+derive JSONEncode ConsType
+derive JSONDecode ConsType
+
+dynamicEditor :: !(DynamicEditor a) -> Editor (DynamicEditorValue a) | TC a
+dynamicEditor dynEditor=:(DynamicEditor conses)
+ | duplicateIds = abort "duplicate cons IDs in dynamic editor"
+ = compoundEditorToEditor
+ {CompoundEditor| genUI = genUI, onEdit = onEdit, onRefresh = onRefresh, valueFromState = valueFromState}
+where
+ duplicateIds = hasDup $ (\b -> b.consId) <$> conses
+ where
+ // TODO: use hasDup from platform as soon as available
+ hasDup :: ![a] -> Bool | Eq a
+ hasDup [] = False
+ hasDup [x:xs] = isMember x xs || hasDup xs
+
+ genUI :: DataPath !(EditMode (DynamicEditorValue a)) !*VSt
+ -> *(!MaybeErrorString (!UI, !Maybe (!DynamicConsId, !ConsType), ![EditState]), !*VSt)
+ genUI dp mode vst=:{VSt|taskId} = case mode of
+ Enter = case matchingConses of
+ [onlyChoice] | hideCons
+ # (mbUis, _, type, _, vst) = genChildEditors dp onlyChoice.consId Enter vst
+ # mbUis = ( \(uis, childSts) -> (uiContainer uis, Just (onlyChoice.consId, type), [nullState: childSts])
+ ) <$>
+ mbUis
+ = (mbUis, vst)
+ _
+ # (consChooseUI, chooseSt) = genConsChooseUI taskId dp Nothing
+ = (Ok (uiContainer [consChooseUI], Nothing, [chooseSt]), vst)
+
+ Update (DynamicEditorValue cid val)
+ # (mbUis, idx, type, label, vst) = genChildEditors dp cid (Update val) vst
+ = case mbUis of
+ Ok (uis, childSts)
+ | hideCons
+ = (Ok (uiContainer uis, Just (cid, type), [nullState: childSts]), vst)
+ | otherwise
+ # (consChooseUI, chooseSt) = genConsChooseUI taskId dp (Just idx)
+ = (Ok (uiContainer [consChooseUI: uis], Just (cid, type), [chooseSt: childSts]), vst)
+ Error e = (Error e, vst)
+
+ View (DynamicEditorValue cid val)
+ # (mbUis, _, type, label, vst) = genChildEditors dp cid (View val) vst
+ = case mbUis of
+ Ok (uis, childSts)
+ | hideCons
+ = (Ok (uiContainer uis, Just (cid, type), [nullState: childSts]), vst)
+ | otherwise
+ # consChooseUI = uia UITextView $ valueAttr $ JSONString label
+ = (Ok (uiContainer [consChooseUI: uis], Just (cid, type), [nullState: childSts]), vst)
+ Error e = (Error e, vst)
+
+ genConsChooseUI taskId dp mbSelectedCons = (consChooseUI, consChooseSt)
+ where
+ consOptions = [JSONObject [("id",JSONInt i),("text",JSONString cons.DynamicCons.label)] \\ cons <- matchingConses & i <- [0..]]
+ consChooseUI = uia UIDropdown
+ ( 'Map'.put "width" JSONNull $
+ choiceAttrs taskId (editorId dp) (maybe [] (\x -> [x]) mbSelectedCons) consOptions
+ )
+ consChooseSt = LeafState {touched=False,state=maybe JSONNull (\x -> JSONInt x) mbSelectedCons}
+
+ onEdit :: !DataPath
+ !(!DataPath, !JSONNode)
+ !(Maybe (!DynamicConsId, !ConsType))
+ ![EditState]
+ !*VSt
+ -> *( !MaybeErrorString (!UIChange, !Maybe (!DynamicConsId, !ConsType), ![EditState])
+ , !*VSt
+ )
+ // new builder is selected: create a UI for the new builder
+ onEdit dp ([], JSONArray [JSONInt builderIdx]) _ [_: childrenSts] vst
+ | builderIdx < 0 || builderIdx >= length matchingConses
+ = (Error "Dynamic editor selection out of bounds", vst)
+ # cons = matchingConses !! builderIdx
+ # (mbRes, _, type, _, vst) = genChildEditors dp cons.consId Enter vst
+ = case mbRes of
+ Ok (uis, childSts)
+ // insert new UIs for arguments
+ # inserts = [(i, InsertChild ui) \\ ui <- uis & i <- [1..]]
+ # removals = removeNChildren $ length childrenSts
+ # change = ChangeUI [] (removals ++ inserts)
+ # builderChooseState = LeafState {touched = True, state = JSONInt $ length uis}
+ = (Ok (change, Just (cons.consId, type), [builderChooseState: childSts]), vst)
+ Error e = (Error e, vst)
+
+ // other events targeted directly at this building cons
+ onEdit dp ([],e) _ [_: childSts] vst
+ | e =: JSONNull || e =: (JSONArray []) // A null or an empty array are accepted as a reset events
+ //If necessary remove the fields of the previously selected cons
+ # change = ChangeUI [] $ removeNChildren $ length childSts
+ = (Ok (change, Nothing, [nullState: childSts]), vst)
+ | otherwise
+ = (Error $ concat ["Unknown dynamic editor select event: '", toString e, "'"], vst)
+
+ // update is targeted somewhere inside this value
+ onEdit dp ([argIdx: tp], e) (Just (cid, type)) childSts vst
+ # (cons, _) = consWithId cid matchingConses
+ # (res, vst) = case cons.builder of
+ FunctionCons fbuilder
+ # children = childrenEditors fbuilder
+ | argIdx < 0 || argIdx >= length children
+ = (Error "Edit event for dynamic editor has invalid path", vst)
+ # (E editor) = children !! argIdx
+ = editor.Editor.onEdit (dp ++ [argIdx]) (tp, e) (childSts !! (argIdx + 1)) vst
+ ListCons lbuilder
+ = (listBuilderEditor lbuilder).Editor.onEdit (dp ++ [0]) (tp, e) (childSts !! 1) vst
+ CustomEditorCons editor
+ = editor.Editor.onEdit (dp ++ [0]) (tp, e) (childSts !! 1) vst
+ = case res of
+ Ok (change, childSt)
+ # change = ChangeUI [] [(argIdx + if hideCons 0 1, ChangeChild change)]
+ // replace state for this child
+ = (Ok (change, Just (cid, type), updateAt (argIdx + 1) childSt childSts), vst)
+ Error e = (Error e, vst)
+
+ onEdit _ _ _ _ vst = (Error "Invalid edit event for dynamic editor.", vst)
+
+ removeNChildren :: !Int -> [(!Int, !UIChildChange)]
+ removeNChildren nrArgs = repeatn nrArgs (1, RemoveChild)
+
+ childrenEditors :: !Dynamic -> [E]
+ childrenEditors (f :: a -> b) = [E $ dynamicEditorFstArg f : childrenEditors (dynamic (f undef))]
+ where
+ // first argument only used for type
+ dynamicEditorFstArg :: (a -> b) -> Editor (DynamicEditorValue a) | TC a
+ dynamicEditorFstArg _ = dynamicEditor $ DynamicEditor conses
+ childrenEditors _ = []
+
+ onRefresh :: !DataPath
+ !(DynamicEditorValue a)
+ !(Maybe (!DynamicConsId, !ConsType))
+ ![EditState]
+ !*VSt
+ -> *( !MaybeErrorString ( !UIChange
+ , !Maybe (!DynamicConsId, !ConsType)
+ , ![EditState]
+ )
+ , !*VSt
+ )
+ onRefresh dp new mbCid childSts vst = (Error "dynamic editor: onRefresh not implemented!", vst)
+
+ // TODO: accept ID or index
+ genChildEditors :: !DataPath !DynamicConsId !(EditMode DEVal) !*VSt
+ -> *(!MaybeErrorString (![UI], ![EditState]), Int, ConsType, String, !*VSt)
+ genChildEditors dp cid mode vst= case cons.builder of
+ FunctionCons fbuilder
+ # (mbUis, vst) = genChildEditors` (reverse $ zip3 vals (childrenEditors fbuilder) [0..]) [] [] vst
+ = (mbUis, idx, type, cons.DynamicCons.label, vst)
+ where
+ genChildEditors` [] accUi accSt vst = (Ok (accUi, accSt), vst)
+ genChildEditors` [(mbVal, E editor, i): children] accUi accSt vst =
+ case editor.Editor.genUI (dp ++ [i]) (maybe Enter (if viewMode View Update) mbVal) vst of
+ (Ok (ui, st), vst) = genChildEditors` children [ui: accUi] [st: accSt] vst
+ (Error e, vst) = (Error e, vst)
+
+ vals :: [Maybe (DynamicEditorValue a)]
+ vals = case editModeValue mode of
+ // update or view mode
+ Just (DEApplication children) = [Just $ DynamicEditorValue cid val \\ (cid, val) <- children]
+ // enter mode
+ _ = repeat Nothing
+ ListCons lbuilder
+ # listEditorMode = mapEditMode (\(DEApplication listElems) -> listElems) mode
+ # (mbUi, vst) = (listBuilderEditor lbuilder).Editor.genUI (dp ++ [0]) listEditorMode vst
+ = ((\(ui, st) -> ([ui], [st])) <$> mbUi, idx, type, cons.DynamicCons.label, vst)
+ CustomEditorCons editor
+ # editorMode = mapEditMode
+ (\(DEJSONValue json) -> fromMaybe (abort "Invalid dynamic editor state") $ fromJSON json)
+ mode
+ # (mbUi, vst) = editor.Editor.genUI (dp ++ [0]) editorMode vst
+ = ((\(ui, st) -> ([ui], [st])) <$> mbUi, idx, type, cons.DynamicCons.label, vst)
+ where
+ (cons, idx) = consWithId cid matchingConses
+ type = case cons.builder of
+ FunctionCons _ = Function
+ ListCons _ = List
+ CustomEditorCons _ = CustomEditor
+ viewMode = mode =: View _
+
+ hideCons = case matchingConses of
+ [onlyChoice] | not onlyChoice.showIfOnlyChoice = True
+ _ = False
+
+ matchingConses = catMaybes (matchingCons dynEditor <$> conses)
+
+ // first arg only used for type
+ // packs matching conses, with possibly updated (= more specific) type
+ matchingCons :: !(DynamicEditor a) !DynamicCons -> Maybe DynamicCons | TC a
+ matchingCons dynEd cons=:{builder} = (\b -> {cons & builder = b}) <$> mbBuilder`
+ where
+ mbBuilder` = case builder of
+ FunctionCons fbuilder = matchf fbuilder
+ CustomEditorCons editor = matchc editor
+ ListCons lbuilder = matchl lbuilder
+
+ // works for functions with upto 10 args
+ // the type of the dynamic is updated by unifying the function result with the type produced by the editor
+ matchf :: !Dynamic -> Maybe DynamicConsBuilder
+ matchf b = case (b, dynamic dynEd) of
+ (b :: a b c d e f g h i j -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
+ (b :: a b c d e f g h i -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
+ (b :: a b c d e f g h -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
+ (b :: a b c d e f g -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
+ (b :: a b c d e f -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
+ (b :: a b c d e -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
+ (b :: a b c d -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
+ (b :: a b c -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
+ (b :: a b -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
+ (b :: a -> z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
+ (b :: z, _ :: DynamicEditor z) = Just $ FunctionCons (dynamic b)
+ _ = Nothing
+
+ // custom editors do not allow for quantified variables, so no type update is required
+ matchc e = case (dynamic e, dynamic dynEd) of
+ (_ :: Editor a, _ :: DynamicEditor a) = Just $ CustomEditorCons e
+ _ = Nothing
+
+ matchl f = case (f, dynamic dynEd) of
+ (f :: [a] -> b, _ :: DynamicEditor b) = Just $ ListCons (dynamic f)
+ _ = Nothing
+
+ listBuilderEditor :: !Dynamic -> Editor [(!DynamicConsId, !DEVal)]
+ listBuilderEditor (lbuilder :: [a] -> b) = listEditor (Just $ const Nothing) True True Nothing childrenEd`
+ where
+ childrenEd = childrenEditorList lbuilder
+ childrenEd` = bijectEditorValue (\(cid, val) -> DynamicEditorValue cid val)
+ (\(DynamicEditorValue cid val) -> (cid, val))
+ childrenEd
+
+ // first argument only used for type
+ childrenEditorList :: ([a] -> b) -> Editor (DynamicEditorValue a) | TC a
+ childrenEditorList _ = dynamicEditor $ DynamicEditor conses
+ listBuilderEditor _ = abort "dynamic editors: invalid list builder value"
+
+ uiContainer :: [UI] -> UI
+ uiContainer uis = UI UIContainer
+ ('Map'.fromList [("direction", JSONString "horizontal"), ("width", JSONString "wrap")])
+ uis
+
+ valueFromState :: !(Maybe (!DynamicConsId, !ConsType)) ![EditState] -> *Maybe (DynamicEditorValue a)
+ valueFromState (Just (cid, CustomEditor)) [_: [editorSt]] =
+ mapMaybe (DynamicEditorValue cid o DEJSONValue o toJSON`) $ editor.Editor.valueFromState editorSt
+ where
+ ({builder}, _) = consWithId cid conses
+
+ // toJSON` is used to solve overloading, JSONEncode{|*|} is attached to CustomEditorCons
+ (editor, toJSON`) = case builder of
+ CustomEditorCons editor = (editor, toJSON)
+ _ = abort "corrupt dynamic editor state"
+
+ valueFromState (Just (cid, type)) [_: childSts] =
+ mapMaybe (\childVals -> DynamicEditorValue cid $ DEApplication childVals) $ childValuesFor childSts` []
+ where
+ childSts` = case (type, childSts) of
+ (List, [CompoundState _ childSts]) = childSts
+ (_, childSts) = childSts
+
+ childValuesFor :: ![EditState] ![(!DynamicConsId, !DEVal)]
+ -> Maybe [(!DynamicConsId, !DEVal)]
+ childValuesFor [] acc = Just $ reverse acc
+ childValuesFor [childSt: childSts] acc = case (dynamicEditor dynEditor).Editor.valueFromState childSt of
+ Just (DynamicEditorValue childCid childVal) = childValuesFor childSts [(childCid, childVal): acc]
+ _ = Nothing
+ valueFromState _ _ = Nothing
+
+consWithId :: !DynamicConsId ![DynamicCons] -> (!DynamicCons, !Int)
+consWithId cid conses = case filter (\({consId}, _) -> consId == cid) $ zip2 conses [0..] of
+ [cons] = cons
+ [] = abort $ "cons not found: " +++ cid
+ _ = abort $ "duplicate conses: " +++ cid
+
+nullState :: EditState
+nullState = LeafState {touched = True, state = JSONNull}
module gopt
-import StdGeneric, StdOverloaded, StdClass, StdArray, StdChar, StdBool, StdList, StdMisc, StdFunc, StdTuple, StdString
+import StdEnv, StdGeneric
import Data.List
import Data.Error
:: 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
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)
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{|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) RECORD f
gopt{|OBJECT|} f = bifmap (\(OBJECT a)->a) OBJECT f
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
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)
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
+:: T2 = {f :: Int, f2 :: Bool}
+:: C = A Int | B | C Bool
+
+:: ADT
+ = ADT1
+ | ADT2 Int String
+
derive binumap Opt, [], (,), MaybeError
-derive gopt T, T2, C
+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{|*|}
repositories / clean-tests.git / commitdiff