module Web.Routes.Quasi
(
parseRoutes
, parseRoutesNoCheck
, createQuasiDispatch
, createRender
, createParse
, createQuasiSite
, createQuasiSite'
, QuasiSiteSettings (..)
, QuasiSiteDecs (..)
, QuasiDispatch
, QuasiSite (..)
, quasiFromSite
, quasiToSite
, Routes
, BlankArgs (..)
, Resource (..)
, Handler (..)
, Piece (..)
, liftResources
, SinglePiece (..)
, MultiPiece (..)
, Strings
#if TEST
, testSuite
#endif
) where
import Data.Char
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Data.Data
import Data.Maybe
import Control.Monad
import Web.Routes.Site
import Data.Either
import Data.List
import Data.Int (Int64)
#if TEST
import Test.Framework (testGroup, Test)
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test)
#endif
data Resource = Resource String [Piece] Handler
deriving (Read, Show, Eq, Data, Typeable)
data Handler = ByMethod [(String, String)]
| Single String
| SubSite String String String
deriving (Read, Show, Eq, Data, Typeable)
data Piece = StaticPiece String
| SinglePiece String
| MultiPiece String
deriving (Read, Show, Eq, Data, Typeable)
type family Routes a
type QuasiDispatch app sub master
= (Routes master -> String)
-> Routes sub
-> (Routes sub -> Routes master)
-> master
-> (master -> sub)
-> app
-> String
-> app
data QuasiSite app sub master = QuasiSite
{ quasiDispatch :: QuasiDispatch app sub master
, quasiRender :: Routes sub -> [String]
, quasiParse :: [String] -> Either String (Routes sub)
}
data BlankArgs routes = BlankArgs
type instance Routes (BlankArgs routes) = routes
quasiFromSite :: Site surl app -> QuasiSite app (BlankArgs surl) master
quasiFromSite (Site dispatch render parse) = QuasiSite
{ quasiDispatch = \mrender surl constr _ _ _ _ ->
dispatch (mrender . constr) surl
, quasiRender = render
, quasiParse = parse
}
quasiToSite :: QuasiSite app sub sub
-> ((String -> app) -> app)
-> app
-> sub
-> Site (Routes sub) app
quasiToSite (QuasiSite dispatch render parse) grabMethod badMethod sub = Site
{ handleSite = \rend url -> grabMethod (dispatch
rend
url
id
sub
id
badMethod)
, formatPathSegments = render
, parsePathSegments = parse
}
isStatic :: Piece -> Bool
isStatic (StaticPiece _) = True
isStatic _ = False
isSubSite :: Handler -> Bool
isSubSite (SubSite _ _ _) = True
isSubSite _ = False
trim :: String -> String
trim = dropWhile isSpace
resourcesFromString :: String -> [Resource]
resourcesFromString = map go . filter (not . null) . map trim . lines where
go s =
case words s of
(pattern:constr:rest) ->
let pieces = piecesFromString $ drop1Slash pattern
handler = go' constr rest
in if all isStatic pieces || not (isSubSite handler)
then Resource constr pieces handler
else error "Subsites must have static pieces"
_ -> error $ "Invalid resource line: " ++ s
go' constr [] = Single $ "handle" ++ constr
go' _ [routes, getSite@(x:_), grabArgs@(y:_)]
| isLower x && isLower y = SubSite routes getSite grabArgs
go' constr rest = ByMethod $ map helper rest
where
helper x =
case break (== ':') x of
(method, ':' : func) -> (method, func)
_ -> (x, map toLower x ++ constr)
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
parseRoutes :: QuasiQuoter
parseRoutes = QuasiQuoter x y where
x s = do
let res = resourcesFromString s
case findOverlaps res of
[] -> liftResources res
_ -> error $ "Overlapping routes: " ++ unlines (map show res)
y = dataToPatQ (const Nothing) . resourcesFromString
parseRoutesNoCheck :: QuasiQuoter
parseRoutesNoCheck = QuasiQuoter x y where
x = liftResources . resourcesFromString
y = dataToPatQ (const Nothing) . resourcesFromString
liftResources :: [Resource] -> Q Exp
liftResources = fmap ListE . mapM go where
go :: Resource -> Q Exp
go (Resource s ps h) = do
r <- [|Resource|]
s' <- lift s
ps' <- liftPieces ps
h' <- liftHandler h
return $ r `AppE` s' `AppE` ps' `AppE` h'
liftPieces :: [Piece] -> Q Exp
liftPieces = fmap ListE . mapM go where
go (StaticPiece s) = do
c <- [|StaticPiece|]
s' <- lift s
return $ c `AppE` s'
go (SinglePiece s) = do
c <- [|SinglePiece|]
s' <- lift s
return $ c `AppE` s'
go (MultiPiece s) = do
c <- [|MultiPiece|]
s' <- lift s
return $ c `AppE` s'
liftHandler :: Handler -> Q Exp
liftHandler (ByMethod s) = do
c <- [|ByMethod|]
s' <- lift s
return $ c `AppE` s'
liftHandler (Single s) = do
c <- [|Single|]
s' <- lift s
return $ c `AppE` s'
liftHandler (SubSite x y z) = do
c <- [|SubSite|]
x' <- lift x
y' <- lift y
z' <- lift z
return $ c `AppE` x' `AppE` y' `AppE` z'
dataTypeDec :: QuasiSiteSettings -> Q Dec
dataTypeDec set =
return $ DataD [] (crRoutes set) []
(map go $ crResources set) claz
where
go (Resource n pieces h) = NormalC (mkName n)
$ mapMaybe go' pieces
++ go'' h
go' (SinglePiece x) = Just (NotStrict, ConT $ mkName x)
go' (MultiPiece x) = Just (NotStrict, ConT $ mkName x)
go' (StaticPiece _) = Nothing
go'' (SubSite t _ _) = [(NotStrict, ConT ''Routes `AppT` ConT (mkName t))]
go'' _ = []
claz = [''Show, ''Read, ''Eq]
findOverlaps :: [Resource] -> [(Resource, Resource)]
findOverlaps = gos . map justPieces
where
justPieces r@(Resource _ ps (SubSite{})) = (ps ++ [MultiPiece ""], r)
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)
areResourcesComplete :: [Resource] -> 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 :: Resource -> Maybe (Either Int Int)
go (Resource _ ps (SubSite _ _ _)) = go' Left ps
go (Resource _ ps _) =
case reverse ps of
[] -> Just $ Right 0
(MultiPiece _:rest) -> go' Left rest
x -> go' Right x
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
createParse :: QuasiSiteSettings -> [Resource] -> Q [Clause]
createParse set res = do
final' <- final
clauses <- mapM go res
return $ if areResourcesComplete res
then clauses
else clauses ++ [final']
where
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 cons = ConP $ mkName ":"
return $ (cons [LitP $ StringL s, 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'
let cons = ConP $ mkName ":"
return (cons [VarP v, x], parse'')
mkPat' _ [] parse = return (ListP [], parse)
go (Resource n ps (SubSite argType f _)) = do
unless (all isStatic ps) $ error "SubSite cannot have parameters"
let strs = map (\(StaticPiece s) -> s) ps
parse <- [|quasiParse|]
let siteType = ConT ''QuasiSite
`AppT` crApplication set
`AppT` ConT (mkName argType)
`AppT` crArgument set
siteVar = VarE (mkName f) `SigE` siteType
let parse' = parse `AppE` siteVar
var <- newName "var"
let rhs = parse' `AppE` VarE var
fm <- [|fmape|]
let body = NormalB $ fm `AppE` ConE (mkName n) `AppE` rhs
let cons s p = ConP (mkName ":") [LitP $ StringL s, p]
let pat = foldr cons (VarP var) strs
return $ Clause [pat] body []
go (Resource n ps _) = do
ri <- [|Right|]
be <- [|ape|]
(pat, parse) <- mkPat' be ps $ ri `AppE` ConE (mkName n)
return $ Clause [pat] (NormalB 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
fmape :: (a -> b) -> Either String a -> Either String b
fmape _ (Left e) = Left e
fmape f (Right a) = Right $ f a
createRender :: QuasiSiteSettings -> [Resource] -> Q [Clause]
createRender set res = mapM go res
where
go (Resource n ps h) = do
let ps' = zip [1..] ps
let pat = ConP (mkName n) $ mapMaybe go' ps' ++ lastPat h
bod <- mkBod ps' h
return $ Clause [pat] (NormalB bod) []
lastPat (SubSite _ _ _) = [VarP $ mkName "var0"]
lastPat _ = []
go' (_, StaticPiece _) = Nothing
go' (i, _) = Just $ VarP $ mkName $ "var" ++ show (i :: Int)
mkBod [] (SubSite argType f _) = do
format <- [|quasiRender|]
let siteType = ConT ''QuasiSite
`AppT` crApplication set
`AppT` ConT (mkName argType)
`AppT` crArgument set
siteVar = VarE (mkName f) `SigE` siteType
let format' = format `AppE` siteVar
return $ format' `AppE` VarE (mkName "var0")
mkBod [] _ = lift ([] :: [String])
mkBod ((_, StaticPiece x):xs) h = do
x' <- lift x
xs' <- mkBod xs h
return $ ConE (mkName ":") `AppE` x' `AppE` xs'
mkBod ((i, SinglePiece _):xs) h = do
let x' = VarE $ mkName $ "var" ++ show i
tsp <- [|toSinglePiece|]
let x'' = tsp `AppE` x'
xs' <- mkBod xs h
return $ ConE (mkName ":") `AppE` x'' `AppE` xs'
mkBod ((i, MultiPiece _):_) _ = do
let x' = VarE $ mkName $ "var" ++ show i
tmp <- [|toMultiPiece|]
return $ tmp `AppE` x'
createQuasiDispatch :: QuasiSiteSettings -> Q [Clause]
createQuasiDispatch set = do
mrender <- newName "_mrender"
tomurl <- newName "_tomurl"
marg <- newName "_marg"
tosarg <- newName "_tosarg"
method <- newName "_method"
badMethod <- newName "_badMethod"
mapM (go mrender tomurl marg tosarg method badMethod) $ crResources set
where
go mrender tomurl marg tosarg method badMethod
(Resource constr ps handler) = do
conArgs <- go' ps handler
url <- newName "_url"
let pat = [ VarP mrender
, AsP url $ ConP (mkName constr) $ map VarP conArgs
, VarP tomurl
, VarP marg
, VarP tosarg
, VarP badMethod
, VarP method
]
b <- case handler of
Single s' -> do
unexploded <- foldM go'' (VarE $ mkName s') conArgs
let exploded = crExplode set `AppE` unexploded
return $ exploded
`AppE` VarE mrender
`AppE` VarE url
`AppE` VarE tomurl
`AppE` VarE marg
`AppE` VarE tosarg
`AppE` VarE badMethod
`AppE` VarE method
ByMethod methods -> do
matches <- forM methods $ \(m, f) -> do
let pat' = LitP $ StringL m
unexploded <- foldM go'' (VarE $ mkName f) conArgs
let exploded = crExplode set `AppE` unexploded
let bod = exploded
`AppE` VarE mrender
`AppE` VarE url
`AppE` VarE tomurl
`AppE` VarE marg
`AppE` VarE tosarg
`AppE` VarE badMethod
`AppE` VarE method
return $ Match pat' (NormalB bod) []
let final =
if length methods == 4
then []
else [Match WildP (NormalB $ VarE badMethod) []]
return $ CaseE (VarE method) $ matches ++ final
SubSite argType f getArg -> do
qd <- [|quasiDispatch|]
let siteType = ConT ''QuasiSite
`AppT` crApplication set
`AppT` ConT (mkName argType)
`AppT` crArgument set
siteVar = VarE (mkName f) `SigE` siteType
let disp = qd `AppE` siteVar
o <- [|(.)|]
let tomurl' = InfixE (Just $ VarE tomurl) o
$ Just $ ConE $ mkName constr
let tosarg' = InfixE (Just $ VarE $ mkName getArg) o
$ Just $ VarE tosarg
return $ disp
`AppE` VarE mrender
`AppE` VarE (last conArgs)
`AppE` tomurl'
`AppE` VarE marg
`AppE` tosarg'
`AppE` VarE badMethod
`AppE` VarE method
return $ Clause pat (NormalB b) []
go' [] (SubSite _ _ _) = do
n <- newName "arg"
return [n]
go' [] _ = return []
go' (StaticPiece _:rest) h = go' rest h
go' (_:rest) h = do
n <- newName "arg"
ns <- go' rest h
return $ n : ns
go'' base arg = return $ base `AppE` VarE arg
siteDecType :: QuasiSiteSettings -> Q Dec
siteDecType set = do
let core = ConT ''QuasiSite `AppT` crApplication set `AppT` crArgument set
let ty = case crMaster set of
Left master -> core `AppT` master
Right classes ->
let foralls = map (PlainTV . mkName)
$ nub
$ filter firstLower
$ concatMap (words . fst) classes
cxt = concatMap mkContext classes
in ForallT foralls cxt
$ core `AppT` (VarT $ mkName "master")
return $ SigD (crSite set) ty
where
mkContext (dt, typs) = do
let dt' = mkDataType' $ words dt
typ <- typs
return $ ClassP typ [dt']
mkDataType' [] = error "mkDataType with null"
mkDataType' x = foldl1 AppT $ map go x
go "" = error "go with null"
go x@(y:_)
| isUpper y = ConT $ mkName x
| otherwise = VarT $ mkName x
firstLower (x:_) | isLower x = True
firstLower _ = False
siteDec :: Name
-> [Clause]
-> [Clause]
-> [Clause]
-> Q Dec
siteDec name parse render dispatch = do
si <- [|QuasiSite|]
dname <- newName "dispatch"
rname <- newName "render"
pname <- newName "parse"
let body = si `AppE` VarE dname
`AppE` VarE rname
`AppE` VarE pname
return $ FunD name
[ Clause [] (NormalB body)
[ FunD dname dispatch
, FunD rname render
, FunD pname parse
]
]
createQuasiSite :: QuasiSiteSettings -> Q QuasiSiteDecs
createQuasiSite set = do
dt <- dataTypeDec set
let tySyn = TySynInstD ''Routes [crArgument set] $ ConT $ crRoutes set
parseClauses <- createParse set $ crResources set
renderClauses <- createRender set $ crResources set
dispatchClauses <- createQuasiDispatch set
st <- siteDecType set
s <- siteDec (crSite set) parseClauses renderClauses dispatchClauses
return QuasiSiteDecs
{ decRoutes = dt
, decRoutesSyn = tySyn
, decSiteType = st
, decSite = s
}
data QuasiSiteSettings = QuasiSiteSettings
{
crRoutes :: Name
, crApplication :: Type
, crArgument :: Type
, crExplode :: Exp
, crResources :: [Resource]
, crSite :: Name
, crMaster :: Either Type [(String, [Name])]
}
data QuasiSiteDecs = QuasiSiteDecs
{
decRoutes :: Dec
, decRoutesSyn :: Dec
, decSiteType :: Dec
, decSite :: Dec
}
createQuasiSite' :: QuasiSiteSettings -> Q [Dec]
createQuasiSite' s = do
QuasiSiteDecs a b c d <- createQuasiSite s
return [a, b, c, d]
#if TEST
testSuite :: Test
testSuite = testGroup "Web.Routes.Quasi"
[ testCase "overlaps" caseOverlaps
, testCase "complete" caseComplete
]
caseOverlaps :: Assertion
caseOverlaps = do
assertBool "empty" $ null $ findOverlaps []
assertBool "single" $ null $ findOverlaps
[ Resource "Foo" [] $ Single "foo"
]
assertBool "two empties" $ not $ null $ findOverlaps
[ Resource "Foo" [] $ Single "foo"
, Resource "Bar" [] $ Single "bar"
]
assertBool "slurp versus empty" $ not $ null $ findOverlaps
[ Resource "Foo" [] $ Single "foo"
, Resource "Bar" [] $ SubSite "a" "b" "c"
]
assertBool "static + slurp versus empty" $ null $ findOverlaps
[ Resource "Foo" [] $ Single "foo"
, Resource "Bar" [StaticPiece "5"] $ SubSite "a" "b" "c"
]
caseComplete :: Assertion
caseComplete = do
assertBool "empty" $ not $ areResourcesComplete []
assertBool "slurp" $ areResourcesComplete
[ Resource "Foo" [MultiPiece "Foos"] $ Single "foo"
]
assertBool "subsite" $ areResourcesComplete
[ Resource "Foo" [] $ SubSite "a" "b" "c"
]
assertBool "string + subsite" $ areResourcesComplete
[ Resource "Foo" [SinglePiece "Foo"] $ SubSite "a" "b" "c"
, Resource "Bar" [] $ Single "bar"
]
assertBool "static + subsite" $ not $ areResourcesComplete
[ Resource "Foo" [StaticPiece "foo"] $ SubSite "a" "b" "c"
]
assertBool "two pieces" $ not $ areResourcesComplete
[ Resource "Foo" [SinglePiece "Foo"] $ Single "foo"
, Resource "Bar" [StaticPiece "foo"] $ SubSite "a" "b" "c"
]
#endif
class SinglePiece s where
fromSinglePiece :: String -> Either String s
toSinglePiece :: s -> String
instance SinglePiece String where
fromSinglePiece = Right
toSinglePiece = id
instance SinglePiece Integer where
fromSinglePiece s = case reads s of
(i, _):_ -> Right i
_ -> Left $ "Invalid integer: " ++ s
toSinglePiece = show
instance SinglePiece Int where
fromSinglePiece s = case reads s of
(i, _):_ -> Right i
_ -> Left $ "Invalid integer: " ++ s
toSinglePiece = show
instance SinglePiece Int64 where
fromSinglePiece s = case reads s of
(i, _):_ -> Right i
_ -> Left $ "Invalid integer: " ++ s
toSinglePiece = show
class MultiPiece s where
fromMultiPiece :: [String] -> Either String s
toMultiPiece :: s -> [String]
instance MultiPiece [String] where
fromMultiPiece = Right
toMultiPiece = id
type Strings = [String]