implementation module GenVerify

import StdGeneric, StdBool, StdInt, StdList, StdTuple, StdFunc, Maybe, Functor, Util, Text, Generic_NG
import GenUpdate, StdMisc

derive gVerify (,), (,,), (,,,), Void, Either, DateTime, Timestamp, Map, EmailAddress, Action, TreeNode, UserConstraint, ManagementMeta, TaskPriority, Tree
derive gVerify GoogleMapSettings, GoogleMapPerspective, GoogleMapPosition, GoogleMapMarker, GoogleMapType

import StdDebug
derive JSONEncode UpdateMask, VerifyMask, ErrorMessage

verifyForm :: !a !UpdateMask -> VerifyMask | gVerify{|*|} a
verifyForm val updateMask
	# verSt = gVerify{|*|} (Just val) {updateMask = [updateMask], verifyMask = [], optional = False, staticDisplay = False}
	# msk = hd verSt.verifyMask
	= (hd verSt.verifyMask)
	
verifyValue :: !a -> Bool | gVerify{|*|} a
verifyValue val = isValidValue (verifyForm val Touched)

isValidValue :: !VerifyMask -> Bool
isValidValue (VMUntouched _ optional cm)	= optional && (and (map isValidValue cm)) 
isValidValue (VMValid _ cm)					= and (map isValidValue cm)
isValidValue (VMValidWithState _ cm _)		= and (map isValidValue cm)
isValidValue _								= False

//Generic Verify
generic gVerify a :: !(Maybe a) !*VerSt -> *VerSt

gVerify{|UNIT|} 			  _ 					vst = vst
gVerify{|PAIR|}			fx fy p						vst = fy (fmap fromPAIRY p) (fx (fmap fromPAIRX p) vst)

gVerify{|RECORD of {grd_arity}|} fx r				vst=:{updateMask,verifyMask,optional}
	# val		= fmap fromRECORD r
	# (cmu,um)	= popMask updateMask
	# vst=:{verifyMask=childMask}	= fx val {vst & updateMask = childMasksN cmu grd_arity, verifyMask = [], optional = False}	
	# vst							= {vst & verifyMask=childMask}
	# (consMask,vst) = if (isTouched cmu)
								(VMValid Nothing childMask,vst)
								(VMUntouched Nothing optional childMask, vst)
	= {vst & updateMask = um, optional = optional, verifyMask = appendToMask verifyMask consMask}
	
gVerify{|FIELD|}		fx f						vst = fx (fmap fromFIELD f) vst

gVerify{|EITHER|} 		_  _  Nothing				vst = vst
gVerify{|EITHER|}		fx _  (Just (LEFT x))		vst	= fx (Just x) vst
gVerify{|EITHER|}		_  fy (Just (RIGHT y))		vst = fy (Just y) vst

gVerify{|OBJECT of {gtd_num_conses}|}	fx    obj	vst=:{updateMask,verifyMask,optional}
	# val		= fmap fromOBJECT obj
	# (cmu,um)	= popMask updateMask
	# vst		= {vst & updateMask = [cmu:um], verifyMask = []}
	# (consMask,vst) = case gtd_num_conses of
		1	// ADT's with just one constructor
			# vst=:{verifyMask = childMask} = fx val vst
			# vst							= {vst & verifyMask = childMask}
			| isTouched cmu					= (VMValid Nothing childMask,vst)
			| otherwise						= (VMUntouched Nothing optional childMask,vst)
		_	// ADT's with multiple constructors
			# vst=:{verifyMask = childMask} = fx val {vst & optional = False}
			# vst							= {vst & verifyMask = childMask}
			 = case cmu of
			 	Blanked | not optional		= (VMInvalid IsBlankError childMask,vst)
				Untouched					= (VMUntouched (Just "Select an option") optional childMask,vst)
				_							= (VMValid (Just "Select an option") childMask,vst)
	= {vst & updateMask = um, optional = optional, verifyMask = appendToMask verifyMask consMask}

gVerify{|CONS of {gcd_arity}|} fx c	 vst=:{updateMask}
	# (cmu,um)	= popMask updateMask
	= fx (fmap fromCONS c) {vst & updateMask = childMasksN cmu gcd_arity}

