implementation module InteractionTasks

from StdFunc import id, const, o, flip
from SystemData import null
from Tuple import appSnd
from List import isMemberGen, instance Functor []
from Shared import makeReadOnlyShared, :: SharedId
from Time import :: Timestamp(..)
import StdBool, StdList, StdMisc, StdTuple
import CoreTasks, TuningCombinators, CoreCombinators, ExceptionCombinators, SystemData, CommonCombinators

enterInformation :: !d ![LocalViewOn m] -> Task m | descr d & iTask m
enterInformation d options` = InputTask @>> LocalInteractionTask @>>
	mapToLocalState (updateSharedInformation` d options voidNull defaultValue)
where
	options _	= filterOptions filterInputOptions defaultOpts options`
	defaultOpts	= [EnterView (PutbackLocal (\l _ _ -> l))]
	
updateInformation :: !d ![LocalViewOn m] m -> Task m | descr d & iTask m
updateInformation d options` m = UpdateTask @>> LocalInteractionTask @>>
	mapToLocalState (updateSharedInformation` d options voidNull m)
where
	options _	= filterOptions noFilter defaultOpts options`
	defaultOpts	= [UpdateView (GetLocal id, PutbackLocal (\l _ _ -> l))]
	
showInformation :: !d ![LocalViewOn m] !m -> Task m | descr d & iTask m
showInformation d options` m = OutputTask PassiveOutput @>> LocalInteractionTask @>>
	mapToLocalState (updateSharedInformation` d options voidNull m)
where
	options	 _	= filterOptions filterOutputOptions defaultOpts options`
	defaultOpts	= [ShowView (GetLocal id)]
	
mapToLocalState = mapActionTaskModelValue (\(_,l) -> l)

enterSharedInformation :: !d ![ViewOn l r w] !(ReadWriteShared r w) -> Task (r,l) | descr d & iTask l & iTask r & iTask w
enterSharedInformation d options` shared = InputTask @>> updateSharedInformation` d options shared defaultValue
where
	options _	= filterOptions filterInputOptions defaultOpts options`
	defaultOpts	= [EnterView (PutbackLocal (\l _ _ -> l)), EnterView (PutbackShared (\w _ _ -> w))]
	
updateSharedInformation :: !d ![ViewOn l r w] !(ReadWriteShared r w) l -> Task (r,l) | descr d & iTask l & iTask r & iTask w
updateSharedInformation d options` shared initLocal = UpdateTask @>> updateSharedInformation` d options shared initLocal
where
	options _							= filterOptions noFilter defaultOpts options`
	defaultOpts							= [defaultLocalView,defaultSharedView]
	defaultLocalView					= UpdateView (GetLocal id, PutbackLocal (\l _ _ -> l))
	defaultSharedView = case dynamic id :: A.a: (a -> a) of
		(putback :: (r^ -> w^))			= UpdateView	(GetShared id,PutbackShared (\r _ _ -> (putback r)))
		_								= ShowView		(GetShared id)

showSharedInformation :: !d ![ViewOn l r w] !(ReadWriteShared r w) !l -> Task (r,l) | descr d & iTask l & iTask r & iTask w
showSharedInformation d options` shared local = OutputTask PassiveOutput @>> updateSharedInformation` d options shared local
where
	options _	= filterOptions filterOutputOptions defaultOpts options`
	defaultOpts	= [ShowView (GetLocal id), ShowView (GetShared id)]
	
filterOptions filterF defaultOpts options = addDefault (catMaybes (map filterF options))
where	
	addDefault options
		| any (\o -> case o of (About _) = False; _ = True) options	= options
		| otherwise													= options ++ defaultOpts
		
filterInputOptions option = case option of
		About a						= Just (About a)
		EnterView e					= Just (EnterView e)
		UpdateView (_,e)			= Just (EnterView e)
		ShowView (GetShared get)	= Just (ShowView (GetShared get))
		_							= Nothing
		
filterOutputOptions option = case option of
		About a				= Just (About a)
		ShowView s			= Just (ShowView s)
		UpdateView (s,_)	= Just (ShowView s)
		_					= Nothing
		
noFilter = Just

enterChoice :: !d ![ChoiceView ChoiceType o] !(container o) -> Task o | descr d & OptionContainer container & iTask o & iTask (container o)
enterChoice d views choiceOpts = InputTask @>> LocalInteractionTask @>>
	choice` d views (constShared choiceOpts) Nothing

updateChoice :: !d ![ChoiceView ChoiceType o] !(container o) o -> Task o | descr d & OptionContainer container & iTask o & iTask (container o)
updateChoice d views choiceOpts initC = UpdateTask @>> LocalInteractionTask @>>
	choice` d views (constShared choiceOpts) (Just initC)
	
