implementation module InteractionTasks

from StdFunc import id, const, o, flip
from SystemData import null
from Tuple import appSnd
from List_NG import isMemberGen, instance Functor []
from Time import :: Timestamp(..)
from Map import qualified put
from Util import kvSet

import StdBool, StdList, StdMisc, StdTuple
import CoreTasks, CoreCombinators, CommonCombinators, LayoutCombinators, SystemData

enterInformation :: !d ![EnterOption m] -> Task m | descr d & iTask m
enterInformation d [EnterWith fromf]
/*
	= interact d null
//		(\r -> (defaultValue,defaultValue,Untouched))
		(\r -> let v = defaultValue in (fromf v,v,Untouched))
		(\l r v m ok -> if ok (fromf v,v,m) (l,v,m))
*/
	= interactNullEnter d defaultValue fromf
enterInformation d _ = enterInformation d [EnterWith id]

updateInformation :: !d ![UpdateOption m m] m -> Task m | descr d & iTask m
updateInformation d [UpdateWith tof fromf] m

	= interact d null
		(\r -> let v = tof m in (m,v,Touched))
		(\l r v m ok -> if ok (let nl = fromf l v in (let nv = tof nl in (nl,nv,m))) (l,v,m))

//THIS OPTIMIZATION IS WRONG!
//	= interactNullUpdate d tof fromf m
updateInformation d _ m = updateInformation d [UpdateWith (\l -> l) (\_ v -> v)] m

viewInformation :: !d ![ViewOption m] !m -> Task m | descr d & iTask m
viewInformation d [ViewWith tof] m
/*
	= interact d null
		(\r -> let v = Display (tof m) in (m,v,defaultMask v))
		(\l r v m ok -> (l,v,m))
*/
	= interactNullView d tof m
viewInformation d _ m = viewInformation d [ViewWith id] m

updateSharedInformation :: !d ![UpdateOption r w] !(ReadWriteShared r w) -> Task w | descr d & iTask r & iTask w
updateSharedInformation d [UpdateWith tof fromf] shared
	= interact d (toReadOnly shared)
				(\r -> let v = tof r in (fromf r v,v,Touched))
				(\l r v m ok -> if ok (if (fromf r (tof r) =!= l) (let nv = tof r in (fromf r nv,nv,Touched)) (fromf r v,v,m)) (l,v,m))
				@> (mapval,shared)
updateSharedInformation d _ shared			
	//Use dynamics to test if r == w, if so we can use an update view	
	//If different types are used we can only resort to a display of type r and an enter of type w
	= case dynamic id :: A.a: (a -> a) of
		(rtow :: (r^ -> w^))
			= interact d (toReadOnly shared)
				(\r -> let v = rtow r in (rtow r,v,Touched))
				(\l r v m ok -> if ok (if (rtow r =!= l) (let nv = rtow r in (nv,nv,Touched)) (v,v,m)) (l,v,m))
				@> (mapval,shared)
		_
			= interact d (toReadOnly shared)
				(\r -> let v = (Display r,defaultValue) in (defaultValue,v,PartiallyTouched [Touched,Untouched]))
				(\l r (_,v) (PartiallyTouched [_,m]) ok -> let nl = if ok v l in (let nv = (Display r,nl) in (nl,nv,PartiallyTouched [Touched,m])))
				@> (mapval,shared)	

mapval (Value w _) _	= Just w
mapval _ _				= Nothing

viewSharedInformation :: !d ![ViewOption r] !(ReadWriteShared r w) -> Task r | descr d & iTask r
viewSharedInformation d [ViewWith tof] shared
/*
	= interact d (toReadOnly shared)
		(\r -> let v = Display (tof r) in (r,v,defaultMask v))
		(\l r v m ok -> let v = Display (tof r) in (r,v,defaultMask v)) 
*/
	= interactSharedInformation d (toReadOnly shared) (\r -> Display (tof r))
viewSharedInformation d _ shared = viewSharedInformation d [ViewWith id] shared

