mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

finished convering android build to pinned packages

Browse source 
Package versions match Debian jessie, except for a few differences
needed due to the different version of ghc pulling in a few buildin
packages with other versions.

Most of the patches were cherry-picked from past commits, since these are
older versions.
This commit is contained in:
Joey Hess 2014-10-16 00:31:59 -04:00
parent fe5e25eec7
commit 076e9c55ba
16 changed files with 1382 additions and 1376 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
standalone/android/cabal.config
View file

@ -2,13 +2,13 @@ constraints: Crypto ==4.2.5.1,
DAV ==1.0.3, DAV ==1.0.3,
HTTP ==4000.2.17, HTTP ==4000.2.17,
HUnit ==1.2.5.2, HUnit ==1.2.5.2,
IfElse ==0.85.0.0.1, IfElse ==0.85,
MissingH ==1.2.1.0, MissingH ==1.2.1.0,
MonadRandom ==0.1.13, MonadRandom ==0.1.13,
QuickCheck ==2.7.6, QuickCheck ==2.7.6,
SHA ==1.6.1, SHA ==1.6.1,
SafeSemaphore ==0.10.1, SafeSemaphore ==0.10.1,
aeson ==0.7.0.4, aeson ==0.7.0.6,
ansi-terminal ==0.6.1.1, ansi-terminal ==0.6.1.1,
ansi-wl-pprint ==0.6.7.1, ansi-wl-pprint ==0.6.7.1,
appar ==0.1.4, appar ==0.1.4,
@ -16,17 +16,17 @@ constraints: Crypto ==4.2.5.1,
asn1-parse ==0.8.1, asn1-parse ==0.8.1,
asn1-types ==0.2.3, asn1-types ==0.2.3,
async ==2.0.1.5, async ==2.0.1.5,
attoparsec ==0.10.4.0, attoparsec ==0.11.3.4,
attoparsec-conduit ==1.1.0, attoparsec-conduit ==1.1.0,
authenticate ==1.3.2.10, authenticate ==1.3.2.10,
base-unicode-symbols ==0.2.2.4, base-unicode-symbols ==0.2.2.4,
base16-bytestring ==0.1.1.6, base16-bytestring ==0.1.1.6,
base64-bytestring ==1.0.0.1, base64-bytestring ==1.0.0.1,
bifunctors ==4.1.1.1, bifunctors ==4.1.1.1,
bloomfilter ==1.2.6.10, bloomfilter ==2.0.0.0,
byteable ==0.1.1, byteable ==0.1.1,
byteorder ==1.0.4, byteorder ==1.0.4,
case-insensitive ==1.1.0.2, case-insensitive ==1.2.0.1,
cereal ==0.4.0.1, cereal ==0.4.0.1,
cipher-aes ==0.2.8, cipher-aes ==0.2.8,
cipher-des ==0.0.6, cipher-des ==0.0.6,
@ -48,6 +48,7 @@ constraints: Crypto ==4.2.5.1,
cryptohash ==0.11.6, cryptohash ==0.11.6,
cryptohash-conduit ==0.1.1, cryptohash-conduit ==0.1.1,
css-text ==0.1.2.1, css-text ==0.1.2.1,
shakespeare-text ==1.0.2,
data-default ==0.5.3, data-default ==0.5.3,
data-default-class ==0.0.1, data-default-class ==0.0.1,
data-default-instances-base ==0.0.1, data-default-instances-base ==0.0.1,
@ -72,7 +73,6 @@ constraints: Crypto ==4.2.5.1,
file-embed ==0.0.6, file-embed ==0.0.6,
fingertree ==0.1.0.0, fingertree ==0.1.0.0,
free ==4.9, free ==4.9,
git-annex ==5.20141013,
gnuidn ==0.2, gnuidn ==0.2,
gnutls ==0.1.4, gnutls ==0.1.4,
gsasl ==0.3.5, gsasl ==0.3.5,
@ -97,7 +97,7 @@ constraints: Crypto ==4.2.5.1,
keys ==3.10.1, keys ==3.10.1,
language-javascript ==0.5.13, language-javascript ==0.5.13,
lens ==4.4.0.2, lens ==4.4.0.2,
libxml-sax ==0.7.3, libxml-sax ==0.7.5,
mime-mail ==0.4.1.2, mime-mail ==0.4.1.2,
mime-types ==0.1.0.4, mime-types ==0.1.0.4,
mmorph ==1.0.3, mmorph ==1.0.3,
@ -153,7 +153,7 @@ constraints: Crypto ==4.2.5.1,
stringprep ==0.1.5, stringprep ==0.1.5,
stringsearch ==0.3.6.5, stringsearch ==0.3.6.5,
syb ==0.4.0, syb ==0.4.0,
system-fileio ==0.3.11, system-fileio ==0.3.14,
system-filepath ==0.4.12, system-filepath ==0.4.12,
tagged ==0.7.2, tagged ==0.7.2,
tagsoup ==0.13.1, tagsoup ==0.13.1,
@ -162,7 +162,7 @@ constraints: Crypto ==4.2.5.1,
tasty-hunit ==0.9, tasty-hunit ==0.9,
tasty-quickcheck ==0.8.1, tasty-quickcheck ==0.8.1,
tasty-rerun ==1.1.3, tasty-rerun ==1.1.3,
text ==0.11.3.1, text ==1.1.1.0,
text-icu ==0.6.3.7, text-icu ==0.6.3.7,
tf-random ==0.5, tf-random ==0.5,
tls ==1.2.9, tls ==1.2.9,
@ -170,7 +170,7 @@ constraints: Crypto ==4.2.5.1,
transformers-base ==0.4.1, transformers-base ==0.4.1,
transformers-compat ==0.3.3.3, transformers-compat ==0.3.3.3,
unbounded-delays ==0.1.0.8, unbounded-delays ==0.1.0.8,
unix-compat ==0.4.0.0, unix-compat ==0.4.1.3,
unix-time ==0.2.2, unix-time ==0.2.2,
unordered-containers ==0.2.5.0, unordered-containers ==0.2.5.0,
utf8-string ==0.3.7, utf8-string ==0.3.7,
@ -205,4 +205,4 @@ constraints: Crypto ==4.2.5.1,
yesod-static ==1.2.4, yesod-static ==1.2.4,
zlib ==0.5.4.1, zlib ==0.5.4.1,
bytestring ==0.10.4.0, bytestring ==0.10.4.0,
scientific ==0.2.0.2 scientific ==0.3.3.1

49
standalone/android/haskell-patches/dns_use-android-net.dns1-command-instead-of-resolv.conf.patch
View file

