1 implementation module MetaType
3 from StdFunc import o, flip
4 from Data.Func import $
6 import StdOverloaded, StdString, StdList, StdMisc, StdTuple, StdBool
10 //import Control.Applicative
16 import iTasks.UI.Editor
17 import iTasks.UI.Editor.Containers
18 import iTasks.UI.Editor.Controls
19 import iTasks.UI.Editor.Generic
20 import iTasks.UI.Editor.Common
21 import iTasks.UI.Editor.Modifiers
27 derive class iTask MetaType
30 derive JSONEncode MetaInst
31 derive JSONDecode MetaInst
32 gDefault{|MetaInst|} = trace "Unable to derive a default value for MetaInst without the MetaType" IVoid
33 gEditor{|MetaInst|} = trace "Unable to derive an editor for MetaInst without the MetaType" emptyEditor
35 instance toString MetaType
38 toString MReal = "Real"
39 toString MBool = "Bool"
40 toString MChar = "Char"
41 toString MVoid = "Void"
42 toString (MPoint p) = "(Pointer " +++ toString p +++ ")"
43 toString (MRecord m) = "{" +++ join "," [
44 k +++ "::" +++ toString v\\(k,v)<-m] +++ "}"
45 toString (MADT m) = join " | " [
46 k +++ " " +++ join " " (map toString v)\\(k,v)<-m]
47 toString MThis = "This"
49 instance fromString MetaType
53 typeToInst :: MetaType -> MetaInst
54 typeToInst m = typeToInst` m
56 typeToInst` :: MetaType -> MetaInst
57 typeToInst` MInt = IInt 0
58 typeToInst` MReal = IReal 0.0
59 typeToInst` MBool = IBool False
60 typeToInst` MChar = IChar ' '
61 typeToInst` MVoid = IVoid
62 typeToInst` MThis = typeToInst m
63 typeToInst` (MPoint _) = IPoint ""
64 typeToInst` (MRecord fs) = IRecord $ map (typeToInst` o snd) fs
65 typeToInst` (MADT []) = IADT -1 []
66 typeToInst` (MADT [(c, fs):_]) = IADT 0 $ map typeToInst` fs
68 typeToEditor :: MetaType -> Editor MetaInst
69 typeToEditor x = typeToEditor` x
71 typeToEditor` :: MetaType -> Editor MetaInst
72 typeToEditor` MInt = bijectEditorValue (\(IInt i) ->i) IInt integerField
73 typeToEditor` MReal = bijectEditorValue (\(IReal i)->i) IReal decimalField
74 typeToEditor` MBool = bijectEditorValue (\(IBool i)->i) IBool checkBox
75 typeToEditor` MChar = bijectEditorValue (\(IChar i)->i) IChar gEditor{|*|}
76 typeToEditor` MVoid = bijectEditorValue (\_->()) (\_->IVoid) emptyEditor
77 typeToEditor` (MPoint _) = bijectEditorValue (\(IPoint i)->i) IPoint gEditor{|*|}
78 typeToEditor` MThis = typeToEditor x
79 typeToEditor` (MRecord fs) =
80 bijectEditorValue (\(IRecord i)->i) IRecord
81 $ containerL [row k (typeToEditor` v)\\(k, v)<-fs]
82 typeToEditor` (MADT []) = emptyEditor
83 typeToEditor` (MADT [(k, v)]) = bijectEditorValue (\(IADT 0 m)->m) (IADT 0)
84 $ row k (containerL (map typeToEditor` v) <<@ directionAttr Horizontal)
85 typeToEditor` (MADT kvs) = abort "blurp"/*bijectEditorValue (\(IADT i m)->(i, m)) (uncurry IADT)
86 $ choose [(k, containerL (map typeToEditor` v) <<@ directionAttr Horizontal)\\(k,v)<-kvs]*/
87 typeToEditor` x = abort $ "Nomatch: " +++ toString x
89 enterValueOfType :: MetaType -> Task MetaInst
90 enterValueOfType mt = enterValueOfType` mt
92 enterValueOfType` MInt = enterInformation () [] @ IInt
93 enterValueOfType` MReal = enterInformation () [] @ IReal
94 enterValueOfType` MBool = enterInformation () [] @ IBool
95 enterValueOfType` MChar = enterInformation () [] @ IChar
96 enterValueOfType` MVoid = return IVoid
97 enterValueOfType` MThis = enterValueOfType` mt
98 enterValueOfType` (MPoint _) = enterInformation () [] @ IPoint
99 enterValueOfType` (MRecord fs)
100 = allTasks [enterValueOfType` v <<@ Title k\\(k,v)<-fs]
101 >>* [OnAction (Action "Continue") $ ifValue (\v->length v == length fs) $ return o IRecord]
102 enterValueOfType` (MADT kvs)
103 = enterChoice "Cons" [ChooseFromDropdown (fst o fst)] (zip2 kvs [0..])
104 >&> \sh->whileUnchanged sh \mc->case mc of
105 Nothing = viewInformation () [] () @! IVoid
107 = allTasks (map enterValueOfType` vs) <<@ Title k @ IADT i
109 row :: String (Editor a) -> Editor a
110 row l e = bijectEditorValue (tuple l) snd $
111 container2 label e <<@ directionAttr Horizontal
113 parse :: MetaType [Char] -> Either String (MetaInst, [Char])
114 parse t cs = parse` t t cs
116 parse` t MVoid cs = Right (IVoid, cs)
117 parse` t MInt cs = case parseInt cs of
118 (i, []) = Right (IInt i, cs)
119 (i, [' ':cs]) = Right (IInt i, cs)
120 _ = Left "Integer must end with a space"
121 parse` t MReal cs = Right $ appFst IReal (parseReal cs)
122 parse` t MBool [c:cs]
123 | c == '0' || c == '1' = Right (IBool (c == '1'), cs)
124 = Left "Bool must be encoded as 0 or 1"
125 parse` t MChar [c:cs] = Right (IChar c, cs)
126 parse` t (MPoint _) ['\0':cs] = Right (IPoint "", cs)
127 parse` t p=:(MPoint _) [c:cs] = case parse p cs of
129 Right (IPoint ss, cs) = Right (IPoint (toString c +++ ss), cs)
130 parse` t MThis c = parse t c
131 parse` t (MRecord fs) cs = undef
132 parse` t (MADT cons) cs = case parse MInt cs of
134 | c < 0 || c > length cons = Left $ "Not a valid cons identifier: " +++ toString c
135 = appFst (IADT c) <$> plist t (snd $ cons !! c) cs
137 parse` t _ [] = Left "Empty input"
138 parse` t` t _ = Left $ "Undef: " +++ toString t` +++ " , " +++ toString t
140 plist t [] cs = Right ([], cs)
141 plist t [a:as] cs = case parse` t a cs of
143 Right (a, cs) = case plist t as cs of
145 Right (as, cs) = Right ([a:as], cs)
147 parseInt :: [Char] -> (Int, [Char])
148 parseInt [c:cs] = appFst ((*) -1) $ int cs
151 int = appFst (toInt o toString) o span isDigit
153 parseReal :: [Char] -> (Real, [Char])
154 parseReal cs = (0.0, cs)
156 print :: MetaInst -> String
157 print i = trim $ print` i
160 print` (IInt i) = toString i +++ " "
161 print` (IReal i) = toString i +++ " "
162 print` (IBool i) = if i "1" "0"
163 print` (IChar i) = toString i
164 print` (IPoint i) = i +++ "\0"
165 print` (IRecord fs) = concat $ map print fs
166 print` (IADT i cs) = concat [toString i," ":map print cs]