--- /dev/null
+definition module EditorExt
+
+from iTasks.UI.Editor import :: Editor
+
+row :: String (Editor a) -> Editor a
+
+choose :: [(String, Editor a)] -> Editor (Int, a)
--- /dev/null
+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)
--- /dev/null
+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
--- /dev/null
+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]
--- /dev/null
+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
repositories / clean-tests.git / commitdiff