#{path'} |] defaultErrorHandler (PermissionDenied msg) = applyLayout' "Permission Denied" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + [HAMLET|
#{msg} |] defaultErrorHandler (InvalidArgs ia) = applyLayout' "Invalid Arguments" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + [HAMLET|
#{e} |] defaultErrorHandler (BadMethod m) = applyLayout' "Bad Method" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + [HAMLET|
Method "#{S8.unpack m}" not supported
|]
@@ -486,7 +477,7 @@
let scripts = runUniqueList scripts'
let stylesheets = runUniqueList stylesheets'
let jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b
- jelper :: Julius url -> Hamlet url
+ jelper :: JavascriptUrl url -> HtmlUrl url
jelper = fmap jsToHtml
render <- getUrlRenderParams
@@ -496,7 +487,7 @@
Just (Left s) -> Just s
Just (Right (u, p)) -> Just $ render u p
css <- forM (Map.toList style) $ \(mmedia, content) -> do
- let rendered = renderCassius render content
+ let rendered = renderCssUrl render content
x <- addStaticContent "css" "text/css; charset=utf-8"
$ encodeUtf8 rendered
return (mmedia,
@@ -508,7 +499,7 @@
Nothing -> return Nothing
Just s -> do
x <- addStaticContent "js" "text/javascript; charset=utf-8"
- $ encodeUtf8 $ renderJulius render s
+ $ encodeUtf8 $ renderJavascriptUrl render s
return $ renderLoc x
let addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z)
@@ -526,12 +517,7 @@
left _ = Nothing
right (Right x) = Just x
right _ = Nothing
- let head'' =
-#if GHC7
- [hamlet|
-#else
- [$hamlet|
-#endif
+ let head'' = [HAMLET|
$forall s <- stylesheets
^{mkLinkTag s}
$forall s <- css
diff --git a/Yesod/Internal/Dispatch.hs b/Yesod/Internal/Dispatch.hs
--- a/Yesod/Internal/Dispatch.hs
+++ b/Yesod/Internal/Dispatch.hs
@@ -7,9 +7,8 @@
import Prelude hiding (exp)
import Language.Haskell.TH.Syntax
-import Web.Routes.Quasi
-import Web.Routes.Quasi.Parse
-import Web.Routes.Quasi.TH
+import Web.PathPieces
+import Yesod.Internal.RouteParsing
import Control.Monad (foldM)
import Yesod.Handler (badMethod)
import Yesod.Content (chooseRep)
diff --git a/Yesod/Internal/RouteParsing.hs b/Yesod/Internal/RouteParsing.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Internal/RouteParsing.hs
@@ -0,0 +1,348 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
+module Yesod.Internal.RouteParsing
+ ( createRoutes
+ , createRender
+ , createParse
+ , createDispatch
+ , Pieces (..)
+ , THResource
+ , parseRoutes
+ , parseRoutesFile
+ , parseRoutesNoCheck
+ , parseRoutesFileNoCheck
+ , Resource (..)
+ , Piece (..)
+ ) where
+
+import Web.PathPieces
+import Language.Haskell.TH.Syntax
+import Data.Maybe
+import Data.Either
+import Data.List
+import Data.Char (toLower)
+import qualified Data.Text
+import Language.Haskell.TH.Quote
+import Data.Data
+import qualified System.IO as SIO
+
+data Pieces =
+ SubSite
+ { ssType :: Type
+ , ssParse :: Exp
+ , ssRender :: Exp
+ , ssDispatch :: Exp
+ , ssToMasterArg :: Exp
+ , ssPieces :: [Piece]
+ }
+ | Simple [Piece] [String] -- ^ methods
+ deriving Show
+type THResource = (String, Pieces)
+
+createRoutes :: [THResource] -> Q [Con]
+createRoutes res =
+ return $ map go res
+ where
+ go (n, SubSite{ssType = s, ssPieces = pieces}) =
+ NormalC (mkName n) $ mapMaybe go' pieces ++ [(NotStrict, s)]
+ go (n, Simple pieces _) = NormalC (mkName n) $ mapMaybe go' pieces
+ go' (SinglePiece x) = Just (NotStrict, ConT $ mkName x)
+ go' (MultiPiece x) = Just (NotStrict, ConT $ mkName x)
+ go' (StaticPiece _) = Nothing
+
+-- | Generates the set of clauses necesary to parse the given 'Resource's. See 'quasiParse'.
+createParse :: [THResource] -> Q [Clause]
+createParse res = do
+ final' <- final
+ clauses <- mapM go res
+ return $ if areResourcesComplete res
+ then clauses
+ else clauses ++ [final']
+ where
+ cons x y = ConP (mkName ":") [x, y]
+ go (constr, SubSite{ssParse = p, ssPieces = ps}) = do
+ ri <- [|Right|]
+ be <- [|ape|]
+ (pat', parse) <- mkPat' be ps $ ri `AppE` ConE (mkName constr)
+
+ x <- newName "x"
+ let pat = init pat' ++ [VarP x]
+
+ --let pat = foldr (\a b -> cons [LitP (StringL a), b]) (VarP x) pieces
+ let eitherSub = p `AppE` VarE x
+ let bod = be `AppE` parse `AppE` eitherSub
+ --let bod = fmape' `AppE` ConE (mkName constr) `AppE` eitherSub
+ return $ Clause [foldr1 cons pat] (NormalB bod) []
+ go (n, Simple ps _) = do
+ ri <- [|Right|]
+ be <- [|ape|]
+ (pat, parse) <- mkPat' be ps $ ri `AppE` ConE (mkName n)
+ return $ Clause [foldr1 cons pat] (NormalB parse) []
+ final = do
+ no <- [|Left "Invalid URL"|]
+ return $ Clause [WildP] (NormalB no) []
+ mkPat' :: Exp -> [Piece] -> Exp -> Q ([Pat], Exp)
+ mkPat' be [MultiPiece s] parse = do
+ v <- newName $ "var" ++ s
+ fmp <- [|fromMultiPiece|]
+ let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v
+ return ([VarP v], parse')
+ mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last"
+ mkPat' be (StaticPiece s:rest) parse = do
+ (x, parse') <- mkPat' be rest parse
+ let sp = LitP $ StringL s
+ return (sp : x, parse')
+ mkPat' be (SinglePiece s:rest) parse = do
+ fsp <- [|fromSinglePiece|]
+ v <- newName $ "var" ++ s
+ let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v
+ (x, parse'') <- mkPat' be rest parse'
+ return (VarP v : x, parse'')
+ mkPat' _ [] parse = return ([ListP []], parse)
+
+-- | 'ap' for 'Either'
+ape :: Either String (a -> b) -> Either String a -> Either String b
+ape (Left e) _ = Left e
+ape (Right _) (Left e) = Left e
+ape (Right f) (Right a) = Right $ f a
+
+-- | Generates the set of clauses necesary to render the given 'Resource's. See
+-- 'quasiRender'.
+createRender :: [THResource] -> Q [Clause]
+createRender = mapM go
+ where
+ go (n, Simple ps _) = do
+ let ps' = zip [1..] ps
+ let pat = ConP (mkName n) $ mapMaybe go' ps'
+ bod <- mkBod ps'
+ return $ Clause [pat] (NormalB $ TupE [bod, ListE []]) []
+ go (n, SubSite{ssRender = r, ssPieces = pieces}) = do
+ cons' <- [|\a (b, c) -> (a ++ b, c)|]
+ let cons a b = cons' `AppE` a `AppE` b
+ x <- newName "x"
+ let r' = r `AppE` VarE x
+ let pieces' = zip [1..] pieces
+ let pat = ConP (mkName n) $ mapMaybe go' pieces' ++ [VarP x]
+ bod <- mkBod pieces'
+ return $ Clause [pat] (NormalB $ cons bod r') []
+ go' (_, StaticPiece _) = Nothing
+ go' (i, _) = Just $ VarP $ mkName $ "var" ++ show (i :: Int)
+ mkBod :: (Show t) => [(t, Piece)] -> Q Exp
+ mkBod [] = lift ([] :: [String])
+ mkBod ((_, StaticPiece x):xs) = do
+ x' <- lift x
+ pack <- [|Data.Text.pack|]
+ xs' <- mkBod xs
+ return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs'
+ mkBod ((i, SinglePiece _):xs) = do
+ let x' = VarE $ mkName $ "var" ++ show i
+ tsp <- [|toSinglePiece|]
+ let x'' = tsp `AppE` x'
+ xs' <- mkBod xs
+ return $ ConE (mkName ":") `AppE` x'' `AppE` xs'
+ mkBod ((i, MultiPiece _):_) = do
+ let x' = VarE $ mkName $ "var" ++ show i
+ tmp <- [|toMultiPiece|]
+ return $ tmp `AppE` x'
+
+-- | Whether the set of resources cover all possible URLs.
+areResourcesComplete :: [THResource] -> Bool
+areResourcesComplete res =
+ let (slurps, noSlurps) = partitionEithers $ mapMaybe go res
+ in case slurps of
+ [] -> False
+ _ -> let minSlurp = minimum slurps
+ in helper minSlurp $ reverse $ sort noSlurps
+ where
+ go :: THResource -> Maybe (Either Int Int)
+ go (_, Simple ps _) =
+ case reverse ps of
+ [] -> Just $ Right 0
+ (MultiPiece _:rest) -> go' Left rest
+ x -> go' Right x
+ go (n, SubSite{ssPieces = ps}) =
+ go (n, Simple (ps ++ [MultiPiece ""]) [])
+ go' b x = if all isSingle x then Just (b $ length x) else Nothing
+ helper 0 _ = True
+ helper _ [] = False
+ helper m (i:is)
+ | i >= m = helper m is
+ | i + 1 == m = helper i is
+ | otherwise = False
+ isSingle (SinglePiece _) = True
+ isSingle _ = False
+
+notStatic :: Piece -> Bool
+notStatic StaticPiece{} = False
+notStatic _ = True
+
+createDispatch :: Exp -- ^ modify a master handler
+ -> Exp -- ^ convert a subsite handler to a master handler
+ -> [THResource]
+ -> Q [Clause]
+createDispatch modMaster toMaster = mapM go
+ where
+ go :: (String, Pieces) -> Q Clause
+ go (n, Simple ps methods) = do
+ meth <- newName "method"
+ xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"
+ let pat = [ ConP (mkName n) $ map VarP xs
+ , if null methods then WildP else VarP meth
+ ]
+ bod <- go' n meth xs methods
+ return $ Clause pat (NormalB bod) []
+ go (n, SubSite{ssDispatch = d, ssToMasterArg = tma, ssPieces = ps}) = do
+ meth <- newName "method"
+ x <- newName "x"
+ xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"
+ let pat = [ConP (mkName n) $ map VarP xs ++ [VarP x], VarP meth]
+ let bod = d `AppE` VarE x `AppE` VarE meth
+ fmap' <- [|fmap|]
+ let routeToMaster = foldl AppE (ConE (mkName n)) $ map VarE xs
+ tma' = foldl AppE tma $ map VarE xs
+ let toMaster' = toMaster `AppE` routeToMaster `AppE` tma' `AppE` VarE x
+ let bod' = InfixE (Just toMaster') fmap' (Just bod)
+ let bod'' = InfixE (Just modMaster) fmap' (Just bod')
+ return $ Clause pat (NormalB bod'') []
+ go' n _ xs [] = do
+ jus <- [|Just|]
+ let bod = foldl AppE (VarE $ mkName $ "handle" ++ n) $ map VarE xs
+ return $ jus `AppE` (modMaster `AppE` bod)
+ go' n meth xs methods = do
+ noth <- [|Nothing|]
+ j <- [|Just|]
+ let noMatch = Match WildP (NormalB noth) []
+ return $ CaseE (VarE meth) $ map (go'' n xs j) methods ++ [noMatch]
+ go'' n xs j method =
+ let pat = LitP $ StringL method
+ func = map toLower method ++ n
+ bod = foldl AppE (VarE $ mkName func) $ map VarE xs
+ in Match pat (NormalB $ j `AppE` (modMaster `AppE` bod)) []
+
+-- | 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
+ , quotePat = y
+ }
+ where
+ x s = do
+ let res = resourcesFromString s
+ case findOverlaps res of
+ [] -> lift res
+ z -> error $ "Overlapping routes: " ++ unlines (map show z)
+ y = dataToPatQ (const Nothing) . resourcesFromString
+
+parseRoutesFile :: FilePath -> Q Exp
+parseRoutesFile fp = do
+ s <- qRunIO $ readUtf8File fp
+ quoteExp parseRoutes s
+
+parseRoutesFileNoCheck :: FilePath -> Q Exp
+parseRoutesFileNoCheck fp = do
+ s <- qRunIO $ readUtf8File fp
+ quoteExp parseRoutesNoCheck 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 = x
+ , quotePat = y
+ }
+ where
+ x = lift . resourcesFromString
+ y = dataToPatQ (const Nothing) . resourcesFromString
+
+instance Lift Resource where
+ lift (Resource s ps h) = do
+ r <- [|Resource|]
+ s' <- lift s
+ ps' <- lift ps
+ h' <- lift h
+ return $ r `AppE` s' `AppE` ps' `AppE` h'
+
+-- | A single resource pattern.
+--
+-- First argument is the name of the constructor, second is the URL pattern to
+-- match, third is how to dispatch.
+data Resource = Resource String [Piece] [String]
+ deriving (Read, Show, Eq, Data, Typeable)
+
+-- | A single piece of a URL, delimited by slashes.
+--
+-- In the case of StaticPiece, the argument is the value of the piece; for the
+-- other constructors, it is the name of the parameter represented by this
+-- piece. That value is not used here, but may be useful elsewhere.
+data Piece = StaticPiece String
+ | SinglePiece String
+ | MultiPiece String
+ deriving (Read, Show, Eq, Data, Typeable)
+
+instance Lift Piece where
+ lift (StaticPiece s) = do
+ c <- [|StaticPiece|]
+ s' <- lift s
+ return $ c `AppE` s'
+ lift (SinglePiece s) = do
+ c <- [|SinglePiece|]
+ s' <- lift s
+ return $ c `AppE` s'
+ lift (MultiPiece s) = do
+ c <- [|MultiPiece|]
+ s' <- lift s
+ return $ c `AppE` s'
+
+-- | 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 -> [Resource]
+resourcesFromString =
+ mapMaybe go . lines
+ where
+ go s =
+ case takeWhile (/= "--") $ words s of
+ (pattern:constr:rest) ->
+ let pieces = piecesFromString $ drop1Slash pattern
+ in Just $ Resource constr pieces rest
+ [] -> Nothing
+ _ -> error $ "Invalid resource line: " ++ s
+
+drop1Slash :: String -> String
+drop1Slash ('/':x) = x
+drop1Slash x = x
+
+piecesFromString :: String -> [Piece]
+piecesFromString "" = []
+piecesFromString x =
+ let (y, z) = break (== '/') x
+ in pieceFromString y : piecesFromString (drop1Slash z)
+
+pieceFromString :: String -> Piece
+pieceFromString ('#':x) = SinglePiece x
+pieceFromString ('*':x) = MultiPiece x
+pieceFromString x = StaticPiece x
+
+findOverlaps :: [Resource] -> [(Resource, Resource)]
+findOverlaps = gos . map justPieces
+ where
+ justPieces r@(Resource _ ps _) = (ps, r)
+ gos [] = []
+ gos (x:xs) = mapMaybe (go x) xs ++ gos xs
+ go (StaticPiece x:xs, xr) (StaticPiece y:ys, yr)
+ | x == y = go (xs, xr) (ys, yr)
+ | otherwise = Nothing
+ go (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)
+ go (_, xr) (MultiPiece _:_, yr) = Just (xr, yr)
+ go ([], xr) ([], yr) = Just (xr, yr)
+ go ([], _) (_, _) = Nothing
+ go (_, _) ([], _) = Nothing
+ go (_:xs, xr) (_:ys, yr) = go (xs, xr) (ys, yr)
diff --git a/Yesod/Internal/Session.hs b/Yesod/Internal/Session.hs
--- a/Yesod/Internal/Session.hs
+++ b/Yesod/Internal/Session.hs
@@ -12,12 +12,13 @@
import Control.Arrow ((***))
encodeSession :: CS.Key
+ -> CS.IV
-> UTCTime -- ^ expire time
-> ByteString -- ^ remote host
-> [(Text, Text)] -- ^ session
-> ByteString -- ^ cookie value
-encodeSession key expire rhost session' =
- CS.encrypt key $ encode $ SessionCookie expire rhost session'
+encodeSession key iv expire rhost session' =
+ CS.encrypt key iv $ encode $ SessionCookie expire rhost session'
decodeSession :: CS.Key
-> UTCTime -- ^ current time
diff --git a/Yesod/Logger.hs b/Yesod/Logger.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Logger.hs
@@ -0,0 +1,82 @@
+-- blantantly taken from hakyll
+-- http://hackage.haskell.org/packages/archive/hakyll/3.1.1.0/doc/html/src/Hakyll-Core-Logger.html
+--
+-- | Produce pretty, thread-safe logs
+--
+{-# LANGUAGE BangPatterns #-}
+module Yesod.Logger
+ ( Logger
+ , makeLogger
+ , flushLogger
+ , timed
+ , logText
+ , logLazyText
+ , logString
+ ) where
+
+import Control.Monad (forever)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Applicative ((<$>), (<*>))
+import Control.Concurrent (forkIO)
+import Control.Concurrent.Chan.Strict (Chan, newChan, readChan, writeChan)
+import Control.Concurrent.MVar.Strict (MVar, newEmptyMVar, takeMVar, putMVar)
+import Text.Printf (printf)
+import Data.Text
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.IO
+import Data.Time (getCurrentTime, diffUTCTime)
+
+data Logger = Logger
+ { loggerChan :: Chan (Maybe TL.Text) -- Nothing marks the end
+ , loggerSync :: MVar () -- Used for sync on quit
+ }
+
+makeLogger :: IO Logger
+makeLogger = do
+ logger <- Logger <$> newChan <*> newEmptyMVar
+ _ <- forkIO $ loggerThread logger
+ return logger
+ where
+ loggerThread logger = forever $ do
+ msg <- readChan $ loggerChan logger
+ case msg of
+ -- Stop: sync
+ Nothing -> putMVar (loggerSync logger) ()
+ -- Print and continue
+ Just m -> Data.Text.Lazy.IO.putStrLn m
+
+-- | Flush the logger (blocks until flushed)
+--
+flushLogger :: Logger -> IO ()
+flushLogger logger = do
+ writeChan (loggerChan logger) Nothing
+ () <- takeMVar $ loggerSync logger
+ return ()
+
+-- | Send a raw message to the logger
+-- Native format is lazy text
+logLazyText :: Logger -> TL.Text -> IO ()
+logLazyText logger = writeChan (loggerChan logger) . Just
+
+logText :: Logger -> Text -> IO ()
+logText logger = logLazyText logger . TL.fromStrict
+
+logString :: Logger -> String -> IO ()
+logString logger = logLazyText logger . TL.pack
+
+-- | Execute a monadic action and log the duration
+--
+timed :: MonadIO m
+ => Logger -- ^ Logger
+ -> Text -- ^ Message
+ -> m a -- ^ Action
+ -> m a -- ^ Timed and logged action
+timed logger msg action = do
+ start <- liftIO getCurrentTime
+ !result <- action
+ stop <- liftIO getCurrentTime
+ let diff = fromEnum $ diffUTCTime stop start
+ ms = diff `div` 10 ^ (9 :: Int)
+ formatted = printf " [%4dms] %s" ms (unpack msg)
+ liftIO $ logString logger formatted
+ return result
diff --git a/Yesod/Message.hs b/Yesod/Message.hs
--- a/Yesod/Message.hs
+++ b/Yesod/Message.hs
@@ -2,10 +2,12 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ExistentialQuantification #-}
module Yesod.Message
( mkMessage
, RenderMessage (..)
, ToMessage (..)
+ , SomeMessage (..)
) where
import Language.Haskell.TH.Syntax
@@ -17,10 +19,12 @@
import Data.Text.Encoding (decodeUtf8)
import Data.Char (isSpace, toLower, toUpper)
import Data.Ord (comparing)
-import Text.Shakespeare (Deref (..), Ident (..), parseHash, derefToExp)
+import Text.Shakespeare.Base (Deref (..), Ident (..), parseHash, derefToExp)
import Text.ParserCombinators.Parsec (parse, many, eof, many1, noneOf, (<|>))
import Control.Arrow ((***))
import Data.Monoid (mempty, mappend)
+import qualified Data.Text as T
+import Data.String (IsString (fromString))
class ToMessage a where
toMessage :: a -> Text
@@ -248,3 +252,8 @@
case break (== '@') s of
(x, '@':y) -> (x, Just y)
_ -> (s, Nothing)
+
+data SomeMessage master = forall msg. RenderMessage master msg => SomeMessage msg
+
+instance IsString (SomeMessage master) where
+ fromString = SomeMessage . T.pack
diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs
--- a/Yesod/Widget.hs
+++ b/Yesod/Widget.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier
-- generator, allowing you to create truly modular HTML components.
module Yesod.Widget
@@ -14,6 +15,10 @@
, whamlet
, whamletFile
, ihamletToRepHtml
+ -- * Convert to Widget
+ , ToWidget (..)
+ , ToWidgetHead (..)
+ , ToWidgetBody (..)
-- * Creating
-- ** Head of page
, setTitle
@@ -54,7 +59,6 @@
import qualified Text.Blaze.Html5 as H
import Text.Hamlet
import Text.Cassius
-import Text.Lucius (Lucius)
import Text.Julius
import Text.Coffee
import Yesod.Handler
@@ -74,8 +78,9 @@
import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName)
import Control.Monad.IO.Control (MonadControlIO)
-import qualified Text.Hamlet.NonPoly as NP
+import qualified Text.Hamlet as NP
import Data.Text.Lazy.Builder (fromLazyText)
+import Text.Blaze (toHtml, preEscapedLazyText)
-- | A generic widget, allowing specification of both the subsite and master
-- site datatypes. This is basically a large 'WriterT' stack keeping track of
@@ -93,19 +98,6 @@
mempty = return ()
mappend x y = x >> y
-instance (Monad monad, a ~ ()) => HamletValue (GGWidget m monad a) where
- newtype HamletMonad (GGWidget m monad a) b =
- GWidget' { runGWidget' :: GGWidget m monad b }
- type HamletUrl (GGWidget m monad a) = Route m
- toHamletValue = runGWidget'
- htmlToHamletMonad = GWidget' . addHtml
- urlToHamletMonad url params = GWidget' $
- addHamlet $ \r -> preEscapedText (r url params)
- fromHamletValue = GWidget'
-instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget m monad a)) where
- return = GWidget' . return
- x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y
-
addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a
addSubWidget sub (GWidget w) = do
master <- lift getYesod
@@ -116,6 +108,54 @@
GWidget $ tell w'
return a
+class ToWidget sub master a where
+ toWidget :: a -> GWidget sub master ()
+
+-- FIXME At some point in the future, deprecate all the
+-- addHamlet/Cassius/Lucius/Julius stuff. For the most part, toWidget* will be
+-- sufficient. For somethings, like addLuciusMedia, create addCssUrlMedia.
+
+type RY master = Route master -> [(Text, Text)] -> Text
+
+instance render ~ RY master => ToWidget sub master (render -> Html) where
+ toWidget = addHamlet
+instance render ~ RY master => ToWidget sub master (render -> Css) where
+ toWidget = addCassius
+instance render ~ RY master => ToWidget sub master (render -> Javascript) where
+ toWidget = addJulius
+instance ToWidget sub master (GWidget sub master ()) where
+ toWidget = id
+instance ToWidget sub master Html where
+ toWidget = addHtml
+instance render ~ RY master => ToWidget sub master (render -> Coffeescript) where
+ toWidget = addCoffee
+
+class ToWidgetBody sub master a where
+ toWidgetBody :: a -> GWidget sub master ()
+
+instance render ~ RY master => ToWidgetBody sub master (render -> Html) where
+ toWidgetBody = addHamlet
+instance render ~ RY master => ToWidgetBody sub master (render -> Javascript) where
+ toWidgetBody = addJuliusBody
+instance ToWidgetBody sub master Html where
+ toWidgetBody = addHtml
+instance render ~ RY master => ToWidgetBody sub master (render -> Coffeescript) where
+ toWidgetBody = addCoffeeBody
+
+class ToWidgetHead sub master a where
+ toWidgetHead :: a -> GWidget sub master ()
+
+instance render ~ RY master => ToWidgetHead sub master (render -> Html) where
+ toWidgetHead = addHamletHead
+instance render ~ RY master => ToWidgetHead sub master (render -> Css) where
+ toWidgetHead = addCassius
+instance render ~ RY master => ToWidgetHead sub master (render -> Javascript) where
+ toWidgetHead = addJulius
+instance ToWidgetHead sub master Html where
+ toWidgetHead = addHtmlHead
+instance render ~ RY master => ToWidgetHead sub master (render -> Coffeescript) where
+ toWidgetHead = addCoffee
+
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
-- set values.
setTitle :: Monad m => Html -> GGWidget master m ()
@@ -129,7 +169,7 @@
setTitle $ toHtml $ mr msg
-- | Add a 'Hamlet' to the head tag.
-addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget master m ()
+addHamletHead :: Monad m => HtmlUrl (Route master) -> GGWidget master m ()
addHamletHead = GWidget . tell . GWData mempty mempty mempty mempty mempty mempty . Head
-- | Add a 'Html' to the head tag.
@@ -137,7 +177,7 @@
addHtmlHead = addHamletHead . const
-- | Add a 'Hamlet' to the body tag.
-addHamlet :: Monad m => Hamlet (Route master) -> GGWidget master m ()
+addHamlet :: Monad m => HtmlUrl (Route master) -> GGWidget master m ()
addHamlet x = GWidget $ tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
-- | Add a 'Html' to the body tag.
@@ -150,19 +190,19 @@
addWidget = id
-- | Add some raw CSS to the style tag. Applies to all media types.
-addCassius :: Monad m => Cassius (Route master) -> GGWidget master m ()
+addCassius :: Monad m => CssUrl (Route master) -> GGWidget master m ()
addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing x) mempty mempty
-- | Identical to 'addCassius'.
-addLucius :: Monad m => Lucius (Route master) -> GGWidget master m ()
+addLucius :: Monad m => CssUrl (Route master) -> GGWidget master m ()
addLucius = addCassius
-- | Add some raw CSS to the style tag, for a specific media type.
-addCassiusMedia :: Monad m => Text -> Cassius (Route master) -> GGWidget master m ()
+addCassiusMedia :: Monad m => Text -> CssUrl (Route master) -> GGWidget master m ()
addCassiusMedia m x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) x) mempty mempty
-- | Identical to 'addCassiusMedia'.
-addLuciusMedia :: Monad m => Text -> Lucius (Route master) -> GGWidget master m ()
+addLuciusMedia :: Monad m => Text -> CssUrl (Route master) -> GGWidget master m ()
addLuciusMedia = addCassiusMedia
-- | Link to the specified local stylesheet.
@@ -204,17 +244,17 @@
addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
-- | Include raw Javascript in the page's script tag.
-addJulius :: Monad m => Julius (Route master) -> GGWidget master m ()
+addJulius :: Monad m => JavascriptUrl (Route master) -> GGWidget master m ()
addJulius x = GWidget $ tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
-- | Add a new script tag to the body with the contents of this 'Julius'
-- template.
-addJuliusBody :: Monad m => Julius (Route master) -> GGWidget master m ()
-addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJulius r j
+addJuliusBody :: Monad m => JavascriptUrl (Route master) -> GGWidget master m ()
+addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
-- | Add Coffesscript to the page's script tag. Requires the coffeescript
-- executable to be present at runtime.
-addCoffee :: MonadIO m => Coffee (Route master) -> GGWidget master (GGHandler sub master m) ()
+addCoffee :: MonadIO m => CoffeeUrl (Route master) -> GGWidget master (GGHandler sub master m) ()
addCoffee c = do
render <- lift getUrlRenderParams
t <- liftIO $ renderCoffee render c
@@ -222,7 +262,7 @@
-- | Add a new script tag to the body with the contents of this Coffesscript
-- template. Requires the coffeescript executable to be present at runtime.
-addCoffeeBody :: MonadIO m => Coffee (Route master) -> GGWidget master (GGHandler sub master m) ()
+addCoffeeBody :: MonadIO m => CoffeeUrl (Route master) -> GGWidget master (GGHandler sub master m) ()
addCoffeeBody c = do
render <- lift getUrlRenderParams
t <- liftIO $ renderCoffee render c
@@ -230,7 +270,7 @@
-- | Pull out the HTML tag contents and return it. Useful for performing some
-- manipulations. It can be easier to use this sometimes than 'wrapWidget'.
-extractBody :: Monad mo => GGWidget m mo () -> GGWidget m mo (Hamlet (Route m))
+extractBody :: Monad mo => GGWidget m mo () -> GGWidget m mo (HtmlUrl (Route m))
extractBody (GWidget w) =
GWidget $ mapRWST (liftM go) w
where
@@ -239,11 +279,11 @@
-- | Content for a web page. By providing this datatype, we can easily create
-- generic site templates, which would have the type signature:
--
--- > PageContent url -> Hamlet url
+-- > PageContent url -> HtmlUrl url
data PageContent url = PageContent
{ pageTitle :: Html
- , pageHead :: Hamlet url
- , pageBody :: Hamlet url
+ , pageHead :: HtmlUrl url
+ , pageBody :: HtmlUrl url
}
whamlet :: QuasiQuoter
@@ -271,7 +311,7 @@
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
ihamletToRepHtml :: (Monad mo, RenderMessage master message)
- => NP.IHamlet message (Route master)
+ => HtmlUrlI18n message (Route master)
-> GGHandler sub master mo RepHtml
ihamletToRepHtml ih = do
urender <- getUrlRenderParams
diff --git a/runtests.hs b/runtests.hs
deleted file mode 100644
--- a/runtests.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-import Test.Framework (defaultMain)
-import Test.CleanPath
-import Test.Exceptions
-import Test.Widget
-import Test.Media
-import Test.Links
-import Test.NoOverloadedStrings
-
-main :: IO ()
-main = defaultMain
- [ cleanPathTest
- , exceptionsTest
- , widgetTest
- , mediaTest
- , linksTest
- , noOverloadedTest
- ]
diff --git a/yesod-core.cabal b/yesod-core.cabal
--- a/yesod-core.cabal
+++ b/yesod-core.cabal
@@ -1,5 +1,5 @@
name: yesod-core
-version: 0.8.3.2
+version: 0.9.1
license: BSD3
license-file: LICENSE
author: Michael Snoyman