module Yesod.Internal.RouteParsing
( createRoutes
, createRender
, createParse
, createDispatch
, Pieces (..)
, THResource
, parseRoutes
, parseRoutesFile
, parseRoutesNoCheck
, parseRoutesFileNoCheck
, Resource (..)
, Piece (..)
) where
import Web.PathPieces
import Language.Haskell.TH.Syntax
import Data.Maybe
import Data.Either
import Data.List
import Data.Char (toLower)
import qualified Data.Text
import Language.Haskell.TH.Quote
import Data.Data
import qualified System.IO as SIO
data Pieces =
SubSite
{ ssType :: Type
, ssParse :: Exp
, ssRender :: Exp
, ssDispatch :: Exp
, ssToMasterArg :: Exp
, ssPieces :: [Piece]
}
| Simple [Piece] [String]
deriving Show
type THResource = (String, Pieces)
createRoutes :: [THResource] -> Q [Con]
createRoutes res =
return $ map go res
where
go (n, SubSite{ssType = s, ssPieces = pieces}) =
NormalC (mkName n) $ mapMaybe go' pieces ++ [(NotStrict, s)]
go (n, Simple pieces _) = NormalC (mkName n) $ mapMaybe go' pieces
go' (SinglePiece x) = Just (NotStrict, ConT $ mkName x)
go' (MultiPiece x) = Just (NotStrict, ConT $ mkName x)
go' (StaticPiece _) = Nothing
createParse :: [THResource] -> Q [Clause]
createParse res = do
final' <- final
clauses <- mapM go res
return $ if areResourcesComplete res
then clauses
else clauses ++ [final']
where
cons x y = ConP (mkName ":") [x, y]
go (constr, SubSite{ssParse = p, ssPieces = ps}) = do
ri <- [|Right|]
be <- [|ape|]
(pat', parse) <- mkPat' be ps $ ri `AppE` ConE (mkName constr)
x <- newName "x"
let pat = init pat' ++ [VarP x]
let eitherSub = p `AppE` VarE x
let bod = be `AppE` parse `AppE` eitherSub
return $ Clause [foldr1 cons pat] (NormalB bod) []
go (n, Simple ps _) = do
ri <- [|Right|]
be <- [|ape|]
(pat, parse) <- mkPat' be ps $ ri `AppE` ConE (mkName n)
return $ Clause [foldr1 cons pat] (NormalB parse) []
final = do
no <- [|Left "Invalid URL"|]
return $ Clause [WildP] (NormalB no) []
mkPat' :: Exp -> [Piece] -> Exp -> Q ([Pat], Exp)
mkPat' be [MultiPiece s] parse = do
v <- newName $ "var" ++ s
fmp <- [|fromMultiPiece|]
let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v
return ([VarP v], parse')
mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last"
mkPat' be (StaticPiece s:rest) parse = do
(x, parse') <- mkPat' be rest parse
let sp = LitP $ StringL s
return (sp : x, parse')
mkPat' be (SinglePiece s:rest) parse = do
fsp <- [|fromSinglePiece|]
v <- newName $ "var" ++ s
let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v
(x, parse'') <- mkPat' be rest parse'
return (VarP v : x, parse'')
mkPat' _ [] parse = return ([ListP []], parse)
ape :: Either String (a -> b) -> Either String a -> Either String b
ape (Left e) _ = Left e
ape (Right _) (Left e) = Left e
ape (Right f) (Right a) = Right $ f a
createRender :: [THResource] -> Q [Clause]
createRender = mapM go
where
go (n, Simple ps _) = do
let ps' = zip [1..] ps
let pat = ConP (mkName n) $ mapMaybe go' ps'
bod <- mkBod ps'
return $ Clause [pat] (NormalB $ TupE [bod, ListE []]) []
go (n, SubSite{ssRender = r, ssPieces = pieces}) = do
cons' <- [|\a (b, c) -> (a ++ b, c)|]
let cons a b = cons' `AppE` a `AppE` b
x <- newName "x"
let r' = r `AppE` VarE x
let pieces' = zip [1..] pieces
let pat = ConP (mkName n) $ mapMaybe go' pieces' ++ [VarP x]
bod <- mkBod pieces'
return $ Clause [pat] (NormalB $ cons bod r') []
go' (_, StaticPiece _) = Nothing
go' (i, _) = Just $ VarP $ mkName $ "var" ++ show (i :: Int)
mkBod :: (Show t) => [(t, Piece)] -> Q Exp
mkBod [] = lift ([] :: [String])
mkBod ((_, StaticPiece x):xs) = do
x' <- lift x
pack <- [|Data.Text.pack|]
xs' <- mkBod xs
return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs'
mkBod ((i, SinglePiece _):xs) = do
let x' = VarE $ mkName $ "var" ++ show i
tsp <- [|toSinglePiece|]
let x'' = tsp `AppE` x'
xs' <- mkBod xs
return $ ConE (mkName ":") `AppE` x'' `AppE` xs'
mkBod ((i, MultiPiece _):_) = do
let x' = VarE $ mkName $ "var" ++ show i
tmp <- [|toMultiPiece|]
return $ tmp `AppE` x'
areResourcesComplete :: [THResource] -> Bool
areResourcesComplete res =
let (slurps, noSlurps) = partitionEithers $ mapMaybe go res
in case slurps of
[] -> False
_ -> let minSlurp = minimum slurps
in helper minSlurp $ reverse $ sort noSlurps
where
go :: THResource -> Maybe (Either Int Int)
go (_, Simple ps _) =
case reverse ps of
[] -> Just $ Right 0
(MultiPiece _:rest) -> go' Left rest
x -> go' Right x
go (n, SubSite{ssPieces = ps}) =
go (n, Simple (ps ++ [MultiPiece ""]) [])
go' b x = if all isSingle x then Just (b $ length x) else Nothing
helper 0 _ = True
helper _ [] = False
helper m (i:is)
| i >= m = helper m is
| i + 1 == m = helper i is
| otherwise = False
isSingle (SinglePiece _) = True
isSingle _ = False
notStatic :: Piece -> Bool
notStatic StaticPiece{} = False
notStatic _ = True
createDispatch :: Exp
-> Exp
-> [THResource]
-> Q [Clause]
createDispatch modMaster toMaster = mapM go
where
go :: (String, Pieces) -> Q Clause
go (n, Simple ps methods) = do
meth <- newName "method"
xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"
let pat = [ ConP (mkName n) $ map VarP xs
, if null methods then WildP else VarP meth
]
bod <- go' n meth xs methods
return $ Clause pat (NormalB bod) []
go (n, SubSite{ssDispatch = d, ssToMasterArg = tma, ssPieces = ps}) = do
meth <- newName "method"
x <- newName "x"
xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"
let pat = [ConP (mkName n) $ map VarP xs ++ [VarP x], VarP meth]
let bod = d `AppE` VarE x `AppE` VarE meth
fmap' <- [|fmap|]
let routeToMaster = foldl AppE (ConE (mkName n)) $ map VarE xs
tma' = foldl AppE tma $ map VarE xs
let toMaster' = toMaster `AppE` routeToMaster `AppE` tma' `AppE` VarE x
let bod' = InfixE (Just toMaster') fmap' (Just bod)
let bod'' = InfixE (Just modMaster) fmap' (Just bod')
return $ Clause pat (NormalB bod'') []
go' n _ xs [] = do
jus <- [|Just|]
let bod = foldl AppE (VarE $ mkName $ "handle" ++ n) $ map VarE xs
return $ jus `AppE` (modMaster `AppE` bod)
go' n meth xs methods = do
noth <- [|Nothing|]
j <- [|Just|]
let noMatch = Match WildP (NormalB noth) []
return $ CaseE (VarE meth) $ map (go'' n xs j) methods ++ [noMatch]
go'' n xs j method =
let pat = LitP $ StringL method
func = map toLower method ++ n
bod = foldl AppE (VarE $ mkName func) $ map VarE xs
in Match pat (NormalB $ j `AppE` (modMaster `AppE` bod)) []
parseRoutes :: QuasiQuoter
parseRoutes = QuasiQuoter
{ quoteExp = x
, quotePat = 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
parseRoutesFile :: FilePath -> Q Exp
parseRoutesFile fp = do
s <- qRunIO $ readUtf8File fp
quoteExp parseRoutes s
parseRoutesFileNoCheck :: FilePath -> Q Exp
parseRoutesFileNoCheck fp = do
s <- qRunIO $ readUtf8File fp
quoteExp parseRoutesNoCheck s
readUtf8File :: FilePath -> IO String
readUtf8File fp = do
h <- SIO.openFile fp SIO.ReadMode
SIO.hSetEncoding h SIO.utf8_bom
SIO.hGetContents h
parseRoutesNoCheck :: QuasiQuoter
parseRoutesNoCheck = QuasiQuoter
{ quoteExp = x
, quotePat = 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
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 = go . map justPieces
where
justPieces :: Resource -> ([Piece], Resource)
justPieces r@(Resource _ ps _) = (ps, r)
go [] = []
go (x:xs) = mapMaybe (mOverlap x) xs ++ go xs
mOverlap :: ([Piece], Resource) -> ([Piece], Resource) ->
Maybe (Resource, Resource)
mOverlap (StaticPiece x:xs, xr) (StaticPiece y:ys, yr)
| x == y = mOverlap (xs, xr) (ys, yr)
| otherwise = Nothing
mOverlap (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)
mOverlap (_, xr) (MultiPiece _:_, yr) = Just (xr, yr)
mOverlap ([], xr) ([], yr) = Just (xr, yr)
mOverlap ([], _) (_, _) = Nothing
mOverlap (_, _) ([], _) = Nothing
mOverlap (_:xs, xr) (_:ys, yr) = mOverlap (xs, xr) (ys, yr)