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
17 import iTasks.UI.Editor
18 import iTasks.UI.Editor.Containers
19 import iTasks.UI.Editor.Controls
20 import iTasks.UI.Editor.Generic
21 import iTasks.UI.Editor.Common
22 import iTasks.UI.Editor.Modifiers
28 derive class iTask MetaType
31 derive JSONEncode MetaInst
32 derive JSONDecode MetaInst
33 gDefault{|MetaInst|} = trace "Unable to derive a default value for MetaInst without the MetaType" IVoid
34 gEditor{|MetaInst|} = trace "Unable to derive an editor for MetaInst without the MetaType" emptyEditor
36 instance toString MetaType
39 toString MReal = "Real"
40 toString MBool = "Bool"
41 toString MChar = "Char"
42 toString MVoid = "Void"
43 toString (MPoint p) = "(Pointer " +++ toString p +++ ")"
44 toString (MRecord m) = "{" +++ join "," [
45 k +++ "::" +++ toString v\\(k,v)<-m] +++ "}"
46 toString (MADT m) = join " | " [
47 k +++ " " +++ join " " (map toString v)\\(k,v)<-m]
48 toString MThis = "This"
50 instance fromString MetaType
54 typeToInst :: MetaType -> MetaInst
55 typeToInst m = typeToInst` m
57 typeToInst` :: MetaType -> MetaInst
58 typeToInst` MInt = IInt 0
59 typeToInst` MReal = IReal 0.0
60 typeToInst` MBool = IBool False
61 typeToInst` MChar = IChar ' '
62 typeToInst` MVoid = IVoid
63 typeToInst` MThis = typeToInst m
64 typeToInst` (MPoint _) = IPoint ""
65 typeToInst` (MRecord fs) = IRecord $ map (typeToInst` o snd) fs
66 typeToInst` (MADT []) = IADT -1 []
67 typeToInst` (MADT [(c, fs):_]) = IADT 0 $ map typeToInst` fs
69 typeToEditor :: MetaType -> Editor MetaInst
70 typeToEditor x = typeToEditor` x
72 typeToEditor` :: MetaType -> Editor MetaInst
73 typeToEditor` MInt = bijectEditorValue (\(IInt i) ->i) IInt integerField
74 typeToEditor` MReal = bijectEditorValue (\(IReal i)->i) IReal decimalField
75 typeToEditor` MBool = bijectEditorValue (\(IBool i)->i) IBool checkBox
76 typeToEditor` MChar = bijectEditorValue (\(IChar i)->i) IChar gEditor{|*|}
77 typeToEditor` MVoid = bijectEditorValue (\_->()) (\_->IVoid) emptyEditor
78 typeToEditor` (MPoint _) = bijectEditorValue (\(IPoint i)->i) IPoint gEditor{|*|}
79 typeToEditor` MThis = typeToEditor x
80 typeToEditor` (MRecord fs) =
81 bijectEditorValue (\(IRecord i)->i) IRecord
82 $ containerL [row k (typeToEditor` v)\\(k, v)<-fs]
83 typeToEditor` (MADT []) = emptyEditor
84 typeToEditor` (MADT [(k, v)]) = bijectEditorValue (\(IADT 0 m)->m) (IADT 0)
85 $ row k (containerL (map typeToEditor` v) <<@ directionAttr Horizontal)
86 typeToEditor` (MADT kvs) = bijectEditorValue (\(IADT i m)->(i, m)) (uncurry IADT)
88 (chooseWithDropdown [k\\(k,_)<-kvs])
90 , containerL (map typeToEditor` v) <<@ directionAttr Horizontal
92 typeToEditor` x = abort $ "Nomatch: " +++ toString x
94 enterValueOfType :: MetaType -> Task MetaInst
95 enterValueOfType mt = enterValueOfType` mt
97 enterValueOfType` MInt = enterInformation () [] @ IInt
98 enterValueOfType` MReal = enterInformation () [] @ IReal
99 enterValueOfType` MBool = enterInformation () [] @ IBool
100 enterValueOfType` MChar = enterInformation () [] @ IChar
101 enterValueOfType` MVoid = return IVoid
102 enterValueOfType` MThis = enterValueOfType` mt
103 enterValueOfType` (MPoint _) = enterInformation () [] @ IPoint
104 enterValueOfType` (MRecord fs)
105 = allTasks [enterValueOfType` v <<@ Title k\\(k,v)<-fs]
106 >>* [OnAction (Action "Continue") $ ifValue (\v->length v == length fs) $ return o IRecord]
107 enterValueOfType` (MADT kvs)
108 = enterChoice "Cons" [ChooseFromDropdown (fst o fst)] (zip2 kvs [0..])
109 >&> \sh->whileUnchanged sh \mc->case mc of
110 Nothing = viewInformation () [] () @! IVoid
112 = allTasks (map enterValueOfType` vs) <<@ Title k @ IADT i
114 row :: String (Editor a) -> Editor a
115 row l e = bijectEditorValue (tuple l) snd $
116 container2 label e <<@ directionAttr Horizontal
118 parse :: MetaType [Char] -> Either String (MetaInst, [Char])
119 parse t cs = parse` t t cs
121 parse` t MVoid cs = Right (IVoid, cs)
122 parse` t MInt cs = case parseInt cs of
123 (i, []) = Right (IInt i, cs)
124 (i, [' ':cs]) = Right (IInt i, cs)
125 _ = Left "Integer must end with a space"
126 parse` t MReal cs = Right $ appFst IReal (parseReal cs)
127 parse` t MBool [c:cs]
128 | c == '0' || c == '1' = Right (IBool (c == '1'), cs)
129 = Left "Bool must be encoded as 0 or 1"
130 parse` t MChar [c:cs] = Right (IChar c, cs)
131 parse` t (MPoint _) ['\0':cs] = Right (IPoint "", cs)
132 parse` t p=:(MPoint _) [c:cs] = case parse p cs of
134 Right (IPoint ss, cs) = Right (IPoint (toString c +++ ss), cs)
135 parse` t MThis c = parse t c
136 parse` t (MRecord fs) cs = undef
137 parse` t (MADT cons) cs = case parse MInt cs of
139 | c < 0 || c > length cons = Left $ "Not a valid cons identifier: " +++ toString c
140 = appFst (IADT c) <$> plist t (snd $ cons !! c) cs
142 parse` t _ [] = Left "Empty input"
143 parse` t` t _ = Left $ "Undef: " +++ toString t` +++ " , " +++ toString t
145 plist t [] cs = Right ([], cs)
146 plist t [a:as] cs = case parse` t a cs of
148 Right (a, cs) = case plist t as cs of
150 Right (as, cs) = Right ([a:as], cs)
152 parseInt :: [Char] -> (Int, [Char])
153 parseInt [c:cs] = appFst ((*) -1) $ int cs
156 int = appFst (toInt o toString) o span isDigit
158 parseReal :: [Char] -> (Real, [Char])
159 parseReal cs = (0.0, cs)
161 print :: MetaInst -> String
162 print i = trim $ print` i
165 print` (IInt i) = toString i +++ " "
166 print` (IReal i) = toString i +++ " "
167 print` (IBool i) = if i "1" "0"
168 print` (IChar i) = toString i
169 print` (IPoint i) = i +++ "\0"
170 print` (IRecord fs) = concat $ map print fs
171 print` (IADT i cs) = concat [toString i," ":map print cs]