haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request #1366 from jprider63/dev.jp

Browse Source 
Contexts can be parsed and included in instances. Standalone deriving…
This commit is contained in:
Michael Snoyman 2017-06-05 11:33:11 +03:00 committed by GitHub
commit 0b1a4b114c
7 changed files with 128 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
yesod-core/ChangeLog.md
View File

@ -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)

86
yesod-core/Yesod/Core/Internal/TH.hs
View File

@ -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
fst <$> mkYesodGeneral name' (fmap Left rest) isSub return res
let (name', rest, cxt) = case parse parseName "" name of
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 )
Right ts -> ( VarT n :xs, ns
Left t ->
( 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
renderRouteDec <- mkRenderRouteInstance site res
routeAttrsDec <- mkRouteAttrsInstance site res
res = map (fmap (parseType . dropBracket)) resS
renderRouteDec <- mkRenderRouteInstance' appCxt 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

28
yesod-core/Yesod/Routes/Parse.hs
View File

@ -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, dynamicPieceFromString x) -- https://github.com/yesodweb/yesod/issues/652
pieceFromString ('#':x) = Right $ (True, dynamicPieceFromString x)
pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x)
pieceFromString ('!':'#':x) = Right $ (False, Dynamic $ dropBracket x) -- https://github.com/yesodweb/yesod/issues/652
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
dynamicPieceFromString str@('{':x) = case break (== '}') x of
(s, "}") -> Dynamic s
_ -> error $ "Invalid path piece: " ++ str
dynamicPieceFromString x = Dynamic x
-- JP: Should we check if there are curly brackets or other invalid characters?
dropBracket :: String -> String
dropBracket str@('{':x) = case break (== '}') x of
(s, "}") -> s
_ -> error $ "Unclosed bracket ('{'): " ++ str
dropBracket x = x

8
yesod-core/Yesod/Routes/TH/ParseRoute.hs
View File

@ -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)

23
yesod-core/Yesod/Routes/TH/RenderRoute.hs
View File

@ -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

8
yesod-core/Yesod/Routes/TH/RouteAttrs.hs
View File

@ -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
]

2
yesod-core/yesod-core.cabal
View File

@ -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>