From: Mart Lubbers Date: Fri, 21 Sep 2018 07:03:17 +0000 (+0200) Subject: Merge branch 'master' of git.martlubbers.net:clean-tests X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=ec0704b3b8d380f05f93076ca16da6c5701fe4bc;p=clean-tests.git Merge branch 'master' of git.martlubbers.net:clean-tests --- ec0704b3b8d380f05f93076ca16da6c5701fe4bc diff --cc metaeditor/.gitignore index 0000000,0000000..b28cd46 new file mode 100644 --- /dev/null +++ b/metaeditor/.gitignore @@@ -1,0 -1,0 +1,1 @@@ ++ed diff --cc metaeditor/EditorExt.dcl index 0000000,0000000..af074d1 new file mode 100644 --- /dev/null +++ b/metaeditor/EditorExt.dcl @@@ -1,0 -1,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 --cc metaeditor/EditorExt.icl index 0000000,0000000..4512ae0 new file mode 100644 --- /dev/null +++ b/metaeditor/EditorExt.icl @@@ -1,0 -1,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 --cc metaeditor/MetaType.dcl index 0000000,0000000..7f85458 new file mode 100644 --- /dev/null +++ b/metaeditor/MetaType.dcl @@@ -1,0 -1,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 --cc metaeditor/MetaType.icl index 0000000,0000000..4d891b9 new file mode 100644 --- /dev/null +++ b/metaeditor/MetaType.icl @@@ -1,0 -1,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 --cc metaeditor/ed.icl index 0000000,0000000..a7835c2 new file mode 100644 --- /dev/null +++ b/metaeditor/ed.icl @@@ -1,0 -1,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