{-# LANGUAGE TemplateHaskell #-}{-# LANGUAGE CPP #-}{-# LANGUAGE TypeFamilies #-}{-# LANGUAGE TypeSynonymInstances #-}{-# LANGUAGE FlexibleContexts #-}{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE GeneralizedNewtypeDeriving #-}{-# LANGUAGE EmptyDataDecls #-}{-# LANGUAGE PatternGuards #-}{-# OPTIONS_GHC -fno-warn-missing-fields #-}moduleText.Hamlet(-- * Plain HTMLHtml,shamlet,shamletFile,xshamlet,xshamletFile-- * Hamlet,HtmlUrl,hamlet,hamletFile,xhamlet,xhamletFile-- * I18N Hamlet,HtmlUrlI18n,ihamlet,ihamletFile-- * Type classes,ToAttributes(..)-- * Internal, for making more,HamletSettings(..),NewlineStyle(..),hamletWithSettings,hamletFileWithSettings,defaultHamletSettings,xhtmlHamletSettings,Env(..),HamletRules(..),hamletRules,ihamletRules,htmlRules,CloseStyle(..))whereimportText.Shakespeare.BaseimportText.Hamlet.ParseimportLanguage.Haskell.TH.SyntaximportLanguage.Haskell.TH.QuoteimportData.Char(isUpper,isDigit)importData.Maybe(fromMaybe)importData.Text(Text,pack)importqualifiedData.Text.LazyasTLimportText.Blaze.Html(Html,toHtml)importText.Blaze.Internal(preEscapedText)importqualifiedData.FoldableasFimportControl.Monad(mplus)importData.Monoid(mempty,mappend)importControl.Arrow((***))importData.List(intercalate)-- | Convert some value to a list of attribute pairs.classToAttributesawheretoAttributes::a->[(Text,Text)]instanceToAttributes(Text,Text)wheretoAttributes=returninstanceToAttributes(String,String)wheretoAttributes(k,v)=[(packk,packv)]instanceToAttributes[(Text,Text)]wheretoAttributes=idinstanceToAttributes[(String,String)]wheretoAttributes=map(pack***pack)attrsToHtml::[(Text,Text)]->HtmlattrsToHtml=foldrgomemptywherego(k,v)rest=toHtml" "`mappend`preEscapedTextk`mappend`preEscapedText(pack"=\"")`mappend`toHtmlv`mappend`preEscapedText(pack"\"")`mappend`resttypeRenderurl=url->[(Text,Text)]->TexttypeTranslatemsg=msg->Html-- | A function generating an 'Html' given a URL-rendering function.typeHtmlUrlurl=Renderurl->Html-- | A function generating an 'Html' given a message translator and a URL rendering function.typeHtmlUrlI18nmsgurl=Translatemsg->Renderurl->HtmldocsToExp::Env->HamletRules->Scope->[Doc]->QExpdocsToExpenvhrscopedocs=doexps<-mapM(docToExpenvhrscope)docscaseexpsof[]->[|return()|][x]->returnx_->return$DoE$mapNoBindSexpsunIdent::Ident->StringunIdent(Idents)=sbindingPattern::Binding->Q(Pat,[(Ident,Exp)])bindingPattern(BindAsi@(Idents)b)=doname<-newNames(pattern,scope)<-bindingPatternbreturn(AsPnamepattern,(i,VarEname):scope)bindingPattern(BindVari@(Idents))|allisDigits=doreturn(LitP$IntegerL$reads,[])|otherwise=doname<-newNamesreturn(VarPname,[(i,VarEname)])bindingPattern(BindTupleis)=do(patterns,scopes)<-fmapunzip$mapMbindingPatternisreturn(TupPpatterns,concatscopes)bindingPattern(BindListis)=do(patterns,scopes)<-fmapunzip$mapMbindingPatternisreturn(ListPpatterns,concatscopes)bindingPattern(BindConstrconis)=do(patterns,scopes)<-fmapunzip$mapMbindingPatternisreturn(ConP(mkConNamecon)patterns,concatscopes)bindingPattern(BindRecordconfieldswild)=doletf(Identfield,b)=do(p,s)<-bindingPatternbreturn((mkNamefield,p),s)(patterns,scopes)<-fmapunzip$mapMffields(patterns1,scopes1)<-ifwildthenbindWildFieldscon$mapfstfieldselsereturn([],[])return(RecP(mkConNamecon)(patterns++patterns1),concatscopes++scopes1)mkConName::DataConstr->NamemkConName=mkName.conToStrconToStr::DataConstr->StringconToStr(DCUnqualified(Identx))=xconToStr(DCQualified(Modulexs)(Identx))=intercalate"."$xs++[x]-- Wildcards bind all of the unbound fields to variables whose name-- matches the field name.---- For example: data R = C { f1, f2 :: Int }-- C {..} is equivalent to C {f1=f1, f2=f2}-- C {f1 = a, ..} is equivalent to C {f1=a, f2=f2}-- C {f2 = a, ..} is equivalent to C {f1=f1, f2=a}bindWildFields::DataConstr->[Ident]->Q([(Name,Pat)],[(Ident,Exp)])bindWildFieldsconNamefields=dofieldNames<-recordToFieldNamesconNameletavailablen=nameBasen`notElem`mapunIdentfieldsletremainingFields=filteravailablefieldNamesletmkPatn=doe<-newName(nameBasen)return((n,VarPe),(Ident(nameBasen),VarEe))fmapunzip$mapMmkPatremainingFields-- Important note! reify will fail if the record type is defined in the-- same module as the reify is used. This means quasi-quoted Hamlet-- literals will not be able to use wildcards to match record types-- defined in the same module.recordToFieldNames::DataConstr->Q[Name]recordToFieldNamesconStr=do-- use 'lookupValueName' instead of just using 'mkName' so we reify the-- data constructor and not the type constructor if their names match.JustconName<-lookupValueName$conToStrconStrDataConI__typeName_<-reifyconNameTyConI(DataD___cons_)<-reifytypeName[fields]<-return[fields|RecCnamefields<-cons,name==conName]return[fieldName|(fieldName,_,_)<-fields]docToExp::Env->HamletRules->Scope->Doc->QExpdocToExpenvhrscope(DocForalllistidentsinside)=doletlist'=derefToExpscopelist(pat,extraScope)<-bindingPatternidentsletscope'=extraScope++scopemh<-[|F.mapM_|]inside'<-docsToExpenvhrscope'insideletlam=LamE[pat]inside'return$mh`AppE`lam`AppE`list'docToExpenvhrscope(DocWith[]inside)=doinside'<-docsToExpenvhrscopeinsidereturn$inside'docToExpenvhrscope(DocWith((deref,idents):dis)inside)=doletderef'=derefToExpscopederef(pat,extraScope)<-bindingPatternidentsletscope'=extraScope++scopeinside'<-docToExpenvhrscope'(DocWithdisinside)letlam=LamE[pat]inside'return$lam`AppE`deref'docToExpenvhrscope(DocMaybevalidentsinsidemno)=doletval'=derefToExpscopeval(pat,extraScope)<-bindingPatternidentsletscope'=extraScope++scopeinside'<-docsToExpenvhrscope'insideletinside''=LamE[pat]inside'ninside'<-casemnoofNothing->[|Nothing|]Justno->dono'<-docsToExpenvhrscopenoj<-[|Just|]return$j`AppE`no'mh<-[|maybeH|]return$mh`AppE`val'`AppE`inside''`AppE`ninside'docToExpenvhrscope(DocCondcondsfinal)=doconds'<-mapMgocondsfinal'<-casefinalofNothing->[|Nothing|]Justf->dof'<-docsToExpenvhrscopefj<-[|Just|]return$j`AppE`f'ch<-[|condH|]return$ch`AppE`ListEconds'`AppE`final'wherego::(Deref,[Doc])->QExpgo(d,docs)=doletd'=derefToExp((specialOrIdent,VarE'or):scope)ddocs'<-docsToExpenvhrscopedocsreturn$TupE[d',docs']docToExpenvhrscope(DocCasederefcases)=doletexp_=derefToExpscopederefmatches<-mapMtoMatchcasesreturn$CaseEexp_matcheswherereadMays=casereadssof(x,""):_->Justx_->NothingtoMatch::(Binding,[Doc])->QMatchtoMatch(idents,inside)=do(pat,extraScope)<-bindingPatternidentsletscope'=extraScope++scopeinsideExp<-docsToExpenvhrscope'insidereturn$Matchpat(NormalBinsideExp)[]docToExpenvhrv(DocContentc)=contentToExpenvhrvccontentToExp::Env->HamletRules->Scope->Content->QExpcontentToExp_hr_(ContentRaws)=doos<-[|preEscapedText.pack|]lets'=LitE$StringLsreturn$hrFromHtmlhr`AppE`(os`AppE`s')contentToExp_hrscope(ContentVard)=dostr<-[|toHtml|]return$hrFromHtmlhr`AppE`(str`AppE`derefToExpscoped)contentToExpenvhrscope(ContentUrlhasParamsd)=caseurlRenderenvofNothing->error"URL interpolation used, but no URL renderer provided"Justwrender->wrender$\render->doletrender'=returnrenderou<-ifhasParamsthen[|\(u,p)->$(render')up|]else[|\u->$(render')u[]|]letd'=derefToExpscopedpet<-[|toHtml|]return$hrFromHtmlhr`AppE`(pet`AppE`(ou`AppE`d'))contentToExpenvhrscope(ContentEmbedd)=hrEmbedhrenv$derefToExpscopedcontentToExpenvhrscope(ContentMsgd)=casemsgRenderenvofNothing->error"Message interpolation used, but no message renderer provided"Justwrender->wrender$\render->return$hrFromHtmlhr`AppE`(render`AppE`derefToExpscoped)contentToExp_hrscope(ContentAttrsd)=dohtml<-[|attrsToHtml.toAttributes|]return$hrFromHtmlhr`AppE`(html`AppE`derefToExpscoped)shamlet::QuasiQuotershamlet=hamletWithSettingshtmlRulesdefaultHamletSettingsxshamlet::QuasiQuoterxshamlet=hamletWithSettingshtmlRulesxhtmlHamletSettingshtmlRules::QHamletRuleshtmlRules=doi<-[|id|]return$HamletRulesi($(EnvNothingNothing))(\_b->returnb)hamlet::QuasiQuoterhamlet=hamletWithSettingshamletRulesdefaultHamletSettingsxhamlet::QuasiQuoterxhamlet=hamletWithSettingshamletRulesxhtmlHamletSettingsasHtmlUrl::HtmlUrlurl->HtmlUrlurlasHtmlUrl=idhamletRules::QHamletRuleshamletRules=doi<-[|id|]leturf=dor<-newName"_render"letenv=Env{urlRender=Just($(VarEr)),msgRender=Nothing}h<-fenvreturn$LamE[VarPr]hreturn$HamletRulesiuremwhereem(Env(Justurender)Nothing)e=doasHtmlUrl'<-[|asHtmlUrl|]urender$\ur'->return((asHtmlUrl'`AppE`e)`AppE`ur')em__=error"bad Env"ihamlet::QuasiQuoterihamlet=hamletWithSettingsihamletRulesdefaultHamletSettingsihamletRules::QHamletRulesihamletRules=doi<-[|id|]leturf=dou<-newName"_urender"m<-newName"_mrender"letenv=Env{urlRender=Just($(VarEu)),msgRender=Just($(VarEm))}h<-fenvreturn$LamE[VarPm,VarPu]hreturn$HamletRulesiuremwhereem(Env(Justurender)(Justmrender))e=urender$\ur'->mrender$\mr->return(e`AppE`mr`AppE`ur')em__=error"bad Env"hamletWithSettings::QHamletRules->HamletSettings->QuasiQuoterhamletWithSettingshrset=QuasiQuoter{quoteExp=hamletFromStringhrset}dataHamletRules=HamletRules{hrFromHtml::Exp,hrWithEnv::(Env->QExp)->QExp,hrEmbed::Env->Exp->QExp}dataEnv=Env{urlRender::Maybe((Exp->QExp)->QExp),msgRender::Maybe((Exp->QExp)->QExp)}hamletFromString::QHamletRules->HamletSettings->String->QExphamletFromStringqhrsets=dohr<-qhrcaseparseDocsetsofErrors'->errors'Ok(_mnl,d)->hrWithEnvhr$\env->docsToExpenvhr[]dhamletFileWithSettings::QHamletRules->HamletSettings->FilePath->QExphamletFileWithSettingsqhrsetfp=do#ifdef GHC_7_4qAddDependentFilefp#endifcontents<-fmapTL.unpack$qRunIO$readUtf8FilefphamletFromStringqhrsetcontentshamletFile::FilePath->QExphamletFile=hamletFileWithSettingshamletRulesdefaultHamletSettingsxhamletFile::FilePath->QExpxhamletFile=hamletFileWithSettingshamletRulesxhtmlHamletSettingsshamletFile::FilePath->QExpshamletFile=hamletFileWithSettingshtmlRulesdefaultHamletSettingsxshamletFile::FilePath->QExpxshamletFile=hamletFileWithSettingshtmlRulesxhtmlHamletSettingsihamletFile::FilePath->QExpihamletFile=hamletFileWithSettingsihamletRulesdefaultHamletSettingsvarName::Scope->String->ExpvarName_""=error"Illegal empty varName"varNamescopev@(_:_)=fromMaybe(strToExpv)$lookup(Identv)scopestrToExp::String->ExpstrToExps@(c:_)|allisDigits=LitE$IntegerL$reads|isUpperc=ConE$mkNames|otherwise=VarE$mkNamesstrToExp""=error"strToExp on empty string"-- | Checks for truth in the left value in each pair in the first argument. If-- a true exists, then the corresponding right action is performed. Only the-- first is performed. In there are no true values, then the second argument is-- performed, if supplied.condH::Monadm=>[(Bool,m())]->Maybe(m())->m()condHbmsmm=fromMaybe(return())$lookupTruebms`mplus`mm-- | Runs the second argument with the value in the first, if available.-- Otherwise, runs the third argument, if available.maybeH::Monadm=>Maybev->(v->m())->Maybe(m())->m()maybeHmvfmm=fromMaybe(return())$fmapfmv`mplus`mm