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

update haskell patches (incomplete)

Browse source
This commit is contained in:
Your Name 2014-05-20 22:12:29 +00:00
parent 155326a813
commit 5dfc43915a
12 changed files with 1399 additions and 1508 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
standalone/linux/install-haskell-packages
View file

@ -63,18 +63,14 @@ install_pkgs () {
patched network
patched wai-app-static
patched aeson
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 file-embed
patched shakespeare-text
patched process-conduit
patched yesod-static
patched yesod-persistent

40
standalone/no-th/haskell-patches/aeson_remove-TH.patch Normal file
View file

@ -0,0 +1,40 @@
From f147ec9aeaa03ca6e30232c84c413ef29b95fb62 Mon Sep 17 00:00:00 2001
From: Your Name <you@example.com>
Date: Tue, 20 May 2014 19:53:55 +0000
Subject: [PATCH] avoid TH
---
aeson.cabal | 3 ---
1 file changed, 3 deletions(-)
diff --git a/aeson.cabal b/aeson.cabal
index 493d625..02dc6f4 100644
--- a/aeson.cabal
+++ b/aeson.cabal
@@ -88,7 +88,6 @@ library
Data.Aeson.Generic
Data.Aeson.Parser
Data.Aeson.Types
- Data.Aeson.TH
other-modules:
Data.Aeson.Functions
@@ -121,7 +120,6 @@ library
old-locale,
scientific >= 0.3.1 && < 0.4,
syb,
- template-haskell >= 2.4,
time,
unordered-containers >= 0.2.3.0,
vector >= 0.7.1
@@ -164,7 +162,6 @@ test-suite tests
base,
containers,
bytestring,
- template-haskell,
test-framework,
test-framework-quickcheck2,
test-framework-hunit,
--
2.0.0.rc2

205
standalone/no-th/haskell-patches/hamlet_remove-TH.patch
View file

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

26
standalone/no-th/haskell-patches/shakespeare-css_1.0.2_0002-expose-modules-used-by-TH.patch
View file

@ -1,26 +0,0 @@
From 23e96f0d948e7a26febf1745a4c373faf579c8ee Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Mon, 15 Apr 2013 16:32:31 -0400
Subject: [PATCH] expose modules used by TH
---
shakespeare-css.cabal | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/shakespeare-css.cabal b/shakespeare-css.cabal
index de2497b..468353a 100644
--- a/shakespeare-css.cabal
+++ b/shakespeare-css.cabal
@@ -39,8 +39,8 @@ library
exposed-modules: Text.Cassius
Text.Lucius
- other-modules: Text.MkSizeType
Text.Css
+ other-modules: Text.MkSizeType
Text.IndentToBrace
Text.CssCommon
ghc-options: -Wall
--
1.8.2.rc3

351
standalone/no-th/haskell-patches/shakespeare-css_1.0.2_0003-remove-more-TH.patch
View file

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

215
standalone/no-th/haskell-patches/shakespeare-i18n_0001-remove-TH.patch
View file

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

316
standalone/no-th/haskell-patches/shakespeare-js_0001-remove-TH.patch
View file

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

153
standalone/no-th/haskell-patches/shakespeare-text_remove-TH.patch
View file

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

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

File diff suppressed because it is too large Load diff

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

@ -1,189 +0,0 @@
From 753f8ce37e096a343f1dd02a696a287bc91c24a0 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 6 Mar 2014 22:34:03 +0000
Subject: [PATCH] remove TH
---
Text/Shakespeare.hs | 73 ++++++++++--------------------------------------
Text/Shakespeare/Base.hs | 28 -------------------
2 files changed, 14 insertions(+), 87 deletions(-)
diff --git a/Text/Shakespeare.hs b/Text/Shakespeare.hs
index 68e344f..aef741c 100644
--- a/Text/Shakespeare.hs
+++ b/Text/Shakespeare.hs
@@ -14,17 +14,20 @@ module Text.Shakespeare
, WrapInsertion (..)
, PreConversion (..)
, defaultShakespeareSettings
- , shakespeare
- , shakespeareFile
- , shakespeareFileReload
+ -- , shakespeare
+ -- , shakespeareFile
+ -- , shakespeareFileReload
-- * low-level
- , shakespeareFromString
- , shakespeareUsedIdentifiers
+ -- , shakespeareFromString
+ -- , shakespeareUsedIdentifiers
, RenderUrl
, VarType (..)
, Deref
, Parser
+ -- used by TH
+ , pack'
+
#ifdef TEST_EXPORT
, preFilter
#endif
@@ -154,38 +157,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)
@@ -349,6 +320,7 @@ pack' = TS.pack
{-# NOINLINE pack' #-}
#endif
+{-
contentsToShakespeare :: ShakespeareSettings -> [Content] -> Q Exp
contentsToShakespeare rs a = do
r <- newName "_render"
@@ -400,16 +372,19 @@ shakespeareFile r fp =
qAddDependentFile fp >>
#endif
readFileQ fp >>= shakespeareFromString r
+-}
data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin
deriving (Show, Eq, Ord, Enum, Bounded, Typeable, Data, Generic)
+{-
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
@@ -418,8 +393,10 @@ data VarExp url = EPlain Builder
-- | 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
@@ -436,28 +413,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 a0e983c..23b4692 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.9.0

23
standalone/no-th/haskell-patches/wai-app-static_deal-with-TH.patch
View file

@ -1,6 +1,6 @@
From 8cc398092892377d5fdbda990a2e860155422afa Mon Sep 17 00:00:00 2001
From: foo <foo@bar>
Date: Sun, 22 Sep 2013 07:29:39 +0000
From 8d28a63e9a67cde6149bb2cbcf6172ddd997cfff Mon Sep 17 00:00:00 2001
From: dummy <dummy@example.com>
Date: Tue, 20 May 2014 17:53:41 +0000
Subject: [PATCH] deal with TH
Export modules referenced by it.
@ -10,8 +10,8 @@ Splicer.
---
Network/Wai/Application/Static.hs | 4 ----
WaiAppStatic/Storage/Embedded.hs | 8 ++++----
wai-app-static.cabal | 4 +---
3 files changed, 5 insertions(+), 11 deletions(-)
wai-app-static.cabal | 2 --
3 files changed, 4 insertions(+), 10 deletions(-)
diff --git a/Network/Wai/Application/Static.hs b/Network/Wai/Application/Static.hs
index f2fa743..1a82b30 100644
@ -55,7 +55,7 @@ index daa6e50..9873d4e 100644
-import WaiAppStatic.Storage.Embedded.TH
+--import WaiAppStatic.Storage.Embedded.TH
diff --git a/wai-app-static.cabal b/wai-app-static.cabal
index 5d81150..8f8c144 100644
index 925d350..d0086e8 100644
--- a/wai-app-static.cabal
+++ b/wai-app-static.cabal
@@ -33,7 +33,6 @@ library
@ -66,17 +66,14 @@ index 5d81150..8f8c144 100644
, 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
@@ -62,7 +61,6 @@ library
WaiAppStatic.CmdLine
other-modules: Util
WaiAppStatic.Storage.Embedded.Runtime
- WaiAppStatic.Storage.Embedded.TH
+ other-modules: Util
ghc-options: -Wall
extensions: CPP
--
1.8.5.1
2.0.0.rc2

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

@ -1,25 +1,25 @@
From be8d5895522da0397fd594d5553ed7d3641eb399 Mon Sep 17 00:00:00 2001
From 8dd61c7ea1b852957c74dc264004a6f7d70044a9 Mon Sep 17 00:00:00 2001
From: dummy <dummy@example.com>
Date: Fri, 7 Mar 2014 01:40:29 +0000
Date: Tue, 20 May 2014 21:39:04 +0000
Subject: [PATCH] remove and expand TH
fix Loc from MonadLogger
---
Yesod/Core.hs | 30 +++---
Yesod/Core/Class/Yesod.hs | 257 ++++++++++++++++++++++++++++++---------------
Yesod/Core/Dispatch.hs | 37 ++-----
Yesod/Core/Dispatch.hs | 38 ++-----
Yesod/Core/Handler.hs | 25 ++---
Yesod/Core/Internal/Run.hs | 8 +-
Yesod/Core/Internal/TH.hs | 111 --------------------
Yesod/Core/Types.hs | 3 +-
Yesod/Core/Widget.hs | 32 +-----
8 files changed, 215 insertions(+), 288 deletions(-)
8 files changed, 215 insertions(+), 289 deletions(-)
diff --git a/Yesod/Core.hs b/Yesod/Core.hs
index 12e59d5..2817a69 100644
index 9b29317..7c0792d 100644
--- a/Yesod/Core.hs
+++ b/Yesod/Core.hs
@@ -29,16 +29,16 @@ module Yesod.Core
@@ -31,16 +31,16 @@ module Yesod.Core
, unauthorizedI
-- * Logging
, LogLevel (..)
@ -46,7 +46,7 @@ index 12e59d5..2817a69 100644
-- * Sessions
, SessionBackend (..)
, customizeSessionCookies
@@ -85,17 +85,15 @@ module Yesod.Core
@@ -87,17 +87,15 @@ module Yesod.Core
, readIntegral
-- * Shakespeare
-- ** Hamlet
@ -409,7 +409,7 @@ index 140600b..75daabc 100644
- char = show . snd . loc_start
+fileLocationToString loc = "unknown"
diff --git a/Yesod/Core/Dispatch.hs b/Yesod/Core/Dispatch.hs
index e6f489d..3ff37c1 100644
index 59663a8..9408a95 100644
--- a/Yesod/Core/Dispatch.hs
+++ b/Yesod/Core/Dispatch.hs
@@ -1,4 +1,3 @@
@ -446,7 +446,7 @@ index e6f489d..3ff37c1 100644
, PathMultiPiece (..)
, Texts
-- * Convert to WAI
@@ -128,13 +127,6 @@ toWaiAppLogger logger site = do
@@ -130,13 +129,6 @@ toWaiAppLogger logger site = do
, yreSite = site
, yreSessionBackend = sb
}
@ -460,10 +460,11 @@ index e6f489d..3ff37c1 100644
middleware <- mkDefaultMiddlewares logger
return $ middleware $ toWaiAppYre yre
@@ -163,13 +155,7 @@ warp port site = do
@@ -165,14 +157,7 @@ warp port site = do
]
-}
, Network.Wai.Handler.Warp.settingsOnException = const $ \e ->
- when (shouldLog' e) $
- messageLoggerSource
- site
- logger
@ -471,11 +472,11 @@ index e6f489d..3ff37c1 100644
- "yesod-core"
- LevelError
- (toLogStr $ "Exception from Warp: " ++ show e)
+ error (show e)
+ when (shouldLog' e) $ error (show e)
}
-- | A default set of middlewares.
@@ -194,7 +180,6 @@ mkDefaultMiddlewares logger = do
where
shouldLog' =
@@ -206,7 +191,6 @@ defaultMiddlewaresNoLogging = acceptOverride . autohead . gzip def . methodOverr
-- | Deprecated synonym for 'warp'.
warpDebug :: YesodDispatch site => Int -> site -> IO ()
warpDebug = warp
@ -484,10 +485,10 @@ index e6f489d..3ff37c1 100644
-- | Runs your application using default middlewares (i.e., via 'toWaiApp'). It
-- reads port information from the PORT environment variable, as used by tools
diff --git a/Yesod/Core/Handler.hs b/Yesod/Core/Handler.hs
index 7c561c5..847d475 100644
index e5cbc44..d583607 100644
--- a/Yesod/Core/Handler.hs
+++ b/Yesod/Core/Handler.hs
@@ -164,7 +164,7 @@ import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
@@ -169,7 +169,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
@ -496,15 +497,15 @@ index 7c561c5..847d475 100644
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
@@ -550,6 +550,7 @@ sendFilePart ct fp off count = do
#else
handlerError $ HCSendFile ct fp $ Just $ W.FilePart off count
#endif
+import qualified Text.Blaze.Internal
get :: MonadHandler m => m GHState
get = liftHandlerT $ HandlerT $ I.readIORef . handlerState
@@ -748,19 +749,15 @@ redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
-- | Bypass remaining handler code and output the given content with a 200
-- status code.
@@ -806,19 +807,15 @@ redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
-> m a
redirectToPost url = do
urlText <- toTextUrl url
@ -534,11 +535,11 @@ index 7c561c5..847d475 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 10871a2..e8d1907 100644
index 3e2e4e0..b92eadb 100644
--- a/Yesod/Core/Internal/Run.hs
+++ b/Yesod/Core/Internal/Run.hs
@@ -15,8 +15,8 @@ import qualified Control.Exception as E
import Control.Exception.Lifted (catch)
@@ -16,8 +16,8 @@ import Control.Exception.Lifted (catch)
import Control.Monad (mplus)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Logger (LogLevel (LevelError), LogSource,
@ -548,7 +549,7 @@ index 10871a2..e8d1907 100644
import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState, createInternalState, closeInternalState)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
@@ -30,7 +30,7 @@ import qualified Data.Text as T
@@ -31,7 +31,7 @@ import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
@ -557,7 +558,7 @@ index 10871a2..e8d1907 100644
import qualified Network.HTTP.Types as H
import Network.Wai
#if MIN_VERSION_wai(2, 0, 0)
@@ -131,8 +131,6 @@ safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
@@ -157,8 +157,6 @@ safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> ErrorResponse
-> YesodApp
safeEh log' er req = do
@ -686,18 +687,18 @@ index 7e84c1c..a273c29 100644
- ]
- return $ LetE [fun] (VarE helper)
diff --git a/Yesod/Core/Types.hs b/Yesod/Core/Types.hs
index de09f78..9183a64 100644
index 7e3fd0d..994d322 100644
--- a/Yesod/Core/Types.hs
+++ b/Yesod/Core/Types.hs
@@ -17,6 +17,7 @@ import Control.Exception (Exception)
import Control.Monad (liftM, ap)
import Control.Monad.Base (MonadBase (liftBase))
@@ -21,6 +21,7 @@ import Control.Monad.Catch (MonadCatch (..))
import Control.Monad.Catch (MonadMask (..))
#endif
import Control.Monad.IO.Class (MonadIO (liftIO))
+import qualified Control.Monad.Logger
import Control.Monad.Logger (LogLevel, LogSource,
MonadLogger (..))
import Control.Monad.Trans.Control (MonadBaseControl (..))
@@ -179,7 +180,7 @@ data RunHandlerEnv site = RunHandlerEnv
@@ -187,7 +188,7 @@ data RunHandlerEnv site = RunHandlerEnv
, rheRoute :: !(Maybe (Route site))
, rheSite :: !site
, rheUpload :: !(RequestBodyLength -> FileUpload)
@ -707,7 +708,7 @@ index de09f78..9183a64 100644
-- ^ How to respond when an error is thrown internally.
--
diff --git a/Yesod/Core/Widget.hs b/Yesod/Core/Widget.hs
index a972efa..156cd45 100644
index 481199e..8489fbe 100644
--- a/Yesod/Core/Widget.hs
+++ b/Yesod/Core/Widget.hs
@@ -16,8 +16,8 @@ module Yesod.Core.Widget
@ -730,7 +731,7 @@ index a972efa..156cd45 100644
, asWidgetT
) where
@@ -189,35 +189,9 @@ addScriptRemote = flip addScriptRemoteAttrs []
@@ -207,35 +207,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
@ -767,5 +768,5 @@ index a972efa..156cd45 100644
ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)
=> HtmlUrlI18n message (Route (HandlerSite m))
--
1.9.0
2.0.0.rc2