{-# LANGUAGE TemplateHaskell #-}{-# LANGUAGE DeriveDataTypeable #-}{-# OPTIONS_GHC -fno-warn-missing-fields #-}-- QuasiQuotermoduleYesod.Internal.RouteParsing(createRoutes,createRender,createParse,createDispatch,Pieces(..),THResource,parseRoutes,parseRoutesFile,parseRoutesNoCheck,parseRoutesFileNoCheck,Resource(..),Piece(..))whereimportWeb.PathPiecesimportLanguage.Haskell.TH.SyntaximportData.MaybeimportData.EitherimportData.ListimportData.Char(toLower)importqualifiedData.TextimportLanguage.Haskell.TH.QuoteimportData.DataimportqualifiedSystem.IOasSIOdataPieces=SubSite{ssType::Type,ssParse::Exp,ssRender::Exp,ssDispatch::Exp,ssToMasterArg::Exp,ssPieces::[Piece]}|Simple[Piece][String]-- ^ methodsderivingShowtypeTHResource=(String,Pieces)createRoutes::[THResource]->Q[Con]createRoutesres=return$mapgoreswherego(n,SubSite{ssType=s,ssPieces=pieces})=NormalC(mkNamen)$mapMaybego'pieces++[(NotStrict,s)]go(n,Simplepieces_)=NormalC(mkNamen)$mapMaybego'piecesgo'(SinglePiecex)=Just(NotStrict,ConT$mkNamex)go'(MultiPiecex)=Just(NotStrict,ConT$mkNamex)go'(StaticPiece_)=Nothing-- | Generates the set of clauses necesary to parse the given 'Resource's. See 'quasiParse'.createParse::[THResource]->Q[Clause]createParseres=dofinal'<-finalclauses<-mapMgoresreturn$ifareResourcesCompleteresthenclauseselseclauses++[final']whereconsxy=ConP(mkName":")[x,y]go(constr,SubSite{ssParse=p,ssPieces=ps})=dori<-[|Right|]be<-[|ape|](pat',parse)<-mkPat'beps$ri`AppE`ConE(mkNameconstr)x<-newName"x"letpat=initpat'++[VarPx]--let pat = foldr (\a b -> cons [LitP (StringL a), b]) (VarP x) piecesleteitherSub=p`AppE`VarExletbod=be`AppE`parse`AppE`eitherSub--let bod = fmape' `AppE` ConE (mkName constr) `AppE` eitherSubreturn$Clause[foldr1conspat](NormalBbod)[]go(n,Simpleps_)=dori<-[|Right|]be<-[|ape|](pat,parse)<-mkPat'beps$ri`AppE`ConE(mkNamen)return$Clause[foldr1conspat](NormalBparse)[]final=dono<-[|Left"Invalid URL"|]return$Clause[WildP](NormalBno)[]mkPat'::Exp->[Piece]->Exp->Q([Pat],Exp)mkPat'be[MultiPieces]parse=dov<-newName$"var"++sfmp<-[|fromMultiPiece|]letparse'=InfixE(Justparse)be$Just$fmp`AppE`VarEvreturn([VarPv],parse')mkPat'_(MultiPiece_:_)_parse=error"MultiPiece must be last"mkPat'be(StaticPieces:rest)parse=do(x,parse')<-mkPat'berestparseletsp=LitP$StringLsreturn(sp:x,parse')mkPat'be(SinglePieces:rest)parse=dofsp<-[|fromSinglePiece|]v<-newName$"var"++sletparse'=InfixE(Justparse)be$Just$fsp`AppE`VarEv(x,parse'')<-mkPat'berestparse'return(VarPv:x,parse'')mkPat'_[]parse=return([ListP[]],parse)-- | 'ap' for 'Either'ape::EitherString(a->b)->EitherStringa->EitherStringbape(Lefte)_=Lefteape(Right_)(Lefte)=Lefteape(Rightf)(Righta)=Right$fa-- | Generates the set of clauses necesary to render the given 'Resource's. See-- 'quasiRender'.createRender::[THResource]->Q[Clause]createRender=mapMgowherego(n,Simpleps_)=doletps'=zip[1..]psletpat=ConP(mkNamen)$mapMaybego'ps'bod<-mkBodps'return$Clause[pat](NormalB$TupE[bod,ListE[]])[]go(n,SubSite{ssRender=r,ssPieces=pieces})=docons'<-[|\a(b,c)->(a++b,c)|]letconsab=cons'`AppE`a`AppE`bx<-newName"x"letr'=r`AppE`VarExletpieces'=zip[1..]piecesletpat=ConP(mkNamen)$mapMaybego'pieces'++[VarPx]bod<-mkBodpieces'return$Clause[pat](NormalB$consbodr')[]go'(_,StaticPiece_)=Nothinggo'(i,_)=Just$VarP$mkName$"var"++show(i::Int)mkBod::(Showt)=>[(t,Piece)]->QExpmkBod[]=lift([]::[String])mkBod((_,StaticPiecex):xs)=dox'<-liftxpack<-[|Data.Text.pack|]xs'<-mkBodxsreturn$ConE(mkName":")`AppE`(pack`AppE`x')`AppE`xs'mkBod((i,SinglePiece_):xs)=doletx'=VarE$mkName$"var"++showitsp<-[|toSinglePiece|]letx''=tsp`AppE`x'xs'<-mkBodxsreturn$ConE(mkName":")`AppE`x''`AppE`xs'mkBod((i,MultiPiece_):_)=doletx'=VarE$mkName$"var"++showitmp<-[|toMultiPiece|]return$tmp`AppE`x'-- | Whether the set of resources cover all possible URLs.areResourcesComplete::[THResource]->BoolareResourcesCompleteres=let(slurps,noSlurps)=partitionEithers$mapMaybegoresincaseslurpsof[]->False_->letminSlurp=minimumslurpsinhelperminSlurp$reverse$sortnoSlurpswherego::THResource->Maybe(EitherIntInt)go(_,Simpleps_)=casereversepsof[]->Just$Right0(MultiPiece_:rest)->go'Leftrestx->go'Rightxgo(n,SubSite{ssPieces=ps})=go(n,Simple(ps++[MultiPiece""])[])go'bx=ifallisSinglexthenJust(b$lengthx)elseNothinghelper0_=Truehelper_[]=Falsehelperm(i:is)|i>=m=helpermis|i+1==m=helperiis|otherwise=FalseisSingle(SinglePiece_)=TrueisSingle_=FalsenotStatic::Piece->BoolnotStaticStaticPiece{}=FalsenotStatic_=TruecreateDispatch::Exp-- ^ modify a master handler->Exp-- ^ convert a subsite handler to a master handler->[THResource]->Q[Clause]createDispatchmodMastertoMaster=mapMgowherego::(String,Pieces)->QClausego(n,Simplepsmethods)=dometh<-newName"method"xs<-mapMnewName$replicate(length$filternotStaticps)"x"letpat=[ConP(mkNamen)$mapVarPxs,ifnullmethodsthenWildPelseVarPmeth]bod<-go'nmethxsmethodsreturn$Clausepat(NormalBbod)[]go(n,SubSite{ssDispatch=d,ssToMasterArg=tma,ssPieces=ps})=dometh<-newName"method"x<-newName"x"xs<-mapMnewName$replicate(length$filternotStaticps)"x"letpat=[ConP(mkNamen)$mapVarPxs++[VarPx],VarPmeth]letbod=d`AppE`VarEx`AppE`VarEmethfmap'<-[|fmap|]letrouteToMaster=foldlAppE(ConE(mkNamen))$mapVarExstma'=foldlAppEtma$mapVarExslettoMaster'=toMaster`AppE`routeToMaster`AppE`tma'`AppE`VarExletbod'=InfixE(JusttoMaster')fmap'(Justbod)letbod''=InfixE(JustmodMaster)fmap'(Justbod')return$Clausepat(NormalBbod'')[]go'n_xs[]=dojus<-[|Just|]letbod=foldlAppE(VarE$mkName$"handle"++n)$mapVarExsreturn$jus`AppE`(modMaster`AppE`bod)go'nmethxsmethods=donoth<-[|Nothing|]j<-[|Just|]letnoMatch=MatchWildP(NormalBnoth)[]return$CaseE(VarEmeth)$map(go''nxsj)methods++[noMatch]go''nxsjmethod=letpat=LitP$StringLmethodfunc=maptoLowermethod++nbod=foldlAppE(VarE$mkNamefunc)$mapVarExsinMatchpat(NormalB$j`AppE`(modMaster`AppE`bod))[]-- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for-- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the-- checking. See documentation site for details on syntax.parseRoutes::QuasiQuoterparseRoutes=QuasiQuoter{quoteExp=x,quotePat=y}wherexs=doletres=resourcesFromStringscasefindOverlapsresof[]->liftresz->error$"Overlapping routes: "++unlines(mapshowz)y=dataToPatQ(constNothing).resourcesFromStringparseRoutesFile::FilePath->QExpparseRoutesFilefp=dos<-qRunIO$readUtf8FilefpquoteExpparseRoutessparseRoutesFileNoCheck::FilePath->QExpparseRoutesFileNoCheckfp=dos<-qRunIO$readUtf8FilefpquoteExpparseRoutesNoChecksreadUtf8File::FilePath->IOStringreadUtf8Filefp=doh<-SIO.openFilefpSIO.ReadModeSIO.hSetEncodinghSIO.utf8_bomSIO.hGetContentsh-- | Same as 'parseRoutes', but performs no overlap checking.parseRoutesNoCheck::QuasiQuoterparseRoutesNoCheck=QuasiQuoter{quoteExp=x,quotePat=y}wherex=lift.resourcesFromStringy=dataToPatQ(constNothing).resourcesFromStringinstanceLiftResourcewherelift(Resourcespsh)=dor<-[|Resource|]s'<-liftsps'<-liftpsh'<-lifthreturn$r`AppE`s'`AppE`ps'`AppE`h'-- | A single resource pattern.---- First argument is the name of the constructor, second is the URL pattern to-- match, third is how to dispatch.dataResource=ResourceString[Piece][String]deriving(Read,Show,Eq,Data,Typeable)-- | A single piece of a URL, delimited by slashes.---- In the case of StaticPiece, the argument is the value of the piece; for the-- other constructors, it is the name of the parameter represented by this-- piece. That value is not used here, but may be useful elsewhere.dataPiece=StaticPieceString|SinglePieceString|MultiPieceStringderiving(Read,Show,Eq,Data,Typeable)instanceLiftPiecewherelift(StaticPieces)=doc<-[|StaticPiece|]s'<-liftsreturn$c`AppE`s'lift(SinglePieces)=doc<-[|SinglePiece|]s'<-liftsreturn$c`AppE`s'lift(MultiPieces)=doc<-[|MultiPiece|]s'<-liftsreturn$c`AppE`s'-- | Convert a multi-line string to a set of resources. See documentation for-- the format of this string. This is a partial function which calls 'error' on-- invalid input.resourcesFromString::String->[Resource]resourcesFromString=mapMaybego.lineswheregos=casetakeWhile(/="--")$wordssof(pattern:constr:rest)->letpieces=piecesFromString$drop1SlashpatterninJust$Resourceconstrpiecesrest[]->Nothing_->error$"Invalid resource line: "++sdrop1Slash::String->Stringdrop1Slash('/':x)=xdrop1Slashx=xpiecesFromString::String->[Piece]piecesFromString""=[]piecesFromStringx=let(y,z)=break(=='/')xinpieceFromStringy:piecesFromString(drop1Slashz)pieceFromString::String->PiecepieceFromString('#':x)=SinglePiecexpieceFromString('*':x)=MultiPiecexpieceFromStringx=StaticPiecex-- n^2, should be a way to speed it upfindOverlaps::[Resource]->[(Resource,Resource)]findOverlaps=go.mapjustPieceswherejustPieces::Resource->([Piece],Resource)justPiecesr@(Resource_ps_)=(ps,r)go[]=[]go(x:xs)=mapMaybe(mOverlapx)xs++goxsmOverlap::([Piece],Resource)->([Piece],Resource)->Maybe(Resource,Resource)mOverlap(StaticPiecex:xs,xr)(StaticPiecey:ys,yr)|x==y=mOverlap(xs,xr)(ys,yr)|otherwise=NothingmOverlap(MultiPiece_:_,xr)(_,yr)=Just(xr,yr)mOverlap(_,xr)(MultiPiece_:_,yr)=Just(xr,yr)mOverlap([],xr)([],yr)=Just(xr,yr)mOverlap([],_)(_,_)=NothingmOverlap(_,_)([],_)=NothingmOverlap(_:xs,xr)(_:ys,yr)=mOverlap(xs,xr)(ys,yr)