gVerify{|[]|} fx mbL vst=:{optional,verifyMask,updateMask,staticDisplay}
	# (cm,um)			= popMask updateMask
	# l					= fromMaybe [] mbL
	# (listMask,vst)	= verifyList l cm vst	
	= {vst & updateMask = um, optional = optional, verifyMask = appendToMask verifyMask listMask}
where
	verifyList l cm vst
		# vst=:{verifyMask=childMask} = verifyItems fx l {vst & verifyMask = [], updateMask = childMasksN cm (length l)}
		# vst = {vst & verifyMask = childMask}
		| staticDisplay
				= (VMValid Nothing childMask,vst)
		| not (isTouched cm)
				= (VMUntouched Nothing True childMask,vst)
		| otherwise
				= (VMValid Nothing childMask,vst)
				
	verifyItems fx [] vst=:{optional}
		# vst = fx Nothing {vst & optional = True}
		= {vst & optional = optional}
	verifyItems fx [x:xs] vst
		# vst = fx (Just x) vst
		= verifyItems fx xs vst
	
gVerify{|Maybe|} fx mb vst=:{optional,verifyMask}
	# vst=:{verifyMask} = fx (fromMaybe Nothing mb) {vst & optional = True}
	= {vst & optional = optional}

gVerify{|Hidden|}				_ _ vst		= verifyHidden vst
gVerify{|Editable|}				fx e vst	= verifyEditable fx (fmap fromEditable e) vst
gVerify{|Display|}				fx d vst	= verifyDisplay fx (fmap fromDisplay d) vst
gVerify{|VisualizationHint|}	fx v vst	= case v of
	Just (VHEditable e)	= verifyEditable fx (Just e) vst
	Just (VHDisplay d)	= verifyDisplay fx (Just d) vst
	Just (VHHidden _)	= verifyHidden vst
	_					= vst
	
verifyEditable	fx e vst=:{staticDisplay}		= (\vst -> {vst & staticDisplay = staticDisplay}) (fx e {vst & staticDisplay = False})
verifyDisplay	fx d vst=:{staticDisplay}		= (\vst -> {vst & staticDisplay = staticDisplay}) (fx d {vst & staticDisplay = True})
verifyHidden	vst=:{verifyMask,updateMask}	= {vst & verifyMask = appendToMask verifyMask (VMValid Nothing []), updateMask = snd (popMask updateMask)}

gVerify{|Int|}    				_ vst = simpleVerify "Enter a number" vst
gVerify{|Real|}   				_ vst = simpleVerify "Enter a decimal number" vst
gVerify{|Char|}   				_ vst = simpleVerify "Enter a character" vst
gVerify{|String|}				_ vst = simpleVerify "Enter a short text" vst
gVerify{|Bool|}   				_ vst = alwaysValid vst
gVerify{|Document|}				_ vst = simpleVerify "Upload a document" vst
gVerify{|Username|}				_ vst = simpleVerify "Enter a username" vst
gVerify{|Password|}				_ vst = simpleVerify "Enter a password" vst
gVerify{|Date|}					_ vst = simpleVerify "Enter a date" vst
gVerify{|Time|}					_ vst = simpleVerify "Enter a time of day" vst
gVerify{|Note|}					_ vst = simpleVerify "Enter a long text" vst
gVerify{|URL|}					_ vst = simpleVerify "Enter a uniform resource locator (URL)" vst
gVerify{|FormButton|}			_ vst = alwaysValid vst
gVerify{|EUR|}					_ vst = simpleVerify "Enter an amount in EUR" vst
gVerify{|USD|}					_ vst = simpleVerify "Enter an amount in USD" vst
gVerify{|BoundedInt|}			_ vst = alwaysValid vst
gVerify{|Progress|}				_ vst = alwaysValid vst
gVerify{|User|}					_ vst = simpleVerify "Select a username" vst 
gVerify{|RadioChoice|} _ _		_ vst = simpleVerify "Choose one item" vst
gVerify{|RadioChoiceNoView|} _	_ vst = simpleVerify "Choose one item" vst
gVerify{|ComboChoice|} _ _		_ vst = simpleVerify "Choose one item" vst
gVerify{|ComboChoiceNoView|} _	_ vst = simpleVerify "Choose one item" vst
gVerify{|GridChoice|} _ _		_ vst = alwaysValid vst
gVerify{|GridChoiceNoView|} _	_ vst = alwaysValid vst
gVerify{|CheckMultiChoice|} _ _	_ vst = simpleVerify "Choose a number of items" vst
gVerify{|Table|}				_ vst = alwaysValid vst
gVerify{|TreeChoice|} _ _		_ vst = simpleVerify "Choose an element of the tree" vst
gVerify{|TreeChoiceNoView|} _	_ vst = simpleVerify "Choose an element of the tree" vst
gVerify{|HtmlInclude|}			_ vst = alwaysValid vst
gVerify{|HtmlTag|}				_ vst = alwaysValid vst
gVerify{|GoogleMap|}			_ vst = alwaysValid vst

