Merge pull request #1366 from jprider63/dev.jp

Contexts can be parsed and included in instances. Standalone deriving…

yesod-core/ChangeLog.md

@@ -1,3 +1,8 @@
+## 1.4.35
+
+* Contexts can be included in generated TH instances. [1365](https://github.com/yesodweb/yesod/issues/1365)
+* Type variables can be included in routes.
+
 ## 1.4.34
 
 * Add `WaiSubsiteWithAuth`. [#1394](https://github.com/yesodweb/yesod/pull/1394)

yesod-core/Yesod/Core/Internal/TH.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Yesod.Core.Internal.TH where
 
 import Prelude hiding (exp)
@@ -15,12 +16,18 @@ import Language.Haskell.TH.Syntax
 import qualified Network.Wai as W
 
 import Data.ByteString.Lazy.Char8 ()
+#if MIN_VERSION_base(4,8,0)
+import Data.List (foldl', uncons)
+#else
 import Data.List (foldl')
+#endif
 #if __GLASGOW_HASKELL__ < 710
 import Control.Applicative ((<$>))
 #endif
 import Control.Monad (replicateM, void)
 import Data.Either (partitionEithers)
+import Text.Parsec (parse, many1, many, eof, try, option, sepBy1)
+import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
 
 import Yesod.Routes.TH
 import Yesod.Routes.Parse
@@ -55,8 +62,40 @@ mkYesodSubData name = mkYesodDataGeneral name True
 
 mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec]
 mkYesodDataGeneral name isSub res = do
-    let (name':rest) = words name
+    let (name', rest, cxt) = case parse parseName "" name of
-    fst <$> mkYesodGeneral name' (fmap Left rest) isSub return res
+            Left err -> error $ show err
+            Right a -> a
+    fst <$> mkYesodGeneral' cxt name' (fmap Left rest) isSub return res
+
+    where
+        parseName = do
+            cxt <- option [] parseContext
+            name' <- parseWord
+            args <- many parseWord
+            spaces
+            eof
+            return ( name', args, cxt)
+
+        parseWord = do
+            spaces
+            many1 alphaNum
+
+        parseContext = try $ do
+            cxts <- parseParen parseContexts
+            spaces
+            _ <- string "=>"
+            return cxts
+
+        parseParen p = do
+            spaces
+            _ <- char '('
+            r <- p
+            spaces
+            _ <- char ')'
+            return r
+
+        parseContexts = 
+            sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())
 
 -- | See 'mkYesodData'.
 mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
@@ -80,7 +119,23 @@ mkYesodGeneral :: String                    -- ^ foundation type
                -> (Exp -> Q Exp)            -- ^ unwrap handler
                -> [ResourceTree String]
                -> Q([Dec],[Dec])
-mkYesodGeneral namestr args isSub f resS = do
+mkYesodGeneral = mkYesodGeneral' []
+
+mkYesodGeneral' :: [[String]]               -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
+               -> String                    -- ^ foundation type
+               -> [Either String [String]]  -- ^ arguments for the type
+               -> Bool                      -- ^ is this a subsite
+               -> (Exp -> Q Exp)            -- ^ unwrap handler
+               -> [ResourceTree String]
+               -> Q([Dec],[Dec])
+mkYesodGeneral' appCxt' namestr args isSub f resS = do
+    let appCxt = fmap (\(c:rest) -> 
+#if MIN_VERSION_template_haskell(2,10,0)
+            foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest
+#else
+            ClassP (mkName c) $ fmap nameToType rest
+#endif
+          ) appCxt'
     mname <- lookupTypeName namestr
     arity <- case mname of
                Just name -> do
@@ -105,10 +160,13 @@ mkYesodGeneral namestr args isSub f resS = do
     vns <- replicateM (arity - length mtys) $ newName "t"
         -- Base type (site type with variables)
     let (argtypes,cxt) = (\(ns,r,cs) -> (ns ++ fmap VarT r, cs)) $
-          foldr (\arg (xs,n:ns,cs) ->
+          foldr (\arg (xs,vns',cs) ->
                    case arg of
-                     Left  t  -> ( ConT (mkName t):xs, n:ns, cs )
+                     Left  t  -> 
-                     Right ts -> ( VarT n         :xs,   ns
+                                 ( nameToType t:xs, vns', cs )
+                     Right ts -> 
+                                 let (n, ns) = maybe (error "mkYesodGeneral: Should be unreachable.") id $ uncons vns' in
+                                 ( VarT n : xs, ns
                                  , fmap (\t ->
 #if MIN_VERSION_template_haskell(2,10,0)
                                                AppT (ConT $ mkName t) (VarT n)
@@ -118,11 +176,11 @@ mkYesodGeneral namestr args isSub f resS = do
                                           ) ts ++ cs )
                  ) ([],vns,[]) args
         site = foldl' AppT (ConT name) argtypes
-        res = map (fmap parseType) resS
+        res = map (fmap (parseType . dropBracket)) resS
-    renderRouteDec <- mkRenderRouteInstance site res
+    renderRouteDec <- mkRenderRouteInstance' appCxt site res
-    routeAttrsDec  <- mkRouteAttrsInstance site res
+    routeAttrsDec  <- mkRouteAttrsInstance' appCxt site res
     dispatchDec    <- mkDispatchInstance site cxt f res
-    parse <- mkParseRouteInstance site res
+    parseRoute <- mkParseRouteInstance' appCxt site res
     let rname = mkName $ "resources" ++ namestr
     eres <- lift resS
     let resourcesDec =
@@ -130,7 +188,7 @@ mkYesodGeneral namestr args isSub f resS = do
             , FunD rname [Clause [] (NormalB eres) []]
             ]
     let dataDec = concat
-            [ [parse]
+            [ [parseRoute]
             , renderRouteDec
             , [routeAttrsDec]
             , resourcesDec
@@ -138,6 +196,12 @@ mkYesodGeneral namestr args isSub f resS = do
             ]
     return (dataDec, dispatchDec)
 
+#if !MIN_VERSION_base(4,8,0)
+    where
+        uncons (h:t) = Just (h,t)
+        uncons _ = Nothing
+#endif
+
 mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
 mkMDS f rh = MkDispatchSettings
     { mdsRunHandler = rh

yesod-core/Yesod/Routes/Parse.hs

@@ -10,10 +10,12 @@ module Yesod.Routes.Parse
     , parseType
     , parseTypeTree
     , TypeTree (..)
+    , dropBracket
+    , nameToType
     ) where
 
 import Language.Haskell.TH.Syntax
-import Data.Char (isUpper, isSpace)
+import Data.Char (isUpper, isLower, isSpace)
 import Language.Haskell.TH.Quote
 import qualified System.IO as SIO
 import Yesod.Routes.TH
@@ -252,14 +254,18 @@ toTypeTree orig = do
             gos' (front . (t:)) xs'
 
 ttToType :: TypeTree -> Type
-ttToType (TTTerm s) = ConT $ mkName s
+ttToType (TTTerm s) = nameToType s
 ttToType (TTApp x y) = ttToType x `AppT` ttToType y
 ttToType (TTList t) = ListT `AppT` ttToType t
 
+nameToType :: String -> Type
+nameToType t@(h:_) | isLower h = VarT $ mkName t
+nameToType t = ConT $ mkName t
+
 pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)
-pieceFromString ('#':'!':x) = Right $ (False, dynamicPieceFromString x)
+pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x)
-pieceFromString ('!':'#':x) = Right $ (False, dynamicPieceFromString x) -- https://github.com/yesodweb/yesod/issues/652
+pieceFromString ('!':'#':x) = Right $ (False, Dynamic $ dropBracket x) -- https://github.com/yesodweb/yesod/issues/652
-pieceFromString ('#':x) = Right $ (True, dynamicPieceFromString x)
+pieceFromString ('#':x) = Right $ (True, Dynamic $ dropBracket x)
 
 pieceFromString ('*':'!':x) = Left (False, x)
 pieceFromString ('+':'!':x) = Left (False, x)
@@ -273,9 +279,9 @@ pieceFromString ('+':x) = Left (True, x)
 pieceFromString ('!':x) = Right $ (False, Static x)
 pieceFromString x = Right $ (True, Static x)
 
-dynamicPieceFromString :: String -> Piece String
+dropBracket :: String -> String
-dynamicPieceFromString str@('{':x) = case break (== '}') x of
+dropBracket str@('{':x) = case break (== '}') x of
-    (s, "}") -> Dynamic s
+    (s, "}") -> s
-    _ -> error $ "Invalid path piece: " ++ str
+    _ -> error $ "Unclosed bracket ('{'): " ++ str
-dynamicPieceFromString x = Dynamic x
+dropBracket x = x
--- JP: Should we check if there are curly brackets or other invalid characters?
+

yesod-core/Yesod/Routes/TH/ParseRoute.hs

@@ -3,6 +3,7 @@
 module Yesod.Routes.TH.ParseRoute
     ( -- ** ParseRoute
       mkParseRouteInstance
+    , mkParseRouteInstance'
     ) where
 
 import Yesod.Routes.TH.Types
@@ -12,7 +13,10 @@ import Yesod.Routes.Class
 import Yesod.Routes.TH.Dispatch
 
 mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec
-mkParseRouteInstance typ ress = do
+mkParseRouteInstance = mkParseRouteInstance' []
+
+mkParseRouteInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
+mkParseRouteInstance' cxt typ ress = do
     cls <- mkDispatchClause
         MkDispatchSettings
             { mdsRunHandler = [|\_ _ x _ -> x|]
@@ -28,7 +32,7 @@ mkParseRouteInstance typ ress = do
         (map removeMethods ress)
     helper <- newName "helper"
     fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|]
-    return $ instanceD [] (ConT ''ParseRoute `AppT` typ)
+    return $ instanceD cxt (ConT ''ParseRoute `AppT` typ)
         [ FunD 'parseRoute $ return $ Clause
             []
             (NormalB $ fixer `AppE` VarE helper)

yesod-core/Yesod/Routes/TH/RenderRoute.hs

@@ -12,6 +12,9 @@ import Yesod.Routes.TH.Types
 import Language.Haskell.TH (conT)
 #endif
 import Language.Haskell.TH.Syntax
+#if MIN_VERSION_template_haskell(2,11,0)
+import Data.Bits (xor)
+#endif
 import Data.Maybe (maybeToList)
 import Control.Monad (replicateM)
 import Data.Text (pack)
@@ -156,18 +159,28 @@ mkRenderRouteInstance' cxt typ ress = do
     cls <- mkRenderRouteClauses ress
     (cons, decs) <- mkRouteCons ress
 #if MIN_VERSION_template_haskell(2,12,0)
-    did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT clazzes)
+    did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False))
+    let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
 #elif MIN_VERSION_template_haskell(2,11,0)
-    did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT clazzes
+    did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False)
+    let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
 #else
-    let did = DataInstD [] ''Route [typ] cons clazzes
+    let did = DataInstD [] ''Route [typ] cons clazzes'
+    let sds = []
 #endif
     return $ instanceD cxt (ConT ''RenderRoute `AppT` typ)
         [ did
         , FunD (mkName "renderRoute") cls
-        ] : decs
+        ]
+        : sds ++ decs
   where
-    clazzes = [''Show, ''Eq, ''Read]
+#if MIN_VERSION_template_haskell(2,11,0)
+    clazzes standalone = if standalone `xor` null cxt then
+          clazzes'
+        else
+          []
+#endif
+    clazzes' = [''Show, ''Eq, ''Read]
 
 #if MIN_VERSION_template_haskell(2,11,0)
 notStrict :: Bang

yesod-core/Yesod/Routes/TH/RouteAttrs.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE RecordWildCards #-}
 module Yesod.Routes.TH.RouteAttrs
     ( mkRouteAttrsInstance
+    , mkRouteAttrsInstance'
     ) where
 
 import Yesod.Routes.TH.Types
@@ -15,9 +16,12 @@ import Control.Applicative ((<$>))
 #endif
 
 mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec
-mkRouteAttrsInstance typ ress = do
+mkRouteAttrsInstance = mkRouteAttrsInstance' []
+
+mkRouteAttrsInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
+mkRouteAttrsInstance' cxt typ ress = do
     clauses <- mapM (goTree id) ress
-    return $ instanceD [] (ConT ''RouteAttrs `AppT` typ)
+    return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ)
         [ FunD 'routeAttrs $ concat clauses
         ]
 

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.4.34
+version:         1.4.35
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>