updateInformationWithShared :: !d ![UpdateOption (r,m) m] !(ReadWriteShared r w) m -> Task m | descr d & iTask r & iTask m
updateInformationWithShared d [UpdateWith tof fromf] shared m
	= interact d (toReadOnly shared)
		(\r -> let v = tof (r,m) in (m,v,Touched))
		(\l r v msk ok -> let nl = if ok (fromf (r,l) v) l in (let v = tof (r,nl) in (nl,v,Touched)))
updateInformationWithShared d _ shared m
	= interact d (toReadOnly shared)
		(\r -> let v = (Display r,m) in (m,v,PartiallyTouched [Touched,Untouched]))
		(\l r (_,v) (PartiallyTouched [_,msk]) ok -> let nl = if ok v l in (let nv = (Display r,nl) in (nl,nv,PartiallyTouched [Touched,msk])))

enterChoice :: !d ![ChoiceOption o] !(container o) -> Task o | descr d & OptionContainer container & iTask o & iTask (container o)
enterChoice d options container
	= updateInformation d (choiceToUpdate options) (container,Nothing) @? res
where
	res (Value (_,Just x) s)	= Value x s
	res _						= NoValue

updateChoice :: !d ![ChoiceOption o] !(container o) o -> Task o | descr d & OptionContainer container & iTask o & iTask (container o)
updateChoice d options container sel
	= updateInformation d (choiceToUpdate options) (container,Just sel) @? res
where
	res (Value (_,Just x) s)	= Value x s
	res _						= NoValue

removeMaybeFromValue (Value (Just x) s)		= Value x s
removeMaybeFromValue _						= NoValue

enterSharedChoice :: !d ![ChoiceOption o] !(ReadWriteShared (container o) w)
					 -> Task o | descr d & OptionContainer container & iTask o & iTask w & iTask (container o)
enterSharedChoice d [] shared
	= updateInformationWithSharedChoiceNoView d shared Nothing @? removeMaybeFromValue
enterSharedChoice d options shared
//	= updateInformationWithShared d (sharedChoiceToUpdate options) shared Nothing @? removeMaybeFromValue
	= updateInformationWithSharedChoice d options shared Nothing @? removeMaybeFromValue

updateSharedChoice :: !d ![ChoiceOption o] !(ReadWriteShared (container o) w) o
					  -> Task o | descr d & OptionContainer container & iTask o & iTask w & iTask (container o)
updateSharedChoice d [] shared sel
	= updateInformationWithSharedChoiceNoView d shared (Just sel) @? removeMaybeFromValue
updateSharedChoice d options shared sel
//	= updateInformationWithShared d (sharedChoiceToUpdate options) shared (Just sel) @? removeMaybeFromValue
	= updateInformationWithSharedChoice d options shared (Just sel) @? removeMaybeFromValue

updateInformationWithSharedChoiceNoView :: d (ReadWriteShared (b c) a) (Maybe c) -> Task (Maybe c) | descr d & iTask c & iTask (b c) & OptionContainer b
updateInformationWithSharedChoiceNoView d shared m
	= interactSharedChoiceNoView d (toReadOnly shared) m toViewId
  where
	toViewId :: (container a) (Maybe a) -> DynamicChoiceNoView a | OptionContainer container & gEq{|*|},gHeaders{|*|} a
	toViewId container mbSel
		# choice = initChoiceNoView (suggestedChoiceType container) container
		= maybe choice (\sel -> selectOptionNoView sel choice) mbSel

updateInformationWithSharedChoice :: !d ![ChoiceOption c] !(ReadWriteShared (b c) a) (Maybe c) -> Task (Maybe c) | descr d & iTask c & iTask (b c) & OptionContainer b
updateInformationWithSharedChoice d [ChooseWith type view] shared m
	= interactSharedChoice d (toReadOnly shared) m (toView type view)
  where
	toView :: ChoiceType (a -> b) (c a) (Maybe a) -> DynamicChoice b a | OptionContainer c & gEq{|*|},gHeaders{|*|} a
	toView type view container mbSel
		# choice = initChoice type container view
		= case mbSel of
			Nothing -> choice
			Just sel -> selectOption sel choice

