web-routes-quasi 0.4.0 → 0.5.0

raw patch · 6 files changed

+416/−712 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Web/Routes/Quasi.hs +5/−711
• Web/Routes/Quasi/Classes.hs +39/−0
• Web/Routes/Quasi/Parse.hs +119/−0
• Web/Routes/Quasi/TH.hs +200/−0
• runtests.hs +49/−0
• web-routes-quasi.cabal +4/−1

@@ -1,9 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-} module Web.Routes.Quasi     (       -- * Quasi quoter@@ -11,715 +5,15 @@     , parseRoutesNoCheck       -- * Template haskell       -- ** Low level-    , createQuasiDispatch+    , createRoutes     , createRender     , createParse-      -- ** High level for 'QuasiSite's-    , createQuasiSite-    , createQuasiSite'-    , QuasiSiteSettings (..)-    , QuasiSiteDecs (..)-      -- * Quasi site-    , QuasiDispatch-    , QuasiSite (..)-    , quasiFromSite-    , quasiToSite-    , Routes-    , BlankArgs (..)-      -- * Underlying data types-    , Resource (..)-    , Handler (..)-    , Piece (..)-    , liftResources-      -- * FIXME+      -- * Type classes     , 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---- | A single resource pattern.------ First argument is the name of the constructor, second is the URL pattern to--- match, third is how to dispatch.-data Resource = Resource String [Piece] Handler-    deriving (Read, Show, Eq, Data, Typeable)---- | Defines how to dispatch a request for a specific resource.------ ByMethod allows a different function to be called for each request method.--- The first value in each pair is the method, the second is the name of the--- handler.------ Single dispatches to a single function for all methods.------ SubSite passes dispatch to a different site. The first argument is the name--- of the datatype for the routes. The second is a function returning a--- 'QuasiSite' for that type of routes. The third is a function converting the--- master argument to the subsite argument.-data Handler = ByMethod [(String, String)] -- ^ (method, handler)-             | Single String-             | SubSite String String 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.-data Piece = StaticPiece String-           | SinglePiece String-           | MultiPiece String-    deriving (Read, Show, Eq, Data, Typeable)--type family Routes a---- | The type for quasiDispatch; separated out for clarity of Haddock docs.-type QuasiDispatch app sub master-                   = (Routes master -> String)-                  -> Routes sub-                  -> (Routes sub -> Routes master)-                  -> master-                  -> (master -> sub)-                  -> app -- ^ bad method handler-                  -> String -- ^ method-                  -> app---- | Very similar in principle to 'Site', but with special support for--- arguments and subsites.-data QuasiSite app sub master = QuasiSite-    { quasiDispatch :: QuasiDispatch app sub master-    , quasiRender :: Routes sub -> [String]-    , quasiParse :: [String] -> Either String (Routes sub)-    }---- | Used for applications with no arguments. In particular, this facilitates a--- translation from a 'Site' to a 'QuasiSite' via 'quasiFromSite'.-data BlankArgs routes = BlankArgs-type instance Routes (BlankArgs routes) = routes---- | Convert a 'Site' to a 'QuasiSite'. 'quasiRender' and 'quasiParse' are--- identical to 'formatPathSegments' and 'parsePathSegments'; for the--- 'quasiDispatch' function, we just ignore the extra arguments that 'Site'--- does not use.-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-    }---- | Convert a 'QuasiSite' to a 'Site'. 'quasiRender' and 'quasiParse' are--- identical to 'formatPathSegments' and 'parsePathSegments'; for the--- 'handleSite' function, we need some extra information passed to this--- function. We also restrict the resulting 'QuasiSite' to cases where subsite--- and master site are the same.-quasiToSite :: QuasiSite app sub sub-            -> ((String -> app) -> app) -- ^ grab method-            -> app -- ^ bad method-            -> 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--{- FIXME-isString :: Piece -> Bool-isString (StringPiece _) = True-isString _ = False--}---- | Drop leading whitespace.-trim :: String -> String-trim = dropWhile isSpace---- | 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 = 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---- | 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 :: 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---- | Same as 'parseRoutes', but performs no overlap checking.-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)---- | Whether the set of resources cover all possible URLs.-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---- | Generates the set of clauses necesary to parse the given 'Resource's. See 'quasiParse'.-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 -- FIXME siteType necessary?-        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) []---- | 'ap' for 'Either'-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---- | Generates the set of clauses necesary to render the given 'Resource's. See--- 'quasiRender'.-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'---- | Generate the set of clauses necesary to dispatch the given 'Resource's.--- See 'quasiDispatch'.-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 -- ^ name of resulting function-        -> [Clause] -- ^ parse-        -> [Clause] -- ^ render-        -> [Clause] -- ^ dispatch-        -> 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-            ]-        ]---- | Template haskell code to convert a list of 'Resource's into appropriate--- declarations for a 'QuasiSite'. See the 'QuasiSiteSettings' and--- 'QuasiSiteDecs' data types for an explanation for the input and output,--- respectively, of this function.-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-        }---- | The arguments passed to 'createQuasiSite' for generating applications--- based on the 'QuasiSite' datatype.-data QuasiSiteSettings = QuasiSiteSettings-    { -- | The name for the URL data type to be created.-      crRoutes :: Name-      -- | The type for underlying applications.-    , crApplication :: Type-      -- | The type for the argument value to be passed to dispatch functions.-    , crArgument :: Type-      -- | Underlying applications will often want to program against some-      -- datatype. The explode function converts that datatype into a function-      -- that will generate an application ('crApplication'). In particular,-      -- the value of crExplode should have a type signature of:-      ---      -- > explode :: handler-      -- >         -> ('Routes' master -> String)-      -- >         -> 'Routes' sub-      -- >         -> ('Routes' sub -> 'Routes' master)-      -- >         -> master-      -- >         -> (master -> sub)-      -- >         -> app-      -- >         -> String-      -- >         -> app-      ---      -- handler is some datatype handled by the calling application;-      -- web-routes-quasi needn't know about it. sub and master are the-      -- arguments for the subsite and master site, respectively. app is the-      -- datatype for the underlying application; the app argument above is the-      -- handler for unsupported method. The 'String' argument is the request-      -- method.-    , crExplode :: Exp-      -- | The 'Resource's upon which we are building the set of URLs and-      -- dispatches. Usually generated by 'parseRoutes'.-    , crResources :: [Resource]-      -- | The name for the resulting function which will return the 'QuasiSite'.-    , crSite :: Name-      -- | Describes the type of the master argument. This can either be a-      -- 'Left' concrete datatype, or 'Right' a list of 'Pred's describing the-      -- context for master.-    , crMaster :: Either Type [(String, [Name])]-    }---- | The template Haskell declarations returned from 'createQuasiSite'.-data QuasiSiteDecs = QuasiSiteDecs-    { -- | Defines the actual URL datatype, with all its constructors.-      decRoutes :: Dec-      -- | Defines the 'Routes' type synonym instance between the argument-      -- ('crArgument') and URL datatype.-    , decRoutesSyn :: Dec-      -- | The type signature for the site function ('decSite').-    , decSiteType :: Dec-      -- | Function which returns a 'QuasiSite'. The type parameters for the-      -- 'QuasiSite' will be 'crApplication', 'crArgument' and a forall master.-    , 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]+import Web.Routes.Quasi.TH+import Web.Routes.Quasi.Parse+import Web.Routes.Quasi.Classes

@@ -0,0 +1,39 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Web.Routes.Quasi.Classes+    ( SinglePiece (..)+    , MultiPiece (..)+    , Strings+    ) where++import Data.Int (Int64)++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]

