{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}moduleText.Formlets(input',inputM',optionalInput,generalInput,generalInputMulti,inputFile,fmapFst,nothingIfNull,check,ensure,ensures,ensureM,checkM,pureM,runFormState,massInput,xml,plug,plug2,plug',Env,Form,Formlet,File(..),ContentType(..),FormContentType(..),Rect(..),stringRect)whereimportData.GenericsimportData.Either(partitionEithers)importData.MonoidimportControl.ApplicativeimportControl.Applicative.ErrorimportControl.Applicative.StateimportData.Maybe(isJust,fromMaybe)importData.List(intercalate)importqualifiedText.Formlets.FormResultasFRimportqualifiedData.ByteString.LazyasBSimportqualifiedData.TraversableasT-- Form stufftypeEnv=[(String,EitherStringFile)]typeFormState=[Integer]typeFormletxmlma=Maybea->FormxmlmatypeName=StringtypeSa=StateFormStateatypeValidatora=S(FR.FormResulta)dataFormContentType=UrlEncoded|MultiPartderiving(Eq,Show,Read)newtypeFormxmlma=Form{deform::Env->S(m(Validatora),xml,FormContentType)}dataFile=File{content::BS.ByteString,fileName::String,contentType::ContentType}deriving(Eq,Show,Read,Data,Typeable)dataContentType=ContentType{ctType::String,ctSubtype::String,ctParameters::[(String,String)]}deriving(Eq,Show,Read,Data,Typeable)dataRect=Rect{rectCols::Int,rectRows::Int}deriving(Eq,Ord,Show,Read,Data,Typeable)-- |Choose a good number of rows for a textarea input. Uses the-- number of newlines in the string and the number of lines that-- are too long for the desired width.stringRect::Int->String->RectstringRectcolss=Rect{rectCols=cols,rectRows=foldr(+)0(map(\line->1+(lengthline)`div`cols)(liness))}-- | Apply a predicate to a value and return FR.Success or FR.Failure as appropriateensure::Showa=>(a->Bool)-- ^ The predicate->String-- ^ The error message, in case the predicate fails->a-- ^ The value->Failingaensurepmsgx|px=Successx|otherwise=Failure[msg]ensureM::(Monadm,Showa)=>(a->mBool)-- ^ The predicate->String-- ^ The error message, in case the predicate fails->a-- ^ The value->m(Failinga)ensureMpmsgx=doresult<-pxreturn$ifresultthenSuccessxelseFailure[msg]-- | Apply multiple predicates to a value, return FR.Success or all the FR.Failure messagesensures::Showa=>[(a->Bool,String)]-- ^ List of predicate functions and error messages, in case the predicate fails->a-- ^ The value->Failingaensurespsx|nullerrors=Successx|otherwise=Failureerrorswhereerrors=[err|(p,err)<-ps,not$px]-- | Helper function for genereting input components based forms.-- -- see also 'optionalInput', 'generalInput', and 'generalInputMulti'input'::Monadm=>(String->String->xml)-- ^ function which takes the control name, the initial value, and returns the control markup->MaybeString-- ^ optional default value->FormxmlmStringinput'idefaultValue=generalInput'i'fromLeft-- `check` maybe (Failure ["not in the data"]) Successwherei'nv=in(fromMaybe(fromMaybe""defaultValue)v)fromLeftnNothing=FR.NotAvailable$n++" is not in the data"fromLeftn(Just(Leftx))=FR.SuccessxfromLeftn(Just(Right_))=FR.Failure[n++" is a file, but should not have been."]{-# DEPRECATED inputM' "You can just use input'"#-}-- |deprecated. See 'input''inputM'::Monadm=>(String->String->xml)->MaybeString->FormxmlmStringinputM'=input'-- | Create a form control which is not required to be successful---- There is no way to provide a default value, because that would-- result in the control being successful.-- -- For more information on successful controls see:---- <http://www.w3.org/TR/html401/interact/forms.html#successful-controls>---- see also 'input'', 'generalInput', and 'generalInputMulti'optionalInput::Monadm=>(String->xml)-- ^ function which takes the form name and produces the control markup->Formxmlm(MaybeString)optionalInputi=generalInput'(\n_->in)fromLeftwherefromLeftnNothing=FR.SuccessNothingfromLeftn(Just(Leftx))=FR.Success(Justx)fromLeftn(Just(Right_))=FR.Failure[n++" is a file, but should not have been."]-- |generate a form control-- -- see also 'input'', 'optionalInput', 'generalInputMulti'.generalInput::Monadm=>(String->MaybeString->xml)-- ^ function which takes the control name, an initial value if one was found in the environment and returns control markup->Formxmlm(MaybeString)generalInputi=generalInput'(\nv->inv)fromLeftwherefromLeftnNothing=FR.SuccessNothingfromLeftn(Just(Leftx))=FR.Success(Justx)fromLeftn(Just(Right_))=FR.Failure[n++" is a file, but should not have been."]-- a combination of lookup and freshName. -- 1. generate a fresh name-- 2. lookup that name in the environment (returns a Maybe value)-- 3. pass the name and the Maybe value to the function 'f', which returns a value of type 'a'lookupFreshName::(Monadm)=>(String->Maybe(EitherStringFile)->a)->Env->m(StateFormStatea)lookupFreshNamefenv=return$(freshName>>=\name->return$fname$(lookupnameenv))-- |generate a form control-- -- see also 'input'', 'optionalInput', 'generalInputMulti'.generalInput'::Monadm=>(String->MaybeString->xml)-- ^ function which takes the control name, an initial value if one was found in the environment and returns control markup->(String->Maybe(EitherStringFile)->FR.FormResulta)->FormxmlmageneralInput'ifromLeft=Form$\env->mkInputenv<$>freshNamewheremkInputenvname=(lookupFreshNamefromLeftenv,-- return . result name,iname(valuenameenv),UrlEncoded)-- A function to obtain the initial value used to compute the-- representation. The environment is the one passed to-- runFormState. It typically reflects the initial value of-- the datatype which the form is meant to represent.valuenameenv=caselookupnameenvofJust(Leftx)->JustxJust(Right_)->error$name++" is a file."Nothing->Nothing-- A function to obtain the form's return value from the-- environment returned after the form is run.-- |generate a form control which can return multiple values---- Useful for controls such as checkboxes and multiple select .---- see also 'input'', 'optionalInput', 'generalInput'.generalInputMulti::forallmxml.Monadm=>(String->[String]->xml)->Formxmlm[String]generalInputMultii=Form$\env->mkInputenv<$>freshNamewheremkInput::Env->String->(m(Validator[String]),xml,FormContentType)mkInputenvname=(return(resultenv),iname(valuenameenv),UrlEncoded)-- A function to obtain the initial value used to compute the-- representation. The environment is the one passed to-- runFormState. It typically reflects the initial value of-- the datatype which the form is meanto to represent.value::String->Env->[String]valuenameenv=casepartitionEithers$lookupsnameenvof(xs,[])->xs_->error$name++" is a file."-- A function to obtain the form's return value from the-- environment returned after the form is run.result::Env->Validator[String]resultenv=doname<-freshNamereturn$casepartitionEithers$lookupsnameenvof([],[])->FR.NotAvailable$name++" is not in the data."(xs,[])->FR.Successxs_->FR.Failure[name++" is a file."]lookups::(Eqa)=>a->[(a,b)]->[b]lookupsk=mapsnd.filter((k==).fst)-- | A File input widget.inputFile::Monadm=>(String->xml)-- ^ Generates the xml for the file-upload widget based on the name->FormxmlmFileinputFilei=Form$\env->mkInputenv<$>freshNamewheremkInputenvname=(lookupFreshNamefromRightenv,iname,MultiPart)fromRightnNothing=FR.NotAvailable$n++" is not in the data"fromRightn(Just(Rightx))=FR.SuccessxfromRightn_=FR.Failure[n++" is not a file"]-- | Runs the form staterunFormState::Monadm=>Env-- ^ A previously filled environment (may be empty)->Formxmlma-- ^ The form->(m(Failinga),xml,FormContentType)runFormStatee(Formf)=fmapFst3(liftMFR.toE.liftMes)(es(fe))wherees=flipevalState[0]-- | Check a condition or convert a resultcheck::(Monadm)=>Formxmlma->(a->Failingb)->Formxmlmbcheck(Formfrm)f=Form$fmapcheckerfrmwherechecker=fmap$fmapFst3(liftM$liftM$f')f'(FR.Failurex)=FR.Failurexf'(FR.NotAvailablex)=FR.NotAvailablexf'(FR.Successx)=FR.fromE$fx-- | Monadically check a condition or convert a resultcheckM::(Monadm)=>Formxmlma->(a->m(Failingb))->FormxmlmbcheckM(Formfrm)f=Form$\env->checkerf(frmenv)wherecheckerffrm=docurrentState<-get(validator,xml,ct)<-frmletvalidator'=transformfvalidatorcurrentStatereturn(validator',xml,ct)--return xtransform::Monadm=>(a->m(Failingb))->m(Validatora)->FormState->m(Validatorb)transformfsourcest=transform'(makeValidatorf)sourcewheremakeValidator::Monadm=>(a->m(Failingb))->a->m(Validatorb)makeValidatorf=fmap(liftM(return.FR.fromE))ftransform'::Monadm=>(a->m(Validatorb))->m(Validatora)->m(Validatorb)transform'fa=doa'<-alet(a'',st')=runStatea'stval<-combinefa''return(changeStatest'val)changeState::st->Statesta->StatestachangeStatest'mComp=doresult<-mCompputst'returnresultconvert::Monadm=>(a->m(Failingb))->(a->m(FR.FormResultb))convertf=fmap(liftMFR.fromE)fcombine::Monadm=>(a->m(Validatorb))->FR.FormResulta->m(Validatorb)combinefx=casexof(FR.Successx)->fx(FR.NotAvailablex)->return.return$FR.NotAvailablex(FR.Failurex)->return.return$FR.Failurexinstance(Functorm,Monadm)=>Functor(Formxmlm)wherefmapf(Forma)=Form$\env->(fmap.fmapFst3.liftM.liftM.fmap)f(aenv)fmapFstf(a,b)=(fa,b)fmapFst3f(a,b,c)=(fa,b,c)instance(Monadm,Applicativem,Monoidxml)=>Applicative(Formxmlm)wherepure=pureF(<*>)=applyF-- | Pure xmlxml::Monadm=>xml->Formxmlm()xmlx=Form$\env->pure(return(return$FR.Success()),x,UrlEncoded)-- | Transform the XML componentplug::(xml->xml1)->Formxmlma->Formxml1maf`plug`(Formm)=Form$\env->pureplugin<*>menvwhereplugin(c,x,t)=(c,fx,t)-- | Combine the XML components of two forms using f, and combine the-- values using g.plug2::(Monadm)=>(xml->xml1->xml2)->(a->b->Failingc)->Formxmlma->Formxml1mb->Formxml2mcplug2fg(Formm)(Formn)=Form$\env->plugin<$>menv<*>nenvwhereplugin(c1,x1,t1)(c2,x2,t2)=(combineCollectorsc1c2,fx1x2,t2)-- combineCollectors :: (Monad m) => m (State FormState (FR.FormResult a)) -> m (State FormState (FR.FormResult b)) -> m (State FormState (FR.FormResult c))combineCollectorsc1c2=doa'<-c1b'<-c2return$combiner<$>a'<*>b'-- combiner :: (FR.FormResult a) -> (FR.FormResult b) -> (FR.FormResult c)combiner(FR.Failurea)(FR.Failureb)=FR.Failure(a++b)combiner(FR.Failurea)_=FR.Failureacombiner_(FR.Failureb)=FR.Failurebcombiner(FR.NotAvailablestr)_=FR.NotAvailablestrcombiner_(FR.NotAvailablestr)=FR.NotAvailablestrcombiner(FR.Successa)(FR.Successb)=FR.fromE(gab)plug'::(xml1->xml2)->Formletxml1ma->Formletxml2maplug'transformerformletvalue=plugtransformer(formletvalue)-- | This generates a single (or more) forms for a, and a parser function for a list of a's.massInput::(Applicativem,Monadm,Monoidxml)=>(Formletxmlma)-- ^ A formlet for a single a->Formletxmlm[a]massInputsingledefaults=Form$\env->domodify(\x->0:0:x)st<-get(collector,xml,contentType)<-(deform$singleNothing)envresetCurrentLevellistXml<-generateListXml(singleNothing)envletnewCollector=liftCollectorstcollectorxml'=caseenvof[]->xml_->listXmlx<-casemaybe[]iddefaultsof[]->return(newCollector,xml',contentType)xs->doresetCurrentLevelxmls<-mapM(generateXmlsingleenv)xsreturn(newCollector,mconcatxmls,contentType)modify(tail.tail)returnxgenerateXml::Monadm=>(Maybea->Formxmlma)->Env->a->SxmlgenerateXmlformenvvalue=do(_,xml,_)<-(deform$form$Justvalue)envmodifynextItemreturnxmlresetCurrentLevel::S()resetCurrentLevel=domodify(tail.tail)modify(\x->0:0:x)generateListXml::(Applicativem,Monadm,Monoidxml)=>Formxmlma->Env->SxmlgenerateListXmlformenv=don<-currentNamecaselookupnenvofNothing->returnmemptyJust_->do(_,xml,_)<-(deformform)envmodifynextItemrest<-generateListXmlformenvreturn$mappendxmlrestliftCollector::(Monadm)=>FormState->m(Validatora)->m(Validator[a])liftCollectorstcoll=docoll'<-collletst'=nextItemstcomputeRest=liftCollectorst'collcaseevalStatecoll'stofFR.Successx->dorest<-computeRestreturn(fmap(fmap(x:))rest)FR.NotAvailablex->return(return(FR.Success[]))FR.Failurex->dorest<-computeRestreturn$combineFailuresxrestnextItemst=flipexecStatest$modifytail>>freshName>>modify(0:)>>getcombineFailures::[String]->Validator[a]->Validator[a]combineFailuresmsgss=dox<-scasexofFR.Successx->return$FR.FailuremsgsFR.Failuref->return$FR.Failure(msgs++f)-- | Returns Nothing if the result is the empty String.nothingIfNull::(Monadm,Functorm)=>FormxmlmString->Formxmlm(MaybeString)nothingIfNullfrm=nullToMaybe<$>frmwherenullToMaybe[]=NothingnullToMaybex=Justx------------------------------------------------- Private methods-----------------------------------------------freshName::SStringfreshName=don<-currentNamemodify(changeHead(+1))returnn-- TODO: think of a good namechangeHeadf[]=error"changeHead: there is no head"changeHeadf(x:xs)=(fx):xscurrentName::SStringcurrentName=gets$\xs->"fval["++(intercalate"."$reverse$mapshowxs)++"]"orTUrlEncodedx=xorTxUrlEncoded=xorTxy=xpureF::(Monadm,Monoidxml)=>a->FormxmlmapureFv=Form$\env->pure(return(return$FR.Successv),mempty,UrlEncoded)pureM::(Monadm,Monoidxml)=>ma->FormxmlmapureMv=Form$\env->pure(liftM(return.FR.Success)v,mempty,UrlEncoded)applyF::(Monadm,Applicativem,Monoidxml)=>Formxmlm(a->b)->Formxmlma->Formxmlmb(Formf)`applyF`(Formv)=Form$\env->combine<$>fenv<*>venvwherecombine(v1,xml1,t1)(v2,xml2,t2)=(firstv1v2,(mappendxml1xml2),t1`orT`t2)first::Monadm=>m(Validator(a->b))->m(Validator(a))->m(Validator(b))firstv1v2=dox<-v1y<-v2return$dox''<-xy''<-yreturn(x''<*>y'')