Merge branch 'android-rebuild'

This commit is contained in:
Joey Hess 2013-09-23 13:46:03 -04:00
commit 78e90130c3
83 changed files with 4042 additions and 6862 deletions

View file

@ -294,6 +294,8 @@ expandExpressionSplice s lls = concat [before, spliced:padding, end]
{- Tweaks code output by GHC in splices to actually build. Yipes. -}
mangleCode :: String -> String
mangleCode = flip_colon
. remove_unnecessary_type_signatures
. lambdaparenhack
. lambdaparens
. declaration_parens
. case_layout
@ -331,6 +333,12 @@ mangleCode = flip_colon
preindent <- many1 $ oneOf " \n"
string "\\ "
lambdaparams <- restofline
continuedlambdaparams <- many $ try $ do
indent <- many1 $ char ' '
p <- satisfy isLetter
aram <- many $ satisfy isAlphaNum <|> oneOf "_"
newline
return $ indent ++ p:aram ++ "\n"
indent <- many1 $ char ' '
string "-> "
firstline <- restofline
@ -342,10 +350,46 @@ mangleCode = flip_colon
return $ concat
[ prefix:preindent
, "(\\ " ++ lambdaparams ++ "\n"
, concat continuedlambdaparams
, indent ++ "-> "
, lambdaparens $ intercalate "\n" (firstline:lambdalines)
, ")\n"
]
{- Hack to add missing parens in a specific case in yesod
- static route code.
-
- StaticR
- yesod_dispatch_env_a4iDV
- (\ p_a4iE2 r_a4iE3
- -> r_a4iE3 {Network.Wai.pathInfo = p_a4iE2}
- xrest_a4iDT req_a4iDW)) }
-
- Need to add another paren around the lambda, and close it
- before its parameters. lambdaparens misses this one because
- there is already one paren present.
-
- FIXME: This is a hack. lambdaparens could just always add a
- layer of parens even when a lambda seems to be in parent.
-}
lambdaparenhack = parsecAndReplace $ do
indent <- many1 $ char ' '
staticr <- string "StaticR"
newline
string indent
yesod_dispatch_env <- restofline
string indent
lambdaprefix <- string "(\\ "
l1 <- restofline
string indent
lambdaarrow <- string " ->"
l2 <- restofline
return $ unlines
[ indent ++ staticr
, indent ++ yesod_dispatch_env
, indent ++ "(" ++ lambdaprefix ++ l1
, indent ++ lambdaarrow ++ l2 ++ ")"
]
restofline = manyTill (noneOf "\n") newline
@ -439,6 +483,19 @@ mangleCode = flip_colon
- declarations. -}
declaration_parens = replace "StaticR Route Static" "StaticR (Route Static)"
{- A type signature is sometimes given for an entire lambda,
- which is not properly parenthesized or laid out. This is a
- hack to remove one specific case where this happens and the
- signature is easily inferred, so is just removed.
-}
remove_unnecessary_type_signatures = parsecAndReplace $ do
string " ::"
newline
many1 $ char ' '
string "Text.Css.Block Text.Css.Resolved"
newline
return ""
{- GHC may add full package and version qualifications for
- symbols from unimported modules. We don't want these.
-

View file

@ -16,10 +16,9 @@ import Crypto
import Types.Remote (RemoteConfig, RemoteConfigKey)
import Remote.Helper.Encryptable (remoteCipher, embedCreds)
#ifndef mingw32_HOST_OS
import Utility.Env (setEnv)
import Utility.Env (setEnv, getEnv)
#endif
import System.Environment
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as M
import Utility.Base64
@ -101,11 +100,10 @@ getRemoteCredPair c storage = maybe fromcache (return . Just) =<< fromenv
{- Gets a CredPair from the environment. -}
getEnvCredPair :: CredPairStorage -> IO (Maybe CredPair)
getEnvCredPair storage = liftM2 (,)
<$> get uenv
<*> get penv
<$> getEnv uenv
<*> getEnv penv
where
(uenv, penv) = credPairEnvironment storage
get = catchMaybeIO . getEnv
{- Stores a CredPair in the environment. -}
setEnvCredPair :: CredPair -> CredPairStorage -> IO ()

View file

@ -160,12 +160,12 @@ osxapp: Build/Standalone Build/OSXMkLibs
rm -f tmp/git-annex.dmg.bz2
bzip2 --fast tmp/git-annex.dmg
ANDROID_FLAGS?=
ANDROID_FLAGS?=-f-XMPP
# Cross compile for Android.
# Uses https://github.com/neurocyte/ghc-android
android: Build/EvilSplicer
echo "Running native build, to get TH splices.."
if [ ! -e dist/setup/setup ]; then $(CABAL) configure -f"-Production $(ANDROID_FLAGS)" -O0; fi
if [ ! -e dist/setup/setup ]; then $(CABAL) configure -f-Production -O0 $(ANDROID_FLAGS); fi
mkdir -p tmp
if ! $(CABAL) build --ghc-options=-ddump-splices 2> tmp/dump-splices; then tail tmp/dump-splices >&2; exit 1; fi
echo "Setting up Android build tree.."
@ -183,9 +183,9 @@ android: Build/EvilSplicer
# Cabal cannot cross compile with custom build type, so workaround.
sed -i 's/Build-type: Custom/Build-type: Simple/' tmp/androidtree/git-annex.cabal
if [ ! -e tmp/androidtree/dist/setup/setup ]; then \
cd tmp/androidtree && $$HOME/.ghc/android-14/arm-linux-androideabi-4.7/arm-linux-androideabi/bin/cabal configure -f"Android $(ANDROID_FLAGS)"; \
cd tmp/androidtree && $$HOME/.ghc/android-14/arm-linux-androideabi-4.7/arm-linux-androideabi/bin/cabal configure -fAndroid $(ANDROID_FLAGS); \
fi
cd tmp/androidtree && $(CABAL) build
cd tmp/androidtree && $$HOME/.ghc/android-14/arm-linux-androideabi-4.7/arm-linux-androideabi/bin/cabal build
adb:
ANDROID_FLAGS="-Production" $(MAKE) android

2
debian/changelog vendored
View file

@ -3,6 +3,8 @@ git-annex (4.20130921) UNRELEASED; urgency=low
* Use cryptohash rather than SHA for hashing when no external hash program
is available. This is a significant speedup for SHA256 on OSX, for
example.
* Android build redone from scratch, many dependencies updated,
and entire build can now be done using provided scripts.
-- Joey Hess <joeyh@debian.org> Sun, 22 Sep 2013 19:42:29 -0400

View file

@ -19,14 +19,14 @@ of Bath CS department.
## building it yourself
git-annex can be built for Android, with `make android`. It's not an easy
process:
git-annex can be built from source for Android.
* First, install <https://github.com/neurocyte/ghc-android>.
* You will need to have the Android SDK and NDK installed; see
`standalone/android/Makefile` to configure the paths to them. You'll also
need ant, and the JDK.
* In `standalone/android/`, run `install-haskell-packages native`
* You also need to install git and all the utilities listed on [[fromscratch]],
on the system doing the building.
* Then to build the full Android app bundle, use `make androidapp`
1. Run `standalone/android/buildchroot` as root (requires debootstrap).
This builds a chroot with an `androidbuilder` user.
The rest of the build will run in this chroot as that user.
2. Then run `standalone/android/install-haskell-packages`
Note that this will break from time to time as new versions of packages
are released, and the patches it applies have to be updated when
this happens.
3. Finally, once the chroot is set up, you can build an Android binary
with `make android`, and `make androidapp` will build the complete APK.

View file

@ -133,8 +133,12 @@ Executable git-annex
CPP-Options: -DWITH_FSEVENTS
else
if (! os(windows) && ! os(solaris) && ! os(linux))
CPP-Options: -DWITH_KQUEUE
C-Sources: Utility/libkqueue.c
if flag(Android)
Build-Depends: hinotify
CPP-Options: -DWITH_INOTIFY
else
CPP-Options: -DWITH_KQUEUE
C-Sources: Utility/libkqueue.c
if os(linux) && flag(Dbus)
Build-Depends: dbus (>= 0.10.3)

View file

@ -2,22 +2,21 @@
# and builds the Android app.
# Add Android cross-compiler to PATH (as installed by ghc-android)
# (This directory also needs to have a cc that is a symlink to the prefixed
# gcc cross-compiler executable.)
ANDROID_CROSS_COMPILER?=$(HOME)/.ghc/android-14/arm-linux-androideabi-4.7/bin
PATH:=$(ANDROID_CROSS_COMPILER):$(PATH)
# Paths to the Android SDK and NDK.
export ANDROID_SDK_ROOT?=$(HOME)/tmp/adt-bundle-linux-x86/sdk
export ANDROID_NDK_ROOT?=$(HOME)/tmp/android-ndk-r8d
export ANDROID_SDK_ROOT?=$(HOME)/adt-bundle-linux-x86/sdk
export ANDROID_NDK_ROOT?=$(HOME)/android-ndk
# Where to store the source tree used to build utilities. This
# directory will be created by `make source`.
GIT_ANNEX_ANDROID_SOURCETREE?=$(HOME)/tmp/android-sourcetree
GIT_ANNEX_ANDROID_SOURCETREE?=$(HOME)/android-sourcetree
GITTREE=$(GIT_ANNEX_ANDROID_SOURCETREE)/git/installed-tree
build: start
if [ ! -e "$(GIT_ANNEX_ANDROID_SOURCETREE)" ]; then $(MAKE) source; fi
$(MAKE) $(GIT_ANNEX_ANDROID_SOURCETREE)/openssl/build-stamp
$(MAKE) $(GIT_ANNEX_ANDROID_SOURCETREE)/openssh/build-stamp
$(MAKE) $(GIT_ANNEX_ANDROID_SOURCETREE)/busybox/build-stamp
@ -85,7 +84,9 @@ $(GIT_ANNEX_ANDROID_SOURCETREE)/openssl/build-stamp:
touch $@
$(GIT_ANNEX_ANDROID_SOURCETREE)/openssh/build-stamp: openssh.patch openssh.config.h
cd $(GIT_ANNEX_ANDROID_SOURCETREE)/openssh && git reset --hard
# This is a known-good version that the patch works with.
# TODO: Upgrade
cd $(GIT_ANNEX_ANDROID_SOURCETREE)/openssh && git reset --hard 0a8617ed5af2f0248d0e9648e26b224e16ada742
cd $(GIT_ANNEX_ANDROID_SOURCETREE)/openssh && ./configure --host=arm-linux-androideabi --with-ssl-dir=../openssl --without-openssl-header-check
cat openssh.patch | (cd $(GIT_ANNEX_ANDROID_SOURCETREE)/openssh && patch -p1)
cp openssh.config.h $(GIT_ANNEX_ANDROID_SOURCETREE)/openssh/config.h
@ -105,7 +106,8 @@ $(GIT_ANNEX_ANDROID_SOURCETREE)/git/build-stamp:
touch $@
$(GIT_ANNEX_ANDROID_SOURCETREE)/rsync/build-stamp: rsync.patch
cat rsync.patch | (cd $(GIT_ANNEX_ANDROID_SOURCETREE)/rsync && git reset --hard origin/master && git am)
# This is a known-good version that the patch works with.
cat rsync.patch | (cd $(GIT_ANNEX_ANDROID_SOURCETREE)/rsync && git reset --hard eec26089b1c7bdbb260674480ffe6ece257bca63 && git am)
cp $(GIT_ANNEX_ANDROID_SOURCETREE)/automake/lib/config.sub $(GIT_ANNEX_ANDROID_SOURCETREE)/automake/lib/config.guess $(GIT_ANNEX_ANDROID_SOURCETREE)/rsync/
cd $(GIT_ANNEX_ANDROID_SOURCETREE)/rsync && ./configure --host=arm-linux-androideabi --disable-locale --disable-iconv-open --disable-iconv --disable-acl-support --disable-xattr-support
cd $(GIT_ANNEX_ANDROID_SOURCETREE)/rsync && $(MAKE)
@ -119,7 +121,8 @@ $(GIT_ANNEX_ANDROID_SOURCETREE)/gnupg/build-stamp:
touch $@
$(GIT_ANNEX_ANDROID_SOURCETREE)/term/build-stamp: term.patch icons
cd $(GIT_ANNEX_ANDROID_SOURCETREE)/term && git reset --hard
# This is a known-good version that the patch works with.
cd $(GIT_ANNEX_ANDROID_SOURCETREE)/term && git reset --hard 3d34b3c42295c215b62e70f3ee696dd664ba08ce
cat term.patch | (cd $(GIT_ANNEX_ANDROID_SOURCETREE)/term && patch -p1)
(cd icons && tar c .) | (cd $(GIT_ANNEX_ANDROID_SOURCETREE)/term/res && tar x)
# This renaming has a purpose. It makes the path to the app's
@ -129,21 +132,21 @@ $(GIT_ANNEX_ANDROID_SOURCETREE)/term/build-stamp: term.patch icons
# app, if it's also installed.
cd $(GIT_ANNEX_ANDROID_SOURCETREE)/term && find -name .git -prune -o -type f -print0 | xargs -0 perl -pi -e 's/jackpal/ga/g'
cd $(GIT_ANNEX_ANDROID_SOURCETREE)/term && perl -pi -e 's/Terminal Emulator/Git Annex/g' res/*/strings.xml
cd $(GIT_ANNEX_ANDROID_SOURCETREE)/term && tools/update.sh >/dev/null 2>&1
cd $(GIT_ANNEX_ANDROID_SOURCETREE)/term && echo y | tools/update.sh
touch $@
source: $(GIT_ANNEX_ANDROID_SOURCETREE)
$(GIT_ANNEX_ANDROID_SOURCETREE):
mkdir -p $(GIT_ANNEX_ANDROID_SOURCETREE)
git clone --bare git://git.savannah.gnu.org/automake.git $(GIT_ANNEX_ANDROID_SOURCETREE)/automake
git clone --bare git://git.debian.org/git/d-i/busybox $(GIT_ANNEX_ANDROID_SOURCETREE)/busybox
git clone --bare git://git.kernel.org/pub/scm/git/git.git $(GIT_ANNEX_ANDROID_SOURCETREE)/git
git clone --bare git://git.samba.org/rsync.git $(GIT_ANNEX_ANDROID_SOURCETREE)/rsync
git clone --bare git://git.gnupg.org/gnupg.git $(GIT_ANNEX_ANDROID_SOURCETREE)/gnupg
git clone --bare git://git.openssl.org/openssl $(GIT_ANNEX_ANDROID_SOURCETREE)/openssl
git clone --bare git://github.com/CyanogenMod/android_external_openssh.git $(GIT_ANNEX_ANDROID_SOURCETREE)/openssh
git clone --bare git://github.com/jackpal/Android-Terminal-Emulator.git $(GIT_ANNEX_ANDROID_SOURCETREE)/term
git clone git://git.savannah.gnu.org/automake.git $(GIT_ANNEX_ANDROID_SOURCETREE)/automake
git clone git://git.debian.org/git/d-i/busybox $(GIT_ANNEX_ANDROID_SOURCETREE)/busybox
git clone git://git.kernel.org/pub/scm/git/git.git $(GIT_ANNEX_ANDROID_SOURCETREE)/git
git clone git://git.samba.org/rsync.git $(GIT_ANNEX_ANDROID_SOURCETREE)/rsync
git clone git://git.gnupg.org/gnupg.git $(GIT_ANNEX_ANDROID_SOURCETREE)/gnupg
git clone git://git.openssl.org/openssl $(GIT_ANNEX_ANDROID_SOURCETREE)/openssl
git clone git://github.com/CyanogenMod/android_external_openssh.git $(GIT_ANNEX_ANDROID_SOURCETREE)/openssh
git clone git://github.com/jackpal/Android-Terminal-Emulator.git $(GIT_ANNEX_ANDROID_SOURCETREE)/term
clean:
rm -rf $(GITTREE)

26
standalone/android/buildchroot Executable file
View file

@ -0,0 +1,26 @@
#!/bin/sh
set -e
if [ "$(whoami)" != root ]; then
echo "Must run this as root!" >&2
exit 1
fi
debootstrap --arch=i386 stable debian-stable-android
cp $0-inchroot debian-stable-android/tmp
cp $0-inchroot-asuser debian-stable-android/tmp
# Don't use these vars in the chroot.
unset TMP
unset TEMP
unset TMPDIR
unset TEMPDIR
chroot debian-stable-android "tmp/$(basename $0)-inchroot"
echo
echo
echo "debian-stable-android is set up, with a user androidbuilder"
echo "your next step is probably to check out git-annex in this chroot"
echo "and run standalone/android/install-haskell-packages"
echo
echo

View file

@ -0,0 +1,25 @@
#!/bin/sh
# Runs inside the chroot set up by buildchroot
set -e
if [ "$(whoami)" != root ]; then
echo "Must run this as root!" >&2
exit 1
fi
# java needs this mounted to work
mount -t proc proc /proc
echo "deb-src http://ftp.us.debian.org/debian stable main" >> /etc/apt/sources.list
apt-get update
apt-get -y install build-essential ghc git libncurses5-dev cabal-install
apt-get -y install llvm-3.0 # not 3.1; buggy on arm. 3.2 is ok too
apt-get -y install ca-certificates curl file m4 autoconf zlib1g-dev
apt-get -y install libgnutls-dev libxml2-dev libgsasl7-dev pkg-config c2hs
apt-get -y install ant default-jdk rsync wget gnupg lsof
apt-get -y install gettext unzip
apt-get clean
wget http://snapshot.debian.org/archive/debian/20130903T155330Z/pool/main/a/automake-1.14/automake_1.14-1_all.deb
dpkg -i automake*.deb
rm *.deb
useradd androidbuilder --create-home
su androidbuilder -c $0-asuser

View file

@ -0,0 +1,36 @@
#!/bin/sh
# Runs inside the chroot set up by buildchroot, as the user it creates
set -e
cd
rm -rf .ghc .cabal
cabal update
cabal install happy alex --bindir=$HOME/bin
PATH=$HOME/bin:$PATH
export PATH
git clone https://github.com/joeyh/ghc-android
cd ghc-android
git checkout stable-ghc-snapshot
./build
# This saves 2 gb, and the same sources are in build-*/ghc
rm -rf stage0
# Set up android SDK where the git-annex android Makefile
# expects to find it.
cd ..
ln -s ghc-android/android-ndk-* android-ndk
wget http://dl.google.com/android/adt/adt-bundle-linux-x86-20130917.zip
unzip adt*.zip
rm adt*.zip
mv adt-bundle-linux-x86-* adt-bundle-linux-x86
rm -rf adt-bundle-linux-x86/eclipse
# The git-annex android Makefile needs this cc symlink.
ln -s arm-linux-androideabi-gcc \
$HOME/.ghc/android-14/arm-linux-androideabi-4.7/bin/cc
git clone git://git-annex.branchable.com/ git-annex
git config --global user.email androidbuilder@example.com
git config --global user.name androidbuilder

View file

@ -0,0 +1,6 @@
#!/bin/sh
# Removes all currently installed cross-compiled haskell packages
# except those part of ghc.
# Useful if the build failed.
rm -f $(grep -l $HOME/.ghc/android-14/arm-linux-androideabi-4.7/.cabal/lib/ $HOME/.ghc/android-14/arm-linux-androideabi-4.7/lib/*-ghc-*/package.conf.d/*.conf)
$HOME/.ghc/android-14/arm-linux-androideabi-4.7/arm-linux-androideabi/bin/ghc-pkg recache

View file

@ -6,6 +6,7 @@
- ** DO NOT COMMIT **
-}
import qualified Data.Monoid
import qualified Data.Set
import qualified Data.Map
import qualified Data.Map as Data.Map.Base
import qualified Data.Foldable
@ -16,12 +17,16 @@ import qualified Text.Hamlet
import qualified Text.Julius
import qualified Text.Css
import qualified "blaze-markup" Text.Blaze.Internal
import qualified Yesod.Widget
import qualified Yesod.Core.Widget
import qualified Yesod.Routes.TH.Types
import qualified Yesod.Routes.Dispatch
import qualified WaiAppStatic.Storage.Embedded
import qualified WaiAppStatic.Storage.Embedded.Runtime
import qualified Data.FileEmbed
import qualified Data.ByteString.Internal
import qualified Data.Text.Encoding
import qualified Network.Wai
import qualified Yesod.Core.Types
{- End EvilSplicer headers. -}

View file

@ -1,306 +0,0 @@
From d195f807dac2351d29aeff00d2aee3e151eb82e3 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 18 Apr 2013 19:37:28 -0400
Subject: [PATCH] build without TH
Used the EvilSplicer to expand the TH
Left off CmdArgs to save time.
---
DAV.cabal | 20 +----
Network/Protocol/HTTP/DAV.hs | 53 ++++++++++---
Network/Protocol/HTTP/DAV/TH.hs | 167 ++++++++++++++++++++++++++++++++++++++-
3 files changed, 207 insertions(+), 33 deletions(-)
diff --git a/DAV.cabal b/DAV.cabal
index 774d4e5..8b85133 100644
--- a/DAV.cabal
+++ b/DAV.cabal
@@ -38,25 +38,7 @@ library
, transformers >= 0.3
, xml-conduit >= 1.0 && <= 1.1
, xml-hamlet >= 0.4 && <= 0.5
-executable hdav
- main-is: hdav.hs
- ghc-options: -Wall
- build-depends: base >= 4.5 && <= 5
- , bytestring
- , bytestring
- , case-insensitive >= 0.4
- , cmdargs >= 0.9
- , containers
- , http-conduit >= 1.4
- , http-types >= 0.7
- , lens >= 3.0
- , lifted-base >= 0.1
- , mtl >= 2.1
- , network >= 2.3
- , resourcet >= 0.3
- , transformers >= 0.3
- , xml-conduit >= 1.0 && <= 1.1
- , xml-hamlet >= 0.4 && <= 0.5
+ , text
source-repository head
type: git
diff --git a/Network/Protocol/HTTP/DAV.hs b/Network/Protocol/HTTP/DAV.hs
index 02e5d15..c0be362 100644
--- a/Network/Protocol/HTTP/DAV.hs
+++ b/Network/Protocol/HTTP/DAV.hs
@@ -52,7 +52,8 @@ import Network.HTTP.Types (hContentType, Method, Status, RequestHeaders, unautho
import qualified Text.XML as XML
import Text.XML.Cursor (($/), (&/), element, node, fromDocument, checkName)
-import Text.Hamlet.XML (xml)
+import Text.Hamlet.XML
+import qualified Data.Text
import Data.CaseInsensitive (mk)
@@ -246,18 +247,48 @@ makeCollection url username password = withDS url username password $
propname :: XML.Document
propname = XML.Document (XML.Prologue [] Nothing []) root []
where
- root = XML.Element "D:propfind" (Map.fromList [("xmlns:D", "DAV:")]) [xml|
-<D:allprop>
-|]
+ root = XML.Element "D:propfind" (Map.fromList [("xmlns:D", "DAV:")]) $ concat
+ [[XML.NodeElement
+ (XML.Element
+ (XML.Name
+ (Data.Text.pack "D:allprop") Nothing Nothing)
+ Map.empty
+ (concat []))]]
+
locky :: XML.Document
locky = XML.Document (XML.Prologue [] Nothing []) root []
where
- root = XML.Element "D:lockinfo" (Map.fromList [("xmlns:D", "DAV:")]) [xml|
-<D:lockscope>
- <D:exclusive>
-<D:locktype>
- <D:write>
-<D:owner>Haskell DAV user
-|]
+ root = XML.Element "D:lockinfo" (Map.fromList [("xmlns:D", "DAV:")]) $ concat
+ [[XML.NodeElement
+ (XML.Element
+ (XML.Name
+ (Data.Text.pack "D:lockscope") Nothing Nothing)
+ Map.empty
+ (concat
+ [[XML.NodeElement
+ (XML.Element
+ (XML.Name
+ (Data.Text.pack "D:exclusive") Nothing Nothing)
+ Map.empty
+ (concat []))]]))],
+ [XML.NodeElement
+ (XML.Element
+ (XML.Name
+ (Data.Text.pack "D:locktype") Nothing Nothing)
+ Map.empty
+ (concat
+ [[XML.NodeElement
+ (XML.Element
+ (XML.Name (Data.Text.pack "D:write") Nothing Nothing)
+ Map.empty
+ (concat []))]]))],
+ [XML.NodeElement
+ (XML.Element
+ (XML.Name (Data.Text.pack "D:owner") Nothing Nothing)
+ Map.empty
+ (concat
+ [[XML.NodeContent
+ (Data.Text.pack "Haskell DAV user")]]))]]
+
diff --git a/Network/Protocol/HTTP/DAV/TH.hs b/Network/Protocol/HTTP/DAV/TH.hs
index 036a2bc..4d3c0f4 100644
--- a/Network/Protocol/HTTP/DAV/TH.hs
+++ b/Network/Protocol/HTTP/DAV/TH.hs
@@ -16,11 +16,13 @@
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RankNTypes #-}
module Network.Protocol.HTTP.DAV.TH where
-import Control.Lens (makeLenses)
+import Control.Lens
+import qualified Control.Lens.Type
+import qualified Data.Functor
import qualified Data.ByteString as B
import Network.HTTP.Conduit (Manager, Request)
@@ -33,4 +35,163 @@ data DAVContext a = DAVContext {
, _basicusername :: B.ByteString
, _basicpassword :: B.ByteString
}
-makeLenses ''DAVContext
+allowedMethods ::
+ forall a_a4Oo.
+ Control.Lens.Type.Lens' (DAVContext a_a4Oo) [B.ByteString]
+allowedMethods
+ _f_a5tt
+ (DAVContext __allowedMethods'_a5tu
+ __baseRequest_a5tw
+ __complianceClasses_a5tx
+ __httpManager_a5ty
+ __lockToken_a5tz
+ __basicusername_a5tA
+ __basicpassword_a5tB)
+ = ((\ __allowedMethods_a5tv
+ -> DAVContext
+ __allowedMethods_a5tv
+ __baseRequest_a5tw
+ __complianceClasses_a5tx
+ __httpManager_a5ty
+ __lockToken_a5tz
+ __basicusername_a5tA
+ __basicpassword_a5tB)
+ Data.Functor.<$> (_f_a5tt __allowedMethods'_a5tu))
+{-# INLINE allowedMethods #-}
+baseRequest ::
+ forall a_a4Oo a_a5tC.
+ Control.Lens.Type.Lens (DAVContext a_a4Oo) (DAVContext a_a5tC) (Request a_a4Oo) (Request a_a5tC)
+baseRequest
+ _f_a5tD
+ (DAVContext __allowedMethods_a5tE
+ __baseRequest'_a5tF
+ __complianceClasses_a5tH
+ __httpManager_a5tI
+ __lockToken_a5tJ
+ __basicusername_a5tK
+ __basicpassword_a5tL)
+ = ((\ __baseRequest_a5tG
+ -> DAVContext
+ __allowedMethods_a5tE
+ __baseRequest_a5tG
+ __complianceClasses_a5tH
+ __httpManager_a5tI
+ __lockToken_a5tJ
+ __basicusername_a5tK
+ __basicpassword_a5tL)
+ Data.Functor.<$> (_f_a5tD __baseRequest'_a5tF))
+{-# INLINE baseRequest #-}
+basicpassword ::
+ forall a_a4Oo.
+ Control.Lens.Type.Lens' (DAVContext a_a4Oo) B.ByteString
+basicpassword
+ _f_a5tM
+ (DAVContext __allowedMethods_a5tN
+ __baseRequest_a5tO
+ __complianceClasses_a5tP
+ __httpManager_a5tQ
+ __lockToken_a5tR
+ __basicusername_a5tS
+ __basicpassword'_a5tT)
+ = ((\ __basicpassword_a5tU
+ -> DAVContext
+ __allowedMethods_a5tN
+ __baseRequest_a5tO
+ __complianceClasses_a5tP
+ __httpManager_a5tQ
+ __lockToken_a5tR
+ __basicusername_a5tS
+ __basicpassword_a5tU)
+ Data.Functor.<$> (_f_a5tM __basicpassword'_a5tT))
+{-# INLINE basicpassword #-}
+basicusername ::
+ forall a_a4Oo.
+ Control.Lens.Type.Lens' (DAVContext a_a4Oo) B.ByteString
+basicusername
+ _f_a5tV
+ (DAVContext __allowedMethods_a5tW
+ __baseRequest_a5tX
+ __complianceClasses_a5tY
+ __httpManager_a5tZ
+ __lockToken_a5u0
+ __basicusername'_a5u1
+ __basicpassword_a5u3)
+ = ((\ __basicusername_a5u2
+ -> DAVContext
+ __allowedMethods_a5tW
+ __baseRequest_a5tX
+ __complianceClasses_a5tY
+ __httpManager_a5tZ
+ __lockToken_a5u0
+ __basicusername_a5u2
+ __basicpassword_a5u3)
+ Data.Functor.<$> (_f_a5tV __basicusername'_a5u1))
+{-# INLINE basicusername #-}
+complianceClasses ::
+ forall a_a4Oo.
+ Control.Lens.Type.Lens' (DAVContext a_a4Oo) [B.ByteString]
+complianceClasses
+ _f_a5u4
+ (DAVContext __allowedMethods_a5u5
+ __baseRequest_a5u6
+ __complianceClasses'_a5u7
+ __httpManager_a5u9
+ __lockToken_a5ua
+ __basicusername_a5ub
+ __basicpassword_a5uc)
+ = ((\ __complianceClasses_a5u8
+ -> DAVContext
+ __allowedMethods_a5u5
+ __baseRequest_a5u6
+ __complianceClasses_a5u8
+ __httpManager_a5u9
+ __lockToken_a5ua
+ __basicusername_a5ub
+ __basicpassword_a5uc)
+ Data.Functor.<$> (_f_a5u4 __complianceClasses'_a5u7))
+{-# INLINE complianceClasses #-}
+httpManager ::
+ forall a_a4Oo. Control.Lens.Type.Lens' (DAVContext a_a4Oo) Manager
+httpManager
+ _f_a5ud
+ (DAVContext __allowedMethods_a5ue
+ __baseRequest_a5uf
+ __complianceClasses_a5ug
+ __httpManager'_a5uh
+ __lockToken_a5uj
+ __basicusername_a5uk
+ __basicpassword_a5ul)
+ = ((\ __httpManager_a5ui
+ -> DAVContext
+ __allowedMethods_a5ue
+ __baseRequest_a5uf
+ __complianceClasses_a5ug
+ __httpManager_a5ui
+ __lockToken_a5uj
+ __basicusername_a5uk
+ __basicpassword_a5ul)
+ Data.Functor.<$> (_f_a5ud __httpManager'_a5uh))
+{-# INLINE httpManager #-}
+lockToken ::
+ forall a_a4Oo.
+ Control.Lens.Type.Lens' (DAVContext a_a4Oo) (Maybe B.ByteString)
+lockToken
+ _f_a5um
+ (DAVContext __allowedMethods_a5un
+ __baseRequest_a5uo
+ __complianceClasses_a5up
+ __httpManager_a5uq
+ __lockToken'_a5ur
+ __basicusername_a5ut
+ __basicpassword_a5uu)
+ = ((\ __lockToken_a5us
+ -> DAVContext
+ __allowedMethods_a5un
+ __baseRequest_a5uo
+ __complianceClasses_a5up
+ __httpManager_a5uq
+ __lockToken_a5us
+ __basicusername_a5ut
+ __basicpassword_a5uu)
+ Data.Functor.<$> (_f_a5um __lockToken'_a5ur))
+{-# INLINE lockToken #-}
--
1.7.10.4

View file

@ -0,0 +1,377 @@
From 2b5fc33607720d0cccd7d8f9cb7232042ead73e6 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 00:36:56 +0000
Subject: [PATCH] expand TH
used the EvilSplicer
+ manual fix ups
---
DAV.cabal | 20 +--
Network/Protocol/HTTP/DAV.hs | 73 ++++++-----
Network/Protocol/HTTP/DAV/TH.hs | 196 +++++++++++++++++++++++++++-
dist/build/HSDAV-0.4.1.o | Bin 140080 -> 0 bytes
dist/build/Network/Protocol/HTTP/DAV.hi | Bin 34549 -> 57657 bytes
dist/build/Network/Protocol/HTTP/DAV.o | Bin 160248 -> 201932 bytes
dist/build/Network/Protocol/HTTP/DAV/TH.hi | Bin 17056 -> 18733 bytes
dist/build/Network/Protocol/HTTP/DAV/TH.o | Bin 19672 -> 28120 bytes
dist/build/autogen/Paths_DAV.hs | 18 ++-
dist/build/autogen/cabal_macros.h | 45 +++----
dist/build/libHSDAV-0.4.1.a | Bin 200082 -> 260188 bytes
dist/package.conf.inplace | 2 -
dist/setup-config | 2 -
13 files changed, 266 insertions(+), 90 deletions(-)
delete mode 100644 dist/build/HSDAV-0.4.1.o
delete mode 100644 dist/package.conf.inplace
delete mode 100644 dist/setup-config
diff --git a/DAV.cabal b/DAV.cabal
index 06b3a8b..90368c6 100644
--- a/DAV.cabal
+++ b/DAV.cabal
@@ -38,25 +38,7 @@ library
, transformers >= 0.3
, xml-conduit >= 1.0 && <= 1.2
, xml-hamlet >= 0.4 && <= 0.5
-executable hdav
- main-is: hdav.hs
- ghc-options: -Wall
- build-depends: base >= 4.5 && <= 5
- , bytestring
- , bytestring
- , case-insensitive >= 0.4
- , containers
- , http-conduit >= 1.9.0
- , http-types >= 0.7
- , lens >= 3.0
- , lifted-base >= 0.1
- , mtl >= 2.1
- , network >= 2.3
- , optparse-applicative
- , resourcet >= 0.3
- , transformers >= 0.3
- , xml-conduit >= 1.0 && <= 1.2
- , xml-hamlet >= 0.4 && <= 0.5
+ , text
source-repository head
type: git
diff --git a/Network/Protocol/HTTP/DAV.hs b/Network/Protocol/HTTP/DAV.hs
index 8ffc270..d064a8f 100644
--- a/Network/Protocol/HTTP/DAV.hs
+++ b/Network/Protocol/HTTP/DAV.hs
@@ -28,12 +28,12 @@ module Network.Protocol.HTTP.DAV (
, deleteContent
, moveContent
, makeCollection
- , caldavReport
, module Network.Protocol.HTTP.DAV.TH
) where
import Network.Protocol.HTTP.DAV.TH
+import qualified Data.Text
import Control.Applicative (liftA2)
import Control.Exception.Lifted (catchJust, finally, bracketOnError)
import Control.Lens ((.~), (^.))
@@ -200,11 +200,6 @@ props2patch = XML.renderLBS XML.def . patch . props . fromDocument
, "{DAV:}supportedlock"
]
-caldavReportM :: MonadResourceBase m => DAVState m XML.Document
-caldavReportM = do
- let ahs = [(hContentType, "application/xml; charset=\"utf-8\"")]
- calrresp <- davRequest "REPORT" ahs (xmlBody calendarquery)
- return $ (XML.parseLBS_ def . responseBody) calrresp
getProps :: String -> B.ByteString -> B.ByteString -> Maybe Depth -> IO XML.Document
getProps url username password md = withDS url username password md getPropsM
@@ -246,9 +241,6 @@ moveContent :: String -> B.ByteString -> B.ByteString -> B.ByteString -> IO ()
moveContent url newurl username password = withDS url username password Nothing $
moveContentM newurl
-caldavReport :: String -> B.ByteString -> B.ByteString -> IO XML.Document
-caldavReport url username password = withDS url username password (Just Depth1) $ caldavReportM
-
-- | Creates a WebDAV collection, which is similar to a directory.
--
-- Returns False if the collection could not be made due to an intermediate
@@ -264,28 +256,45 @@ makeCollection url username password = withDS url username password Nothing $
propname :: XML.Document
propname = XML.Document (XML.Prologue [] Nothing []) root []
where
- root = XML.Element "D:propfind" (Map.fromList [("xmlns:D", "DAV:")]) [xml|
-<D:allprop>
-|]
-
+ root = XML.Element "D:propfind" (Map.fromList [("xmlns:D", "DAV:")]) $ concat
+ [[XML.NodeElement
+ (XML.Element
+ (XML.Name
+ (Data.Text.pack "D:allprop") Nothing Nothing)
+ Map.empty
+ (concat []))]]
locky :: XML.Document
locky = XML.Document (XML.Prologue [] Nothing []) root []
- where
- root = XML.Element "D:lockinfo" (Map.fromList [("xmlns:D", "DAV:")]) [xml|
-<D:lockscope>
- <D:exclusive>
-<D:locktype>
- <D:write>
-<D:owner>Haskell DAV user
-|]
-
-calendarquery :: XML.Document
-calendarquery = XML.Document (XML.Prologue [] Nothing []) root []
- where
- root = XML.Element "C:calendar-query" (Map.fromList [("xmlns:D", "DAV:"),("xmlns:C", "urn:ietf:params:xml:ns:caldav")]) [xml|
-<D:prop>
- <D:getetag>
- <C:calendar-data>
-<C:filter>
- <C:comp-filter name="VCALENDAR">
-|]
+ where
+ root = XML.Element "D:lockinfo" (Map.fromList [("xmlns:D", "DAV:")]) $ concat
+ [[XML.NodeElement
+ (XML.Element
+ (XML.Name
+ (Data.Text.pack "D:lockscope") Nothing Nothing)
+ Map.empty
+ (concat
+ [[XML.NodeElement
+ (XML.Element
+ (XML.Name
+ (Data.Text.pack "D:exclusive") Nothing Nothing)
+ Map.empty
+ (concat []))]]))],
+ [XML.NodeElement
+ (XML.Element
+ (XML.Name
+ (Data.Text.pack "D:locktype") Nothing Nothing)
+ Map.empty
+ (concat
+ [[XML.NodeElement
+ (XML.Element
+ (XML.Name (Data.Text.pack "D:write") Nothing Nothing)
+ Map.empty
+ (concat []))]]))],
+ [XML.NodeElement
+ (XML.Element
+ (XML.Name (Data.Text.pack "D:owner") Nothing Nothing)
+ Map.empty
+ (concat
+ [[XML.NodeContent
+ (Data.Text.pack "Haskell DAV user")]]))]]
+
diff --git a/Network/Protocol/HTTP/DAV/TH.hs b/Network/Protocol/HTTP/DAV/TH.hs
index 9fb3495..18b8df7 100644
--- a/Network/Protocol/HTTP/DAV/TH.hs
+++ b/Network/Protocol/HTTP/DAV/TH.hs
@@ -20,7 +20,8 @@
module Network.Protocol.HTTP.DAV.TH where
-import Control.Lens (makeLenses)
+import qualified Control.Lens.Type
+import qualified Data.Functor
import qualified Data.ByteString as B
import Network.HTTP.Conduit (Manager, Request)
@@ -46,4 +47,195 @@ data DAVContext a = DAVContext {
, _basicpassword :: B.ByteString
, _depth :: Maybe Depth
}
-makeLenses ''DAVContext
+allowedMethods ::
+ Control.Lens.Type.Lens' (DAVContext a_a4I4) [B.ByteString]
+allowedMethods
+ _f_a5GM
+ (DAVContext __allowedMethods'_a5GN
+ __baseRequest_a5GP
+ __complianceClasses_a5GQ
+ __httpManager_a5GR
+ __lockToken_a5GS
+ __basicusername_a5GT
+ __basicpassword_a5GU
+ __depth_a5GV)
+ = ((\ __allowedMethods_a5GO
+ -> DAVContext
+ __allowedMethods_a5GO
+ __baseRequest_a5GP
+ __complianceClasses_a5GQ
+ __httpManager_a5GR
+ __lockToken_a5GS
+ __basicusername_a5GT
+ __basicpassword_a5GU
+ __depth_a5GV)
+ Data.Functor.<$> (_f_a5GM __allowedMethods'_a5GN))
+{-# INLINE allowedMethods #-}
+baseRequest ::
+ Control.Lens.Type.Lens (DAVContext a_a4I4) (DAVContext a_a5GW) (Request a_a4I4) (Request a_a5GW)
+baseRequest
+ _f_a5GX
+ (DAVContext __allowedMethods_a5GY
+ __baseRequest'_a5GZ
+ __complianceClasses_a5H1
+ __httpManager_a5H2
+ __lockToken_a5H3
+ __basicusername_a5H4
+ __basicpassword_a5H5
+ __depth_a5H6)
+ = ((\ __baseRequest_a5H0
+ -> DAVContext
+ __allowedMethods_a5GY
+ __baseRequest_a5H0
+ __complianceClasses_a5H1
+ __httpManager_a5H2
+ __lockToken_a5H3
+ __basicusername_a5H4
+ __basicpassword_a5H5
+ __depth_a5H6)
+ Data.Functor.<$> (_f_a5GX __baseRequest'_a5GZ))
+{-# INLINE baseRequest #-}
+basicpassword ::
+ Control.Lens.Type.Lens' (DAVContext a_a4I4) B.ByteString
+basicpassword
+ _f_a5H7
+ (DAVContext __allowedMethods_a5H8
+ __baseRequest_a5H9
+ __complianceClasses_a5Ha
+ __httpManager_a5Hb
+ __lockToken_a5Hc
+ __basicusername_a5Hd
+ __basicpassword'_a5He
+ __depth_a5Hg)
+ = ((\ __basicpassword_a5Hf
+ -> DAVContext
+ __allowedMethods_a5H8
+ __baseRequest_a5H9
+ __complianceClasses_a5Ha
+ __httpManager_a5Hb
+ __lockToken_a5Hc
+ __basicusername_a5Hd
+ __basicpassword_a5Hf
+ __depth_a5Hg)
+ Data.Functor.<$> (_f_a5H7 __basicpassword'_a5He))
+{-# INLINE basicpassword #-}
+basicusername ::
+ Control.Lens.Type.Lens' (DAVContext a_a4I4) B.ByteString
+basicusername
+ _f_a5Hh
+ (DAVContext __allowedMethods_a5Hi
+ __baseRequest_a5Hj
+ __complianceClasses_a5Hk
+ __httpManager_a5Hl
+ __lockToken_a5Hm
+ __basicusername'_a5Hn
+ __basicpassword_a5Hp
+ __depth_a5Hq)
+ = ((\ __basicusername_a5Ho
+ -> DAVContext
+ __allowedMethods_a5Hi
+ __baseRequest_a5Hj
+ __complianceClasses_a5Hk
+ __httpManager_a5Hl
+ __lockToken_a5Hm
+ __basicusername_a5Ho
+ __basicpassword_a5Hp
+ __depth_a5Hq)
+ Data.Functor.<$> (_f_a5Hh __basicusername'_a5Hn))
+{-# INLINE basicusername #-}
+complianceClasses ::
+ Control.Lens.Type.Lens' (DAVContext a_a4I4) [B.ByteString]
+complianceClasses
+ _f_a5Hr
+ (DAVContext __allowedMethods_a5Hs
+ __baseRequest_a5Ht
+ __complianceClasses'_a5Hu
+ __httpManager_a5Hw
+ __lockToken_a5Hx
+ __basicusername_a5Hy
+ __basicpassword_a5Hz
+ __depth_a5HA)
+ = ((\ __complianceClasses_a5Hv
+ -> DAVContext
+ __allowedMethods_a5Hs
+ __baseRequest_a5Ht
+ __complianceClasses_a5Hv
+ __httpManager_a5Hw
+ __lockToken_a5Hx
+ __basicusername_a5Hy
+ __basicpassword_a5Hz
+ __depth_a5HA)
+ Data.Functor.<$> (_f_a5Hr __complianceClasses'_a5Hu))
+{-# INLINE complianceClasses #-}
+depth ::
+ Control.Lens.Type.Lens' (DAVContext a_a4I4) (Maybe Depth)
+depth
+ _f_a5HB
+ (DAVContext __allowedMethods_a5HC
+ __baseRequest_a5HD
+ __complianceClasses_a5HE
+ __httpManager_a5HF
+ __lockToken_a5HG
+ __basicusername_a5HH
+ __basicpassword_a5HI
+ __depth'_a5HJ)
+ = ((\ __depth_a5HK
+ -> DAVContext
+ __allowedMethods_a5HC
+ __baseRequest_a5HD
+ __complianceClasses_a5HE
+ __httpManager_a5HF
+ __lockToken_a5HG
+ __basicusername_a5HH
+ __basicpassword_a5HI
+ __depth_a5HK)
+ Data.Functor.<$> (_f_a5HB __depth'_a5HJ))
+{-# INLINE depth #-}
+httpManager ::
+ Control.Lens.Type.Lens' (DAVContext a_a4I4) Manager
+httpManager
+ _f_a5HL
+ (DAVContext __allowedMethods_a5HM
+ __baseRequest_a5HN
+ __complianceClasses_a5HO
+ __httpManager'_a5HP
+ __lockToken_a5HR
+ __basicusername_a5HS
+ __basicpassword_a5HT
+ __depth_a5HU)
+ = ((\ __httpManager_a5HQ
+ -> DAVContext
+ __allowedMethods_a5HM
+ __baseRequest_a5HN
+ __complianceClasses_a5HO
+ __httpManager_a5HQ
+ __lockToken_a5HR
+ __basicusername_a5HS
+ __basicpassword_a5HT
+ __depth_a5HU)
+ Data.Functor.<$> (_f_a5HL __httpManager'_a5HP))
+{-# INLINE httpManager #-}
+lockToken ::
+ Control.Lens.Type.Lens' (DAVContext a_a4I4) (Maybe B.ByteString)
+lockToken
+ _f_a5HV
+ (DAVContext __allowedMethods_a5HW
+ __baseRequest_a5HX
+ __complianceClasses_a5HY
+ __httpManager_a5HZ
+ __lockToken'_a5I0
+ __basicusername_a5I2
+ __basicpassword_a5I3
+ __depth_a5I4)
+ = ((\ __lockToken_a5I1
+ -> DAVContext
+ __allowedMethods_a5HW
+ __baseRequest_a5HX
+ __complianceClasses_a5HY
+ __httpManager_a5HZ
+ __lockToken_a5I1
+ __basicusername_a5I2
+ __basicpassword_a5I3
+ __depth_a5I4)
+ Data.Functor.<$> (_f_a5HV __lockToken'_a5I0))
+{-# INLINE lockToken #-}

View file

@ -1,31 +1,25 @@
From 32d0741c64e6bd280e46f7c452db9462fbac05f9 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Tue, 7 May 2013 18:21:04 -0400
Subject: [PATCH] fix build
From 5c57c4ae7dac0c1aa940005f5ea55fdcd4fcd1f5 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sat, 21 Sep 2013 22:46:42 +0000
Subject: [PATCH] fix build with new base
---
HTTP.cabal | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
HTTP.cabal | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/HTTP.cabal b/HTTP.cabal
index 76cb5d6..edddf26 100644
index 76cb5d6..bb38f24 100644
--- a/HTTP.cabal
+++ b/HTTP.cabal
@@ -85,12 +85,12 @@ Library
@@ -85,7 +85,7 @@ Library
Network.HTTP.Utils
Paths_HTTP
GHC-options: -fwarn-missing-signatures -Wall
- Build-depends: base >= 2 && < 4.7, network < 2.5, parsec
+ Build-depends: base >= 2 && < 4.8, network < 2.5, parsec
+ Build-depends: base >= 2 && < 4.9, network < 2.5, parsec
Extensions: FlexibleInstances
if flag(old-base)
Build-depends: base < 3
else
- Build-depends: base >= 3, array, old-time, bytestring
+ Build-depends: base >= 3, array, old-time, bytestring (>= 0.10.3.0)
if flag(mtl1)
Build-depends: mtl >= 1.1 && < 1.2
--
1.7.10.4

View file

@ -0,0 +1,56 @@
From 083c9d135ec68316db173235994c63603ad76444 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sat, 21 Sep 2013 23:01:35 +0000
Subject: [PATCH] hack to get to build with new ghc
Copied the old implemenations of block and unblock from old Control.Exception
since these deprecated functions have now been removed.
---
MonadCatchIO-transformers.cabal | 2 +-
src/Control/Monad/CatchIO.hs | 13 +++++++++++--
2 files changed, 12 insertions(+), 3 deletions(-)
diff --git a/MonadCatchIO-transformers.cabal b/MonadCatchIO-transformers.cabal
index fe6674d..b9f559f 100644
--- a/MonadCatchIO-transformers.cabal
+++ b/MonadCatchIO-transformers.cabal
@@ -26,4 +26,4 @@ Library
Exposed-Modules:
Control.Monad.CatchIO
Hs-Source-Dirs: src
- Ghc-options: -Wall
+ Ghc-options: -Wall -fglasgow-exts
diff --git a/src/Control/Monad/CatchIO.hs b/src/Control/Monad/CatchIO.hs
index 62afb83..853996b 100644
--- a/src/Control/Monad/CatchIO.hs
+++ b/src/Control/Monad/CatchIO.hs
@@ -19,6 +19,9 @@ where
import Prelude hiding ( catch )
import Control.Applicative ((<$>))
import qualified Control.Exception.Extensible as E
+import qualified Control.Exception.Base as E
+import GHC.Base (maskAsyncExceptions#)
+import GHC.IO (unsafeUnmask, IO(..))
import Control.Monad.IO.Class (MonadIO,liftIO)
@@ -51,8 +54,14 @@ class MonadIO m => MonadCatchIO m where
instance MonadCatchIO IO where
catch = E.catch
- block = E.block
- unblock = E.unblock
+ block = oldblock
+ unblock = oldunblock
+
+oldblock :: IO a -> IO a
+oldblock (IO io) = IO $ maskAsyncExceptions# io
+
+oldunblock :: IO a -> IO a
+oldunblock = unsafeUnmask
-- | Warning: this instance is somewhat contentious.
--
--
1.7.10.4

View file

@ -0,0 +1,36 @@
From 010db89634eb0f64e7961581e65da3acbb2b9f3d Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sat, 21 Sep 2013 22:05:41 +0000
Subject: [PATCH] fix build with new base
---
src/Control/Concurrent/MSampleVar.hs | 6 +-----
1 file changed, 1 insertion(+), 5 deletions(-)
diff --git a/src/Control/Concurrent/MSampleVar.hs b/src/Control/Concurrent/MSampleVar.hs
index d029c64..16ad6c5 100644
--- a/src/Control/Concurrent/MSampleVar.hs
+++ b/src/Control/Concurrent/MSampleVar.hs
@@ -30,7 +30,7 @@ module Control.Concurrent.MSampleVar
import Control.Monad(void,join)
import Control.Concurrent.MVar(MVar,newMVar,newEmptyMVar,tryTakeMVar,takeMVar,putMVar,withMVar,isEmptyMVar)
import Control.Exception(mask_)
-import Data.Typeable(Typeable1(typeOf1),mkTyCon,mkTyConApp)
+import Data.Typeable(mkTyConApp)
-- |
-- Sample variables are slightly different from a normal 'MVar':
@@ -62,10 +62,6 @@ data MSampleVar a = MSampleVar { readQueue :: MVar ()
, lockedStore :: MVar (MVar a) }
deriving (Eq)
-instance Typeable1 MSampleVar where
- typeOf1 _ = mkTyConApp tc []
- where tc = mkTyCon "MSampleVar"
-
-- | 'newEmptySV' allocates a new MSampleVar in an empty state. No futher
-- allocation is done when using the 'MSampleVar'.
--
1.7.10.4

View file

@ -1,24 +0,0 @@
From b220c377941d0b1271cf525a8d06bb8e48196d2b Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:29:04 -0400
Subject: [PATCH] disable TH
---
aeson.cabal | 1 -
1 file changed, 1 deletion(-)
diff --git a/aeson.cabal b/aeson.cabal
index 242aa67..275aa49 100644
--- a/aeson.cabal
+++ b/aeson.cabal
@@ -99,7 +99,6 @@ library
Data.Aeson.Generic
Data.Aeson.Parser
Data.Aeson.Types
- Data.Aeson.TH
other-modules:
Data.Aeson.Functions
--
1.7.10.4

View file

@ -1,14 +1,14 @@
From 55f424de9946c4d1d89837bb18698437aecfcfa4 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:29:16 -0400
Subject: [PATCH] allow building with unreleased ghc
From 0035f0366e426af213244b2eb25ffb63cb9e74d0 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 06:14:50 +0000
Subject: [PATCH] fix build with new ghc
---
async.cabal | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/async.cabal b/async.cabal
index 8e47d9d..ff317c7 100644
index 8e47d9d..98e6312 100644
--- a/async.cabal
+++ b/async.cabal
@@ -70,7 +70,7 @@ source-repository head
@ -16,7 +16,7 @@ index 8e47d9d..ff317c7 100644
library
exposed-modules: Control.Concurrent.Async
- build-depends: base >= 4.3 && < 4.7, stm >= 2.2 && < 2.5
+ build-depends: base >= 4.3 && < 4.8, stm >= 2.2 && < 2.5
+ build-depends: base >= 4.3 && < 4.9, stm >= 2.2 && < 2.5
test-suite test-async
type: exitcode-stdio-1.0

View file

@ -0,0 +1,26 @@
From 09bcaf4f203c39c967a6951d56fd015347bb5dae Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sat, 21 Sep 2013 21:57:21 +0000
Subject: [PATCH] fix build with newer base
---
Data/BloomFilter/Array.hs | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/Data/BloomFilter/Array.hs b/Data/BloomFilter/Array.hs
index e085bbe..d94757a 100644
--- a/Data/BloomFilter/Array.hs
+++ b/Data/BloomFilter/Array.hs
@@ -3,7 +3,8 @@
module Data.BloomFilter.Array (newArray) where
-import Control.Monad.ST (ST, unsafeIOToST)
+import Control.Monad.ST (ST)
+import Control.Monad.ST.Unsafe (unsafeIOToST)
import Data.Array.Base (MArray, STUArray(..), unsafeNewArray_)
#if __GLASGOW_HASKELL__ >= 704
import Foreign.C.Types (CInt(..), CSize(..))
--
1.7.10.4

View file

@ -1,27 +0,0 @@
From efd0e93de82c0b5554a4f3a4517e6127f405f6da Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:29:36 -0400
Subject: [PATCH] allow building with unreleased ghc
---
case-insensitive.cabal | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/case-insensitive.cabal b/case-insensitive.cabal
index a73479d..18a1a51 100644
--- a/case-insensitive.cabal
+++ b/case-insensitive.cabal
@@ -25,8 +25,8 @@ source-repository head
Library
GHC-Options: -Wall
- build-depends: base >= 3 && < 4.6
- , bytestring >= 0.9 && < 0.10
+ build-depends: base >= 3 && < 4.8
+ , bytestring >= 0.9 && < 0.15
, text >= 0.3 && < 0.12
, hashable >= 1.0 && < 1.2
exposed-modules: Data.CaseInsensitive
--
1.7.10.4

View file

@ -1,37 +0,0 @@
From 3779c75175e895f94b21341ebd6361e9d6af54fd Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 9 May 2013 12:36:23 -0400
Subject: [PATCH] support Android cert store
Android puts it in a different place and has only hashed files.
See https://github.com/vincenthz/hs-certificate/issues/19
---
System/Certificate/X509/Unix.hs | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/System/Certificate/X509/Unix.hs b/System/Certificate/X509/Unix.hs
index 8463465..74e9503 100644
--- a/System/Certificate/X509/Unix.hs
+++ b/System/Certificate/X509/Unix.hs
@@ -35,7 +35,8 @@ import qualified Control.Exception as E
import Data.Char
defaultSystemPath :: FilePath
-defaultSystemPath = "/etc/ssl/certs/"
+defaultSystemPath = "/system/etc/security/cacerts/"
+--defaultSystemPath = "/etc/ssl/certs/"
envPathOverride :: String
envPathOverride = "SYSTEM_CERTIFICATE_PATH"
@@ -47,7 +48,7 @@ listDirectoryCerts path = (map (path </>) . filter isCert <$> getDirectoryConten
&& isDigit (s !! 9)
&& (s !! 8) == '.'
&& all isHexDigit (take 8 s)
- isCert x = (not $ isPrefixOf "." x) && (not $ isHashedFile x)
+ isCert x = (not $ isPrefixOf "." x)
getSystemCertificateStore :: IO CertificateStore
getSystemCertificateStore = makeCertificateStore . concat <$> (getSystemPath >>= listDirectoryCerts >>= mapM readCertificates)
--
1.8.2.rc3

View file

@ -1,34 +0,0 @@
From d456247000ab839a1d32749717f4f8f92e37dbba Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Tue, 7 May 2013 17:45:45 -0400
Subject: [PATCH] fix cross build
---
cipher-aes.cabal | 5 +----
1 file changed, 1 insertion(+), 4 deletions(-)
diff --git a/cipher-aes.cabal b/cipher-aes.cabal
index 02ddfd0..eb916e3 100644
--- a/cipher-aes.cabal
+++ b/cipher-aes.cabal
@@ -31,16 +31,13 @@ Extra-Source-Files: Tests/*.hs
Library
Build-Depends: base >= 4 && < 5
- , bytestring
+ , bytestring >= 0.10.3.0
Exposed-modules: Crypto.Cipher.AES
ghc-options: -Wall
C-sources: cbits/aes_generic.c
cbits/aes.c
cbits/gf.c
cbits/cpu.c
- if os(linux) && (arch(i386) || arch(x86_64))
- CC-options: -mssse3 -maes -mpclmul -DWITH_AESNI
- C-sources: cbits/aes_x86ni.c
Test-Suite test-cipher-aes
type: exitcode-stdio-1.0
--
1.7.10.4

View file

@ -0,0 +1,25 @@
From 2cb43c46d345341d1aa77c4b2a88514c056d3122 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sat, 21 Sep 2013 22:25:18 +0000
Subject: [PATCH] cross build
---
comonad.cabal | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/comonad.cabal b/comonad.cabal
index e01f1a7..e807e05 100644
--- a/comonad.cabal
+++ b/comonad.cabal
@@ -13,7 +13,7 @@ copyright: Copyright (C) 2008-2013 Edward A. Kmett,
Copyright (C) 2004-2008 Dave Menendez
synopsis: Haskell 98 compatible comonads
description: Haskell 98 compatible comonads
-build-type: Custom
+build-type: Simple
extra-source-files:
.gitignore
.travis.yml
--
1.7.10.4

View file

@ -1,73 +0,0 @@
From 8459f93270c7a6e8a2ebd415db2110a66bf1ec41 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Wed, 15 May 2013 20:31:14 -0400
Subject: [PATCH] use getprop to get dns server
---
Network/DNS/Resolver.hs | 13 +++++++++++--
dns.cabal | 4 ++++
2 files changed, 15 insertions(+), 2 deletions(-)
diff --git a/Network/DNS/Resolver.hs b/Network/DNS/Resolver.hs
index 70ab9ed..9b27336 100644
--- a/Network/DNS/Resolver.hs
+++ b/Network/DNS/Resolver.hs
@@ -41,6 +41,8 @@ import Network.Socket.ByteString.Lazy
import Prelude hiding (lookup)
import System.Random
import System.Timeout
+import System.Process (readProcess)
+import System.Directory
#if mingw32_HOST_OS == 1
import Network.Socket (send)
@@ -73,7 +75,7 @@ data ResolvConf = ResolvConf {
-}
defaultResolvConf :: ResolvConf
defaultResolvConf = ResolvConf {
- resolvInfo = RCFilePath "/etc/resolv.conf"
+ resolvInfo = RCFilePath "/system/etc/resolv.conf"
, resolvTimeout = 3 * 1000 * 1000
, resolvBufsize = 512
}
@@ -111,7 +113,14 @@ makeResolvSeed conf = ResolvSeed <$> addr
where
addr = case resolvInfo conf of
RCHostName numhost -> makeAddrInfo numhost
- RCFilePath file -> toAddr <$> readFile file >>= makeAddrInfo
+ RCFilePath file -> do
+ exists <- doesFileExist file
+ if exists
+ then toAddr <$> readFile file >>= makeAddrInfo
+ else do
+ s <- readProcess "getprop" ["net.dns1"] ""
+ makeAddrInfo $ takeWhile (/= '\n') s
+
toAddr cs = let l:_ = filter ("nameserver" `isPrefixOf`) $ lines cs
in extract l
extract = reverse . dropWhile isSpace . reverse . dropWhile isSpace . drop 11
diff --git a/dns.cabal b/dns.cabal
index 40671f6..2c19734 100644
--- a/dns.cabal
+++ b/dns.cabal
@@ -34,6 +34,8 @@ library
, network >= 2.3
, network-conduit
, random
+ , process
+ , directory
else
Build-Depends: base >= 4 && < 5
, attoparsec
@@ -49,6 +51,8 @@ library
, network-bytestring
, network-conduit
, random
+ , process
+ , directory
Source-Repository head
Type: git
Location: git://github.com/kazu-yamamoto/dns.git
--
1.7.10.4

View file

@ -0,0 +1,25 @@
From 35c6718205e9d7f5e5fc44578ea6a9971beac151 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sat, 21 Sep 2013 23:32:18 +0000
Subject: [PATCH] cross build
---
entropy.cabal | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/entropy.cabal b/entropy.cabal
index 45e4705..17553d8 100644
--- a/entropy.cabal
+++ b/entropy.cabal
@@ -14,7 +14,7 @@ category: Data, Cryptography
homepage: https://github.com/TomMD/entropy
bug-reports: https://github.com/TomMD/entropy/issues
stability: stable
-build-type: Custom
+build-type: Simple
cabal-version: >= 1.6
tested-with: GHC == 6.12.1
data-files:
--
1.7.10.4

View file

@ -1,193 +0,0 @@
From 256ff157005f44c97fa5affe2ed9655815b3788e Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Mon, 15 Apr 2013 12:38:22 -0400
Subject: [PATCH] remove TH and export one symbol used by TH
---
Data/.FileEmbed.hs.swp | Bin 16384 -> 0 bytes
Data/FileEmbed.hs | 80 +++----------------------------------------------
2 files changed, 4 insertions(+), 76 deletions(-)
delete mode 100644 Data/.FileEmbed.hs.swp
diff --git a/Data/.FileEmbed.hs.swp b/Data/.FileEmbed.hs.swp
deleted file mode 100644
index 1b2ddbfaa71697e9df3869555aee8c97ca7ea0cb..0000000000000000000000000000000000000000
GIT binary patch
literal 0
HcmV?d00001
literal 16384
zcmeHNZEPGz8J?z;l0w=5RfRyn>$8>HBX?)xk`I~qq+D`I3}?sToJzq>+`YRw-^O>l
z*WKCLCgwvzNFb1);!i<T;wykkiv)sSh>r*%6;!D~AU?_ukSIa|0TNP$5Jm93GrM~q
zjuRvP0NRxw-|fsh@60^&&O0;jTz%?+xp_KLykFqiFT`)B+;d-j<zDfRmkV*(lbf7;
zt7p{>ZzZDh-@^(gRkt_UayqggyLH(tOcke!Zz&#`JZUR?@)Xi5oLp=NyHc47r3|DD
z?1q6*wF*b~iTkJDJT;yfqgTJ`{BBC6GARQo11SS311SS311SS311SS31OG=1sNNp&
zPxNOGa0R$6!tMCX1MiLA@sU0$11SS311SS311SS311SS311SS311SS311SUlqYT(h
zA*RvxX$}D3{-0w2zq&_=9|B(oJ`TJeP{1ls23`y71@-_h+%3fOz|Vo70p9>V3^ahF
zz%+0#un)Kc_}e}qegu3C_%d)6aDW-$b-)X+5aMazbHMw6w*zCq9^f|M$M{{sb>Io$
zDsTmu2a3QOfxq4*#4mxL0AB%~0z$wCs=#SrKk&!BLOct68+a6001g9(fV+S@fnUE&
zh$n$h0-pdb0VUu*;P-b5@f+Y7;Bnwnz!hK(r~;F~i!T-8@4!!iYruDb&jKF=LO=l}
z;0?g*f#>cJ;yXYO7zh6R5+S|?d;oYSa0ECE>;;}ffaVv#4}hnDCxOR-j{zSATEGS1
zUf>TH+wTKwz-8bZPyu+%$AEi)y8$7HpN>=%&@2UQZ=IZNDccep(X*R1=Uo!Qv&r|F
z8Jcqy6-rc7zT>V&%DFV2<%^snec$sb!$18fCO`ckYgMW_*Oh*5hAw!aPtCB~-K3yr
zHzc*~fa+4Z)bM;i>?!<IBqOxS=%3}}X(cza!urcaWv_9wd>JSs<)EY;NTk@!fF`JX
zv>3Y3yhZ_fP_B{J(t=EaWs>r`cn*w|i$SmBsN>)V!d0{a3W`nN>yg!w?y722*IsoR
zIjW1e6I2H&$qQI17t5PU8d6Ln`|m=;if3thDtR$n3Za#w9SzTI*ou}jEt$zvX1<oW
z80A4Srn}>`)S~V9(`4Css&o76R4UEVgY_)e>q`~-uF1^iL|+^_<~`SLQkP~+I={=s
zQKTEGGGiGjn24J*LHx6xfM%%a_<^B28kDZxn<tC2t4^S@%zkGHtQDyhsGJt%GIXrK
zI+XMw-SlK|((z?OdH!Z)1LYtdxXm2dolcf}GE@ba=Q{e`fUpEnO%Tq5&Guz#GOZk~
zit~4_h0Q@%JInQuWhu1&*kmb32M!z{>%k4fsOc5bDaxmfoNn(4&sEY@h7~A^-}^l#
z*HdSlW)ntrY@$T4n56TGuod$b)sPe1mtjh|;#q2X16deQ?%kpd`@|>?exEx_%T}C_
zAF|EdMR<`&z3$E|k4;n?*OJNf^GB+<h1z~sSJ2iaKa`@MWMzxlnH4tIQ+6j9%o(Yq
z?0Fqb80}q_yfV8i%x0d;gNZ1#(_CZYjE#7Vj`w;MYRgVf`ZO^{RYz6$(-f{!qish<
z&9<Q5OofsAsGG5k6u`Qcw`ibkTNgz=Sn?_xJ*sm{F+lM<S~%(x&JhHMXW1Ang=pZi
zX;;#$9tJf}a-)~MsHX#eW21_dqgmt9Z92xQJ$$^`JSlrffHCs0!-1{%o~P*GLCQ{M
zF?U&^7<XDUKew>*K;<2^xw8u^N_Kl4Tger;-!<9kSkw6<`KcV7z2los87-D+PCek^
zLl^t`BV)Id&9Qw(oi{T8dSa_%FN!%qBdTt0YlQ+WwVi<Qr`nR%J%6q3`B(tF7G?D>
z5TP<F3I+Vp7M<pK&i>1|9a6r;`r+!bsHn?+u{b<1RC87<BuQ=d%m^_3JSQu9B3qUp
zx+rSABd1fVm(z~ec&t80NH-n|s#wXg+PcZ?B$!m(0jM;DCkZ1Y8BWnfIPpy;ah4{m
zL^y*EFW6m~$uSGD2viLE2E9u6m#TqP44#6EnX*o|=lO~r4sEz%M>c7s9Hdxqiz@s(
z&mpowdKmc5BeJu}oNw~lAK)LB{f5_+n)igwzE@B9jBNhq1`no6rCl4irbtf|X4vqp
zUvI{*7Dx!zZ!yFAm#@QA$LdCS8sPUoVK>0m3)8&CbN$AgMgvyc3^2>}HcT%Rmc`3k
zP7G(yoh_bs1G^>33iaor^jn_aojaRIj`m|j9_|@V2ph5h`=_K3FLA!tDZ&YN9PDji
z1XyIT5cXS;h+xyWj!Z1PxqP(7Cwg`?yW$D>@1um>WBF*@ryYg0SS%ISYxYFEiQ)Z;
znW(&iY<q6BbSDjrXvP$bJj@ODIeEBF8L(aG4M|>b6}dsP&eOTj4jgNnKZn#VT{r8*
z&X#?XFyGG&*MNnFtZ4Pi^Il%AO25j@;8oca8J01^i@wvX4i&g{iw^N(!YVCZ_{ie5
zIB%RNe<-~0>X+BPHsP{ryQ`tSDvM{#s#IJ$Q><;e%HA*@I!Ehm>Bnt#+{>VxS=BY=
zF&#KzxYPQmQR9=wZiq~pO$3+rCXmD$p;&ojyI7Us(3D+IYBZJ+RUdm_{YsR08vSk=
zg^`cMe#7hbcnT}0D@E69hWM^0nzj=5q~c0poT|qcPM<%1x<V%w7iqlk?%~9xXcdp>
z(gJ+`e*))O7w26*|L5^>9q0OIfiD6d0UiM^0B;5E1O9|_{L{cS;4xqcI0Wnm{(>|7
zmw?Xzp9a=}67W3E?$?2D0$%_Kcn$C(&g|EKEnpEi415pg^Q*w;fe!&Iz!6{^xE=T%
z+WHLe7{KlB0_l@7kTQ@mkTQ@mkTQ@m@ZZS*MbFzpgaMiW!X4$}y6-5-8#zuowaEXY
zO(D^Or`kBev0xM}pL2t-)p8mRLO6q=aT5mD!ELj%<qa+cej^TP^H)R_1`f_hIkhN^
zw5~rYVcLNII*1cD8lPwdLK)W3;Rk74Rv#L%3%*2NsCpry9Pv&&D!)xG4k{VRfmYyb
zJs1!(n|Zs1V;33}#oIYfuH*9AgetCQ@LpkJ`^|!>WS92}IBf8pMleGe4v*>U5U#dd
z8>({f!okrwx^0Nk@8+Ii=#C-#?_Dw^w;EPm;t(zeFDmK?6|dF8x(Pv&6-7o7z1H^=
zp6{&cwkmJVy<FA2MmHEb1$q6m6XD@QA8E7YE00EW0TI_bq#a>o6NW|1E4~>r)#MRJ
zMs<S%zBC7Z9QQSC1tU_;QFbbuCq3#WvdOJL2+xhDgx~}mEu$Wk^qov(%qEezmx$W1
zARZXtyuDeML&nADtV`s|bt>2LC=hGcn)&p|kwa&PDJQgEt$EO3jZUuIaqSKi^9_lz
z9hWDvK4Heq9I<p$5b<H0AC0Nv(9@6J#<6O?9MBhJS$c?1$`2tJ({qyV`Zg=dz?jDA
zI%FLM82bu1%(xZ5BBIDW(h77&6yq6+*+fEI<Dg6&2a2*eNY0hd>f<{sAr2sLAk_D|
z`qc+J6D-CzXMwU2H^e;Cr|*ba{SoCH#C(s9#asr$L<aeZ%jg>#<yG9U%QsA@jlbq-
zVmD{{!*M8LFw8#`bk_k6DC6o_$TW{HhA_3Xr+|~_=du%-O(ufrT|dkaU2AGbJCF*)
k07GoDCUU!rsE!Us=xSj*161jGRmD&g5~lU!(k&JL0(zanmH+?%
diff --git a/Data/FileEmbed.hs b/Data/FileEmbed.hs
index 66f7004..f8c98c9 100644
--- a/Data/FileEmbed.hs
+++ b/Data/FileEmbed.hs
@@ -1,31 +1,15 @@
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
module Data.FileEmbed
( -- * Embed at compile time
- embedFile
- , embedDir
- , getDir
+ getDir
-- * Inject into an executable
-#if MIN_VERSION_template_haskell(2,5,0)
- , dummySpace
-#endif
, inject
, injectFile
+
+ -- used by TH (pointlessly)
+ , stringToBs
) where
-import Language.Haskell.TH.Syntax
- ( Exp (AppE, ListE, LitE, TupE, SigE)
-#if MIN_VERSION_template_haskell(2,5,0)
- , Lit (StringL, StringPrimL, IntegerL)
-#else
- , Lit (StringL, IntegerL)
-#endif
- , Q
- , runIO
-#if MIN_VERSION_template_haskell(2,7,0)
- , Quasi(qAddDependentFile)
-#endif
- )
import System.Directory (doesDirectoryExist, doesFileExist,
getDirectoryContents)
import Control.Monad (filterM)
@@ -37,51 +21,12 @@ import Data.ByteString.Unsafe (unsafePackAddressLen)
import System.IO.Unsafe (unsafePerformIO)
import System.FilePath ((</>))
--- | Embed a single file in your source code.
---
--- > import qualified Data.ByteString
--- >
--- > myFile :: Data.ByteString.ByteString
--- > myFile = $(embedFile "dirName/fileName")
-embedFile :: FilePath -> Q Exp
-embedFile fp =
-#if MIN_VERSION_template_haskell(2,7,0)
- qAddDependentFile fp >>
-#endif
- (runIO $ B.readFile fp) >>= bsToExp
-
--- | Embed a directory recusrively in your source code.
---
--- > import qualified Data.ByteString
--- >
--- > myDir :: [(FilePath, Data.ByteString.ByteString)]
--- > myDir = $(embedDir "dirName")
-embedDir :: FilePath -> Q Exp
-embedDir fp = do
- typ <- [t| [(FilePath, B.ByteString)] |]
- e <- ListE <$> ((runIO $ fileList fp) >>= mapM (pairToExp fp))
- return $ SigE e typ
-
-- | Get a directory tree in the IO monad.
--
-- This is the workhorse of 'embedDir'
getDir :: FilePath -> IO [(FilePath, B.ByteString)]
getDir = fileList
-pairToExp :: FilePath -> (FilePath, B.ByteString) -> Q Exp
-pairToExp _root (path, bs) = do
-#if MIN_VERSION_template_haskell(2,7,0)
- qAddDependentFile $ _root ++ '/' : path
-#endif
- exp' <- bsToExp bs
- return $! TupE [LitE $ StringL path, exp']
-
-bsToExp :: B.ByteString -> Q Exp
-bsToExp bs = do
- helper <- [| stringToBs |]
- let chars = B8.unpack bs
- return $! AppE helper $! LitE $! StringL chars
-
stringToBs :: String -> B.ByteString
stringToBs = B8.pack
@@ -123,23 +68,6 @@ padSize i =
let s = show i
in replicate (sizeLen - length s) '0' ++ s
-#if MIN_VERSION_template_haskell(2,5,0)
-dummySpace :: Int -> Q Exp
-dummySpace space = do
- let size = padSize space
- let start = magic ++ size
- let chars = LitE $ StringPrimL $
-#if MIN_VERSION_template_haskell(2,6,0)
- map (toEnum . fromEnum) $
-#endif
- start ++ replicate space '0'
- let len = LitE $ IntegerL $ fromIntegral $ length start + space
- upi <- [|unsafePerformIO|]
- pack <- [|unsafePackAddressLen|]
- getInner' <- [|getInner|]
- return $ getInner' `AppE` (upi `AppE` (pack `AppE` len `AppE` chars))
-#endif
-
inject :: B.ByteString -- ^ bs to inject
-> B.ByteString -- ^ original BS containing dummy
-> Maybe B.ByteString -- ^ new BS, or Nothing if there is insufficient dummy space
--
1.8.2.rc3

View file

@ -0,0 +1,25 @@
From fdbd29ce6e8ff11f721f9e74cac1f4ca14e6773d Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 07:06:33 +0000
Subject: [PATCH] export TH symbols
---
Data/FileEmbed.hs | 2 ++
1 file changed, 2 insertions(+)
diff --git a/Data/FileEmbed.hs b/Data/FileEmbed.hs
index c17f082..6654f60 100644
--- a/Data/FileEmbed.hs
+++ b/Data/FileEmbed.hs
@@ -26,6 +26,8 @@ module Data.FileEmbed
#endif
, inject
, injectFile
+ -- used by TH (pointlessly)
+ , stringToBs
) where
import Language.Haskell.TH.Syntax
--
1.7.10.4

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

View file

@ -1,23 +0,0 @@
From 643b3c9fd95967c5911107f46498cd851e68f97d Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Tue, 7 May 2013 18:26:33 -0400
Subject: [PATCH] fix build
---
hS3.cabal | 3 ---
1 file changed, 3 deletions(-)
diff --git a/hS3.cabal b/hS3.cabal
index 35f7496..e04bf65 100644
--- a/hS3.cabal
+++ b/hS3.cabal
@@ -44,6 +44,3 @@ Library
Network.AWS.AWSConnection,
Network.AWS.Authentication,
Network.AWS.ArrowUtils
-
-Executable hs3
- main-is: hS3.hs
--
1.7.10.4

View file

@ -1,294 +0,0 @@
From b2c677ed39f1aca3a1111691ba51b26f7fd414a4 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Wed, 8 May 2013 01:50:58 -0400
Subject: [PATCH] remove TH
---
Text/Hamlet.hs | 219 ++------------------------------------------------------
hamlet.cabal | 2 +-
2 files changed, 7 insertions(+), 214 deletions(-)
diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs
index 4ac870a..63b8555 100644
--- a/Text/Hamlet.hs
+++ b/Text/Hamlet.hs
@@ -11,35 +11,26 @@
module Text.Hamlet
( -- * Plain HTML
Html
- , shamlet
- , shamletFile
- , xshamlet
- , xshamletFile
-- * Hamlet
, HtmlUrl
- , hamlet
- , hamletFile
- , xhamlet
- , xhamletFile
-- * I18N Hamlet
, HtmlUrlI18n
- , ihamlet
- , ihamletFile
-- * Type classes
, ToAttributes (..)
-- * Internal, for making more
, HamletSettings (..)
, NewlineStyle (..)
- , hamletWithSettings
- , hamletFileWithSettings
, defaultHamletSettings
, xhtmlHamletSettings
, Env (..)
, HamletRules (..)
- , hamletRules
- , ihamletRules
- , htmlRules
, CloseStyle (..)
+ , condH
+ , maybeH
+
+ -- referred to in TH splices
+ , attrsToHtml
+ , asHtmlUrl
) where
import Text.Shakespeare.Base
@@ -90,14 +81,6 @@ 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
@@ -159,169 +142,9 @@ recordToFieldNames conStr = do
[fields] <- return [fields | RecC name fields <- cons, name == conName]
return [fieldName | (fieldName, _, _) <- fields]
-docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp
-docToExp env hr scope (DocForall list idents inside) = do
- let list' = derefToExp scope list
- (pat, extraScope) <- bindingPattern idents
- let scope' = extraScope ++ scope
- mh <- [|F.mapM_|]
- inside' <- docsToExp env hr scope' inside
- let lam = LamE [pat] inside'
- return $ mh `AppE` lam `AppE` list'
-docToExp env hr scope (DocWith [] inside) = do
- inside' <- docsToExp env hr scope inside
- return $ inside'
-docToExp env hr scope (DocWith ((deref, idents):dis) inside) = do
- let deref' = derefToExp scope deref
- (pat, extraScope) <- bindingPattern idents
- let scope' = extraScope ++ scope
- inside' <- docToExp env hr scope' (DocWith dis inside)
- let lam = LamE [pat] inside'
- return $ lam `AppE` deref'
-docToExp env hr scope (DocMaybe val idents inside mno) = do
- let val' = derefToExp scope val
- (pat, extraScope) <- bindingPattern idents
- let scope' = extraScope ++ scope
- inside' <- docsToExp env hr scope' inside
- let inside'' = LamE [pat] inside'
- ninside' <- case mno of
- Nothing -> [|Nothing|]
- Just no -> do
- no' <- docsToExp env hr scope no
- j <- [|Just|]
- return $ j `AppE` no'
- mh <- [|maybeH|]
- return $ mh `AppE` val' `AppE` inside'' `AppE` ninside'
-docToExp env hr scope (DocCond conds final) = do
- conds' <- mapM go conds
- final' <- case final of
- Nothing -> [|Nothing|]
- Just f -> do
- f' <- docsToExp env hr scope f
- j <- [|Just|]
- return $ j `AppE` f'
- ch <- [|condH|]
- return $ ch `AppE` ListE conds' `AppE` final'
- where
- go :: (Deref, [Doc]) -> Q Exp
- go (d, docs) = do
- let d' = derefToExp scope d
- docs' <- docsToExp env hr scope docs
- return $ TupE [d', docs']
-docToExp env hr scope (DocCase deref cases) = do
- let exp_ = derefToExp scope deref
- matches <- mapM toMatch cases
- return $ CaseE exp_ matches
- where
- readMay s =
- case reads s of
- (x, ""):_ -> Just x
- _ -> Nothing
- toMatch (idents, inside) = do
- let pat = case map unIdent idents of
- ["_"] -> WildP
- [str]
- | Just i <- readMay str -> LitP $ IntegerL i
- strs -> let (constr:fields) = map mkName strs
- in ConP constr (map VarP fields)
- insideExp <- docsToExp env hr scope inside
- return $ Match pat (NormalB insideExp) []
-docToExp env hr v (DocContent c) = contentToExp env hr v c
-
-contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp
-contentToExp _ hr _ (ContentRaw s) = do
- os <- [|preEscapedText . pack|]
- let s' = LitE $ StringL s
- return $ hrFromHtml hr `AppE` (os `AppE` s')
-contentToExp _ hr scope (ContentVar d) = do
- str <- [|toHtml|]
- return $ hrFromHtml hr `AppE` (str `AppE` derefToExp scope d)
-contentToExp env hr scope (ContentUrl hasParams d) =
- case urlRender env of
- Nothing -> error "URL interpolation used, but no URL renderer provided"
- Just wrender -> wrender $ \render -> do
- let render' = return render
- ou <- if hasParams
- then [|\(u, p) -> $(render') u p|]
- else [|\u -> $(render') u []|]
- let d' = derefToExp scope d
- pet <- [|toHtml|]
- return $ hrFromHtml hr `AppE` (pet `AppE` (ou `AppE` d'))
-contentToExp env hr scope (ContentEmbed d) = hrEmbed hr env $ derefToExp scope d
-contentToExp env hr scope (ContentMsg d) =
- case msgRender env of
- Nothing -> error "Message interpolation used, but no message renderer provided"
- Just wrender -> wrender $ \render ->
- return $ hrFromHtml hr `AppE` (render `AppE` derefToExp scope d)
-contentToExp _ hr scope (ContentAttrs d) = do
- html <- [|attrsToHtml . toAttributes|]
- return $ hrFromHtml hr `AppE` (html `AppE` derefToExp scope d)
-
-shamlet :: QuasiQuoter
-shamlet = hamletWithSettings htmlRules defaultHamletSettings
-
-xshamlet :: QuasiQuoter
-xshamlet = hamletWithSettings htmlRules xhtmlHamletSettings
-
-htmlRules :: Q HamletRules
-htmlRules = do
- i <- [|id|]
- return $ HamletRules i ($ (Env Nothing Nothing)) (\_ b -> return b)
-
-hamlet :: QuasiQuoter
-hamlet = hamletWithSettings hamletRules defaultHamletSettings
-
-xhamlet :: QuasiQuoter
-xhamlet = hamletWithSettings hamletRules xhtmlHamletSettings
-
asHtmlUrl :: HtmlUrl url -> HtmlUrl url
asHtmlUrl = id
-hamletRules :: Q HamletRules
-hamletRules = do
- i <- [|id|]
- let ur f = do
- r <- newName "_render"
- let env = Env
- { urlRender = Just ($ (VarE r))
- , msgRender = Nothing
- }
- h <- f env
- return $ LamE [VarP r] h
- return $ HamletRules i ur em
- where
- em (Env (Just urender) Nothing) e = do
- asHtmlUrl' <- [|asHtmlUrl|]
- urender $ \ur' -> return ((asHtmlUrl' `AppE` e) `AppE` ur')
- em _ _ = error "bad Env"
-
-ihamlet :: QuasiQuoter
-ihamlet = hamletWithSettings ihamletRules defaultHamletSettings
-
-ihamletRules :: Q HamletRules
-ihamletRules = do
- i <- [|id|]
- let ur f = do
- u <- newName "_urender"
- m <- newName "_mrender"
- let env = Env
- { urlRender = Just ($ (VarE u))
- , msgRender = Just ($ (VarE m))
- }
- h <- f env
- return $ LamE [VarP m, VarP u] h
- return $ HamletRules i ur em
- where
- em (Env (Just urender) (Just mrender)) e =
- urender $ \ur' -> mrender $ \mr -> return (e `AppE` mr `AppE` ur')
- em _ _ = error "bad Env"
-
-hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter
-hamletWithSettings hr set =
- QuasiQuoter
- { quoteExp = hamletFromString hr set
- }
-
data HamletRules = HamletRules
{ hrFromHtml :: Exp
, hrWithEnv :: (Env -> Q Exp) -> Q Exp
@@ -333,36 +156,6 @@ data Env = Env
, msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
}
-hamletFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp
-hamletFromString qhr set s = do
- hr <- qhr
- case parseDoc set s of
- Error s' -> error s'
- Ok (_mnl, d) -> hrWithEnv hr $ \env -> docsToExp env hr [] d
-
-hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp
-hamletFileWithSettings qhr set fp = do
-#ifdef GHC_7_4
- qAddDependentFile fp
-#endif
- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
- hamletFromString qhr set contents
-
-hamletFile :: FilePath -> Q Exp
-hamletFile = hamletFileWithSettings hamletRules defaultHamletSettings
-
-xhamletFile :: FilePath -> Q Exp
-xhamletFile = hamletFileWithSettings hamletRules xhtmlHamletSettings
-
-shamletFile :: FilePath -> Q Exp
-shamletFile = hamletFileWithSettings htmlRules defaultHamletSettings
-
-xshamletFile :: FilePath -> Q Exp
-xshamletFile = hamletFileWithSettings htmlRules xhtmlHamletSettings
-
-ihamletFile :: FilePath -> Q Exp
-ihamletFile = hamletFileWithSettings ihamletRules defaultHamletSettings
-
varName :: Scope -> String -> Exp
varName _ "" = error "Illegal empty varName"
varName scope v@(_:_) = fromMaybe (strToExp v) $ lookup (Ident v) scope
diff --git a/hamlet.cabal b/hamlet.cabal
index 73fa6a8..4348508 100644
--- a/hamlet.cabal
+++ b/hamlet.cabal
@@ -50,7 +50,7 @@ library
, text >= 0.7 && < 0.12
, containers >= 0.2
, blaze-builder >= 0.2 && < 0.4
- , process >= 1.0 && < 1.2
+ , process >= 1.0 && < 1.3
, blaze-html >= 0.5 && < 0.6
, blaze-markup >= 0.5.1 && < 0.6
--
1.7.10.4

View file

@ -0,0 +1,28 @@
From 9819f4b387679c889f1259f9fd969513aa2efcf2 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 03:51:06 +0000
Subject: [PATCH] export TH splice stuff
---
Text/Hamlet.hs | 5 +++++
1 file changed, 5 insertions(+)
diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs
index 6568d6c..687dec4 100644
--- a/Text/Hamlet.hs
+++ b/Text/Hamlet.hs
@@ -40,6 +40,11 @@ module Text.Hamlet
, ihamletRules
, htmlRules
, CloseStyle (..)
+ -- referred to by TH splices
+ , asHtmlUrl
+ , maybeH
+ , condH
+ , attrsToHtml
) where
import Text.Shakespeare.Base
--
1.7.10.4

View file

@ -1,27 +1,30 @@
From bbb49942123f06a36b170966e445692297f71d26 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 18 Apr 2013 19:14:30 -0400
Subject: [PATCH] build without TH
From 3141355f14d6acb9382bebcf8723c411be5aa62f Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 00:31:39 +0000
Subject: [PATCH] various hacking to cross build
---
lens.cabal | 13 +------------
src/Control/Exception/Lens.hs | 2 +-
src/Control/Lens.hs | 6 +++---
src/Control/Lens/Equality.hs | 4 ++--
src/Control/Lens/Fold.hs | 6 +++---
src/Control/Lens/Internal.hs | 2 +-
src/Control/Lens/Internal/Zipper.hs | 2 +-
src/Control/Lens/Iso.hs | 2 --
src/Control/Lens/Lens.hs | 2 +-
src/Control/Lens/Operators.hs | 2 +-
src/Control/Lens/Plated.hs | 2 +-
src/Control/Lens/Setter.hs | 2 --
src/Control/Lens/TH.hs | 2 +-
src/Data/Data/Lens.hs | 6 +++---
14 files changed, 19 insertions(+), 34 deletions(-)
lens.cabal | 12 +-----------
src/Control/Exception/Lens.hs | 2 +-
src/Control/Lens.hs | 6 +++---
src/Control/Lens/Equality.hs | 4 ++--
src/Control/Lens/Fold.hs | 6 +++---
src/Control/Lens/Internal.hs | 2 +-
src/Control/Lens/Internal/Exception.hs | 26 +-------------------------
src/Control/Lens/Internal/Instances.hs | 14 --------------
src/Control/Lens/Internal/Zipper.hs | 2 +-
src/Control/Lens/Iso.hs | 2 --
src/Control/Lens/Lens.hs | 2 +-
src/Control/Lens/Operators.hs | 2 +-
src/Control/Lens/Plated.hs | 2 +-
src/Control/Lens/Prism.hs | 2 --
src/Control/Lens/Setter.hs | 2 --
src/Control/Lens/TH.hs | 2 +-
src/Data/Data/Lens.hs | 6 +++---
17 files changed, 20 insertions(+), 74 deletions(-)
diff --git a/lens.cabal b/lens.cabal
index a06b3ce..a654b3d 100644
index 2a94e1e..1f9a4b7 100644
--- a/lens.cabal
+++ b/lens.cabal
@@ -10,7 +10,7 @@ stability: provisional
@ -33,15 +36,7 @@ index a06b3ce..a654b3d 100644
tested-with: GHC == 7.0.4, GHC == 7.4.1, GHC == 7.4.2, GHC == 7.6.1, GHC == 7.7.20121213, GHC == 7.7.20130117
synopsis: Lenses, Folds and Traversals
description:
@@ -171,7 +171,6 @@ library
containers >= 0.4.0 && < 0.6,
distributive >= 0.3 && < 1,
filepath >= 1.2.0.0 && < 1.4,
- generic-deriving == 1.4.*,
ghc-prim,
hashable >= 1.1.2.3 && < 1.3,
MonadCatchIO-transformers >= 0.3 && < 0.4,
@@ -233,14 +232,12 @@ library
@@ -238,14 +238,12 @@ library
Control.Lens.Review
Control.Lens.Setter
Control.Lens.Simple
@ -56,7 +51,7 @@ index a06b3ce..a654b3d 100644
Control.Parallel.Strategies.Lens
Control.Seq.Lens
Data.Array.Lens
@@ -264,12 +261,8 @@ library
@@ -269,12 +267,8 @@ library
Data.Typeable.Lens
Data.Vector.Lens
Data.Vector.Generic.Lens
@ -69,7 +64,7 @@ index a06b3ce..a654b3d 100644
Numeric.Lens
if flag(safe)
@@ -368,7 +361,6 @@ test-suite doctests
@@ -373,7 +367,6 @@ test-suite doctests
deepseq,
doctest >= 0.9.1,
filepath,
@ -77,7 +72,7 @@ index a06b3ce..a654b3d 100644
mtl,
nats,
parallel,
@@ -394,7 +386,6 @@ benchmark plated
@@ -399,7 +392,6 @@ benchmark plated
comonad,
criterion,
deepseq,
@ -85,7 +80,7 @@ index a06b3ce..a654b3d 100644
lens,
transformers
@@ -429,7 +420,6 @@ benchmark unsafe
@@ -434,7 +426,6 @@ benchmark unsafe
comonads-fd,
criterion,
deepseq,
@ -93,7 +88,7 @@ index a06b3ce..a654b3d 100644
lens,
transformers
@@ -446,6 +436,5 @@ benchmark zipper
@@ -451,6 +442,5 @@ benchmark zipper
comonads-fd,
criterion,
deepseq,
@ -101,7 +96,7 @@ index a06b3ce..a654b3d 100644
lens,
transformers
diff --git a/src/Control/Exception/Lens.hs b/src/Control/Exception/Lens.hs
index 5c26d4e..9909132 100644
index 4bc3926..28f55be 100644
--- a/src/Control/Exception/Lens.hs
+++ b/src/Control/Exception/Lens.hs
@@ -112,7 +112,7 @@ import Prelude
@ -114,7 +109,7 @@ index 5c26d4e..9909132 100644
-- $setup
-- >>> :set -XNoOverloadedStrings
diff --git a/src/Control/Lens.hs b/src/Control/Lens.hs
index 8481e44..74700ae 100644
index 242c3c1..2ab9cdb 100644
--- a/src/Control/Lens.hs
+++ b/src/Control/Lens.hs
@@ -59,7 +59,7 @@ module Control.Lens
@ -157,10 +152,10 @@ index 982c2d7..3a3fe1a 100644
-- $setup
-- >>> import Control.Lens
diff --git a/src/Control/Lens/Fold.hs b/src/Control/Lens/Fold.hs
index ae5100d..467eb37 100644
index 32a4073..cc7da1e 100644
--- a/src/Control/Lens/Fold.hs
+++ b/src/Control/Lens/Fold.hs
@@ -161,9 +161,9 @@ import Data.Traversable
@@ -163,9 +163,9 @@ import Data.Traversable
-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g
-- >>> let timingOut :: NFData a => a -> IO a; timingOut = fmap (fromMaybe (error "timeout")) . timeout (5*10^6) . evaluate . force
@ -183,6 +178,90 @@ index 295662e..539642d 100644
-{-# ANN module "HLint: ignore Use import/export shortcut" #-}
+
diff --git a/src/Control/Lens/Internal/Exception.hs b/src/Control/Lens/Internal/Exception.hs
index 387203e..8bea89b 100644
--- a/src/Control/Lens/Internal/Exception.hs
+++ b/src/Control/Lens/Internal/Exception.hs
@@ -36,6 +36,7 @@ import Data.Monoid
import Data.Proxy
import Data.Reflection
import Data.Typeable
+import Data.Typeable
import System.IO.Unsafe
------------------------------------------------------------------------------
@@ -128,18 +129,6 @@ class Handleable e (m :: * -> *) (h :: * -> *) | h -> e m where
handler_ l = handler l . const
{-# INLINE handler_ #-}
-instance Handleable SomeException IO Exception.Handler where
- handler = handlerIO
-
-instance Handleable SomeException m (CatchIO.Handler m) where
- handler = handlerCatchIO
-
-handlerIO :: forall a r. Getting (First a) SomeException a -> (a -> IO r) -> Exception.Handler r
-handlerIO l f = reify (preview l) $ \ (_ :: Proxy s) -> Exception.Handler (\(Handling a :: Handling a s IO) -> f a)
-
-handlerCatchIO :: forall m a r. Getting (First a) SomeException a -> (a -> m r) -> CatchIO.Handler m r
-handlerCatchIO l f = reify (preview l) $ \ (_ :: Proxy s) -> CatchIO.Handler (\(Handling a :: Handling a s m) -> f a)
-
------------------------------------------------------------------------------
-- Helpers
------------------------------------------------------------------------------
@@ -159,21 +148,8 @@ supply = unsafePerformIO $ newIORef 0
-- | This permits the construction of an \"impossible\" 'Control.Exception.Handler' that matches only if some function does.
newtype Handling a s (m :: * -> *) = Handling a
--- the m parameter exists simply to break the Typeable1 pattern, so we can provide this without overlap.
--- here we simply generate a fresh TypeRep so we'll fail to compare as equal to any other TypeRep.
-instance Typeable (Handling a s m) where
- typeOf _ = unsafePerformIO $ do
- i <- atomicModifyIORef supply $ \a -> let a' = a + 1 in a' `seq` (a', a)
- return $ mkTyConApp (mkTyCon3 "lens" "Control.Lens.Internal.Exception" ("Handling" ++ show i)) []
- {-# INLINE typeOf #-}
-
-- The @Handling@ wrapper is uninteresting, and should never be thrown, so you won't get much benefit here.
instance Show (Handling a s m) where
showsPrec d _ = showParen (d > 10) $ showString "Handling ..."
{-# INLINE showsPrec #-}
-instance Reifies s (SomeException -> Maybe a) => Exception (Handling a s m) where
- toException _ = SomeException HandlingException
- {-# INLINE toException #-}
- fromException = fmap Handling . reflect (Proxy :: Proxy s)
- {-# INLINE fromException #-}
diff --git a/src/Control/Lens/Internal/Instances.hs b/src/Control/Lens/Internal/Instances.hs
index 6783f33..17715ce 100644
--- a/src/Control/Lens/Internal/Instances.hs
+++ b/src/Control/Lens/Internal/Instances.hs
@@ -24,26 +24,12 @@ import Data.Traversable
-- Orphan Instances
-------------------------------------------------------------------------------
-instance Foldable ((,) b) where
- foldMap f (_, a) = f a
-
instance Foldable1 ((,) b) where
foldMap1 f (_, a) = f a
-instance Traversable ((,) b) where
- traverse f (b, a) = (,) b <$> f a
-
instance Traversable1 ((,) b) where
traverse1 f (b, a) = (,) b <$> f a
-instance Foldable (Either a) where
- foldMap _ (Left _) = mempty
- foldMap f (Right a) = f a
-
-instance Traversable (Either a) where
- traverse _ (Left b) = pure (Left b)
- traverse f (Right a) = Right <$> f a
-
instance Foldable (Const m) where
foldMap _ _ = mempty
diff --git a/src/Control/Lens/Internal/Zipper.hs b/src/Control/Lens/Internal/Zipper.hs
index 95875b7..76060be 100644
--- a/src/Control/Lens/Internal/Zipper.hs
@ -197,12 +276,12 @@ index 95875b7..76060be 100644
------------------------------------------------------------------------------
-- * Jacket
diff --git a/src/Control/Lens/Iso.hs b/src/Control/Lens/Iso.hs
index 62d40ef..235511a 100644
index 1152af4..80c3175 100644
--- a/src/Control/Lens/Iso.hs
+++ b/src/Control/Lens/Iso.hs
@@ -70,8 +70,6 @@ import Data.Profunctor.Unsafe
import Unsafe.Coerce
#endif
@@ -82,8 +82,6 @@ import Data.Maybe
import Data.Profunctor
import Data.Profunctor.Unsafe
-{-# ANN module "HLint: ignore Use on" #-}
-
@ -210,12 +289,12 @@ index 62d40ef..235511a 100644
-- >>> :set -XNoOverloadedStrings
-- >>> import Control.Lens
diff --git a/src/Control/Lens/Lens.hs b/src/Control/Lens/Lens.hs
index ff2a45f..5401ec4 100644
index b26cc06..6f84943 100644
--- a/src/Control/Lens/Lens.hs
+++ b/src/Control/Lens/Lens.hs
@@ -120,7 +120,7 @@ import Data.Profunctor
import Data.Profunctor.Rep
@@ -126,7 +126,7 @@ import Data.Profunctor.Rep
import Data.Profunctor.Unsafe
import Data.Void
-{-# ANN module "HLint: ignore Use ***" #-}
+
@ -223,17 +302,17 @@ index ff2a45f..5401ec4 100644
-- $setup
-- >>> :set -XNoOverloadedStrings
diff --git a/src/Control/Lens/Operators.hs b/src/Control/Lens/Operators.hs
index d88cb49..fa7b37e 100644
index 11868e0..475c945 100644
--- a/src/Control/Lens/Operators.hs
+++ b/src/Control/Lens/Operators.hs
@@ -107,4 +107,4 @@ import Control.Lens.Review
@@ -108,4 +108,4 @@ import Control.Lens.Review
import Control.Lens.Setter
import Control.Lens.Zipper
-{-# ANN module "HLint: ignore Use import/export shortcut" #-}
+
diff --git a/src/Control/Lens/Plated.hs b/src/Control/Lens/Plated.hs
index 07d9212..27070c0 100644
index a8c4d20..cef574e 100644
--- a/src/Control/Lens/Plated.hs
+++ b/src/Control/Lens/Plated.hs
@@ -95,7 +95,7 @@ import Data.Data.Lens
@ -245,6 +324,19 @@ index 07d9212..27070c0 100644
-- | A 'Plated' type is one where we know how to extract its immediate self-similar children.
--
diff --git a/src/Control/Lens/Prism.hs b/src/Control/Lens/Prism.hs
index 45b5cfe..88c7ff9 100644
--- a/src/Control/Lens/Prism.hs
+++ b/src/Control/Lens/Prism.hs
@@ -53,8 +53,6 @@ import Unsafe.Coerce
import Data.Profunctor.Unsafe
#endif
-{-# ANN module "HLint: ignore Use camelCase" #-}
-
-- $setup
-- >>> :set -XNoOverloadedStrings
-- >>> import Control.Lens
diff --git a/src/Control/Lens/Setter.hs b/src/Control/Lens/Setter.hs
index 2acbfa6..4a12c6b 100644
--- a/src/Control/Lens/Setter.hs
@ -259,7 +351,7 @@ index 2acbfa6..4a12c6b 100644
-- >>> import Control.Lens
-- >>> import Control.Monad.State
diff --git a/src/Control/Lens/TH.hs b/src/Control/Lens/TH.hs
index fbf4adb..ee723d7 100644
index a05eb07..49218b5 100644
--- a/src/Control/Lens/TH.hs
+++ b/src/Control/Lens/TH.hs
@@ -87,7 +87,7 @@ import Language.Haskell.TH
@ -289,5 +381,5 @@ index cf1e7c9..b39dacf 100644
-- $setup
-- >>> :set -XNoOverloadedStrings
--
1.8.2.rc3
1.7.10.4

View file

@ -1,27 +0,0 @@
From 9d53e3fa4516a948a6e84987e9c1c9fd07f973bf Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Sun, 21 Apr 2013 15:44:51 -0400
Subject: [PATCH] static link with libxml2
This requires libxml2.a (and no .so) be installed in the ugly hardcoded
lib dir. When built this way, the haskell library will link the
C library into executables with no further options.
---
libxml-sax.cabal | 1 +
1 file changed, 1 insertion(+)
diff --git a/libxml-sax.cabal b/libxml-sax.cabal
index 5edfdb6..338bc55 100644
--- a/libxml-sax.cabal
+++ b/libxml-sax.cabal
@@ -31,6 +31,7 @@ library
hs-source-dirs: lib
ghc-options: -Wall -O2
cc-options: -Wall
+ LD-Options: -L /home/joey/.ghc/android-14/arm-linux-androideabi-4.7/arm-linux-androideabi/sysroot/usr/lib/
build-depends:
base >= 4.1 && < 5.0
--
1.7.10.4

View file

@ -1,163 +0,0 @@
From 4bb0de1e6213ec925820c8b9cc3ff5f3c3c72d7a Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:31:27 -0400
Subject: [PATCH] hacked for newer ghc
---
Control/Concurrent/Lifted.hs | 2 +-
Control/Exception/Lifted.hs | 11 ++--------
Setup.hs | 46 ++----------------------------------------
lifted-base.cabal | 9 ++++-----
4 files changed, 9 insertions(+), 59 deletions(-)
diff --git a/Control/Concurrent/Lifted.hs b/Control/Concurrent/Lifted.hs
index 4bc58a8..e4445e6 100644
--- a/Control/Concurrent/Lifted.hs
+++ b/Control/Concurrent/Lifted.hs
@@ -124,7 +124,7 @@ import Control.Concurrent.SampleVar.Lifted
#endif
import Control.Exception.Lifted ( throwTo
#if MIN_VERSION_base(4,6,0)
- , SomeException, try, mask
+ , SomeException, try
#endif
)
#include "inlinable.h"
diff --git a/Control/Exception/Lifted.hs b/Control/Exception/Lifted.hs
index 871cda7..0b9d8b7 100644
--- a/Control/Exception/Lifted.hs
+++ b/Control/Exception/Lifted.hs
@@ -50,8 +50,8 @@ module Control.Exception.Lifted
-- |The following functions allow a thread to control delivery of
-- asynchronous exceptions during a critical region.
#if MIN_VERSION_base(4,3,0)
- , mask, mask_
- , uninterruptibleMask, uninterruptibleMask_
+ , mask_
+ , uninterruptibleMask_
, getMaskingState
#if MIN_VERSION_base(4,4,0)
, allowInterrupt
@@ -266,10 +266,6 @@ evaluate = liftBase ∘ E.evaluate
--------------------------------------------------------------------------------
#if MIN_VERSION_base(4,3,0)
--- |Generalized version of 'E.mask'.
-mask ∷ MonadBaseControl IO m ⇒ ((∀ a. m a → m a) → m b) → m b
-mask = liftBaseOp E.mask ∘ liftRestore
-{-# INLINABLE mask #-}
liftRestore ∷ MonadBaseControl IO m
⇒ ((∀ a. m a → m a) → b)
@@ -283,9 +279,6 @@ mask_ = liftBaseOp_ E.mask_
{-# INLINABLE mask_ #-}
-- |Generalized version of 'E.uninterruptibleMask'.
-uninterruptibleMask ∷ MonadBaseControl IO m ⇒ ((∀ a. m a → m a) → m b) → m b
-uninterruptibleMask = liftBaseOp E.uninterruptibleMask ∘ liftRestore
-{-# INLINABLE uninterruptibleMask #-}
-- |Generalized version of 'E.uninterruptibleMask_'.
uninterruptibleMask_ ∷ MonadBaseControl IO m ⇒ m a → m a
diff --git a/Setup.hs b/Setup.hs
index 33956e1..9a994af 100644
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,44 +1,2 @@
-#! /usr/bin/env runhaskell
-
-{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-}
-
-module Main (main) where
-
-
--------------------------------------------------------------------------------
--- Imports
--------------------------------------------------------------------------------
-
--- from base
-import System.IO ( IO )
-
--- from cabal
-import Distribution.Simple ( defaultMainWithHooks
- , simpleUserHooks
- , UserHooks(haddockHook)
- )
-
-import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
-import Distribution.Simple.Program ( userSpecifyArgs )
-import Distribution.Simple.Setup ( HaddockFlags )
-import Distribution.PackageDescription ( PackageDescription(..) )
-
-
--------------------------------------------------------------------------------
--- Cabal setup program which sets the CPP define '__HADDOCK __' when haddock is run.
--------------------------------------------------------------------------------
-
-main ∷ IO ()
-main = defaultMainWithHooks hooks
- where
- hooks = simpleUserHooks { haddockHook = haddockHook' }
-
--- Define __HADDOCK__ for CPP when running haddock.
-haddockHook' ∷ PackageDescription → LocalBuildInfo → UserHooks → HaddockFlags → IO ()
-haddockHook' pkg lbi =
- haddockHook simpleUserHooks pkg (lbi { withPrograms = p })
- where
- p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi)
-
-
--- The End ---------------------------------------------------------------------
+import Distribution.Simple
+main = defaultMain
diff --git a/lifted-base.cabal b/lifted-base.cabal
index 54ef418..8da5086 100644
--- a/lifted-base.cabal
+++ b/lifted-base.cabal
@@ -9,7 +9,7 @@ Copyright: (c) 2011-2012 Bas van Dijk, Anders Kaseorg
Homepage: https://github.com/basvandijk/lifted-base
Bug-reports: https://github.com/basvandijk/lifted-base/issues
Category: Control
-Build-type: Custom
+Build-type: Simple
Cabal-version: >= 1.9.2
Description: @lifted-base@ exports IO operations from the base library lifted to
any instance of 'MonadBase' or 'MonadBaseControl'.
@@ -37,7 +37,6 @@ Library
Exposed-modules: Control.Exception.Lifted
Control.Concurrent.MVar.Lifted
Control.Concurrent.Chan.Lifted
- Control.Concurrent.Lifted
Data.IORef.Lifted
System.Timeout.Lifted
if impl(ghc < 7.6)
@@ -46,7 +45,7 @@ Library
Control.Concurrent.QSemN.Lifted
Control.Concurrent.SampleVar.Lifted
- Build-depends: base >= 3 && < 4.7
+ Build-depends: base >= 3 && < 4.8
, base-unicode-symbols >= 0.1.1 && < 0.3
, transformers-base >= 0.4 && < 0.5
, monad-control >= 0.3 && < 0.4
@@ -64,7 +63,7 @@ test-suite test-lifted-base
hs-source-dirs: test
build-depends: lifted-base
- , base >= 3 && < 4.7
+ , base >= 3 && < 4.8
, transformers >= 0.2 && < 0.4
, transformers-base >= 0.4 && < 0.5
, monad-control >= 0.3 && < 0.4
@@ -87,7 +86,7 @@ benchmark bench-lifted-base
ghc-options: -O2
build-depends: lifted-base
- , base >= 3 && < 4.7
+ , base >= 3 && < 4.8
, transformers >= 0.2 && < 0.4
, criterion >= 0.5 && < 0.7
, monad-control >= 0.3 && < 0.4
--
1.7.10.4

View file

@ -0,0 +1,25 @@
From 8a98fa29048b508c64d5bb1e03ef89bfad8adc01 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sat, 21 Sep 2013 21:34:17 +0000
Subject: [PATCH] crossbuild
---
lifted-base.cabal | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/lifted-base.cabal b/lifted-base.cabal
index 24f2860..3bef225 100644
--- a/lifted-base.cabal
+++ b/lifted-base.cabal
@@ -9,7 +9,7 @@ Copyright: (c) 2011-2012 Bas van Dijk, Anders Kaseorg
Homepage: https://github.com/basvandijk/lifted-base
Bug-reports: https://github.com/basvandijk/lifted-base/issues
Category: Control
-Build-type: Custom
+Build-type: Simple
Cabal-version: >= 1.8
Description: @lifted-base@ exports IO operations from the base library lifted to
any instance of 'MonadBase' or 'MonadBaseControl'.
--
1.7.10.4

View file

@ -1,25 +0,0 @@
From 3dde0175096903207c9774d8f6bba9b81ab6c2f9 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:31:45 -0400
Subject: [PATCH] build with newer ghc
---
monad-control.cabal | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/monad-control.cabal b/monad-control.cabal
index 2e3eb46..b12ffaf 100644
--- a/monad-control.cabal
+++ b/monad-control.cabal
@@ -56,7 +56,7 @@ Library
Exposed-modules: Control.Monad.Trans.Control
- Build-depends: base >= 3 && < 4.7
+ Build-depends: base >= 3 && < 4.8
, base-unicode-symbols >= 0.1.1 && < 0.3
, transformers >= 0.2 && < 0.4
, transformers-base >= 0.4.1 && < 0.5
--
1.7.10.4

View file

@ -1,124 +0,0 @@
From ca88563e63cc31f0b96b00d3a4fe1f0c56b1e1eb Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:32:01 -0400
Subject: [PATCH] remove TH logging stuff
---
Control/Monad/Logger.hs | 76 -----------------------------------------------
monad-logger.cabal | 2 +-
2 files changed, 1 insertion(+), 77 deletions(-)
diff --git a/Control/Monad/Logger.hs b/Control/Monad/Logger.hs
index fd1282b..80b8ed9 100644
--- a/Control/Monad/Logger.hs
+++ b/Control/Monad/Logger.hs
@@ -27,18 +27,6 @@ module Control.Monad.Logger
, LoggingT (..)
, runStderrLoggingT
, runStdoutLoggingT
- -- * TH logging
- , logDebug
- , logInfo
- , logWarn
- , logError
- , logOther
- -- * TH logging with source
- , logDebugS
- , logInfoS
- , logWarnS
- , logErrorS
- , logOtherS
) where
import Language.Haskell.TH.Syntax (Lift (lift), Q, Exp, Loc (..), qLocation)
@@ -91,13 +79,6 @@ import Control.Monad.Writer.Class ( MonadWriter (..) )
data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text
deriving (Eq, Prelude.Show, Prelude.Read, Ord)
-instance Lift LogLevel where
- lift LevelDebug = [|LevelDebug|]
- lift LevelInfo = [|LevelInfo|]
- lift LevelWarn = [|LevelWarn|]
- lift LevelError = [|LevelError|]
- lift (LevelOther x) = [|LevelOther $ pack $(lift $ unpack x)|]
-
type LogSource = Text
class Monad m => MonadLogger m where
@@ -128,63 +109,6 @@ instance (MonadLogger m, Monoid w) => MonadLogger (Strict.WriterT w m) where DEF
instance (MonadLogger m, Monoid w) => MonadLogger (Strict.RWST r w s m) where DEF
#undef DEF
-logTH :: LogLevel -> Q Exp
-logTH level =
- [|monadLoggerLog $(qLocation >>= liftLoc) $(lift level) . (id :: Text -> Text)|]
-
--- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage:
---
--- > $(logDebug) "This is a debug log message"
-logDebug :: Q Exp
-logDebug = logTH LevelDebug
-
--- | See 'logDebug'
-logInfo :: Q Exp
-logInfo = logTH LevelInfo
--- | See 'logDebug'
-logWarn :: Q Exp
-logWarn = logTH LevelWarn
--- | See 'logDebug'
-logError :: Q Exp
-logError = logTH LevelError
-
--- | Generates a function that takes a 'Text' and logs a 'LevelOther' message. Usage:
---
--- > $(logOther "My new level") "This is a log message"
-logOther :: Text -> Q Exp
-logOther = logTH . LevelOther
-
-liftLoc :: Loc -> Q Exp
-liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc
- $(lift a)
- $(lift b)
- $(lift c)
- ($(lift d1), $(lift d2))
- ($(lift e1), $(lift e2))
- |]
-
--- | Generates a function that takes a 'LogSource' and 'Text' and logs a 'LevelDebug' message. Usage:
---
--- > $logDebug "SomeSource" "This is a debug log message"
-logDebugS :: Q Exp
-logDebugS = [|\a b -> monadLoggerLogSource $(qLocation >>= liftLoc) a LevelDebug (b :: Text)|]
-
--- | See 'logDebugS'
-logInfoS :: Q Exp
-logInfoS = [|\a b -> monadLoggerLogSource $(qLocation >>= liftLoc) a LevelInfo (b :: Text)|]
--- | See 'logDebugS'
-logWarnS :: Q Exp
-logWarnS = [|\a b -> monadLoggerLogSource $(qLocation >>= liftLoc) a LevelWarn (b :: Text)|]
--- | See 'logDebugS'
-logErrorS :: Q Exp
-logErrorS = [|\a b -> monadLoggerLogSource $(qLocation >>= liftLoc) a LevelError (b :: Text)|]
-
--- | Generates a function that takes a 'LogSource', a level name and a 'Text' and logs a 'LevelOther' message. Usage:
---
--- > $logOther "SomeSource" "My new level" "This is a log message"
-logOtherS :: Q Exp
-logOtherS = [|\src level msg -> monadLoggerLogSource $(qLocation >>= liftLoc) src (LevelOther level) (msg :: Text)|]
-
-- | Monad transformer that adds a new logging function.
--
-- Since 0.2.2
diff --git a/monad-logger.cabal b/monad-logger.cabal
index ab71424..fa3d292 100644
--- a/monad-logger.cabal
+++ b/monad-logger.cabal
@@ -24,4 +24,4 @@ library
, transformers-base
, monad-control
, mtl
- , bytestring
+ , bytestring >= 0.10.3.0
--
1.7.10.4

View file

@ -1,43 +0,0 @@
From 3e05f3a3bf886c302fb6d6caa7ee92cf9736b6ad Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:33:45 -0400
Subject: [PATCH] NoDelay does not work on Android
(I think the other change is no-op)
---
Data/Conduit/Network/Utils.hs | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/Data/Conduit/Network/Utils.hs b/Data/Conduit/Network/Utils.hs
index 32a7286..01ff84e 100644
--- a/Data/Conduit/Network/Utils.hs
+++ b/Data/Conduit/Network/Utils.hs
@@ -6,14 +6,14 @@ module Data.Conduit.Network.Utils
, getSocket
) where
-import Network.Socket (AddrInfo, Socket, SocketType)
+import Network.Socket (Socket, SocketType)
import qualified Network.Socket as NS
import Data.String (IsString (fromString))
import Control.Exception (bracketOnError, IOException)
import qualified Control.Exception as E
-- | Attempt to connect to the given host/port using given @SocketType@.
-getSocket :: String -> Int -> SocketType -> IO (Socket, AddrInfo)
+getSocket :: String -> Int -> SocketType -> IO (Socket, NS.AddrInfo)
getSocket host' port' sockettype = do
let hints = NS.defaultHints {
NS.addrFlags = [NS.AI_ADDRCONFIG]
@@ -93,7 +93,7 @@ bindPort p s sockettype = do
sockOpts =
case sockettype of
NS.Datagram -> [(NS.ReuseAddr,1)]
- _ -> [(NS.NoDelay,1), (NS.ReuseAddr,1)]
+ _ -> [(NS.ReuseAddr,1)] -- Android seems to not have NoDelay
theBody addr =
bracketOnError
--
1.7.10.4

View file

@ -1,60 +0,0 @@
From d15ae2193eff9cd38ebce641279996233434b50f Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Sun, 21 Apr 2013 16:05:53 -0400
Subject: [PATCH] avoid using gnuidn
IDN is only used to handle the domain name part of a XMPP server JID.
Which seems not worth the bloat on Android.
---
lib/Network/Protocol/XMPP/JID.hs | 11 ++++-------
network-protocol-xmpp.cabal | 1 -
2 files changed, 4 insertions(+), 8 deletions(-)
diff --git a/lib/Network/Protocol/XMPP/JID.hs b/lib/Network/Protocol/XMPP/JID.hs
index 91745e0..2a50409 100644
--- a/lib/Network/Protocol/XMPP/JID.hs
+++ b/lib/Network/Protocol/XMPP/JID.hs
@@ -29,7 +29,6 @@ module Network.Protocol.XMPP.JID
import qualified Data.Text
import Data.Text (Text)
-import qualified Data.Text.IDN.StringPrep as SP
import Data.String (IsString, fromString)
newtype Node = Node { strNode :: Text }
@@ -85,16 +84,14 @@ parseJID str = maybeJID where
then Just Nothing
else fmap Just (f x)
maybeJID = do
- preppedNode <- nullable node (stringprepM SP.xmppNode)
- preppedDomain <- stringprepM SP.nameprep domain
- preppedResource <- nullable resource (stringprepM SP.xmppResource)
+ preppedNode <- nullable node (stringprepM id)
+ preppedDomain <- stringprepM id domain
+ preppedResource <- nullable resource (stringprepM id)
return $ JID
(fmap Node preppedNode)
(Domain preppedDomain)
(fmap Resource preppedResource)
- stringprepM p x = case SP.stringprep p SP.defaultFlags x of
- Left _ -> Nothing
- Right y -> Just y
+ stringprepM p x = Just x
parseJID_ :: Text -> JID
parseJID_ text = case parseJID text of
diff --git a/network-protocol-xmpp.cabal b/network-protocol-xmpp.cabal
index 807cda9..3aaad67 100644
--- a/network-protocol-xmpp.cabal
+++ b/network-protocol-xmpp.cabal
@@ -30,7 +30,6 @@ library
build-depends:
base >= 4.0 && < 5.0
, bytestring >= 0.9
- , gnuidn >= 0.2 && < 0.3
, gnutls >= 0.1.4 && < 0.3
, gsasl >= 0.3 && < 0.4
, libxml-sax >= 0.7 && < 0.8
--
1.7.10.4

View file

@ -0,0 +1,25 @@
From 0b9df0de3aa45918a2a9226a2da6be4680276419 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 03:31:55 +0000
Subject: [PATCH] stub out
---
persistent-template.cabal | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/persistent-template.cabal b/persistent-template.cabal
index 8216ce7..f23234b 100644
--- a/persistent-template.cabal
+++ b/persistent-template.cabal
@@ -23,7 +23,7 @@ library
, containers
, aeson
, monad-logger
- exposed-modules: Database.Persist.TH
+ exposed-modules:
ghc-options: -Wall
if impl(ghc >= 7.4)
cpp-options: -DGHC_7_4
--
1.7.10.4

View file

@ -1,71 +1,32 @@
From 8fddef803ee9191ca15363283b7e4d5af4c70f3a Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:34:10 -0400
From 760fa2c5044ae38bee8114ff84c625ac59f35c6f Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 00:03:55 +0000
Subject: [PATCH] disable TH
---
Database/Persist/GenericSql/Internal.hs | 6 +-----
Database/Persist/GenericSql/Raw.hs | 5 ++---
2 files changed, 3 insertions(+), 8 deletions(-)
Database/Persist/Sql/Raw.hs | 2 --
1 file changed, 2 deletions(-)
diff --git a/Database/Persist/GenericSql/Internal.hs b/Database/Persist/GenericSql/Internal.hs
index f109887..5273398 100644
--- a/Database/Persist/GenericSql/Internal.hs
+++ b/Database/Persist/GenericSql/Internal.hs
@@ -14,7 +14,6 @@ module Database.Persist.GenericSql.Internal
, createSqlPool
, mkColumns
, Column (..)
- , logSQL
, InsertSqlResult (..)
) where
@@ -33,7 +32,7 @@ import Data.Monoid (Monoid, mappend, mconcat)
import Database.Persist.EntityDef
import qualified Data.Conduit as C
import Language.Haskell.TH.Syntax (Q, Exp)
-import Control.Monad.Logger (logDebugS)
+
import Data.Maybe (mapMaybe, listToMaybe)
import Data.Int (Int64)
@@ -197,6 +196,3 @@ tableColumn t s = go $ entityColumns t
| x == s = ColumnDef x y z
| otherwise = go rest
-}
-
-logSQL :: Q Exp
-logSQL = [|\sql_foo params_foo -> $logDebugS (T.pack "SQL") $ T.pack $ show (sql_foo :: Text) ++ " " ++ show (params_foo :: [PersistValue])|]
diff --git a/Database/Persist/GenericSql/Raw.hs b/Database/Persist/GenericSql/Raw.hs
index e4bf9f4..3da8fa0 100644
--- a/Database/Persist/GenericSql/Raw.hs
+++ b/Database/Persist/GenericSql/Raw.hs
@@ -26,7 +26,6 @@ import Database.Persist.GenericSql.Internal hiding (execute, withStmt)
import Database.Persist.Store (PersistValue)
import Data.IORef
import Control.Monad.IO.Class
-import Control.Monad.Logger (logDebugS)
import Control.Monad.Trans.Reader
import qualified Data.Map as Map
import Control.Applicative (Applicative)
@@ -134,7 +133,7 @@ withStmt :: (MonadSqlPersist m, MonadResource m)
diff --git a/Database/Persist/Sql/Raw.hs b/Database/Persist/Sql/Raw.hs
index 73189dd..6efebea 100644
--- a/Database/Persist/Sql/Raw.hs
+++ b/Database/Persist/Sql/Raw.hs
@@ -22,7 +22,6 @@ rawQuery :: (MonadSqlPersist m, MonadResource m)
-> [PersistValue]
-> Source m [PersistValue]
withStmt sql vals = do
rawQuery sql vals = do
- lift $ $logDebugS (pack "SQL") $ pack $ show sql ++ " " ++ show vals
+ -- lift $ pack $ show sql ++ " " ++ show vals
conn <- lift askSqlConn
bracketP
(getStmt' conn sql)
@@ -146,7 +145,7 @@ execute x y = liftM (const ()) $ executeCount x y
(getStmtConn conn sql)
@@ -34,7 +33,6 @@ rawExecute x y = liftM (const ()) $ rawExecuteCount x y
executeCount :: MonadSqlPersist m => Text -> [PersistValue] -> m Int64
executeCount sql vals = do
rawExecuteCount :: MonadSqlPersist m => Text -> [PersistValue] -> m Int64
rawExecuteCount sql vals = do
- $logDebugS (pack "SQL") $ pack $ show sql ++ " " ++ show vals
+ -- pack $ show sql ++ " " ++ show vals
stmt <- getStmt sql
res <- liftIO $ I.execute stmt vals
liftIO $ reset stmt
res <- liftIO $ stmtExecute stmt vals
liftIO $ stmtReset stmt
--
1.7.10.4

View file

@ -0,0 +1,96 @@
From 2b1ee45058b0d6db90f77e4859d01d1e8434906c Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sat, 21 Sep 2013 23:11:51 +0000
Subject: [PATCH] fix build with new ghc
---
Data/Primitive/Array.hs | 2 +-
Data/Primitive/ByteArray.hs | 2 +-
Data/Primitive/MutVar.hs | 4 ++--
Data/Primitive/Types.hs | 13 +++++++------
4 files changed, 11 insertions(+), 10 deletions(-)
diff --git a/Data/Primitive/Array.hs b/Data/Primitive/Array.hs
index b82dcac..b28abea 100644
--- a/Data/Primitive/Array.hs
+++ b/Data/Primitive/Array.hs
@@ -106,7 +106,7 @@ unsafeThawArray (Array arr#)
sameMutableArray :: MutableArray s a -> MutableArray s a -> Bool
{-# INLINE sameMutableArray #-}
sameMutableArray (MutableArray arr#) (MutableArray brr#)
- = sameMutableArray# arr# brr#
+ = tagToEnum# (sameMutableArray# arr# brr#)
-- | Copy a slice of an immutable array to a mutable array.
copyArray :: PrimMonad m
diff --git a/Data/Primitive/ByteArray.hs b/Data/Primitive/ByteArray.hs
index 2a47254..3a1ed6e 100644
--- a/Data/Primitive/ByteArray.hs
+++ b/Data/Primitive/ByteArray.hs
@@ -99,7 +99,7 @@ mutableByteArrayContents (MutableByteArray arr#)
sameMutableByteArray :: MutableByteArray s -> MutableByteArray s -> Bool
{-# INLINE sameMutableByteArray #-}
sameMutableByteArray (MutableByteArray arr#) (MutableByteArray brr#)
- = sameMutableByteArray# arr# brr#
+ = tagToEnum# (sameMutableByteArray# arr# brr#)
-- | Convert a mutable byte array to an immutable one without copying. The
-- array should not be modified after the conversion.
diff --git a/Data/Primitive/MutVar.hs b/Data/Primitive/MutVar.hs
index 9745ec7..eb654c9 100644
--- a/Data/Primitive/MutVar.hs
+++ b/Data/Primitive/MutVar.hs
@@ -23,7 +23,7 @@ module Data.Primitive.MutVar (
) where
import Control.Monad.Primitive ( PrimMonad(..), primitive_ )
-import GHC.Prim ( MutVar#, sameMutVar#, newMutVar#,
+import GHC.Prim ( MutVar#, sameMutVar#, newMutVar#, tagToEnum#,
readMutVar#, writeMutVar#, atomicModifyMutVar# )
import Data.Typeable ( Typeable )
@@ -33,7 +33,7 @@ data MutVar s a = MutVar (MutVar# s a)
deriving ( Typeable )
instance Eq (MutVar s a) where
- MutVar mva# == MutVar mvb# = sameMutVar# mva# mvb#
+ MutVar mva# == MutVar mvb# = tagToEnum# (sameMutVar# mva# mvb#)
-- | Create a new 'MutVar' with the specified initial value
newMutVar :: PrimMonad m => a -> m (MutVar (PrimState m) a)
diff --git a/Data/Primitive/Types.hs b/Data/Primitive/Types.hs
index 7568f0c..d961e97 100644
--- a/Data/Primitive/Types.hs
+++ b/Data/Primitive/Types.hs
@@ -20,6 +20,7 @@ module Data.Primitive.Types (
import Control.Monad.Primitive
import Data.Primitive.MachDeps
import Data.Primitive.Internal.Operations
+import GHC.Prim (tagToEnum#)
import GHC.Base (
unsafeCoerce#,
@@ -48,14 +49,14 @@ import Data.Primitive.Internal.Compat ( mkNoRepType )
data Addr = Addr Addr# deriving ( Typeable )
instance Eq Addr where
- Addr a# == Addr b# = eqAddr# a# b#
- Addr a# /= Addr b# = neAddr# a# b#
+ Addr a# == Addr b# = tagToEnum# (eqAddr# a# b#)
+ Addr a# /= Addr b# = tagToEnum# (neAddr# a# b#)
instance Ord Addr where
- Addr a# > Addr b# = gtAddr# a# b#
- Addr a# >= Addr b# = geAddr# a# b#
- Addr a# < Addr b# = ltAddr# a# b#
- Addr a# <= Addr b# = leAddr# a# b#
+ Addr a# > Addr b# = tagToEnum# (gtAddr# a# b#)
+ Addr a# >= Addr b# = tagToEnum# (geAddr# a# b#)
+ Addr a# < Addr b# = tagToEnum# (ltAddr# a# b#)
+ Addr a# <= Addr b# = tagToEnum# (leAddr# a# b#)
instance Data Addr where
toConstr _ = error "toConstr"
--
1.7.10.4

View file

@ -0,0 +1,24 @@
From 0b0d4250cfce44b1a03b50458b4122370ab349ce Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sat, 21 Sep 2013 21:50:51 +0000
Subject: [PATCH] fix build with new ghc
---
System/Process/Internals.hs | 1 +
1 file changed, 1 insertion(+)
diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs
index a73c6fc..6676a72 100644
--- a/System/Process/Internals.hs
+++ b/System/Process/Internals.hs
@@ -61,6 +61,7 @@ import Control.Concurrent
import Control.Exception
import Foreign.C
import Foreign
+import System.IO.Unsafe
# ifdef __GLASGOW_HASKELL__
--
1.7.10.4

View file

@ -1,44 +0,0 @@
From c10ab80793a21dce0c7516725e1ca3b36a87aa25 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:35:08 -0400
Subject: [PATCH] hack to build with hacked up lifted-base, which is currently
lacking a mask
---
Control/Monad/Trans/Resource.hs | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/Control/Monad/Trans/Resource.hs b/Control/Monad/Trans/Resource.hs
index d209dd8..61ab349 100644
--- a/Control/Monad/Trans/Resource.hs
+++ b/Control/Monad/Trans/Resource.hs
@@ -5,7 +5,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, ImpredicativeTypes #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE ConstraintKinds #-}
#endif
@@ -554,7 +554,7 @@ GOX(Monoid w, Strict.WriterT w)
--
-- Since 0.3.0
resourceForkIO :: MonadBaseControl IO m => ResourceT m () -> ResourceT m ThreadId
-resourceForkIO (ResourceT f) = ResourceT $ \r -> L.mask $ \restore ->
+resourceForkIO (ResourceT f) = ResourceT $ \r ->
-- We need to make sure the counter is incremented before this call
-- returns. Otherwise, the parent thread may call runResourceT before
-- the child thread increments, and all resources will be freed
@@ -565,7 +565,7 @@ resourceForkIO (ResourceT f) = ResourceT $ \r -> L.mask $ \restore ->
(liftBaseDiscard forkIO $ bracket_
(return ())
(stateCleanup r)
- (restore $ f r))
+ (return ()))
-- | A @Monad@ based on some monad which allows running of some 'IO' actions,
-- via unsafe calls. This applies to 'IO' and 'ST', for instance.
--
1.7.10.4

View file

@ -1,15 +1,13 @@
From 8f058e84892a8c4202275f524f74bd6a7097ad40 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Wed, 8 May 2013 02:07:15 -0400
From 05d0b6e6d2f84cd8ff53b8ee3e42021fa02fe8e4 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sat, 21 Sep 2013 23:21:52 +0000
Subject: [PATCH] remove TH
---
Text/Cassius.hs | 23 --------------
Text/Css.hs | 84 -------------------------------------------------
Text/CssCommon.hs | 4 ---
Text/Lucius.hs | 30 +-----------------
shakespeare-css.cabal | 2 +-
5 files changed, 2 insertions(+), 141 deletions(-)
Text/Cassius.hs | 23 -----------------------
Text/CssCommon.hs | 4 ----
Text/Lucius.hs | 30 +-----------------------------
3 files changed, 1 insertion(+), 56 deletions(-)
diff --git a/Text/Cassius.hs b/Text/Cassius.hs
index ce05374..ae56b0a 100644
@ -64,117 +62,6 @@ index ce05374..ae56b0a 100644
-- | 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 8e6fc09..401a166 100644
--- a/Text/Css.hs
+++ b/Text/Css.hs
@@ -108,19 +108,6 @@ cssUsedIdentifiers toi2b parseBlocks s' =
(scope, rest') = go rest
go' (k, v) = k ++ v
-cssFileDebug :: Bool -- ^ perform the indent-to-brace conversion
- -> Q Exp -> Parser [TopLevel] -> 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 :: Selector -> Selector -> Selector
combineSelectors a b = do
a' <- a
@@ -202,17 +189,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|]
-
getVars :: Monad m => [(String, String)] -> Content -> m [(Deref, VarType)]
getVars _ ContentRaw{} = return []
getVars scope (ContentVar d) =
@@ -268,68 +244,8 @@ compressBlock (Block x y blocks) =
cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c
cc (a:b) = a : cc b
-blockToCss :: Name -> Scope -> Block -> Q Exp
-blockToCss r scope (Block sel props subblocks) =
- [|(:) (Css' $(selectorToBuilder r scope sel) $(listE $ map go props))
- . foldr (.) id $(listE $ map subGo subblocks)
- |]
- where
- go (x, y) = tupE [contentsToBuilder r scope x, contentsToBuilder r scope y]
- subGo (Block sel' b c) =
- blockToCss r scope $ Block sel'' b c
- where
- sel'' = combineSelectors sel sel'
-
-selectorToBuilder :: Name -> Scope -> Selector -> 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))
-
type Scope = [(String, String)]
-topLevelsToCassius :: [TopLevel] -> 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 Css ($(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 <- [|(:) $ AtBlock $(lift name) $(s') $(blocksToCassius r scope b)|]
- es <- go r scope rest
- return $ e : es
- go r scope (TopAtDecl dec cs:rest) = do
- e <- [|(:) $ AtDecl $(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] -> 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-- FIXME use a foldr
diff --git a/Text/CssCommon.hs b/Text/CssCommon.hs
index 719e0a8..8c40e8c 100644
--- a/Text/CssCommon.hs
@ -192,10 +79,10 @@ index 719e0a8..8c40e8c 100644
-mkSizeType "ExSize" "ex"
-mkSizeType "PixelSize" "px"
diff --git a/Text/Lucius.hs b/Text/Lucius.hs
index b71614e..a902e1c 100644
index 89328bd..0a1cf5e 100644
--- a/Text/Lucius.hs
+++ b/Text/Lucius.hs
@@ -6,12 +6,8 @@
@@ -8,12 +8,8 @@
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
module Text.Lucius
( -- * Parsing
@ -203,13 +90,13 @@ index b71614e..a902e1c 100644
- , luciusFile
- , luciusFileDebug
- , luciusFileReload
-- ** Mixins
- , luciusMixin
+ luciusMixin
, Mixin
-- ** Runtime
- , luciusRT
+ luciusRT
, luciusRT'
, -- * Datatypes
Css
@@ -31,11 +27,8 @@ module Text.Lucius
, luciusRT
@@ -40,11 +36,8 @@ module Text.Lucius
, AbsoluteUnit (..)
, AbsoluteSize (..)
, absoluteSize
@ -221,9 +108,9 @@ index b71614e..a902e1c 100644
-- * Internal
, parseTopLevels
, luciusUsedIdentifiers
@@ -57,18 +50,6 @@ import Data.Either (partitionEithers)
import Data.Monoid (mconcat)
@@ -66,18 +59,6 @@ import Data.Monoid (mconcat)
import Data.List (isSuffixOf)
import Control.Arrow (second)
--- |
---
@ -240,7 +127,7 @@ index b71614e..a902e1c 100644
whiteSpace :: Parser ()
whiteSpace = many whiteSpace1 >> return ()
@@ -179,15 +160,6 @@ parseComment = do
@@ -217,15 +198,6 @@ parseComment = do
_ <- manyTill anyChar $ try $ string "*/"
return $ ContentRaw ""
@ -253,22 +140,9 @@ index b71614e..a902e1c 100644
-luciusFileDebug = cssFileDebug False [|parseTopLevels|] parseTopLevels
-luciusFileReload = luciusFileDebug
-
parseTopLevels :: Parser [TopLevel]
parseTopLevels :: Parser [TopLevel Unresolved]
parseTopLevels =
go id
diff --git a/shakespeare-css.cabal b/shakespeare-css.cabal
index de2497b..874a3b5 100644
--- a/shakespeare-css.cabal
+++ b/shakespeare-css.cabal
@@ -33,7 +33,7 @@ library
, shakespeare >= 1.0 && < 1.1
, template-haskell
, text >= 0.11.1.1 && < 0.12
- , process >= 1.0 && < 1.2
+ , process >= 1.0 && < 1.3
, parsec >= 2 && < 4
, transformers
--
1.7.10.4

View file

@ -1,162 +0,0 @@
From b128412ecee9677b788abecbbf1fd1edd447eea2 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:35:59 -0400
Subject: [PATCH] remove TH
---
Text/Shakespeare/I18N.hs | 130 +---------------------------------------------
1 file changed, 1 insertion(+), 129 deletions(-)
diff --git a/Text/Shakespeare/I18N.hs b/Text/Shakespeare/I18N.hs
index 1b486ed..aa5e358 100644
--- a/Text/Shakespeare/I18N.hs
+++ b/Text/Shakespeare/I18N.hs
@@ -51,10 +51,7 @@
--
-- You can also adapt those instructions for use with other systems.
module Text.Shakespeare.I18N
- ( mkMessage
- , mkMessageFor
- , mkMessageVariant
- , RenderMessage (..)
+ ( RenderMessage (..)
, ToMessage (..)
, SomeMessage (..)
, Lang
@@ -115,133 +112,8 @@ type Lang = Text
--
-- 3. create a 'RenderMessage' instance
--
-mkMessage :: String -- ^ base name to use for translation type
- -> FilePath -- ^ subdirectory which contains the translation files
- -> Lang -- ^ default translation language
- -> Q [Dec]
-mkMessage dt folder lang =
- mkMessageCommon True "Msg" "Message" dt dt folder lang
--- | create 'RenderMessage' instance for an existing data-type
-mkMessageFor :: String -- ^ master translation data type
- -> String -- ^ existing type to add translations for
- -> FilePath -- ^ path to translation folder
- -> Lang -- ^ default language
- -> Q [Dec]
-mkMessageFor master dt folder lang = mkMessageCommon False "" "" master dt folder lang
-
--- | create an additional set of translations for a type created by `mkMessage`
-mkMessageVariant :: String -- ^ master translation data type
- -> String -- ^ existing type to add translations for
- -> FilePath -- ^ path to translation folder
- -> Lang -- ^ default language
- -> Q [Dec]
-mkMessageVariant master dt folder lang = mkMessageCommon False "Msg" "Message" master dt folder lang
-
--- |used by 'mkMessage' and 'mkMessageFor' to generate a 'RenderMessage' and possibly a message data type
-mkMessageCommon :: Bool -- ^ generate a new datatype from the constructors found in the .msg files
- -> String -- ^ string to append to constructor names
- -> String -- ^ string to append to datatype name
- -> String -- ^ base name of master datatype
- -> String -- ^ base name of translation datatype
- -> FilePath -- ^ path to translation folder
- -> Lang -- ^ default lang
- -> Q [Dec]
-mkMessageCommon genType prefix postfix master dt folder lang = do
- files <- qRunIO $ getDirectoryContents folder
- (_files', contents) <- qRunIO $ fmap (unzip . catMaybes) $ mapM (loadLang folder) files
-#ifdef GHC_7_4
- mapM_ qAddDependentFile _files'
-#endif
- sdef <-
- case lookup lang contents of
- Nothing -> error $ "Did not find main language file: " ++ unpack lang
- Just def -> toSDefs def
- mapM_ (checkDef sdef) $ map snd contents
- let mname = mkName $ dt ++ postfix
- c1 <- fmap concat $ mapM (toClauses prefix dt) contents
- c2 <- mapM (sToClause prefix dt) sdef
- c3 <- defClause
- return $
- ( if genType
- then ((DataD [] mname [] (map (toCon dt) sdef) []) :)
- else id)
- [ InstanceD
- []
- (ConT ''RenderMessage `AppT` (ConT $ mkName master) `AppT` ConT mname)
- [ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [c3]
- ]
- ]
-
-toClauses :: String -> String -> (Lang, [Def]) -> Q [Clause]
-toClauses prefix dt (lang, defs) =
- mapM go defs
- where
- go def = do
- a <- newName "lang"
- (pat, bod) <- mkBody dt (prefix ++ constr def) (map fst $ vars def) (content def)
- guard <- fmap NormalG [|$(return $ VarE a) == pack $(lift $ unpack lang)|]
- return $ Clause
- [WildP, ConP (mkName ":") [VarP a, WildP], pat]
- (GuardedB [(guard, bod)])
- []
-
-mkBody :: String -- ^ datatype
- -> String -- ^ constructor
- -> [String] -- ^ variable names
- -> [Content]
- -> Q (Pat, Exp)
-mkBody dt cs vs ct = do
- vp <- mapM go vs
- let pat = RecP (mkName cs) (map (varName dt *** VarP) vp)
- let ct' = map (fixVars vp) ct
- pack' <- [|Data.Text.pack|]
- tomsg <- [|toMessage|]
- let ct'' = map (toH pack' tomsg) ct'
- mapp <- [|mappend|]
- let app a b = InfixE (Just a) mapp (Just b)
- e <-
- case ct'' of
- [] -> [|mempty|]
- [x] -> return x
- (x:xs) -> return $ foldl' app x xs
- return (pat, e)
- where
- toH pack' _ (Raw s) = pack' `AppE` SigE (LitE (StringL s)) (ConT ''String)
- toH _ tomsg (Var d) = tomsg `AppE` derefToExp [] d
- go x = do
- let y = mkName $ '_' : x
- return (x, y)
- fixVars vp (Var d) = Var $ fixDeref vp d
- fixVars _ (Raw s) = Raw s
- fixDeref vp (DerefIdent (Ident i)) = DerefIdent $ Ident $ fixIdent vp i
- fixDeref vp (DerefBranch a b) = DerefBranch (fixDeref vp a) (fixDeref vp b)
- fixDeref _ d = d
- fixIdent vp i =
- case lookup i vp of
- Nothing -> i
- Just y -> nameBase y
-
-sToClause :: String -> String -> SDef -> Q Clause
-sToClause prefix dt sdef = do
- (pat, bod) <- mkBody dt (prefix ++ sconstr sdef) (map fst $ svars sdef) (scontent sdef)
- return $ Clause
- [WildP, ConP (mkName "[]") [], pat]
- (NormalB bod)
- []
-
-defClause :: Q Clause
-defClause = do
- a <- newName "sub"
- c <- newName "langs"
- d <- newName "msg"
- rm <- [|renderMessage|]
- return $ Clause
- [VarP a, ConP (mkName ":") [WildP, VarP c], VarP d]
- (NormalB $ rm `AppE` VarE a `AppE` VarE c `AppE` VarE d)
- []
-
toCon :: String -> SDef -> Con
toCon dt (SDef c vs _) =
RecC (mkName $ "Msg" ++ c) $ map go vs
--
1.7.10.4

View file

@ -1,308 +0,0 @@
From 332c71b3f6bc4786b914e675020a23c492beee5a Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Tue, 7 May 2013 19:28:06 -0400
Subject: [PATCH] remove TH
---
Text/Coffee.hs | 54 -------------------------------------------------
Text/Julius.hs | 56 ++++-----------------------------------------------
Text/Roy.hs | 54 -------------------------------------------------
Text/TypeScript.hs | 57 +---------------------------------------------------
4 files changed, 5 insertions(+), 216 deletions(-)
diff --git a/Text/Coffee.hs b/Text/Coffee.hs
index 2481936..3f7f9c3 100644
--- a/Text/Coffee.hs
+++ b/Text/Coffee.hs
@@ -51,14 +51,6 @@ 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
-
-#ifdef TEST_EXPORT
- , coffeeSettings
-#endif
) where
import Language.Haskell.TH.Quote (QuasiQuoter (..))
@@ -66,49 +58,3 @@ 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 = ")"
- , wrapInsertionApplyBegin = "("
- , wrapInsertionApplyClose = ")\n"
- }
- }
- }
-
--- | 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 230eac3..1a0376f 100644
--- a/Text/Julius.hs
+++ b/Text/Julius.hs
@@ -14,17 +14,8 @@ 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
-
-- * Datatypes
- , JavascriptUrl
+ JavascriptUrl
, Javascript (..)
, RawJavascript (..)
@@ -37,9 +28,11 @@ module Text.Julius
, renderJavascriptUrl
-- ** internal, used by 'Text.Coffee'
- , javascriptSettings
-- ** internal
, juliusUsedIdentifiers
+
+ -- used by TH splices
+ , asJavascriptUrl
) where
import Language.Haskell.TH.Quote (QuasiQuoter (..))
@@ -101,47 +94,6 @@ instance RawJS TL.Text where rawJS = RawJavascript . fromLazyText
instance RawJS Builder where rawJS = RawJavascript
instance RawJS Bool where rawJS = RawJavascript . 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)]
diff --git a/Text/Roy.hs b/Text/Roy.hs
index cf09cec..870c9f6 100644
--- a/Text/Roy.hs
+++ b/Text/Roy.hs
@@ -23,13 +23,6 @@ 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
-
-#ifdef TEST_EXPORT
- , roySettings
-#endif
) where
import Language.Haskell.TH.Quote (QuasiQuoter (..))
@@ -37,50 +30,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"]
- , preEscapeIgnoreBalanced = "'\""
- , preEscapeIgnoreLine = "//"
- , wrapInsertion = Nothing
- {-
- Just WrapInsertion {
- wrapInsertionIndent = Just " "
- , wrapInsertionStartBegin = "(\\"
- , wrapInsertionSeparator = " "
- , wrapInsertionStartClose = " ->\n"
- , wrapInsertionEnd = ")"
- , wrapInsertionApplyBegin = " "
- , wrapInsertionApplyClose = ")\n"
- }
- -}
- }
- }
-
--- | 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 34bf4bf..30c5388 100644
--- a/Text/TypeScript.hs
+++ b/Text/TypeScript.hs
@@ -53,65 +53,10 @@
--
-- 2. TypeScript: <http://typescript.codeplex.com/>
module Text.TypeScript
- ( -- * Functions
- -- ** Template-Reading Functions
- -- | These QuasiQuoter and Template Haskell methods return values of
- -- type @'JavascriptUrl' url@. See the Yesod book for details.
- tsc
- , typeScriptFile
- , typeScriptFileReload
-
-#ifdef TEST_EXPORT
- , typeScriptSettings
-#endif
+ (
) where
import Language.Haskell.TH.Quote (QuasiQuoter (..))
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 = "})"
- , wrapInsertionApplyBegin = "("
- , wrapInsertionApplyClose = ");\n"
- }
- }
- }
-
--- | Read inline, quasiquoted TypeScript
-tsc :: QuasiQuoter
-tsc = QuasiQuoter { quoteExp = \s -> do
- rs <- typeScriptSettings
- quoteExp (shakespeare rs) s
- }
-
--- | Read in a Roy 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
--
1.7.10.4