@@ -0,0 +1,119 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Web.Routes.Quasi.Parse+    ( -- * Quasi quoter+      parseRoutes+    , parseRoutesNoCheck+    , Resource (..)+    , Piece (..)+    ) where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Quote+import Data.Data+import Data.Char+import Data.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 :: 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++-- | Same as 'parseRoutes', but performs no overlap checking.+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'++-- | A single resource pattern.+--+-- First argument is the name of the constructor, second is the URL pattern to+-- match, third is how to dispatch.+data Resource = Resource String [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.+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'++-- | 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 = map go . filter (not . null) . map trim . lines where+    go s =+        case words s of+            (pattern:constr:rest) ->+                let pieces = piecesFromString $ drop1Slash pattern+                 in Resource constr pieces rest+            _ -> error $ "Invalid resource line: " ++ s++-- | Drop leading whitespace.+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)

@@ -0,0 +1,200 @@+{-# LANGUAGE TemplateHaskell #-}+module Web.Routes.Quasi.TH+    ( createRoutes+    , createRender+    , createParse+    , createDispatch+    , Pieces (..)+    , THResource+    ) where++import Web.Routes.Quasi.Parse+import Web.Routes.Quasi.Classes+import Language.Haskell.TH.Syntax+import Data.Maybe+import Data.Either+import Data.List+import Data.Char (toLower)++data Pieces =+    SubSite+        { ssType :: Type+        , ssParse :: Exp+        , ssRender :: Exp+        , ssDispatch :: Exp+        , ssToMasterArg :: Exp+        , ssPieces :: [String]+        }+  | Simple [Piece] [String] -- ^ methods+type THResource = (String, Pieces)++createRoutes :: [THResource] -> Q [Con]+createRoutes res =+    return $ map go res+  where+    go (n, SubSite{ssType = s}) =+        NormalC (mkName n) [(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++-- | Generates the set of clauses necesary to parse the given 'Resource's. See 'quasiParse'.+createParse :: [THResource] -> Q [Clause]+createParse res = do+    final' <- final+    clauses <- mapM go res+    return $ if areResourcesComplete res+                then clauses+                else clauses ++ [final']+  where+    go (constr, SubSite{ssParse = p, ssPieces = pieces}) = do+        let cons = ConP $ mkName ":"+        x <- newName "x"+        let pat = foldr (\a b -> cons [LitP (StringL a), b]) (VarP x) pieces+        let eitherSub = p `AppE` VarE x+        fmape' <- [|fmape|]+        let bod = fmape' `AppE` ConE (mkName constr) `AppE` eitherSub+        return $ Clause [pat] (NormalB bod) []+    go (n, Simple ps _) = do+        ri <- [|Right|]+        be <- [|ape|]+        (pat, parse) <- mkPat' be ps $ ri `AppE` ConE (mkName n)+        return $ Clause [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 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)++fmape :: (a -> b) -> Either String a -> Either String b+fmape _ (Left s) = Left s+fmape f (Right a) = Right $ f a++-- | 'ap' for 'Either'+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++-- | Generates the set of clauses necesary to render the given 'Resource's. See+-- 'quasiRender'.+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 bod) []+    go (n, SubSite{ssRender = r, ssPieces = pieces}) = do+        let cons a b = InfixE (Just a) (ConE $ mkName ":") (Just b)+        x <- newName "x"+        let r' = r `AppE` VarE x+        let pat = ConP (mkName n) [VarP x]+        let bod = foldr (\a b -> cons (LitE $ StringL a) b) r' pieces+        return $ Clause [pat] (NormalB bod) []+    go' (_, StaticPiece _) = Nothing+    go' (i, _) = Just $ VarP $ mkName $ "var" ++ show (i :: Int)+    mkBod [] = lift ([] :: [String])+    mkBod ((_, StaticPiece x):xs) = do+        x' <- lift x+        xs' <- mkBod xs+        return $ ConE (mkName ":") `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'++-- | Whether the set of resources cover all possible URLs.+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 (map StaticPiece 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 -- ^ modify a master handler+               -> Exp -- ^ convert a subsite handler to a master handler+               -> [THResource]+               -> Q [Clause]+createDispatch modMaster toMaster = mapM go+  where+    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}) = do+        meth <- newName "method"+        x <- newName "x"+        let pat = [ConP (mkName n) [VarP x], VarP meth]+        let bod = d `AppE` VarE x `AppE` VarE meth+        fmap' <- [|fmap|]+        let toMaster' = toMaster `AppE` ConE (mkName n) `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)) []

@@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-} module Main     ( main     , waiSite@@ -155,3 +156,51 @@ drop1Slash :: String -> String drop1Slash ('/':x) = x drop1Slash x = x++#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

@@ -1,5 +1,5 @@ name:            web-routes-quasi-version:         0.4.0+version:         0.5.0 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -20,6 +20,9 @@                      web-routes >= 0.22 && < 0.23,                      template-haskell >= 2.4 && < 2.5     exposed-modules: Web.Routes.Quasi+                     Web.Routes.Quasi.Classes+                     Web.Routes.Quasi.Parse+                     Web.Routes.Quasi.TH     ghc-options:     -Wall  executable             runtests