enterSharedChoice :: !d ![ChoiceView ChoiceType o] !(ReadWriteShared (container o) w) -> Task o | descr d & OptionContainer container & iTask o & iTask w & iTask (container o)
enterSharedChoice d views shared = InputTask @>> choice` d views shared Nothing

updateSharedChoice :: !d ![ChoiceView ChoiceType o] !(ReadWriteShared (container o) w) o -> Task o | descr d & OptionContainer container & iTask o & iTask w & iTask (container o)
updateSharedChoice d views shared initC = UpdateTask @>> choice` d views shared (Just initC)

choice` d views shared mbInitSel = mapActionTask transF (updateSharedInformation` d (toChoiceViews (addDefault views)) shared Nothing)
where
	transF {modelValue=v=:(options,mbSelection)}
		= let mbSel = maybe mbInitSel Just mbSelection in {modelValue = fromMaybe defaultValue mbSel, localValid = isJust mbSel && isMemberGen (fromJust mbSel) (toOptionList options)}
	
	toChoiceViews views options = map toChoiceView views
	where
		toChoiceView view = case view of
			ChoiceContext v			= About v
			ChoiceView (type,viewF)	= choiceView type viewF
		
		choiceView type viewF = case type of
			AutoChoiceView				= choiceView (suggestedChoiceType options) viewF
			ChooseFromRadioButtons		= choiceView` mkRadioChoice
			ChooseFromComboBox			= choiceView` mkComboChoice
			//ChooseFromTable
			ChooseFromTree				= choiceView` mkTreeChoice
		where
			choiceView` mkF				= UpdateView (GetLocalAndShared (toChoice mkF viewF), PutbackLocal fromChoice)
			
		toChoice mkF get mbSel options	= mkF (fmap (\o -> (get o, o)) options) (maybe mbInitSel Just mbSel)
		fromChoice choice _ _			= getMbSelection choice
	
	addDefault options
		| any (\o -> case o of (ChoiceContext _) = False; _ = True) options	= options
		| otherwise															= options ++ [ChoiceView (AutoChoiceView, id)]

enterMultipleChoice :: !d ![ChoiceView MultiChoiceType o] !(container o) -> Task [o] | descr d & OptionContainer container & iTask o & iTask (container o)
enterMultipleChoice d views choiceOpts = InputTask @>> LocalInteractionTask @>>
	multipleChoice` d views (constShared choiceOpts) []

updateMultipleChoice :: !d ![ChoiceView MultiChoiceType o] !(container o) [o] -> Task [o] | descr d & OptionContainer container & iTask o & iTask (container o)
updateMultipleChoice d views choiceOpts initC = UpdateTask @>> LocalInteractionTask @>>
	multipleChoice` d views (constShared choiceOpts) initC

enterSharedMultipleChoice :: !d ![ChoiceView MultiChoiceType o] !(ReadWriteShared (container o) w) -> Task [o] | descr d & OptionContainer container & iTask o & iTask w & iTask (container o)
enterSharedMultipleChoice d views shared = InputTask @>> multipleChoice` d views shared []

updateSharedMultipleChoice :: !d ![ChoiceView MultiChoiceType o] !(ReadWriteShared (container o) w) [o] -> Task [o] | descr d & OptionContainer container & iTask o & iTask w & iTask (container o)
updateSharedMultipleChoice d views shared sel = UpdateTask @>> multipleChoice` d views shared sel

multipleChoice` d views shared initSels = mapActionTask transF (updateSharedInformation` d (toChoiceViews (addDefault views)) shared Nothing)
where
	transF {modelValue=v=:(options,mbSelections)} = {modelValue = filter (\sel -> isMemberGen sel (toOptionList options)) (fromMaybe initSels mbSelections), localValid = True}
	
	toChoiceViews views options = map toChoiceView views
	where
		toChoiceView view = case view of
			ChoiceContext v			= About v
			ChoiceView (type,viewF)	= choiceView type viewF
		
		choiceView type viewF = case type of
			AutoMultiChoiceView			= choiceView (suggestedMultiChoiceType options) viewF
			ChooseFromCheckBoxes		= choiceView` mkCheckMultiChoice
		where
			choiceView` mkF				= UpdateView (GetLocalAndShared (toChoice mkF viewF), PutbackLocal fromChoice)
	
	choiceView mkF viewF			= UpdateView (GetLocalAndShared (toChoice mkF viewF), PutbackLocal fromChoice)
	toChoice mkF get mbSel options	= mkF (fmap (\o -> (get o, o)) options) (fromMaybe initSels mbSel)
	fromChoice choice _ _			= Just (getSelections choice)
	
	addDefault options
		| any (\o -> case o of (ChoiceContext _) = False; _ = True) options	= options
		| otherwise															= options ++ [ChoiceView (AutoMultiChoiceView, id)]

