{-# LANGUAGE TemplateHaskell #-}{-# LANGUAGE DeriveDataTypeable #-}moduleWeb.Routes.Quasi.Parse(-- * Quasi quoterparseRoutes,parseRoutesNoCheck,Resource(..),Piece(..))whereimportLanguage.Haskell.TH.SyntaximportLanguage.Haskell.TH.QuoteimportData.DataimportData.CharimportData.Maybe-- | 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=QuasiQuoterxywherexs=doletres=resourcesFromStringscasefindOverlapsresof[]->liftresz->error$"Overlapping routes: "++unlines(mapshowz)y=dataToPatQ(constNothing).resourcesFromString-- | Same as 'parseRoutes', but performs no overlap checking.parseRoutesNoCheck::QuasiQuoterparseRoutesNoCheck=QuasiQuoterxywherex=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=mapgo.filter(not.null).maptrim.lineswheregos=casewordssof(pattern:constr:rest)->letpieces=piecesFromString$drop1SlashpatterninResourceconstrpiecesrest_->error$"Invalid resource line: "++s-- | Drop leading whitespace.trim::String->Stringtrim=dropWhileisSpacedrop1Slash::String->Stringdrop1Slash('/':x)=xdrop1Slashx=xpiecesFromString::String->[Piece]piecesFromString""=[]piecesFromStringx=let(y,z)=break(=='/')xinpieceFromStringy:piecesFromString(drop1Slashz)pieceFromString::String->PiecepieceFromString('#':x)=SinglePiecexpieceFromString('*':x)=MultiPiecexpieceFromStringx=StaticPiecexfindOverlaps::[Resource]->[(Resource,Resource)]findOverlaps=gos.mapjustPieceswherejustPiecesr@(Resource_ps_)=(ps,r)gos[]=[]gos(x:xs)=mapMaybe(gox)xs++gosxsgo(StaticPiecex:xs,xr)(StaticPiecey:ys,yr)|x==y=go(xs,xr)(ys,yr)|otherwise=Nothinggo(MultiPiece_:_,xr)(_,yr)=Just(xr,yr)go(_,xr)(MultiPiece_:_,yr)=Just(xr,yr)go([],xr)([],yr)=Just(xr,yr)go([],_)(_,_)=Nothinggo(_,_)([],_)=Nothinggo(_:xs,xr)(_:ys,yr)=go(xs,xr)(ys,yr)