{-# LANGUAGE TemplateHaskell #-}{-# LANGUAGE GeneralizedNewtypeDeriving #-}{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE CPP #-}{-# LANGUAGE RecordWildCards #-}{-# OPTIONS_GHC -fno-warn-missing-fields #-}{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}-- | For lack of a better name... a parameterized version of Julius.moduleText.Shakespeare(ShakespeareSettings(..),PreConvert(..),WrapInsertion(..),PreConversion(..),defaultShakespeareSettings,shakespeare,shakespeareFile,shakespeareFileReload-- * low-level,shakespeareFromString,shakespeareUsedIdentifiers,RenderUrl,VarType,Deref,Parser#ifdef TEST_EXPORT,preFilter#endif)whereimportData.List(intersperse)importData.Char(isAlphaNum,isSpace)importText.ParserCombinators.Parsechiding(Line,parse,Parser)importText.Parsec.Prim(modifyState,Parsec)importLanguage.Haskell.TH.Quote(QuasiQuoter(..))importLanguage.Haskell.TH(appE)importLanguage.Haskell.TH.Syntax#if !MIN_VERSION_template_haskell(2,8,0)importLanguage.Haskell.TH.Syntax.Internals#endifimportData.Text.Lazy.Builder(Builder,fromText)importData.MonoidimportSystem.IO.Unsafe(unsafePerformIO)importqualifiedData.TextasTSimportqualifiedData.Text.LazyasTLimportText.Shakespeare.BaseimportPreludehiding(catch)importControl.Exception(throwIO,catch)-- for pre conversionimportSystem.Process(readProcess)-- | A parser with a user state of [String]typeParser=ParsecString[String]-- | run a parser with a user state of [String]parse::GenParsertok[a1]a->SourceName->[tok]->EitherParseErroraparsep=runParserp[]-- move to Shakespeare.Base?readFileQ::FilePath->QStringreadFileQfp=qRunIO$readFileUtf8fp-- move to Shakespeare.Base?readFileUtf8::FilePath->IOStringreadFileUtf8fp=fmapTL.unpack$readUtf8Filefp-- | Coffeescript, TypeScript, and other languages compiles down to Javascript.-- Previously we waited until the very end, at the rendering stage to perform this compilation.-- Lets call is a post-conversion-- This had the advantage that all Haskell values were inserted first:-- for example a value could be inserted that Coffeescript would compile into Javascript.-- While that is perhaps a safer approach, the advantage is not used in practice:-- it was that way mainly for ease of implementation.-- The down-side is the template must be compiled down to Javascript during every request.-- If instead we do a pre-conversion to compile down to Javascript,-- we only need to perform the compilation once.---- The problem then is the insertion of Haskell values: we need a hole for-- them. This can be done with variables known to the language.-- During the pre-conversion we first modify all Haskell insertions-- So #{a} is change to shakespeare_var_a-- Then we can place the Haskell values in a function wrapper that exposes-- those variables: (function(shakespeare_var_a){ ... shakespeare_var_a ...})-- TypeScript can compile that, and then we tack an application of the-- Haskell values onto the result: (#{a})---- preEscapeIgnoreBalanced is used to not insert backtacks for variable already inside strings or backticks.-- coffeescript will happily ignore the interpolations, and backticks would not be treated as escaping in that context.-- preEscapeIgnoreLine was added to ignore comments (which in Coffeescript begin with a '#')dataPreConvert=PreConvert{preConvert::PreConversion,preEscapeIgnoreBalanced::[Char],preEscapeIgnoreLine::[Char],wrapInsertion::MaybeWrapInsertion}dataWrapInsertion=WrapInsertion{wrapInsertionIndent::MaybeString,wrapInsertionStartBegin::String,wrapInsertionSeparator::String,wrapInsertionStartClose::String,wrapInsertionEnd::String,wrapInsertionAddParens::Bool}dataPreConversion=ReadProcessString[String]|IddataShakespeareSettings=ShakespeareSettings{varChar::Char,urlChar::Char,intChar::Char,toBuilder::Exp,wrap::Exp,unwrap::Exp,justVarInterpolation::Bool,preConversion::MaybePreConvert,modifyFinalValue::MaybeExp-- ^ A transformation applied to the final expression. Most often, this-- would be used to force the type of the expression to help make more-- meaningful error messages.}defaultShakespeareSettings::ShakespeareSettingsdefaultShakespeareSettings=ShakespeareSettings{varChar='#',urlChar='@',intChar='^',justVarInterpolation=False,preConversion=Nothing,modifyFinalValue=Nothing}instanceLiftPreConvertwherelift(PreConvertconvertignorecommentwrapInsertion)=[|PreConvert$(liftconvert)$(liftignore)$(liftcomment)$(liftwrapInsertion)|]instanceLiftWrapInsertionwherelift(WrapInsertionindentsbsepscewp)=[|WrapInsertion$(liftindent)$(liftsb)$(liftsep)$(liftsc)$(lifte)$(liftwp)|]instanceLiftPreConversionwherelift(ReadProcesscommandargs)=[|ReadProcess$(liftcommand)$(liftargs)|]liftId=[|Id|]instanceLiftShakespeareSettingswherelift(ShakespeareSettingsx1x2x3x4x5x6x7x8x9)=[|ShakespeareSettings$(liftx1)$(liftx2)$(liftx3)$(liftExpx4)$(liftExpx5)$(liftExpx6)$(liftx7)$(liftx8)$(liftMExpx9)|]whereliftExp(VarEn)=[|VarE$(liftNamen)|]liftExp(ConEn)=[|ConE$(liftNamen)|]liftExp_=error"liftExp only supports VarE and ConE"liftMExpNothing=[|Nothing|]liftMExp(Juste)=[|Just|]`appE`liftExpeliftName(Name(OccNamea)b)=[|Name(OccName$(lifta))$(liftFlavourb)|]liftFlavourNameS=[|NameS|]liftFlavour(NameQ(ModNamea))=[|NameQ(ModName$(lifta))|]liftFlavour(NameU_)=error"liftFlavour NameU"-- [|NameU $(lift $ fromIntegral a)|]liftFlavour(NameL_)=error"liftFlavour NameL"-- [|NameU $(lift $ fromIntegral a)|]liftFlavour(NameGns(PkgNamep)(ModNamem))=[|NameG$(liftNSns)(PkgName$(liftp))(ModName$(liftm))|]liftNSVarName=[|VarName|]liftNSDataName=[|DataName|]typeQueryParameters=[(TS.Text,TS.Text)]typeRenderUrlurl=(url->QueryParameters->TS.Text)typeShakespeareurl=RenderUrlurl->BuilderdataContent=ContentRawString|ContentVarDeref|ContentUrlDeref|ContentUrlParamDeref|ContentMixDerefderiving(Show,Eq)typeContents=[Content]eShowErrors::EitherParseErrorc->ceShowErrors=either(error.show)idcontentFromString::ShakespeareSettings->String->[Content]contentFromString_""=[]contentFromStringrss=compressContents$eShowErrors$parse(parseContentsrs)sswherecompressContents::Contents->ContentscompressContents[]=[]compressContents(ContentRawx:ContentRawy:z)=compressContents$ContentRaw(x++y):zcompressContents(x:y)=x:compressContentsyparseContents::ShakespeareSettings->ParserContentsparseContents=many1.parseContentwhereparseContent::ShakespeareSettings->ParserContentparseContentShakespeareSettings{..}=parseVar'<|>parseUrl'<|>parseInt'<|>parseChar'whereparseVar'=eitherContentRawContentVar`fmap`parseVarvarCharparseUrl'=eitherContentRawcontentUrl`fmap`parseUrlurlChar'?'wherecontentUrl(d,False)=ContentUrldcontentUrl(d,True)=ContentUrlParamdparseInt'=eitherContentRawContentMix`fmap`parseIntintCharparseChar'=ContentRaw`fmap`many1(noneOf[varChar,urlChar,intChar])preFilter::ShakespeareSettings->String->IOStringpreFilterShakespeareSettings{..}template=casepreConversionofNothing->returntemplateJustpre@(PreConvertconvert__mWrapI)->ifallisSpacetemplatethenreturntemplateelselet(groups,rvars)=eShowErrors$parse(parseConvertWrapInsertionmWrapIpre)templatetemplatevars=reverservarsparsed=mconcatgroupswithVars=(addVarsmWrapIvarsparsed)inapplyVarsmWrapIvars`fmap`caseconvertofId->returnwithVarsReadProcesscommandargs->readProcesscommandargswithVars`catch`(\ex->printwithVars>>throwIO(ex::IOError))whereaddIndent::MaybeString->String->StringaddIndentNothingstr=straddIndent(Justindent)str=mapLines(\line->indent<>line)strwheremapLinesf=unlines.mapf.linesshakespeare_prefix="shakespeare_var_"shakespeare_var_conversion('@':'?':'{':str)=shakespeare_var_conversion('@':'{':str)shakespeare_var_conversion(_:'{':str)=shakespeare_prefix<>filterisAlphaNum(initstr)shakespeare_var_conversionerr=error$"did not expect: "<>errapplyVars_[]str=strapplyVarsNothing_str=strapplyVars(JustWrapInsertion{..})varsstr=(ifwrapInsertionAddParensthen"("else"")<>removeTrailingSemiColon<>(ifwrapInsertionAddParensthen")"else"")<>"("<>(mconcat$intersperse", "vars)<>");\n"whereremoveTrailingSemiColon=reverse$dropWhile(\c->c==';'||isSpacec)(reversestr)addVars_[]str=straddVarsNothing_str=straddVars(JustWrapInsertion{..})varsstr=wrapInsertionStartBegin<>(mconcat$interspersewrapInsertionSeparator$mapshakespeare_var_conversionvars)<>wrapInsertionStartClose<>addIndentwrapInsertionIndentstr<>wrapInsertionEndparseConvertWrapInsertionNothing=parseConvertidparseConvertWrapInsertion(Just_)=parseConvertshakespeare_var_conversionparseConvertvarConvertPreConvert{..}=dostr<-many1$choice$map(try.escapedParse)preEscapeIgnoreBalanced++[mainParser]st<-getStatereturn(str,st)whereescapedParseignoreC=do_<-charignoreCinside<-many$noneOf[ignoreC]_<-charignoreCreturn$ignoreC:inside++[ignoreC]mainParser=parseVar'<|>parseUrl'<|>parseInt'<|>parseCommentLinepreEscapeIgnoreLine<|>parseChar'preEscapeIgnoreLinepreEscapeIgnoreBalancedrecordRight(Leftstr)=returnstrrecordRight(Rightstr)=modifyState(\vars->str:vars)>>(return$varConvertstr)newLine="\r\n"parseCommentLinecs=dobegin<-oneOfcscomment<-many$noneOfnewLinereturn$begin:commentparseVar'::(ParsecString[String])StringparseVar'=recordRight=<<parseVarStringvarCharparseUrl'=recordRight=<<parseUrlStringurlChar'?'parseInt'=recordRight=<<parseIntStringintCharparseChar'commentsignores=many1(noneOf([varChar,urlChar,intChar]++comments++ignores))pack'::String->TS.Textpack'=TS.pack#if !MIN_VERSION_text(0, 11, 2){-# NOINLINE pack' #-}#endifcontentsToShakespeare::ShakespeareSettings->[Content]->QExpcontentsToShakespearersa=dor<-newName"_render"c<-mapM(contentToBuilderr)acompiledTemplate<-casecof-- Make sure we convert this mempty using toBuilder to pin down the-- type appropriately[]->fmap(AppE$wraprs)[|mempty|][x]->returnx_->domc<-[|mconcat|]return$mc`AppE`ListEcfmap(maybeidAppE$modifyFinalValuers)$ifjustVarInterpolationrsthenreturncompiledTemplateelsereturn$LamE[VarPr]compiledTemplatewherecontentToBuilder::Name->Content->QExpcontentToBuilder_(ContentRaws')=dots<-[|fromText.pack'|]return$wraprs`AppE`(ts`AppE`LitE(StringLs'))contentToBuilder_(ContentVard)=return$wraprs`AppE`(toBuilderrs`AppE`derefToExp[]d)contentToBuilderr(ContentUrld)=dots<-[|fromText|]return$wraprs`AppE`(ts`AppE`(VarEr`AppE`derefToExp[]d`AppE`ListE[]))contentToBuilderr(ContentUrlParamd)=dots<-[|fromText|]up<-[|\r'(u,p)->r'up|]return$wraprs`AppE`(ts`AppE`(up`AppE`VarEr`AppE`derefToExp[]d))contentToBuilderr(ContentMixd)=return$derefToExp[]d`AppE`VarErshakespeare::ShakespeareSettings->QuasiQuotershakespearer=QuasiQuoter{quoteExp=shakespeareFromStringr}shakespeareFromString::ShakespeareSettings->String->QExpshakespeareFromStringrstr=dos<-qRunIO$preFilterrstrcontentsToShakespearer$contentFromStringrsshakespeareFile::ShakespeareSettings->FilePath->QExpshakespeareFilerfp=do#ifdef GHC_7_4qAddDependentFilefp#endifreadFileQfp>>=shakespeareFromStringrdataVarType=VTPlain|VTUrl|VTUrlParam|VTMixingetVars::Content->[(Deref,VarType)]getVarsContentRaw{}=[]getVars(ContentVard)=[(d,VTPlain)]getVars(ContentUrld)=[(d,VTUrl)]getVars(ContentUrlParamd)=[(d,VTUrlParam)]getVars(ContentMixd)=[(d,VTMixin)]dataVarExpurl=EPlainBuilder|EUrlurl|EUrlParam(url,[(TS.Text,TS.Text)])|EMixin(Shakespeareurl)-- | Determine which identifiers are used by the given template, useful for-- creating systems like yesod devel.shakespeareUsedIdentifiers::ShakespeareSettings->String->[(Deref,VarType)]shakespeareUsedIdentifierssettings=concatMapgetVars.contentFromStringsettingsshakespeareFileReload::ShakespeareSettings->FilePath->QExpshakespeareFileReloadrsfp=dostr<-readFileQfps<-qRunIO$preFilterrsstrletb=shakespeareUsedIdentifiersrssc<-mapMvtToExpbrt<-[|shakespeareRuntime|]wrap'<-[|\x->$(return$wraprs).x|]r'<-liftrsreturn$wrap'`AppE`(rt`AppE`r'`AppE`(LitE$StringLfp)`AppE`ListEc)wherevtToExp::(Deref,VarType)->QExpvtToExp(d,vt)=dod'<-liftdc'<-cvtreturn$TupE[d',c'`AppE`derefToExp[]d]wherec::VarType->QExpcVTPlain=[|EPlain.$(return$toBuilderrs)|]cVTUrl=[|EUrl|]cVTUrlParam=[|EUrlParam|]cVTMixin=[|\x->EMixin$\r->$(return$unwraprs)$xr|]shakespeareRuntime::ShakespeareSettings->FilePath->[(Deref,VarExpurl)]->ShakespeareurlshakespeareRuntimersfpcdrender'=unsafePerformIO$dostr<-readFileUtf8fps<-preFilterrsstrreturn$mconcat$mapgo$contentFromStringrsswherego::Content->Buildergo(ContentRaws)=fromText$TS.packsgo(ContentVard)=caselookupdcdofJust(EPlains)->s_->error$showd++": expected EPlain"go(ContentUrld)=caselookupdcdofJust(EUrlu)->fromText$render'u[]_->error$showd++": expected EUrl"go(ContentUrlParamd)=caselookupdcdofJust(EUrlParam(u,p))->fromText$render'up_->error$showd++": expected EUrlParam"go(ContentMixd)=caselookupdcdofJust(EMixinm)->mrender'_->error$showd++": expected EMixin"