--- /dev/null
--- /dev/null
++ed
--- /dev/null
--- /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
--- /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
--- /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
--- /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
--- /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