module Web.Routes.Quasi.Parse
(
parseRoutes
, parseRoutesNoCheck
, Resource (..)
, Piece (..)
) where
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Data.Data
import Data.Char
import Data.Maybe
parseRoutes :: QuasiQuoter
parseRoutes = QuasiQuoter x y where
x s = do
let res = resourcesFromString s
case findOverlaps res of
[] -> lift res
z -> error $ "Overlapping routes: " ++ unlines (map show z)
y = dataToPatQ (const Nothing) . resourcesFromString
parseRoutesNoCheck :: QuasiQuoter
parseRoutesNoCheck = QuasiQuoter x y where
x = lift . resourcesFromString
y = dataToPatQ (const Nothing) . resourcesFromString
instance Lift Resource where
lift (Resource s ps h) = do
r <- [|Resource|]
s' <- lift s
ps' <- lift ps
h' <- lift h
return $ r `AppE` s' `AppE` ps' `AppE` h'
data Resource = Resource String [Piece] [String]
deriving (Read, Show, Eq, Data, Typeable)
data Piece = StaticPiece String
| SinglePiece String
| MultiPiece String
deriving (Read, Show, Eq, Data, Typeable)
instance Lift Piece where
lift (StaticPiece s) = do
c <- [|StaticPiece|]
s' <- lift s
return $ c `AppE` s'
lift (SinglePiece s) = do
c <- [|SinglePiece|]
s' <- lift s
return $ c `AppE` s'
lift (MultiPiece s) = do
c <- [|MultiPiece|]
s' <- lift s
return $ c `AppE` s'
resourcesFromString :: String -> [Resource]
resourcesFromString =
mapMaybe go . lines
where
go s =
case takeWhile (/= "--") $ words s of
(pattern:constr:rest) ->
let pieces = piecesFromString $ drop1Slash pattern
in Just $ Resource constr pieces rest
[] -> Nothing
_ -> error $ "Invalid resource line: " ++ s
trim :: String -> String
trim = dropWhile isSpace
drop1Slash :: String -> String
drop1Slash ('/':x) = x
drop1Slash x = x
piecesFromString :: String -> [Piece]
piecesFromString "" = []
piecesFromString x =
let (y, z) = break (== '/') x
in pieceFromString y : piecesFromString (drop1Slash z)
pieceFromString :: String -> Piece
pieceFromString ('#':x) = SinglePiece x
pieceFromString ('*':x) = MultiPiece x
pieceFromString x = StaticPiece x
findOverlaps :: [Resource] -> [(Resource, Resource)]
findOverlaps = gos . map justPieces
where
justPieces r@(Resource _ ps _) = (ps, r)
gos [] = []
gos (x:xs) = mapMaybe (go x) xs ++ gos xs
go (StaticPiece x:xs, xr) (StaticPiece y:ys, yr)
| x == y = go (xs, xr) (ys, yr)
| otherwise = Nothing
go (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)
go (_, xr) (MultiPiece _:_, yr) = Just (xr, yr)
go ([], xr) ([], yr) = Just (xr, yr)
go ([], _) (_, _) = Nothing
go (_, _) ([], _) = Nothing
go (_:xs, xr) (_:ys, yr) = go (xs, xr) (ys, yr)