From: Mart Lubbers Date: Thu, 11 Oct 2018 13:29:11 +0000 (+0200) Subject: Merge branch 'master' of git.martlubbers.net:clean-tests X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=35c4da367b878a80b465dab0eb1d06538fa47b49;hp=ee4c83a9c7be2c7c45a8f0815bd35fed6de346c0;p=clean-tests.git Merge branch 'master' of git.martlubbers.net:clean-tests --- diff --git a/afp/a4/skeleton4 b/afp/a4/skeleton4 new file mode 100755 index 0000000..328ba6b Binary files /dev/null and b/afp/a4/skeleton4 differ diff --git a/afp/a4/skeleton4.icl b/afp/a4/skeleton4.icl index 8e4d8c6..6b96cd5 100644 --- a/afp/a4/skeleton4.icl +++ b/afp/a4/skeleton4.icl @@ -104,7 +104,6 @@ changeName s changeNameEdcomb :: Student -> Task Student changeNameEdcomb s = updateInformation "New name" [UpdateUsing id (\_ v->v) nameEditor] s - >>= viewInformation "done" [] where nameEditor :: Editor Student nameEditor = bijectEditorValue diff --git a/bug/t.icl b/bug/t.icl new file mode 100644 index 0000000..5f863e0 --- /dev/null +++ b/bug/t.icl @@ -0,0 +1,13 @@ +module t + +import Data.Maybe, Control.Monad + +//f :: Maybe (Maybe a) +//f = return Nothing >>= return +// +f :: Maybe (Maybe a) +f = return Nothing >>= \x->return x + + + +Start = () diff --git a/dynamicclass/test.icl b/dynamicclass/test.icl new file mode 100644 index 0000000..6a9c935 --- /dev/null +++ b/dynamicclass/test.icl @@ -0,0 +1,22 @@ +module test + +import StdEnv, StdMaybe +import Data.Func + +pack :: a -> Dynamic | TC, + a +pack a = dynamic a :: a^ + +//square :: Dynamic -> Dynamic +//square (v :: A.a: a | + a) = dynamic (v + v) + +plus :: Dynamic -> Int +plus (plus :: A.a : a -> a | + a) = plus 2 3 +plus _ = 0 + +app :: Dynamic Dynamic -> Dynamic +app (db :: A.a: a -> a | + a) (a :: A.a: a | + a) = dynamic (db a) + +dub :: a -> a| + a +dub a = a + a + +Start w = typeCodeOfDynamic (dynamic (\x->x + x) :: A.a : a a -> a | + a) diff --git a/dyneditors/DynEditorExample.icl b/dyneditors/DynEditorExample.icl new file mode 100644 index 0000000..854710c --- /dev/null +++ b/dyneditors/DynEditorExample.icl @@ -0,0 +1,52 @@ +module DynEditorExample + +import Data.Func, Data.Functor, Data.Maybe +import iTasks, iTasks.UI.Editor.Modifiers +import DynamicEditor + +// non-typesafe expression +:: Expr = IntLit Int | RealLit Real | Plus Expr Expr | ToInt Expr | ToReal Expr | Eq Expr Expr + +// expression with phantom type +:: TypedExpr a =: TypedExpr Expr + +derive class iTask Expr, TypedExpr + +dslEditor :: DynamicEditor (TypedExpr a) +dslEditor = DynamicEditor + ( [ functionConsDyn "plus" "plus" + ( dynamic \(TypedExpr x) (TypedExpr y) -> TypedExpr (Plus x y) :: + A.b: (TypedExpr b) (TypedExpr b) -> TypedExpr b + ) + , functionCons "toInt" "to integer" toIntExpr + , functionCons "toReal" "to decimal" toRealExpr + , customEditorCons "int" "(enter integer)" + (bijectEditorValue (\(TypedExpr (IntLit i)) -> i) intLit gEditor{|*|}) + , customEditorCons "real" "(enter decimal)" + (bijectEditorValue (\(TypedExpr (RealLit r)) -> r) realLit gEditor{|*|}) + , functionConsDyn "eq" "are equal" + ( dynamic \(TypedExpr x) (TypedExpr y) -> TypedExpr (Eq x y) :: + A.b: (TypedExpr b) (TypedExpr b) -> TypedExpr Bool + ) + ] + ) +where + toIntExpr :: (TypedExpr Real) -> TypedExpr Int + toIntExpr (TypedExpr x) = TypedExpr (ToInt x) + + toRealExpr :: (TypedExpr Int) -> TypedExpr Real + toRealExpr (TypedExpr x) = TypedExpr (ToReal x) + + intLit :: Int -> TypedExpr Int + intLit i = TypedExpr (IntLit i) + + realLit :: Real -> TypedExpr Real + realLit r = TypedExpr (RealLit r) + +// possible results can be Int, Real +// Bool does not work yet +enterExpr :: Task (Maybe (DynamicEditorValue (TypedExpr Int))) +enterExpr = enterInformation () [EnterUsing id $ dynamicEditor dslEditor] >&> + viewSharedInformation () [ViewAs $ fmap $ toValue dslEditor] + +Start world = doTasks enterExpr world diff --git a/dyneditors/DynamicEditor.dcl b/dyneditors/DynamicEditor.dcl new file mode 100644 index 0000000..36d91b0 --- /dev/null +++ b/dyneditors/DynamicEditor.dcl @@ -0,0 +1,38 @@ +definition module DynamicEditor + +// TODO: quantified variables with constraints? + +import iTasks + +:: DynamicEditor a =: DynamicEditor [DynamicCons] +// phantom type only needed for top level +:: DynamicEditorValue a = DynamicEditorValue !DynamicConsId !DEVal + +:: DEVal = DEApplication ![(!DynamicConsId, !DEVal)] + | DEJSONValue !JSONNode + +derive class iTask DynamicEditorValue + +:: DynamicCons +:: DynamicConsOption = HideIfOnlyChoice + +(<<@@@) infixl 2 :: !DynamicCons !DynamicConsOption -> DynamicCons +(@@@>>) infixr 2 :: !DynamicConsOption !DynamicCons -> DynamicCons + +:: DynamicConsId :== String +:: DynamicConsBuilder = FunctionCons !Dynamic + | E.a: CustomEditorCons !(Editor a) & JSONEncode{|*|}, JSONDecode{|*|}, gText{|*|}, TC a + | ListCons !Dynamic //* must contain a value of type [a] -> b + +functionCons :: !String !String !a -> DynamicCons | TC a +listCons :: !String !String !([a] -> b) -> DynamicCons | TC a & TC b +customEditorCons :: !String !String !(Editor a) -> DynamicCons | TC, JSONEncode{|*|}, JSONDecode{|*|}, gText{|*|} a +// dynamic variants are required because this is the only way to use a quantified type variable +functionConsDyn :: !String !String !Dynamic -> DynamicCons +listConsDyn :: !String !String !Dynamic -> DynamicCons + +dynamicEditor :: !(DynamicEditor a) -> Editor (DynamicEditorValue a) | TC a + +toValue :: !(DynamicEditor a) !(DynamicEditorValue a) -> a | TC a +dynEditorValToString :: !(DynamicEditor a) !(DynamicEditorValue a) -> String + diff --git a/dyneditors/DynamicEditor.icl b/dyneditors/DynamicEditor.icl new file mode 100644 index 0000000..270cfb2 --- /dev/null +++ b/dyneditors/DynamicEditor.icl @@ -0,0 +1,404 @@ +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} diff --git a/gentests/test.icl b/gentests/test.icl new file mode 100644 index 0000000..25bdc4e --- /dev/null +++ b/gentests/test.icl @@ -0,0 +1,10 @@ +module test + +import StdGeneric +import iTasks + + +Start w = startEngine t w + +t :: Task UNIT +t = enterInformation () [] diff --git a/gopt/gopt.icl b/gopt/gopt.icl index 1713a6b..57cf229 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) @@ -37,9 +37,9 @@ 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{|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 @@ -50,23 +50,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 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 +84,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 +:: 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{|*|} diff --git a/metaeditor/MetaType.icl b/metaeditor/MetaType.icl index 4d891b9..9e776bc 100644 --- a/metaeditor/MetaType.icl +++ b/metaeditor/MetaType.icl @@ -12,6 +12,7 @@ import Data.Functor import Data.Tuple import Data.Either import Data.List +import Data.Maybe import iTasks import iTasks.UI.Editor import iTasks.UI.Editor.Containers @@ -82,8 +83,12 @@ where typeToEditor` (MADT []) = emptyEditor typeToEditor` (MADT [(k, v)]) = bijectEditorValue (\(IADT 0 m)->m) (IADT 0) $ row k (containerL (map typeToEditor` v) <<@ directionAttr Horizontal) - typeToEditor` (MADT kvs) = abort "blurp"/*bijectEditorValue (\(IADT i m)->(i, m)) (uncurry IADT) - $ choose [(k, containerL (map typeToEditor` v) <<@ directionAttr Horizontal)\\(k,v)<-kvs]*/ + typeToEditor` (MADT kvs) = bijectEditorValue (\(IADT i m)->(i, m)) (uncurry IADT) + $ containerc + (chooseWithDropdown [k\\(k,_)<-kvs]) + [(maybe undef id + , containerL (map typeToEditor` v) <<@ directionAttr Horizontal + )\\(k,v)<-kvs] typeToEditor` x = abort $ "Nomatch: " +++ toString x enterValueOfType :: MetaType -> Task MetaInst diff --git a/paard.icl b/paard.icl new file mode 100644 index 0000000..9e79cce --- /dev/null +++ b/paard.icl @@ -0,0 +1,39 @@ +module paard + +import StdEnv, StdFunc + +bord :: {{Char}} +bord = + {{'e', 'p', 's'} + ,{'o', ' ', 't'} + ,{'s', 'r', 'a'} + } + +inbord :: Int Int -> Bool +inbord x y = x >= 0 && y >= 0 && x < size bord && y < size bord.[0] + +zetten :: [(Int, Int)] +zetten = + let m = [(1,2), (-1,2), (1,-2), (-1,-2)] + in m ++ map (\(x,y)->(y,x)) m + +zet :: [(Int, Int)] -> [[(Int, Int)]] +zet [] = [] +zet gehad=:[(x, y):_] = + [ [(x+dx, y+dy):gehad] + \\(dx,dy)<-zetten + | inbord (dx+x) (dy+y) + && not (isMember (dx+x,dy+y) gehad) + ] + +str :: [(Int, Int)] -> String +str s = {bord.[x].[y]\\(x, y)<-reverse s} +++ "\n" + +startposities :: [[(Int,Int)]] +startposities = [[(x,y)]\\x<-[0..2],y<-[0..2]] + + +($) infixr 0 +($) :== id + +Start = map str $ iter ((size bord*size bord.[0]) - 2) (flatten o map zet) startposities