+++ /dev/null
-implementation module MetaType
-
-from StdFunc import o, flip
-from Data.Func import $
-
-import StdOverloaded, StdString, StdList, StdMisc, StdTuple, StdBool
-import StdGeneric
-
-//import Control.Monad
-//import Control.Applicative
-import Data.Functor
-import Data.Tuple
-import Data.Either
-import Data.List
-import Data.Maybe
-import iTasks
-import iTasks.UI.Editor
-import iTasks.UI.Editor.Containers
-import iTasks.UI.Editor.Controls
-import iTasks.UI.Editor.Generic
-import iTasks.UI.Editor.Common
-import iTasks.UI.Editor.Modifiers
-import Text.GenJSON
-import Text
-
-import StdDebug
-
-derive class iTask MetaType
-derive gEq MetaInst
-derive gText MetaInst
-derive JSONEncode MetaInst
-derive JSONDecode MetaInst
-gDefault{|MetaInst|} = trace "Unable to derive a default value for MetaInst without the MetaType" IVoid
-gEditor{|MetaInst|} = trace "Unable to derive an editor for MetaInst without the MetaType" emptyEditor
-
-instance toString MetaType
-where
- toString MInt = "Int"
- toString MReal = "Real"
- toString MBool = "Bool"
- toString MChar = "Char"
- toString MVoid = "Void"
- toString (MPoint p) = "(Pointer " +++ toString p +++ ")"
- toString (MRecord m) = "{" +++ join "," [
- k +++ "::" +++ toString v\\(k,v)<-m] +++ "}"
- toString (MADT m) = join " | " [
- k +++ " " +++ join " " (map toString v)\\(k,v)<-m]
- toString MThis = "This"
-
-instance fromString MetaType
-where
- fromString x = MInt
-
-typeToInst :: MetaType -> MetaInst
-typeToInst m = typeToInst` m
-where
- typeToInst` :: MetaType -> MetaInst
- typeToInst` MInt = IInt 0
- typeToInst` MReal = IReal 0.0
- typeToInst` MBool = IBool False
- typeToInst` MChar = IChar ' '
- typeToInst` MVoid = IVoid
- typeToInst` MThis = typeToInst m
- typeToInst` (MPoint _) = IPoint ""
- typeToInst` (MRecord fs) = IRecord $ map (typeToInst` o snd) fs
- typeToInst` (MADT []) = IADT -1 []
- typeToInst` (MADT [(c, fs):_]) = IADT 0 $ map typeToInst` fs
-
-typeToEditor :: MetaType -> Editor MetaInst
-typeToEditor x = typeToEditor` x
-where
- typeToEditor` :: MetaType -> Editor MetaInst
- typeToEditor` MInt = bijectEditorValue (\(IInt i) ->i) IInt integerField
- typeToEditor` MReal = bijectEditorValue (\(IReal i)->i) IReal decimalField
- typeToEditor` MBool = bijectEditorValue (\(IBool i)->i) IBool checkBox
- typeToEditor` MChar = bijectEditorValue (\(IChar i)->i) IChar gEditor{|*|}
- typeToEditor` MVoid = bijectEditorValue (\_->()) (\_->IVoid) emptyEditor
- typeToEditor` (MPoint _) = bijectEditorValue (\(IPoint i)->i) IPoint gEditor{|*|}
- typeToEditor` MThis = typeToEditor x
- typeToEditor` (MRecord fs) =
- bijectEditorValue (\(IRecord i)->i) IRecord
- $ containerL [row k (typeToEditor` v)\\(k, v)<-fs]
- typeToEditor` (MADT []) = emptyEditor
- typeToEditor` (MADT [(k, v)]) = bijectEditorValue (\(IADT 0 m)->m) (IADT 0)
- $ row k (containerL (map typeToEditor` v) <<@ directionAttr Horizontal)
- typeToEditor` (MADT kvs) = bijectEditorValue (\(IADT i m)->(i, m)) (uncurry IADT)
- $ containerc
- (chooseWithDropdown [k\\(k,_)<-kvs])
- [(maybe undef id
- , containerL (map typeToEditor` v) <<@ directionAttr Horizontal
- )\\(k,v)<-kvs]
- typeToEditor` x = abort $ "Nomatch: " +++ toString x
-
-enterValueOfType :: MetaType -> Task MetaInst
-enterValueOfType mt = enterValueOfType` mt
-where
- enterValueOfType` MInt = enterInformation () [] @ IInt
- enterValueOfType` MReal = enterInformation () [] @ IReal
- enterValueOfType` MBool = enterInformation () [] @ IBool
- enterValueOfType` MChar = enterInformation () [] @ IChar
- enterValueOfType` MVoid = return IVoid
- enterValueOfType` MThis = enterValueOfType` mt
- enterValueOfType` (MPoint _) = enterInformation () [] @ IPoint
- enterValueOfType` (MRecord fs)
- = allTasks [enterValueOfType` v <<@ Title k\\(k,v)<-fs]
- >>* [OnAction (Action "Continue") $ ifValue (\v->length v == length fs) $ return o IRecord]
- enterValueOfType` (MADT kvs)
- = enterChoice "Cons" [ChooseFromDropdown (fst o fst)] (zip2 kvs [0..])
- >&> \sh->whileUnchanged sh \mc->case mc of
- Nothing = viewInformation () [] () @! IVoid
- Just ((k, vs), i)
- = allTasks (map enterValueOfType` vs) <<@ Title k @ IADT i
-
-row :: String (Editor a) -> Editor a
-row l e = bijectEditorValue (tuple l) snd $
- container2 label e <<@ directionAttr Horizontal
-
-parse :: MetaType [Char] -> Either String (MetaInst, [Char])
-parse t cs = parse` t t cs
-where
- parse` t MVoid cs = Right (IVoid, cs)
- parse` t MInt cs = case parseInt cs of
- (i, []) = Right (IInt i, cs)
- (i, [' ':cs]) = Right (IInt i, cs)
- _ = Left "Integer must end with a space"
- parse` t MReal cs = Right $ appFst IReal (parseReal cs)
- parse` t MBool [c:cs]
- | c == '0' || c == '1' = Right (IBool (c == '1'), cs)
- = Left "Bool must be encoded as 0 or 1"
- parse` t MChar [c:cs] = Right (IChar c, cs)
- parse` t (MPoint _) ['\0':cs] = Right (IPoint "", cs)
- parse` t p=:(MPoint _) [c:cs] = case parse p cs of
- Left e = Left e
- Right (IPoint ss, cs) = Right (IPoint (toString c +++ ss), cs)
- parse` t MThis c = parse t c
- parse` t (MRecord fs) cs = undef
- parse` t (MADT cons) cs = case parse MInt cs of
- Right (IInt c, cs)
- | c < 0 || c > length cons = Left $ "Not a valid cons identifier: " +++ toString c
- = appFst (IADT c) <$> plist t (snd $ cons !! c) cs
- Left e = Left e
- parse` t _ [] = Left "Empty input"
- parse` t` t _ = Left $ "Undef: " +++ toString t` +++ " , " +++ toString t
-
- plist t [] cs = Right ([], cs)
- plist t [a:as] cs = case parse` t a cs of
- Left e = Left e
- Right (a, cs) = case plist t as cs of
- Left e = Left e
- Right (as, cs) = Right ([a:as], cs)
-
- parseInt :: [Char] -> (Int, [Char])
- parseInt [c:cs] = appFst ((*) -1) $ int cs
- parseInt cs = int cs
-
- int = appFst (toInt o toString) o span isDigit
-
- parseReal :: [Char] -> (Real, [Char])
- parseReal cs = (0.0, cs)
-
-print :: MetaInst -> String
-print i = trim $ print` i
-where
- print` IVoid = ""
- print` (IInt i) = toString i +++ " "
- print` (IReal i) = toString i +++ " "
- print` (IBool i) = if i "1" "0"
- print` (IChar i) = toString i
- print` (IPoint i) = i +++ "\0"
- print` (IRecord fs) = concat $ map print fs
- print` (IADT i cs) = concat [toString i," ":map print cs]
repositories / clean-tests.git / blobdiff