moduleText.Formlets(input',inputM',optionalInput,inputFile,fmapFst,nothingIfNull,check,ensure,ensures,ensureM,checkM,pureM,runFormState,massInput,xml,plug,plug',Env,Form,Formlet,File(..),ContentType(..),FormContentType(..))whereimportData.MonoidimportControl.ApplicativeimportControl.Applicative.ErrorimportControl.Applicative.StateimportData.Maybe(isJust)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),mxml,FormContentType)}dataFile=File{content::BS.ByteString,fileName::String,contentType::ContentType}deriving(Eq,Show,Read)dataContentType=ContentType{ctType::String,ctSubtype::String,ctParameters::[(String,String)]}deriving(Eq,Show,Read)-- | 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.input'::Monadm=>(String->String->xml)->MaybeString->FormxmlmStringinput'i=inputM'(\n->return.in)inputM'::Monadm=>(String->String->mxml)->MaybeString->FormxmlmStringinputM'idefaultValue=Form$\env->mkInputenv<$>freshNamewheremkInputenvname=(lookupFreshNamefromLeftenv,iname(valuenameenv),UrlEncoded)valuenameenv=maybe(maybe""iddefaultValue)fromLeft'(lookupnameenv)fromLeft'(Leftx)=xfromLeft'_=""fromLeftnNothing=FR.NotAvailable$n++" is not in the data"fromLeftn(Just(Leftx))=FR.SuccessxfromLeftn_=FR.Failure[n++" is a file."]lookupFreshNamefenv=return$(freshName>>=\name->return$fname$(lookupnameenv))optionalInput::Monadm=>(String->xml)->Formxmlm(MaybeString)optionalInputi=Form$\env->mkInputenv<$>freshNamewheremkInputenvname=(lookupFreshNamefromLeftenv,return(iname),UrlEncoded)fromLeftnNothing=FR.SuccessNothingfromLeftn(Just(Leftx))=FR.Success(Justx)fromLeftn_=FR.Failure[n++" could not be recognized."]-- | 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,return(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),mxml,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<-getfrm'<-frmreturn$fmapFst3(transformf.liftM(flipevalStatecurrentState))frm'transformfsource=source>>=\x->casexofFR.Successx->liftMreturn(convertfx)FR.NotAvailablex->return.return$FR.NotAvailablexFR.Failurex->return.return$FR.Failurexconvert::Monadm=>(a->m(Failingb))->(a->m(FR.FormResultb))convertf=fmap(liftMFR.fromE)finstance(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()),returnx,UrlEncoded)-- | Transform the XML componentplug::(Monadm,Monoidxml)=>(xml->xml1)->Formxmlma->Formxml1maf`plug`(Formm)=Form$\env->pureplugin<*>menvwhereplugin(c,x,t)=(c,liftMfx,t)plug'::(Monadm,Monoidxml1)=>(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)xsletxmls'=sequencexmlsreturn(newCollector,liftMmconcatxmls',contentType)modify(tail.tail)returnxgenerateXml::Monadm=>(Maybea->Formxmlma)->Env->a->S(mxml)generateXmlformenvvalue=do(_,xml,_)<-(deform$form$Justvalue)envmodifynextItemreturnxmlresetCurrentLevel::S()resetCurrentLevel=domodify(tail.tail)modify(\x->0:0:x)generateListXml::(Applicativem,Monadm,Monoidxml)=>Formxmlma->Env->S(mxml)generateListXmlformenv=don<-currentNamecaselookupnenvofNothing->return$returnmemptyJust_->do(_,xml,_)<-(deformform)envmodifynextItemrest<-generateListXmlformenvreturn$mappend<$>xml<*>restliftCollector::(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),returnmempty,UrlEncoded)pureM::(Monadm,Monoidxml)=>ma->FormxmlmapureMv=Form$\env->pure(liftM(return.FR.Success)v,returnmempty,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,(mappend<$>xml1<*>xml2),t1`orT`t2)first::Monadm=>m(Validator(a->b))->m(Validator(a))->m(Validator(b))firstv1v2=dox<-v1y<-v2return$dox''<-xy''<-yreturn(x''<*>y'')