metaeditor/MetaType.icl

   1 implementation module MetaType
   2
   3 from StdFunc import o, flip
   4 from Data.Func import $
   5
   6 import StdOverloaded, StdString, StdList, StdMisc, StdTuple, StdBool
   7 import StdGeneric
   8
   9 //import Control.Monad
  10 //import Control.Applicative
  11 import Data.Functor
  12 import Data.Tuple
  13 import Data.Either
  14 import Data.List
  15 import iTasks
  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
  22 import Text.GenJSON
  23 import Text
  24
  25 import StdDebug
  26
  27 derive class iTask MetaType
  28 derive gEq MetaInst
  29 derive gText MetaInst
  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
  34
  35 instance toString MetaType
  36 where
  37         toString MInt = "Int"
  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"
  48
  49 instance fromString MetaType
  50 where
  51         fromString x = MInt
  52
  53 typeToInst :: MetaType -> MetaInst
  54 typeToInst m = typeToInst` m
  55 where
  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
  67
  68 typeToEditor :: MetaType -> Editor MetaInst
  69 typeToEditor x = typeToEditor` x
  70 where
  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
  88
  89 enterValueOfType :: MetaType -> Task MetaInst
  90 enterValueOfType mt = enterValueOfType` mt
  91 where
  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
 106                         Just ((k, vs), i)
 107                                 = allTasks (map enterValueOfType` vs) <<@ Title k @ IADT i
 108
 109 row :: String (Editor a) -> Editor a
 110 row l e = bijectEditorValue (tuple l) snd $
 111         container2 label e <<@ directionAttr Horizontal
 112
 113 parse :: MetaType [Char] -> Either String (MetaInst, [Char])
 114 parse t cs = parse` t t cs
 115 where
 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
 128                 Left e = Left e
 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
 133                         Right (IInt c, cs)
 134                                 | c < 0 || c > length cons = Left $ "Not a valid cons identifier: " +++ toString c
 135                                 = appFst (IADT c) <$> plist t (snd $ cons !! c) cs
 136                         Left e = Left e
 137         parse` t _ [] = Left "Empty input"
 138         parse` t` t _ = Left $ "Undef: " +++ toString t` +++ " , " +++ toString t
 139
 140         plist t [] cs = Right ([], cs)
 141         plist t [a:as] cs = case parse` t a cs of
 142                 Left e = Left e
 143                 Right (a, cs) = case plist t as cs of
 144                         Left e = Left e
 145                         Right (as, cs) = Right ([a:as], cs)
 146
 147         parseInt :: [Char] -> (Int, [Char])
 148         parseInt [c:cs] = appFst ((*) -1) $ int cs
 149         parseInt cs = int cs
 150
 151         int = appFst (toInt o toString) o span isDigit
 152
 153         parseReal :: [Char] -> (Real, [Char])
 154         parseReal cs = (0.0, cs)
 155
 156 print :: MetaInst -> String
 157 print i = trim $ print` i
 158 where
 159         print` IVoid = ""
 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]