diff options
| author |  Joey Hess <joey@kitenet.net> | 2013-12-18 21:41:17 +0000 |
|---|---|---|
| committer | Joey Hess <joey@kitenet.net> | 2013-12-18 21:41:17 +0000 |
| commit | 64121182de585c3e0998e4a9066dfdc181cc99f9 (patch) | |
| tree | eb8f99dc91e2f97bdee050608137da94595fb305 | |
| parent | 696c355a7008fb6f8912dba4327ff152cbf05d02 (diff) | |
allow building webapp with EvilSplicer for non-android arm
Was able to reuse many of the android patches, but several had to be
re-done. On Android, ghc is a stage2 build, so can compile, but not run TH
code. But debian's ghc on armel cannot even compile TH code, so it has
to be patched out.
Some haskell packages have been updated to new versions, including yesod
and DAV, and their patches had to be redone.
The Makefile now has 2 new targets. The first is run on a companion x86
system to do the build and get TH splices. Then the second target is run
the same source tree on the arm system to build without needing TH.
This commit was sponsored by Svenne Krap.
37 files changed, 4494 insertions, 1095 deletions
@@ -196,6 +196,34 @@ osxapp: Build/Standalone Build/OSXMkLibs hdiutil create -format UDBZ -srcfolder tmp/build-dmg \ -volname git-annex -o tmp/git-annex.dmg +# Must be run on a system with TH supported, and the same +# versions of TH splice generating packages as the arm system installed. +no-th-webapp-stage1: Build/EvilSplicer + echo "Running throwaway build, to get TH splices.." + if [ ! -e dist/setup/setup ]; then $(CABAL) configure -f-Production -O0; 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 no-th build tree.." + ./Build/EvilSplicer tmp/splices tmp/dump-splices standalone/no-th/evilsplicer-headers.hs + rsync -az --exclude tmp --exclude dist . tmp/no-th-tree +# Copy the files with expanded splices to the source tree, but +# only if the existing source file is not newer. (So, if a file +# used to have TH splices but they were removed, it will be newer, +# and not overwritten.) + cp -uR tmp/splices/* tmp/no-th-tree || true +# Some additional dependencies needed by the expanded splices. + sed -i 's/^ Build-Depends: / Build-Depends: yesod-routes, yesod-core, shakespeare-css, shakespeare-js, shakespeare, blaze-markup, file-embed, wai-app-static, /' tmp/no-th-tree/git-annex.cabal +# Avoid warnings due to sometimes unused imports added for the splices. + sed -i 's/GHC-Options: \(.*\)-Wall/GHC-Options: \1-Wall -fno-warn-unused-imports /i' tmp/no-th-tree/git-annex.cabal + +# Run on the arm system, after stage1 +no-th-webapp-stage2: + if [ ! -e tmp/no-th-tree/dist/setup-config ]; then \ + cd tmp/no-th-tree && cabal configure; \ + fi + cd tmp/no-th-tree && cabal build --ghc-option=-D__NO_TH__ + cd tmp/no-th-tree && $(MAKE) linuxstandalone + ANDROID_FLAGS?= # Cross compile for Android. # Uses https://github.com/neurocyte/ghc-android diff --git a/standalone/android/haskell-patches/lens_various-hacking-to-cross-build.patch b/standalone/android/haskell-patches/lens_various-hacking-to-cross-build.patch deleted file mode 100644 index 274efc71e..000000000 --- a/standalone/android/haskell-patches/lens_various-hacking-to-cross-build.patch +++ /dev/null @@ -1,385 +0,0 @@ -From 41706061810410cc38f602ccc9a4c9560502251f Mon Sep 17 00:00:00 2001 -From: dummy <dummy@example.com> -Date: Sat, 19 Oct 2013 01:44:52 +0000 -Subject: [PATCH] hackity - ---- - 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 b25adf4..3e5c30c 100644 ---- a/lens.cabal -+++ b/lens.cabal -@@ -10,7 +10,7 @@ stability: provisional - homepage: http://github.com/ekmett/lens/ - bug-reports: http://github.com/ekmett/lens/issues - copyright: Copyright (C) 2012-2013 Edward A. Kmett --build-type: Custom -+build-type: Simple - tested-with: GHC == 7.6.3 - synopsis: Lenses, Folds and Traversals - description: -@@ -235,14 +235,12 @@ library - Control.Lens.Review - Control.Lens.Setter - Control.Lens.Simple -- Control.Lens.TH - Control.Lens.Traversal - Control.Lens.Tuple - Control.Lens.Type - Control.Lens.Wrapped - Control.Lens.Zipper - Control.Lens.Zoom -- Control.Monad.Error.Lens - Control.Parallel.Strategies.Lens - Control.Seq.Lens - Data.Array.Lens -@@ -266,12 +264,8 @@ library - Data.Typeable.Lens - Data.Vector.Lens - Data.Vector.Generic.Lens -- Generics.Deriving.Lens -- GHC.Generics.Lens - System.Exit.Lens - System.FilePath.Lens -- System.IO.Error.Lens -- Language.Haskell.TH.Lens - Numeric.Lens - - if flag(safe) -@@ -370,7 +364,6 @@ test-suite doctests - deepseq, - doctest >= 0.9.1, - filepath, -- generic-deriving, - mtl, - nats, - parallel, -@@ -396,7 +389,6 @@ benchmark plated - comonad, - criterion, - deepseq, -- generic-deriving, - lens, - transformers - -@@ -431,7 +423,6 @@ benchmark unsafe - comonads-fd, - criterion, - deepseq, -- generic-deriving, - lens, - transformers - -@@ -448,6 +439,5 @@ benchmark zipper - comonads-fd, - criterion, - deepseq, -- generic-deriving, - lens, - transformers -diff --git a/src/Control/Exception/Lens.hs b/src/Control/Exception/Lens.hs -index 0619335..c97ad9b 100644 ---- a/src/Control/Exception/Lens.hs -+++ b/src/Control/Exception/Lens.hs -@@ -112,7 +112,7 @@ import Prelude - , Maybe(..), Either(..), Functor(..), String, IO - ) - --{-# ANN module "HLint: ignore Use Control.Exception.catch" #-} -+ - - -- $setup - -- >>> :set -XNoOverloadedStrings -diff --git a/src/Control/Lens.hs b/src/Control/Lens.hs -index 242c3c1..2ab9cdb 100644 ---- a/src/Control/Lens.hs -+++ b/src/Control/Lens.hs -@@ -59,7 +59,7 @@ module Control.Lens - , module Control.Lens.Review - , module Control.Lens.Setter - , module Control.Lens.Simple --#ifndef DISABLE_TEMPLATE_HASKELL -+#if 0 - , module Control.Lens.TH - #endif - , module Control.Lens.Traversal -@@ -89,7 +89,7 @@ import Control.Lens.Reified - import Control.Lens.Review - import Control.Lens.Setter - import Control.Lens.Simple --#ifndef DISABLE_TEMPLATE_HASKELL -+#if 0 - import Control.Lens.TH - #endif - import Control.Lens.Traversal -@@ -99,4 +99,4 @@ import Control.Lens.Wrapped - import Control.Lens.Zipper - import Control.Lens.Zoom - --{-# ANN module "HLint: ignore Use import/export shortcut" #-} -+ -diff --git a/src/Control/Lens/Equality.hs b/src/Control/Lens/Equality.hs -index 982c2d7..3a3fe1a 100644 ---- a/src/Control/Lens/Equality.hs -+++ b/src/Control/Lens/Equality.hs -@@ -28,8 +28,8 @@ module Control.Lens.Equality - import Control.Lens.Internal.Setter - import Control.Lens.Type - --{-# ANN module "HLint: ignore Use id" #-} --{-# ANN module "HLint: ignore Eta reduce" #-} -+ -+ - - -- $setup - -- >>> import Control.Lens -diff --git a/src/Control/Lens/Fold.hs b/src/Control/Lens/Fold.hs -index 32a4073..cc7da1e 100644 ---- a/src/Control/Lens/Fold.hs -+++ b/src/Control/Lens/Fold.hs -@@ -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 - --{-# ANN module "HLint: ignore Eta reduce" #-} --{-# ANN module "HLint: ignore Use camelCase" #-} --{-# ANN module "HLint: ignore Use curry" #-} -+ -+ -+ - - infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?! - -diff --git a/src/Control/Lens/Internal.hs b/src/Control/Lens/Internal.hs -index 295662e..539642d 100644 ---- a/src/Control/Lens/Internal.hs -+++ b/src/Control/Lens/Internal.hs -@@ -43,4 +43,4 @@ import Control.Lens.Internal.Review - import Control.Lens.Internal.Setter - import Control.Lens.Internal.Zoom - --{-# 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 -+++ b/src/Control/Lens/Internal/Zipper.hs -@@ -53,7 +53,7 @@ import Data.Profunctor.Unsafe - -- >>> import Control.Lens - -- >>> import Data.Char - --{-# ANN module "HLint: ignore Use foldl" #-} -+ - - ------------------------------------------------------------------------------ - -- * Jacket -diff --git a/src/Control/Lens/Iso.hs b/src/Control/Lens/Iso.hs -index 1152af4..80c3175 100644 ---- a/src/Control/Lens/Iso.hs -+++ b/src/Control/Lens/Iso.hs -@@ -82,8 +82,6 @@ import Data.Maybe - import Data.Profunctor - import Data.Profunctor.Unsafe - --{-# ANN module "HLint: ignore Use on" #-} -- - -- $setup - -- >>> :set -XNoOverloadedStrings - -- >>> import Control.Lens -diff --git a/src/Control/Lens/Lens.hs b/src/Control/Lens/Lens.hs -index b26cc06..6f84943 100644 ---- a/src/Control/Lens/Lens.hs -+++ b/src/Control/Lens/Lens.hs -@@ -126,7 +126,7 @@ import Data.Profunctor.Rep - import Data.Profunctor.Unsafe - import Data.Void - --{-# ANN module "HLint: ignore Use ***" #-} -+ - - -- $setup - -- >>> :set -XNoOverloadedStrings -diff --git a/src/Control/Lens/Operators.hs b/src/Control/Lens/Operators.hs -index 11868e0..475c945 100644 ---- a/src/Control/Lens/Operators.hs -+++ b/src/Control/Lens/Operators.hs -@@ -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 a8c4d20..cef574e 100644 ---- a/src/Control/Lens/Plated.hs -+++ b/src/Control/Lens/Plated.hs -@@ -95,7 +95,7 @@ import Data.Data.Lens - import Data.Monoid - import Data.Tree - --{-# ANN module "HLint: ignore Reduce duplication" #-} -+ - - -- | 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 -+++ b/src/Control/Lens/Setter.hs -@@ -87,8 +87,6 @@ import Data.Profunctor - import Data.Profunctor.Rep - import Data.Profunctor.Unsafe - --{-# ANN module "HLint: ignore Avoid lambda" #-} -- - -- $setup - -- >>> import Control.Lens - -- >>> import Control.Monad.State -diff --git a/src/Control/Lens/TH.hs b/src/Control/Lens/TH.hs -index a05eb07..49218b5 100644 ---- a/src/Control/Lens/TH.hs -+++ b/src/Control/Lens/TH.hs -@@ -87,7 +87,7 @@ import Language.Haskell.TH - import Language.Haskell.TH.Syntax - import Language.Haskell.TH.Lens - --{-# ANN module "HLint: ignore Use foldl" #-} -+ - - -- | Flags for 'Lens' construction - data LensFlag -diff --git a/src/Data/Data/Lens.hs b/src/Data/Data/Lens.hs -index cf1e7c9..b39dacf 100644 ---- a/src/Data/Data/Lens.hs -+++ b/src/Data/Data/Lens.hs -@@ -65,9 +65,9 @@ import Data.Monoid - import GHC.Exts (realWorld#) - #endif - --{-# ANN module "HLint: ignore Eta reduce" #-} --{-# ANN module "HLint: ignore Use foldl" #-} --{-# ANN module "HLint: ignore Reduce duplication" #-} -+ -+ -+ - - -- $setup - -- >>> :set -XNoOverloadedStrings --- -1.7.10.4 - diff --git a/standalone/android/haskell-patches/shakespeare-css_1.0.2_0001-remove-TH.patch b/standalone/android/haskell-patches/shakespeare-css_1.0.2_0001-remove-TH.patch deleted file mode 100644 index 1c82eaead..000000000 --- a/standalone/android/haskell-patches/shakespeare-css_1.0.2_0001-remove-TH.patch +++ /dev/null @@ -1,148 +0,0 @@ -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/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 ---- a/Text/Cassius.hs -+++ b/Text/Cassius.hs -@@ -13,10 +13,6 @@ module Text.Cassius - , renderCss - , renderCssUrl - -- * Parsing -- , cassius -- , cassiusFile -- , cassiusFileDebug -- , cassiusFileReload - -- * ToCss instances - -- ** Color - , Color (..) -@@ -27,11 +23,8 @@ module Text.Cassius - , AbsoluteUnit (..) - , AbsoluteSize (..) - , absoluteSize -- , EmSize (..) -- , ExSize (..) - , PercentageSize (..) - , percentageSize -- , PixelSize (..) - -- * Internal - , cassiusUsedIdentifiers - ) where -@@ -42,25 +35,9 @@ import Language.Haskell.TH.Quote (QuasiQuoter (..)) - import Language.Haskell.TH.Syntax - import qualified Data.Text.Lazy as TL - import Text.CssCommon --import Text.Lucius (lucius) - import qualified Text.Lucius - import Text.IndentToBrace (i2b) - --cassius :: QuasiQuoter --cassius = QuasiQuoter { quoteExp = quoteExp lucius . i2b } -- --cassiusFile :: FilePath -> Q Exp --cassiusFile fp = do --#ifdef GHC_7_4 -- qAddDependentFile fp --#endif -- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp -- quoteExp cassius contents -- --cassiusFileDebug, cassiusFileReload :: FilePath -> Q Exp --cassiusFileDebug = cssFileDebug True [|Text.Lucius.parseTopLevels|] Text.Lucius.parseTopLevels --cassiusFileReload = cassiusFileDebug -- - -- | Determine which identifiers are used by the given template, useful for - -- creating systems like yesod devel. - cassiusUsedIdentifiers :: String -> [(Deref, VarType)] -diff --git a/Text/CssCommon.hs b/Text/CssCommon.hs -index 719e0a8..8c40e8c 100644 ---- a/Text/CssCommon.hs -+++ b/Text/CssCommon.hs -@@ -1,4 +1,3 @@ --{-# LANGUAGE TemplateHaskell #-} - {-# LANGUAGE GeneralizedNewtypeDeriving #-} - {-# LANGUAGE FlexibleInstances #-} - {-# LANGUAGE CPP #-} -@@ -156,6 +155,3 @@ showSize :: Rational -> String -> String - showSize value' unit = printf "%f" value ++ unit - where value = fromRational value' :: Double - --mkSizeType "EmSize" "em" --mkSizeType "ExSize" "ex" --mkSizeType "PixelSize" "px" -diff --git a/Text/Lucius.hs b/Text/Lucius.hs -index 89328bd..0a1cf5e 100644 ---- a/Text/Lucius.hs -+++ b/Text/Lucius.hs -@@ -8,12 +8,8 @@ - {-# OPTIONS_GHC -fno-warn-missing-fields #-} - module Text.Lucius - ( -- * Parsing -- lucius -- , luciusFile -- , luciusFileDebug -- , luciusFileReload - -- ** Mixins -- , luciusMixin -+ luciusMixin - , Mixin - -- ** Runtime - , luciusRT -@@ -40,11 +36,8 @@ module Text.Lucius - , AbsoluteUnit (..) - , AbsoluteSize (..) - , absoluteSize -- , EmSize (..) -- , ExSize (..) - , PercentageSize (..) - , percentageSize -- , PixelSize (..) - -- * Internal - , parseTopLevels - , luciusUsedIdentifiers -@@ -66,18 +59,6 @@ import Data.Monoid (mconcat) - import Data.List (isSuffixOf) - import Control.Arrow (second) - ---- | ---- ---- >>> renderCss ([lucius|foo{bar:baz}|] undefined) ---- "foo{bar:baz}" --lucius :: QuasiQuoter --lucius = QuasiQuoter { quoteExp = luciusFromString } -- --luciusFromString :: String -> Q Exp --luciusFromString s = -- topLevelsToCassius -- $ either (error . show) id $ parse parseTopLevels s s -- - whiteSpace :: Parser () - whiteSpace = many whiteSpace1 >> return () - -@@ -217,15 +198,6 @@ parseComment = do - _ <- manyTill anyChar $ try $ string "*/" - return $ ContentRaw "" - --luciusFile :: FilePath -> Q Exp --luciusFile fp = do -- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp -- luciusFromString contents -- --luciusFileDebug, luciusFileReload :: FilePath -> Q Exp --luciusFileDebug = cssFileDebug False [|parseTopLevels|] parseTopLevels --luciusFileReload = luciusFileDebug -- - parseTopLevels :: Parser [TopLevel Unresolved] - parseTopLevels = - go id --- -1.7.10.4 - diff --git a/standalone/android/haskell-patches/yesod_001_hacked-up-for-Android.patch b/standalone/android/haskell-patches/yesod_001_hacked-up-for-Android.patch deleted file mode 100644 index 23ba50d33..000000000 --- a/standalone/android/haskell-patches/yesod_001_hacked-up-for-Android.patch +++ /dev/null @@ -1,74 +0,0 @@ -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 - diff --git a/standalone/android/haskell-patches/yesod_002_hack-around-missing-symbols.patch b/standalone/android/haskell-patches/yesod_002_hack-around-missing-symbols.patch deleted file mode 100644 index eaad739e5..000000000 --- a/standalone/android/haskell-patches/yesod_002_hack-around-missing-symbols.patch +++ /dev/null @@ -1,41 +0,0 @@ -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 - diff --git a/standalone/android/install-haskell-packages b/standalone/android/install-haskell-packages index b78eda83a..333a88260 100755 --- a/standalone/android/install-haskell-packages +++ b/standalone/android/install-haskell-packages @@ -35,7 +35,7 @@ patched () { git config user.email dummy@example.com git add . git commit -m "pre-patched state of $pkg" - for patch in ../../haskell-patches/${pkg}_* ../../../haskell-patches/no-th/${pkg}_*; do + for patch in ../../haskell-patches/${pkg}_* ../../../no-th/haskell-patches/${pkg}_*; do if [ -e "$patch" ]; then echo trying $patch if ! patch -p1 < $patch; then diff --git a/standalone/haskell-patches/no-th/DAV_build-without-TH.patch b/standalone/haskell-patches/no-th/DAV_build-without-TH.patch deleted file mode 100644 index b871fa9ef..000000000 --- a/standalone/haskell-patches/no-th/DAV_build-without-TH.patch +++ /dev/null @@ -1,377 +0,0 @@ -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 #-} diff --git a/standalone/linux/install-haskell-packages b/standalone/linux/install-haskell-packages index 62bdf701b..f22bf17cb 100755 --- a/standalone/linux/install-haskell-packages +++ b/standalone/linux/install-haskell-packages @@ -34,7 +34,7 @@ patched () { git config user.email dummy@example.com git add . git commit -m "pre-patched state of $pkg" - for patch in ../../../haskell-patches/no-th/${pkg}_*; do + for patch in ../../../no-th/haskell-patches/${pkg}_*; do if [ -e "$patch" ]; then echo trying $patch if ! patch -p1 < $patch; then @@ -61,6 +61,30 @@ install_pkgs () { mkdir tmp cd tmp + patched wai-app-static + patched shakespeare + patched shakespeare-css + patched yesod-routes + patched hamlet + patched monad-logger + patched shakespeare-i18n + patched shakespeare-js + patched yesod-core + patched persistent + patched persistent-template + patched yesod + patched process-conduit + patched yesod-static + patched yesod-form + patched file-embed + patched yesod-auth + patched yesod + patched generic-deriving + patched profunctors + patched reflection + patched lens + patched xml-hamlet + patched shakespeare-text patched DAV cd .. diff --git a/standalone/android/evilsplicer-headers.hs b/standalone/no-th/evilsplicer-headers.hs index ee4d6f1a3..ef9e2603a 100644 --- a/standalone/android/evilsplicer-headers.hs +++ b/standalone/no-th/evilsplicer-headers.hs @@ -7,6 +7,7 @@ -} import qualified Data.Monoid import qualified Data.Set +import qualified Data.Set as Data.Set.Base import qualified Data.Map import qualified Data.Map as Data.Map.Base import qualified Data.Foldable @@ -26,6 +27,7 @@ import qualified Data.FileEmbed import qualified Data.ByteString.Internal import qualified Data.Text.Encoding import qualified Network.Wai +import qualified Network.Wai as Network.Wai.Internal import qualified Yesod.Core.Types {- End EvilSplicer headers. -} diff --git a/standalone/no-th/haskell-patches/DAV_build-without-TH.patch b/standalone/no-th/haskell-patches/DAV_build-without-TH.patch new file mode 100644 index 000000000..ac6ba2a19 --- /dev/null +++ b/standalone/no-th/haskell-patches/DAV_build-without-TH.patch @@ -0,0 +1,414 @@ +From 67e5fc4eb21fe801f7ab4c01b98c02912c5cb43f Mon Sep 17 00:00:00 2001 +From: Joey Hess <joey@kitenet.net> +Date: Wed, 18 Dec 2013 05:44:10 +0000 +Subject: [PATCH] expand TH + +plus manual fixups +--- + DAV.cabal | 22 +--- + Network/Protocol/HTTP/DAV.hs | 96 +++++++++++++---- + Network/Protocol/HTTP/DAV/TH.hs | 232 +++++++++++++++++++++++++++++++++++++++- + 3 files changed, 307 insertions(+), 43 deletions(-) + +diff --git a/DAV.cabal b/DAV.cabal +index 1f1eb1f..ea117ff 100644 +--- a/DAV.cabal ++++ b/DAV.cabal +@@ -36,27 +36,7 @@ library + , lifted-base >= 0.1 + , monad-control + , mtl >= 2.1 +- , transformers >= 0.3 +- , transformers-base +- , 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-client >= 0.2 +- , http-client-tls >= 0.2 +- , http-types >= 0.7 +- , lens >= 3.0 +- , lifted-base >= 0.1 +- , monad-control +- , mtl >= 2.1 +- , network >= 2.3 +- , optparse-applicative ++ , text + , transformers >= 0.3 + , transformers-base + , xml-conduit >= 1.0 && <= 1.2 +diff --git a/Network/Protocol/HTTP/DAV.hs b/Network/Protocol/HTTP/DAV.hs +index 9d8c070..5993fca 100644 +--- a/Network/Protocol/HTTP/DAV.hs ++++ b/Network/Protocol/HTTP/DAV.hs +@@ -77,7 +77,7 @@ 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 qualified Data.Text + + import Data.CaseInsensitive (mk) + +@@ -335,28 +335,84 @@ makeCollection url username password = choke $ evalDAVT url $ do + 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 +-|] ++ 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")]]))]] ++ + + 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"> +-|] ++ root = XML.Element "C:calendar-query" (Map.fromList [("xmlns:D", "DAV:"),("xmlns:C", "urn:ietf:params:xml:ns:caldav")]) $ concat ++ [[XML.NodeElement ++ (XML.Element ++ (XML.Name (Data.Text.pack "D:prop") Nothing Nothing) ++ Map.empty ++ (concat ++ [[XML.NodeElement ++ (XML.Element ++ (XML.Name ++ (Data.Text.pack "D:getetag") Nothing Nothing) ++ Map.empty ++ (concat []))], ++ [XML.NodeElement ++ (XML.Element ++ (XML.Name ++ (Data.Text.pack "C:calendar-data") Nothing Nothing) ++ Map.empty ++ (concat []))]]))], ++ [XML.NodeElement ++ (XML.Element ++ (XML.Name ++ (Data.Text.pack "C:filter") Nothing Nothing) ++ Map.empty ++ (concat ++ [[XML.NodeElement ++ (XML.Element ++ (XML.Name ++ (Data.Text.pack "C:comp-filter") Nothing Nothing) ++ (Map.insert ++ (XML.Name (Data.Text.pack "name") Nothing Nothing) ++ (Data.Text.concat ++ [Data.Text.pack "VCALENDAR"]) ++ Map.empty) ++ (concat []))]]))]] ++ +diff --git a/Network/Protocol/HTTP/DAV/TH.hs b/Network/Protocol/HTTP/DAV/TH.hs +index b072116..5a01bf9 100644 +--- a/Network/Protocol/HTTP/DAV/TH.hs ++++ b/Network/Protocol/HTTP/DAV/TH.hs +@@ -20,9 +20,11 @@ + + module Network.Protocol.HTTP.DAV.TH where + +-import Control.Lens (makeLenses) ++import Control.Lens + import qualified Data.ByteString as B + import Network.HTTP.Client (Manager, Request) ++import qualified Control.Lens.Type ++import qualified Data.Functor + + data Depth = Depth0 | Depth1 | DepthInfinity + instance Read Depth where +@@ -47,4 +49,230 @@ data DAVContext = DAVContext { + , _lockToken :: Maybe B.ByteString + , _userAgent :: B.ByteString + } +-makeLenses ''DAVContext ++allowedMethods :: Control.Lens.Type.Lens' DAVContext [B.ByteString] ++allowedMethods ++ _f_a2PF ++ (DAVContext __allowedMethods'_a2PG ++ __baseRequest_a2PI ++ __basicusername_a2PJ ++ __basicpassword_a2PK ++ __complianceClasses_a2PL ++ __depth_a2PM ++ __httpManager_a2PN ++ __lockToken_a2PO ++ __userAgent_a2PP) ++ = ((\ __allowedMethods_a2PH ++ -> DAVContext ++ __allowedMethods_a2PH ++ __baseRequest_a2PI ++ __basicusername_a2PJ ++ __basicpassword_a2PK ++ __complianceClasses_a2PL ++ __depth_a2PM ++ __httpManager_a2PN ++ __lockToken_a2PO ++ __userAgent_a2PP) ++ Data.Functor.<$> (_f_a2PF __allowedMethods'_a2PG)) ++{-# INLINE allowedMethods #-} ++baseRequest :: Control.Lens.Type.Lens' DAVContext Request ++baseRequest ++ _f_a2PQ ++ (DAVContext __allowedMethods_a2PR ++ __baseRequest'_a2PS ++ __basicusername_a2PU ++ __basicpassword_a2PV ++ __complianceClasses_a2PW ++ __depth_a2PX ++ __httpManager_a2PY ++ __lockToken_a2PZ ++ __userAgent_a2Q0) ++ = ((\ __baseRequest_a2PT ++ -> DAVContext ++ __allowedMethods_a2PR ++ __baseRequest_a2PT ++ __basicusername_a2PU ++ __basicpassword_a2PV ++ __complianceClasses_a2PW ++ __depth_a2PX ++ __httpManager_a2PY ++ __lockToken_a2PZ ++ __userAgent_a2Q0) ++ Data.Functor.<$> (_f_a2PQ __baseRequest'_a2PS)) ++{-# INLINE baseRequest #-} ++basicpassword :: Control.Lens.Type.Lens' DAVContext B.ByteString ++basicpassword ++ _f_a2Q1 ++ (DAVContext __allowedMethods_a2Q2 ++ __baseRequest_a2Q3 ++ __basicusername_a2Q4 ++ __basicpassword'_a2Q5 ++ __complianceClasses_a2Q7 ++ __depth_a2Q8 ++ __httpManager_a2Q9 ++ __lockToken_a2Qa ++ __userAgent_a2Qb) ++ = ((\ __basicpassword_a2Q6 ++ -> DAVContext ++ __allowedMethods_a2Q2 ++ __baseRequest_a2Q3 ++ __basicusername_a2Q4 ++ __basicpassword_a2Q6 ++ __complianceClasses_a2Q7 ++ __depth_a2Q8 ++ __httpManager_a2Q9 ++ __lockToken_a2Qa ++ __userAgent_a2Qb) ++ Data.Functor.<$> (_f_a2Q1 __basicpassword'_a2Q5)) ++{-# INLINE basicpassword #-} ++basicusername :: Control.Lens.Type.Lens' DAVContext B.ByteString ++basicusername ++ _f_a2Qc ++ (DAVContext __allowedMethods_a2Qd ++ __baseRequest_a2Qe ++ __basicusername'_a2Qf ++ __basicpassword_a2Qh ++ __complianceClasses_a2Qi ++ __depth_a2Qj ++ __httpManager_a2Qk ++ __lockToken_a2Ql ++ __userAgent_a2Qm) ++ = ((\ __basicusername_a2Qg ++ -> DAVContext ++ __allowedMethods_a2Qd ++ __baseRequest_a2Qe ++ __basicusername_a2Qg ++ __basicpassword_a2Qh ++ __complianceClasses_a2Qi ++ __depth_a2Qj ++ __httpManager_a2Qk ++ __lockToken_a2Ql ++ __userAgent_a2Qm) ++ Data.Functor.<$> (_f_a2Qc __basicusername'_a2Qf)) ++{-# INLINE basicusername #-} ++complianceClasses :: ++ Control.Lens.Type.Lens' DAVContext [B.ByteString] ++complianceClasses ++ _f_a2Qn ++ (DAVContext __allowedMethods_a2Qo ++ __baseRequest_a2Qp ++ __basicusername_a2Qq ++ __basicpassword_a2Qr ++ __complianceClasses'_a2Qs ++ __depth_a2Qu ++ __httpManager_a2Qv ++ __lockToken_a2Qw ++ __userAgent_a2Qx) ++ = ((\ __complianceClasses_a2Qt ++ -> DAVContext ++ __allowedMethods_a2Qo ++ __baseRequest_a2Qp ++ __basicusername_a2Qq ++ __basicpassword_a2Qr ++ __complianceClasses_a2Qt ++ __depth_a2Qu ++ __httpManager_a2Qv ++ __lockToken_a2Qw ++ __userAgent_a2Qx) ++ Data.Functor.<$> (_f_a2Qn __complianceClasses'_a2Qs)) ++{-# INLINE complianceClasses #-} ++depth :: Control.Lens.Type.Lens' DAVContext (Maybe Depth) ++depth ++ _f_a2Qy ++ (DAVContext __allowedMethods_a2Qz ++ __baseRequest_a2QA ++ __basicusername_a2QB ++ __basicpassword_a2QC ++ __complianceClasses_a2QD ++ __depth'_a2QE ++ __httpManager_a2QG ++ __lockToken_a2QH ++ __userAgent_a2QI) ++ = ((\ __depth_a2QF ++ -> DAVContext ++ __allowedMethods_a2Qz ++ __baseRequest_a2QA ++ __basicusername_a2QB ++ __basicpassword_a2QC ++ __complianceClasses_a2QD ++ __depth_a2QF ++ __httpManager_a2QG ++ __lockToken_a2QH ++ __userAgent_a2QI) ++ Data.Functor.<$> (_f_a2Qy __depth'_a2QE)) ++{-# INLINE depth #-} ++httpManager :: Control.Lens.Type.Lens' DAVContext Manager ++httpManager ++ _f_a2QJ ++ (DAVContext __allowedMethods_a2QK ++ __baseRequest_a2QL ++ __basicusername_a2QM ++ __basicpassword_a2QN ++ __complianceClasses_a2QO ++ __depth_a2QP ++ __httpManager'_a2QQ ++ __lockToken_a2QS ++ __userAgent_a2QT) ++ = ((\ __httpManager_a2QR ++ -> DAVContext ++ __allowedMethods_a2QK ++ __baseRequest_a2QL ++ __basicusername_a2QM ++ __basicpassword_a2QN ++ __complianceClasses_a2QO ++ __depth_a2QP ++ __httpManager_a2QR ++ __lockToken_a2QS ++ __userAgent_a2QT) ++ Data.Functor.<$> (_f_a2QJ __httpManager'_a2QQ)) ++{-# INLINE httpManager #-} ++lockToken :: ++ Control.Lens.Type.Lens' DAVContext (Maybe B.ByteString) ++lockToken ++ _f_a2QU ++ (DAVContext __allowedMethods_a2QV ++ __baseRequest_a2QW ++ __basicusername_a2QX ++ __basicpassword_a2QY ++ __complianceClasses_a2QZ ++ __depth_a2R0 ++ __httpManager_a2R1 ++ __lockToken'_a2R2 ++ __userAgent_a2R4) ++ = ((\ __lockToken_a2R3 ++ -> DAVContext ++ __allowedMethods_a2QV ++ __baseRequest_a2QW ++ __basicusername_a2QX ++ __basicpassword_a2QY ++ __complianceClasses_a2QZ ++ __depth_a2R0 ++ __httpManager_a2R1 ++ __lockToken_a2R3 ++ __userAgent_a2R4) ++ Data.Functor.<$> (_f_a2QU __lockToken'_a2R2)) ++{-# INLINE lockToken #-} ++userAgent :: Control.Lens.Type.Lens' DAVContext B.ByteString ++userAgent ++ _f_a2R5 ++ (DAVContext __allowedMethods_a2R6 ++ __baseRequest_a2R7 ++ __basicusername_a2R8 ++ __basicpassword_a2R9 ++ __complianceClasses_a2Ra ++ __depth_a2Rb ++ __httpManager_a2Rc ++ __lockToken_a2Rd ++ __userAgent'_a2Re) ++ = ((\ __userAgent_a2Rf ++ -> DAVContext ++ __allowedMethods_a2R6 ++ __baseRequest_a2R7 ++ __basicusername_a2R8 ++ __basicpassword_a2R9 ++ __complianceClasses_a2Ra ++ __depth_a2Rb ++ __httpManager_a2Rc ++ __lockToken_a2Rd ++ __userAgent_a2Rf) ++ Data.Functor.<$> (_f_a2R5 __userAgent'_a2Re)) ++{-# INLINE userAgent #-} +-- +1.8.5.1 + diff --git a/standalone/no-th/haskell-patches/file-embed_remove-TH.patch b/standalone/no-th/haskell-patches/file-embed_remove-TH.patch new file mode 100644 index 000000000..e637465e1 --- /dev/null +++ b/standalone/no-th/haskell-patches/file-embed_remove-TH.patch @@ -0,0 +1,131 @@ +From cd49a96991dc3dd8867038fa9d426a8ccdb25f8d Mon Sep 17 00:00:00 2001 +From: Joey Hess <joey@kitenet.net> +Date: Tue, 17 Dec 2013 18:40:48 +0000 +Subject: [PATCH] remove TH + +--- + Data/FileEmbed.hs | 87 ++++--------------------------------------------------- + 1 file changed, 5 insertions(+), 82 deletions(-) + +diff --git a/Data/FileEmbed.hs b/Data/FileEmbed.hs +index 5617493..ad92cdc 100644 +--- a/Data/FileEmbed.hs ++++ b/Data/FileEmbed.hs +@@ -17,13 +17,13 @@ + -- > {-# LANGUAGE TemplateHaskell #-} + module Data.FileEmbed + ( -- * Embed at compile time +- embedFile +- , embedOneFileOf +- , embedDir +- , getDir ++ -- embedFile ++ --, embedOneFileOf ++ --, embedDir ++ getDir + -- * Inject into an executable + #if MIN_VERSION_template_haskell(2,5,0) +- , dummySpace ++ --, dummySpace + #endif + , inject + , injectFile +@@ -56,72 +56,11 @@ 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 single existing file in your source code +--- out of list a list of paths supplied. +--- +--- > import qualified Data.ByteString +--- > +--- > myFile :: Data.ByteString.ByteString +--- > myFile = $(embedFile' [ "dirName/fileName", "src/dirName/fileName" ]) +-embedOneFileOf :: [FilePath] -> Q Exp +-embedOneFileOf ps = +- (runIO $ readExistingFile ps) >>= \ ( path, content ) -> do +-#if MIN_VERSION_template_haskell(2,7,0) +- qAddDependentFile path +-#endif +- bsToExp content +- where +- readExistingFile :: [FilePath] -> IO ( FilePath, B.ByteString ) +- readExistingFile xs = do +- ys <- filterM doesFileExist xs +- case ys of +- (p:_) -> B.readFile p >>= \ c -> return ( p, c ) +- _ -> throw $ ErrorCall "Cannot find file to embed as resource" +- +--- | Embed a directory recursively 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 +@@ -164,22 +103,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 +-- +1.8.5.1 + diff --git a/standalone/no-th/haskell-patches/generic-deriving_remove-TH.patch b/standalone/no-th/haskell-patches/generic-deriving_remove-TH.patch new file mode 100644 index 000000000..83c8ffd2a --- /dev/null +++ b/standalone/no-th/haskell-patches/generic-deriving_remove-TH.patch @@ -0,0 +1,394 @@ +From 9a41401d903f160e11d56fff35c24eb59d97885d Mon Sep 17 00:00:00 2001 +From: Joey Hess <joey@kitenet.net> +Date: Tue, 17 Dec 2013 19:04:40 +0000 +Subject: [PATCH] remove TH + +--- + src/Generics/Deriving/TH.hs | 354 -------------------------------------------- + 1 file changed, 354 deletions(-) + +diff --git a/src/Generics/Deriving/TH.hs b/src/Generics/Deriving/TH.hs +index 783cb65..9aab713 100644 +--- a/src/Generics/Deriving/TH.hs ++++ b/src/Generics/Deriving/TH.hs +@@ -19,18 +19,6 @@ +
+ -- Adapted from Generics.Regular.TH
+ module Generics.Deriving.TH (
+-
+- deriveMeta
+- , deriveData
+- , deriveConstructors
+- , deriveSelectors
+-
+-#if __GLASGOW_HASKELL__ < 701
+- , deriveAll
+- , deriveRepresentable0
+- , deriveRep0
+- , simplInstance
+-#endif
+ ) where
+
+ import Generics.Deriving.Base
+@@ -41,124 +29,6 @@ import Language.Haskell.TH.Syntax (Lift(..)) + import Data.List (intercalate)
+ import Control.Monad
+
+--- | Given the names of a generic class, a type to instantiate, a function in
+--- the class and the default implementation, generates the code for a basic
+--- generic instance.
+-simplInstance :: Name -> Name -> Name -> Name -> Q [Dec]
+-simplInstance cl ty fn df = do
+- i <- reify (genRepName 0 ty)
+- x <- newName "x"
+- let typ = ForallT [PlainTV x] []
+- ((foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT (genRepName 0 ty))
+- (typeVariables i)) `AppT` (VarT x))
+- fmap (: []) $ instanceD (cxt []) (conT cl `appT` conT ty)
+- [funD fn [clause [] (normalB (varE df `appE`
+- (sigE (global 'undefined) (return typ)))) []]]
+-
+-
+--- | Given the type and the name (as string) for the type to derive,
+--- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'
+--- instances, and the 'Representable0' instance.
+-deriveAll :: Name -> Q [Dec]
+-deriveAll n =
+- do a <- deriveMeta n
+- b <- deriveRepresentable0 n
+- return (a ++ b)
+-
+--- | Given the type and the name (as string) for the type to derive,
+--- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector'
+--- instances.
+-deriveMeta :: Name -> Q [Dec]
+-deriveMeta n =
+- do a <- deriveData n
+- b <- deriveConstructors n
+- c <- deriveSelectors n
+- return (a ++ b ++ c)
+-
+--- | Given a datatype name, derive a datatype and instance of class 'Datatype'.
+-deriveData :: Name -> Q [Dec]
+-deriveData = dataInstance
+-
+--- | Given a datatype name, derive datatypes and
+--- instances of class 'Constructor'.
+-deriveConstructors :: Name -> Q [Dec]
+-deriveConstructors = constrInstance
+-
+--- | Given a datatype name, derive datatypes and instances of class 'Selector'.
+-deriveSelectors :: Name -> Q [Dec]
+-deriveSelectors = selectInstance
+-
+--- | Given the type and the name (as string) for the Representable0 type
+--- synonym to derive, generate the 'Representable0' instance.
+-deriveRepresentable0 :: Name -> Q [Dec]
+-deriveRepresentable0 n = do
+- rep0 <- deriveRep0 n
+- inst <- deriveInst n
+- return $ rep0 ++ inst
+-
+--- | Derive only the 'Rep0' type synonym. Not needed if 'deriveRepresentable0'
+--- is used.
+-deriveRep0 :: Name -> Q [Dec]
+-deriveRep0 n = do
+- i <- reify n
+- fmap (:[]) $ tySynD (genRepName 0 n) (typeVariables i) (rep0Type n)
+-
+-deriveInst :: Name -> Q [Dec]
+-deriveInst t = do
+- i <- reify t
+- let typ q = foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT q)
+- (typeVariables i)
+-#if __GLASGOW_HASKELL__ >= 707
+- let tyIns = TySynInstD ''Rep (TySynEqn [typ t] (typ (genRepName 0 t)))
+-#else
+- let tyIns = TySynInstD ''Rep [typ t] (typ (genRepName 0 t))
+-#endif
+- fcs <- mkFrom t 1 0 t
+- tcs <- mkTo t 1 0 t
+- liftM (:[]) $
+- instanceD (cxt []) (conT ''Generic `appT` return (typ t))
+- [return tyIns, funD 'from fcs, funD 'to tcs]
+-
+-
+-dataInstance :: Name -> Q [Dec]
+-dataInstance n = do
+- i <- reify n
+- case i of
+- TyConI (DataD _ n _ _ _) -> mkInstance n
+- TyConI (NewtypeD _ n _ _ _) -> mkInstance n
+- _ -> return []
+- where
+- mkInstance n = do
+- ds <- mkDataData n
+- is <- mkDataInstance n
+- return $ [ds,is]
+-
+-constrInstance :: Name -> Q [Dec]
+-constrInstance n = do
+- i <- reify n
+- case i of
+- TyConI (DataD _ n _ cs _) -> mkInstance n cs
+- TyConI (NewtypeD _ n _ c _) -> mkInstance n [c]
+- _ -> return []
+- where
+- mkInstance n cs = do
+- ds <- mapM (mkConstrData n) cs
+- is <- mapM (mkConstrInstance n) cs
+- return $ ds ++ is
+-
+-selectInstance :: Name -> Q [Dec]
+-selectInstance n = do
+- i <- reify n
+- case i of
+- TyConI (DataD _ n _ cs _) -> mkInstance n cs
+- TyConI (NewtypeD _ n _ c _) -> mkInstance n [c]
+- _ -> return []
+- where
+- mkInstance n cs = do
+- ds <- mapM (mkSelectData n) cs
+- is <- mapM (mkSelectInstance n) cs
+- return $ concat (ds ++ is)
+-
+ typeVariables :: Info -> [TyVarBndr]
+ typeVariables (TyConI (DataD _ _ tv _ _)) = tv
+ typeVariables (TyConI (NewtypeD _ _ tv _ _)) = tv
+@@ -179,233 +49,9 @@ genName = mkName . (++"_") . intercalate "_" . map nameBase + genRepName :: Int -> Name -> Name
+ genRepName n = mkName . (++"_") . (("Rep" ++ show n) ++) . nameBase
+
+-mkDataData :: Name -> Q Dec
+-mkDataData n = dataD (cxt []) (genName [n]) [] [] []
+-
+-mkConstrData :: Name -> Con -> Q Dec
+-mkConstrData dt (NormalC n _) =
+- dataD (cxt []) (genName [dt, n]) [] [] []
+-mkConstrData dt r@(RecC _ _) =
+- mkConstrData dt (stripRecordNames r)
+-mkConstrData dt (InfixC t1 n t2) =
+- mkConstrData dt (NormalC n [t1,t2])
+-
+-mkSelectData :: Name -> Con -> Q [Dec]
+-mkSelectData dt r@(RecC n fs) = return (map one fs)
+- where one (f, _, _) = DataD [] (genName [dt, n, f]) [] [] []
+-mkSelectData dt _ = return []
+-
+-
+-mkDataInstance :: Name -> Q Dec
+-mkDataInstance n =
+- instanceD (cxt []) (appT (conT ''Datatype) (conT $ genName [n]))
+- [funD 'datatypeName [clause [wildP] (normalB (stringE (nameBase n))) []]
+- ,funD 'moduleName [clause [wildP] (normalB (stringE name)) []]]
+- where
+- name = maybe (error "Cannot fetch module name!") id (nameModule n)
+-
+-instance Lift Fixity where
+- lift Prefix = conE 'Prefix
+- lift (Infix a n) = conE 'Infix `appE` [| a |] `appE` [| n |]
+-
+-instance Lift Associativity where
+- lift LeftAssociative = conE 'LeftAssociative
+- lift RightAssociative = conE 'RightAssociative
+- lift NotAssociative = conE 'NotAssociative
+-
+-mkConstrInstance :: Name -> Con -> Q Dec
+-mkConstrInstance dt (NormalC n _) = mkConstrInstanceWith dt n []
+-mkConstrInstance dt (RecC n _) = mkConstrInstanceWith dt n
+- [ funD 'conIsRecord [clause [wildP] (normalB (conE 'True)) []]]
+-mkConstrInstance dt (InfixC t1 n t2) =
+- do
+- i <- reify n
+- let fi = case i of
+- DataConI _ _ _ f -> convertFixity f
+- _ -> Prefix
+- instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n]))
+- [funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []],
+- funD 'conFixity [clause [wildP] (normalB [| fi |]) []]]
+- where
+- convertFixity (Fixity n d) = Infix (convertDirection d) n
+- convertDirection InfixL = LeftAssociative
+- convertDirection InfixR = RightAssociative
+- convertDirection InfixN = NotAssociative
+-
+-mkConstrInstanceWith :: Name -> Name -> [Q Dec] -> Q Dec
+-mkConstrInstanceWith dt n extra =
+- instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n]))
+- (funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra)
+-
+-mkSelectInstance :: Name -> Con -> Q [Dec]
+-mkSelectInstance dt r@(RecC n fs) = return (map one fs) where
+- one (f, _, _) =
+- InstanceD ([]) (AppT (ConT ''Selector) (ConT $ genName [dt, n, f]))
+- [FunD 'selName [Clause [WildP]
+- (NormalB (LitE (StringL (nameBase f)))) []]]
+-mkSelectInstance _ _ = return []
+-
+-rep0Type :: Name -> Q Type
+-rep0Type n =
+- do
+- -- runIO $ putStrLn $ "processing " ++ show n
+- i <- reify n
+- let b = case i of
+- TyConI (DataD _ dt vs cs _) ->
+- (conT ''D1) `appT` (conT $ genName [dt]) `appT`
+- (foldr1' sum (conT ''V1)
+- (map (rep0Con (dt, map tyVarBndrToName vs)) cs))
+- TyConI (NewtypeD _ dt vs c _) ->
+- (conT ''D1) `appT` (conT $ genName [dt]) `appT`
+- (rep0Con (dt, map tyVarBndrToName vs) c)
+- TyConI (TySynD t _ _) -> error "type synonym?"
+- _ -> error "unknown construct"
+- --appT b (conT $ mkName (nameBase n))
+- b where
+- sum :: Q Type -> Q Type -> Q Type
+- sum a b = conT ''(:+:) `appT` a `appT` b
+-
+-
+-rep0Con :: (Name, [Name]) -> Con -> Q Type
+-rep0Con (dt, vs) (NormalC n []) =
+- conT ''C1 `appT` (conT $ genName [dt, n]) `appT`
+- (conT ''S1 `appT` conT ''NoSelector `appT` conT ''U1)
+-rep0Con (dt, vs) (NormalC n fs) =
+- conT ''C1 `appT` (conT $ genName [dt, n]) `appT`
+- (foldr1 prod (map (repField (dt, vs) . snd) fs)) where
+- prod :: Q Type -> Q Type -> Q Type
+- prod a b = conT ''(:*:) `appT` a `appT` b
+-rep0Con (dt, vs) r@(RecC n []) =
+- conT ''C1 `appT` (conT $ genName [dt, n]) `appT` conT ''U1
+-rep0Con (dt, vs) r@(RecC n fs) =
+- conT ''C1 `appT` (conT $ genName [dt, n]) `appT`
+- (foldr1 prod (map (repField' (dt, vs) n) fs)) where
+- prod :: Q Type -> Q Type -> Q Type
+- prod a b = conT ''(:*:) `appT` a `appT` b
+-
+-rep0Con d (InfixC t1 n t2) = rep0Con d (NormalC n [t1,t2])
+-
+---dataDeclToType :: (Name, [Name]) -> Type
+---dataDeclToType (dt, vs) = foldl (\a b -> AppT a (VarT b)) (ConT dt) vs
+-
+-repField :: (Name, [Name]) -> Type -> Q Type
+---repField d t | t == dataDeclToType d = conT ''I
+-repField d t = conT ''S1 `appT` conT ''NoSelector `appT`
+- (conT ''Rec0 `appT` return t)
+-
+-repField' :: (Name, [Name]) -> Name -> (Name, Strict, Type) -> Q Type
+---repField' d ns (_, _, t) | t == dataDeclToType d = conT ''I
+-repField' (dt, vs) ns (f, _, t) = conT ''S1 `appT` conT (genName [dt, ns, f])
+- `appT` (conT ''Rec0 `appT` return t)
+--- Note: we should generate Par0 too, at some point
+-
+-
+-mkFrom :: Name -> Int -> Int -> Name -> Q [Q Clause]
+-mkFrom ns m i n =
+- do
+- -- runIO $ putStrLn $ "processing " ++ show n
+- let wrapE e = lrE m i e
+- i <- reify n
+- let b = case i of
+- TyConI (DataD _ dt vs cs _) ->
+- zipWith (fromCon wrapE ns (dt, map tyVarBndrToName vs)
+- (length cs)) [0..] cs
+- TyConI (NewtypeD _ dt vs c _) ->
+- [fromCon wrapE ns (dt, map tyVarBndrToName vs) 1 0 c]
+- TyConI (TySynD t _ _) -> error "type synonym?"
+- -- [clause [varP (field 0)] (normalB (wrapE $ conE 'K1 `appE` varE (field 0))) []]
+- _ -> error "unknown construct"
+- return b
+-
+-mkTo :: Name -> Int -> Int -> Name -> Q [Q Clause]
+-mkTo ns m i n =
+- do
+- -- runIO $ putStrLn $ "processing " ++ show n
+- let wrapP p = lrP m i p
+- i <- reify n
+- let b = case i of
+- TyConI (DataD _ dt vs cs _) ->
+- zipWith (toCon wrapP ns (dt, map tyVarBndrToName vs)
+- (length cs)) [0..] cs
+- TyConI (NewtypeD _ dt vs c _) ->
+- [toCon wrapP ns (dt, map tyVarBndrToName vs) 1 0 c]
+- TyConI (TySynD t _ _) -> error "type synonym?"
+- -- [clause [wrapP $ conP 'K1 [varP (field 0)]] (normalB $ varE (field 0)) []]
+- _ -> error "unknown construct"
+- return b
+-
+-fromCon :: (Q Exp -> Q Exp) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause
+-fromCon wrap ns (dt, vs) m i (NormalC cn []) =
+- clause
+- [conP cn []]
+- (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ appE (conE 'M1) $
+- conE 'M1 `appE` (conE 'U1)) []
+-fromCon wrap ns (dt, vs) m i (NormalC cn fs) =
+- -- runIO (putStrLn ("constructor " ++ show ix)) >>
+- clause
+- [conP cn (map (varP . field) [0..length fs - 1])]
+- (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE`
+- foldr1 prod (zipWith (fromField (dt, vs)) [0..] (map snd fs))) []
+- where prod x y = conE '(:*:) `appE` x `appE` y
+-fromCon wrap ns (dt, vs) m i r@(RecC cn []) =
+- clause
+- [conP cn []]
+- (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` (conE 'U1)) []
+-fromCon wrap ns (dt, vs) m i r@(RecC cn fs) =
+- clause
+- [conP cn (map (varP . field) [0..length fs - 1])]
+- (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE`
+- foldr1 prod (zipWith (fromField (dt, vs)) [0..] (map trd fs))) []
+- where prod x y = conE '(:*:) `appE` x `appE` y
+-fromCon wrap ns (dt, vs) m i (InfixC t1 cn t2) =
+- fromCon wrap ns (dt, vs) m i (NormalC cn [t1,t2])
+-
+-fromField :: (Name, [Name]) -> Int -> Type -> Q Exp
+---fromField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conE 'I `appE` varE (field nr)
+-fromField (dt, vs) nr t = conE 'M1 `appE` (conE 'K1 `appE` varE (field nr))
+-
+-toCon :: (Q Pat -> Q Pat) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause
+-toCon wrap ns (dt, vs) m i (NormalC cn []) =
+- clause
+- [wrap $ conP 'M1 [lrP m i $ conP 'M1 [conP 'M1 [conP 'U1 []]]]]
+- (normalB $ conE cn) []
+-toCon wrap ns (dt, vs) m i (NormalC cn fs) =
+- -- runIO (putStrLn ("constructor " ++ show ix)) >>
+- clause
+- [wrap $ conP 'M1 [lrP m i $ conP 'M1
+- [foldr1 prod (zipWith (toField (dt, vs)) [0..] (map snd fs))]]]
+- (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) []
+- where prod x y = conP '(:*:) [x,y]
+-toCon wrap ns (dt, vs) m i r@(RecC cn []) =
+- clause
+- [wrap $ conP 'M1 [lrP m i $ conP 'M1 [conP 'U1 []]]]
+- (normalB $ conE cn) []
+-toCon wrap ns (dt, vs) m i r@(RecC cn fs) =
+- clause
+- [wrap $ conP 'M1 [lrP m i $ conP 'M1
+- [foldr1 prod (zipWith (toField (dt, vs)) [0..] (map trd fs))]]]
+- (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) []
+- where prod x y = conP '(:*:) [x,y]
+-toCon wrap ns (dt, vs) m i (InfixC t1 cn t2) =
+- toCon wrap ns (dt, vs) m i (NormalC cn [t1,t2])
+-
+-toField :: (Name, [Name]) -> Int -> Type -> Q Pat
+---toField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conP 'I [varP (field nr)]
+-toField (dt, vs) nr t = conP 'M1 [conP 'K1 [varP (field nr)]]
+-
+-
+ field :: Int -> Name
+ field n = mkName $ "f" ++ show n
+
+-lrP :: Int -> Int -> (Q Pat -> Q Pat)
+-lrP 1 0 p = p
+-lrP m 0 p = conP 'L1 [p]
+-lrP m i p = conP 'R1 [lrP (m-1) (i-1) p]
+-
+-lrE :: Int -> Int -> (Q Exp -> Q Exp)
+-lrE 1 0 e = e
+-lrE m 0 e = conE 'L1 `appE` e
+-lrE m i e = conE 'R1 `appE` lrE (m-1) (i-1) e
+
+ trd (_,_,c) = c
+
+-- +1.8.5.1 + diff --git a/standalone/no-th/haskell-patches/hamlet_remove-TH.patch b/standalone/no-th/haskell-patches/hamlet_remove-TH.patch new file mode 100644 index 000000000..c5c352fe4 --- /dev/null +++ b/standalone/no-th/haskell-patches/hamlet_remove-TH.patch @@ -0,0 +1,365 @@ +From f500a9e447912e68c12f011fe97b62e6a6c5c3ce Mon Sep 17 00:00:00 2001 +From: Joey Hess <joey@kitenet.net> +Date: Tue, 17 Dec 2013 16:16:32 +0000 +Subject: [PATCH] remove TH + +--- + Text/Hamlet.hs | 310 ++++----------------------------------------------------- + 1 file changed, 17 insertions(+), 293 deletions(-) + +diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs +index 4f873f4..10d8ba6 100644 +--- a/Text/Hamlet.hs ++++ b/Text/Hamlet.hs +@@ -11,34 +11,34 @@ + module Text.Hamlet + ( -- * Plain HTML + Html +- , shamlet +- , shamletFile +- , xshamlet +- , xshamletFile ++ --, shamlet ++ --, shamletFile ++ --, xshamlet ++ --, xshamletFile + -- * Hamlet + , HtmlUrl +- , hamlet +- , hamletFile +- , xhamlet +- , xhamletFile ++ --, hamlet ++ --, hamletFile ++ --, xhamlet ++ --, xhamletFile + -- * I18N Hamlet + , HtmlUrlI18n +- , ihamlet +- , ihamletFile ++ --, ihamlet ++ --, ihamletFile + -- * Type classes + , ToAttributes (..) + -- * Internal, for making more + , HamletSettings (..) + , NewlineStyle (..) +- , hamletWithSettings +- , hamletFileWithSettings ++ --, hamletWithSettings ++ --, hamletFileWithSettings + , defaultHamletSettings + , xhtmlHamletSettings +- , Env (..) +- , HamletRules (..) +- , hamletRules +- , ihamletRules +- , htmlRules ++ --, Env (..) ++ --, HamletRules (..) ++ --, hamletRules ++ --, ihamletRules ++ --, htmlRules + , CloseStyle (..) + -- * Used by generated code + , condH +@@ -100,47 +100,9 @@ type HtmlUrl url = Render url -> Html + -- | A function generating an 'Html' given a message translator and a URL rendering function. + type HtmlUrlI18n msg url = Translate msg -> Render url -> Html + +-docsToExp :: Env -> HamletRules -> Scope -> [Doc] -> Q Exp +-docsToExp env hr scope docs = do +- exps <- mapM (docToExp env hr scope) docs +- case exps of +- [] -> [|return ()|] +- [x] -> return x +- _ -> return $ DoE $ map NoBindS exps +- + unIdent :: Ident -> String + unIdent (Ident s) = s + +-bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)]) +-bindingPattern (BindAs i@(Ident s) b) = do +- name <- newName s +- (pattern, scope) <- bindingPattern b +- return (AsP name pattern, (i, VarE name):scope) +-bindingPattern (BindVar i@(Ident s)) +- | all isDigit s = do +- return (LitP $ IntegerL $ read s, []) +- | otherwise = do +- name <- newName s +- return (VarP name, [(i, VarE name)]) +-bindingPattern (BindTuple is) = do +- (patterns, scopes) <- fmap unzip $ mapM bindingPattern is +- return (TupP patterns, concat scopes) +-bindingPattern (BindList is) = do +- (patterns, scopes) <- fmap unzip $ mapM bindingPattern is +- return (ListP patterns, concat scopes) +-bindingPattern (BindConstr con is) = do +- (patterns, scopes) <- fmap unzip $ mapM bindingPattern is +- return (ConP (mkConName con) patterns, concat scopes) +-bindingPattern (BindRecord con fields wild) = do +- let f (Ident field,b) = +- do (p,s) <- bindingPattern b +- return ((mkName field,p),s) +- (patterns, scopes) <- fmap unzip $ mapM f fields +- (patterns1, scopes1) <- if wild +- then bindWildFields con $ map fst fields +- else return ([],[]) +- return (RecP (mkConName con) (patterns++patterns1), concat scopes ++ scopes1) +- + mkConName :: DataConstr -> Name + mkConName = mkName . conToStr + +@@ -148,248 +110,10 @@ conToStr :: DataConstr -> String + conToStr (DCUnqualified (Ident x)) = x + conToStr (DCQualified (Module xs) (Ident x)) = intercalate "." $ xs ++ [x] + +--- Wildcards bind all of the unbound fields to variables whose name +--- matches the field name. +--- +--- For example: data R = C { f1, f2 :: Int } +--- C {..} is equivalent to C {f1=f1, f2=f2} +--- C {f1 = a, ..} is equivalent to C {f1=a, f2=f2} +--- C {f2 = a, ..} is equivalent to C {f1=f1, f2=a} +-bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)]) +-bindWildFields conName fields = do +- fieldNames <- recordToFieldNames conName +- let available n = nameBase n `notElem` map unIdent fields +- let remainingFields = filter available fieldNames +- let mkPat n = do +- e <- newName (nameBase n) +- return ((n,VarP e), (Ident (nameBase n), VarE e)) +- fmap unzip $ mapM mkPat remainingFields +- +--- Important note! reify will fail if the record type is defined in the +--- same module as the reify is used. This means quasi-quoted Hamlet +--- literals will not be able to use wildcards to match record types +--- defined in the same module. +-recordToFieldNames :: DataConstr -> Q [Name] +-recordToFieldNames conStr = do +- -- use 'lookupValueName' instead of just using 'mkName' so we reify the +- -- data constructor and not the type constructor if their names match. +- Just conName <- lookupValueName $ conToStr conStr +- DataConI _ _ typeName _ <- reify conName +- TyConI (DataD _ _ _ cons _) <- reify typeName +- [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 ((specialOrIdent, VarE 'or):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 :: (Binding, [Doc]) -> Q Match +- toMatch (idents, inside) = do +- (pat, extraScope) <- bindingPattern idents +- let scope' = extraScope ++ scope +- 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 +- , hrEmbed :: Env -> Exp -> Q Exp +- } +- +-data Env = Env +- { urlRender :: Maybe ((Exp -> Q Exp) -> Q Exp) +- , 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 +- +-strToExp :: String -> Exp +-strToExp s@(c:_) +- | all isDigit s = LitE $ IntegerL $ read s +- | isUpper c = ConE $ mkName s +- | otherwise = VarE $ mkName s +-strToExp "" = error "strToExp on empty string" + + -- | Checks for truth in the left value in each pair in the first argument. If + -- a true exists, then the corresponding right action is performed. Only the +-- +1.8.5.1 + diff --git a/standalone/no-th/haskell-patches/lens_no-TH.patch b/standalone/no-th/haskell-patches/lens_no-TH.patch new file mode 100644 index 000000000..ffcf0027e --- /dev/null +++ b/standalone/no-th/haskell-patches/lens_no-TH.patch @@ -0,0 +1,175 @@ +From 2b5fa1851a84f58b43e7c4224bd5695a32a80de9 Mon Sep 17 00:00:00 2001 +From: dummy <dummy@example.com> +Date: Wed, 18 Dec 2013 03:27:54 +0000 +Subject: [PATCH] avoid TH + +--- + lens.cabal | 13 +------------ + src/Control/Lens.hs | 4 ++-- + src/Control/Lens/Internal/Exception.hs | 30 ------------------------------ + src/Control/Lens/Prism.hs | 2 -- + 4 files changed, 3 insertions(+), 46 deletions(-) + +diff --git a/lens.cabal b/lens.cabal +index 8477892..a6ac7a5 100644 +--- a/lens.cabal ++++ b/lens.cabal +@@ -10,7 +10,7 @@ stability: provisional + homepage: http://github.com/ekmett/lens/ + bug-reports: http://github.com/ekmett/lens/issues + copyright: Copyright (C) 2012-2013 Edward A. Kmett +-build-type: Custom ++build-type: Simple + tested-with: GHC == 7.6.3 + synopsis: Lenses, Folds and Traversals + description: +@@ -173,7 +173,6 @@ library + containers >= 0.4.0 && < 0.6, + distributive >= 0.3 && < 1, + filepath >= 1.2.0.0 && < 1.4, +- generic-deriving >= 1.4 && < 1.7, + ghc-prim, + hashable >= 1.1.2.3 && < 1.3, + MonadCatchIO-transformers >= 0.3 && < 0.4, +@@ -235,14 +234,12 @@ library + Control.Lens.Review + Control.Lens.Setter + Control.Lens.Simple +- Control.Lens.TH + Control.Lens.Traversal + Control.Lens.Tuple + Control.Lens.Type + Control.Lens.Wrapped + Control.Lens.Zipper + Control.Lens.Zoom +- Control.Monad.Error.Lens + Control.Parallel.Strategies.Lens + Control.Seq.Lens + Data.Array.Lens +@@ -266,12 +263,8 @@ library + Data.Typeable.Lens + Data.Vector.Lens + Data.Vector.Generic.Lens +- Generics.Deriving.Lens +- GHC.Generics.Lens + System.Exit.Lens + System.FilePath.Lens +- System.IO.Error.Lens +- Language.Haskell.TH.Lens + Numeric.Lens + + if flag(safe) +@@ -370,7 +363,6 @@ test-suite doctests + deepseq, + doctest >= 0.9.1, + filepath, +- generic-deriving, + mtl, + nats, + parallel, +@@ -396,7 +388,6 @@ benchmark plated + comonad, + criterion, + deepseq, +- generic-deriving, + lens, + transformers + +@@ -431,7 +422,6 @@ benchmark unsafe + comonads-fd, + criterion, + deepseq, +- generic-deriving, + lens, + transformers + +@@ -448,6 +438,5 @@ benchmark zipper + comonads-fd, + criterion, + deepseq, +- generic-deriving, + lens, + transformers +diff --git a/src/Control/Lens.hs b/src/Control/Lens.hs +index f7c6548..125153e 100644 +--- a/src/Control/Lens.hs ++++ b/src/Control/Lens.hs +@@ -59,7 +59,7 @@ module Control.Lens + , module Control.Lens.Review + , module Control.Lens.Setter + , module Control.Lens.Simple +-#ifndef DISABLE_TEMPLATE_HASKELL ++#if 0 + , module Control.Lens.TH + #endif + , module Control.Lens.Traversal +@@ -89,7 +89,7 @@ import Control.Lens.Reified + import Control.Lens.Review + import Control.Lens.Setter + import Control.Lens.Simple +-#ifndef DISABLE_TEMPLATE_HASKELL ++#if 0 + import Control.Lens.TH + #endif + import Control.Lens.Traversal +diff --git a/src/Control/Lens/Internal/Exception.hs b/src/Control/Lens/Internal/Exception.hs +index 387203e..bb1ca10 100644 +--- a/src/Control/Lens/Internal/Exception.hs ++++ b/src/Control/Lens/Internal/Exception.hs +@@ -128,18 +128,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 +147,3 @@ 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/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 +-- +1.8.5.1 + diff --git a/standalone/no-th/haskell-patches/monad-logger_remove-TH.patch b/standalone/no-th/haskell-patches/monad-logger_remove-TH.patch new file mode 100644 index 000000000..78cf7be35 --- /dev/null +++ b/standalone/no-th/haskell-patches/monad-logger_remove-TH.patch @@ -0,0 +1,150 @@ +From 08aa9d495cb486c45998dfad95518c646b5fa8cc Mon Sep 17 00:00:00 2001 +From: Joey Hess <joey@kitenet.net> +Date: Tue, 17 Dec 2013 16:24:31 +0000 +Subject: [PATCH] remove TH + +--- + Control/Monad/Logger.hs | 109 ++++++++++-------------------------------------- + 1 file changed, 21 insertions(+), 88 deletions(-) + +diff --git a/Control/Monad/Logger.hs b/Control/Monad/Logger.hs +index be756d7..d4979f8 100644 +--- a/Control/Monad/Logger.hs ++++ b/Control/Monad/Logger.hs +@@ -31,31 +31,31 @@ module Control.Monad.Logger + , withChannelLogger + , NoLoggingT (..) + -- * TH logging +- , logDebug +- , logInfo +- , logWarn +- , logError +- , logOther ++ --, logDebug ++ --, logInfo ++ --, logWarn ++ --, logError ++ --, logOther + -- * TH logging with source +- , logDebugS +- , logInfoS +- , logWarnS +- , logErrorS +- , logOtherS ++ --, logDebugS ++ --, logInfoS ++ --, logWarnS ++ --, logErrorS ++ --, logOtherS + -- * TH util +- , liftLoc ++ -- , liftLoc + -- * Non-TH logging +- , logDebugN +- , logInfoN +- , logWarnN +- , logErrorN +- , logOtherN ++ --, logDebugN ++ --, logInfoN ++ --, logWarnN ++ --, logErrorN ++ --, logOtherN + -- * Non-TH logging with source +- , logDebugNS +- , logInfoNS +- , logWarnNS +- , logErrorNS +- , logOtherNS ++ --, logDebugNS ++ --, logInfoNS ++ --, logWarnNS ++ --, logErrorNS ++ --, logOtherNS + ) where + + import Language.Haskell.TH.Syntax (Lift (lift), Q, Exp, Loc (..), qLocation) +@@ -115,13 +115,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 +@@ -152,66 +145,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) (pack "") $(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 +- +--- | Lift a location into an Exp. +--- +--- Since 0.3.1 +-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: +--- +--- > $logDebugS "SomeSource" "This is a debug log message" +-logDebugS :: Q Exp +-logDebugS = [|\a b -> monadLoggerLog $(qLocation >>= liftLoc) a LevelDebug (b :: Text)|] +- +--- | See 'logDebugS' +-logInfoS :: Q Exp +-logInfoS = [|\a b -> monadLoggerLog $(qLocation >>= liftLoc) a LevelInfo (b :: Text)|] +--- | See 'logDebugS' +-logWarnS :: Q Exp +-logWarnS = [|\a b -> monadLoggerLog $(qLocation >>= liftLoc) a LevelWarn (b :: Text)|] +--- | See 'logDebugS' +-logErrorS :: Q Exp +-logErrorS = [|\a b -> monadLoggerLog $(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: +--- +--- > $logOtherS "SomeSource" "My new level" "This is a log message" +-logOtherS :: Q Exp +-logOtherS = [|\src level msg -> monadLoggerLog $(qLocation >>= liftLoc) src (LevelOther level) (msg :: Text)|] +- + -- | Monad transformer that disables logging. + -- + -- Since 0.2.4 +-- +1.8.5.1 + diff --git a/standalone/android/haskell-patches/persistent-template_stub-out.patch b/standalone/no-th/haskell-patches/persistent-template_stub-out.patch index 6b7b62bd4..6b7b62bd4 100644 --- a/standalone/android/haskell-patches/persistent-template_stub-out.patch +++ b/standalone/no-th/haskell-patches/persistent-template_stub-out.patch diff --git a/standalone/android/haskell-patches/persistent_1.1.5.1_0001-disable-TH.patch b/standalone/no-th/haskell-patches/persistent_1.1.5.1_0001-disable-TH.patch index 300975b83..7a66e1fd1 100644 --- a/standalone/android/haskell-patches/persistent_1.1.5.1_0001-disable-TH.patch +++ b/standalone/no-th/haskell-patches/persistent_1.1.5.1_0001-disable-TH.patch @@ -1,16 +1,25 @@ -From 760fa2c5044ae38bee8114ff84c625ac59f35c6f Mon Sep 17 00:00:00 2001 -From: foo <foo@bar> -Date: Sun, 22 Sep 2013 00:03:55 +0000 +From efd18199fa245e51e6137036062ded8b0b26f78c Mon Sep 17 00:00:00 2001 +From: dummy <dummy@example.com> +Date: Tue, 17 Dec 2013 18:08:22 +0000 Subject: [PATCH] disable TH --- - Database/Persist/Sql/Raw.hs | 2 -- - 1 file changed, 2 deletions(-) + Database/Persist/Sql/Raw.hs | 4 +--- + 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/Database/Persist/Sql/Raw.hs b/Database/Persist/Sql/Raw.hs -index 73189dd..6efebea 100644 +index 73189dd..d432790 100644 --- a/Database/Persist/Sql/Raw.hs +++ b/Database/Persist/Sql/Raw.hs +@@ -11,7 +11,7 @@ import Data.IORef (writeIORef, readIORef, newIORef) + import Control.Exception (throwIO) + import Control.Monad (when, liftM) + import Data.Text (Text, pack) +-import Control.Monad.Logger (logDebugS) ++--import Control.Monad.Logger (logDebugS) + import Data.Int (Int64) + import Control.Monad.Trans.Class (lift) + import qualified Data.Text as T @@ -22,7 +22,6 @@ rawQuery :: (MonadSqlPersist m, MonadResource m) -> [PersistValue] -> Source m [PersistValue] @@ -28,5 +37,5 @@ index 73189dd..6efebea 100644 res <- liftIO $ stmtExecute stmt vals liftIO $ stmtReset stmt -- -1.7.10.4 +1.8.5.1 diff --git a/standalone/no-th/haskell-patches/process-conduit_avoid-TH.patch b/standalone/no-th/haskell-patches/process-conduit_avoid-TH.patch new file mode 100644 index 000000000..9298c6833 --- /dev/null +++ b/standalone/no-th/haskell-patches/process-conduit_avoid-TH.patch @@ -0,0 +1,24 @@ +From c9f40fae5f7f44c7c28b243bf924606ef4f26700 Mon Sep 17 00:00:00 2001 +From: Joey Hess <joey@kitenet.net> +Date: Wed, 18 Dec 2013 04:17:59 +0000 +Subject: [PATCH] avoid TH + +--- + process-conduit.cabal | 1 - + 1 file changed, 1 deletion(-) + +diff --git a/process-conduit.cabal b/process-conduit.cabal +index c917d90..4410e2c 100644 +--- a/process-conduit.cabal ++++ b/process-conduit.cabal +@@ -24,7 +24,6 @@ source-repository head +
+ library
+ exposed-modules: Data.Conduit.Process
+- System.Process.QQ
+
+ build-depends: base == 4.*
+ , template-haskell >= 2.4
+-- +1.8.5.1 + diff --git a/standalone/android/haskell-patches/profunctors_3.3-0001-fix-cross-build.patch b/standalone/no-th/haskell-patches/profunctors_3.3-0001-fix-cross-build.patch index 45397f3e5..45397f3e5 100644 --- a/standalone/android/haskell-patches/profunctors_3.3-0001-fix-cross-build.patch +++ b/standalone/no-th/haskell-patches/profunctors_3.3-0001-fix-cross-build.patch diff --git a/standalone/no-th/haskell-patches/reflection_remove-TH.patch b/standalone/no-th/haskell-patches/reflection_remove-TH.patch new file mode 100644 index 000000000..7c63f05fc --- /dev/null +++ b/standalone/no-th/haskell-patches/reflection_remove-TH.patch @@ -0,0 +1,113 @@ +From 22c68b43dce437b3c22956f5a968f1b886e60e0c Mon Sep 17 00:00:00 2001 +From: Joey Hess <joey@kitenet.net> +Date: Tue, 17 Dec 2013 19:15:16 +0000 +Subject: [PATCH] remove TH + +--- + fast/Data/Reflection.hs | 80 +------------------------------------------------ + 1 file changed, 1 insertion(+), 79 deletions(-) + +diff --git a/fast/Data/Reflection.hs b/fast/Data/Reflection.hs +index 119d773..cf99efa 100644 +--- a/fast/Data/Reflection.hs ++++ b/fast/Data/Reflection.hs +@@ -58,7 +58,7 @@ module Data.Reflection + , Given(..) + , give + -- * Template Haskell reflection +- , int, nat ++ --, int, nat + -- * Useful compile time naturals + , Z, D, SD, PD + ) where +@@ -151,87 +151,9 @@ instance Reifies n Int => Reifies (PD n) Int where + reflect = (\n -> n + n - 1) <$> retagPD reflect + {-# INLINE reflect #-} + +--- | This can be used to generate a template haskell splice for a type level version of a given 'int'. +--- +--- This does not use GHC TypeLits, instead it generates a numeric type by hand similar to the ones used +--- in the \"Functional Pearl: Implicit Configurations\" paper by Oleg Kiselyov and Chung-Chieh Shan. +-int :: Int -> TypeQ +-int n = case quotRem n 2 of +- (0, 0) -> conT ''Z +- (q,-1) -> conT ''PD `appT` int q +- (q, 0) -> conT ''D `appT` int q +- (q, 1) -> conT ''SD `appT` int q +- _ -> error "ghc is bad at math" +- +--- | This is a restricted version of 'int' that can only generate natural numbers. Attempting to generate +--- a negative number results in a compile time error. Also the resulting sequence will consist entirely of +--- Z, D, and SD constructors representing the number in zeroless binary. +-nat :: Int -> TypeQ +-nat n +- | n >= 0 = int n +- | otherwise = error "nat: negative" +- +-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL < 704 +-instance Show (Q a) +-instance Eq (Q a) +-#endif +-instance Num a => Num (Q a) where +- (+) = liftM2 (+) +- (*) = liftM2 (*) +- (-) = liftM2 (-) +- negate = fmap negate +- abs = fmap abs +- signum = fmap signum +- fromInteger = return . fromInteger +- +-instance Fractional a => Fractional (Q a) where +- (/) = liftM2 (/) +- recip = fmap recip +- fromRational = return . fromRational +- +--- | This permits the use of $(5) as a type splice. +-instance Num Type where +-#ifdef USE_TYPE_LITS +- a + b = AppT (AppT (VarT ''(+)) a) b +- a * b = AppT (AppT (VarT ''(*)) a) b +-#if MIN_VERSION_base(4,8,0) +- a - b = AppT (AppT (VarT ''(-)) a) b +-#else +- (-) = error "Type.(-): undefined" +-#endif +- fromInteger = LitT . NumTyLit +-#else +- (+) = error "Type.(+): undefined" +- (*) = error "Type.(*): undefined" +- (-) = error "Type.(-): undefined" +- fromInteger n = case quotRem n 2 of +- (0, 0) -> ConT ''Z +- (q,-1) -> ConT ''PD `AppT` fromInteger q +- (q, 0) -> ConT ''D `AppT` fromInteger q +- (q, 1) -> ConT ''SD `AppT` fromInteger q +- _ -> error "ghc is bad at math" +-#endif +- abs = error "Type.abs" +- signum = error "Type.signum" +- + plus, times, minus :: Num a => a -> a -> a + plus = (+) + times = (*) + minus = (-) + fract :: Fractional a => a -> a -> a + fract = (/) +- +--- | This permits the use of $(5) as an expression splice. +-instance Num Exp where +- a + b = AppE (AppE (VarE 'plus) a) b +- a * b = AppE (AppE (VarE 'times) a) b +- a - b = AppE (AppE (VarE 'minus) a) b +- negate = AppE (VarE 'negate) +- signum = AppE (VarE 'signum) +- abs = AppE (VarE 'abs) +- fromInteger = LitE . IntegerL +- +-instance Fractional Exp where +- a / b = AppE (AppE (VarE 'fract) a) b +- recip = AppE (VarE 'recip) +- fromRational = LitE . RationalL +-- +1.8.5.1 + diff --git a/standalone/android/haskell-patches/shakespeare-css_1.0.2_0002-expose-modules-used-by-TH.patch b/standalone/no-th/haskell-patches/shakespeare-css_1.0.2_0002-expose-modules-used-by-TH.patch index 5bf57d527..5bf57d527 100644 --- a/standalone/android/haskell-patches/shakespeare-css_1.0.2_0002-expose-modules-used-by-TH.patch +++ b/standalone/no-th/haskell-patches/shakespeare-css_1.0.2_0002-expose-modules-used-by-TH.patch diff --git a/standalone/no-th/haskell-patches/shakespeare-css_1.0.2_0003-remove-more-TH.patch b/standalone/no-th/haskell-patches/shakespeare-css_1.0.2_0003-remove-more-TH.patch new file mode 100644 index 000000000..c57eb01c6 --- /dev/null +++ b/standalone/no-th/haskell-patches/shakespeare-css_1.0.2_0003-remove-more-TH.patch @@ -0,0 +1,351 @@ +From 8c9e29d3716bcbbfc3144cf1f8af0569212a5878 Mon Sep 17 00:00:00 2001 +From: dummy <dummy@example.com> +Date: Tue, 17 Dec 2013 06:33:03 +0000 +Subject: [PATCH] remove more TH + +--- + Text/Cassius.hs | 23 --------- + Text/Css.hs | 151 ------------------------------------------------------ + Text/CssCommon.hs | 4 -- + Text/Lucius.hs | 46 +---------------- + 4 files changed, 2 insertions(+), 222 deletions(-) + +diff --git a/Text/Cassius.hs b/Text/Cassius.hs +index ce05374..ae56b0a 100644 +--- a/Text/Cassius.hs ++++ b/Text/Cassius.hs +@@ -13,10 +13,6 @@ module Text.Cassius + , renderCss + , renderCssUrl + -- * Parsing +- , cassius +- , cassiusFile +- , cassiusFileDebug +- , cassiusFileReload + -- * ToCss instances + -- ** Color + , Color (..) +@@ -27,11 +23,8 @@ module Text.Cassius + , AbsoluteUnit (..) + , AbsoluteSize (..) + , absoluteSize +- , EmSize (..) +- , ExSize (..) + , PercentageSize (..) + , percentageSize +- , PixelSize (..) + -- * Internal + , cassiusUsedIdentifiers + ) where +@@ -42,25 +35,9 @@ import Language.Haskell.TH.Quote (QuasiQuoter (..)) + import Language.Haskell.TH.Syntax + import qualified Data.Text.Lazy as TL + import Text.CssCommon +-import Text.Lucius (lucius) + import qualified Text.Lucius + import Text.IndentToBrace (i2b) + +-cassius :: QuasiQuoter +-cassius = QuasiQuoter { quoteExp = quoteExp lucius . i2b } +- +-cassiusFile :: FilePath -> Q Exp +-cassiusFile fp = do +-#ifdef GHC_7_4 +- qAddDependentFile fp +-#endif +- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp +- quoteExp cassius contents +- +-cassiusFileDebug, cassiusFileReload :: FilePath -> Q Exp +-cassiusFileDebug = cssFileDebug True [|Text.Lucius.parseTopLevels|] Text.Lucius.parseTopLevels +-cassiusFileReload = cassiusFileDebug +- + -- | Determine which identifiers are used by the given template, useful for + -- creating systems like yesod devel. + cassiusUsedIdentifiers :: String -> [(Deref, VarType)] +diff --git a/Text/Css.hs b/Text/Css.hs +index fb06dd2..954e574 100644 +--- a/Text/Css.hs ++++ b/Text/Css.hs +@@ -169,22 +169,6 @@ cssUsedIdentifiers toi2b parseBlocks s' = + (scope, rest') = go rest + go' (Attr k v) = k ++ v + +-cssFileDebug :: Bool -- ^ perform the indent-to-brace conversion +- -> Q Exp +- -> Parser [TopLevel Unresolved] +- -> FilePath +- -> Q Exp +-cssFileDebug toi2b parseBlocks' parseBlocks fp = do +- s <- fmap TL.unpack $ qRunIO $ readUtf8File fp +-#ifdef GHC_7_4 +- qAddDependentFile fp +-#endif +- let vs = cssUsedIdentifiers toi2b parseBlocks s +- c <- mapM vtToExp vs +- cr <- [|cssRuntime toi2b|] +- parseBlocks'' <- parseBlocks' +- return $ cr `AppE` parseBlocks'' `AppE` (LitE $ StringL fp) `AppE` ListE c +- + combineSelectors :: HasLeadingSpace + -> [Contents] + -> [Contents] +@@ -290,18 +274,6 @@ cssRuntime toi2b parseBlocks fp cd render' = unsafePerformIO $ do + + addScope scope = map (DerefIdent . Ident *** CDPlain . fromString) scope ++ cd + +-vtToExp :: (Deref, VarType) -> Q Exp +-vtToExp (d, vt) = do +- d' <- lift d +- c' <- c vt +- return $ TupE [d', c' `AppE` derefToExp [] d] +- where +- c :: VarType -> Q Exp +- c VTPlain = [|CDPlain . toCss|] +- c VTUrl = [|CDUrl|] +- c VTUrlParam = [|CDUrlParam|] +- c VTMixin = [|CDMixin|] +- + getVars :: Monad m => [(String, String)] -> Content -> m [(Deref, VarType)] + getVars _ ContentRaw{} = return [] + getVars scope (ContentVar d) = +@@ -345,111 +317,8 @@ compressBlock (Block x y blocks mixins) = + cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c + cc (a:b) = a : cc b + +-blockToMixin :: Name +- -> Scope +- -> Block Unresolved +- -> Q Exp +-blockToMixin r scope (Block _sel props subblocks mixins) = +- [|Mixin +- { mixinAttrs = concat +- $ $(listE $ map go props) +- : map mixinAttrs $mixinsE +- -- FIXME too many complications to implement sublocks for now... +- , mixinBlocks = [] -- foldr (.) id $(listE $ map subGo subblocks) [] +- }|] +- {- +- . foldr (.) id $(listE $ map subGo subblocks) +- . (concatMap mixinBlocks $mixinsE ++) +- |] +- -} +- where +- mixinsE = return $ ListE $ map (derefToExp []) mixins +- go (Attr x y) = conE 'Attr +- `appE` (contentsToBuilder r scope x) +- `appE` (contentsToBuilder r scope y) +- subGo (Block sel' b c d) = blockToCss r scope $ Block sel' b c d +- +-blockToCss :: Name +- -> Scope +- -> Block Unresolved +- -> Q Exp +-blockToCss r scope (Block sel props subblocks mixins) = +- [|((Block +- { blockSelector = $(selectorToBuilder r scope sel) +- , blockAttrs = concat +- $ $(listE $ map go props) +- : map mixinAttrs $mixinsE +- , blockBlocks = () +- , blockMixins = () +- } :: Block Resolved):) +- . foldr (.) id $(listE $ map subGo subblocks) +- . (concatMap mixinBlocks $mixinsE ++) +- |] +- where +- mixinsE = return $ ListE $ map (derefToExp []) mixins +- go (Attr x y) = conE 'Attr +- `appE` (contentsToBuilder r scope x) +- `appE` (contentsToBuilder r scope y) +- subGo (hls, Block sel' b c d) = +- blockToCss r scope $ Block sel'' b c d +- where +- sel'' = combineSelectors hls sel sel' +- +-selectorToBuilder :: Name -> Scope -> [Contents] -> Q Exp +-selectorToBuilder r scope sels = +- contentsToBuilder r scope $ intercalate [ContentRaw ","] sels +- +-contentsToBuilder :: Name -> Scope -> [Content] -> Q Exp +-contentsToBuilder r scope contents = +- appE [|mconcat|] $ listE $ map (contentToBuilder r scope) contents +- +-contentToBuilder :: Name -> Scope -> Content -> Q Exp +-contentToBuilder _ _ (ContentRaw x) = +- [|fromText . pack|] `appE` litE (StringL x) +-contentToBuilder _ scope (ContentVar d) = +- case d of +- DerefIdent (Ident s) +- | Just val <- lookup s scope -> [|fromText . pack|] `appE` litE (StringL val) +- _ -> [|toCss|] `appE` return (derefToExp [] d) +-contentToBuilder r _ (ContentUrl u) = +- [|fromText|] `appE` +- (varE r `appE` return (derefToExp [] u) `appE` listE []) +-contentToBuilder r _ (ContentUrlParam u) = +- [|fromText|] `appE` +- ([|uncurry|] `appE` varE r `appE` return (derefToExp [] u)) +-contentToBuilder _ _ ContentMixin{} = error "contentToBuilder on ContentMixin" +- + type Scope = [(String, String)] + +-topLevelsToCassius :: [TopLevel Unresolved] +- -> Q Exp +-topLevelsToCassius a = do +- r <- newName "_render" +- lamE [varP r] $ appE [|CssNoWhitespace . foldr ($) []|] $ fmap ListE $ go r [] a +- where +- go _ _ [] = return [] +- go r scope (TopBlock b:rest) = do +- e <- [|(++) $ map TopBlock ($(blockToCss r scope b) [])|] +- es <- go r scope rest +- return $ e : es +- go r scope (TopAtBlock name s b:rest) = do +- let s' = contentsToBuilder r scope s +- e <- [|(:) $ TopAtBlock $(lift name) $(s') $(blocksToCassius r scope b)|] +- es <- go r scope rest +- return $ e : es +- go r scope (TopAtDecl dec cs:rest) = do +- e <- [|(:) $ TopAtDecl $(lift dec) $(contentsToBuilder r scope cs)|] +- es <- go r scope rest +- return $ e : es +- go r scope (TopVar k v:rest) = go r ((k, v) : scope) rest +- +-blocksToCassius :: Name +- -> Scope +- -> [Block Unresolved] +- -> Q Exp +-blocksToCassius r scope a = do +- appE [|foldr ($) []|] $ listE $ map (blockToCss r scope) a +- + renderCss :: Css -> TL.Text + renderCss css = + toLazyText $ mconcat $ map go tops +@@ -518,23 +387,3 @@ renderBlock haveWhiteSpace indent (Block sel attrs () ()) + | haveWhiteSpace = fromString ";\n" + | otherwise = singleton ';' + +-instance Lift Mixin where +- lift (Mixin a b) = [|Mixin a b|] +-instance Lift (Attr Unresolved) where +- lift (Attr k v) = [|Attr k v :: Attr Unresolved |] +-instance Lift (Attr Resolved) where +- lift (Attr k v) = [|Attr $(liftBuilder k) $(liftBuilder v) :: Attr Resolved |] +- +-liftBuilder :: Builder -> Q Exp +-liftBuilder b = [|fromText $ pack $(lift $ TL.unpack $ toLazyText b)|] +- +-instance Lift Content where +- lift (ContentRaw s) = [|ContentRaw s|] +- lift (ContentVar d) = [|ContentVar d|] +- lift (ContentUrl d) = [|ContentUrl d|] +- lift (ContentUrlParam d) = [|ContentUrlParam d|] +- lift (ContentMixin m) = [|ContentMixin m|] +-instance Lift (Block Unresolved) where +- lift (Block a b c d) = [|Block a b c d|] +-instance Lift (Block Resolved) where +- lift (Block a b () ()) = [|Block $(liftBuilder a) b () ()|] +diff --git a/Text/CssCommon.hs b/Text/CssCommon.hs +index 719e0a8..8c40e8c 100644 +--- a/Text/CssCommon.hs ++++ b/Text/CssCommon.hs +@@ -1,4 +1,3 @@ +-{-# LANGUAGE TemplateHaskell #-} + {-# LANGUAGE GeneralizedNewtypeDeriving #-} + {-# LANGUAGE FlexibleInstances #-} + {-# LANGUAGE CPP #-} +@@ -156,6 +155,3 @@ showSize :: Rational -> String -> String + showSize value' unit = printf "%f" value ++ unit + where value = fromRational value' :: Double + +-mkSizeType "EmSize" "em" +-mkSizeType "ExSize" "ex" +-mkSizeType "PixelSize" "px" +diff --git a/Text/Lucius.hs b/Text/Lucius.hs +index c2c4352..8b2bb9c 100644 +--- a/Text/Lucius.hs ++++ b/Text/Lucius.hs +@@ -8,13 +8,9 @@ + {-# OPTIONS_GHC -fno-warn-missing-fields #-} + module Text.Lucius + ( -- * Parsing +- lucius +- , luciusFile +- , luciusFileDebug +- , luciusFileReload + -- ** Mixins +- , luciusMixin +- , Mixin ++ -- luciusMixin ++ Mixin + -- ** Runtime + , luciusRT + , luciusRT' +@@ -40,11 +36,8 @@ module Text.Lucius + , AbsoluteUnit (..) + , AbsoluteSize (..) + , absoluteSize +- , EmSize (..) +- , ExSize (..) + , PercentageSize (..) + , percentageSize +- , PixelSize (..) + -- * Internal + , parseTopLevels + , luciusUsedIdentifiers +@@ -66,18 +59,6 @@ import Data.Monoid (mconcat) + import Data.List (isSuffixOf) + import Control.Arrow (second) + +--- | +--- +--- >>> renderCss ([lucius|foo{bar:baz}|] undefined) +--- "foo{bar:baz}" +-lucius :: QuasiQuoter +-lucius = QuasiQuoter { quoteExp = luciusFromString } +- +-luciusFromString :: String -> Q Exp +-luciusFromString s = +- topLevelsToCassius +- $ either (error . show) id $ parse parseTopLevels s s +- + whiteSpace :: Parser () + whiteSpace = many whiteSpace1 >> return () + +@@ -217,17 +198,6 @@ parseComment = do + _ <- manyTill anyChar $ try $ string "*/" + return $ ContentRaw "" + +-luciusFile :: FilePath -> Q Exp +-luciusFile fp = do +-#ifdef GHC_7_4 +- qAddDependentFile fp +-#endif +- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp +- luciusFromString contents +- +-luciusFileDebug, luciusFileReload :: FilePath -> Q Exp +-luciusFileDebug = cssFileDebug False [|parseTopLevels|] parseTopLevels +-luciusFileReload = luciusFileDebug + + parseTopLevels :: Parser [TopLevel Unresolved] + parseTopLevels = +@@ -376,15 +346,3 @@ luciusRTMinified tl scope = either Left (Right . renderCss . CssNoWhitespace) $ + -- creating systems like yesod devel. + luciusUsedIdentifiers :: String -> [(Deref, VarType)] + luciusUsedIdentifiers = cssUsedIdentifiers False parseTopLevels +- +-luciusMixin :: QuasiQuoter +-luciusMixin = QuasiQuoter { quoteExp = luciusMixinFromString } +- +-luciusMixinFromString :: String -> Q Exp +-luciusMixinFromString s' = do +- r <- newName "_render" +- case fmap compressBlock $ parse parseBlock s s of +- Left e -> error $ show e +- Right block -> blockToMixin r [] block +- where +- s = concat ["mixin{", s', "}"] +-- +1.8.5.1 + diff --git a/standalone/no-th/haskell-patches/shakespeare-i18n_0001-remove-TH.patch b/standalone/no-th/haskell-patches/shakespeare-i18n_0001-remove-TH.patch new file mode 100644 index 000000000..3c6924039 --- /dev/null +++ b/standalone/no-th/haskell-patches/shakespeare-i18n_0001-remove-TH.patch @@ -0,0 +1,215 @@ +From 57ad7d1512a3144fd0b00f9796d5fd9e0ea86852 Mon Sep 17 00:00:00 2001 +From: Joey Hess <joey@kitenet.net> +Date: Tue, 17 Dec 2013 16:30:59 +0000 +Subject: [PATCH] remove TH + +--- + Text/Shakespeare/I18N.hs | 178 ++--------------------------------------------- + 1 file changed, 4 insertions(+), 174 deletions(-) + +diff --git a/Text/Shakespeare/I18N.hs b/Text/Shakespeare/I18N.hs +index 2077914..2289214 100644 +--- a/Text/Shakespeare/I18N.hs ++++ b/Text/Shakespeare/I18N.hs +@@ -51,10 +51,10 @@ + -- + -- You can also adapt those instructions for use with other systems. + module Text.Shakespeare.I18N +- ( mkMessage +- , mkMessageFor +- , mkMessageVariant +- , RenderMessage (..) ++ --( mkMessage ++ --, mkMessageFor ++ ---, mkMessageVariant ++ ( RenderMessage (..) + , ToMessage (..) + , SomeMessage (..) + , Lang +@@ -105,143 +105,6 @@ instance RenderMessage master Text where + -- | an RFC1766 / ISO 639-1 language code (eg, @fr@, @en-GB@, etc). + type Lang = Text + +--- |generate translations from translation files +--- +--- This function will: +--- +--- 1. look in the supplied subdirectory for files ending in @.msg@ +--- +--- 2. generate a type based on the constructors found +--- +--- 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 +@@ -257,39 +120,6 @@ varName a y = + upper (x:xs) = toUpper x : xs + upper [] = [] + +-checkDef :: [SDef] -> [Def] -> Q () +-checkDef x y = +- go (sortBy (comparing sconstr) x) (sortBy (comparing constr) y) +- where +- go _ [] = return () +- go [] (b:_) = error $ "Extra message constructor: " ++ constr b +- go (a:as) (b:bs) +- | sconstr a < constr b = go as (b:bs) +- | sconstr a > constr b = error $ "Extra message constructor: " ++ constr b +- | otherwise = do +- go' (svars a) (vars b) +- go as bs +- go' ((an, at):as) ((bn, mbt):bs) +- | an /= bn = error "Mismatched variable names" +- | otherwise = +- case mbt of +- Nothing -> go' as bs +- Just bt +- | at == bt -> go' as bs +- | otherwise -> error "Mismatched variable types" +- go' [] [] = return () +- go' _ _ = error "Mistmached variable count" +- +-toSDefs :: [Def] -> Q [SDef] +-toSDefs = mapM toSDef +- +-toSDef :: Def -> Q SDef +-toSDef d = do +- vars' <- mapM go $ vars d +- return $ SDef (constr d) vars' (content d) +- where +- go (a, Just b) = return (a, b) +- go (a, Nothing) = error $ "Main language missing type for " ++ show (constr d, a) + + data SDef = SDef + { sconstr :: String +-- +1.8.5.1 + diff --git a/standalone/no-th/haskell-patches/shakespeare-js_0001-remove-TH.patch b/standalone/no-th/haskell-patches/shakespeare-js_0001-remove-TH.patch new file mode 100644 index 000000000..52b4b3b7c --- /dev/null +++ b/standalone/no-th/haskell-patches/shakespeare-js_0001-remove-TH.patch @@ -0,0 +1,316 @@ +From be50798c9abc22648a0a3eb81db462abea79698c Mon Sep 17 00:00:00 2001 +From: Joey Hess <joey@kitenet.net> +Date: Tue, 17 Dec 2013 16:47:03 +0000 +Subject: [PATCH] remove TH + +--- + Text/Coffee.hs | 56 ++++----------------------------------------- + Text/Julius.hs | 67 +++++++++--------------------------------------------- + Text/Roy.hs | 51 ++++------------------------------------- + Text/TypeScript.hs | 51 ++++------------------------------------- + 4 files changed, 24 insertions(+), 201 deletions(-) + +diff --git a/Text/Coffee.hs b/Text/Coffee.hs +index 488c81b..61db85b 100644 +--- a/Text/Coffee.hs ++++ b/Text/Coffee.hs +@@ -51,13 +51,13 @@ module Text.Coffee + -- ** Template-Reading Functions + -- | These QuasiQuoter and Template Haskell methods return values of + -- type @'JavascriptUrl' url@. See the Yesod book for details. +- coffee +- , coffeeFile +- , coffeeFileReload +- , coffeeFileDebug ++ -- coffee ++ --, coffeeFile ++ --, coffeeFileReload ++ --, coffeeFileDebug + + #ifdef TEST_EXPORT +- , coffeeSettings ++ --, coffeeSettings + #endif + ) where + +@@ -65,49 +65,3 @@ import Language.Haskell.TH.Quote (QuasiQuoter (..)) + import Language.Haskell.TH.Syntax + import Text.Shakespeare + import Text.Julius +- +-coffeeSettings :: Q ShakespeareSettings +-coffeeSettings = do +- jsettings <- javascriptSettings +- return $ jsettings { varChar = '%' +- , preConversion = Just PreConvert { +- preConvert = ReadProcess "coffee" ["-spb"] +- , preEscapeIgnoreBalanced = "'\"`" -- don't insert backtacks for variable already inside strings or backticks. +- , preEscapeIgnoreLine = "#" -- ignore commented lines +- , wrapInsertion = Just WrapInsertion { +- wrapInsertionIndent = Just " " +- , wrapInsertionStartBegin = "(" +- , wrapInsertionSeparator = ", " +- , wrapInsertionStartClose = ") =>" +- , wrapInsertionEnd = "" +- , wrapInsertionAddParens = False +- } +- } +- } +- +--- | Read inline, quasiquoted CoffeeScript. +-coffee :: QuasiQuoter +-coffee = QuasiQuoter { quoteExp = \s -> do +- rs <- coffeeSettings +- quoteExp (shakespeare rs) s +- } +- +--- | Read in a CoffeeScript template file. This function reads the file once, at +--- compile time. +-coffeeFile :: FilePath -> Q Exp +-coffeeFile fp = do +- rs <- coffeeSettings +- shakespeareFile rs fp +- +--- | Read in a CoffeeScript template file. This impure function uses +--- unsafePerformIO to re-read the file on every call, allowing for rapid +--- iteration. +-coffeeFileReload :: FilePath -> Q Exp +-coffeeFileReload fp = do +- rs <- coffeeSettings +- shakespeareFileReload rs fp +- +--- | Deprecated synonym for 'coffeeFileReload' +-coffeeFileDebug :: FilePath -> Q Exp +-coffeeFileDebug = coffeeFileReload +-{-# DEPRECATED coffeeFileDebug "Please use coffeeFileReload instead." #-} +diff --git a/Text/Julius.hs b/Text/Julius.hs +index ec30690..5b5a075 100644 +--- a/Text/Julius.hs ++++ b/Text/Julius.hs +@@ -14,17 +14,17 @@ module Text.Julius + -- ** Template-Reading Functions + -- | These QuasiQuoter and Template Haskell methods return values of + -- type @'JavascriptUrl' url@. See the Yesod book for details. +- js +- , julius +- , juliusFile +- , jsFile +- , juliusFileDebug +- , jsFileDebug +- , juliusFileReload +- , jsFileReload ++ -- js ++ -- julius ++ -- juliusFile ++ -- jsFile ++ --, juliusFileDebug ++ --, jsFileDebug ++ --, juliusFileReload ++ --, jsFileReload + + -- * Datatypes +- , JavascriptUrl ++ JavascriptUrl + , Javascript (..) + , RawJavascript (..) + +@@ -37,9 +37,9 @@ module Text.Julius + , renderJavascriptUrl + + -- ** internal, used by 'Text.Coffee' +- , javascriptSettings ++ --, javascriptSettings + -- ** internal +- , juliusUsedIdentifiers ++ --, juliusUsedIdentifiers + , asJavascriptUrl + ) where + +@@ -102,48 +102,3 @@ instance RawJS TL.Text where rawJS = RawJavascript . fromLazyText + instance RawJS Builder where rawJS = RawJavascript + instance RawJS Bool where rawJS = RawJavascript . unJavascript . toJavascript + +-javascriptSettings :: Q ShakespeareSettings +-javascriptSettings = do +- toJExp <- [|toJavascript|] +- wrapExp <- [|Javascript|] +- unWrapExp <- [|unJavascript|] +- asJavascriptUrl' <- [|asJavascriptUrl|] +- return $ defaultShakespeareSettings { toBuilder = toJExp +- , wrap = wrapExp +- , unwrap = unWrapExp +- , modifyFinalValue = Just asJavascriptUrl' +- } +- +-js, julius :: QuasiQuoter +-js = QuasiQuoter { quoteExp = \s -> do +- rs <- javascriptSettings +- quoteExp (shakespeare rs) s +- } +- +-julius = js +- +-jsFile, juliusFile :: FilePath -> Q Exp +-jsFile fp = do +- rs <- javascriptSettings +- shakespeareFile rs fp +- +-juliusFile = jsFile +- +- +-jsFileReload, juliusFileReload :: FilePath -> Q Exp +-jsFileReload fp = do +- rs <- javascriptSettings +- shakespeareFileReload rs fp +- +-juliusFileReload = jsFileReload +- +-jsFileDebug, juliusFileDebug :: FilePath -> Q Exp +-juliusFileDebug = jsFileReload +-{-# DEPRECATED juliusFileDebug "Please use juliusFileReload instead." #-} +-jsFileDebug = jsFileReload +-{-# DEPRECATED jsFileDebug "Please use jsFileReload instead." #-} +- +--- | Determine which identifiers are used by the given template, useful for +--- creating systems like yesod devel. +-juliusUsedIdentifiers :: String -> [(Deref, VarType)] +-juliusUsedIdentifiers = shakespeareUsedIdentifiers defaultShakespeareSettings +diff --git a/Text/Roy.hs b/Text/Roy.hs +index 8bffc5a..8bf2a09 100644 +--- a/Text/Roy.hs ++++ b/Text/Roy.hs +@@ -39,12 +39,12 @@ module Text.Roy + -- ** Template-Reading Functions + -- | These QuasiQuoter and Template Haskell methods return values of + -- type @'JavascriptUrl' url@. See the Yesod book for details. +- roy +- , royFile +- , royFileReload ++ -- roy ++ --, royFile ++ --, royFileReload + + #ifdef TEST_EXPORT +- , roySettings ++ --, roySettings + #endif + ) where + +@@ -53,46 +53,3 @@ import Language.Haskell.TH.Syntax + import Text.Shakespeare + import Text.Julius + +--- | The Roy language compiles down to Javascript. +--- We do this compilation once at compile time to avoid needing to do it during the request. +--- We call this a preConversion because other shakespeare modules like Lucius use Haskell to compile during the request instead rather than a system call. +-roySettings :: Q ShakespeareSettings +-roySettings = do +- jsettings <- javascriptSettings +- return $ jsettings { varChar = '#' +- , preConversion = Just PreConvert { +- preConvert = ReadProcess "roy" ["--stdio", "--browser"] +- , preEscapeIgnoreBalanced = "'\"" +- , preEscapeIgnoreLine = "//" +- , wrapInsertion = Just WrapInsertion { +- wrapInsertionIndent = Just " " +- , wrapInsertionStartBegin = "(\\" +- , wrapInsertionSeparator = " " +- , wrapInsertionStartClose = " ->\n" +- , wrapInsertionEnd = ")" +- , wrapInsertionAddParens = True +- } +- } +- } +- +--- | Read inline, quasiquoted Roy. +-roy :: QuasiQuoter +-roy = QuasiQuoter { quoteExp = \s -> do +- rs <- roySettings +- quoteExp (shakespeare rs) s +- } +- +--- | Read in a Roy template file. This function reads the file once, at +--- compile time. +-royFile :: FilePath -> Q Exp +-royFile fp = do +- rs <- roySettings +- shakespeareFile rs fp +- +--- | Read in a Roy template file. This impure function uses +--- unsafePerformIO to re-read the file on every call, allowing for rapid +--- iteration. +-royFileReload :: FilePath -> Q Exp +-royFileReload fp = do +- rs <- roySettings +- shakespeareFileReload rs fp +diff --git a/Text/TypeScript.hs b/Text/TypeScript.hs +index 70c8820..5be994a 100644 +--- a/Text/TypeScript.hs ++++ b/Text/TypeScript.hs +@@ -57,12 +57,12 @@ module Text.TypeScript + -- ** Template-Reading Functions + -- | These QuasiQuoter and Template Haskell methods return values of + -- type @'JavascriptUrl' url@. See the Yesod book for details. +- tsc +- , typeScriptFile +- , typeScriptFileReload ++ -- tsc ++ --, typeScriptFile ++ --, typeScriptFileReload + + #ifdef TEST_EXPORT +- , typeScriptSettings ++ --, typeScriptSettings + #endif + ) where + +@@ -71,46 +71,3 @@ import Language.Haskell.TH.Syntax + import Text.Shakespeare + import Text.Julius + +--- | The TypeScript language compiles down to Javascript. +--- We do this compilation once at compile time to avoid needing to do it during the request. +--- We call this a preConversion because other shakespeare modules like Lucius use Haskell to compile during the request instead rather than a system call. +-typeScriptSettings :: Q ShakespeareSettings +-typeScriptSettings = do +- jsettings <- javascriptSettings +- return $ jsettings { varChar = '#' +- , preConversion = Just PreConvert { +- preConvert = ReadProcess "sh" ["-c", "TMP_IN=$(mktemp XXXXXXXXXX.ts); TMP_OUT=$(mktemp XXXXXXXXXX.js); cat /dev/stdin > ${TMP_IN} && tsc --out ${TMP_OUT} ${TMP_IN} && cat ${TMP_OUT}; rm ${TMP_IN} && rm ${TMP_OUT}"] +- , preEscapeIgnoreBalanced = "'\"" +- , preEscapeIgnoreLine = "//" +- , wrapInsertion = Just WrapInsertion { +- wrapInsertionIndent = Nothing +- , wrapInsertionStartBegin = ";(function(" +- , wrapInsertionSeparator = ", " +- , wrapInsertionStartClose = "){" +- , wrapInsertionEnd = "})" +- , wrapInsertionAddParens = False +- } +- } +- } +- +--- | Read inline, quasiquoted TypeScript +-tsc :: QuasiQuoter +-tsc = QuasiQuoter { quoteExp = \s -> do +- rs <- typeScriptSettings +- quoteExp (shakespeare rs) s +- } +- +--- | Read in a TypeScript template file. This function reads the file once, at +--- compile time. +-typeScriptFile :: FilePath -> Q Exp +-typeScriptFile fp = do +- rs <- typeScriptSettings +- shakespeareFile rs fp +- +--- | Read in a Roy template file. This impure function uses +--- unsafePerformIO to re-read the file on every call, allowing for rapid +--- iteration. +-typeScriptFileReload :: FilePath -> Q Exp +-typeScriptFileReload fp = do +- rs <- typeScriptSettings +- shakespeareFileReload rs fp +-- +1.8.5.1 + diff --git a/standalone/no-th/haskell-patches/shakespeare-text_remove-TH.patch b/standalone/no-th/haskell-patches/shakespeare-text_remove-TH.patch new file mode 100644 index 000000000..4af0995bd --- /dev/null +++ b/standalone/no-th/haskell-patches/shakespeare-text_remove-TH.patch @@ -0,0 +1,153 @@ +From f94ab5c4fe8f01cb9353a9d246e8f7c48475d834 Mon Sep 17 00:00:00 2001 +From: Joey Hess <joey@kitenet.net> +Date: Wed, 18 Dec 2013 04:10:23 +0000 +Subject: [PATCH] remove TH + +--- + Text/Shakespeare/Text.hs | 125 +++++------------------------------------------ + 1 file changed, 11 insertions(+), 114 deletions(-) + +diff --git a/Text/Shakespeare/Text.hs b/Text/Shakespeare/Text.hs +index 738164b..65818ee 100644 +--- a/Text/Shakespeare/Text.hs ++++ b/Text/Shakespeare/Text.hs +@@ -7,18 +7,18 @@ module Text.Shakespeare.Text + ( TextUrl + , ToText (..) + , renderTextUrl +- , stext +- , text +- , textFile +- , textFileDebug +- , textFileReload +- , st -- | strict text +- , lt -- | lazy text, same as stext :) ++ --, stext ++ --, text ++ --, textFile ++ --, textFileDebug ++ --, textFileReload ++ --, st -- | strict text ++ --, lt -- | lazy text, same as stext :) + -- * Yesod code generation +- , codegen +- , codegenSt +- , codegenFile +- , codegenFileReload ++ --, codegen ++ --, codegenSt ++ --, codegenFile ++ --, codegenFileReload + ) where + + import Language.Haskell.TH.Quote (QuasiQuoter (..)) +@@ -43,106 +43,3 @@ instance ToText TL.Text where toText = fromLazyText + instance ToText Int32 where toText = toText . show + instance ToText Int64 where toText = toText . show + +-settings :: Q ShakespeareSettings +-settings = do +- toTExp <- [|toText|] +- wrapExp <- [|id|] +- unWrapExp <- [|id|] +- return $ defaultShakespeareSettings { toBuilder = toTExp +- , wrap = wrapExp +- , unwrap = unWrapExp +- } +- +- +-stext, lt, st, text :: QuasiQuoter +-stext = +- QuasiQuoter { quoteExp = \s -> do +- rs <- settings +- render <- [|toLazyText|] +- rendered <- shakespeareFromString rs { justVarInterpolation = True } s +- return (render `AppE` rendered) +- } +-lt = stext +- +-st = +- QuasiQuoter { quoteExp = \s -> do +- rs <- settings +- render <- [|TL.toStrict . toLazyText|] +- rendered <- shakespeareFromString rs { justVarInterpolation = True } s +- return (render `AppE` rendered) +- } +- +-text = QuasiQuoter { quoteExp = \s -> do +- rs <- settings +- quoteExp (shakespeare rs) $ filter (/='\r') s +- } +- +- +-textFile :: FilePath -> Q Exp +-textFile fp = do +- rs <- settings +- shakespeareFile rs fp +- +- +-textFileDebug :: FilePath -> Q Exp +-textFileDebug = textFileReload +-{-# DEPRECATED textFileDebug "Please use textFileReload instead" #-} +- +-textFileReload :: FilePath -> Q Exp +-textFileReload fp = do +- rs <- settings +- shakespeareFileReload rs fp +- +--- | codegen is designed for generating Yesod code, including templates +--- So it uses different interpolation characters that won't clash with templates. +-codegenSettings :: Q ShakespeareSettings +-codegenSettings = do +- toTExp <- [|toText|] +- wrapExp <- [|id|] +- unWrapExp <- [|id|] +- return $ defaultShakespeareSettings { toBuilder = toTExp +- , wrap = wrapExp +- , unwrap = unWrapExp +- , varChar = '~' +- , urlChar = '*' +- , intChar = '&' +- , justVarInterpolation = True -- always! +- } +- +--- | codegen is designed for generating Yesod code, including templates +--- So it uses different interpolation characters that won't clash with templates. +--- You can use the normal text quasiquoters to generate code +-codegen :: QuasiQuoter +-codegen = +- QuasiQuoter { quoteExp = \s -> do +- rs <- codegenSettings +- render <- [|toLazyText|] +- rendered <- shakespeareFromString rs { justVarInterpolation = True } s +- return (render `AppE` rendered) +- } +- +--- | Generates strict Text +--- codegen is designed for generating Yesod code, including templates +--- So it uses different interpolation characters that won't clash with templates. +-codegenSt :: QuasiQuoter +-codegenSt = +- QuasiQuoter { quoteExp = \s -> do +- rs <- codegenSettings +- render <- [|TL.toStrict . toLazyText|] +- rendered <- shakespeareFromString rs { justVarInterpolation = True } s +- return (render `AppE` rendered) +- } +- +-codegenFileReload :: FilePath -> Q Exp +-codegenFileReload fp = do +- rs <- codegenSettings +- render <- [|TL.toStrict . toLazyText|] +- rendered <- shakespeareFileReload rs{ justVarInterpolation = True } fp +- return (render `AppE` rendered) +- +-codegenFile :: FilePath -> Q Exp +-codegenFile fp = do +- rs <- codegenSettings +- render <- [|TL.toStrict . toLazyText|] +- rendered <- shakespeareFile rs{ justVarInterpolation = True } fp +- return (render `AppE` rendered) +-- +1.8.5.1 + diff --git a/standalone/android/haskell-patches/shakespeare_1.0.3_0001-export-symbol-used-by-TH-splices.patch b/standalone/no-th/haskell-patches/shakespeare_1.0.3_0001-export-symbol-used-by-TH-splices.patch index 51443b5d4..51443b5d4 100644 --- a/standalone/android/haskell-patches/shakespeare_1.0.3_0001-export-symbol-used-by-TH-splices.patch +++ b/standalone/no-th/haskell-patches/shakespeare_1.0.3_0001-export-symbol-used-by-TH-splices.patch diff --git a/standalone/no-th/haskell-patches/shakespeare_1.0.3_0002-remove-TH.patch b/standalone/no-th/haskell-patches/shakespeare_1.0.3_0002-remove-TH.patch new file mode 100644 index 000000000..38c2cb012 --- /dev/null +++ b/standalone/no-th/haskell-patches/shakespeare_1.0.3_0002-remove-TH.patch @@ -0,0 +1,223 @@ +From b66f160fea86d8839572620892181eb4ada2ad29 Mon Sep 17 00:00:00 2001 +From: Joey Hess <joey@kitenet.net> +Date: Tue, 17 Dec 2013 06:17:26 +0000 +Subject: [PATCH 2/2] remove TH + +--- + Text/Shakespeare.hs | 131 +++-------------------------------------------- + Text/Shakespeare/Base.hs | 28 ---------- + 2 files changed, 6 insertions(+), 153 deletions(-) + +diff --git a/Text/Shakespeare.hs b/Text/Shakespeare.hs +index f908ff4..55cd1d1 100644 +--- a/Text/Shakespeare.hs ++++ b/Text/Shakespeare.hs +@@ -12,14 +12,14 @@ module Text.Shakespeare + , WrapInsertion (..) + , PreConversion (..) + , defaultShakespeareSettings +- , shakespeare +- , shakespeareFile +- , shakespeareFileReload ++ --, shakespeare ++ --, shakespeareFile ++ -- , shakespeareFileReload + -- * low-level +- , shakespeareFromString +- , shakespeareUsedIdentifiers ++ -- , shakespeareFromString ++ --, shakespeareUsedIdentifiers + , RenderUrl +- , VarType ++ --, VarType + , Deref + , Parser + +@@ -151,38 +151,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 wp) = +- [|WrapInsertion $(lift indent) $(lift sb) $(lift sep) $(lift sc) $(lift e) $(lift wp)|] +- +-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) +@@ -346,77 +314,12 @@ 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 $ (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 Nothing r $ +-#ifdef WINDOWS +- filter (/='\r') +-#endif +- 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)] +-getVars ContentRaw{} = [] +-getVars (ContentVar d) = [(d, VTPlain)] +-getVars (ContentUrl d) = [(d, VTUrl)] +-getVars (ContentUrlParam d) = [(d, VTUrlParam)] +-getVars (ContentMix d) = [(d, VTMixin)] + + data VarExp url = EPlain Builder + | EUrl url + | EUrlParam (url, [(TS.Text, TS.Text)]) + | EMixin (Shakespeare url) + +--- | Determine which identifiers are used by the given template, useful for +--- creating systems like yesod devel. +-shakespeareUsedIdentifiers :: ShakespeareSettings -> String -> [(Deref, VarType)] +-shakespeareUsedIdentifiers settings = concatMap getVars . contentFromString settings +- + type MTime = UTCTime + + {-# NOINLINE reloadMapRef #-} +@@ -432,28 +335,6 @@ insertReloadMap :: FilePath -> (MTime, [Content]) -> IO [Content] + insertReloadMap fp (mt, content) = atomicModifyIORef reloadMapRef + (\reloadMap -> (M.insert fp (mt, content) reloadMap, content)) + +-shakespeareFileReload :: ShakespeareSettings -> FilePath -> Q Exp +-shakespeareFileReload settings fp = do +- str <- readFileQ fp +- s <- qRunIO $ preFilter (Just fp) settings str +- let b = shakespeareUsedIdentifiers settings s +- c <- mapM vtToExp b +- rt <- [|shakespeareRuntime settings fp|] +- wrap' <- [|\x -> $(return $ wrap settings) . x|] +- return $ wrap' `AppE` (rt `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 $ +- InfixE (Just $ unwrap settings) (VarE '(.)) (Just $ toBuilder settings))|] +- c VTUrl = [|EUrl|] +- c VTUrlParam = [|EUrlParam|] +- c VTMixin = [|\x -> EMixin $ \r -> $(return $ unwrap settings) $ x r|] + + + +diff --git a/Text/Shakespeare/Base.hs b/Text/Shakespeare/Base.hs +index 9573533..49f1995 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 +-- +1.8.5.1 + diff --git a/standalone/android/haskell-patches/wai-app-static_deal-with-TH.patch b/standalone/no-th/haskell-patches/wai-app-static_deal-with-TH.patch index d9860f922..b9f4283ca 100644 --- a/standalone/android/haskell-patches/wai-app-static_deal-with-TH.patch +++ b/standalone/no-th/haskell-patches/wai-app-static_deal-with-TH.patch @@ -1,4 +1,4 @@ -From 432a8fc47bb11cf8fd0a832e033cfb94a6332dbe Mon Sep 17 00:00:00 2001 +From 8cc398092892377d5fdbda990a2e860155422afa 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 @@ -8,12 +8,13 @@ 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 ---- - wai-app-static.cabal | 2 +- - 2 files changed, 1 insertion(+), 5 deletions(-) + Network/Wai/Application/Static.hs | 4 ---- + WaiAppStatic/Storage/Embedded.hs | 8 ++++---- + wai-app-static.cabal | 4 +--- + 3 files changed, 5 insertions(+), 11 deletions(-) diff --git a/Network/Wai/Application/Static.hs b/Network/Wai/Application/Static.hs -index 3f07391..75709b7 100644 +index f2fa743..1a82b30 100644 --- a/Network/Wai/Application/Static.hs +++ b/Network/Wai/Application/Static.hs @@ -33,8 +33,6 @@ import Control.Monad.IO.Class (liftIO) @@ -34,21 +35,48 @@ index 3f07391..75709b7 100644 staticAppPieces ss rawPieces req = liftIO $ do case toPieces rawPieces of Just pieces -> checkPieces ss pieces req >>= response +diff --git a/WaiAppStatic/Storage/Embedded.hs b/WaiAppStatic/Storage/Embedded.hs +index daa6e50..9873d4e 100644 +--- a/WaiAppStatic/Storage/Embedded.hs ++++ b/WaiAppStatic/Storage/Embedded.hs +@@ -3,10 +3,10 @@ module WaiAppStatic.Storage.Embedded( + embeddedSettings + + -- * Template Haskell +- , Etag +- , EmbeddableEntry(..) +- , mkSettings ++ --, Etag ++ --, EmbeddableEntry(..) ++ --, mkSettings + ) where + + import WaiAppStatic.Storage.Embedded.Runtime +-import WaiAppStatic.Storage.Embedded.TH ++--import WaiAppStatic.Storage.Embedded.TH diff --git a/wai-app-static.cabal b/wai-app-static.cabal -index ec22813..e944caa 100644 +index 5d81150..8f8c144 100644 --- a/wai-app-static.cabal +++ b/wai-app-static.cabal -@@ -56,9 +56,9 @@ library +@@ -33,7 +33,6 @@ library + , containers >= 0.2 + , time >= 1.1.4 + , old-locale >= 1.0.0.2 +- , file-embed >= 0.0.3.1 + , text >= 0.7 + , blaze-builder >= 0.2.1.4 + , base64-bytestring >= 0.1 +@@ -57,9 +56,8 @@ library WaiAppStatic.Storage.Embedded WaiAppStatic.Listing WaiAppStatic.Types - other-modules: Util WaiAppStatic.Storage.Embedded.Runtime - WaiAppStatic.Storage.Embedded.TH +- WaiAppStatic.Storage.Embedded.TH + other-modules: Util ghc-options: -Wall extensions: CPP -- -1.7.10.4 +1.8.5.1 diff --git a/standalone/no-th/haskell-patches/xml-hamlet_remove_TH.patch b/standalone/no-th/haskell-patches/xml-hamlet_remove_TH.patch new file mode 100644 index 000000000..b6334d31f --- /dev/null +++ b/standalone/no-th/haskell-patches/xml-hamlet_remove_TH.patch @@ -0,0 +1,108 @@ +From b53713fbb4f3bb6bdd25b07afcaed4940b32dfa8 Mon Sep 17 00:00:00 2001 +From: Joey Hess <joey@kitenet.net> +Date: Wed, 18 Dec 2013 03:32:44 +0000 +Subject: [PATCH] remove TH + +--- + 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..4e830bd 100644 +--- a/Text/Hamlet/XML.hs ++++ b/Text/Hamlet/XML.hs +@@ -1,9 +1,7 @@ + {-# LANGUAGE TemplateHaskell #-} + {-# OPTIONS_GHC -fno-warn-missing-fields #-} + module Text.Hamlet.XML +- ( xml +- , xmlFile +- ) where ++ () where + + import Language.Haskell.TH.Syntax + import Language.Haskell.TH.Quote +@@ -19,80 +17,3 @@ 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.5.1 + diff --git a/standalone/android/haskell-patches/yesod-auth_don-t-really-build.patch b/standalone/no-th/haskell-patches/yesod-auth_don-t-really-build.patch index 7016e001c..7016e001c 100644 --- a/standalone/android/haskell-patches/yesod-auth_don-t-really-build.patch +++ b/standalone/no-th/haskell-patches/yesod-auth_don-t-really-build.patch diff --git a/standalone/android/haskell-patches/yesod-core_expand_TH.patch b/standalone/no-th/haskell-patches/yesod-core_expand_TH.patch index 1687ff0e4..d5596395a 100644 --- a/standalone/android/haskell-patches/yesod-core_expand_TH.patch +++ b/standalone/no-th/haskell-patches/yesod-core_expand_TH.patch @@ -1,21 +1,63 @@ -From 7583457fb410d07f480a2aa7d6c2f174324b3592 Mon Sep 17 00:00:00 2001 +From 08cc43788c16fb91f63bc0bd520eeccdcdab477a Mon Sep 17 00:00:00 2001 From: dummy <dummy@example.com> -Date: Sat, 19 Oct 2013 02:03:18 +0000 -Subject: [PATCH] hackity +Date: Tue, 17 Dec 2013 17:15:33 +0000 +Subject: [PATCH] remove and expand TH --- - 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 - - 5 files changed, 179 insertions(+), 103 deletions(-) + Yesod/Core.hs | 30 +++--- + Yesod/Core/Class/Yesod.hs | 249 +++++++++++++++++++++++++++++++-------------- + Yesod/Core/Dispatch.hs | 27 ++--- + Yesod/Core/Handler.hs | 25 ++--- + Yesod/Core/Internal/Run.hs | 4 +- + Yesod/Core/Internal/TH.hs | 111 -------------------- + Yesod/Core/Widget.hs | 32 +----- + 7 files changed, 209 insertions(+), 269 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs -index 12e59d5..f1ff21c 100644 +index 12e59d5..2817a69 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs -@@ -94,8 +94,6 @@ module Yesod.Core +@@ -29,16 +29,16 @@ module Yesod.Core + , unauthorizedI + -- * Logging + , LogLevel (..) +- , logDebug +- , logInfo +- , logWarn +- , logError +- , logOther +- , logDebugS +- , logInfoS +- , logWarnS +- , logErrorS +- , logOtherS ++ --, logDebug ++ --, logInfo ++ --, logWarn ++ --, logError ++ --, logOther ++ --, logDebugS ++ --, logInfoS ++ --, logWarnS ++ --, logErrorS ++ --, logOtherS + -- * Sessions + , SessionBackend (..) + , customizeSessionCookies +@@ -85,17 +85,15 @@ module Yesod.Core + , readIntegral + -- * Shakespeare + -- ** Hamlet +- , hamlet +- , shamlet +- , xhamlet ++ --, hamlet ++ -- , shamlet ++ --, xhamlet + , HtmlUrl + -- ** Julius +- , julius ++ --, julius , JavascriptUrl , renderJavascriptUrl -- ** Cassius/Lucius @@ -25,10 +67,16 @@ index 12e59d5..f1ff21c 100644 , renderCssUrl ) where diff --git a/Yesod/Core/Class/Yesod.hs b/Yesod/Core/Class/Yesod.hs -index cf02a1a..3f1e88e 100644 +index a64d6eb..5dffbfa 100644 --- a/Yesod/Core/Class/Yesod.hs +++ b/Yesod/Core/Class/Yesod.hs -@@ -9,6 +9,10 @@ import Yesod.Core.Content +@@ -5,11 +5,15 @@ + {-# LANGUAGE CPP #-} + module Yesod.Core.Class.Yesod where + +-import Control.Monad.Logger (logErrorS) ++--import Control.Monad.Logger (logErrorS) + import Yesod.Core.Content import Yesod.Core.Handler import Yesod.Routes.Class @@ -39,7 +87,7 @@ index cf02a1a..3f1e88e 100644 import Blaze.ByteString.Builder (Builder) import Blaze.ByteString.Builder.Char.Utf8 (fromText) -@@ -87,18 +91,27 @@ class RenderRoute site => Yesod site where +@@ -94,18 +98,27 @@ class RenderRoute site => Yesod site where defaultLayout w = do p <- widgetToPageContent w mmsg <- getMessage @@ -79,7 +127,7 @@ index cf02a1a..3f1e88e 100644 -- | 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 +@@ -370,45 +383,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 @@ -222,7 +270,7 @@ index cf02a1a..3f1e88e 100644 return $ PageContent title headAll $ case jsLoader master of -@@ -424,10 +495,13 @@ defaultErrorHandler NotFound = selectRep $ do +@@ -438,10 +509,13 @@ defaultErrorHandler NotFound = selectRep $ do r <- waiRequest let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r setTitle "Not Found" @@ -240,7 +288,7 @@ index cf02a1a..3f1e88e 100644 provideRep $ return $ object ["message" .= ("Not Found" :: Text)] -- For API requests. -@@ -437,10 +511,11 @@ defaultErrorHandler NotFound = selectRep $ do +@@ -451,10 +525,11 @@ defaultErrorHandler NotFound = selectRep $ do defaultErrorHandler NotAuthenticated = selectRep $ do provideRep $ defaultLayout $ do setTitle "Not logged in" @@ -256,7 +304,7 @@ index cf02a1a..3f1e88e 100644 provideRep $ do -- 401 *MUST* include a WWW-Authenticate header -@@ -462,10 +537,13 @@ defaultErrorHandler NotAuthenticated = selectRep $ do +@@ -476,10 +551,13 @@ defaultErrorHandler NotAuthenticated = selectRep $ do defaultErrorHandler (PermissionDenied msg) = selectRep $ do provideRep $ defaultLayout $ do setTitle "Permission Denied" @@ -274,7 +322,7 @@ index cf02a1a..3f1e88e 100644 provideRep $ return $ object $ [ "message" .= ("Permission Denied. " <> msg) -@@ -474,30 +552,43 @@ defaultErrorHandler (PermissionDenied msg) = selectRep $ do +@@ -488,30 +566,43 @@ defaultErrorHandler (PermissionDenied msg) = selectRep $ do defaultErrorHandler (InvalidArgs ia) = selectRep $ do provideRep $ defaultLayout $ do setTitle "Invalid Arguments" @@ -334,10 +382,39 @@ index cf02a1a..3f1e88e 100644 asyncHelper :: (url -> [x] -> Text) diff --git a/Yesod/Core/Dispatch.hs b/Yesod/Core/Dispatch.hs -index 335a15c..4ca05da 100644 +index df822e2..5583495 100644 --- a/Yesod/Core/Dispatch.hs +++ b/Yesod/Core/Dispatch.hs -@@ -123,13 +123,6 @@ toWaiApp site = do +@@ -6,18 +6,18 @@ + {-# LANGUAGE CPP #-} + module Yesod.Core.Dispatch + ( -- * Quasi-quoted routing +- parseRoutes +- , parseRoutesNoCheck +- , parseRoutesFile +- , parseRoutesFileNoCheck +- , mkYesod ++ -- parseRoutes ++ --, parseRoutesNoCheck ++ --, parseRoutesFile ++ --, parseRoutesFileNoCheck ++ --, mkYesod + -- ** More fine-grained +- , mkYesodData +- , mkYesodSubData +- , mkYesodDispatch +- , mkYesodSubDispatch ++ --, mkYesodData ++ --, mkYesodSubData ++ --, mkYesodDispatch ++ --, mkYesodSubDispatch + -- ** Path pieces +- , PathPiece (..) ++ PathPiece (..) + , PathMultiPiece (..) + , Texts + -- * Convert to WAI +@@ -124,13 +124,6 @@ toWaiApp site = do , yreSite = site , yreSessionBackend = sb } @@ -352,19 +429,27 @@ index 335a15c..4ca05da 100644 return $ middleware $ toWaiAppYre yre diff --git a/Yesod/Core/Handler.hs b/Yesod/Core/Handler.hs -index f3b1799..d819b04 100644 +index 3581dbc..908256e 100644 --- a/Yesod/Core/Handler.hs +++ b/Yesod/Core/Handler.hs -@@ -152,7 +152,7 @@ import qualified Control.Monad.Trans.Writer as Writer +@@ -164,7 +164,7 @@ import Data.Text.Encoding (decodeUtf8With, encodeUtf8) + import Data.Text.Encoding.Error (lenientDecode) + import qualified Data.Text.Lazy as TL + import qualified Text.Blaze.Html.Renderer.Text as RenderText +-import Text.Hamlet (Html, HtmlUrl, hamlet) ++import Text.Hamlet (Html, HtmlUrl) - import Control.Monad.IO.Class (MonadIO, liftIO) - import Control.Monad.Trans.Resource (MonadResource, liftResourceT) -- + import qualified Data.ByteString as S + import qualified Data.ByteString.Lazy as L +@@ -198,6 +198,7 @@ import Data.CaseInsensitive (CI) + #if MIN_VERSION_wai(2, 0, 0) + import qualified System.PosixCompat.Files as PC + #endif +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) + + get :: MonadHandler m => m GHState + get = liftHandlerT $ HandlerT $ I.readIORef . handlerState +@@ -743,19 +744,15 @@ redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url) -> m a redirectToPost url = do urlText <- toTextUrl url @@ -394,10 +479,19 @@ index f3b1799..d819b04 100644 -- | 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 +index 25f51f1..d04d2cd 100644 --- a/Yesod/Core/Internal/Run.hs +++ b/Yesod/Core/Internal/Run.hs -@@ -122,8 +122,6 @@ safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) +@@ -15,7 +15,7 @@ import Control.Exception.Lifted (catch) + import Control.Monad.IO.Class (MonadIO) + import Control.Monad.IO.Class (liftIO) + import Control.Monad.Logger (LogLevel (LevelError), LogSource, +- liftLoc) ++ ) + import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState, createInternalState, closeInternalState) + import qualified Data.ByteString as S + import qualified Data.ByteString.Char8 as S8 +@@ -128,8 +128,6 @@ safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> ErrorResponse -> YesodApp safeEh log' er req = do @@ -406,6 +500,185 @@ index 35f1d3f..8b92e99 100644 return $ YRPlain H.status500 [] +diff --git a/Yesod/Core/Internal/TH.hs b/Yesod/Core/Internal/TH.hs +index 7e84c1c..a273c29 100644 +--- a/Yesod/Core/Internal/TH.hs ++++ b/Yesod/Core/Internal/TH.hs +@@ -23,114 +23,3 @@ import Yesod.Core.Content + import Yesod.Core.Class.Dispatch + import Yesod.Core.Internal.Run + +--- | 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 +- +--- | 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 -> [ResourceTree String] -> Q [Dec] +-mkYesodSubData name res = mkYesodDataGeneral name True res +- +-mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec] +-mkYesodDataGeneral name isSub res = do +- let (name':rest) = words name +- fmap fst $ mkYesodGeneral name' rest isSub res +- +--- | See 'mkYesodData'. +-mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec] +-mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False +- +--- | Get the Handler and Widget type synonyms for the given site. +-masterTypeSyns :: Type -> [Dec] +-masterTypeSyns site = +- [ TySynD (mkName "Handler") [] +- $ ConT ''HandlerT `AppT` site `AppT` ConT ''IO +- , TySynD (mkName "Widget") [] +- $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''() +- ] +- +-mkYesodGeneral :: String -- ^ foundation type +- -> [String] -- ^ arguments for the type +- -> Bool -- ^ it this a subsite +- -> [ResourceTree String] +- -> Q([Dec],[Dec]) +-mkYesodGeneral name args isSub resS = do +- renderRouteDec <- mkRenderRouteInstance site res +- routeAttrsDec <- mkRouteAttrsInstance site res +- dispatchDec <- mkDispatchInstance site res +- parse <- mkParseRouteInstance site res +- let rname = mkName $ "resources" ++ name +- eres <- lift resS +- let resourcesDec = +- [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String) +- , FunD rname [Clause [] (NormalB eres) []] +- ] +- let dataDec = concat +- [ [parse] +- , renderRouteDec +- , [routeAttrsDec] +- , resourcesDec +- , if isSub then [] else masterTypeSyns site +- ] +- return (dataDec, dispatchDec) +- where site = foldl' AppT (ConT $ mkName name) (map (VarT . mkName) args) +- res = map (fmap parseType) resS +- +-mkMDS :: Q Exp -> MkDispatchSettings +-mkMDS rh = MkDispatchSettings +- { mdsRunHandler = rh +- , mdsSubDispatcher = +- [|\parentRunner getSub toParent env -> yesodSubDispatch +- YesodSubRunnerEnv +- { ysreParentRunner = parentRunner +- , ysreGetSub = getSub +- , ysreToParentRoute = toParent +- , ysreParentEnv = env +- } +- |] +- , mdsGetPathInfo = [|W.pathInfo|] +- , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|] +- , mdsMethod = [|W.requestMethod|] +- , mds404 = [|notFound >> return ()|] +- , mds405 = [|badMethod >> return ()|] +- , mdsGetHandler = defaultGetHandler +- } +- +--- | 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 :: Type -- ^ The master site type +- -> [ResourceTree a] -- ^ The resource +- -> DecsQ +-mkDispatchInstance master res = do +- clause' <- mkDispatchClause (mkMDS [|yesodRunner|]) res +- let thisDispatch = FunD 'yesodDispatch [clause'] +- return [InstanceD [] yDispatch [thisDispatch]] +- where +- yDispatch = ConT ''YesodDispatch `AppT` master +- +-mkYesodSubDispatch :: [ResourceTree a] -> Q Exp +-mkYesodSubDispatch res = do +- clause' <- mkDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res +- inner <- newName "inner" +- let innerFun = FunD inner [clause'] +- helper <- newName "helper" +- let fun = FunD helper +- [ Clause +- [] +- (NormalB $ VarE inner) +- [innerFun] +- ] +- return $ LetE [fun] (VarE helper) +diff --git a/Yesod/Core/Widget.hs b/Yesod/Core/Widget.hs +index a972efa..156cd45 100644 +--- a/Yesod/Core/Widget.hs ++++ b/Yesod/Core/Widget.hs +@@ -16,8 +16,8 @@ module Yesod.Core.Widget + WidgetT + , PageContent (..) + -- * Special Hamlet quasiquoter/TH for Widgets +- , whamlet +- , whamletFile ++ --, whamlet ++ --, whamletFile + , ihamletToRepHtml + , ihamletToHtml + -- * Convert to Widget +@@ -46,7 +46,7 @@ module Yesod.Core.Widget + , widgetToParentWidget + , handlerToWidget + -- * Internal +- , whamletFileWithSettings ++ --, whamletFileWithSettings + , asWidgetT + ) where + +@@ -189,35 +189,9 @@ addScriptRemote = flip addScriptRemoteAttrs [] + addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m () + addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty + +-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 +- + asWidgetT :: WidgetT site m () -> WidgetT site m () + asWidgetT = id + +-rules :: Q NP.HamletRules +-rules = do +- ah <- [|asWidgetT . 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 [|getUrlRenderParams|]) +- (Just $ helper [|liftM (toHtml .) getMessageRender|]) +- f env +- return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b +- + -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. + ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message) + => HtmlUrlI18n message (Route (HandlerSite m)) -- -1.7.10.4 +1.8.5.1 diff --git a/standalone/android/haskell-patches/yesod-form_spliced-TH.patch b/standalone/no-th/haskell-patches/yesod-form_spliced-TH.patch index 486d2aaee..0a82434ea 100644 --- a/standalone/android/haskell-patches/yesod-form_spliced-TH.patch +++ b/standalone/no-th/haskell-patches/yesod-form_spliced-TH.patch @@ -1,19 +1,19 @@ -From f645acc0efbfcba7715cd2b6734f0e9df98f7020 Mon Sep 17 00:00:00 2001 +From fbd8f048c239e34625e438a24213534f6f68c3e8 Mon Sep 17 00:00:00 2001 From: dummy <dummy@example.com> -Date: Mon, 11 Nov 2013 01:26:56 +0000 -Subject: [PATCH] update +Date: Tue, 17 Dec 2013 18:34:25 +0000 +Subject: [PATCH] spliced TH --- - Yesod/Form/Fields.hs | 771 +++++++++++++++++++++++++++++++++++------------ - Yesod/Form/Functions.hs | 237 ++++++++++++--- - Yesod/Form/Jquery.hs | 125 ++++++-- - Yesod/Form/MassInput.hs | 233 +++++++++++--- - Yesod/Form/Nic.hs | 61 +++- - yesod-form.cabal | 1 + - 6 files changed, 1122 insertions(+), 306 deletions(-) + Yesod/Form/Fields.hs | 771 ++++++++++++++++++++++++++++++++++++------------ + Yesod/Form/Functions.hs | 239 ++++++++++++--- + Yesod/Form/Jquery.hs | 129 ++++++-- + Yesod/Form/MassInput.hs | 233 ++++++++++++--- + Yesod/Form/Nic.hs | 65 +++- + yesod-form.cabal | 1 + + 6 files changed, 1127 insertions(+), 311 deletions(-) diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs -index 0689859..1e9d49b 100644 +index b2a47c6..016c98b 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -1,4 +1,3 @@ @@ -982,10 +982,17 @@ index 0689859..1e9d49b 100644 , fvRequired = False } diff --git a/Yesod/Form/Functions.hs b/Yesod/Form/Functions.hs -index 8a36710..c375ae0 100644 +index 8a36710..8675a10 100644 --- a/Yesod/Form/Functions.hs +++ b/Yesod/Form/Functions.hs -@@ -59,6 +59,10 @@ import Data.Maybe (listToMaybe, fromMaybe) +@@ -53,12 +53,16 @@ import Text.Blaze (Markup, toMarkup) + #define toHtml toMarkup + import Yesod.Core + import Network.Wai (requestMethod) +-import Text.Hamlet (shamlet) ++--`import Text.Hamlet (shamlet) + import Data.Monoid (mempty) + import Data.Maybe (listToMaybe, fromMaybe) import qualified Data.Map as Map import qualified Data.Text.Encoding as TE import Control.Arrow (first) @@ -1265,10 +1272,10 @@ index 8a36710..c375ae0 100644 check :: (Monad m, RenderMessage (HandlerSite m) msg) diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs -index 2c4ae25..4362188 100644 +index 2c4ae25..ed9b366 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs -@@ -12,6 +12,18 @@ module Yesod.Form.Jquery +@@ -12,12 +12,24 @@ module Yesod.Form.Jquery , Default (..) ) where @@ -1287,6 +1294,14 @@ index 2c4ae25..4362188 100644 import Yesod.Core import Yesod.Form import Data.Time (Day) + import Data.Default +-import Text.Hamlet (shamlet) +-import Text.Julius (julius, rawJS) ++--import Text.Hamlet (shamlet) ++import Text.Julius (rawJS) + import Data.Text (Text, pack, unpack) + import Data.Monoid (mconcat) + @@ -60,27 +72,59 @@ jqueryDayField jds = Field . readMay . unpack @@ -1684,10 +1699,10 @@ index 332eb66..5015e7b 100644 - <td .errors>#{err} -|] diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs -index 2862678..7b49b1a 100644 +index 2862678..04ddaba 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs -@@ -9,6 +9,19 @@ module Yesod.Form.Nic +@@ -9,11 +9,24 @@ module Yesod.Form.Nic , nicHtmlField ) where @@ -1707,6 +1722,13 @@ index 2862678..7b49b1a 100644 import Yesod.Core import Yesod.Form import Text.HTML.SanitizeXSS (sanitizeBalance) +-import Text.Hamlet (shamlet) +-import Text.Julius (julius, rawJS) ++--import Text.Hamlet (shamlet) ++import Text.Julius ( rawJS) + import Text.Blaze.Html.Renderer.String (renderHtml) + import Data.Text (Text, pack) + import Data.Maybe (listToMaybe) @@ -27,20 +40,48 @@ nicHtmlField :: YesodNic site => Field (HandlerT site IO) Html nicHtmlField = Field { fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e @@ -1767,7 +1789,7 @@ index 2862678..7b49b1a 100644 } where diff --git a/yesod-form.cabal b/yesod-form.cabal -index 39fa680..88ed066 100644 +index 9e0c710..a39f71f 100644 --- a/yesod-form.cabal +++ b/yesod-form.cabal @@ -19,6 +19,7 @@ library @@ -1779,5 +1801,5 @@ index 39fa680..88ed066 100644 , persistent >= 1.2 && < 1.3 , template-haskell -- -1.7.10.4 +1.8.5.1 diff --git a/standalone/android/haskell-patches/yesod-persistent_do-not-really-build.patch b/standalone/no-th/haskell-patches/yesod-persistent_do-not-really-build.patch index ecccf75ac..ecccf75ac 100644 --- a/standalone/android/haskell-patches/yesod-persistent_do-not-really-build.patch +++ b/standalone/no-th/haskell-patches/yesod-persistent_do-not-really-build.patch diff --git a/standalone/android/haskell-patches/yesod-routes_export-module-referenced-by-TH-splices.patch b/standalone/no-th/haskell-patches/yesod-routes_export-module-referenced-by-TH-splices.patch index e20e3c7f1..e20e3c7f1 100644 --- a/standalone/android/haskell-patches/yesod-routes_export-module-referenced-by-TH-splices.patch +++ b/standalone/no-th/haskell-patches/yesod-routes_export-module-referenced-by-TH-splices.patch diff --git a/standalone/no-th/haskell-patches/yesod-routes_remove-TH.patch b/standalone/no-th/haskell-patches/yesod-routes_remove-TH.patch new file mode 100644 index 000000000..18c1416de --- /dev/null +++ b/standalone/no-th/haskell-patches/yesod-routes_remove-TH.patch @@ -0,0 +1,169 @@ +From acebcf203b270d00aac0a29be48832ae2c64ce7e Mon Sep 17 00:00:00 2001 +From: Joey Hess <joey@kitenet.net> +Date: Tue, 17 Dec 2013 06:57:07 +0000 +Subject: [PATCH] remove TH + +--- + Yesod/Routes/Parse.hs | 39 +++++---------------------------------- + Yesod/Routes/TH.hs | 16 ++++++++-------- + Yesod/Routes/TH/Types.hs | 16 ---------------- + yesod-routes.cabal | 4 ---- + 4 files changed, 13 insertions(+), 62 deletions(-) + +diff --git a/Yesod/Routes/Parse.hs b/Yesod/Routes/Parse.hs +index 3d27980..c2e3e6d 100644 +--- a/Yesod/Routes/Parse.hs ++++ b/Yesod/Routes/Parse.hs +@@ -2,11 +2,11 @@ + {-# LANGUAGE DeriveDataTypeable #-} + {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter + module Yesod.Routes.Parse +- ( parseRoutes +- , parseRoutesFile +- , parseRoutesNoCheck +- , parseRoutesFileNoCheck +- , parseType ++ --( parseRoutes ++ --, parseRoutesFile ++ --, parseRoutesNoCheck ++ --, parseRoutesFileNoCheck ++ ( parseType + , parseTypeTree + , TypeTree (..) + ) where +@@ -19,41 +19,12 @@ import Yesod.Routes.TH + import Yesod.Routes.Overlap (findOverlapNames) + import Data.List (foldl') + +--- | 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 +- qAddDependentFile fp +- 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 +diff --git a/Yesod/Routes/TH.hs b/Yesod/Routes/TH.hs +index 7b2e50b..b05fc57 100644 +--- a/Yesod/Routes/TH.hs ++++ b/Yesod/Routes/TH.hs +@@ -2,15 +2,15 @@ + module Yesod.Routes.TH + ( module Yesod.Routes.TH.Types + -- * Functions +- , module Yesod.Routes.TH.RenderRoute +- , module Yesod.Routes.TH.ParseRoute +- , module Yesod.Routes.TH.RouteAttrs ++ -- , module Yesod.Routes.TH.RenderRoute ++ -- , module Yesod.Routes.TH.ParseRoute ++ -- , module Yesod.Routes.TH.RouteAttrs + -- ** Dispatch +- , module Yesod.Routes.TH.Dispatch ++ -- , module Yesod.Routes.TH.Dispatch + ) where + + import Yesod.Routes.TH.Types +-import Yesod.Routes.TH.RenderRoute +-import Yesod.Routes.TH.ParseRoute +-import Yesod.Routes.TH.RouteAttrs +-import Yesod.Routes.TH.Dispatch ++--import Yesod.Routes.TH.RenderRoute ++--import Yesod.Routes.TH.ParseRoute ++--import Yesod.Routes.TH.RouteAttrs ++--import Yesod.Routes.TH.Dispatch +diff --git a/Yesod/Routes/TH/Types.hs b/Yesod/Routes/TH/Types.hs +index d0a0405..3232e99 100644 +--- a/Yesod/Routes/TH/Types.hs ++++ b/Yesod/Routes/TH/Types.hs +@@ -31,10 +31,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)] +@@ -48,9 +44,6 @@ type CheckOverlap = Bool + instance Functor Resource where + fmap f (Resource a b c d) = Resource a (map (second $ fmap f) b) (fmap f c) d + +-instance Lift t => Lift (Resource t) where +- lift (Resource a b c d) = [|Resource a b c d|] +- + data Piece typ = Static String | Dynamic typ + deriving Show + +@@ -58,10 +51,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 +@@ -77,11 +66,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 0e44409..e01ea06 100644 +--- a/yesod-routes.cabal ++++ b/yesod-routes.cabal +@@ -28,10 +28,6 @@ library + 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 + ghc-options: -Wall + + test-suite runtests +-- +1.8.5.1 + diff --git a/standalone/no-th/haskell-patches/yesod-static_remove-TH.patch b/standalone/no-th/haskell-patches/yesod-static_remove-TH.patch new file mode 100644 index 000000000..425edc017 --- /dev/null +++ b/standalone/no-th/haskell-patches/yesod-static_remove-TH.patch @@ -0,0 +1,597 @@ +From ad0166a6e537021c9f5a1e01cde4b7c520edcf3a Mon Sep 17 00:00:00 2001 +From: Joey Hess <joey@kitenet.net> +Date: Wed, 18 Dec 2013 05:10:59 +0000 +Subject: [PATCH] remove TH + +--- + Yesod/EmbeddedStatic.hs | 64 ----------- + Yesod/EmbeddedStatic/Generators.hs | 102 +---------------- + Yesod/EmbeddedStatic/Internal.hs | 41 ------- + Yesod/EmbeddedStatic/Types.hs | 14 --- + Yesod/Static.hs | 224 +------------------------------------ + 5 files changed, 12 insertions(+), 433 deletions(-) + +diff --git a/Yesod/EmbeddedStatic.hs b/Yesod/EmbeddedStatic.hs +index e819630..a564d4b 100644 +--- a/Yesod/EmbeddedStatic.hs ++++ b/Yesod/EmbeddedStatic.hs +@@ -41,7 +41,6 @@ module Yesod.EmbeddedStatic ( + -- * Subsite + EmbeddedStatic + , embeddedResourceR +- , mkEmbeddedStatic + , embedStaticContent + + -- * Generators +@@ -91,69 +90,6 @@ instance Yesod master => YesodSubDispatch EmbeddedStatic (HandlerT master IO) wh + ("widget":_) -> staticApp (widgetSettings site) req + _ -> return $ responseLBS status404 [] "Not Found" + +--- | Create the haskell variable for the link to the entry +-mkRoute :: ComputedEntry -> Q [Dec] +-mkRoute (ComputedEntry { cHaskellName = Nothing }) = return [] +-mkRoute (c@ComputedEntry { cHaskellName = Just name }) = do +- routeType <- [t| Route EmbeddedStatic |] +- link <- [| $(cLink c) |] +- return [ SigD name routeType +- , ValD (VarP name) (NormalB link) [] +- ] +- +--- | Creates an 'EmbeddedStatic' by running, at compile time, a list of generators. +--- Each generator produces a list of entries to embed into the executable. +--- +--- This template haskell splice creates a variable binding holding the resulting +--- 'EmbeddedStatic' and in addition creates variable bindings for all the routes +--- produced by the generators. For example, if a directory called static has +--- the following contents: +--- +--- * js/jquery.js +--- +--- * css/bootstrap.css +--- +--- * img/logo.png +--- +--- then a call to +--- +--- > #ifdef DEVELOPMENT +--- > #define DEV_BOOL True +--- > #else +--- > #define DEV_BOOL False +--- > #endif +--- > mkEmbeddedStatic DEV_BOOL "myStatic" [embedDir "static"] +--- +--- will produce variables +--- +--- > myStatic :: EmbeddedStatic +--- > js_jquery_js :: Route EmbeddedStatic +--- > css_bootstrap_css :: Route EmbeddedStatic +--- > img_logo_png :: Route EmbeddedStatic +-mkEmbeddedStatic :: Bool -- ^ development? +- -> String -- ^ variable name for the created 'EmbeddedStatic' +- -> [Generator] -- ^ the generators (see "Yesod.EmbeddedStatic.Generators") +- -> Q [Dec] +-mkEmbeddedStatic dev esName gen = do +- entries <- concat <$> sequence gen +- computed <- runIO $ mapM (if dev then devEmbed else prodEmbed) entries +- +- let settings = Static.mkSettings $ return $ map cStEntry computed +- devExtra = listE $ catMaybes $ map ebDevelExtraFiles entries +- ioRef = [| unsafePerformIO $ newIORef M.empty |] +- +- -- build the embedded static +- esType <- [t| EmbeddedStatic |] +- esCreate <- if dev +- then [| EmbeddedStatic (develApp $settings $devExtra) $ioRef |] +- else [| EmbeddedStatic (staticApp $! $settings) $ioRef |] +- let es = [ SigD (mkName esName) esType +- , ValD (VarP $ mkName esName) (NormalB esCreate) [] +- ] +- +- routes <- mapM mkRoute computed +- +- return $ es ++ concat routes + + -- | Use this for 'addStaticContent' to have the widget static content be served by + -- the embedded static subsite. For example, +diff --git a/Yesod/EmbeddedStatic/Generators.hs b/Yesod/EmbeddedStatic/Generators.hs +index e83785d..bc35359 100644 +--- a/Yesod/EmbeddedStatic/Generators.hs ++++ b/Yesod/EmbeddedStatic/Generators.hs +@@ -6,12 +6,12 @@ + module Yesod.EmbeddedStatic.Generators ( + -- * Generators + Location +- , embedFile +- , embedFileAt +- , embedDir +- , embedDirAt +- , concatFiles +- , concatFilesWith ++ --, embedFile ++ --, embedFileAt ++ --, embedDir ++ --, embedDirAt ++ --, concatFiles ++ --, concatFilesWith + + -- * Compression options for 'concatFilesWith' + , jasmine +@@ -50,28 +50,6 @@ import qualified Data.Text as T + + import Yesod.EmbeddedStatic.Types + +--- | Embed a single file. Equivalent to passing the same string twice to 'embedFileAt'. +-embedFile :: FilePath -> Generator +-embedFile f = embedFileAt f f +- +--- | Embed a single file at a given location within the static subsite and generate a +--- route variable based on the location via 'pathToName'. The @FilePath@ must be a relative +--- path to the directory in which you run @cabal build@. During development, the file located +--- at this filepath will be reloaded on every request. When compiling for production, the contents +--- of the file will be embedded into the executable and so the file does not need to be +--- distributed along with the executable. +-embedFileAt :: Location -> FilePath -> Generator +-embedFileAt loc f = do +- let mime = defaultMimeLookup $ T.pack f +- let entry = def { +- ebHaskellName = Just $ pathToName loc +- , ebLocation = loc +- , ebMimeType = mime +- , ebProductionContent = BL.readFile f +- , ebDevelReload = [| BL.readFile $(litE $ stringL f) |] +- } +- return [entry] +- + -- | List all files recursively in a directory + getRecursiveContents :: Location -- ^ The directory to search + -> FilePath -- ^ The prefix to add to the filenames +@@ -88,74 +66,6 @@ getRecursiveContents prefix topdir = do + else return [(loc, path)] + return (concat paths) + +--- | Embed all files in a directory into the static subsite. +--- +--- Equivalent to passing the empty string as the location to 'embedDirAt', +--- so the directory path itself is not part of the resource locations (and so +--- also not part of the generated route variable names). +-embedDir :: FilePath -> Generator +-embedDir = embedDirAt "" +- +--- | Embed all files in a directory to a given location within the static subsite. +--- +--- The directory tree rooted at the 'FilePath' (which must be relative to the directory in +--- which you run @cabal build@) is embedded into the static subsite at the given +--- location. Also, route variables will be created based on the final location +--- of each file. For example, if a directory \"static\" contains the files +--- +--- * css/bootstrap.css +--- +--- * js/jquery.js +--- +--- * js/bootstrap.js +--- +--- then @embedDirAt \"somefolder\" \"static\"@ will +--- +--- * Make the file @static\/css\/bootstrap.css@ available at the location +--- @somefolder\/css\/bootstrap.css@ within the static subsite and similarly +--- for the other two files. +--- +--- * Create variables @somefolder_css_bootstrap_css@, @somefolder_js_jquery_js@, +--- @somefolder_js_bootstrap_js@ all of type @Route EmbeddedStatic@. +--- +--- * During development, the files will be reloaded on every request. During +--- production, the contents of all files will be embedded into the executable. +--- +--- * During development, files that are added to the directory while the server +--- is running will not be detected. You need to recompile the module which +--- contains the call to @mkEmbeddedStatic@. This will also generate new route +--- variables for the new files. +-embedDirAt :: Location -> FilePath -> Generator +-embedDirAt loc dir = do +- files <- runIO $ getRecursiveContents loc dir +- concat <$> mapM (uncurry embedFileAt) files +- +--- | Concatinate a list of files and embed it at the location. Equivalent to passing @return@ to +--- 'concatFilesWith'. +-concatFiles :: Location -> [FilePath] -> Generator +-concatFiles loc files = concatFilesWith loc return files +- +--- | Concatinate a list of files into a single 'BL.ByteString', run the resulting content through the given +--- function, embed it at the given location, and create a haskell variable name for the route based on +--- the location. +--- +--- The processing function is only run when compiling for production, and the processing function is +--- executed at compile time. During development, on every request the files listed are reloaded, +--- concatenated, and served as a single resource at the given location without being processed. +-concatFilesWith :: Location -> (BL.ByteString -> IO BL.ByteString) -> [FilePath] -> Generator +-concatFilesWith loc process files = do +- let load = do putStrLn $ "Creating " ++ loc +- BL.concat <$> mapM BL.readFile files >>= process +- expFiles = listE $ map (litE . stringL) files +- expCt = [| BL.concat <$> mapM BL.readFile $expFiles |] +- mime = defaultMimeLookup $ T.pack loc +- return [def { ebHaskellName = Just $ pathToName loc +- , ebLocation = loc +- , ebMimeType = mime +- , ebProductionContent = load +- , ebDevelReload = expCt +- }] +- + -- | Convienient rexport of 'minifym' with a type signature to work with 'concatFilesWith'. + jasmine :: BL.ByteString -> IO BL.ByteString + jasmine ct = return $ either (const ct) id $ minifym ct +diff --git a/Yesod/EmbeddedStatic/Internal.hs b/Yesod/EmbeddedStatic/Internal.hs +index 0882c16..6f61a0f 100644 +--- a/Yesod/EmbeddedStatic/Internal.hs ++++ b/Yesod/EmbeddedStatic/Internal.hs +@@ -7,9 +7,6 @@ + module Yesod.EmbeddedStatic.Internal ( + EmbeddedStatic(..) + , Route(..) +- , ComputedEntry(..) +- , devEmbed +- , prodEmbed + , develApp + , AddStaticContent + , staticContentHelper +@@ -68,44 +65,6 @@ instance ParseRoute EmbeddedStatic where + parseRoute (["widget",h], _) = Just $ EmbeddedWidgetR h + parseRoute _ = Nothing + +--- | At compile time, one of these is created for every 'Entry' created by +--- the generators. The cLink is a template haskell expression of type @Route EmbeddedStatic@. +-data ComputedEntry = ComputedEntry { +- cHaskellName :: Maybe Name -- ^ Optional haskell name to create a variable for the route +- , cStEntry :: Static.EmbeddableEntry -- ^ The entry to be embedded into the executable +- , cLink :: ExpQ -- ^ The route for this entry +-} +- +-mkStr :: String -> ExpQ +-mkStr = litE . stringL +- +--- | Create a 'ComputedEntry' for development mode, reloading the content on every request. +-devEmbed :: Entry -> IO ComputedEntry +-devEmbed e = return computed +- where +- st = Static.EmbeddableEntry { +- Static.eLocation = "res/" `T.append` T.pack (ebLocation e) +- , Static.eMimeType = ebMimeType e +- , Static.eContent = Right [| $(ebDevelReload e) >>= \c -> +- return (T.pack (base64md5 c), c) |] +- } +- link = [| EmbeddedResourceR (T.splitOn (T.pack "/") $ T.pack $(mkStr $ ebLocation e)) [] |] +- computed = ComputedEntry (ebHaskellName e) st link +- +--- | Create a 'ComputedEntry' for production mode, hashing and embedding the content into the executable. +-prodEmbed :: Entry -> IO ComputedEntry +-prodEmbed e = do +- ct <- ebProductionContent e +- let hash = base64md5 ct +- link = [| EmbeddedResourceR (T.splitOn (T.pack "/") $ T.pack $(mkStr $ ebLocation e)) +- [(T.pack "etag", T.pack $(mkStr hash))] |] +- st = Static.EmbeddableEntry { +- Static.eLocation = "res/" `T.append` T.pack (ebLocation e) +- , Static.eMimeType = ebMimeType e +- , Static.eContent = Left (T.pack hash, ct) +- } +- return $ ComputedEntry (ebHaskellName e) st link +- + tryExtraDevelFiles :: [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application + tryExtraDevelFiles [] _ = return $ responseLBS status404 [] "" + tryExtraDevelFiles (f:fs) r = do +diff --git a/Yesod/EmbeddedStatic/Types.hs b/Yesod/EmbeddedStatic/Types.hs +index 5cbd662..d3e514f 100644 +--- a/Yesod/EmbeddedStatic/Types.hs ++++ b/Yesod/EmbeddedStatic/Types.hs +@@ -1,7 +1,6 @@ + {-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} + module Yesod.EmbeddedStatic.Types( + Location +- , Generator + -- ** Entry + , Entry + , ebHaskellName +@@ -52,16 +51,3 @@ data Entry = Entry { + -- taking as input the list of path pieces and optionally returning a mime type + -- and content. + } +- +--- | When using 'def', you must fill in at least 'ebLocation'. +-instance Default Entry where +- def = Entry { ebHaskellName = Nothing +- , ebLocation = "xxxx" +- , ebMimeType = "application/octet-stream" +- , ebProductionContent = return BL.empty +- , ebDevelReload = [| return BL.empty |] +- , ebDevelExtraFiles = Nothing +- } +- +--- | An embedded generator is executed at compile time to produce the entries to embed. +-type Generator = Q [Entry] +diff --git a/Yesod/Static.hs b/Yesod/Static.hs +index ef27f1b..5795f45 100644 +--- a/Yesod/Static.hs ++++ b/Yesod/Static.hs +@@ -37,8 +37,8 @@ module Yesod.Static + , staticDevel + -- * Combining CSS/JS + -- $combining +- , combineStylesheets' +- , combineScripts' ++ --, combineStylesheets' ++ --, combineScripts' + -- ** Settings + , CombineSettings + , csStaticDir +@@ -48,13 +48,13 @@ module Yesod.Static + , csJsPreProcess + , csCombinedFolder + -- * Template Haskell helpers +- , staticFiles +- , staticFilesList +- , publicFiles ++ --, staticFiles ++ --, staticFilesList ++ --, publicFiles + -- * Hashing + , base64md5 + -- * Embed +- , embed ++ --, embed + #ifdef TEST_EXPORT + , getFileListPieces + #endif +@@ -64,7 +64,6 @@ import Prelude hiding (FilePath) + import qualified Prelude + import System.Directory + import Control.Monad +-import Data.FileEmbed (embedDir) + + import Yesod.Core + import Yesod.Core.Types +@@ -135,21 +134,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. +--- +--- You should use "Yesod.EmbeddedStatic" instead, it is much more powerful. +--- +--- 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'). + -- +@@ -214,59 +198,6 @@ getFileListPieces = flip evalStateT M.empty . flip go id + put $ M.insert s s m + return s + +--- | 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 +@@ -309,53 +240,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 $(TH.lift f)|] +- let route = mkName routeConName +- pack' <- [|pack|] +- qs <- if makeHash +- then do hash <- qRunIO $ base64md5File $ pathFromRawPieces fp f +- [|[(pack "etag", pack $(TH.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 +@@ -379,55 +263,6 @@ base64 = map tr + tr '/' = '_' + tr c = c + +--- $combining +--- +--- A common scenario on a site is the desire to include many external CSS and +--- Javascript files on every page. Doing so via the Widget functionality in +--- Yesod will work, but would also mean that the same content will be +--- downloaded many times. A better approach would be to combine all of these +--- files together into a single static file and serve that as a static resource +--- for every page. That resource can be cached on the client, and bandwidth +--- usage reduced. +--- +--- This could be done as a manual process, but that becomes tedious. Instead, +--- you can use some Template Haskell code which will combine these files into a +--- single static file at compile time. +- +-data CombineType = JS | CSS +- +-combineStatics' :: CombineType +- -> CombineSettings +- -> [Route Static] -- ^ files to combine +- -> Q Exp +-combineStatics' combineType CombineSettings {..} routes = do +- texts <- qRunIO $ runResourceT $ mapM_ yield fps $$ awaitForever readUTFFile =$ consume +- ltext <- qRunIO $ preProcess $ TL.fromChunks texts +- bs <- qRunIO $ postProcess fps $ TLE.encodeUtf8 ltext +- let hash' = base64md5 bs +- suffix = csCombinedFolder </> F.decodeString hash' <.> extension +- fp = csStaticDir </> suffix +- qRunIO $ do +- createTree $ F.directory fp +- L.writeFile (F.encodeString fp) bs +- let pieces = map T.unpack $ T.splitOn "/" $ either id id $ F.toText suffix +- [|StaticRoute (map pack pieces) []|] +- where +- fps :: [F.FilePath] +- fps = map toFP routes +- toFP (StaticRoute pieces _) = csStaticDir </> F.concat (map F.fromText pieces) +- readUTFFile fp = sourceFile (F.encodeString fp) =$= CT.decode CT.utf8 +- postProcess = +- case combineType of +- JS -> csJsPostProcess +- CSS -> csCssPostProcess +- preProcess = +- case combineType of +- JS -> csJsPreProcess +- CSS -> csCssPreProcess +- extension = +- case combineType of +- JS -> "js" +- CSS -> "css" + + -- | Data type for holding all settings for combining files. + -- +@@ -504,50 +339,3 @@ instance Default CombineSettings where + errorIntro :: [FilePath] -> [Char] -> [Char] + errorIntro fps s = "Error minifying " ++ show fps ++ ": " ++ s + +-liftRoutes :: [Route Static] -> Q Exp +-liftRoutes = +- fmap ListE . mapM go +- where +- go :: Route Static -> Q Exp +- go (StaticRoute x y) = [|StaticRoute $(liftTexts x) $(liftPairs y)|] +- +- liftTexts = fmap ListE . mapM liftT +- liftT t = [|pack $(TH.lift $ T.unpack t)|] +- +- liftPairs = fmap ListE . mapM liftPair +- liftPair (x, y) = [|($(liftT x), $(liftT y))|] +- +--- | Combine multiple CSS files together. Common usage would be: +--- +--- >>> combineStylesheets' development def 'StaticR [style1_css, style2_css] +--- +--- Where @development@ is a variable in your site indicated whether you are in +--- development or production mode. +--- +--- Since 1.2.0 +-combineStylesheets' :: Bool -- ^ development? if so, perform no combining +- -> CombineSettings +- -> Name -- ^ Static route constructor name, e.g. \'StaticR +- -> [Route Static] -- ^ files to combine +- -> Q Exp +-combineStylesheets' development cs con routes +- | development = [| mapM_ (addStylesheet . $(return $ ConE con)) $(liftRoutes routes) |] +- | otherwise = [| addStylesheet $ $(return $ ConE con) $(combineStatics' CSS cs routes) |] +- +- +--- | Combine multiple JS files together. Common usage would be: +--- +--- >>> combineScripts' development def 'StaticR [script1_js, script2_js] +--- +--- Where @development@ is a variable in your site indicated whether you are in +--- development or production mode. +--- +--- Since 1.2.0 +-combineScripts' :: Bool -- ^ development? if so, perform no combining +- -> CombineSettings +- -> Name -- ^ Static route constructor name, e.g. \'StaticR +- -> [Route Static] -- ^ files to combine +- -> Q Exp +-combineScripts' development cs con routes +- | development = [| mapM_ (addScript . $(return $ ConE con)) $(liftRoutes routes) |] +- | otherwise = [| addScript $ $(return $ ConE con) $(combineStatics' JS cs routes) |] +-- +1.8.5.1 + diff --git a/standalone/no-th/haskell-patches/yesod_hack-TH.patch b/standalone/no-th/haskell-patches/yesod_hack-TH.patch new file mode 100644 index 000000000..eedc7df15 --- /dev/null +++ b/standalone/no-th/haskell-patches/yesod_hack-TH.patch @@ -0,0 +1,140 @@ +From e3d1ead4f02c2c45e64a1ccad5b461cc6fdabbd2 Mon Sep 17 00:00:00 2001 +From: dummy <dummy@example.com> +Date: Tue, 17 Dec 2013 18:48:56 +0000 +Subject: [PATCH] hack for TH + +--- + Yesod.hs | 19 ++++++++++++-- + Yesod/Default/Util.hs | 69 ++------------------------------------------------- + 2 files changed, 19 insertions(+), 69 deletions(-) + +diff --git a/Yesod.hs b/Yesod.hs +index b367144..fbe309c 100644 +--- a/Yesod.hs ++++ b/Yesod.hs +@@ -5,9 +5,24 @@ module Yesod + ( -- * Re-exports from yesod-core + module Yesod.Core + , module Yesod.Form +- , module Yesod.Persist ++ , insertBy ++ , replace ++ , deleteBy ++ , delete ++ , insert ++ , Key + ) where + + import Yesod.Core + import Yesod.Form +-import Yesod.Persist ++ ++-- 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 ++ +diff --git a/Yesod/Default/Util.hs b/Yesod/Default/Util.hs +index a10358e..0547424 100644 +--- a/Yesod/Default/Util.hs ++++ b/Yesod/Default/Util.hs +@@ -5,10 +5,9 @@ + module Yesod.Default.Util + ( addStaticContentExternal + , globFile +- , widgetFileNoReload +- , widgetFileReload ++ --, 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,68 +65,7 @@ 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 +- +-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.8.5.1 + |