updateSharedInformation` :: !d !(r -> [ViewOn l r w]) !(ReadWriteShared r w) l -> Task (r,l) | descr d & iTask l & iTask r & iTask w
updateSharedInformation` d viewF shared initLocal = mapActionTaskModelValue (\((l,_,_),r) -> (r,l)) (interact d interaction (initLocal,False,False) shared)
where
	interaction (l,updateLocalViews,updateSharedViews) r changed = map mkPart (viewF r)
	where
		mkPart part = case part of
			About a							= DisplayPart a
			EnterView putback				= FormPart	(Unchanged Blank)
														(mkPutback putback l r)
			ShowView get = case get of
				GetLocal get				= DisplayPart (get l)
				GetShared get				= DisplayPart (get r)
				GetLocalAndShared get		= DisplayPart (get l r)
			UpdateView (get,putback)
				# updateViewGet = case get of
					GetLocal get			= let form = FormValue (get l) in if updateLocalViews										form (Unchanged form)
					GetShared get			= let form = FormValue (get r) in if (updateSharedViews || changed)							form (Unchanged form)
					GetLocalAndShared get	= let form = FormValue (get l r) in if (updateLocalViews || updateSharedViews || changed)	form (Unchanged form)
				= FormPart
					updateViewGet
					(mkPutback putback l r)
			UpdateTrigger label updateF = case updateF of
				UpdateData f
					# (mbL, mbW)		= f l r
					# updateSharedView	= isJust mbW
					= UpdatePart label (maybe (l, False, updateSharedViews) (\l -> (l, True, updateSharedViews)) mbL, mbW)
				UpdateLocal f				= UpdatePart label ((f l, True, False), Nothing)
				UpdateShared f				= UpdatePart label ((l, False, True), Just (f r))
									
		mkPutback putback l r mbV = case mbV of
			Nothing = ((l,False,False),Nothing)
			Just v = case putback of
				Putback putback
					# (mbL,mbW)			= putback v l r
					# updateSharedViews	= isJust mbW
					= (maybe (l,False,updateSharedViews) (\l -> (l,True,updateSharedViews)) mbL,mbW)
				PutbackLocal putback	= ((putback v l r, True, False), Nothing)
				PutbackShared putback	= ((l, False, True), Just (putback v l r))

waitForTime :: !Time -> Task Time
waitForTime time =
	(showSharedInformation ("Wait for time", ("Wait until " +++ toString time)) [] currentTime Void >? \(now,_) -> time < now) >>= transform fst

waitForDate :: !Date -> Task Date
waitForDate date =
	(showSharedInformation ("Wait for date", ("Wait until " +++ toString date)) [] currentDate Void >? \(now,_) -> date < now) >>= transform fst
	
waitForDateTime :: !DateTime -> Task DateTime
waitForDateTime datetime =
	(showSharedInformation ("Wait for date and time", ("Wait until " +++ toString datetime)) [] currentDateTime Void >? \(now,_) -> datetime < now) >>= transform fst

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

chooseAction :: ![(!Action,a)] -> Task a | iTask a
chooseAction actions = Hide @>> maximalInteractionLayout @>> interact chooseActionDescr (\_ _ _ -> []) Void voidNull >>+ \_ -> UserActions (map (appSnd Just) actions)

chooseActionDyn :: !(r -> InteractionTerminators a) !(ReadWriteShared r w) -> Task a | iTask a & iTask r & iTask w
chooseActionDyn termF shared = interact chooseActionDescr (\_ _ _ -> []) Void shared >>+ \{modelValue=v=:(_,r)} -> termF r

chooseActionDescr = "Choose an action"
	
voidNull :: Shared Void
voidNull = null

constShared a = makeReadOnlyShared ("const_" +++ toString (toJSON a)) (\world -> (a,world)) (\world -> (Timestamp 0,world))