View file

@ -0,0 +1,25 @@
From 40182bfb77ba16beab0da95b664d2c052d5fcad6 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 04:53:30 +0000
Subject: [PATCH] TH exports
---
Text/Julius.hs | 2 ++
1 file changed, 2 insertions(+)
diff --git a/Text/Julius.hs b/Text/Julius.hs
index 3a9f83e..2b98f30 100644
--- a/Text/Julius.hs
+++ b/Text/Julius.hs
@@ -40,6 +40,8 @@ module Text.Julius
, javascriptSettings
-- ** internal
, juliusUsedIdentifiers
+ -- used by TH
+ , asJavascriptUrl
) where
import Language.Haskell.TH.Quote (QuasiQuoter (..))
--
1.7.10.4

View file

@ -1,139 +1,26 @@
From 3cb1056782c29b0b68bdcff8fa49d3ea92126956 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Mon, 15 Apr 2013 16:46:15 -0400
Subject: [PATCH] export symbol used by TH splices
From 4a75a2f0d77168aa3115b991284a5120484e18f0 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 04:59:21 +0000
Subject: [PATCH] TH exports
---
Text/.Shakespeare.hs.swp | Bin 24576 -> 0 bytes
Text/Shakespeare.hs | 2 ++
2 files changed, 2 insertions(+)
delete mode 100644 Text/.Shakespeare.hs.swp
diff --git a/Text/.Shakespeare.hs.swp b/Text/.Shakespeare.hs.swp
deleted file mode 100644
index 4d6cd6a0295fdfb59f32a66b4af556c0630dd5b0..0000000000000000000000000000000000000000
GIT binary patch
literal 0
HcmV?d00001
literal 24576
zcmeI4e~et$RmWd`KnqD)L_(BS5xTW4?M$;fu@g0M7u$*LtdmXsW9?l#wDxBEJo9Gf
z#WU|s-h1QO^^dk7RGJp46wwy`NCj0Y(S!!1AgEe}NKk}8ErJRNG@z(KqJ@T13Q|#9
zR6ghact2*x>kWSanvuTVnRm}U_uO;OJ@?*o&-2-xr{<5SdmDFqe16RHu3haOfAZ_E
z_a3<Dd5^`xx;(zxXEhpJjYOBfM;P9j_4;?F9sgXA_5(i&W_C4pHtxQ2DOk(yTr3_p
zI_Z{pPKYKNm}p=N8W?2lncX*eci**Z=k{%HQ8)ki$t_fxkW4f%(ZECl6Aer>Fwww7
z0}~BQG%(S?|0fM({p-CS(4lL=qu?5g>-pOOzWx0}{5=c)#QwgHzc+z9s33JFpNR%0
z8klHcqJfD9CK{M%V4{JE1|}MqXkem&i3TPb_}{AmzvX$m5$_9fi0A%aVgN6{(es`I
zzX&dZcYzu3y*GH??}AT&_ks{CfP2BM;5zUML4hxWFM!X2XTa0o<KXAP`#=U#umonn
zH*WO2=fM+T70iL#!MASkynh0}2c7~Kz&pX+;8ySx;0HhIc`t#lfM>xI;GN(`@b5q3
zdEW+q1)c*R0v`lD@F2Ja+zkHk^`6%R`@wf#=Xt*dj)L33^FQo)>);_U2fj-n<a6LW
zI1H`<&k-!?f&<__@MVG{?*jitQ04pJW$--sD0mzk0{4Uaz?;FV=w9^yS?~$)BrqSv
zXIc#tzds+PL6U`Ww3zuxb|5I1l)qQ0R>Mfm&Z@;M38Pg{=v0;4eAEh}Oh1S2h`)X|
zaMUe7^VK8erq$k&-{go$)yw+d5jmw@!>_`_lJ=8eE^Ye#V16}<li+X|1ybSk!H%CS
zkEc1{cm1dtv_|MIDtH}?qw}aoiWc0j6lHn36ZxZz9uz+?z8R^!L6D)JD!<jDsVr8Z
z7Em?gUJp&Bsy6I|&5lB`2jg}-2-0Q}_A_-h5M2+$tfPE2wSB5C%$sG3Vc6}ej^FQx
z-F3$`>jZGhf}|gJeHq<!TKQ2+o%NgNvaoqBRl|7DZK)`h7F3o5euh}cN4tKXK@~x=
zj-SyMeAcqYm`>%I3sW^nO}B(&sBOwLMuVwp$B8=cC!v3~8z{d^Yb`{L(y$e%RNGLh
zAjzeZ#-zQ6{PbKv@6P+(K>$gF-lS_ukPf=ptg3Cl=wH?vSz7N0i$-HjKN78?4mw5;
zOwXx?8hL_1s6wHyZrIeiQE^+iN`qM^PJ>+3lor~9s3{7pl~RjV=*x;<zo;6GhT8C4
zo?4-7n<7!a>o-N7V6;={*;lR=J&F23q6JsMS|4#z5o|G5(pQD1n;kz|g;l(<X`y^z
zAahc;gbmIxd|0s9tn|JeCTXU6aVu=EGZ5We7&ByIC`JuIuc4MY(i*a3A+4B+q^;16
zW2(+Y@em_1L&6+d9r&w(wv#2g*-v6dyC;G~BDQorZ$(sI9o$(FFABs6RVQZXuo*-V
zX()&zY+IMo9QvV9bG8F*hml#Vo1bq>OBq%sbz3nkM^ph9XCf`ziHH63zL|5=(x`Mn
zie|KtTKTh}$2ewz>J3mMYOzdOnp9L#a8WHY5CQ66$6_DHg3T-nGbNrt&#s}ru6lkb
z-IGZY_?REM327$~zo2`jJM~D%8MJ5<9Wdo_Co1*Z*bC;I#D23gt@Z4;&imBGN+6XP
zsb?pa)=zw_xf#q#7j=VczBC0NJ;&&fxCMG<hDzqNIDv{wGOokv4>wcpwjF=k?Vx@c
z^g<ZTs%&+3UJrw$)S$LeE#Tn*zu1%tuwxA4G%MM&bOEP(K8yz`>SLsbekfjS5M^Ok
zH?374L@iuErXM8y2=x3&wR$SnL?fnCh0-rodOocRH)Fg?Oa~L?Y~R(#Rc*AYhUbaj
zJH#lS%-XwEyU(K0?)iPSbht5y`r?;%U?+Y{iiHf4Y86%?dA{JY7|iTb^T*thiY9vT
zdF>O*sg4J*ru&L!kDE3hKQV}?YT7D^lecwTmb-F8$G6r_-%qe!=~gm`7UW05uhYw(
zDS)YZFmMG~d`_MAcP%rnbY(FfB+cNc-wWi|X$qI+%N)xdOf;{#Bw>R1GU}J40Wk>E
zhFu)7@r2bxrYAG#wAq_1dl@T(;gHBGEmfMfKLwFyx_@g7Jtk+&o?vku7t?DjBylrH
zS-)lI><_&p$@IeQU{lTmv$Hi-B`LKrI#RCi@qynB+aZSh06V3IrakOmz+b1B$|h8r
zV9^m+@#c>;PDbJ*RBfRDE*S4Qf2{5(bu&leC=OedM|sPQ1B0;3yiqm#Wm>h9xF_Xx
zZ#z>eY`cnw-7;Xkdt>RL#^O4@Xst0X`;o}+rr!3jt=@8E{^-i7xf6@?$BwQzzq-;f
z3x4gc>D|*ia{;f+bdzRP4WBr-DUaiW7-Oj&ANXmgzth7;qn_8%3NRMKFo!)=Gb<-s
z<t&)Cwls!1IT-iOhLNAeN!qX$*9lv)EZ1a5I&BQia!7IxdLU${s%l}nzuWKlM+d!W
zoZlkeA*hla4q1U}dXGoGGe%uEd*-?tGGzicEbOA$=wpV=XVfpMZv}0&G`G04GWXL9
z$4)GnYEBlrMScJlZTtO{pNQMDzfNcmdNS$S-=*!(Nw$FVvh5e^O;Sz3#Cogh#>1H|
z>!7QH1U~z>(gauxvJCZ@I>=JqYwIzwtyQ-C<$}BhN?`~!c}<OJ!4xx&101X#;1ZE>
zE{B-7?AFeS8}V5SGZd#He3NYVwAbM~&%z7LQMb8*_TfP{9Hb5J;>>n+Y+(t*UR-(b
zp@V9s9mO+4KZ$0-NEVnbm1p|Cu#Hl+edh8eHF{y1qL>*p+HDoYhxZ?S@Z|mn=hTUy
z87Hkrn4SmyWE{c4g@wF{yw;&^uokjAn`f6KXP+^Q@zg<rBchK-gP}N4Y$7}_HtZzM
z*)7>^k=xM;ft>&Uh%@+2oZaR8&sXp3ob|s5J`T=;IZy}Jf|sECb?^k}fd_!py%9`4
z6Aer>Fwww70}~BQG%(S?L<18IOf)djz(fQ8M>L>HpA`x01v;3wgBy%^s9NfdJJhyW
zx$X#>62P5160U{OHhqY9H6NCUd(D)nUR{{<h?Yt?cPb}rO8C4R$L9upxHemy;C0z*
ztZE149xKXVty*=pH?JcNY(*wQ9)xoIUR5lq?P6g%q^bo{1J(DW$bGEzjt8+gf--gK
zh381NAbVc@f7*en?1fNjpcOi{BgAiCn}|lea{hl4=J_SLbLRXnIsbpdIsdo8hruei
z54;`h2CoDE%31$a@D1?K;Pc>9;KN`YoCT5>um`*e{2M`qFM*!{_kdf#8^BHACGPou
z1AGkp97w=%@HTKOxCPt{zQ$euv*118GB^YFfZM@$xa)rryZ}B0o&uM^Nw5TN0sqN8
z|I6S>@KMkK?*O-gf8gH#x4_dN0Y|_bxB<LO4!|eD$G{Qbfp3uq@B;WCcmmuHzDXXy
zzkpZ4?|}D%E_esH9lSzbz_XwO_JZrdSFb~N;Aepk-VDA;KEOYM-v<{!1m?l_7@t1_
zGEQHVu^Rhv7Ql6d1TeYLC6+#jy83&A8>~K08cP4p&4sIOn+8zRrWWd)0Op?18#c8w
zQbi`SDO7v*X(n~$Lc(LX9p%<V;!t}>iA>~EWHsD^mWxa&Bf&6~)(g3Ij7?e?hPu%W
zJjS+Lv?=YnPo3y<t3~8ARlQ*-7s_1O$<;&4geD!G`Fo<cIglHup4`;?$!aQkDcvem
z%DgHI`8D4%6|zARDODoi;!odquU7?nx7<FxTh+AZF}D<%^Oyy9Beo10BwU!Q)g&JD
zO{BJ<(mmwjM{Yau!HN7XNl*}0zY)NefN^P{P}evWRjaAdksmEC|E}pC;QkRUs|Ju|
zY>17Q8zeZZYNm_RrW;~1!6FNlzJW^d@|vON+Tb$7Tv6&MeJ+{YH%2H#kA|~m6?9V*
zNmqo6S<z_y{#q$`?S^56HAz%atPsxnv`ti)YDx4U!p-zk-}kfl@xTQB$A-c$lBiI~
zySGHmU0o?G?xOQzUgla&z7^Mx<_badVN}fx#uQ3J6j^ak_(Nq)4a;8NrD_q$1jo3d
z!${<|V_FT8uKB`!hJ0BrMnrSu>PQ#{<~p#%*M5~n-8SLqaRHiDA)Cn8G$OH(sv5V#
zOUWRR;k9gv_0<z%_Zg{lh%2m-TB_waV)CH${fqmp<$>{d`Ae+J@{4=}qZ2iCU$MW@
z%$UUEnb}@YUQvepwwkt5j*(C^-E(Q589^;?{!42=|0UyNB+}B@M#q|qwlA~Os?c89
zx)#JoCT=_s*N9rKoibj=jvCh7%$RyrqOG=Jyp&dq+|7_#l-e$FrMot}F6ObOX2thb
z3)ihO#i&M#cDN3R>DSg|dkddgb>Rxl*an4qZMO7def9#)kFRuk8Nuw{Y=Z!FKJNrG
z)qRIkG4vZM?HK3fRPH@xDyJ$*>nc^L*EC8$#5J(>2&`}n&6t7}wQZY`bz`L~k5b`h
zPFwMpJ+JJBb9YcPhY88ViidT@C3cyN7B*%PG{t{4Nf?#f0H+<1F>gxo;b>tlylUe8
zr`6o!g<Fzx@(?V&_@Cm+RF_rCnNL`@-@6*orsXn^O(QMIptMaRwf!dMW3*;FR`THD
zO`yy#Z}o3<VDIydBC4f(IiyetqT>THn6&(I>#27oON%-$p>8UU5}?SMrNGBpQikuc
zCzsLY4*d}K<K0t|*N0qoZPUfoHLP0p7)vH<z#$cxja1hjSy#4BpJ!8#ij&Hh7I|{N
zaa-0G%9HI=-j(m7At-4uUjr|0R%N_Bn>9#!uau<f1b)Q+wLR$Cb8ru*L$VfE$Ckom
zSdoS0vMR|XvDt&#WVvjX%qkAd;;$sPk3^<U(Cy<H&yk%*=Bs1%sM=3@ryr%T=$Sk@
zo%+Zzn>xa!EhACl)lf%Bv|=O3jF)t>(74Dk14nO7ChpvtIqvFA1I*D~isu9iZex;Z
zxu(_Fk%as}9J?%mK{O;uSaOjH_8XsMu}e;=5IRHPp)6RoRSa5w3D5lLMYlNSPxbT~
zH}qo-g7Z>kv#s3c5*zZ7JYhXlG7a-gA-A8()0MQO##BZUpZAlox_+=L3986%XSy^t
zj_!a?8{U*|j#I{_1f;nn*%lgH3|M+4*+rH3$@!lny7#o4DLMb2<<DPo#$N-sfxn>e
z&%v|cBj8bR8~6@q_s@Y}1-}B;z%rNyH-OJ@X8#57UJ!s5m<BI#UjGXCG<X8+15@A)
z;3jYlc$xG1AAny5LvRSpft}!1@O{qguYk{h$3O`7fWPOw{&zs~`9BHX4^D&K;9hVo
z_+!rRAFyZnDgM65+5NA<=fN}JLm&e^&;|E^w}BhMw>iiEDR>HGK=S|PeE(MPM(`qM
z`ric4fEDm|@HNi#zXU!4?ganAS^jUq3*ZCbeV_^M0Y3?@1z%+>WIR4CW0HTwgxqH<
zfv|-x`Kn_hNxDR_LtxP;PJdenY{}A=$FxepI$6?SN1mijH{<ZddZKeBO#=|iWH!4I
zY1gf2<*klAgzd<WuzbU_P<IELH+@JM*~oaJkW}r_dHnVSB^#W~coP0fnViifPtxXd
zdTH_BOp;@ng=8~Qi9}B#kv3FGUq;gKkf9Zit15G|V3@Bz^ikS$NuZ}|dQUK|&>?<O
z7WTT%oh;RrhrAh6FdNC#QmIY9LOS%pA^(V|Cy=!^C9JbiN3OzVOs_1z@m(@nW$7i!
ztiCKMSWOfw>0m0=DV8ZAAy&2ZAdN}1mOL_@WPFL;5c`0h1d!~z6GieF@e{jxo?X|g
z+-i89<G4GAvoA;kS%6s;t0zPm_)9hdt=RbG|DUMVtS80g52PpE=1%rY(_^<jBl|`e
zn0k6(^m0>-9%C?PCXzE{&yB=r44bw%#GYEx;c`?rN|#F}bITFChvVt>G%S&hp>mVe
zQE6dIbapZ_cQ0O+W(&EhGj+_^o8^)Q#1^P~YRPEg65o&;t?9pJFD*ZG&pnsyD2aDR
zkIf%FJb!eKvtjexl+INflWw|})pky+UAv~$U3CtQLb=y@7W-SwSHGGfc4{}VRa2=(
zGisZJGvoxwdCR=$!*}!UPfDh#vn5v0G|)%ug3wZx?kY5uK8{PMO)~#ZgsUCiKH9T~
z{=$JWE41AJRU1Hu($TS1DYI1vSBX4~t<Ip?>gP>Vr`j^bQ{t&>jNO<7?7G{}<h2x1
z>L}L^GBEY)W==6B601}3#WEPUQX5)|f}sSMOQePggeLaXEY>HZdNVpwNi`+JfKOKT
zW0~=A+nMAHOJ816)<n$=MVcit*-DARs&)pI=wlOwv+}*J_U)5|aoa)Bm<dnH3R4(G
zh5g~6o#|qwM^IOVx)4UBHGPo?jYJkVynr_H%)P&r_orY{QpZRots<g98!KtU99yF8
zZfuFRi*kv)45Mv?Z2fBAa&?(`ad4JbROAIR=F@5WXt^TP3ZvbW?Y=Fo6xzxgEax?{
z(yz+}EiJKYr))hY-jcU$`%q)xrWwp)s5x*U3JzT7mgn?JZ&Yd-ZxA)it9iDq`snz&
zvDE4)lvrqlCfz*QCHtOE%zHp;hi=MF0UaUN$02Kt#j#D9Se{Ia4K=DUb#v3QB9oxP
zwzU1w@6WNRu*bx!Fm!?M5q`vZteUtpl5-)+%;rs24mL%JOcA9&qh!VLrXZ-fOO729
zKPK3rQ|qhji{p;jMqasN`rfA);}JIIeOp|cZr)uN8TD0FD!Q+0X5s+sdf+Oou)><h
z@^6Kg)7(m_yy$C1XT{;NAb4%c(0;9`ypg*;l3D_HPgH9qao@bzRy$*&a%wMunV*_c
zmoB*%A5@d;G*^Q@+GSJ180JQ6>pIJ;jMG|PctyQ!GSmbiv3Qr)u&ouEmum^pkkc@$
zw#m&VrMmx{u&J%gPF<Xum0rTGOo$t96J~@>TffSIcHAo>@*W5;6-uS6@+S&5%ay{F
cT45AdikYcun%oMsfwvWjb+Ig{u-NAPH%ay)TmS$7
Text/Shakespeare.hs | 3 +++
1 file changed, 3 insertions(+)
diff --git a/Text/Shakespeare.hs b/Text/Shakespeare.hs
index d300951..fabbf66 100644
index 9eb06a2..1290ab1 100644
--- a/Text/Shakespeare.hs
+++ b/Text/Shakespeare.hs
@@ -22,6 +22,8 @@ module Text.Shakespeare
@@ -23,6 +23,9 @@ module Text.Shakespeare
, Deref
, Parser
+ -- used by TH
+ , pack'
+
#ifdef TEST_EXPORT
, preFilter
#endif
+ -- used by TH splices
+ , pack'
) where
import Data.List (intersperse)
--
1.8.2.rc3
1.7.10.4

