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 Data.Maybe
  16 import iTasks
  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
  23 import Text.GenJSON
  24 import Text
  25
  26 import StdDebug
  27
  28 derive class iTask MetaType
  29 derive gEq MetaInst
  30 derive gText MetaInst
  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
  35
  36 instance toString MetaType
  37 where
  38         toString MInt = "Int"
  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"
  49
  50 instance fromString MetaType
  51 where
  52         fromString x = MInt
  53
  54 typeToInst :: MetaType -> MetaInst
  55 typeToInst m = typeToInst` m
  56 where
  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
  68
  69 typeToEditor :: MetaType -> Editor MetaInst
  70 typeToEditor x = typeToEditor` x
  71 where
  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)
  87                 $ containerc
  88                         (chooseWithDropdown [k\\(k,_)<-kvs])
  89                         [(maybe undef id
  90                         , containerL (map typeToEditor` v) <<@ directionAttr Horizontal
  91                         )\\(k,v)<-kvs]
  92         typeToEditor` x = abort $ "Nomatch: " +++ toString x
  93
  94 enterValueOfType :: MetaType -> Task MetaInst
  95 enterValueOfType mt = enterValueOfType` mt
  96 where
  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
 111                         Just ((k, vs), i)
 112                                 = allTasks (map enterValueOfType` vs) <<@ Title k @ IADT i
 113
 114 row :: String (Editor a) -> Editor a
 115 row l e = bijectEditorValue (tuple l) snd $
 116         container2 label e <<@ directionAttr Horizontal
 117
 118 parse :: MetaType [Char] -> Either String (MetaInst, [Char])
 119 parse t cs = parse` t t cs
 120 where
 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
 133                 Left e = Left e
 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
 138                         Right (IInt c, cs)
 139                                 | c < 0 || c > length cons = Left $ "Not a valid cons identifier: " +++ toString c
 140                                 = appFst (IADT c) <$> plist t (snd $ cons !! c) cs
 141                         Left e = Left e
 142         parse` t _ [] = Left "Empty input"
 143         parse` t` t _ = Left $ "Undef: " +++ toString t` +++ " , " +++ toString t
 144
 145         plist t [] cs = Right ([], cs)
 146         plist t [a:as] cs = case parse` t a cs of
 147                 Left e = Left e
 148                 Right (a, cs) = case plist t as cs of
 149                         Left e = Left e
 150                         Right (as, cs) = Right ([a:as], cs)
 151
 152         parseInt :: [Char] -> (Int, [Char])
 153         parseInt [c:cs] = appFst ((*) -1) $ int cs
 154         parseInt cs = int cs
 155
 156         int = appFst (toInt o toString) o span isDigit
 157
 158         parseReal :: [Char] -> (Real, [Char])
 159         parseReal cs = (0.0, cs)
 160
 161 print :: MetaInst -> String
 162 print i = trim $ print` i
 163 where
 164         print` IVoid = ""
 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]