implementation module GenVerify

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

derive gVerify (,), (,,), (,,,), Void, Either, UserDetails, DateTime, Timestamp, Map, EmailAddress, Action, TreeNode, ManagementMeta, TaskPriority, Tree
verifyForm :: !a !UpdateMask -> VerifyMask | gVerify{|*|} a
verifyForm val updateMask
	# verSt = gVerify{|*|} (Just val) {updateMask = [updateMask], verifyMask = [], optional = False, staticDisplay = False}
	= hd verSt.verifyMask

verifyValue :: !a -> Bool | gVerify{|*|}, gDefaultMask{|*|} a
verifyValue val = isValidValue (verifyForm val (defaultMask val))

isValidValue :: !VerifyMask -> Bool
isValidValue (VMUntouched _ optional cm)	= optional && (and (map isValidValue cm)) 
isValidValue (VMValid _ cm)					= and (map isValidValue cm)
isValidValue (VMInvalid _ _)				= 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{|CONS|}			fx c						vst = fx (fmap fromCONS c) vst
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 d|}	fx    obj					vst=:{updateMask,verifyMask,optional}
	# val		= fmap fromOBJECT obj
	# (cmu,um)	= popMask updateMask
	# vst		= {vst & updateMask = childMasks cmu, verifyMask = []}
	# (consMask,vst) = case (isRecordType d,d.gtd_num_conses) of
		(False,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)
		(False,_) // 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)
		(True,_) // Records
			//Only compute child verify mask if record has value. Else you can end up in endless recursion!
			# (childMask,vst) = case isJust obj of
				True
					# vst=:{verifyMask = childMask} = fx val {vst & optional = False}
					= (childMask,{vst & verifyMask = childMask})
				False
					= ([],vst)
			| isTouched cmu					= (VMValid Nothing childMask,vst)
			| otherwise						= (VMUntouched Nothing optional childMask,vst)		
	= {vst & updateMask = um, optional = optional, verifyMask = appendToMask verifyMask consMask}

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 = childMasks cm, optional = False}
		# vst = {vst & verifyMask = childMask}
		| staticDisplay
				= (VMValid Nothing childMask,vst)
		| not (isTouched cm)
				= (VMUntouched Nothing optional childMask,vst)
		| isEmpty l
			| optional
				= (VMValid hintOpt childMask,vst)
			| otherwise
				= (VMInvalid (ErrorMessage "You must add at least one item") 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
	
	hintOpt	= Just "You may add list items"

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{|ControlSize|}		fx v vst = fx (fmap fromControlSize v) vst
gVerify{|FillControlSize|}	fx v vst = fx (fmap fromFillControlSize v) vst
gVerify{|FillWControlSize|}	fx v vst = fx (fmap fromFillWControlSize v) vst
gVerify{|FillHControlSize|}	fx v vst = fx (fmap fromFillHControlSize v) vst

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{|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{|User|}					_ vst = simpleVerify "Select a username" vst 
gVerify{|RadioChoice|} _ _		_ vst = simpleVerify "Choose one item" vst
gVerify{|ComboChoice|} _ _		_ vst = simpleVerify "Choose one item" vst
gVerify{|GridChoice|} _ _		_ vst = alwaysValid vst//simpleVerify "Choose one row" 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{|HtmlInclude|}			_ vst = alwaysValid vst
gVerify{|HtmlTag|}				_ vst = alwaysValid vst

gVerify{|Dynamic|}			_ vst = alwaysValid vst
gVerify{|(->)|} _ _			_ vst = alwaysValid vst
gVerify{|JSONNode|}			_ 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 []					   		= (VMValid Nothing [], [])
	popMask [c:cm]						= (c,cm)
	
	appendToMask :: ![VerifyMask] !VerifyMask -> [VerifyMask]
	appendToMask l c = l++[c]
	
	childMasks :: !VerifyMask -> [VerifyMask]
	childMasks (VMValid _ cm)		= cm
	childMasks (VMInvalid _ cm)		= cm
	childMasks (VMUntouched _ _ cm)	= cm
	
	isTouched :: !VerifyMask -> Bool
	isTouched (VMUntouched _ _ _)			= False
	isTouched (VMInvalid IsBlankError _)	= False
	isTouched _								= True
	
alwaysValid :: !*VerSt -> *VerSt
alwaysValid vst=:{verifyMask,updateMask}
	# (cm,um) = popMask updateMask
	= {vst & updateMask = um, verifyMask = appendToMask verifyMask (VMValid Nothing [])}
	
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
					_			= VMValid mbHint []
			| otherwise
				= case cm of
					Untouched	= VMUntouched mbHint False []
					Blanked		= VMInvalid IsBlankError []
					Touched _	= validateValue val
		Nothing
								= VMValid mbHint []
	= {vst & updateMask = um, verifyMask = appendToMask verifyMask vmask}
where
	validateValue val
		| pred val	= VMValid mbHint []
		| otherwise	= VMInvalid (ErrorMessage (mkErrMsg val)) []

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