web-routes-quasi 0.1.0 → 0.2.0

raw patch · 2 files changed

+79/−22 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Web/Routes/Quasi.hs +78/−21
• web-routes-quasi.cabal +1/−1

@@ -14,6 +14,7 @@     , createParse       -- ** High level for 'QuasiSite's     , createQuasiSite+    , createQuasiSite'     , QuasiSiteSettings (..)     , QuasiSiteDecs (..)       -- * Quasi site@@ -27,6 +28,11 @@     , Resource (..)     , Handler (..)     , Piece (..)+    , liftResources+      -- * FIXME+    , ToString (..)+    , IsString+    , IsSlurp (..) #if TEST     , testSuite #endif@@ -41,6 +47,7 @@ import Web.Routes.Site import Data.Either import Data.List+import Data.String  #if TEST import Test.Framework (testGroup, Test)@@ -78,9 +85,9 @@ -- 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-           | StringPiece String-           | IntPiece String-           | SlurpPiece String+           | StringPiece (Maybe String)+           | IntPiece (Maybe String)+           | SlurpPiece (Maybe String)     deriving (Read, Show, Eq, Data, Typeable)  type family Routes a@@ -190,11 +197,15 @@      in pieceFromString y : piecesFromString (drop1Slash z)  pieceFromString :: String -> Piece-pieceFromString ('$':x) = StringPiece x-pieceFromString ('#':x) = IntPiece x-pieceFromString ('*':x) = SlurpPiece x+pieceFromString ('$':x) = StringPiece $ getConstr x+pieceFromString ('#':x) = IntPiece $ getConstr x+pieceFromString ('*':x) = SlurpPiece $ getConstr x pieceFromString x = StaticPiece x +getConstr :: String -> Maybe String+getConstr a@(x:_) | isUpper x = Just a+getConstr _ = Nothing+ -- | 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.@@ -266,18 +277,23 @@     go (Resource n pieces h) = NormalC (mkName n)                              $ mapMaybe go' pieces                             ++ go'' h-    go' (StringPiece _) = Just (NotStrict, ConT ''String)-    go' (IntPiece _) = Just (NotStrict, ConT ''Integer)-    go' (SlurpPiece _) = Just (NotStrict, AppT ListT $ ConT ''String)+    go' (StringPiece x) = Just (NotStrict, getConstr' (ConT ''String) x)+    go' (IntPiece x) = Just (NotStrict, getConstr' (ConT ''Integer) x)+    go' (SlurpPiece x) =+        Just (NotStrict, getConstr' (AppT ListT $ ConT ''String) x)     go' _ = Nothing     go'' (SubSite t _ _) = [(NotStrict, ConT ''Routes `AppT` ConT (mkName t))]     go'' _ = []     claz = [''Show, ''Read, ''Eq] +getConstr' :: Type -> Maybe String -> Type+getConstr' t Nothing = t+getConstr' _ (Just s) = ConT $ mkName s+ findOverlaps :: [Resource] -> [(Resource, Resource)] findOverlaps = gos . map justPieces   where-    justPieces r@(Resource _ ps (SubSite{})) = (ps ++ [SlurpPiece ""], r)+    justPieces r@(Resource _ ps (SubSite{})) = (ps ++ [SlurpPiece Nothing], r)     justPieces r@(Resource _ ps _) = (ps, r)     gos [] = []     gos (x:xs) = mapMaybe (go x) xs ++ gos xs@@ -347,7 +363,7 @@                             siteVar = VarE (mkName f) `SigE` siteType                         let parse' = parse `AppE` siteVar                         let rhs = parse' `AppE` VarE (mkName "var0")-                        fm <- [|fmap|]+                        fm <- [|fmape|]                         return $ fm `AppE` bod `AppE` rhs                     _ -> do                         ri <- [|Right|]@@ -367,12 +383,24 @@         , mkPat rest h         ]     go' x (_, StaticPiece _) = return x-    go' x (i, SlurpPiece _) =-        return $ x `AppE` VarE (mkName $ "var" ++ show i)-    go' x (i, StringPiece _) =-        return $ x `AppE` VarE (mkName $ "var" ++ show i)+    go' x (i, SlurpPiece y) = do+        let e = VarE (mkName $ "var" ++ show i)+        e' <- case y of+                Nothing -> return e+                Just _ -> do+                    fs <- [|fromSlurp|]+                    return $ fs `AppE` e+        return $ x `AppE` e'+    go' x (i, StringPiece y) = do+        let e = VarE $ mkName $ "var" ++ show i+        e' <- case y of+                Nothing -> return e+                Just _ -> do+                    fs <- [|fromString|]+                    return $ fs `AppE` e+        return $ x `AppE` e'     go' x (i, IntPiece _) = do-        re <- [|read|]+        re <- [|fromInteger . read|]         return $ x `AppE` (re `AppE` VarE (mkName $ "var" ++ show i))     checkInts [] = [|True|]     checkInts ((i, IntPiece _):rest) = do@@ -383,6 +411,11 @@                    `AppE` rest'     checkInts (_:rest) = checkInts rest +-- | 'fmap' for 'Either'+fmape :: (a -> b) -> Either l a -> Either l b+fmape _ (Left l) = Left l+fmape f (Right a) = Right $ f a+ isInt :: String -> Bool isInt [] = False isInt ('-':rest) = all isDigit rest@@ -416,16 +449,28 @@         x' <- lift x         xs' <- mkBod xs h         return $ ConE (mkName ":") `AppE` x' `AppE` xs'-    mkBod ((i, StringPiece _):xs) h = do+    mkBod ((i, StringPiece y):xs) h = do         let x' = VarE $ mkName $ "var" ++ show i+        x'' <- case y of+                Nothing -> return x'+                Just _ -> do+                    ts <- [|toString|]+                    return $ ts `AppE` x'         xs' <- mkBod xs h-        return $ ConE (mkName ":") `AppE` x' `AppE` xs'+        return $ ConE (mkName ":") `AppE` x'' `AppE` xs'     mkBod ((i, IntPiece _):xs) h= do-        sh <- [|show|]+        sh <- [|show . (fromIntegral :: Integral i => i -> Integer)|]         let x' = AppE sh $ VarE $ mkName $ "var" ++ show i         xs' <- mkBod xs h         return $ ConE (mkName ":") `AppE` x' `AppE` xs'-    mkBod ((i, SlurpPiece _):_) _ = return $ VarE $ mkName $ "var" ++ show i+    mkBod ((i, SlurpPiece y):_) _ = do+        let x' = VarE $ mkName $ "var" ++ show i+        x'' <- case y of+                Nothing -> return x'+                Just _ -> do+                    ts <- [|toSlurp|]+                    return $ ts `AppE` x'+        return x''  -- | Generate the set of clauses necesary to dispatch the given 'Resource's. -- See 'quasiDispatch'.@@ -612,7 +657,7 @@  -- | The template Haskell declarations returned from 'createQuasiSite'. data QuasiSiteDecs = QuasiSiteDecs-    { -- | Defines the actual URL datatype, which all its constructors.+    { -- | Defines the actual URL datatype, with all its constructors.       decRoutes :: Dec       -- | Defines the 'Routes' type synonym instance between the argument       -- ('crArgument') and URL datatype.@@ -624,6 +669,11 @@     , 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"@@ -671,3 +721,10 @@                 , Resource "Bar" [IntPiece "x"] $ SubSite "a" "b" "c"                 ] #endif++class IsString s => ToString s where+    toString :: s -> String++class IsSlurp s where+    fromSlurp :: [String] -> s+    toSlurp :: s -> [String]

@@ -1,5 +1,5 @@ name:            web-routes-quasi-version:         0.1.0+version:         0.2.0 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>