module DynEditorExample import StdEnv import Data.Func import Data.Functor import Text import iTasks import iTasks.Extensions.Editors.DynamicEditor // Synonyms //////////////////////////////////////////////////////////////////// :: List a :== [a] // Main //////////////////////////////////////////////////////////////////////// Start world = doTasks editTask world editTask = forever ( enterInformation ("Contruct a task", info1) [EnterUsing id $ dynamicEditor taskEditor] >>= \v -> viewInformation ("Evaluate the task", info2) [] () ||- (evalTaskConstExpr (toValue taskEditor v) <<@ ApplyLayout frameCompact) >>= viewInformation ("Done!", info3) [] >>= return ) where info1 :: String info1 = "Select the editors and combinators you'd like to use. When you're ready, push the 'Continue' button below to run your program." info2 :: String info2 = "Now step through the task you just created to test it." info3 :: String info3 = "The program is done, the result is given below." // Data //////////////////////////////////////////////////////////////////////// :: TaskExpr = Done Expr // | Apply TaskFuncExpr Expr | EnterInfo String Ty | Then TaskExpr TaskFuncExpr | Or TaskExpr TaskExpr | And TaskExpr TaskExpr | When TaskExpr (List TaskContExpr) :: TaskFuncExpr = ViewInfo String | UpdateInfo String :: TaskContExpr = { name :: String, pred :: FuncExpr, cont :: TaskFuncExpr} :: Expr = Int Int | Bool Bool | String String | Tuple Expr Expr | Fst Expr | Snd Expr | Eq Expr Expr :: Value = VInt Int | VBool Bool | VString String | VTuple Value Value :: FuncExpr = EqV Value | GrtV Value | LessV Value :: Ty = E.a: Ty (a -> Value) & iTask a :: Typed a b =: Typed a derive class iTask TaskExpr, TaskFuncExpr, TaskContExpr, Expr, FuncExpr, Value, Typed // These instances cannot be auto derived because of the existential quantifier. // However, they will be never used, so we make them undefined. gDefault{|Ty|} = undef gEq{|Ty|} _ _ = undef JSONEncode{|Ty|} _ _ = undef JSONDecode{|Ty|} _ _ = undef gText{|Ty|} _ _ = undef gEditor{|Ty|} = undef // Editor ////////////////////////////////////////////////////////////////////// taskEditor :: DynamicEditor TaskExpr taskEditor = DynamicEditor conses where conses = [ // This cons is used to provide untyped `TaskExpr` values. DynamicCons $ functionConsDyn "TaskExpr" "(enter task)" (dynamic \(Typed taskExpr) -> taskExpr :: A.a: (Typed TaskExpr a) -> TaskExpr) <<@@@ HideIfOnlyChoice , DynamicConsGroup "Combinators" [ functionConsDyn "Done" "done" ( dynamic \(Typed expr) -> Typed (Done expr) :: A.a: (Typed Expr a) -> Typed TaskExpr (Task a) ) , functionConsDyn "Then" "sequence" ( dynamic \(Typed task) (Typed taskFunc) -> Typed (Then task taskFunc) :: A.a b: (Typed TaskExpr (Task a)) (Typed TaskFuncExpr (a -> Task b)) -> Typed TaskExpr (Task b) ) , functionConsDyn "When" "guarded sequence" ( dynamic \(Typed task1) (Typed steps) -> Typed (When task1 steps) :: // Typed (When task1 [(expr, pred, tfExpr) \\ (Typed expr, pred, Typed tfExpr) <- steps]) :: A.a b: (Typed TaskExpr (Task a)) (Typed (List TaskContExpr) (a -> Task b)) // (Typed (List (Typed FuncExpr (a -> Bool), String, Typed TaskFuncExpr (a -> Task a))) (a -> Task b)) -> Typed TaskExpr (Task b) ) <<@@@ applyHorizontalClasses , functionConsDyn "Or" "or" ( dynamic \(Typed task1) (Typed task2) -> Typed (Or task1 task2) :: A.a b: (Typed TaskExpr (Task a)) (Typed TaskExpr (Task a)) -> Typed TaskExpr (Task a) ) <<@@@ applyHorizontalClasses , functionConsDyn "And" "and" ( dynamic \(Typed task1) (Typed task2) -> Typed (And task1 task2) :: A.a b: (Typed TaskExpr (Task a)) (Typed TaskExpr (Task b)) -> Typed TaskExpr (Task (a, b)) ) <<@@@ applyHorizontalClasses , listConsDyn "List TaskContExpr" "continuations" ( dynamic \typedSteps -> Typed ((\(Typed expr) -> expr) <$> typedSteps) :: A.a b: (List (Typed TaskContExpr (a -> Task b))) -> Typed (List TaskContExpr) (a -> Task b) ) <<@@@ HideIfOnlyChoice , functionConsDyn "TaskContExpr" "continuation" ( dynamic \s (Typed func) (Typed taskFunc) -> Typed {name = s, pred = func, cont = taskFunc} :: A.a b: String (Typed FuncExpr a) (Typed TaskFuncExpr (a -> Task b)) -> Typed TaskContExpr (a -> Task b) ) <<@@@ HideIfOnlyChoice <<@@@ AddLabels [Just "name", Just "predicate", Just "continuation"] ] , DynamicConsGroup "Editors" // [ functionConsDyn "Apply" "apply" // ( dynamic \(Typed taskFunc) (Typed expr) -> // Typed (Apply taskFunc expr) :: // A.a b: // (Typed TaskFuncExpr (a -> Task b)) // (Typed Expr a) // -> Typed TaskExpr (Task b) // ) [ functionConsDyn "EnterInfo" "enter information" ( dynamic \s (Typed ty) -> Typed (EnterInfo s ty) :: A.a: String (Typed Ty a) -> Typed TaskExpr (Task a) ) <<@@@ applyHorizontalClasses , functionConsDyn "ViewInfo" "view information" ( dynamic \s -> Typed (ViewInfo s) :: A.a: String -> Typed TaskFuncExpr (a -> Task a) ) <<@@@ applyHorizontalClasses , functionConsDyn "UpdateInfo" "update information" ( dynamic \s -> Typed (UpdateInfo s) :: A.a: String -> Typed TaskFuncExpr (a -> Task a) ) <<@@@ applyHorizontalClasses ] // ordinary (non-task) expressions , DynamicCons $ functionConsDyn "EqV" "equal" (dynamic \i -> Typed (EqV (VInt i)) :: Int -> Typed FuncExpr Int) <<@@@ applyHorizontalClasses , DynamicCons $ functionConsDyn "GrtV" "greater" (dynamic \i -> Typed (GrtV (VInt i)) :: Int -> Typed FuncExpr Int) <<@@@ applyHorizontalClasses , DynamicCons $ functionConsDyn "LessV" "less" (dynamic \i -> Typed (LessV (VInt i)) :: Int -> Typed FuncExpr Int) <<@@@ applyHorizontalClasses , DynamicCons $ functionConsDyn "int" "enter an integer:" (dynamic \i -> Typed (Int i) :: Int -> Typed Expr Int) , DynamicCons $ functionConsDyn "bool" "enter a boolean:" (dynamic \b -> Typed (Bool b) :: Bool -> Typed Expr Bool) , DynamicCons $ functionConsDyn "string" "enter a string:" (dynamic \s -> Typed (String s) :: String -> Typed Expr String) , DynamicCons $ functionConsDyn "tuple" "enter tuple:" ( dynamic \(Typed a) (Typed b) -> Typed (Tuple a b) :: A.a b: (Typed Expr a) (Typed Expr b) -> Typed Expr (a, b) ) , DynamicCons $ functionConsDyn "fst" "fst" (dynamic \(Typed (Tuple a _)) -> Typed a :: A.a b: (Typed Expr (a, b)) -> Typed Expr a) <<@@@ applyHorizontalClasses , DynamicCons $ functionConsDyn "snd" "snd" (dynamic \(Typed (Tuple _ b)) -> Typed b :: A.a b: (Typed Expr (a, b)) -> Typed Expr b) <<@@@ applyHorizontalClasses , DynamicCons $ functionConsDyn "==" "==" ( dynamic \(Typed a) (Typed b) -> Typed (Eq a b) :: A.a: (Typed Expr a) (Typed Expr a) -> Typed Expr Bool ) <<@@@ applyHorizontalClasses , DynamicCons $ customEditorCons "Int" "(enter integer)" intEditor <<@@@ HideIfOnlyChoice , DynamicCons $ customEditorCons "Bool" "(enter boolean)" boolEditor <<@@@ HideIfOnlyChoice , DynamicCons $ customEditorCons "String" "(enter string )" stringEditor <<@@@ HideIfOnlyChoice // type specifications for enterInformation , DynamicCons $ functionConsDyn "Ty.Int" "Int" (dynamic Typed (Ty VInt) :: Typed Ty Int) , DynamicCons $ functionConsDyn "Ty.Bool" "Bool" (dynamic Typed (Ty VBool) :: Typed Ty Bool) , DynamicCons $ functionConsDyn "Ty.String" "String" (dynamic Typed (Ty VString) :: Typed Ty String) , DynamicCons $ functionConsDyn "Ty.Tuple" "Tuple" ( dynamic \(Typed (Ty toValue1)) (Typed (Ty toValue2)) -> Typed (Ty \(x, y) -> VTuple (toValue1 x) (toValue2 y)) :: A.a b: (Typed Ty a) (Typed Ty b) -> Typed Ty (a, b) ) <<@@@ applyHorizontalClasses ] // Helpers // derivedType :: Typed Ty a | iTask a derivedType = case dynToValue of (toValue :: a^ -> Value | iTask a^) = Typed (Ty toValue) where dynToValue = dynamic () intEditor :: Editor Int intEditor = gEditor{|*|} boolEditor :: Editor Bool boolEditor = gEditor{|*|} stringEditor :: Editor String stringEditor = gEditor{|*|} applyHorizontalClasses = ApplyCssClasses ["itasks-horizontal", "itasks-wrap-width", "itasks-panel"] // Evaluation ////////////////////////////////////////////////////////////////// evalTaskConstExpr :: TaskExpr -> Task Value evalTaskConstExpr (Done expr) = return $ evalExpr expr evalTaskConstExpr (EnterInfo msg (Ty toValue)) = enterInformation msg [] @ toValue // evalTaskConstExpr (Apply taskFunc expr) = evalTaskFuncExpr taskFunc $ evalExpr expr evalTaskConstExpr (Then task taskFunc) = evalTaskConstExpr task >>= evalTaskFuncExpr taskFunc evalTaskConstExpr (Or task1 task2) = (evalTaskConstExpr task1 -||- evalTaskConstExpr task2 <<@ ApplyLayout arrangeHorizontal) evalTaskConstExpr (And task1 task2) = (evalTaskConstExpr task1 -&&- evalTaskConstExpr task2 <<@ ApplyLayout arrangeHorizontal) @ \(a, b) -> VTuple a b evalTaskConstExpr (When task1 options) = evalTaskConstExpr task1 >>* [ OnAction (Action name) (ifValue (test pred) (evalTaskFuncExpr cont)) \\ {name, pred, cont} <- options ] where test pred (VInt i) = case pred of LessV (VInt j) -> i < j GrtV (VInt j) -> i > j EqV (VInt j) -> i == j test pred (VBool i) = case pred of EqV (VBool j) -> i == j LessV (VBool j) -> False GrtV (VBool j) -> False evalTaskFuncExpr :: TaskFuncExpr Value -> Task Value evalTaskFuncExpr (ViewInfo p) (VInt i) = (viewInformation p [] i @ VInt) <<@ ApplyLayout arrangeHorizontal evalTaskFuncExpr (ViewInfo p) (VBool b) = (viewInformation p [] b @ VBool) <<@ ApplyLayout arrangeHorizontal evalTaskFuncExpr (ViewInfo p) (VString s) = (viewInformation p [] s @ VString) <<@ ApplyLayout arrangeHorizontal evalTaskFuncExpr (ViewInfo p) (VTuple a b) = ( viewInformation p [] () ||- evalTaskFuncExpr (ViewInfo "") a -&&- evalTaskFuncExpr (ViewInfo "") b @ \(a, b) -> VTuple a b ) <<@ ApplyLayout arrangeHorizontal evalTaskFuncExpr (UpdateInfo p) (VInt i) = (updateInformation p [] i @ VInt) <<@ ApplyLayout arrangeHorizontal evalTaskFuncExpr (UpdateInfo p) (VBool b) = (updateInformation p [] b @ VBool) <<@ ApplyLayout arrangeHorizontal evalTaskFuncExpr (UpdateInfo p) (VString s) = (updateInformation p [] s @ VString) <<@ ApplyLayout arrangeHorizontal evalTaskFuncExpr (UpdateInfo p) (VTuple a b) = ( viewInformation p [] () ||- evalTaskFuncExpr (UpdateInfo "") a -&&- evalTaskFuncExpr (UpdateInfo "") b @ \(a, b) -> VTuple a b ) <<@ ApplyLayout arrangeHorizontal evalExpr :: Expr -> Value evalExpr (Int i) = VInt i evalExpr (Bool b) = VBool b evalExpr (String s) = VString s evalExpr (Tuple fstExpr sndExpr) = VTuple (evalExpr fstExpr) (evalExpr sndExpr) evalExpr (Fst expr) = fst where (VTuple fst _) = evalExpr expr evalExpr (Snd expr) = snd where (VTuple _ snd) = evalExpr expr evalExpr (Eq expr1 expr2) = VBool $ evalExpr expr1 === evalExpr expr2