diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,266 @@ +# ChangeLog for shakespeare + +### 2.2.0 + +* Added $component with binding for reusable blocks + +You can now bind a component-producing function and reuse its sub-components within the same Hamlet block. + +#### Example + +```haskell +data Modal = Modal + { modalHeader :: Widget -> Widget + , modalBody :: Widget -> Widget + } + +modalWidget :: (Modal -> Widget) -> Widget +``` + +```hamlet +$component modal <- modalWidget + $component modalHeader modal +

This is the title + + $component modalBody modal +

This is the content +``` + +Conceptually, this desugars to: + +```haskell +^{ modalWidget $ \modal -> + [whamlet| + ^{ modalHeader modal [whamlet|

This is the title |] } + ^{ modalBody modal [whamlet|

This is the content |] } + |] + } +

outside +``` + +Since everything here is just plain Haskell, you can freely pass additional data or parameters to your component-producing function—`modalWidget` and its subcomponents are ordinary functions. +Only the *outermost* component (`modalWidget` in this case) needs to follow the `(Modal -> Widget) -> Widget` pattern; all nested subcomponents can have arbitrary types and arguments. + +### 2.1.7.1 + +* Add missing other-messages to shakespeare.cabal [#299](https://github.com/yesodweb/shakespeare/pull/299) + +### 2.1.7 + +* Use ByteString’s Lift for Hamlet code generation [#298](https://github.com/yesodweb/shakespeare/pull/298) + +### 2.1.6 + +* Introduce options type for i18n, add ability to stop using record types for messages [#290](https://github.com/yesodweb/shakespeare/pull/290) + +### 2.1.5 + +* Add better support for `mkMessage`ing data types with params.[#295](https://github.com/yesodweb/shakespeare/pull/295) + + +### 2.1.4 + +* [#292](https://github.com/yesodweb/shakespeare/pull/292) + * Add support for multi-line attributes. An example use of this is [here](https://github.com/yesodweb/shakespeare/issues/291). + +### 2.1.2 + +* Add support for context parsing in mkMessage function and related ones [#282](https://github.com/yesodweb/shakespeare/issues/282). Added support for building with LTS versions of 22, 21, 20 and removed older ones. + +### 2.1.0 + +* Add `OverloadedRecordDot`-style record access in expressions + +### 2.0.30 + +* Add `Text.Cassius.Ordered` and `Text.Lucius.Ordered` modules with parsers to maintain order between attributes and mixin blocks. + +### 2.0.29 + +* Support the upcoming `template-haskell` release with GHC 9.4 [#267](https://github.com/yesodweb/shakespeare/pull/267) + +### 2.0.28 + +* Add support for sub-blocks in mixins [#264](https://github.com/yesodweb/shakespeare/pull/264) + +### 2.0.27 + +* Change how embedded templates are located by the compiler. Relative files are now resolved using the Cabal project root, to fix builds of multi-project codebases. [#266](https://github.com/yesodweb/shakespeare/pull/266) +* Change how messages are located by the compiler. The message directory is now resolved using the Cabal project root, to fix builds of multi-project codebases. [#266](https://github.com/yesodweb/shakespeare/pull/266) + +### 2.0.26 + +* Support `@supports` [#263](https://github.com/yesodweb/shakespeare/pull/263) + +### 2.0.25.1 + +* Support for GHC 9.2 and aeson 2 [#260](https://github.com/yesodweb/shakespeare/pull/260) + +### 2.0.25 + +* Support for GHC 9.0 [#254](https://github.com/yesodweb/shakespeare/pull/254) + +### 2.0.24.1 + +* Derive Lift instances wherever possible [#252](https://github.com/yesodweb/shakespeare/pull/252) + +### 2.0.24 + +* Fix build errors with GHC 8.10.1-alpha2 [#245](https://github.com/yesodweb/shakespeare/pull/245) + +### 2.0.23 + +* Add support to use caret interpolation in only var shakespeares [#242](https://github.com/yesodweb/shakespeare/issues/242) + +### 2.0.22 + +* Add `stextFile` to `Text.Shakespeare.Text`, which can be used to produce `Text` directly in the same way `shamletFile` can be used to produce `Html` directly. [#240](https://github.com/yesodweb/shakespeare/pull/240) + +### 2.0.21 + +* Support for GHC 8.8 + +### 2.0.20 + +* Restore allowing GHC to detect changes to i18n message files in GHC >= 8.4. + +### 2.0.19 + +* Change of the default behaviour of `*File` functions, they now will add their templates' source file to ghc-dependencies, thus recompiling on templates' changes. + +### 2.0.18 + +* ToJavascript instance for String, Strict and Lazy Text [#227](https://github.com/yesodweb/shakespeare/pull/227) + +### 2.0.17 + +* Fix parse pattern-match with operator constructor [#222](https://github.com/yesodweb/shakespeare/issues/222) + +### 2.0.16 + +* Updated `encodeToTextBuilder` also escapes single quotes [#221](https://github.com/yesodweb/shakespeare/pull/221) + +### 2.0.15 + +* Semigroup instances + +### 2.0.14.1 + +* Handle expressions with infix operator and trailing spaces [#211](https://github.com/yesodweb/shakespeare/issues/211) + +### 2.0.14 + +* Fix Cassius and Lucius reload mode [#206](https://github.com/yesodweb/shakespeare/issues/206) + +### 2.0.13 + +* Expose Text.Internal.Css [#205](https://github.com/yesodweb/shakespeare/pull/205) + +### 2.0.12.1 + +* New contentHash parser breaks hash hrefs [#200](https://github.com/yesodweb/shakespeare/issues/200) + +### 2.0.12 + +* Parser fails without space between class and ID (Hamlet) [#197](https://github.com/yesodweb/shakespeare/issues/197) + +### 2.0.11.2 + +* Support for template-haskell 2.12.0 [#196](https://github.com/yesodweb/shakespeare/pull/196) + +### 2.0.11.1 + +* Handle parsing of trailing semicolon after mixins [#194](https://github.com/yesodweb/shakespeare/issues/194) + +### 2.0.11 + +* Export hamletFromString [#191](https://github.com/yesodweb/shakespeare/pull/191) + +### 2.0.10 + +* Added `ixhamlet` [#177](https://github.com/yesodweb/shakespeare/pull/177) + +### 2.0.9 + +* Better empty HTML tag list + +### 2.0.8.1 + +* Make it work with ghc-8.0 [#181](https://github.com/yesodweb/shakespeare/pull/181) + +### 2.0.8 + +* Improve docs in Text.Hamlet [#180](https://github.com/yesodweb/shakespeare/pull/180) + +### 2.0.7 + +* Include aeson's JSON encoding and escape `<`, `>` and `&` to avoid XSS attacks + +### 2.0.6 + +* Provide the `Text.Hamlet.Runtime` module + +### 2.0.5 + +* Drop system-filepath + +### 2.0.4.1 + +Fix build for GHC 7.10 [#151](https://github.com/yesodweb/shakespeare/pull/151) + +### 2.0.4 + +* [Add multiline literal aligned with bar #148](https://github.com/yesodweb/shakespeare/pull/148) + +### 2.0.3 + +* `cassiusMixin` added + +### 2.0.2.2 + +GHC 7.10 support + +### shakesepare 2.0.2 + +shakespeare-i18n supports message directories. + +### Hamlet 0.5.0 (August 29, 2010) + +* Use can use parantheses when referencing variables. This allows you to have + functions applied to multiple arguments. +* Added the hamlet' and xhamlet' quasiquoters for generating plain Html + values. +* Added runtime Hamlet support. +* Added "file debug" support. This is a mode that is a drop-in replacement for + external files compiled via template haskell. However, this mode also has a + runtime component, in that is reads your templates at runtime, thus avoiding + the need to a recompile for each template change. This takes a runtime hit + obviously, so it's recommended that you switch back to the compile-time + templates for production systems. +* Added the Cassius and Julius template languages for CSS and Javascript, + respectively. The former is white-space sensitive, whereas the latter is just + a passthrough for raw Javascript code. The big feature in both of them is that + they support variable interpolation just like Hamlet does. + +### New in Hamlet 0.4.0 + +* Internal template parsing is now done via Parsec. This opened the doors for + the other changes mentioned below, but also hopefully gives more meaningful + error messages. There's absolutely no runtime performance hit for this change, + since all parsing is done at compile time, and if there *is* any compile-time + hit, it's too negligible to be noticed. +* Attribute values can now be quoted. This allows you to embed spaces, periods + and pounds in an attribute value. For example: + [$hamlet|%input!type=submit!value="Add new value"|]. +* Space-delimited references in addition to period-delimited ones. This only + applies to references in content, not in statements. For example, you could + write [\$hamlet|\$foo bar baz\$|]. +* Dollar-sign interpolation is now polymorphic, based on the ToHtml typeclass. + You can now do away with \$string.var\$ and simply type \$var\$. Currently, the + ToHtml typeclass is not exposed, and it only provides instances for String and + Html, though this is open for discussion. +* Added hamletFile and xhamletFile which loads a Hamlet template from an + external file. The file is parsed at compile time, just like a quasi-quoted + template, and must be UTF-8 encoded. Additionally, be warned that the compiler + won't automatically know to recompile a module if the template file gets + changed. diff --git a/Text/Cassius.hs b/Text/Cassius.hs --- a/Text/Cassius.hs +++ b/Text/Cassius.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} + module Text.Cassius ( -- * Datatypes Css @@ -17,6 +18,9 @@ , cassiusFile , cassiusFileDebug , cassiusFileReload + -- ** Mixims + , cassiusMixin + , Mixin -- * ToCss instances -- ** Color , Color (..) @@ -36,33 +40,40 @@ , cassiusUsedIdentifiers ) where -import Text.Css -import Text.Shakespeare.Base -import Text.Shakespeare (VarType) 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) +import Text.Internal.Cassius (i2bMixin) +import Text.Internal.Css +import Text.Internal.CssCommon +import Text.Internal.Lucius (parseTopLevels) +import qualified Text.Lucius as Lucius +import Text.Shakespeare (VarType) +import Text.Shakespeare.Base cassius :: QuasiQuoter -cassius = QuasiQuoter { quoteExp = quoteExp lucius . i2b } +cassius = QuasiQuoter { quoteExp = quoteExp Lucius.lucius . i2b } cassiusFile :: FilePath -> Q Exp cassiusFile fp = do -#ifdef GHC_7_4 - qAddDependentFile fp -#endif - contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp + contents <- readFileRecompileQ fp quoteExp cassius contents -cassiusFileDebug, cassiusFileReload :: FilePath -> Q Exp -cassiusFileDebug = cssFileDebug True [|Text.Lucius.parseTopLevels|] Text.Lucius.parseTopLevels +cassiusFileDebug :: FilePath -> Q Exp +cassiusFileDebug = cssFileDebug True [|parseTopLevels Unordered|] (parseTopLevels Unordered) + +cassiusFileReload :: FilePath -> Q Exp cassiusFileReload = cassiusFileDebug -- | Determine which identifiers are used by the given template, useful for -- creating systems like yesod devel. cassiusUsedIdentifiers :: String -> [(Deref, VarType)] -cassiusUsedIdentifiers = cssUsedIdentifiers True Text.Lucius.parseTopLevels +cassiusUsedIdentifiers = cssUsedIdentifiers True (parseTopLevels Unordered) + +-- | Create a mixin with Cassius syntax. +-- +-- Since 2.0.3 +cassiusMixin :: QuasiQuoter +cassiusMixin = QuasiQuoter + { quoteExp = quoteExp Lucius.luciusMixin . i2bMixin + } diff --git a/Text/Cassius/Ordered.hs b/Text/Cassius/Ordered.hs new file mode 100644 --- /dev/null +++ b/Text/Cassius/Ordered.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} + +-- | This module is the twin brother of module Text.Cassius. +-- The difference is that these parsers preserv the given order of attributes and mixin blocks. +-- +-- > let bams = [cassiusMixin| +-- > bam1:bam2 +-- > ^{bins} +-- > bam3:bam4 +-- > |] :: Mixin +-- > bins = [cassiusMixin| +-- > bin1:bin2 +-- > |] :: Mixin +-- > in renderCss ([Text.Ordered.lucius|foo{bar1:bar2;^{bams};bar3:bar4;}|] undefined) +-- > "foo{bar1:bar2;bam1:bam2;bin1:bin2;bam3:bam4;bar3:bar4}" + +module Text.Cassius.Ordered + ( -- * Datatypes + Css + , CssUrl + -- * Type class + , ToCss (..) + -- * Rendering + , renderCss + , renderCssUrl + -- * Parsing + , cassius + , cassiusFile + , cassiusFileDebug + , cassiusFileReload + -- ** Mixims + , cassiusMixin + , Mixin + -- * ToCss instances + -- ** Color + , Color (..) + , colorRed + , colorBlack + -- ** Size + , mkSize + , AbsoluteUnit (..) + , AbsoluteSize (..) + , absoluteSize + , EmSize (..) + , ExSize (..) + , PercentageSize (..) + , percentageSize + , PixelSize (..) + -- * Internal + , cassiusUsedIdentifiers + ) where + +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Language.Haskell.TH.Syntax +import Text.IndentToBrace (i2b) +import Text.Internal.Cassius (i2bMixin) +import Text.Internal.Css +import Text.Internal.CssCommon +import Text.Internal.Lucius (parseTopLevels) +import qualified Text.Lucius.Ordered as Lucius.Ordered +import Text.Shakespeare (VarType) +import Text.Shakespeare.Base + +-- | @since 2.0.30 +cassius :: QuasiQuoter +cassius = QuasiQuoter { quoteExp = quoteExp Lucius.Ordered.lucius . i2b } + +-- | @since 2.0.30 +cassiusFile :: FilePath -> Q Exp +cassiusFile fp = do + contents <- readFileRecompileQ fp + quoteExp cassius contents + +-- | @since 2.0.30 +cassiusFileDebug :: FilePath -> Q Exp +cassiusFileDebug = cssFileDebug True [|parseTopLevels Ordered|] (parseTopLevels Ordered) + +-- | @since 2.0.30 +cassiusFileReload :: FilePath -> Q Exp +cassiusFileReload = cassiusFileDebug + +-- | Determine which identifiers are used by the given template, useful for +-- creating systems like yesod devel. +-- | @since 2.0.30 +cassiusUsedIdentifiers :: String -> [(Deref, VarType)] +cassiusUsedIdentifiers = cssUsedIdentifiers True (parseTopLevels Ordered) + +-- | Create a mixin with Cassius syntax. +-- +-- | @since 2.0.30 +cassiusMixin :: QuasiQuoter +cassiusMixin = QuasiQuoter + { quoteExp = quoteExp Lucius.Ordered.luciusMixin . i2bMixin + } diff --git a/Text/Coffee.hs b/Text/Coffee.hs --- a/Text/Coffee.hs +++ b/Text/Coffee.hs @@ -43,7 +43,7 @@ -- -- Further reading: -- --- 1. Shakespearean templates: +-- 1. Shakespearean templates: -- -- 2. CoffeeScript: module Text.Coffee diff --git a/Text/Css.hs b/Text/Css.hs deleted file mode 100644 --- a/Text/Css.hs +++ /dev/null @@ -1,537 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE EmptyDataDecls #-} -module Text.Css where - -import Data.List (intersperse, intercalate) -import Data.Text.Lazy.Builder (Builder, singleton, toLazyText, fromLazyText, fromString) -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB -import Data.Monoid (Monoid, mconcat, mappend, mempty) -import Data.Text (Text) -import qualified Data.Text as T -import Language.Haskell.TH.Syntax -import System.IO.Unsafe (unsafePerformIO) -import Text.ParserCombinators.Parsec (Parser, parse) -import Text.Shakespeare.Base hiding (Scope) -import Language.Haskell.TH -import Control.Applicative ((<$>), (<*>)) -import Control.Arrow ((***), second) -import Text.IndentToBrace (i2b) -import Data.Functor.Identity (runIdentity) -import Text.Shakespeare (VarType (..)) - -#if MIN_VERSION_base(4,5,0) -import Data.Monoid ((<>)) -#else -(<>) :: Monoid m => m -> m -> m -(<>) = mappend -{-# INLINE (<>) #-} -#endif - -type CssUrl url = (url -> [(T.Text, T.Text)] -> T.Text) -> Css - -type DList a = [a] -> [a] - --- FIXME great use case for data kinds -data Resolved -data Unresolved - -type family Selector a -type instance Selector Resolved = Builder -type instance Selector Unresolved = [Contents] - -type family ChildBlocks a -type instance ChildBlocks Resolved = () -type instance ChildBlocks Unresolved = [(HasLeadingSpace, Block Unresolved)] - -type HasLeadingSpace = Bool - -type family Str a -type instance Str Resolved = Builder -type instance Str Unresolved = Contents - -type family Mixins a -type instance Mixins Resolved = () -type instance Mixins Unresolved = [Deref] - -data Block a = Block - { blockSelector :: !(Selector a) - , blockAttrs :: ![Attr a] - , blockBlocks :: !(ChildBlocks a) - , blockMixins :: !(Mixins a) - } - -data Mixin = Mixin - { mixinAttrs :: ![Attr Resolved] - , mixinBlocks :: ![Block Resolved] - } -instance Monoid Mixin where - mempty = Mixin mempty mempty - mappend (Mixin a x) (Mixin b y) = Mixin (a ++ b) (x ++ y) - -data TopLevel a where - TopBlock :: !(Block a) -> TopLevel a - TopAtBlock :: !String -- name e.g., media - -> !(Str a) -- selector - -> ![Block a] - -> TopLevel a - TopAtDecl :: !String -> !(Str a) -> TopLevel a - TopVar :: !String -> !String -> TopLevel Unresolved - -data Attr a = Attr - { attrKey :: !(Str a) - , attrVal :: !(Str a) - } - -data Css = CssWhitespace ![TopLevel Resolved] - | CssNoWhitespace ![TopLevel Resolved] - -data Content = ContentRaw String - | ContentVar Deref - | ContentUrl Deref - | ContentUrlParam Deref - | ContentMixin Deref - deriving (Show, Eq) - -type Contents = [Content] - -data CDData url = CDPlain Builder - | CDUrl url - | CDUrlParam (url, [(Text, Text)]) - | CDMixin Mixin - -pack :: String -> Text -pack = T.pack -#if !MIN_VERSION_text(0, 11, 2) -{-# NOINLINE pack #-} -#endif - -fromText :: Text -> Builder -fromText = TLB.fromText -{-# NOINLINE fromText #-} - -class ToCss a where - toCss :: a -> Builder - -instance ToCss [Char] where toCss = fromLazyText . TL.pack -instance ToCss Text where toCss = fromText -instance ToCss TL.Text where toCss = fromLazyText - --- | Determine which identifiers are used by the given template, useful for --- creating systems like yesod devel. -cssUsedIdentifiers :: Bool -- ^ perform the indent-to-brace conversion - -> Parser [TopLevel Unresolved] - -> String - -> [(Deref, VarType)] -cssUsedIdentifiers toi2b parseBlocks s' = - concat $ runIdentity $ mapM (getVars scope0) contents - where - s = if toi2b then i2b s' else s' - a = either (error . show) id $ parse parseBlocks s s - (scope0, contents) = go a - - go :: [TopLevel Unresolved] - -> (Scope, [Content]) - go [] = ([], []) - go (TopAtDecl dec cs:rest) = - (scope, rest'') - where - (scope, rest') = go rest - rest'' = - ContentRaw ('@' : dec ++ " ") - : cs - ++ ContentRaw ";" - : rest' - go (TopAtBlock _ _ blocks:rest) = - (scope1 ++ scope2, rest1 ++ rest2) - where - (scope1, rest1) = go (map TopBlock blocks) - (scope2, rest2) = go rest - go (TopBlock (Block x y z mixins):rest) = - (scope1 ++ scope2, rest0 ++ rest1 ++ rest2 ++ restm) - where - rest0 = intercalate [ContentRaw ","] x ++ concatMap go' y - (scope1, rest1) = go (map (TopBlock . snd) z) - (scope2, rest2) = go rest - restm = map ContentMixin mixins - go (TopVar k v:rest) = - ((k, v):scope, rest') - where - (scope, rest') = go rest - go' (Attr k v) = k ++ v - -cssFileDebug :: Bool -- ^ perform the indent-to-brace conversion - -> Q Exp - -> Parser [TopLevel Unresolved] - -> FilePath - -> Q Exp -cssFileDebug toi2b parseBlocks' parseBlocks fp = do - s <- fmap TL.unpack $ qRunIO $ readUtf8File fp -#ifdef GHC_7_4 - qAddDependentFile fp -#endif - let vs = cssUsedIdentifiers toi2b parseBlocks s - c <- mapM vtToExp vs - cr <- [|cssRuntime toi2b|] - parseBlocks'' <- parseBlocks' - return $ cr `AppE` parseBlocks'' `AppE` (LitE $ StringL fp) `AppE` ListE c - -combineSelectors :: HasLeadingSpace - -> [Contents] - -> [Contents] - -> [Contents] -combineSelectors hsl a b = do - a' <- a - b' <- b - return $ a' ++ addSpace b' - where - addSpace - | hsl = (ContentRaw " " :) - | otherwise = id - -blockRuntime :: [(Deref, CDData url)] - -> (url -> [(Text, Text)] -> Text) - -> Block Unresolved - -> Either String (DList (Block Resolved)) --- FIXME share code with blockToCss -blockRuntime cd render' (Block x attrs z mixinsDerefs) = do - mixins <- mapM getMixin mixinsDerefs - x' <- mapM go' $ intercalate [ContentRaw ","] x - attrs' <- mapM resolveAttr attrs - z' <- mapM (subGo x) z -- FIXME use difflists again - Right $ \rest -> Block - { blockSelector = mconcat x' - , blockAttrs = concat $ attrs' : map mixinAttrs mixins - , blockBlocks = () - , blockMixins = () - } : foldr ($) rest z' - {- - (:) (Css' (mconcat $ map go' $ intercalate [ContentRaw "," ] x) (map go'' y)) - . foldr (.) id (map (subGo x) z) - -} - where - go' = contentToBuilderRT cd render' - - getMixin d = - case lookup d cd of - Nothing -> Left $ "Mixin not found: " ++ show d - Just (CDMixin m) -> Right m - Just _ -> Left $ "For " ++ show d ++ ", expected Mixin" - - resolveAttr :: Attr Unresolved -> Either String (Attr Resolved) - resolveAttr (Attr k v) = Attr <$> (mconcat <$> mapM go' k) <*> (mconcat <$> mapM go' v) - - subGo :: [Contents] -- ^ parent selectors - -> (HasLeadingSpace, Block Unresolved) - -> Either String (DList (Block Resolved)) - subGo x' (hls, Block a b c d) = - blockRuntime cd render' (Block a' b c d) - where - a' = combineSelectors hls x' a - -contentToBuilderRT :: [(Deref, CDData url)] - -> (url -> [(Text, Text)] -> Text) - -> Content - -> Either String Builder -contentToBuilderRT _ _ (ContentRaw s) = Right $ fromText $ pack s -contentToBuilderRT cd _ (ContentVar d) = - case lookup d cd of - Just (CDPlain s) -> Right s - _ -> Left $ show d ++ ": expected CDPlain" -contentToBuilderRT cd render' (ContentUrl d) = - case lookup d cd of - Just (CDUrl u) -> Right $ fromText $ render' u [] - _ -> Left $ show d ++ ": expected CDUrl" -contentToBuilderRT cd render' (ContentUrlParam d) = - case lookup d cd of - Just (CDUrlParam (u, p)) -> - Right $ fromText $ render' u p - _ -> Left $ show d ++ ": expected CDUrlParam" -contentToBuilderRT _ _ ContentMixin{} = Left "contentToBuilderRT ContentMixin" - -cssRuntime :: Bool -- ^ i2b? - -> Parser [TopLevel Unresolved] - -> FilePath - -> [(Deref, CDData url)] - -> (url -> [(Text, Text)] -> Text) - -> Css -cssRuntime toi2b parseBlocks fp cd render' = unsafePerformIO $ do - s' <- fmap TL.unpack $ qRunIO $ readUtf8File fp - let s = if toi2b then i2b s' else s' - let a = either (error . show) id $ parse parseBlocks s s - return $ CssWhitespace $ goTop [] a - where - goTop :: [(String, String)] -- ^ scope - -> [TopLevel Unresolved] - -> [TopLevel Resolved] - goTop _ [] = [] - goTop scope (TopAtDecl dec cs':rest) = - TopAtDecl dec cs : goTop scope rest - where - cs = either error mconcat $ mapM (contentToBuilderRT cd render') cs' - goTop scope (TopBlock b:rest) = - map TopBlock (either error ($[]) $ blockRuntime (addScope scope) render' b) ++ - goTop scope rest - goTop scope (TopAtBlock name s' b:rest) = - TopAtBlock name s (foldr (either error id . blockRuntime (addScope scope) render') [] b) : - goTop scope rest - where - s = either error mconcat $ mapM (contentToBuilderRT cd render') s' - goTop scope (TopVar k v:rest) = goTop ((k, v):scope) rest - - addScope scope = map (DerefIdent . Ident *** CDPlain . fromString) scope ++ cd - -vtToExp :: (Deref, VarType) -> Q Exp -vtToExp (d, vt) = do - d' <- lift d - c' <- c vt - return $ TupE [d', c' `AppE` derefToExp [] d] - where - c :: VarType -> Q Exp - c VTPlain = [|CDPlain . toCss|] - c VTUrl = [|CDUrl|] - c VTUrlParam = [|CDUrlParam|] - c VTMixin = [|CDMixin|] - -getVars :: Monad m => [(String, String)] -> Content -> m [(Deref, VarType)] -getVars _ ContentRaw{} = return [] -getVars scope (ContentVar d) = - case lookupD d scope of - Just _ -> return [] - Nothing -> return [(d, VTPlain)] -getVars scope (ContentUrl d) = - case lookupD d scope of - Nothing -> return [(d, VTUrl)] - Just s -> fail $ "Expected URL for " ++ s -getVars scope (ContentUrlParam d) = - case lookupD d scope of - Nothing -> return [(d, VTUrlParam)] - Just s -> fail $ "Expected URLParam for " ++ s -getVars scope (ContentMixin d) = - case lookupD d scope of - Nothing -> return [(d, VTMixin)] - Just s -> fail $ "Expected Mixin for " ++ s - -lookupD :: Deref -> [(String, b)] -> Maybe String -lookupD (DerefIdent (Ident s)) scope = - case lookup s scope of - Nothing -> Nothing - Just _ -> Just s -lookupD _ _ = Nothing - -compressTopLevel :: TopLevel Unresolved - -> TopLevel Unresolved -compressTopLevel (TopBlock b) = TopBlock $ compressBlock b -compressTopLevel (TopAtBlock name s b) = TopAtBlock name s $ map compressBlock b -compressTopLevel x@TopAtDecl{} = x -compressTopLevel x@TopVar{} = x - -compressBlock :: Block Unresolved - -> Block Unresolved -compressBlock (Block x y blocks mixins) = - Block (map cc x) (map go y) (map (second compressBlock) blocks) mixins - where - go (Attr k v) = Attr (cc k) (cc v) - cc [] = [] - cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c - cc (a:b) = a : cc b - -blockToMixin :: Name - -> Scope - -> Block Unresolved - -> Q Exp -blockToMixin r scope (Block _sel props subblocks mixins) = - [|Mixin - { mixinAttrs = concat - $ $(listE $ map go props) - : map mixinAttrs $mixinsE - -- FIXME too many complications to implement sublocks for now... - , mixinBlocks = [] -- foldr (.) id $(listE $ map subGo subblocks) [] - }|] - {- - . foldr (.) id $(listE $ map subGo subblocks) - . (concatMap mixinBlocks $mixinsE ++) - |] - -} - where - mixinsE = return $ ListE $ map (derefToExp []) mixins - go (Attr x y) = conE 'Attr - `appE` (contentsToBuilder r scope x) - `appE` (contentsToBuilder r scope y) - subGo (Block sel' b c d) = blockToCss r scope $ Block sel' b c d - -blockToCss :: Name - -> Scope - -> Block Unresolved - -> Q Exp -blockToCss r scope (Block sel props subblocks mixins) = - [|((Block - { blockSelector = $(selectorToBuilder r scope sel) - , blockAttrs = concat - $ $(listE $ map go props) - : map mixinAttrs $mixinsE - , blockBlocks = () - , blockMixins = () - } :: Block Resolved):) - . foldr (.) id $(listE $ map subGo subblocks) - . (concatMap mixinBlocks $mixinsE ++) - |] - where - mixinsE = return $ ListE $ map (derefToExp []) mixins - go (Attr x y) = conE 'Attr - `appE` (contentsToBuilder r scope x) - `appE` (contentsToBuilder r scope y) - subGo (hls, Block sel' b c d) = - blockToCss r scope $ Block sel'' b c d - where - sel'' = combineSelectors hls sel sel' - -selectorToBuilder :: Name -> Scope -> [Contents] -> Q Exp -selectorToBuilder r scope sels = - contentsToBuilder r scope $ intercalate [ContentRaw ","] sels - -contentsToBuilder :: Name -> Scope -> [Content] -> Q Exp -contentsToBuilder r scope contents = - appE [|mconcat|] $ listE $ map (contentToBuilder r scope) contents - -contentToBuilder :: Name -> Scope -> Content -> Q Exp -contentToBuilder _ _ (ContentRaw x) = - [|fromText . pack|] `appE` litE (StringL x) -contentToBuilder _ scope (ContentVar d) = - case d of - DerefIdent (Ident s) - | Just val <- lookup s scope -> [|fromText . pack|] `appE` litE (StringL val) - _ -> [|toCss|] `appE` return (derefToExp [] d) -contentToBuilder r _ (ContentUrl u) = - [|fromText|] `appE` - (varE r `appE` return (derefToExp [] u) `appE` listE []) -contentToBuilder r _ (ContentUrlParam u) = - [|fromText|] `appE` - ([|uncurry|] `appE` varE r `appE` return (derefToExp [] u)) -contentToBuilder _ _ ContentMixin{} = error "contentToBuilder on ContentMixin" - -type Scope = [(String, String)] - -topLevelsToCassius :: [TopLevel Unresolved] - -> Q Exp -topLevelsToCassius a = do - r <- newName "_render" - lamE [varP r] $ appE [|CssNoWhitespace . foldr ($) []|] $ fmap ListE $ go r [] a - where - go _ _ [] = return [] - go r scope (TopBlock b:rest) = do - e <- [|(++) $ map TopBlock ($(blockToCss r scope b) [])|] - es <- go r scope rest - return $ e : es - go r scope (TopAtBlock name s b:rest) = do - let s' = contentsToBuilder r scope s - e <- [|(:) $ TopAtBlock $(lift name) $(s') $(blocksToCassius r scope b)|] - es <- go r scope rest - return $ e : es - go r scope (TopAtDecl dec cs:rest) = do - e <- [|(:) $ TopAtDecl $(lift dec) $(contentsToBuilder r scope cs)|] - es <- go r scope rest - return $ e : es - go r scope (TopVar k v:rest) = go r ((k, v) : scope) rest - -blocksToCassius :: Name - -> Scope - -> [Block Unresolved] - -> Q Exp -blocksToCassius r scope a = do - appE [|foldr ($) []|] $ listE $ map (blockToCss r scope) a - -renderCss :: Css -> TL.Text -renderCss css = - toLazyText $ mconcat $ map go tops - where - (haveWhiteSpace, tops) = - case css of - CssWhitespace x -> (True, x) - CssNoWhitespace x -> (False, x) - go (TopBlock x) = renderBlock haveWhiteSpace mempty x - go (TopAtBlock name s x) = - fromText (pack $ concat ["@", name, " "]) `mappend` - s `mappend` - startBlock `mappend` - foldr mappend endBlock (map (renderBlock haveWhiteSpace (fromString " ")) x) - go (TopAtDecl dec cs) = fromText (pack $ concat ["@", dec, " "]) `mappend` - cs `mappend` - endDecl - - startBlock - | haveWhiteSpace = fromString " {\n" - | otherwise = singleton '{' - - endBlock - | haveWhiteSpace = fromString "}\n" - | otherwise = singleton '}' - - endDecl - | haveWhiteSpace = fromString ";\n" - | otherwise = singleton ';' - -renderBlock :: Bool -- ^ have whitespace? - -> Builder -- ^ indentation - -> Block Resolved - -> Builder -renderBlock haveWhiteSpace indent (Block sel attrs () ()) - | null attrs = mempty - | otherwise = startSelect - <> sel - <> startBlock - <> mconcat (intersperse endDecl $ map renderAttr attrs) - <> endBlock - where - renderAttr (Attr k v) = startDecl <> k <> colon <> v - - colon - | haveWhiteSpace = fromString ": " - | otherwise = singleton ':' - - startSelect - | haveWhiteSpace = indent - | otherwise = mempty - - startBlock - | haveWhiteSpace = fromString " {\n" - | otherwise = singleton '{' - - endBlock - | haveWhiteSpace = fromString ";\n" `mappend` indent `mappend` fromString "}\n" - | otherwise = singleton '}' - - startDecl - | haveWhiteSpace = indent `mappend` fromString " " - | otherwise = mempty - - endDecl - | haveWhiteSpace = fromString ";\n" - | otherwise = singleton ';' - -instance Lift Mixin where - lift (Mixin a b) = [|Mixin a b|] -instance Lift (Attr Unresolved) where - lift (Attr k v) = [|Attr k v :: Attr Unresolved |] -instance Lift (Attr Resolved) where - lift (Attr k v) = [|Attr $(liftBuilder k) $(liftBuilder v) :: Attr Resolved |] - -liftBuilder :: Builder -> Q Exp -liftBuilder b = [|fromText $ pack $(lift $ TL.unpack $ toLazyText b)|] - -instance Lift Content where - lift (ContentRaw s) = [|ContentRaw s|] - lift (ContentVar d) = [|ContentVar d|] - lift (ContentUrl d) = [|ContentUrl d|] - lift (ContentUrlParam d) = [|ContentUrlParam d|] - lift (ContentMixin m) = [|ContentMixin m|] -instance Lift (Block Unresolved) where - lift (Block a b c d) = [|Block a b c d|] -instance Lift (Block Resolved) where - lift (Block a b () ()) = [|Block $(liftBuilder a) b () ()|] diff --git a/Text/CssCommon.hs b/Text/CssCommon.hs deleted file mode 100644 --- a/Text/CssCommon.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} -module Text.CssCommon where - -import Text.Css -import Text.MkSizeType -import qualified Data.Text as TS -import Text.Printf (printf) -import Language.Haskell.TH -import Data.Word (Word8) -import Data.Bits -import Data.Text.Lazy.Builder (fromLazyText) -import qualified Data.Text.Lazy as TL - -renderCssUrl :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> CssUrl url -> TL.Text -renderCssUrl r s = renderCss $ s r - -data Color = Color Word8 Word8 Word8 - deriving Show -instance ToCss Color where - toCss (Color r g b) = - let (r1, r2) = toHex r - (g1, g2) = toHex g - (b1, b2) = toHex b - in fromText $ TS.pack $ '#' : - if r1 == r2 && g1 == g2 && b1 == b2 - then [r1, g1, b1] - else [r1, r2, g1, g2, b1, b2] - where - toHex :: Word8 -> (Char, Char) - toHex x = (toChar $ shiftR x 4, toChar $ x .&. 15) - toChar :: Word8 -> Char - toChar c - | c < 10 = mkChar c 0 '0' - | otherwise = mkChar c 10 'A' - mkChar :: Word8 -> Word8 -> Char -> Char - mkChar a b' c = - toEnum $ fromIntegral $ a - b' + fromIntegral (fromEnum c) - -colorRed :: Color -colorRed = Color 255 0 0 - -colorBlack :: Color -colorBlack = Color 0 0 0 - --- CSS size wrappers - --- | Create a CSS size, e.g. $(mkSize "100px"). -mkSize :: String -> ExpQ -mkSize s = appE nameE valueE - where [(value, unit)] = reads s :: [(Double, String)] - absoluteSizeE = varE $ mkName "absoluteSize" - nameE = case unit of - "cm" -> appE absoluteSizeE (conE $ mkName "Centimeter") - "em" -> conE $ mkName "EmSize" - "ex" -> conE $ mkName "ExSize" - "in" -> appE absoluteSizeE (conE $ mkName "Inch") - "mm" -> appE absoluteSizeE (conE $ mkName "Millimeter") - "pc" -> appE absoluteSizeE (conE $ mkName "Pica") - "pt" -> appE absoluteSizeE (conE $ mkName "Point") - "px" -> conE $ mkName "PixelSize" - "%" -> varE $ mkName "percentageSize" - _ -> error $ "In mkSize, invalid unit: " ++ unit - valueE = litE $ rationalL (toRational value) - --- | Absolute size units. -data AbsoluteUnit = Centimeter - | Inch - | Millimeter - | Pica - | Point - deriving (Eq, Show) - --- | Not intended for direct use, see 'mkSize'. -data AbsoluteSize = AbsoluteSize - { absoluteSizeUnit :: AbsoluteUnit -- ^ Units used for text formatting. - , absoluteSizeValue :: Rational -- ^ Normalized value in centimeters. - } - --- | Absolute size unit convertion rate to centimeters. -absoluteUnitRate :: AbsoluteUnit -> Rational -absoluteUnitRate Centimeter = 1 -absoluteUnitRate Inch = 2.54 -absoluteUnitRate Millimeter = 0.1 -absoluteUnitRate Pica = 12 * absoluteUnitRate Point -absoluteUnitRate Point = 1 / 72 * absoluteUnitRate Inch - --- | Constructs 'AbsoluteSize'. Not intended for direct use, see 'mkSize'. -absoluteSize :: AbsoluteUnit -> Rational -> AbsoluteSize -absoluteSize unit value = AbsoluteSize unit (value * absoluteUnitRate unit) - -instance Show AbsoluteSize where - show (AbsoluteSize unit value') = printf "%f" value ++ suffix - where value = fromRational (value' / absoluteUnitRate unit) :: Double - suffix = case unit of - Centimeter -> "cm" - Inch -> "in" - Millimeter -> "mm" - Pica -> "pc" - Point -> "pt" - -instance Eq AbsoluteSize where - (AbsoluteSize _ v1) == (AbsoluteSize _ v2) = v1 == v2 - -instance Ord AbsoluteSize where - compare (AbsoluteSize _ v1) (AbsoluteSize _ v2) = compare v1 v2 - -instance Num AbsoluteSize where - (AbsoluteSize u1 v1) + (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 + v2) - (AbsoluteSize u1 v1) * (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 * v2) - (AbsoluteSize u1 v1) - (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 - v2) - abs (AbsoluteSize u v) = AbsoluteSize u (abs v) - signum (AbsoluteSize u v) = AbsoluteSize u (abs v) - fromInteger x = AbsoluteSize Centimeter (fromInteger x) - -instance Fractional AbsoluteSize where - (AbsoluteSize u1 v1) / (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 / v2) - fromRational x = AbsoluteSize Centimeter (fromRational x) - -instance ToCss AbsoluteSize where - toCss = fromText . TS.pack . show - --- | Not intended for direct use, see 'mkSize'. -data PercentageSize = PercentageSize - { percentageSizeValue :: Rational -- ^ Normalized value, 1 == 100%. - } - deriving (Eq, Ord) - --- | Constructs 'PercentageSize'. Not intended for direct use, see 'mkSize'. -percentageSize :: Rational -> PercentageSize -percentageSize value = PercentageSize (value / 100) - -instance Show PercentageSize where - show (PercentageSize value') = printf "%f" value ++ "%" - where value = fromRational (value' * 100) :: Double - -instance Num PercentageSize where - (PercentageSize v1) + (PercentageSize v2) = PercentageSize (v1 + v2) - (PercentageSize v1) * (PercentageSize v2) = PercentageSize (v1 * v2) - (PercentageSize v1) - (PercentageSize v2) = PercentageSize (v1 - v2) - abs (PercentageSize v) = PercentageSize (abs v) - signum (PercentageSize v) = PercentageSize (abs v) - fromInteger x = PercentageSize (fromInteger x) - -instance Fractional PercentageSize where - (PercentageSize v1) / (PercentageSize v2) = PercentageSize (v1 / v2) - fromRational x = PercentageSize (fromRational x) - -instance ToCss PercentageSize where - toCss = fromText . TS.pack . show - --- | Converts number and unit suffix to CSS format. -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/Hamlet.hs b/Text/Hamlet.hs --- a/Text/Hamlet.hs +++ b/Text/Hamlet.hs @@ -1,12 +1,7 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Hamlet ( -- * Plain HTML @@ -17,16 +12,18 @@ , xshamletFile -- * Hamlet , HtmlUrl + , Render , hamlet , hamletFile , hamletFileReload - , ihamletFileReload , xhamlet , xhamletFile -- * I18N Hamlet , HtmlUrlI18n + , Translate , ihamlet , ihamletFile + , ihamletFileReload -- * Type classes , ToAttributes (..) -- * Internal, for making more @@ -47,19 +44,19 @@ , maybeH , asHtmlUrl , attrsToHtml + -- * low-level + , hamletFromString ) where +import Text.Blaze.Internal (unsafeByteString) import Text.Shakespeare.Base import Text.Hamlet.Parse -#if MIN_VERSION_template_haskell(2,9,0) import Language.Haskell.TH.Syntax hiding (Module) -#else -import Language.Haskell.TH.Syntax -#endif import Language.Haskell.TH.Quote import Data.Char (isUpper, isDigit) import Data.Maybe (fromMaybe) import Data.Text (Text, pack) +import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import Text.Blaze.Html (Html, toHtml) import Text.Blaze.Internal (preEscapedText) @@ -72,9 +69,8 @@ import Data.IORef import qualified Data.Map as M import System.IO.Unsafe (unsafePerformIO) -import Filesystem (getModified) +import System.Directory (getModificationTime) import Data.Time (UTCTime) -import Filesystem.Path.CurrentOS (decodeString) import Text.Blaze.Html (preEscapedToHtml) -- | Convert some value to a list of attribute pairs. @@ -116,7 +112,11 @@ case exps of [] -> [|return ()|] [x] -> return x - _ -> return $ DoE $ map NoBindS exps + _ -> return $ DoE +#if MIN_VERSION_template_haskell(2,17,0) + Nothing +#endif + $ map NoBindS exps unIdent :: Ident -> String unIdent (Ident s) = s @@ -124,9 +124,10 @@ bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)]) bindingPattern (BindAs i@(Ident s) b) = do name <- newName s - (pattern, scope) <- bindingPattern b - return (AsP name pattern, (i, VarE name):scope) + (newPattern, scope) <- bindingPattern b + return (AsP name newPattern, (i, VarE name):scope) bindingPattern (BindVar i@(Ident s)) + | s == "_" = return (WildP, []) | all isDigit s = do return (LitP $ IntegerL $ read s, []) | otherwise = do @@ -140,7 +141,7 @@ return (ListP patterns, concat scopes) bindingPattern (BindConstr con is) = do (patterns, scopes) <- fmap unzip $ mapM bindingPattern is - return (ConP (mkConName con) patterns, concat scopes) + return (conP (mkConName con) patterns, concat scopes) bindingPattern (BindRecord con fields wild) = do let f (Ident field,b) = do (p,s) <- bindingPattern b @@ -158,6 +159,13 @@ conToStr (DCUnqualified (Ident x)) = x conToStr (DCQualified (Module xs) (Ident x)) = intercalate "." $ xs ++ [x] +conP :: Name -> [Pat] -> Pat +#if MIN_VERSION_template_haskell(2,18,0) +conP name = ConP name [] +#else +conP = ConP +#endif + -- Wildcards bind all of the unbound fields to variables whose name -- matches the field name. -- @@ -184,8 +192,8 @@ -- use 'lookupValueName' instead of just using 'mkName' so we reify the -- data constructor and not the type constructor if their names match. Just conName <- lookupValueName $ conToStr conStr - DataConI _ _ typeName _ <- reify conName - TyConI (DataD _ _ _ cons _) <- reify typeName + DataConI _ _ typeName <- reify conName + TyConI (DataD _ _ _ _ cons _) <- reify typeName [fields] <- return [fields | RecC name fields <- cons, name == conName] return [fieldName | (fieldName, _, _) <- fields] @@ -208,6 +216,22 @@ inside' <- docToExp env hr scope' (DocWith dis inside) let lam = LamE [pat] inside' return $ lam `AppE` deref' +docToExp env hr scope (DocComponent mbinding deref inside) = do + let deref' = derefToExp scope deref + case mbinding of + Just binding -> do + (pat, extraScope) <- bindingPattern binding + let scope' = extraScope ++ scope + inside' <- + hrWithEnv hr $ \env -> + docsToExp env hr scope' inside + hrEmbed hr env $ deref' `AppE` LamE [pat] inside' + Nothing -> do + inside' <- + hrWithEnv hr $ \env -> + docsToExp env hr scope inside + hrEmbed hr env $ deref' `AppE` inside' + docToExp env hr scope (DocMaybe val idents inside mno) = do let val' = derefToExp scope val (pat, extraScope) <- bindingPattern idents @@ -237,7 +261,11 @@ go (d, docs) = do let d' = derefToExp ((specialOrIdent, VarE 'or):scope) d docs' <- docsToExp env hr scope docs - return $ TupE [d', docs'] + return $ TupE +#if MIN_VERSION_template_haskell(2,16,0) + $ map Just +#endif + [d', docs'] docToExp env hr scope (DocCase deref cases) = do let exp_ = derefToExp scope deref matches <- mapM toMatch cases @@ -253,8 +281,8 @@ contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp contentToExp _ hr _ (ContentRaw s) = do - os <- [|preEscapedText . pack|] - let s' = LitE $ StringL s + os <- [|unsafeByteString|] + s' <- lift $ TE.encodeUtf8 (pack s) return $ hrFromHtml hr `AppE` (os `AppE` s') contentToExp _ hr scope (ContentVar d) = do str <- [|toHtml|] @@ -280,9 +308,18 @@ html <- [|attrsToHtml . toAttributes|] return $ hrFromHtml hr `AppE` (html `AppE` derefToExp scope d) +-- | "Simple Hamlet" quasi-quoter. May only be used to generate expressions. +-- +-- Generated expressions have type 'Html'. +-- +-- @ +-- >>> 'putStrLn' ('Text.Blaze.Html.Renderer.renderHtml' ['shamlet'|\Hello, world!|]) +-- \Hello, world!\ +-- @ shamlet :: QuasiQuoter shamlet = hamletWithSettings htmlRules defaultHamletSettings +-- | Like 'shamlet', but produces XHTML. xshamlet :: QuasiQuoter xshamlet = hamletWithSettings htmlRules xhtmlHamletSettings @@ -291,9 +328,23 @@ i <- [|id|] return $ HamletRules i ($ (Env Nothing Nothing)) (\_ b -> return b) +-- | Hamlet quasi-quoter. May only be used to generate expressions. +-- +-- Generated expression have type @'HtmlUrl' url@, for some @url@. +-- +-- @ +-- data MyRoute = Home +-- +-- render :: 'Render' MyRoute +-- render Home _ = \"/home\" +-- +-- >>> 'putStrLn' ('Text.Blaze.Html.Renderer.String.renderHtml' (['hamlet'|\Home|] render)) +-- \Home\<\/a\> +-- @ hamlet :: QuasiQuoter hamlet = hamletWithSettings hamletRules defaultHamletSettings +-- | Like 'hamlet', but produces XHTML. xhamlet :: QuasiQuoter xhamlet = hamletWithSettings hamletRules xhtmlHamletSettings @@ -318,6 +369,27 @@ urender $ \ur' -> return ((asHtmlUrl' `AppE` e) `AppE` ur') em _ _ = error "bad Env" +-- | Hamlet quasi-quoter with internationalization. May only be used to generate +-- expressions. +-- +-- Generated expressions have type @'HtmlUrlI18n' msg url@, for some @msg@ and +-- @url@. +-- +-- @ +-- data MyMsg = Hi | Bye +-- +-- data MyRoute = Home +-- +-- renderEnglish :: 'Translate' MyMsg +-- renderEnglish Hi = \"hi\" +-- renderEnglish Bye = \"bye\" +-- +-- renderUrl :: 'Render' MyRoute +-- renderUrl Home _ = \"/home\" +-- +-- >>> 'putStrLn' ('Text.Blaze.Html.Renderer.renderHtml' (['ihamlet'|@{Home} _{Hi} _{Bye}|] renderEnglish renderUrl)) +-- \/home hi bye \ +-- @ ihamlet :: QuasiQuoter ihamlet = hamletWithSettings ihamletRules defaultHamletSettings @@ -339,6 +411,12 @@ urender $ \ur' -> mrender $ \mr -> return (e `AppE` mr `AppE` ur') em _ _ = error "bad Env" +-- | Quasiquoter that follows XHTML serialization rules and supports i18n. +-- +-- @since 2.0.10 +ixhamlet :: QuasiQuoter +ixhamlet = hamletWithSettings ihamletRules xhtmlHamletSettings + hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter hamletWithSettings hr set = QuasiQuoter @@ -369,32 +447,50 @@ 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 + contents <- readFileRecompileQ fp hamletFromString qhr set contents +-- | Like 'hamlet', but reads an external file at compile time. +-- +-- @ +-- $('hamletFile' \"foo.hamlet\") :: 'HtmlUrl' MyRoute +-- @ hamletFile :: FilePath -> Q Exp hamletFile = hamletFileWithSettings hamletRules defaultHamletSettings +-- | Like 'hamletFile', but the external file is parsed at runtime. Allows for +-- more rapid development, but should not be used in production. hamletFileReload :: FilePath -> Q Exp hamletFileReload = hamletFileReloadWithSettings runtimeRules defaultHamletSettings where runtimeRules = HamletRuntimeRules { hrrI18n = False } +-- | Like 'ihamletFile', but the external file is parsed at runtime. Allows for +-- more rapid development, but should not be used in production. ihamletFileReload :: FilePath -> Q Exp ihamletFileReload = hamletFileReloadWithSettings runtimeRules defaultHamletSettings where runtimeRules = HamletRuntimeRules { hrrI18n = True } +-- | Like 'hamletFile', but produces XHTML. xhamletFile :: FilePath -> Q Exp xhamletFile = hamletFileWithSettings hamletRules xhtmlHamletSettings +-- | Like 'shamlet', but reads an external file at compile time. +-- +-- @ +-- $('shamletFile' \"foo.hamlet\") :: 'Html' +-- @ shamletFile :: FilePath -> Q Exp shamletFile = hamletFileWithSettings htmlRules defaultHamletSettings +-- | Like 'shamletFile', but produces XHTML. xshamletFile :: FilePath -> Q Exp xshamletFile = hamletFileWithSettings htmlRules xhtmlHamletSettings +-- | Like 'ihamlet', but reads an external file at compile time. +-- +-- @ +-- $('ihamletFile' \"foo.hamlet\") :: 'HtmlUrlI18n' MyMsg MyRoute +-- @ ihamletFile :: FilePath -> Q Exp ihamletFile = hamletFileWithSettings ihamletRules defaultHamletSettings @@ -476,7 +572,11 @@ vtToExp (d, vt) = do d' <- lift d c' <- toExp vt - return $ TupE [d', c' `AppE` derefToExp [] d] + return $ TupE +#if MIN_VERSION_template_haskell(2,16,0) + $ map Just +#endif + [d', c' `AppE` derefToExp [] d] where toExp = c where @@ -488,14 +588,6 @@ c VTMixin = [|\r -> EMixin $ \c -> r c|] c VTMsg = [|EMsg|] --- move to Shakespeare.Base? -readFileUtf8 :: FilePath -> IO String -readFileUtf8 fp = fmap TL.unpack $ readUtf8File fp - --- move to Shakespeare.Base? -readFileQ :: FilePath -> Q String -readFileQ fp = qRunIO $ readFileUtf8 fp - {-# NOINLINE reloadMapRef #-} reloadMapRef :: IORef (M.Map FilePath (MTime, [Content])) reloadMapRef = unsafePerformIO $ newIORef M.empty @@ -518,6 +610,7 @@ justContent (DocContent c) = c justContent DocForall{} = unsupported "$forall" justContent DocWith{} = unsupported "$with" + justContent DocComponent{} = unsupported "$component" justContent DocMaybe{} = unsupported "$maybe" justContent DocCase{} = unsupported "$case" justContent DocCond{} = unsupported "attribute conditionals" @@ -528,7 +621,7 @@ -> [(Deref, VarExp msg url)] -> Shakespeare url hamletRuntime settings fp cd render = unsafePerformIO $ do - mtime <- qRunIO $ getModified $ decodeString fp + mtime <- qRunIO $ getModificationTime fp mdata <- lookupReloadMap fp case mdata of Just (lastMtime, lastContents) -> @@ -537,7 +630,7 @@ Nothing -> fmap go' $ newContent mtime where newContent mtime = do - s <- readFileUtf8 fp + s <- readUtf8FileString fp insertReloadMap fp (mtime, contentFromString settings s) go' = mconcat . map (runtimeContentToHtml cd render (error "I18n embed IMPOSSIBLE") handleMsgEx) @@ -549,7 +642,7 @@ -> RuntimeVars msg url -> HtmlUrlI18n msg url hamletRuntimeMsg settings fp cd i18nRender render = unsafePerformIO $ do - mtime <- qRunIO $ getModified $ decodeString fp + mtime <- qRunIO $ getModificationTime fp mdata <- lookupReloadMap fp case mdata of Just (lastMtime, lastContents) -> @@ -558,14 +651,17 @@ Nothing -> fmap go' $ newContent mtime where newContent mtime = do - s <- readFileUtf8 fp + s <- readUtf8FileString fp insertReloadMap fp (mtime, contentFromString settings s) go' = mconcat . map (runtimeContentToHtml cd render i18nRender handleMsg) handleMsg d = case lookup d cd of Just (EMsg s) -> i18nRender s - _ -> error $ show d ++ ": expected EMsg for ContentMsg" + _ -> nothingError "EMsg for ContentMsg" d +nothingError :: Show a => String -> a -> b +nothingError expected d = error $ "expected " ++ expected ++ " but got Nothing for: " ++ show d + runtimeContentToHtml :: RuntimeVars msg url -> Render url -> Translate msg -> (Deref -> Html) -> Content -> Html runtimeContentToHtml cd render i18nRender handleMsg = go where @@ -584,7 +680,7 @@ case lookup d cd of Just (EUrl u) -> toHtml $ render u [] Just wrong -> error $ "expected EUrl but got: " ++ show wrong ++ "\nfor: " ++ show d - _ -> error $ "expected EUrl but got Nothing for: " ++ show d + _ -> nothingError "EUrl" d go (ContentUrl True d) = case lookup d cd of Just (EUrlParam (u, p)) -> diff --git a/Text/Hamlet/Parse.hs b/Text/Hamlet/Parse.hs --- a/Text/Hamlet/Parse.hs +++ b/Text/Hamlet/Parse.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} module Text.Hamlet.Parse ( Result (..) @@ -23,13 +25,13 @@ import Control.Applicative ((<$>), Applicative (..)) import Control.Monad import Control.Arrow -import Data.Char (isUpper) +import Data.Char (GeneralCategory(..), generalCategory, isUpper) import Data.Data import Text.ParserCombinators.Parsec hiding (Line) import Data.Set (Set) import qualified Data.Set as Set import Data.Maybe (mapMaybe, fromMaybe, isNothing) -import Language.Haskell.TH.Syntax (Lift (..)) +import Language.Haskell.TH.Syntax hiding (Module) data Result v = Error String | Ok v deriving (Show, Eq, Read, Data, Typeable) @@ -37,7 +39,10 @@ return = Ok Error s >>= _ = Error s Ok v >>= f = f v +#if MIN_VERSION_base(4,13,0) +instance MonadFail Result where fail = Error +#endif instance Functor Result where fmap = liftM instance Applicative Result where @@ -61,6 +66,7 @@ | LineNothing | LineCase Deref | LineOf Binding + | LineComponent (Maybe Binding) Deref | LineTag { _lineTagName :: String , _lineAttr :: [(Maybe Deref, String, Maybe [Content])] @@ -74,7 +80,7 @@ parseLines :: HamletSettings -> String -> Result (Maybe NewlineStyle, HamletSettings, [(Int, Line)]) parseLines set s = - case parse parser s s of + case parse parser "[Hamlet input]" s of Left e -> Error $ show e Right x -> Ok x where @@ -120,6 +126,7 @@ controlWith <|> controlCase <|> controlOf <|> + controlComponent <|> angle <|> invalidDollar <|> (eol' >> return (LineContent [] True)) <|> @@ -233,6 +240,14 @@ _ <- spaceTabs eol return $ LineOf x + controlComponent = do + _ <- try $ string "$component" + spaces + (x, b) <- (second Just <$> try binding) <|> + ((\x -> (x, Nothing)) <$> parseDeref) + _ <- spaceTabs + eol + return $ LineComponent b x content cr = do x <- many $ content' cr case cr of @@ -245,12 +260,18 @@ cc [] = [] cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c cc (a:b) = a : cc b - content' cr = contentHash <|> contentAt <|> contentCaret - <|> contentUnder - <|> contentReg' cr - contentHash = do + + content' cr = contentHash cr + <|> contentAt + <|> contentCaret + <|> contentUnder + <|> contentReg' cr + contentHash cr = do x <- parseHash case x of + Left "#" -> case cr of + NotInQuotes -> fail "Expected hash at end of line, got Id" + _ -> return (ContentRaw "#", False) Left str -> return (ContentRaw str, null str) Right deref -> return (ContentVar deref, False) contentAt = do @@ -272,7 +293,7 @@ contentReg InContent = (ContentRaw . return) <$> noneOf "#@^\r\n" contentReg NotInQuotes = (ContentRaw . return) <$> noneOf "@^#. \t\n\r>" contentReg NotInQuotesAttr = (ContentRaw . return) <$> noneOf "@^ \t\n\r>" - contentReg InQuotes = (ContentRaw . return) <$> noneOf "#@^\"\n\r" + contentReg InQuotes = (ContentRaw . return) <$> noneOf "#@^\"" tagAttribValue notInQuotes = do cr <- (char '"' >> return InQuotes) <|> return notInQuotes fst <$> content cr @@ -280,13 +301,7 @@ tagCond = do d <- between (char ':') (char ':') parseDeref tagClass (Just d) <|> tagAttrib (Just d) - tagClass x = do - clazz <- char '.' >> tagAttribValue NotInQuotes - let hasHash (ContentRaw s) = any (== '#') s - hasHash _ = False - if any hasHash clazz - then fail $ "Invalid class: " ++ show clazz ++ ". Did you want a space between a class and an ID?" - else return (TagClass (x, clazz)) + tagClass x = char '.' >> (TagClass . ((,)x)) <$> tagAttribValue NotInQuotes tagAttrib cond = do s <- many1 $ noneOf " \t=\r\n><" v <- (char '=' >> Just <$> tagAttribValue NotInQuotesAttr) <|> return Nothing @@ -306,7 +321,8 @@ ident :: Parser Ident ident = do - i <- many1 (alphaNum <|> char '_' <|> char '\'') + i <- many1 (alphaNum <|> char '_' <|> char '\'') <|> + (char '(' *> many1 (satisfy (\c -> generalCategory c == OtherPunctuation)) <* char ')') white return (Ident i) "identifier" @@ -330,7 +346,7 @@ isVariable (Ident (x:_)) = not (isUpper x) isVariable (Ident []) = error "isVariable: bad identifier" - isConstructor (Ident (x:_)) = isUpper x + isConstructor (Ident (x:_)) = isUpper x || generalCategory x == OtherPunctuation isConstructor (Ident []) = error "isConstructor: bad identifier" identPattern :: Parser Binding @@ -444,6 +460,7 @@ | DocCond [(Deref, [Doc])] (Maybe [Doc]) | DocMaybe Deref Binding [Doc] (Maybe [Doc]) | DocCase Deref [(Binding, [Doc])] + | DocComponent (Maybe Binding) Deref [Doc] | DocContent Content deriving (Show, Eq, Read, Data, Typeable) @@ -480,6 +497,10 @@ cases <- mapM getOf inside rest' <- nestToDoc set rest Ok $ DocCase d cases : rest' +nestToDoc set (Nest (LineComponent b d) inside:rest) = do + inside' <- nestToDoc set inside + rest' <- nestToDoc set rest + Ok $ DocComponent b d inside' : rest' nestToDoc set (Nest (LineTag tn attrs content classes attrsD avoidNewLine) inside:rest) = do let attrFix (x, y, z) = (x, y, [(Nothing, z)]) let takeClass (a, "class", b) = Just (a, fromMaybe [] b) @@ -540,6 +561,8 @@ DocForall d i (compressDoc doc) : compressDoc rest compressDoc (DocWith dis doc:rest) = DocWith dis (compressDoc doc) : compressDoc rest +compressDoc (DocComponent b d i:rest) = + DocComponent b d i : compressDoc rest compressDoc (DocMaybe d i doc mnothing:rest) = DocMaybe d i (compressDoc doc) (fmap compressDoc mnothing) : compressDoc rest @@ -609,41 +632,45 @@ -- | Mapping from short names in \"$doctype\" statements to full doctype. , hamletDoctypeNames :: [(String, String)] } + deriving Lift data NewlineStyle = NoNewlines -- ^ never add newlines | NewlinesText -- ^ add newlines between consecutive text lines | AlwaysNewlines -- ^ add newlines everywhere | DefaultNewlineStyle - deriving Show - -instance Lift NewlineStyle where - lift NoNewlines = [|NoNewlines|] - lift NewlinesText = [|NewlinesText|] - lift AlwaysNewlines = [|AlwaysNewlines|] - lift DefaultNewlineStyle = [|DefaultNewlineStyle|] + deriving (Show, Lift) instance Lift (String -> CloseStyle) where lift _ = [|\s -> htmlCloseStyle s|] - -instance Lift HamletSettings where - lift (HamletSettings a b c d) = [|HamletSettings $(lift a) $(lift b) $(lift c) $(lift d)|] +#if MIN_VERSION_template_haskell(2,17,0) + liftTyped = unsafeCodeCoerce . lift +#elif MIN_VERSION_template_haskell(2,16,0) + liftTyped = unsafeTExpCoerce . lift +#endif +-- See the html specification for a list of all void elements: +-- https://www.w3.org/TR/html/syntax.html#void-elements htmlEmptyTags :: Set String htmlEmptyTags = Set.fromAscList [ "area" , "base" - , "basefont" + , "basefont" -- not html 5 , "br" , "col" - , "frame" + , "embed" + , "frame" -- not html 5 , "hr" , "img" , "input" - , "isindex" + , "isindex" -- not html 5 + , "keygen" , "link" , "meta" , "param" + , "source" + , "track" + , "wbr" ] -- | Defaults settings: HTML5 doctype and HTML-style empty tags. diff --git a/Text/Hamlet/RT.hs b/Text/Hamlet/RT.hs --- a/Text/Hamlet/RT.hs +++ b/Text/Hamlet/RT.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-} --- | Most everything exported here is exported also by "Text.Hamlet". The --- exceptions to that rule should not be necessary for normal usage. +-- | Provides functionality for runtime Hamlet templates. Please use +-- "Text.Hamlet.Runtime" instead. module Text.Hamlet.RT ( -- * Public API HamletRT (..) @@ -22,20 +23,11 @@ import Data.Typeable (Typeable) import Text.Hamlet.Parse import Data.List (intercalate) -#if MIN_VERSION_blaze_html(0,5,0) import Text.Blaze.Html (Html) import Text.Blaze.Internal (preEscapedString, preEscapedText) -#else -import Text.Blaze (preEscapedString, preEscapedText, Html) -#endif import Data.Text (Text) -#if MIN_VERSION_exceptions(0,4,0) import Control.Monad.Catch (MonadThrow, throwM) -#else -import Control.Monad.Catch (MonadCatch, throwM) -#define MonadThrow MonadCatch -#endif type HamletMap url = [([String], HamletData url)] type UrlRenderer url = (url -> [(Text, Text)] -> Text) @@ -120,6 +112,7 @@ docs'' <- mapM convert docs' return (deref', docs'') convert DocWith{} = error "Runtime hamlet does not currently support $with" + convert DocComponent{} = error "Runtime hamlet does not currently support $component" convert DocCase{} = error "Runtime hamlet does not currently support $case" renderHamletRT :: MonadThrow m @@ -129,12 +122,8 @@ -> m Html renderHamletRT = renderHamletRT' False -#if MIN_VERSION_exceptions(0,4,0) renderHamletRT' :: MonadThrow m -#else -renderHamletRT' :: MonadCatch m -#endif - => Bool + => Bool -- ^ should embeded template (via ^{..}) be plain Html or actual templates? -> HamletRT -> HamletMap url -> (url -> [(Text, Text)] -> Text) @@ -190,12 +179,7 @@ renderHamletRT' tempAsHtml (HamletRT docs') scope renderUrl HDBool False -> go scope (SDCond cs els) _ -> fa $ showName b ++ ": expected HDBool" -#if MIN_VERSION_exceptions(0,4,0) - lookup' :: MonadThrow m -#else - lookup' :: MonadCatch m -#endif - => [String] -> [String] -> HamletMap url -> m (HamletData url) + lookup' :: MonadThrow m => [String] -> [String] -> HamletMap url -> m (HamletData url) lookup' orig k m = case lookup k m of Nothing | k == ["True"] -> return $ HDBool True @@ -208,11 +192,7 @@ showName :: [String] -> String showName = intercalate "." . reverse -#if MIN_VERSION_exceptions(0,4,0) flattenDeref' :: MonadThrow f => Doc -> Deref -> f [String] -#else -flattenDeref' :: MonadCatch f => Doc -> Deref -> f [String] -#endif flattenDeref' orig deref = case flattenDeref deref of Nothing -> throwM $ HamletUnsupportedDocException orig diff --git a/Text/Hamlet/Runtime.hs b/Text/Hamlet/Runtime.hs new file mode 100644 --- /dev/null +++ b/Text/Hamlet/Runtime.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- | Module for parsing and rendering Hamlet templates at runtime, not compile +-- time. This uses the same Hamlet parsing as compile-time Hamlet, but has some +-- limitations, such as: +-- +-- * No compile-time checking of validity +-- +-- * Can't apply functions at runtime +-- +-- * No URL rendering +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > import Text.Hamlet.Runtime +-- > import qualified Data.Map as Map +-- > import Text.Blaze.Html.Renderer.String (renderHtml) +-- > +-- > main :: IO () +-- > main = do +-- > template <- parseHamletTemplate defaultHamletSettings $ unlines +-- > [ "

Hello, #{name}" +-- > , "$if hungry" +-- > , "

Available food:" +-- > , "