enterMultipleChoice :: !d ![MultiChoiceOption o] !(container o) -> Task [o] | descr d & OptionContainer container & iTask o & iTask (container o)
enterMultipleChoice d options container
	= updateInformation d (multiChoiceToUpdate options) (container,[]) @ snd

updateMultipleChoice :: !d ![MultiChoiceOption o] !(container o) [o] -> Task [o] | descr d & OptionContainer container & iTask o & iTask (container o)
updateMultipleChoice d options container sel
	= updateInformation d (multiChoiceToUpdate options) (container,sel) @ snd

enterSharedMultipleChoice :: !d ![MultiChoiceOption o] !(ReadWriteShared (container o) w) -> Task [o] | descr d & OptionContainer container & iTask o & iTask w & iTask (container o)
enterSharedMultipleChoice d options shared
	= updateInformationWithShared d (sharedMultiChoiceToUpdate options) shared []

updateSharedMultipleChoice :: !d ![MultiChoiceOption o] !(ReadWriteShared (container o) w) [o] -> Task [o] | descr d & OptionContainer container & iTask o & iTask w & iTask (container o)
updateSharedMultipleChoice d options shared sel 
	= updateInformationWithShared d (sharedMultiChoiceToUpdate options) shared sel

wait :: !d (r -> Bool) !(ReadWriteShared r w) -> Task r | descr d & iTask r
wait desc pred shared
	=	viewSharedInformation desc [ViewWith (const "Waiting for information update")] shared
	>>* [WhenValid pred return]
	
waitForTime :: !Time -> Task Time
waitForTime time =
	viewSharedInformation ("Wait for time", ("Wait until " +++ toString time)) [] currentTime >>* [WhenValid (\now -> time < now) return]

waitForDate :: !Date -> Task Date
waitForDate date =
	viewSharedInformation ("Wait for date", ("Wait until " +++ toString date)) [] currentDate >>* [WhenValid (\now -> date < now) return]
	
waitForDateTime :: !DateTime -> Task DateTime
waitForDateTime datetime =
	viewSharedInformation ("Wait for date and time", ("Wait until " +++ toString datetime)) [] currentDateTime >>* [WhenValid (\now -> datetime < now) return]

waitForTimer :: !Time -> Task Time
waitForTimer time = get currentTime >>= \now -> waitForTime (now + time)

chooseAction :: ![(!Action,a)] -> Task a | iTask a
chooseAction actions
	=	SetLayout hideLayout 
	@>> viewInformation "Choose an action" [] Void
	>>* [AnyTime action (\_ -> return val) \\ (action,val) <- actions]
	
instance OptionContainer []
where
	toOptionList l				= l
	toOptionTree l				= Tree (map Leaf l)
	suggestedChoiceType	l
		| not (isEmpty (headers l undef))	= ChooseFromGrid
		| length l > 7						= ChooseFromComboBox
		| otherwise							= ChooseFromRadioButtons
	where
		// unify type of list elements with type to determine headers for
		headers :: [a] a -> [String] | gHeaders{|*|} a
		headers _ a = gHeaders{|*|} a
	suggestedMultiChoiceType _	= ChooseFromCheckBoxes
	
