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]