From: Mart Lubbers Date: Fri, 21 Sep 2018 07:23:50 +0000 (+0200) Subject: Merge branch 'master' of git.martlubbers.net:clean-tests X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=d19291be9099351d160c3578fecc196c599b9cb0;hp=8b58864aa5e0ace806f15156d51cdbc256e4f9f5;p=clean-tests.git Merge branch 'master' of git.martlubbers.net:clean-tests --- diff --git a/metaeditor/.gitignore b/metaeditor/.gitignore new file mode 100644 index 0000000..b28cd46 --- /dev/null +++ b/metaeditor/.gitignore @@ -0,0 +1 @@ +ed diff --git a/metaeditor/EditorExt.dcl b/metaeditor/EditorExt.dcl new file mode 100644 index 0000000..af074d1 --- /dev/null +++ b/metaeditor/EditorExt.dcl @@ -0,0 +1,7 @@ +definition module EditorExt + +from iTasks.UI.Editor import :: Editor + +row :: String (Editor a) -> Editor a + +choose :: [(String, Editor a)] -> Editor (Int, a) diff --git a/metaeditor/EditorExt.icl b/metaeditor/EditorExt.icl new file mode 100644 index 0000000..4512ae0 --- /dev/null +++ b/metaeditor/EditorExt.icl @@ -0,0 +1,150 @@ +implementation module EditorExt + +from Data.Func import $ +import Data.Tuple +import qualified Data.Map as DM +import StdTuple +import Data.Maybe + +import iTasks +import iTasks.UI.Editor.Common + +row :: String (Editor a) -> Editor a +row l e = bijectEditorValue (tuple l) snd $ + container2 label e <<@ directionAttr Horizontal + +import StdDebug, StdMisc + +// Choose combinators (Used for selecting constructors in ADTs) +choose :: [(String, Editor a)] -> Editor (Int, a) +choose [] = emptyEditor +choose [(k,v)] = bijectEditorValue snd (tuple 0) $ row k v +choose cs = {Editor|genUI=genUI,onEdit=onEdit,onRefresh=onRefresh} +where + numConses = length cs + conses = map fst cs + + genUI dp (consindex, value) vst=:{VSt|taskId,mode,optional,selectedConsIndex} + # cured = snd (cs !! consindex) + = case mode of + Enter + # (consChooseUI,consChooseMask) = genConsChooseUI taskId dp optional conses Nothing + = (Ok (UI UIVarCons 'DM'.newMap [consChooseUI],CompoundMask {fields=[consChooseMask],state=JSONNull}),{vst & selectedConsIndex = selectedConsIndex}) + Update + = case cured.Editor.genUI dp value vst of + (Ok (consUI=:(UI _ attr items), consMask=:(CompoundMask {fields})),vst) + # (consChooseUI,consChooseMask) = genConsChooseUI taskId dp optional conses (Just vst.selectedConsIndex) + = (Ok (UI UIVarCons attr [consChooseUI:items],CompoundMask {fields=[consChooseMask:fields],state=JSONNull}) + ,{vst & selectedConsIndex = selectedConsIndex}) + (Error e,vst) = (Error e,vst) + View + = case cured.Editor.genUI dp value vst of + (Ok (consUI=:(UI _ attr items), consMask=:(CompoundMask {fields})),vst) + # (consViewUI,consViewMask) = genConsViewUI conses vst.selectedConsIndex + = (Ok (UI UIVarCons attr [consViewUI:items],CompoundMask {fields=[consViewMask:fields],state=JSONNull}) + ,{vst & selectedConsIndex = selectedConsIndex}) + (Error e,vst) = (Error e,vst) + + genConsChooseUI taskId dp optional gtd_conses mbSelectedCons = (consChooseUI,consChooseMask) + where + consOptions = [JSONObject [("id",JSONInt i),("text",JSONString gdc)] \\ gdc <- gtd_conses & i <- [0..]] + consChooseUI = uia UIDropdown (choiceAttrs taskId (editorId dp) (maybeToList mbSelectedCons) consOptions) + consChooseMask = FieldMask {touched=False,valid=optional || isJust mbSelectedCons,state=maybe JSONNull JSONInt mbSelectedCons} + + genConsViewUI gtd_conses selectedCons + = (uia UITextView (valueAttr (JSONString (gtd_conses !! selectedCons))), newFieldMask) + + //Update is a constructor switch + onEdit dp ([],JSONArray [JSONInt consIdx]) (i, val) (CompoundMask {fields=[FieldMask {FieldMask|touched,valid,state}:masks]}) vst//=:{VSt|mode} + | not (trace_tn ("cons switch from " +++ toString i +++ " to " +++ toString consIdx)) = undef + # cured = snd (cs !! consIdx) + | consIdx < 0 || consIdx >= numConses + = (Error "Constructor selection out of bounds", (i, val),vst) + //Create a default value for the selected constructor + //This is a rather ugly trick: We create a special target path that consists only of negative values that is + //decoded by the the onEdit instance of EITHER to create a value that consists of the correct nesting of LEFT's and RIGHT's + // //TODO hier zit de bug + # (_,val,vst) = cured.Editor.onEdit dp (consCreatePath consIdx numConses,JSONNull) val newCompoundMask vst + //Create a UI for the new constructor + = case cured.Editor.genUI dp val {vst & mode = Enter} of + (Ok (UI _ attr items, CompoundMask {fields=masks}),vst) + //Construct a UI change that does the following: + //1: If necessary remove the fields of the previously selected constructor + # removals = case state of +// (JSONInt prevConsIdx) = repeatn (length (snd (cs !! prevConsIdx))) (1,RemoveChild) +// (JSONInt prevConsIdx) = repeatn (length items) (1,RemoveChild) + _ = [] + //2: Inserts the fields of the newly created ui + # inserts = [(i,InsertChild ui) \\ ui <- items & i <- [1..]] + # change = ChangeUI [] (removals ++ inserts) + //Create a new mask for the constructor selection + # consChooseMask = FieldMask {touched=True,valid=True,state=JSONInt consIdx} + = (Ok (change,CompoundMask {fields=[consChooseMask:masks],state=JSONNull}), (consIdx, val), vst) + (Error e,vst) = (Error e, (i, val), vst) + + //Other events targeted directly at the ADT + onEdit dp ([],e) (i, val) (CompoundMask {fields=[consChooseMask=:(FieldMask {FieldMask|touched,valid,state}):masks]}) vst=:{VSt|optional} + | 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 constructor + # change = case state of +// (JSONInt prevConsIdx) = ChangeUI [] (repeatn 32 /*(gtd_conses !! prevConsIdx).gcd_arity */(1,RemoveChild)) + _ = NoChange + # consChooseMask = FieldMask {touched=True,valid=optional,state=JSONNull} + = (Ok (change,CompoundMask {fields=[consChooseMask:masks],state=JSONNull}),(i, val), vst) + = (Error "Unknown constructor select event ",(i, val),vst) + + //Update is targeted somewhere inside this value + onEdit dp (tp,e) (i, val) mask=:(CompoundMask {fields,state}) vst + # cured = snd (cs !! i) + //Adjust for the added constructor switch UI + # consChooseMask = hd fields + = case cured.Editor.onEdit dp (tp,e) val (CompoundMask {fields=tl fields,state=JSONNull}) vst of + (Ok (change,CompoundMask {fields}),val,vst) + # change = case change of + (ChangeUI attrChanges itemChanges) = ChangeUI attrChanges [(i + 1,c) \\ (i,c) <- itemChanges] + _ = NoChange + = (Ok (change,CompoundMask {fields=[consChooseMask:fields],state=JSONNull}),(i, val),vst) + (Error e,val,vst) = (Error e, (i, val), vst) + + consCreatePath i n + | i >= n = [] + | n == 1 = [] + | i < (n /2) = [ -1: consCreatePath i (n/2) ] + | otherwise = [ -2: consCreatePath (i - (n/2)) (n - (n/2)) ] + + onRefresh dp (i, new) (j, old) mask=:(CompoundMask {fields}) vst=:{VSt|mode,taskId,optional,selectedConsIndex=curSelectedConsIndex} + # cured = snd (cs !! i) + | numConses == 1 + # (change,val,vst) = cured.Editor.onRefresh dp new old mask vst + = (change,(j, val),vst) + | otherwise + //Adjust for the added constructor view/choose UI + # consChooseMask = hd fields + //Don't recursively refresh if no constructor has been chosen + | (not mode =: View) && consChooseMask =: (FieldMask {FieldMask|state=JSONNull}) + = (Ok (NoChange,mask),(i, old),vst) + = case cured.Editor.onRefresh dp new old (CompoundMask {fields=tl fields,state=JSONNull}) {vst & selectedConsIndex = 0} of + (Ok (change,CompoundMask {fields}),val,vst=:{VSt|selectedConsIndex}) + //If the cons was changed we need to update the selector + # consIndex = ~selectedConsIndex - 1 + # consChange = if (selectedConsIndex < 0) + [(0, ChangeChild (ChangeUI [SetAttribute "value" (JSONArray [JSONInt consIndex,JSONBool True])] []))] + [] + //Adjust the changes + # change = case change of + NoChange = if (consChange =: []) NoChange (ChangeUI [] consChange) + (ChangeUI attrChanges itemChanges) = ChangeUI attrChanges (consChange ++ [(i + 1,c) \\ (i,c) <- itemChanges]) + (ReplaceUI ui=:(UI type attr items)) + //Add the constructor selection/view ui + # (consUI,_) = if (mode =: View) + (genConsViewUI conses consIndex) + (genConsChooseUI taskId dp optional conses (Just consIndex)) + = ReplaceUI (UI type attr [consUI:items]) + | otherwise + = (Ok (change, CompoundMask {fields=[consChooseMask:fields],state=JSONNull}), (j, val),{vst & selectedConsIndex = curSelectedConsIndex}) + + (Ok (change,mask),val,vst=:{VSt|selectedConsIndex}) + = (Error "Corrupt mask in generic choose editor",(i, old), vst) + (Error e,val,vst) = (Error e,(i, val),vst) + onRefresh dp (i, new) (j, old) mask vst + = (Error "Corrupt mask in generic choose editor",(j, old), vst) diff --git a/metaeditor/MetaType.dcl b/metaeditor/MetaType.dcl new file mode 100644 index 0000000..7f85458 --- /dev/null +++ b/metaeditor/MetaType.dcl @@ -0,0 +1,42 @@ +definition module MetaType + +from StdOverloaded import class toString, class fromString +from iTasks.UI.Editor import :: Editor +from iTasks.UI.Definition import :: UIType +from iTasks.WF.Definition import class iTask +from iTasks.UI.Editor import :: Editor +from iTasks.UI.Editor.Generic import generic gEditor +from iTasks.Internal.Generic.Visualization import generic gText, :: TextFormat +from iTasks.Internal.Generic.Defaults import generic gDefault +from iTasks.WF.Definition import :: Task +from Text.GenJSON import generic JSONEncode, generic JSONDecode, :: JSONNode +from Data.GenEq import generic gEq +from Data.Maybe import :: Maybe +from Data.Either import :: Either + +derive class iTask MetaType +derive gEq MetaInst +derive gText MetaInst +derive JSONEncode MetaInst +derive JSONDecode MetaInst +derive gEditor MetaInst +derive gDefault MetaInst + +:: MetaType = MInt | MReal | MBool | MChar | MVoid | MPoint MetaType | MThis + | MRecord [(String, MetaType)] | MADT [(String, [MetaType])] +// | MTup2 (MetaType, MetaType) +// | MTup3 (MetaType, MetaType, MetaType) +// | MTup4 (MetaType, MetaType, MetaType, MetaType) + +:: MetaInst = IInt Int | IReal Real | IBool Bool | IChar Char | IVoid + | IPoint String | IRecord [MetaInst] | IADT Int [MetaInst] + +typeToInst :: MetaType -> MetaInst +typeToEditor :: MetaType -> Editor MetaInst + +enterValueOfType :: MetaType -> Task MetaInst + +parse :: MetaType [Char] -> Either String (MetaInst, [Char]) + +instance toString MetaType +instance fromString MetaType diff --git a/metaeditor/MetaType.icl b/metaeditor/MetaType.icl new file mode 100644 index 0000000..4d891b9 --- /dev/null +++ b/metaeditor/MetaType.icl @@ -0,0 +1,166 @@ +implementation module MetaType + +from StdFunc import o, flip +from Data.Func import $ + +import StdOverloaded, StdString, StdList, StdMisc, StdTuple, StdBool +import StdGeneric + +//import Control.Monad +//import Control.Applicative +import Data.Functor +import Data.Tuple +import Data.Either +import Data.List +import iTasks +import iTasks.UI.Editor +import iTasks.UI.Editor.Containers +import iTasks.UI.Editor.Controls +import iTasks.UI.Editor.Generic +import iTasks.UI.Editor.Common +import iTasks.UI.Editor.Modifiers +import Text.GenJSON +import Text + +import StdDebug + +derive class iTask MetaType +derive gEq MetaInst +derive gText MetaInst +derive JSONEncode MetaInst +derive JSONDecode MetaInst +gDefault{|MetaInst|} = trace "Unable to derive a default value for MetaInst without the MetaType" IVoid +gEditor{|MetaInst|} = trace "Unable to derive an editor for MetaInst without the MetaType" emptyEditor + +instance toString MetaType +where + toString MInt = "Int" + toString MReal = "Real" + toString MBool = "Bool" + toString MChar = "Char" + toString MVoid = "Void" + toString (MPoint p) = "(Pointer " +++ toString p +++ ")" + toString (MRecord m) = "{" +++ join "," [ + k +++ "::" +++ toString v\\(k,v)<-m] +++ "}" + toString (MADT m) = join " | " [ + k +++ " " +++ join " " (map toString v)\\(k,v)<-m] + toString MThis = "This" + +instance fromString MetaType +where + fromString x = MInt + +typeToInst :: MetaType -> MetaInst +typeToInst m = typeToInst` m +where + typeToInst` :: MetaType -> MetaInst + typeToInst` MInt = IInt 0 + typeToInst` MReal = IReal 0.0 + typeToInst` MBool = IBool False + typeToInst` MChar = IChar ' ' + typeToInst` MVoid = IVoid + typeToInst` MThis = typeToInst m + typeToInst` (MPoint _) = IPoint "" + typeToInst` (MRecord fs) = IRecord $ map (typeToInst` o snd) fs + typeToInst` (MADT []) = IADT -1 [] + typeToInst` (MADT [(c, fs):_]) = IADT 0 $ map typeToInst` fs + +typeToEditor :: MetaType -> Editor MetaInst +typeToEditor x = typeToEditor` x +where + typeToEditor` :: MetaType -> Editor MetaInst + typeToEditor` MInt = bijectEditorValue (\(IInt i) ->i) IInt integerField + typeToEditor` MReal = bijectEditorValue (\(IReal i)->i) IReal decimalField + typeToEditor` MBool = bijectEditorValue (\(IBool i)->i) IBool checkBox + typeToEditor` MChar = bijectEditorValue (\(IChar i)->i) IChar gEditor{|*|} + typeToEditor` MVoid = bijectEditorValue (\_->()) (\_->IVoid) emptyEditor + typeToEditor` (MPoint _) = bijectEditorValue (\(IPoint i)->i) IPoint gEditor{|*|} + typeToEditor` MThis = typeToEditor x + typeToEditor` (MRecord fs) = + bijectEditorValue (\(IRecord i)->i) IRecord + $ containerL [row k (typeToEditor` v)\\(k, v)<-fs] + 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` x = abort $ "Nomatch: " +++ toString x + +enterValueOfType :: MetaType -> Task MetaInst +enterValueOfType mt = enterValueOfType` mt +where + enterValueOfType` MInt = enterInformation () [] @ IInt + enterValueOfType` MReal = enterInformation () [] @ IReal + enterValueOfType` MBool = enterInformation () [] @ IBool + enterValueOfType` MChar = enterInformation () [] @ IChar + enterValueOfType` MVoid = return IVoid + enterValueOfType` MThis = enterValueOfType` mt + enterValueOfType` (MPoint _) = enterInformation () [] @ IPoint + enterValueOfType` (MRecord fs) + = allTasks [enterValueOfType` v <<@ Title k\\(k,v)<-fs] + >>* [OnAction (Action "Continue") $ ifValue (\v->length v == length fs) $ return o IRecord] + enterValueOfType` (MADT kvs) + = enterChoice "Cons" [ChooseFromDropdown (fst o fst)] (zip2 kvs [0..]) + >&> \sh->whileUnchanged sh \mc->case mc of + Nothing = viewInformation () [] () @! IVoid + Just ((k, vs), i) + = allTasks (map enterValueOfType` vs) <<@ Title k @ IADT i + +row :: String (Editor a) -> Editor a +row l e = bijectEditorValue (tuple l) snd $ + container2 label e <<@ directionAttr Horizontal + +parse :: MetaType [Char] -> Either String (MetaInst, [Char]) +parse t cs = parse` t t cs +where + parse` t MVoid cs = Right (IVoid, cs) + parse` t MInt cs = case parseInt cs of + (i, []) = Right (IInt i, cs) + (i, [' ':cs]) = Right (IInt i, cs) + _ = Left "Integer must end with a space" + parse` t MReal cs = Right $ appFst IReal (parseReal cs) + parse` t MBool [c:cs] + | c == '0' || c == '1' = Right (IBool (c == '1'), cs) + = Left "Bool must be encoded as 0 or 1" + parse` t MChar [c:cs] = Right (IChar c, cs) + parse` t (MPoint _) ['\0':cs] = Right (IPoint "", cs) + parse` t p=:(MPoint _) [c:cs] = case parse p cs of + Left e = Left e + Right (IPoint ss, cs) = Right (IPoint (toString c +++ ss), cs) + parse` t MThis c = parse t c + parse` t (MRecord fs) cs = undef + parse` t (MADT cons) cs = case parse MInt cs of + Right (IInt c, cs) + | c < 0 || c > length cons = Left $ "Not a valid cons identifier: " +++ toString c + = appFst (IADT c) <$> plist t (snd $ cons !! c) cs + Left e = Left e + parse` t _ [] = Left "Empty input" + parse` t` t _ = Left $ "Undef: " +++ toString t` +++ " , " +++ toString t + + plist t [] cs = Right ([], cs) + plist t [a:as] cs = case parse` t a cs of + Left e = Left e + Right (a, cs) = case plist t as cs of + Left e = Left e + Right (as, cs) = Right ([a:as], cs) + + parseInt :: [Char] -> (Int, [Char]) + parseInt [c:cs] = appFst ((*) -1) $ int cs + parseInt cs = int cs + + int = appFst (toInt o toString) o span isDigit + + parseReal :: [Char] -> (Real, [Char]) + parseReal cs = (0.0, cs) + +print :: MetaInst -> String +print i = trim $ print` i +where + print` IVoid = "" + print` (IInt i) = toString i +++ " " + print` (IReal i) = toString i +++ " " + print` (IBool i) = if i "1" "0" + print` (IChar i) = toString i + print` (IPoint i) = i +++ "\0" + print` (IRecord fs) = concat $ map print fs + print` (IADT i cs) = concat [toString i," ":map print cs] diff --git a/metaeditor/ed.icl b/metaeditor/ed.icl new file mode 100644 index 0000000..a7835c2 --- /dev/null +++ b/metaeditor/ed.icl @@ -0,0 +1,21 @@ +module ed + +from Data.Func import $ +import iTasks +import MetaType +import Data.Maybe +import Data.Functor + +import GenPrint +derive gPrint MetaInst + +Start w = startEngine t w +where + t = enterInformation "Enter MetaType" [] + >&> \sh->whileUnchanged sh \mt->case mt of + Nothing = viewInformation () [] "No type entered" + Just mt = enterValueOfType mt + >&> viewSharedInformation "Value:" [ViewAs $ fmap lens] @! "" + + lens :: (MetaInst -> String) + lens = printToString