instance OptionContainer Tree
where
	toOptionList (Tree nodes) = flatten (map toOptionList` nodes)
	where
		toOptionList` node = case node of
			Leaf option			= [option]
			Node option nodes	= [option:flatten (map toOptionList` nodes)]
	toOptionTree t = t
	suggestedChoiceType _		= ChooseFromTree
	suggestedMultiChoiceType _	= ChooseFromCheckBoxes

choiceToUpdate :: [ChoiceOption o] -> [UpdateOption (container o, Maybe o) (container o, Maybe o)] | OptionContainer container & iTask o
choiceToUpdate [ChooseWith type view] = [UpdateWith (toView type view) fromView]
where
	toView :: ChoiceType (a -> b) (c a,Maybe a) -> DynamicChoice b a | OptionContainer c & gEq{|*|},gHeaders{|*|} a
	toView type view (container,mbSel)
		= let choice = initChoice type container view in
			maybe choice (\sel -> selectOption sel choice) mbSel
	
	fromView :: (.a,.b) (c d e) -> (.a,Maybe e) | Choice c
	fromView (container,_) choice = (container,getMbSelection choice)
choiceToUpdate _ = [UpdateWith toViewId fromViewId]
where
	toViewId (container,mbSel)
		= let choice = initChoiceNoView (suggestedChoiceType container) container in
			maybe choice (\sel -> selectOptionNoView sel choice) mbSel

	fromViewId (container,_) choice = (container,getMbSelectionNoView choice)

initChoice AutoChoice 				container view = initChoice (suggestedChoiceType container) container view
initChoice ChooseFromComboBox		container view = DCCombo (ComboChoice [(view o,o) \\ o <- toOptionList container] Nothing)
initChoice ChooseFromRadioButtons	container view = DCRadio (RadioChoice [(view o,o) \\ o <- toOptionList container] Nothing)
initChoice ChooseFromTree			container view = DCTree (TreeChoice (fmap (\o -> (view o,o)) (toOptionTree container)) Nothing)
initChoice ChooseFromGrid			container view = DCGrid (GridChoice [(view o,o) \\ o <- toOptionList container] Nothing)

initChoiceNoView ChooseFromComboBox		container = DCComboNoView	(ComboChoiceNoView (toOptionList container) Nothing)
initChoiceNoView ChooseFromRadioButtons	container = DCRadioNoView	(RadioChoiceNoView (toOptionList container) Nothing)
initChoiceNoView ChooseFromTree			container = DCTreeNoView	(TreeChoiceNoView (toOptionTree container) Nothing)
initChoiceNoView ChooseFromGrid			container = DCGridNoView	(GridChoiceNoView (toOptionList container) Nothing)

/*
sharedChoiceToUpdate :: [ChoiceOption o] -> [UpdateOption (container o, Maybe o) (Maybe o)] | OptionContainer container & iTask o
sharedChoiceToUpdate options = case choiceToUpdate options of
	[UpdateWith fromf tof]	= [UpdateWith fromf (\m v -> snd (tof m v))]
	_						= []
*/

multiChoiceToUpdate :: [MultiChoiceOption o] -> [UpdateOption (container o, [o]) (container o,[o])] | OptionContainer container & iTask o
multiChoiceToUpdate [ChooseMultipleWith type view] = [UpdateWith (toView type) fromView]
where
	toView type (container,sel)	= selectOptions sel (initChoice type container)

	initChoice AutoMultiChoice container		= initChoice (suggestedMultiChoiceType container) container
	initChoice ChooseFromCheckBoxes container	= CheckMultiChoice [(view o,o) \\ o <- toOptionList container] []
	
	fromView (container,_) choice = (container,getSelections choice)
	
multiChoiceToUpdate _ = multiChoiceToUpdate [ChooseMultipleWith AutoMultiChoice id]

sharedMultiChoiceToUpdate :: [MultiChoiceOption o] -> [UpdateOption (container o, [o]) [o]] | OptionContainer container & iTask o
sharedMultiChoiceToUpdate options = case multiChoiceToUpdate options of
	[UpdateWith fromf tof]	= [UpdateWith fromf (\m v -> snd (tof m v))]
	_						= []

viewTitle :: !a -> Task a | iTask a 
viewTitle a = viewInformation Void  [ViewWith view] a
where
	title				= visualizeAsText AsLabel a
	view a				= DivTag [] [SpanTag [StyleAttr "font-size: 30px"] [Text title]]
	addTitleAttr attr	= 'Map'.put TITLE_ATTRIBUTE title attr