moduleText.Formlets(input',inputFile,fmapFst,check,ensure,ensures,ensureM,checkM,runFormState,xml,plug,Env,Form,Plus(..),File(..),ContentType(..),FormContentType(..))whereimportControl.ApplicativeimportControl.Applicative.ErrorimportControl.Applicative.StateimportData.Maybe(isJust)importqualifiedData.ByteString.LazyasBSimportqualifiedData.TraversableasT-- Form stufftypeEnv=[(String,EitherStringFile)]typeFormState=NamestypeNames=IntegertypeName=StringtypeCollectora=Env->adataFormContentType=UrlEncoded|MultiPartderiving(Eq,Show,Read)newtypeFormxmlma=Form{deform::Env->StateFormState(Collector(m(Failinga)),xml,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)classPlusawherezero::aplus::a->a->a-- | Apply a predicate to a value and return Success or 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 Success or all the 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'idefaultValue=Form$\env->mkInputenv<$>freshNamewheremkInputenvname=(return.fromLeftname.(lookupname),iname(valuenameenv),UrlEncoded)valuenameenv=maybe(maybe""iddefaultValue)fromLeft'(lookupnameenv)fromLeft'(Leftx)=xfromLeft'_=""fromLeftnNothing=Failure[n++" is not in the data"]fromLeftn(Just(Leftx))=SuccessxfromLeftn_=Failure[n++" is a file."]inputFile::Monadm=>(String->xml)->FormxmlmFileinputFilei=Form$\env->mkInputenv<$>freshNamewheremkInputenvname=(return.fromRightname.(lookupname),iname,MultiPart)fromRightnNothing=Failure[n++" is not in the data"]fromRightn(Just(Rightx))=SuccessxfromRightn_=Failure[n++" is not a file"]-- | Runs the form staterunFormState::Monadm=>Env-- ^ A previously filled environment (may be empty)->Formxmlma-- ^ The form->(Collector(m(Failinga)),xml,FormContentType)runFormStatee(Formf)=evalState(fe)0-- | Add additional validation to an already validated componentcheck::(Monadm)=>Formxmlma->(a->Failingb)->Formxmlmbcheck(Formfrm)f=Form$fmapcheckerfrmwherechecker=fmap$fmapFst3(fmap.liftM$f')-- fmap $ fmapFst3 (fmap (f' f .))f'(Failurex)=Failurexf'(Successx)=fx-- | Add additional validation to an already validated componentcheckM::(Monadm)=>Formxmlma->(a->m(Failingb))->FormxmlmbcheckM(Formfrm)f=Form$fmapcheckerfrmwherechecker=fmap$fmapFst3(fmapf')-- fmap $ fmapFst3 (fmap (f' f .))f'v'=dov<-v'casevofFailuremsg->return$FailuremsgSuccessx->fxinstance(Functorm,Monadm)=>Functor(Formxmlm)wherefmapf(Forma)=Form$\env->(fmap.fmapFst3.liftM.fmap.fmap)f(aenv)fmapFstf(a,b)=(fa,b)fmapFst3f(a,b,c)=(fa,b,c)instance(Monadm,Applicativem,Plusxml)=>Applicative(Formxmlm)wherepure=pureF(<*>)=applyFpureF::(Monadm,Plusxml)=>a->FormxmlmapureFv=Form$\env->pure(const(return$Successv),zero,UrlEncoded)applyF::(Monadm,Applicativem,Plusxml)=>Formxmlm(a->b)->Formxmlma->Formxmlmb(Formf)`applyF`(Formv)=Form$\env->purecombine<*>fenv<*>venvwherecombine(v1,xml1,t1)(v2,xml2,t2)=(firstv1v2,xml1`plus`xml2,t1`orT`t2)firstv1v2e=dox<-v1ey<-v2ereturn$x<*>yorTUrlEncodedx=xorTxUrlEncoded=xorTxy=x-- | Component: just some xmlxml::Monadm=>xml->Formxmlm()xmlx=Form$\env->pure(const$return$Success(),x,UrlEncoded)-- | Transform the XML componentplug::Plusxml=>(xml->xml)->Formxmlma->Formxmlmaf`plug`(Formm)=Form$\env->pureplugin<*>menvwhereplugin(c,x,t)=(c,fx,t)------------------------------------------------- Private methods-----------------------------------------------freshName::StateFormStateStringfreshName=don<-currentNamemodify(+1)returnncurrentName::StateFormStateStringcurrentName=gets$(++)"input".show