diff options
Diffstat (limited to 'standalone/no-th')
29 files changed, 6876 insertions, 0 deletions
diff --git a/standalone/no-th/evilsplicer-headers.hs b/standalone/no-th/evilsplicer-headers.hs new file mode 100644 index 000000000..ef9e2603a --- /dev/null +++ b/standalone/no-th/evilsplicer-headers.hs @@ -0,0 +1,34 @@ + + +{- This file was modified by the EvilSplicer, adding these headers, + - and expanding Template Haskell. + - + - ** DO NOT COMMIT ** + -} +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 +import qualified Data.Text +import qualified Data.Text.Lazy.Builder +import qualified Text.Shakespeare +import qualified Text.Hamlet +import qualified Text.Julius +import qualified Text.Css +import qualified "blaze-markup" Text.Blaze.Internal +import qualified Yesod.Core.Widget +import qualified Yesod.Routes.TH.Types +import qualified Yesod.Routes.Dispatch +import qualified WaiAppStatic.Storage.Embedded +import qualified WaiAppStatic.Storage.Embedded.Runtime +import qualified Data.FileEmbed +import qualified Data.ByteString.Internal +import qualified Data.Text.Encoding +import qualified Network.Wai +import qualified 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/no-th/haskell-patches/persistent-template_stub-out.patch b/standalone/no-th/haskell-patches/persistent-template_stub-out.patch new file mode 100644 index 000000000..6b7b62bd4 --- /dev/null +++ b/standalone/no-th/haskell-patches/persistent-template_stub-out.patch @@ -0,0 +1,25 @@ +From 0b9df0de3aa45918a2a9226a2da6be4680276419 Mon Sep 17 00:00:00 2001 +From: foo <foo@bar> +Date: Sun, 22 Sep 2013 03:31:55 +0000 +Subject: [PATCH] stub out + +--- + persistent-template.cabal | 2 +- + 1 file changed, 1 insertion(+), 1 deletion(-) + +diff --git a/persistent-template.cabal b/persistent-template.cabal +index 8216ce7..f23234b 100644 +--- a/persistent-template.cabal ++++ b/persistent-template.cabal +@@ -23,7 +23,7 @@ library + , containers + , aeson + , monad-logger +- exposed-modules: Database.Persist.TH ++ exposed-modules: + ghc-options: -Wall + if impl(ghc >= 7.4) + cpp-options: -DGHC_7_4 +-- +1.7.10.4 + diff --git a/standalone/no-th/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 new file mode 100644 index 000000000..7a66e1fd1 --- /dev/null +++ b/standalone/no-th/haskell-patches/persistent_1.1.5.1_0001-disable-TH.patch @@ -0,0 +1,41 @@ +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 | 4 +--- + 1 file changed, 1 insertion(+), 3 deletions(-) + +diff --git a/Database/Persist/Sql/Raw.hs b/Database/Persist/Sql/Raw.hs +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] + rawQuery sql vals = do +- lift $ $logDebugS (pack "SQL") $ pack $ show sql ++ " " ++ show vals + conn <- lift askSqlConn + bracketP + (getStmtConn conn sql) +@@ -34,7 +33,6 @@ rawExecute x y = liftM (const ()) $ rawExecuteCount x y + + rawExecuteCount :: MonadSqlPersist m => Text -> [PersistValue] -> m Int64 + rawExecuteCount sql vals = do +- $logDebugS (pack "SQL") $ pack $ show sql ++ " " ++ show vals + stmt <- getStmt sql + res <- liftIO $ stmtExecute stmt vals + liftIO $ stmtReset stmt +-- +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/no-th/haskell-patches/profunctors_3.3-0001-fix-cross-build.patch b/standalone/no-th/haskell-patches/profunctors_3.3-0001-fix-cross-build.patch new file mode 100644 index 000000000..45397f3e5 --- /dev/null +++ b/standalone/no-th/haskell-patches/profunctors_3.3-0001-fix-cross-build.patch @@ -0,0 +1,26 @@ +From 392602f5ff14c0b5a801397d075ddcbcd890aa83 Mon Sep 17 00:00:00 2001 +From: Joey Hess <joey@kitenet.net> +Date: Thu, 18 Apr 2013 17:50:59 -0400 +Subject: [PATCH] fix cross build + +--- + src/Data/Profunctor/Unsafe.hs | 3 --- + 1 file changed, 3 deletions(-) + +diff --git a/src/Data/Profunctor/Unsafe.hs b/src/Data/Profunctor/Unsafe.hs +index 025c7c4..0249274 100644 +--- a/src/Data/Profunctor/Unsafe.hs ++++ b/src/Data/Profunctor/Unsafe.hs +@@ -40,9 +40,6 @@ import Data.Tagged + import Prelude hiding (id,(.),sequence) + import Unsafe.Coerce + +-{-# ANN module "Hlint: ignore Redundant lambda" #-} +-{-# ANN module "Hlint: ignore Collapse lambdas" #-} +- + infixr 9 #. + infixl 8 .# + +-- +1.8.2.rc3 + 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/no-th/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 new file mode 100644 index 000000000..5bf57d527 --- /dev/null +++ b/standalone/no-th/haskell-patches/shakespeare-css_1.0.2_0002-expose-modules-used-by-TH.patch @@ -0,0 +1,26 @@ +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 + 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/no-th/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 new file mode 100644 index 000000000..51443b5d4 --- /dev/null +++ b/standalone/no-th/haskell-patches/shakespeare_1.0.3_0001-export-symbol-used-by-TH-splices.patch @@ -0,0 +1,26 @@ +From 4a75a2f0d77168aa3115b991284a5120484e18f0 Mon Sep 17 00:00:00 2001 +From: foo <foo@bar> +Date: Sun, 22 Sep 2013 04:59:21 +0000 +Subject: [PATCH] TH exports + +--- + Text/Shakespeare.hs | 3 +++ + 1 file changed, 3 insertions(+) + +diff --git a/Text/Shakespeare.hs b/Text/Shakespeare.hs +index 9eb06a2..1290ab1 100644 +--- a/Text/Shakespeare.hs ++++ b/Text/Shakespeare.hs +@@ -23,6 +23,9 @@ module Text.Shakespeare + , Deref + , Parser + ++ -- used by TH ++ , pack' ++ + #ifdef TEST_EXPORT + , preFilter + #endif +-- +1.7.10.4 + 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/no-th/haskell-patches/wai-app-static_deal-with-TH.patch b/standalone/no-th/haskell-patches/wai-app-static_deal-with-TH.patch new file mode 100644 index 000000000..b9f4283ca --- /dev/null +++ b/standalone/no-th/haskell-patches/wai-app-static_deal-with-TH.patch @@ -0,0 +1,82 @@ +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 + +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 ---- + 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 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) + + import Blaze.ByteString.Builder (toByteString) + +-import Data.FileEmbed (embedFile) +- + import Data.Text (Text) + import qualified Data.Text as T + +@@ -198,8 +196,6 @@ staticAppPieces _ _ req + H.status405 + [("Content-Type", "text/plain")] + "Only GET is supported" +-staticAppPieces _ [".hidden", "folder.png"] _ = return $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/folder.png")] +-staticAppPieces _ [".hidden", "haskell.png"] _ = return $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/haskell.png")] + 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 5d81150..8f8c144 100644 +--- a/wai-app-static.cabal ++++ b/wai-app-static.cabal +@@ -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 ++ other-modules: Util + ghc-options: -Wall + extensions: CPP + +-- +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/no-th/haskell-patches/yesod-auth_don-t-really-build.patch b/standalone/no-th/haskell-patches/yesod-auth_don-t-really-build.patch new file mode 100644 index 000000000..7016e001c --- /dev/null +++ b/standalone/no-th/haskell-patches/yesod-auth_don-t-really-build.patch @@ -0,0 +1,34 @@ +From 3eb7b0a42099721dc19363ac41319efeed4ac5f9 Mon Sep 17 00:00:00 2001 +From: foo <foo@bar> +Date: Sun, 22 Sep 2013 05:19:53 +0000 +Subject: [PATCH] don't really build + +--- + yesod-auth.cabal | 11 +---------- + 1 file changed, 1 insertion(+), 10 deletions(-) + +diff --git a/yesod-auth.cabal b/yesod-auth.cabal +index 591ced5..11217be 100644 +--- a/yesod-auth.cabal ++++ b/yesod-auth.cabal +@@ -52,16 +52,7 @@ library + , safe + , time + +- exposed-modules: Yesod.Auth +- Yesod.Auth.BrowserId +- Yesod.Auth.Dummy +- Yesod.Auth.Email +- Yesod.Auth.OpenId +- Yesod.Auth.Rpxnow +- Yesod.Auth.HashDB +- Yesod.Auth.Message +- Yesod.Auth.GoogleEmail +- other-modules: Yesod.Auth.Routes ++ exposed-modules: + ghc-options: -Wall + + source-repository head +-- +1.7.10.4 + diff --git a/standalone/no-th/haskell-patches/yesod-core_expand_TH.patch b/standalone/no-th/haskell-patches/yesod-core_expand_TH.patch new file mode 100644 index 000000000..d5596395a --- /dev/null +++ b/standalone/no-th/haskell-patches/yesod-core_expand_TH.patch @@ -0,0 +1,684 @@ +From 08cc43788c16fb91f63bc0bd520eeccdcdab477a Mon Sep 17 00:00:00 2001 +From: dummy <dummy@example.com> +Date: Tue, 17 Dec 2013 17:15:33 +0000 +Subject: [PATCH] remove and expand TH + +--- + 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..2817a69 100644 +--- a/Yesod/Core.hs ++++ b/Yesod/Core.hs +@@ -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 +- , cassius +- , lucius + , CssUrl + , renderCssUrl + ) where +diff --git a/Yesod/Core/Class/Yesod.hs b/Yesod/Core/Class/Yesod.hs +index a64d6eb..5dffbfa 100644 +--- a/Yesod/Core/Class/Yesod.hs ++++ b/Yesod/Core/Class/Yesod.hs +@@ -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 ++import qualified Text.Blaze.Internal ++import qualified Control.Monad.Logger ++import qualified Text.Hamlet ++import qualified Data.Foldable + + import Blaze.ByteString.Builder (Builder) + import Blaze.ByteString.Builder.Char.Utf8 (fromText) +@@ -94,18 +98,27 @@ class RenderRoute site => Yesod site where + defaultLayout w = do + p <- widgetToPageContent w + mmsg <- getMessage +- giveUrlRenderer [hamlet| +- $newline never +- $doctype 5 +- <html> +- <head> +- <title>#{pageTitle p} +- ^{pageHead p} +- <body> +- $maybe msg <- mmsg +- <p .message>#{msg} +- ^{pageBody p} +- |] ++ giveUrlRenderer $ \ _render_aHra ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "<!DOCTYPE html>\n<html><head><title>"); ++ id (TBH.toHtml (pageTitle p)); ++ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</title>"); ++ Text.Hamlet.asHtmlUrl (pageHead p) _render_aHra; ++ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</head><body>"); ++ Text.Hamlet.maybeH ++ mmsg ++ (\ msg_aHrb ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "<p class=\"message\">"); ++ id (TBH.toHtml msg_aHrb); ++ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</p>") }) ++ Nothing; ++ Text.Hamlet.asHtmlUrl (pageBody p) _render_aHra; ++ id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) "</body></html>") } ++ + + -- | Override the rendering function for a particular URL. One use case for + -- this is to offload static hosting to a different domain name to avoid +@@ -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 +- regularScriptLoad = [hamlet| +- $newline never +- $forall s <- scripts +- ^{mkScriptTag s} +- $maybe j <- jscript +- $maybe s <- jsLoc +- <script src="#{s}"> +- $nothing +- <script>^{jelper j} +- |] +- +- headAll = [hamlet| +- $newline never +- \^{head'} +- $forall s <- stylesheets +- ^{mkLinkTag s} +- $forall s <- css +- $maybe t <- right $ snd s +- $maybe media <- fst s +- <link rel=stylesheet media=#{media} href=#{t}> +- $nothing +- <link rel=stylesheet href=#{t}> +- $maybe content <- left $ snd s +- $maybe media <- fst s +- <style media=#{media}>#{content} +- $nothing +- <style>#{content} +- $case jsLoader master +- $of BottomOfBody +- $of BottomOfHeadAsync asyncJsLoader +- ^{asyncJsLoader asyncScripts mcomplete} +- $of BottomOfHeadBlocking +- ^{regularScriptLoad} +- |] +- let bodyScript = [hamlet| +- $newline never +- ^{body} +- ^{regularScriptLoad} +- |] ++ regularScriptLoad = \ _render_aHsO ++ -> do { Data.Foldable.mapM_ ++ (\ s_aHsP ++ -> Text.Hamlet.asHtmlUrl (mkScriptTag s_aHsP) _render_aHsO) ++ scripts; ++ Text.Hamlet.maybeH ++ jscript ++ (\ j_aHsQ ++ -> Text.Hamlet.maybeH ++ jsLoc ++ (\ s_aHsR ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "<script src=\""); ++ id (TBH.toHtml s_aHsR); ++ id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "\"></script>") }) ++ (Just ++ (do { id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) "<script>"); ++ Text.Hamlet.asHtmlUrl (jelper j_aHsQ) _render_aHsO; ++ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</script>") }))) ++ Nothing } ++ ++ ++ headAll = \ _render_aHsW ++ -> do { Text.Hamlet.asHtmlUrl head' _render_aHsW; ++ Data.Foldable.mapM_ ++ (\ s_aHsX -> Text.Hamlet.asHtmlUrl (mkLinkTag s_aHsX) _render_aHsW) ++ stylesheets; ++ Data.Foldable.mapM_ ++ (\ s_aHsY ++ -> do { Text.Hamlet.maybeH ++ (right (snd s_aHsY)) ++ (\ t_aHsZ ++ -> Text.Hamlet.maybeH ++ (fst s_aHsY) ++ (\ media_aHt0 ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "<link rel=\"stylesheet\" media=\""); ++ id (TBH.toHtml media_aHt0); ++ id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "\" href=\""); ++ id (TBH.toHtml t_aHsZ); ++ id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "\">") }) ++ (Just ++ (do { id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "<link rel=\"stylesheet\" href=\""); ++ id (TBH.toHtml t_aHsZ); ++ id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "\">") }))) ++ Nothing; ++ Text.Hamlet.maybeH ++ (left (snd s_aHsY)) ++ (\ content_aHt1 ++ -> Text.Hamlet.maybeH ++ (fst s_aHsY) ++ (\ media_aHt2 ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "<style media=\""); ++ id (TBH.toHtml media_aHt2); ++ id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "\">"); ++ id (TBH.toHtml content_aHt1); ++ id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "</style>") }) ++ (Just ++ (do { id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "<style>"); ++ id (TBH.toHtml content_aHt1); ++ id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "</style>") }))) ++ Nothing }) ++ css; ++ case jsLoader master of { ++ BottomOfBody -> return () ++ ; BottomOfHeadAsync asyncJsLoader_aHt3 ++ -> Text.Hamlet.asHtmlUrl ++ (asyncJsLoader_aHt3 asyncScripts mcomplete) _render_aHsW ++ ; BottomOfHeadBlocking ++ -> Text.Hamlet.asHtmlUrl regularScriptLoad _render_aHsW } } ++ ++ let bodyScript = \ _render_aHt8 -> do { Text.Hamlet.asHtmlUrl body _render_aHt8; ++ Text.Hamlet.asHtmlUrl regularScriptLoad _render_aHt8 } ++ + + return $ PageContent title headAll $ + case jsLoader master of +@@ -438,10 +509,13 @@ defaultErrorHandler NotFound = selectRep $ do + r <- waiRequest + let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r + setTitle "Not Found" +- toWidget [hamlet| +- <h1>Not Found +- <p>#{path'} +- |] ++ toWidget $ \ _render_aHte ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "<h1>Not Found</h1>\n<p>"); ++ id (TBH.toHtml path'); ++ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</p>") } ++ + provideRep $ return $ object ["message" .= ("Not Found" :: Text)] + + -- For API requests. +@@ -451,10 +525,11 @@ defaultErrorHandler NotFound = selectRep $ do + defaultErrorHandler NotAuthenticated = selectRep $ do + provideRep $ defaultLayout $ do + setTitle "Not logged in" +- toWidget [hamlet| +- <h1>Not logged in +- <p style="display:none;">Set the authRoute and the user will be redirected there. +- |] ++ toWidget $ \ _render_aHti ++ -> id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "<h1>Not logged in</h1>\n<p style=\"none;\">Set the authRoute and the user will be redirected there.</p>") ++ + + provideRep $ do + -- 401 *MUST* include a WWW-Authenticate header +@@ -476,10 +551,13 @@ defaultErrorHandler NotAuthenticated = selectRep $ do + defaultErrorHandler (PermissionDenied msg) = selectRep $ do + provideRep $ defaultLayout $ do + setTitle "Permission Denied" +- toWidget [hamlet| +- <h1>Permission denied +- <p>#{msg} +- |] ++ toWidget $ \ _render_aHtq ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "<h1>Permission denied</h1>\n<p>"); ++ id (TBH.toHtml msg); ++ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</p>") } ++ + provideRep $ + return $ object $ [ + "message" .= ("Permission Denied. " <> msg) +@@ -488,30 +566,43 @@ defaultErrorHandler (PermissionDenied msg) = selectRep $ do + defaultErrorHandler (InvalidArgs ia) = selectRep $ do + provideRep $ defaultLayout $ do + setTitle "Invalid Arguments" +- toWidget [hamlet| +- <h1>Invalid Arguments +- <ul> +- $forall msg <- ia +- <li>#{msg} +- |] ++ toWidget $ \ _render_aHtv ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "<h1>Invalid Arguments</h1>\n<ul>"); ++ Data.Foldable.mapM_ ++ (\ msg_aHtw ++ -> do { id ((Text.Blaze.Internal.preEscapedText . T.pack) "<li>"); ++ id (TBH.toHtml msg_aHtw); ++ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</li>") }) ++ ia; ++ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</ul>") } ++ + provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia] + defaultErrorHandler (InternalError e) = do +- $logErrorS "yesod-core" e + selectRep $ do + provideRep $ defaultLayout $ do + setTitle "Internal Server Error" +- toWidget [hamlet| +- <h1>Internal Server Error +- <pre>#{e} +- |] ++ toWidget $ \ _render_aHtC ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "<h1>Internal Server Error</h1>\n<pre>"); ++ id (TBH.toHtml e); ++ id ((Text.Blaze.Internal.preEscapedText . T.pack) "</pre>") } ++ + provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e] + defaultErrorHandler (BadMethod m) = selectRep $ do + provideRep $ defaultLayout $ do + setTitle"Bad Method" +- toWidget [hamlet| +- <h1>Method Not Supported +- <p>Method <code>#{S8.unpack m}</code> not supported +- |] ++ toWidget $ \ _render_aHtH ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "<h1>Method Not Supported</h1>\n<p>Method <code>"); ++ id (TBH.toHtml (S8.unpack m)); ++ id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "</code> not supported</p>") } ++ + provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= m] + + asyncHelper :: (url -> [x] -> Text) +diff --git a/Yesod/Core/Dispatch.hs b/Yesod/Core/Dispatch.hs +index df822e2..5583495 100644 +--- a/Yesod/Core/Dispatch.hs ++++ b/Yesod/Core/Dispatch.hs +@@ -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 + } +- messageLoggerSource +- site +- logger +- $(qLocation >>= liftLoc) +- "yesod-core" +- LevelInfo +- (toLogStr ("Application launched" :: S.ByteString)) + middleware <- mkDefaultMiddlewares logger + return $ middleware $ toWaiAppYre yre + +diff --git a/Yesod/Core/Handler.hs b/Yesod/Core/Handler.hs +index 3581dbc..908256e 100644 +--- a/Yesod/Core/Handler.hs ++++ b/Yesod/Core/Handler.hs +@@ -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 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 + + 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 +- giveUrlRenderer [hamlet| +-$newline never +-$doctype 5 +- +-<html> +- <head> +- <title>Redirecting... +- <body onload="document.getElementById('form').submit()"> +- <form id="form" method="post" action=#{urlText}> +- <noscript> +- <p>Javascript has been disabled; please click on the button below to be redirected. +- <input type="submit" value="Continue"> +-|] >>= sendResponse ++ giveUrlRenderer $ \ _render_awps ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "<!DOCTYPE html>\n<html><head><title>Redirecting...</title></head><body onload=\"document.getElementById('form').submit()\"><form id=\"form\" method=\"post\" action=\""); ++ id (toHtml urlText); ++ id ++ ((Text.Blaze.Internal.preEscapedText . T.pack) ++ "\"><noscript><p>Javascript has been disabled; please click on the button below to be redirected.</p></noscript><input type=\"submit\" value=\"Continue\"></form></body></html>") } ++ >>= sendResponse + + -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. + hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html +diff --git a/Yesod/Core/Internal/Run.hs b/Yesod/Core/Internal/Run.hs +index 25f51f1..d04d2cd 100644 +--- a/Yesod/Core/Internal/Run.hs ++++ b/Yesod/Core/Internal/Run.hs +@@ -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 +- liftIO $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError +- $ toLogStr $ "Error handler errored out: " ++ show er + 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.8.5.1 + diff --git a/standalone/no-th/haskell-patches/yesod-form_spliced-TH.patch b/standalone/no-th/haskell-patches/yesod-form_spliced-TH.patch new file mode 100644 index 000000000..0a82434ea --- /dev/null +++ b/standalone/no-th/haskell-patches/yesod-form_spliced-TH.patch @@ -0,0 +1,1805 @@ +From fbd8f048c239e34625e438a24213534f6f68c3e8 Mon Sep 17 00:00:00 2001 +From: dummy <dummy@example.com> +Date: Tue, 17 Dec 2013 18:34:25 +0000 +Subject: [PATCH] spliced TH + +--- + 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 b2a47c6..016c98b 100644 +--- a/Yesod/Form/Fields.hs ++++ b/Yesod/Form/Fields.hs +@@ -1,4 +1,3 @@ +-{-# LANGUAGE QuasiQuotes #-} + {-# LANGUAGE TypeFamilies #-} + {-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE GeneralizedNewtypeDeriving #-} +@@ -36,15 +35,11 @@ module Yesod.Form.Fields + , selectFieldList + , radioField + , radioFieldList +- , checkboxesFieldList +- , checkboxesField + , multiSelectField + , multiSelectFieldList + , Option (..) + , OptionList (..) + , mkOptionList +- , optionsPersist +- , optionsPersistKey + , optionsPairs + , optionsEnum + ) where +@@ -70,6 +65,15 @@ import Text.HTML.SanitizeXSS (sanitizeBalance) + import Control.Monad (when, unless) + import Data.Maybe (listToMaybe, fromMaybe) + ++import qualified Text.Blaze as Text.Blaze.Internal ++import qualified Text.Blaze.Internal ++import qualified Text.Hamlet ++import qualified Yesod.Core.Widget ++import qualified Text.Css ++import qualified Data.Monoid ++import qualified Data.Foldable ++import qualified Control.Monad ++ + import qualified Blaze.ByteString.Builder.Html.Utf8 as B + import Blaze.ByteString.Builder (writeByteString, toLazyByteString) + import Blaze.ByteString.Builder.Internal.Write (fromWriteList) +@@ -82,14 +86,12 @@ import Data.Text (Text, unpack, pack) + import qualified Data.Text.Read + + import qualified Data.Map as Map +-import Yesod.Persist (selectList, runDB, Filter, SelectOpt, Key, YesodPersist, PersistEntity, PersistQuery, YesodDB) + import Control.Arrow ((&&&)) + + import Control.Applicative ((<$>), (<|>)) + + import Data.Attoparsec.Text (Parser, char, string, digit, skipSpace, endOfInput, parseOnly) + +-import Yesod.Persist.Core + + defaultFormMessage :: FormMessage -> Text + defaultFormMessage = englishFormMessage +@@ -102,10 +104,24 @@ intField = Field + Right (a, "") -> Right a + _ -> Left $ MsgInvalidInteger s + +- , fieldView = \theId name attrs val isReq -> toWidget [hamlet| +-$newline never +-<input id="#{theId}" name="#{name}" *{attrs} type="number" :isReq:required="" value="#{showVal val}"> +-|] ++ , fieldView = \theId name attrs val isReq -> toWidget $ \ _render_arOn ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\""); ++ id (toHtml theId); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ id (toHtml name); ++ id ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"number\""); ++ Text.Hamlet.condH ++ [(isReq, ++ id ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))] ++ Nothing; ++ id ((Text.Blaze.Internal.preEscapedText . pack) " value=\""); ++ id (toHtml (showVal val)); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ id ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ id ((Text.Blaze.Internal.preEscapedText . pack) ">") } ++ + , fieldEnctype = UrlEncoded + } + where +@@ -119,10 +135,24 @@ doubleField = Field + Right (a, "") -> Right a + _ -> Left $ MsgInvalidNumber s + +- , fieldView = \theId name attrs val isReq -> toWidget [hamlet| +-$newline never +-<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{showVal val}"> +-|] ++ , fieldView = \theId name attrs val isReq -> toWidget $ \ _render_arOz ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\""); ++ id (toHtml theId); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ id (toHtml name); ++ id ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"text\""); ++ Text.Hamlet.condH ++ [(isReq, ++ id ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))] ++ Nothing; ++ id ((Text.Blaze.Internal.preEscapedText . pack) " value=\""); ++ id (toHtml (showVal val)); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ id ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ id ((Text.Blaze.Internal.preEscapedText . pack) ">") } ++ + , fieldEnctype = UrlEncoded + } + where showVal = either id (pack . show) +@@ -130,10 +160,24 @@ $newline never + dayField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Day + dayField = Field + { fieldParse = parseHelper $ parseDate . unpack +- , fieldView = \theId name attrs val isReq -> toWidget [hamlet| +-$newline never +-<input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}"> +-|] ++ , fieldView = \theId name attrs val isReq -> toWidget $ \ _render_arOJ ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\""); ++ id (toHtml theId); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ id (toHtml name); ++ id ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"date\""); ++ Text.Hamlet.condH ++ [(isReq, ++ id ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))] ++ Nothing; ++ id ((Text.Blaze.Internal.preEscapedText . pack) " value=\""); ++ id (toHtml (showVal val)); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ id ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ id ((Text.Blaze.Internal.preEscapedText . pack) ">") } ++ + , fieldEnctype = UrlEncoded + } + where showVal = either id (pack . show) +@@ -141,10 +185,23 @@ $newline never + timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay + timeField = Field + { fieldParse = parseHelper parseTime +- , fieldView = \theId name attrs val isReq -> toWidget [hamlet| +-$newline never +-<input id="#{theId}" name="#{name}" *{attrs} :isReq:required="" value="#{showVal val}"> +-|] ++ , fieldView = \theId name attrs val isReq -> toWidget $ \ _render_arOW ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\""); ++ id (toHtml theId); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ id (toHtml name); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ Text.Hamlet.condH ++ [(isReq, ++ id ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))] ++ Nothing; ++ id ((Text.Blaze.Internal.preEscapedText . pack) " value=\""); ++ id (toHtml (showVal val)); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ id ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ id ((Text.Blaze.Internal.preEscapedText . pack) ">") } ++ + , fieldEnctype = UrlEncoded + } + where +@@ -157,10 +214,18 @@ $newline never + htmlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Html + htmlField = Field + { fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance +- , fieldView = \theId name attrs val _isReq -> toWidget [hamlet| +-$newline never +-<textarea id="#{theId}" name="#{name}" *{attrs}>#{showVal val} +-|] ++ , fieldView = \theId name attrs val _isReq -> toWidget $ \ _render_arP6 ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . pack) "<textarea id=\""); ++ id (toHtml theId); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ id (toHtml name); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ id ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ id ((Text.Blaze.Internal.preEscapedText . pack) ">"); ++ id (toHtml (showVal val)); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "</textarea>") } ++ + , fieldEnctype = UrlEncoded + } + where showVal = either id (pack . renderHtml) +@@ -169,8 +234,6 @@ $newline never + -- br-tags. + newtype Textarea = Textarea { unTextarea :: Text } + deriving (Show, Read, Eq, PersistField, Ord) +-instance PersistFieldSql Textarea where +- sqlType _ = SqlString + instance ToHtml Textarea where + toHtml = + unsafeByteString +@@ -188,10 +251,18 @@ instance ToHtml Textarea where + textareaField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Textarea + textareaField = Field + { fieldParse = parseHelper $ Right . Textarea +- , fieldView = \theId name attrs val _isReq -> toWidget [hamlet| +-$newline never +-<textarea id="#{theId}" name="#{name}" *{attrs}>#{either id unTextarea val} +-|] ++ , fieldView = \theId name attrs val _isReq -> toWidget $ \ _render_arPf ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . pack) "<textarea id=\""); ++ id (toHtml theId); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ id (toHtml name); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ id ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ id ((Text.Blaze.Internal.preEscapedText . pack) ">"); ++ id (toHtml (either id unTextarea val)); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "</textarea>") } ++ + , fieldEnctype = UrlEncoded + } + +@@ -199,10 +270,19 @@ hiddenField :: (Monad m, PathPiece p, RenderMessage (HandlerSite m) FormMessage) + => Field m p + hiddenField = Field + { fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece +- , fieldView = \theId name attrs val _isReq -> toWidget [hamlet| +-$newline never +-<input type="hidden" id="#{theId}" name="#{name}" *{attrs} value="#{either id toPathPiece val}"> +-|] ++ , fieldView = \theId name attrs val _isReq -> toWidget $ \ _render_arPo ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<input type=\"hidden\" id=\""); ++ id (toHtml theId); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ id (toHtml name); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\" value=\""); ++ id (toHtml (either id toPathPiece val)); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ id ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ id ((Text.Blaze.Internal.preEscapedText . pack) ">") } ++ + , fieldEnctype = UrlEncoded + } + +@@ -210,20 +290,55 @@ textField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Tex + textField = Field + { fieldParse = parseHelper $ Right + , fieldView = \theId name attrs val isReq -> +- [whamlet| +-$newline never +-<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required value="#{either id id val}"> +-|] ++ do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml name); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"text\""); ++ Text.Hamlet.condH ++ [(isReq, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " required"))] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " value=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ (toHtml (either id id val)); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ">") } ++ + , fieldEnctype = UrlEncoded + } + + passwordField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text + passwordField = Field + { fieldParse = parseHelper $ Right +- , fieldView = \theId name attrs val isReq -> toWidget [hamlet| +-$newline never +-<input id="#{theId}" name="#{name}" *{attrs} type="password" :isReq:required="" value="#{either id id val}"> +-|] ++ , fieldView = \theId name attrs val isReq -> toWidget $ \ _render_arPF ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\""); ++ id (toHtml theId); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ id (toHtml name); ++ id ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "\" type=\"password\""); ++ Text.Hamlet.condH ++ [(isReq, ++ id ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))] ++ Nothing; ++ id ((Text.Blaze.Internal.preEscapedText . pack) " value=\""); ++ id (toHtml (either id id val)); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ id ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ id ((Text.Blaze.Internal.preEscapedText . pack) ">") } ++ + , fieldEnctype = UrlEncoded + } + +@@ -295,10 +410,24 @@ emailField = Field + case Email.canonicalizeEmail $ encodeUtf8 s of + Just e -> Right $ decodeUtf8With lenientDecode e + Nothing -> Left $ MsgInvalidEmail s +- , fieldView = \theId name attrs val isReq -> toWidget [hamlet| +-$newline never +-<input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{either id id val}"> +-|] ++ , fieldView = \theId name attrs val isReq -> toWidget $ \ _render_arQe ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\""); ++ id (toHtml theId); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ id (toHtml name); ++ id ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"email\""); ++ Text.Hamlet.condH ++ [(isReq, ++ id ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))] ++ Nothing; ++ id ((Text.Blaze.Internal.preEscapedText . pack) " value=\""); ++ id (toHtml (either id id val)); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ id ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ id ((Text.Blaze.Internal.preEscapedText . pack) ">") } ++ + , fieldEnctype = UrlEncoded + } + +@@ -307,20 +436,78 @@ searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus + searchField autoFocus = Field + { fieldParse = parseHelper Right + , fieldView = \theId name attrs val isReq -> do +- [whamlet|\ +-$newline never +-<input id="#{theId}" name="#{name}" *{attrs} type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}"> +-|] ++ do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml name); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"search\""); ++ Text.Hamlet.condH ++ [(isReq, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))] ++ Nothing; ++ Text.Hamlet.condH ++ [(autoFocus, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " autofocus=\"\""))] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " value=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ (toHtml (either id id val)); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ">") } ++ + when autoFocus $ do + -- we want this javascript to be placed immediately after the field +- [whamlet| +-$newline never +-<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();} +-|] +- toWidget [cassius| +- ##{theId} +- -webkit-appearance: textfield +- |] ++ do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "').focus();}</script>") } ++ ++ toWidget $ \ _render_arQv ++ -> (Text.Css.CssNoWhitespace ++ . (foldr ($) [])) ++ [((++) ++ $ (map ++ Text.Css.TopBlock ++ (((Text.Css.Block ++ {Text.Css.blockSelector = Data.Monoid.mconcat ++ [(Text.Css.fromText ++ . Text.Css.pack) ++ "#", ++ toCss theId], ++ Text.Css.blockAttrs = (concat ++ $ ([Text.Css.Attr ++ (Data.Monoid.mconcat ++ [(Text.Css.fromText ++ . Text.Css.pack) ++ "-webkit-appearance"]) ++ (Data.Monoid.mconcat ++ [(Text.Css.fromText ++ . Text.Css.pack) ++ "textfield"])] ++ : ++ (map ++ Text.Css.mixinAttrs ++ []))), ++ Text.Css.blockBlocks = (), ++ Text.Css.blockMixins = ()} ++ :) ++ . ((foldr (.) id []) ++ . (concatMap Text.Css.mixinBlocks [] ++))) ++ [])))] ++ + , fieldEnctype = UrlEncoded + } + +@@ -331,7 +518,30 @@ urlField = Field + Nothing -> Left $ MsgInvalidUrl s + Just _ -> Right s + , fieldView = \theId name attrs val isReq -> +- [whamlet|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id id val}>|] ++ do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml name); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"url\""); ++ Text.Hamlet.condH ++ [(isReq, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " required"))] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " value=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ (toHtml (either id id val)); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ">") } ++ + , fieldEnctype = UrlEncoded + } + +@@ -344,18 +554,56 @@ selectField :: (Eq a, RenderMessage site FormMessage) + => HandlerT site IO (OptionList a) + -> Field (HandlerT site IO) a + selectField = selectFieldHelper +- (\theId name attrs inside -> [whamlet| +-$newline never +-<select ##{theId} name=#{name} *{attrs}>^{inside} +-|]) -- outside +- (\_theId _name isSel -> [whamlet| +-$newline never +-<option value=none :isSel:selected>_{MsgSelectNone} +-|]) -- onOpt +- (\_theId _name _attrs value isSel text -> [whamlet| +-$newline never +-<option value=#{value} :isSel:selected>#{text} +-|]) -- inside ++ (\theId name attrs inside -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "<select id=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml name); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) inside; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</select>") }) ++ -- outside ++ (\_theId _name isSel -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<option value=\"none\""); ++ Text.Hamlet.condH ++ [(isSel, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " selected"))] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ">"); ++ ((Control.Monad.liftM (toHtml .) getMessageRender) ++ >>= ++ (\ urender_arQS ++ -> (Yesod.Core.Widget.asWidgetT . toWidget) ++ (urender_arQS MsgSelectNone))); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</option>") }) ++ -- onOpt ++ (\_theId _name _attrs value isSel text -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "<option value=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml value); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ Text.Hamlet.condH ++ [(isSel, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " selected"))] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml text); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</option>") }) ++ -- inside + + multiSelectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) + => [(msg, a)] +@@ -378,11 +626,48 @@ multiSelectField ioptlist = + view theId name attrs val isReq = do + opts <- fmap olOptions $ handlerToWidget ioptlist + let selOpts = map (id &&& (optselected val)) opts +- [whamlet| +- <select ##{theId} name=#{name} :isReq:required multiple *{attrs}> +- $forall (opt, optsel) <- selOpts +- <option value=#{optionExternalValue opt} :optsel:selected>#{optionDisplay opt} +- |] ++ do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "<select id=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml name); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ Text.Hamlet.condH ++ [(isReq, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " required"))] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " multiple"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ">"); ++ Data.Foldable.mapM_ ++ (\ (opt_arRl, optsel_arRm) ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "<option value=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ (toHtml (optionExternalValue opt_arRl)); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ Text.Hamlet.condH ++ [(optsel_arRm, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " selected"))] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ (toHtml (optionDisplay opt_arRl)); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</option>") }) ++ selOpts; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</select>") } ++ + where + optselected (Left _) _ = False + optselected (Right vals) opt = (optionInternalValue opt) `elem` vals +@@ -392,67 +677,172 @@ radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) + -> Field (HandlerT site IO) a + radioFieldList = radioField . optionsPairs + +-checkboxesFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) => [(msg, a)] +- -> Field (HandlerT site IO) [a] +-checkboxesFieldList = checkboxesField . optionsPairs +- +-checkboxesField :: (Eq a, RenderMessage site FormMessage) +- => HandlerT site IO (OptionList a) +- -> Field (HandlerT site IO) [a] +-checkboxesField ioptlist = (multiSelectField ioptlist) +- { fieldView = +- \theId name attrs val isReq -> do +- opts <- fmap olOptions $ handlerToWidget ioptlist +- let optselected (Left _) _ = False +- optselected (Right vals) opt = (optionInternalValue opt) `elem` vals +- [whamlet| +- <span ##{theId}> +- $forall opt <- opts +- <label> +- <input type=checkbox name=#{name} value=#{optionExternalValue opt} *{attrs} :optselected val opt:checked> +- #{optionDisplay opt} +- |] +- } + + radioField :: (Eq a, RenderMessage site FormMessage) + => HandlerT site IO (OptionList a) + -> Field (HandlerT site IO) a + radioField = selectFieldHelper +- (\theId _name _attrs inside -> [whamlet| +-$newline never +-<div ##{theId}>^{inside} +-|]) +- (\theId name isSel -> [whamlet| +-$newline never +-<label .radio for=#{theId}-none> +- <div> +- <input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked> +- _{MsgSelectNone} +-|]) +- (\theId name attrs value isSel text -> [whamlet| +-$newline never +-<label .radio for=#{theId}-#{value}> +- <div> +- <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}> +- \#{text} +-|]) ++ (\theId _name _attrs inside -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "<div id=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) inside; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</div>") }) ++ ++ (\theId name isSel -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<label class=\"radio\" for=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "-none\"><div><input id=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "-none\" type=\"radio\" name=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml name); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" value=\"none\""); ++ Text.Hamlet.condH ++ [(isSel, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " checked"))] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ">"); ++ ((Control.Monad.liftM (toHtml .) getMessageRender) ++ >>= ++ (\ urender_arRA ++ -> (Yesod.Core.Widget.asWidgetT . toWidget) ++ (urender_arRA MsgSelectNone))); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</div></label>") }) ++ ++ (\theId name attrs value isSel text -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<label class=\"radio\" for=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "-"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml value); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "\"><div><input id=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "-"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml value); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "\" type=\"radio\" name=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml name); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" value=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml value); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ Text.Hamlet.condH ++ [(isSel, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " checked"))] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml text); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</div></label>") }) ++ + + boolField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool + boolField = Field + { fieldParse = \e _ -> return $ boolParser e +- , fieldView = \theId name attrs val isReq -> [whamlet| +-$newline never +- $if not isReq +- <input id=#{theId}-none *{attrs} type=radio name=#{name} value=none checked> +- <label for=#{theId}-none>_{MsgSelectNone} ++ , fieldView = \theId name attrs val isReq -> do { Text.Hamlet.condH ++ [(not isReq, ++ do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "-none\" type=\"radio\" name=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml name); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "\" value=\"none\" checked"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "><label for=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "-none\">"); ++ ((Control.Monad.liftM (toHtml .) getMessageRender) ++ >>= ++ (\ urender_arRX ++ -> (Yesod.Core.Widget.asWidgetT . toWidget) ++ (urender_arRX MsgSelectNone))); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</label>") })] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "-yes\" type=\"radio\" name=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml name); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" value=\"yes\""); ++ Text.Hamlet.condH ++ [(showVal id val, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " checked"))] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "><label for=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "-yes\">"); ++ ((Control.Monad.liftM (toHtml .) getMessageRender) ++ >>= ++ (\ urender_arRY ++ -> (Yesod.Core.Widget.asWidgetT . toWidget) ++ (urender_arRY MsgBoolYes))); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "</label><input id=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "-no\" type=\"radio\" name=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml name); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" value=\"no\""); ++ Text.Hamlet.condH ++ [(showVal not val, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " checked"))] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "><label for=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "-no\">"); ++ ((Control.Monad.liftM (toHtml .) getMessageRender) ++ >>= ++ (\ urender_arRZ ++ -> (Yesod.Core.Widget.asWidgetT . toWidget) ++ (urender_arRZ MsgBoolNo))); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</label>") } + +- +-<input id=#{theId}-yes *{attrs} type=radio name=#{name} value=yes :showVal id val:checked> +-<label for=#{theId}-yes>_{MsgBoolYes} +- +-<input id=#{theId}-no *{attrs} type=radio name=#{name} value=no :showVal not val:checked> +-<label for=#{theId}-no>_{MsgBoolNo} +-|] + , fieldEnctype = UrlEncoded + } + where +@@ -478,10 +868,25 @@ $newline never + checkBoxField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool + checkBoxField = Field + { fieldParse = \e _ -> return $ checkBoxParser e +- , fieldView = \theId name attrs val _ -> [whamlet| +-$newline never +-<input id=#{theId} *{attrs} type=checkbox name=#{name} value=yes :showVal id val:checked> +-|] ++ , fieldView = \theId name attrs val _ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml theId); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "\" type=\"checkbox\" name=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml name); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" value=\"yes\""); ++ Text.Hamlet.condH ++ [(showVal id val, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " checked"))] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ">") } ++ + , fieldEnctype = UrlEncoded + } + +@@ -525,49 +930,7 @@ optionsPairs opts = do + optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a) + optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound] + +-optionsPersist :: ( YesodPersist site, PersistEntity a +- , PersistQuery (YesodDB site) +- , PathPiece (Key a) +- , PersistEntityBackend a ~ PersistMonadBackend (YesodDB site) +- , RenderMessage site msg +- ) +- => [Filter a] +- -> [SelectOpt a] +- -> (a -> msg) +- -> HandlerT site IO (OptionList (Entity a)) +-optionsPersist filts ords toDisplay = fmap mkOptionList $ do +- mr <- getMessageRender +- pairs <- runDB $ selectList filts ords +- return $ map (\(Entity key value) -> Option +- { optionDisplay = mr (toDisplay value) +- , optionInternalValue = Entity key value +- , optionExternalValue = toPathPiece key +- }) pairs +- +--- | An alternative to 'optionsPersist' which returns just the @Key@ instead of +--- the entire @Entity@. +--- +--- Since 1.3.2 +-optionsPersistKey +- :: (YesodPersist site +- , PersistEntity a +- , PersistQuery (YesodPersistBackend site (HandlerT site IO)) +- , PathPiece (Key a) +- , RenderMessage site msg +- , PersistEntityBackend a ~ PersistMonadBackend (YesodDB site)) +- => [Filter a] +- -> [SelectOpt a] +- -> (a -> msg) +- -> HandlerT site IO (OptionList (Key a)) +- +-optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do +- mr <- getMessageRender +- pairs <- runDB $ selectList filts ords +- return $ map (\(Entity key value) -> Option +- { optionDisplay = mr (toDisplay value) +- , optionInternalValue = key +- , optionExternalValue = toPathPiece key +- }) pairs ++ + + selectFieldHelper + :: (Eq a, RenderMessage site FormMessage) +@@ -611,9 +974,21 @@ fileField = Field + case files of + [] -> Right Nothing + file:_ -> Right $ Just file +- , fieldView = \id' name attrs _ isReq -> toWidget [hamlet| +- <input id=#{id'} name=#{name} *{attrs} type=file :isReq:required> +- |] ++ , fieldView = \id' name attrs _ isReq -> toWidget $ \ _render_arSN ++ -> do { id ++ ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\""); ++ id (toHtml id'); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ id (toHtml name); ++ id ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"file\""); ++ Text.Hamlet.condH ++ [(isReq, ++ id ((Text.Blaze.Internal.preEscapedText . pack) " required"))] ++ Nothing; ++ id ((Text.Hamlet.attrsToHtml . toAttributes) attrs); ++ id ((Text.Blaze.Internal.preEscapedText . pack) ">") } ++ + , fieldEnctype = Multipart + } + +@@ -640,10 +1015,20 @@ fileAFormReq fs = AForm $ \(site, langs) menvs ints -> do + { fvLabel = toHtml $ renderMessage site langs $ fsLabel fs + , fvTooltip = fmap (toHtml . renderMessage site langs) $ fsTooltip fs + , fvId = id' +- , fvInput = [whamlet| +-$newline never +-<input type=file name=#{name} ##{id'} *{fsAttrs fs}> +-|] ++ , fvInput = do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<input type=\"file\" name=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml name); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" id=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml id'); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Hamlet.attrsToHtml . toAttributes) (fsAttrs fs)); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ">") } ++ + , fvErrors = errs + , fvRequired = True + } +@@ -672,10 +1057,20 @@ fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do + { fvLabel = toHtml $ renderMessage master langs $ fsLabel fs + , fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs + , fvId = id' +- , fvInput = [whamlet| +-$newline never +-<input type=file name=#{name} ##{id'} *{fsAttrs fs}> +-|] ++ , fvInput = do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<input type=\"file\" name=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml name); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" id=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml id'); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Hamlet.attrsToHtml . toAttributes) (fsAttrs fs)); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ">") } ++ + , fvErrors = errs + , fvRequired = False + } +diff --git a/Yesod/Form/Functions.hs b/Yesod/Form/Functions.hs +index 8a36710..8675a10 100644 +--- a/Yesod/Form/Functions.hs ++++ b/Yesod/Form/Functions.hs +@@ -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) ++import qualified Text.Blaze.Internal ++import qualified Yesod.Core.Widget ++import qualified Data.Foldable ++import qualified Text.Hamlet + + -- | Get a unique identifier. + newFormIdent :: Monad m => MForm m Text +@@ -210,7 +214,14 @@ postHelper form env = do + let token = + case reqToken req of + Nothing -> mempty +- Just n -> [shamlet|<input type=hidden name=#{tokenKey} value=#{n}>|] ++ Just n -> do { id ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<input type=\"hidden\" name=\""); ++ id (toHtml tokenKey); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\" value=\""); ++ id (toHtml n); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\">") } ++ + m <- getYesod + langs <- languages + ((res, xml), enctype) <- runFormGeneric (form token) m langs env +@@ -279,7 +290,12 @@ getHelper :: MonadHandler m + -> Maybe (Env, FileEnv) + -> m (a, Enctype) + getHelper form env = do +- let fragment = [shamlet|<input type=hidden name=#{getKey}>|] ++ let fragment = do { id ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<input type=\"hidden\" name=\""); ++ id (toHtml getKey); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\">") } ++ + langs <- languages + m <- getYesod + runFormGeneric (form fragment) m langs env +@@ -293,19 +309,66 @@ renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a + renderTable aform fragment = do + (res, views') <- aFormToForm aform + let views = views' [] +- let widget = [whamlet| +-$newline never +-\#{fragment} +-$forall view <- views +- <tr :fvRequired view:.required :not $ fvRequired view:.optional> +- <td> +- <label for=#{fvId view}>#{fvLabel view} +- $maybe tt <- fvTooltip view +- <div .tooltip>#{tt} +- <td>^{fvInput view} +- $maybe err <- fvErrors view +- <td .errors>#{err} +-|] ++ let widget = do { (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml fragment); ++ Data.Foldable.mapM_ ++ (\ view_aagq ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "<tr"); ++ Text.Hamlet.condH ++ [(or [fvRequired view_aagq, not (fvRequired view_aagq)], ++ do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " class=\""); ++ Text.Hamlet.condH ++ [(fvRequired view_aagq, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "required "))] ++ Nothing; ++ Text.Hamlet.condH ++ [(not (fvRequired view_aagq), ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "optional"))] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\"") })] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "><td><label for=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml (fvId view_aagq)); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ (toHtml (fvLabel view_aagq)); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</label>"); ++ Text.Hamlet.maybeH ++ (fvTooltip view_aagq) ++ (\ tt_aagr ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<div class=\"tooltip\">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml tt_aagr); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</div>") }) ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</td><td>"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (fvInput view_aagq); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</td>"); ++ Text.Hamlet.maybeH ++ (fvErrors view_aagq) ++ (\ err_aags ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<td class=\"errors\">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml err_aags); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</td>") }) ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</tr>") }) ++ views } ++ + return (res, widget) + + -- | render a field inside a div +@@ -318,19 +381,67 @@ renderDivsMaybeLabels :: Monad m => Bool -> FormRender m a + renderDivsMaybeLabels withLabels aform fragment = do + (res, views') <- aFormToForm aform + let views = views' [] +- let widget = [whamlet| +-$newline never +-\#{fragment} +-$forall view <- views +- <div :fvRequired view:.required :not $ fvRequired view:.optional> +- $if withLabels +- <label for=#{fvId view}>#{fvLabel view} +- $maybe tt <- fvTooltip view +- <div .tooltip>#{tt} +- ^{fvInput view} +- $maybe err <- fvErrors view +- <div .errors>#{err} +-|] ++ let widget = do { (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml fragment); ++ Data.Foldable.mapM_ ++ (\ view_aagE ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "<div"); ++ Text.Hamlet.condH ++ [(or [fvRequired view_aagE, not (fvRequired view_aagE)], ++ do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) " class=\""); ++ Text.Hamlet.condH ++ [(fvRequired view_aagE, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "required "))] ++ Nothing; ++ Text.Hamlet.condH ++ [(not (fvRequired view_aagE), ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "optional"))] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\"") })] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ">"); ++ Text.Hamlet.condH ++ [(withLabels, ++ do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "<label for=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml (fvId view_aagE)); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ (toHtml (fvLabel view_aagE)); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</label>") })] ++ Nothing; ++ Text.Hamlet.maybeH ++ (fvTooltip view_aagE) ++ (\ tt_aagF ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<div class=\"tooltip\">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml tt_aagF); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</div>") }) ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) (fvInput view_aagE); ++ Text.Hamlet.maybeH ++ (fvErrors view_aagE) ++ (\ err_aagG ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<div class=\"errors\">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml err_aagG); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</div>") }) ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</div>") }) ++ views } ++ + return (res, widget) + + -- | Render a form using Bootstrap-friendly shamlet syntax. +@@ -354,19 +465,63 @@ renderBootstrap aform fragment = do + let views = views' [] + has (Just _) = True + has Nothing = False +- let widget = [whamlet| +- $newline never +- \#{fragment} +- $forall view <- views +- <div .control-group .clearfix :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.error> +- <label .control-label for=#{fvId view}>#{fvLabel view} +- <div .controls .input> +- ^{fvInput view} +- $maybe tt <- fvTooltip view +- <span .help-block>#{tt} +- $maybe err <- fvErrors view +- <span .help-block>#{err} +- |] ++ let widget = do { (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml fragment); ++ Data.Foldable.mapM_ ++ (\ view_aagR ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<div class=\"control-group clearfix "); ++ Text.Hamlet.condH ++ [(fvRequired view_aagR, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "required "))] ++ Nothing; ++ Text.Hamlet.condH ++ [(not (fvRequired view_aagR), ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "optional "))] ++ Nothing; ++ Text.Hamlet.condH ++ [(has (fvErrors view_aagR), ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "error"))] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "\"><label class=\"control-label\" for=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml (fvId view_aagR)); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "\">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ (toHtml (fvLabel view_aagR)); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "</label><div class=\"controls input\">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (fvInput view_aagR); ++ Text.Hamlet.maybeH ++ (fvTooltip view_aagR) ++ (\ tt_aagS ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<span class=\"help-block\">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml tt_aagS); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</span>") }) ++ Nothing; ++ Text.Hamlet.maybeH ++ (fvErrors view_aagR) ++ (\ err_aagT ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<span class=\"help-block\">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml err_aagT); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</span>") }) ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . pack) "</div></div>") }) ++ views } ++ + return (res, widget) + + check :: (Monad m, RenderMessage (HandlerSite m) msg) +diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs +index 2c4ae25..ed9b366 100644 +--- a/Yesod/Form/Jquery.hs ++++ b/Yesod/Form/Jquery.hs +@@ -12,12 +12,24 @@ module Yesod.Form.Jquery + , Default (..) + ) where + ++import qualified Text.Blaze as Text.Blaze.Internal ++import qualified Text.Blaze.Internal ++import qualified Text.Hamlet ++import qualified Yesod.Core.Widget ++import qualified Text.Css ++import qualified Data.Monoid ++import qualified Data.Foldable ++import qualified Control.Monad ++import qualified Text.Julius ++import qualified Data.Text.Lazy.Builder ++import qualified Text.Shakespeare ++ + 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 + , fieldView = \theId name attrs val isReq -> do +- toWidget [shamlet| +-$newline never +-<input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}"> +-|] ++ toWidget $ do { id ++ ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\""); ++ id (toHtml theId); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ id (toHtml name); ++ id ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"date\""); ++ Text.Hamlet.condH ++ [(isReq, ++ id ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))] ++ Nothing; ++ id ((Text.Blaze.Internal.preEscapedText . pack) " value=\""); ++ id (toHtml (showVal val)); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ id ((Text.Hamlet.attrsToHtml . Text.Hamlet.toAttributes) attrs); ++ id ((Text.Blaze.Internal.preEscapedText . pack) ">") } ++ + addScript' urlJqueryJs + addScript' urlJqueryUiJs + addStylesheet' urlJqueryUiCss +- toWidget [julius| +-$(function(){ +- var i = document.getElementById("#{rawJS theId}"); +- if (i.type != "date") { +- $(i).datepicker({ +- dateFormat:'yy-mm-dd', +- changeMonth:#{jsBool $ jdsChangeMonth jds}, +- changeYear:#{jsBool $ jdsChangeYear jds}, +- numberOfMonths:#{rawJS $ mos $ jdsNumberOfMonths jds}, +- yearRange:#{toJSON $ jdsYearRange jds} +- }); +- } +-}); +-|] ++ toWidget $ Text.Julius.asJavascriptUrl ++ (\ _render_a1lYC ++ -> mconcat ++ [Text.Julius.Javascript ++ ((Data.Text.Lazy.Builder.fromText ++ . Text.Shakespeare.pack') ++ "\n$(function(){\n var i = document.getElementById(\""), ++ Text.Julius.toJavascript (rawJS theId), ++ Text.Julius.Javascript ++ ((Data.Text.Lazy.Builder.fromText ++ . Text.Shakespeare.pack') ++ "\");\n if (i.type != \"date\") {\n $(i).datepicker({\n dateFormat:'yy-mm-dd',\n changeMonth:"), ++ Text.Julius.toJavascript (jsBool (jdsChangeMonth jds)), ++ Text.Julius.Javascript ++ ((Data.Text.Lazy.Builder.fromText ++ . Text.Shakespeare.pack') ++ ",\n changeYear:"), ++ Text.Julius.toJavascript (jsBool (jdsChangeYear jds)), ++ Text.Julius.Javascript ++ ((Data.Text.Lazy.Builder.fromText ++ . Text.Shakespeare.pack') ++ ",\n numberOfMonths:"), ++ Text.Julius.toJavascript (rawJS (mos (jdsNumberOfMonths jds))), ++ Text.Julius.Javascript ++ ((Data.Text.Lazy.Builder.fromText ++ . Text.Shakespeare.pack') ++ ",\n yearRange:"), ++ Text.Julius.toJavascript (toJSON (jdsYearRange jds)), ++ Text.Julius.Javascript ++ ((Data.Text.Lazy.Builder.fromText ++ . Text.Shakespeare.pack') ++ "\n });\n }\n});")]) ++ + , fieldEnctype = UrlEncoded + } + where +@@ -101,16 +145,47 @@ jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site) + jqueryAutocompleteField src = Field + { fieldParse = parseHelper $ Right + , fieldView = \theId name attrs val isReq -> do +- toWidget [shamlet| +-$newline never +-<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{either id id val}" .autocomplete> +-|] ++ toWidget $ do { id ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<input class=\"autocomplete\" id=\""); ++ id (toHtml theId); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ id (toHtml name); ++ id ++ ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"text\""); ++ Text.Hamlet.condH ++ [(isReq, ++ id ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))] ++ Nothing; ++ id ((Text.Blaze.Internal.preEscapedText . pack) " value=\""); ++ id (toHtml (either id id val)); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ id ((Text.Hamlet.attrsToHtml . Text.Hamlet.toAttributes) attrs); ++ id ((Text.Blaze.Internal.preEscapedText . pack) ">") } ++ + addScript' urlJqueryJs + addScript' urlJqueryUiJs + addStylesheet' urlJqueryUiCss +- toWidget [julius| +-$(function(){$("##{rawJS theId}").autocomplete({source:"@{src}",minLength:2})}); +-|] ++ toWidget $ Text.Julius.asJavascriptUrl ++ (\ _render_a1lYP ++ -> mconcat ++ [Text.Julius.Javascript ++ ((Data.Text.Lazy.Builder.fromText ++ . Text.Shakespeare.pack') ++ "\n$(function(){$(\"#"), ++ Text.Julius.toJavascript (rawJS theId), ++ Text.Julius.Javascript ++ ((Data.Text.Lazy.Builder.fromText ++ . Text.Shakespeare.pack') ++ "\").autocomplete({source:\""), ++ Text.Julius.Javascript ++ (Data.Text.Lazy.Builder.fromText ++ (_render_a1lYP src [])), ++ Text.Julius.Javascript ++ ((Data.Text.Lazy.Builder.fromText ++ . Text.Shakespeare.pack') ++ "\",minLength:2})});")]) ++ + , fieldEnctype = UrlEncoded + } + +diff --git a/Yesod/Form/MassInput.hs b/Yesod/Form/MassInput.hs +index 332eb66..5015e7b 100644 +--- a/Yesod/Form/MassInput.hs ++++ b/Yesod/Form/MassInput.hs +@@ -9,6 +9,16 @@ module Yesod.Form.MassInput + , massTable + ) where + ++import qualified Data.Text ++import qualified Text.Blaze as Text.Blaze.Internal ++import qualified Text.Blaze.Internal ++import qualified Text.Hamlet ++import qualified Yesod.Core.Widget ++import qualified Text.Css ++import qualified Data.Monoid ++import qualified Data.Foldable ++import qualified Control.Monad ++ + import Yesod.Form.Types + import Yesod.Form.Functions + import Yesod.Form.Fields (boolField) +@@ -70,16 +80,28 @@ inputList label fixXml single mdef = formToAForm $ do + { fvLabel = label + , fvTooltip = Nothing + , fvId = theId +- , fvInput = [whamlet| +-$newline never +-^{fixXml views} +-<p> +- $forall xml <- xmls +- ^{xml} +- <input .count type=hidden name=#{countName} value=#{count}> +- <input type=checkbox name=#{addName}> +- Add another row +-|] ++ , fvInput = do { (Yesod.Core.Widget.asWidgetT . toWidget) (fixXml views); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "<p>"); ++ Data.Foldable.mapM_ ++ (\ xml_aUS3 -> (Yesod.Core.Widget.asWidgetT . toWidget) xml_aUS3) ++ xmls; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "<input class=\"count\" type=\"hidden\" name=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml countName); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "\" value=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml count); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "\"><input type=\"checkbox\" name=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml addName); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "\">Add another row</p>") } ++ + , fvErrors = Nothing + , fvRequired = False + }]) +@@ -92,10 +114,14 @@ withDelete af = do + deleteName <- newFormIdent + (menv, _, _) <- ask + res <- case menv >>= Map.lookup deleteName . fst of +- Just ("yes":_) -> return $ Left [whamlet| +-$newline never +-<input type=hidden name=#{deleteName} value=yes> +-|] ++ Just ("yes":_) -> return $ Left $ do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "<input type=\"hidden\" name=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml deleteName); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "\" value=\"yes\">") } ++ + _ -> do + (_, xml2) <- aFormToForm $ areq boolField FieldSettings + { fsLabel = SomeMessage MsgDelete +@@ -121,32 +147,155 @@ fixme eithers = + massDivs, massTable + :: [[FieldView site]] + -> WidgetT site IO () +-massDivs viewss = [whamlet| +-$newline never +-$forall views <- viewss +- <fieldset> +- $forall view <- views +- <div :fvRequired view:.required :not $ fvRequired view:.optional> +- <label for=#{fvId view}>#{fvLabel view} +- $maybe tt <- fvTooltip view +- <div .tooltip>#{tt} +- ^{fvInput view} +- $maybe err <- fvErrors view +- <div .errors>#{err} +-|] ++massDivs viewss = Data.Foldable.mapM_ ++ (\ views_aUSm ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "<fieldset>"); ++ Data.Foldable.mapM_ ++ (\ view_aUSn ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "<div"); ++ Text.Hamlet.condH ++ [(or [fvRequired view_aUSn, not (fvRequired view_aUSn)], ++ do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ " class=\""); ++ Text.Hamlet.condH ++ [(fvRequired view_aUSn, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "required "))] ++ Nothing; ++ Text.Hamlet.condH ++ [(not (fvRequired view_aUSn), ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "optional"))] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "\"") })] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "><label for=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml (fvId view_aUSn)); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "\">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ (toHtml (fvLabel view_aUSn)); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "</label>"); ++ Text.Hamlet.maybeH ++ (fvTooltip view_aUSn) ++ (\ tt_aUSo ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "<div class=\"tooltip\">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ (toHtml tt_aUSo); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "</div>") }) ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) (fvInput view_aUSn); ++ Text.Hamlet.maybeH ++ (fvErrors view_aUSn) ++ (\ err_aUSp ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "<div class=\"errors\">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ (toHtml err_aUSp); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "</div>") }) ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "</div>") }) ++ views_aUSm; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "</fieldset>") }) ++ viewss ++ ++ ++massTable viewss = Data.Foldable.mapM_ ++ (\ views_aUSu ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "<fieldset><table>"); ++ Data.Foldable.mapM_ ++ (\ view_aUSv ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "<tr"); ++ Text.Hamlet.condH ++ [(or [fvRequired view_aUSv, not (fvRequired view_aUSv)], ++ do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ " class=\""); ++ Text.Hamlet.condH ++ [(fvRequired view_aUSv, ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "required "))] ++ Nothing; ++ Text.Hamlet.condH ++ [(not (fvRequired view_aUSv), ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "optional"))] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "\"") })] ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "><td><label for=\""); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (toHtml (fvId view_aUSv)); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "\">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ (toHtml (fvLabel view_aUSv)); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "</label>"); ++ Text.Hamlet.maybeH ++ (fvTooltip view_aUSv) ++ (\ tt_aUSw ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "<div class=\"tooltip\">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ (toHtml tt_aUSw); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "</div>") }) ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "</td><td>"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) (fvInput view_aUSv); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "</td>"); ++ Text.Hamlet.maybeH ++ (fvErrors view_aUSv) ++ (\ err_aUSx ++ -> do { (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "<td class=\"errors\">"); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ (toHtml err_aUSx); ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "</td>") }) ++ Nothing; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "</tr>") }) ++ views_aUSu; ++ (Yesod.Core.Widget.asWidgetT . toWidget) ++ ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) ++ "</table></fieldset>") }) ++ viewss + +-massTable viewss = [whamlet| +-$newline never +-$forall views <- viewss +- <fieldset> +- <table> +- $forall view <- views +- <tr :fvRequired view:.required :not $ fvRequired view:.optional> +- <td> +- <label for=#{fvId view}>#{fvLabel view} +- $maybe tt <- fvTooltip view +- <div .tooltip>#{tt} +- <td>^{fvInput view} +- $maybe err <- fvErrors view +- <td .errors>#{err} +-|] +diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs +index 2862678..04ddaba 100644 +--- a/Yesod/Form/Nic.hs ++++ b/Yesod/Form/Nic.hs +@@ -9,11 +9,24 @@ module Yesod.Form.Nic + , nicHtmlField + ) where + ++import qualified Text.Blaze as Text.Blaze.Internal ++import qualified Text.Blaze.Internal ++import qualified Text.Hamlet ++import qualified Yesod.Core.Widget ++import qualified Text.Css ++import qualified Data.Monoid ++import qualified Data.Foldable ++import qualified Control.Monad ++import qualified Text.Julius ++import qualified Data.Text.Lazy.Builder ++import qualified Text.Shakespeare ++ ++ + 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 + , fieldView = \theId name attrs val _isReq -> do +- toWidget [shamlet| +-$newline never +- <textarea id="#{theId}" *{attrs} name="#{name}" .html>#{showVal val} +-|] ++ toWidget $ do { id ++ ((Text.Blaze.Internal.preEscapedText . pack) ++ "<textarea class=\"html\" id=\""); ++ id (toHtml theId); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\""); ++ id (toHtml name); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "\""); ++ id ((Text.Hamlet.attrsToHtml . Text.Hamlet.toAttributes) attrs); ++ id ((Text.Blaze.Internal.preEscapedText . pack) ">"); ++ id (toHtml (showVal val)); ++ id ((Text.Blaze.Internal.preEscapedText . pack) "</textarea>") } ++ + addScript' urlNicEdit + master <- getYesod + toWidget $ + case jsLoader master of +- BottomOfHeadBlocking -> [julius| +-bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{rawJS theId}")}); +-|] +- _ -> [julius| +-(function(){new nicEditor({fullPanel:true}).panelInstance("#{rawJS theId}")})(); +-|] ++ BottomOfHeadBlocking -> Text.Julius.asJavascriptUrl ++ (\ _render_a1qhO ++ -> Data.Monoid.mconcat ++ [Text.Julius.Javascript ++ ((Data.Text.Lazy.Builder.fromText ++ . Text.Shakespeare.pack') ++ "\nbkLib.onDomLoaded(function(){new nicEditor({true}).panelInstance(\""), ++ Text.Julius.toJavascript (rawJS theId), ++ Text.Julius.Javascript ++ ((Data.Text.Lazy.Builder.fromText ++ . Text.Shakespeare.pack') ++ "\")});")]) ++ ++ _ -> Text.Julius.asJavascriptUrl ++ (\ _render_a1qhS ++ -> Data.Monoid.mconcat ++ [Text.Julius.Javascript ++ ((Data.Text.Lazy.Builder.fromText ++ . Text.Shakespeare.pack') ++ "\n(function(){new nicEditor({true}).panelInstance(\""), ++ Text.Julius.toJavascript (rawJS theId), ++ Text.Julius.Javascript ++ ((Data.Text.Lazy.Builder.fromText ++ . Text.Shakespeare.pack') ++ "\")})();")]) ++ + , fieldEnctype = UrlEncoded + } + where +diff --git a/yesod-form.cabal b/yesod-form.cabal +index 9e0c710..a39f71f 100644 +--- a/yesod-form.cabal ++++ b/yesod-form.cabal +@@ -19,6 +19,7 @@ library + , time >= 1.1.4 + , hamlet >= 1.1 && < 1.2 + , shakespeare-css >= 1.0 && < 1.1 ++ , shakespeare + , shakespeare-js >= 1.0.2 && < 1.3 + , persistent >= 1.2 && < 1.3 + , template-haskell +-- +1.8.5.1 + diff --git a/standalone/no-th/haskell-patches/yesod-persistent_do-not-really-build.patch b/standalone/no-th/haskell-patches/yesod-persistent_do-not-really-build.patch new file mode 100644 index 000000000..ecccf75ac --- /dev/null +++ b/standalone/no-th/haskell-patches/yesod-persistent_do-not-really-build.patch @@ -0,0 +1,26 @@ +From 03819615edb1c5f7414768dae84234d6791bd758 Mon Sep 17 00:00:00 2001 +From: foo <foo@bar> +Date: Sun, 22 Sep 2013 04:11:46 +0000 +Subject: [PATCH] do not really build + +--- + yesod-persistent.cabal | 3 +-- + 1 file changed, 1 insertion(+), 2 deletions(-) + +diff --git a/yesod-persistent.cabal b/yesod-persistent.cabal +index 98c2146..11960cf 100644 +--- a/yesod-persistent.cabal ++++ b/yesod-persistent.cabal +@@ -23,8 +23,7 @@ library + , lifted-base + , pool-conduit + , resourcet +- exposed-modules: Yesod.Persist +- Yesod.Persist.Core ++ exposed-modules: + ghc-options: -Wall + + test-suite test +-- +1.7.10.4 + diff --git a/standalone/no-th/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 new file mode 100644 index 000000000..e20e3c7f1 --- /dev/null +++ b/standalone/no-th/haskell-patches/yesod-routes_export-module-referenced-by-TH-splices.patch @@ -0,0 +1,29 @@ +From f6bfe8e01d8fe6d129ad3819070aa17934094a0a Mon Sep 17 00:00:00 2001 +From: foo <foo@bar> +Date: Sun, 22 Sep 2013 06:24:09 +0000 +Subject: [PATCH] export module referenced by TH splices + +--- + yesod-routes.cabal | 2 +- + 1 file changed, 1 insertion(+), 1 deletion(-) + +diff --git a/yesod-routes.cabal b/yesod-routes.cabal +index 0b245f2..a97582a 100644 +--- a/yesod-routes.cabal ++++ b/yesod-routes.cabal +@@ -27,11 +27,11 @@ library + Yesod.Routes.Class + Yesod.Routes.Parse + Yesod.Routes.Overlap ++ Yesod.Routes.TH.Types + other-modules: Yesod.Routes.TH.Dispatch + Yesod.Routes.TH.RenderRoute + Yesod.Routes.TH.ParseRoute + Yesod.Routes.TH.RouteAttrs +- Yesod.Routes.TH.Types + ghc-options: -Wall + + test-suite runtests +-- +1.7.10.4 + 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 + |