gVerify{|Dynamic|}				_ vst = alwaysValid vst
gVerify{|(->)|} _ _				_ vst = alwaysValid vst
gVerify{|JSONNode|}				_ vst = alwaysValid vst

gVerify{|DynamicChoice|} fx fy	(Just (DCCombo v)) vst = gVerify{|*->*->*|} fx fy (Just v) vst
gVerify{|DynamicChoice|} fx fy	(Just (DCRadio v)) vst = gVerify{|*->*->*|} fx fy (Just v) vst
gVerify{|DynamicChoice|} fx fy	(Just (DCTree v)) vst = gVerify{|*->*->*|} fx fy (Just v) vst
gVerify{|DynamicChoice|} fx fy	(Just (DCGrid v)) vst = gVerify{|*->*->*|} fx fy (Just v) vst
gVerify{|DynamicChoice|} fx fy	Nothing vst = alwaysValid vst

gVerify{|DynamicChoiceNoView|} fx (Just (DCComboNoView v)) vst = gVerify{|*->*|} fx (Just v) vst
gVerify{|DynamicChoiceNoView|} fx (Just (DCRadioNoView v)) vst = gVerify{|*->*|} fx (Just v) vst
gVerify{|DynamicChoiceNoView|} fx (Just (DCTreeNoView v)) vst = gVerify{|*->*|} fx (Just v) vst
gVerify{|DynamicChoiceNoView|} fx (Just (DCGridNoView v)) vst = gVerify{|*->*|} fx (Just v) vst
gVerify{|DynamicChoiceNoView|} fx Nothing vst = alwaysValid vst

//********************************************************************************************************
anyError :: ![VerifyMask] -> Bool
anyError children = or [isError c \\ c <- children]
where
	isError (VMInvalid _ _) = True
	isError _				= False

anyUntouched :: ![VerifyMask] -> Bool
anyUntouched children = or [isUntouched c \\ c <- children]
where
	isUntouched (VMUntouched _ _ _)	= True
	isUntouched _					= False

allUntouched :: ![VerifyMask] -> Bool
allUntouched children = and [isUntouched c \\ c <- children]
where
	isUntouched (VMUntouched _ _ _)	= True
	isUntouched _					= False

allValid :: ![VerifyMask] -> Bool
allValid children = and [isValid c \\ c <- children]
where
	isValid (VMValid _ _)	= True
	isValid _				= False

instance toString ErrorMessage
where
	toString (ErrorMessage s) = s
	toString IsBlankError = "This value is required"
	
instance GenMask VerifyMask
where
	popMask :: ![VerifyMask] -> (!VerifyMask, ![VerifyMask])
	popMask []					   		= (VMUntouched Nothing True [],[])
	popMask [c:cm]						= (c,cm)
	
	appendToMask :: ![VerifyMask] !VerifyMask -> [VerifyMask]
	appendToMask l c = l++[c]
	
	childMasks :: !VerifyMask -> [VerifyMask]
	childMasks (VMValid _ cm)				= cm
	childMasks (VMValidWithState _ cm _)	= cm
	childMasks (VMInvalid _ cm)				= cm
	childMasks (VMInvalidWithState _ cm _)	= cm
	childMasks (VMUntouched _ _ cm)			= cm
	
	childMasksN :: !VerifyMask !Int -> [VerifyMask]
	childMasksN m _ = childMasks m
	
	isTouched :: !VerifyMask -> Bool
	isTouched (VMUntouched _ _ _)			= False
	isTouched (VMInvalid IsBlankError _)	= False
	isTouched _								= True
	