@ -1,20 +1,15 @@
From 99f349066fc960bfa60b4e369bb21431c87d9b59 Mon Sep 17 00:00:00 2001 From 087f1ae5e17f0e6d7c9f6b4092a5bb5bb6f5bf60 Mon Sep 17 00:00:00 2001
From: dummy <dummy@example.com> From: dummy <dummy@example.com>
Date: Tue, 14 Oct 2014 03:54:57 +0000 Date: Thu, 16 Oct 2014 02:59:11 +0000
Subject: [PATCH] use android net.dns1 command instead of resolv.conf file Subject: [PATCH] port
Android has no /etc/resolv.conf. Some might have /system/etc/resolv.conf,
but even that does not seem likely.
This is likely a little slow, but is at least fine for git-annex's uses,
since it only uses this library for occasional SRV lookups.
--- ---
Network/DNS/Resolver.hs | 11 +++++++++-- Network/DNS/Resolver.hs | 13 ++++++++-----
dns.cabal | 1 + dns.cabal | 1 +
2 files changed, 10 insertions(+), 2 deletions(-) 2 files changed, 9 insertions(+), 5 deletions(-)
diff --git a/Network/DNS/Resolver.hs b/Network/DNS/Resolver.hs diff --git a/Network/DNS/Resolver.hs b/Network/DNS/Resolver.hs
index 9e8342b..4c6c380 100644 index 5721e03..c4400d1 100644
--- a/Network/DNS/Resolver.hs --- a/Network/DNS/Resolver.hs
+++ b/Network/DNS/Resolver.hs +++ b/Network/DNS/Resolver.hs
@@ -19,7 +19,7 @@ module Network.DNS.Resolver ( @@ -19,7 +19,7 @@ module Network.DNS.Resolver (
@ -23,10 +18,10 @@ index 9e8342b..4c6c380 100644
import Control.Applicative ((<$>), (<*>), pure) import Control.Applicative ((<$>), (<*>), pure)
-import Control.Exception (bracket) -import Control.Exception (bracket)
+import Control.Exception (bracket, catch, IOException) +import Control.Exception (bracket, catch, IOException)
import qualified Data.ByteString.Char8 as BS
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.List (isPrefixOf) import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe) @@ -32,6 +32,7 @@ import Network.Socket (AddrInfoFlag(..), AddrInfo(..), defaultHints, getAddrInfo
@@ -33,6 +33,7 @@ import Network.Socket (AddrInfoFlag(..), AddrInfo(..), SockAddr(..), PortNumber(
import Prelude hiding (lookup) import Prelude hiding (lookup)
import System.Random (getStdRandom, randomR) import System.Random (getStdRandom, randomR)
import System.Timeout (timeout) import System.Timeout (timeout)
@ -34,26 +29,28 @@ index 9e8342b..4c6c380 100644
#if mingw32_HOST_OS == 1 #if mingw32_HOST_OS == 1
import Network.Socket (send) import Network.Socket (send)
@@ -133,7 +134,13 @@ makeResolvSeed conf = ResolvSeed <$> addr @@ -130,10 +131,12 @@ makeResolvSeed conf = ResolvSeed <$> addr
where
addr = case resolvInfo conf of addr = case resolvInfo conf of
RCHostName numhost -> makeAddrInfo numhost Nothing RCHostName numhost -> makeAddrInfo numhost
RCHostPort numhost mport -> makeAddrInfo numhost $ Just mport - RCFilePath file -> toAddr <$> readFile file >>= makeAddrInfo
- RCFilePath file -> toAddr <$> readFile file >>= \i -> makeAddrInfo i Nothing - toAddr cs = let l:_ = filter ("nameserver" `isPrefixOf`) $ lines cs
- in extract l
- extract = reverse . dropWhile isSpace . reverse . dropWhile isSpace . drop 11
+ RCFilePath file -> do + RCFilePath file -> do
+ -- Android has no /etc/resolv.conf; use getprop command. + -- Android has no /etc/resolv.conf; use getprop command.
+ ls <- catch (lines <$> readProcess "getprop" ["net.dns1"] []) (const (return []) :: IOException -> IO [String]) + ls <- catch (lines <$> readProcess "getprop" ["net.dns1"] []) (const (return []) :: IOException -> IO [String])
+ let addr = case ls of + makeAddrInfo $ case ls of
+ [] -> "8.8.8.8" -- google public dns as a fallback only + [] -> "8.8.8.8" -- google public dns as a fallback only
+ (l:_) -> l + (l:_) -> l
+ makeAddrInfo addr Nothing
toAddr cs = let l:_ = filter ("nameserver" `isPrefixOf`) $ lines cs makeAddrInfo :: HostName -> IO AddrInfo
in extract l makeAddrInfo addr = do
extract = reverse . dropWhile isSpace . reverse . dropWhile isSpace . drop 11
diff --git a/dns.cabal b/dns.cabal diff --git a/dns.cabal b/dns.cabal
index fd7d7a3..5ad8a84 100644 index ceaf5f4..cd15e61 100644
--- a/dns.cabal --- a/dns.cabal
+++ b/dns.cabal +++ b/dns.cabal
@@ -38,6 +38,7 @@ Library @@ -37,6 +37,7 @@ Library
, network >= 2.3 , network >= 2.3
, random , random
, resourcet , resourcet
@ -62,5 +59,5 @@ index fd7d7a3..5ad8a84 100644
Build-Depends: base >= 4 && < 5 Build-Depends: base >= 4 && < 5
, attoparsec , attoparsec
-- --
1.7.10.4 2.1.1

50
standalone/android/haskell-patches/gnuidn_fix-build-with-new-base.patch Normal file
View file

@ -0,0 +1,50 @@
From afdec6c9e66211a0ac8419fffe191b059d1fd00c Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 17:24:33 +0000
Subject: [PATCH] fix build with new base
---
Data/Text/IDN/IDNA.chs | 1 +
Data/Text/IDN/Punycode.chs | 1 +
Data/Text/IDN/StringPrep.chs | 1 +
3 files changed, 3 insertions(+)
diff --git a/Data/Text/IDN/IDNA.chs b/Data/Text/IDN/IDNA.chs
index ed29ee4..dbb4ba5 100644
--- a/Data/Text/IDN/IDNA.chs
+++ b/Data/Text/IDN/IDNA.chs
@@ -31,6 +31,7 @@ import Foreign
import Foreign.C
import Data.Text.IDN.Internal
+import System.IO.Unsafe
#include <idna.h>
#include <idn-free.h>
diff --git a/Data/Text/IDN/Punycode.chs b/Data/Text/IDN/Punycode.chs
index 24b5fa6..4e62555 100644
--- a/Data/Text/IDN/Punycode.chs
+++ b/Data/Text/IDN/Punycode.chs
@@ -32,6 +32,7 @@ import Data.List (unfoldr)
import qualified Data.ByteString as B
import qualified Data.Text as T
+import System.IO.Unsafe
import Foreign
import Foreign.C
diff --git a/Data/Text/IDN/StringPrep.chs b/Data/Text/IDN/StringPrep.chs
index 752dc9e..5e9fd84 100644
--- a/Data/Text/IDN/StringPrep.chs
+++ b/Data/Text/IDN/StringPrep.chs
@@ -39,6 +39,7 @@ import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
+import System.IO.Unsafe
import Foreign
import Foreign.C
--
1.7.10.4

153
standalone/android/haskell-patches/shakespeare-text_remove-TH.patch Normal file
View file

@ -0,0 +1,153 @@
From dca2a30ca06865bf66cd25cc14b06f5d28190231 Mon Sep 17 00:00:00 2001
From: dummy <dummy@example.com>
Date: Thu, 16 Oct 2014 02:46:57 +0000
Subject: [PATCH] remove TH
---
Text/Shakespeare/Text.hs | 125 +++++------------------------------------------
1 file changed, 11 insertions(+), 114 deletions(-)
diff --git a/Text/Shakespeare/Text.hs b/Text/Shakespeare/Text.hs
index 6865a5a..e25a8be 100644
--- a/Text/Shakespeare/Text.hs
+++ b/Text/Shakespeare/Text.hs
@@ -7,18 +7,18 @@ module Text.Shakespeare.Text
( TextUrl
, ToText (..)
, renderTextUrl
- , stext
- , text
- , textFile
- , textFileDebug
- , textFileReload
- , st -- | strict text
- , lt -- | lazy text, same as stext :)
+ --, stext
+ --, text
+ --, textFile
+ --, textFileDebug
+ --, textFileReload
+ --, st -- | strict text
+ --, lt -- | lazy text, same as stext :)
-- * Yesod code generation
- , codegen
- , codegenSt
- , codegenFile
- , codegenFileReload
+ --, codegen
+ --, codegenSt
+ --, codegenFile
+ --, codegenFileReload
) where
import Language.Haskell.TH.Quote (QuasiQuoter (..))
@@ -45,106 +45,3 @@ instance ToText Int32 where toText = toText . show
instance ToText Int64 where toText = toText . show
instance ToText Int where toText = toText . show
-settings :: Q ShakespeareSettings
-settings = do
- toTExp <- [|toText|]
- wrapExp <- [|id|]
- unWrapExp <- [|id|]
- return $ defaultShakespeareSettings { toBuilder = toTExp
- , wrap = wrapExp
- , unwrap = unWrapExp
- }
-
-
-stext, lt, st, text :: QuasiQuoter
-stext =
- QuasiQuoter { quoteExp = \s -> do
- rs <- settings
- render <- [|toLazyText|]
- rendered <- shakespeareFromString rs { justVarInterpolation = True } s
- return (render `AppE` rendered)
- }
-lt = stext
-
-st =
- QuasiQuoter { quoteExp = \s -> do
- rs <- settings
- render <- [|TL.toStrict . toLazyText|]
- rendered <- shakespeareFromString rs { justVarInterpolation = True } s
- return (render `AppE` rendered)
- }
-
-text = QuasiQuoter { quoteExp = \s -> do
- rs <- settings
- quoteExp (shakespeare rs) $ filter (/='\r') s
- }
-
-
-textFile :: FilePath -> Q Exp
-textFile fp = do
- rs <- settings
- shakespeareFile rs fp
-
-
-textFileDebug :: FilePath -> Q Exp
-textFileDebug = textFileReload
-{-# DEPRECATED textFileDebug "Please use textFileReload instead" #-}
-
-textFileReload :: FilePath -> Q Exp
-textFileReload fp = do
- rs <- settings
- shakespeareFileReload rs fp
-
--- | codegen is designed for generating Yesod code, including templates
--- So it uses different interpolation characters that won't clash with templates.
-codegenSettings :: Q ShakespeareSettings
-codegenSettings = do
- toTExp <- [|toText|]
- wrapExp <- [|id|]
- unWrapExp <- [|id|]
- return $ defaultShakespeareSettings { toBuilder = toTExp
- , wrap = wrapExp
- , unwrap = unWrapExp
- , varChar = '~'
- , urlChar = '*'
- , intChar = '&'
- , justVarInterpolation = True -- always!
- }
-
--- | codegen is designed for generating Yesod code, including templates
--- So it uses different interpolation characters that won't clash with templates.
--- You can use the normal text quasiquoters to generate code
-codegen :: QuasiQuoter
-codegen =
- QuasiQuoter { quoteExp = \s -> do
- rs <- codegenSettings
- render <- [|toLazyText|]
- rendered <- shakespeareFromString rs { justVarInterpolation = True } s
- return (render `AppE` rendered)
- }
-
--- | Generates strict Text
--- codegen is designed for generating Yesod code, including templates
--- So it uses different interpolation characters that won't clash with templates.
-codegenSt :: QuasiQuoter
-codegenSt =
- QuasiQuoter { quoteExp = \s -> do
- rs <- codegenSettings
- render <- [|TL.toStrict . toLazyText|]
- rendered <- shakespeareFromString rs { justVarInterpolation = True } s
- return (render `AppE` rendered)
- }
-
-codegenFileReload :: FilePath -> Q Exp
-codegenFileReload fp = do
- rs <- codegenSettings
- render <- [|TL.toStrict . toLazyText|]
- rendered <- shakespeareFileReload rs{ justVarInterpolation = True } fp
- return (render `AppE` rendered)
-
-codegenFile :: FilePath -> Q Exp
-codegenFile fp = do
- rs <- codegenSettings
- render <- [|TL.toStrict . toLazyText|]
- rendered <- shakespeareFile rs{ justVarInterpolation = True } fp
- return (render `AppE` rendered)
--
2.1.1

13
standalone/android/install-haskell-packages
View file

@ -16,8 +16,6 @@ if [ ! -d haskell-patches ]; then
fi fi
setupcabal () { setupcabal () {
cabal update
# Some packages fail to install in a non unicode locale. # Some packages fail to install in a non unicode locale.
LANG=en_US.UTF-8 LANG=en_US.UTF-8
export LANG export LANG
@ -40,6 +38,7 @@ patched () {
git config user.email dummy@example.com git config user.email dummy@example.com
git add . git add .
git commit -m "pre-patched state of $pkg" git commit -m "pre-patched state of $pkg"
ln -sf ../../cabal.config
for patch in ../../haskell-patches/${pkg}_* ../../../no-th/haskell-patches/${pkg}_*; do for patch in ../../haskell-patches/${pkg}_* ../../../no-th/haskell-patches/${pkg}_*; do
if [ -e "$patch" ]; then if [ -e "$patch" ]; then
echo trying $patch echo trying $patch
@ -50,8 +49,6 @@ patched () {
fi fi
fi fi
done done
set -x
ln -sf ../../cabal.config
if [ -e config.sub ]; then if [ -e config.sub ]; then
cp /usr/share/misc/config.sub . cp /usr/share/misc/config.sub .
fi fi
@ -66,8 +63,7 @@ patched () {
} }
installgitannexdeps () { installgitannexdeps () {
pushd pushd ../..
cd ../..
ln -sf standalone/android/cabal.config ln -sf standalone/android/cabal.config
cabal install --only-dependencies "$@" cabal install --only-dependencies "$@"
rm -f cabal.config rm -f cabal.config
@ -107,6 +103,7 @@ EOF
patched shakespeare-css patched shakespeare-css
patched shakespeare-js patched shakespeare-js
patched yesod-routes patched yesod-routes
patched hamlet
patched yesod-core patched yesod-core
patched yesod-persistent patched yesod-persistent
patched yesod-form patched yesod-form
@ -121,6 +118,8 @@ EOF
patched dns patched dns
patched gnutls patched gnutls
patched unbounded-delays patched unbounded-delays
patched gnuidn
patched network-protocol-xmpp
cd .. cd ..
@ -132,4 +131,6 @@ cabal update
PATH=$HOME/.ghc/$(cat abiversion)/bin:$HOME/.ghc/$(cat abiversion)/arm-linux-androideabi/bin:$PATH PATH=$HOME/.ghc/$(cat abiversion)/bin:$HOME/.ghc/$(cat abiversion)/arm-linux-androideabi/bin:$PATH
setupcabal setupcabal
cabal update
install_pkgs install_pkgs

25
standalone/no-th/haskell-patches/DAV_build-without-TH.patch
View file

@ -1,19 +1,19 @@
From 438479e3573d4a9fa2e001b8f7ec5f9a595d7514 Mon Sep 17 00:00:00 2001 From e54cfacbb9fb24f75d3d93cd8ee6da67b161574f Mon Sep 17 00:00:00 2001
From: dummy <dummy@example.com> From: dummy <dummy@example.com>
Date: Tue, 14 Oct 2014 03:48:07 +0000 Date: Thu, 16 Oct 2014 02:51:28 +0000
Subject: [PATCH] avoid TH Subject: [PATCH] remove TH
--- ---
DAV.cabal | 25 +---- DAV.cabal | 28 +----
Network/Protocol/HTTP/DAV.hs | 92 +++++++++++++--- Network/Protocol/HTTP/DAV.hs | 92 +++++++++++++---
Network/Protocol/HTTP/DAV/TH.hs | 232 ++++++++++++++++++++++++++++++++++++++- Network/Protocol/HTTP/DAV/TH.hs | 232 +++++++++++++++++++++++++++++++++++++++-
3 files changed, 306 insertions(+), 43 deletions(-) 3 files changed, 306 insertions(+), 46 deletions(-)
diff --git a/DAV.cabal b/DAV.cabal diff --git a/DAV.cabal b/DAV.cabal
index f8fdd40..92945c3 100644 index 95fffd8..5669c51 100644
--- a/DAV.cabal --- a/DAV.cabal
+++ b/DAV.cabal +++ b/DAV.cabal
@@ -43,30 +43,7 @@ library @@ -47,33 +47,7 @@ library
, utf8-string , utf8-string
, xml-conduit >= 1.0 && < 1.3 , xml-conduit >= 1.0 && < 1.3
, xml-hamlet >= 0.4 && < 0.5 , xml-hamlet >= 0.4 && < 0.5
@ -34,13 +34,16 @@ index f8fdd40..92945c3 100644
- , http-types >= 0.7 - , http-types >= 0.7
- , lens >= 3.0 - , lens >= 3.0
- , mtl >= 2.1 - , mtl >= 2.1
- , network >= 2.3
- , optparse-applicative >= 0.10.0 - , optparse-applicative >= 0.10.0
- , transformers >= 0.3 - , transformers >= 0.3
- , transformers-base - , transformers-base
- , utf8-string - , utf8-string
- , xml-conduit >= 1.0 && < 1.3 - , xml-conduit >= 1.0 && < 1.3
- , xml-hamlet >= 0.4 && < 0.5 - , xml-hamlet >= 0.4 && < 0.5
- if flag(network-uri)
- build-depends: network-uri >= 2.6, network >= 2.6
- else
- build-depends: network >= 2.3 && <2.6
+ , text + , text
source-repository head source-repository head
@ -413,5 +416,5 @@ index 0ecd476..1653bf6 100644
+ Data.Functor.<$> (_f_a3k7 __userAgent'_a3kg)) + Data.Functor.<$> (_f_a3k7 __userAgent'_a3kg))
+{-# INLINE userAgent #-} +{-# INLINE userAgent #-}
-- --
1.7.10.4 2.1.1

205
standalone/no-th/haskell-patches/hamlet_hack_TH.patch Normal file
View file

@ -0,0 +1,205 @@
From 0509d4383c328c20be61cf3e3bbc98a0a1161588 Mon Sep 17 00:00:00 2001
From: dummy <dummy@example.com>
Date: Thu, 16 Oct 2014 02:21:17 +0000
Subject: [PATCH] hack TH
---
Text/Hamlet.hs | 86 +++++++++++++++++-----------------------------------
Text/Hamlet/Parse.hs | 3 +-
2 files changed, 29 insertions(+), 60 deletions(-)
diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs
index 9500ecb..ec8471a 100644
--- a/Text/Hamlet.hs
+++ b/Text/Hamlet.hs
@@ -11,36 +11,36 @@
module Text.Hamlet
( -- * Plain HTML
Html
- , shamlet
- , shamletFile
- , xshamlet
- , xshamletFile
+ --, shamlet
+ --, shamletFile
+ --, xshamlet
+ --, xshamletFile
-- * Hamlet
, HtmlUrl
- , hamlet
- , hamletFile
- , hamletFileReload
- , ihamletFileReload
- , xhamlet
- , xhamletFile
+ --, hamlet
+ --, hamletFile
+ --, hamletFileReload
+ --, ihamletFileReload
+ --, xhamlet
+ --, xhamletFile
-- * I18N Hamlet
, HtmlUrlI18n
- , ihamlet
- , ihamletFile
+ --, ihamlet
+ --, ihamletFile
-- * Type classes
, ToAttributes (..)
-- * Internal, for making more
, HamletSettings (..)
, NewlineStyle (..)
- , hamletWithSettings
- , hamletFileWithSettings
+ --, hamletWithSettings
+ --, hamletFileWithSettings
, defaultHamletSettings
, xhtmlHamletSettings
- , Env (..)
- , HamletRules (..)
- , hamletRules
- , ihamletRules
- , htmlRules
+ --, Env (..)
+ --, HamletRules (..)
+ --, hamletRules
+ --, ihamletRules
+ --, htmlRules
, CloseStyle (..)
-- * Used by generated code
, condH
@@ -110,47 +110,9 @@ type HtmlUrl url = Render url -> Html
-- | A function generating an 'Html' given a message translator and a URL rendering function.
type HtmlUrlI18n msg url = Translate msg -> Render url -> Html
-docsToExp :: Env -> HamletRules -> Scope -> [Doc] -> Q Exp
-docsToExp env hr scope docs = do
- exps <- mapM (docToExp env hr scope) docs
- case exps of
- [] -> [|return ()|]
- [x] -> return x
- _ -> return $ DoE $ map NoBindS exps
-
unIdent :: Ident -> String
unIdent (Ident s) = s
-bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)])
-bindingPattern (BindAs i@(Ident s) b) = do
- name <- newName s
- (pattern, scope) <- bindingPattern b
- return (AsP name pattern, (i, VarE name):scope)
-bindingPattern (BindVar i@(Ident s))
- | all isDigit s = do
- return (LitP $ IntegerL $ read s, [])
- | otherwise = do
- name <- newName s
- return (VarP name, [(i, VarE name)])
-bindingPattern (BindTuple is) = do
- (patterns, scopes) <- fmap unzip $ mapM bindingPattern is
- return (TupP patterns, concat scopes)
-bindingPattern (BindList is) = do
- (patterns, scopes) <- fmap unzip $ mapM bindingPattern is
- return (ListP patterns, concat scopes)
-bindingPattern (BindConstr con is) = do
- (patterns, scopes) <- fmap unzip $ mapM bindingPattern is
- return (ConP (mkConName con) patterns, concat scopes)
-bindingPattern (BindRecord con fields wild) = do
- let f (Ident field,b) =
- do (p,s) <- bindingPattern b
- return ((mkName field,p),s)
- (patterns, scopes) <- fmap unzip $ mapM f fields
- (patterns1, scopes1) <- if wild
- then bindWildFields con $ map fst fields
- else return ([],[])
- return (RecP (mkConName con) (patterns++patterns1), concat scopes ++ scopes1)
-
mkConName :: DataConstr -> Name
mkConName = mkName . conToStr
@@ -158,6 +120,7 @@ conToStr :: DataConstr -> String
conToStr (DCUnqualified (Ident x)) = x
conToStr (DCQualified (Module xs) (Ident x)) = intercalate "." $ xs ++ [x]
+{-
-- Wildcards bind all of the unbound fields to variables whose name
-- matches the field name.
--
@@ -296,10 +259,12 @@ hamlet = hamletWithSettings hamletRules defaultHamletSettings
xhamlet :: QuasiQuoter
xhamlet = hamletWithSettings hamletRules xhtmlHamletSettings
+-}
asHtmlUrl :: HtmlUrl url -> HtmlUrl url
asHtmlUrl = id
+{-
hamletRules :: Q HamletRules
hamletRules = do
i <- [|id|]
@@ -360,6 +325,7 @@ hamletFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp
hamletFromString qhr set s = do
hr <- qhr
hrWithEnv hr $ \env -> docsToExp env hr [] $ docFromString set s
+-}
docFromString :: HamletSettings -> String -> [Doc]
docFromString set s =
@@ -367,6 +333,7 @@ docFromString set s =
Error s' -> error s'
Ok (_, d) -> d
+{-
hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp
hamletFileWithSettings qhr set fp = do
#ifdef GHC_7_4
@@ -408,6 +375,7 @@ strToExp s@(c:_)
| isUpper c = ConE $ mkName s
| otherwise = VarE $ mkName s
strToExp "" = error "strToExp on empty string"
+-}
-- | Checks for truth in the left value in each pair in the first argument. If
-- a true exists, then the corresponding right action is performed. Only the
@@ -452,7 +420,7 @@ hamletUsedIdentifiers settings =
data HamletRuntimeRules = HamletRuntimeRules {
hrrI18n :: Bool
}
-
+{-
hamletFileReloadWithSettings :: HamletRuntimeRules
-> HamletSettings -> FilePath -> Q Exp
hamletFileReloadWithSettings hrr settings fp = do
@@ -479,7 +447,7 @@ hamletFileReloadWithSettings hrr settings fp = do
c VTUrlParam = [|EUrlParam|]
c VTMixin = [|\r -> EMixin $ \c -> r c|]
c VTMsg = [|EMsg|]
-
+-}
-- move to Shakespeare.Base?
readFileUtf8 :: FilePath -> IO String
readFileUtf8 fp = fmap TL.unpack $ readUtf8File fp
diff --git a/Text/Hamlet/Parse.hs b/Text/Hamlet/Parse.hs
index b7e2954..1f14946 100644
--- a/Text/Hamlet/Parse.hs
+++ b/Text/Hamlet/Parse.hs
@@ -616,6 +616,7 @@ data NewlineStyle = NoNewlines -- ^ never add newlines
| DefaultNewlineStyle
deriving Show
+{-
instance Lift NewlineStyle where
lift NoNewlines = [|NoNewlines|]
lift NewlinesText = [|NewlinesText|]
@@ -627,7 +628,7 @@ instance Lift (String -> CloseStyle) where
instance Lift HamletSettings where
lift (HamletSettings a b c d) = [|HamletSettings $(lift a) $(lift b) $(lift c) $(lift d)|]
-
+-}
htmlEmptyTags :: Set String
htmlEmptyTags = Set.fromAscList
--
2.1.1

52
standalone/no-th/haskell-patches/lens_no-TH.patch
View file

@ -1,20 +1,20 @@
From bc312c7431877b3b788de5e7ce5ee743be73c0ba Mon Sep 17 00:00:00 2001 From 10c9ade98b3ac2054947f411d77db2eb28896b9f Mon Sep 17 00:00:00 2001
From: dummy <dummy@example.com> From: dummy <dummy@example.com>
Date: Tue, 10 Jun 2014 22:13:58 +0000 Date: Thu, 16 Oct 2014 01:43:10 +0000
Subject: [PATCH] remove TH Subject: [PATCH] avoid TH
--- ---
lens.cabal | 19 +------------------ lens.cabal | 17 +----------------
src/Control/Lens.hs | 8 ++------ src/Control/Lens.hs | 8 ++------
src/Control/Lens/Cons.hs | 2 -- src/Control/Lens/Cons.hs | 2 --
src/Control/Lens/Internal/Fold.hs | 2 -- src/Control/Lens/Internal/Fold.hs | 2 --
src/Control/Lens/Operators.hs | 2 +- src/Control/Lens/Operators.hs | 2 +-
src/Control/Lens/Prism.hs | 2 -- src/Control/Lens/Prism.hs | 2 --
src/Control/Monad/Primitive/Lens.hs | 1 - src/Control/Monad/Primitive/Lens.hs | 1 -
7 files changed, 4 insertions(+), 32 deletions(-) 7 files changed, 4 insertions(+), 30 deletions(-)
diff --git a/lens.cabal b/lens.cabal diff --git a/lens.cabal b/lens.cabal
index d70c2f4..28af768 100644 index 5388301..d7b02b9 100644
--- a/lens.cabal --- a/lens.cabal
+++ b/lens.cabal +++ b/lens.cabal
@@ -10,7 +10,7 @@ stability: provisional @@ -10,7 +10,7 @@ stability: provisional
@ -26,7 +26,7 @@ index d70c2f4..28af768 100644
-- build-tools: cpphs -- build-tools: cpphs
tested-with: GHC == 7.4.1, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.1, GHC == 7.8.2 tested-with: GHC == 7.4.1, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.1, GHC == 7.8.2
synopsis: Lenses, Folds and Traversals synopsis: Lenses, Folds and Traversals
@@ -220,7 +220,6 @@ library @@ -217,7 +217,6 @@ library
Control.Exception.Lens Control.Exception.Lens
Control.Lens Control.Lens
Control.Lens.Action Control.Lens.Action
@ -34,7 +34,16 @@ index d70c2f4..28af768 100644
Control.Lens.Combinators Control.Lens.Combinators
Control.Lens.Cons Control.Lens.Cons
Control.Lens.Each Control.Lens.Each
@@ -248,29 +247,24 @@ library @@ -234,8 +233,6 @@ library
Control.Lens.Internal.Context
Control.Lens.Internal.Deque
Control.Lens.Internal.Exception
- Control.Lens.Internal.FieldTH
- Control.Lens.Internal.PrismTH
Control.Lens.Internal.Fold
Control.Lens.Internal.Getter
Control.Lens.Internal.Indexed
@@ -247,25 +244,21 @@ library
Control.Lens.Internal.Reflection Control.Lens.Internal.Reflection
Control.Lens.Internal.Review Control.Lens.Internal.Review
Control.Lens.Internal.Setter Control.Lens.Internal.Setter
@ -60,11 +69,7 @@ index d70c2f4..28af768 100644
Control.Monad.Primitive.Lens Control.Monad.Primitive.Lens
Control.Parallel.Strategies.Lens Control.Parallel.Strategies.Lens
Control.Seq.Lens Control.Seq.Lens
- Data.Aeson.Lens @@ -291,12 +284,8 @@ library
Data.Array.Lens
Data.Bits.Lens
Data.ByteString.Lens
@@ -293,17 +287,10 @@ library
Data.Typeable.Lens Data.Typeable.Lens
Data.Vector.Lens Data.Vector.Lens
Data.Vector.Generic.Lens Data.Vector.Generic.Lens
@ -76,13 +81,8 @@ index d70c2f4..28af768 100644
- Language.Haskell.TH.Lens - Language.Haskell.TH.Lens
Numeric.Lens Numeric.Lens
- other-modules: other-modules:
- Control.Lens.Internal.TupleIxedTH @@ -403,7 +392,6 @@ test-suite doctests
-
cpp-options: -traditional
if flag(safe)
@@ -405,7 +392,6 @@ test-suite doctests
deepseq, deepseq,
doctest >= 0.9.1, doctest >= 0.9.1,
filepath, filepath,
@ -90,7 +90,7 @@ index d70c2f4..28af768 100644
mtl, mtl,
nats, nats,
parallel, parallel,
@@ -443,7 +429,6 @@ benchmark plated @@ -441,7 +429,6 @@ benchmark plated
comonad, comonad,
criterion, criterion,
deepseq, deepseq,
@ -98,7 +98,7 @@ index d70c2f4..28af768 100644
lens, lens,
transformers transformers
@@ -478,7 +463,6 @@ benchmark unsafe @@ -476,7 +463,6 @@ benchmark unsafe
comonads-fd, comonads-fd,
criterion, criterion,
deepseq, deepseq,
@ -106,7 +106,7 @@ index d70c2f4..28af768 100644
lens, lens,
transformers transformers
@@ -495,6 +479,5 @@ benchmark zipper @@ -493,6 +479,5 @@ benchmark zipper
comonads-fd, comonads-fd,
criterion, criterion,
deepseq, deepseq,
@ -201,10 +201,10 @@ index 9992e63..631e8e6 100644
, ( # ) , ( # )
-- * "Control.Lens.Setter" -- * "Control.Lens.Setter"
diff --git a/src/Control/Lens/Prism.hs b/src/Control/Lens/Prism.hs diff --git a/src/Control/Lens/Prism.hs b/src/Control/Lens/Prism.hs
index 9e0bec7..0cf6737 100644 index b75c870..c6c6596 100644
--- a/src/Control/Lens/Prism.hs --- a/src/Control/Lens/Prism.hs
+++ b/src/Control/Lens/Prism.hs +++ b/src/Control/Lens/Prism.hs
@@ -59,8 +59,6 @@ import Unsafe.Coerce @@ -61,8 +61,6 @@ import Unsafe.Coerce
import Data.Profunctor.Unsafe import Data.Profunctor.Unsafe
#endif #endif
@ -226,5 +226,5 @@ index ee942c6..2f37134 100644
prim :: (PrimMonad m) => Iso' (m a) (State# (PrimState m) -> (# State# (PrimState m), a #)) prim :: (PrimMonad m) => Iso' (m a) (State# (PrimState m) -> (# State# (PrimState m), a #))
prim = iso internal primitive prim = iso internal primitive
-- --
2.0.0 2.1.1

20
standalone/no-th/haskell-patches/persistent-template_stub-out.patch
View file

@ -1,25 +1,25 @@
From 97e13262aa53cd3cc4f3997ac9156007ca1b9ce0 Mon Sep 17 00:00:00 2001 From e6542197f1da6984bb6cd3310dba77363dfab2d9 Mon Sep 17 00:00:00 2001
From: dummy <dummy@example.com> From: dummy <dummy@example.com>
Date: Tue, 14 Oct 2014 02:18:08 +0000 Date: Thu, 16 Oct 2014 01:51:02 +0000
Subject: [PATCH] unused Subject: [PATCH] stub out
--- ---
persistent-template.cabal | 2 +- persistent-template.cabal | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-) 1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/persistent-template.cabal b/persistent-template.cabal diff --git a/persistent-template.cabal b/persistent-template.cabal
index e247f6b..68184af 100644 index 59b4149..e11b418 100644
--- a/persistent-template.cabal --- a/persistent-template.cabal
+++ b/persistent-template.cabal +++ b/persistent-template.cabal
@@ -29,7 +29,7 @@ library @@ -26,7 +26,7 @@ library
, tagged , aeson
, path-pieces , monad-logger
, ghc-prim , unordered-containers
- exposed-modules: Database.Persist.TH - exposed-modules: Database.Persist.TH
+ exposed-modules: + exposed-modules:
ghc-options: -Wall ghc-options: -Wall
if impl(ghc >= 7.4) if impl(ghc >= 7.4)
cpp-options: -DGHC_7_4 cpp-options: -DGHC_7_4
-- --
1.7.10.4 2.1.1

366
standalone/no-th/haskell-patches/shakespeare-css_remove_TH.patch Normal file
View file

@ -0,0 +1,366 @@
From 657fa7135bbcf3d5adb3cc0032e09887dd80a2a7 Mon Sep 17 00:00:00 2001
From: dummy <dummy@example.com>
Date: Thu, 16 Oct 2014 02:05:14 +0000
Subject: [PATCH] hack TH
---
Text/Cassius.hs | 23 --------
Text/Css.hs | 151 --------------------------------------------------
Text/CssCommon.hs | 4 --
Text/Lucius.hs | 46 +--------------
shakespeare-css.cabal | 2 +-
5 files changed, 3 insertions(+), 223 deletions(-)
diff --git a/Text/Cassius.hs b/Text/Cassius.hs
index 91fc90f..c515807 100644
--- a/Text/Cassius.hs
+++ b/Text/Cassius.hs
@@ -13,10 +13,6 @@ module Text.Cassius
, renderCss
, renderCssUrl
-- * Parsing
- , cassius
- , cassiusFile
- , cassiusFileDebug
- , cassiusFileReload
-- * ToCss instances
-- ** Color
, Color (..)
@@ -27,11 +23,8 @@ module Text.Cassius
, AbsoluteUnit (..)
, AbsoluteSize (..)
, absoluteSize
- , EmSize (..)
- , ExSize (..)
, PercentageSize (..)
, percentageSize
- , PixelSize (..)
-- * Internal
, cassiusUsedIdentifiers
) where
@@ -43,25 +36,9 @@ import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Language.Haskell.TH.Syntax
import qualified Data.Text.Lazy as TL
import Text.CssCommon
-import Text.Lucius (lucius)
import qualified Text.Lucius
import Text.IndentToBrace (i2b)
-cassius :: QuasiQuoter
-cassius = QuasiQuoter { quoteExp = quoteExp lucius . i2b }
-
-cassiusFile :: FilePath -> Q Exp
-cassiusFile fp = do
-#ifdef GHC_7_4
- qAddDependentFile fp
-#endif
- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
- quoteExp cassius contents
-
-cassiusFileDebug, cassiusFileReload :: FilePath -> Q Exp
-cassiusFileDebug = cssFileDebug True [|Text.Lucius.parseTopLevels|] Text.Lucius.parseTopLevels
-cassiusFileReload = cassiusFileDebug
-
-- | Determine which identifiers are used by the given template, useful for
-- creating systems like yesod devel.
cassiusUsedIdentifiers :: String -> [(Deref, VarType)]
diff --git a/Text/Css.hs b/Text/Css.hs
index 75dc549..20c206c 100644
--- a/Text/Css.hs
+++ b/Text/Css.hs
@@ -166,22 +166,6 @@ cssUsedIdentifiers toi2b parseBlocks s' =
(scope, rest') = go rest
go' (Attr k v) = k ++ v
-cssFileDebug :: Bool -- ^ perform the indent-to-brace conversion
- -> Q Exp
- -> Parser [TopLevel Unresolved]
- -> FilePath
- -> Q Exp
-cssFileDebug toi2b parseBlocks' parseBlocks fp = do
- s <- fmap TL.unpack $ qRunIO $ readUtf8File fp
-#ifdef GHC_7_4
- qAddDependentFile fp
-#endif
- let vs = cssUsedIdentifiers toi2b parseBlocks s
- c <- mapM vtToExp vs
- cr <- [|cssRuntime toi2b|]
- parseBlocks'' <- parseBlocks'
- return $ cr `AppE` parseBlocks'' `AppE` (LitE $ StringL fp) `AppE` ListE c
-
combineSelectors :: HasLeadingSpace
-> [Contents]
-> [Contents]
@@ -287,18 +271,6 @@ cssRuntime toi2b parseBlocks fp cd render' = unsafePerformIO $ do
addScope scope = map (DerefIdent . Ident *** CDPlain . fromString) scope ++ cd
-vtToExp :: (Deref, VarType) -> Q Exp
-vtToExp (d, vt) = do
- d' <- lift d
- c' <- c vt
- return $ TupE [d', c' `AppE` derefToExp [] d]
- where
- c :: VarType -> Q Exp
- c VTPlain = [|CDPlain . toCss|]
- c VTUrl = [|CDUrl|]
- c VTUrlParam = [|CDUrlParam|]
- c VTMixin = [|CDMixin|]
-
getVars :: Monad m => [(String, String)] -> Content -> m [(Deref, VarType)]
getVars _ ContentRaw{} = return []
getVars scope (ContentVar d) =
@@ -342,111 +314,8 @@ compressBlock (Block x y blocks mixins) =
cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c
cc (a:b) = a : cc b
-blockToMixin :: Name
- -> Scope
- -> Block Unresolved
- -> Q Exp
-blockToMixin r scope (Block _sel props subblocks mixins) =
- [|Mixin
- { mixinAttrs = concat
- $ $(listE $ map go props)
- : map mixinAttrs $mixinsE
- -- FIXME too many complications to implement sublocks for now...
- , mixinBlocks = [] -- foldr (.) id $(listE $ map subGo subblocks) []
- }|]
- {-
- . foldr (.) id $(listE $ map subGo subblocks)
- . (concatMap mixinBlocks $mixinsE ++)
- |]
- -}
- where
- mixinsE = return $ ListE $ map (derefToExp []) mixins
- go (Attr x y) = conE 'Attr
- `appE` (contentsToBuilder r scope x)
- `appE` (contentsToBuilder r scope y)
- subGo (Block sel' b c d) = blockToCss r scope $ Block sel' b c d
-
-blockToCss :: Name
- -> Scope
- -> Block Unresolved
- -> Q Exp
-blockToCss r scope (Block sel props subblocks mixins) =
- [|((Block
- { blockSelector = $(selectorToBuilder r scope sel)
- , blockAttrs = concat
- $ $(listE $ map go props)
- : map mixinAttrs $mixinsE
- , blockBlocks = ()
- , blockMixins = ()
- } :: Block Resolved):)
- . foldr (.) id $(listE $ map subGo subblocks)
- . (concatMap mixinBlocks $mixinsE ++)
- |]
- where
- mixinsE = return $ ListE $ map (derefToExp []) mixins
- go (Attr x y) = conE 'Attr
- `appE` (contentsToBuilder r scope x)
- `appE` (contentsToBuilder r scope y)
- subGo (hls, Block sel' b c d) =
- blockToCss r scope $ Block sel'' b c d
- where
- sel'' = combineSelectors hls sel sel'
-
-selectorToBuilder :: Name -> Scope -> [Contents] -> Q Exp
-selectorToBuilder r scope sels =
- contentsToBuilder r scope $ intercalate [ContentRaw ","] sels
-
-contentsToBuilder :: Name -> Scope -> [Content] -> Q Exp
-contentsToBuilder r scope contents =
- appE [|mconcat|] $ listE $ map (contentToBuilder r scope) contents
-
-contentToBuilder :: Name -> Scope -> Content -> Q Exp
-contentToBuilder _ _ (ContentRaw x) =
- [|fromText . pack|] `appE` litE (StringL x)
-contentToBuilder _ scope (ContentVar d) =
- case d of
- DerefIdent (Ident s)
- | Just val <- lookup s scope -> [|fromText . pack|] `appE` litE (StringL val)
- _ -> [|toCss|] `appE` return (derefToExp [] d)
-contentToBuilder r _ (ContentUrl u) =
- [|fromText|] `appE`
- (varE r `appE` return (derefToExp [] u) `appE` listE [])
-contentToBuilder r _ (ContentUrlParam u) =
- [|fromText|] `appE`
- ([|uncurry|] `appE` varE r `appE` return (derefToExp [] u))
-contentToBuilder _ _ ContentMixin{} = error "contentToBuilder on ContentMixin"
-
type Scope = [(String, String)]
-topLevelsToCassius :: [TopLevel Unresolved]
- -> Q Exp
-topLevelsToCassius a = do
- r <- newName "_render"
- lamE [varP r] $ appE [|CssNoWhitespace . foldr ($) []|] $ fmap ListE $ go r [] a
- where
- go _ _ [] = return []
- go r scope (TopBlock b:rest) = do
- e <- [|(++) $ map TopBlock ($(blockToCss r scope b) [])|]
- es <- go r scope rest
- return $ e : es
- go r scope (TopAtBlock name s b:rest) = do
- let s' = contentsToBuilder r scope s
- e <- [|(:) $ TopAtBlock $(lift name) $(s') $(blocksToCassius r scope b)|]
- es <- go r scope rest
- return $ e : es
- go r scope (TopAtDecl dec cs:rest) = do
- e <- [|(:) $ TopAtDecl $(lift dec) $(contentsToBuilder r scope cs)|]
- es <- go r scope rest
- return $ e : es
- go r scope (TopVar k v:rest) = go r ((k, v) : scope) rest
-
-blocksToCassius :: Name
- -> Scope
- -> [Block Unresolved]
- -> Q Exp
-blocksToCassius r scope a = do
- appE [|foldr ($) []|] $ listE $ map (blockToCss r scope) a
-
renderCss :: Css -> TL.Text
renderCss css =
toLazyText $ mconcat $ map go tops
@@ -515,23 +384,3 @@ renderBlock haveWhiteSpace indent (Block sel attrs () ())
| haveWhiteSpace = fromString ";\n"
| otherwise = singleton ';'
-instance Lift Mixin where
- lift (Mixin a b) = [|Mixin a b|]
-instance Lift (Attr Unresolved) where
- lift (Attr k v) = [|Attr k v :: Attr Unresolved |]
-instance Lift (Attr Resolved) where
- lift (Attr k v) = [|Attr $(liftBuilder k) $(liftBuilder v) :: Attr Resolved |]
-
-liftBuilder :: Builder -> Q Exp
-liftBuilder b = [|fromText $ pack $(lift $ TL.unpack $ toLazyText b)|]
-
-instance Lift Content where
- lift (ContentRaw s) = [|ContentRaw s|]
- lift (ContentVar d) = [|ContentVar d|]
- lift (ContentUrl d) = [|ContentUrl d|]
- lift (ContentUrlParam d) = [|ContentUrlParam d|]
- lift (ContentMixin m) = [|ContentMixin m|]
-instance Lift (Block Unresolved) where
- lift (Block a b c d) = [|Block a b c d|]
-instance Lift (Block Resolved) where
- lift (Block a b () ()) = [|Block $(liftBuilder a) b () ()|]
diff --git a/Text/CssCommon.hs b/Text/CssCommon.hs
index 719e0a8..8c40e8c 100644
--- a/Text/CssCommon.hs
+++ b/Text/CssCommon.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}
@@ -156,6 +155,3 @@ showSize :: Rational -> String -> String
showSize value' unit = printf "%f" value ++ unit
where value = fromRational value' :: Double
-mkSizeType "EmSize" "em"
-mkSizeType "ExSize" "ex"
-mkSizeType "PixelSize" "px"
diff --git a/Text/Lucius.hs b/Text/Lucius.hs
index 346883d..f38492b 100644
--- a/Text/Lucius.hs
+++ b/Text/Lucius.hs
@@ -8,13 +8,9 @@
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
module Text.Lucius
( -- * Parsing
- lucius
- , luciusFile
- , luciusFileDebug
- , luciusFileReload
-- ** Mixins
- , luciusMixin
- , Mixin
+ -- luciusMixin
+ Mixin
-- ** Runtime
, luciusRT
, luciusRT'
@@ -40,11 +36,8 @@ module Text.Lucius
, AbsoluteUnit (..)
, AbsoluteSize (..)
, absoluteSize
- , EmSize (..)
- , ExSize (..)
, PercentageSize (..)
, percentageSize
- , PixelSize (..)
-- * Internal
, parseTopLevels
, luciusUsedIdentifiers
@@ -67,18 +60,6 @@ import Data.List (isSuffixOf)
import Control.Arrow (second)
import Text.Shakespeare (VarType)
--- |
---
--- >>> renderCss ([lucius|foo{bar:baz}|] undefined)
--- "foo{bar:baz}"
-lucius :: QuasiQuoter
-lucius = QuasiQuoter { quoteExp = luciusFromString }
-
-luciusFromString :: String -> Q Exp
-luciusFromString s =
- topLevelsToCassius
- $ either (error . show) id $ parse parseTopLevels s s
-
whiteSpace :: Parser ()
whiteSpace = many whiteSpace1 >> return ()
@@ -218,17 +199,6 @@ parseComment = do
_ <- manyTill anyChar $ try $ string "*/"
return $ ContentRaw ""
-luciusFile :: FilePath -> Q Exp
-luciusFile fp = do
-#ifdef GHC_7_4
- qAddDependentFile fp
-#endif
- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
- luciusFromString contents
-
-luciusFileDebug, luciusFileReload :: FilePath -> Q Exp
-luciusFileDebug = cssFileDebug False [|parseTopLevels|] parseTopLevels
-luciusFileReload = luciusFileDebug
parseTopLevels :: Parser [TopLevel Unresolved]
parseTopLevels =
@@ -377,15 +347,3 @@ luciusRTMinified tl scope = either Left (Right . renderCss . CssNoWhitespace) $
-- creating systems like yesod devel.
luciusUsedIdentifiers :: String -> [(Deref, VarType)]
luciusUsedIdentifiers = cssUsedIdentifiers False parseTopLevels
-
-luciusMixin :: QuasiQuoter
-luciusMixin = QuasiQuoter { quoteExp = luciusMixinFromString }
-
-luciusMixinFromString :: String -> Q Exp
-luciusMixinFromString s' = do
- r <- newName "_render"
- case fmap compressBlock $ parse parseBlock s s of
- Left e -> error $ show e
- Right block -> blockToMixin r [] block
- where
- s = concat ["mixin{", s', "}"]
diff --git a/shakespeare-css.cabal b/shakespeare-css.cabal
index 2d3b25a..cc0553c 100644
--- a/shakespeare-css.cabal
+++ b/shakespeare-css.cabal
@@ -35,8 +35,8 @@ library
exposed-modules: Text.Cassius
Text.Lucius
- other-modules: Text.MkSizeType
Text.Css
+ other-modules: Text.MkSizeType
Text.IndentToBrace
Text.CssCommon
ghc-options: -Wall
--
2.1.1

316
standalone/no-th/haskell-patches/shakespeare-js_hack_TH.patch Normal file
View file

@ -0,0 +1,316 @@
From 26f7328b0123d3ffa66873b91189ba3bdae3356c Mon Sep 17 00:00:00 2001
From: dummy <dummy@example.com>
Date: Thu, 16 Oct 2014 02:07:32 +0000
Subject: [PATCH] hack TH
---
Text/Coffee.hs | 56 ++++-----------------------------------------
Text/Julius.hs | 67 +++++++++---------------------------------------------
Text/Roy.hs | 51 ++++-------------------------------------
Text/TypeScript.hs | 51 ++++-------------------------------------
4 files changed, 24 insertions(+), 201 deletions(-)
diff --git a/Text/Coffee.hs b/Text/Coffee.hs
index 488c81b..61db85b 100644
--- a/Text/Coffee.hs
+++ b/Text/Coffee.hs
@@ -51,13 +51,13 @@ module Text.Coffee
-- ** Template-Reading Functions
-- | These QuasiQuoter and Template Haskell methods return values of
-- type @'JavascriptUrl' url@. See the Yesod book for details.
- coffee
- , coffeeFile
- , coffeeFileReload
- , coffeeFileDebug
+ -- coffee
+ --, coffeeFile
+ --, coffeeFileReload
+ --, coffeeFileDebug
#ifdef TEST_EXPORT
- , coffeeSettings
+ --, coffeeSettings
#endif
) where
@@ -65,49 +65,3 @@ import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Language.Haskell.TH.Syntax
import Text.Shakespeare
import Text.Julius
-
-coffeeSettings :: Q ShakespeareSettings
-coffeeSettings = do
- jsettings <- javascriptSettings
- return $ jsettings { varChar = '%'
- , preConversion = Just PreConvert {
- preConvert = ReadProcess "coffee" ["-spb"]
- , preEscapeIgnoreBalanced = "'\"`" -- don't insert backtacks for variable already inside strings or backticks.
- , preEscapeIgnoreLine = "#" -- ignore commented lines
- , wrapInsertion = Just WrapInsertion {
- wrapInsertionIndent = Just " "
- , wrapInsertionStartBegin = "("
- , wrapInsertionSeparator = ", "
- , wrapInsertionStartClose = ") =>"
- , wrapInsertionEnd = ""
- , wrapInsertionAddParens = False
- }
- }
- }
-
--- | Read inline, quasiquoted CoffeeScript.
-coffee :: QuasiQuoter
-coffee = QuasiQuoter { quoteExp = \s -> do
- rs <- coffeeSettings
- quoteExp (shakespeare rs) s
- }
-
--- | Read in a CoffeeScript template file. This function reads the file once, at
--- compile time.
-coffeeFile :: FilePath -> Q Exp
-coffeeFile fp = do
- rs <- coffeeSettings
- shakespeareFile rs fp
-
--- | Read in a CoffeeScript template file. This impure function uses
--- unsafePerformIO to re-read the file on every call, allowing for rapid
--- iteration.
-coffeeFileReload :: FilePath -> Q Exp
-coffeeFileReload fp = do
- rs <- coffeeSettings
- shakespeareFileReload rs fp
-
--- | Deprecated synonym for 'coffeeFileReload'
-coffeeFileDebug :: FilePath -> Q Exp
-coffeeFileDebug = coffeeFileReload
-{-# DEPRECATED coffeeFileDebug "Please use coffeeFileReload instead." #-}
diff --git a/Text/Julius.hs b/Text/Julius.hs
index ec30690..5b5a075 100644
--- a/Text/Julius.hs
+++ b/Text/Julius.hs
@@ -14,17 +14,17 @@ module Text.Julius
-- ** Template-Reading Functions
-- | These QuasiQuoter and Template Haskell methods return values of
-- type @'JavascriptUrl' url@. See the Yesod book for details.
- js
- , julius
- , juliusFile
- , jsFile
- , juliusFileDebug
- , jsFileDebug
- , juliusFileReload
- , jsFileReload
+ -- js
+ -- julius
+ -- juliusFile
+ -- jsFile
+ --, juliusFileDebug
+ --, jsFileDebug
+ --, juliusFileReload
+ --, jsFileReload
-- * Datatypes
- , JavascriptUrl
+ JavascriptUrl
, Javascript (..)
, RawJavascript (..)
@@ -37,9 +37,9 @@ module Text.Julius
, renderJavascriptUrl
-- ** internal, used by 'Text.Coffee'
- , javascriptSettings
+ --, javascriptSettings
-- ** internal
- , juliusUsedIdentifiers
+ --, juliusUsedIdentifiers
, asJavascriptUrl
) where
@@ -102,48 +102,3 @@ instance RawJS TL.Text where rawJS = RawJavascript . fromLazyText
instance RawJS Builder where rawJS = RawJavascript
instance RawJS Bool where rawJS = RawJavascript . unJavascript . toJavascript
-javascriptSettings :: Q ShakespeareSettings
-javascriptSettings = do
- toJExp <- [|toJavascript|]
- wrapExp <- [|Javascript|]
- unWrapExp <- [|unJavascript|]
- asJavascriptUrl' <- [|asJavascriptUrl|]
- return $ defaultShakespeareSettings { toBuilder = toJExp
- , wrap = wrapExp
- , unwrap = unWrapExp
- , modifyFinalValue = Just asJavascriptUrl'
- }
-
-js, julius :: QuasiQuoter
-js = QuasiQuoter { quoteExp = \s -> do
- rs <- javascriptSettings
- quoteExp (shakespeare rs) s
- }
-
-julius = js
-
-jsFile, juliusFile :: FilePath -> Q Exp
-jsFile fp = do
- rs <- javascriptSettings
- shakespeareFile rs fp
-
-juliusFile = jsFile
-
-
-jsFileReload, juliusFileReload :: FilePath -> Q Exp
-jsFileReload fp = do
- rs <- javascriptSettings
- shakespeareFileReload rs fp
-
-juliusFileReload = jsFileReload
-
-jsFileDebug, juliusFileDebug :: FilePath -> Q Exp
-juliusFileDebug = jsFileReload
-{-# DEPRECATED juliusFileDebug "Please use juliusFileReload instead." #-}
-jsFileDebug = jsFileReload
-{-# DEPRECATED jsFileDebug "Please use jsFileReload instead." #-}
-
--- | Determine which identifiers are used by the given template, useful for
--- creating systems like yesod devel.
-juliusUsedIdentifiers :: String -> [(Deref, VarType)]
-juliusUsedIdentifiers = shakespeareUsedIdentifiers defaultShakespeareSettings
diff --git a/Text/Roy.hs b/Text/Roy.hs
index 6e5e246..9ab0dbc 100644
--- a/Text/Roy.hs
+++ b/Text/Roy.hs
@@ -39,12 +39,12 @@ module Text.Roy
-- ** Template-Reading Functions
-- | These QuasiQuoter and Template Haskell methods return values of
-- type @'JavascriptUrl' url@. See the Yesod book for details.
- roy
- , royFile
- , royFileReload
+ -- roy
+ --, royFile
+ --, royFileReload
#ifdef TEST_EXPORT
- , roySettings
+ --, roySettings
#endif
) where
@@ -53,46 +53,3 @@ import Language.Haskell.TH.Syntax
import Text.Shakespeare
import Text.Julius
--- | The Roy language compiles down to Javascript.
--- We do this compilation once at compile time to avoid needing to do it during the request.
--- We call this a preConversion because other shakespeare modules like Lucius use Haskell to compile during the request instead rather than a system call.
-roySettings :: Q ShakespeareSettings
-roySettings = do
- jsettings <- javascriptSettings
- return $ jsettings { varChar = '#'
- , preConversion = Just PreConvert {
- preConvert = ReadProcess "roy" ["--stdio", "--browser"]
- , preEscapeIgnoreBalanced = "'\""
- , preEscapeIgnoreLine = "//"
- , wrapInsertion = Just WrapInsertion {
- wrapInsertionIndent = Just " "
- , wrapInsertionStartBegin = "(\\"
- , wrapInsertionSeparator = " "
- , wrapInsertionStartClose = " ->\n"
- , wrapInsertionEnd = ")"
- , wrapInsertionAddParens = True
- }
- }
- }
-
--- | Read inline, quasiquoted Roy.
-roy :: QuasiQuoter
-roy = QuasiQuoter { quoteExp = \s -> do
- rs <- roySettings
- quoteExp (shakespeare rs) s
- }
-
--- | Read in a Roy template file. This function reads the file once, at
--- compile time.
-royFile :: FilePath -> Q Exp
-royFile fp = do
- rs <- roySettings
- shakespeareFile rs fp
-
--- | Read in a Roy template file. This impure function uses
--- unsafePerformIO to re-read the file on every call, allowing for rapid
--- iteration.
-royFileReload :: FilePath -> Q Exp
-royFileReload fp = do
- rs <- roySettings
- shakespeareFileReload rs fp
diff --git a/Text/TypeScript.hs b/Text/TypeScript.hs
index 70c8820..5be994a 100644
--- a/Text/TypeScript.hs
+++ b/Text/TypeScript.hs
@@ -57,12 +57,12 @@ module Text.TypeScript
-- ** Template-Reading Functions
-- | These QuasiQuoter and Template Haskell methods return values of
-- type @'JavascriptUrl' url@. See the Yesod book for details.
- tsc
- , typeScriptFile
- , typeScriptFileReload
+ -- tsc
+ --, typeScriptFile
+ --, typeScriptFileReload
#ifdef TEST_EXPORT
- , typeScriptSettings
+ --, typeScriptSettings
#endif
) where
@@ -71,46 +71,3 @@ import Language.Haskell.TH.Syntax
import Text.Shakespeare
import Text.Julius
--- | The TypeScript language compiles down to Javascript.
--- We do this compilation once at compile time to avoid needing to do it during the request.
--- We call this a preConversion because other shakespeare modules like Lucius use Haskell to compile during the request instead rather than a system call.
-typeScriptSettings :: Q ShakespeareSettings
-typeScriptSettings = do
- jsettings <- javascriptSettings
- return $ jsettings { varChar = '#'
- , preConversion = Just PreConvert {
- preConvert = ReadProcess "sh" ["-c", "TMP_IN=$(mktemp XXXXXXXXXX.ts); TMP_OUT=$(mktemp XXXXXXXXXX.js); cat /dev/stdin > ${TMP_IN} && tsc --out ${TMP_OUT} ${TMP_IN} && cat ${TMP_OUT}; rm ${TMP_IN} && rm ${TMP_OUT}"]
- , preEscapeIgnoreBalanced = "'\""
- , preEscapeIgnoreLine = "//"
- , wrapInsertion = Just WrapInsertion {
- wrapInsertionIndent = Nothing
- , wrapInsertionStartBegin = ";(function("
- , wrapInsertionSeparator = ", "
- , wrapInsertionStartClose = "){"
- , wrapInsertionEnd = "})"
- , wrapInsertionAddParens = False
- }
- }
- }
-
--- | Read inline, quasiquoted TypeScript
-tsc :: QuasiQuoter
-tsc = QuasiQuoter { quoteExp = \s -> do
- rs <- typeScriptSettings
- quoteExp (shakespeare rs) s
- }
-
--- | Read in a TypeScript template file. This function reads the file once, at
--- compile time.
-typeScriptFile :: FilePath -> Q Exp
-typeScriptFile fp = do
- rs <- typeScriptSettings
- shakespeareFile rs fp
-
--- | Read in a Roy template file. This impure function uses
--- unsafePerformIO to re-read the file on every call, allowing for rapid
--- iteration.
-typeScriptFileReload :: FilePath -> Q Exp
-typeScriptFileReload fp = do
- rs <- typeScriptSettings
- shakespeareFileReload rs fp
--
2.1.1

1161
standalone/no-th/haskell-patches/shakespeare_remove-TH.patch
View file

File diff suppressed because it is too large Load diff

95
standalone/no-th/haskell-patches/yesod-core_expand_TH.patch
View file

@ -1,17 +1,17 @@
From e163ab104cf2f8d2bac07ab389caec49dfc39665 Mon Sep 17 00:00:00 2001 From f1feea61dcba0b16afed5ce8dd5d2433fe505461 Mon Sep 17 00:00:00 2001
From: dummy <dummy@example.com> From: dummy <dummy@example.com>
Date: Tue, 14 Oct 2014 02:49:19 +0000 Date: Thu, 16 Oct 2014 02:15:23 +0000
Subject: [PATCH] expand and remove TH Subject: [PATCH] hack TH
--- ---
Yesod/Core.hs | 30 +++--- Yesod/Core.hs | 30 +++---
Yesod/Core/Class/Yesod.hs | 256 +++++++++++++++++++++++++++++--------------- Yesod/Core/Class/Yesod.hs | 256 ++++++++++++++++++++++++++++++---------------
Yesod/Core/Dispatch.hs | 38 ++----- Yesod/Core/Dispatch.hs | 38 ++-----
Yesod/Core/Handler.hs | 25 ++--- Yesod/Core/Handler.hs | 25 ++---
Yesod/Core/Internal/Run.hs | 6 +- Yesod/Core/Internal/Run.hs | 6 +-
Yesod/Core/Internal/TH.hs | 111 ------------------- Yesod/Core/Internal/TH.hs | 111 --------------------
Yesod/Core/Types.hs | 3 +- Yesod/Core/Types.hs | 3 +-
Yesod/Core/Widget.hs | 32 +----- Yesod/Core/Widget.hs | 32 +-----
8 files changed, 213 insertions(+), 288 deletions(-) 8 files changed, 213 insertions(+), 288 deletions(-)
diff --git a/Yesod/Core.hs b/Yesod/Core.hs diff --git a/Yesod/Core.hs b/Yesod/Core.hs
@ -68,10 +68,10 @@ index 9b29317..7c0792d 100644
, renderCssUrl , renderCssUrl
) where ) where
diff --git a/Yesod/Core/Class/Yesod.hs b/Yesod/Core/Class/Yesod.hs diff --git a/Yesod/Core/Class/Yesod.hs b/Yesod/Core/Class/Yesod.hs
index 5dbaff2..edd98a5 100644 index 8631d27..c40eb10 100644
--- a/Yesod/Core/Class/Yesod.hs --- a/Yesod/Core/Class/Yesod.hs
+++ b/Yesod/Core/Class/Yesod.hs +++ b/Yesod/Core/Class/Yesod.hs
@@ -5,11 +5,15 @@ @@ -5,18 +5,22 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Yesod.Core.Class.Yesod where module Yesod.Core.Class.Yesod where
@ -88,16 +88,15 @@ index 5dbaff2..edd98a5 100644
import Blaze.ByteString.Builder (Builder) import Blaze.ByteString.Builder (Builder)
import Blaze.ByteString.Builder.Char.Utf8 (fromText) import Blaze.ByteString.Builder.Char.Utf8 (fromText)
@@ -17,7 +21,7 @@ import Control.Arrow ((***), second) import Control.Arrow ((***), second)
import Control.Exception (bracket)
import Control.Monad (forM, when, void) import Control.Monad (forM, when, void)
import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.IO.Class (MonadIO (liftIO))
-import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), -import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther),
+import Control.Monad.Logger (Loc, LogLevel (LevelInfo, LevelOther), +import Control.Monad.Logger (Loc, LogLevel (LevelInfo, LevelOther),
LogSource) LogSource)
import Control.Monad.Trans.Resource (InternalState, createInternalState, closeInternalState)
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
@@ -35,7 +39,6 @@ import qualified Data.Text.Encoding.Error as TEE import qualified Data.ByteString.Lazy as L
@@ -33,7 +37,6 @@ import qualified Data.Text.Encoding.Error as TEE
import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Word (Word64) import Data.Word (Word64)
@ -105,7 +104,7 @@ index 5dbaff2..edd98a5 100644
import Network.HTTP.Types (encodePath) import Network.HTTP.Types (encodePath)
import qualified Network.Wai as W import qualified Network.Wai as W
import Data.Default (def) import Data.Default (def)
@@ -87,18 +90,26 @@ class RenderRoute site => Yesod site where @@ -94,18 +97,26 @@ class RenderRoute site => Yesod site where
defaultLayout w = do defaultLayout w = do
p <- widgetToPageContent w p <- widgetToPageContent w
mmsg <- getMessage mmsg <- getMessage
@ -144,7 +143,7 @@ index 5dbaff2..edd98a5 100644
-- | Override the rendering function for a particular URL. One use case for -- | 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 -- this is to offload static hosting to a different domain name to avoid
@@ -373,45 +384,103 @@ widgetToPageContent w = do @@ -374,45 +385,103 @@ widgetToPageContent w = do
-- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing -- 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 -- 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 let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc
@ -287,7 +286,7 @@ index 5dbaff2..edd98a5 100644
return $ PageContent title headAll $ return $ PageContent title headAll $
case jsLoader master of case jsLoader master of
@@ -441,10 +510,13 @@ defaultErrorHandler NotFound = selectRep $ do @@ -442,10 +511,13 @@ defaultErrorHandler NotFound = selectRep $ do
r <- waiRequest r <- waiRequest
let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
setTitle "Not Found" setTitle "Not Found"
@ -305,7 +304,7 @@ index 5dbaff2..edd98a5 100644
provideRep $ return $ object ["message" .= ("Not Found" :: Text)] provideRep $ return $ object ["message" .= ("Not Found" :: Text)]
-- For API requests. -- For API requests.
@@ -454,10 +526,11 @@ defaultErrorHandler NotFound = selectRep $ do @@ -455,10 +527,11 @@ defaultErrorHandler NotFound = selectRep $ do
defaultErrorHandler NotAuthenticated = selectRep $ do defaultErrorHandler NotAuthenticated = selectRep $ do
provideRep $ defaultLayout $ do provideRep $ defaultLayout $ do
setTitle "Not logged in" setTitle "Not logged in"
@ -321,7 +320,7 @@ index 5dbaff2..edd98a5 100644
provideRep $ do provideRep $ do
-- 401 *MUST* include a WWW-Authenticate header -- 401 *MUST* include a WWW-Authenticate header
@@ -479,10 +552,13 @@ defaultErrorHandler NotAuthenticated = selectRep $ do @@ -480,10 +553,13 @@ defaultErrorHandler NotAuthenticated = selectRep $ do
defaultErrorHandler (PermissionDenied msg) = selectRep $ do defaultErrorHandler (PermissionDenied msg) = selectRep $ do
provideRep $ defaultLayout $ do provideRep $ defaultLayout $ do
setTitle "Permission Denied" setTitle "Permission Denied"
@ -339,7 +338,7 @@ index 5dbaff2..edd98a5 100644
provideRep $ provideRep $
return $ object $ [ return $ object $ [
"message" .= ("Permission Denied. " <> msg) "message" .= ("Permission Denied. " <> msg)
@@ -491,30 +567,42 @@ defaultErrorHandler (PermissionDenied msg) = selectRep $ do @@ -492,30 +568,42 @@ defaultErrorHandler (PermissionDenied msg) = selectRep $ do
defaultErrorHandler (InvalidArgs ia) = selectRep $ do defaultErrorHandler (InvalidArgs ia) = selectRep $ do
provideRep $ defaultLayout $ do provideRep $ defaultLayout $ do
setTitle "Invalid Arguments" setTitle "Invalid Arguments"
@ -397,7 +396,7 @@ index 5dbaff2..edd98a5 100644
provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m] provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m]
asyncHelper :: (url -> [x] -> Text) asyncHelper :: (url -> [x] -> Text)
@@ -653,8 +741,4 @@ loadClientSession key getCachedDate sessionName req = load @@ -682,8 +770,4 @@ loadClientSession key getCachedDate sessionName req = load
-- turn the TH Loc loaction information into a human readable string -- turn the TH Loc loaction information into a human readable string
-- leaving out the loc_end parameter -- leaving out the loc_end parameter
fileLocationToString :: Loc -> String fileLocationToString :: Loc -> String
@ -408,7 +407,7 @@ index 5dbaff2..edd98a5 100644
- char = show . snd . loc_start - char = show . snd . loc_start
+fileLocationToString loc = "unknown" +fileLocationToString loc = "unknown"
diff --git a/Yesod/Core/Dispatch.hs b/Yesod/Core/Dispatch.hs diff --git a/Yesod/Core/Dispatch.hs b/Yesod/Core/Dispatch.hs
index ad56452..d3d58ee 100644 index e0d1f0e..cc23fdd 100644
--- a/Yesod/Core/Dispatch.hs --- a/Yesod/Core/Dispatch.hs
+++ b/Yesod/Core/Dispatch.hs +++ b/Yesod/Core/Dispatch.hs
@@ -1,4 +1,3 @@ @@ -1,4 +1,3 @@
@ -445,7 +444,7 @@ index ad56452..d3d58ee 100644
, PathMultiPiece (..) , PathMultiPiece (..)
, Texts , Texts
-- * Convert to WAI -- * Convert to WAI
@@ -130,13 +129,6 @@ toWaiAppLogger logger site = do @@ -135,13 +134,6 @@ toWaiAppLogger logger site = do
, yreSite = site , yreSite = site
, yreSessionBackend = sb , yreSessionBackend = sb
} }
@ -459,10 +458,10 @@ index ad56452..d3d58ee 100644
middleware <- mkDefaultMiddlewares logger middleware <- mkDefaultMiddlewares logger
return $ middleware $ toWaiAppYre yre return $ middleware $ toWaiAppYre yre
@@ -156,14 +148,7 @@ warp port site = do @@ -170,14 +162,7 @@ warp port site = do
Network.Wai.Handler.Warp.setPort port $ ]
Network.Wai.Handler.Warp.setServerName serverValue $ -}
Network.Wai.Handler.Warp.setOnException (\_ e -> , Network.Wai.Handler.Warp.settingsOnException = const $ \e ->
- when (shouldLog' e) $ - when (shouldLog' e) $
- messageLoggerSource - messageLoggerSource
- site - site
@ -470,12 +469,12 @@ index ad56452..d3d58ee 100644
- $(qLocation >>= liftLoc) - $(qLocation >>= liftLoc)
- "yesod-core" - "yesod-core"
- LevelError - LevelError
- (toLogStr $ "Exception from Warp: " ++ show e)) $ - (toLogStr $ "Exception from Warp: " ++ show e)
+ when (shouldLog' e) $ error (show e)) $ + when (shouldLog' e) $ error (show e)
Network.Wai.Handler.Warp.defaultSettings) }
where where
shouldLog' = Network.Wai.Handler.Warp.defaultShouldDisplayException shouldLog' =
@@ -197,7 +182,6 @@ defaultMiddlewaresNoLogging = acceptOverride . autohead . gzip def . methodOverr @@ -211,7 +196,6 @@ defaultMiddlewaresNoLogging = acceptOverride . autohead . gzip def . methodOverr
-- | Deprecated synonym for 'warp'. -- | Deprecated synonym for 'warp'.
warpDebug :: YesodDispatch site => Int -> site -> IO () warpDebug :: YesodDispatch site => Int -> site -> IO ()
warpDebug = warp warpDebug = warp
@ -484,10 +483,10 @@ index ad56452..d3d58ee 100644
-- | Runs your application using default middlewares (i.e., via 'toWaiApp'). It -- | Runs your application using default middlewares (i.e., via 'toWaiApp'). It
-- reads port information from the PORT environment variable, as used by tools -- reads port information from the PORT environment variable, as used by tools
diff --git a/Yesod/Core/Handler.hs b/Yesod/Core/Handler.hs diff --git a/Yesod/Core/Handler.hs b/Yesod/Core/Handler.hs
index 36f8f5c..948de5f 100644 index d2b196b..13cac17 100644
--- a/Yesod/Core/Handler.hs --- a/Yesod/Core/Handler.hs
+++ b/Yesod/Core/Handler.hs +++ b/Yesod/Core/Handler.hs
@@ -171,7 +171,7 @@ import Data.Text.Encoding (decodeUtf8With, encodeUtf8) @@ -174,7 +174,7 @@ import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import qualified Text.Blaze.Html.Renderer.Text as RenderText import qualified Text.Blaze.Html.Renderer.Text as RenderText
@ -496,7 +495,7 @@ index 36f8f5c..948de5f 100644
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
@@ -199,6 +199,7 @@ import Control.Exception (throwIO) @@ -203,6 +203,7 @@ import Control.Exception (throwIO)
import Blaze.ByteString.Builder (Builder) import Blaze.ByteString.Builder (Builder)
import Safe (headMay) import Safe (headMay)
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
@ -504,7 +503,7 @@ index 36f8f5c..948de5f 100644
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
import Control.Monad (unless) import Control.Monad (unless)
import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO
@@ -803,19 +804,15 @@ redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url) @@ -855,19 +856,15 @@ redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
-> m a -> m a
redirectToPost url = do redirectToPost url = do
urlText <- toTextUrl url urlText <- toTextUrl url
@ -534,7 +533,7 @@ index 36f8f5c..948de5f 100644
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html
diff --git a/Yesod/Core/Internal/Run.hs b/Yesod/Core/Internal/Run.hs diff --git a/Yesod/Core/Internal/Run.hs b/Yesod/Core/Internal/Run.hs
index fdb2261..12ed4fc 100644 index 311f208..63f666f 100644
--- a/Yesod/Core/Internal/Run.hs --- a/Yesod/Core/Internal/Run.hs
+++ b/Yesod/Core/Internal/Run.hs +++ b/Yesod/Core/Internal/Run.hs
@@ -16,7 +16,7 @@ import Control.Exception.Lifted (catch) @@ -16,7 +16,7 @@ import Control.Exception.Lifted (catch)
@ -544,7 +543,7 @@ index fdb2261..12ed4fc 100644
-import Control.Monad.Logger (LogLevel (LevelError), LogSource, -import Control.Monad.Logger (LogLevel (LevelError), LogSource,
+import Control.Monad.Logger (Loc, LogLevel (LevelError), LogSource, +import Control.Monad.Logger (Loc, LogLevel (LevelError), LogSource,
liftLoc) liftLoc)
import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState) import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState, createInternalState, closeInternalState)
import qualified Data.ByteString as S import qualified Data.ByteString as S
@@ -31,7 +31,7 @@ import qualified Data.Text as T @@ -31,7 +31,7 @@ import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (encodeUtf8)
@ -554,8 +553,8 @@ index fdb2261..12ed4fc 100644
+import Language.Haskell.TH.Syntax (qLocation) +import Language.Haskell.TH.Syntax (qLocation)
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import Network.Wai import Network.Wai
import Network.Wai.Internal #if MIN_VERSION_wai(2, 0, 0)
@@ -157,8 +157,6 @@ safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) @@ -158,8 +158,6 @@ safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> ErrorResponse -> ErrorResponse
-> YesodApp -> YesodApp
safeEh log' er req = do safeEh log' er req = do
@ -684,18 +683,18 @@ index 7e84c1c..a273c29 100644
- ] - ]
- return $ LetE [fun] (VarE helper) - return $ LetE [fun] (VarE helper)
diff --git a/Yesod/Core/Types.hs b/Yesod/Core/Types.hs diff --git a/Yesod/Core/Types.hs b/Yesod/Core/Types.hs
index 4d4474b..61ddb20 100644 index 388dfe3..b3fce0f 100644
--- a/Yesod/Core/Types.hs --- a/Yesod/Core/Types.hs
+++ b/Yesod/Core/Types.hs +++ b/Yesod/Core/Types.hs
@@ -19,6 +19,7 @@ import Control.Monad.Base (MonadBase (liftBase)) @@ -21,6 +21,7 @@ import Control.Monad.Catch (MonadCatch (..))
import Control.Monad.Catch (MonadCatch (..))
import Control.Monad.Catch (MonadMask (..)) import Control.Monad.Catch (MonadMask (..))
#endif
import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.IO.Class (MonadIO (liftIO))
+import qualified Control.Monad.Logger +import qualified Control.Monad.Logger
import Control.Monad.Logger (LogLevel, LogSource, import Control.Monad.Logger (LogLevel, LogSource,
MonadLogger (..)) MonadLogger (..))
import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Control (MonadBaseControl (..))
@@ -174,7 +175,7 @@ data RunHandlerEnv site = RunHandlerEnv @@ -191,7 +192,7 @@ data RunHandlerEnv site = RunHandlerEnv
, rheRoute :: !(Maybe (Route site)) , rheRoute :: !(Maybe (Route site))
, rheSite :: !site , rheSite :: !site
, rheUpload :: !(RequestBodyLength -> FileUpload) , rheUpload :: !(RequestBodyLength -> FileUpload)
@ -765,5 +764,5 @@ index 481199e..8489fbe 100644
ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message) ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)
=> HtmlUrlI18n message (Route (HandlerSite m)) => HtmlUrlI18n message (Route (HandlerSite m))
-- --
1.7.10.4 2.1.1

