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

Contexts can be parsed and included in instances. Standalone deriving is used when

Browse Source 
a context is provided. Type variables can be included in routes/TH.
This commit is contained in:
James Parker 2017-03-23 22:39:41 -04:00
parent 6c7a40ea5b
commit adf89bcf84
5 changed files with 93 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
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,16 @@ import Language.Haskell.TH.Syntax
import qualified Network.Wai as W
import Data.ByteString.Lazy.Char8 ()
import Data.List (foldl')
import Data.Char (isLower)
import Data.List (foldl', uncons)
#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.Parsec.Token (symbol)
import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
import Yesod.Routes.TH
import Yesod.Routes.Parse
@ -55,8 +60,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 +117,17 @@ 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) -> foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest) appCxt'
mname <- lookupTypeName namestr
arity <- case mname of
Just name -> do
@ -105,10 +152,15 @@ 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@(h:_) | isLower h ->
( VarT (mkName t):xs, vns', cs )
Left t ->
( ConT (mkName 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)
@ -119,10 +171,10 @@ mkYesodGeneral namestr args isSub f resS = do
) ([],vns,[]) args
site = foldl' AppT (ConT name) argtypes
res = map (fmap parseType) resS
renderRouteDec <- mkRenderRouteInstance site res
routeAttrsDec <- mkRouteAttrsInstance site res
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 +182,7 @@ mkYesodGeneral namestr args isSub f resS = do
, FunD rname [Clause [] (NormalB eres) []]
]
let dataDec = concat
[ [parse]
[ [parseRoute]
, renderRouteDec
, [routeAttrsDec]
, resourcesDec
@ -138,6 +190,10 @@ mkYesodGeneral namestr args isSub f resS = do
]
return (dataDec, dispatchDec)
where
nameToType t@(h:_) | isLower h = VarT $ mkName t
nameToType t = ConT $ mkName t
mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
mkMDS f rh = MkDispatchSettings
{ mdsRunHandler = rh

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

@ -13,7 +13,7 @@ module Yesod.Routes.Parse
) 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,6 +252,7 @@ toTypeTree orig = do
gos' (front . (t:)) xs'
ttToType :: TypeTree -> Type
ttToType (TTTerm s@(h:_)) | isLower h = VarT $ mkName s
ttToType (TTTerm s) = ConT $ mkName s
ttToType (TTApp x y) = ttToType x `AppT` ttToType y
ttToType (TTList t) = ListT `AppT` ttToType t

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)

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

@ -3,6 +3,7 @@ module Yesod.Routes.TH.RenderRoute
( -- ** RenderRoute
mkRenderRouteInstance
, mkRenderRouteInstance'
, mkRenderRouteInstance'
, mkRouteCons
, mkRenderRouteClauses
) where
@ -12,6 +13,7 @@ import Yesod.Routes.TH.Types
import Language.Haskell.TH (conT)
#endif
import Language.Haskell.TH.Syntax
import Data.Bits (xor)
import Data.Maybe (maybeToList)
import Control.Monad (replicateM)
import Data.Text (pack)
@ -156,18 +158,23 @@ 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))
#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)
#else
let did = DataInstD [] ''Route [typ] cons clazzes
let did = DataInstD [] ''Route [typ] cons (clazzes False)
#endif
let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
return $ instanceD cxt (ConT ''RenderRoute `AppT` typ)
[ did
, FunD (mkName "renderRoute") cls
] : decs
]
: sds ++ decs
where
clazzes = [''Show, ''Eq, ''Read]
clazzes standalone = if standalone `xor` null cxt then
[''Show, ''Eq, ''Read]
else
[]
#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
]