{-# LANGUAGE DeriveDataTypeable #-}{-# LANGUAGE TemplateHaskell #-}{-# LANGUAGE CPP #-}{-# LANGUAGE FlexibleInstances #-}moduleText.Hamlet.Parse(Result(..),Content(..),Doc(..),parseDoc,HamletSettings(..),defaultHamletSettings,xhtmlHamletSettings,CloseStyle(..),Binding(..),NewlineStyle(..),specialOrIdent,DataConstr(..),Module(..))whereimportText.Shakespeare.BaseimportControl.Applicative((<$>),Applicative(..))importControl.MonadimportControl.ArrowimportData.Char(isUpper)importData.DataimportText.ParserCombinators.Parsechiding(Line)importData.Set(Set)importqualifiedData.SetasSetimportData.Maybe(mapMaybe,fromMaybe,isNothing)importLanguage.Haskell.TH.SyntaxdataResultv=ErrorString|Okvderiving(Show,Eq,Read,Data,Typeable)instanceMonadResultwherereturn=OkErrors>>=_=ErrorsOkv>>=f=fvfail=ErrorinstanceFunctorResultwherefmap=liftMinstanceApplicativeResultwherepure=return(<*>)=apdataContent=ContentRawString|ContentVarDeref|ContentUrlBoolDeref-- ^ bool: does it include params?|ContentEmbedDeref|ContentMsgDeref|ContentAttrsDerefderiving(Show,Eq,Read,Data,Typeable)dataLine=LineForallDerefBinding|LineIfDeref|LineElseIfDeref|LineElse|LineWith[(Deref,Binding)]|LineMaybeDerefBinding|LineNothing|LineCaseDeref|LineOfBinding|LineTag{_lineTagName::String,_lineAttr::[(MaybeDeref,String,Maybe[Content])],_lineContent::[Content],_lineClasses::[(MaybeDeref,[Content])],_lineAttrs::[Deref],_lineNoNewline::Bool}|LineContent[Content]Bool-- ^ True == avoid newlinesderiving(Eq,Show,Read)parseLines::HamletSettings->String->Result(MaybeNewlineStyle,HamletSettings,[(Int,Line)])parseLinessets=caseparseparserssofLefte->Error$showeRightx->Okxwhereparser=domnewline<-parseNewlineletset'=casemnewlineofNothing->casehamletNewlinessetofDefaultNewlineStyle->set{hamletNewlines=AlwaysNewlines}_->setJustn->set{hamletNewlines=n}res<-many(parseLineset')return(mnewline,set',res)parseNewline=(try(manyeol'>>spaceTabs>>string"$newline ")>>parseNewline'>>=\nl->eol'>>returnnl)<|>returnNothingparseNewline'=(try(string"always")>>return(JustAlwaysNewlines))<|>(try(string"never")>>return(JustNoNewlines))<|>(try(string"text")>>return(JustNewlinesText))eol'=(char'\n'>>return())<|>(string"\r\n">>return())parseLine::HamletSettings->Parser(Int,Line)parseLineset=doss<-fmapsum$many((char' '>>return1)<|>(char'\t'>>fail"Tabs are not allowed in Hamlet indentation"))x<-doctype<|>doctypeDollar<|>comment<|>ssiInclude<|>htmlComment<|>doctypeRaw<|>backslash<|>controlIf<|>controlElseIf<|>(try(string"$else")>>spaceTabs>>eol>>returnLineElse)<|>controlMaybe<|>(try(string"$nothing")>>spaceTabs>>eol>>returnLineNothing)<|>controlForall<|>controlWith<|>controlCase<|>controlOf<|>angle<|>invalidDollar<|>(eol'>>return(LineContent[]True))<|>(do(cs,avoidNewLines)<-contentInContentisEof<-(eof>>returnTrue)<|>returnFalseifnullcs&&ss==0&&isEofthenfail"End of Hamlet template"elsereturn$LineContentcsavoidNewLines)return(ss,x)whereeol'=(char'\n'>>return())<|>(string"\r\n">>return())eol=eof<|>eol'doctype=dotry$string"!!!">>eolreturn$LineContent[ContentRaw$hamletDoctypeset++"\n"]TruedoctypeDollar=do_<-try$string"$doctype "name<-many$noneOf"\r\n"eolcaselookupname$hamletDoctypeNamessetofNothing->fail$"Unknown doctype name: "++nameJustval->return$LineContent[ContentRaw$val++"\n"]TruedoctypeRaw=dox<-try$string"<!"y<-many$noneOf"\r\n"eolreturn$LineContent[ContentRaw$concat[x,y,"\n"]]TrueinvalidDollar=do_<-char'$'fail"Received a command I did not understand. If you wanted a literal $, start the line with a backslash."comment=do_<-try$string"$#"_<-many$noneOf"\r\n"eolreturn$LineContent[]TruessiInclude=dox<-try$string"<!--#"y<-many$noneOf"\r\n"eolreturn$LineContent[ContentRaw$x++y]FalsehtmlComment=do_<-try$string"<!--"_<-manyTillanyChar$try$string"-->"x<-manynonCommentseolreturn$LineContent[ContentRaw$concatx]False{- FIXME -}-- FIXME handle variables?nonComments=(many1$noneOf"\r\n<")<|>(do_<-char'<'(do_<-try$string"!--"_<-manyTillanyChar$try$string"-->"return"")<|>return"<")backslash=do_<-char'\\'(eol>>return(LineContent[ContentRaw"\n"]True))<|>(uncurryLineContent<$>contentInContent)controlIf=do_<-try$string"$if"spacesx<-parseDeref_<-spaceTabseolreturn$LineIfxcontrolElseIf=do_<-try$string"$elseif"spacesx<-parseDeref_<-spaceTabseolreturn$LineElseIfxbinding=doy<-identPatternspaces_<-string"<-"spacesx<-parseDeref_<-spaceTabsreturn(x,y)bindingSep=char','>>spaceTabscontrolMaybe=do_<-try$string"$maybe"spaces(x,y)<-bindingeolreturn$LineMaybexycontrolForall=do_<-try$string"$forall"spaces(x,y)<-bindingeolreturn$LineForallxycontrolWith=do_<-try$string"$with"spacesbindings<-(binding`sepBy`bindingSep)`endBy`eolreturn$LineWith$concatbindings-- concat because endBy returns a [[(Deref,Ident)]]controlCase=do_<-try$string"$case"spacesx<-parseDeref_<-spaceTabseolreturn$LineCasexcontrolOf=do_<-try$string"$of"spacesx<-identPattern_<-spaceTabseolreturn$LineOfxcontentcr=dox<-many$content'crcasecrofInQuotes->void$char'"'NotInQuotes->return()NotInQuotesAttr->return()InContent->eolreturn(cc$mapfstx,anysndx)wherecc[]=[]cc(ContentRawa:ContentRawb:c)=cc$ContentRaw(a++b):ccc(a:b)=a:ccbcontent'cr=contentHash<|>contentAt<|>contentCaret<|>contentUnder<|>contentReg'crcontentHash=dox<-parseHashcasexofLeftstr->return(ContentRawstr,nullstr)Rightderef->return(ContentVarderef,False)contentAt=dox<-parseAtreturn$casexofLeftstr->(ContentRawstr,nullstr)Right(s,y)->(ContentUrlys,False)contentCaret=dox<-parseCaretcasexofLeftstr->return(ContentRawstr,nullstr)Rightderef->return(ContentEmbedderef,False)contentUnder=dox<-parseUndercasexofLeftstr->return(ContentRawstr,nullstr)Rightderef->return(ContentMsgderef,False)contentReg'x=(flip(,)False)<$>contentRegxcontentRegInContent=(ContentRaw.return)<$>noneOf"#@^\r\n"contentRegNotInQuotes=(ContentRaw.return)<$>noneOf"@^#. \t\n\r>"contentRegNotInQuotesAttr=(ContentRaw.return)<$>noneOf"@^ \t\n\r>"contentRegInQuotes=(ContentRaw.return)<$>noneOf"#@^\"\n\r"tagAttribValuenotInQuotes=docr<-(char'"'>>returnInQuotes)<|>returnnotInQuotesfst<$>contentcrtagIdent=char'#'>>TagIdent<$>tagAttribValueNotInQuotestagCond=dod<-between(char':')(char':')parseDereftagClass(Justd)<|>tagAttrib(Justd)tagClassx=doclazz<-char'.'>>tagAttribValueNotInQuoteslethasHash(ContentRaws)=any(=='#')shasHash_=FalseifanyhasHashclazzthenfail$"Invalid class: "++showclazz++". Did you want a space between a class and an ID?"elsereturn(TagClass(x,clazz))tagAttribcond=dos<-many1$noneOf" \t=\r\n><"v<-(char'='>>Just<$>tagAttribValueNotInQuotesAttr)<|>returnNothingreturn$TagAttrib(cond,s,v)tagAttrs=do_<-char'*'d<-between(char'{')(char'}')parseDerefreturn$TagAttribsdtag'=foldrtag''("div",[],[],[])tag''(TagNames)(_,y,z,as)=(s,y,z,as)tag''(TagIdents)(x,y,z,as)=(x,(Nothing,"id",Justs):y,z,as)tag''(TagClasss)(x,y,z,as)=(x,y,s:z,as)tag''(TagAttribs)(x,y,z,as)=(x,s:y,z,as)tag''(TagAttribss)(x,y,z,as)=(x,y,z,s:as)ident::ParserIdentident=doi<-many1(alphaNum<|>char'_'<|>char'\'')whitereturn(Identi)<?>"identifier"parens=between(char'('>>white)(char')'>>white)brackets=between(char'['>>white)(char']'>>white)braces=between(char'{'>>white)(char'}'>>white)comma=char','>>whiteatsign=char'@'>>whiteequals=char'='>>whitewhite=skipMany$char' 'wildDots=string"..">>whiteisVariable(Ident(x:_))=not(isUpperx)isVariable(Ident[])=error"isVariable: bad identifier"isConstructor(Ident(x:_))=isUpperxisConstructor(Ident[])=error"isConstructor: bad identifier"identPattern::ParserBindingidentPattern=gconTrue<|>apatwhereapat=choice[varpat,gconFalse,parenstuplepat,bracketslistpat]varpat=dov<-try$dov<-identguard(isVariablev)returnvoption(BindVarv)$doatsignb<-apatreturn(BindAsvb)<?>"variable"gcon::Bool->ParserBindinggconallowArgs=doc<-try$doc<-dataConstrreturncchoice[recordc,fmap(BindConstrc)(guardallowArgs>>manyapat),return(BindConstrc[])]<?>"constructor"dataConstr=dop<-dcPieceps<-manydcPiecesreturn$toDataConstrppsdcPiece=dox@(Identy)<-identguard$isConstructorxreturnydcPieces=do_<-char'.'dcPiecetoDataConstrx[]=DCUnqualified$IdentxtoDataConstrx(y:ys)=go(x:)yyswheregofrontnext[]=DCQualified(Module$front[])(Identnext)gofrontnext(rest:rests)=go(front.(next:))restrestsrecordc=braces$do(fields,wild)<-option([],False)$goreturn(BindRecordcfieldswild)wherego=(wildDots>>return([],True))<|>(dox<-recordField(xs,wild)<-option([],False)(comma>>go)return(x:xs,wild))recordField=dofield<-identp<-option(BindVarfield)-- support punning(equals>>identPattern)return(field,p)tuplepat=doxs<-identPattern`sepBy`commareturn$casexsof[x]->x_->BindTuplexslistpat=BindList<$>identPattern`sepBy`commaangle=do_<-char'<'name'<-many$noneOf" \t.#\r\n!>"letname=ifnullname'then"div"elsename'xs<-many$try((many$oneOf" \t\r\n")>>(tagIdent<|>tagCond<|>tagClassNothing<|>tagAttrs<|>tagAttribNothing))_<-many$oneOf" \t\r\n"_<-char'>'(c,avoidNewLines)<-contentInContentlet(tn,attr,classes,attrsd)=tag'$TagNamename:xsif'/'`elem`tnthenfail"A tag name may not contain a slash. Perhaps you have a closing tag in your HTML."elsereturn$LineTagtnattrcclassesattrsdavoidNewLinesdataTagPiece=TagNameString|TagIdent[Content]|TagClass(MaybeDeref,[Content])|TagAttrib(MaybeDeref,String,Maybe[Content])|TagAttribsDerefderivingShowdataContentRule=InQuotes|NotInQuotes|NotInQuotesAttr|InContentdataNest=NestLine[Nest]nestLines::[(Int,Line)]->[Nest]nestLines[]=[]nestLines((i,l):rest)=let(deeper,rest')=span(\(i',_)->i'>i)restinNestl(nestLinesdeeper):nestLinesrest'dataDoc=DocForallDerefBinding[Doc]|DocWith[(Deref,Binding)][Doc]|DocCond[(Deref,[Doc])](Maybe[Doc])|DocMaybeDerefBinding[Doc](Maybe[Doc])|DocCaseDeref[(Binding,[Doc])]|DocContentContentderiving(Show,Eq,Read,Data,Typeable)nestToDoc::HamletSettings->[Nest]->Result[Doc]nestToDoc_set[]=Ok[]nestToDocset(Nest(LineForalldi)inside:rest)=doinside'<-nestToDocsetinsiderest'<-nestToDocsetrestOk$DocForalldiinside':rest'nestToDocset(Nest(LineWithdis)inside:rest)=doinside'<-nestToDocsetinsiderest'<-nestToDocsetrestOk$DocWithdisinside':rest'nestToDocset(Nest(LineIfd)inside:rest)=doinside'<-nestToDocsetinside(ifs,el,rest')<-parseCondsset((:)(d,inside'))restrest''<-nestToDocsetrest'Ok$DocCondifsel:rest''nestToDocset(Nest(LineMaybedi)inside:rest)=doinside'<-nestToDocsetinside(nothing,rest')<-caserestofNestLineNothingninside:x->doninside'<-nestToDocsetninsidereturn(Justninside',x)_->return(Nothing,rest)rest''<-nestToDocsetrest'Ok$DocMaybediinside'nothing:rest''nestToDocset(Nest(LineCased)inside:rest)=doletgetOf(Nest(LineOfx)insideC)=doinsideC'<-nestToDocsetinsideCOk(x,insideC')getOf_=Error"Inside a $case there may only be $of. Use '$of _' for a wildcard."cases<-mapMgetOfinsiderest'<-nestToDocsetrestOk$DocCasedcases:rest'nestToDocset(Nest(LineTagtnattrscontentclassesattrsDavoidNewLine)inside:rest)=doletattrFix(x,y,z)=(x,y,[(Nothing,z)])lettakeClass(a,"class",b)=Just(a,fromMaybe[]b)takeClass_=Nothingletclazzes=classes++mapMaybetakeClassattrsletnotClass(_,x,_)=x/="class"letnoclass=filternotClassattrsletattrs'=caseclazzesof[]->mapattrFixnoclass_->(testIncludeClazzesclazzes,"class",map(secondJust)clazzes):mapattrFixnoclassletcloseStyle=ifnot(nullcontent)||not(nullinside)thenCloseSeparateelsehamletCloseStylesettnletend=casecloseStyleofCloseSeparate->DocContent$ContentRaw$"</"++tn++">"_->DocContent$ContentRaw""seal=casecloseStyleofCloseInside->DocContent$ContentRaw"/>"_->DocContent$ContentRaw">"start=DocContent$ContentRaw$"<"++tnattrs''=concatMapattrToContentattrs'newline'=DocContent$ContentRaw$casehamletNewlinessetof{AlwaysNewlines|notavoidNewLine->"\n";_->""}inside'<-nestToDocsetinsiderest'<-nestToDocsetrestOk$start:attrs''++map(DocContent.ContentAttrs)attrsD++seal:mapDocContentcontent++inside'++end:newline':rest'nestToDocset(Nest(LineContentcontentavoidNewLine)inside:rest)=doinside'<-nestToDocsetinsiderest'<-nestToDocsetrestletnewline'=DocContent$ContentRaw$casehamletNewlinessetof{NoNewlines->"";_->ifnextIsContent&&notavoidNewLinethen"\n"else""}nextIsContent=case(inside,rest)of([],NestLineContent{}_:_)->True([],NestLineTag{}_:_)->True_->FalseOk$mapDocContentcontent++newline':inside'++rest'nestToDoc_set(Nest(LineElseIf_)_:_)=Error"Unexpected elseif"nestToDoc_set(NestLineElse_:_)=Error"Unexpected else"nestToDoc_set(NestLineNothing_:_)=Error"Unexpected nothing"nestToDoc_set(Nest(LineOf_)_:_)=Error"Unexpected 'of' (did you forget a $case?)"compressDoc::[Doc]->[Doc]compressDoc[]=[]compressDoc(DocForalldidoc:rest)=DocForalldi(compressDocdoc):compressDocrestcompressDoc(DocWithdisdoc:rest)=DocWithdis(compressDocdoc):compressDocrestcompressDoc(DocMaybedidocmnothing:rest)=DocMaybedi(compressDocdoc)(fmapcompressDocmnothing):compressDocrestcompressDoc(DocCond[(a,x)]Nothing:DocCond[(b,y)]Nothing:rest)|a==b=compressDoc$DocCond[(a,x++y)]Nothing:restcompressDoc(DocCondxy:rest)=DocCond(map(secondcompressDoc)x)(compressDoc`fmap`y):compressDocrestcompressDoc(DocCasedcs:rest)=DocCased(map(secondcompressDoc)cs):compressDocrestcompressDoc(DocContent(ContentRaw""):rest)=compressDocrestcompressDoc(DocContent(ContentRawx):DocContent(ContentRawy):rest)=compressDoc$(DocContent$ContentRaw$x++y):restcompressDoc(DocContentx:rest)=DocContentx:compressDocrestparseDoc::HamletSettings->String->Result(MaybeNewlineStyle,[Doc])parseDocsets=do(mnl,set',ls)<-parseLinessetsletnotEmpty(_,LineContent[]_)=FalsenotEmpty_=Trueletns=nestLines$filternotEmptylsds<-nestToDocset'nsreturn(mnl,compressDocds)attrToContent::(MaybeDeref,String,[(MaybeDeref,Maybe[Content])])->[Doc]attrToContent(Justcond,k,v)=[DocCond[(cond,attrToContent(Nothing,k,v))]Nothing]attrToContent(Nothing,k,[])=[DocContent$ContentRaw$' ':k]attrToContent(Nothing,k,[(Nothing,Nothing)])=[DocContent$ContentRaw$' ':k]attrToContent(Nothing,k,[(Nothing,Justv)])=DocContent(ContentRaw(' ':k++"=\"")):mapDocContentv++[DocContent$ContentRaw"\""]attrToContent(Nothing,k,v)=-- only for classDocContent(ContentRaw(' ':k++"=\"")):concatMapgo(initv)++go'(lastv)++[DocContent$ContentRaw"\""]wherego(Nothing,x)=mapDocContent(fromMaybe[]x)++[DocContent$ContentRaw" "]go(Justb,x)=[DocCond[(b,mapDocContent(fromMaybe[]x)++[DocContent$ContentRaw" "])]Nothing]go'(Nothing,x)=maybe[](mapDocContent)xgo'(Justb,x)=[DocCond[(b,maybe[](mapDocContent)x)]Nothing]-- | Settings for parsing of a hamlet document.dataHamletSettings=HamletSettings{-- | The value to replace a \"!!!\" with. Do not include the trailing-- newline.hamletDoctype::String-- | Should we add newlines to the output, making it more human-readable?-- Useful for client-side debugging but may alter browser page layout.,hamletNewlines::NewlineStyle-- | How a tag should be closed. Use this to switch between HTML, XHTML-- or even XML output.,hamletCloseStyle::String->CloseStyle-- | Mapping from short names in \"$doctype\" statements to full doctype.,hamletDoctypeNames::[(String,String)]}dataNewlineStyle=NoNewlines-- ^ never add newlines|NewlinesText-- ^ add newlines between consecutive text lines|AlwaysNewlines-- ^ add newlines everywhere|DefaultNewlineStylederivingShowinstanceLiftNewlineStylewhereliftNoNewlines=[|NoNewlines|]liftNewlinesText=[|NewlinesText|]liftAlwaysNewlines=[|AlwaysNewlines|]liftDefaultNewlineStyle=[|DefaultNewlineStyle|]instanceLift(String->CloseStyle)wherelift_=[|\s->htmlCloseStyles|]instanceLiftHamletSettingswherelift(HamletSettingsabcd)=[|HamletSettings$(lifta)$(liftb)$(liftc)$(liftd)|]htmlEmptyTags::SetStringhtmlEmptyTags=Set.fromAscList["area","base","basefont","br","col","frame","hr","img","input","isindex","link","meta","param"]-- | Defaults settings: HTML5 doctype and HTML-style empty tags.defaultHamletSettings::HamletSettingsdefaultHamletSettings=HamletSettings"<!DOCTYPE html>"DefaultNewlineStylehtmlCloseStyledoctypeNamesxhtmlHamletSettings::HamletSettingsxhtmlHamletSettings=HamletSettingsdoctypeDefaultNewlineStylexhtmlCloseStyledoctypeNameswheredoctype="<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" "++"\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"htmlCloseStyle::String->CloseStylehtmlCloseStyles=ifSet.membershtmlEmptyTagsthenNoCloseelseCloseSeparatexhtmlCloseStyle::String->CloseStylexhtmlCloseStyles=ifSet.membershtmlEmptyTagsthenCloseInsideelseCloseSeparatedataCloseStyle=NoClose|CloseInside|CloseSeparateparseConds::HamletSettings->([(Deref,[Doc])]->[(Deref,[Doc])])->[Nest]->Result([(Deref,[Doc])],Maybe[Doc],[Nest])parseCondssetfront(NestLineElseinside:rest)=doinside'<-nestToDocsetinsideOk(front[],Justinside',rest)parseCondssetfront(Nest(LineElseIfd)inside:rest)=doinside'<-nestToDocsetinsideparseCondsset(front.(:)(d,inside'))restparseConds_frontrest=Ok(front[],Nothing,rest)doctypeNames::[(String,String)]doctypeNames=[("5","<!DOCTYPE html>"),("html","<!DOCTYPE html>"),("1.1","<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">"),("strict","<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")]dataBinding=BindVarIdent|BindAsIdentBinding|BindConstrDataConstr[Binding]|BindTuple[Binding]|BindList[Binding]|BindRecordDataConstr[(Ident,Binding)]Boolderiving(Eq,Show,Read,Data,Typeable)dataDataConstr=DCQualifiedModuleIdent|DCUnqualifiedIdentderiving(Eq,Show,Read,Data,Typeable)newtypeModule=Module[String]deriving(Eq,Show,Read,Data,Typeable)spaceTabs::ParserStringspaceTabs=many$oneOf" \t"-- | When using conditional classes, it will often be a single class, e.g.:---- > <div :isHome:.homepage>---- If isHome is False, we do not want any class attribute to be present.-- However, due to combining multiple classes together, the most obvious-- implementation would produce a class="". The purpose of this function is to-- work around that. It does so by checking if all the classes on this tag are-- optional. If so, it will only include the class attribute if at least one-- conditional is true.testIncludeClazzes::[(MaybeDeref,[Content])]->MaybeDereftestIncludeClazzescs|any(isNothing.fst)cs=Nothing|otherwise=Just$DerefBranch(DerefIdentspecialOrIdent)$DerefList$mapMaybefstcs-- | This funny hack is to allow us to refer to the 'or' function without-- requiring the user to have it in scope. See how this function is used in-- Text.Hamlet.specialOrIdent::IdentspecialOrIdent=Ident"__or__hamlet__special"