add patches porting necessary Haskell libraries to Android
This goes all the way up to Yesod, but everything above Wai is a real hack job, removing TH left and right.
This commit is contained in:
Joey Hess
parent
1943bb31ab
commit
1bc5734037
31 changed files with 6311 additions and 0 deletions
|
|
@ -0,0 +1,34 @@
|
|||
From 8c4220e4dd48ad197aa0ad49214e6e7bd768044e Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:28:57 -0400
|
||||
Subject: [PATCH] fix build (not Android specific)
|
||||
|
||||
---
|
||||
src/System/Cmd/Utils.hs | 4 ++--
|
||||
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/src/System/Cmd/Utils.hs b/src/System/Cmd/Utils.hs
|
||||
index a9fa46f..6c6aba2 100644
|
||||
--- a/src/System/Cmd/Utils.hs
|
||||
+++ b/src/System/Cmd/Utils.hs
|
||||
@@ -325,7 +325,7 @@ forceSuccess (PipeHandle pid fp args funcname) =
|
||||
Just (Exited (ExitSuccess)) -> return ()
|
||||
Just (Exited (ExitFailure fc)) ->
|
||||
cmdfailed funcname fp args fc
|
||||
- Just (Terminated sig) ->
|
||||
+ Just (Terminated sig _) ->
|
||||
warnfail fp args $ "Terminated by signal " ++ show sig
|
||||
Just (Stopped sig) ->
|
||||
warnfail fp args $ "Stopped by signal " ++ show sig
|
||||
@@ -351,7 +351,7 @@ safeSystem command args =
|
||||
case ec of
|
||||
Exited ExitSuccess -> return ()
|
||||
Exited (ExitFailure fc) -> cmdfailed "safeSystem" command args fc
|
||||
- Terminated s -> cmdsignalled "safeSystem" command args s
|
||||
+ Terminated s _ -> cmdsignalled "safeSystem" command args s
|
||||
Stopped s -> cmdsignalled "safeSystem" command args s
|
||||
#endif
|
||||
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
From b220c377941d0b1271cf525a8d06bb8e48196d2b Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:29:04 -0400
|
||||
Subject: [PATCH] disable TH
|
||||
|
||||
---
|
||||
aeson.cabal | 1 -
|
||||
1 file changed, 1 deletion(-)
|
||||
|
||||
diff --git a/aeson.cabal b/aeson.cabal
|
||||
index 242aa67..275aa49 100644
|
||||
--- a/aeson.cabal
|
||||
+++ b/aeson.cabal
|
||||
@@ -99,7 +99,6 @@ library
|
||||
Data.Aeson.Generic
|
||||
Data.Aeson.Parser
|
||||
Data.Aeson.Types
|
||||
- Data.Aeson.TH
|
||||
|
||||
other-modules:
|
||||
Data.Aeson.Functions
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
From 55f424de9946c4d1d89837bb18698437aecfcfa4 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:29:16 -0400
|
||||
Subject: [PATCH] allow building with unreleased ghc
|
||||
|
||||
---
|
||||
async.cabal | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/async.cabal b/async.cabal
|
||||
index 8e47d9d..ff317c7 100644
|
||||
--- a/async.cabal
|
||||
+++ b/async.cabal
|
||||
@@ -70,7 +70,7 @@ source-repository head
|
||||
|
||||
library
|
||||
exposed-modules: Control.Concurrent.Async
|
||||
- build-depends: base >= 4.3 && < 4.7, stm >= 2.2 && < 2.5
|
||||
+ build-depends: base >= 4.3 && < 4.8, stm >= 2.2 && < 2.5
|
||||
|
||||
test-suite test-async
|
||||
type: exitcode-stdio-1.0
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
From efd0e93de82c0b5554a4f3a4517e6127f405f6da Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:29:36 -0400
|
||||
Subject: [PATCH] allow building with unreleased ghc
|
||||
|
||||
---
|
||||
case-insensitive.cabal | 4 ++--
|
||||
1 file changed, 2 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/case-insensitive.cabal b/case-insensitive.cabal
|
||||
index a73479d..18a1a51 100644
|
||||
--- a/case-insensitive.cabal
|
||||
+++ b/case-insensitive.cabal
|
||||
@@ -25,8 +25,8 @@ source-repository head
|
||||
|
||||
Library
|
||||
GHC-Options: -Wall
|
||||
- build-depends: base >= 3 && < 4.6
|
||||
- , bytestring >= 0.9 && < 0.10
|
||||
+ build-depends: base >= 3 && < 4.8
|
||||
+ , bytestring >= 0.9 && < 0.15
|
||||
, text >= 0.3 && < 0.12
|
||||
, hashable >= 1.0 && < 1.2
|
||||
exposed-modules: Data.CaseInsensitive
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,276 @@
|
|||
From 7be8bf3ba75acc5209066e6ba31ae589c541f344 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:30:01 -0400
|
||||
Subject: [PATCH] axe murdered
|
||||
|
||||
---
|
||||
Text/Hamlet.hs | 215 +-------------------------------------------------------
|
||||
1 file changed, 2 insertions(+), 213 deletions(-)
|
||||
|
||||
diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs
|
||||
index 4ac870a..bc8edd5 100644
|
||||
--- a/Text/Hamlet.hs
|
||||
+++ b/Text/Hamlet.hs
|
||||
@@ -11,35 +11,22 @@
|
||||
module Text.Hamlet
|
||||
( -- * Plain HTML
|
||||
Html
|
||||
- , shamlet
|
||||
- , shamletFile
|
||||
- , xshamlet
|
||||
- , xshamletFile
|
||||
-- * Hamlet
|
||||
, HtmlUrl
|
||||
- , hamlet
|
||||
- , hamletFile
|
||||
- , xhamlet
|
||||
- , xhamletFile
|
||||
-- * I18N Hamlet
|
||||
, HtmlUrlI18n
|
||||
- , ihamlet
|
||||
- , ihamletFile
|
||||
-- * Type classes
|
||||
, ToAttributes (..)
|
||||
-- * Internal, for making more
|
||||
, HamletSettings (..)
|
||||
, NewlineStyle (..)
|
||||
- , hamletWithSettings
|
||||
- , hamletFileWithSettings
|
||||
, defaultHamletSettings
|
||||
, xhtmlHamletSettings
|
||||
, Env (..)
|
||||
, HamletRules (..)
|
||||
- , hamletRules
|
||||
- , ihamletRules
|
||||
- , htmlRules
|
||||
, CloseStyle (..)
|
||||
+ , condH
|
||||
+ , maybeH
|
||||
) where
|
||||
|
||||
import Text.Shakespeare.Base
|
||||
@@ -90,14 +77,6 @@ type HtmlUrl url = Render url -> Html
|
||||
-- | A function generating an 'Html' given a message translator and a URL rendering function.
|
||||
type HtmlUrlI18n msg url = Translate msg -> Render url -> Html
|
||||
|
||||
-docsToExp :: Env -> HamletRules -> Scope -> [Doc] -> Q Exp
|
||||
-docsToExp env hr scope docs = do
|
||||
- exps <- mapM (docToExp env hr scope) docs
|
||||
- case exps of
|
||||
- [] -> [|return ()|]
|
||||
- [x] -> return x
|
||||
- _ -> return $ DoE $ map NoBindS exps
|
||||
-
|
||||
unIdent :: Ident -> String
|
||||
unIdent (Ident s) = s
|
||||
|
||||
@@ -159,169 +138,9 @@ recordToFieldNames conStr = do
|
||||
[fields] <- return [fields | RecC name fields <- cons, name == conName]
|
||||
return [fieldName | (fieldName, _, _) <- fields]
|
||||
|
||||
-docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp
|
||||
-docToExp env hr scope (DocForall list idents inside) = do
|
||||
- let list' = derefToExp scope list
|
||||
- (pat, extraScope) <- bindingPattern idents
|
||||
- let scope' = extraScope ++ scope
|
||||
- mh <- [|F.mapM_|]
|
||||
- inside' <- docsToExp env hr scope' inside
|
||||
- let lam = LamE [pat] inside'
|
||||
- return $ mh `AppE` lam `AppE` list'
|
||||
-docToExp env hr scope (DocWith [] inside) = do
|
||||
- inside' <- docsToExp env hr scope inside
|
||||
- return $ inside'
|
||||
-docToExp env hr scope (DocWith ((deref, idents):dis) inside) = do
|
||||
- let deref' = derefToExp scope deref
|
||||
- (pat, extraScope) <- bindingPattern idents
|
||||
- let scope' = extraScope ++ scope
|
||||
- inside' <- docToExp env hr scope' (DocWith dis inside)
|
||||
- let lam = LamE [pat] inside'
|
||||
- return $ lam `AppE` deref'
|
||||
-docToExp env hr scope (DocMaybe val idents inside mno) = do
|
||||
- let val' = derefToExp scope val
|
||||
- (pat, extraScope) <- bindingPattern idents
|
||||
- let scope' = extraScope ++ scope
|
||||
- inside' <- docsToExp env hr scope' inside
|
||||
- let inside'' = LamE [pat] inside'
|
||||
- ninside' <- case mno of
|
||||
- Nothing -> [|Nothing|]
|
||||
- Just no -> do
|
||||
- no' <- docsToExp env hr scope no
|
||||
- j <- [|Just|]
|
||||
- return $ j `AppE` no'
|
||||
- mh <- [|maybeH|]
|
||||
- return $ mh `AppE` val' `AppE` inside'' `AppE` ninside'
|
||||
-docToExp env hr scope (DocCond conds final) = do
|
||||
- conds' <- mapM go conds
|
||||
- final' <- case final of
|
||||
- Nothing -> [|Nothing|]
|
||||
- Just f -> do
|
||||
- f' <- docsToExp env hr scope f
|
||||
- j <- [|Just|]
|
||||
- return $ j `AppE` f'
|
||||
- ch <- [|condH|]
|
||||
- return $ ch `AppE` ListE conds' `AppE` final'
|
||||
- where
|
||||
- go :: (Deref, [Doc]) -> Q Exp
|
||||
- go (d, docs) = do
|
||||
- let d' = derefToExp scope d
|
||||
- docs' <- docsToExp env hr scope docs
|
||||
- return $ TupE [d', docs']
|
||||
-docToExp env hr scope (DocCase deref cases) = do
|
||||
- let exp_ = derefToExp scope deref
|
||||
- matches <- mapM toMatch cases
|
||||
- return $ CaseE exp_ matches
|
||||
- where
|
||||
- readMay s =
|
||||
- case reads s of
|
||||
- (x, ""):_ -> Just x
|
||||
- _ -> Nothing
|
||||
- toMatch (idents, inside) = do
|
||||
- let pat = case map unIdent idents of
|
||||
- ["_"] -> WildP
|
||||
- [str]
|
||||
- | Just i <- readMay str -> LitP $ IntegerL i
|
||||
- strs -> let (constr:fields) = map mkName strs
|
||||
- in ConP constr (map VarP fields)
|
||||
- insideExp <- docsToExp env hr scope inside
|
||||
- return $ Match pat (NormalB insideExp) []
|
||||
-docToExp env hr v (DocContent c) = contentToExp env hr v c
|
||||
-
|
||||
-contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp
|
||||
-contentToExp _ hr _ (ContentRaw s) = do
|
||||
- os <- [|preEscapedText . pack|]
|
||||
- let s' = LitE $ StringL s
|
||||
- return $ hrFromHtml hr `AppE` (os `AppE` s')
|
||||
-contentToExp _ hr scope (ContentVar d) = do
|
||||
- str <- [|toHtml|]
|
||||
- return $ hrFromHtml hr `AppE` (str `AppE` derefToExp scope d)
|
||||
-contentToExp env hr scope (ContentUrl hasParams d) =
|
||||
- case urlRender env of
|
||||
- Nothing -> error "URL interpolation used, but no URL renderer provided"
|
||||
- Just wrender -> wrender $ \render -> do
|
||||
- let render' = return render
|
||||
- ou <- if hasParams
|
||||
- then [|\(u, p) -> $(render') u p|]
|
||||
- else [|\u -> $(render') u []|]
|
||||
- let d' = derefToExp scope d
|
||||
- pet <- [|toHtml|]
|
||||
- return $ hrFromHtml hr `AppE` (pet `AppE` (ou `AppE` d'))
|
||||
-contentToExp env hr scope (ContentEmbed d) = hrEmbed hr env $ derefToExp scope d
|
||||
-contentToExp env hr scope (ContentMsg d) =
|
||||
- case msgRender env of
|
||||
- Nothing -> error "Message interpolation used, but no message renderer provided"
|
||||
- Just wrender -> wrender $ \render ->
|
||||
- return $ hrFromHtml hr `AppE` (render `AppE` derefToExp scope d)
|
||||
-contentToExp _ hr scope (ContentAttrs d) = do
|
||||
- html <- [|attrsToHtml . toAttributes|]
|
||||
- return $ hrFromHtml hr `AppE` (html `AppE` derefToExp scope d)
|
||||
-
|
||||
-shamlet :: QuasiQuoter
|
||||
-shamlet = hamletWithSettings htmlRules defaultHamletSettings
|
||||
-
|
||||
-xshamlet :: QuasiQuoter
|
||||
-xshamlet = hamletWithSettings htmlRules xhtmlHamletSettings
|
||||
-
|
||||
-htmlRules :: Q HamletRules
|
||||
-htmlRules = do
|
||||
- i <- [|id|]
|
||||
- return $ HamletRules i ($ (Env Nothing Nothing)) (\_ b -> return b)
|
||||
-
|
||||
-hamlet :: QuasiQuoter
|
||||
-hamlet = hamletWithSettings hamletRules defaultHamletSettings
|
||||
-
|
||||
-xhamlet :: QuasiQuoter
|
||||
-xhamlet = hamletWithSettings hamletRules xhtmlHamletSettings
|
||||
-
|
||||
asHtmlUrl :: HtmlUrl url -> HtmlUrl url
|
||||
asHtmlUrl = id
|
||||
|
||||
-hamletRules :: Q HamletRules
|
||||
-hamletRules = do
|
||||
- i <- [|id|]
|
||||
- let ur f = do
|
||||
- r <- newName "_render"
|
||||
- let env = Env
|
||||
- { urlRender = Just ($ (VarE r))
|
||||
- , msgRender = Nothing
|
||||
- }
|
||||
- h <- f env
|
||||
- return $ LamE [VarP r] h
|
||||
- return $ HamletRules i ur em
|
||||
- where
|
||||
- em (Env (Just urender) Nothing) e = do
|
||||
- asHtmlUrl' <- [|asHtmlUrl|]
|
||||
- urender $ \ur' -> return ((asHtmlUrl' `AppE` e) `AppE` ur')
|
||||
- em _ _ = error "bad Env"
|
||||
-
|
||||
-ihamlet :: QuasiQuoter
|
||||
-ihamlet = hamletWithSettings ihamletRules defaultHamletSettings
|
||||
-
|
||||
-ihamletRules :: Q HamletRules
|
||||
-ihamletRules = do
|
||||
- i <- [|id|]
|
||||
- let ur f = do
|
||||
- u <- newName "_urender"
|
||||
- m <- newName "_mrender"
|
||||
- let env = Env
|
||||
- { urlRender = Just ($ (VarE u))
|
||||
- , msgRender = Just ($ (VarE m))
|
||||
- }
|
||||
- h <- f env
|
||||
- return $ LamE [VarP m, VarP u] h
|
||||
- return $ HamletRules i ur em
|
||||
- where
|
||||
- em (Env (Just urender) (Just mrender)) e =
|
||||
- urender $ \ur' -> mrender $ \mr -> return (e `AppE` mr `AppE` ur')
|
||||
- em _ _ = error "bad Env"
|
||||
-
|
||||
-hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter
|
||||
-hamletWithSettings hr set =
|
||||
- QuasiQuoter
|
||||
- { quoteExp = hamletFromString hr set
|
||||
- }
|
||||
-
|
||||
data HamletRules = HamletRules
|
||||
{ hrFromHtml :: Exp
|
||||
, hrWithEnv :: (Env -> Q Exp) -> Q Exp
|
||||
@@ -333,36 +152,6 @@ data Env = Env
|
||||
, msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
|
||||
}
|
||||
|
||||
-hamletFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp
|
||||
-hamletFromString qhr set s = do
|
||||
- hr <- qhr
|
||||
- case parseDoc set s of
|
||||
- Error s' -> error s'
|
||||
- Ok (_mnl, d) -> hrWithEnv hr $ \env -> docsToExp env hr [] d
|
||||
-
|
||||
-hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp
|
||||
-hamletFileWithSettings qhr set fp = do
|
||||
-#ifdef GHC_7_4
|
||||
- qAddDependentFile fp
|
||||
-#endif
|
||||
- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
|
||||
- hamletFromString qhr set contents
|
||||
-
|
||||
-hamletFile :: FilePath -> Q Exp
|
||||
-hamletFile = hamletFileWithSettings hamletRules defaultHamletSettings
|
||||
-
|
||||
-xhamletFile :: FilePath -> Q Exp
|
||||
-xhamletFile = hamletFileWithSettings hamletRules xhtmlHamletSettings
|
||||
-
|
||||
-shamletFile :: FilePath -> Q Exp
|
||||
-shamletFile = hamletFileWithSettings htmlRules defaultHamletSettings
|
||||
-
|
||||
-xshamletFile :: FilePath -> Q Exp
|
||||
-xshamletFile = hamletFileWithSettings htmlRules xhtmlHamletSettings
|
||||
-
|
||||
-ihamletFile :: FilePath -> Q Exp
|
||||
-ihamletFile = hamletFileWithSettings ihamletRules defaultHamletSettings
|
||||
-
|
||||
varName :: Scope -> String -> Exp
|
||||
varName _ "" = error "Illegal empty varName"
|
||||
varName scope v@(_:_) = fromMaybe (strToExp v) $ lookup (Ident v) scope
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,163 @@
|
|||
From 4bb0de1e6213ec925820c8b9cc3ff5f3c3c72d7a Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:31:27 -0400
|
||||
Subject: [PATCH] hacked for newer ghc
|
||||
|
||||
---
|
||||
Control/Concurrent/Lifted.hs | 2 +-
|
||||
Control/Exception/Lifted.hs | 11 ++--------
|
||||
Setup.hs | 46 ++----------------------------------------
|
||||
lifted-base.cabal | 9 ++++-----
|
||||
4 files changed, 9 insertions(+), 59 deletions(-)
|
||||
|
||||
diff --git a/Control/Concurrent/Lifted.hs b/Control/Concurrent/Lifted.hs
|
||||
index 4bc58a8..e4445e6 100644
|
||||
--- a/Control/Concurrent/Lifted.hs
|
||||
+++ b/Control/Concurrent/Lifted.hs
|
||||
@@ -124,7 +124,7 @@ import Control.Concurrent.SampleVar.Lifted
|
||||
#endif
|
||||
import Control.Exception.Lifted ( throwTo
|
||||
#if MIN_VERSION_base(4,6,0)
|
||||
- , SomeException, try, mask
|
||||
+ , SomeException, try
|
||||
#endif
|
||||
)
|
||||
#include "inlinable.h"
|
||||
diff --git a/Control/Exception/Lifted.hs b/Control/Exception/Lifted.hs
|
||||
index 871cda7..0b9d8b7 100644
|
||||
--- a/Control/Exception/Lifted.hs
|
||||
+++ b/Control/Exception/Lifted.hs
|
||||
@@ -50,8 +50,8 @@ module Control.Exception.Lifted
|
||||
-- |The following functions allow a thread to control delivery of
|
||||
-- asynchronous exceptions during a critical region.
|
||||
#if MIN_VERSION_base(4,3,0)
|
||||
- , mask, mask_
|
||||
- , uninterruptibleMask, uninterruptibleMask_
|
||||
+ , mask_
|
||||
+ , uninterruptibleMask_
|
||||
, getMaskingState
|
||||
#if MIN_VERSION_base(4,4,0)
|
||||
, allowInterrupt
|
||||
@@ -266,10 +266,6 @@ evaluate = liftBase ∘ E.evaluate
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
#if MIN_VERSION_base(4,3,0)
|
||||
--- |Generalized version of 'E.mask'.
|
||||
-mask ∷ MonadBaseControl IO m ⇒ ((∀ a. m a → m a) → m b) → m b
|
||||
-mask = liftBaseOp E.mask ∘ liftRestore
|
||||
-{-# INLINABLE mask #-}
|
||||
|
||||
liftRestore ∷ MonadBaseControl IO m
|
||||
⇒ ((∀ a. m a → m a) → b)
|
||||
@@ -283,9 +279,6 @@ mask_ = liftBaseOp_ E.mask_
|
||||
{-# INLINABLE mask_ #-}
|
||||
|
||||
-- |Generalized version of 'E.uninterruptibleMask'.
|
||||
-uninterruptibleMask ∷ MonadBaseControl IO m ⇒ ((∀ a. m a → m a) → m b) → m b
|
||||
-uninterruptibleMask = liftBaseOp E.uninterruptibleMask ∘ liftRestore
|
||||
-{-# INLINABLE uninterruptibleMask #-}
|
||||
|
||||
-- |Generalized version of 'E.uninterruptibleMask_'.
|
||||
uninterruptibleMask_ ∷ MonadBaseControl IO m ⇒ m a → m a
|
||||
diff --git a/Setup.hs b/Setup.hs
|
||||
index 33956e1..9a994af 100644
|
||||
--- a/Setup.hs
|
||||
+++ b/Setup.hs
|
||||
@@ -1,44 +1,2 @@
|
||||
-#! /usr/bin/env runhaskell
|
||||
-
|
||||
-{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-}
|
||||
-
|
||||
-module Main (main) where
|
||||
-
|
||||
-
|
||||
--------------------------------------------------------------------------------
|
||||
--- Imports
|
||||
--------------------------------------------------------------------------------
|
||||
-
|
||||
--- from base
|
||||
-import System.IO ( IO )
|
||||
-
|
||||
--- from cabal
|
||||
-import Distribution.Simple ( defaultMainWithHooks
|
||||
- , simpleUserHooks
|
||||
- , UserHooks(haddockHook)
|
||||
- )
|
||||
-
|
||||
-import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
|
||||
-import Distribution.Simple.Program ( userSpecifyArgs )
|
||||
-import Distribution.Simple.Setup ( HaddockFlags )
|
||||
-import Distribution.PackageDescription ( PackageDescription(..) )
|
||||
-
|
||||
-
|
||||
--------------------------------------------------------------------------------
|
||||
--- Cabal setup program which sets the CPP define '__HADDOCK __' when haddock is run.
|
||||
--------------------------------------------------------------------------------
|
||||
-
|
||||
-main ∷ IO ()
|
||||
-main = defaultMainWithHooks hooks
|
||||
- where
|
||||
- hooks = simpleUserHooks { haddockHook = haddockHook' }
|
||||
-
|
||||
--- Define __HADDOCK__ for CPP when running haddock.
|
||||
-haddockHook' ∷ PackageDescription → LocalBuildInfo → UserHooks → HaddockFlags → IO ()
|
||||
-haddockHook' pkg lbi =
|
||||
- haddockHook simpleUserHooks pkg (lbi { withPrograms = p })
|
||||
- where
|
||||
- p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi)
|
||||
-
|
||||
-
|
||||
--- The End ---------------------------------------------------------------------
|
||||
+import Distribution.Simple
|
||||
+main = defaultMain
|
||||
diff --git a/lifted-base.cabal b/lifted-base.cabal
|
||||
index 54ef418..8da5086 100644
|
||||
--- a/lifted-base.cabal
|
||||
+++ b/lifted-base.cabal
|
||||
@@ -9,7 +9,7 @@ Copyright: (c) 2011-2012 Bas van Dijk, Anders Kaseorg
|
||||
Homepage: https://github.com/basvandijk/lifted-base
|
||||
Bug-reports: https://github.com/basvandijk/lifted-base/issues
|
||||
Category: Control
|
||||
-Build-type: Custom
|
||||
+Build-type: Simple
|
||||
Cabal-version: >= 1.9.2
|
||||
Description: @lifted-base@ exports IO operations from the base library lifted to
|
||||
any instance of 'MonadBase' or 'MonadBaseControl'.
|
||||
@@ -37,7 +37,6 @@ Library
|
||||
Exposed-modules: Control.Exception.Lifted
|
||||
Control.Concurrent.MVar.Lifted
|
||||
Control.Concurrent.Chan.Lifted
|
||||
- Control.Concurrent.Lifted
|
||||
Data.IORef.Lifted
|
||||
System.Timeout.Lifted
|
||||
if impl(ghc < 7.6)
|
||||
@@ -46,7 +45,7 @@ Library
|
||||
Control.Concurrent.QSemN.Lifted
|
||||
Control.Concurrent.SampleVar.Lifted
|
||||
|
||||
- Build-depends: base >= 3 && < 4.7
|
||||
+ Build-depends: base >= 3 && < 4.8
|
||||
, base-unicode-symbols >= 0.1.1 && < 0.3
|
||||
, transformers-base >= 0.4 && < 0.5
|
||||
, monad-control >= 0.3 && < 0.4
|
||||
@@ -64,7 +63,7 @@ test-suite test-lifted-base
|
||||
hs-source-dirs: test
|
||||
|
||||
build-depends: lifted-base
|
||||
- , base >= 3 && < 4.7
|
||||
+ , base >= 3 && < 4.8
|
||||
, transformers >= 0.2 && < 0.4
|
||||
, transformers-base >= 0.4 && < 0.5
|
||||
, monad-control >= 0.3 && < 0.4
|
||||
@@ -87,7 +86,7 @@ benchmark bench-lifted-base
|
||||
ghc-options: -O2
|
||||
|
||||
build-depends: lifted-base
|
||||
- , base >= 3 && < 4.7
|
||||
+ , base >= 3 && < 4.8
|
||||
, transformers >= 0.2 && < 0.4
|
||||
, criterion >= 0.5 && < 0.7
|
||||
, monad-control >= 0.3 && < 0.4
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
From 3dde0175096903207c9774d8f6bba9b81ab6c2f9 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:31:45 -0400
|
||||
Subject: [PATCH] build with newer ghc
|
||||
|
||||
---
|
||||
monad-control.cabal | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/monad-control.cabal b/monad-control.cabal
|
||||
index 2e3eb46..b12ffaf 100644
|
||||
--- a/monad-control.cabal
|
||||
+++ b/monad-control.cabal
|
||||
@@ -56,7 +56,7 @@ Library
|
||||
|
||||
Exposed-modules: Control.Monad.Trans.Control
|
||||
|
||||
- Build-depends: base >= 3 && < 4.7
|
||||
+ Build-depends: base >= 3 && < 4.8
|
||||
, base-unicode-symbols >= 0.1.1 && < 0.3
|
||||
, transformers >= 0.2 && < 0.4
|
||||
, transformers-base >= 0.4.1 && < 0.5
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,124 @@
|
|||
From ca88563e63cc31f0b96b00d3a4fe1f0c56b1e1eb Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:32:01 -0400
|
||||
Subject: [PATCH] remove TH logging stuff
|
||||
|
||||
---
|
||||
Control/Monad/Logger.hs | 76 -----------------------------------------------
|
||||
monad-logger.cabal | 2 +-
|
||||
2 files changed, 1 insertion(+), 77 deletions(-)
|
||||
|
||||
diff --git a/Control/Monad/Logger.hs b/Control/Monad/Logger.hs
|
||||
index fd1282b..80b8ed9 100644
|
||||
--- a/Control/Monad/Logger.hs
|
||||
+++ b/Control/Monad/Logger.hs
|
||||
@@ -27,18 +27,6 @@ module Control.Monad.Logger
|
||||
, LoggingT (..)
|
||||
, runStderrLoggingT
|
||||
, runStdoutLoggingT
|
||||
- -- * TH logging
|
||||
- , logDebug
|
||||
- , logInfo
|
||||
- , logWarn
|
||||
- , logError
|
||||
- , logOther
|
||||
- -- * TH logging with source
|
||||
- , logDebugS
|
||||
- , logInfoS
|
||||
- , logWarnS
|
||||
- , logErrorS
|
||||
- , logOtherS
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH.Syntax (Lift (lift), Q, Exp, Loc (..), qLocation)
|
||||
@@ -91,13 +79,6 @@ import Control.Monad.Writer.Class ( MonadWriter (..) )
|
||||
data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text
|
||||
deriving (Eq, Prelude.Show, Prelude.Read, Ord)
|
||||
|
||||
-instance Lift LogLevel where
|
||||
- lift LevelDebug = [|LevelDebug|]
|
||||
- lift LevelInfo = [|LevelInfo|]
|
||||
- lift LevelWarn = [|LevelWarn|]
|
||||
- lift LevelError = [|LevelError|]
|
||||
- lift (LevelOther x) = [|LevelOther $ pack $(lift $ unpack x)|]
|
||||
-
|
||||
type LogSource = Text
|
||||
|
||||
class Monad m => MonadLogger m where
|
||||
@@ -128,63 +109,6 @@ instance (MonadLogger m, Monoid w) => MonadLogger (Strict.WriterT w m) where DEF
|
||||
instance (MonadLogger m, Monoid w) => MonadLogger (Strict.RWST r w s m) where DEF
|
||||
#undef DEF
|
||||
|
||||
-logTH :: LogLevel -> Q Exp
|
||||
-logTH level =
|
||||
- [|monadLoggerLog $(qLocation >>= liftLoc) $(lift level) . (id :: Text -> Text)|]
|
||||
-
|
||||
--- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage:
|
||||
---
|
||||
--- > $(logDebug) "This is a debug log message"
|
||||
-logDebug :: Q Exp
|
||||
-logDebug = logTH LevelDebug
|
||||
-
|
||||
--- | See 'logDebug'
|
||||
-logInfo :: Q Exp
|
||||
-logInfo = logTH LevelInfo
|
||||
--- | See 'logDebug'
|
||||
-logWarn :: Q Exp
|
||||
-logWarn = logTH LevelWarn
|
||||
--- | See 'logDebug'
|
||||
-logError :: Q Exp
|
||||
-logError = logTH LevelError
|
||||
-
|
||||
--- | Generates a function that takes a 'Text' and logs a 'LevelOther' message. Usage:
|
||||
---
|
||||
--- > $(logOther "My new level") "This is a log message"
|
||||
-logOther :: Text -> Q Exp
|
||||
-logOther = logTH . LevelOther
|
||||
-
|
||||
-liftLoc :: Loc -> Q Exp
|
||||
-liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc
|
||||
- $(lift a)
|
||||
- $(lift b)
|
||||
- $(lift c)
|
||||
- ($(lift d1), $(lift d2))
|
||||
- ($(lift e1), $(lift e2))
|
||||
- |]
|
||||
-
|
||||
--- | Generates a function that takes a 'LogSource' and 'Text' and logs a 'LevelDebug' message. Usage:
|
||||
---
|
||||
--- > $logDebug "SomeSource" "This is a debug log message"
|
||||
-logDebugS :: Q Exp
|
||||
-logDebugS = [|\a b -> monadLoggerLogSource $(qLocation >>= liftLoc) a LevelDebug (b :: Text)|]
|
||||
-
|
||||
--- | See 'logDebugS'
|
||||
-logInfoS :: Q Exp
|
||||
-logInfoS = [|\a b -> monadLoggerLogSource $(qLocation >>= liftLoc) a LevelInfo (b :: Text)|]
|
||||
--- | See 'logDebugS'
|
||||
-logWarnS :: Q Exp
|
||||
-logWarnS = [|\a b -> monadLoggerLogSource $(qLocation >>= liftLoc) a LevelWarn (b :: Text)|]
|
||||
--- | See 'logDebugS'
|
||||
-logErrorS :: Q Exp
|
||||
-logErrorS = [|\a b -> monadLoggerLogSource $(qLocation >>= liftLoc) a LevelError (b :: Text)|]
|
||||
-
|
||||
--- | Generates a function that takes a 'LogSource', a level name and a 'Text' and logs a 'LevelOther' message. Usage:
|
||||
---
|
||||
--- > $logOther "SomeSource" "My new level" "This is a log message"
|
||||
-logOtherS :: Q Exp
|
||||
-logOtherS = [|\src level msg -> monadLoggerLogSource $(qLocation >>= liftLoc) src (LevelOther level) (msg :: Text)|]
|
||||
-
|
||||
-- | Monad transformer that adds a new logging function.
|
||||
--
|
||||
-- Since 0.2.2
|
||||
diff --git a/monad-logger.cabal b/monad-logger.cabal
|
||||
index ab71424..fa3d292 100644
|
||||
--- a/monad-logger.cabal
|
||||
+++ b/monad-logger.cabal
|
||||
@@ -24,4 +24,4 @@ library
|
||||
, transformers-base
|
||||
, monad-control
|
||||
, mtl
|
||||
- , bytestring
|
||||
+ , bytestring >= 0.10.3.0
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -0,0 +1,43 @@
|
|||
From 3e05f3a3bf886c302fb6d6caa7ee92cf9736b6ad Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:33:45 -0400
|
||||
Subject: [PATCH] NoDelay does not work on Android
|
||||
|
||||
(I think the other change is no-op)
|
||||
---
|
||||
Data/Conduit/Network/Utils.hs | 6 +++---
|
||||
1 file changed, 3 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/Data/Conduit/Network/Utils.hs b/Data/Conduit/Network/Utils.hs
|
||||
index 32a7286..01ff84e 100644
|
||||
--- a/Data/Conduit/Network/Utils.hs
|
||||
+++ b/Data/Conduit/Network/Utils.hs
|
||||
@@ -6,14 +6,14 @@ module Data.Conduit.Network.Utils
|
||||
, getSocket
|
||||
) where
|
||||
|
||||
-import Network.Socket (AddrInfo, Socket, SocketType)
|
||||
+import Network.Socket (Socket, SocketType)
|
||||
import qualified Network.Socket as NS
|
||||
import Data.String (IsString (fromString))
|
||||
import Control.Exception (bracketOnError, IOException)
|
||||
import qualified Control.Exception as E
|
||||
|
||||
-- | Attempt to connect to the given host/port using given @SocketType@.
|
||||
-getSocket :: String -> Int -> SocketType -> IO (Socket, AddrInfo)
|
||||
+getSocket :: String -> Int -> SocketType -> IO (Socket, NS.AddrInfo)
|
||||
getSocket host' port' sockettype = do
|
||||
let hints = NS.defaultHints {
|
||||
NS.addrFlags = [NS.AI_ADDRCONFIG]
|
||||
@@ -93,7 +93,7 @@ bindPort p s sockettype = do
|
||||
sockOpts =
|
||||
case sockettype of
|
||||
NS.Datagram -> [(NS.ReuseAddr,1)]
|
||||
- _ -> [(NS.NoDelay,1), (NS.ReuseAddr,1)]
|
||||
+ _ -> [(NS.ReuseAddr,1)] -- Android seems to not have NoDelay
|
||||
|
||||
theBody addr =
|
||||
bracketOnError
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
From 8fddef803ee9191ca15363283b7e4d5af4c70f3a Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:34:10 -0400
|
||||
Subject: [PATCH] disable TH
|
||||
|
||||
---
|
||||
Database/Persist/GenericSql/Internal.hs | 6 +-----
|
||||
Database/Persist/GenericSql/Raw.hs | 5 ++---
|
||||
2 files changed, 3 insertions(+), 8 deletions(-)
|
||||
|
||||
diff --git a/Database/Persist/GenericSql/Internal.hs b/Database/Persist/GenericSql/Internal.hs
|
||||
index f109887..5273398 100644
|
||||
--- a/Database/Persist/GenericSql/Internal.hs
|
||||
+++ b/Database/Persist/GenericSql/Internal.hs
|
||||
@@ -14,7 +14,6 @@ module Database.Persist.GenericSql.Internal
|
||||
, createSqlPool
|
||||
, mkColumns
|
||||
, Column (..)
|
||||
- , logSQL
|
||||
, InsertSqlResult (..)
|
||||
) where
|
||||
|
||||
@@ -33,7 +32,7 @@ import Data.Monoid (Monoid, mappend, mconcat)
|
||||
import Database.Persist.EntityDef
|
||||
import qualified Data.Conduit as C
|
||||
import Language.Haskell.TH.Syntax (Q, Exp)
|
||||
-import Control.Monad.Logger (logDebugS)
|
||||
+
|
||||
import Data.Maybe (mapMaybe, listToMaybe)
|
||||
import Data.Int (Int64)
|
||||
|
||||
@@ -197,6 +196,3 @@ tableColumn t s = go $ entityColumns t
|
||||
| x == s = ColumnDef x y z
|
||||
| otherwise = go rest
|
||||
-}
|
||||
-
|
||||
-logSQL :: Q Exp
|
||||
-logSQL = [|\sql_foo params_foo -> $logDebugS (T.pack "SQL") $ T.pack $ show (sql_foo :: Text) ++ " " ++ show (params_foo :: [PersistValue])|]
|
||||
diff --git a/Database/Persist/GenericSql/Raw.hs b/Database/Persist/GenericSql/Raw.hs
|
||||
index e4bf9f4..3da8fa0 100644
|
||||
--- a/Database/Persist/GenericSql/Raw.hs
|
||||
+++ b/Database/Persist/GenericSql/Raw.hs
|
||||
@@ -26,7 +26,6 @@ import Database.Persist.GenericSql.Internal hiding (execute, withStmt)
|
||||
import Database.Persist.Store (PersistValue)
|
||||
import Data.IORef
|
||||
import Control.Monad.IO.Class
|
||||
-import Control.Monad.Logger (logDebugS)
|
||||
import Control.Monad.Trans.Reader
|
||||
import qualified Data.Map as Map
|
||||
import Control.Applicative (Applicative)
|
||||
@@ -134,7 +133,7 @@ withStmt :: (MonadSqlPersist m, MonadResource m)
|
||||
-> [PersistValue]
|
||||
-> Source m [PersistValue]
|
||||
withStmt sql vals = do
|
||||
- lift $ $logDebugS (pack "SQL") $ pack $ show sql ++ " " ++ show vals
|
||||
+ -- lift $ pack $ show sql ++ " " ++ show vals
|
||||
conn <- lift askSqlConn
|
||||
bracketP
|
||||
(getStmt' conn sql)
|
||||
@@ -146,7 +145,7 @@ execute x y = liftM (const ()) $ executeCount x y
|
||||
|
||||
executeCount :: MonadSqlPersist m => Text -> [PersistValue] -> m Int64
|
||||
executeCount sql vals = do
|
||||
- $logDebugS (pack "SQL") $ pack $ show sql ++ " " ++ show vals
|
||||
+ -- pack $ show sql ++ " " ++ show vals
|
||||
stmt <- getStmt sql
|
||||
res <- liftIO $ I.execute stmt vals
|
||||
liftIO $ reset stmt
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
From 5cb5c3dabb213f809b8328b0b4049f7c754e9c77 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:34:32 -0400
|
||||
Subject: [PATCH] disable i386 opt stuff to allow cross-compilation
|
||||
|
||||
---
|
||||
primitive.cabal | 3 ---
|
||||
1 file changed, 3 deletions(-)
|
||||
|
||||
diff --git a/primitive.cabal b/primitive.cabal
|
||||
index 8c4328a..9a6093f 100644
|
||||
--- a/primitive.cabal
|
||||
+++ b/primitive.cabal
|
||||
@@ -51,7 +51,4 @@ Library
|
||||
includes: primitive-memops.h
|
||||
c-sources: cbits/primitive-memops.c
|
||||
cc-options: -O3 -ftree-vectorize -fomit-frame-pointer
|
||||
- if arch(i386) || arch(x86_64) {
|
||||
- cc-options: -msse2
|
||||
- }
|
||||
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
From c10ab80793a21dce0c7516725e1ca3b36a87aa25 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:35:08 -0400
|
||||
Subject: [PATCH] hack to build with hacked up lifted-base, which is currently
|
||||
lacking a mask
|
||||
|
||||
---
|
||||
Control/Monad/Trans/Resource.hs | 6 +++---
|
||||
1 file changed, 3 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/Control/Monad/Trans/Resource.hs b/Control/Monad/Trans/Resource.hs
|
||||
index d209dd8..61ab349 100644
|
||||
--- a/Control/Monad/Trans/Resource.hs
|
||||
+++ b/Control/Monad/Trans/Resource.hs
|
||||
@@ -5,7 +5,7 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
-{-# LANGUAGE DeriveDataTypeable #-}
|
||||
+{-# LANGUAGE DeriveDataTypeable, ImpredicativeTypes #-}
|
||||
#if __GLASGOW_HASKELL__ >= 704
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
#endif
|
||||
@@ -554,7 +554,7 @@ GOX(Monoid w, Strict.WriterT w)
|
||||
--
|
||||
-- Since 0.3.0
|
||||
resourceForkIO :: MonadBaseControl IO m => ResourceT m () -> ResourceT m ThreadId
|
||||
-resourceForkIO (ResourceT f) = ResourceT $ \r -> L.mask $ \restore ->
|
||||
+resourceForkIO (ResourceT f) = ResourceT $ \r ->
|
||||
-- We need to make sure the counter is incremented before this call
|
||||
-- returns. Otherwise, the parent thread may call runResourceT before
|
||||
-- the child thread increments, and all resources will be freed
|
||||
@@ -565,7 +565,7 @@ resourceForkIO (ResourceT f) = ResourceT $ \r -> L.mask $ \restore ->
|
||||
(liftBaseDiscard forkIO $ bracket_
|
||||
(return ())
|
||||
(stateCleanup r)
|
||||
- (restore $ f r))
|
||||
+ (return ()))
|
||||
|
||||
-- | A @Monad@ based on some monad which allows running of some 'IO' actions,
|
||||
-- via unsafe calls. This applies to 'IO' and 'ST', for instance.
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,194 @@
|
|||
From 2e6721d571148cb77fb8c906042f6fa61e660999 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:35:41 -0400
|
||||
Subject: [PATCH] remove TH
|
||||
|
||||
---
|
||||
Text/Shakespeare.hs | 109 ----------------------------------------------
|
||||
Text/Shakespeare/Base.hs | 28 ------------
|
||||
2 files changed, 137 deletions(-)
|
||||
|
||||
diff --git a/Text/Shakespeare.hs b/Text/Shakespeare.hs
|
||||
index e774e65..d300951 100644
|
||||
--- a/Text/Shakespeare.hs
|
||||
+++ b/Text/Shakespeare.hs
|
||||
@@ -12,11 +12,7 @@ module Text.Shakespeare
|
||||
, WrapInsertion (..)
|
||||
, PreConversion (..)
|
||||
, defaultShakespeareSettings
|
||||
- , shakespeare
|
||||
- , shakespeareFile
|
||||
- , shakespeareFileReload
|
||||
-- * low-level
|
||||
- , shakespeareFromString
|
||||
, shakespeareUsedIdentifiers
|
||||
, RenderUrl
|
||||
, VarType
|
||||
@@ -133,39 +129,6 @@ defaultShakespeareSettings = ShakespeareSettings {
|
||||
, modifyFinalValue = Nothing
|
||||
}
|
||||
|
||||
-instance Lift PreConvert where
|
||||
- lift (PreConvert convert ignore comment wrapInsertion) =
|
||||
- [|PreConvert $(lift convert) $(lift ignore) $(lift comment) $(lift wrapInsertion)|]
|
||||
-
|
||||
-instance Lift WrapInsertion where
|
||||
- lift (WrapInsertion indent sb sep sc e ab ac) =
|
||||
- [|WrapInsertion $(lift indent) $(lift sb) $(lift sep) $(lift sc) $(lift e) $(lift ab) $(lift ac)|]
|
||||
-
|
||||
-instance Lift PreConversion where
|
||||
- lift (ReadProcess command args) =
|
||||
- [|ReadProcess $(lift command) $(lift args)|]
|
||||
- lift Id = [|Id|]
|
||||
-
|
||||
-instance Lift ShakespeareSettings where
|
||||
- lift (ShakespeareSettings x1 x2 x3 x4 x5 x6 x7 x8 x9) =
|
||||
- [|ShakespeareSettings
|
||||
- $(lift x1) $(lift x2) $(lift x3)
|
||||
- $(liftExp x4) $(liftExp x5) $(liftExp x6) $(lift x7) $(lift x8) $(liftMExp x9)|]
|
||||
- where
|
||||
- liftExp (VarE n) = [|VarE $(liftName n)|]
|
||||
- liftExp (ConE n) = [|ConE $(liftName n)|]
|
||||
- liftExp _ = error "liftExp only supports VarE and ConE"
|
||||
- liftMExp Nothing = [|Nothing|]
|
||||
- liftMExp (Just e) = [|Just|] `appE` liftExp e
|
||||
- liftName (Name (OccName a) b) = [|Name (OccName $(lift a)) $(liftFlavour b)|]
|
||||
- liftFlavour NameS = [|NameS|]
|
||||
- liftFlavour (NameQ (ModName a)) = [|NameQ (ModName $(lift a))|]
|
||||
- liftFlavour (NameU _) = error "liftFlavour NameU" -- [|NameU $(lift $ fromIntegral a)|]
|
||||
- liftFlavour (NameL _) = error "liftFlavour NameL" -- [|NameU $(lift $ fromIntegral a)|]
|
||||
- liftFlavour (NameG ns (PkgName p) (ModName m)) = [|NameG $(liftNS ns) (PkgName $(lift p)) (ModName $(lift m))|]
|
||||
- liftNS VarName = [|VarName|]
|
||||
- liftNS DataName = [|DataName|]
|
||||
-
|
||||
type QueryParameters = [(TS.Text, TS.Text)]
|
||||
type RenderUrl url = (url -> QueryParameters -> TS.Text)
|
||||
type Shakespeare url = RenderUrl url -> Builder
|
||||
@@ -300,54 +263,6 @@ pack' = TS.pack
|
||||
{-# NOINLINE pack' #-}
|
||||
#endif
|
||||
|
||||
-contentsToShakespeare :: ShakespeareSettings -> [Content] -> Q Exp
|
||||
-contentsToShakespeare rs a = do
|
||||
- r <- newName "_render"
|
||||
- c <- mapM (contentToBuilder r) a
|
||||
- compiledTemplate <- case c of
|
||||
- -- Make sure we convert this mempty using toBuilder to pin down the
|
||||
- -- type appropriately
|
||||
- [] -> fmap (AppE $ wrap rs) [|mempty|]
|
||||
- [x] -> return x
|
||||
- _ -> do
|
||||
- mc <- [|mconcat|]
|
||||
- return $ mc `AppE` ListE c
|
||||
- fmap (maybe id AppE $ modifyFinalValue rs) $
|
||||
- if justVarInterpolation rs
|
||||
- then return compiledTemplate
|
||||
- else return $ LamE [VarP r] compiledTemplate
|
||||
- where
|
||||
- contentToBuilder :: Name -> Content -> Q Exp
|
||||
- contentToBuilder _ (ContentRaw s') = do
|
||||
- ts <- [|fromText . pack'|]
|
||||
- return $ wrap rs `AppE` (ts `AppE` LitE (StringL s'))
|
||||
- contentToBuilder _ (ContentVar d) =
|
||||
- return $ wrap rs `AppE` (toBuilder rs `AppE` derefToExp [] d)
|
||||
- contentToBuilder r (ContentUrl d) = do
|
||||
- ts <- [|fromText|]
|
||||
- return $ wrap rs `AppE` (ts `AppE` (VarE r `AppE` derefToExp [] d `AppE` ListE []))
|
||||
- contentToBuilder r (ContentUrlParam d) = do
|
||||
- ts <- [|fromText|]
|
||||
- up <- [|\r' (u, p) -> r' u p|]
|
||||
- return $ wrap rs `AppE` (ts `AppE` (up `AppE` VarE r `AppE` derefToExp [] d))
|
||||
- contentToBuilder r (ContentMix d) =
|
||||
- return $ derefToExp [] d `AppE` VarE r
|
||||
-
|
||||
-shakespeare :: ShakespeareSettings -> QuasiQuoter
|
||||
-shakespeare r = QuasiQuoter { quoteExp = shakespeareFromString r }
|
||||
-
|
||||
-shakespeareFromString :: ShakespeareSettings -> String -> Q Exp
|
||||
-shakespeareFromString r str = do
|
||||
- s <- qRunIO $ preFilter r str
|
||||
- contentsToShakespeare r $ contentFromString r s
|
||||
-
|
||||
-shakespeareFile :: ShakespeareSettings -> FilePath -> Q Exp
|
||||
-shakespeareFile r fp = do
|
||||
-#ifdef GHC_7_4
|
||||
- qAddDependentFile fp
|
||||
-#endif
|
||||
- readFileQ fp >>= shakespeareFromString r
|
||||
-
|
||||
data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin
|
||||
|
||||
getVars :: Content -> [(Deref, VarType)]
|
||||
@@ -367,30 +282,6 @@ data VarExp url = EPlain Builder
|
||||
shakespeareUsedIdentifiers :: ShakespeareSettings -> String -> [(Deref, VarType)]
|
||||
shakespeareUsedIdentifiers settings = concatMap getVars . contentFromString settings
|
||||
|
||||
-shakespeareFileReload :: ShakespeareSettings -> FilePath -> Q Exp
|
||||
-shakespeareFileReload rs fp = do
|
||||
- str <- readFileQ fp
|
||||
- s <- qRunIO $ preFilter rs str
|
||||
- let b = shakespeareUsedIdentifiers rs s
|
||||
- c <- mapM vtToExp b
|
||||
- rt <- [|shakespeareRuntime|]
|
||||
- wrap' <- [|\x -> $(return $ wrap rs) . x|]
|
||||
- r' <- lift rs
|
||||
- return $ wrap' `AppE` (rt `AppE` r' `AppE` (LitE $ StringL fp) `AppE` ListE c)
|
||||
- where
|
||||
- vtToExp :: (Deref, VarType) -> Q Exp
|
||||
- vtToExp (d, vt) = do
|
||||
- d' <- lift d
|
||||
- c' <- c vt
|
||||
- return $ TupE [d', c' `AppE` derefToExp [] d]
|
||||
- where
|
||||
- c :: VarType -> Q Exp
|
||||
- c VTPlain = [|EPlain . $(return $ toBuilder rs)|]
|
||||
- c VTUrl = [|EUrl|]
|
||||
- c VTUrlParam = [|EUrlParam|]
|
||||
- c VTMixin = [|\x -> EMixin $ \r -> $(return $ unwrap rs) $ x r|]
|
||||
-
|
||||
-
|
||||
shakespeareRuntime :: ShakespeareSettings -> FilePath -> [(Deref, VarExp url)] -> Shakespeare url
|
||||
shakespeareRuntime rs fp cd render' = unsafePerformIO $ do
|
||||
str <- readFileUtf8 fp
|
||||
diff --git a/Text/Shakespeare/Base.hs b/Text/Shakespeare/Base.hs
|
||||
index 7c96898..ef769b1 100644
|
||||
--- a/Text/Shakespeare/Base.hs
|
||||
+++ b/Text/Shakespeare/Base.hs
|
||||
@@ -52,34 +52,6 @@ data Deref = DerefModulesIdent [String] Ident
|
||||
| DerefTuple [Deref]
|
||||
deriving (Show, Eq, Read, Data, Typeable, Ord)
|
||||
|
||||
-instance Lift Ident where
|
||||
- lift (Ident s) = [|Ident|] `appE` lift s
|
||||
-instance Lift Deref where
|
||||
- lift (DerefModulesIdent v s) = do
|
||||
- dl <- [|DerefModulesIdent|]
|
||||
- v' <- lift v
|
||||
- s' <- lift s
|
||||
- return $ dl `AppE` v' `AppE` s'
|
||||
- lift (DerefIdent s) = do
|
||||
- dl <- [|DerefIdent|]
|
||||
- s' <- lift s
|
||||
- return $ dl `AppE` s'
|
||||
- lift (DerefBranch x y) = do
|
||||
- x' <- lift x
|
||||
- y' <- lift y
|
||||
- db <- [|DerefBranch|]
|
||||
- return $ db `AppE` x' `AppE` y'
|
||||
- lift (DerefIntegral i) = [|DerefIntegral|] `appE` lift i
|
||||
- lift (DerefRational r) = do
|
||||
- n <- lift $ numerator r
|
||||
- d <- lift $ denominator r
|
||||
- per <- [|(%) :: Int -> Int -> Ratio Int|]
|
||||
- dr <- [|DerefRational|]
|
||||
- return $ dr `AppE` InfixE (Just n) per (Just d)
|
||||
- lift (DerefString s) = [|DerefString|] `appE` lift s
|
||||
- lift (DerefList x) = [|DerefList $(lift x)|]
|
||||
- lift (DerefTuple x) = [|DerefTuple $(lift x)|]
|
||||
-
|
||||
derefParens, derefCurlyBrackets :: UserParser a Deref
|
||||
derefParens = between (char '(') (char ')') parseDeref
|
||||
derefCurlyBrackets = between (char '{') (char '}') parseDeref
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,260 @@
|
|||
From cb77113314702175f066cd801dee5c38d3e26576 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:35:51 -0400
|
||||
Subject: [PATCH] remove TH
|
||||
|
||||
---
|
||||
Text/Cassius.hs | 23 ---------------
|
||||
Text/Css.hs | 84 -----------------------------------------------------
|
||||
Text/CssCommon.hs | 4 ---
|
||||
Text/Lucius.hs | 30 +------------------
|
||||
4 files changed, 1 insertion(+), 140 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 8e6fc09..401a166 100644
|
||||
--- a/Text/Css.hs
|
||||
+++ b/Text/Css.hs
|
||||
@@ -108,19 +108,6 @@ cssUsedIdentifiers toi2b parseBlocks s' =
|
||||
(scope, rest') = go rest
|
||||
go' (k, v) = k ++ v
|
||||
|
||||
-cssFileDebug :: Bool -- ^ perform the indent-to-brace conversion
|
||||
- -> Q Exp -> Parser [TopLevel] -> FilePath -> Q Exp
|
||||
-cssFileDebug toi2b parseBlocks' parseBlocks fp = do
|
||||
- s <- fmap TL.unpack $ qRunIO $ readUtf8File fp
|
||||
-#ifdef GHC_7_4
|
||||
- qAddDependentFile fp
|
||||
-#endif
|
||||
- let vs = cssUsedIdentifiers toi2b parseBlocks s
|
||||
- c <- mapM vtToExp vs
|
||||
- cr <- [|cssRuntime toi2b|]
|
||||
- parseBlocks'' <- parseBlocks'
|
||||
- return $ cr `AppE` parseBlocks'' `AppE` (LitE $ StringL fp) `AppE` ListE c
|
||||
-
|
||||
combineSelectors :: Selector -> Selector -> Selector
|
||||
combineSelectors a b = do
|
||||
a' <- a
|
||||
@@ -202,17 +189,6 @@ cssRuntime toi2b parseBlocks fp cd render' = unsafePerformIO $ do
|
||||
|
||||
addScope scope = map (DerefIdent . Ident *** CDPlain . fromString) scope ++ cd
|
||||
|
||||
-vtToExp :: (Deref, VarType) -> Q Exp
|
||||
-vtToExp (d, vt) = do
|
||||
- d' <- lift d
|
||||
- c' <- c vt
|
||||
- return $ TupE [d', c' `AppE` derefToExp [] d]
|
||||
- where
|
||||
- c :: VarType -> Q Exp
|
||||
- c VTPlain = [|CDPlain . toCss|]
|
||||
- c VTUrl = [|CDUrl|]
|
||||
- c VTUrlParam = [|CDUrlParam|]
|
||||
-
|
||||
getVars :: Monad m => [(String, String)] -> Content -> m [(Deref, VarType)]
|
||||
getVars _ ContentRaw{} = return []
|
||||
getVars scope (ContentVar d) =
|
||||
@@ -268,68 +244,8 @@ compressBlock (Block x y blocks) =
|
||||
cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c
|
||||
cc (a:b) = a : cc b
|
||||
|
||||
-blockToCss :: Name -> Scope -> Block -> Q Exp
|
||||
-blockToCss r scope (Block sel props subblocks) =
|
||||
- [|(:) (Css' $(selectorToBuilder r scope sel) $(listE $ map go props))
|
||||
- . foldr (.) id $(listE $ map subGo subblocks)
|
||||
- |]
|
||||
- where
|
||||
- go (x, y) = tupE [contentsToBuilder r scope x, contentsToBuilder r scope y]
|
||||
- subGo (Block sel' b c) =
|
||||
- blockToCss r scope $ Block sel'' b c
|
||||
- where
|
||||
- sel'' = combineSelectors sel sel'
|
||||
-
|
||||
-selectorToBuilder :: Name -> Scope -> Selector -> Q Exp
|
||||
-selectorToBuilder r scope sels =
|
||||
- contentsToBuilder r scope $ intercalate [ContentRaw ","] sels
|
||||
-
|
||||
-contentsToBuilder :: Name -> Scope -> [Content] -> Q Exp
|
||||
-contentsToBuilder r scope contents =
|
||||
- appE [|mconcat|] $ listE $ map (contentToBuilder r scope) contents
|
||||
-
|
||||
-contentToBuilder :: Name -> Scope -> Content -> Q Exp
|
||||
-contentToBuilder _ _ (ContentRaw x) =
|
||||
- [|fromText . pack|] `appE` litE (StringL x)
|
||||
-contentToBuilder _ scope (ContentVar d) =
|
||||
- case d of
|
||||
- DerefIdent (Ident s)
|
||||
- | Just val <- lookup s scope -> [|fromText . pack|] `appE` litE (StringL val)
|
||||
- _ -> [|toCss|] `appE` return (derefToExp [] d)
|
||||
-contentToBuilder r _ (ContentUrl u) =
|
||||
- [|fromText|] `appE`
|
||||
- (varE r `appE` return (derefToExp [] u) `appE` listE [])
|
||||
-contentToBuilder r _ (ContentUrlParam u) =
|
||||
- [|fromText|] `appE`
|
||||
- ([|uncurry|] `appE` varE r `appE` return (derefToExp [] u))
|
||||
-
|
||||
type Scope = [(String, String)]
|
||||
|
||||
-topLevelsToCassius :: [TopLevel] -> Q Exp
|
||||
-topLevelsToCassius a = do
|
||||
- r <- newName "_render"
|
||||
- lamE [varP r] $ appE [|CssNoWhitespace . foldr ($) []|] $ fmap ListE $ go r [] a
|
||||
- where
|
||||
- go _ _ [] = return []
|
||||
- go r scope (TopBlock b:rest) = do
|
||||
- e <- [|(++) $ map Css ($(blockToCss r scope b) [])|]
|
||||
- es <- go r scope rest
|
||||
- return $ e : es
|
||||
- go r scope (TopAtBlock name s b:rest) = do
|
||||
- let s' = contentsToBuilder r scope s
|
||||
- e <- [|(:) $ AtBlock $(lift name) $(s') $(blocksToCassius r scope b)|]
|
||||
- es <- go r scope rest
|
||||
- return $ e : es
|
||||
- go r scope (TopAtDecl dec cs:rest) = do
|
||||
- e <- [|(:) $ AtDecl $(lift dec) $(contentsToBuilder r scope cs)|]
|
||||
- es <- go r scope rest
|
||||
- return $ e : es
|
||||
- go r scope (TopVar k v:rest) = go r ((k, v) : scope) rest
|
||||
-
|
||||
-blocksToCassius :: Name -> Scope -> [Block] -> Q Exp
|
||||
-blocksToCassius r scope a = do
|
||||
- appE [|foldr ($) []|] $ listE $ map (blockToCss r scope) a
|
||||
-
|
||||
renderCss :: Css -> TL.Text
|
||||
renderCss css =
|
||||
toLazyText $ mconcat $ map go tops-- FIXME use a foldr
|
||||
diff --git a/Text/CssCommon.hs b/Text/CssCommon.hs
|
||||
index 719e0a8..8c40e8c 100644
|
||||
--- a/Text/CssCommon.hs
|
||||
+++ 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 b71614e..a902e1c 100644
|
||||
--- a/Text/Lucius.hs
|
||||
+++ b/Text/Lucius.hs
|
||||
@@ -6,12 +6,8 @@
|
||||
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
|
||||
module Text.Lucius
|
||||
( -- * Parsing
|
||||
- lucius
|
||||
- , luciusFile
|
||||
- , luciusFileDebug
|
||||
- , luciusFileReload
|
||||
-- ** Runtime
|
||||
- , luciusRT
|
||||
+ luciusRT
|
||||
, luciusRT'
|
||||
, -- * Datatypes
|
||||
Css
|
||||
@@ -31,11 +27,8 @@ module Text.Lucius
|
||||
, AbsoluteUnit (..)
|
||||
, AbsoluteSize (..)
|
||||
, absoluteSize
|
||||
- , EmSize (..)
|
||||
- , ExSize (..)
|
||||
, PercentageSize (..)
|
||||
, percentageSize
|
||||
- , PixelSize (..)
|
||||
-- * Internal
|
||||
, parseTopLevels
|
||||
, luciusUsedIdentifiers
|
||||
@@ -57,18 +50,6 @@ import Data.Either (partitionEithers)
|
||||
import Data.Monoid (mconcat)
|
||||
import Data.List (isSuffixOf)
|
||||
|
||||
--- |
|
||||
---
|
||||
--- >>> 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 ()
|
||||
|
||||
@@ -179,15 +160,6 @@ parseComment = do
|
||||
_ <- manyTill anyChar $ try $ string "*/"
|
||||
return $ ContentRaw ""
|
||||
|
||||
-luciusFile :: FilePath -> Q Exp
|
||||
-luciusFile fp = do
|
||||
- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
|
||||
- luciusFromString contents
|
||||
-
|
||||
-luciusFileDebug, luciusFileReload :: FilePath -> Q Exp
|
||||
-luciusFileDebug = cssFileDebug False [|parseTopLevels|] parseTopLevels
|
||||
-luciusFileReload = luciusFileDebug
|
||||
-
|
||||
parseTopLevels :: Parser [TopLevel]
|
||||
parseTopLevels =
|
||||
go id
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,162 @@
|
|||
From b128412ecee9677b788abecbbf1fd1edd447eea2 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:35:59 -0400
|
||||
Subject: [PATCH] remove TH
|
||||
|
||||
---
|
||||
Text/Shakespeare/I18N.hs | 130 +---------------------------------------------
|
||||
1 file changed, 1 insertion(+), 129 deletions(-)
|
||||
|
||||
diff --git a/Text/Shakespeare/I18N.hs b/Text/Shakespeare/I18N.hs
|
||||
index 1b486ed..aa5e358 100644
|
||||
--- a/Text/Shakespeare/I18N.hs
|
||||
+++ b/Text/Shakespeare/I18N.hs
|
||||
@@ -51,10 +51,7 @@
|
||||
--
|
||||
-- You can also adapt those instructions for use with other systems.
|
||||
module Text.Shakespeare.I18N
|
||||
- ( mkMessage
|
||||
- , mkMessageFor
|
||||
- , mkMessageVariant
|
||||
- , RenderMessage (..)
|
||||
+ ( RenderMessage (..)
|
||||
, ToMessage (..)
|
||||
, SomeMessage (..)
|
||||
, Lang
|
||||
@@ -115,133 +112,8 @@ type Lang = Text
|
||||
--
|
||||
-- 3. create a 'RenderMessage' instance
|
||||
--
|
||||
-mkMessage :: String -- ^ base name to use for translation type
|
||||
- -> FilePath -- ^ subdirectory which contains the translation files
|
||||
- -> Lang -- ^ default translation language
|
||||
- -> Q [Dec]
|
||||
-mkMessage dt folder lang =
|
||||
- mkMessageCommon True "Msg" "Message" dt dt folder lang
|
||||
|
||||
|
||||
--- | create 'RenderMessage' instance for an existing data-type
|
||||
-mkMessageFor :: String -- ^ master translation data type
|
||||
- -> String -- ^ existing type to add translations for
|
||||
- -> FilePath -- ^ path to translation folder
|
||||
- -> Lang -- ^ default language
|
||||
- -> Q [Dec]
|
||||
-mkMessageFor master dt folder lang = mkMessageCommon False "" "" master dt folder lang
|
||||
-
|
||||
--- | create an additional set of translations for a type created by `mkMessage`
|
||||
-mkMessageVariant :: String -- ^ master translation data type
|
||||
- -> String -- ^ existing type to add translations for
|
||||
- -> FilePath -- ^ path to translation folder
|
||||
- -> Lang -- ^ default language
|
||||
- -> Q [Dec]
|
||||
-mkMessageVariant master dt folder lang = mkMessageCommon False "Msg" "Message" master dt folder lang
|
||||
-
|
||||
--- |used by 'mkMessage' and 'mkMessageFor' to generate a 'RenderMessage' and possibly a message data type
|
||||
-mkMessageCommon :: Bool -- ^ generate a new datatype from the constructors found in the .msg files
|
||||
- -> String -- ^ string to append to constructor names
|
||||
- -> String -- ^ string to append to datatype name
|
||||
- -> String -- ^ base name of master datatype
|
||||
- -> String -- ^ base name of translation datatype
|
||||
- -> FilePath -- ^ path to translation folder
|
||||
- -> Lang -- ^ default lang
|
||||
- -> Q [Dec]
|
||||
-mkMessageCommon genType prefix postfix master dt folder lang = do
|
||||
- files <- qRunIO $ getDirectoryContents folder
|
||||
- (_files', contents) <- qRunIO $ fmap (unzip . catMaybes) $ mapM (loadLang folder) files
|
||||
-#ifdef GHC_7_4
|
||||
- mapM_ qAddDependentFile _files'
|
||||
-#endif
|
||||
- sdef <-
|
||||
- case lookup lang contents of
|
||||
- Nothing -> error $ "Did not find main language file: " ++ unpack lang
|
||||
- Just def -> toSDefs def
|
||||
- mapM_ (checkDef sdef) $ map snd contents
|
||||
- let mname = mkName $ dt ++ postfix
|
||||
- c1 <- fmap concat $ mapM (toClauses prefix dt) contents
|
||||
- c2 <- mapM (sToClause prefix dt) sdef
|
||||
- c3 <- defClause
|
||||
- return $
|
||||
- ( if genType
|
||||
- then ((DataD [] mname [] (map (toCon dt) sdef) []) :)
|
||||
- else id)
|
||||
- [ InstanceD
|
||||
- []
|
||||
- (ConT ''RenderMessage `AppT` (ConT $ mkName master) `AppT` ConT mname)
|
||||
- [ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [c3]
|
||||
- ]
|
||||
- ]
|
||||
-
|
||||
-toClauses :: String -> String -> (Lang, [Def]) -> Q [Clause]
|
||||
-toClauses prefix dt (lang, defs) =
|
||||
- mapM go defs
|
||||
- where
|
||||
- go def = do
|
||||
- a <- newName "lang"
|
||||
- (pat, bod) <- mkBody dt (prefix ++ constr def) (map fst $ vars def) (content def)
|
||||
- guard <- fmap NormalG [|$(return $ VarE a) == pack $(lift $ unpack lang)|]
|
||||
- return $ Clause
|
||||
- [WildP, ConP (mkName ":") [VarP a, WildP], pat]
|
||||
- (GuardedB [(guard, bod)])
|
||||
- []
|
||||
-
|
||||
-mkBody :: String -- ^ datatype
|
||||
- -> String -- ^ constructor
|
||||
- -> [String] -- ^ variable names
|
||||
- -> [Content]
|
||||
- -> Q (Pat, Exp)
|
||||
-mkBody dt cs vs ct = do
|
||||
- vp <- mapM go vs
|
||||
- let pat = RecP (mkName cs) (map (varName dt *** VarP) vp)
|
||||
- let ct' = map (fixVars vp) ct
|
||||
- pack' <- [|Data.Text.pack|]
|
||||
- tomsg <- [|toMessage|]
|
||||
- let ct'' = map (toH pack' tomsg) ct'
|
||||
- mapp <- [|mappend|]
|
||||
- let app a b = InfixE (Just a) mapp (Just b)
|
||||
- e <-
|
||||
- case ct'' of
|
||||
- [] -> [|mempty|]
|
||||
- [x] -> return x
|
||||
- (x:xs) -> return $ foldl' app x xs
|
||||
- return (pat, e)
|
||||
- where
|
||||
- toH pack' _ (Raw s) = pack' `AppE` SigE (LitE (StringL s)) (ConT ''String)
|
||||
- toH _ tomsg (Var d) = tomsg `AppE` derefToExp [] d
|
||||
- go x = do
|
||||
- let y = mkName $ '_' : x
|
||||
- return (x, y)
|
||||
- fixVars vp (Var d) = Var $ fixDeref vp d
|
||||
- fixVars _ (Raw s) = Raw s
|
||||
- fixDeref vp (DerefIdent (Ident i)) = DerefIdent $ Ident $ fixIdent vp i
|
||||
- fixDeref vp (DerefBranch a b) = DerefBranch (fixDeref vp a) (fixDeref vp b)
|
||||
- fixDeref _ d = d
|
||||
- fixIdent vp i =
|
||||
- case lookup i vp of
|
||||
- Nothing -> i
|
||||
- Just y -> nameBase y
|
||||
-
|
||||
-sToClause :: String -> String -> SDef -> Q Clause
|
||||
-sToClause prefix dt sdef = do
|
||||
- (pat, bod) <- mkBody dt (prefix ++ sconstr sdef) (map fst $ svars sdef) (scontent sdef)
|
||||
- return $ Clause
|
||||
- [WildP, ConP (mkName "[]") [], pat]
|
||||
- (NormalB bod)
|
||||
- []
|
||||
-
|
||||
-defClause :: Q Clause
|
||||
-defClause = do
|
||||
- a <- newName "sub"
|
||||
- c <- newName "langs"
|
||||
- d <- newName "msg"
|
||||
- rm <- [|renderMessage|]
|
||||
- return $ Clause
|
||||
- [VarP a, ConP (mkName ":") [WildP, VarP c], VarP d]
|
||||
- (NormalB $ rm `AppE` VarE a `AppE` VarE c `AppE` VarE d)
|
||||
- []
|
||||
-
|
||||
toCon :: String -> SDef -> Con
|
||||
toCon dt (SDef c vs _) =
|
||||
RecC (mkName $ "Msg" ++ c) $ map go vs
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,303 @@
|
|||
From f3e31696cfb45a528e4b4b6f016dc7101d7cd4fb Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:36:06 -0400
|
||||
Subject: [PATCH] remove TH
|
||||
|
||||
---
|
||||
Text/Coffee.hs | 54 -------------------------------------------------
|
||||
Text/Julius.hs | 53 +-----------------------------------------------
|
||||
Text/Roy.hs | 54 -------------------------------------------------
|
||||
Text/TypeScript.hs | 57 +---------------------------------------------------
|
||||
4 files changed, 2 insertions(+), 216 deletions(-)
|
||||
|
||||
diff --git a/Text/Coffee.hs b/Text/Coffee.hs
|
||||
index 2481936..3f7f9c3 100644
|
||||
--- a/Text/Coffee.hs
|
||||
+++ b/Text/Coffee.hs
|
||||
@@ -51,14 +51,6 @@ module Text.Coffee
|
||||
-- ** Template-Reading Functions
|
||||
-- | These QuasiQuoter and Template Haskell methods return values of
|
||||
-- type @'JavascriptUrl' url@. See the Yesod book for details.
|
||||
- coffee
|
||||
- , coffeeFile
|
||||
- , coffeeFileReload
|
||||
- , coffeeFileDebug
|
||||
-
|
||||
-#ifdef TEST_EXPORT
|
||||
- , coffeeSettings
|
||||
-#endif
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter (..))
|
||||
@@ -66,49 +58,3 @@ import Language.Haskell.TH.Syntax
|
||||
import Text.Shakespeare
|
||||
import Text.Julius
|
||||
|
||||
-coffeeSettings :: Q ShakespeareSettings
|
||||
-coffeeSettings = do
|
||||
- jsettings <- javascriptSettings
|
||||
- return $ jsettings { varChar = '%'
|
||||
- , preConversion = Just PreConvert {
|
||||
- preConvert = ReadProcess "coffee" ["-spb"]
|
||||
- , preEscapeIgnoreBalanced = "'\"`" -- don't insert backtacks for variable already inside strings or backticks.
|
||||
- , preEscapeIgnoreLine = "#" -- ignore commented lines
|
||||
- , wrapInsertion = Just WrapInsertion {
|
||||
- wrapInsertionIndent = Just " "
|
||||
- , wrapInsertionStartBegin = "(("
|
||||
- , wrapInsertionSeparator = ", "
|
||||
- , wrapInsertionStartClose = ") =>"
|
||||
- , wrapInsertionEnd = ")"
|
||||
- , wrapInsertionApplyBegin = "("
|
||||
- , wrapInsertionApplyClose = ")\n"
|
||||
- }
|
||||
- }
|
||||
- }
|
||||
-
|
||||
--- | Read inline, quasiquoted CoffeeScript.
|
||||
-coffee :: QuasiQuoter
|
||||
-coffee = QuasiQuoter { quoteExp = \s -> do
|
||||
- rs <- coffeeSettings
|
||||
- quoteExp (shakespeare rs) s
|
||||
- }
|
||||
-
|
||||
--- | Read in a CoffeeScript template file. This function reads the file once, at
|
||||
--- compile time.
|
||||
-coffeeFile :: FilePath -> Q Exp
|
||||
-coffeeFile fp = do
|
||||
- rs <- coffeeSettings
|
||||
- shakespeareFile rs fp
|
||||
-
|
||||
--- | Read in a CoffeeScript template file. This impure function uses
|
||||
--- unsafePerformIO to re-read the file on every call, allowing for rapid
|
||||
--- iteration.
|
||||
-coffeeFileReload :: FilePath -> Q Exp
|
||||
-coffeeFileReload fp = do
|
||||
- rs <- coffeeSettings
|
||||
- shakespeareFileReload rs fp
|
||||
-
|
||||
--- | Deprecated synonym for 'coffeeFileReload'
|
||||
-coffeeFileDebug :: FilePath -> Q Exp
|
||||
-coffeeFileDebug = coffeeFileReload
|
||||
-{-# DEPRECATED coffeeFileDebug "Please use coffeeFileReload instead." #-}
|
||||
diff --git a/Text/Julius.hs b/Text/Julius.hs
|
||||
index 230eac3..b990f73 100644
|
||||
--- a/Text/Julius.hs
|
||||
+++ b/Text/Julius.hs
|
||||
@@ -14,17 +14,8 @@ module Text.Julius
|
||||
-- ** Template-Reading Functions
|
||||
-- | These QuasiQuoter and Template Haskell methods return values of
|
||||
-- type @'JavascriptUrl' url@. See the Yesod book for details.
|
||||
- js
|
||||
- , julius
|
||||
- , juliusFile
|
||||
- , jsFile
|
||||
- , juliusFileDebug
|
||||
- , jsFileDebug
|
||||
- , juliusFileReload
|
||||
- , jsFileReload
|
||||
-
|
||||
-- * Datatypes
|
||||
- , JavascriptUrl
|
||||
+ JavascriptUrl
|
||||
, Javascript (..)
|
||||
, RawJavascript (..)
|
||||
|
||||
@@ -37,7 +28,6 @@ module Text.Julius
|
||||
, renderJavascriptUrl
|
||||
|
||||
-- ** internal, used by 'Text.Coffee'
|
||||
- , javascriptSettings
|
||||
-- ** internal
|
||||
, juliusUsedIdentifiers
|
||||
) where
|
||||
@@ -101,47 +91,6 @@ instance RawJS TL.Text where rawJS = RawJavascript . fromLazyText
|
||||
instance RawJS Builder where rawJS = RawJavascript
|
||||
instance RawJS Bool where rawJS = RawJavascript . toJavascript
|
||||
|
||||
-javascriptSettings :: Q ShakespeareSettings
|
||||
-javascriptSettings = do
|
||||
- toJExp <- [|toJavascript|]
|
||||
- wrapExp <- [|Javascript|]
|
||||
- unWrapExp <- [|unJavascript|]
|
||||
- asJavascriptUrl' <- [|asJavascriptUrl|]
|
||||
- return $ defaultShakespeareSettings { toBuilder = toJExp
|
||||
- , wrap = wrapExp
|
||||
- , unwrap = unWrapExp
|
||||
- , modifyFinalValue = Just asJavascriptUrl'
|
||||
- }
|
||||
-
|
||||
-js, julius :: QuasiQuoter
|
||||
-js = QuasiQuoter { quoteExp = \s -> do
|
||||
- rs <- javascriptSettings
|
||||
- quoteExp (shakespeare rs) s
|
||||
- }
|
||||
-
|
||||
-julius = js
|
||||
-
|
||||
-jsFile, juliusFile :: FilePath -> Q Exp
|
||||
-jsFile fp = do
|
||||
- rs <- javascriptSettings
|
||||
- shakespeareFile rs fp
|
||||
-
|
||||
-juliusFile = jsFile
|
||||
-
|
||||
-
|
||||
-jsFileReload, juliusFileReload :: FilePath -> Q Exp
|
||||
-jsFileReload fp = do
|
||||
- rs <- javascriptSettings
|
||||
- shakespeareFileReload rs fp
|
||||
-
|
||||
-juliusFileReload = jsFileReload
|
||||
-
|
||||
-jsFileDebug, juliusFileDebug :: FilePath -> Q Exp
|
||||
-juliusFileDebug = jsFileReload
|
||||
-{-# DEPRECATED juliusFileDebug "Please use juliusFileReload instead." #-}
|
||||
-jsFileDebug = jsFileReload
|
||||
-{-# DEPRECATED jsFileDebug "Please use jsFileReload instead." #-}
|
||||
-
|
||||
-- | Determine which identifiers are used by the given template, useful for
|
||||
-- creating systems like yesod devel.
|
||||
juliusUsedIdentifiers :: String -> [(Deref, VarType)]
|
||||
diff --git a/Text/Roy.hs b/Text/Roy.hs
|
||||
index cf09cec..870c9f6 100644
|
||||
--- a/Text/Roy.hs
|
||||
+++ b/Text/Roy.hs
|
||||
@@ -23,13 +23,6 @@ module Text.Roy
|
||||
-- ** Template-Reading Functions
|
||||
-- | These QuasiQuoter and Template Haskell methods return values of
|
||||
-- type @'JavascriptUrl' url@. See the Yesod book for details.
|
||||
- roy
|
||||
- , royFile
|
||||
- , royFileReload
|
||||
-
|
||||
-#ifdef TEST_EXPORT
|
||||
- , roySettings
|
||||
-#endif
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter (..))
|
||||
@@ -37,50 +30,3 @@ import Language.Haskell.TH.Syntax
|
||||
import Text.Shakespeare
|
||||
import Text.Julius
|
||||
|
||||
--- | The Roy language compiles down to Javascript.
|
||||
--- We do this compilation once at compile time to avoid needing to do it during the request.
|
||||
--- We call this a preConversion because other shakespeare modules like Lucius use Haskell to compile during the request instead rather than a system call.
|
||||
-roySettings :: Q ShakespeareSettings
|
||||
-roySettings = do
|
||||
- jsettings <- javascriptSettings
|
||||
- return $ jsettings { varChar = '#'
|
||||
- , preConversion = Just PreConvert {
|
||||
- preConvert = ReadProcess "roy" ["--stdio"]
|
||||
- , preEscapeIgnoreBalanced = "'\""
|
||||
- , preEscapeIgnoreLine = "//"
|
||||
- , wrapInsertion = Nothing
|
||||
- {-
|
||||
- Just WrapInsertion {
|
||||
- wrapInsertionIndent = Just " "
|
||||
- , wrapInsertionStartBegin = "(\\"
|
||||
- , wrapInsertionSeparator = " "
|
||||
- , wrapInsertionStartClose = " ->\n"
|
||||
- , wrapInsertionEnd = ")"
|
||||
- , wrapInsertionApplyBegin = " "
|
||||
- , wrapInsertionApplyClose = ")\n"
|
||||
- }
|
||||
- -}
|
||||
- }
|
||||
- }
|
||||
-
|
||||
--- | Read inline, quasiquoted Roy.
|
||||
-roy :: QuasiQuoter
|
||||
-roy = QuasiQuoter { quoteExp = \s -> do
|
||||
- rs <- roySettings
|
||||
- quoteExp (shakespeare rs) s
|
||||
- }
|
||||
-
|
||||
--- | Read in a Roy template file. This function reads the file once, at
|
||||
--- compile time.
|
||||
-royFile :: FilePath -> Q Exp
|
||||
-royFile fp = do
|
||||
- rs <- roySettings
|
||||
- shakespeareFile rs fp
|
||||
-
|
||||
--- | Read in a Roy template file. This impure function uses
|
||||
--- unsafePerformIO to re-read the file on every call, allowing for rapid
|
||||
--- iteration.
|
||||
-royFileReload :: FilePath -> Q Exp
|
||||
-royFileReload fp = do
|
||||
- rs <- roySettings
|
||||
- shakespeareFileReload rs fp
|
||||
diff --git a/Text/TypeScript.hs b/Text/TypeScript.hs
|
||||
index 34bf4bf..30c5388 100644
|
||||
--- a/Text/TypeScript.hs
|
||||
+++ b/Text/TypeScript.hs
|
||||
@@ -53,65 +53,10 @@
|
||||
--
|
||||
-- 2. TypeScript: <http://typescript.codeplex.com/>
|
||||
module Text.TypeScript
|
||||
- ( -- * Functions
|
||||
- -- ** Template-Reading Functions
|
||||
- -- | These QuasiQuoter and Template Haskell methods return values of
|
||||
- -- type @'JavascriptUrl' url@. See the Yesod book for details.
|
||||
- tsc
|
||||
- , typeScriptFile
|
||||
- , typeScriptFileReload
|
||||
-
|
||||
-#ifdef TEST_EXPORT
|
||||
- , typeScriptSettings
|
||||
-#endif
|
||||
+ (
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter (..))
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Text.Shakespeare
|
||||
import Text.Julius
|
||||
-
|
||||
--- | The TypeScript language compiles down to Javascript.
|
||||
--- We do this compilation once at compile time to avoid needing to do it during the request.
|
||||
--- We call this a preConversion because other shakespeare modules like Lucius use Haskell to compile during the request instead rather than a system call.
|
||||
-typeScriptSettings :: Q ShakespeareSettings
|
||||
-typeScriptSettings = do
|
||||
- jsettings <- javascriptSettings
|
||||
- return $ jsettings { varChar = '#'
|
||||
- , preConversion = Just PreConvert {
|
||||
- preConvert = ReadProcess "sh" ["-c", "TMP_IN=$(mktemp XXXXXXXXXX.ts); TMP_OUT=$(mktemp XXXXXXXXXX.js); cat /dev/stdin > ${TMP_IN} && tsc --out ${TMP_OUT} ${TMP_IN} && cat ${TMP_OUT}; rm ${TMP_IN} && rm ${TMP_OUT}"]
|
||||
- , preEscapeIgnoreBalanced = "'\""
|
||||
- , preEscapeIgnoreLine = "//"
|
||||
- , wrapInsertion = Just WrapInsertion {
|
||||
- wrapInsertionIndent = Nothing
|
||||
- , wrapInsertionStartBegin = ";(function("
|
||||
- , wrapInsertionSeparator = ", "
|
||||
- , wrapInsertionStartClose = "){"
|
||||
- , wrapInsertionEnd = "})"
|
||||
- , wrapInsertionApplyBegin = "("
|
||||
- , wrapInsertionApplyClose = ");\n"
|
||||
- }
|
||||
- }
|
||||
- }
|
||||
-
|
||||
--- | Read inline, quasiquoted TypeScript
|
||||
-tsc :: QuasiQuoter
|
||||
-tsc = QuasiQuoter { quoteExp = \s -> do
|
||||
- rs <- typeScriptSettings
|
||||
- quoteExp (shakespeare rs) s
|
||||
- }
|
||||
-
|
||||
--- | Read in a Roy template file. This function reads the file once, at
|
||||
--- compile time.
|
||||
-typeScriptFile :: FilePath -> Q Exp
|
||||
-typeScriptFile fp = do
|
||||
- rs <- typeScriptSettings
|
||||
- shakespeareFile rs fp
|
||||
-
|
||||
--- | Read in a Roy template file. This impure function uses
|
||||
--- unsafePerformIO to re-read the file on every call, allowing for rapid
|
||||
--- iteration.
|
||||
-typeScriptFileReload :: FilePath -> Q Exp
|
||||
-typeScriptFileReload fp = do
|
||||
- rs <- typeScriptSettings
|
||||
- shakespeareFileReload rs fp
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,107 @@
|
|||
From abab0f8202998a3e88c5dc5f67a8245da6c174b3 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:36:20 -0400
|
||||
Subject: [PATCH] remove IPv6 stuff
|
||||
|
||||
---
|
||||
Network/Socks5.hs | 1 -
|
||||
Network/Socks5/Command.hs | 16 ++--------------
|
||||
Network/Socks5/Types.hs | 3 +--
|
||||
Network/Socks5/Wire.hs | 2 --
|
||||
4 files changed, 3 insertions(+), 19 deletions(-)
|
||||
|
||||
diff --git a/Network/Socks5.hs b/Network/Socks5.hs
|
||||
index 67b0060..80efb9c 100644
|
||||
--- a/Network/Socks5.hs
|
||||
+++ b/Network/Socks5.hs
|
||||
@@ -54,7 +54,6 @@ socksConnectAddr :: Socket -> SockAddr -> SockAddr -> IO ()
|
||||
socksConnectAddr sock sockserver destaddr = withSocks sock sockserver $ do
|
||||
case destaddr of
|
||||
SockAddrInet p h -> socks5ConnectIPV4 sock h p >> return ()
|
||||
- SockAddrInet6 p _ h _ -> socks5ConnectIPV6 sock h p >> return ()
|
||||
_ -> error "unsupported unix sockaddr type"
|
||||
|
||||
-- | connect a new socket to the socks server, and connect the stream to a FQDN
|
||||
diff --git a/Network/Socks5/Command.hs b/Network/Socks5/Command.hs
|
||||
index 2952706..db994c9 100644
|
||||
--- a/Network/Socks5/Command.hs
|
||||
+++ b/Network/Socks5/Command.hs
|
||||
@@ -9,9 +9,8 @@
|
||||
--
|
||||
module Network.Socks5.Command
|
||||
( socks5Establish
|
||||
- , socks5ConnectIPV4
|
||||
- , socks5ConnectIPV6
|
||||
, socks5ConnectDomainName
|
||||
+ , socks5ConnectIPV4
|
||||
-- * lowlevel interface
|
||||
, socks5Rpc
|
||||
) where
|
||||
@@ -23,7 +22,7 @@ import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import Data.Serialize
|
||||
|
||||
-import Network.Socket (Socket, PortNumber, HostAddress, HostAddress6)
|
||||
+import Network.Socket (Socket, PortNumber, HostAddress)
|
||||
import Network.Socket.ByteString
|
||||
|
||||
import Network.Socks5.Types
|
||||
@@ -46,17 +45,6 @@ socks5ConnectIPV4 socket hostaddr port = onReply <$> socks5Rpc socket request
|
||||
onReply (SocksAddrIPV4 h, p) = (h, p)
|
||||
onReply _ = error "ipv4 requested, got something different"
|
||||
|
||||
-socks5ConnectIPV6 :: Socket -> HostAddress6 -> PortNumber -> IO (HostAddress6, PortNumber)
|
||||
-socks5ConnectIPV6 socket hostaddr6 port = onReply <$> socks5Rpc socket request
|
||||
- where
|
||||
- request = SocksRequest
|
||||
- { requestCommand = SocksCommandConnect
|
||||
- , requestDstAddr = SocksAddrIPV6 hostaddr6
|
||||
- , requestDstPort = fromIntegral port
|
||||
- }
|
||||
- onReply (SocksAddrIPV6 h, p) = (h, p)
|
||||
- onReply _ = error "ipv6 requested, got something different"
|
||||
-
|
||||
-- TODO: FQDN should only be ascii, maybe putting a "fqdn" data type
|
||||
-- in front to make sure and make the BC.pack safe.
|
||||
socks5ConnectDomainName :: Socket -> String -> PortNumber -> IO (SocksAddr, PortNumber)
|
||||
diff --git a/Network/Socks5/Types.hs b/Network/Socks5/Types.hs
|
||||
index 5dc7d5e..12dea99 100644
|
||||
--- a/Network/Socks5/Types.hs
|
||||
+++ b/Network/Socks5/Types.hs
|
||||
@@ -17,7 +17,7 @@ module Network.Socks5.Types
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Word
|
||||
import Data.Data
|
||||
-import Network.Socket (HostAddress, HostAddress6)
|
||||
+import Network.Socket (HostAddress)
|
||||
import Control.Exception
|
||||
|
||||
data SocksCommand =
|
||||
@@ -38,7 +38,6 @@ data SocksMethod =
|
||||
data SocksAddr =
|
||||
SocksAddrIPV4 HostAddress
|
||||
| SocksAddrDomainName ByteString
|
||||
- | SocksAddrIPV6 HostAddress6
|
||||
deriving (Show,Eq)
|
||||
|
||||
data SocksReply =
|
||||
diff --git a/Network/Socks5/Wire.hs b/Network/Socks5/Wire.hs
|
||||
index 2cfed52..d3bd9c5 100644
|
||||
--- a/Network/Socks5/Wire.hs
|
||||
+++ b/Network/Socks5/Wire.hs
|
||||
@@ -41,12 +41,10 @@ data SocksResponse = SocksResponse
|
||||
|
||||
getAddr 1 = SocksAddrIPV4 <$> getWord32be
|
||||
getAddr 3 = SocksAddrDomainName <$> (getWord8 >>= getByteString . fromIntegral)
|
||||
-getAddr 4 = SocksAddrIPV6 <$> (liftM4 (,,,) getWord32le getWord32le getWord32le getWord32le)
|
||||
getAddr n = error ("cannot get unknown socket address type: " ++ show n)
|
||||
|
||||
putAddr (SocksAddrIPV4 h) = putWord8 1 >> putWord32host h
|
||||
putAddr (SocksAddrDomainName b) = putWord8 3 >> putWord8 (fromIntegral $ B.length b) >> putByteString b
|
||||
-putAddr (SocksAddrIPV6 (a,b,c,d)) = putWord8 4 >> mapM_ putWord32host [a,b,c,d]
|
||||
|
||||
getSocksRequest 5 = do
|
||||
cmd <- toEnum . fromIntegral <$> getWord8
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
From 2feaef797641587a3da83753ee17d20e712c79cf Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:36:30 -0400
|
||||
Subject: [PATCH] modify to build with unreleased ghc
|
||||
|
||||
---
|
||||
split.cabal | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/split.cabal b/split.cabal
|
||||
index 2183c3e..29b9b32 100644
|
||||
--- a/split.cabal
|
||||
+++ b/split.cabal
|
||||
@@ -51,7 +51,7 @@ Source-repository head
|
||||
|
||||
Library
|
||||
ghc-options: -Wall
|
||||
- build-depends: base <4.7
|
||||
+ build-depends: base <4.8
|
||||
exposed-modules: Data.List.Split, Data.List.Split.Internals
|
||||
default-language: Haskell2010
|
||||
Hs-source-dirs: src
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
From c40fe2c484096c5de4cac8ca14a0ca5d892999f7 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:36:43 -0400
|
||||
Subject: [PATCH] hack for cross-compiling
|
||||
|
||||
---
|
||||
syb.cabal | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/syb.cabal b/syb.cabal
|
||||
index 0aee93d..0a645c6 100644
|
||||
--- a/syb.cabal
|
||||
+++ b/syb.cabal
|
||||
@@ -17,7 +17,7 @@ description:
|
||||
|
||||
category: Generics
|
||||
stability: provisional
|
||||
-build-type: Custom
|
||||
+build-type: Simple
|
||||
cabal-version: >= 1.6
|
||||
|
||||
extra-source-files: tests/*.hs,
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,91 @@
|
|||
From abca378462337ca0eb13a7e4d3073cb96a50d36c Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:37:23 -0400
|
||||
Subject: [PATCH] remove stuff not available on Android
|
||||
|
||||
---
|
||||
System/Posix/Resource.hsc | 4 ++++
|
||||
System/Posix/Terminal/Common.hsc | 29 +++--------------------------
|
||||
2 files changed, 7 insertions(+), 26 deletions(-)
|
||||
|
||||
diff --git a/System/Posix/Resource.hsc b/System/Posix/Resource.hsc
|
||||
index 6651998..2615b1e 100644
|
||||
--- a/System/Posix/Resource.hsc
|
||||
+++ b/System/Posix/Resource.hsc
|
||||
@@ -101,7 +101,9 @@ packResource ResourceTotalMemory = (#const RLIMIT_AS)
|
||||
#endif
|
||||
|
||||
unpackRLimit :: CRLim -> ResourceLimit
|
||||
+#if 0
|
||||
unpackRLimit (#const RLIM_INFINITY) = ResourceLimitInfinity
|
||||
+#endif
|
||||
#ifdef RLIM_SAVED_MAX
|
||||
unpackRLimit (#const RLIM_SAVED_MAX) = ResourceLimitUnknown
|
||||
unpackRLimit (#const RLIM_SAVED_CUR) = ResourceLimitUnknown
|
||||
@@ -109,7 +111,9 @@ unpackRLimit (#const RLIM_SAVED_CUR) = ResourceLimitUnknown
|
||||
unpackRLimit other = ResourceLimit (fromIntegral other)
|
||||
|
||||
packRLimit :: ResourceLimit -> Bool -> CRLim
|
||||
+#if 0
|
||||
packRLimit ResourceLimitInfinity _ = (#const RLIM_INFINITY)
|
||||
+#endif
|
||||
#ifdef RLIM_SAVED_MAX
|
||||
packRLimit ResourceLimitUnknown True = (#const RLIM_SAVED_CUR)
|
||||
packRLimit ResourceLimitUnknown False = (#const RLIM_SAVED_MAX)
|
||||
diff --git a/System/Posix/Terminal/Common.hsc b/System/Posix/Terminal/Common.hsc
|
||||
index 3a6254d..32a22f2 100644
|
||||
--- a/System/Posix/Terminal/Common.hsc
|
||||
+++ b/System/Posix/Terminal/Common.hsc
|
||||
@@ -419,11 +419,7 @@ foreign import ccall unsafe "tcsendbreak"
|
||||
-- | @drainOutput fd@ calls @tcdrain@ to block until all output
|
||||
-- written to @Fd@ @fd@ has been transmitted.
|
||||
drainOutput :: Fd -> IO ()
|
||||
-drainOutput (Fd fd) = throwErrnoIfMinus1_ "drainOutput" (c_tcdrain fd)
|
||||
-
|
||||
-foreign import ccall unsafe "tcdrain"
|
||||
- c_tcdrain :: CInt -> IO CInt
|
||||
-
|
||||
+drainOutput (Fd fd) = error "drainOutput not implemented"
|
||||
|
||||
data QueueSelector
|
||||
= InputQueue -- TCIFLUSH
|
||||
@@ -434,16 +430,7 @@ data QueueSelector
|
||||
-- pending input and\/or output for @Fd@ @fd@,
|
||||
-- as indicated by the @QueueSelector@ @queues@.
|
||||
discardData :: Fd -> QueueSelector -> IO ()
|
||||
-discardData (Fd fd) queue =
|
||||
- throwErrnoIfMinus1_ "discardData" (c_tcflush fd (queue2Int queue))
|
||||
- where
|
||||
- queue2Int :: QueueSelector -> CInt
|
||||
- queue2Int InputQueue = (#const TCIFLUSH)
|
||||
- queue2Int OutputQueue = (#const TCOFLUSH)
|
||||
- queue2Int BothQueues = (#const TCIOFLUSH)
|
||||
-
|
||||
-foreign import ccall unsafe "tcflush"
|
||||
- c_tcflush :: CInt -> CInt -> IO CInt
|
||||
+discardData (Fd fd) queue = error "discardData not implemented"
|
||||
|
||||
data FlowAction
|
||||
= SuspendOutput -- ^ TCOOFF
|
||||
@@ -455,17 +442,7 @@ data FlowAction
|
||||
-- flow of data on @Fd@ @fd@, as indicated by
|
||||
-- @action@.
|
||||
controlFlow :: Fd -> FlowAction -> IO ()
|
||||
-controlFlow (Fd fd) action =
|
||||
- throwErrnoIfMinus1_ "controlFlow" (c_tcflow fd (action2Int action))
|
||||
- where
|
||||
- action2Int :: FlowAction -> CInt
|
||||
- action2Int SuspendOutput = (#const TCOOFF)
|
||||
- action2Int RestartOutput = (#const TCOON)
|
||||
- action2Int TransmitStop = (#const TCIOFF)
|
||||
- action2Int TransmitStart = (#const TCION)
|
||||
-
|
||||
-foreign import ccall unsafe "tcflow"
|
||||
- c_tcflow :: CInt -> CInt -> IO CInt
|
||||
+controlFlow (Fd fd) action = error "controlFlow not implemented"
|
||||
|
||||
-- | @getTerminalProcessGroupID fd@ calls @tcgetpgrp@ to
|
||||
-- obtain the @ProcessGroupID@ of the foreground process group
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
From 8b8a8422a9235b730049de4e6e626821abdc8393 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:37:44 -0400
|
||||
Subject: [PATCH] hacks for android
|
||||
|
||||
---
|
||||
cbits/conv.c | 2 +-
|
||||
unix-time.cabal | 2 +-
|
||||
2 files changed, 2 insertions(+), 2 deletions(-)
|
||||
|
||||
diff --git a/cbits/conv.c b/cbits/conv.c
|
||||
index 3b6a129..895e6b7 100644
|
||||
--- a/cbits/conv.c
|
||||
+++ b/cbits/conv.c
|
||||
@@ -51,7 +51,7 @@ time_t c_parse_unix_time_gmt(char *fmt, char *src) {
|
||||
#else
|
||||
strptime(src, fmt, &dst);
|
||||
#endif
|
||||
- return timegm(&dst);
|
||||
+ return NULL; /* timegm(&dst); */
|
||||
}
|
||||
|
||||
void c_format_unix_time(char *fmt, time_t src, char* dst, int siz) {
|
||||
diff --git a/unix-time.cabal b/unix-time.cabal
|
||||
index a905d63..98d2495 100644
|
||||
--- a/unix-time.cabal
|
||||
+++ b/unix-time.cabal
|
||||
@@ -21,7 +21,7 @@ Library
|
||||
Data.UnixTime.Types
|
||||
Data.UnixTime.Sys
|
||||
Build-Depends: base >= 4 && < 5
|
||||
- , bytestring
|
||||
+ , bytestring (>= 0.10.3.0)
|
||||
, old-time
|
||||
C-Sources: cbits/conv.c
|
||||
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
From 3a4ee8091ba9da44f9f4a04522a5ff45fabe70d9 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:37:56 -0400
|
||||
Subject: [PATCH] disable optimisation that breaks when cross-compiling
|
||||
|
||||
This needs TH to work actually.
|
||||
---
|
||||
Data/Vector/Fusion/Stream/Monadic.hs | 1 -
|
||||
1 file changed, 1 deletion(-)
|
||||
|
||||
diff --git a/Data/Vector/Fusion/Stream/Monadic.hs b/Data/Vector/Fusion/Stream/Monadic.hs
|
||||
index 51fec75..b089b3d 100644
|
||||
--- a/Data/Vector/Fusion/Stream/Monadic.hs
|
||||
+++ b/Data/Vector/Fusion/Stream/Monadic.hs
|
||||
@@ -101,7 +101,6 @@ import GHC.Exts ( SpecConstrAnnotation(..) )
|
||||
|
||||
data SPEC = SPEC | SPEC2
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
-{-# ANN type SPEC ForceSpecConstr #-}
|
||||
#endif
|
||||
|
||||
emptyStream :: String
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
From dc6d0128e666dcab07ddee56a22a4177ebfc0c7b Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:38:33 -0400
|
||||
Subject: [PATCH] disable CGI module
|
||||
|
||||
I don't need it and it failed to build.
|
||||
---
|
||||
wai-extra.cabal | 2 +-
|
||||
1 file changed, 1 insertion(+), 1 deletion(-)
|
||||
|
||||
diff --git a/wai-extra.cabal b/wai-extra.cabal
|
||||
index 9e9f0fc..007dd0f 100644
|
||||
--- a/wai-extra.cabal
|
||||
+++ b/wai-extra.cabal
|
||||
@@ -44,7 +44,7 @@ Library
|
||||
, void >= 0.5 && < 0.6
|
||||
, stringsearch >= 0.3 && < 0.4
|
||||
|
||||
- Exposed-modules: Network.Wai.Handler.CGI
|
||||
+ Exposed-modules:
|
||||
Network.Wai.Middleware.AcceptOverride
|
||||
Network.Wai.Middleware.Autohead
|
||||
Network.Wai.Middleware.CleanPath
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,157 @@
|
|||
From 37abd5d34e18d11ff2961f672cf4491471029684 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:39:18 -0400
|
||||
Subject: [PATCH] hacked up to build on Android
|
||||
|
||||
removing stuff I don't need and stuff removed from other modules
|
||||
---
|
||||
Yesod.hs | 7 ------
|
||||
yesod.cabal | 77 -----------------------------------------------------------
|
||||
2 files changed, 84 deletions(-)
|
||||
|
||||
diff --git a/Yesod.hs b/Yesod.hs
|
||||
index ef9623d..255ab56 100644
|
||||
--- a/Yesod.hs
|
||||
+++ b/Yesod.hs
|
||||
@@ -6,7 +6,6 @@ module Yesod
|
||||
module Yesod.Core
|
||||
, module Yesod.Form
|
||||
, module Yesod.Json
|
||||
- , module Yesod.Persist
|
||||
-- * Running your application
|
||||
, warp
|
||||
, warpDebug
|
||||
@@ -21,19 +20,14 @@ module Yesod
|
||||
, readIntegral
|
||||
-- * Hamlet library
|
||||
-- ** Hamlet
|
||||
- , hamlet
|
||||
- , xhamlet
|
||||
, HtmlUrl
|
||||
, Html
|
||||
, toHtml
|
||||
-- ** Julius
|
||||
- , julius
|
||||
, JavascriptUrl
|
||||
, renderJavascriptUrl
|
||||
, toJSON
|
||||
-- ** Cassius/Lucius
|
||||
- , cassius
|
||||
- , lucius
|
||||
, CssUrl
|
||||
, renderCssUrl
|
||||
) where
|
||||
@@ -46,7 +40,6 @@ import Text.Julius
|
||||
|
||||
import Yesod.Form
|
||||
import Yesod.Json
|
||||
-import Yesod.Persist
|
||||
import Control.Monad.IO.Class (liftIO, MonadIO(..))
|
||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
||||
|
||||
diff --git a/yesod.cabal b/yesod.cabal
|
||||
index 741f19a..7566cfb 100644
|
||||
--- a/yesod.cabal
|
||||
+++ b/yesod.cabal
|
||||
@@ -13,7 +13,6 @@ description:
|
||||
The Yesod documentation site <http://www.yesodweb.com/> has much more information, including on the supporting packages mentioned above.
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
-cabal-version: >= 1.6
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
|
||||
@@ -28,9 +27,7 @@ extra-source-files:
|
||||
library
|
||||
build-depends: base >= 4.3 && < 5
|
||||
, yesod-core >= 1.1.5 && < 1.2
|
||||
- , yesod-auth >= 1.1 && < 1.2
|
||||
, yesod-json >= 1.1 && < 1.2
|
||||
- , yesod-persistent >= 1.1 && < 1.2
|
||||
, yesod-form >= 1.1 && < 1.3
|
||||
, yesod-default >= 1.1.3 && < 1.2
|
||||
, monad-control >= 0.3 && < 0.4
|
||||
@@ -48,80 +45,6 @@ library
|
||||
exposed-modules: Yesod
|
||||
ghc-options: -Wall
|
||||
|
||||
-executable yesod-ghc-wrapper
|
||||
- main-is: ghcwrapper.hs
|
||||
- build-depends:
|
||||
- base >= 4 && < 5
|
||||
- , Cabal
|
||||
-
|
||||
-executable yesod-ld-wrapper
|
||||
- main-is: ghcwrapper.hs
|
||||
- cpp-options: -DLDCMD
|
||||
- build-depends:
|
||||
- base >= 4 && < 5
|
||||
- , Cabal
|
||||
-executable yesod-ar-wrapper
|
||||
- main-is: ghcwrapper.hs
|
||||
- cpp-options: -DARCMD
|
||||
- build-depends:
|
||||
- base >= 4 && < 5
|
||||
- , Cabal
|
||||
-
|
||||
-executable yesod
|
||||
- if os(windows)
|
||||
- cpp-options: -DWINDOWS
|
||||
- build-depends: base >= 4.3 && < 5
|
||||
- , ghc >= 7.0.3 && < 7.8
|
||||
- , ghc-paths >= 0.1
|
||||
- , parsec >= 2.1 && < 4
|
||||
- , text >= 0.11
|
||||
- , shakespeare-text >= 1.0 && < 1.1
|
||||
- , shakespeare >= 1.0.2 && < 1.1
|
||||
- , shakespeare-js >= 1.0.2 && < 1.2
|
||||
- , shakespeare-css >= 1.0.2 && < 1.1
|
||||
- , bytestring >= 0.9.1.4
|
||||
- , time >= 1.1.4
|
||||
- , template-haskell
|
||||
- , directory >= 1.0
|
||||
- , Cabal
|
||||
- , unix-compat >= 0.2 && < 0.5
|
||||
- , containers >= 0.2
|
||||
- , attoparsec >= 0.10
|
||||
- , http-types >= 0.7
|
||||
- , blaze-builder >= 0.2.1.4 && < 0.4
|
||||
- , filepath >= 1.1
|
||||
- , process
|
||||
- , zlib >= 0.5 && < 0.6
|
||||
- , tar >= 0.4 && < 0.5
|
||||
- , system-filepath >= 0.4 && < 0.5
|
||||
- , system-fileio >= 0.3 && < 0.4
|
||||
- , unordered-containers
|
||||
- , yaml >= 0.8 && < 0.9
|
||||
- , optparse-applicative >= 0.4
|
||||
- , fsnotify >= 0.0 && < 0.1
|
||||
- , split >= 0.2 && < 0.3
|
||||
- , file-embed
|
||||
- , conduit >= 0.5 && < 0.6
|
||||
- , resourcet >= 0.3 && < 0.5
|
||||
- , base64-bytestring
|
||||
- , lifted-base
|
||||
- , http-reverse-proxy >= 0.1.1
|
||||
- , network
|
||||
- , http-conduit
|
||||
- , network-conduit
|
||||
- , project-template >= 0.1.1
|
||||
-
|
||||
- ghc-options: -Wall -threaded
|
||||
- main-is: main.hs
|
||||
- other-modules: Scaffolding.Scaffolder
|
||||
- Devel
|
||||
- Build
|
||||
- GhcBuild
|
||||
- Keter
|
||||
- AddHandler
|
||||
- Paths_yesod
|
||||
- Options
|
||||
-
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/yesodweb/yesod
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,476 @@
|
|||
From 801f6dea3be43113400e41aabb443456fffcd227 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:39:40 -0400
|
||||
Subject: [PATCH] remove TH
|
||||
|
||||
---
|
||||
Yesod/Core.hs | 10 ----
|
||||
Yesod/Dispatch.hs | 119 +----------------------------------------------
|
||||
Yesod/Handler.hs | 27 +----------
|
||||
Yesod/Internal/Cache.hs | 5 --
|
||||
Yesod/Internal/Core.hs | 119 +++++------------------------------------------
|
||||
Yesod/Widget.hs | 29 ------------
|
||||
6 files changed, 13 insertions(+), 296 deletions(-)
|
||||
|
||||
diff --git a/Yesod/Core.hs b/Yesod/Core.hs
|
||||
index 7268d6c..ce04b7d 100644
|
||||
--- a/Yesod/Core.hs
|
||||
+++ b/Yesod/Core.hs
|
||||
@@ -21,16 +21,6 @@ module Yesod.Core
|
||||
, unauthorizedI
|
||||
-- * Logging
|
||||
, LogLevel (..)
|
||||
- , logDebug
|
||||
- , logInfo
|
||||
- , logWarn
|
||||
- , logError
|
||||
- , logOther
|
||||
- , logDebugS
|
||||
- , logInfoS
|
||||
- , logWarnS
|
||||
- , logErrorS
|
||||
- , logOtherS
|
||||
-- * Sessions
|
||||
, SessionBackend (..)
|
||||
, defaultClientSessionBackend
|
||||
diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs
|
||||
index 1e19388..dd37475 100644
|
||||
--- a/Yesod/Dispatch.hs
|
||||
+++ b/Yesod/Dispatch.hs
|
||||
@@ -6,20 +6,9 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
module Yesod.Dispatch
|
||||
( -- * Quasi-quoted routing
|
||||
- parseRoutes
|
||||
- , parseRoutesNoCheck
|
||||
- , parseRoutesFile
|
||||
- , parseRoutesFileNoCheck
|
||||
- , mkYesod
|
||||
- , mkYesodSub
|
||||
-- ** More fine-grained
|
||||
- , mkYesodData
|
||||
- , mkYesodSubData
|
||||
- , mkYesodDispatch
|
||||
- , mkYesodSubDispatch
|
||||
- , mkDispatchInstance
|
||||
-- ** Path pieces
|
||||
- , PathPiece (..)
|
||||
+ PathPiece (..)
|
||||
, PathMultiPiece (..)
|
||||
, Texts
|
||||
-- * Convert to WAI
|
||||
@@ -52,117 +41,11 @@ import Data.Monoid (mappend)
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Blaze.ByteString.Builder
|
||||
import Network.HTTP.Types (status301)
|
||||
-import Yesod.Routes.TH
|
||||
import Yesod.Content (chooseRep)
|
||||
-import Yesod.Routes.Parse
|
||||
import System.Log.FastLogger (Logger)
|
||||
|
||||
type Texts = [Text]
|
||||
|
||||
--- | Generates URL datatype and site function for the given 'Resource's. This
|
||||
--- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
|
||||
--- Use 'parseRoutes' to create the 'Resource's.
|
||||
-mkYesod :: String -- ^ name of the argument datatype
|
||||
- -> [ResourceTree String]
|
||||
- -> Q [Dec]
|
||||
-mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
|
||||
-
|
||||
--- | Generates URL datatype and site function for the given 'Resource's. This
|
||||
--- is used for creating subsites, /not/ sites. See 'mkYesod' for the latter.
|
||||
--- Use 'parseRoutes' to create the 'Resource's. In general, a subsite is not
|
||||
--- executable by itself, but instead provides functionality to
|
||||
--- be embedded in other sites.
|
||||
-mkYesodSub :: String -- ^ name of the argument datatype
|
||||
- -> Cxt
|
||||
- -> [ResourceTree String]
|
||||
- -> Q [Dec]
|
||||
-mkYesodSub name clazzes =
|
||||
- fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True
|
||||
- where
|
||||
- (name':rest) = words name
|
||||
-
|
||||
--- | Sometimes, you will want to declare your routes in one file and define
|
||||
--- your handlers elsewhere. For example, this is the only way to break up a
|
||||
--- monolithic file into smaller parts. Use this function, paired with
|
||||
--- 'mkYesodDispatch', to do just that.
|
||||
-mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
|
||||
-mkYesodData name res = mkYesodDataGeneral name [] False res
|
||||
-
|
||||
-mkYesodSubData :: String -> Cxt -> [ResourceTree String] -> Q [Dec]
|
||||
-mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res
|
||||
-
|
||||
-mkYesodDataGeneral :: String -> Cxt -> Bool -> [ResourceTree String] -> Q [Dec]
|
||||
-mkYesodDataGeneral name clazzes isSub res = do
|
||||
- let (name':rest) = words name
|
||||
- (x, _) <- mkYesodGeneral name' rest clazzes isSub res
|
||||
- let rname = mkName $ "resources" ++ name
|
||||
- eres <- lift res
|
||||
- let y = [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)
|
||||
- , FunD rname [Clause [] (NormalB eres) []]
|
||||
- ]
|
||||
- return $ x ++ y
|
||||
-
|
||||
--- | See 'mkYesodData'.
|
||||
-mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
|
||||
-mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
|
||||
-
|
||||
-mkYesodSubDispatch :: String -> Cxt -> [ResourceTree String] -> Q [Dec]
|
||||
-mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True
|
||||
- where (name':rest) = words name
|
||||
-
|
||||
-mkYesodGeneral :: String -- ^ foundation type
|
||||
- -> [String] -- ^ arguments for the type
|
||||
- -> Cxt -- ^ the type constraints
|
||||
- -> Bool -- ^ it this a subsite
|
||||
- -> [ResourceTree String]
|
||||
- -> Q([Dec],[Dec])
|
||||
-mkYesodGeneral name args clazzes isSub resS = do
|
||||
- subsite <- sub
|
||||
- masterTypeSyns <- if isSub then return []
|
||||
- else sequence [handler, widget]
|
||||
- renderRouteDec <- mkRenderRouteInstance subsite res
|
||||
- dispatchDec <- mkDispatchInstance context sub master res
|
||||
- return (renderRouteDec ++ masterTypeSyns, dispatchDec)
|
||||
- where sub = foldl appT subCons subArgs
|
||||
- master = if isSub then (varT $ mkName "master") else sub
|
||||
- context = if isSub then cxt $ yesod : map return clazzes
|
||||
- else return []
|
||||
- yesod = classP ''Yesod [master]
|
||||
- handler = tySynD (mkName "Handler") [] [t| GHandler $master $master |]
|
||||
- widget = tySynD (mkName "Widget") [] [t| GWidget $master $master () |]
|
||||
- res = map (fmap parseType) resS
|
||||
- subCons = conT $ mkName name
|
||||
- subArgs = map (varT. mkName) args
|
||||
-
|
||||
--- | If the generation of @'YesodDispatch'@ instance require finer
|
||||
--- control of the types, contexts etc. using this combinator. You will
|
||||
--- hardly need this generality. However, in certain situations, like
|
||||
--- when writing library/plugin for yesod, this combinator becomes
|
||||
--- handy.
|
||||
-mkDispatchInstance :: CxtQ -- ^ The context
|
||||
- -> TypeQ -- ^ The subsite type
|
||||
- -> TypeQ -- ^ The master site type
|
||||
- -> [ResourceTree a] -- ^ The resource
|
||||
- -> DecsQ
|
||||
-mkDispatchInstance context sub master res = do
|
||||
- logger <- newName "logger"
|
||||
- let loggerE = varE logger
|
||||
- loggerP = VarP logger
|
||||
- yDispatch = conT ''YesodDispatch `appT` sub `appT` master
|
||||
- thisDispatch = do
|
||||
- Clause pat body decs <- mkDispatchClause
|
||||
- [|yesodRunner $loggerE |]
|
||||
- [|yesodDispatch $loggerE |]
|
||||
- [|fmap chooseRep|]
|
||||
- res
|
||||
- return $ FunD 'yesodDispatch
|
||||
- [ Clause (loggerP:pat)
|
||||
- body
|
||||
- decs
|
||||
- ]
|
||||
- in sequence [instanceD context yDispatch [thisDispatch]]
|
||||
-
|
||||
-
|
||||
-- | Convert the given argument into a WAI application, executable with any WAI
|
||||
-- handler. This is the same as 'toWaiAppPlain', except it includes two
|
||||
-- middlewares: GZIP compression and autohead. This is the
|
||||
diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs
|
||||
index 1997bdb..98c915c 100644
|
||||
--- a/Yesod/Handler.hs
|
||||
+++ b/Yesod/Handler.hs
|
||||
@@ -42,7 +42,6 @@ module Yesod.Handler
|
||||
, RedirectUrl (..)
|
||||
, redirect
|
||||
, redirectWith
|
||||
- , redirectToPost
|
||||
-- ** Errors
|
||||
, notFound
|
||||
, badMethod
|
||||
@@ -100,7 +99,6 @@ module Yesod.Handler
|
||||
, getMessageRender
|
||||
-- * Per-request caching
|
||||
, CacheKey
|
||||
- , mkCacheKey
|
||||
, cacheLookup
|
||||
, cacheInsert
|
||||
, cacheDelete
|
||||
@@ -172,7 +170,7 @@ import System.Log.FastLogger
|
||||
import Control.Monad.Logger
|
||||
|
||||
import qualified Yesod.Internal.Cache as Cache
|
||||
-import Yesod.Internal.Cache (mkCacheKey, CacheKey)
|
||||
+import Yesod.Internal.Cache (CacheKey)
|
||||
import qualified Data.IORef as I
|
||||
import Control.Exception.Lifted (catch)
|
||||
import Control.Monad.Trans.Control
|
||||
@@ -937,29 +935,6 @@ newIdent = do
|
||||
put x { ghsIdent = i' }
|
||||
return $ T.pack $ 'h' : show i'
|
||||
|
||||
--- | Redirect to a POST resource.
|
||||
---
|
||||
--- This is not technically a redirect; instead, it returns an HTML page with a
|
||||
--- POST form, and some Javascript to automatically submit the form. This can be
|
||||
--- useful when you need to post a plain link somewhere that needs to cause
|
||||
--- changes on the server.
|
||||
-redirectToPost :: RedirectUrl master url => url -> GHandler sub master a
|
||||
-redirectToPost url = do
|
||||
- urlText <- toTextUrl url
|
||||
- hamletToRepHtml [hamlet|
|
||||
-$newline never
|
||||
-$doctype 5
|
||||
-
|
||||
-<html>
|
||||
- <head>
|
||||
- <title>Redirecting...
|
||||
- <body onload="document.getElementById('form').submit()">
|
||||
- <form id="form" method="post" action=#{urlText}>
|
||||
- <noscript>
|
||||
- <p>Javascript has been disabled; please click on the button below to be redirected.
|
||||
- <input type="submit" value="Continue">
|
||||
-|] >>= sendResponse
|
||||
-
|
||||
-- | Converts the given Hamlet template into 'Content', which can be used in a
|
||||
-- Yesod 'Response'.
|
||||
hamletToContent :: HtmlUrl (Route master) -> GHandler sub master Content
|
||||
diff --git a/Yesod/Internal/Cache.hs b/Yesod/Internal/Cache.hs
|
||||
index 4aec0d2..fdef9d7 100644
|
||||
--- a/Yesod/Internal/Cache.hs
|
||||
+++ b/Yesod/Internal/Cache.hs
|
||||
@@ -3,7 +3,6 @@
|
||||
module Yesod.Internal.Cache
|
||||
( Cache
|
||||
, CacheKey
|
||||
- , mkCacheKey
|
||||
, lookup
|
||||
, insert
|
||||
, delete
|
||||
@@ -24,10 +23,6 @@ newtype Cache = Cache (Map.IntMap Any)
|
||||
|
||||
newtype CacheKey a = CacheKey Int
|
||||
|
||||
--- | Generate a new 'CacheKey'. Be sure to give a full type signature.
|
||||
-mkCacheKey :: Q Exp
|
||||
-mkCacheKey = [|CacheKey|] `appE` (LitE . IntegerL . fromIntegral . hashUnique <$> runIO newUnique)
|
||||
-
|
||||
lookup :: CacheKey a -> Cache -> Maybe a
|
||||
lookup (CacheKey i) (Cache m) = unsafeCoerce <$> Map.lookup i m
|
||||
|
||||
diff --git a/Yesod/Internal/Core.hs b/Yesod/Internal/Core.hs
|
||||
index c4a9796..90c05fc 100644
|
||||
--- a/Yesod/Internal/Core.hs
|
||||
+++ b/Yesod/Internal/Core.hs
|
||||
@@ -44,7 +44,6 @@ module Yesod.Internal.Core
|
||||
|
||||
import Yesod.Content
|
||||
import Yesod.Handler hiding (lift, getExpires)
|
||||
-import Control.Monad.Logger (logErrorS)
|
||||
|
||||
import Yesod.Routes.Class
|
||||
import Data.Time (UTCTime, addUTCTime, getCurrentTime)
|
||||
@@ -165,22 +164,7 @@ class RenderRoute a => Yesod a where
|
||||
|
||||
-- | Applies some form of layout to the contents of a page.
|
||||
defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml
|
||||
- defaultLayout w = do
|
||||
- p <- widgetToPageContent w
|
||||
- mmsg <- getMessage
|
||||
- hamletToRepHtml [hamlet|
|
||||
-$newline never
|
||||
-$doctype 5
|
||||
-
|
||||
-<html>
|
||||
- <head>
|
||||
- <title>#{pageTitle p}
|
||||
- ^{pageHead p}
|
||||
- <body>
|
||||
- $maybe msg <- mmsg
|
||||
- <p .message>#{msg}
|
||||
- ^{pageBody p}
|
||||
-|]
|
||||
+ defaultLayout w = error "defaultLayout not implemented"
|
||||
|
||||
-- | Override the rendering function for a particular URL. One use case for
|
||||
-- this is to offload static hosting to a different domain name to avoid
|
||||
@@ -521,46 +505,11 @@ applyLayout' title body = fmap chooseRep $ defaultLayout $ do
|
||||
|
||||
-- | The default error handler for 'errorHandler'.
|
||||
defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep
|
||||
-defaultErrorHandler NotFound = do
|
||||
- r <- waiRequest
|
||||
- let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
|
||||
- applyLayout' "Not Found"
|
||||
- [hamlet|
|
||||
-$newline never
|
||||
-<h1>Not Found
|
||||
-<p>#{path'}
|
||||
-|]
|
||||
-defaultErrorHandler (PermissionDenied msg) =
|
||||
- applyLayout' "Permission Denied"
|
||||
- [hamlet|
|
||||
-$newline never
|
||||
-<h1>Permission denied
|
||||
-<p>#{msg}
|
||||
-|]
|
||||
-defaultErrorHandler (InvalidArgs ia) =
|
||||
- applyLayout' "Invalid Arguments"
|
||||
- [hamlet|
|
||||
-$newline never
|
||||
-<h1>Invalid Arguments
|
||||
-<ul>
|
||||
- $forall msg <- ia
|
||||
- <li>#{msg}
|
||||
-|]
|
||||
-defaultErrorHandler (InternalError e) = do
|
||||
- $logErrorS "yesod-core" e
|
||||
- applyLayout' "Internal Server Error"
|
||||
- [hamlet|
|
||||
-$newline never
|
||||
-<h1>Internal Server Error
|
||||
-<pre>#{e}
|
||||
-|]
|
||||
-defaultErrorHandler (BadMethod m) =
|
||||
- applyLayout' "Bad Method"
|
||||
- [hamlet|
|
||||
-$newline never
|
||||
-<h1>Method Not Supported
|
||||
-<p>Method <code>#{S8.unpack m}</code> not supported
|
||||
-|]
|
||||
+defaultErrorHandler NotFound = error "Not Found"
|
||||
+defaultErrorHandler (PermissionDenied msg) = error "Permission Denied"
|
||||
+defaultErrorHandler (InvalidArgs ia) = error "Invalid Arguments"
|
||||
+defaultErrorHandler (InternalError e) = error "Internal Server Error"
|
||||
+defaultErrorHandler (BadMethod m) = error "Bad Method"
|
||||
|
||||
-- | Return the same URL if the user is authorized to see it.
|
||||
--
|
||||
@@ -616,45 +565,10 @@ widgetToPageContent w = do
|
||||
-- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing
|
||||
-- the asynchronous loader means your page doesn't have to wait for all the js to load
|
||||
let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc
|
||||
- regularScriptLoad = [hamlet|
|
||||
-$newline never
|
||||
-$forall s <- scripts
|
||||
- ^{mkScriptTag s}
|
||||
-$maybe j <- jscript
|
||||
- $maybe s <- jsLoc
|
||||
- <script src="#{s}">
|
||||
- $nothing
|
||||
- <script>^{jelper j}
|
||||
-|]
|
||||
-
|
||||
- headAll = [hamlet|
|
||||
-$newline never
|
||||
-\^{head'}
|
||||
-$forall s <- stylesheets
|
||||
- ^{mkLinkTag s}
|
||||
-$forall s <- css
|
||||
- $maybe t <- right $ snd s
|
||||
- $maybe media <- fst s
|
||||
- <link rel=stylesheet media=#{media} href=#{t}>
|
||||
- $nothing
|
||||
- <link rel=stylesheet href=#{t}>
|
||||
- $maybe content <- left $ snd s
|
||||
- $maybe media <- fst s
|
||||
- <style media=#{media}>#{content}
|
||||
- $nothing
|
||||
- <style>#{content}
|
||||
-$case jsLoader master
|
||||
- $of BottomOfBody
|
||||
- $of BottomOfHeadAsync asyncJsLoader
|
||||
- ^{asyncJsLoader asyncScripts mcomplete}
|
||||
- $of BottomOfHeadBlocking
|
||||
- ^{regularScriptLoad}
|
||||
-|]
|
||||
- let bodyScript = [hamlet|
|
||||
-$newline never
|
||||
-^{body}
|
||||
-^{regularScriptLoad}
|
||||
-|]
|
||||
+ regularScriptLoad = error "TODO"
|
||||
+
|
||||
+ headAll = error "TODO"
|
||||
+ let bodyScript = error "TODO"
|
||||
|
||||
return $ PageContent title headAll (case jsLoader master of
|
||||
BottomOfBody -> bodyScript
|
||||
@@ -696,18 +610,7 @@ jsonArray = unsafeLazyByteString . encode . Array . Vector.fromList . map String
|
||||
|
||||
-- | For use with setting 'jsLoader' to 'BottomOfHeadAsync'
|
||||
loadJsYepnope :: Yesod master => Either Text (Route master) -> [Text] -> Maybe (HtmlUrl (Route master)) -> (HtmlUrl (Route master))
|
||||
-loadJsYepnope eyn scripts mcomplete =
|
||||
- [hamlet|
|
||||
-$newline never
|
||||
- $maybe yn <- left eyn
|
||||
- <script src=#{yn}>
|
||||
- $maybe yn <- right eyn
|
||||
- <script src=@{yn}>
|
||||
- $maybe complete <- mcomplete
|
||||
- <script>yepnope({load:#{jsonArray scripts},complete:function(){^{complete}}});
|
||||
- $nothing
|
||||
- <script>yepnope({load:#{jsonArray scripts}});
|
||||
-|]
|
||||
+loadJsYepnope eyn scripts mcomplete = error "TODO"
|
||||
|
||||
asyncHelper :: (url -> [x] -> Text)
|
||||
-> [Script (url)]
|
||||
diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs
|
||||
index bd94bd3..bf79150 100644
|
||||
--- a/Yesod/Widget.hs
|
||||
+++ b/Yesod/Widget.hs
|
||||
@@ -15,8 +15,6 @@ module Yesod.Widget
|
||||
GWidget
|
||||
, PageContent (..)
|
||||
-- * Special Hamlet quasiquoter/TH for Widgets
|
||||
- , whamlet
|
||||
- , whamletFile
|
||||
, ihamletToRepHtml
|
||||
-- * Convert to Widget
|
||||
, ToWidget (..)
|
||||
@@ -54,7 +52,6 @@ module Yesod.Widget
|
||||
, addScriptEither
|
||||
-- * Internal
|
||||
, unGWidget
|
||||
- , whamletFileWithSettings
|
||||
) where
|
||||
|
||||
import Data.Monoid
|
||||
@@ -274,32 +271,6 @@ data PageContent url = PageContent
|
||||
, pageBody :: HtmlUrl url
|
||||
}
|
||||
|
||||
-whamlet :: QuasiQuoter
|
||||
-whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
|
||||
-
|
||||
-whamletFile :: FilePath -> Q Exp
|
||||
-whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings
|
||||
-
|
||||
-whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp
|
||||
-whamletFileWithSettings = NP.hamletFileWithSettings rules
|
||||
-
|
||||
-rules :: Q NP.HamletRules
|
||||
-rules = do
|
||||
- ah <- [|toWidget|]
|
||||
- let helper qg f = do
|
||||
- x <- newName "urender"
|
||||
- e <- f $ VarE x
|
||||
- let e' = LamE [VarP x] e
|
||||
- g <- qg
|
||||
- bind <- [|(>>=)|]
|
||||
- return $ InfixE (Just g) bind (Just e')
|
||||
- let ur f = do
|
||||
- let env = NP.Env
|
||||
- (Just $ helper [|liftW getUrlRenderParams|])
|
||||
- (Just $ helper [|liftM (toHtml .) $ liftW getMessageRender|])
|
||||
- f env
|
||||
- return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b
|
||||
-
|
||||
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
||||
ihamletToRepHtml :: RenderMessage master message
|
||||
=> HtmlUrlI18n message (Route master)
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,102 @@
|
|||
From 8ff7908799eb69d440168ff3df1fe3187879df33 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:39:57 -0400
|
||||
Subject: [PATCH] remove TH
|
||||
|
||||
---
|
||||
Yesod/Default/Util.hs | 61 +------------------------------------------------
|
||||
1 file changed, 1 insertion(+), 60 deletions(-)
|
||||
|
||||
diff --git a/Yesod/Default/Util.hs b/Yesod/Default/Util.hs
|
||||
index 578b9bc..178e342 100644
|
||||
--- a/Yesod/Default/Util.hs
|
||||
+++ b/Yesod/Default/Util.hs
|
||||
@@ -5,8 +5,6 @@
|
||||
module Yesod.Default.Util
|
||||
( addStaticContentExternal
|
||||
, globFile
|
||||
- , widgetFileNoReload
|
||||
- , widgetFileReload
|
||||
, TemplateLanguage (..)
|
||||
, defaultTemplateLanguages
|
||||
, WidgetFileSettings
|
||||
@@ -21,9 +19,6 @@ import Yesod.Core -- purposely using complete import so that Haddock will see ad
|
||||
import Control.Monad (when, unless)
|
||||
import System.Directory (doesFileExist, createDirectoryIfMissing)
|
||||
import Language.Haskell.TH.Syntax
|
||||
-import Text.Lucius (luciusFile, luciusFileReload)
|
||||
-import Text.Julius (juliusFile, juliusFileReload)
|
||||
-import Text.Cassius (cassiusFile, cassiusFileReload)
|
||||
import Text.Hamlet (HamletSettings, defaultHamletSettings)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Default (Default (def))
|
||||
@@ -72,13 +67,7 @@ data TemplateLanguage = TemplateLanguage
|
||||
|
||||
defaultTemplateLanguages :: HamletSettings -> [TemplateLanguage]
|
||||
defaultTemplateLanguages hset =
|
||||
- [ TemplateLanguage False "hamlet" whamletFile' whamletFile'
|
||||
- , TemplateLanguage True "cassius" cassiusFile cassiusFileReload
|
||||
- , TemplateLanguage True "julius" juliusFile juliusFileReload
|
||||
- , TemplateLanguage True "lucius" luciusFile luciusFileReload
|
||||
- ]
|
||||
- where
|
||||
- whamletFile' = whamletFileWithSettings hset
|
||||
+ [ ]
|
||||
|
||||
data WidgetFileSettings = WidgetFileSettings
|
||||
{ wfsLanguages :: HamletSettings -> [TemplateLanguage]
|
||||
@@ -87,51 +76,3 @@ data WidgetFileSettings = WidgetFileSettings
|
||||
|
||||
instance Default WidgetFileSettings where
|
||||
def = WidgetFileSettings defaultTemplateLanguages defaultHamletSettings
|
||||
-
|
||||
-widgetFileNoReload :: WidgetFileSettings -> FilePath -> Q Exp
|
||||
-widgetFileNoReload wfs x = combine "widgetFileNoReload" x False $ wfsLanguages wfs $ wfsHamletSettings wfs
|
||||
-
|
||||
-widgetFileReload :: WidgetFileSettings -> FilePath -> Q Exp
|
||||
-widgetFileReload wfs x = combine "widgetFileReload" x True $ wfsLanguages wfs $ wfsHamletSettings wfs
|
||||
-
|
||||
-combine :: String -> String -> Bool -> [TemplateLanguage] -> Q Exp
|
||||
-combine func file isReload tls = do
|
||||
- mexps <- qmexps
|
||||
- case catMaybes mexps of
|
||||
- [] -> error $ concat
|
||||
- [ "Called "
|
||||
- , func
|
||||
- , " on "
|
||||
- , show file
|
||||
- , ", but no template were found."
|
||||
- ]
|
||||
- exps -> return $ DoE $ map NoBindS exps
|
||||
- where
|
||||
- qmexps :: Q [Maybe Exp]
|
||||
- qmexps = mapM go tls
|
||||
-
|
||||
- go :: TemplateLanguage -> Q (Maybe Exp)
|
||||
- go tl = whenExists file (tlRequiresToWidget tl) (tlExtension tl) ((if isReload then tlReload else tlNoReload) tl)
|
||||
-
|
||||
-whenExists :: String
|
||||
- -> Bool -- ^ requires toWidget wrap
|
||||
- -> String -> (FilePath -> Q Exp) -> Q (Maybe Exp)
|
||||
-whenExists = warnUnlessExists False
|
||||
-
|
||||
-warnUnlessExists :: Bool
|
||||
- -> String
|
||||
- -> Bool -- ^ requires toWidget wrap
|
||||
- -> String -> (FilePath -> Q Exp) -> Q (Maybe Exp)
|
||||
-warnUnlessExists shouldWarn x wrap glob f = do
|
||||
- let fn = globFile glob x
|
||||
- e <- qRunIO $ doesFileExist fn
|
||||
- when (shouldWarn && not e) $ qRunIO $ putStrLn $ "widget file not found: " ++ fn
|
||||
- if e
|
||||
- then do
|
||||
- ex <- f fn
|
||||
- if wrap
|
||||
- then do
|
||||
- tw <- [|toWidget|]
|
||||
- return $ Just $ tw `AppE` ex
|
||||
- else return $ Just ex
|
||||
- else return Nothing
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,675 @@
|
|||
From c47d263779fba34629130398f1b08be1b8e468f7 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:40:05 -0400
|
||||
Subject: [PATCH] avoid TH (hack job)
|
||||
|
||||
---
|
||||
Yesod/Form/Fields.hs | 93 ++++++++++++++++++++++++++++---------
|
||||
Yesod/Form/Functions.hs | 118 ++++++++++++++++++++++++++++++++---------------
|
||||
Yesod/Form/Jquery.hs | 13 ++++--
|
||||
Yesod/Form/MassInput.hs | 18 ++++++--
|
||||
yesod-form.cabal | 1 -
|
||||
5 files changed, 173 insertions(+), 70 deletions(-)
|
||||
|
||||
diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs
|
||||
index adc59de..353c8d0 100644
|
||||
--- a/Yesod/Form/Fields.hs
|
||||
+++ b/Yesod/Form/Fields.hs
|
||||
@@ -50,7 +50,7 @@ import Yesod.Form.Types
|
||||
import Yesod.Form.I18n.English
|
||||
import Yesod.Form.Functions (parseHelper)
|
||||
import Yesod.Handler (getMessageRender)
|
||||
-import Yesod.Widget (toWidget, whamlet, GWidget)
|
||||
+import Yesod.Widget (toWidget, GWidget)
|
||||
import Yesod.Message (RenderMessage (renderMessage), SomeMessage (..))
|
||||
import Text.Hamlet
|
||||
import Text.Blaze (ToMarkup (toMarkup), preEscapedToMarkup, unsafeByteString)
|
||||
@@ -108,10 +108,12 @@ intField = Field
|
||||
Right (a, "") -> Right a
|
||||
_ -> Left $ MsgInvalidInteger s
|
||||
|
||||
- , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|
||||
+ , fieldView = \theId name attrs val isReq -> error "intField TH TODO"
|
||||
+{- toWidget [hamlet|
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="number" :isReq:required="" value="#{showVal val}">
|
||||
|]
|
||||
+-}
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
where
|
||||
@@ -125,32 +127,40 @@ doubleField = Field
|
||||
Right (a, "") -> Right a
|
||||
_ -> Left $ MsgInvalidNumber s
|
||||
|
||||
- , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|
||||
+ , fieldView = \theId name attrs val isReq -> error "doubleField TH TODO"
|
||||
+{-
|
||||
+ - toWidget [hamlet|
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{showVal val}">
|
||||
|]
|
||||
+-}
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
- where showVal = either id (pack . show)
|
||||
+{-
|
||||
+ where showVal = either id (pack . show)-}
|
||||
|
||||
dayField :: RenderMessage master FormMessage => Field sub master Day
|
||||
dayField = Field
|
||||
{ fieldParse = parseHelper $ parseDate . unpack
|
||||
- , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|
||||
+ , fieldView = \theId name attrs val isReq -> error "dayfield TH TODO"
|
||||
+{- toWidget [hamlet|
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}">
|
||||
|]
|
||||
+-}
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
- where showVal = either id (pack . show)
|
||||
+{- where showVal = either id (pack . show) -}
|
||||
|
||||
timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay
|
||||
timeField = Field
|
||||
{ fieldParse = parseHelper parseTime
|
||||
- , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|
||||
+ , fieldView = \theId name attrs val isReq -> error "timefield TH TODO"
|
||||
+{- toWidget [hamlet|
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} :isReq:required="" value="#{showVal val}">
|
||||
|]
|
||||
+-}
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
where
|
||||
@@ -163,10 +173,12 @@ $newline never
|
||||
htmlField :: RenderMessage master FormMessage => Field sub master Html
|
||||
htmlField = Field
|
||||
{ fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance
|
||||
- , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
|
||||
+ , fieldView = \theId name attrs val _isReq -> error "htmlField TH TODO"
|
||||
+{- toWidget [hamlet|
|
||||
$newline never
|
||||
<textarea id="#{theId}" name="#{name}" *{attrs}>#{showVal val}
|
||||
|]
|
||||
+-}
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
where showVal = either id (pack . renderHtml)
|
||||
@@ -192,10 +204,12 @@ instance ToHtml Textarea where
|
||||
textareaField :: RenderMessage master FormMessage => Field sub master Textarea
|
||||
textareaField = Field
|
||||
{ fieldParse = parseHelper $ Right . Textarea
|
||||
- , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
|
||||
+ , fieldView = \theId name attrs val _isReq -> error "textAreafield TH TODO"
|
||||
+{- toWidget [hamlet|
|
||||
$newline never
|
||||
<textarea id="#{theId}" name="#{name}" *{attrs}>#{either id unTextarea val}
|
||||
|]
|
||||
+-}
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
|
||||
@@ -203,31 +217,37 @@ hiddenField :: (PathPiece p, RenderMessage master FormMessage)
|
||||
=> Field sub master p
|
||||
hiddenField = Field
|
||||
{ fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece
|
||||
- , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
|
||||
+ , fieldView = \theId name attrs val _isReq -> error "hiddenfield TH TODO"
|
||||
+{- toWidget [hamlet|
|
||||
$newline never
|
||||
<input type="hidden" id="#{theId}" name="#{name}" *{attrs} value="#{either id toPathPiece val}">
|
||||
|]
|
||||
+-}
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
|
||||
textField :: RenderMessage master FormMessage => Field sub master Text
|
||||
textField = Field
|
||||
{ fieldParse = parseHelper $ Right
|
||||
- , fieldView = \theId name attrs val isReq ->
|
||||
+ , fieldView = \theId name attrs val isReq -> error "textField TH TODO"
|
||||
+{-
|
||||
[whamlet|
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required value="#{either id id val}">
|
||||
|]
|
||||
+-}
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
|
||||
passwordField :: RenderMessage master FormMessage => Field sub master Text
|
||||
passwordField = Field
|
||||
{ fieldParse = parseHelper $ Right
|
||||
- , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|
||||
+ , fieldView = \theId name attrs val isReq -> error "passwordfield TH TODO"
|
||||
+{- toWidget [hamlet|
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="password" :isReq:required="" value="#{either id id val}">
|
||||
|]
|
||||
+-}
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
|
||||
@@ -305,10 +325,13 @@ emailField = Field
|
||||
then Right s
|
||||
else Left $ MsgInvalidEmail s
|
||||
#endif
|
||||
- , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
|
||||
+ , fieldView = \theId name attrs val isReq -> error "emailField TH TODO"
|
||||
+{-
|
||||
+toWidget [hamlet|
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{either id id val}">
|
||||
|]
|
||||
+-}
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
|
||||
@@ -316,7 +339,8 @@ type AutoFocus = Bool
|
||||
searchField :: RenderMessage master FormMessage => AutoFocus -> Field sub master Text
|
||||
searchField autoFocus = Field
|
||||
{ fieldParse = parseHelper Right
|
||||
- , fieldView = \theId name attrs val isReq -> do
|
||||
+ , fieldView = \theId name attrs val isReq -> error "searchfield TH TODO"
|
||||
+{-
|
||||
[whamlet|\
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">
|
||||
@@ -331,6 +355,7 @@ $newline never
|
||||
##{theId}
|
||||
-webkit-appearance: textfield
|
||||
|]
|
||||
+-}
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
|
||||
@@ -340,11 +365,13 @@ urlField = Field
|
||||
case parseURI $ unpack s of
|
||||
Nothing -> Left $ MsgInvalidUrl s
|
||||
Just _ -> Right s
|
||||
- , fieldView = \theId name attrs val isReq ->
|
||||
+ , fieldView = \theId name attrs val isReq -> error "urlField TH TODO"
|
||||
+{-
|
||||
[whamlet|
|
||||
$newline never
|
||||
<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id id val}>
|
||||
|]
|
||||
+-}
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
|
||||
@@ -352,6 +379,8 @@ selectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master
|
||||
selectFieldList = selectField . optionsPairs
|
||||
|
||||
selectField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a
|
||||
+selectField = error "selectfield TH TODO"
|
||||
+{-
|
||||
selectField = selectFieldHelper
|
||||
(\theId name attrs inside -> [whamlet|
|
||||
$newline never
|
||||
@@ -365,6 +394,7 @@ $newline never
|
||||
$newline never
|
||||
<option value=#{value} :isSel:selected>#{text}
|
||||
|]) -- inside
|
||||
+-}
|
||||
|
||||
multiSelectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master [a]
|
||||
multiSelectFieldList = multiSelectField . optionsPairs
|
||||
@@ -382,7 +412,8 @@ multiSelectField ioptlist =
|
||||
Nothing -> return $ Left "Error parsing values"
|
||||
Just res -> return $ Right $ Just res
|
||||
|
||||
- view theId name attrs val isReq = do
|
||||
+ view theId name attrs val isReq = error "multiSelectField TH TODO"
|
||||
+{-
|
||||
opts <- fmap olOptions $ lift ioptlist
|
||||
let selOpts = map (id &&& (optselected val)) opts
|
||||
[whamlet|
|
||||
@@ -394,12 +425,15 @@ $newline never
|
||||
where
|
||||
optselected (Left _) _ = False
|
||||
optselected (Right vals) opt = (optionInternalValue opt) `elem` vals
|
||||
+-}
|
||||
|
||||
radioFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master a
|
||||
radioFieldList = radioField . optionsPairs
|
||||
|
||||
radioField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a
|
||||
-radioField = selectFieldHelper
|
||||
+radioField = error "radioField TH TODO"
|
||||
+{-
|
||||
+ selectFieldHelper
|
||||
(\theId _name _attrs inside -> [whamlet|
|
||||
$newline never
|
||||
<div ##{theId}>^{inside}
|
||||
@@ -418,11 +452,14 @@ $newline never
|
||||
<input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}>
|
||||
\#{text}
|
||||
|])
|
||||
+-}
|
||||
|
||||
boolField :: RenderMessage master FormMessage => Field sub master Bool
|
||||
boolField = Field
|
||||
{ fieldParse = \e _ -> return $ boolParser e
|
||||
- , fieldView = \theId name attrs val isReq -> [whamlet|
|
||||
+ , fieldView = \theId name attrs val isReq -> error "boolField TH TODO"
|
||||
+{-
|
||||
+[whamlet|
|
||||
$newline never
|
||||
$if not isReq
|
||||
<input id=#{theId}-none *{attrs} type=radio name=#{name} value=none checked>
|
||||
@@ -435,6 +472,7 @@ $newline never
|
||||
<input id=#{theId}-no *{attrs} type=radio name=#{name} value=no :showVal not val:checked>
|
||||
<label for=#{theId}-no>_{MsgBoolNo}
|
||||
|]
|
||||
+-}
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
where
|
||||
@@ -458,10 +496,13 @@ $newline never
|
||||
checkBoxField :: RenderMessage m FormMessage => Field s m Bool
|
||||
checkBoxField = Field
|
||||
{ fieldParse = \e _ -> return $ checkBoxParser e
|
||||
- , fieldView = \theId name attrs val _ -> [whamlet|
|
||||
+ , fieldView = \theId name attrs val _ -> error "checkBoxField TH TODO"
|
||||
+{-
|
||||
+ [whamlet|
|
||||
$newline never
|
||||
<input id=#{theId} *{attrs} type=checkbox name=#{name} value=yes :showVal id val:checked>
|
||||
|]
|
||||
+-}
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
|
||||
@@ -566,9 +607,11 @@ fileField = Field
|
||||
case files of
|
||||
[] -> Right Nothing
|
||||
file:_ -> Right $ Just file
|
||||
- , fieldView = \id' name attrs _ isReq -> toWidget [hamlet|
|
||||
+ , fieldView = \id' name attrs _ isReq -> error "fieldField TODO"
|
||||
+{- toWidget [hamlet|
|
||||
<input id=#{id'} name=#{name} *{attrs} type=file :isReq:required>
|
||||
|]
|
||||
+-}
|
||||
, fieldEnctype = Multipart
|
||||
}
|
||||
|
||||
@@ -594,10 +637,13 @@ fileAFormReq 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|
|
||||
+ , fvInput = error "fileAFormReq TH TODO"
|
||||
+{-
|
||||
+[whamlet|
|
||||
$newline never
|
||||
<input type=file name=#{name} ##{id'} *{fsAttrs fs}>
|
||||
|]
|
||||
+-}
|
||||
, fvErrors = errs
|
||||
, fvRequired = True
|
||||
}
|
||||
@@ -623,10 +669,13 @@ 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|
|
||||
+ , fvInput = error "fileAFormOpt TH TODO"
|
||||
+{-
|
||||
+[whamlet|
|
||||
$newline never
|
||||
<input type=file name=#{name} ##{id'} *{fsAttrs fs}>
|
||||
|]
|
||||
+-}
|
||||
, fvErrors = errs
|
||||
, fvRequired = False
|
||||
}
|
||||
diff --git a/Yesod/Form/Functions.hs b/Yesod/Form/Functions.hs
|
||||
index db3e493..a51e132 100644
|
||||
--- a/Yesod/Form/Functions.hs
|
||||
+++ b/Yesod/Form/Functions.hs
|
||||
@@ -44,20 +44,21 @@ module Yesod.Form.Functions
|
||||
|
||||
import Yesod.Form.Types
|
||||
import Data.Text (Text, pack)
|
||||
+import Data.Foldable
|
||||
import Control.Arrow (second)
|
||||
import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad (liftM, join)
|
||||
import Crypto.Classes (constTimeEq)
|
||||
import Text.Blaze (Markup, toMarkup)
|
||||
+import qualified Text.Blaze.Internal
|
||||
#define Html Markup
|
||||
#define toHtml toMarkup
|
||||
import Yesod.Handler (GHandler, getRequest, runRequestBody, newIdent, getYesod)
|
||||
import Yesod.Core (RenderMessage, SomeMessage (..))
|
||||
-import Yesod.Widget (GWidget, whamlet)
|
||||
+import Yesod.Widget (GWidget, toWidget)
|
||||
import Yesod.Request (reqToken, reqWaiRequest, reqGetParams, languages)
|
||||
import Network.Wai (requestMethod)
|
||||
-import Text.Hamlet (shamlet)
|
||||
import Data.Monoid (mempty)
|
||||
import Data.Maybe (listToMaybe, fromMaybe)
|
||||
import Yesod.Message (RenderMessage (..))
|
||||
@@ -66,6 +67,7 @@ import qualified Data.Text.Encoding as TE
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Arrow (first)
|
||||
import Yesod.Request (FileInfo)
|
||||
+import Text.Hamlet (condH, maybeH)
|
||||
|
||||
-- | Get a unique identifier.
|
||||
newFormIdent :: MForm sub master Text
|
||||
@@ -189,26 +191,7 @@ postHelper :: RenderMessage master FormMessage
|
||||
postHelper form env = do
|
||||
req <- getRequest
|
||||
let tokenKey = "_token"
|
||||
- let token =
|
||||
- case reqToken req of
|
||||
- Nothing -> mempty
|
||||
- Just n -> [shamlet|
|
||||
-$newline never
|
||||
-<input type=hidden name=#{tokenKey} value=#{n}>
|
||||
-|]
|
||||
- m <- getYesod
|
||||
- langs <- languages
|
||||
- ((res, xml), enctype) <- runFormGeneric (form token) m langs env
|
||||
- let res' =
|
||||
- case (res, env) of
|
||||
- (FormSuccess{}, Just (params, _))
|
||||
- | not (Map.lookup tokenKey params === reqToken req) ->
|
||||
- FormFailure [renderMessage m langs MsgCsrfWarning]
|
||||
- _ -> res
|
||||
- where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constTimeEq` TE.encodeUtf8 t2
|
||||
- Nothing === Nothing = True -- It's important to use constTimeEq
|
||||
- _ === _ = False -- in order to avoid timing attacks.
|
||||
- return ((res', xml), enctype)
|
||||
+ error "yesod-form postHelper needs TH, disabled"
|
||||
|
||||
-- | Similar to 'runFormPost', except it always ignore the currently available
|
||||
-- environment. This is necessary in cases like a wizard UI, where a single
|
||||
@@ -253,7 +236,8 @@ getKey :: Text
|
||||
getKey = "_hasdata"
|
||||
|
||||
getHelper :: (Html -> MForm sub master a) -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype)
|
||||
-getHelper form env = do
|
||||
+getHelper form env = error "yesod-form getHelper needs TH, disabled"
|
||||
+{-
|
||||
let fragment = [shamlet|
|
||||
$newline never
|
||||
<input type=hidden name=#{getKey}>
|
||||
@@ -261,6 +245,7 @@ $newline never
|
||||
langs <- languages
|
||||
m <- getYesod
|
||||
runFormGeneric (form fragment) m langs env
|
||||
+-}
|
||||
|
||||
type FormRender sub master a =
|
||||
AForm sub master a
|
||||
@@ -271,6 +256,7 @@ renderTable, renderDivs, renderDivsNoLabels :: FormRender sub master a
|
||||
renderTable aform fragment = do
|
||||
(res, views') <- aFormToForm aform
|
||||
let views = views' []
|
||||
+{-
|
||||
let widget = [whamlet|
|
||||
$newline never
|
||||
\#{fragment}
|
||||
@@ -285,6 +271,8 @@ $forall view <- views
|
||||
<td .errors>#{err}
|
||||
|]
|
||||
return (res, widget)
|
||||
+-}
|
||||
+ error "yesod-form renderTable, needs TN, not implemented"
|
||||
|
||||
-- | render a field inside a div
|
||||
renderDivs = renderDivsMaybeLabels True
|
||||
@@ -293,7 +281,8 @@ renderDivs = renderDivsMaybeLabels True
|
||||
renderDivsNoLabels = renderDivsMaybeLabels False
|
||||
|
||||
renderDivsMaybeLabels :: Bool -> FormRender sub master a
|
||||
-renderDivsMaybeLabels withLabels aform fragment = do
|
||||
+renderDivsMaybeLabels withLabels aform fragment = error "yesod-form renderDivsMaybeLabels needs TH, not implemented"
|
||||
+{-
|
||||
(res, views') <- aFormToForm aform
|
||||
let views = views' []
|
||||
let widget = [whamlet|
|
||||
@@ -310,6 +299,7 @@ $forall view <- views
|
||||
<div .errors>#{err}
|
||||
|]
|
||||
return (res, widget)
|
||||
+-}
|
||||
|
||||
-- | Render a form using Bootstrap-friendly shamlet syntax.
|
||||
--
|
||||
@@ -332,19 +322,73 @@ 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.Widget.toWidget
|
||||
+ (Text.Blaze.toHtml fragment);
|
||||
+ Data.Foldable.mapM_
|
||||
+ (\ view_a55Y
|
||||
+ -> do { Yesod.Widget.toWidget
|
||||
+ ((Text.Blaze.Internal.preEscapedText . pack)
|
||||
+ "<div class=\"control-group clearfix ");
|
||||
+ Text.Hamlet.condH
|
||||
+ [(fvRequired view_a55Y,
|
||||
+ Yesod.Widget.toWidget
|
||||
+ ((Text.Blaze.Internal.preEscapedText . pack)
|
||||
+ "required "))]
|
||||
+ Nothing;
|
||||
+ Text.Hamlet.condH
|
||||
+ [(not (fvRequired view_a55Y),
|
||||
+ Yesod.Widget.toWidget
|
||||
+ ((Text.Blaze.Internal.preEscapedText . pack)
|
||||
+ "optional "))]
|
||||
+ Nothing;
|
||||
+ Text.Hamlet.condH
|
||||
+ [(has (fvErrors view_a55Y),
|
||||
+ Yesod.Widget.toWidget
|
||||
+ ((Text.Blaze.Internal.preEscapedText . pack)
|
||||
+ "error"))]
|
||||
+ Nothing;
|
||||
+ Yesod.Widget.toWidget
|
||||
+ ((Text.Blaze.Internal.preEscapedText . pack)
|
||||
+ "\"><label class=\"control-label\" for=\"");
|
||||
+ Yesod.Widget.toWidget
|
||||
+ (Text.Blaze.toHtml (fvId view_a55Y));
|
||||
+ Yesod.Widget.toWidget
|
||||
+ ((Text.Blaze.Internal.preEscapedText . pack)
|
||||
+ "\">");
|
||||
+ Yesod.Widget.toWidget
|
||||
+ (Text.Blaze.toHtml (fvLabel view_a55Y));
|
||||
+ Yesod.Widget.toWidget
|
||||
+ ((Text.Blaze.Internal.preEscapedText . pack)
|
||||
+ "</label><div class=\"controls input\">");
|
||||
+ Yesod.Widget.toWidget (fvInput view_a55Y);
|
||||
+ Text.Hamlet.maybeH
|
||||
+ (fvTooltip view_a55Y)
|
||||
+ (\ tt_a55Z
|
||||
+ -> do { Yesod.Widget.toWidget
|
||||
+ ((Text.Blaze.Internal.preEscapedText . pack)
|
||||
+ "<span class=\"help-block\">");
|
||||
+ Yesod.Widget.toWidget
|
||||
+ (Text.Blaze.toHtml tt_a55Z);
|
||||
+ Yesod.Widget.toWidget
|
||||
+ ((Text.Blaze.Internal.preEscapedText . pack)
|
||||
+ "</span>") })
|
||||
+ Nothing;
|
||||
+ Text.Hamlet.maybeH
|
||||
+ (fvErrors view_a55Y)
|
||||
+ (\ err_a560
|
||||
+ -> do { Yesod.Widget.toWidget
|
||||
+ ((Text.Blaze.Internal.preEscapedText . pack)
|
||||
+ "<span class=\"help-block\">");
|
||||
+ Yesod.Widget.toWidget
|
||||
+ (Text.Blaze.toHtml err_a560);
|
||||
+ Yesod.Widget.toWidget
|
||||
+ ((Text.Blaze.Internal.preEscapedText . pack)
|
||||
+ "</span>") })
|
||||
+ Nothing;
|
||||
+ Yesod.Widget.toWidget
|
||||
+ ((Text.Blaze.Internal.preEscapedText . pack)
|
||||
+ "</div></div>") })
|
||||
+ views }
|
||||
return (res, widget)
|
||||
|
||||
check :: RenderMessage master msg
|
||||
diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs
|
||||
index 85a0c76..656a8e0 100644
|
||||
--- a/Yesod/Form/Jquery.hs
|
||||
+++ b/Yesod/Form/Jquery.hs
|
||||
@@ -18,8 +18,7 @@ import Yesod.Form
|
||||
import Yesod.Widget
|
||||
import Data.Time (Day)
|
||||
import Data.Default
|
||||
-import Text.Hamlet (shamlet)
|
||||
-import Text.Julius (julius, rawJS)
|
||||
+import Text.Julius (rawJS)
|
||||
import Data.Text (Text, pack, unpack)
|
||||
import Data.Monoid (mconcat)
|
||||
import Yesod.Core (RenderMessage)
|
||||
@@ -63,7 +62,8 @@ jqueryDayField jds = Field
|
||||
Right
|
||||
. readMay
|
||||
. unpack
|
||||
- , fieldView = \theId name attrs val isReq -> do
|
||||
+ , fieldView = \theId name attrs val isReq -> error "jqueryDayField TH TODO"
|
||||
+{-
|
||||
toWidget [shamlet|
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}">
|
||||
@@ -85,10 +85,11 @@ $(function(){
|
||||
}
|
||||
});
|
||||
|]
|
||||
+-}
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
where
|
||||
- showVal = either id (pack . show)
|
||||
+{- showVal = either id (pack . show) -}
|
||||
jsBool True = toJSON True
|
||||
jsBool False = toJSON False
|
||||
mos (Left i) = show i
|
||||
@@ -104,7 +105,8 @@ jqueryAutocompleteField :: (RenderMessage master FormMessage, YesodJquery master
|
||||
=> Route master -> Field sub master Text
|
||||
jqueryAutocompleteField src = Field
|
||||
{ fieldParse = parseHelper $ Right
|
||||
- , fieldView = \theId name attrs val isReq -> do
|
||||
+ , fieldView = \theId name attrs val isReq -> error "jqueryAutocompleteField TH TODO"
|
||||
+{-
|
||||
toWidget [shamlet|
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{either id id val}" .autocomplete>
|
||||
@@ -115,6 +117,7 @@ $newline never
|
||||
toWidget [julius|
|
||||
$(function(){$("##{rawJS theId}").autocomplete({source:"@{src}",minLength:2})});
|
||||
|]
|
||||
+-}
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
|
||||
diff --git a/Yesod/Form/MassInput.hs b/Yesod/Form/MassInput.hs
|
||||
index 62e89d6..14a4125 100644
|
||||
--- a/Yesod/Form/MassInput.hs
|
||||
+++ b/Yesod/Form/MassInput.hs
|
||||
@@ -12,7 +12,7 @@ module Yesod.Form.MassInput
|
||||
import Yesod.Form.Types
|
||||
import Yesod.Form.Functions
|
||||
import Yesod.Form.Fields (boolField)
|
||||
-import Yesod.Widget (GWidget, whamlet)
|
||||
+import Yesod.Widget (GWidget)
|
||||
import Yesod.Message (RenderMessage)
|
||||
import Yesod.Handler (newIdent, GHandler)
|
||||
import Text.Blaze.Html (Html)
|
||||
@@ -75,7 +75,8 @@ inputList label fixXml single mdef = formToAForm $ do
|
||||
{ fvLabel = label
|
||||
, fvTooltip = Nothing
|
||||
, fvId = theId
|
||||
- , fvInput = [whamlet|
|
||||
+ , fvInput = error "inputList TH TODO"
|
||||
+{-[whamlet|
|
||||
$newline never
|
||||
^{fixXml views}
|
||||
<p>
|
||||
@@ -85,6 +86,7 @@ $newline never
|
||||
<input type=checkbox name=#{addName}>
|
||||
Add another row
|
||||
|]
|
||||
+-}
|
||||
, fvErrors = Nothing
|
||||
, fvRequired = False
|
||||
}])
|
||||
@@ -97,10 +99,12 @@ withDelete af = do
|
||||
deleteName <- newFormIdent
|
||||
(menv, _, _) <- ask
|
||||
res <- case menv >>= Map.lookup deleteName . fst of
|
||||
- Just ("yes":_) -> return $ Left [whamlet|
|
||||
+ Just ("yes":_) -> return $ Left $ error "withDelete TH TODO"
|
||||
+{- [whamlet|
|
||||
$newline never
|
||||
<input type=hidden name=#{deleteName} value=yes>
|
||||
|]
|
||||
+-}
|
||||
_ -> do
|
||||
(_, xml2) <- aFormToForm $ areq boolField FieldSettings
|
||||
{ fsLabel = SomeMessage MsgDelete
|
||||
@@ -126,7 +130,8 @@ fixme eithers =
|
||||
massDivs, massTable
|
||||
:: [[FieldView sub master]]
|
||||
-> GWidget sub master ()
|
||||
-massDivs viewss = [whamlet|
|
||||
+massDivs viewss = error "massDivs TODO"
|
||||
+{-[whamlet|
|
||||
$newline never
|
||||
$forall views <- viewss
|
||||
<fieldset>
|
||||
@@ -139,8 +144,10 @@ $forall views <- viewss
|
||||
$maybe err <- fvErrors view
|
||||
<div .errors>#{err}
|
||||
|]
|
||||
+-}
|
||||
|
||||
-massTable viewss = [whamlet|
|
||||
+massTable viewss = error "massTable TH TODO"
|
||||
+{- [whamlet|
|
||||
$newline never
|
||||
$forall views <- viewss
|
||||
<fieldset>
|
||||
@@ -155,3 +162,4 @@ $forall views <- viewss
|
||||
$maybe err <- fvErrors view
|
||||
<td .errors>#{err}
|
||||
|]
|
||||
+-}
|
||||
diff --git a/yesod-form.cabal b/yesod-form.cabal
|
||||
index b0ac64e..249de69 100644
|
||||
--- a/yesod-form.cabal
|
||||
+++ b/yesod-form.cabal
|
||||
@@ -45,7 +45,6 @@ library
|
||||
Yesod.Form.Input
|
||||
Yesod.Form.Fields
|
||||
Yesod.Form.Jquery
|
||||
- Yesod.Form.Nic
|
||||
Yesod.Form.MassInput
|
||||
Yesod.Form.I18n.English
|
||||
Yesod.Form.I18n.Portuguese
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
From 62cc9e3f70d8cea848d56efa198a68527fd07267 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:40:19 -0400
|
||||
Subject: [PATCH] avoid TH
|
||||
|
||||
---
|
||||
Yesod/Persist.hs | 2 --
|
||||
yesod-persistent.cabal | 1 -
|
||||
2 files changed, 3 deletions(-)
|
||||
|
||||
diff --git a/Yesod/Persist.hs b/Yesod/Persist.hs
|
||||
index 0646152..5130497 100644
|
||||
--- a/Yesod/Persist.hs
|
||||
+++ b/Yesod/Persist.hs
|
||||
@@ -7,11 +7,9 @@ module Yesod.Persist
|
||||
, get404
|
||||
, getBy404
|
||||
, module Database.Persist
|
||||
- , module Database.Persist.TH
|
||||
) where
|
||||
|
||||
import Database.Persist
|
||||
-import Database.Persist.TH
|
||||
import Control.Monad.Trans.Class (MonadTrans)
|
||||
|
||||
import Yesod.Handler
|
||||
diff --git a/yesod-persistent.cabal b/yesod-persistent.cabal
|
||||
index 111c1b9..07f6e17 100644
|
||||
--- a/yesod-persistent.cabal
|
||||
+++ b/yesod-persistent.cabal
|
||||
@@ -16,7 +16,6 @@ library
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core >= 1.1 && < 1.2
|
||||
, persistent >= 1.0 && < 1.2
|
||||
- , persistent-template >= 1.0 && < 1.2
|
||||
, transformers >= 0.2.2 && < 0.4
|
||||
exposed-modules: Yesod.Persist
|
||||
ghc-options: -Wall
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,715 @@
|
|||
From bf9b294fd3a4ae4e550844504f3ac4ed0dc226c0 Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:40:44 -0400
|
||||
Subject: [PATCH] remove TH (hack job)
|
||||
|
||||
---
|
||||
Yesod/Routes/Overlap.hs | 74 ----------
|
||||
Yesod/Routes/Parse.hs | 115 ---------------
|
||||
Yesod/Routes/TH.hs | 12 --
|
||||
Yesod/Routes/TH/Dispatch.hs | 344 -------------------------------------------
|
||||
Yesod/Routes/TH/Types.hs | 84 -----------
|
||||
yesod-routes.cabal | 22 ---
|
||||
6 files changed, 651 deletions(-)
|
||||
delete mode 100644 Yesod/Routes/Overlap.hs
|
||||
delete mode 100644 Yesod/Routes/Parse.hs
|
||||
delete mode 100644 Yesod/Routes/TH.hs
|
||||
delete mode 100644 Yesod/Routes/TH/Dispatch.hs
|
||||
delete mode 100644 Yesod/Routes/TH/Types.hs
|
||||
|
||||
diff --git a/Yesod/Routes/Overlap.hs b/Yesod/Routes/Overlap.hs
|
||||
deleted file mode 100644
|
||||
index ae45a02..0000000
|
||||
--- a/Yesod/Routes/Overlap.hs
|
||||
+++ /dev/null
|
||||
@@ -1,74 +0,0 @@
|
||||
--- | Check for overlapping routes.
|
||||
-module Yesod.Routes.Overlap
|
||||
- ( findOverlaps
|
||||
- , findOverlapNames
|
||||
- , Overlap (..)
|
||||
- ) where
|
||||
-
|
||||
-import Yesod.Routes.TH.Types
|
||||
-import Data.List (intercalate)
|
||||
-
|
||||
-data Overlap t = Overlap
|
||||
- { overlapParents :: [String] -> [String] -- ^ parent resource trees
|
||||
- , overlap1 :: ResourceTree t
|
||||
- , overlap2 :: ResourceTree t
|
||||
- }
|
||||
-
|
||||
-findOverlaps :: ([String] -> [String]) -> [ResourceTree t] -> [Overlap t]
|
||||
-findOverlaps _ [] = []
|
||||
-findOverlaps front (x:xs) = concatMap (findOverlap front x) xs ++ findOverlaps front xs
|
||||
-
|
||||
-findOverlap :: ([String] -> [String]) -> ResourceTree t -> ResourceTree t -> [Overlap t]
|
||||
-findOverlap front x y =
|
||||
- here rest
|
||||
- where
|
||||
- here
|
||||
- | overlaps (resourceTreePieces x) (resourceTreePieces y) (hasSuffix x) (hasSuffix y) = (Overlap front x y:)
|
||||
- | otherwise = id
|
||||
- rest =
|
||||
- case x of
|
||||
- ResourceParent name _ children -> findOverlaps (front . (name:)) children
|
||||
- ResourceLeaf{} -> []
|
||||
-
|
||||
-hasSuffix :: ResourceTree t -> Bool
|
||||
-hasSuffix (ResourceLeaf r) =
|
||||
- case resourceDispatch r of
|
||||
- Subsite{} -> True
|
||||
- Methods Just{} _ -> True
|
||||
- Methods Nothing _ -> False
|
||||
-hasSuffix ResourceParent{} = True
|
||||
-
|
||||
-overlaps :: [(CheckOverlap, Piece t)] -> [(CheckOverlap, Piece t)] -> Bool -> Bool -> Bool
|
||||
-
|
||||
--- No pieces on either side, will overlap regardless of suffix
|
||||
-overlaps [] [] _ _ = True
|
||||
-
|
||||
--- No pieces on the left, will overlap if the left side has a suffix
|
||||
-overlaps [] _ suffixX _ = suffixX
|
||||
-
|
||||
--- Ditto for the right
|
||||
-overlaps _ [] _ suffixY = suffixY
|
||||
-
|
||||
--- As soon as we ignore a single piece (via CheckOverlap == False), we say that
|
||||
--- the routes don't overlap at all. In other words, disabling overlap checking
|
||||
--- on a single piece disables it on the whole route.
|
||||
-overlaps ((False, _):_) _ _ _ = False
|
||||
-overlaps _ ((False, _):_) _ _ = False
|
||||
-
|
||||
--- Compare the actual pieces
|
||||
-overlaps ((True, pieceX):xs) ((True, pieceY):ys) suffixX suffixY =
|
||||
- piecesOverlap pieceX pieceY && overlaps xs ys suffixX suffixY
|
||||
-
|
||||
-piecesOverlap :: Piece t -> Piece t -> Bool
|
||||
--- Statics only match if they equal. Dynamics match with anything
|
||||
-piecesOverlap (Static x) (Static y) = x == y
|
||||
-piecesOverlap _ _ = True
|
||||
-
|
||||
-findOverlapNames :: [ResourceTree t] -> [(String, String)]
|
||||
-findOverlapNames =
|
||||
- map go . findOverlaps id
|
||||
- where
|
||||
- go (Overlap front x y) =
|
||||
- (go' $ resourceTreeName x, go' $ resourceTreeName y)
|
||||
- where
|
||||
- go' = intercalate "/" . front . return
|
||||
diff --git a/Yesod/Routes/Parse.hs b/Yesod/Routes/Parse.hs
|
||||
deleted file mode 100644
|
||||
index fc16eef..0000000
|
||||
--- a/Yesod/Routes/Parse.hs
|
||||
+++ /dev/null
|
||||
@@ -1,115 +0,0 @@
|
||||
-{-# LANGUAGE TemplateHaskell #-}
|
||||
-{-# LANGUAGE DeriveDataTypeable #-}
|
||||
-{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
|
||||
-module Yesod.Routes.Parse
|
||||
- ( parseRoutes
|
||||
- , parseRoutesFile
|
||||
- , parseRoutesNoCheck
|
||||
- , parseRoutesFileNoCheck
|
||||
- , parseType
|
||||
- ) where
|
||||
-
|
||||
-import Language.Haskell.TH.Syntax
|
||||
-import Data.Char (isUpper)
|
||||
-import Language.Haskell.TH.Quote
|
||||
-import qualified System.IO as SIO
|
||||
-import Yesod.Routes.TH
|
||||
-import Yesod.Routes.Overlap (findOverlapNames)
|
||||
-
|
||||
--- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for
|
||||
--- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the
|
||||
--- checking. See documentation site for details on syntax.
|
||||
-parseRoutes :: QuasiQuoter
|
||||
-parseRoutes = QuasiQuoter { quoteExp = x }
|
||||
- where
|
||||
- x s = do
|
||||
- let res = resourcesFromString s
|
||||
- case findOverlapNames res of
|
||||
- [] -> lift res
|
||||
- z -> error $ "Overlapping routes: " ++ unlines (map show z)
|
||||
-
|
||||
-parseRoutesFile :: FilePath -> Q Exp
|
||||
-parseRoutesFile = parseRoutesFileWith parseRoutes
|
||||
-
|
||||
-parseRoutesFileNoCheck :: FilePath -> Q Exp
|
||||
-parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck
|
||||
-
|
||||
-parseRoutesFileWith :: QuasiQuoter -> FilePath -> Q Exp
|
||||
-parseRoutesFileWith qq fp = do
|
||||
- s <- qRunIO $ readUtf8File fp
|
||||
- quoteExp qq s
|
||||
-
|
||||
-readUtf8File :: FilePath -> IO String
|
||||
-readUtf8File fp = do
|
||||
- h <- SIO.openFile fp SIO.ReadMode
|
||||
- SIO.hSetEncoding h SIO.utf8_bom
|
||||
- SIO.hGetContents h
|
||||
-
|
||||
--- | Same as 'parseRoutes', but performs no overlap checking.
|
||||
-parseRoutesNoCheck :: QuasiQuoter
|
||||
-parseRoutesNoCheck = QuasiQuoter
|
||||
- { quoteExp = lift . resourcesFromString
|
||||
- }
|
||||
-
|
||||
--- | Convert a multi-line string to a set of resources. See documentation for
|
||||
--- the format of this string. This is a partial function which calls 'error' on
|
||||
--- invalid input.
|
||||
-resourcesFromString :: String -> [ResourceTree String]
|
||||
-resourcesFromString =
|
||||
- fst . parse 0 . lines
|
||||
- where
|
||||
- parse _ [] = ([], [])
|
||||
- parse indent (thisLine:otherLines)
|
||||
- | length spaces < indent = ([], thisLine : otherLines)
|
||||
- | otherwise = (this others, remainder)
|
||||
- where
|
||||
- spaces = takeWhile (== ' ') thisLine
|
||||
- (others, remainder) = parse indent otherLines'
|
||||
- (this, otherLines') =
|
||||
- case takeWhile (/= "--") $ words thisLine of
|
||||
- [pattern, constr] | last constr == ':' ->
|
||||
- let (children, otherLines'') = parse (length spaces + 1) otherLines
|
||||
- (pieces, Nothing) = piecesFromString $ drop1Slash pattern
|
||||
- in ((ResourceParent (init constr) pieces children :), otherLines'')
|
||||
- (pattern:constr:rest) ->
|
||||
- let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
|
||||
- disp = dispatchFromString rest mmulti
|
||||
- in ((ResourceLeaf (Resource constr pieces disp):), otherLines)
|
||||
- [] -> (id, otherLines)
|
||||
- _ -> error $ "Invalid resource line: " ++ thisLine
|
||||
-
|
||||
-dispatchFromString :: [String] -> Maybe String -> Dispatch String
|
||||
-dispatchFromString rest mmulti
|
||||
- | null rest = Methods mmulti []
|
||||
- | all (all isUpper) rest = Methods mmulti rest
|
||||
-dispatchFromString [subTyp, subFun] Nothing =
|
||||
- Subsite subTyp subFun
|
||||
-dispatchFromString [_, _] Just{} =
|
||||
- error "Subsites cannot have a multipiece"
|
||||
-dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest
|
||||
-
|
||||
-drop1Slash :: String -> String
|
||||
-drop1Slash ('/':x) = x
|
||||
-drop1Slash x = x
|
||||
-
|
||||
-piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe String)
|
||||
-piecesFromString "" = ([], Nothing)
|
||||
-piecesFromString x =
|
||||
- case (this, rest) of
|
||||
- (Left typ, ([], Nothing)) -> ([], Just typ)
|
||||
- (Left _, _) -> error "Multipiece must be last piece"
|
||||
- (Right piece, (pieces, mtyp)) -> (piece:pieces, mtyp)
|
||||
- where
|
||||
- (y, z) = break (== '/') x
|
||||
- this = pieceFromString y
|
||||
- rest = piecesFromString $ drop 1 z
|
||||
-
|
||||
-parseType :: String -> Type
|
||||
-parseType = ConT . mkName -- FIXME handle more complicated stuff
|
||||
-
|
||||
-pieceFromString :: String -> Either String (CheckOverlap, Piece String)
|
||||
-pieceFromString ('#':'!':x) = Right $ (False, Dynamic x)
|
||||
-pieceFromString ('#':x) = Right $ (True, Dynamic x)
|
||||
-pieceFromString ('*':x) = Left x
|
||||
-pieceFromString ('!':x) = Right $ (False, Static x)
|
||||
-pieceFromString x = Right $ (True, Static x)
|
||||
diff --git a/Yesod/Routes/TH.hs b/Yesod/Routes/TH.hs
|
||||
deleted file mode 100644
|
||||
index 41045b3..0000000
|
||||
--- a/Yesod/Routes/TH.hs
|
||||
+++ /dev/null
|
||||
@@ -1,12 +0,0 @@
|
||||
-{-# LANGUAGE TemplateHaskell #-}
|
||||
-module Yesod.Routes.TH
|
||||
- ( module Yesod.Routes.TH.Types
|
||||
- -- * Functions
|
||||
- , module Yesod.Routes.TH.RenderRoute
|
||||
- -- ** Dispatch
|
||||
- , module Yesod.Routes.TH.Dispatch
|
||||
- ) where
|
||||
-
|
||||
-import Yesod.Routes.TH.Types
|
||||
-import Yesod.Routes.TH.RenderRoute
|
||||
-import Yesod.Routes.TH.Dispatch
|
||||
diff --git a/Yesod/Routes/TH/Dispatch.hs b/Yesod/Routes/TH/Dispatch.hs
|
||||
deleted file mode 100644
|
||||
index a52f69a..0000000
|
||||
--- a/Yesod/Routes/TH/Dispatch.hs
|
||||
+++ /dev/null
|
||||
@@ -1,344 +0,0 @@
|
||||
-{-# LANGUAGE TemplateHaskell #-}
|
||||
-module Yesod.Routes.TH.Dispatch
|
||||
- ( -- ** Dispatch
|
||||
- mkDispatchClause
|
||||
- ) where
|
||||
-
|
||||
-import Prelude hiding (exp)
|
||||
-import Yesod.Routes.TH.Types
|
||||
-import Language.Haskell.TH.Syntax
|
||||
-import Data.Maybe (catMaybes)
|
||||
-import Control.Monad (forM, replicateM)
|
||||
-import Data.Text (pack)
|
||||
-import qualified Yesod.Routes.Dispatch as D
|
||||
-import qualified Data.Map as Map
|
||||
-import Data.Char (toLower)
|
||||
-import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
|
||||
-import Control.Applicative ((<$>))
|
||||
-import Data.List (foldl')
|
||||
-
|
||||
-data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a)
|
||||
-
|
||||
-flatten :: [ResourceTree a] -> [FlatResource a]
|
||||
-flatten =
|
||||
- concatMap (go id)
|
||||
- where
|
||||
- go front (ResourceLeaf (Resource a b c)) = [FlatResource (front []) a b c]
|
||||
- go front (ResourceParent name pieces children) =
|
||||
- concatMap (go (front . ((name, pieces):))) children
|
||||
-
|
||||
--- |
|
||||
---
|
||||
--- This function will generate a single clause that will address all
|
||||
--- your routing needs. It takes four arguments. The fourth (a list of
|
||||
--- 'Resource's) is self-explanatory. We\'ll discuss the first
|
||||
--- three. But first, let\'s cover the terminology.
|
||||
---
|
||||
--- Dispatching involves a master type and a sub type. When you dispatch to the
|
||||
--- top level type, master and sub are the same. Each time to dispatch to
|
||||
--- another subsite, the sub changes. This requires two changes:
|
||||
---
|
||||
--- * Getting the new sub value. This is handled via 'subsiteFunc'.
|
||||
---
|
||||
--- * Figure out a way to convert sub routes to the original master route. To
|
||||
--- address this, we keep a toMaster function, and each time we dispatch to a
|
||||
--- new subsite, we compose it with the constructor for that subsite.
|
||||
---
|
||||
--- Dispatching acts on two different components: the request method and a list
|
||||
--- of path pieces. If we cannot match the path pieces, we need to return a 404
|
||||
--- response. If the path pieces match, but the method is not supported, we need
|
||||
--- to return a 405 response.
|
||||
---
|
||||
--- The final result of dispatch is going to be an application type. A simple
|
||||
--- example would be the WAI Application type. However, our handler functions
|
||||
--- will need more input: the master/subsite, the toMaster function, and the
|
||||
--- type-safe route. Therefore, we need to have another type, the handler type,
|
||||
--- and a function that turns a handler into an application, i.e.
|
||||
---
|
||||
--- > runHandler :: handler sub master -> master -> sub -> Route sub -> (Route sub -> Route master) -> app
|
||||
---
|
||||
--- This is the first argument to our function. Note that this will almost
|
||||
--- certainly need to be a method of a typeclass, since it will want to behave
|
||||
--- differently based on the subsite.
|
||||
---
|
||||
--- Note that the 404 response passed in is an application, while the 405
|
||||
--- response is a handler, since the former can\'t be passed the type-safe
|
||||
--- route.
|
||||
---
|
||||
--- In the case of a subsite, we don\'t directly deal with a handler function.
|
||||
--- Instead, we redispatch to the subsite, passing on the updated sub value and
|
||||
--- toMaster function, as well as any remaining, unparsed path pieces. This
|
||||
--- function looks like:
|
||||
---
|
||||
--- > dispatcher :: master -> sub -> (Route sub -> Route master) -> app -> handler sub master -> Text -> [Text] -> app
|
||||
---
|
||||
--- Where the parameters mean master, sub, toMaster, 404 response, 405 response,
|
||||
--- request method and path pieces. This is the second argument of our function.
|
||||
---
|
||||
--- Finally, we need a way to decide which of the possible formats
|
||||
--- should the handler send the data out. Think of each URL holding an
|
||||
--- abstract object which has multiple representation (JSON, plain HTML
|
||||
--- etc). Each client might have a preference on which format it wants
|
||||
--- the abstract object in. For example, a javascript making a request
|
||||
--- (on behalf of a browser) might prefer a JSON object over a plain
|
||||
--- HTML file where as a user browsing with javascript disabled would
|
||||
--- want the page in HTML. The third argument is a function that
|
||||
--- converts the abstract object to the desired representation
|
||||
--- depending on the preferences sent by the client.
|
||||
---
|
||||
--- The typical values for the first three arguments are,
|
||||
--- @'yesodRunner'@ for the first, @'yesodDispatch'@ for the second and
|
||||
--- @fmap 'chooseRep'@.
|
||||
-
|
||||
-mkDispatchClause :: Q Exp -- ^ runHandler function
|
||||
- -> Q Exp -- ^ dispatcher function
|
||||
- -> Q Exp -- ^ fixHandler function
|
||||
- -> [ResourceTree a]
|
||||
- -> Q Clause
|
||||
-mkDispatchClause runHandler dispatcher fixHandler ress' = do
|
||||
- -- Allocate the names to be used. Start off with the names passed to the
|
||||
- -- function itself (with a 0 suffix).
|
||||
- --
|
||||
- -- We don't reuse names so as to avoid shadowing names (triggers warnings
|
||||
- -- with -Wall). Additionally, we want to ensure that none of the code
|
||||
- -- passed to toDispatch uses variables from the closure to prevent the
|
||||
- -- dispatch data structure from being rebuilt on each run.
|
||||
- master0 <- newName "master0"
|
||||
- sub0 <- newName "sub0"
|
||||
- toMaster0 <- newName "toMaster0"
|
||||
- app4040 <- newName "app4040"
|
||||
- handler4050 <- newName "handler4050"
|
||||
- method0 <- newName "method0"
|
||||
- pieces0 <- newName "pieces0"
|
||||
-
|
||||
- -- Name of the dispatch function
|
||||
- dispatch <- newName "dispatch"
|
||||
-
|
||||
- -- Dispatch function applied to the pieces
|
||||
- let dispatched = VarE dispatch `AppE` VarE pieces0
|
||||
-
|
||||
- -- The 'D.Route's used in the dispatch function
|
||||
- routes <- mapM (buildRoute runHandler dispatcher fixHandler) ress
|
||||
-
|
||||
- -- The dispatch function itself
|
||||
- toDispatch <- [|D.toDispatch|]
|
||||
- let dispatchFun = FunD dispatch [Clause [] (NormalB $ toDispatch `AppE` ListE routes) []]
|
||||
-
|
||||
- -- The input to the clause.
|
||||
- let pats = map VarP [master0, sub0, toMaster0, app4040, handler4050, method0, pieces0]
|
||||
-
|
||||
- -- For each resource that dispatches based on methods, build up a map for handling the dispatching.
|
||||
- methodMaps <- catMaybes <$> mapM (buildMethodMap fixHandler) ress
|
||||
-
|
||||
- u <- [|case $(return dispatched) of
|
||||
- Just f -> f $(return $ VarE master0)
|
||||
- $(return $ VarE sub0)
|
||||
- $(return $ VarE toMaster0)
|
||||
- $(return $ VarE app4040)
|
||||
- $(return $ VarE handler4050)
|
||||
- $(return $ VarE method0)
|
||||
- Nothing -> $(return $ VarE app4040)
|
||||
- |]
|
||||
- return $ Clause pats (NormalB u) $ dispatchFun : methodMaps
|
||||
- where
|
||||
- ress = flatten ress'
|
||||
-
|
||||
--- | Determine the name of the method map for a given resource name.
|
||||
-methodMapName :: String -> Name
|
||||
-methodMapName s = mkName $ "methods" ++ s
|
||||
-
|
||||
-buildMethodMap :: Q Exp -- ^ fixHandler
|
||||
- -> FlatResource a
|
||||
- -> Q (Maybe Dec)
|
||||
-buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function
|
||||
-buildMethodMap fixHandler (FlatResource parents name pieces' (Methods mmulti methods)) = do
|
||||
- fromList <- [|Map.fromList|]
|
||||
- methods' <- mapM go methods
|
||||
- let exp = fromList `AppE` ListE methods'
|
||||
- let fun = FunD (methodMapName name) [Clause [] (NormalB exp) []]
|
||||
- return $ Just fun
|
||||
- where
|
||||
- pieces = concat $ map snd parents ++ [pieces']
|
||||
- go method = do
|
||||
- fh <- fixHandler
|
||||
- let func = VarE $ mkName $ map toLower method ++ name
|
||||
- pack' <- [|pack|]
|
||||
- let isDynamic Dynamic{} = True
|
||||
- isDynamic _ = False
|
||||
- let argCount = length (filter (isDynamic . snd) pieces) + maybe 0 (const 1) mmulti
|
||||
- xs <- replicateM argCount $ newName "arg"
|
||||
- let rhs = LamE (map VarP xs) $ fh `AppE` (foldl' AppE func $ map VarE xs)
|
||||
- return $ TupE [pack' `AppE` LitE (StringL method), rhs]
|
||||
-buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing
|
||||
-
|
||||
--- | Build a single 'D.Route' expression.
|
||||
-buildRoute :: Q Exp -> Q Exp -> Q Exp -> FlatResource a -> Q Exp
|
||||
-buildRoute runHandler dispatcher fixHandler (FlatResource parents name resPieces resDisp) = do
|
||||
- -- First two arguments to D.Route
|
||||
- routePieces <- ListE <$> mapM (convertPiece . snd) allPieces
|
||||
- isMulti <-
|
||||
- case resDisp of
|
||||
- Methods Nothing _ -> [|False|]
|
||||
- _ -> [|True|]
|
||||
-
|
||||
- [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler parents name (map snd allPieces) resDisp)|]
|
||||
- where
|
||||
- allPieces = concat $ map snd parents ++ [resPieces]
|
||||
-
|
||||
-routeArg3 :: Q Exp -- ^ runHandler
|
||||
- -> Q Exp -- ^ dispatcher
|
||||
- -> Q Exp -- ^ fixHandler
|
||||
- -> [(String, [(CheckOverlap, Piece a)])]
|
||||
- -> String -- ^ name of resource
|
||||
- -> [Piece a]
|
||||
- -> Dispatch a
|
||||
- -> Q Exp
|
||||
-routeArg3 runHandler dispatcher fixHandler parents name resPieces resDisp = do
|
||||
- pieces <- newName "pieces"
|
||||
-
|
||||
- -- Allocate input piece variables (xs) and variables that have been
|
||||
- -- converted via fromPathPiece (ys)
|
||||
- xs <- forM resPieces $ \piece ->
|
||||
- case piece of
|
||||
- Static _ -> return Nothing
|
||||
- Dynamic _ -> Just <$> newName "x"
|
||||
-
|
||||
- -- Note: the zipping with Ints is just a workaround for (apparently) a bug
|
||||
- -- in GHC where the identifiers are considered to be overlapping. Using
|
||||
- -- newName should avoid the problem, but it doesn't.
|
||||
- ys <- forM (zip (catMaybes xs) [1..]) $ \(x, i) -> do
|
||||
- y <- newName $ "y" ++ show (i :: Int)
|
||||
- return (x, y)
|
||||
-
|
||||
- -- In case we have multi pieces at the end
|
||||
- xrest <- newName "xrest"
|
||||
- yrest <- newName "yrest"
|
||||
-
|
||||
- -- Determine the pattern for matching the pieces
|
||||
- pat <-
|
||||
- case resDisp of
|
||||
- Methods Nothing _ -> return $ ListP $ map (maybe WildP VarP) xs
|
||||
- _ -> do
|
||||
- let cons = mkName ":"
|
||||
- return $ foldr (\a b -> ConP cons [maybe WildP VarP a, b]) (VarP xrest) xs
|
||||
-
|
||||
- -- Convert the xs
|
||||
- fromPathPiece' <- [|fromPathPiece|]
|
||||
- xstmts <- forM ys $ \(x, y) -> return $ BindS (VarP y) (fromPathPiece' `AppE` VarE x)
|
||||
-
|
||||
- -- Convert the xrest if appropriate
|
||||
- (reststmts, yrest') <-
|
||||
- case resDisp of
|
||||
- Methods (Just _) _ -> do
|
||||
- fromPathMultiPiece' <- [|fromPathMultiPiece|]
|
||||
- return ([BindS (VarP yrest) (fromPathMultiPiece' `AppE` VarE xrest)], [yrest])
|
||||
- _ -> return ([], [])
|
||||
-
|
||||
- -- The final expression that actually uses the values we've computed
|
||||
- caller <- buildCaller runHandler dispatcher fixHandler xrest parents name resDisp $ map snd ys ++ yrest'
|
||||
-
|
||||
- -- Put together all the statements
|
||||
- just <- [|Just|]
|
||||
- let stmts = concat
|
||||
- [ xstmts
|
||||
- , reststmts
|
||||
- , [NoBindS $ just `AppE` caller]
|
||||
- ]
|
||||
-
|
||||
- errorMsg <- [|error "Invariant violated"|]
|
||||
- let matches =
|
||||
- [ Match pat (NormalB $ DoE stmts) []
|
||||
- , Match WildP (NormalB errorMsg) []
|
||||
- ]
|
||||
-
|
||||
- return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches
|
||||
-
|
||||
--- | The final expression in the individual Route definitions.
|
||||
-buildCaller :: Q Exp -- ^ runHandler
|
||||
- -> Q Exp -- ^ dispatcher
|
||||
- -> Q Exp -- ^ fixHandler
|
||||
- -> Name -- ^ xrest
|
||||
- -> [(String, [(CheckOverlap, Piece a)])]
|
||||
- -> String -- ^ name of resource
|
||||
- -> Dispatch a
|
||||
- -> [Name] -- ^ ys
|
||||
- -> Q Exp
|
||||
-buildCaller runHandler dispatcher fixHandler xrest parents name resDisp ys = do
|
||||
- master <- newName "master"
|
||||
- sub <- newName "sub"
|
||||
- toMaster <- newName "toMaster"
|
||||
- app404 <- newName "_app404"
|
||||
- handler405 <- newName "_handler405"
|
||||
- method <- newName "_method"
|
||||
-
|
||||
- let pat = map VarP [master, sub, toMaster, app404, handler405, method]
|
||||
-
|
||||
- -- Create the route
|
||||
- let route = routeFromDynamics parents name ys
|
||||
-
|
||||
- exp <-
|
||||
- case resDisp of
|
||||
- Methods _ ms -> do
|
||||
- handler <- newName "handler"
|
||||
-
|
||||
- -- Run the whole thing
|
||||
- runner <- [|$(runHandler)
|
||||
- $(return $ VarE handler)
|
||||
- $(return $ VarE master)
|
||||
- $(return $ VarE sub)
|
||||
- (Just $(return route))
|
||||
- $(return $ VarE toMaster)|]
|
||||
-
|
||||
- let myLet handlerExp =
|
||||
- LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner
|
||||
-
|
||||
- if null ms
|
||||
- then do
|
||||
- -- Just a single handler
|
||||
- fh <- fixHandler
|
||||
- let he = fh `AppE` foldl' (\a b -> a `AppE` VarE b) (VarE $ mkName $ "handle" ++ name) ys
|
||||
- return $ myLet he
|
||||
- else do
|
||||
- -- Individual methods
|
||||
- mf <- [|Map.lookup $(return $ VarE method) $(return $ VarE $ methodMapName name)|]
|
||||
- f <- newName "f"
|
||||
- let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys
|
||||
- let body405 =
|
||||
- VarE handler405
|
||||
- `AppE` route
|
||||
- return $ CaseE mf
|
||||
- [ Match (ConP 'Just [VarP f]) (NormalB $ myLet apply) []
|
||||
- , Match (ConP 'Nothing []) (NormalB body405) []
|
||||
- ]
|
||||
-
|
||||
- Subsite _ getSub -> do
|
||||
- let sub2 = foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys
|
||||
- [|$(dispatcher)
|
||||
- $(return $ VarE master)
|
||||
- $(return sub2)
|
||||
- ($(return $ VarE toMaster) . $(return route))
|
||||
- $(return $ VarE app404)
|
||||
- ($(return $ VarE handler405) . $(return route))
|
||||
- $(return $ VarE method)
|
||||
- $(return $ VarE xrest)
|
||||
- |]
|
||||
-
|
||||
- return $ LamE pat exp
|
||||
-
|
||||
--- | Convert a 'Piece' to a 'D.Piece'
|
||||
-convertPiece :: Piece a -> Q Exp
|
||||
-convertPiece (Static s) = [|D.Static (pack $(lift s))|]
|
||||
-convertPiece (Dynamic _) = [|D.Dynamic|]
|
||||
-
|
||||
-routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])] -- ^ parents
|
||||
- -> String -- ^ constructor name
|
||||
- -> [Name]
|
||||
- -> Exp
|
||||
-routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys
|
||||
-routeFromDynamics ((parent, pieces):rest) name ys =
|
||||
- foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here
|
||||
- where
|
||||
- (here', ys') = splitAt (length $ filter (isDynamic . snd) pieces) ys
|
||||
- isDynamic Dynamic{} = True
|
||||
- isDynamic _ = False
|
||||
- here = map VarE here' ++ [routeFromDynamics rest name ys']
|
||||
diff --git a/Yesod/Routes/TH/Types.hs b/Yesod/Routes/TH/Types.hs
|
||||
deleted file mode 100644
|
||||
index 52cd446..0000000
|
||||
--- a/Yesod/Routes/TH/Types.hs
|
||||
+++ /dev/null
|
||||
@@ -1,84 +0,0 @@
|
||||
-{-# LANGUAGE TemplateHaskell #-}
|
||||
-module Yesod.Routes.TH.Types
|
||||
- ( -- * Data types
|
||||
- Resource (..)
|
||||
- , ResourceTree (..)
|
||||
- , Piece (..)
|
||||
- , Dispatch (..)
|
||||
- , CheckOverlap
|
||||
- -- ** Helper functions
|
||||
- , resourceMulti
|
||||
- , resourceTreePieces
|
||||
- , resourceTreeName
|
||||
- ) where
|
||||
-
|
||||
-import Language.Haskell.TH.Syntax
|
||||
-import Control.Arrow (second)
|
||||
-
|
||||
-data ResourceTree typ = ResourceLeaf (Resource typ) | ResourceParent String [(CheckOverlap, Piece typ)] [ResourceTree typ]
|
||||
-
|
||||
-resourceTreePieces :: ResourceTree typ -> [(CheckOverlap, Piece typ)]
|
||||
-resourceTreePieces (ResourceLeaf r) = resourcePieces r
|
||||
-resourceTreePieces (ResourceParent _ x _) = x
|
||||
-
|
||||
-resourceTreeName :: ResourceTree typ -> String
|
||||
-resourceTreeName (ResourceLeaf r) = resourceName r
|
||||
-resourceTreeName (ResourceParent x _ _) = x
|
||||
-
|
||||
-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)]
|
||||
- , resourceDispatch :: Dispatch typ
|
||||
- }
|
||||
- deriving Show
|
||||
-
|
||||
-type CheckOverlap = Bool
|
||||
-
|
||||
-instance Functor Resource where
|
||||
- fmap f (Resource a b c) = Resource a (map (second $ fmap f) b) (fmap f c)
|
||||
-
|
||||
-instance Lift t => Lift (Resource t) where
|
||||
- lift (Resource a b c) = [|Resource $(lift a) $(lift b) $(lift c)|]
|
||||
-
|
||||
-data Piece typ = Static String | Dynamic typ
|
||||
- deriving Show
|
||||
-
|
||||
-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
|
||||
- , methodsMethods :: [String] -- ^ supported request methods
|
||||
- }
|
||||
- | Subsite
|
||||
- { subsiteType :: typ
|
||||
- , subsiteFunc :: String
|
||||
- }
|
||||
- deriving Show
|
||||
-
|
||||
-instance Functor Dispatch where
|
||||
- fmap f (Methods a b) = Methods (fmap f a) b
|
||||
- fmap f (Subsite a b) = Subsite (f a) b
|
||||
-
|
||||
-instance Lift t => Lift (Dispatch t) where
|
||||
- lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]
|
||||
- lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|]
|
||||
- lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|]
|
||||
-
|
||||
-resourceMulti :: Resource typ -> Maybe typ
|
||||
-resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
|
||||
-resourceMulti _ = Nothing
|
||||
diff --git a/yesod-routes.cabal b/yesod-routes.cabal
|
||||
index eb367b3..0984dfe 100644
|
||||
--- a/yesod-routes.cabal
|
||||
+++ b/yesod-routes.cabal
|
||||
@@ -23,29 +23,7 @@ library
|
||||
, path-pieces >= 0.1 && < 0.2
|
||||
|
||||
exposed-modules: Yesod.Routes.Dispatch
|
||||
- Yesod.Routes.TH
|
||||
Yesod.Routes.Class
|
||||
- Yesod.Routes.Parse
|
||||
- Yesod.Routes.Overlap
|
||||
- other-modules: Yesod.Routes.TH.Dispatch
|
||||
- Yesod.Routes.TH.RenderRoute
|
||||
- Yesod.Routes.TH.Types
|
||||
- ghc-options: -Wall
|
||||
-
|
||||
-test-suite runtests
|
||||
- type: exitcode-stdio-1.0
|
||||
- main-is: main.hs
|
||||
- hs-source-dirs: test
|
||||
- other-modules: Hierarchy
|
||||
-
|
||||
- build-depends: base >= 4.3 && < 5
|
||||
- , yesod-routes
|
||||
- , text >= 0.5 && < 0.12
|
||||
- , HUnit >= 1.2 && < 1.3
|
||||
- , hspec >= 1.3
|
||||
- , containers
|
||||
- , template-haskell
|
||||
- , path-pieces
|
||||
ghc-options: -Wall
|
||||
|
||||
source-repository head
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
From 63d07ae4a1e3b77cbe023364599f7c2c3e853d5f Mon Sep 17 00:00:00 2001
|
||||
From: Joey Hess <joey@kitenet.net>
|
||||
Date: Thu, 28 Feb 2013 23:40:57 -0400
|
||||
Subject: [PATCH] hack to build on Android
|
||||
|
||||
---
|
||||
Codec/Compression/Zlib/Stream.hsc | 4 ++--
|
||||
zlib.cabal | 2 +-
|
||||
2 files changed, 3 insertions(+), 3 deletions(-)
|
||||
|
||||
diff --git a/Codec/Compression/Zlib/Stream.hsc b/Codec/Compression/Zlib/Stream.hsc
|
||||
index fe851e6..c6168f4 100644
|
||||
--- a/Codec/Compression/Zlib/Stream.hsc
|
||||
+++ b/Codec/Compression/Zlib/Stream.hsc
|
||||
@@ -921,7 +921,7 @@ foreign import ccall unsafe "zlib.h inflateInit2_"
|
||||
|
||||
c_inflateInit2 :: StreamState -> CInt -> IO CInt
|
||||
c_inflateInit2 z n =
|
||||
- withCAString #{const_str ZLIB_VERSION} $ \versionStr ->
|
||||
+ withCAString "1.2.5" $ \versionStr ->
|
||||
c_inflateInit2_ z n versionStr (#{const sizeof(z_stream)} :: CInt)
|
||||
|
||||
foreign import ccall unsafe "zlib.h inflate"
|
||||
@@ -940,7 +940,7 @@ foreign import ccall unsafe "zlib.h deflateInit2_"
|
||||
c_deflateInit2 :: StreamState
|
||||
-> CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt
|
||||
c_deflateInit2 z a b c d e =
|
||||
- withCAString #{const_str ZLIB_VERSION} $ \versionStr ->
|
||||
+ withCAString "1.2.5" $ \versionStr ->
|
||||
c_deflateInit2_ z a b c d e versionStr (#{const sizeof(z_stream)} :: CInt)
|
||||
|
||||
foreign import ccall unsafe "zlib.h deflateSetDictionary"
|
||||
diff --git a/zlib.cabal b/zlib.cabal
|
||||
index f2d1f5d..751bfab 100644
|
||||
--- a/zlib.cabal
|
||||
+++ b/zlib.cabal
|
||||
@@ -36,7 +36,7 @@ library
|
||||
other-modules: Codec.Compression.Zlib.Stream
|
||||
extensions: CPP, ForeignFunctionInterface
|
||||
build-depends: base >= 3 && < 5,
|
||||
- bytestring >= 0.9 && < 0.12
|
||||
+ bytestring >= 0.10.3.0
|
||||
includes: zlib.h
|
||||
ghc-options: -Wall
|
||||
if !os(windows)
|
||||
--
|
||||
1.7.10.4
|
||||
|
||||
Loading…
Reference in a new issue