alwaysValid :: !*VerSt -> *VerSt
alwaysValid vst=:{verifyMask,updateMask}
	# (cm,um) = popMask updateMask
	# nm = case cm of
		TouchedWithState s	= VMValidWithState Nothing [] s
		_					= VMValid Nothing []
	= {vst & updateMask = um, verifyMask = appendToMask verifyMask nm}
	
simpleVerify :: !String !*VerSt -> *VerSt
simpleVerify hint vst
	= customVerify (Just hint) (const True) (const "") (Just (abort "no value needed for simple verify")) vst

wrapperVerify :: !(Maybe String) !(a -> Bool) !(a -> String) !(Maybe a) !*VerSt -> *VerSt
wrapperVerify mbHint pred parseErr mbVal vst=:{updateMask, verifyMask, optional, staticDisplay} 
	# (cm,um) = popMask updateMask
	# vmask = case mbVal of
		Just val
			| staticDisplay
							= VMValid Nothing [VMValid Nothing []]
			| optional = case cm of
				Touched		= validateValue val
				_			= VMValid Nothing [VMValid mbHint []]           
			| otherwise = case cm of
				Untouched	= VMUntouched Nothing False [VMUntouched mbHint False []]
				Blanked		= VMInvalid IsBlankError [VMInvalid IsBlankError []]
				Touched		= validateValue val     
		Nothing
							= VMValid Nothing [VMValid mbHint []]
	= {vst & updateMask = um, verifyMask = appendToMask verifyMask vmask}
where
    validateValue val
	    | pred val  = VMValid Nothing [VMValid mbHint []]
	    | otherwise = VMInvalid (ErrorMessage "") [VMInvalid (ErrorMessage (parseErr val)) []]

customVerify :: !(Maybe String) !(a -> Bool) !(a -> String) !(Maybe a) !*VerSt -> *VerSt
customVerify mbHint pred mkErrMsg mbVal vst=:{updateMask, verifyMask, optional, staticDisplay} 
	# (cm,um) = popMask updateMask
	# vmask = case mbVal of
		Just val
			| staticDisplay
								= VMValid Nothing []
			| optional
				= case cm of
					Touched				= validateValue val
					TouchedWithState s	= validateValueWithState s val
					_					= VMValid mbHint []
			| otherwise
				= case cm of
					Untouched			= VMUntouched mbHint False []
					PartiallyTouched _	= validateValue val
					Touched				= validateValue val
					TouchedWithState s	= validateValueWithState s val
					Blanked				= VMInvalid IsBlankError []
		Nothing
			= case cm of
				TouchedWithState s	= VMValidWithState mbHint [] s
				_					= VMValid mbHint []
	= {vst & updateMask = um, verifyMask = appendToMask verifyMask vmask}
where
	validateValue val
		| pred val	= VMValid mbHint []
		| otherwise	= VMInvalid (ErrorMessage (mkErrMsg val)) []
		
	validateValueWithState state val
		| pred val	= VMValidWithState mbHint [] state
		| otherwise	= VMInvalidWithState (ErrorMessage (mkErrMsg val)) [] state  

setInvalid :: ![(!DataPath,!ErrorMessage)] !VerifyMask -> VerifyMask
setInvalid errors mask = seq (map setInvalid` errors) mask
where
	setInvalid` (p,msg) mask = hd (setInvalid`` (reverse (dataPathList p)) [mask])
	where
		setInvalid`` [0]	[mask:masks] = [VMInvalid msg (childMasks mask):masks]
		setInvalid`` [0:p]	[mask:masks] = [setChildren mask (setInvalid`` p (childMasks mask)):masks]
		setInvalid`` [n:p]	[mask:masks] = [mask:setInvalid`` [dec n:p] masks]
		
	setChildren (VMUntouched	mbHint optional _)	children = VMUntouched	mbHint optional children
	setChildren (VMValid	 	mbHint _)			children = VMValid	 	mbHint children
	setChildren (VMInvalid		errorM _)			children = VMInvalid	errorM children