183
standalone/no-th/haskell-patches/yesod-form_spliced-TH.patch
View file

@ -1,16 +1,16 @@
From 98077d391b930a4c1f69e3b8810409fd261eee34 Mon Sep 17 00:00:00 2001 From 1b24ece1a40c9365f719472ca6e342c8c4065c25 Mon Sep 17 00:00:00 2001
From: androidbuilder <androidbuilder@example.com> From: dummy <dummy@example.com>
Date: Tue, 14 Oct 2014 03:17:38 +0000 Date: Thu, 16 Oct 2014 02:31:20 +0000
Subject: [PATCH] expand and remove TH Subject: [PATCH] hack TH
--- ---
Yesod/Form/Bootstrap3.hs | 186 +++++++++-- Yesod/Form/Bootstrap3.hs | 186 +++++++++--
Yesod/Form/Fields.hs | 797 +++++++++++++++++++++++++++++++++++----------- Yesod/Form/Fields.hs | 816 +++++++++++++++++++++++++++++++++++------------
Yesod/Form/Functions.hs | 257 ++++++++++++--- Yesod/Form/Functions.hs | 257 ++++++++++++---
Yesod/Form/Jquery.hs | 134 ++++++-- Yesod/Form/Jquery.hs | 134 ++++++--
Yesod/Form/MassInput.hs | 226 ++++++++++--- Yesod/Form/MassInput.hs | 226 ++++++++++---
Yesod/Form/Nic.hs | 46 +-- Yesod/Form/Nic.hs | 67 +++-
6 files changed, 1279 insertions(+), 367 deletions(-) 6 files changed, 1322 insertions(+), 364 deletions(-)
diff --git a/Yesod/Form/Bootstrap3.hs b/Yesod/Form/Bootstrap3.hs diff --git a/Yesod/Form/Bootstrap3.hs b/Yesod/Form/Bootstrap3.hs
index 84e85fc..1954fb4 100644 index 84e85fc..1954fb4 100644
@ -229,7 +229,7 @@ index 84e85fc..1954fb4 100644
, fvTooltip = Nothing , fvTooltip = Nothing
, fvId = bootstrapSubmitId , fvId = bootstrapSubmitId
diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs
index 8173e78..68a284c 100644 index c6091a9..9e6bd4e 100644
--- a/Yesod/Form/Fields.hs --- a/Yesod/Form/Fields.hs
+++ b/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs
@@ -1,4 +1,3 @@ @@ -1,4 +1,3 @@
@ -279,7 +279,7 @@ index 8173e78..68a284c 100644
import qualified Blaze.ByteString.Builder.Html.Utf8 as B import qualified Blaze.ByteString.Builder.Html.Utf8 as B
import Blaze.ByteString.Builder (writeByteString, toLazyByteString) import Blaze.ByteString.Builder (writeByteString, toLazyByteString)
import Blaze.ByteString.Builder.Internal.Write (fromWriteList) import Blaze.ByteString.Builder.Internal.Write (fromWriteList)
@@ -87,15 +88,12 @@ import qualified Data.Text as T (drop, dropWhile) @@ -91,15 +92,12 @@ import qualified Data.Text as T (drop, dropWhile)
import qualified Data.Text.Read import qualified Data.Text.Read
import qualified Data.Map as Map import qualified Data.Map as Map
@ -295,7 +295,7 @@ index 8173e78..68a284c 100644
defaultFormMessage :: FormMessage -> Text defaultFormMessage :: FormMessage -> Text
defaultFormMessage = englishFormMessage defaultFormMessage = englishFormMessage
@@ -107,10 +105,25 @@ intField = Field @@ -111,10 +109,25 @@ intField = Field
Right (a, "") -> Right a Right (a, "") -> Right a
_ -> Left $ MsgInvalidInteger s _ -> Left $ MsgInvalidInteger s
@ -325,7 +325,7 @@ index 8173e78..68a284c 100644
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
where where
@@ -124,10 +137,25 @@ doubleField = Field @@ -128,10 +141,25 @@ doubleField = Field
Right (a, "") -> Right a Right (a, "") -> Right a
_ -> Left $ MsgInvalidNumber s _ -> Left $ MsgInvalidNumber s
@ -355,7 +355,7 @@ index 8173e78..68a284c 100644
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
where showVal = either id (pack . show) where showVal = either id (pack . show)
@@ -135,10 +163,24 @@ $newline never @@ -139,10 +167,24 @@ $newline never
dayField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Day dayField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Day
dayField = Field dayField = Field
{ fieldParse = parseHelper $ parseDate . unpack { fieldParse = parseHelper $ parseDate . unpack
@ -384,7 +384,7 @@ index 8173e78..68a284c 100644
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
where showVal = either id (pack . show) where showVal = either id (pack . show)
@@ -146,10 +188,23 @@ $newline never @@ -150,10 +192,23 @@ $newline never
timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
timeField = Field timeField = Field
{ fieldParse = parseHelper parseTime { fieldParse = parseHelper parseTime
@ -412,7 +412,7 @@ index 8173e78..68a284c 100644
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
where where
@@ -162,10 +217,23 @@ $newline never @@ -166,10 +221,23 @@ $newline never
htmlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Html htmlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Html
htmlField = Field htmlField = Field
{ fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance { fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance
@ -440,13 +440,13 @@ index 8173e78..68a284c 100644
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
where showVal = either id (pack . renderHtml) where showVal = either id (pack . renderHtml)
@@ -193,10 +261,17 @@ instance ToHtml Textarea where @@ -197,10 +265,18 @@ instance ToHtml Textarea where
textareaField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Textarea textareaField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Textarea
textareaField = Field textareaField = Field
{ fieldParse = parseHelper $ Right . Textarea { fieldParse = parseHelper $ Right . Textarea
- , fieldView = \theId name attrs val isReq -> toWidget [hamlet| - , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
-$newline never -$newline never
-<textarea id="#{theId}" name="#{name}" :isReq:required="" *{attrs}>#{either id unTextarea val} -<textarea id="#{theId}" name="#{name}" *{attrs}>#{either id unTextarea val}
-|] -|]
+ , fieldView = \theId name attrs val _isReq -> toWidget $ \ _render_aJKe + , fieldView = \theId name attrs val _isReq -> toWidget $ \ _render_aJKe
+ -> do { id + -> do { id
@ -459,10 +459,11 @@ index 8173e78..68a284c 100644
+ id ((Text.Blaze.Internal.preEscapedText . pack) ">"); + id ((Text.Blaze.Internal.preEscapedText . pack) ">");
+ id (toHtml (either id unTextarea val)); + id (toHtml (either id unTextarea val));
+ id ((Text.Blaze.Internal.preEscapedText . pack) "</textarea>") } + id ((Text.Blaze.Internal.preEscapedText . pack) "</textarea>") }
+
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
@@ -204,10 +279,19 @@ hiddenField :: (Monad m, PathPiece p, RenderMessage (HandlerSite m) FormMessage) @@ -208,10 +284,19 @@ hiddenField :: (Monad m, PathPiece p, RenderMessage (HandlerSite m) FormMessage)
=> Field m p => Field m p
hiddenField = Field hiddenField = Field
{ fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece { fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece
@ -486,7 +487,7 @@ index 8173e78..68a284c 100644
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
@@ -215,20 +299,53 @@ textField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Tex @@ -219,20 +304,53 @@ textField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Tex
textField = Field textField = Field
{ fieldParse = parseHelper $ Right { fieldParse = parseHelper $ Right
, fieldView = \theId name attrs val isReq -> , fieldView = \theId name attrs val isReq ->
@ -548,7 +549,7 @@ index 8173e78..68a284c 100644
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
@@ -300,10 +417,24 @@ emailField = Field @@ -304,10 +422,24 @@ emailField = Field
case Email.canonicalizeEmail $ encodeUtf8 s of case Email.canonicalizeEmail $ encodeUtf8 s of
Just e -> Right $ decodeUtf8With lenientDecode e Just e -> Right $ decodeUtf8With lenientDecode e
Nothing -> Left $ MsgInvalidEmail s Nothing -> Left $ MsgInvalidEmail s
@ -577,7 +578,7 @@ index 8173e78..68a284c 100644
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
@@ -318,10 +449,25 @@ multiEmailField = Field @@ -322,10 +454,25 @@ multiEmailField = Field
in case partitionEithers addrs of in case partitionEithers addrs of
([], good) -> Right good ([], good) -> Right good
(bad, _) -> Left $ MsgInvalidEmail $ cat bad (bad, _) -> Left $ MsgInvalidEmail $ cat bad
@ -607,7 +608,7 @@ index 8173e78..68a284c 100644
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
where where
@@ -337,20 +483,75 @@ searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus @@ -341,20 +488,75 @@ searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus
searchField autoFocus = Field searchField autoFocus = Field
{ fieldParse = parseHelper Right { fieldParse = parseHelper Right
, fieldView = \theId name attrs val isReq -> do , fieldView = \theId name attrs val isReq -> do
@ -695,7 +696,7 @@ index 8173e78..68a284c 100644
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
@@ -361,7 +562,28 @@ urlField = Field @@ -365,7 +567,28 @@ urlField = Field
Nothing -> Left $ MsgInvalidUrl s Nothing -> Left $ MsgInvalidUrl s
Just _ -> Right s Just _ -> Right s
, fieldView = \theId name attrs val isReq -> , fieldView = \theId name attrs val isReq ->
@ -725,7 +726,7 @@ index 8173e78..68a284c 100644
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
@@ -374,18 +596,54 @@ selectField :: (Eq a, RenderMessage site FormMessage) @@ -378,18 +601,54 @@ selectField :: (Eq a, RenderMessage site FormMessage)
=> HandlerT site IO (OptionList a) => HandlerT site IO (OptionList a)
-> Field (HandlerT site IO) a -> Field (HandlerT site IO) a
selectField = selectFieldHelper selectField = selectFieldHelper
@ -792,7 +793,7 @@ index 8173e78..68a284c 100644
multiSelectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) multiSelectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
=> [(msg, a)] => [(msg, a)]
@@ -408,11 +666,45 @@ multiSelectField ioptlist = @@ -412,11 +671,45 @@ multiSelectField ioptlist =
view theId name attrs val isReq = do view theId name attrs val isReq = do
opts <- fmap olOptions $ handlerToWidget ioptlist opts <- fmap olOptions $ handlerToWidget ioptlist
let selOpts = map (id &&& (optselected val)) opts let selOpts = map (id &&& (optselected val)) opts
@ -843,7 +844,7 @@ index 8173e78..68a284c 100644
where where
optselected (Left _) _ = False optselected (Left _) _ = False
optselected (Right vals) opt = (optionInternalValue opt) `elem` vals optselected (Right vals) opt = (optionInternalValue opt) `elem` vals
@@ -435,54 +727,196 @@ checkboxesField ioptlist = (multiSelectField ioptlist) @@ -439,54 +732,196 @@ checkboxesField ioptlist = (multiSelectField ioptlist)
opts <- fmap olOptions $ handlerToWidget ioptlist opts <- fmap olOptions $ handlerToWidget ioptlist
let optselected (Left _) _ = False let optselected (Left _) _ = False
optselected (Right vals) opt = (optionInternalValue opt) `elem` vals optselected (Right vals) opt = (optionInternalValue opt) `elem` vals
@ -1077,7 +1078,7 @@ index 8173e78..68a284c 100644
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
where where
@@ -508,10 +942,24 @@ $newline never @@ -512,10 +947,24 @@ $newline never
checkBoxField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool checkBoxField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool
checkBoxField = Field checkBoxField = Field
{ fieldParse = \e _ -> return $ checkBoxParser e { fieldParse = \e _ -> return $ checkBoxParser e
@ -1106,16 +1107,25 @@ index 8173e78..68a284c 100644
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
@@ -555,51 +1003,6 @@ optionsPairs opts = do @@ -559,69 +1008,6 @@ optionsPairs opts = do
optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a) optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a)
optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound] optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
-#if MIN_VERSION_persistent(2, 0, 0)
-optionsPersist :: ( YesodPersist site, PersistEntity a -optionsPersist :: ( YesodPersist site, PersistEntity a
- , PersistQuery (PersistEntityBackend a) - , PersistQuery (PersistEntityBackend a)
- , PathPiece (Key a) - , PathPiece (Key a)
- , RenderMessage site msg - , RenderMessage site msg
- , YesodPersistBackend site ~ PersistEntityBackend a - , YesodPersistBackend site ~ PersistEntityBackend a
- ) - )
-#else
-optionsPersist :: ( YesodPersist site, PersistEntity a
- , PersistQuery (YesodPersistBackend site (HandlerT site IO))
- , PathPiece (Key a)
- , PersistEntityBackend a ~ PersistMonadBackend (YesodPersistBackend site (HandlerT site IO))
- , RenderMessage site msg
- )
-#endif
- => [Filter a] - => [Filter a]
- -> [SelectOpt a] - -> [SelectOpt a]
- -> (a -> msg) - -> (a -> msg)
@ -1133,6 +1143,7 @@ index 8173e78..68a284c 100644
--- the entire @Entity@. --- the entire @Entity@.
--- ---
--- Since 1.3.2 --- Since 1.3.2
-#if MIN_VERSION_persistent(2, 0, 0)
-optionsPersistKey -optionsPersistKey
- :: (YesodPersist site - :: (YesodPersist site
- , PersistEntity a - , PersistEntity a
@ -1141,6 +1152,15 @@ index 8173e78..68a284c 100644
- , RenderMessage site msg - , RenderMessage site msg
- , YesodPersistBackend site ~ PersistEntityBackend a - , YesodPersistBackend site ~ PersistEntityBackend a
- ) - )
-#else
-optionsPersistKey
- :: (YesodPersist site
- , PersistEntity a
- , PersistQuery (YesodPersistBackend site (HandlerT site IO))
- , PathPiece (Key a)
- , RenderMessage site msg
- , PersistEntityBackend a ~ PersistMonadBackend (YesodDB site))
-#endif
- => [Filter a] - => [Filter a]
- -> [SelectOpt a] - -> [SelectOpt a]
- -> (a -> msg) - -> (a -> msg)
@ -1154,11 +1174,10 @@ index 8173e78..68a284c 100644
- , optionInternalValue = key - , optionInternalValue = key
- , optionExternalValue = toPathPiece key - , optionExternalValue = toPathPiece key
- }) pairs - }) pairs
-
selectFieldHelper selectFieldHelper
:: (Eq a, RenderMessage site FormMessage) :: (Eq a, RenderMessage site FormMessage)
=> (Text -> Text -> [(Text, Text)] -> WidgetT site IO () -> WidgetT site IO ()) @@ -665,9 +1051,21 @@ fileField = Field
@@ -642,9 +1045,21 @@ fileField = Field
case files of case files of
[] -> Right Nothing [] -> Right Nothing
file:_ -> Right $ Just file file:_ -> Right $ Just file
@ -1183,7 +1202,7 @@ index 8173e78..68a284c 100644
, fieldEnctype = Multipart , fieldEnctype = Multipart
} }
@@ -671,10 +1086,19 @@ fileAFormReq fs = AForm $ \(site, langs) menvs ints -> do @@ -694,10 +1092,19 @@ fileAFormReq fs = AForm $ \(site, langs) menvs ints -> do
{ fvLabel = toHtml $ renderMessage site langs $ fsLabel fs { fvLabel = toHtml $ renderMessage site langs $ fsLabel fs
, fvTooltip = fmap (toHtml . renderMessage site langs) $ fsTooltip fs , fvTooltip = fmap (toHtml . renderMessage site langs) $ fsTooltip fs
, fvId = id' , fvId = id'
@ -1207,7 +1226,7 @@ index 8173e78..68a284c 100644
, fvErrors = errs , fvErrors = errs
, fvRequired = True , fvRequired = True
} }
@@ -703,10 +1127,19 @@ fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do @@ -726,10 +1133,19 @@ fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do
{ fvLabel = toHtml $ renderMessage master langs $ fsLabel fs { fvLabel = toHtml $ renderMessage master langs $ fsLabel fs
, fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs , fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs
, fvId = id' , fvId = id'
@ -1971,14 +1990,11 @@ index a2b434d..75eb484 100644
- <td .errors>#{err} - <td .errors>#{err}
-|] -|]
diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs
index 2862678..7a0f25a 100644 index 7e4af07..b59745a 100644
--- a/Yesod/Form/Nic.hs --- a/Yesod/Form/Nic.hs
+++ b/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs
@@ -6,14 +6,24 @@ @@ -9,11 +9,22 @@ module Yesod.Form.Nic
-- | Provide the user with a rich text editor. , nicHtmlField
module Yesod.Form.Nic
( YesodNic (..)
- , nicHtmlField
) where ) where
+import qualified Text.Blaze as Text.Blaze.Internal +import qualified Text.Blaze as Text.Blaze.Internal
@ -2002,40 +2018,69 @@ index 2862678..7a0f25a 100644
import Text.Blaze.Html.Renderer.String (renderHtml) import Text.Blaze.Html.Renderer.String (renderHtml)
import Data.Text (Text, pack) import Data.Text (Text, pack)
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
@@ -22,33 +32,3 @@ class Yesod a => YesodNic a where @@ -27,20 +38,52 @@ nicHtmlField :: YesodNic site => Field (HandlerT site IO) Html
-- | NIC Editor Javascript file. nicHtmlField = Field
urlNicEdit :: a -> Either (Route a) Text { fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e
urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" , fieldView = \theId name attrs val isReq -> do
-
-nicHtmlField :: YesodNic site => Field (HandlerT site IO) Html
-nicHtmlField = Field
- { fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e
- , fieldView = \theId name attrs val _isReq -> do
- toWidget [shamlet| - toWidget [shamlet|
-$newline never -$newline never
- <textarea id="#{theId}" *{attrs} name="#{name}" .html>#{showVal val} - <textarea id="#{theId}" *{attrs} name="#{name}" :isReq:required .html>#{showVal val}
-|] -|]
- addScript' urlNicEdit + toWidget $ do { id
- master <- getYesod + ((Text.Blaze.Internal.preEscapedText . pack)
- toWidget $ + "<textarea class=\"html\" id=\"");
- case jsLoader master of + id (toHtml theId);
+ id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");
+ id (toHtml name);
+ id ((Text.Blaze.Internal.preEscapedText . pack) "\"");
+ Text.Hamlet.condH
+ [(isReq,
+ id ((Text.Blaze.Internal.preEscapedText . pack) " required"))]
+ Nothing;
+ id ((Text.Hamlet.attrsToHtml . Text.Hamlet.toAttributes) attrs);
+ id ((Text.Blaze.Internal.preEscapedText . pack) ">");
+ id (toHtml (showVal val));
+ id ((Text.Blaze.Internal.preEscapedText . pack) "</textarea>") }
+
addScript' urlNicEdit
master <- getYesod
toWidget $
case jsLoader master of
- BottomOfHeadBlocking -> [julius| - BottomOfHeadBlocking -> [julius|
-bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{rawJS theId}")}); -bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{rawJS theId}")});
-|] -|]
- _ -> [julius| - _ -> [julius|
-(function(){new nicEditor({fullPanel:true}).panelInstance("#{rawJS theId}")})(); -(function(){new nicEditor({fullPanel:true}).panelInstance("#{rawJS theId}")})();
-|] -|]
- , fieldEnctype = UrlEncoded + BottomOfHeadBlocking -> Text.Julius.asJavascriptUrl
- } + (\ _render_a2rMh
- where + -> Data.Monoid.mconcat
- showVal = either id (pack . renderHtml) + [Text.Julius.Javascript
- + ((Data.Text.Lazy.Builder.fromText
-addScript' :: (MonadWidget m, HandlerSite m ~ site) + . Text.Shakespeare.pack')
- => (site -> Either (Route site) Text) + "\nbkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance(\""),
- -> m () + Text.Julius.toJavascript (rawJS theId),
-addScript' f = do + Text.Julius.Javascript
- y <- getYesod + ((Data.Text.Lazy.Builder.fromText
- addScriptEither $ f y + . Text.Shakespeare.pack')
+ "\")});")])
+
+ _ -> Text.Julius.asJavascriptUrl
+ (\ _render_a2rMm
+ -> Data.Monoid.mconcat
+ [Text.Julius.Javascript
+ ((Data.Text.Lazy.Builder.fromText
+ . Text.Shakespeare.pack')
+ "\n(function(){new nicEditor({fullPanel:true}).panelInstance(\""),
+ Text.Julius.toJavascript (rawJS theId),
+ Text.Julius.Javascript
+ ((Data.Text.Lazy.Builder.fromText
+ . Text.Shakespeare.pack')
+ "\")})();")])
+
, fieldEnctype = UrlEncoded
}
where
-- --
1.7.10.4 2.1.1

18
standalone/no-th/haskell-patches/yesod-persistent_do-not-really-build.patch
View file

@ -1,23 +1,23 @@
From 85917e8b5da3c67c6ca0791fdad735ffb864ae3b Mon Sep 17 00:00:00 2001 From e82ed4e6fd7b5ea6dbe474b5de2755ec5794161c Mon Sep 17 00:00:00 2001
From: dummy <dummy@example.com> From: dummy <dummy@example.com>
Date: Tue, 14 Oct 2014 02:50:19 +0000 Date: Thu, 16 Oct 2014 02:23:50 +0000
Subject: [PATCH] not needed Subject: [PATCH] stub out
--- ---
yesod-persistent.cabal | 10 ---------- yesod-persistent.cabal | 10 ----------
1 file changed, 10 deletions(-) 1 file changed, 10 deletions(-)
diff --git a/yesod-persistent.cabal b/yesod-persistent.cabal diff --git a/yesod-persistent.cabal b/yesod-persistent.cabal
index 2e5735d..438c76d 100644 index b116f3a..017b184 100644
--- a/yesod-persistent.cabal --- a/yesod-persistent.cabal
+++ b/yesod-persistent.cabal +++ b/yesod-persistent.cabal
@@ -14,16 +14,6 @@ description: Some helpers for using Persistent from Yesod. @@ -14,16 +14,6 @@ description: Some helpers for using Persistent from Yesod.
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
- , yesod-core >= 1.4.0 && < 1.5 - , yesod-core >= 1.2.2 && < 1.3
- , persistent >= 2.1 && < 2.2 - , persistent >= 1.2 && < 2.1
- , persistent-template >= 2.1 && < 2.2 - , persistent-template >= 1.2 && < 2.1
- , transformers >= 0.2.2 - , transformers >= 0.2.2
- , blaze-builder - , blaze-builder
- , conduit - , conduit
@ -29,5 +29,5 @@ index 2e5735d..438c76d 100644
test-suite test test-suite test
-- --
1.7.10.4 2.1.1

30
standalone/no-th/haskell-patches/yesod_hack-TH.patch
View file

@ -1,13 +1,13 @@
From 1d12efe6c85c57bce44d0cd9389c5538f36f599e Mon Sep 17 00:00:00 2001 From 59091cd37958fee79b9e346fe3118d5ed7d0104b Mon Sep 17 00:00:00 2001
From: dummy <dummy@example.com> From: dummy <dummy@example.com>
Date: Tue, 14 Oct 2014 03:40:28 +0000 Date: Thu, 16 Oct 2014 02:36:37 +0000
Subject: [PATCH] hack to build Subject: [PATCH] hack TH
--- ---
Yesod.hs | 19 ++++++++++++-- Yesod.hs | 19 ++++++++++++--
Yesod/Default/Main.hs | 27 +------------------ Yesod/Default/Main.hs | 31 +----------------------
Yesod/Default/Util.hs | 69 ++----------------------------------------------- Yesod/Default/Util.hs | 69 ++-------------------------------------------------
3 files changed, 20 insertions(+), 95 deletions(-) 3 files changed, 20 insertions(+), 99 deletions(-)
diff --git a/Yesod.hs b/Yesod.hs diff --git a/Yesod.hs b/Yesod.hs
index b367144..fbe309c 100644 index b367144..fbe309c 100644
@ -41,7 +41,7 @@ index b367144..fbe309c 100644
+insert = undefined +insert = undefined
+ +
diff --git a/Yesod/Default/Main.hs b/Yesod/Default/Main.hs diff --git a/Yesod/Default/Main.hs b/Yesod/Default/Main.hs
index 44e094e..41c2df0 100644 index 565ed35..bf46642 100644
--- a/Yesod/Default/Main.hs --- a/Yesod/Default/Main.hs
+++ b/Yesod/Default/Main.hs +++ b/Yesod/Default/Main.hs
@@ -1,10 +1,8 @@ @@ -1,10 +1,8 @@
@ -64,7 +64,7 @@ index 44e094e..41c2df0 100644
import System.Log.FastLogger (LogStr, toLogStr) import System.Log.FastLogger (LogStr, toLogStr)
import Language.Haskell.TH.Syntax (qLocation) import Language.Haskell.TH.Syntax (qLocation)
@@ -55,29 +53,6 @@ defaultMain load getApp = do @@ -55,33 +53,6 @@ defaultMain load getApp = do
type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
@ -89,11 +89,15 @@ index 44e094e..41c2df0 100644
- (toLogStr $ "Exception from Warp: " ++ show e) - (toLogStr $ "Exception from Warp: " ++ show e)
- } app - } app
- where - where
- shouldLog' = Warp.defaultShouldDisplayException - shouldLog' =
- -#if MIN_VERSION_warp(2,1,3)
- Warp.defaultShouldDisplayException
-#else
- const True
-#endif
-- | Run your application continously, listening for SIGINT and exiting -- | Run your application continously, listening for SIGINT and exiting
-- when received -- when received
--
diff --git a/Yesod/Default/Util.hs b/Yesod/Default/Util.hs diff --git a/Yesod/Default/Util.hs b/Yesod/Default/Util.hs
index a10358e..0547424 100644 index a10358e..0547424 100644
--- a/Yesod/Default/Util.hs --- a/Yesod/Default/Util.hs
@ -191,5 +195,5 @@ index a10358e..0547424 100644
- else return $ Just ex - else return $ Just ex
- else return Nothing - else return Nothing
-- --
1.7.10.4 2.1.1