git-annex/standalone/android/haskell-patches/yesod-core-1.1.8_0001-remove-TH.patch

From 801f6dea3be43113400e41aabb443456fffcd227 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:39:40 -0400
Subject: [PATCH 1/2] remove TH

---
 Yesod/Core.hs           |   10 ----
 Yesod/Dispatch.hs       |  119 +----------------------------------------------
 Yesod/Handler.hs        |   27 +----------
 Yesod/Internal/Cache.hs |    5 --
 Yesod/Internal/Core.hs  |  119 +++++------------------------------------------
 Yesod/Widget.hs         |   29 ------------
 6 files changed, 13 insertions(+), 296 deletions(-)

diff --git a/Yesod/Core.hs b/Yesod/Core.hs
index 7268d6c..ce04b7d 100644
--- a/Yesod/Core.hs
+++ b/Yesod/Core.hs
@@ -21,16 +21,6 @@ module Yesod.Core
     , unauthorizedI
       -- * Logging
     , LogLevel (..)
-    , logDebug
-    , logInfo
-    , logWarn
-    , logError
-    , logOther
-    , logDebugS
-    , logInfoS
-    , logWarnS
-    , logErrorS
-    , logOtherS
       -- * Sessions
     , SessionBackend (..)
     , defaultClientSessionBackend
diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs
index 1e19388..dd37475 100644
--- a/Yesod/Dispatch.hs
+++ b/Yesod/Dispatch.hs
@@ -6,20 +6,9 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 module Yesod.Dispatch
     ( -- * Quasi-quoted routing
-      parseRoutes
-    , parseRoutesNoCheck
-    , parseRoutesFile
-    , parseRoutesFileNoCheck
-    , mkYesod
-    , mkYesodSub
       -- ** More fine-grained
-    , mkYesodData
-    , mkYesodSubData
-    , mkYesodDispatch
-    , mkYesodSubDispatch
-    , mkDispatchInstance
       -- ** Path pieces
-    , PathPiece (..)
+      PathPiece (..)
     , PathMultiPiece (..)
     , Texts
       -- * Convert to WAI
@@ -52,117 +41,11 @@ import Data.Monoid (mappend)
 import qualified Data.ByteString as S
 import qualified Blaze.ByteString.Builder
 import Network.HTTP.Types (status301)
-import Yesod.Routes.TH
 import Yesod.Content (chooseRep)
-import Yesod.Routes.Parse
 import System.Log.FastLogger (Logger)
 
 type Texts = [Text]
 
--- | Generates URL datatype and site function for the given 'Resource's. This
--- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
--- Use 'parseRoutes' to create the 'Resource's.
-mkYesod :: String -- ^ name of the argument datatype
-        -> [ResourceTree String]
-        -> Q [Dec]
-mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
-
--- | Generates URL datatype and site function for the given 'Resource's. This
--- is used for creating subsites, /not/ sites. See 'mkYesod' for the latter.
--- Use 'parseRoutes' to create the 'Resource's. In general, a subsite is not
--- executable by itself, but instead provides functionality to
--- be embedded in other sites.
-mkYesodSub :: String -- ^ name of the argument datatype
-           -> Cxt
-           -> [ResourceTree String]
-           -> Q [Dec]
-mkYesodSub name clazzes =
-    fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True
-  where
-    (name':rest) = words name
-
--- | 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 res = mkYesodDataGeneral name [] False res
-
-mkYesodSubData :: String -> Cxt -> [ResourceTree String] -> Q [Dec]
-mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res
-
-mkYesodDataGeneral :: String -> Cxt -> Bool -> [ResourceTree String] -> Q [Dec]
-mkYesodDataGeneral name clazzes isSub res = do
-    let (name':rest) = words name
-    (x, _) <- mkYesodGeneral name' rest clazzes isSub res
-    let rname = mkName $ "resources" ++ name
-    eres <- lift res
-    let y = [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)
-            , FunD rname [Clause [] (NormalB eres) []]
-            ]
-    return $ x ++ y
-
--- | See 'mkYesodData'.
-mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
-
-mkYesodSubDispatch :: String -> Cxt -> [ResourceTree String] -> Q [Dec]
-mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True 
-  where (name':rest) = words name
-
-mkYesodGeneral :: String                   -- ^ foundation type
-               -> [String]                 -- ^ arguments for the type
-               -> Cxt                      -- ^ the type constraints
-               -> Bool                     -- ^ it this a subsite
-               -> [ResourceTree String]
-               -> Q([Dec],[Dec])
-mkYesodGeneral name args clazzes isSub resS = do
-     subsite        <- sub
-     masterTypeSyns <- if isSub then return   [] 
-                                else sequence [handler, widget]
-     renderRouteDec <- mkRenderRouteInstance subsite res
-     dispatchDec    <- mkDispatchInstance context sub master res
-     return (renderRouteDec ++ masterTypeSyns, dispatchDec)
-  where sub     = foldl appT subCons subArgs
-        master  = if isSub then (varT $ mkName "master") else sub
-        context = if isSub then cxt $ yesod : map return clazzes
-                           else return []
-        yesod   = classP ''Yesod [master]
-        handler = tySynD (mkName "Handler") [] [t| GHandler $master $master    |]
-        widget  = tySynD (mkName "Widget")  [] [t| GWidget  $master $master () |]
-        res     = map (fmap parseType) resS
-        subCons = conT $ mkName name
-        subArgs = map (varT. mkName) args
-        
--- | If the generation of @'YesodDispatch'@ instance require finer
--- control of the types, contexts etc. using this combinator. You will
--- hardly need this generality. However, in certain situations, like
--- when writing library/plugin for yesod, this combinator becomes
--- handy.
-mkDispatchInstance :: CxtQ                -- ^ The context
-                   -> TypeQ               -- ^ The subsite type
-                   -> TypeQ               -- ^ The master site type
-                   -> [ResourceTree a]    -- ^ The resource
-                   -> DecsQ
-mkDispatchInstance context sub master res = do
-  logger <- newName "logger"
-  let loggerE = varE logger
-      loggerP = VarP logger
-      yDispatch = conT ''YesodDispatch `appT` sub `appT` master
-      thisDispatch = do
-            Clause pat body decs <- mkDispatchClause
-                                    [|yesodRunner   $loggerE |]
-                                    [|yesodDispatch $loggerE |]
-                                    [|fmap chooseRep|]
-                                    res
-            return $ FunD 'yesodDispatch
-                         [ Clause (loggerP:pat)
-                                  body
-                                  decs
-                         ]
-      in sequence [instanceD context yDispatch [thisDispatch]]
-        
-
 -- | Convert the given argument into a WAI application, executable with any WAI
 -- handler. This is the same as 'toWaiAppPlain', except it includes two
 -- middlewares: GZIP compression and autohead. This is the
diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs
index 1997bdb..98c915c 100644
--- a/Yesod/Handler.hs
+++ b/Yesod/Handler.hs
@@ -42,7 +42,6 @@ module Yesod.Handler
     , RedirectUrl (..)
     , redirect
     , redirectWith
-    , redirectToPost
       -- ** Errors
     , notFound
     , badMethod
@@ -100,7 +99,6 @@ module Yesod.Handler
     , getMessageRender
       -- * Per-request caching
     , CacheKey
-    , mkCacheKey
     , cacheLookup
     , cacheInsert
     , cacheDelete
@@ -172,7 +170,7 @@ import System.Log.FastLogger
 import Control.Monad.Logger
 
 import qualified Yesod.Internal.Cache as Cache
-import Yesod.Internal.Cache (mkCacheKey, CacheKey)
+import Yesod.Internal.Cache (CacheKey)
 import qualified Data.IORef as I
 import Control.Exception.Lifted (catch)
 import Control.Monad.Trans.Control
@@ -937,29 +935,6 @@ newIdent = do
     put x { ghsIdent = i' }
     return $ T.pack $ 'h' : show i'
 
--- | Redirect to a POST resource.
---
--- This is not technically a redirect; instead, it returns an HTML page with a
--- POST form, and some Javascript to automatically submit the form. This can be
--- useful when you need to post a plain link somewhere that needs to cause
--- changes on the server.
-redirectToPost :: RedirectUrl master url => url -> GHandler sub master a
-redirectToPost url = do
-    urlText <- toTextUrl url
-    hamletToRepHtml [hamlet|
-$newline never
-$doctype 5
-
-<html>
-    <head>
-        <title>Redirecting...
-    <body onload="document.getElementById('form').submit()">
-        <form id="form" method="post" action=#{urlText}>
-            <noscript>
-                <p>Javascript has been disabled; please click on the button below to be redirected.
-            <input type="submit" value="Continue">
-|] >>= sendResponse
-
 -- | Converts the given Hamlet template into 'Content', which can be used in a
 -- Yesod 'Response'.
 hamletToContent :: HtmlUrl (Route master) -> GHandler sub master Content
diff --git a/Yesod/Internal/Cache.hs b/Yesod/Internal/Cache.hs
index 4aec0d2..fdef9d7 100644
--- a/Yesod/Internal/Cache.hs
+++ b/Yesod/Internal/Cache.hs
@@ -3,7 +3,6 @@
 module Yesod.Internal.Cache
     ( Cache
     , CacheKey
-    , mkCacheKey
     , lookup
     , insert
     , delete
@@ -24,10 +23,6 @@ newtype Cache = Cache (Map.IntMap Any)
 
 newtype CacheKey a = CacheKey Int
 
--- | Generate a new 'CacheKey'. Be sure to give a full type signature.
-mkCacheKey :: Q Exp
-mkCacheKey = [|CacheKey|] `appE` (LitE . IntegerL . fromIntegral . hashUnique <$> runIO newUnique)
-
 lookup :: CacheKey a -> Cache -> Maybe a
 lookup (CacheKey i) (Cache m) = unsafeCoerce <$> Map.lookup i m
 
diff --git a/Yesod/Internal/Core.hs b/Yesod/Internal/Core.hs
index c4a9796..90c05fc 100644
--- a/Yesod/Internal/Core.hs
+++ b/Yesod/Internal/Core.hs
@@ -44,7 +44,6 @@ module Yesod.Internal.Core
 
 import Yesod.Content
 import Yesod.Handler hiding (lift, getExpires)
-import Control.Monad.Logger (logErrorS)
 
 import Yesod.Routes.Class
 import Data.Time (UTCTime, addUTCTime, getCurrentTime)
@@ -165,22 +164,7 @@ class RenderRoute a => Yesod a where
 
     -- | Applies some form of layout to the contents of a page.
     defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml
-    defaultLayout w = do
-        p <- widgetToPageContent w
-        mmsg <- getMessage
-        hamletToRepHtml [hamlet|
-$newline never
-$doctype 5
-
-<html>
-    <head>
-        <title>#{pageTitle p}
-        ^{pageHead p}
-    <body>
-        $maybe msg <- mmsg
-            <p .message>#{msg}
-        ^{pageBody p}
-|]
+    defaultLayout w = error "defaultLayout not implemented"
 
     -- | Override the rendering function for a particular URL. One use case for
     -- this is to offload static hosting to a different domain name to avoid
@@ -521,46 +505,11 @@ applyLayout' title body = fmap chooseRep $ defaultLayout $ do
 
 -- | The default error handler for 'errorHandler'.
 defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep
-defaultErrorHandler NotFound = do
-    r <- waiRequest
-    let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
-    applyLayout' "Not Found"
-        [hamlet|
-$newline never
-<h1>Not Found
-<p>#{path'}
-|]
-defaultErrorHandler (PermissionDenied msg) =
-    applyLayout' "Permission Denied"
-        [hamlet|
-$newline never
-<h1>Permission denied
-<p>#{msg}
-|]
-defaultErrorHandler (InvalidArgs ia) =
-    applyLayout' "Invalid Arguments"
-        [hamlet|
-$newline never
-<h1>Invalid Arguments
-<ul>
-    $forall msg <- ia
-        <li>#{msg}
-|]
-defaultErrorHandler (InternalError e) = do
-    $logErrorS "yesod-core" e
-    applyLayout' "Internal Server Error"
-        [hamlet|
-$newline never
-<h1>Internal Server Error
-<pre>#{e}
-|]
-defaultErrorHandler (BadMethod m) =
-    applyLayout' "Bad Method"
-        [hamlet|
-$newline never
-<h1>Method Not Supported
-<p>Method <code>#{S8.unpack m}</code> not supported
-|]
+defaultErrorHandler NotFound = error "Not Found"
+defaultErrorHandler (PermissionDenied msg) = error "Permission Denied"
+defaultErrorHandler (InvalidArgs ia) = error "Invalid Arguments"
+defaultErrorHandler (InternalError e) = error "Internal Server Error"
+defaultErrorHandler (BadMethod m) = error "Bad Method"
 
 -- | Return the same URL if the user is authorized to see it.
 --
@@ -616,45 +565,10 @@ widgetToPageContent w = do
     -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing
     -- the asynchronous loader means your page doesn't have to wait for all the js to load
     let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc
-        regularScriptLoad = [hamlet|
-$newline never
-$forall s <- scripts
-    ^{mkScriptTag s}
-$maybe j <- jscript
-    $maybe s <- jsLoc
-        <script src="#{s}">
-    $nothing
-        <script>^{jelper j}
-|]
-
-        headAll = [hamlet|
-$newline never
-\^{head'}
-$forall s <- stylesheets
-    ^{mkLinkTag s}
-$forall s <- css
-    $maybe t <- right $ snd s
-        $maybe media <- fst s
-            <link rel=stylesheet media=#{media} href=#{t}>
-        $nothing
-            <link rel=stylesheet href=#{t}>
-    $maybe content <- left $ snd s
-        $maybe media <- fst s
-            <style media=#{media}>#{content}
-        $nothing
-            <style>#{content}
-$case jsLoader master
-  $of BottomOfBody
-  $of BottomOfHeadAsync asyncJsLoader
-      ^{asyncJsLoader asyncScripts mcomplete}
-  $of BottomOfHeadBlocking
-      ^{regularScriptLoad}
-|]
-    let bodyScript = [hamlet|
-$newline never
-^{body}
-^{regularScriptLoad}
-|]
+        regularScriptLoad = error "TODO"
+
+        headAll = error "TODO"
+    let bodyScript = error "TODO"
 
     return $ PageContent title headAll (case jsLoader master of
       BottomOfBody -> bodyScript
@@ -696,18 +610,7 @@ jsonArray = unsafeLazyByteString . encode . Array . Vector.fromList . map String
 
 -- | For use with setting 'jsLoader' to 'BottomOfHeadAsync'
 loadJsYepnope :: Yesod master => Either Text (Route master) -> [Text] -> Maybe (HtmlUrl (Route master)) -> (HtmlUrl (Route master))
-loadJsYepnope eyn scripts mcomplete =
-  [hamlet|
-$newline never
-    $maybe yn <- left eyn
-        <script src=#{yn}>
-    $maybe yn <- right eyn
-        <script src=@{yn}>
-    $maybe complete <- mcomplete
-        <script>yepnope({load:#{jsonArray scripts},complete:function(){^{complete}}});
-    $nothing
-        <script>yepnope({load:#{jsonArray scripts}});
-|]
+loadJsYepnope eyn scripts mcomplete = error "TODO"
 
 asyncHelper :: (url -> [x] -> Text)
          -> [Script (url)]
diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs
index bd94bd3..bf79150 100644
--- a/Yesod/Widget.hs
+++ b/Yesod/Widget.hs
@@ -15,8 +15,6 @@ module Yesod.Widget
       GWidget
     , PageContent (..)
       -- * Special Hamlet quasiquoter/TH for Widgets
-    , whamlet
-    , whamletFile
     , ihamletToRepHtml
       -- * Convert to Widget
     , ToWidget (..)
@@ -54,7 +52,6 @@ module Yesod.Widget
     , addScriptEither
       -- * Internal
     , unGWidget
-    , whamletFileWithSettings
     ) where
 
 import Data.Monoid
@@ -274,32 +271,6 @@ data PageContent url = PageContent
     , pageBody :: HtmlUrl url
     }
 
-whamlet :: QuasiQuoter
-whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
-
-whamletFile :: FilePath -> Q Exp
-whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings
-
-whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp
-whamletFileWithSettings = NP.hamletFileWithSettings rules
-
-rules :: Q NP.HamletRules
-rules = do
-    ah <- [|toWidget|]
-    let helper qg f = do
-            x <- newName "urender"
-            e <- f $ VarE x
-            let e' = LamE [VarP x] e
-            g <- qg
-            bind <- [|(>>=)|]
-            return $ InfixE (Just g) bind (Just e')
-    let ur f = do
-            let env = NP.Env
-                    (Just $ helper [|liftW getUrlRenderParams|])
-                    (Just $ helper [|liftM (toHtml .) $ liftW getMessageRender|])
-            f env
-    return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b
-
 -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
 ihamletToRepHtml :: RenderMessage master message
                  => HtmlUrlI18n message (Route master)
-- 
1.7.10.4