diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs index 2b285746..5e0121c8 100644 --- a/yesod-core/Yesod/Core/Internal/TH.hs +++ b/yesod-core/Yesod/Core/Internal/TH.hs @@ -16,16 +16,11 @@ 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) @@ -42,7 +37,7 @@ import Yesod.Core.Internal.Run mkYesod :: String -- ^ name of the argument datatype -> [ResourceTree String] -> Q [Dec] -mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False return +mkYesod name = fmap (uncurry (++)) . mkYesodWithParser name False return {-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name. (https://github.com/yesodweb/yesod/pull/1366)" #-} mkYesodWith :: [[String]] @@ -50,24 +45,29 @@ mkYesodWith :: [[String]] -> [String] -> [ResourceTree String] -> Q [Dec] -mkYesodWith cxts name args = fmap (uncurry (++)) . mkYesodGeneral' cxts name args False return +mkYesodWith cxts name args = fmap (uncurry (++)) . mkYesodGeneral cxts name args False return -- | Sometimes, you will want to declare your routes in one file and define -- your handlers elsewhere. For example, this is the only way to break up a -- monolithic file into smaller parts. Use this function, paired with -- 'mkYesodDispatch', to do just that. mkYesodData :: String -> [ResourceTree String] -> Q [Dec] -mkYesodData name = mkYesodDataGeneral name False +mkYesodData name resS = fst <$> mkYesodWithParser name False return resS mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec] -mkYesodSubData name = mkYesodDataGeneral name True +mkYesodSubData name resS = fst <$> mkYesodWithParser name True return resS -mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec] -mkYesodDataGeneral name isSub res = do +-- | Parses contexts and type arguments out of name before generating TH. +mkYesodWithParser :: String -- ^ foundation type + -> Bool -- ^ is this a subsite + -> (Exp -> Q Exp) -- ^ unwrap handler + -> [ResourceTree String] + -> Q([Dec],[Dec]) +mkYesodWithParser name isSub f resS = do let (name', rest, cxt) = case parse parseName "" name of Left err -> error $ show err Right a -> a - fst <$> mkYesodGeneral' cxt name' rest isSub return res + mkYesodGeneral cxt name' rest isSub f resS where parseName = do @@ -101,7 +101,7 @@ mkYesodDataGeneral name isSub res = do -- | See 'mkYesodData'. mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec] -mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False return +mkYesodDispatch name = fmap snd . mkYesodWithParser name False return -- | Get the Handler and Widget type synonyms for the given site. masterTypeSyns :: [Name] -> Type -> [Dec] @@ -112,25 +112,14 @@ masterTypeSyns vs site = $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''() ] --- | 'Left' arguments indicate a monomorphic type, a 'Right' argument --- indicates a polymorphic type, and provides the list of classes --- the type must be instance of. -mkYesodGeneral :: String -- ^ foundation type - -> [String] -- ^ arguments for the type - -> Bool -- ^ is this a subsite - -> (Exp -> Q Exp) -- ^ unwrap handler - -> [ResourceTree String] - -> Q([Dec],[Dec]) -mkYesodGeneral = mkYesodGeneral' [] - -mkYesodGeneral' :: [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances. +mkYesodGeneral :: [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances. -> String -- ^ foundation type -> [String] -- ^ arguments for the type -> Bool -- ^ is this a subsite -> (Exp -> Q Exp) -- ^ unwrap handler -> [ResourceTree String] -> Q([Dec],[Dec]) -mkYesodGeneral' appCxt' namestr mtys isSub f resS = do +mkYesodGeneral appCxt' namestr mtys 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 @@ -183,12 +172,6 @@ mkYesodGeneral' appCxt' namestr mtys 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