View file

@ -1,208 +0,0 @@
From 10484c5f68431349b249f07517c392c4a90bdb05 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Wed, 8 May 2013 01:47:19 -0400
Subject: [PATCH] remove TH
---
Text/Shakespeare.hs | 109 ----------------------------------------------
Text/Shakespeare/Base.hs | 28 ------------
shakespeare.cabal | 2 +-
3 files changed, 1 insertion(+), 138 deletions(-)
diff --git a/Text/Shakespeare.hs b/Text/Shakespeare.hs
index 7750135..fabbf66 100644
--- a/Text/Shakespeare.hs
+++ b/Text/Shakespeare.hs
@@ -12,11 +12,7 @@ module Text.Shakespeare
, WrapInsertion (..)
, PreConversion (..)
, defaultShakespeareSettings
- , shakespeare
- , shakespeareFile
- , shakespeareFileReload
-- * low-level
- , shakespeareFromString
, shakespeareUsedIdentifiers
, RenderUrl
, VarType
@@ -135,39 +131,6 @@ defaultShakespeareSettings = ShakespeareSettings {
, modifyFinalValue = Nothing
}
-instance Lift PreConvert where
- lift (PreConvert convert ignore comment wrapInsertion) =
- [|PreConvert $(lift convert) $(lift ignore) $(lift comment) $(lift wrapInsertion)|]
-
-instance Lift WrapInsertion where
- lift (WrapInsertion indent sb sep sc e ab ac) =
- [|WrapInsertion $(lift indent) $(lift sb) $(lift sep) $(lift sc) $(lift e) $(lift ab) $(lift ac)|]
-
-instance Lift PreConversion where
- lift (ReadProcess command args) =
- [|ReadProcess $(lift command) $(lift args)|]
- lift Id = [|Id|]
-
-instance Lift ShakespeareSettings where
- lift (ShakespeareSettings x1 x2 x3 x4 x5 x6 x7 x8 x9) =
- [|ShakespeareSettings
- $(lift x1) $(lift x2) $(lift x3)
- $(liftExp x4) $(liftExp x5) $(liftExp x6) $(lift x7) $(lift x8) $(liftMExp x9)|]
- where
- liftExp (VarE n) = [|VarE $(liftName n)|]
- liftExp (ConE n) = [|ConE $(liftName n)|]
- liftExp _ = error "liftExp only supports VarE and ConE"
- liftMExp Nothing = [|Nothing|]
- liftMExp (Just e) = [|Just|] `appE` liftExp e
- liftName (Name (OccName a) b) = [|Name (OccName $(lift a)) $(liftFlavour b)|]
- liftFlavour NameS = [|NameS|]
- liftFlavour (NameQ (ModName a)) = [|NameQ (ModName $(lift a))|]
- liftFlavour (NameU _) = error "liftFlavour NameU" -- [|NameU $(lift $ fromIntegral a)|]
- liftFlavour (NameL _) = error "liftFlavour NameL" -- [|NameU $(lift $ fromIntegral a)|]
- liftFlavour (NameG ns (PkgName p) (ModName m)) = [|NameG $(liftNS ns) (PkgName $(lift p)) (ModName $(lift m))|]
- liftNS VarName = [|VarName|]
- liftNS DataName = [|DataName|]
-
type QueryParameters = [(TS.Text, TS.Text)]
type RenderUrl url = (url -> QueryParameters -> TS.Text)
type Shakespeare url = RenderUrl url -> Builder
@@ -302,54 +265,6 @@ pack' = TS.pack
{-# NOINLINE pack' #-}
#endif
-contentsToShakespeare :: ShakespeareSettings -> [Content] -> Q Exp
-contentsToShakespeare rs a = do
- r <- newName "_render"
- c <- mapM (contentToBuilder r) a
- compiledTemplate <- case c of
- -- Make sure we convert this mempty using toBuilder to pin down the
- -- type appropriately
- [] -> fmap (AppE $ wrap rs) [|mempty|]
- [x] -> return x
- _ -> do
- mc <- [|mconcat|]
- return $ mc `AppE` ListE c
- fmap (maybe id AppE $ modifyFinalValue rs) $
- if justVarInterpolation rs
- then return compiledTemplate
- else return $ LamE [VarP r] compiledTemplate
- where
- contentToBuilder :: Name -> Content -> Q Exp
- contentToBuilder _ (ContentRaw s') = do
- ts <- [|fromText . pack'|]
- return $ wrap rs `AppE` (ts `AppE` LitE (StringL s'))
- contentToBuilder _ (ContentVar d) =
- return $ wrap rs `AppE` (toBuilder rs `AppE` derefToExp [] d)
- contentToBuilder r (ContentUrl d) = do
- ts <- [|fromText|]
- return $ wrap rs `AppE` (ts `AppE` (VarE r `AppE` derefToExp [] d `AppE` ListE []))
- contentToBuilder r (ContentUrlParam d) = do
- ts <- [|fromText|]
- up <- [|\r' (u, p) -> r' u p|]
- return $ wrap rs `AppE` (ts `AppE` (up `AppE` VarE r `AppE` derefToExp [] d))
- contentToBuilder r (ContentMix d) =
- return $ derefToExp [] d `AppE` VarE r
-
-shakespeare :: ShakespeareSettings -> QuasiQuoter
-shakespeare r = QuasiQuoter { quoteExp = shakespeareFromString r }
-
-shakespeareFromString :: ShakespeareSettings -> String -> Q Exp
-shakespeareFromString r str = do
- s <- qRunIO $ preFilter r str
- contentsToShakespeare r $ contentFromString r s
-
-shakespeareFile :: ShakespeareSettings -> FilePath -> Q Exp
-shakespeareFile r fp = do
-#ifdef GHC_7_4
- qAddDependentFile fp
-#endif
- readFileQ fp >>= shakespeareFromString r
-
data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin
getVars :: Content -> [(Deref, VarType)]
@@ -369,30 +284,6 @@ data VarExp url = EPlain Builder
shakespeareUsedIdentifiers :: ShakespeareSettings -> String -> [(Deref, VarType)]
shakespeareUsedIdentifiers settings = concatMap getVars . contentFromString settings
-shakespeareFileReload :: ShakespeareSettings -> FilePath -> Q Exp
-shakespeareFileReload rs fp = do
- str <- readFileQ fp
- s <- qRunIO $ preFilter rs str
- let b = shakespeareUsedIdentifiers rs s
- c <- mapM vtToExp b
- rt <- [|shakespeareRuntime|]
- wrap' <- [|\x -> $(return $ wrap rs) . x|]
- r' <- lift rs
- return $ wrap' `AppE` (rt `AppE` r' `AppE` (LitE $ StringL fp) `AppE` ListE c)
- where
- 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 = [|EPlain . $(return $ toBuilder rs)|]
- c VTUrl = [|EUrl|]
- c VTUrlParam = [|EUrlParam|]
- c VTMixin = [|\x -> EMixin $ \r -> $(return $ unwrap rs) $ x r|]
-
-
shakespeareRuntime :: ShakespeareSettings -> FilePath -> [(Deref, VarExp url)] -> Shakespeare url
shakespeareRuntime rs fp cd render' = unsafePerformIO $ do
str <- readFileUtf8 fp
diff --git a/Text/Shakespeare/Base.hs b/Text/Shakespeare/Base.hs
index 7c96898..ef769b1 100644
--- a/Text/Shakespeare/Base.hs
+++ b/Text/Shakespeare/Base.hs
@@ -52,34 +52,6 @@ data Deref = DerefModulesIdent [String] Ident
| DerefTuple [Deref]
deriving (Show, Eq, Read, Data, Typeable, Ord)
-instance Lift Ident where
- lift (Ident s) = [|Ident|] `appE` lift s
-instance Lift Deref where
- lift (DerefModulesIdent v s) = do
- dl <- [|DerefModulesIdent|]
- v' <- lift v
- s' <- lift s
- return $ dl `AppE` v' `AppE` s'
- lift (DerefIdent s) = do
- dl <- [|DerefIdent|]
- s' <- lift s
- return $ dl `AppE` s'
- lift (DerefBranch x y) = do
- x' <- lift x
- y' <- lift y
- db <- [|DerefBranch|]
- return $ db `AppE` x' `AppE` y'
- lift (DerefIntegral i) = [|DerefIntegral|] `appE` lift i
- lift (DerefRational r) = do
- n <- lift $ numerator r
- d <- lift $ denominator r
- per <- [|(%) :: Int -> Int -> Ratio Int|]
- dr <- [|DerefRational|]
- return $ dr `AppE` InfixE (Just n) per (Just d)
- lift (DerefString s) = [|DerefString|] `appE` lift s
- lift (DerefList x) = [|DerefList $(lift x)|]
- lift (DerefTuple x) = [|DerefTuple $(lift x)|]
-
derefParens, derefCurlyBrackets :: UserParser a Deref
derefParens = between (char '(') (char ')') parseDeref
derefCurlyBrackets = between (char '{') (char '}') parseDeref
diff --git a/shakespeare.cabal b/shakespeare.cabal
index 01c8d5d..0fff966 100644
--- a/shakespeare.cabal
+++ b/shakespeare.cabal
@@ -27,7 +27,7 @@ library
, template-haskell
, parsec >= 2 && < 4
, text >= 0.7 && < 0.12
- , process >= 1.0 && < 1.2
+ , process >= 1.0 && < 1.3
exposed-modules:
Text.Shakespeare
--
1.7.10.4

View file

@ -0,0 +1,24 @@
From 3a04b41ffce4e4e87b0fedd3a1e3434a3f06cc76 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 00:18:12 +0000
Subject: [PATCH] hardcode little endian
---
c_impl/optimized/skein_port.h | 1 +
1 file changed, 1 insertion(+)
diff --git a/c_impl/optimized/skein_port.h b/c_impl/optimized/skein_port.h
index a2d0fc2..6929bb0 100644
--- a/c_impl/optimized/skein_port.h
+++ b/c_impl/optimized/skein_port.h
@@ -45,6 +45,7 @@ typedef uint64_t u64b_t; /* 64-bit unsigned integer */
* platform-specific code instead (e.g., for big-endian CPUs).
*
*/
+#define SKEIN_NEED_SWAP (0)
#ifndef SKEIN_NEED_SWAP /* compile-time "override" for endianness? */
#include "brg_endian.h" /* get endianness selection */
--
1.7.10.4

View file

@ -1,43 +1,29 @@
From abab0f8202998a3e88c5dc5f67a8245da6c174b3 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:36:20 -0400
From 28e6a6599ee91e15aa7b2f9d25433490f192f22e Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sat, 21 Sep 2013 23:17:29 +0000
Subject: [PATCH] remove IPv6 stuff
---
Network/Socks5.hs | 1 -
Network/Socks5/Command.hs | 16 ++--------------
Network/Socks5/Types.hs | 3 +--
Network/Socks5/Wire.hs | 2 --
4 files changed, 3 insertions(+), 19 deletions(-)
Network/Socks5/Command.hs | 8 +-------
Network/Socks5/Conf.hs | 1 -
Network/Socks5/Lowlevel.hs | 1 -
Network/Socks5/Types.hs | 18 +-----------------
Network/Socks5/Wire.hs | 2 --
5 files changed, 2 insertions(+), 28 deletions(-)
diff --git a/Network/Socks5.hs b/Network/Socks5.hs
index 67b0060..80efb9c 100644
--- a/Network/Socks5.hs
+++ b/Network/Socks5.hs
@@ -54,7 +54,6 @@ socksConnectAddr :: Socket -> SockAddr -> SockAddr -> IO ()
socksConnectAddr sock sockserver destaddr = withSocks sock sockserver $ do
case destaddr of
SockAddrInet p h -> socks5ConnectIPV4 sock h p >> return ()
- SockAddrInet6 p _ h _ -> socks5ConnectIPV6 sock h p >> return ()
_ -> error "unsupported unix sockaddr type"
-- | connect a new socket to the socks server, and connect the stream to a FQDN
diff --git a/Network/Socks5/Command.hs b/Network/Socks5/Command.hs
index 2952706..db994c9 100644
index 8ce06ec..222d954 100644
--- a/Network/Socks5/Command.hs
+++ b/Network/Socks5/Command.hs
@@ -9,9 +9,8 @@
--
module Network.Socks5.Command
( socks5Establish
- , socks5ConnectIPV4
- , socks5ConnectIPV6
, socks5ConnectDomainName
+ , socks5ConnectIPV4
-- * lowlevel interface
, socks5Rpc
) where
@@ -23,7 +22,7 @@ import qualified Data.ByteString as B
@@ -12,7 +12,6 @@ module Network.Socks5.Command
, Connect(..)
, Command(..)
, connectIPV4
- , connectIPV6
, connectDomainName
-- * lowlevel interface
, rpc
@@ -28,7 +27,7 @@ import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import Data.Serialize
@ -46,50 +32,92 @@ index 2952706..db994c9 100644
import Network.Socket.ByteString
import Network.Socks5.Types
@@ -46,17 +45,6 @@ socks5ConnectIPV4 socket hostaddr port = onReply <$> socks5Rpc socket request
onReply (SocksAddrIPV4 h, p) = (h, p)
onReply _ = error "ipv4 requested, got something different"
@@ -64,11 +63,6 @@ connectIPV4 socket hostaddr port = onReply <$> rpc_ socket (Connect $ SocksAddre
where onReply (SocksAddrIPV4 h, p) = (h, p)
onReply _ = error "ipv4 requested, got something different"
-socks5ConnectIPV6 :: Socket -> HostAddress6 -> PortNumber -> IO (HostAddress6, PortNumber)
-socks5ConnectIPV6 socket hostaddr6 port = onReply <$> socks5Rpc socket request
- where
- request = SocksRequest
- { requestCommand = SocksCommandConnect
- , requestDstAddr = SocksAddrIPV6 hostaddr6
- , requestDstPort = fromIntegral port
- }
- onReply (SocksAddrIPV6 h, p) = (h, p)
- onReply _ = error "ipv6 requested, got something different"
-connectIPV6 :: Socket -> HostAddress6 -> PortNumber -> IO (HostAddress6, PortNumber)
-connectIPV6 socket hostaddr6 port = onReply <$> rpc_ socket (Connect $ SocksAddress (SocksAddrIPV6 hostaddr6) port)
- where onReply (SocksAddrIPV6 h, p) = (h, p)
- onReply _ = error "ipv6 requested, got something different"
-
-- TODO: FQDN should only be ascii, maybe putting a "fqdn" data type
-- in front to make sure and make the BC.pack safe.
socks5ConnectDomainName :: Socket -> String -> PortNumber -> IO (SocksAddr, PortNumber)
connectDomainName :: Socket -> String -> PortNumber -> IO (SocksHostAddress, PortNumber)
diff --git a/Network/Socks5/Conf.hs b/Network/Socks5/Conf.hs
index c29ff7b..007d382 100644
--- a/Network/Socks5/Conf.hs
+++ b/Network/Socks5/Conf.hs
@@ -47,5 +47,4 @@ defaultSocksConfFromSockAddr sockaddr = SocksConf server SocksVer5
where server = SocksAddress haddr port
(haddr,port) = case sockaddr of
SockAddrInet p h -> (SocksAddrIPV4 h, p)
- SockAddrInet6 p _ h _ -> (SocksAddrIPV6 h, p)
_ -> error "unsupported unix sockaddr type"
diff --git a/Network/Socks5/Lowlevel.hs b/Network/Socks5/Lowlevel.hs
index c10d9b9..2c3d59c 100644
--- a/Network/Socks5/Lowlevel.hs
+++ b/Network/Socks5/Lowlevel.hs
@@ -17,7 +17,6 @@ resolveToSockAddr :: SocksAddress -> IO SockAddr
resolveToSockAddr (SocksAddress sockHostAddr port) =
case sockHostAddr of
SocksAddrIPV4 ha -> return $ SockAddrInet port ha
- SocksAddrIPV6 ha6 -> return $ SockAddrInet6 port 0 ha6 0
SocksAddrDomainName bs -> do he <- getHostByName (BC.unpack bs)
return $ SockAddrInet port (hostAddress he)
diff --git a/Network/Socks5/Types.hs b/Network/Socks5/Types.hs
index 5dc7d5e..12dea99 100644
index 7fbec25..17c7c83 100644
--- a/Network/Socks5/Types.hs
+++ b/Network/Socks5/Types.hs
@@ -17,7 +17,7 @@ module Network.Socks5.Types
@@ -19,7 +19,7 @@ module Network.Socks5.Types
import Data.ByteString (ByteString)
import Data.Word
import Data.Data
-import Network.Socket (HostAddress, HostAddress6)
+import Network.Socket (HostAddress)
-import Network.Socket (HostAddress, HostAddress6, PortNumber)
+import Network.Socket (HostAddress, PortNumber)
import Control.Exception
import qualified Data.ByteString.Char8 as BC
import Numeric (showHex)
@@ -53,12 +53,10 @@ data SocksMethod =
data SocksHostAddress =
SocksAddrIPV4 !HostAddress
| SocksAddrDomainName !ByteString
- | SocksAddrIPV6 !HostAddress6
deriving (Eq,Ord)
data SocksCommand =
@@ -38,7 +38,6 @@ data SocksMethod =
data SocksAddr =
SocksAddrIPV4 HostAddress
| SocksAddrDomainName ByteString
- | SocksAddrIPV6 HostAddress6
deriving (Show,Eq)
instance Show SocksHostAddress where
show (SocksAddrIPV4 ha) = "SocksAddrIPV4(" ++ showHostAddress ha ++ ")"
- show (SocksAddrIPV6 ha6) = "SocksAddrIPV6(" ++ showHostAddress6 ha6 ++ ")"
show (SocksAddrDomainName dn) = "SocksAddrDomainName(" ++ BC.unpack dn ++ ")"
data SocksReply =
-- | Converts a HostAddress to a String in dot-decimal notation
@@ -69,20 +67,6 @@ showHostAddress num = concat [show q1, ".", show q2, ".", show q3, ".", show q4]
(num''',q3) = num'' `quotRem` 256
(_,q4) = num''' `quotRem` 256
--- | Converts a IPv6 HostAddress6 to standard hex notation
-showHostAddress6 :: HostAddress6 -> String
-showHostAddress6 (a,b,c,d) =
- (concat . intersperse ":" . map (flip showHex ""))
- [p1,p2,p3,p4,p5,p6,p7,p8]
- where (a',p2) = a `quotRem` 65536
- (_,p1) = a' `quotRem` 65536
- (b',p4) = b `quotRem` 65536
- (_,p3) = b' `quotRem` 65536
- (c',p6) = c `quotRem` 65536
- (_,p5) = c' `quotRem` 65536
- (d',p8) = d `quotRem` 65536
- (_,p7) = d' `quotRem` 65536
-
-- | Describe a Socket address on the SOCKS protocol
data SocksAddress = SocksAddress !SocksHostAddress !PortNumber
deriving (Show,Eq,Ord)
diff --git a/Network/Socks5/Wire.hs b/Network/Socks5/Wire.hs
index 2cfed52..d3bd9c5 100644
index 3ab95a8..2881988 100644
--- a/Network/Socks5/Wire.hs
+++ b/Network/Socks5/Wire.hs
@@ -41,12 +41,10 @@ data SocksResponse = SocksResponse
@@ -46,12 +46,10 @@ data SocksResponse = SocksResponse
getAddr 1 = SocksAddrIPV4 <$> getWord32be
getAddr 3 = SocksAddrDomainName <$> (getWord8 >>= getByteString . fromIntegral)
@ -101,7 +129,7 @@ index 2cfed52..d3bd9c5 100644
-putAddr (SocksAddrIPV6 (a,b,c,d)) = putWord8 4 >> mapM_ putWord32host [a,b,c,d]
getSocksRequest 5 = do
cmd <- toEnum . fromIntegral <$> getWord8
cmd <- toEnum . fromIntegral <$> getWord8
--
1.7.10.4

View file

@ -1,25 +0,0 @@
From 2feaef797641587a3da83753ee17d20e712c79cf Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:36:30 -0400
Subject: [PATCH] modify to build with unreleased ghc
---
split.cabal | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/split.cabal b/split.cabal
index 2183c3e..29b9b32 100644
--- a/split.cabal
+++ b/split.cabal
@@ -51,7 +51,7 @@ Source-repository head
Library
ghc-options: -Wall
- build-depends: base <4.7
+ build-depends: base <4.8
exposed-modules: Data.List.Split, Data.List.Split.Internals
default-language: Haskell2010
Hs-source-dirs: src
--
1.7.10.4

View file

@ -1,25 +0,0 @@
From c40fe2c484096c5de4cac8ca14a0ca5d892999f7 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:36:43 -0400
Subject: [PATCH] hack for cross-compiling
---
syb.cabal | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/syb.cabal b/syb.cabal
index 0aee93d..0a645c6 100644
--- a/syb.cabal
+++ b/syb.cabal
@@ -17,7 +17,7 @@ description:
category: Generics
stability: provisional
-build-type: Custom
+build-type: Simple
cabal-version: >= 1.6
extra-source-files: tests/*.hs,
--
1.7.10.4

View file

@ -1,81 +0,0 @@
From 4023b952871ad2bc248db887716d06932ac0dbb9 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Wed, 8 May 2013 14:00:19 -0400
Subject: [PATCH] hacks for android
---
cbits/conv.c | 4 +---
unix-time.cabal | 28 ++--------------------------
2 files changed, 3 insertions(+), 29 deletions(-)
diff --git a/cbits/conv.c b/cbits/conv.c
index 3b6a129..5a68f91 100644
--- a/cbits/conv.c
+++ b/cbits/conv.c
@@ -1,5 +1,3 @@
-#include "config.h"
-
#if IS_LINUX
/* Linux cheats AC_CHECK_FUNCS(strptime_l), sigh. */
#define THREAD_SAFE 0
@@ -51,7 +49,7 @@ time_t c_parse_unix_time_gmt(char *fmt, char *src) {
#else
strptime(src, fmt, &dst);
#endif
- return timegm(&dst);
+ return NULL; /* timegm(&dst); */
}
void c_format_unix_time(char *fmt, time_t src, char* dst, int siz) {
diff --git a/unix-time.cabal b/unix-time.cabal
index a905d63..f32d952 100644
--- a/unix-time.cabal
+++ b/unix-time.cabal
@@ -8,7 +8,7 @@ Synopsis: Unix time parser/formatter and utilities
Description: Fast parser\/formatter\/utilities for Unix time
Category: Data
Cabal-Version: >= 1.10
-Build-Type: Configure
+Build-Type: Simple
Extra-Source-Files: cbits/conv.c cbits/config.h.in configure configure.ac
Extra-Tmp-Files: config.log config.status autom4te.cache cbits/config.h
@@ -21,34 +21,10 @@ Library
Data.UnixTime.Types
Data.UnixTime.Sys
Build-Depends: base >= 4 && < 5
- , bytestring
+ , bytestring (>= 0.10.3.0)
, old-time
C-Sources: cbits/conv.c
-Test-Suite doctests
- Type: exitcode-stdio-1.0
- HS-Source-Dirs: test
- Ghc-Options: -threaded -Wall
- Main-Is: doctests.hs
- Build-Depends: base
- , doctest >= 0.9.3
-
-Test-Suite spec
- Type: exitcode-stdio-1.0
- Default-Language: Haskell2010
- Hs-Source-Dirs: test
- Ghc-Options: -Wall
- Main-Is: Spec.hs
- Other-Modules: UnixTimeSpec
- Build-Depends: base
- , bytestring
- , hspec
- , old-locale
- , old-time
- , QuickCheck
- , time
- , unix-time
-
Source-Repository head
Type: git
Location: https://github.com/kazu-yamamoto/unix-time
--
1.7.10.4

View file

@ -0,0 +1,25 @@
From eff7034f0c9f80fd30c9d8952b3fd0a343adccc8 Mon Sep 17 00:00:00 2001
From: foo <bar>
Date: Mon, 23 Sep 2013 00:12:35 +0000
Subject: [PATCH] hack for Bionic
---
cbits/conv.c | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/cbits/conv.c b/cbits/conv.c
index 7ff7b87..2e4c870 100644
--- a/cbits/conv.c
+++ b/cbits/conv.c
@@ -55,7 +55,7 @@ time_t c_parse_unix_time_gmt(char *fmt, char *src) {
#else
strptime(src, fmt, &dst);
#endif
- return timegm(&dst);
+ return NULL; /* timegm(&dst); (not in Bionic) */
}
size_t c_format_unix_time(char *fmt, time_t src, char* dst, int siz) {
--
1.7.10.4

View file

@ -1,91 +0,0 @@
From abca378462337ca0eb13a7e4d3073cb96a50d36c Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:37:23 -0400
Subject: [PATCH] remove stuff not available on Android
---
System/Posix/Resource.hsc | 4 ++++
System/Posix/Terminal/Common.hsc | 29 +++--------------------------
2 files changed, 7 insertions(+), 26 deletions(-)
diff --git a/System/Posix/Resource.hsc b/System/Posix/Resource.hsc
index 6651998..2615b1e 100644
--- a/System/Posix/Resource.hsc
+++ b/System/Posix/Resource.hsc
@@ -101,7 +101,9 @@ packResource ResourceTotalMemory = (#const RLIMIT_AS)
#endif
unpackRLimit :: CRLim -> ResourceLimit
+#if 0
unpackRLimit (#const RLIM_INFINITY) = ResourceLimitInfinity
+#endif
#ifdef RLIM_SAVED_MAX
unpackRLimit (#const RLIM_SAVED_MAX) = ResourceLimitUnknown
unpackRLimit (#const RLIM_SAVED_CUR) = ResourceLimitUnknown
@@ -109,7 +111,9 @@ unpackRLimit (#const RLIM_SAVED_CUR) = ResourceLimitUnknown
unpackRLimit other = ResourceLimit (fromIntegral other)
packRLimit :: ResourceLimit -> Bool -> CRLim
+#if 0
packRLimit ResourceLimitInfinity _ = (#const RLIM_INFINITY)
+#endif
#ifdef RLIM_SAVED_MAX
packRLimit ResourceLimitUnknown True = (#const RLIM_SAVED_CUR)
packRLimit ResourceLimitUnknown False = (#const RLIM_SAVED_MAX)
diff --git a/System/Posix/Terminal/Common.hsc b/System/Posix/Terminal/Common.hsc
index 3a6254d..32a22f2 100644
--- a/System/Posix/Terminal/Common.hsc
+++ b/System/Posix/Terminal/Common.hsc
@@ -419,11 +419,7 @@ foreign import ccall unsafe "tcsendbreak"
-- | @drainOutput fd@ calls @tcdrain@ to block until all output
-- written to @Fd@ @fd@ has been transmitted.
drainOutput :: Fd -> IO ()
-drainOutput (Fd fd) = throwErrnoIfMinus1_ "drainOutput" (c_tcdrain fd)
-
-foreign import ccall unsafe "tcdrain"
- c_tcdrain :: CInt -> IO CInt
-
+drainOutput (Fd fd) = error "drainOutput not implemented"
data QueueSelector
= InputQueue -- TCIFLUSH
@@ -434,16 +430,7 @@ data QueueSelector
-- pending input and\/or output for @Fd@ @fd@,
-- as indicated by the @QueueSelector@ @queues@.
discardData :: Fd -> QueueSelector -> IO ()
-discardData (Fd fd) queue =
- throwErrnoIfMinus1_ "discardData" (c_tcflush fd (queue2Int queue))
- where
- queue2Int :: QueueSelector -> CInt
- queue2Int InputQueue = (#const TCIFLUSH)
- queue2Int OutputQueue = (#const TCOFLUSH)
- queue2Int BothQueues = (#const TCIOFLUSH)
-
-foreign import ccall unsafe "tcflush"
- c_tcflush :: CInt -> CInt -> IO CInt
+discardData (Fd fd) queue = error "discardData not implemented"
data FlowAction
= SuspendOutput -- ^ TCOOFF
@@ -455,17 +442,7 @@ data FlowAction
-- flow of data on @Fd@ @fd@, as indicated by
-- @action@.
controlFlow :: Fd -> FlowAction -> IO ()
-controlFlow (Fd fd) action =
- throwErrnoIfMinus1_ "controlFlow" (c_tcflow fd (action2Int action))
- where
- action2Int :: FlowAction -> CInt
- action2Int SuspendOutput = (#const TCOOFF)
- action2Int RestartOutput = (#const TCOON)
- action2Int TransmitStop = (#const TCIOFF)
- action2Int TransmitStart = (#const TCION)
-
-foreign import ccall unsafe "tcflow"
- c_tcflow :: CInt -> CInt -> IO CInt
+controlFlow (Fd fd) action = error "controlFlow not implemented"
-- | @getTerminalProcessGroupID fd@ calls @tcgetpgrp@ to
-- obtain the @ProcessGroupID@ of the foreground process group
--
1.7.10.4

View file

@ -0,0 +1,32 @@
From 2d1f0027ae1ca56bbf4449887cf3bc61dc1c8e84 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sat, 21 Sep 2013 22:32:01 +0000
Subject: [PATCH] fix build with new ghc
---
Data/HashMap/Base.hs | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/Data/HashMap/Base.hs b/Data/HashMap/Base.hs
index 6a77df4..93a384d 100644
--- a/Data/HashMap/Base.hs
+++ b/Data/HashMap/Base.hs
@@ -86,7 +86,7 @@ import qualified Data.List as L
import Data.Monoid (Monoid(mempty, mappend))
import Data.Traversable (Traversable(..))
import Data.Word (Word)
-import GHC.Exts ((==#), build, reallyUnsafePtrEquality#)
+import GHC.Exts ((==#), build, reallyUnsafePtrEquality#, tagToEnum#)
import Prelude hiding (filter, foldr, lookup, map, null, pred)
import qualified Data.HashMap.Array as A
@@ -1072,5 +1072,5 @@ fullNodeMask = complement (complement 0 `unsafeShiftL` maxChildren)
-- | Check if two the two arguments are the same value. N.B. This
-- function might give false negatives (due to GC moving objects.)
ptrEq :: a -> a -> Bool
-ptrEq x y = reallyUnsafePtrEquality# x y ==# 1#
+ptrEq x y = tagToEnum# (reallyUnsafePtrEquality# x y ==# 1#)
{-# INLINE ptrEq #-}
--
1.7.10.4

View file

@ -1,25 +0,0 @@
From 3a4ee8091ba9da44f9f4a04522a5ff45fabe70d9 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:37:56 -0400
Subject: [PATCH] disable optimisation that breaks when cross-compiling
This needs TH to work actually.
---
Data/Vector/Fusion/Stream/Monadic.hs | 1 -
1 file changed, 1 deletion(-)
diff --git a/Data/Vector/Fusion/Stream/Monadic.hs b/Data/Vector/Fusion/Stream/Monadic.hs
index 51fec75..b089b3d 100644
--- a/Data/Vector/Fusion/Stream/Monadic.hs
+++ b/Data/Vector/Fusion/Stream/Monadic.hs
@@ -101,7 +101,6 @@ import GHC.Exts ( SpecConstrAnnotation(..) )
data SPEC = SPEC | SPEC2
#if __GLASGOW_HASKELL__ >= 700
-{-# ANN type SPEC ForceSpecConstr #-}
#endif
emptyStream :: String
--
1.7.10.4

View file

@ -0,0 +1,130 @@
From af259b521574b734a7a0b1b3e9e6868df33ebdb9 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sat, 21 Sep 2013 23:47:47 +0000
Subject: [PATCH] hack to build with new ghc
---
Data/Vector.hs | 1 -
Data/Vector/Fusion/Stream/Monadic.hs | 1 -
Data/Vector/Generic.hs | 10 ++--------
Data/Vector/Primitive.hs | 1 -
Data/Vector/Storable.hs | 1 -
Data/Vector/Unboxed/Base.hs | 15 +--------------
6 files changed, 3 insertions(+), 26 deletions(-)
diff --git a/Data/Vector.hs b/Data/Vector.hs
index 138b2db..92c4387 100644
--- a/Data/Vector.hs
+++ b/Data/Vector.hs
@@ -215,7 +215,6 @@ instance Data a => Data (Vector a) where
toConstr _ = error "toConstr"
gunfold _ _ = error "gunfold"
dataTypeOf _ = G.mkType "Data.Vector.Vector"
- dataCast1 = G.dataCast
type instance G.Mutable Vector = MVector
diff --git a/Data/Vector/Fusion/Stream/Monadic.hs b/Data/Vector/Fusion/Stream/Monadic.hs
index 51fec75..b089b3d 100644
--- a/Data/Vector/Fusion/Stream/Monadic.hs
+++ b/Data/Vector/Fusion/Stream/Monadic.hs
@@ -101,7 +101,6 @@ import GHC.Exts ( SpecConstrAnnotation(..) )
data SPEC = SPEC | SPEC2
#if __GLASGOW_HASKELL__ >= 700
-{-# ANN type SPEC ForceSpecConstr #-}
#endif
emptyStream :: String
diff --git a/Data/Vector/Generic.hs b/Data/Vector/Generic.hs
index 78f7260..f4ea80a 100644
--- a/Data/Vector/Generic.hs
+++ b/Data/Vector/Generic.hs
@@ -157,7 +157,7 @@ module Data.Vector.Generic (
showsPrec, readPrec,
-- ** @Data@ and @Typeable@
- gfoldl, dataCast, mkType
+ gfoldl, mkType
) where
import Data.Vector.Generic.Base
@@ -194,7 +194,7 @@ import Prelude hiding ( length, null,
showsPrec )
import qualified Text.Read as Read
-import Data.Typeable ( Typeable1, gcast1 )
+import Data.Typeable ( gcast1 )
#include "vector.h"
@@ -2019,9 +2019,3 @@ gfoldl f z v = z fromList `f` toList v
mkType :: String -> DataType
{-# INLINE mkType #-}
mkType = mkNoRepType
-
-dataCast :: (Vector v a, Data a, Typeable1 v, Typeable1 t)
- => (forall d. Data d => c (t d)) -> Maybe (c (v a))
-{-# INLINE dataCast #-}
-dataCast f = gcast1 f
-
diff --git a/Data/Vector/Primitive.hs b/Data/Vector/Primitive.hs
index 5f59bae..06e84c3 100644
--- a/Data/Vector/Primitive.hs
+++ b/Data/Vector/Primitive.hs
@@ -188,7 +188,6 @@ instance (Data a, Prim a) => Data (Vector a) where
toConstr _ = error "toConstr"
gunfold _ _ = error "gunfold"
dataTypeOf _ = G.mkType "Data.Vector.Primitive.Vector"
- dataCast1 = G.dataCast
type instance G.Mutable Vector = MVector
diff --git a/Data/Vector/Storable.hs b/Data/Vector/Storable.hs
index f9928e4..a17e3d6 100644
--- a/Data/Vector/Storable.hs
+++ b/Data/Vector/Storable.hs
@@ -194,7 +194,6 @@ instance (Data a, Storable a) => Data (Vector a) where
toConstr _ = error "toConstr"
gunfold _ _ = error "gunfold"
dataTypeOf _ = G.mkType "Data.Vector.Storable.Vector"
- dataCast1 = G.dataCast
type instance G.Mutable Vector = MVector
diff --git a/Data/Vector/Unboxed/Base.hs b/Data/Vector/Unboxed/Base.hs
index 00350cb..c13ea20 100644
--- a/Data/Vector/Unboxed/Base.hs
+++ b/Data/Vector/Unboxed/Base.hs
@@ -31,7 +31,7 @@ import Data.Word ( Word, Word8, Word16, Word32, Word64 )
import Data.Int ( Int8, Int16, Int32, Int64 )
import Data.Complex
-import Data.Typeable ( Typeable1(..), Typeable2(..), mkTyConApp,
+import Data.Typeable ( mkTyConApp,
#if MIN_VERSION_base(4,4,0)
mkTyCon3
#else
@@ -65,19 +65,6 @@ vectorTyCon = mkTyCon3 "vector"
vectorTyCon m s = mkTyCon $ m ++ "." ++ s
#endif
-instance Typeable1 Vector where
- typeOf1 _ = mkTyConApp (vectorTyCon "Data.Vector.Unboxed" "Vector") []
-
-instance Typeable2 MVector where
- typeOf2 _ = mkTyConApp (vectorTyCon "Data.Vector.Unboxed.Mutable" "MVector") []
-
-instance (Data a, Unbox a) => Data (Vector a) where
- gfoldl = G.gfoldl
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = G.mkType "Data.Vector.Unboxed.Vector"
- dataCast1 = G.dataCast
-
-- ----
-- Unit
-- ----
--
1.7.10.4

View file

@ -1,16 +1,19 @@
From c18ae75852b1340ca502528138bf421659f61a3d Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Mon, 15 Apr 2013 12:44:15 -0400
Subject: [PATCH] remove TH
From 432a8fc47bb11cf8fd0a832e033cfb94a6332dbe Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 07:29:39 +0000
Subject: [PATCH] deal with TH
Export modules referenced by it.
Should not need these icons in git-annex, so not worth using the Evil
Splicer.
---
Network/Wai/Application/Static.hs | 4 ----
1 file changed, 4 deletions(-)
Network/Wai/Application/Static.hs | 4 ----
wai-app-static.cabal | 2 +-
2 files changed, 1 insertion(+), 5 deletions(-)
diff --git a/Network/Wai/Application/Static.hs b/Network/Wai/Application/Static.hs
index 3195fbb..b48aa01 100644
index 3f07391..75709b7 100644
--- a/Network/Wai/Application/Static.hs
+++ b/Network/Wai/Application/Static.hs
@@ -33,8 +33,6 @@ import Control.Monad.IO.Class (liftIO)
@ -31,6 +34,21 @@ index 3195fbb..b48aa01 100644
staticAppPieces ss rawPieces req = liftIO $ do
case toPieces rawPieces of
Just pieces -> checkPieces ss pieces req >>= response
diff --git a/wai-app-static.cabal b/wai-app-static.cabal
index ec22813..e944caa 100644
--- a/wai-app-static.cabal
+++ b/wai-app-static.cabal
@@ -56,9 +56,9 @@ library
WaiAppStatic.Storage.Embedded
WaiAppStatic.Listing
WaiAppStatic.Types
- other-modules: Util
WaiAppStatic.Storage.Embedded.Runtime
WaiAppStatic.Storage.Embedded.TH
+ other-modules: Util
ghc-options: -Wall
extensions: CPP
--
1.8.2.rc3
1.7.10.4

View file

@ -1,26 +0,0 @@
From dc6d0128e666dcab07ddee56a22a4177ebfc0c7b Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:38:33 -0400
Subject: [PATCH] disable CGI module
I don't need it and it failed to build.
---
wai-extra.cabal | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/wai-extra.cabal b/wai-extra.cabal
index 9e9f0fc..007dd0f 100644
--- a/wai-extra.cabal
+++ b/wai-extra.cabal
@@ -44,7 +44,7 @@ Library
, void >= 0.5 && < 0.6
, stringsearch >= 0.3 && < 0.4
- Exposed-modules: Network.Wai.Handler.CGI
+ Exposed-modules:
Network.Wai.Middleware.AcceptOverride
Network.Wai.Middleware.Autohead
Network.Wai.Middleware.CleanPath
--
1.7.10.4

View file

@ -1,108 +0,0 @@
From 3e988dec5ea248611d07d59914e3eb131dc6a165 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 18 Apr 2013 17:44:46 -0400
Subject: [PATCH] remove TH code
---
Text/Hamlet/XML.hs | 81 +-----------------------------------------------------
1 file changed, 1 insertion(+), 80 deletions(-)
diff --git a/Text/Hamlet/XML.hs b/Text/Hamlet/XML.hs
index f587410..bf8ce9e 100644
--- a/Text/Hamlet/XML.hs
+++ b/Text/Hamlet/XML.hs
@@ -1,8 +1,7 @@
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
module Text.Hamlet.XML
- ( xml
- , xmlFile
+ (
) where
import Language.Haskell.TH.Syntax
@@ -18,81 +17,3 @@ import Data.String (fromString)
import qualified Data.Foldable as F
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
-
-xml :: QuasiQuoter
-xml = QuasiQuoter { quoteExp = strToExp }
-
-xmlFile :: FilePath -> Q Exp
-xmlFile = strToExp . TL.unpack <=< qRunIO . readUtf8File
-
-strToExp :: String -> Q Exp
-strToExp s =
- case parseDoc s of
- Error e -> error e
- Ok x -> docsToExp [] x
-
-docsToExp :: Scope -> [Doc] -> Q Exp
-docsToExp scope docs = [| concat $(fmap ListE $ mapM (docToExp scope) docs) |]
-
-docToExp :: Scope -> Doc -> Q Exp
-docToExp scope (DocTag name attrs cs) =
- [| [ X.NodeElement (X.Element ($(liftName name)) $(mkAttrs scope attrs) $(docsToExp scope cs))
- ] |]
-docToExp _ (DocContent (ContentRaw s)) = [| [ X.NodeContent (pack $(lift s)) ] |]
-docToExp scope (DocContent (ContentVar d)) = [| [ X.NodeContent $(return $ derefToExp scope d) ] |]
-docToExp scope (DocContent (ContentEmbed d)) = return $ derefToExp scope d
-docToExp scope (DocForall deref ident@(Ident ident') inside) = do
- let list' = derefToExp scope deref
- name <- newName ident'
- let scope' = (ident, VarE name) : scope
- inside' <- docsToExp scope' inside
- let lam = LamE [VarP name] inside'
- [| F.concatMap $(return lam) $(return list') |]
-docToExp scope (DocWith [] inside) = docsToExp scope inside
-docToExp scope (DocWith ((deref, ident@(Ident name)):dis) inside) = do
- let deref' = derefToExp scope deref
- name' <- newName name
- let scope' = (ident, VarE name') : scope
- inside' <- docToExp scope' (DocWith dis inside)
- let lam = LamE [VarP name'] inside'
- return $ lam `AppE` deref'
-docToExp scope (DocMaybe deref ident@(Ident name) just nothing) = do
- let deref' = derefToExp scope deref
- name' <- newName name
- let scope' = (ident, VarE name') : scope
- inside' <- docsToExp scope' just
- let inside'' = LamE [VarP name'] inside'
- nothing' <-
- case nothing of
- Nothing -> [| [] |]
- Just n -> docsToExp scope n
- [| maybe $(return nothing') $(return inside'') $(return deref') |]
-docToExp scope (DocCond conds final) = do
- unit <- [| () |]
- body <- fmap GuardedB $ mapM go $ conds ++ [(DerefIdent $ Ident "otherwise", fromMaybe [] final)]
- return $ CaseE unit [Match (TupP []) body []]
- where
- go (deref, inside) = do
- inside' <- docsToExp scope inside
- return (NormalG $ derefToExp scope deref, inside')
-
-mkAttrs :: Scope -> [(Maybe Deref, String, [Content])] -> Q Exp
-mkAttrs _ [] = [| Map.empty |]
-mkAttrs scope ((mderef, name, value):rest) = do
- rest' <- mkAttrs scope rest
- this <- [| Map.insert $(liftName name) (T.concat $(fmap ListE $ mapM go value)) |]
- let with = [| $(return this) $(return rest') |]
- case mderef of
- Nothing -> with
- Just deref -> [| if $(return $ derefToExp scope deref) then $(with) else $(return rest') |]
- where
- go (ContentRaw s) = [| pack $(lift s) |]
- go (ContentVar d) = return $ derefToExp scope d
- go ContentEmbed{} = error "Cannot use embed interpolation in attribute value"
-
-liftName :: String -> Q Exp
-liftName s = do
- X.Name local mns _ <- return $ fromString s
- case mns of
- Nothing -> [| X.Name (pack $(lift $ unpack local)) Nothing Nothing |]
- Just ns -> [| X.Name (pack $(lift $ unpack local)) (Just $ pack $(lift $ unpack ns)) Nothing |]
--
1.8.2.rc3

View file

@ -0,0 +1,34 @@
From 3eb7b0a42099721dc19363ac41319efeed4ac5f9 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 05:19:53 +0000
Subject: [PATCH] don't really build
---
yesod-auth.cabal | 11 +----------
1 file changed, 1 insertion(+), 10 deletions(-)
diff --git a/yesod-auth.cabal b/yesod-auth.cabal
index 591ced5..11217be 100644
--- a/yesod-auth.cabal
+++ b/yesod-auth.cabal
@@ -52,16 +52,7 @@ library
, safe
, time
- exposed-modules: Yesod.Auth
- Yesod.Auth.BrowserId
- Yesod.Auth.Dummy
- Yesod.Auth.Email
- Yesod.Auth.OpenId
- Yesod.Auth.Rpxnow
- Yesod.Auth.HashDB
- Yesod.Auth.Message
- Yesod.Auth.GoogleEmail
- other-modules: Yesod.Auth.Routes
+ exposed-modules:
ghc-options: -Wall
source-repository head
--
1.7.10.4

View file

@ -1,476 +0,0 @@
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

View file

@ -1,267 +0,0 @@
From 9ae3db0b3292b53715232fecec3c5e2bf03b89cd Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Fri, 1 Mar 2013 01:02:53 -0400
Subject: [PATCH 2/2] replaced TH in Yesod.Internal.Core
Done by running a build with -ddump-splices and manually pasting in the
spliced code, and then modifying it until it compiles.
(This predated the Evil Splicer, and both this and the previous patch need
to be redone to use it.)
---
Yesod/Internal/Core.hs | 211 +++++++++++++++++++++++++++++++++++++++++++++---
1 file changed, 201 insertions(+), 10 deletions(-)
diff --git a/Yesod/Internal/Core.hs b/Yesod/Internal/Core.hs
index 90c05fc..b9a0ae8 100644
--- a/Yesod/Internal/Core.hs
+++ b/Yesod/Internal/Core.hs
@@ -96,6 +96,9 @@ import System.Log.FastLogger (Logger, mkLogger, loggerDate, LogStr (..), loggerP
import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource)
import System.Log.FastLogger.Date (ZonedDate)
import System.IO (stdout)
+import qualified Data.Foldable
+import qualified Text.Blaze.Internal
+import qualified Text.Hamlet
yesodVersion :: String
yesodVersion = showVersion Paths_yesod_core.version
@@ -164,7 +167,28 @@ 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 = error "defaultLayout not implemented"
+ defaultLayout w = do
+ p <- widgetToPageContent w
+ mmsg <- getMessage
+ hamletToRepHtml $ \ _render_ay88 -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<!DOCTYPE html>\n<html><head><title>");
+ id (TBH.toHtml (pageTitle p));
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</title>");
+ id (pageHead p) _render_ay88;
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</head><body>");
+ Text.Hamlet.maybeH
+ mmsg
+ (\ msg_ay89
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<p class=\"message\">");
+ id (TBH.toHtml msg_ay89);
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</p>") })
+ Nothing;
+ id (pageBody p) _render_ay88;
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack) "</body></html>") }
-- | 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
@@ -505,11 +529,45 @@ applyLayout' title body = fmap chooseRep $ defaultLayout $ do
-- | The default error handler for 'errorHandler'.
defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep
-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"
+defaultErrorHandler NotFound = do
+ r <- waiRequest
+ let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
+ applyLayout' "Not Found" $ \ _render_ayac -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<h1>Not Found</h1><p>");
+ id (TBH.toHtml path');
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</p>") }
+defaultErrorHandler (PermissionDenied msg) =
+ applyLayout' "Permission Denied" $ \ _render_ayah -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<h1>Permission denied</h1><p>");
+ id (TBH.toHtml msg);
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</p>") }
+defaultErrorHandler (InvalidArgs ia) =
+ applyLayout' "Invalid Arguments" $ \ _render_ayam -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<h1>Invalid Arguments</h1><ul>");
+ Data.Foldable.mapM_
+ (\ msg_ayan
+ -> do { id ((Text.Blaze.Internal.preEscapedText . T.pack) "<li>");
+ id (TBH.toHtml msg_ayan);
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</li>") })
+ ia;
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</ul>") }
+defaultErrorHandler (InternalError e) = do
+ applyLayout' "Internal Server Error" $ \ _render_ayau -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<h1>Internal Server Error</h1><pre>");
+ id (TBH.toHtml e);
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</pre>") }
+defaultErrorHandler (BadMethod m) =
+ applyLayout' "Bad Method" $ \ _render_ayaz -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<h1>Method Not Supported</h1><p>Method <code>");
+ id (TBH.toHtml (S8.unpack m));
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "</code> not supported</p>") }
-- | Return the same URL if the user is authorized to see it.
--
@@ -565,10 +623,99 @@ 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 = error "TODO"
-
- headAll = error "TODO"
- let bodyScript = error "TODO"
+ regularScriptLoad = \ _render_aybs -> do { Data.Foldable.mapM_
+ (\ s_aybt
+ -> id (mkScriptTag s_aybt) _render_aybs)
+ scripts;
+ Text.Hamlet.maybeH
+ jscript
+ (\ j_aybu
+ -> Text.Hamlet.maybeH
+ jsLoc
+ (\ s_aybv
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<script src=\"");
+ id (TBH.toHtml s_aybv);
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "\"></script>") })
+ (Just
+ (do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack) "<script>");
+ id (jelper j_aybu) _render_aybs;
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</script>") })))
+ Nothing }
+
+ headAll = \ _render_aybz -> do
+ { id head' _render_aybz;
+ Data.Foldable.mapM_
+ (\ s_aybA -> id (mkLinkTag s_aybA) _render_aybz)
+ stylesheets;
+ Data.Foldable.mapM_
+ (\ s_aybB
+ -> do { Text.Hamlet.maybeH
+ (right (snd s_aybB))
+ (\ t_aybC
+ -> Text.Hamlet.maybeH
+ (fst s_aybB)
+ (\ media_aybD
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<link rel=\"stylesheet\" media=\"");
+ id (TBH.toHtml media_aybD);
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "\" href=\"");
+ id (TBH.toHtml t_aybC);
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "\">") })
+ (Just
+ (do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<link rel=\"stylesheet\" href=\"");
+ id (TBH.toHtml t_aybC);
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "\">") })))
+ Nothing;
+ Text.Hamlet.maybeH
+ (left (snd s_aybB))
+ (\ content_aybE
+ -> Text.Hamlet.maybeH
+ (fst s_aybB)
+ (\ media_aybF
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<style media=\"");
+ id (TBH.toHtml media_aybF);
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "\">");
+ id (TBH.toHtml content_aybE);
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "</style>") })
+ (Just
+ (do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<style>");
+ id (TBH.toHtml content_aybE);
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "</style>") })))
+ Nothing })
+ css;
+ case jsLoader master of
+ BottomOfBody -> return ()
+ BottomOfHeadAsync asyncJsLoader -> id (asyncJsLoader asyncScripts mcomplete) _render_aybz
+ BottomOfHeadBlocking -> id regularScriptLoad _render_aybz
+ }
+
+ let bodyScript = \ _render_aybL -> do {
+ id body _render_aybL;
+ id regularScriptLoad _render_aybL }
return $ PageContent title headAll (case jsLoader master of
BottomOfBody -> bodyScript
@@ -611,6 +758,50 @@ 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 = error "TODO"
+{-
+ \ _render_aybU
+ -> do { Text.Hamlet.maybeH
+ (left eyn)
+ (\ yn_aybV
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack) "<script src=\"");
+ id (TBH.toHtml yn_aybV);
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack) "\"></script>") })
+ Nothing;
+ Text.Hamlet.maybeH
+ (right eyn)
+ (\ yn_aybW
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack) "<script src=\"");
+ id
+ (TBH.toHtml
+ (\ u_aybX -> _render_aybU u_aybX [] yn_aybW));
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack) "\"></script>") })
+ Nothing;
+ Text.Hamlet.maybeH
+ mcomplete
+ (\ complete_aybY
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<script>yepnope({load:");
+ id (TBH.toHtml (jsonArray scripts));
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ ",complete:function(){");
+ id complete_aybY _render_aybU;
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack) "}});</script>") })
+ (Just
+ (do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<script>yepnope({load:");
+ id (TBH.toHtml (jsonArray scripts));
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "});</script>") })) }
+-}
asyncHelper :: (url -> [x] -> Text)
-> [Script (url)]
--
1.7.10.4

View file

@ -1,26 +0,0 @@
From b7e01a2fded6575678db234e1f2de1f104f11376 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Mon, 15 Apr 2013 15:25:07 -0400
Subject: [PATCH 3/3] exports for TH splices
---
Yesod/Widget.hs | 3 +++
1 file changed, 3 insertions(+)
diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs
index bf79150..01ae294 100644
--- a/Yesod/Widget.hs
+++ b/Yesod/Widget.hs
@@ -52,6 +52,9 @@ module Yesod.Widget
, addScriptEither
-- * Internal
, unGWidget
+
+ -- used by TH code
+ , liftW
) where
import Data.Monoid
--
1.8.2.rc3

View file

@ -0,0 +1,427 @@
From 9e15d4af1f53c76a402ec1782e0306a4bee7eec7 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 04:03:56 +0000
Subject: [PATCH] expad TH
used EvilSplicer
Has to remove some logger TH splices which didn't come out.
---
Yesod/Core.hs | 2 -
Yesod/Core/Class/Yesod.hs | 247 ++++++++++++++++++++++++++++++--------------
Yesod/Core/Dispatch.hs | 7 --
Yesod/Core/Handler.hs | 24 ++---
Yesod/Core/Internal/Run.hs | 2 -
Yesod/Core/Widget.hs | 2 +
6 files changed, 181 insertions(+), 103 deletions(-)
diff --git a/Yesod/Core.hs b/Yesod/Core.hs
index 12e59d5..f1ff21c 100644
--- a/Yesod/Core.hs
+++ b/Yesod/Core.hs
@@ -94,8 +94,6 @@ module Yesod.Core
, JavascriptUrl
, renderJavascriptUrl
-- ** Cassius/Lucius
- , cassius
- , lucius
, CssUrl
, renderCssUrl
) where
diff --git a/Yesod/Core/Class/Yesod.hs b/Yesod/Core/Class/Yesod.hs
index cf02a1a..3f1e88e 100644
--- a/Yesod/Core/Class/Yesod.hs
+++ b/Yesod/Core/Class/Yesod.hs
@@ -9,6 +9,10 @@ import Yesod.Core.Content
import Yesod.Core.Handler
import Yesod.Routes.Class
+import qualified Text.Blaze.Internal
+import qualified Control.Monad.Logger
+import qualified Text.Hamlet
+import qualified Data.Foldable
import Blaze.ByteString.Builder (Builder)
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
@@ -87,18 +91,27 @@ class RenderRoute site => Yesod site where
defaultLayout w = do
p <- widgetToPageContent w
mmsg <- getMessage
- giveUrlRenderer [hamlet|
- $newline never
- $doctype 5
- <html>
- <head>
- <title>#{pageTitle p}
- ^{pageHead p}
- <body>
- $maybe msg <- mmsg
- <p .message>#{msg}
- ^{pageBody p}
- |]
+ giveUrlRenderer $ \ _render_aHra
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<!DOCTYPE html>\n<html><head><title>");
+ id (TBH.toHtml (pageTitle p));
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</title>");
+ Text.Hamlet.asHtmlUrl (pageHead p) _render_aHra;
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</head><body>");
+ Text.Hamlet.maybeH
+ mmsg
+ (\ msg_aHrb
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<p class=\"message\">");
+ id (TBH.toHtml msg_aHrb);
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</p>") })
+ Nothing;
+ Text.Hamlet.asHtmlUrl (pageBody p) _render_aHra;
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack) "</body></html>") }
+
-- | 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
@@ -356,45 +369,103 @@ 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 = \ _render_aHsO
+ -> do { Data.Foldable.mapM_
+ (\ s_aHsP
+ -> Text.Hamlet.asHtmlUrl (mkScriptTag s_aHsP) _render_aHsO)
+ scripts;
+ Text.Hamlet.maybeH
+ jscript
+ (\ j_aHsQ
+ -> Text.Hamlet.maybeH
+ jsLoc
+ (\ s_aHsR
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<script src=\"");
+ id (TBH.toHtml s_aHsR);
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "\"></script>") })
+ (Just
+ (do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack) "<script>");
+ Text.Hamlet.asHtmlUrl (jelper j_aHsQ) _render_aHsO;
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</script>") })))
+ Nothing }
+
+
+ headAll = \ _render_aHsW
+ -> do { Text.Hamlet.asHtmlUrl head' _render_aHsW;
+ Data.Foldable.mapM_
+ (\ s_aHsX -> Text.Hamlet.asHtmlUrl (mkLinkTag s_aHsX) _render_aHsW)
+ stylesheets;
+ Data.Foldable.mapM_
+ (\ s_aHsY
+ -> do { Text.Hamlet.maybeH
+ (right (snd s_aHsY))
+ (\ t_aHsZ
+ -> Text.Hamlet.maybeH
+ (fst s_aHsY)
+ (\ media_aHt0
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<link rel=\"stylesheet\" media=\"");
+ id (TBH.toHtml media_aHt0);
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "\" href=\"");
+ id (TBH.toHtml t_aHsZ);
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "\">") })
+ (Just
+ (do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<link rel=\"stylesheet\" href=\"");
+ id (TBH.toHtml t_aHsZ);
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "\">") })))
+ Nothing;
+ Text.Hamlet.maybeH
+ (left (snd s_aHsY))
+ (\ content_aHt1
+ -> Text.Hamlet.maybeH
+ (fst s_aHsY)
+ (\ media_aHt2
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<style media=\"");
+ id (TBH.toHtml media_aHt2);
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "\">");
+ id (TBH.toHtml content_aHt1);
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "</style>") })
+ (Just
+ (do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<style>");
+ id (TBH.toHtml content_aHt1);
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "</style>") })))
+ Nothing })
+ css;
+ case jsLoader master of {
+ BottomOfBody -> return ()
+ ; BottomOfHeadAsync asyncJsLoader_aHt3
+ -> Text.Hamlet.asHtmlUrl
+ (asyncJsLoader_aHt3 asyncScripts mcomplete) _render_aHsW
+ ; BottomOfHeadBlocking
+ -> Text.Hamlet.asHtmlUrl regularScriptLoad _render_aHsW } }
+
+ let bodyScript = \ _render_aHt8 -> do { Text.Hamlet.asHtmlUrl body _render_aHt8;
+ Text.Hamlet.asHtmlUrl regularScriptLoad _render_aHt8 }
+
return $ PageContent title headAll $
case jsLoader master of
@@ -424,10 +495,13 @@ defaultErrorHandler NotFound = selectRep $ do
r <- waiRequest
let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
setTitle "Not Found"
- toWidget [hamlet|
- <h1>Not Found
- <p>#{path'}
- |]
+ toWidget $ \ _render_aHte
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<h1>Not Found</h1>\n<p>");
+ id (TBH.toHtml path');
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</p>") }
+
provideRep $ return $ object ["message" .= ("Not Found" :: Text)]
-- For API requests.
@@ -437,10 +511,11 @@ defaultErrorHandler NotFound = selectRep $ do
defaultErrorHandler NotAuthenticated = selectRep $ do
provideRep $ defaultLayout $ do
setTitle "Not logged in"
- toWidget [hamlet|
- <h1>Not logged in
- <p style="display:none;">Set the authRoute and the user will be redirected there.
- |]
+ toWidget $ \ _render_aHti
+ -> id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<h1>Not logged in</h1>\n<p style=\"none;\">Set the authRoute and the user will be redirected there.</p>")
+
provideRep $ do
-- 401 *MUST* include a WWW-Authenticate header
@@ -462,10 +537,13 @@ defaultErrorHandler NotAuthenticated = selectRep $ do
defaultErrorHandler (PermissionDenied msg) = selectRep $ do
provideRep $ defaultLayout $ do
setTitle "Permission Denied"
- toWidget [hamlet|
- <h1>Permission denied
- <p>#{msg}
- |]
+ toWidget $ \ _render_aHtq
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<h1>Permission denied</h1>\n<p>");
+ id (TBH.toHtml msg);
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</p>") }
+
provideRep $
return $ object $ [
"message" .= ("Permission Denied. " <> msg)
@@ -474,30 +552,43 @@ defaultErrorHandler (PermissionDenied msg) = selectRep $ do
defaultErrorHandler (InvalidArgs ia) = selectRep $ do
provideRep $ defaultLayout $ do
setTitle "Invalid Arguments"
- toWidget [hamlet|
- <h1>Invalid Arguments
- <ul>
- $forall msg <- ia
- <li>#{msg}
- |]
+ toWidget $ \ _render_aHtv
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<h1>Invalid Arguments</h1>\n<ul>");
+ Data.Foldable.mapM_
+ (\ msg_aHtw
+ -> do { id ((Text.Blaze.Internal.preEscapedText . T.pack) "<li>");
+ id (TBH.toHtml msg_aHtw);
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</li>") })
+ ia;
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</ul>") }
+
provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia]
defaultErrorHandler (InternalError e) = do
- $logErrorS "yesod-core" e
selectRep $ do
provideRep $ defaultLayout $ do
setTitle "Internal Server Error"
- toWidget [hamlet|
- <h1>Internal Server Error
- <pre>#{e}
- |]
+ toWidget $ \ _render_aHtC
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<h1>Internal Server Error</h1>\n<pre>");
+ id (TBH.toHtml e);
+ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</pre>") }
+
provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e]
defaultErrorHandler (BadMethod m) = selectRep $ do
provideRep $ defaultLayout $ do
setTitle"Bad Method"
- toWidget [hamlet|
- <h1>Method Not Supported
- <p>Method <code>#{S8.unpack m}</code> not supported
- |]
+ toWidget $ \ _render_aHtH
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<h1>Method Not Supported</h1>\n<p>Method <code>");
+ id (TBH.toHtml (S8.unpack m));
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "</code> not supported</p>") }
+
provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= m]
asyncHelper :: (url -> [x] -> Text)
diff --git a/Yesod/Core/Dispatch.hs b/Yesod/Core/Dispatch.hs
index 335a15c..4ca05da 100644
--- a/Yesod/Core/Dispatch.hs
+++ b/Yesod/Core/Dispatch.hs
@@ -123,13 +123,6 @@ toWaiApp site = do
, yreSite = site
, yreSessionBackend = sb
}
- messageLoggerSource
- site
- logger
- $(qLocation >>= liftLoc)
- "yesod-core"
- LevelInfo
- (toLogStr ("Application launched" :: S.ByteString))
middleware <- mkDefaultMiddlewares logger
return $ middleware $ toWaiAppYre yre
diff --git a/Yesod/Core/Handler.hs b/Yesod/Core/Handler.hs
index f3b1799..d819b04 100644
--- a/Yesod/Core/Handler.hs
+++ b/Yesod/Core/Handler.hs
@@ -152,7 +152,7 @@ import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Resource (MonadResource, liftResourceT)
-
+import qualified Text.Blaze.Internal
import qualified Network.HTTP.Types as H
import qualified Network.Wai as W
import Control.Monad.Trans.Class (lift)
@@ -710,19 +710,15 @@ redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
-> m a
redirectToPost url = do
urlText <- toTextUrl url
- giveUrlRenderer [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
+ giveUrlRenderer $ \ _render_awps
+ -> do { id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "<!DOCTYPE html>\n<html><head><title>Redirecting...</title></head><body onload=\"document.getElementById('form').submit()\"><form id=\"form\" method=\"post\" action=\"");
+ id (toHtml urlText);
+ id
+ ((Text.Blaze.Internal.preEscapedText . T.pack)
+ "\"><noscript><p>Javascript has been disabled; please click on the button below to be redirected.</p></noscript><input type=\"submit\" value=\"Continue\"></form></body></html>") }
+ >>= sendResponse
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html
diff --git a/Yesod/Core/Internal/Run.hs b/Yesod/Core/Internal/Run.hs
index 35f1d3f..8b92e99 100644
--- a/Yesod/Core/Internal/Run.hs
+++ b/Yesod/Core/Internal/Run.hs
@@ -122,8 +122,6 @@ safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> ErrorResponse
-> YesodApp
safeEh log' er req = do
- liftIO $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError
- $ toLogStr $ "Error handler errored out: " ++ show er
return $ YRPlain
H.status500
[]
diff --git a/Yesod/Core/Widget.hs b/Yesod/Core/Widget.hs
index be97764..874f018 100644
--- a/Yesod/Core/Widget.hs
+++ b/Yesod/Core/Widget.hs
@@ -47,6 +47,8 @@ module Yesod.Core.Widget
, handlerToWidget
-- * Internal
, whamletFileWithSettings
+ -- used by TH
+ , asWidgetT
) where
import Data.Monoid
--
1.7.10.4

View file

@ -1,102 +0,0 @@
From 8ff7908799eb69d440168ff3df1fe3187879df33 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:39:57 -0400
Subject: [PATCH] remove TH
---
Yesod/Default/Util.hs | 61 +------------------------------------------------
1 file changed, 1 insertion(+), 60 deletions(-)
diff --git a/Yesod/Default/Util.hs b/Yesod/Default/Util.hs
index 578b9bc..178e342 100644
--- a/Yesod/Default/Util.hs
+++ b/Yesod/Default/Util.hs
@@ -5,8 +5,6 @@
module Yesod.Default.Util
( addStaticContentExternal
, globFile
- , widgetFileNoReload
- , widgetFileReload
, TemplateLanguage (..)
, defaultTemplateLanguages
, WidgetFileSettings
@@ -21,9 +19,6 @@ import Yesod.Core -- purposely using complete import so that Haddock will see ad
import Control.Monad (when, unless)
import System.Directory (doesFileExist, createDirectoryIfMissing)
import Language.Haskell.TH.Syntax
-import Text.Lucius (luciusFile, luciusFileReload)
-import Text.Julius (juliusFile, juliusFileReload)
-import Text.Cassius (cassiusFile, cassiusFileReload)
import Text.Hamlet (HamletSettings, defaultHamletSettings)
import Data.Maybe (catMaybes)
import Data.Default (Default (def))
@@ -72,13 +67,7 @@ data TemplateLanguage = TemplateLanguage
defaultTemplateLanguages :: HamletSettings -> [TemplateLanguage]
defaultTemplateLanguages hset =
- [ TemplateLanguage False "hamlet" whamletFile' whamletFile'
- , TemplateLanguage True "cassius" cassiusFile cassiusFileReload
- , TemplateLanguage True "julius" juliusFile juliusFileReload
- , TemplateLanguage True "lucius" luciusFile luciusFileReload
- ]
- where
- whamletFile' = whamletFileWithSettings hset
+ [ ]
data WidgetFileSettings = WidgetFileSettings
{ wfsLanguages :: HamletSettings -> [TemplateLanguage]
@@ -87,51 +76,3 @@ data WidgetFileSettings = WidgetFileSettings
instance Default WidgetFileSettings where
def = WidgetFileSettings defaultTemplateLanguages defaultHamletSettings
-
-widgetFileNoReload :: WidgetFileSettings -> FilePath -> Q Exp
-widgetFileNoReload wfs x = combine "widgetFileNoReload" x False $ wfsLanguages wfs $ wfsHamletSettings wfs
-
-widgetFileReload :: WidgetFileSettings -> FilePath -> Q Exp
-widgetFileReload wfs x = combine "widgetFileReload" x True $ wfsLanguages wfs $ wfsHamletSettings wfs
-
-combine :: String -> String -> Bool -> [TemplateLanguage] -> Q Exp
-combine func file isReload tls = do
- mexps <- qmexps
- case catMaybes mexps of
- [] -> error $ concat
- [ "Called "
- , func
- , " on "
- , show file
- , ", but no template were found."
- ]
- exps -> return $ DoE $ map NoBindS exps
- where
- qmexps :: Q [Maybe Exp]
- qmexps = mapM go tls
-
- go :: TemplateLanguage -> Q (Maybe Exp)
- go tl = whenExists file (tlRequiresToWidget tl) (tlExtension tl) ((if isReload then tlReload else tlNoReload) tl)
-
-whenExists :: String
- -> Bool -- ^ requires toWidget wrap
- -> String -> (FilePath -> Q Exp) -> Q (Maybe Exp)
-whenExists = warnUnlessExists False
-
-warnUnlessExists :: Bool
- -> String
- -> Bool -- ^ requires toWidget wrap
- -> String -> (FilePath -> Q Exp) -> Q (Maybe Exp)
-warnUnlessExists shouldWarn x wrap glob f = do
- let fn = globFile glob x
- e <- qRunIO $ doesFileExist fn
- when (shouldWarn && not e) $ qRunIO $ putStrLn $ "widget file not found: " ++ fn
- if e
- then do
- ex <- f fn
- if wrap
- then do
- tw <- [|toWidget|]
- return $ Just $ tw `AppE` ex
- else return $ Just ex
- else return Nothing
--
1.7.10.4

View file

@ -1,83 +0,0 @@
From a603bac40f0a0f6232fbfb056a778860270101de Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Mon, 15 Apr 2013 15:59:56 -0400
Subject: [PATCH 1/2] prepare for Evil Splicer
---
Yesod/Form/Functions.hs | 3 +--
evilsplicer-headers.hs | 9 +++++++++
yesod-form.cabal | 5 +++--
3 files changed, 13 insertions(+), 4 deletions(-)
create mode 100644 evilsplicer-headers.hs
diff --git a/Yesod/Form/Functions.hs b/Yesod/Form/Functions.hs
index db3e493..89eb1e8 100644
--- a/Yesod/Form/Functions.hs
+++ b/Yesod/Form/Functions.hs
@@ -54,10 +54,9 @@ import Text.Blaze (Markup, toMarkup)
#define toHtml toMarkup
import Yesod.Handler (GHandler, getRequest, runRequestBody, newIdent, getYesod)
import Yesod.Core (RenderMessage, SomeMessage (..))
-import Yesod.Widget (GWidget, whamlet)
+import Yesod.Widget (GWidget)
import Yesod.Request (reqToken, reqWaiRequest, reqGetParams, languages)
import Network.Wai (requestMethod)
-import Text.Hamlet (shamlet)
import Data.Monoid (mempty)
import Data.Maybe (listToMaybe, fromMaybe)
import Yesod.Message (RenderMessage (..))
diff --git a/evilsplicer-headers.hs b/evilsplicer-headers.hs
new file mode 100644
index 0000000..865d043
--- /dev/null
+++ b/evilsplicer-headers.hs
@@ -0,0 +1,9 @@
+import qualified Data.Text.Lazy.Builder
+import qualified Text.Shakespeare
+import qualified Text.Hamlet
+import qualified Data.Monoid
+import qualified Text.Julius
+import qualified "blaze-markup" Text.Blaze.Internal
+import qualified "blaze-markup" Text.Blaze as Text.Blaze.Markup
+import qualified Yesod.Widget
+import qualified Data.Foldable
diff --git a/yesod-form.cabal b/yesod-form.cabal
index a0d2a80..ae99ddc 100644
--- a/yesod-form.cabal
+++ b/yesod-form.cabal
@@ -18,7 +18,7 @@ library
, yesod-persistent >= 1.1 && < 1.2
, time >= 1.1.4
, hamlet >= 1.1 && < 1.2
- , shakespeare-css >= 1.0 && < 1.1
+ , shakespeare-css == 1.0.2
, shakespeare-js >= 1.0.2 && < 1.2
, persistent >= 1.0 && < 1.2
, template-haskell
@@ -37,6 +37,7 @@ library
, attoparsec >= 0.10 && < 0.11
, crypto-api >= 0.8 && < 0.11
, aeson
+ , shakespeare
exposed-modules: Yesod.Form
Yesod.Form.Class
@@ -45,7 +46,6 @@ library
Yesod.Form.Input
Yesod.Form.Fields
Yesod.Form.Jquery
- Yesod.Form.Nic
Yesod.Form.MassInput
Yesod.Form.I18n.English
Yesod.Form.I18n.Portuguese
@@ -56,6 +56,7 @@ library
Yesod.Form.I18n.Japanese
-- FIXME Yesod.Helpers.Crud
ghc-options: -Wall
+ Extensions: PackageImports
test-suite test
type: exitcode-stdio-1.0
--
1.8.2.rc3

File diff suppressed because it is too large Load diff

View file

@ -1,41 +0,0 @@
From 62cc9e3f70d8cea848d56efa198a68527fd07267 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:40:19 -0400
Subject: [PATCH] avoid TH
---
Yesod/Persist.hs | 2 --
yesod-persistent.cabal | 1 -
2 files changed, 3 deletions(-)
diff --git a/Yesod/Persist.hs b/Yesod/Persist.hs
index 0646152..5130497 100644
--- a/Yesod/Persist.hs
+++ b/Yesod/Persist.hs
@@ -7,11 +7,9 @@ module Yesod.Persist
, get404
, getBy404
, module Database.Persist
- , module Database.Persist.TH
) where
import Database.Persist
-import Database.Persist.TH
import Control.Monad.Trans.Class (MonadTrans)
import Yesod.Handler
diff --git a/yesod-persistent.cabal b/yesod-persistent.cabal
index 111c1b9..07f6e17 100644
--- a/yesod-persistent.cabal
+++ b/yesod-persistent.cabal
@@ -16,7 +16,6 @@ library
build-depends: base >= 4 && < 5
, yesod-core >= 1.1 && < 1.2
, persistent >= 1.0 && < 1.2
- , persistent-template >= 1.0 && < 1.2
, transformers >= 0.2.2 && < 0.4
exposed-modules: Yesod.Persist
ghc-options: -Wall
--
1.7.10.4

View file

@ -0,0 +1,26 @@
From 03819615edb1c5f7414768dae84234d6791bd758 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 04:11:46 +0000
Subject: [PATCH] do not really build
---
yesod-persistent.cabal | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/yesod-persistent.cabal b/yesod-persistent.cabal
index 98c2146..11960cf 100644
--- a/yesod-persistent.cabal
+++ b/yesod-persistent.cabal
@@ -23,8 +23,7 @@ library
, lifted-base
, pool-conduit
, resourcet
- exposed-modules: Yesod.Persist
- Yesod.Persist.Core
+ exposed-modules:
ghc-options: -Wall
test-suite test
--
1.7.10.4

View file

@ -1,674 +0,0 @@
From 06176b0f3dbbe559490f0971e0db205287793286 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Mon, 15 Apr 2013 21:01:12 -0400
Subject: [PATCH] remove TH and export module used by TH splices
---
Yesod/Routes/Overlap.hs | 74 ----------
Yesod/Routes/Parse.hs | 115 ---------------
Yesod/Routes/TH.hs | 12 --
Yesod/Routes/TH/Dispatch.hs | 344 --------------------------------------------
Yesod/Routes/TH/Types.hs | 16 ---
yesod-routes.cabal | 21 ---
6 files changed, 582 deletions(-)
delete mode 100644 Yesod/Routes/Overlap.hs
delete mode 100644 Yesod/Routes/Parse.hs
delete mode 100644 Yesod/Routes/TH.hs
delete mode 100644 Yesod/Routes/TH/Dispatch.hs
diff --git a/Yesod/Routes/Overlap.hs b/Yesod/Routes/Overlap.hs
deleted file mode 100644
index ae45a02..0000000
--- a/Yesod/Routes/Overlap.hs
+++ /dev/null
@@ -1,74 +0,0 @@
--- | Check for overlapping routes.
-module Yesod.Routes.Overlap
- ( findOverlaps
- , findOverlapNames
- , Overlap (..)
- ) where
-
-import Yesod.Routes.TH.Types
-import Data.List (intercalate)
-
-data Overlap t = Overlap
- { overlapParents :: [String] -> [String] -- ^ parent resource trees
- , overlap1 :: ResourceTree t
- , overlap2 :: ResourceTree t
- }
-
-findOverlaps :: ([String] -> [String]) -> [ResourceTree t] -> [Overlap t]
-findOverlaps _ [] = []
-findOverlaps front (x:xs) = concatMap (findOverlap front x) xs ++ findOverlaps front xs
-
-findOverlap :: ([String] -> [String]) -> ResourceTree t -> ResourceTree t -> [Overlap t]
-findOverlap front x y =
- here rest
- where
- here
- | overlaps (resourceTreePieces x) (resourceTreePieces y) (hasSuffix x) (hasSuffix y) = (Overlap front x y:)
- | otherwise = id
- rest =
- case x of
- ResourceParent name _ children -> findOverlaps (front . (name:)) children
- ResourceLeaf{} -> []
-
-hasSuffix :: ResourceTree t -> Bool
-hasSuffix (ResourceLeaf r) =
- case resourceDispatch r of
- Subsite{} -> True
- Methods Just{} _ -> True
- Methods Nothing _ -> False
-hasSuffix ResourceParent{} = True
-
-overlaps :: [(CheckOverlap, Piece t)] -> [(CheckOverlap, Piece t)] -> Bool -> Bool -> Bool
-
--- No pieces on either side, will overlap regardless of suffix
-overlaps [] [] _ _ = True
-
--- No pieces on the left, will overlap if the left side has a suffix
-overlaps [] _ suffixX _ = suffixX
-
--- Ditto for the right
-overlaps _ [] _ suffixY = suffixY
-
--- As soon as we ignore a single piece (via CheckOverlap == False), we say that
--- the routes don't overlap at all. In other words, disabling overlap checking
--- on a single piece disables it on the whole route.
-overlaps ((False, _):_) _ _ _ = False
-overlaps _ ((False, _):_) _ _ = False
-
--- Compare the actual pieces
-overlaps ((True, pieceX):xs) ((True, pieceY):ys) suffixX suffixY =
- piecesOverlap pieceX pieceY && overlaps xs ys suffixX suffixY
-
-piecesOverlap :: Piece t -> Piece t -> Bool
--- Statics only match if they equal. Dynamics match with anything
-piecesOverlap (Static x) (Static y) = x == y
-piecesOverlap _ _ = True
-
-findOverlapNames :: [ResourceTree t] -> [(String, String)]
-findOverlapNames =
- map go . findOverlaps id
- where
- go (Overlap front x y) =
- (go' $ resourceTreeName x, go' $ resourceTreeName y)
- where
- go' = intercalate "/" . front . return
diff --git a/Yesod/Routes/Parse.hs b/Yesod/Routes/Parse.hs
deleted file mode 100644
index fc16eef..0000000
--- a/Yesod/Routes/Parse.hs
+++ /dev/null
@@ -1,115 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
-module Yesod.Routes.Parse
- ( parseRoutes
- , parseRoutesFile
- , parseRoutesNoCheck
- , parseRoutesFileNoCheck
- , parseType
- ) where
-
-import Language.Haskell.TH.Syntax
-import Data.Char (isUpper)
-import Language.Haskell.TH.Quote
-import qualified System.IO as SIO
-import Yesod.Routes.TH
-import Yesod.Routes.Overlap (findOverlapNames)
-
--- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for
--- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the
--- checking. See documentation site for details on syntax.
-parseRoutes :: QuasiQuoter
-parseRoutes = QuasiQuoter { quoteExp = x }
- where
- x s = do
- let res = resourcesFromString s
- case findOverlapNames res of
- [] -> lift res
- z -> error $ "Overlapping routes: " ++ unlines (map show z)
-
-parseRoutesFile :: FilePath -> Q Exp
-parseRoutesFile = parseRoutesFileWith parseRoutes
-
-parseRoutesFileNoCheck :: FilePath -> Q Exp
-parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck
-
-parseRoutesFileWith :: QuasiQuoter -> FilePath -> Q Exp
-parseRoutesFileWith qq fp = do
- s <- qRunIO $ readUtf8File fp
- quoteExp qq s
-
-readUtf8File :: FilePath -> IO String
-readUtf8File fp = do
- h <- SIO.openFile fp SIO.ReadMode
- SIO.hSetEncoding h SIO.utf8_bom
- SIO.hGetContents h
-
--- | Same as 'parseRoutes', but performs no overlap checking.
-parseRoutesNoCheck :: QuasiQuoter
-parseRoutesNoCheck = QuasiQuoter
- { quoteExp = lift . resourcesFromString
- }
-
--- | Convert a multi-line string to a set of resources. See documentation for
--- the format of this string. This is a partial function which calls 'error' on
--- invalid input.
-resourcesFromString :: String -> [ResourceTree String]
-resourcesFromString =
- fst . parse 0 . lines
- where
- parse _ [] = ([], [])
- parse indent (thisLine:otherLines)
- | length spaces < indent = ([], thisLine : otherLines)
- | otherwise = (this others, remainder)
- where
- spaces = takeWhile (== ' ') thisLine
- (others, remainder) = parse indent otherLines'
- (this, otherLines') =
- case takeWhile (/= "--") $ words thisLine of
- [pattern, constr] | last constr == ':' ->
- let (children, otherLines'') = parse (length spaces + 1) otherLines
- (pieces, Nothing) = piecesFromString $ drop1Slash pattern
- in ((ResourceParent (init constr) pieces children :), otherLines'')
- (pattern:constr:rest) ->
- let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
- disp = dispatchFromString rest mmulti
- in ((ResourceLeaf (Resource constr pieces disp):), otherLines)
- [] -> (id, otherLines)
- _ -> error $ "Invalid resource line: " ++ thisLine
-
-dispatchFromString :: [String] -> Maybe String -> Dispatch String
-dispatchFromString rest mmulti
- | null rest = Methods mmulti []
- | all (all isUpper) rest = Methods mmulti rest
-dispatchFromString [subTyp, subFun] Nothing =
- Subsite subTyp subFun
-dispatchFromString [_, _] Just{} =
- error "Subsites cannot have a multipiece"
-dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest
-
-drop1Slash :: String -> String
-drop1Slash ('/':x) = x
-drop1Slash x = x
-
-piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe String)
-piecesFromString "" = ([], Nothing)
-piecesFromString x =
- case (this, rest) of
- (Left typ, ([], Nothing)) -> ([], Just typ)
- (Left _, _) -> error "Multipiece must be last piece"
- (Right piece, (pieces, mtyp)) -> (piece:pieces, mtyp)
- where
- (y, z) = break (== '/') x
- this = pieceFromString y
- rest = piecesFromString $ drop 1 z
-
-parseType :: String -> Type
-parseType = ConT . mkName -- FIXME handle more complicated stuff
-
-pieceFromString :: String -> Either String (CheckOverlap, Piece String)
-pieceFromString ('#':'!':x) = Right $ (False, Dynamic x)
-pieceFromString ('#':x) = Right $ (True, Dynamic x)
-pieceFromString ('*':x) = Left x
-pieceFromString ('!':x) = Right $ (False, Static x)
-pieceFromString x = Right $ (True, Static x)
diff --git a/Yesod/Routes/TH.hs b/Yesod/Routes/TH.hs
deleted file mode 100644
index 41045b3..0000000
--- a/Yesod/Routes/TH.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-module Yesod.Routes.TH
- ( module Yesod.Routes.TH.Types
- -- * Functions
- , module Yesod.Routes.TH.RenderRoute
- -- ** Dispatch
- , module Yesod.Routes.TH.Dispatch
- ) where
-
-import Yesod.Routes.TH.Types
-import Yesod.Routes.TH.RenderRoute
-import Yesod.Routes.TH.Dispatch
diff --git a/Yesod/Routes/TH/Dispatch.hs b/Yesod/Routes/TH/Dispatch.hs
deleted file mode 100644
index a52f69a..0000000
--- a/Yesod/Routes/TH/Dispatch.hs
+++ /dev/null
@@ -1,344 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-module Yesod.Routes.TH.Dispatch
- ( -- ** Dispatch
- mkDispatchClause
- ) where
-
-import Prelude hiding (exp)
-import Yesod.Routes.TH.Types
-import Language.Haskell.TH.Syntax
-import Data.Maybe (catMaybes)
-import Control.Monad (forM, replicateM)
-import Data.Text (pack)
-import qualified Yesod.Routes.Dispatch as D
-import qualified Data.Map as Map
-import Data.Char (toLower)
-import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
-import Control.Applicative ((<$>))
-import Data.List (foldl')
-
-data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a)
-
-flatten :: [ResourceTree a] -> [FlatResource a]
-flatten =
- concatMap (go id)
- where
- go front (ResourceLeaf (Resource a b c)) = [FlatResource (front []) a b c]
- go front (ResourceParent name pieces children) =
- concatMap (go (front . ((name, pieces):))) children
-
--- |
---
--- This function will generate a single clause that will address all
--- your routing needs. It takes four arguments. The fourth (a list of
--- 'Resource's) is self-explanatory. We\'ll discuss the first
--- three. But first, let\'s cover the terminology.
---
--- Dispatching involves a master type and a sub type. When you dispatch to the
--- top level type, master and sub are the same. Each time to dispatch to
--- another subsite, the sub changes. This requires two changes:
---
--- * Getting the new sub value. This is handled via 'subsiteFunc'.
---
--- * Figure out a way to convert sub routes to the original master route. To
--- address this, we keep a toMaster function, and each time we dispatch to a
--- new subsite, we compose it with the constructor for that subsite.
---
--- Dispatching acts on two different components: the request method and a list
--- of path pieces. If we cannot match the path pieces, we need to return a 404
--- response. If the path pieces match, but the method is not supported, we need
--- to return a 405 response.
---
--- The final result of dispatch is going to be an application type. A simple
--- example would be the WAI Application type. However, our handler functions
--- will need more input: the master/subsite, the toMaster function, and the
--- type-safe route. Therefore, we need to have another type, the handler type,
--- and a function that turns a handler into an application, i.e.
---
--- > runHandler :: handler sub master -> master -> sub -> Route sub -> (Route sub -> Route master) -> app
---
--- This is the first argument to our function. Note that this will almost
--- certainly need to be a method of a typeclass, since it will want to behave
--- differently based on the subsite.
---
--- Note that the 404 response passed in is an application, while the 405
--- response is a handler, since the former can\'t be passed the type-safe
--- route.
---
--- In the case of a subsite, we don\'t directly deal with a handler function.
--- Instead, we redispatch to the subsite, passing on the updated sub value and
--- toMaster function, as well as any remaining, unparsed path pieces. This
--- function looks like:
---
--- > dispatcher :: master -> sub -> (Route sub -> Route master) -> app -> handler sub master -> Text -> [Text] -> app
---
--- Where the parameters mean master, sub, toMaster, 404 response, 405 response,
--- request method and path pieces. This is the second argument of our function.
---
--- Finally, we need a way to decide which of the possible formats
--- should the handler send the data out. Think of each URL holding an
--- abstract object which has multiple representation (JSON, plain HTML
--- etc). Each client might have a preference on which format it wants
--- the abstract object in. For example, a javascript making a request
--- (on behalf of a browser) might prefer a JSON object over a plain
--- HTML file where as a user browsing with javascript disabled would
--- want the page in HTML. The third argument is a function that
--- converts the abstract object to the desired representation
--- depending on the preferences sent by the client.
---
--- The typical values for the first three arguments are,
--- @'yesodRunner'@ for the first, @'yesodDispatch'@ for the second and
--- @fmap 'chooseRep'@.
-
-mkDispatchClause :: Q Exp -- ^ runHandler function
- -> Q Exp -- ^ dispatcher function
- -> Q Exp -- ^ fixHandler function
- -> [ResourceTree a]
- -> Q Clause
-mkDispatchClause runHandler dispatcher fixHandler ress' = do
- -- Allocate the names to be used. Start off with the names passed to the
- -- function itself (with a 0 suffix).
- --
- -- We don't reuse names so as to avoid shadowing names (triggers warnings
- -- with -Wall). Additionally, we want to ensure that none of the code
- -- passed to toDispatch uses variables from the closure to prevent the
- -- dispatch data structure from being rebuilt on each run.
- master0 <- newName "master0"
- sub0 <- newName "sub0"
- toMaster0 <- newName "toMaster0"
- app4040 <- newName "app4040"
- handler4050 <- newName "handler4050"
- method0 <- newName "method0"
- pieces0 <- newName "pieces0"
-
- -- Name of the dispatch function
- dispatch <- newName "dispatch"
-
- -- Dispatch function applied to the pieces
- let dispatched = VarE dispatch `AppE` VarE pieces0
-
- -- The 'D.Route's used in the dispatch function
- routes <- mapM (buildRoute runHandler dispatcher fixHandler) ress
-
- -- The dispatch function itself
- toDispatch <- [|D.toDispatch|]
- let dispatchFun = FunD dispatch [Clause [] (NormalB $ toDispatch `AppE` ListE routes) []]
-
- -- The input to the clause.
- let pats = map VarP [master0, sub0, toMaster0, app4040, handler4050, method0, pieces0]
-
- -- For each resource that dispatches based on methods, build up a map for handling the dispatching.
- methodMaps <- catMaybes <$> mapM (buildMethodMap fixHandler) ress
-
- u <- [|case $(return dispatched) of
- Just f -> f $(return $ VarE master0)
- $(return $ VarE sub0)
- $(return $ VarE toMaster0)
- $(return $ VarE app4040)
- $(return $ VarE handler4050)
- $(return $ VarE method0)
- Nothing -> $(return $ VarE app4040)
- |]
- return $ Clause pats (NormalB u) $ dispatchFun : methodMaps
- where
- ress = flatten ress'
-
--- | Determine the name of the method map for a given resource name.
-methodMapName :: String -> Name
-methodMapName s = mkName $ "methods" ++ s
-
-buildMethodMap :: Q Exp -- ^ fixHandler
- -> FlatResource a
- -> Q (Maybe Dec)
-buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function
-buildMethodMap fixHandler (FlatResource parents name pieces' (Methods mmulti methods)) = do
- fromList <- [|Map.fromList|]
- methods' <- mapM go methods
- let exp = fromList `AppE` ListE methods'
- let fun = FunD (methodMapName name) [Clause [] (NormalB exp) []]
- return $ Just fun
- where
- pieces = concat $ map snd parents ++ [pieces']
- go method = do
- fh <- fixHandler
- let func = VarE $ mkName $ map toLower method ++ name
- pack' <- [|pack|]
- let isDynamic Dynamic{} = True
- isDynamic _ = False
- let argCount = length (filter (isDynamic . snd) pieces) + maybe 0 (const 1) mmulti
- xs <- replicateM argCount $ newName "arg"
- let rhs = LamE (map VarP xs) $ fh `AppE` (foldl' AppE func $ map VarE xs)
- return $ TupE [pack' `AppE` LitE (StringL method), rhs]
-buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing
-
--- | Build a single 'D.Route' expression.
-buildRoute :: Q Exp -> Q Exp -> Q Exp -> FlatResource a -> Q Exp
-buildRoute runHandler dispatcher fixHandler (FlatResource parents name resPieces resDisp) = do
- -- First two arguments to D.Route
- routePieces <- ListE <$> mapM (convertPiece . snd) allPieces
- isMulti <-
- case resDisp of
- Methods Nothing _ -> [|False|]
- _ -> [|True|]
-
- [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler parents name (map snd allPieces) resDisp)|]
- where
- allPieces = concat $ map snd parents ++ [resPieces]
-
-routeArg3 :: Q Exp -- ^ runHandler
- -> Q Exp -- ^ dispatcher
- -> Q Exp -- ^ fixHandler
- -> [(String, [(CheckOverlap, Piece a)])]
- -> String -- ^ name of resource
- -> [Piece a]
- -> Dispatch a
- -> Q Exp
-routeArg3 runHandler dispatcher fixHandler parents name resPieces resDisp = do
- pieces <- newName "pieces"
-
- -- Allocate input piece variables (xs) and variables that have been
- -- converted via fromPathPiece (ys)
- xs <- forM resPieces $ \piece ->
- case piece of
- Static _ -> return Nothing
- Dynamic _ -> Just <$> newName "x"
-
- -- Note: the zipping with Ints is just a workaround for (apparently) a bug
- -- in GHC where the identifiers are considered to be overlapping. Using
- -- newName should avoid the problem, but it doesn't.
- ys <- forM (zip (catMaybes xs) [1..]) $ \(x, i) -> do
- y <- newName $ "y" ++ show (i :: Int)
- return (x, y)
-
- -- In case we have multi pieces at the end
- xrest <- newName "xrest"
- yrest <- newName "yrest"
-
- -- Determine the pattern for matching the pieces
- pat <-
- case resDisp of
- Methods Nothing _ -> return $ ListP $ map (maybe WildP VarP) xs
- _ -> do
- let cons = mkName ":"
- return $ foldr (\a b -> ConP cons [maybe WildP VarP a, b]) (VarP xrest) xs
-
- -- Convert the xs
- fromPathPiece' <- [|fromPathPiece|]
- xstmts <- forM ys $ \(x, y) -> return $ BindS (VarP y) (fromPathPiece' `AppE` VarE x)
-
- -- Convert the xrest if appropriate
- (reststmts, yrest') <-
- case resDisp of
- Methods (Just _) _ -> do
- fromPathMultiPiece' <- [|fromPathMultiPiece|]
- return ([BindS (VarP yrest) (fromPathMultiPiece' `AppE` VarE xrest)], [yrest])
- _ -> return ([], [])
-
- -- The final expression that actually uses the values we've computed
- caller <- buildCaller runHandler dispatcher fixHandler xrest parents name resDisp $ map snd ys ++ yrest'
-
- -- Put together all the statements
- just <- [|Just|]
- let stmts = concat
- [ xstmts
- , reststmts
- , [NoBindS $ just `AppE` caller]
- ]
-
- errorMsg <- [|error "Invariant violated"|]
- let matches =
- [ Match pat (NormalB $ DoE stmts) []
- , Match WildP (NormalB errorMsg) []
- ]
-
- return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches
-
--- | The final expression in the individual Route definitions.
-buildCaller :: Q Exp -- ^ runHandler
- -> Q Exp -- ^ dispatcher
- -> Q Exp -- ^ fixHandler
- -> Name -- ^ xrest
- -> [(String, [(CheckOverlap, Piece a)])]
- -> String -- ^ name of resource
- -> Dispatch a
- -> [Name] -- ^ ys
- -> Q Exp
-buildCaller runHandler dispatcher fixHandler xrest parents name resDisp ys = do
- master <- newName "master"
- sub <- newName "sub"
- toMaster <- newName "toMaster"
- app404 <- newName "_app404"
- handler405 <- newName "_handler405"
- method <- newName "_method"
-
- let pat = map VarP [master, sub, toMaster, app404, handler405, method]
-
- -- Create the route
- let route = routeFromDynamics parents name ys
-
- exp <-
- case resDisp of
- Methods _ ms -> do
- handler <- newName "handler"
-
- -- Run the whole thing
- runner <- [|$(runHandler)
- $(return $ VarE handler)
- $(return $ VarE master)
- $(return $ VarE sub)
- (Just $(return route))
- $(return $ VarE toMaster)|]
-
- let myLet handlerExp =
- LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner
-
- if null ms
- then do
- -- Just a single handler
- fh <- fixHandler
- let he = fh `AppE` foldl' (\a b -> a `AppE` VarE b) (VarE $ mkName $ "handle" ++ name) ys
- return $ myLet he
- else do
- -- Individual methods
- mf <- [|Map.lookup $(return $ VarE method) $(return $ VarE $ methodMapName name)|]
- f <- newName "f"
- let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys
- let body405 =
- VarE handler405
- `AppE` route
- return $ CaseE mf
- [ Match (ConP 'Just [VarP f]) (NormalB $ myLet apply) []
- , Match (ConP 'Nothing []) (NormalB body405) []
- ]
-
- Subsite _ getSub -> do
- let sub2 = foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys
- [|$(dispatcher)
- $(return $ VarE master)
- $(return sub2)
- ($(return $ VarE toMaster) . $(return route))
- $(return $ VarE app404)
- ($(return $ VarE handler405) . $(return route))
- $(return $ VarE method)
- $(return $ VarE xrest)
- |]
-
- return $ LamE pat exp
-
--- | Convert a 'Piece' to a 'D.Piece'
-convertPiece :: Piece a -> Q Exp
-convertPiece (Static s) = [|D.Static (pack $(lift s))|]
-convertPiece (Dynamic _) = [|D.Dynamic|]
-
-routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])] -- ^ parents
- -> String -- ^ constructor name
- -> [Name]
- -> Exp
-routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys
-routeFromDynamics ((parent, pieces):rest) name ys =
- foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here
- where
- (here', ys') = splitAt (length $ filter (isDynamic . snd) pieces) ys
- isDynamic Dynamic{} = True
- isDynamic _ = False
- here = map VarE here' ++ [routeFromDynamics rest name ys']
diff --git a/Yesod/Routes/TH/Types.hs b/Yesod/Routes/TH/Types.hs
index 52cd446..18208d3 100644
--- a/Yesod/Routes/TH/Types.hs
+++ b/Yesod/Routes/TH/Types.hs
@@ -29,10 +29,6 @@ instance Functor ResourceTree where
fmap f (ResourceLeaf r) = ResourceLeaf (fmap f r)
fmap f (ResourceParent a b c) = ResourceParent a (map (second $ fmap f) b) $ map (fmap f) c
-instance Lift t => Lift (ResourceTree t) where
- lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|]
- lift (ResourceParent a b c) = [|ResourceParent $(lift a) $(lift b) $(lift c)|]
-
data Resource typ = Resource
{ resourceName :: String
, resourcePieces :: [(CheckOverlap, Piece typ)]
@@ -45,9 +41,6 @@ type CheckOverlap = Bool
instance Functor Resource where
fmap f (Resource a b c) = Resource a (map (second $ fmap f) b) (fmap f c)
-instance Lift t => Lift (Resource t) where
- lift (Resource a b c) = [|Resource $(lift a) $(lift b) $(lift c)|]
-
data Piece typ = Static String | Dynamic typ
deriving Show
@@ -55,10 +48,6 @@ instance Functor Piece where
fmap _ (Static s) = (Static s)
fmap f (Dynamic t) = Dynamic (f t)
-instance Lift t => Lift (Piece t) where
- lift (Static s) = [|Static $(lift s)|]
- lift (Dynamic t) = [|Dynamic $(lift t)|]
-
data Dispatch typ =
Methods
{ methodsMulti :: Maybe typ -- ^ type of the multi piece at the end
@@ -74,11 +63,6 @@ instance Functor Dispatch where
fmap f (Methods a b) = Methods (fmap f a) b
fmap f (Subsite a b) = Subsite (f a) b
-instance Lift t => Lift (Dispatch t) where
- lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]
- lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|]
- lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|]
-
resourceMulti :: Resource typ -> Maybe typ
resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
resourceMulti _ = Nothing
diff --git a/yesod-routes.cabal b/yesod-routes.cabal
index eb367b3..dc6a12c 100644
--- a/yesod-routes.cabal
+++ b/yesod-routes.cabal
@@ -23,31 +23,10 @@ library
, path-pieces >= 0.1 && < 0.2
exposed-modules: Yesod.Routes.Dispatch
- Yesod.Routes.TH
Yesod.Routes.Class
- Yesod.Routes.Parse
- Yesod.Routes.Overlap
- other-modules: Yesod.Routes.TH.Dispatch
- Yesod.Routes.TH.RenderRoute
Yesod.Routes.TH.Types
ghc-options: -Wall
-test-suite runtests
- type: exitcode-stdio-1.0
- main-is: main.hs
- hs-source-dirs: test
- other-modules: Hierarchy
-
- build-depends: base >= 4.3 && < 5
- , yesod-routes
- , text >= 0.5 && < 0.12
- , HUnit >= 1.2 && < 1.3
- , hspec >= 1.3
- , containers
- , template-haskell
- , path-pieces
- ghc-options: -Wall
-
source-repository head
type: git
location: https://github.com/yesodweb/yesod
--
1.8.2.rc3

View file

@ -0,0 +1,29 @@
From f6bfe8e01d8fe6d129ad3819070aa17934094a0a Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 06:24:09 +0000
Subject: [PATCH] export module referenced by TH splices
---
yesod-routes.cabal | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/yesod-routes.cabal b/yesod-routes.cabal
index 0b245f2..a97582a 100644
--- a/yesod-routes.cabal
+++ b/yesod-routes.cabal
@@ -27,11 +27,11 @@ library
Yesod.Routes.Class
Yesod.Routes.Parse
Yesod.Routes.Overlap
+ Yesod.Routes.TH.Types
other-modules: Yesod.Routes.TH.Dispatch
Yesod.Routes.TH.RenderRoute
Yesod.Routes.TH.ParseRoute
Yesod.Routes.TH.RouteAttrs
- Yesod.Routes.TH.Types
ghc-options: -Wall
test-suite runtests
--
1.7.10.4

View file

@ -1,174 +0,0 @@
From 476414b04064bb66fc25ba9ca426c309fe5c156e Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Mon, 15 Apr 2013 12:48:13 -0400
Subject: [PATCH] remove TH
---
Yesod/Static.hs | 121 ----------------------------------------------
dist/package.conf.inplace | 3 +-
2 files changed, 2 insertions(+), 122 deletions(-)
diff --git a/Yesod/Static.hs b/Yesod/Static.hs
index e8ca09f..193b1f0 100644
--- a/Yesod/Static.hs
+++ b/Yesod/Static.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -34,11 +32,6 @@ module Yesod.Static
-- * Smart constructor
, static
, staticDevel
- , embed
- -- * Template Haskell helpers
- , staticFiles
- , staticFilesList
- , publicFiles
-- * Hashing
, base64md5
#ifdef TEST_EXPORT
@@ -50,7 +43,6 @@ import Prelude hiding (FilePath)
import qualified Prelude
import System.Directory
import Control.Monad
-import Data.FileEmbed (embedDir)
import Yesod.Core hiding (lift)
@@ -111,18 +103,6 @@ staticDevel dir = do
hashLookup <- cachedETagLookupDevel dir
return $ Static $ webAppSettingsWithLookup (F.decodeString dir) hashLookup
--- | Produce a 'Static' based on embedding all of the static
--- files' contents in the executable at compile time.
--- Nota Bene: if you replace the scaffolded 'static' call in Settings/StaticFiles.hs
--- you will need to change the scaffolded addStaticContent. Otherwise, some of your
--- assets will be 404'ed. This is because by default yesod will generate compile those
--- assets to @static/tmp@ which for 'static' is fine since they are served out of the
--- directory itself. With embedded static, that will not work.
--- You can easily change @addStaticContent@ to @\_ _ _ -> return Nothing@ as a workaround.
--- This will cause yesod to embed those assets into the generated HTML file itself.
-embed :: Prelude.FilePath -> Q Exp
-embed fp = [|Static (embeddedSettings $(embedDir fp))|]
-
instance RenderRoute Static where
-- | A route on the static subsite (see also 'staticFiles').
--
@@ -167,59 +147,6 @@ getFileListPieces = flip go id
dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs
return $ concat $ files' : dirs'
--- | Template Haskell function that automatically creates routes
--- for all of your static files.
---
--- For example, if you used
---
--- > staticFiles "static/"
---
--- and you had files @\"static\/style.css\"@ and
--- @\"static\/js\/script.js\"@, then the following top-level
--- definitions would be created:
---
--- > style_css = StaticRoute ["style.css"] []
--- > js_script_js = StaticRoute ["js/script.js"] []
---
--- Note that dots (@.@), dashes (@-@) and slashes (@\/@) are
--- replaced by underscores (@\_@) to create valid Haskell
--- identifiers.
-staticFiles :: Prelude.FilePath -> Q [Dec]
-staticFiles dir = mkStaticFiles dir
-
--- | Same as 'staticFiles', but takes an explicit list of files
--- to create identifiers for. The files path given are relative
--- to the static folder. For example, to create routes for the
--- files @\"static\/js\/jquery.js\"@ and
--- @\"static\/css\/normalize.css\"@, you would use:
---
--- > staticFilesList \"static\" [\"js\/jquery.js\", \"css\/normalize.css\"]
---
--- This can be useful when you have a very large number of static
--- files, but only need to refer to a few of them from Haskell.
-staticFilesList :: Prelude.FilePath -> [Prelude.FilePath] -> Q [Dec]
-staticFilesList dir fs =
- mkStaticFilesList dir (map split fs) "StaticRoute" True
- where
- split :: Prelude.FilePath -> [String]
- split [] = []
- split x =
- let (a, b) = break (== '/') x
- in a : split (drop 1 b)
-
--- | Same as 'staticFiles', but doesn't append an ETag to the
--- query string.
---
--- Using 'publicFiles' will speed up the compilation, since there
--- won't be any need for hashing files during compile-time.
--- However, since the ETag ceases to be part of the URL, the
--- 'Static' subsite won't be able to set the expire date too far
--- on the future. Browsers still will be able to cache the
--- contents, however they'll need send a request to the server to
--- see if their copy is up-to-date.
-publicFiles :: Prelude.FilePath -> Q [Dec]
-publicFiles dir = mkStaticFiles' dir "StaticRoute" False
-
mkHashMap :: Prelude.FilePath -> IO (M.Map F.FilePath S8.ByteString)
mkHashMap dir = do
@@ -262,54 +189,6 @@ cachedETagLookup dir = do
etags <- mkHashMap dir
return $ (\f -> return $ M.lookup f etags)
-mkStaticFiles :: Prelude.FilePath -> Q [Dec]
-mkStaticFiles fp = mkStaticFiles' fp "StaticRoute" True
-
-mkStaticFiles' :: Prelude.FilePath -- ^ static directory
- -> String -- ^ route constructor "StaticRoute"
- -> Bool -- ^ append checksum query parameter
- -> Q [Dec]
-mkStaticFiles' fp routeConName makeHash = do
- fs <- qRunIO $ getFileListPieces fp
- mkStaticFilesList fp fs routeConName makeHash
-
-mkStaticFilesList
- :: Prelude.FilePath -- ^ static directory
- -> [[String]] -- ^ list of files to create identifiers for
- -> String -- ^ route constructor "StaticRoute"
- -> Bool -- ^ append checksum query parameter
- -> Q [Dec]
-mkStaticFilesList fp fs routeConName makeHash = do
- concat `fmap` mapM mkRoute fs
- where
- replace' c
- | 'A' <= c && c <= 'Z' = c
- | 'a' <= c && c <= 'z' = c
- | '0' <= c && c <= '9' = c
- | otherwise = '_'
- mkRoute f = do
- let name' = intercalate "_" $ map (map replace') f
- routeName = mkName $
- case () of
- ()
- | null name' -> error "null-named file"
- | isDigit (head name') -> '_' : name'
- | isLower (head name') -> name'
- | otherwise -> '_' : name'
- f' <- [|map pack $(lift f)|]
- let route = mkName routeConName
- pack' <- [|pack|]
- qs <- if makeHash
- then do hash <- qRunIO $ base64md5File $ pathFromRawPieces fp f
- [|[(pack "etag", pack $(lift hash))]|]
- else return $ ListE []
- return
- [ SigD routeName $ ConT route
- , FunD routeName
- [ Clause [] (NormalB $ (ConE route) `AppE` f' `AppE` qs) []
- ]
- ]
-
base64md5File :: Prelude.FilePath -> IO String
base64md5File = fmap (base64 . encode) . hashFile
where encode d = Data.Serialize.encode (d :: MD5)

View file

@ -0,0 +1,74 @@
From 8bf7c428a42b984f63f435bb34f22743202ae449 Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 05:24:19 +0000
Subject: [PATCH] hacked up for Android
---
Yesod.hs | 2 --
Yesod/Default/Util.hs | 17 -----------------
2 files changed, 19 deletions(-)
diff --git a/Yesod.hs b/Yesod.hs
index b367144..3050bf5 100644
--- a/Yesod.hs
+++ b/Yesod.hs
@@ -5,9 +5,7 @@ module Yesod
( -- * Re-exports from yesod-core
module Yesod.Core
, module Yesod.Form
- , module Yesod.Persist
) where
import Yesod.Core
import Yesod.Form
-import Yesod.Persist
diff --git a/Yesod/Default/Util.hs b/Yesod/Default/Util.hs
index a10358e..c5a4e58 100644
--- a/Yesod/Default/Util.hs
+++ b/Yesod/Default/Util.hs
@@ -8,7 +8,6 @@ module Yesod.Default.Util
, widgetFileNoReload
, widgetFileReload
, TemplateLanguage (..)
- , defaultTemplateLanguages
, WidgetFileSettings
, wfsLanguages
, wfsHamletSettings
@@ -20,9 +19,6 @@ import Yesod.Core -- purposely using complete import so that Haddock will see ad
import Control.Monad (when, unless)
import System.Directory (doesFileExist, createDirectoryIfMissing)
import Language.Haskell.TH.Syntax
-import Text.Lucius (luciusFile, luciusFileReload)
-import Text.Julius (juliusFile, juliusFileReload)
-import Text.Cassius (cassiusFile, cassiusFileReload)
import Text.Hamlet (HamletSettings, defaultHamletSettings)
import Data.Maybe (catMaybes)
import Data.Default (Default (def))
@@ -69,24 +65,11 @@ data TemplateLanguage = TemplateLanguage
, tlReload :: FilePath -> Q Exp
}
-defaultTemplateLanguages :: HamletSettings -> [TemplateLanguage]
-defaultTemplateLanguages hset =
- [ TemplateLanguage False "hamlet" whamletFile' whamletFile'
- , TemplateLanguage True "cassius" cassiusFile cassiusFileReload
- , TemplateLanguage True "julius" juliusFile juliusFileReload
- , TemplateLanguage True "lucius" luciusFile luciusFileReload
- ]
- where
- whamletFile' = whamletFileWithSettings hset
-
data WidgetFileSettings = WidgetFileSettings
{ wfsLanguages :: HamletSettings -> [TemplateLanguage]
, wfsHamletSettings :: HamletSettings
}
-instance Default WidgetFileSettings where
- def = WidgetFileSettings defaultTemplateLanguages defaultHamletSettings
-
widgetFileNoReload :: WidgetFileSettings -> FilePath -> Q Exp
widgetFileNoReload wfs x = combine "widgetFileNoReload" x False $ wfsLanguages wfs $ wfsHamletSettings wfs
--
1.7.10.4

View file

@ -0,0 +1,41 @@
From 7e815b11f242d6836f9615439e32f9937bf2feaf Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 13:59:34 +0000
Subject: [PATCH] hack around missing symbols
---
Yesod.hs | 17 +++++++++++++++++
1 file changed, 17 insertions(+)
diff --git a/Yesod.hs b/Yesod.hs
index 3050bf5..fbe309c 100644
--- a/Yesod.hs
+++ b/Yesod.hs
@@ -5,7 +5,24 @@ module Yesod
( -- * Re-exports from yesod-core
module Yesod.Core
, module Yesod.Form
+ , insertBy
+ , replace
+ , deleteBy
+ , delete
+ , insert
+ , Key
) where
import Yesod.Core
import Yesod.Form
+
+-- These symbols are usually imported from persistent,
+-- But it is not built on Android. Still export them
+-- just so that hiding them will work.
+data Key = DummyKey
+insertBy = undefined
+replace = undefined
+deleteBy = undefined
+delete = undefined
+insert = undefined
+
--
1.7.10.4

View file

@ -1,157 +0,0 @@
From 37abd5d34e18d11ff2961f672cf4491471029684 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:39:18 -0400
Subject: [PATCH] hacked up to build on Android
removing stuff I don't need and stuff removed from other modules
---
Yesod.hs | 7 ------
yesod.cabal | 77 -----------------------------------------------------------
2 files changed, 84 deletions(-)
diff --git a/Yesod.hs b/Yesod.hs
index ef9623d..255ab56 100644
--- a/Yesod.hs
+++ b/Yesod.hs
@@ -6,7 +6,6 @@ module Yesod
module Yesod.Core
, module Yesod.Form
, module Yesod.Json
- , module Yesod.Persist
-- * Running your application
, warp
, warpDebug
@@ -21,19 +20,14 @@ module Yesod
, readIntegral
-- * Hamlet library
-- ** Hamlet
- , hamlet
- , xhamlet
, HtmlUrl
, Html
, toHtml
-- ** Julius
- , julius
, JavascriptUrl
, renderJavascriptUrl
, toJSON
-- ** Cassius/Lucius
- , cassius
- , lucius
, CssUrl
, renderCssUrl
) where
@@ -46,7 +40,6 @@ import Text.Julius
import Yesod.Form
import Yesod.Json
-import Yesod.Persist
import Control.Monad.IO.Class (liftIO, MonadIO(..))
import Control.Monad.Trans.Control (MonadBaseControl)
diff --git a/yesod.cabal b/yesod.cabal
index 741f19a..7566cfb 100644
--- a/yesod.cabal
+++ b/yesod.cabal
@@ -13,7 +13,6 @@ description:
The Yesod documentation site <http://www.yesodweb.com/> has much more information, including on the supporting packages mentioned above.
category: Web, Yesod
stability: Stable
-cabal-version: >= 1.6
build-type: Simple
homepage: http://www.yesodweb.com/
@@ -28,9 +27,7 @@ extra-source-files:
library
build-depends: base >= 4.3 && < 5
, yesod-core >= 1.1.5 && < 1.2
- , yesod-auth >= 1.1 && < 1.2
, yesod-json >= 1.1 && < 1.2
- , yesod-persistent >= 1.1 && < 1.2
, yesod-form >= 1.1 && < 1.3
, yesod-default >= 1.1.3 && < 1.2
, monad-control >= 0.3 && < 0.4
@@ -48,80 +45,6 @@ library
exposed-modules: Yesod
ghc-options: -Wall
-executable yesod-ghc-wrapper
- main-is: ghcwrapper.hs
- build-depends:
- base >= 4 && < 5
- , Cabal
-
-executable yesod-ld-wrapper
- main-is: ghcwrapper.hs
- cpp-options: -DLDCMD
- build-depends:
- base >= 4 && < 5
- , Cabal
-executable yesod-ar-wrapper
- main-is: ghcwrapper.hs
- cpp-options: -DARCMD
- build-depends:
- base >= 4 && < 5
- , Cabal
-
-executable yesod
- if os(windows)
- cpp-options: -DWINDOWS
- build-depends: base >= 4.3 && < 5
- , ghc >= 7.0.3 && < 7.8
- , ghc-paths >= 0.1
- , parsec >= 2.1 && < 4
- , text >= 0.11
- , shakespeare-text >= 1.0 && < 1.1
- , shakespeare >= 1.0.2 && < 1.1
- , shakespeare-js >= 1.0.2 && < 1.2
- , shakespeare-css >= 1.0.2 && < 1.1
- , bytestring >= 0.9.1.4
- , time >= 1.1.4
- , template-haskell
- , directory >= 1.0
- , Cabal
- , unix-compat >= 0.2 && < 0.5
- , containers >= 0.2
- , attoparsec >= 0.10
- , http-types >= 0.7
- , blaze-builder >= 0.2.1.4 && < 0.4
- , filepath >= 1.1
- , process
- , zlib >= 0.5 && < 0.6
- , tar >= 0.4 && < 0.5
- , system-filepath >= 0.4 && < 0.5
- , system-fileio >= 0.3 && < 0.4
- , unordered-containers
- , yaml >= 0.8 && < 0.9
- , optparse-applicative >= 0.4
- , fsnotify >= 0.0 && < 0.1
- , split >= 0.2 && < 0.3
- , file-embed
- , conduit >= 0.5 && < 0.6
- , resourcet >= 0.3 && < 0.5
- , base64-bytestring
- , lifted-base
- , http-reverse-proxy >= 0.1.1
- , network
- , http-conduit
- , network-conduit
- , project-template >= 0.1.1
-
- ghc-options: -Wall -threaded
- main-is: main.hs
- other-modules: Scaffolding.Scaffolder
- Devel
- Build
- GhcBuild
- Keter
- AddHandler
- Paths_yesod
- Options
-
source-repository head
type: git
location: https://github.com/yesodweb/yesod
--
1.7.10.4

View file

@ -30,19 +30,6 @@ index fe851e6..c6168f4 100644
c_deflateInit2_ z a b c d e versionStr (#{const sizeof(z_stream)} :: CInt)
foreign import ccall unsafe "zlib.h deflateSetDictionary"
diff --git a/zlib.cabal b/zlib.cabal
index f2d1f5d..751bfab 100644
--- a/zlib.cabal
+++ b/zlib.cabal
@@ -36,7 +36,7 @@ library
other-modules: Codec.Compression.Zlib.Stream
extensions: CPP, ForeignFunctionInterface
build-depends: base >= 3 && < 5,
- bytestring >= 0.9 && < 0.12
+ bytestring >= 0.10.3.0
includes: zlib.h
ghc-options: -Wall
if !os(windows)
--
1.7.10.4

View file

@ -1,24 +1,20 @@
#!/bin/sh
#!/bin/bash
# Bootstraps from an empty cabal to all the necessary haskell packages
# being installed, with the necessary patches to work on Android.
#
# Packages are installed at specific versions we have patches for. Newer
# versions often break cross-compilation by adding TH, etc.
#
# Needs some extra C libraries to be installed inside the cross-compiler
# lib directory: libgnutls libxml2
# You should install ghc-android first.
#
# When run with "native" as a parameter, the same versions are installed
# in the host system. This is needed in order to use the EvilSplicer to
# expand Template Haskell.
# Note that the newest version of packages is installed.
# It attempts to reuse patches for older versions, but
# new versions of packages often break cross-compilation by adding TH,
# etc
# lib dir
set -e
if [ "$1" ]; then
mode="$1"
shift 1
if [ ! -d haskell-patches ]; then
cd standalone/android
fi
cabalopts="$@"
cabalinstall () {
@ -28,36 +24,32 @@ cabalinstall () {
patched () {
pkg=$1
version=$2
if [ "$native" ]; then
cabalinstall --force-reinstalls $pkg-$version
else
shift 2
cabal unpack $pkg-$version
cd $pkg-$version
for patch in ../../haskell-patches/${pkg}_*; do
echo applying $patch
patch -p1 < $patch
done
cabalinstall "$@"
cd ..
fi
}
unpatched () {
shift 1
cabal unpack $pkg
cd $pkg*
git init
git config user.name dummy
git config user.email dummy@example.com
git add .
git commit -m "pre-patched state of $pkg"
for patch in ../../haskell-patches/${pkg}_*; do
echo trying $patch
if ! patch -p1 < $patch; then
echo "failed to apply $patch"
echo "please resolve this, replace the patch with a new version, and exit the subshell to continue"
$SHELL
fi
done
cabalinstall "$@"
rm -rf $pkg*
cd ..
}
onlycross () {
if [ ! "$native" ]; then
eval "$@"
fi
}
onlynative () {
if [ "$native" ]; then
eval "$@"
fi
installgitannexdeps () {
pushd ../..
echo cabal install --only-dependencies
cabal install --only-dependencies "$@"
popd
}
install_pkgs () {
@ -65,145 +57,61 @@ install_pkgs () {
mkdir tmp
cd tmp
onlycross unpatched bytestring-0.10.3.0 text-0.11.3.1 parsec-3.1.3
patched network 2.4.1.0
unpatched cereal-0.3.5.2
patched socks 0.4.2
unpatched hslogger-1.2.1
patched MissingH 1.2.0.0
patched unix-time 0.1.4
patched async 2.0.1.4
patched zlib 0.5.4.0
patched primitive 0.5.0.1
patched vector 0.10.0.1
patched distributive 0.3
unpatched hashable-1.1.2.5
patched case-insensitive 0.4.0.1
unpatched nats-0.1 semigroups-0.9 tagged-0.4.4 comonad-3.0.1.1 comonad-transformers-3.0.1
patched profunctors 3.3
patched split 0.2.1.2
unpatched monads-tf-0.1.0.1
onlycross patched gnutls 0.1.4
unpatched attoparsec-0.10.4.0 blaze-builder-0.3.1.1
patched syb 0.3.7
patched aeson 0.6.1.0
patched lifted-base 0.2.0.2
patched resourcet 0.4.4
patched monad-control 0.3.1.4
unpatched conduit-0.5.6
patched monad-logger 0.2.3.2
unpatched reflection-1.1.7 bifunctors-3.2 semigroupoids-3.0.2
unpatched bifunctors-3.2 comonads-fd-3.0.1 groupoids-3.0.1.1
unpatched profunctor-extras-3.3
patched lens 3.8.5
unpatched xml-types-0.3.3
patched libxml-sax 0.7.3
patched network-conduit 0.6.2.2
unpatched asn1-data-0.7.1 asn1-types-0.1.3 attoparsec-conduit-0.5.0.3
unpatched blaze-builder-conduit-0.5.0.3 blaze-markup-0.5.1.5 blaze-html-0.5.1.3
patched cipher-aes 0.1.7
unpatched crypto-api-0.10.2
unpatched cprng-aes-0.3.4
unpatched http-types-0.8.0 mime-types-0.1.0.3
patched certificate 1.3.7
unpatched system-fileio-0.3.11 tls-1.1.2
unpatched utf8-string-0.3.7
unpatched publicsuffixlist-0.1
unpatched xml-conduit-1.0.3.3
unpatched zlib-bindings-0.1.1.3 zlib-conduit-0.5.0.3
patched shakespeare 1.0.3
patched hamlet 1.1.6.1
patched xml-hamlet 0.4.0.3
unpatched certificate-1.3.7
unpatched dataenc-0.12 hxt-charproperties-9.1.1 \
hxt-regex-xmlschema-9.1.0 hxt-unicode-9.0.2 hxt-9.3.1.1
unpatched -f-templateHaskell QuickCheck-2.5.1.1
unpatched Crypto-4.2.5.1
patched HTTP 4000.2.8
patched hS3 0.5.7
patched file-embed 0.0.4.7
patched gsasl 0.3.5 \
--ghc-options=-I$HOME/.ghc/android-14/arm-linux-androideabi-4.7/arm-linux-androideabi/sysroot/usr/include/ \
--ld-options="-L$HOME/.ghc/android-14/arm-linux-androideabi-4.7/arm-linux-androideabi/sysroot/usr/lib/"
onlycross patched network-protocol-xmpp 0.4.4
onlynative network-protocol-xmpp
patched shakespeare-css 1.0.2
patched shakespeare-i18n 1.0.0.2
patched shakespeare-js 1.1.2
patched persistent 1.1.5.1
onlycross unpatched largeword-1.0.4 crypto-api-0.10.2 http-date-0.0.4 \
cryptohash-0.8.3 vault-0.2.0.4 unix-compat-0.4.1.1 \
crypto-conduit-0.4.3 wai-1.3.0.3
patched wai-app-static 1.3.1
onlycross patched wai-extra 1.3.2.1
patched yesod-routes 1.1.2
onlycross unpatched http-conduit-1.8.7.1
onlycross patched DAV 0.3
onlynative unpatched DAV
patched yesod-core 1.1.8
patched yesod-persistent 1.1.0.1
patched yesod-form 1.2.1.1
onlycross unpatched warp-1.3.7.2 yaml-0.8.2
patched yesod-default 1.1.3.2
patched yesod 1.1.8
patched yesod-static 1.1.2
unpatched ifelse-0.85
unpatched SafeSemaphore-0.9.0
if [ ! "$native" ]; then cabal install bloomfilter-1.2.6.10 --constraint 'bytestring >= 0.10.3.0'; fi
onlynative unpatched bloomfilter-1.2.6.10
unpatched edit-distance-0.2.1.2
unpatched uuid-1.2.12
unpatched json-0.7
unpatched SHA-1.6.1
onlycross unpatched data-endian-0.0.1
unpatched hinotify-0.3.5
patched iproute 1.2.11
unpatched dns 0.3.6
patched network
patched unix-time
patched lifted-base
patched zlib
patched process
patched MissingH
patched bloomfilter
patched SafeSemaphore
patched unordered-containers
patched comonad
patched HTTP
patched MonadCatchIO-transformers
patched distributive
patched iproute
patched primitive
patched socks
patched entropy
patched vector
patched persistent
patched profunctors
patched skein
patched lens
patched persistent-template
patched file-embed
patched wai-app-static
patched shakespeare
patched hamlet
patched shakespeare-css
patched shakespeare-js
patched yesod-routes
patched yesod-core
patched yesod-persistent
patched yesod-form
patched yesod-auth
patched yesod
patched async
patched gnuidn
patched DAV
cd ..
rm -rf tmp
installgitannexdeps -fAndroid -f-Pairing
}
native_install () {
echo "Native install"
native=1
if [ ! -e $HOME/.cabal/packages/hackage.haskell.org ]; then
cabal update
fi
install_pkgs
}
echo
echo
echo native build
echo
cabal update
installgitannexdeps
cross_path () {
PATH=$HOME/.ghc/android-14/arm-linux-androideabi-4.7/bin:$HOME/.ghc/android-14/arm-linux-androideabi-4.7/arm-linux-androideabi/bin:$PATH
}
cross_install () {
echo "Cross install"
native=
cross_path
if [ ! -e $HOME/.ghc/android-14/arm-linux-androideabi-4.7/cabal/packages/hackage.haskell.org ]; then
cabal update
fi
install_pkgs
}
case "$mode" in
native)
native_install
;;
cross)
cross_install
;;
cleancross)
# cross install, first removing all currently installed
# packages except those part of ghc
rm -f $(grep -l $HOME/.ghc/android-14/arm-linux-androideabi-4.7/.cabal/lib/ $HOME/.ghc/android-14/arm-linux-androideabi-4.7/lib/ghc-*/package.conf.d/*.conf)
cross_path
ghc-pkg recache
cross_install
;;
"")
cross_install
native_install
;;
esac
echo
echo
echo cross build
echo
PATH=$HOME/.ghc/android-14/arm-linux-androideabi-4.7/bin:$HOME/.ghc/android-14/arm-linux-androideabi-4.7/arm-linux-androideabi/bin:$PATH
cabal update
install_pkgs