shakespeare 2.0.1.1 → 2.2.0
raw patch · 37 files changed
Files
- ChangeLog.md +266/−0
- Text/Cassius.hs +29/−18
- Text/Cassius/Ordered.hs +98/−0
- Text/Coffee.hs +1/−1
- Text/Css.hs +0/−537
- Text/CssCommon.hs +0/−161
- Text/Hamlet.hs +137/−41
- Text/Hamlet/Parse.hs +58/−31
- Text/Hamlet/RT.hs +7/−27
- Text/Hamlet/Runtime.hs +137/−0
- Text/Internal/Cassius.hs +26/−0
- Text/Internal/Css.hs +573/−0
- Text/Internal/CssCommon.hs +162/−0
- Text/Internal/Lucius.hs +357/−0
- Text/Julius.hs +94/−14
- Text/Lucius.hs +19/−306
- Text/Lucius/Ordered.hs +121/−0
- Text/MkSizeType.hs +49/−21
- Text/Roy.hs +1/−1
- Text/Shakespeare.hs +37/−62
- Text/Shakespeare/Base.hs +70/−42
- Text/Shakespeare/I18N.hs +253/−55
- Text/Shakespeare/Text.hs +70/−7
- Text/TypeScript.hs +42/−2
- other-messages/en.msg +29/−0
- shakespeare.cabal +37/−54
- test/Text/CssSpec.hs +1566/−0
- test/Text/HamletSpec.hs +1167/−0
- test/Text/JuliusSpec.hs +205/−0
- test/Text/Shakespeare/BaseSpec.hs +33/−6
- test/Text/Shakespeare/BuilderQQ.hs +18/−0
- test/Text/Shakespeare/CssSpec.hs +0/−600
- test/Text/Shakespeare/HamletSpec.hs +0/−1068
- test/Text/Shakespeare/I18NSpec.hs +45/−4
- test/Text/Shakespeare/JsSpec.hs +0/−196
- test/Text/Shakespeare/TextSpec.hs +35/−2
- test/cassiuses/external-supports.lucius +7/−0
+ ChangeLog.md view
@@ -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+ <h1>This is the title++ $component modalBody modal+ <p>This is the content+```++Conceptually, this desugars to:++```haskell+^{ modalWidget $ \modal ->+ [whamlet|+ ^{ modalHeader modal [whamlet| <h1>This is the title |] }+ ^{ modalBody modal [whamlet| <p>This is the content |] }+ |]+ }+<p>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.
Text/Cassius.hs view
@@ -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+ }
+ Text/Cassius/Ordered.hs view
@@ -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+ }
Text/Coffee.hs view
@@ -43,7 +43,7 @@ -- -- Further reading: ----- 1. Shakespearean templates: <http://www.yesodweb.com/book/templates>+-- 1. Shakespearean templates: <https://www.yesodweb.com/book/shakespearean-templates> -- -- 2. CoffeeScript: <http://coffeescript.org/> module Text.Coffee
− Text/Css.hs
@@ -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 () ()|]
− Text/CssCommon.hs
@@ -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"
Text/Hamlet.hs view
@@ -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'|\<div\>Hello, world!|])+-- \<div\>Hello, world!\</div\>+-- @ 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'|\<a href=@{Home}\>Home|] render))+-- \<a href="\/home"\>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))+-- \<div\>/home hi bye \<div\>+-- @ 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)) ->
Text/Hamlet/Parse.hs view
@@ -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.
Text/Hamlet/RT.hs view
@@ -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
+ Text/Hamlet/Runtime.hs view
@@ -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+-- > [ "<p>Hello, #{name}"+-- > , "$if hungry"+-- > , " <p>Available food:"+-- > , " <ul>"+-- > , " $forall food <- foods"+-- > , " <li>#{food}"+-- > ]+-- > let hamletDataMap = Map.fromList+-- > [ ("name", "Michael")+-- > , ("hungry", toHamletData True) -- always True+-- > , ("foods", toHamletData+-- > [ "Apples"+-- > , "Bananas"+-- > , "Carrots"+-- > ])+-- > ]+-- > html <- renderHamletTemplate template hamletDataMap+-- > putStrLn $ renderHtml html+--+-- @since 2.0.6+module Text.Hamlet.Runtime+ ( HamletTemplate+ , HamletSettings+ , defaultHamletSettings+ , HamletData+ , ToHamletData (..)+ , parseHamletTemplate+ , readHamletTemplateFile+ , renderHamletTemplate+ ) where++import Control.Arrow ((***))+import Control.Monad.Catch (MonadThrow)+import Text.Hamlet (HamletSettings, defaultHamletSettings)+import qualified Text.Hamlet.RT as RT+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import Data.String+import Text.Blaze.Html (Html, toHtml)+import Control.Monad (liftM)+import Control.Monad.IO.Class+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import qualified Data.ByteString as S+import qualified Data.Text as T++-- Just to skip a dependency for GHC < 7.10+data Void+absurd :: Void -> a+absurd _ = error "absurd"++-- | A parsed Hamlet template. See 'parseHamletTemplate' and+-- 'readHamletTemplateFile'.+--+-- @since 2.0.6+newtype HamletTemplate = HamletTemplate RT.HamletRT++-- | A piece of data that can be embedded and passed to a Hamlet template (via+-- 'renderHamletTemplate').+--+-- This supplies an 'IsString' instance, so with @OverloadedStrings@ it will+-- support literal strings, which are converted to HTML via 'toHtml'. For other+-- datatypes, use 'toHamletData'.+--+-- @since 2.0.6+newtype HamletData = HamletData { unHamletData :: RT.HamletData Void }+instance IsString HamletData where+ fromString = HamletData . RT.HDHtml . fromString++-- | Data which can be passed to a Hamlet template.+--+-- @since 2.0.6+class ToHamletData a where+ toHamletData :: a -> HamletData+instance ToHamletData HamletData where+ toHamletData = id+instance a ~ HamletData => ToHamletData [a] where+ toHamletData = HamletData . RT.HDList . map (\x -> [([], unHamletData x)])+instance a ~ HamletData => ToHamletData (Maybe a) where+ toHamletData = HamletData . RT.HDMaybe . fmap (\x -> [([], unHamletData x)])+instance ToHamletData Text where+ toHamletData = toHamletData . toHtml+instance ToHamletData Html where+ toHamletData = HamletData . RT.HDHtml+instance ToHamletData Bool where+ toHamletData = HamletData . RT.HDBool++-- | Parse an in-memory Hamlet template. This operation may fail if the+-- template is not parsable.+--+-- @since 2.0.6+parseHamletTemplate :: MonadThrow m => HamletSettings -> String -> m HamletTemplate+parseHamletTemplate set str = HamletTemplate `liftM` RT.parseHamletRT set str++-- | Same as 'parseHamletTemplate', but reads from a file. The file is assumed+-- to be UTF-8 encoded (same assumption as compile-time Hamlet).+--+-- @since 2.0.6+readHamletTemplateFile :: (MonadThrow m, MonadIO m) => HamletSettings -> FilePath -> m HamletTemplate+readHamletTemplateFile set fp = do+ bs <- liftIO $ S.readFile fp+ parseHamletTemplate set $ T.unpack $ decodeUtf8With lenientDecode bs++-- | Render a runtime Hamlet template, together with a 'Map' of variables to+-- pass in, into an 'Html' value. This can fail if the template references a+-- variable that is not present in the @Map@.+--+-- @since 2.0.6+renderHamletTemplate :: MonadThrow m => HamletTemplate -> Map Text HamletData -> m Html+renderHamletTemplate (HamletTemplate rt) m =+ RT.renderHamletRT' True rt m' renderUrl+ where+ m' = map (return . T.unpack *** unHamletData) $ Map.toList m+ renderUrl url _ = absurd url
+ Text/Internal/Cassius.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.Internal.Cassius (i2bMixin) where++import qualified Data.Text.Lazy as TL+import Text.IndentToBrace (i2b)++i2bMixin :: String -> String+i2bMixin s' =+ TL.unpack+ $ stripEnd "}"+ $ stripFront "mixin {"+ $ TL.strip+ $ TL.pack+ $ i2b+ $ unlines+ $ "mixin" : (map (" " ++) $ lines s')+ where+ stripFront x y =+ case TL.stripPrefix x y of+ Nothing -> y+ Just z -> z+ stripEnd x y =+ case TL.stripSuffix x y of+ Nothing -> y+ Just z -> z
+ Text/Internal/Css.hs view
@@ -0,0 +1,573 @@+{-# OPTIONS_HADDOCK hide #-}+-- | This module is only being exposed to work around a GHC bug, its API is not stable++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE EmptyDataDecls #-}+module Text.Internal.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.Semigroup (Semigroup(..))+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 (..))++type CssUrl url = (url -> [(T.Text, T.Text)] -> T.Text) -> Css++type DList a = [a] -> [a]++data Resolved = Resolved | Unresolved++-- Should mixins keep order (new version) or not (deprecated version)+data Order = Ordered | Unordered deriving (Lift)++type HasLeadingSpace = Bool++type family Str (a :: Resolved)+type instance Str 'Resolved = Builder+type instance Str 'Unresolved = Contents++data Block (a :: Resolved) where+ BlockResolved :: + { brSelectors :: !Builder+ , brAttrs :: ![Attr 'Resolved]+ } -> Block 'Resolved+ BlockUnresolved ::+ { buSelectors :: ![Contents]+ , buAttrsAndMixins :: ![Either (Attr 'Unresolved) Deref]+ , buBlocks :: ![(HasLeadingSpace, Block 'Unresolved)]+ } -> Block 'Unresolved++data Mixin = Mixin+ { mixinAttrs :: ![Attr 'Resolved]+ , mixinBlocks :: ![(HasLeadingSpace, Block 'Resolved)]+ }+ deriving Lift+instance Semigroup Mixin where+ Mixin a x <> Mixin b y = Mixin (a ++ b) (x ++ y)+instance Monoid Mixin where+ mempty = Mixin mempty mempty++data TopLevel (a :: Resolved) 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 :: Resolved) where+ AttrResolved ::+ { attrResKey :: !Builder+ , attrResVal :: !Builder+ } -> Attr 'Resolved+ AttrUnresolved ::+ { attrUnresKey :: !Contents+ , attrUnresVal :: !Contents+ } -> Attr 'Unresolved++data Css = CssWhitespace ![TopLevel 'Resolved]+ | CssNoWhitespace ![TopLevel 'Resolved]++data Content = ContentRaw String+ | ContentVar Deref+ | ContentUrl Deref+ | ContentUrlParam Deref+ | ContentMixin Deref+ deriving (Show, Eq, Lift)++type Contents = [Content]++data CDData url = CDPlain Builder+ | CDUrl url+ | CDUrlParam (url, [(Text, Text)])+ | CDMixin Mixin++pack :: String -> Text+pack = T.pack++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 $ either error id $ 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 (BlockUnresolved x y z):rest) =+ (scope1 ++ scope2, rest0 ++ rest1 ++ rest2)+ where+ rest0 = intercalate [ContentRaw ","] x ++ concatMap go' y+ (scope1, rest1) = go (map (TopBlock . snd) z)+ (scope2, rest2) = go rest+ go (TopVar k v:rest) =+ ((k, v):scope, rest')+ where+ (scope, rest') = go rest+ go' :: Either (Attr 'Unresolved) Deref -> [Content]+ go' (Left (AttrUnresolved k v)) = k ++ (v :: [Content])+ go' (Right m) = [ContentMixin m]++cssFileDebug :: Bool -- ^ perform the indent-to-brace conversion+ -> Q Exp+ -> Parser [TopLevel 'Unresolved]+ -> FilePath+ -> Q Exp+cssFileDebug toi2b parseBlocks' parseBlocks fp = do+ s <- readFileQ fp+ 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++runtimePrependSelector :: Builder -> (HasLeadingSpace, Block 'Resolved) -> Block 'Resolved+runtimePrependSelector builder (hsl, BlockResolved x b) =+ BlockResolved (builder <> addSpace x) b+ where+ addSpace = if hsl then (TLB.singleton ' ' <>) else id++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' (BlockUnresolved x attrsAndMixins z) = do+ x' <- mapM go' $ intercalate [ContentRaw ","] x+ attrs' <- mapM (either resolveAttr getMixinAttrs) attrsAndMixins+ blocks' <- mapM (either (const $ Right []) getMixinBlocks) attrsAndMixins+ z' <- mapM (subGo x) z -- FIXME use difflists again+ Right $ \rest -> BlockResolved+ { brSelectors = mconcat x'+ , brAttrs = concat attrs'+ }+ : map (runtimePrependSelector $ mconcat x') (concat blocks')+ ++ 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 :: Deref -> Either String Mixin+ 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"++ getMixinAttrs :: Deref -> Either String [Attr 'Resolved]+ getMixinAttrs = fmap mixinAttrs . getMixin++ getMixinBlocks :: Deref -> Either String [(HasLeadingSpace, Block 'Resolved)]+ getMixinBlocks = fmap mixinBlocks . getMixin++ resolveAttr :: Attr 'Unresolved -> Either String [Attr 'Resolved]+ resolveAttr (AttrUnresolved k v) =+ let eAttr = AttrResolved <$> (mconcat <$> mapM go' k) <*> (mconcat <$> mapM go' v)+ in fmap (:[]) eAttr++ subGo :: [Contents] -- ^ parent selectors+ -> (HasLeadingSpace, Block 'Unresolved)+ -> Either String (DList (Block 'Resolved))+ subGo x' (hls, BlockUnresolved a b c) =+ let a' = combineSelectors hls x' a+ in blockRuntime cd render' (BlockUnresolved a' b c)++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' <- readUtf8FileString 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+#if MIN_VERSION_template_haskell(2,16,0)+ $ map Just+#endif+ [d', c' `AppE` derefToExp [] d]+ where+ c :: VarType -> Q Exp+ c VTPlain = [|CDPlain . toCss|]+ c VTUrl = [|CDUrl|]+ c VTUrlParam = [|CDUrlParam|]+ c VTMixin = [|CDMixin|]++getVars :: [(String, String)] -> Content -> Either String [(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 -> Left $ "Expected URL for " ++ s+getVars scope (ContentUrlParam d) =+ case lookupD d scope of+ Nothing -> return [(d, VTUrlParam)]+ Just s -> Left $ "Expected URLParam for " ++ s+getVars scope (ContentMixin d) =+ case lookupD d scope of+ Nothing -> return [(d, VTMixin)]+ Just s -> Left $ "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 (BlockUnresolved x y blocks) =+ BlockUnresolved (map cc x) (map go y) (map (second compressBlock) blocks)+ where+ go :: Either (Attr 'Unresolved) Deref -> Either (Attr 'Unresolved) Deref+ go (Left (AttrUnresolved k v)) = Left $ AttrUnresolved (cc k) (cc v)+ go (Right m) = Right m+ cc :: Contents -> Contents+ 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 (BlockUnresolved _sel props subblocks) =+ -- TODO: preserve the CPS in @mixinBlocks@ below+ [| let attrsAndMixins = $(processAttrsAndDerefs r scope props)+ in Mixin+ { mixinAttrs =+ concatMap (either (:[]) mixinAttrs) attrsAndMixins+ , mixinBlocks =+ concat $+ $(listE $ map subGo subblocks)+ ++ map (either (const []) mixinBlocks) attrsAndMixins+ }+ |]+ where+ -- We don't use the @hls@ to combine selectors, because the parent+ -- selector for a mixin is the dummy @mixin@ selector. But we may want+ -- to know later if the block needs a leading space, because the mixin+ -- might include an @&@ which needs to mix correctly with the parent+ -- block's selector.+ subGo (hls, BlockUnresolved sel' b c) =+ [| map (\x -> ($(lift hls), x))+ $ $(blockToCss r scope $ BlockUnresolved sel' b c) []+ |]+ +blockToCss :: Name+ -> Scope+ -> Block 'Unresolved+ -> ExpQ+blockToCss r scope (BlockUnresolved sel props subblocks) =+ [| let attrsAndMixins = $(processAttrsAndDerefs r scope props)+ selToBuilder = $(selectorToBuilder r scope sel)+ in ( BlockResolved+ { brSelectors = selToBuilder+ , brAttrs = concatMap (either (:[]) mixinAttrs) attrsAndMixins+ }:)+ . foldr (.) id $(listE $ map subGo subblocks)+ . (fmap+ (runtimePrependSelector selToBuilder)+ (concatMap (either (const []) mixinBlocks) attrsAndMixins) ++)+ |]+ where+ subGo :: (HasLeadingSpace, Block 'Unresolved) -> Q Exp+ subGo (hls, BlockUnresolved sel' b c) =+ let sel'' = combineSelectors hls sel sel'+ in blockToCss r scope $ BlockUnresolved sel'' b c+++processAttrsAndDerefs ::+ Name+ -> Scope+ -> [Either (Attr 'Unresolved) Deref]+ -> Q Exp -- ^ Either (Attr 'Resolved) Mixin+processAttrsAndDerefs r scope props = listE $ map go props+ where+ go (Right deref) = pure $ ConE 'Right `AppE` (derefToExp [] deref)+ go (Left (AttrUnresolved x y)) =+ conE 'Left `appE`+ ( conE 'AttrResolved+ `appE` (contentsToBuilder r scope x)+ `appE` (contentsToBuilder r scope y)+ )++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 (BlockResolved sel attrs)+ | null attrs = mempty+ | otherwise = startSelect+ <> sel+ <> startBlock+ <> mconcat (intersperse endDecl $ map renderAttr attrs)+ <> endBlock+ where+ renderAttr (AttrResolved 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 (Attr a) where+ lift = \case+ AttrResolved k v -> [|AttrResolved $(liftBuilder k) $(liftBuilder v)|]+ AttrUnresolved k v -> [|AttrUnresolved k v|]+#if MIN_VERSION_template_haskell(2,17,0)+ liftTyped = unsafeCodeCoerce . lift+#elif MIN_VERSION_template_haskell(2,16,0)+ liftTyped = unsafeTExpCoerce . lift+#endif++#if MIN_VERSION_template_haskell(2,17,0)+liftBuilder :: Quote m => Builder -> m Exp+#else+liftBuilder :: Builder -> Q Exp+#endif+liftBuilder b = [|fromText $ pack $(lift $ TL.unpack $ toLazyText b)|]++instance Lift (Block a) where+ lift = \case+ BlockResolved a b -> [|BlockResolved $(liftBuilder a) b|]+ BlockUnresolved a b c -> [|BlockUnresolved a b c|]+#if MIN_VERSION_template_haskell(2,17,0)+ liftTyped = unsafeCodeCoerce . lift+#elif MIN_VERSION_template_haskell(2,16,0)+ liftTyped = unsafeTExpCoerce . lift+#endif
+ Text/Internal/CssCommon.hs view
@@ -0,0 +1,162 @@+{-# OPTIONS_HADDOCK hide #-}+-- | This module is only being exposed to work around a GHC bug, its API is not stable++{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+module Text.Internal.CssCommon where++import Text.Internal.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 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"
+ Text/Internal/Lucius.hs view
@@ -0,0 +1,357 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}++module Text.Internal.Lucius where++import Text.Shakespeare.Base+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax+import Data.Text (Text, unpack)+import qualified Data.Text.Lazy as TL+import Text.ParserCombinators.Parsec hiding (Line)+import Text.Internal.Css+import Data.Char (isSpace, toLower, toUpper)+import Numeric (readHex)+import Control.Monad (when, unless)+import Data.List (isSuffixOf)+import Control.Arrow (second)+import Text.Shakespeare (VarType)++luciusWithOrder :: Order -> QuasiQuoter+luciusWithOrder order = QuasiQuoter { quoteExp = luciusFromString order}++luciusFromString :: Order -> String -> Q Exp+luciusFromString order s =+ topLevelsToCassius+ $ either (error . show) id $ parse (parseTopLevels order) s s++whiteSpace :: Parser ()+whiteSpace = many whiteSpace1 >> return ()++whiteSpace1 :: Parser ()+whiteSpace1 =+ ((oneOf " \t\n\r" >> return ()) <|> (parseComment >> return ()))++parseBlock :: Order -> Parser (Block 'Unresolved)+parseBlock order = do+ sel <- parseSelector+ _ <- char '{'+ whiteSpace+ pairsBlocks <- parsePairsBlocks order id+ let (attrs, blocks) = partitionPBs order pairsBlocks+ whiteSpace+ return $ BlockUnresolved sel attrs (map detectAmp blocks)++-- | Looks for an & at the beginning of a selector and, if present, indicates+-- that we should not have a leading space. Otherwise, we should have the+-- leading space.+detectAmp :: Block 'Unresolved -> (Bool, Block 'Unresolved)+detectAmp (BlockUnresolved (sel) b c) =+ (hls, BlockUnresolved sel' b c)+ where+ (hls, sel') =+ case sel of+ (ContentRaw "&":rest):others -> (False, rest : others)+ (ContentRaw ('&':s):rest):others -> (False, (ContentRaw s : rest) : others)+ _ -> (True, sel)++partitionPBs ::+ Order+ -> [PairBlock]+ -> ([Either (Attr 'Unresolved) Deref], [Block 'Unresolved])+partitionPBs order = go id id id+ where+ -- We append the unordered legacy mixins 'c' to the end of the ordered list 'a'+ go a b c [] = (a $ c [], b [])+ go a b c (PBAttr x:xs) = go (a . ((Left x):)) b c xs+ go a b c (PBBlock x:xs) = go a (b . (x:)) c xs+ go a b c (PBMixin x:xs) = case order of+ -- If we are interested in order, then we collect attributes and mixins in one list 'a'.+ Ordered -> go (a . ((Right x):)) b c xs+ -- Otherwise (legacy style) we collect mixins in a separate list 'c'.+ Unordered -> go a b (c . (Right x:)) xs++parseSelector :: Parser [Contents]+parseSelector =+ go id+ where+ go front = do+ c <- parseContents "{,"+ let front' = front . (:) (trim c)+ (char ',' >> go front') <|> return (front' [])++trim :: Contents -> Contents+trim =+ reverse . trim' False . reverse . trim' True+ where+ trim' _ [] = []+ trim' b (ContentRaw s:rest) =+ let s' = trimS b s+ in if null s' then trim' b rest else ContentRaw s' : rest+ trim' _ x = x+ trimS True = dropWhile isSpace+ trimS False = reverse . dropWhile isSpace . reverse++data PairBlock = PBAttr (Attr 'Unresolved)+ | PBBlock (Block 'Unresolved)+ | PBMixin Deref+parsePairsBlocks :: Order -> ([PairBlock] -> [PairBlock]) -> Parser [PairBlock]+parsePairsBlocks order front = (char '}' >> return (front [])) <|> (do+ isBlock <- lookAhead checkIfBlock+ x <- grabMixin <|> (if isBlock then grabBlock else grabPair)+ parsePairsBlocks order $ front . (:) x)+ where+ grabBlock = do+ b <- parseBlock order+ whiteSpace+ return $ PBBlock b+ grabPair = PBAttr <$> parsePair+ grabMixin = try $ do+ whiteSpace+ Right x <- parseCaret+ whiteSpace+ (char ';' >> return ()) <|> return ()+ whiteSpace+ return $ PBMixin x+ checkIfBlock = do+ skipMany $ noneOf "#@{};"+ (parseHash >> checkIfBlock)+ <|> (parseAt >> checkIfBlock)+ <|> (char '{' >> return True)+ <|> (oneOf ";}" >> return False)+ <|> (anyChar >> checkIfBlock)+ <|> fail "checkIfBlock"++parsePair :: Parser (Attr 'Unresolved)+parsePair = do+ key <- parseContents ":"+ _ <- char ':'+ whiteSpace+ val <- parseContents ";}"+ (char ';' >> return ()) <|> return ()+ whiteSpace+ return $ AttrUnresolved key val++parseContents :: String -> Parser Contents+parseContents = many1 . parseContent++parseContent :: String -> Parser Content+parseContent restricted =+ parseHash' <|> parseAt' <|> parseComment <|> parseBack <|> parseChar+ where+ parseHash' = either ContentRaw ContentVar `fmap` parseHash+ parseAt' =+ either ContentRaw go `fmap` parseAt+ where+ go (d, False) = ContentUrl d+ go (d, True) = ContentUrlParam d+ parseBack = try $ do+ _ <- char '\\'+ hex <- atMost 6 $ satisfy isHex+ (int, _):_ <- return $ readHex $ dropWhile (== '0') hex+ when (length hex < 6) $+ ((string "\r\n" >> return ()) <|> (satisfy isSpace >> return ()))+ return $ ContentRaw [toEnum int]+ parseChar = (ContentRaw . return) `fmap` noneOf restricted++isHex :: Char -> Bool+isHex c =+ ('0' <= c && c <= '9') ||+ ('A' <= c && c <= 'F') ||+ ('a' <= c && c <= 'f')++atMost :: Int -> Parser a -> Parser [a]+atMost 0 _ = return []+atMost i p = (do+ c <- p+ s <- atMost (i - 1) p+ return $ c : s) <|> return []++parseComment :: Parser Content+parseComment = do+ _ <- try $ string "/*"+ _ <- manyTill anyChar $ try $ string "*/"+ return $ ContentRaw ""++luciusFileWithOrd :: Order -> FilePath -> Q Exp+luciusFileWithOrd order fp = do+ contents <- readFileRecompileQ fp+ luciusFromString order contents++luciusFileDebugWithOrder :: Order -> FilePath -> Q Exp+luciusFileDebugWithOrder order =+ cssFileDebug False [|parseTopLevels order|] (parseTopLevels order)++parseTopLevels :: Order -> Parser [TopLevel 'Unresolved]+parseTopLevels order =+ go id+ where+ go front = do+ let string' s = string s >> return ()+ ignore = many (whiteSpace1 <|> string' "<!--" <|> string' "-->")+ >> return ()+ ignore+ tl <- ((charset <|> media <|> impor <|> supports <|> topAtBlock <|> var <|> fmap TopBlock (parseBlock order)) >>= \x -> go (front . (:) x))+ <|> (return $ map compressTopLevel $ front [])+ ignore+ return tl+ charset = do+ try $ stringCI "@charset "+ cs <- parseContents ";"+ _ <- char ';'+ return $ TopAtDecl "charset" cs+ media = do+ try $ stringCI "@media "+ selector <- parseContents "{"+ _ <- char '{'+ b <- parseBlocks id+ return $ TopAtBlock "media" selector b+ impor = do+ try $ stringCI "@import ";+ val <- parseContents ";"+ _ <- char ';'+ return $ TopAtDecl "import" val+ supports = do+ try $ stringCI "@supports "+ selector <- parseContents "{"+ _ <- char '{'+ b <- parseBlocks id+ return $ TopAtBlock "supports" selector b+ var = try $ do+ _ <- char '@'+ isPage <- (try $ string "page " >> return True) <|>+ (try $ string "font-face " >> return True) <|>+ return False+ when isPage $ fail "page is not a variable"+ k <- many1 $ noneOf ":"+ _ <- char ':'+ v <- many1 $ noneOf ";"+ _ <- char ';'+ let trimS = reverse . dropWhile isSpace . reverse . dropWhile isSpace+ return $ TopVar (trimS k) (trimS v)+ topAtBlock = do+ (name, selector) <- try $ do+ _ <- char '@'+ name <- many1 $ noneOf " \t"+ _ <- many1 $ oneOf " \t"+ unless ("keyframes" `isSuffixOf` name) $ fail "only accepting keyframes"+ selector <- parseContents "{"+ _ <- char '{'+ return (name, selector)+ b <- parseBlocks id+ return $ TopAtBlock name selector b+ parseBlocks front = do+ whiteSpace+ (char '}' >> return (map compressBlock $ front []))+ <|> ((parseBlock order) >>= \x -> parseBlocks (front . (:) x))++stringCI :: String -> Parser ()+stringCI [] = return ()+stringCI (c:cs) = (char (toLower c) <|> char (toUpper c)) >> stringCI cs++luciusRTWithOrder'::+ Order -- ^ Should we keep attributes and mixins order or not+ -> TL.Text+ -> Either String ([(Text, Text)] -> Either String [TopLevel 'Resolved])+luciusRTWithOrder' order =+ either Left (Right . go) . luciusRTInternal order+ where+ go :: ([(Text, RTValue)] -> Either String [TopLevel 'Resolved])+ -> ([(Text, Text)] -> Either String [TopLevel 'Resolved])+ go f = f . map (second RTVRaw)++luciusRTInternal ::+ Order+ -> TL.Text+ -> Either String ([(Text, RTValue)]+ -> Either String [TopLevel 'Resolved])+luciusRTInternal order tl =+ case parse (parseTopLevels order) (TL.unpack tl) (TL.unpack tl) of+ Left s -> Left $ show s+ Right tops -> Right $ \scope -> go scope tops+ where+ go :: [(Text, RTValue)]+ -> [TopLevel 'Unresolved]+ -> Either String [TopLevel 'Resolved]+ go _ [] = Right []+ go scope (TopAtDecl dec cs':rest) = do+ let scope' = map goScope scope+ render = error "luciusRT has no URLs"+ cs <- mapM (contentToBuilderRT scope' render) cs'+ rest' <- go scope rest+ Right $ TopAtDecl dec (mconcat cs) : rest'+ go scope (TopBlock b:rest) = do+ b' <- goBlock scope b+ rest' <- go scope rest+ Right $ map TopBlock b' ++ rest'+ go scope (TopAtBlock name m' bs:rest) = do+ let scope' = map goScope scope+ render = error "luciusRT has no URLs"+ m <- mapM (contentToBuilderRT scope' render) m'+ bs' <- mapM (goBlock scope) bs+ rest' <- go scope rest+ Right $ TopAtBlock name (mconcat m) (concat bs') : rest'+ go scope (TopVar k v:rest) = go ((pack k, RTVRaw $ pack v):scope) rest++ goBlock :: [(Text, RTValue)]+ -> Block 'Unresolved+ -> Either String [Block 'Resolved]+ goBlock scope =+ either Left (Right . ($ [])) . blockRuntime scope' (error "luciusRT has no URLs")+ where+ scope' = map goScope scope++ goScope (k, rt) =+ (DerefIdent (Ident $ unpack k), cd)+ where+ cd =+ case rt of+ RTVRaw t -> CDPlain $ fromText t+ RTVMixin m -> CDMixin m++luciusRTWithOrder :: Order -> TL.Text -> [(Text, Text)] -> Either String TL.Text+luciusRTWithOrder order tl scope =+ either Left (Right . renderCss . CssWhitespace) $ either Left ($ scope) (luciusRTWithOrder' order tl)++luciusRTMixinWithOrder ::+ Order+ -> TL.Text -- ^ template+ -> Bool -- ^ minify?+ -> [(Text, RTValue)] -- ^ scope+ -> Either String TL.Text+luciusRTMixinWithOrder order tl minify scope =+ either Left (Right . renderCss . cw) $ either Left ($ scope) (luciusRTInternal order tl)+ where+ cw | minify = CssNoWhitespace+ | otherwise = CssWhitespace++data RTValue = RTVRaw Text+ | RTVMixin Mixin++luciusRTMinifiedWithOrder :: Order -> TL.Text -> [(Text, Text)] -> Either String TL.Text+luciusRTMinifiedWithOrder order tl scope =+ either Left (Right . renderCss . CssNoWhitespace) $ either Left ($ scope) (luciusRTWithOrder' order tl)++-- | Determine which identifiers are used by the given template, useful for+-- creating systems like yesod devel.+luciusUsedIdentifiers :: Order -> String -> [(Deref, VarType)]+luciusUsedIdentifiers order = cssUsedIdentifiers False (parseTopLevels order)++luciusMixinWithOrder :: Order -> QuasiQuoter+luciusMixinWithOrder order = QuasiQuoter { quoteExp = luciusMixinFromString order}++luciusMixinFromString :: Order -> String -> Q Exp+luciusMixinFromString order s' = do+ r <- newName "_render"+ case fmap compressBlock $ parse (parseBlock order) s s of+ Left e -> error $ show e+ Right block -> blockToMixin r [] block+ where+ s = concat ["mixin{", s', "}"]
Text/Julius.hs view
@@ -1,14 +1,16 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- | A Shakespearean module for Javascript templates, introducing type-safe, -- compile-time variable and url interpolation.-- -- -- You might consider trying 'Text.Typescript' or 'Text.Coffee' which compile down to Javascript. ----- Further reading: <http://www.yesodweb.com/book/templates>+-- Further reading: <http://www.yesodweb.com/book/shakespearean-templates> module Text.Julius ( -- * Functions -- ** Template-Reading Functions@@ -46,12 +48,23 @@ import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText)-import Data.Monoid+import Data.Monoid (Monoid(..))+import Data.Semigroup (Semigroup(..)) import qualified Data.Text as TS import qualified Data.Text.Lazy as TL import Text.Shakespeare-import Data.Aeson (Value)-import Data.Aeson.Encode (fromValue)+import Data.Aeson (Value, toJSON)+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+#endif+import Data.Aeson.Types (Value(..))+import Numeric (showHex)+import qualified Data.HashMap.Strict as H+import qualified Data.Vector as V+import Data.Text.Lazy.Builder (singleton, fromString)+import qualified Data.Text as T+import Data.Scientific (FPFormat(..), Scientific, base10Exponent)+import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder) renderJavascript :: Javascript -> TL.Text renderJavascript (Javascript b) = toLazyText b@@ -68,7 +81,7 @@ -- | Newtype wrapper of 'Builder'. newtype Javascript = Javascript { unJavascript :: Builder }- deriving Monoid+ deriving (Semigroup, Monoid) -- | Return type of template-reading functions. type JavascriptUrl url = (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Javascript@@ -79,15 +92,82 @@ -- | A typeclass for types that can be interpolated in CoffeeScript templates. class ToJavascript a where toJavascript :: a -> Javascript-#if 0-instance ToJavascript [Char] where toJavascript = Javascript . fromLazyText . TL.pack-instance ToJavascript TS.Text where toJavascript = Javascript . fromText-instance ToJavascript TL.Text where toJavascript = Javascript . fromLazyText-instance ToJavascript Javascript where toJavascript = Javascript . unJavascript-instance ToJavascript Builder where toJavascript = Javascript-#endif+ instance ToJavascript Bool where toJavascript = Javascript . fromText . TS.toLower . TS.pack . show-instance ToJavascript Value where toJavascript = Javascript . fromValue+instance ToJavascript Value where toJavascript = Javascript . encodeToTextBuilder+instance ToJavascript String where toJavascript = toJavascript . toJSON+instance ToJavascript TS.Text where toJavascript = toJavascript . toJSON+instance ToJavascript TL.Text where toJavascript = toJavascript . toJSON++-- | Encode a JSON 'Value' to a "Data.Text" 'Builder', which can be+-- embedded efficiently in a text-based protocol.+--+-- If you are going to immediately encode straight to a+-- 'L.ByteString', it is more efficient to use 'encodeToBuilder'+-- instead.+encodeToTextBuilder :: Value -> Builder+encodeToTextBuilder =+ go+ where+ go Null = {-# SCC "go/Null" #-} "null"+ go (Bool b) = {-# SCC "go/Bool" #-} if b then "true" else "false"+ go (Number s) = {-# SCC "go/Number" #-} fromScientific s+ go (String s) = {-# SCC "go/String" #-} string s+ go (Array v)+ | V.null v = {-# SCC "go/Array" #-} "[]"+ | otherwise = {-# SCC "go/Array" #-}+ singleton '[' <>+ go (V.unsafeHead v) <>+ V.foldr f (singleton ']') (V.unsafeTail v)+ where f a z = singleton ',' <> go a <> z+ go (Object m) = {-# SCC "go/Object" #-}+ case fromObject m of+ (x:xs) -> singleton '{' <> one x <> foldr f (singleton '}') xs+ _ -> "{}"+ where f a z = singleton ',' <> one a <> z+ one (k,v) = string k <> singleton ':' <> go v++#if MIN_VERSION_aeson(2,0,0)+ fromObject = H.toList . KeyMap.toHashMapText+#else+ fromObject = H.toList+#endif++string :: T.Text -> Builder+string s = {-# SCC "string" #-} singleton '"' <> quote s <> singleton '"'+ where+ quote q = case T.uncons t of+ Nothing -> fromText h+ Just (!c,t') -> fromText h <> escape c <> quote t'+ where (h,t) = {-# SCC "break" #-} T.break isEscape q+ isEscape c = c == '\"' ||+ c == '\'' ||+ c == '\\' ||+ c == '<' ||+ c == '>' ||+ c == '&' ||+ c < '\x20'+ escape '\"' = "\\\""+ escape '\'' = "\\\'"+ escape '\\' = "\\\\"+ escape '\n' = "\\n"+ escape '\r' = "\\r"+ escape '\t' = "\\t"+ escape '<' = "\\u003c"+ escape '>' = "\\u003e"+ escape '&' = "\\u0026"++ escape c+ | c < '\x20' = fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h+ | otherwise = singleton c+ where h = showHex (fromEnum c) ""++fromScientific :: Scientific -> Builder+fromScientific s = formatScientificBuilder format prec s+ where+ (format, prec)+ | base10Exponent s < 0 = (Generic, Nothing)+ | otherwise = (Fixed, Just 0) newtype RawJavascript = RawJavascript Builder instance ToJavascript RawJavascript where
Text/Lucius.hs view
@@ -1,9 +1,10 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Lucius@@ -50,306 +51,39 @@ , luciusUsedIdentifiers ) where -import Text.CssCommon-import Text.Shakespeare.Base+import Text.Internal.CssCommon+import Text.Internal.Lucius import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax-import Data.Text (Text, unpack)+import Data.Text (Text) import qualified Data.Text.Lazy as TL-import Text.ParserCombinators.Parsec hiding (Line)-import Text.Css-import Data.Char (isSpace, toLower, toUpper)-import Numeric (readHex)-import Control.Applicative ((<$>))-import Control.Monad (when, unless)-import Data.Monoid (mconcat)-import Data.List (isSuffixOf)-import Control.Arrow (second)-import Text.Shakespeare (VarType)+import Text.Internal.Css -- | -- -- >>> 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 ()--whiteSpace1 :: Parser ()-whiteSpace1 =- ((oneOf " \t\n\r" >> return ()) <|> (parseComment >> return ()))--parseBlock :: Parser (Block Unresolved)-parseBlock = do- sel <- parseSelector- _ <- char '{'- whiteSpace- pairsBlocks <- parsePairsBlocks id- let (pairs, blocks, mixins) = partitionPBs pairsBlocks- whiteSpace- return $ Block sel pairs (map detectAmp blocks) mixins---- | Looks for an & at the beginning of a selector and, if present, indicates--- that we should not have a leading space. Otherwise, we should have the--- leading space.-detectAmp :: Block Unresolved -> (Bool, Block Unresolved)-detectAmp (Block (sel) b c d) =- (hls, Block sel' b c d)- where- (hls, sel') =- case sel of- (ContentRaw "&":rest):others -> (False, rest : others)- (ContentRaw ('&':s):rest):others -> (False, (ContentRaw s : rest) : others)- _ -> (True, sel)--partitionPBs :: [PairBlock] -> ([Attr Unresolved], [Block Unresolved], [Deref])-partitionPBs =- go id id id- where- go a b c [] = (a [], b [], c [])- go a b c (PBAttr x:xs) = go (a . (x:)) b c xs- go a b c (PBBlock x:xs) = go a (b . (x:)) c xs- go a b c (PBMixin x:xs) = go a b (c . (x:)) xs--parseSelector :: Parser (Selector Unresolved)-parseSelector =- go id- where- go front = do- c <- parseContents "{,"- let front' = front . (:) (trim c)- (char ',' >> go front') <|> return (front' [])--trim :: Contents -> Contents-trim =- reverse . trim' False . reverse . trim' True- where- trim' _ [] = []- trim' b (ContentRaw s:rest) =- let s' = trimS b s- in if null s' then trim' b rest else ContentRaw s' : rest- trim' _ x = x- trimS True = dropWhile isSpace- trimS False = reverse . dropWhile isSpace . reverse--data PairBlock = PBAttr (Attr Unresolved)- | PBBlock (Block Unresolved)- | PBMixin Deref-parsePairsBlocks :: ([PairBlock] -> [PairBlock]) -> Parser [PairBlock]-parsePairsBlocks front = (char '}' >> return (front [])) <|> (do- isBlock <- lookAhead checkIfBlock- x <- grabMixin <|> (if isBlock then grabBlock else grabPair)- parsePairsBlocks $ front . (:) x)- where- grabBlock = do- b <- parseBlock- whiteSpace- return $ PBBlock b- grabPair = PBAttr <$> parsePair- grabMixin = try $ do- whiteSpace- Right x <- parseCaret- whiteSpace- return $ PBMixin x- checkIfBlock = do- skipMany $ noneOf "#@{};"- (parseHash >> checkIfBlock)- <|> (parseAt >> checkIfBlock)- <|> (char '{' >> return True)- <|> (oneOf ";}" >> return False)- <|> (anyChar >> checkIfBlock)- <|> fail "checkIfBlock"--parsePair :: Parser (Attr Unresolved)-parsePair = do- key <- parseContents ":"- _ <- char ':'- whiteSpace- val <- parseContents ";}"- (char ';' >> return ()) <|> return ()- whiteSpace- return $ Attr key val--parseContents :: String -> Parser Contents-parseContents = many1 . parseContent--parseContent :: String -> Parser Content-parseContent restricted =- parseHash' <|> parseAt' <|> parseComment <|> parseBack <|> parseChar- where- parseHash' = either ContentRaw ContentVar `fmap` parseHash- parseAt' =- either ContentRaw go `fmap` parseAt- where- go (d, False) = ContentUrl d- go (d, True) = ContentUrlParam d- parseBack = try $ do- _ <- char '\\'- hex <- atMost 6 $ satisfy isHex- (int, _):_ <- return $ readHex $ dropWhile (== '0') hex- when (length hex < 6) $- ((string "\r\n" >> return ()) <|> (satisfy isSpace >> return ()))- return $ ContentRaw [toEnum int]- parseChar = (ContentRaw . return) `fmap` noneOf restricted--isHex :: Char -> Bool-isHex c =- ('0' <= c && c <= '9') ||- ('A' <= c && c <= 'F') ||- ('a' <= c && c <= 'f')--atMost :: Int -> Parser a -> Parser [a]-atMost 0 _ = return []-atMost i p = (do- c <- p- s <- atMost (i - 1) p- return $ c : s) <|> return []--parseComment :: Parser Content-parseComment = do- _ <- try $ string "/*"- _ <- manyTill anyChar $ try $ string "*/"- return $ ContentRaw ""+lucius = luciusWithOrder Unordered luciusFile :: FilePath -> Q Exp-luciusFile fp = do-#ifdef GHC_7_4- qAddDependentFile fp-#endif- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp- luciusFromString contents+luciusFile = luciusFileWithOrd Unordered -luciusFileDebug, luciusFileReload :: FilePath -> Q Exp-luciusFileDebug = cssFileDebug False [|parseTopLevels|] parseTopLevels+luciusFileDebug :: FilePath -> Q Exp+luciusFileDebug = luciusFileDebugWithOrder Unordered++luciusFileReload :: FilePath -> Q Exp luciusFileReload = luciusFileDebug -parseTopLevels :: Parser [TopLevel Unresolved]-parseTopLevels =- go id- where- go front = do- let string' s = string s >> return ()- ignore = many (whiteSpace1 <|> string' "<!--" <|> string' "-->")- >> return ()- ignore- tl <- ((charset <|> media <|> impor <|> topAtBlock <|> var <|> fmap TopBlock parseBlock) >>= \x -> go (front . (:) x))- <|> (return $ map compressTopLevel $ front [])- ignore- return tl- charset = do- try $ stringCI "@charset "- cs <- parseContents ";"- _ <- char ';'- return $ TopAtDecl "charset" cs- media = do- try $ stringCI "@media "- selector <- parseContents "{"- _ <- char '{'- b <- parseBlocks id- return $ TopAtBlock "media" selector b- impor = do- try $ stringCI "@import ";- val <- parseContents ";"- _ <- char ';'- return $ TopAtDecl "import" val- var = try $ do- _ <- char '@'- isPage <- (try $ string "page " >> return True) <|>- (try $ string "font-face " >> return True) <|>- return False- when isPage $ fail "page is not a variable"- k <- many1 $ noneOf ":"- _ <- char ':'- v <- many1 $ noneOf ";"- _ <- char ';'- let trimS = reverse . dropWhile isSpace . reverse . dropWhile isSpace- return $ TopVar (trimS k) (trimS v)- topAtBlock = do- (name, selector) <- try $ do- _ <- char '@'- name <- many1 $ noneOf " \t"- _ <- many1 $ oneOf " \t"- unless ("keyframes" `isSuffixOf` name) $ fail "only accepting keyframes"- selector <- parseContents "{"- _ <- char '{'- return (name, selector)- b <- parseBlocks id- return $ TopAtBlock name selector b- parseBlocks front = do- whiteSpace- (char '}' >> return (map compressBlock $ front []))- <|> (parseBlock >>= \x -> parseBlocks (front . (:) x)) -stringCI :: String -> Parser ()-stringCI [] = return ()-stringCI (c:cs) = (char (toLower c) <|> char (toUpper c)) >> stringCI cs- luciusRT' :: TL.Text- -> Either String ([(Text, Text)] -> Either String [TopLevel Resolved])-luciusRT' =- either Left (Right . go) . luciusRTInternal- where- go :: ([(Text, RTValue)] -> Either String [TopLevel Resolved])- -> ([(Text, Text)] -> Either String [TopLevel Resolved])- go f = f . map (second RTVRaw)--luciusRTInternal- :: TL.Text- -> Either String ([(Text, RTValue)] -> Either String [TopLevel Resolved])-luciusRTInternal tl =- case parse parseTopLevels (TL.unpack tl) (TL.unpack tl) of- Left s -> Left $ show s- Right tops -> Right $ \scope -> go scope tops- where- go :: [(Text, RTValue)]- -> [TopLevel Unresolved]- -> Either String [TopLevel Resolved]- go _ [] = Right []- go scope (TopAtDecl dec cs':rest) = do- let scope' = map goScope scope- render = error "luciusRT has no URLs"- cs <- mapM (contentToBuilderRT scope' render) cs'- rest' <- go scope rest- Right $ TopAtDecl dec (mconcat cs) : rest'- go scope (TopBlock b:rest) = do- b' <- goBlock scope b- rest' <- go scope rest- Right $ map TopBlock b' ++ rest'- go scope (TopAtBlock name m' bs:rest) = do- let scope' = map goScope scope- render = error "luciusRT has no URLs"- m <- mapM (contentToBuilderRT scope' render) m'- bs' <- mapM (goBlock scope) bs- rest' <- go scope rest- Right $ TopAtBlock name (mconcat m) (concat bs') : rest'- go scope (TopVar k v:rest) = go ((pack k, RTVRaw $ pack v):scope) rest-- goBlock :: [(Text, RTValue)]- -> Block Unresolved- -> Either String [Block Resolved]- goBlock scope =- either Left (Right . ($[])) . blockRuntime scope' (error "luciusRT has no URLs")- where- scope' = map goScope scope-- goScope (k, rt) =- (DerefIdent (Ident $ unpack k), cd)- where- cd =- case rt of- RTVRaw t -> CDPlain $ fromText t- RTVMixin m -> CDMixin m+ -> Either String ([(Text, Text)] -> Either String [TopLevel 'Resolved])+luciusRT' = luciusRTWithOrder' Unordered luciusRT :: TL.Text -> [(Text, Text)] -> Either String TL.Text-luciusRT tl scope = either Left (Right . renderCss . CssWhitespace) $ either Left ($ scope) (luciusRT' tl)+luciusRT = luciusRTWithOrder Unordered + -- | Runtime Lucius with mixin support. -- -- Since 1.0.6@@ -357,35 +91,14 @@ -> Bool -- ^ minify? -> [(Text, RTValue)] -- ^ scope -> Either String TL.Text-luciusRTMixin tl minify scope =- either Left (Right . renderCss . cw) $ either Left ($ scope) (luciusRTInternal tl)- where- cw- | minify = CssNoWhitespace- | otherwise = CssWhitespace--data RTValue = RTVRaw Text- | RTVMixin Mixin+luciusRTMixin = luciusRTMixinWithOrder Unordered -- | Same as 'luciusRT', but output has no added whitespace. -- -- Since 1.0.3 luciusRTMinified :: TL.Text -> [(Text, Text)] -> Either String TL.Text-luciusRTMinified tl scope = either Left (Right . renderCss . CssNoWhitespace) $ either Left ($ scope) (luciusRT' tl)---- | Determine which identifiers are used by the given template, useful for--- creating systems like yesod devel.-luciusUsedIdentifiers :: String -> [(Deref, VarType)]-luciusUsedIdentifiers = cssUsedIdentifiers False parseTopLevels+luciusRTMinified = luciusRTMinifiedWithOrder Unordered luciusMixin :: QuasiQuoter-luciusMixin = QuasiQuoter { quoteExp = luciusMixinFromString }+luciusMixin = luciusMixinWithOrder Unordered -luciusMixinFromString :: String -> Q Exp-luciusMixinFromString s' = do- r <- newName "_render"- case fmap compressBlock $ parse parseBlock s s of- Left e -> error $ show e- Right block -> blockToMixin r [] block- where- s = concat ["mixin{", s', "}"]
+ Text/Lucius/Ordered.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}++-- | This module is the twin brother of module Text.Lucius.+-- The difference is that these parsers preserv the given order of attributes and mixin blocks.+--+-- > let bams = [Text.Ordered.cassiusMixin|+-- > bam1:bam2+-- > ^{bins}+-- > bam3:bam4+-- > |] :: Mixin+-- > bins = [Text.Ordered.cassiusMixin|+-- > bin1:bin2+-- > |] :: Mixin+-- > in renderCss ([lucius|foo{bar1:bar2;^{bams};bar3:bar4;}|] undefined)+-- > "foo{bar1:bar2;bam1:bam2;bin1:bin2;bam3:bam4;bar3:bar4}"++module Text.Lucius.Ordered+ ( -- * Parsing+ lucius+ , luciusFile+ , luciusFileDebug+ , luciusFileReload+ -- ** Mixins+ , luciusMixin+ , Mixin+ -- ** Runtime+ , luciusRT+ , luciusRT'+ , luciusRTMinified+ -- *** Mixin+ , luciusRTMixin+ , RTValue (..)+ , -- * Datatypes+ Css+ , CssUrl+ -- * Type class+ , ToCss (..)+ -- * Rendering+ , renderCss+ , renderCssUrl+ -- * ToCss instances+ -- ** Color+ , Color (..)+ , colorRed+ , colorBlack+ -- ** Size+ , mkSize+ , AbsoluteUnit (..)+ , AbsoluteSize (..)+ , absoluteSize+ , EmSize (..)+ , ExSize (..)+ , PercentageSize (..)+ , percentageSize+ , PixelSize (..)+ -- * Internal+ , parseTopLevels+ , luciusUsedIdentifiers+ ) where++import Text.Internal.CssCommon+import Text.Internal.Lucius+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax+import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import Text.Internal.Css+++-- |+-- >>> renderCss ([lucius|foo{bar:baz}|] undefined)+-- "foo{bar:baz}"+--+-- @since 2.0.30+lucius :: QuasiQuoter+lucius = luciusWithOrder Ordered++-- | @since 2.0.30+luciusFile :: FilePath -> Q Exp+luciusFile = luciusFileWithOrd Ordered++-- | @since 2.0.30+luciusFileDebug :: FilePath -> Q Exp+luciusFileDebug = luciusFileDebugWithOrder Ordered++-- | @since 2.0.30+luciusFileReload :: FilePath -> Q Exp+luciusFileReload = luciusFileDebug++-- | @since 2.0.30+luciusRT' :: TL.Text+ -> Either String ([(Text, Text)]+ -> Either String [TopLevel 'Resolved])+luciusRT' = luciusRTWithOrder' Ordered++-- | @since 2.0.30+luciusRT :: TL.Text -> [(Text, Text)] -> Either String TL.Text+luciusRT = luciusRTWithOrder Ordered++-- | @since 2.0.30+luciusRTMixin :: TL.Text -- ^ template+ -> Bool -- ^ minify?+ -> [(Text, RTValue)] -- ^ scope+ -> Either String TL.Text+luciusRTMixin = luciusRTMixinWithOrder Ordered++-- | @since 2.0.30+luciusRTMinified :: TL.Text -> [(Text, Text)] -> Either String TL.Text+luciusRTMinified = luciusRTMinifiedWithOrder Ordered++-- | @since 2.0.30+luciusMixin :: QuasiQuoter+luciusMixin = luciusMixinWithOrder Ordered
Text/MkSizeType.hs view
@@ -1,57 +1,72 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+ -- | Internal functions to generate CSS size wrapper types. module Text.MkSizeType (mkSizeType) where +#if !MIN_VERSION_template_haskell(2,12,0)+import Language.Haskell.TH (conT)+#endif import Language.Haskell.TH.Syntax+import Data.Text.Lazy.Builder (fromLazyText)+import qualified Data.Text.Lazy as TL mkSizeType :: String -> String -> Q [Dec]-mkSizeType name' unit = return [ dataDec name- , showInstanceDec name unit- , numInstanceDec name- , fractionalInstanceDec name- , toCssInstanceDec name ]+mkSizeType name' unit = do+ ddn <- dataDec name+ return [ ddn+ , showInstanceDec name unit+ , numInstanceDec name+ , fractionalInstanceDec name+ , toCssInstanceDec name ] where name = mkName $ name' -dataDec :: Name -> Dec-dataDec name = DataD [] name [] [constructor] derives- where constructor = NormalC name [(NotStrict, ConT $ mkName "Rational")]+dataDec :: Name -> Q Dec+dataDec name =+#if MIN_VERSION_template_haskell(2,12,0)+ return $+ DataD [] name [] Nothing [constructor] [DerivClause Nothing (map ConT derives)]+#else+ DataD [] name [] Nothing [constructor] <$> mapM conT derives+#endif+ where constructor = NormalC name [(notStrict, ConT $ mkName "Rational")] derives = map mkName ["Eq", "Ord"] showInstanceDec :: Name -> String -> Dec-showInstanceDec name unit' = InstanceD [] (instanceType "Show" name) [showDec]+showInstanceDec name unit' = instanceD [] (instanceType "Show" name) [showDec] where showSize = VarE $ mkName "showSize" x = mkName "x" unit = LitE $ StringL unit' showDec = FunD (mkName "show") [Clause [showPat] showBody []]- showPat = ConP name [VarP x]+ showPat = conP name [VarP x] showBody = NormalB $ AppE (AppE showSize $ VarE x) unit numInstanceDec :: Name -> Dec-numInstanceDec name = InstanceD [] (instanceType "Num" name) decs+numInstanceDec name = instanceD [] (instanceType "Num" name) decs where decs = map (binaryFunDec name) ["+", "*", "-"] ++ map (unariFunDec1 name) ["abs", "signum"] ++ [unariFunDec2 name "fromInteger"] fractionalInstanceDec :: Name -> Dec-fractionalInstanceDec name = InstanceD [] (instanceType "Fractional" name) decs+fractionalInstanceDec name = instanceD [] (instanceType "Fractional" name) decs where decs = [binaryFunDec name "/", unariFunDec2 name "fromRational"] toCssInstanceDec :: Name -> Dec-toCssInstanceDec name = InstanceD [] (instanceType "ToCss" name) [toCssDec]+toCssInstanceDec name = instanceD [] (instanceType "ToCss" name) [toCssDec] where toCssDec = FunD (mkName "toCss") [Clause [] showBody []] showBody = NormalB $ (AppE dot from) `AppE` ((AppE dot pack) `AppE` show')- -- FIXME this whole section makes me a little nervous- from = VarE (mkName "fromLazyText")- pack = VarE (mkName "TL.pack")- dot = VarE (mkName ".")- show' = VarE (mkName "show")+ from = VarE 'fromLazyText+ pack = VarE 'TL.pack+ dot = VarE 'Prelude.fmap+ show' = VarE 'Prelude.show instanceType :: String -> Name -> Type instanceType className name = AppT (ConT $ mkName className) (ConT name) binaryFunDec :: Name -> String -> Dec binaryFunDec name fun' = FunD fun [Clause [pat1, pat2] body []]- where pat1 = ConP name [VarP v1]- pat2 = ConP name [VarP v2]+ where pat1 = conP name [VarP v1]+ pat2 = conP name [VarP v2] body = NormalB $ AppE (ConE name) result result = AppE (AppE (VarE fun) (VarE v1)) (VarE v2) fun = mkName fun'@@ -60,7 +75,7 @@ unariFunDec1 :: Name -> String -> Dec unariFunDec1 name fun' = FunD fun [Clause [pat] body []]- where pat = ConP name [VarP v]+ where pat = conP name [VarP v] body = NormalB $ AppE (ConE name) (AppE (VarE fun) (VarE v)) fun = mkName fun' v = mkName "v"@@ -71,3 +86,16 @@ body = NormalB $ AppE (ConE name) (AppE (VarE fun) (VarE x)) fun = mkName fun' x = mkName "x"++notStrict :: Bang+notStrict = Bang NoSourceUnpackedness NoSourceStrictness++instanceD :: Cxt -> Type -> [Dec] -> Dec+instanceD = InstanceD Nothing++conP :: Name -> [Pat] -> Pat+#if MIN_VERSION_template_haskell(2,18,0)+conP name = ConP name []+#else+conP = ConP+#endif
Text/Roy.hs view
@@ -31,7 +31,7 @@ -- -- Further reading: ----- 1. Shakespearean templates: <http://www.yesodweb.com/book/templates>+-- 1. Shakespearean templates: <https://www.yesodweb.com/book/shakespearean-templates> -- -- 2. Roy: <http://roy.brianmckenna.org/> module Text.Roy
Text/Shakespeare.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- | NOTE: This module should be considered internal, and will be hidden in@@ -39,19 +41,17 @@ import Text.Parsec.Prim (modifyState, Parsec) import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH (appE)+import Language.Haskell.TH.Lift () -- Import orphan Lift Name instance import Language.Haskell.TH.Syntax-#if !MIN_VERSION_template_haskell(2,8,0)-import Language.Haskell.TH.Syntax.Internals-#endif import Data.Text.Lazy.Builder (Builder, fromText)+#if !MIN_VERSION_base(4,11,0) import Data.Monoid+#endif import System.IO.Unsafe (unsafePerformIO) import qualified Data.Text as TS-import qualified Data.Text.Lazy as TL import Text.Shakespeare.Base -import Filesystem (getModified)-import Filesystem.Path.CurrentOS (decodeString)+import System.Directory (getModificationTime) import Data.Time (UTCTime) import Data.IORef import qualified Data.Map as M@@ -63,26 +63,12 @@ import System.Process (readProcessWithExitCode) import System.Exit (ExitCode(..)) -#if !MIN_VERSION_base(4,5,0)-(<>) :: Monoid m => m -> m -> m-(<>) = mappend-{-# INLINE (<>) #-}-#endif- -- | A parser with a user state of [String] type Parser = Parsec String [String] -- | run a parser with a user state of [String] parse :: GenParser tok [a1] a -> SourceName -> [tok] -> Either ParseError a parse p = runParser p [] --- move to Shakespeare.Base?-readFileQ :: FilePath -> Q String-readFileQ fp = qRunIO $ readFileUtf8 fp---- move to Shakespeare.Base?-readFileUtf8 :: FilePath -> IO String-readFileUtf8 fp = fmap TL.unpack $ readUtf8File fp- -- | Coffeescript, TypeScript, and other languages compiles down to Javascript. -- Previously we waited until the very end, at the rendering stage to perform this compilation. -- Lets call is a post-conversion@@ -113,6 +99,7 @@ , preEscapeIgnoreLine :: [Char] , wrapInsertion :: Maybe WrapInsertion }+ deriving Lift data WrapInsertion = WrapInsertion { wrapInsertionIndent :: Maybe String@@ -122,10 +109,11 @@ , wrapInsertionEnd :: String , wrapInsertionAddParens :: Bool }+ deriving Lift data PreConversion = ReadProcess String [String] | Id- + deriving Lift data ShakespeareSettings = ShakespeareSettings@@ -153,38 +141,22 @@ , modifyFinalValue = Nothing } -instance Lift PreConvert where- lift (PreConvert convert ignore comment wrapInsertion) =- [|PreConvert $(lift convert) $(lift ignore) $(lift comment) $(lift wrapInsertion)|]--instance Lift WrapInsertion where- lift (WrapInsertion indent sb sep sc e wp) =- [|WrapInsertion $(lift indent) $(lift sb) $(lift sep) $(lift sc) $(lift e) $(lift wp)|]--instance Lift PreConversion where- lift (ReadProcess command args) =- [|ReadProcess $(lift command) $(lift args)|]- lift Id = [|Id|]- instance Lift ShakespeareSettings where lift (ShakespeareSettings x1 x2 x3 x4 x5 x6 x7 x8 x9) = [|ShakespeareSettings $(lift x1) $(lift x2) $(lift x3) $(liftExp x4) $(liftExp x5) $(liftExp x6) $(lift x7) $(lift x8) $(liftMExp x9)|] where- liftExp (VarE n) = [|VarE $(liftName n)|]- liftExp (ConE n) = [|ConE $(liftName n)|]+ liftExp (VarE n) = [|VarE $(lift n)|]+ liftExp (ConE n) = [|ConE $(lift 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|]+#if MIN_VERSION_template_haskell(2,17,0)+ liftTyped = unsafeCodeCoerce . lift+#elif MIN_VERSION_template_haskell(2,16,0)+ liftTyped = unsafeTExpCoerce . lift+#endif type QueryParameters = [(TS.Text, TS.Text)] type RenderUrl url = (url -> QueryParameters -> TS.Text)@@ -211,7 +183,7 @@ compressContents (ContentRaw x:ContentRaw y:z) = compressContents $ ContentRaw (x ++ y) : z compressContents (x:y) = x : compressContents y- + parseContents :: ShakespeareSettings -> Parser Contents parseContents = many1 . parseContent where@@ -290,7 +262,7 @@ <> "(" <> mconcat (intersperse ", " vars) <> ");\n"- where + where removeTrailingSemiColon = reverse $ dropWhile (\c -> c == ';' || isSpace c) (reverse str) @@ -344,9 +316,6 @@ pack' :: String -> TS.Text pack' = TS.pack-#if !MIN_VERSION_text(0, 11, 2)-{-# NOINLINE pack' #-}-#endif contentsToShakespeare :: ShakespeareSettings -> [Content] -> Q Exp contentsToShakespeare rs a = do@@ -379,7 +348,10 @@ 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+ return $+ if justVarInterpolation rs+ then derefToExp [] d+ else derefToExp [] d `AppE` VarE r shakespeare :: ShakespeareSettings -> QuasiQuoter shakespeare r = QuasiQuoter { quoteExp = shakespeareFromString r }@@ -394,11 +366,7 @@ contentsToShakespeare r $ contentFromString r s shakespeareFile :: ShakespeareSettings -> FilePath -> Q Exp-shakespeareFile r fp =-#ifdef GHC_7_4- qAddDependentFile fp >>-#endif- readFileQ fp >>= shakespeareFromString r+shakespeareFile r fp = readFileRecompileQ fp >>= shakespeareFromString r data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin deriving (Show, Eq, Ord, Enum, Bounded, Typeable, Data, Generic)@@ -449,7 +417,11 @@ vtToExp (d, vt) = do d' <- lift d c' <- c 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 c :: VarType -> Q Exp c VTPlain = [|EPlain . $(return $@@ -460,9 +432,12 @@ +nothingError :: Show a => String -> a -> b+nothingError expected d = error $ "expected " ++ expected ++ " but got Nothing for: " ++ show d+ shakespeareRuntime :: ShakespeareSettings -> FilePath -> [(Deref, VarExp url)] -> Shakespeare url shakespeareRuntime settings fp cd render' = unsafePerformIO $ do- mtime <- qRunIO $ getModified $ decodeString fp+ mtime <- qRunIO $ getModificationTime fp mdata <- lookupReloadMap fp case mdata of Just (lastMtime, lastContents) ->@@ -471,7 +446,7 @@ Nothing -> fmap go' $ newContent mtime where newContent mtime = do- str <- readFileUtf8 fp+ str <- readUtf8FileString fp s <- preFilter (Just fp) settings str insertReloadMap fp (mtime, contentFromString settings s) @@ -482,17 +457,17 @@ go (ContentVar d) = case lookup d cd of Just (EPlain s) -> s- _ -> error $ show d ++ ": expected EPlain"+ _ -> nothingError "EPlain" d go (ContentUrl d) = case lookup d cd of Just (EUrl u) -> fromText $ render' u []- _ -> error $ show d ++ ": expected EUrl"+ _ -> nothingError "EUrl" d go (ContentUrlParam d) = case lookup d cd of Just (EUrlParam (u, p)) -> fromText $ render' u p- _ -> error $ show d ++ ": expected EUrlParam"+ _ -> nothingError "EUrlParam" d go (ContentMix d) = case lookup d cd of Just (EMixin m) -> m render'- _ -> error $ show d ++ ": expected EMixin"+ _ -> nothingError "EMixin" d
Text/Shakespeare/Base.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveLift #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} -- | General parsers, functions and datatypes for all Shakespeare languages.@@ -21,11 +22,15 @@ , derefToExp , flattenDeref , readUtf8File+ , readUtf8FileString+ , readFileQ+ , readFileRecompileQ ) where -import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Syntax hiding (makeRelativeToProject) import Language.Haskell.TH (appE) import Data.Char (isUpper, isSymbol, isPunctuation, isAscii)+import Data.FileEmbed (makeRelativeToProject) import Text.ParserCombinators.Parsec import Text.Parsec.Prim (Parsec) import Data.List (intercalate)@@ -38,7 +43,7 @@ import Control.Monad (when) newtype Ident = Ident String- deriving (Show, Eq, Read, Data, Typeable, Ord)+ deriving (Show, Eq, Read, Data, Typeable, Ord, Lift) type Scope = [(Ident, Exp)] @@ -50,35 +55,12 @@ | DerefBranch Deref Deref | DerefList [Deref] | 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)|]+ | DerefGetField Deref String+ -- ^ Record field access via @OverloadedRecordDot@. 'derefToExp' only supports this+ -- feature on compilers which support @OverloadedRecordDot@.+ --+ -- @since 2.1.0+ deriving (Show, Eq, Read, Data, Typeable, Ord, Lift) derefParens, derefCurlyBrackets :: UserParser a Deref derefParens = between (char '(') (char ')') parseDeref@@ -94,14 +76,13 @@ return $ DerefTuple x parseDeref :: UserParser a Deref-parseDeref = skipMany (oneOf " \t") >> (derefList <|>- derefTuple <|> (do- x <- derefSingle- (derefInfix x) <|> (do- res <- deref' $ (:) x- skipMany $ oneOf " \t"- return res)))+parseDeref = do+ skipMany (oneOf " \t")+ derefList <|> derefTuple <|> derefOther where+ derefOther = do+ x <- derefSingle+ derefInfix x <|> derefPrefix x delim = (many1 (char ' ') >> return()) <|> lookAhead (oneOf "(\"" >> return ()) derefOp = try $ do@@ -115,6 +96,10 @@ | isAscii c = c `elem` "!#$%&*+./<=>?@\\^|-~:" | otherwise = isSymbol c || isPunctuation c + derefPrefix x = do+ res <- deref' $ (:) x+ skipMany $ oneOf " \t"+ return res derefInfix x = try $ do _ <- delim xs <- many $ try $ derefSingle >>= \x' -> delim >> return x'@@ -122,9 +107,18 @@ -- special handling for $, which we don't deal with when (op == "$") $ fail "don't handle $" let op' = DerefIdent $ Ident op- ys <- many1 $ delim >> derefSingle+ ys <- many1 $ try $ delim >> derefSingle+ skipMany $ oneOf " \t" return $ DerefBranch (DerefBranch op' $ foldl1 DerefBranch $ x : xs) (foldl1 DerefBranch ys)- derefSingle = derefTuple <|> derefList <|> derefOp <|> derefParens <|> numeric <|> strLit<|> ident+ derefSingle = do+ x <- derefTuple <|> derefList <|> derefOp <|> derefParens <|> numeric <|> strLit <|> ident+ fields <- many recordDot+ pure $ foldl DerefGetField x fields+ recordDot = do+ _ <- char '.'+ x <- lower <|> char '_'+ xs <- many (alphaNum <|> char '_' <|> char '\'')+ pure (x : xs) deref' lhs = dollar <|> derefSingle' <|> return (foldl1 DerefBranch $ lhs [])@@ -191,7 +185,17 @@ derefToExp _ (DerefRational r) = LitE $ RationalL r derefToExp _ (DerefString s) = LitE $ StringL s derefToExp s (DerefList ds) = ListE $ map (derefToExp s) ds-derefToExp s (DerefTuple ds) = TupE $ map (derefToExp s) ds+derefToExp s (DerefTuple ds) = TupE $+#if MIN_VERSION_template_haskell(2,16,0)+ map Just $+#endif+ map (derefToExp s) ds+derefToExp s (DerefGetField x f) =+#if MIN_VERSION_template_haskell(2,18,0)+ GetFieldE (derefToExp s x) f+#else+ error "Your compiler doesn't support OverloadedRecordDot"+#endif -- FIXME shouldn't we use something besides a list here? flattenDeref :: Deref -> Maybe [String]@@ -277,14 +281,38 @@ deref <- derefCurlyBrackets return $ Right deref) <|> return (Left "_") +-- | Read file's content as `String`, converting newlines+--+-- @since 2.0.19+readUtf8FileString :: FilePath -> IO String+readUtf8FileString fp = fmap TL.unpack $ readUtf8File fp+ readUtf8File :: FilePath -> IO TL.Text readUtf8File fp = do h <- SIO.openFile fp SIO.ReadMode SIO.hSetEncoding h SIO.utf8_bom- ret <- TIO.hGetContents h + ret <- TIO.hGetContents h return $ #ifdef WINDOWS TL.filter ('\r'/=) ret #else ret #endif++-- | Embed file's content, converting newlines+--+-- @since 2.0.19+readFileQ :: FilePath -> Q String+readFileQ rawFp = do+ fp <- makeRelativeToProject rawFp+ qRunIO (readUtf8FileString fp)++-- | Embed file's content, converting newlines+-- and track file via ghc dependencies, recompiling on changes+--+-- @since 2.0.19+readFileRecompileQ :: FilePath -> Q String+readFileRecompileQ rawFp = do+ fp <- makeRelativeToProject rawFp+ addDependentFile fp+ qRunIO (readUtf8FileString fp)
Text/Shakespeare/I18N.hs view
@@ -1,10 +1,10 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- |@@ -59,21 +59,33 @@ , ToMessage (..) , SomeMessage (..) , Lang++ , mkMessageOpts++ , MakeMessageOpts+ , defMakeMessageOpts+ , setGenType+ , setConPrefix+ , setTypeSuffix+ , setUseRecordCons ) where -import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Syntax hiding (makeRelativeToProject)+import Control.Monad (filterM, forM) import Data.Text (Text, pack, unpack) import System.Directory+import Data.FileEmbed (makeRelativeToProject) import Data.Maybe (catMaybes) import Data.List (isSuffixOf, sortBy, foldl')+import qualified Data.Map as Map import qualified Data.ByteString as S import Data.Text.Encoding (decodeUtf8)-import Data.Char (isSpace, toLower, toUpper)+import Data.Char (isSpace, toLower, toUpper, isLower) import Data.Ord (comparing) import Text.Shakespeare.Base (Deref (..), Ident (..), parseHash, derefToExp)-import Text.ParserCombinators.Parsec (parse, many, eof, many1, noneOf, (<|>))+import Text.ParserCombinators.Parsec (parse, many, eof, many1, noneOf, (<|>), + string, spaces, char, option, alphaNum, sepBy1, try) import Control.Arrow ((***))-import Data.Monoid (mempty, mappend) import qualified Data.Text as T import Data.String (IsString (fromString)) @@ -120,8 +132,8 @@ -> 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+mkMessage dt =+ mkMessageCommon True "Msg" "Message" dt dt -- | create 'RenderMessage' instance for an existing data-type@@ -130,7 +142,7 @@ -> FilePath -- ^ path to translation folder -> Lang -- ^ default language -> Q [Dec]-mkMessageFor master dt folder lang = mkMessageCommon False "" "" master dt folder lang+mkMessageFor = mkMessageCommon False "" "" -- | create an additional set of translations for a type created by `mkMessage` mkMessageVariant :: String -- ^ master translation data type@@ -138,7 +150,7 @@ -> FilePath -- ^ path to translation folder -> Lang -- ^ default language -> Q [Dec]-mkMessageVariant master dt folder lang = mkMessageCommon False "Msg" "Message" master dt folder lang+mkMessageVariant = mkMessageCommon False "Msg" "Message" -- |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@@ -149,53 +161,138 @@ -> FilePath -- ^ path to translation folder -> Lang -- ^ default lang -> Q [Dec]-mkMessageCommon genType prefix postfix master dt folder lang = do+mkMessageCommon genType prefix postfix =+ mkMessageOpts opts+ where+ opts = defMakeMessageOpts+ { mmGenType = genType+ , mmConPrefix = prefix+ , mmTypeSuffix = postfix+ }++-- | used by 'mkMessage', 'mkMessageFor' to generate a 'RenderMessage' and possibly a message data type+--+-- @since 2.1.6+mkMessageOpts :: MakeMessageOpts -- ^ options+ -> String -- ^ base name of master datatype+ -> String -- ^ base name of translation datatype+ -> FilePath -- ^ path to translation folder+ -> Lang -- ^ default lang+ -> Q [Dec]+mkMessageOpts opts@(MkMakeMessageOpts {mmGenType = genType, mmTypeSuffix = postfix}) master dt rawFolder lang = do+ folder <- makeRelativeToProject rawFolder files <- qRunIO $ getDirectoryContents folder- (_files', contents) <- qRunIO $ fmap (unzip . catMaybes) $ mapM (loadLang folder) files-#ifdef GHC_7_4- mapM_ qAddDependentFile _files'-#endif+ let files' = filter (`notElem` [".", ".."]) files+ (filess, contents) <- qRunIO $ unzip . catMaybes <$> mapM (loadLang folder) files'+ (mapM_.mapM_) addDependentFile filess+ let contents' = Map.toList $ Map.fromListWith (++) contents sdef <-- case lookup lang contents of+ 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+ mapM_ (checkDef sdef . snd) contents'+ let mname = mkName $ dt2 ++ postfix+ c1 <- concat <$> mapM (toClauses opts dt2 ) contents'+ c2 <- mapM (sToClause opts dt2) sdef c3 <- defClause return $- ( if genType - then ((DataD [] mname [] (map (toCon dt) sdef) []) :)+ ( if genType+ then (DataD [] mname [] Nothing (map (toCon opts dt2) sdef) [] :) else id)- [ InstanceD- []- (ConT ''RenderMessage `AppT` (ConT $ mkName master) `AppT` ConT mname)+ [ instanceD+ cxt -- Here the parsed context should be added, otherwise []+ (ConT ''RenderMessage `AppT` (if ' ' `elem` master' + then let (ts, us) = break (== ' ') . + filter (\x -> x /= '(' && x /= ')') $ master'+ combineArgs typeName p xs' = foldl1 AppT . (typeName :) . fmap (VarT . mkName) . filter (not . null) $ go xs' (id, id)+ where+ go :: String -> ([String] -> [String], String -> String) -> [String]+ go [] (endList, currList) = endList [currList []]+ go (x : xs) (endList, currList)+ | p x = go xs (endList . (currList [] :), id)+ | otherwise = go xs (endList, currList . (x :))+ in ParensT (combineArgs (ConT (mkName ts)) (== ' ') us)+ else ConT $ mkName master') `AppT` ConT mname) [ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [c3] ] ]+ where (dt1, cxt0) = case parse parseName "" dt of+ Left err -> error $ show err+ Right x -> x+ dt2 = concat . take 1 $ dt1+ master' | null cxt0 = master+ | otherwise = (\xss -> if length xss > 1 + then '(':unwords xss ++ ")" + else concat . take 1 $ xss) . fst $ + (case parse parseName "" master of+ Left err -> error $ show err+ Right x -> x)+ cxt = fmap (\(c:rest) -> foldl' (\acc v -> acc `AppT` nameToType v) + (ConT $ mkName c) rest) cxt0 -toClauses :: String -> String -> (Lang, [Def]) -> Q [Clause]-toClauses prefix dt (lang, defs) =+ nameToType :: String -> Type -- Is taken from the +-- https://hackage.haskell.org/package/yesod-core-1.6.26.0/docs/src/Yesod.Routes.Parse.html#nameToType+ nameToType t = if isTvar t+ then VarT $ mkName t+ else ConT $ mkName t++ isTvar :: String -> Bool -- Is taken from the +-- https://hackage.haskell.org/package/yesod-core-1.6.26.0/docs/src/Yesod.Routes.Parse.html#isTvar+ isTvar (h:_) = isLower h+ isTvar _ = False++ parseName = do+ cxt' <- option [] parseContext+ args <- many parseWord+ spaces+ eof+ return (args, cxt')++ parseWord = do+ spaces+ many1 alphaNum++ parseContext = try $ do+ cxts <- parseParen parseContexts+ spaces+ _ <- string "=>"+ return cxts++ parseParen p = do+ spaces+ _ <- try ( char '(' )+ r <- p+ spaces+ _ <- try ( char ')' )+ return r++ parseContexts =+ sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())++toClauses :: MakeMessageOpts -> String -> (Lang, [Def]) -> Q [Clause] +toClauses opts@(MkMakeMessageOpts {mmConPrefix = 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)+ (pat, bod) <- mkBody opts 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]+ [WildP, conP (mkName ":") [VarP a, WildP], pat] (GuardedB [(guard, bod)]) [] -mkBody :: String -- ^ datatype+mkBody :: MakeMessageOpts+ -> String -- ^ datatype -> String -- ^ constructor -> [String] -- ^ variable names -> [Content] -> Q (Pat, Exp)-mkBody dt cs vs ct = do+mkBody (MkMakeMessageOpts {mmUseRecordCons = useRecord}) dt cs vs ct = do vp <- mapM go vs- let pat = RecP (mkName cs) (map (varName dt *** VarP) vp)+ let pat = if useRecord+ then RecP (mkName cs) (map (varName dt *** VarP) vp)+ else ConP (mkName cs) [] (map (VarP . snd) vp) let ct' = map (fixVars vp) ct pack' <- [|Data.Text.pack|] tomsg <- [|toMessage|]@@ -219,16 +316,13 @@ 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+ fixIdent vp i = maybe i nameBase (lookup i vp) -sToClause :: String -> String -> SDef -> Q Clause-sToClause prefix dt sdef = do- (pat, bod) <- mkBody dt (prefix ++ sconstr sdef) (map fst $ svars sdef) (scontent sdef)+sToClause :: MakeMessageOpts -> String -> SDef -> Q Clause+sToClause opts@(MkMakeMessageOpts {mmConPrefix = prefix}) dt sdef = do+ (pat, bod) <- mkBody opts dt (prefix ++ sconstr sdef) (map fst $ svars sdef) (scontent sdef) return $ Clause- [WildP, ConP (mkName "[]") [], pat]+ [WildP, conP (mkName "[]") [], pat] (NormalB bod) [] @@ -239,16 +333,27 @@ d <- newName "msg" rm <- [|renderMessage|] return $ Clause- [VarP a, ConP (mkName ":") [WildP, VarP c], VarP d]+ [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- where- go (n, t) = (varName dt n, NotStrict, ConT $ mkName t)+conP :: Name -> [Pat] -> Pat+#if MIN_VERSION_template_haskell(2,18,0)+conP name = ConP name []+#else+conP = ConP+#endif +toCon :: MakeMessageOpts -> String -> SDef -> Con+toCon (MkMakeMessageOpts {mmConPrefix = prefix, mmUseRecordCons = useRecord}) dt (SDef c vs _) =+ if useRecord+ then RecC nm $ map goRec vs+ else NormalC nm $ map goNorm vs+ where+ goRec (n, t) = (varName dt n, notStrict, ConT $ mkName t)+ goNorm (_, t) = (notStrict, ConT $ mkName t)+ nm = mkName $ prefix ++ c+ varName :: String -> String -> Name varName a y = mkName $ concat [lower a, "Message", upper y]@@ -304,19 +409,50 @@ , content :: [Content] } -loadLang :: FilePath -> FilePath -> IO (Maybe (FilePath, (Lang, [Def])))+(</>) :: FilePath -> FilePath -> FilePath+path </> file = path ++ '/' : file++loadLang :: FilePath -> FilePath -> IO (Maybe ([FilePath], (Lang, [Def]))) loadLang folder file = do- let file' = folder ++ '/' : file- e <- doesFileExist file'- if e && ".msg" `isSuffixOf` file+ let file' = folder </> file+ isFile <- doesFileExist file'+ if isFile && ".msg" `isSuffixOf` file then do let lang = pack $ reverse $ drop 4 $ reverse file- bs <- S.readFile file'- let s = unpack $ decodeUtf8 bs- defs <- fmap catMaybes $ mapM (parseDef . T.unpack . T.strip . T.pack) $ lines s- return $ Just (file', (lang, defs))- else return Nothing+ defs <- loadLangFile file'+ return $ Just ([file'], (lang, defs))+ else do+ isDir <- doesDirectoryExist file'+ if isDir+ then do+ let lang = pack file+ (files, defs) <- unzip <$> loadLangDir file'+ return $ Just (files, (lang, concat defs))+ else+ return Nothing +loadLangDir :: FilePath -> IO [(FilePath, [Def])]+loadLangDir folder = do+ paths <- map (folder </>) . filter (`notElem` [".", ".."]) <$> getDirectoryContents folder+ files <- filterM doesFileExist paths+ dirs <- filterM doesDirectoryExist paths+ langFiles <-+ forM files $ \file -> do+ if ".msg" `isSuffixOf` file+ then do+ defs <- loadLangFile file+ return $ Just (file, defs)+ else do+ return Nothing+ langDirs <- mapM loadLangDir dirs+ return $ catMaybes langFiles ++ concat langDirs++loadLangFile :: FilePath -> IO [Def]+loadLangFile file = do+ bs <- S.readFile file+ let s = unpack $ decodeUtf8 bs+ fmap catMaybes $ mapM (parseDef . T.unpack . T.strip . T.pack) $ lines s+ parseDef :: String -> IO (Maybe Def) parseDef "" = return Nothing parseDef ('#':_) = return Nothing@@ -365,3 +501,65 @@ instance master ~ master' => RenderMessage master (SomeMessage master') where renderMessage a b (SomeMessage msg) = renderMessage a b msg++notStrict :: Bang+notStrict = Bang NoSourceUnpackedness NoSourceStrictness++instanceD :: Cxt -> Type -> [Dec] -> Dec+instanceD = InstanceD Nothing++-- | Opaque options type for 'mkMessage'+-- This is used to pass options to the 'mkMessage' function.+-- The options are not exposed directly to the user, but can be set using+-- the 'set*' functions, and the default can be made using 'defMakeMessageOpts'.+--+-- @since 2.1.6+data MakeMessageOpts = MkMakeMessageOpts+-- don't export constructor so that we can freely manipulate internals+ { mmGenType :: Bool+ , mmConPrefix :: String+ , mmTypeSuffix :: String+ , mmUseRecordCons :: Bool+ }++-- | Default options for 'mkMessage' are:+-- * @mmGenType@ = @True@+-- * @mmConPrefix@ = @\"Msg\"@+-- * @mmTypeSuffix@ = @\"Message\"@+-- * @mmUseRecordCons@ = @True@+--+-- @since 2.1.6+defMakeMessageOpts :: MakeMessageOpts+defMakeMessageOpts = MkMakeMessageOpts+ { mmGenType = True+ , mmConPrefix = "Msg"+ , mmTypeSuffix = "Message"+ , mmUseRecordCons = True+ }++-- | Whether to generate a new datatype from the constructors found in the .msg+-- files+--+-- @since 2.1.6+setGenType :: Bool -> MakeMessageOpts -> MakeMessageOpts+setGenType x opts = opts { mmGenType = x }++-- | Set the prefix for the constructor names+--+-- @since 2.1.6+setConPrefix :: String -> MakeMessageOpts -> MakeMessageOpts+setConPrefix x opts = opts { mmConPrefix = x }++-- | Set the suffix for the datatype name+--+-- @since 2.1.6+setTypeSuffix :: String -> MakeMessageOpts -> MakeMessageOpts+setTypeSuffix x opts = opts { mmTypeSuffix = x }++-- | Set whether to use record constructors or normal constructors.+-- If you are getting partial-fields warnings you want to remove, set this to+-- 'False'. If you want to use record syntax, set this to 'True'.+--+-- @since 2.1.6+setUseRecordCons :: Bool -> MakeMessageOpts -> MakeMessageOpts+setUseRecordCons x opts = opts { mmUseRecordCons = x }
Text/Shakespeare/Text.hs view
@@ -1,19 +1,42 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-}+-- | A Shakespearean module for general text processing, introducing type-safe,+-- compile-time variable interpolation.+--+-- Text templates use the same parser as for other shakespearean templates+-- which enables variable interpolation using @#{..}@. The parser also+-- recognize the @@{..}@ and @^{..}@ syntax.+--+-- If it is necessary that your template produces the output containing one of+-- the interpolation syntax you can escape the sequence using a backslash:+--+-- > λ> :set -XQuasiQuotes+-- > λ> let bar = 23 :: Int in [st|#{bar}|] :: Text+--+-- produces "23", but+--+-- > λ> let bar = 23 :: Int in [st|#\{bar}|] :: Text+--+-- returns "#{bar}". The escaping backslash is removed from the output.+--+-- Further reading:+-- Shakespearean templates: <https://www.yesodweb.com/book/shakespearean-templates> module Text.Shakespeare.Text ( TextUrl , ToText (..) , renderTextUrl , stext+ , stextFile , text , textFile , textFileDebug , textFileReload , st -- | strict text , lt -- | lazy text, same as stext :)+ , sbt -- | strict text whose left edge is aligned with bar ('|')+ , lbt -- | lazy text, whose left edge is aligned with bar ('|') -- * Yesod code generation , codegen , codegenSt@@ -24,6 +47,7 @@ import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText)+import Data.Text.Lazy.Builder.Int (decimal) import qualified Data.Text as TS import qualified Data.Text.Lazy as TL import Text.Shakespeare@@ -41,9 +65,9 @@ instance ToText TS.Text where toText = fromText instance ToText TL.Text where toText = fromLazyText -instance ToText Int32 where toText = toText . show-instance ToText Int64 where toText = toText . show-instance ToText Int where toText = toText . show+instance ToText Int32 where toText = decimal+instance ToText Int64 where toText = decimal+instance ToText Int where toText = decimal settings :: Q ShakespeareSettings settings = do@@ -55,15 +79,25 @@ , unwrap = unWrapExp } --stext, lt, st, text :: QuasiQuoter-stext = +-- | "Simple text" quasi-quoter. May only be used to generate expressions.+--+-- Generated expressions have type 'TL.Text'.+--+-- @+-- >>> do let x = "world"+-- 'Data.Text.Lazy.IO.putStrLn' ['stext'|Hello, #{x}!|]+-- Hello, world!+-- @+stext :: QuasiQuoter+stext = QuasiQuoter { quoteExp = \s -> do rs <- settings render <- [|toLazyText|] rendered <- shakespeareFromString rs { justVarInterpolation = True } s return (render `AppE` rendered) }++lt, st, text, lbt, sbt :: QuasiQuoter lt = stext st = @@ -79,7 +113,28 @@ quoteExp (shakespeare rs) $ filter (/='\r') s } +dropBar :: [TL.Text] -> [TL.Text]+dropBar [] = []+dropBar (c:cx) = c:dropBar' cx+ where+ dropBar' txt = reverse $ drop 1 $ map (TL.drop 1 . TL.dropWhile (/= '|')) $ reverse txt +lbt = + QuasiQuoter { quoteExp = \s -> do+ rs <- settings+ render <- [|TL.unlines . dropBar . TL.lines . toLazyText|]+ rendered <- shakespeareFromString rs { justVarInterpolation = True } s+ return (render `AppE` rendered)+ }++sbt = + QuasiQuoter { quoteExp = \s -> do+ rs <- settings+ render <- [|TL.toStrict . TL.unlines . dropBar . TL.lines . toLazyText|]+ rendered <- shakespeareFromString rs { justVarInterpolation = True } s+ return (render `AppE` rendered)+ }+ textFile :: FilePath -> Q Exp textFile fp = do rs <- settings@@ -94,6 +149,14 @@ textFileReload fp = do rs <- settings shakespeareFileReload rs fp++-- | Like 'stext', but reads an external file at compile-time.+--+-- @since 2.0.22+stextFile :: FilePath -> Q Exp+stextFile fp = do+ rs <- settings+ [|toLazyText $(shakespeareFile rs { justVarInterpolation = True } fp)|] -- | codegen is designed for generating Yesod code, including templates -- So it uses different interpolation characters that won't clash with templates.
Text/TypeScript.hs view
@@ -49,20 +49,24 @@ -- -- Further reading: ----- 1. Shakespearean templates: <http://www.yesodweb.com/book/templates>+-- 1. Shakespearean templates: <https://www.yesodweb.com/book/shakespearean-templates> ----- 2. TypeScript: <http://typescript.codeplex.com/>+-- 2. TypeScript: <https://www.typescriptlang.org/> 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+ , tscJSX , typeScriptFile+ , typeScriptJSXFile , typeScriptFileReload+ , typeScriptJSXFileReload #ifdef TEST_EXPORT , typeScriptSettings+ , typeScriptJSXSettings #endif ) where @@ -93,6 +97,17 @@ } } ++-- | Identical to 'typeScriptSettings' but uses jsx when compiling TypeScript+typeScriptJSXSettings :: Q ShakespeareSettings+typeScriptJSXSettings = do+ tsSettings <- typeScriptSettings+ let rp = ReadProcess "sh" ["-c", "TMP_IN=$(mktemp XXXXXXXXXX.tsx); TMP_OUT=$(mktemp XXXXXXXXXX.js); cat /dev/stdin > ${TMP_IN} && tsc --module amd --jsx react --out ${TMP_OUT} ${TMP_IN} && cat ${TMP_OUT}; rm ${TMP_IN} && rm ${TMP_OUT}"]+ return $ tsSettings {+ preConversion = fmap (\pc -> pc { preConvert = rp }) (preConversion tsSettings)+ }++ -- | Read inline, quasiquoted TypeScript tsc :: QuasiQuoter tsc = QuasiQuoter { quoteExp = \s -> do@@ -100,6 +115,13 @@ quoteExp (shakespeare rs) s } +-- | Read inline, quasiquoted TypeScript with jsx+tscJSX :: QuasiQuoter+tscJSX = QuasiQuoter { quoteExp = \s -> do+ rs <- typeScriptJSXSettings+ quoteExp (shakespeare rs) s+ }+ -- | Read in a TypeScript template file. This function reads the file once, at -- compile time. typeScriptFile :: FilePath -> Q Exp@@ -107,10 +129,28 @@ rs <- typeScriptSettings shakespeareFile rs fp +-- | Read in a TypeScript template file with jsx. This function reads the file+-- once, at compile time.+typeScriptJSXFile :: FilePath -> Q Exp+typeScriptJSXFile fp = do+ rs <- typeScriptJSXSettings+ shakespeareFile rs fp+++ -- | Read in a TypeScript 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+++-- | Read in a TypeScript with jsx template file. This impure function uses+-- unsafePerformIO to re-read the file on every call, allowing for rapid+-- iteration.+typeScriptJSXFileReload :: FilePath -> Q Exp+typeScriptJSXFileReload fp = do+ rs <- typeScriptJSXSettings shakespeareFileReload rs fp
+ other-messages/en.msg view
@@ -0,0 +1,29 @@+NotAnAdminRR: You must be an administrator to access this page. + +WelcomeHomepageRR: Welcome to the homepage +SeeArchiveRR: See the archive + +NoEntriesRR: There are no entries in the blog +LoginToPostRR: Admins can login to post +NewEntryRR: Post to blog +NewEntryTitleRR: Title +NewEntryContentRR: Content + +PleaseCorrectEntryRR: Your submitted entry had some errors, please correct and try again. +EntryCreatedRR title@Text: Your new blog post, #{title}, has been created + +EntryTitleRR title@Text: Blog postRR: #{title} +CommentsHeadingRR: Comments +NoCommentsRR: There are no comments +AddCommentHeadingRR: Add a Comment +LoginToCommentRR: You must be logged in to comment +AddCommentButtonRR: Add comment + +CommentNameRR: Your display name +CommentTextRR: Comment +CommentAddedRR: Your comment has been added +PleaseCorrectCommentRR: Your submitted comment had some errors, please correct and try again. + +HomepageTitleRR: Yesod Blog Demo +BlogArchiveTitleRR: Blog Archive +
shakespeare.cabal view
@@ -1,5 +1,5 @@ name: shakespeare-version: 2.0.1.1+version: 2.2.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -12,44 +12,50 @@ . Note there is no dependency on haskell-src-extras. Instead Shakespeare believes logic should stay out of templates and has its own minimal Haskell parser. .- Packages that use this: shakespeare-js, shakespeare-css, shakespeare-text, hamlet, and xml-hamlet+ Packages that use this: xml-hamlet . Please see the documentation at <http://www.yesodweb.com/book/shakespearean-templates> for more details. category: Web, Yesod stability: Stable-cabal-version: >= 1.8+cabal-version: >= 1.10 build-type: Simple homepage: http://www.yesodweb.com/book/shakespearean-templates extra-source-files:+ other-messages/*.msg+ test-messages/*.msg test/reload.txt test/texts/*.text test/juliuses/*.julius test/juliuses/*.coffee- test-messages/*.msg test/cassiuses/*.cassius test/cassiuses/*.lucius test/hamlets/*.hamlet test/tmp.hs+ ChangeLog.md library- build-depends: base >= 4 && < 5+ default-language: Haskell2010+ build-depends: base >= 4.11 && < 5 , time >= 1- , system-filepath >= 0.4- , system-fileio >= 0.3 , containers- , template-haskell+ , template-haskell >= 2.7 , parsec >= 2 && < 4 , text >= 0.7 , process >= 1.0 , ghc-prim- , bytestring- , directory- , aeson+ , bytestring >= 0.11.2+ , directory >= 1.2+ , aeson < 3 , blaze-markup , blaze-html , exceptions+ , file-embed >= 0.0.1 && < 0.1 , transformers+ , vector+ , unordered-containers+ , scientific >= 0.3.0.0+ , th-lift exposed-modules: Text.Shakespeare.I18N Text.Shakespeare.Text@@ -58,26 +64,27 @@ Text.Coffee Text.Hamlet Text.Hamlet.RT+ Text.Hamlet.Runtime Text.Lucius+ Text.Lucius.Ordered Text.Cassius+ Text.Cassius.Ordered Text.Shakespeare.Base Text.Shakespeare Text.TypeScript+ Text.Internal.Cassius+ Text.Internal.Css+ Text.Internal.CssCommon+ Text.Internal.Lucius other-modules: Text.Hamlet.Parse- Text.Css Text.MkSizeType Text.IndentToBrace- Text.CssCommon+ ghc-options: -Wall if flag(test_export) cpp-options: -DTEST_EXPORT - extensions: TemplateHaskell-- if impl(ghc >= 7.4)- cpp-options: -DGHC_7_4- if os(windows) CPP-Options: "-DWINDOWS" @@ -99,42 +106,21 @@ default: False flag test_roy- description: render tests through coffeescript render function- -- cabal configure --enable-tests -ftest_coffee && cabal build && dist/build/test/test+ description: render tests through roy render function+ -- cabal configure --enable-tests -ftest_roy && cabal build && dist/build/test/test default: False --- Commented out due to concerns that the Hackage page looks too intimidating.---- flag servius--- description: build the servius web server--- default: True------ Executable servius--- Main-is: servius.hs--- hs-source-dirs: app--- if flag(servius)--- buildable: True--- else--- buildable: False--- Build-depends: base >= 4 && < 5--- , wai-app-static >= 2.0.1 && < 2.1--- , bytestring >= 0.9.1.4--- , text >= 0.7--- , http-types--- , shakespeare--- , wai >= 1.3 && < 2.2--- , blaze-html >= 0.5--- , blaze-builder- test-suite test+ default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs other-modules: Text.Shakespeare.BaseSpec Text.Shakespeare.I18NSpec- Text.Shakespeare.JsSpec Text.Shakespeare.TextSpec- Text.Shakespeare.CssSpec- Text.Shakespeare.HamletSpec+ Text.Shakespeare.BuilderQQ+ Text.CssSpec+ Text.HamletSpec+ Text.JuliusSpec Quoter HamletTestTypes @@ -143,17 +129,16 @@ type: exitcode-stdio-1.0 ghc-options: -Wall- build-depends: base >= 4 && < 5+ build-tool-depends: hspec-discover:hspec-discover+ build-depends: base >= 4.9 && < 5 , shakespeare , time >= 1- , system-filepath >= 0.4- , system-fileio >= 0.3 , containers , parsec >= 2 && < 4- , hspec >= 1.3+ , hspec == 2.* , text >= 0.7 , process- , template-haskell+ , template-haskell >= 2.7 , ghc-prim , HUnit , bytestring@@ -164,9 +149,7 @@ , blaze-html , exceptions - extensions: TemplateHaskell - source-repository head type: git- location: git://github.com/yesodweb/shakespeare.git+ location: https://github.com/yesodweb/shakespeare.git
+ test/Text/CssSpec.hs view
@@ -0,0 +1,1566 @@+{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -O0 #-} +module Text.CssSpec (spec) where + +import Test.HUnit hiding (Test) +import Test.Hspec + +import Prelude hiding (reverse) +import Text.Cassius +import qualified Text.Cassius.Ordered as Ordered +import Text.Lucius +import qualified Text.Lucius.Ordered as Ordered +import Data.List (intercalate) +import qualified Data.Text.Lazy as T +import qualified Data.Text as TS +import qualified Data.List +import qualified Data.List as L +import Data.Text (Text, pack, unpack) + +spec :: Spec +spec = do + describe "Unordered parsers" $ do + it "cassius" caseCassius + it "cassiusFile" caseCassiusFile + it "cassius single comment" caseCassiusSingleComment + it "cassius leading comment" caseCassiusLeadingComment + + it "cassiusFileDebug" $ do + let var = "var" + let selector = "foo" + let urlp = (Home, [(pack "p", pack "q")]) + flip celper $(cassiusFileDebug "test/cassiuses/external1.cassius") $ concat + [ "foo {\n background: #000;\n bar: baz;\n color: #F00;\n}\n" + , "bin {\n" + , " background-image: url(url);\n" + , " bar: bar;\n color: #7F6405;\n fvarx: someval;\n unicode-test: שלום;\n" + , " urlp: url(url?p=q);\n}\n" + ] + +{- TODO + it "cassiusFileDebugChange" $ do + let var = "var" + writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 1" + celper "foo{var:1}" $(cassiusFileDebug "test/cassiuses/external2.cassius") + writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 2" + celper "foo{var:2}" $(cassiusFileDebug "test/cassiuses/external2.cassius") + writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 1" + -} + + + it "cassius comments" $ do + -- FIXME reconsider Hamlet comment syntax? + celper "" [cassius|/* this is a comment */ +/* another comment */ +/*a third one*/|] + + it "cassius pseudo-class" $ + flip celper [cassius| +a:visited + color: blue +|] "a:visited{color:blue}" + + + it "ignores a blank line" $ do + celper "foo{bar:baz}" [cassius| +foo + + bar: baz + +|] + + + it "leading spaces" $ + celper "foo{bar:baz}" [cassius| + foo + bar: baz +|] + + + it "cassius all spaces" $ + celper "h1{color:green }" [cassius| + h1 + color: green + |] + + + it "cassius whitespace and colons" $ do + celper "h1:hover{color:green ;font-family:sans-serif}" [cassius| + h1:hover + color: green + font-family:sans-serif + |] + + + it "cassius trailing comments" $ + celper "h1:hover{color:green ;font-family:sans-serif}" [cassius| + h1:hover /* Please ignore this */ + color: green /* This is a comment. */ + /* Obviously this is ignored too. */ + font-family:sans-serif + |] + + it "cassius nesting" $ + celper "foo bar{baz:bin}" [cassius| + foo + bar + baz: bin + |] + + it "cassius variable" $ + celper "foo bar{baz:bin}" [cassius| + @binvar: bin + foo + bar + baz: #{binvar} + |] + + it "cassius trailing semicolon" $ + celper "foo bar{baz:bin}" [cassius| + @binvar: bin + foo + bar + baz: #{binvar}; + |] + + + + it "cassius module names" $ do + let foo = "foo" + dub = 3.14::Double + int = -5::Int + celper "sel{bar:oof oof 3.14 -5}" + [cassius| +sel + bar: #{Data.List.reverse foo} #{L.reverse foo} #{show dub} #{show int} +|] + + + + it "single dollar at and caret" $ do + celper "sel{att:$@^}" [cassius| +sel + att: $@^ +|] + + {- + celper "sel{att:#{@{^{}" [cassius| +sel + att: #\{@\{^{ +|] +-} + + + it "dollar operator" $ do + let val = (1, (2, 3)) :: (Integer, (Integer, Integer)) + celper "sel{att:2}" [cassius| +sel + att: #{ show $ fst $ snd val } +|] + celper "sel{att:2}" [cassius| +sel + att: #{ show $ fst $ snd $ val} +|] + + + + it "embedded slash" $ do + celper "sel{att:///}" [cassius| +sel + att: /// +|] + + + + + + + it "multi cassius" $ do + celper "foo{bar:baz;bar:bin}" [cassius| +foo + bar: baz + bar: bin +|] + + + + + + + it "lucius" $ do + let var = "var" + let urlp = (Home, [(pack "p", pack "q")]) + flip celper [lucius| +foo { + background: #{colorBlack}; + bar: baz; + color: #{colorRed}; +} +bin { + background-image: url(@{Home}); + bar: bar; + color: #{(((Color 127) 100) 5)}; + f#{var}x: someval; + unicode-test: שלום; + urlp: url(@?{urlp}); +} +|] $ concat + [ "foo{background:#000;bar:baz;color:#F00}" + , "bin{" + , "background-image:url(url);" + , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" + , "urlp:url(url?p=q)}" + ] + + + + it "lucius file" $ do + let var = "var" + let urlp = (Home, [(pack "p", pack "q")]) + flip celper $(luciusFile "test/cassiuses/external1.lucius") $ concat + [ "foo{background:#000;bar:baz;color:#F00}" + , "bin{" + , "background-image:url(url);" + , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" + , "urlp:url(url?p=q)}" + ] + + it "lucius file debug" caseLuciusFileDebug + + + + + it "lucius nested" $ do + celper "foo bar{baz:bin}" $(luciusFile "test/cassiuses/external-nested.lucius") + celper "foo bar {\n baz: bin;\n}\n" $(luciusFileDebug "test/cassiuses/external-nested.lucius") + celper "foo bar{baz:bin}" [lucius| + foo { + bar { + baz: bin; + } + } + |] + celper "foo1 bar,foo2 bar{baz:bin}" [lucius| + foo1, foo2 { + bar { + baz: bin; + } + } + |] + + + it "lucius charset" $ do + celper (concat ["@charset \"utf-8\";" + , "#content ul{list-style:none;padding:0 5em}" + , "#content ul li{padding:1em 0}" + , "#content ul li a{color:#419a56;font-family:'TeXGyreHerosBold',helvetica,arial,sans-serif;font-weight:bold;text-transform:uppercase;white-space:nowrap}" + ]) [lucius| +@charset "utf-8"; +#content ul +{ + list-style: none; + padding: 0 5em; + li + { + padding: 1em 0; + a + { + color: #419a56; + font-family: 'TeXGyreHerosBold',helvetica,arial,sans-serif; + font-weight: bold; + text-transform: uppercase; + white-space: nowrap; + } + } +} +|] + + it "lucius media" $ do + celper "@media only screen{foo bar{baz:bin}}" $(luciusFile "test/cassiuses/external-media.lucius") + celper "@media only screen {\n foo bar {\n baz: bin;\n }\n}\n" $(luciusFileDebug "test/cassiuses/external-media.lucius") + celper "@media only screen{foo bar{baz:bin}}" [lucius| + @media only screen{ + foo { + bar { + baz: bin; + } + } + } + |] + + it "lucius supports" $ do + celper "@supports only screen{hana dul{set:net}}" $(luciusFile "test/cassiuses/external-supports.lucius") + celper "@supports only screen {\n hana dul {\n set: net;\n }\n}\n" $(luciusFileDebug "test/cassiuses/external-supports.lucius") + celper "@supports only screen {hana,dul{set:net;dasut:yeosut}}" [lucius| + @supports only screen { + hana, dul { + set: net; + dasut: yeosut; + } + } + |] + + {- + it "cassius removes whitespace" $ do + celper "foo{bar:baz}" [cassius| + foo + bar : baz + |] + -} + + + + + + it "lucius trailing comments" $ + celper "foo{bar:baz}" [lucius|foo{bar:baz;}/* ignored*/|] + + it "lucius variables" $ celper "foo{bar:baz}" [lucius| +@myvar: baz; +foo { + bar: #{myvar}; +} +|] + it "lucius CDO/CDC tokens" $ + celper "*{a:b}" [lucius| +<!-- --> <!-- +* { + a: b; +} +--> +|] + it "lucius @import statements" $ + celper "@import url(\"bla.css\");" [lucius| +@import url("bla.css"); +|] + it "lucius simple escapes" $ + celper "*{a:test}" [lucius| +* { + a: t\65 st; +} +|] + it "lucius bounded escapes" $ + celper "*{a:teft}" [lucius| +* { + a: t\000065ft; +} +|] + it "lucius case-insensitive keywords" $ + celper "@media foo {}" [lucius| +@MeDIa foo { +} +|] + it "lucius @page statements" $ + celper "@page :right{a:b;c:d}" [lucius| +@page :right { +a:b; +c:d; +} +|] + it "lucius @font-face statements" $ + celper "@font-face{a:b;c:d}" [lucius| +@font-face { +a:b; +c:d; +} +|] + it "lucius runtime" $ Right (T.pack "foo {\n bar: baz;\n}\n") @=? luciusRT (T.pack "foo { bar: #{myvar}}") [(TS.pack "myvar", TS.pack "baz")] + it "lucius runtime variables" $ Right (T.pack "foo {\n bar: baz;\n}\n") @=? luciusRT (T.pack "@dummy: dummy; @myvar: baz; @dummy2: dummy; foo { bar: #{myvar}}") [] + it "lucius whtiespace" $ Right (T.pack "@media foo {\n bar {\n baz: bin;\n baz2: bin2;\n }\n}\n") + @=? luciusRT (T.pack "@media foo{bar{baz:bin;baz2:bin2}}") [] + it "variables inside value" $ + celper "foo{foo:XbarY}" [lucius| +@bar: bar; +foo { foo:X#{bar}Y; } +|] + it "variables in media selector" $ + celper "@media (max-width: 400px){foo{color:red}}" [lucius| +@mobileWidth: 400px; +@media (max-width: #{mobileWidth}){ foo { color: red; } } +|] + -- note: this file format is window (CR;NL) + it "variables in supports selector" $ + celper "@supports ((perspective: 1px)\r\n and (not (-webkit-overflow-scrolling: touch))) {html,body{overflow:hidden;height:100%}body{transform:translateZ(0px)}}" [lucius| +@perspectiveTestValue: 1px; +@supports ((perspective: #{perspectiveTestValue}) + and (not (-webkit-overflow-scrolling: touch))) { + html, body { + overflow: hidden; + height:100%; + } + body { + transform: translateZ(0px); + } +} +|] + it "URLs in import" $ celper + "@import url(\"suburl\");" [lucius| +@import url("@{Sub SubUrl}"); +|] + it "vars in charset" $ do + let charset = "mycharset" + celper "@charset mycharset;" [lucius| +@charset #{charset}; +|] + it "keyframes" $ celper + "@keyframes mymove {from{top:0px}to{top:200px}}" [lucius| +@keyframes mymove { + from { + top: 0px; + } + to { + top: 200px; + } +} +|] + it "prefixed keyframes" $ celper + "@-webkit-keyframes mymove {from{top:0px}to{top:200px}}" [lucius| +@-webkit-keyframes mymove { + from { + top: 0px; + } + to { + top: 200px; + } +} +|] + it "lucius mixins" $ do + let bins = [luciusMixin| + bin:bin2; + foo2 { + x: y; + } + |] :: Mixin + celper "foo{bar:baz;bin:bin2}foo foo2{x:y}" [lucius| + foo { + bar: baz; + ^{bins} + } + |] + it "cassius mixins" $ do + let bins = [cassiusMixin| + bin:bin2 + bin3:bin4 + + foo2 + x:y + |] :: Mixin + celper "foo{bar:baz;bin:bin2;bin3:bin4}foo foo2{x:y}" [lucius| + foo { + bar: baz; + ^{bins} + } + |] + it "cassius nested mixins" $ do + let bins = [cassiusMixin| + bin:bin2 + bin3:bin4 + |] :: Mixin + bams = [cassiusMixin| + bam:bam2 + ^{bins} + bam3:bam4 + |] :: Mixin + celper "foo{bar:baz;bam:bam2;bam3:bam4;bin:bin2;bin3:bin4}" [lucius| + foo { + ^{bams} + bar: baz; + } + |] + + it "more complicated mixins" $ do + let transition val = + [luciusMixin| + -webkit-transition: #{val}; + -moz-transition: #{val}; + -ms-transition: #{val}; + -o-transition: #{val}; + transition: #{val}; + |] + + celper ".some-class{-webkit-transition:all 4s ease;-moz-transition:all 4s ease;-ms-transition:all 4s ease;-o-transition:all 4s ease;transition:all 4s ease}" + [lucius| + .some-class { + ^{transition "all 4s ease"} + } + |] + + it "nested mixin blocks" $ do + let bar = [luciusMixin| + bar { + bin:baz; + } + |] + foo = [luciusMixin| + foo { + ^{bar} + } + |] :: Mixin + celper "selector foo bar{bin:baz}" [lucius| + selector { + ^{foo} + } + |] + + it "mixins with pseudoselectors" $ do + let bar = [luciusMixin| + &:hover { + bin:baz; + } + |] :: Mixin + celper "foo:hover{bin:baz}" [lucius| + foo { + ^{bar} + } + |] + + it "mixins insane structure" $ do + let bar = [luciusMixin| + bar1:bar2; + ^{bim} + &:hover { + ^{bim} + jam1:jam2; + ^{bam} + } + + ram { + ram1:ram2; + ^{bim} + ^{bam} + } + ^{bam} + bar3:bar4; + |] :: Mixin + bim = [luciusMixin| + bim1:bim2; + bim-block1 { + bim3:bim4; + bim5:bim6; + } + bim-block2 { + bim7:bim8; + bim9:bim10; + } + |] + bam = [luciusMixin| + bam1:bam2; + bam-block1 { + bam3:bam4; + bam5:bam6; + } + bam-block2 { + bam7:bam8; + bam9:bam10; + } + |] + + celper + -- 1. attributes + -- 2. mixins attributes + -- 3. blocks + -- 4. mixins blocks + "foo{foo1:foo2;foo3:foo4;bar1:bar2;bar3:bar4;bim1:bim2;bam1:bam2}\ + + \foo foo-block1{bar1:bar2;bar3:bar4;bim1:bim2;bam1:bam2}\ + \foo foo-block1:hover{jam1:jam2;bim1:bim2;bam1:bam2}\ + \foo foo-block1:hover bim-block1{bim3:bim4;bim5:bim6}\ + \foo foo-block1:hover bim-block2{bim7:bim8;bim9:bim10}\ + \foo foo-block1:hover bam-block1{bam3:bam4;bam5:bam6}\ + \foo foo-block1:hover bam-block2{bam7:bam8;bam9:bam10}\ + \foo foo-block1 ram{ram1:ram2;bim1:bim2;bam1:bam2}\ + \foo foo-block1 ram bim-block1{bim3:bim4;bim5:bim6}\ + \foo foo-block1 ram bim-block2{bim7:bim8;bim9:bim10}\ + \foo foo-block1 ram bam-block1{bam3:bam4;bam5:bam6}\ + \foo foo-block1 ram bam-block2{bam7:bam8;bam9:bam10}\ + \foo foo-block1 bim-block1{bim3:bim4;bim5:bim6}\ + \foo foo-block1 bim-block2{bim7:bim8;bim9:bim10}\ + \foo foo-block1 bam-block1{bam3:bam4;bam5:bam6}\ + \foo foo-block1 bam-block2{bam7:bam8;bam9:bam10}\ + + \foo foo-block2{bar1:bar2;bar3:bar4;bim1:bim2;bam1:bam2}\ + \foo foo-block2:hover{jam1:jam2;bim1:bim2;bam1:bam2}\ + \foo foo-block2:hover bim-block1{bim3:bim4;bim5:bim6}\ + \foo foo-block2:hover bim-block2{bim7:bim8;bim9:bim10}\ + \foo foo-block2:hover bam-block1{bam3:bam4;bam5:bam6}\ + \foo foo-block2:hover bam-block2{bam7:bam8;bam9:bam10}\ + \foo foo-block2 ram{ram1:ram2;bim1:bim2;bam1:bam2}\ + \foo foo-block2 ram bim-block1{bim3:bim4;bim5:bim6}\ + \foo foo-block2 ram bim-block2{bim7:bim8;bim9:bim10}\ + \foo foo-block2 ram bam-block1{bam3:bam4;bam5:bam6}\ + \foo foo-block2 ram bam-block2{bam7:bam8;bam9:bam10}\ + \foo foo-block2 bim-block1{bim3:bim4;bim5:bim6}\ + \foo foo-block2 bim-block2{bim7:bim8;bim9:bim10}\ + \foo foo-block2 bam-block1{bam3:bam4;bam5:bam6}\ + \foo foo-block2 bam-block2{bam7:bam8;bam9:bam10}\ + + \foo:hover{jam1:jam2;bim1:bim2;bam1:bam2}\ + \foo:hover bim-block1{bim3:bim4;bim5:bim6}\ + \foo:hover bim-block2{bim7:bim8;bim9:bim10}\ + \foo:hover bam-block1{bam3:bam4;bam5:bam6}\ + \foo:hover bam-block2{bam7:bam8;bam9:bam10}\ + \foo ram{ram1:ram2;bim1:bim2;bam1:bam2}\ + \foo ram bim-block1{bim3:bim4;bim5:bim6}\ + \foo ram bim-block2{bim7:bim8;bim9:bim10}\ + \foo ram bam-block1{bam3:bam4;bam5:bam6}\ + \foo ram bam-block2{bam7:bam8;bam9:bam10}\ + \foo bim-block1{bim3:bim4;bim5:bim6}\ + \foo bim-block2{bim7:bim8;bim9:bim10}\ + \foo bam-block1{bam3:bam4;bam5:bam6}\ + \foo bam-block2{bam7:bam8;bam9:bam10}" + [lucius| + foo { + foo1:foo2; + ^{bar} + foo-block1 { + ^{bar} + } + foo-block2 { + ^{bar} + } + foo3:foo4; + } + |] + + it "runtime mixin" $ do + let bins = [luciusMixin| + bin:bin2; + foo2 { + x: y; + } + |] :: Mixin + Right (T.pack "foo{bar:baz;bin:bin2}foo foo2{x:y}") @=? luciusRTMixin + (T.pack "foo { bar: baz; ^{bins} }") + True + [(TS.pack "bins", RTVMixin bins)] + + it "luciusFileReload mixin" $ do + let mixin = [luciusMixin|foo:bar;baz:bin|] + flip celper $(luciusFileReload "test/cassiuses/mixin.lucius") $ concat + [ "selector {\n foo: bar;\n baz: bin;\n}\n" + ] + + it "cassiusFileReload with import URL" $ do + celper + "@import url(url);\n" + $(cassiusFileReload "test/cassiuses/reload-import.cassius") + + it "& subblocks" $ + celper "foo:bar{baz:bin}" + [lucius| + foo { + &:bar { + baz: bin; + } + } + |] + + describe "font-face #139" $ do + it "lucius" $ + celper "@font-face{font-family:myFirstFont;src:url(sansation_light.woff)}" + [lucius| + @font-face { + font-family: myFirstFont; + src: url(sansation_light.woff); + } + |] + it "cassius" $ + celper "@font-face{font-family:myFirstFont;src:url(sansation_light.woff)}" + [cassius| + @font-face + font-family: myFirstFont + src: url(sansation_light.woff) + |] + + describe "trailing semicolon in mixin" $ do + let someMixin = [luciusMixin|foo:bar|] + it "direct in lucius" $ + celper "baz{foo:bar}" [lucius| + baz { + ^{someMixin}; + } + |] + + it "implicit in cassius #194" $ + celper "baz{foo:bar}" [cassius| + baz + ^{someMixin} + |] + + describe "Ordered parsers" $ do + it "Ordered.cassius" caseCassiusOrd + it "Ordered.cassiusFile" caseCassiusFileOrd + it "Ordered.cassius single comment" caseCassiusSingleCommentOrd + it "Ordered.cassius leading comment" caseCassiusLeadingCommentOrd + + it "cassiusFileDebug" $ do + let var = "var" + let selector = "foo" + let urlp = (Home, [(pack "p", pack "q")]) + flip celper $(cassiusFileDebug "test/cassiuses/external1.cassius") $ concat + [ "foo {\n background: #000;\n bar: baz;\n color: #F00;\n}\n" + , "bin {\n" + , " background-image: url(url);\n" + , " bar: bar;\n color: #7F6405;\n fvarx: someval;\n unicode-test: שלום;\n" + , " urlp: url(url?p=q);\n}\n" + ] + +{- TODO + it "cassiusFileDebugChange" $ do + let var = "var" + writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 1" + celper "foo{var:1}" $(cassiusFileDebug "test/cassiuses/external2.cassius") + writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 2" + celper "foo{var:2}" $(cassiusFileDebug "test/cassiuses/external2.cassius") + writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 1" + -} + + describe "Ordered.cassius" $ do + it "comments" $ do + -- FIXME reconsider Hamlet comment syntax? + celper "" [Ordered.cassius|/* this is a comment */ +/* another comment */ +/*a third one*/|] + + it "pseudo-class" $ + flip celper [Ordered.cassius| +a:visited + color: blue +|] "a:visited{color:blue}" + + + it "ignores a blank line" $ do + celper "foo{bar:baz}" [Ordered.cassius| +foo + + bar: baz + +|] + + + it "leading spaces" $ + celper "foo{bar:baz}" [Ordered.cassius| + foo + bar: baz +|] + + + it "all spaces" $ + celper "h1{color:green }" [Ordered.cassius| + h1 + color: green + |] + + + it "whitespace and colons" $ do + celper "h1:hover{color:green ;font-family:sans-serif}" [Ordered.cassius| + h1:hover + color: green + font-family:sans-serif + |] + + + it "trailing comments" $ + celper "h1:hover{color:green ;font-family:sans-serif}" [Ordered.cassius| + h1:hover /* Please ignore this */ + color: green /* This is a comment. */ + /* Obviously this is ignored too. */ + font-family:sans-serif + |] + + it "nesting" $ + celper "foo bar{baz:bin}" [Ordered.cassius| + foo + bar + baz: bin + |] + + it "variable" $ + celper "foo bar{baz:bin}" [Ordered.cassius| + @binvar: bin + foo + bar + baz: #{binvar} + |] + + it "trailing semicolon" $ + celper "foo bar{baz:bin}" [Ordered.cassius| + @binvar: bin + foo + bar + baz: #{binvar}; + |] + + + it "module names" $ do + let foo = "foo" + dub = 3.14::Double + int = -5::Int + celper "sel{bar:oof oof 3.14 -5}" + [Ordered.cassius| +sel + bar: #{Data.List.reverse foo} #{L.reverse foo} #{show dub} #{show int} +|] + + + it "single dollar at and caret" $ do + celper "sel{att:$@^}" [Ordered.cassius| +sel + att: $@^ +|] + + {- + celper "sel{att:#{@{^{}" [cassius| +sel + att: #\{@\{^{ +|] +-} + + + it "dollar operator" $ do + let val = (1, (2, 3)) :: (Integer, (Integer, Integer)) + celper "sel{att:2}" [Ordered.cassius| +sel + att: #{ show $ fst $ snd val } +|] + celper "sel{att:2}" [Ordered.cassius| +sel + att: #{ show $ fst $ snd $ val} +|] + + + it "embedded slash" $ do + celper "sel{att:///}" [Ordered.cassius| +sel + att: /// +|] + + + it "multi cassius" $ do + celper "foo{bar:baz;bar:bin}" [Ordered.cassius| +foo + bar: baz + bar: bin +|] + + describe "Ordered.lucius" $ do + it "lucius" $ do + let var = "var" + let urlp = (Home, [(pack "p", pack "q")]) + flip celper [Ordered.lucius| +foo { + background: #{colorBlack}; + bar: baz; + color: #{colorRed}; +} +bin { + background-image: url(@{Home}); + bar: bar; + color: #{(((Color 127) 100) 5)}; + f#{var}x: someval; + unicode-test: שלום; + urlp: url(@?{urlp}); +} +|] $ concat + [ "foo{background:#000;bar:baz;color:#F00}" + , "bin{" + , "background-image:url(url);" + , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" + , "urlp:url(url?p=q)}" + ] + + it "lucius file" $ do + let var = "var" + let urlp = (Home, [(pack "p", pack "q")]) + flip celper $(Ordered.luciusFile "test/cassiuses/external1.lucius") $ concat + [ "foo{background:#000;bar:baz;color:#F00}" + , "bin{" + , "background-image:url(url);" + , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" + , "urlp:url(url?p=q)}" + ] + + it "lucius file debug" caseLuciusFileDebugOrd + + it "lucius nested" $ do + celper "foo bar{baz:bin}" $(Ordered.luciusFile "test/cassiuses/external-nested.lucius") + celper "foo bar {\n baz: bin;\n}\n" $(luciusFileDebug "test/cassiuses/external-nested.lucius") + celper "foo bar{baz:bin}" [lucius| + foo { + bar { + baz: bin; + } + } + |] + celper "foo1 bar,foo2 bar{baz:bin}" [lucius| + foo1, foo2 { + bar { + baz: bin; + } + } + |] + + + it "lucius charset" $ do + celper (concat ["@charset \"utf-8\";" + , "#content ul{list-style:none;padding:0 5em}" + , "#content ul li{padding:1em 0}" + , "#content ul li a{color:#419a56;font-family:'TeXGyreHerosBold',helvetica,arial,sans-serif;font-weight:bold;text-transform:uppercase;white-space:nowrap}" + ]) [Ordered.lucius| +@charset "utf-8"; +#content ul +{ + list-style: none; + padding: 0 5em; + li + { + padding: 1em 0; + a + { + color: #419a56; + font-family: 'TeXGyreHerosBold',helvetica,arial,sans-serif; + font-weight: bold; + text-transform: uppercase; + white-space: nowrap; + } + } +} +|] + + it "lucius media" $ do + celper "@media only screen{foo bar{baz:bin}}" $(Ordered.luciusFile "test/cassiuses/external-media.lucius") + celper "@media only screen {\n foo bar {\n baz: bin;\n }\n}\n" $(Ordered.luciusFileDebug "test/cassiuses/external-media.lucius") + celper "@media only screen{foo bar{baz:bin}}" [Ordered.lucius| + @media only screen{ + foo { + bar { + baz: bin; + } + } + } + |] + + it "lucius supports" $ do + celper "@supports only screen{hana dul{set:net}}" $(Ordered.luciusFile "test/cassiuses/external-supports.lucius") + celper "@supports only screen {\n hana dul {\n set: net;\n }\n}\n" $(Ordered.luciusFileDebug "test/cassiuses/external-supports.lucius") + celper "@supports only screen {hana,dul{set:net;dasut:yeosut}}" [Ordered.lucius| + @supports only screen { + hana, dul { + set: net; + dasut: yeosut; + } + } + |] + + {- + it "cassius removes whitespace" $ do + celper "foo{bar:baz}" [cassius| + foo + bar : baz + |] + -} + + it "lucius trailing comments" $ + celper "foo{bar:baz}" [Ordered.lucius|foo{bar:baz;}/* ignored*/|] + + it "lucius variables" $ celper "foo{bar:baz}" [lucius| +@myvar: baz; +foo { + bar: #{myvar}; +} +|] + it "lucius CDO/CDC tokens" $ + celper "*{a:b}" [lucius| +<!-- --> <!-- +* { + a: b; +} +--> +|] + it "lucius @import statements" $ + celper "@import url(\"bla.css\");" [Ordered.lucius| +@import url("bla.css"); +|] + it "lucius simple escapes" $ + celper "*{a:test}" [Ordered.lucius| +* { + a: t\65 st; +} +|] + it "lucius bounded escapes" $ + celper "*{a:teft}" [Ordered.lucius| +* { + a: t\000065ft; +} +|] + it "lucius case-insensitive keywords" $ + celper "@media foo {}" [Ordered.lucius| +@MeDIa foo { +} +|] + it "lucius @page statements" $ + celper "@page :right{a:b;c:d}" [Ordered.lucius| +@page :right { +a:b; +c:d; +} +|] + it "lucius @font-face statements" $ + celper "@font-face{a:b;c:d}" [Ordered.lucius| +@font-face { +a:b; +c:d; +} +|] + it "lucius runtime" $ Right (T.pack "foo {\n bar: baz;\n}\n") @=? Ordered.luciusRT (T.pack "foo { bar: #{myvar}}") [(TS.pack "myvar", TS.pack "baz")] + it "lucius runtime variables" $ Right (T.pack "foo {\n bar: baz;\n}\n") @=? Ordered.luciusRT (T.pack "@dummy: dummy; @myvar: baz; @dummy2: dummy; foo { bar: #{myvar}}") [] + it "lucius whtiespace" $ Right (T.pack "@media foo {\n bar {\n baz: bin;\n baz2: bin2;\n }\n}\n") + @=? Ordered.luciusRT (T.pack "@media foo{bar{baz:bin;baz2:bin2}}") [] + it "variables inside value" $ + celper "foo{foo:XbarY}" [Ordered.lucius| +@bar: bar; +foo { foo:X#{bar}Y; } +|] + it "variables in media selector" $ + celper "@media (max-width: 400px){foo{color:red}}" [Ordered.lucius| +@mobileWidth: 400px; +@media (max-width: #{mobileWidth}){ foo { color: red; } } +|] + -- note: this file format is window (CR;NL) + it "variables in supports selector" $ + celper "@supports ((perspective: 1px)\r\n and (not (-webkit-overflow-scrolling: touch))) {html,body{overflow:hidden;height:100%}body{transform:translateZ(0px)}}" [Ordered.lucius| +@perspectiveTestValue: 1px; +@supports ((perspective: #{perspectiveTestValue}) + and (not (-webkit-overflow-scrolling: touch))) { + html, body { + overflow: hidden; + height:100%; + } + body { + transform: translateZ(0px); + } +} +|] + it "URLs in import" $ celper + "@import url(\"suburl\");" [Ordered.lucius| +@import url("@{Sub SubUrl}"); +|] + it "vars in charset" $ do + let charset = "mycharset" + celper "@charset mycharset;" [Ordered.lucius| +@charset #{charset}; +|] + it "keyframes" $ celper + "@keyframes mymove {from{top:0px}to{top:200px}}" [Ordered.lucius| +@keyframes mymove { + from { + top: 0px; + } + to { + top: 200px; + } +} +|] + it "prefixed keyframes" $ celper + "@-webkit-keyframes mymove {from{top:0px}to{top:200px}}" [Ordered.lucius| +@-webkit-keyframes mymove { + from { + top: 0px; + } + to { + top: 200px; + } +} +|] + + describe "ordered mixins" $ do + it "lucius mixins" $ do + let bins = [Ordered.luciusMixin| + bin:bin2; + foo2 { + x: y; + } + |] :: Mixin + + celper "foo{bar:baz;bin:bin2}foo foo2{x:y}" [Ordered.lucius| + foo { + bar: baz; + ^{bins} + } + |] + it "lucius mixins keep order" $ do + let bins = [Ordered.luciusMixin| + bin:bin2; + foo2 { + x: y; + } + |] :: Mixin + celper "foo{bar1:baz1;bin:bin2;bar2:baz2}foo foo2{x:y}" [Ordered.lucius| + foo { + bar1:baz1; + ^{bins} + bar2: baz2; + } + |] + + it "lucius nested mixins" $ do + let bins = [Ordered.luciusMixin| + bin:bin2; + bin3:bin4; + |] :: Mixin + bams = [Ordered.luciusMixin| + bam:bam2; + ^{bins} + bam3:bam4; + |] :: Mixin + celper "foo{bar:bar2;bam:bam2;bin:bin2;bin3:bin4;bam3:bam4;bar3:bar4}" [Ordered.lucius| + foo { + bar:bar2; + ^{bams} + bar3: bar4; + } + |] + + it "cassius mixins" $ do + let bins = [Ordered.cassiusMixin| + bin:bin2 + bin3:bin4 + |] :: Mixin + -- No sublocks celper "foo{bar:baz;bin:bin2}foo foo2{x:y}" [lucius| + celper "foo{bar:baz;bin:bin2;bin3:bin4}" [Ordered.lucius| + foo { + bar: baz; + ^{bins} + } + |] + + it "cassius mixins keep order" $ do + let bins = [Ordered.cassiusMixin| + bin:bin2 + bin3:bin4 + |] :: Mixin + -- No sublocks celper "foo{bar:baz;bin:bin2}foo foo2{x:y}" [lucius| + celper "foo{bar1:baz1;bin:bin2;bin3:bin4;bar2:baz2}" [Ordered.lucius| + foo { + bar1: baz1; + ^{bins} + bar2:baz2; + } + |] + + it "cassius nested mixins" $ do + let bins = [Ordered.cassiusMixin| + bin:bin2 + bin3:bin4 + |] :: Mixin + bams = [Ordered.cassiusMixin| + bam:bam2 + ^{bins} + bam3:bam4 + |] :: Mixin + celper "foo{bar:bar2;bam:bam2;bin:bin2;bin3:bin4;bam3:bam4;bar3:bar4}" [Ordered.lucius| + foo { + bar:bar2; + ^{bams} + bar3: bar4; + } + |] + + it "more complicated mixins" $ do + let transition val = + [Ordered.luciusMixin| + -webkit-transition: #{val}; + -moz-transition: #{val}; + -ms-transition: #{val}; + -o-transition: #{val}; + transition: #{val}; + |] + + celper ".some-class{-webkit-transition:all 4s ease;-moz-transition:all 4s ease;-ms-transition:all 4s ease;-o-transition:all 4s ease;transition:all 4s ease}" + [Ordered.lucius| + .some-class { + ^{transition "all 4s ease"} + } + |] + + it "nested mixin blocks" $ do + let bar = [Ordered.luciusMixin| + bar { + bin:baz; + } + |] + foo = [luciusMixin| + foo { + ^{bar} + } + |] :: Mixin + celper "selector foo bar{bin:baz}" [Ordered.lucius| + selector { + ^{foo} + } + |] + + it "mixins with pseudoselectors" $ do + let bar = [Ordered.luciusMixin| + &:hover { + bin:baz; + } + |] :: Mixin + celper "foo:hover{bin:baz}" [Ordered.lucius| + foo { + ^{bar} + } + |] + + it "mixins insane structure" $ do + let bar = [Ordered.luciusMixin| + bar1:bar2; + ^{bim} + &:hover { + ^{bim} + jam1:jam2; + ^{bam} + } + + ram { + ^{bim} + ram1:ram2; + ^{bam} + } + ^{bam} + bar3:bar4; + |] :: Mixin + bim = [Ordered.luciusMixin| + bim1:bim2; + bim-block1 { + bim3:bim4; + bim5:bim6; + } + bim-block2 { + bim7:bim8; + bim9:bim10; + } + |] + bam = [Ordered.luciusMixin| + bam1:bam2; + bam-block1 { + bam3:bam4; + bam5:bam6; + } + bam-block2 { + bam7:bam8; + bam9:bam10; + } + |] + + celper + -- 1. ordered attributes and mixins attributes + -- 2. blocks + -- 3. mixins blocks + "foo{foo1:foo2;bar1:bar2;bim1:bim2;bam1:bam2;bar3:bar4;foo3:foo4}\ + + \foo foo-block1{bar1:bar2;bim1:bim2;bam1:bam2;bar3:bar4}\ + \foo foo-block1:hover{bim1:bim2;jam1:jam2;bam1:bam2}\ + \foo foo-block1:hover bim-block1{bim3:bim4;bim5:bim6}\ + \foo foo-block1:hover bim-block2{bim7:bim8;bim9:bim10}\ + \foo foo-block1:hover bam-block1{bam3:bam4;bam5:bam6}\ + \foo foo-block1:hover bam-block2{bam7:bam8;bam9:bam10}\ + \foo foo-block1 ram{bim1:bim2;ram1:ram2;bam1:bam2}\ + \foo foo-block1 ram bim-block1{bim3:bim4;bim5:bim6}\ + \foo foo-block1 ram bim-block2{bim7:bim8;bim9:bim10}\ + \foo foo-block1 ram bam-block1{bam3:bam4;bam5:bam6}\ + \foo foo-block1 ram bam-block2{bam7:bam8;bam9:bam10}\ + \foo foo-block1 bim-block1{bim3:bim4;bim5:bim6}\ + \foo foo-block1 bim-block2{bim7:bim8;bim9:bim10}\ + \foo foo-block1 bam-block1{bam3:bam4;bam5:bam6}\ + \foo foo-block1 bam-block2{bam7:bam8;bam9:bam10}\ + + \foo foo-block2{bar1:bar2;bim1:bim2;bam1:bam2;bar3:bar4}\ + \foo foo-block2:hover{bim1:bim2;jam1:jam2;bam1:bam2}\ + \foo foo-block2:hover bim-block1{bim3:bim4;bim5:bim6}\ + \foo foo-block2:hover bim-block2{bim7:bim8;bim9:bim10}\ + \foo foo-block2:hover bam-block1{bam3:bam4;bam5:bam6}\ + \foo foo-block2:hover bam-block2{bam7:bam8;bam9:bam10}\ + \foo foo-block2 ram{bim1:bim2;ram1:ram2;bam1:bam2}\ + \foo foo-block2 ram bim-block1{bim3:bim4;bim5:bim6}\ + \foo foo-block2 ram bim-block2{bim7:bim8;bim9:bim10}\ + \foo foo-block2 ram bam-block1{bam3:bam4;bam5:bam6}\ + \foo foo-block2 ram bam-block2{bam7:bam8;bam9:bam10}\ + \foo foo-block2 bim-block1{bim3:bim4;bim5:bim6}\ + \foo foo-block2 bim-block2{bim7:bim8;bim9:bim10}\ + \foo foo-block2 bam-block1{bam3:bam4;bam5:bam6}\ + \foo foo-block2 bam-block2{bam7:bam8;bam9:bam10}\ + + \foo:hover{bim1:bim2;jam1:jam2;bam1:bam2}\ + \foo:hover bim-block1{bim3:bim4;bim5:bim6}\ + \foo:hover bim-block2{bim7:bim8;bim9:bim10}\ + \foo:hover bam-block1{bam3:bam4;bam5:bam6}\ + \foo:hover bam-block2{bam7:bam8;bam9:bam10}\ + \foo ram{bim1:bim2;ram1:ram2;bam1:bam2}\ + \foo ram bim-block1{bim3:bim4;bim5:bim6}\ + \foo ram bim-block2{bim7:bim8;bim9:bim10}\ + \foo ram bam-block1{bam3:bam4;bam5:bam6}\ + \foo ram bam-block2{bam7:bam8;bam9:bam10}\ + \foo bim-block1{bim3:bim4;bim5:bim6}\ + \foo bim-block2{bim7:bim8;bim9:bim10}\ + \foo bam-block1{bam3:bam4;bam5:bam6}\ + \foo bam-block2{bam7:bam8;bam9:bam10}" + [Ordered.lucius| + foo { + foo1:foo2; + ^{bar} + foo-block1 { + ^{bar} + } + foo-block2 { + ^{bar} + } + foo3:foo4; + } + |] + + it "runtime mixin" $ do + let bins = [Ordered.luciusMixin| + bin:bin2; + foo2 { + x: y; + } + |] :: Mixin + Right (T.pack "foo{bar:baz;bin:bin2}foo foo2{x:y}") @=? Ordered.luciusRTMixin + (T.pack "foo { bar: baz; ^{bins} }") + True + [(TS.pack "bins", RTVMixin bins)] + + it "luciusFileReload mixin" $ do + let mixin = [Ordered.luciusMixin|foo:bar;baz:bin|] + flip celper $(Ordered.luciusFileReload "test/cassiuses/mixin.lucius") $ concat + [ "selector {\n foo: bar;\n baz: bin;\n}\n" + ] + + it "cassiusFileReload with import URL" $ do + celper + "@import url(url);\n" + $(Ordered.cassiusFileReload "test/cassiuses/reload-import.cassius") + + it "& subblocks" $ + celper "foo:bar{baz:bin}" + [Ordered.lucius| + foo { + &:bar { + baz: bin; + } + } + |] + + describe "font-face #139" $ do + it "lucius" $ + celper "@font-face{font-family:myFirstFont;src:url(sansation_light.woff)}" + [Ordered.lucius| + @font-face { + font-family: myFirstFont; + src: url(sansation_light.woff); + } + |] + it "cassius" $ + celper "@font-face{font-family:myFirstFont;src:url(sansation_light.woff)}" + [Ordered.cassius| + @font-face + font-family: myFirstFont + src: url(sansation_light.woff) + |] + + describe "trailing semicolon in mixin" $ do + let someMixin = [Ordered.luciusMixin|foo:bar|] + it "direct in lucius" $ + celper "baz{foo:bar}" [Ordered.lucius| + baz { + ^{someMixin}; + } + |] + + it "implicit in cassius #194" $ + celper "baz{foo:bar}" [Ordered.cassius| + baz + ^{someMixin} + |] + +data Url = Home | Sub SubUrl +data SubUrl = SubUrl +render :: Url -> [(Text, Text)] -> Text +render Home qs = pack "url" `mappend` showParams qs +render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs + +showParams :: [(Text, Text)] -> Text +showParams [] = pack "" +showParams z = + pack $ '?' : intercalate "&" (map go z) + where + go (x, y) = go' x ++ '=' : go' y + go' = concatMap encodeUrlChar . unpack + +-- | Taken straight from web-encodings; reimplemented here to avoid extra +-- dependencies. +encodeUrlChar :: Char -> String +encodeUrlChar c + -- List of unreserved characters per RFC 3986 + -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding + | 'A' <= c && c <= 'Z' = [c] + | 'a' <= c && c <= 'z' = [c] + | '0' <= c && c <= '9' = [c] +encodeUrlChar c@'-' = [c] +encodeUrlChar c@'_' = [c] +encodeUrlChar c@'.' = [c] +encodeUrlChar c@'~' = [c] +encodeUrlChar ' ' = "+" +encodeUrlChar y = + let (a, c) = fromEnum y `divMod` 16 + b = a `mod` 16 + showHex' x + | x < 10 = toEnum $ x + (fromEnum '0') + | x < 16 = toEnum $ x - 10 + (fromEnum 'A') + | otherwise = error $ "Invalid argument to showHex: " ++ show x + in ['%', showHex' b, showHex' c] + + + +celper :: HasCallStack => String -> CssUrl Url -> Assertion +celper res h = do + let x = renderCssUrl render h + T.pack res @=? x + +caseCassius :: Assertion +caseCassius = do + let var = "var" + let urlp = (Home, [(pack "p", pack "q")]) + flip celper [cassius| +foo + background: #{colorBlack} + bar: baz + color: #{colorRed} +bin + background-image: url(@{Home}) + bar: bar + color: #{(((Color 127) 100) 5)} + f#{var}x: someval + unicode-test: שלום + urlp: url(@?{urlp}) +|] $ concat + [ "foo{background:#000;bar:baz;color:#F00}" + , "bin{" + , "background-image:url(url);" + , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" + , "urlp:url(url?p=q)}" + ] + +caseCassiusOrd :: Assertion +caseCassiusOrd = do + let var = "var" + let urlp = (Home, [(pack "p", pack "q")]) + flip celper [Ordered.cassius| +foo + background: #{colorBlack} + bar: baz + color: #{colorRed} +bin + background-image: url(@{Home}) + bar: bar + color: #{(((Color 127) 100) 5)} + f#{var}x: someval + unicode-test: שלום + urlp: url(@?{urlp}) +|] $ concat + [ "foo{background:#000;bar:baz;color:#F00}" + , "bin{" + , "background-image:url(url);" + , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" + , "urlp:url(url?p=q)}" + ] + +caseCassiusFile :: Assertion +caseCassiusFile = do + let var = "var" + let selector = "foo" + let urlp = (Home, [(pack "p", pack "q")]) + flip celper $(cassiusFile "test/cassiuses/external1.cassius") $ concat + [ "foo{background:#000;bar:baz;color:#F00}" + , "bin{" + , "background-image:url(url);" + , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" + , "urlp:url(url?p=q)}" + ] + +caseCassiusFileOrd :: Assertion +caseCassiusFileOrd = do + let var = "var" + let selector = "foo" + let urlp = (Home, [(pack "p", pack "q")]) + flip celper $(Ordered.cassiusFile "test/cassiuses/external1.cassius") $ concat + [ "foo{background:#000;bar:baz;color:#F00}" + , "bin{" + , "background-image:url(url);" + , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" + , "urlp:url(url?p=q)}" + ] + +caseCassiusSingleComment :: Assertion +caseCassiusSingleComment = + flip celper [cassius| + /* + this is a comment + */ + |] "" + +caseCassiusSingleCommentOrd :: Assertion +caseCassiusSingleCommentOrd = + flip celper [Ordered.cassius| + /* + this is a comment + */ + |] "" + +caseCassiusLeadingComment :: Assertion +caseCassiusLeadingComment = + flip celper [cassius| + /* + this is a comment + */ + sel1 + foo: bar + sel2 + baz: bin + |] "sel1{foo:bar}sel2{baz:bin}" + +caseCassiusLeadingCommentOrd :: Assertion +caseCassiusLeadingCommentOrd = + flip celper [Ordered.cassius| + /* + this is a comment + */ + sel1 + foo: bar + sel2 + baz: bin + |] "sel1{foo:bar}sel2{baz:bin}" + +instance Show Url where + show _ = "FIXME remove this instance show Url" + + +caseLuciusFileDebug :: Assertion +caseLuciusFileDebug = do + let var = "var" + writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 1}" + celper "foo {\n var: 1;\n}\n" $(luciusFileDebug "test/cassiuses/external2.lucius") + writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 2}" + celper "foo {\n var: 2;\n}\n" $(luciusFileDebug "test/cassiuses/external2.lucius") + writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 1}" + +caseLuciusFileDebugOrd :: Assertion +caseLuciusFileDebugOrd = do + let var = "var" + writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 1}" + celper "foo {\n var: 1;\n}\n" $(Ordered.luciusFileDebug "test/cassiuses/external2.lucius") + writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 2}" + celper "foo {\n var: 2;\n}\n" $(Ordered.luciusFileDebug "test/cassiuses/external2.lucius") + writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 1}"
+ test/Text/HamletSpec.hs view
@@ -0,0 +1,1167 @@+{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +module Text.HamletSpec (spec) where + +import HamletTestTypes (ARecord(..)) + +import Test.HUnit hiding (Test) +import Test.Hspec hiding (Arg) + +import Prelude hiding (reverse) +import Text.Hamlet +import Text.Hamlet.RT +import Data.List (intercalate) +import qualified Data.Text.Lazy as T +import qualified Data.List +import qualified Data.List as L +import Data.Text (Text, pack, unpack) +import Data.Monoid (mappend) +import qualified Data.Set as Set +import qualified Text.Blaze.Html.Renderer.Text +import Text.Blaze.Html (toHtml) +import Text.Blaze.Internal (preEscapedString) +import Text.Blaze + +data ExampleModal widget = ExampleModal + { modalHeader :: widget -> widget, + modalContent :: widget -> widget + } + +spec = do + it "empty" caseEmpty + it "static" caseStatic + it "tag" caseTag + it "var" caseVar + it "var chain " caseVarChain + it "url" caseUrl + it "url chain " caseUrlChain + it "embed" caseEmbed + it "embed chain " caseEmbedChain + it "if" caseIf + it "if chain " caseIfChain + it "else" caseElse + it "else chain " caseElseChain + it "elseif" caseElseIf + it "elseif chain " caseElseIfChain + it "list" caseList + it "list chain" caseListChain + it "with" caseWith + it "with multi" caseWithMulti + it "with chain" caseWithChain + it "with comma string" caseWithCommaString + it "with multi scope" caseWithMultiBindingScope + it "script not empty" caseScriptNotEmpty + it "meta empty" caseMetaEmpty + it "input empty" caseInputEmpty + it "multiple classes" caseMultiClass + it "attrib order" caseAttribOrder + it "nothing" caseNothing + it "nothing chain " caseNothingChain + it "just" caseJust + it "just chain " caseJustChain + it "constructor" caseConstructor + it "url + params" caseUrlParams + it "escape" caseEscape + it "empty statement list" caseEmptyStatementList + it "attribute conditionals" caseAttribCond + it "non-ascii" caseNonAscii + it "maybe function" caseMaybeFunction + it "trailing dollar sign" caseTrailingDollarSign + it "non leading percent sign" caseNonLeadingPercent + it "quoted attributes" caseQuotedAttribs + it "spaced derefs" caseSpacedDerefs + it "attrib vars" caseAttribVars + it "strings and html" caseStringsAndHtml + it "nesting" caseNesting + it "trailing space" caseTrailingSpace + it "currency symbols" caseCurrency + it "external" caseExternal + it "parens" caseParens + it "hamlet literals" caseHamletLiterals + it "hamlet' and xhamlet'" caseHamlet' + it "hamlet tuple" caseTuple + it "complex pattern" caseComplex + it "record pattern" caseRecord + it "record wildcard pattern #1" caseRecordWildCard + it "record wildcard pattern #2" caseRecordWildCard1 + + + + it "comments" $ do + -- FIXME reconsider Hamlet comment syntax? + helper "" [hamlet|$# this is a comment +$# another comment +$#a third one|] + + + it "ignores a blank line" $ do + helper "<p>foo</p>\n" [hamlet| +<p> + + foo + + +|] + + + + + it "angle bracket syntax" $ + helper "<p class=\"foo\" height=\"100\"><span id=\"bar\" width=\"50\">HELLO</span></p>" + [hamlet| +$newline never +<p.foo height="100"> + <span #bar width=50>HELLO +|] + + + + it "hamlet module names" $ do + let foo = "foo" + helper "oof oof 3.14 -5" + [hamlet| +$newline never +#{Data.List.reverse foo} # +#{L.reverse foo} # +#{show 3.14} #{show -5}|] + + + + + + it "single dollar at and caret" $ do + helper "$@^" [hamlet|\$@^|] + + helper "#{@{^{" [hamlet|#\{@\{^\{|] + + + it "dollar operator" $ do + let val = (1, (2, 3)) + helper "2" [hamlet|#{ show $ fst $ snd val }|] + helper "2" [hamlet|#{ show $ fst $ snd $ val}|] + + + it "in a row" $ do + helper "1" [hamlet|#{ show $ const 1 2 }|] + + + it "embedded slash" $ do + helper "///" [hamlet|///|] + +{- compile-time error + it "tag with slash" $ do + helper "" [hamlet| +<p> + Text +</p> +|] +-} + + it "string literals" $ do + helper "string" [hamlet|#{"string"}|] + helper "string" [hamlet|#{id "string"}|] + helper "gnirts" [hamlet|#{L.reverse $ id "string"}|] + helper "str"ing" [hamlet|#{"str\"ing"}|] + helper "str<ing" [hamlet|#{"str<ing"}|] + + + it "interpolated operators" $ do + helper "3" [hamlet|#{show $ (+) 1 2}|] + helper "6" [hamlet|#{show $ sum $ (:) 1 ((:) 2 $ return 3)}|] + + + it "HTML comments" $ do + helper "<p>1</p><p>2 not ignored</p>" [hamlet| +$newline never +<p>1 +<!-- ignored comment --> +<p> + 2 + <!-- ignored --> not ignored<!-- ignored --> +|] + + it "Keeps SSI includes" $ + helper "<!--# SSI -->" [hamlet|<!--# SSI -->|] + + + + it "nested maybes" $ do + let muser = Just "User" :: Maybe String + mprof = Nothing :: Maybe Int + m3 = Nothing :: Maybe String + helper "justnothing" [hamlet| +$maybe user <- muser + $maybe profile <- mprof + First two are Just + $maybe desc <- m3 + \ and left us a description: + <p>#{desc} + $nothing + and has left us no description. + $nothing + justnothing +$nothing + <h1>No such Person exists. + |] + + + it "maybe with qualified constructor" $ do + helper "5" [hamlet| + $maybe HamletTestTypes.ARecord x y <- Just $ ARecord 5 True + \#{x} + |] + + it "record with qualified constructor" $ do + helper "5" [hamlet| + $maybe HamletTestTypes.ARecord {..} <- Just $ ARecord 5 True + \#{field1} + |] + + + + + it "conditional class" $ do + helper "<p class=\"current\"></p>\n" + [hamlet|<p :False:.ignored :True:.current>|] + + helper "<p class=\"1 3 2 4\"></p>\n" + [hamlet|<p :True:.1 :True:class=2 :False:.a :False:class=b .3 class=4>|] + + helper "<p class=\"foo bar baz\"></p>\n" + [hamlet|<p class=foo class=bar class=baz>|] + + + + + it "forall on Foldable" $ do + let set = Set.fromList [1..5 :: Int] + helper "12345" [hamlet| +$forall x <- set + #{x} +|] + + + + it "non-poly HTML" $ do + helperHtml "<h1>HELLO WORLD</h1>\n" [shamlet| + <h1>HELLO WORLD + |] + helperHtml "<h1>HELLO WORLD</h1>\n" $(shamletFile "test/hamlets/nonpolyhtml.hamlet") + helper "<h1>HELLO WORLD</h1>\n" $(hamletFileReload "test/hamlets/nonpolyhtml.hamlet") + + + it "non-poly Hamlet" $ do + let embed = [hamlet|<p>EMBEDDED|] + helper "<h1>url</h1>\n<p>EMBEDDED</p>\n" [hamlet| + <h1>@{Home} + ^{embed} + |] + helper "<h1>url</h1>\n" $(hamletFile "test/hamlets/nonpolyhamlet.hamlet") + helper "<h1>url</h1>\n" $(hamletFileReload "test/hamlets/nonpolyhamlet.hamlet") + + it "non-poly IHamlet" $ do + let embed = [ihamlet|<p>EMBEDDED|] + ihelper "<h1>Adios</h1>\n<p>EMBEDDED</p>\n" [ihamlet| + <h1>_{Goodbye} + ^{embed} + |] + ihelper "<h1>Hola</h1>\n" $(ihamletFile "test/hamlets/nonpolyihamlet.hamlet") + ihelper "<h1>Hola</h1>\n" $(ihamletFileReload "test/hamlets/nonpolyihamlet.hamlet") + + it "pattern-match tuples: forall" $ do + let people = [("Michael", 26), ("Miriam", 25)] + helper "<dl><dt>Michael</dt><dd>26</dd><dt>Miriam</dt><dd>25</dd></dl>" [hamlet| +$newline never +<dl> + $forall (name, age) <- people + <dt>#{name} + <dd>#{show age} +|] + it "pattern-match tuples: maybe" $ do + let people = Just ("Michael", 26) + helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet| +$newline never +<dl> + $maybe (name, age) <- people + <dt>#{name} + <dd>#{show age} +|] + it "pattern-match tuples: with" $ do + let people = ("Michael", 26) + helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet| +$newline never +<dl> + $with (name, age) <- people + <dt>#{name} + <dd>#{show age} +|] + it "list syntax for interpolation" $ do + helper "<ul><li>1</li><li>2</li><li>3</li></ul>" [hamlet| +$newline never +<ul> + $forall num <- [1, 2, 3] + <li>#{show num} +|] + it "pattern-match list: maybe" $ do + let example :: [Int] + example = [1, 2, 3] + helper "<ul><li>1</li><li>2</li><li>3</li></ul>" [hamlet| +$newline never +<ul> + $case example + $of (:) x xs + <li>#{x} + $forall y <- xs + <li>#{y} +|] + it "infix operators" $ + helper "5" [hamlet|#{show $ (4 + 5) - (2 + 2)}|] + it "infix operators with parens" $ + helper "5" [hamlet|#{show ((+) 1 1 + 3)}|] + it "doctypes" $ helper "<!DOCTYPE html>\n<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n" [hamlet| +$newline never +$doctype 5 +$doctype strict +|] + + it "case on Maybe" $ + let nothing = Nothing + justTrue = Just True + in helper "<br><br><br><br>" [hamlet| +$newline never +$case nothing + $of Just val + $of Nothing + <br> +$case justTrue + $of Just val + $if val + <br> + $of Nothing +$case (Just $ not False) + $of Nothing + $of Just val + $if val + <br> +$case Nothing + $of Just val + $of _ + <br> +|] + + it "case on Url" $ + let url1 = Home + url2 = Sub SubUrl + in helper "<br>\n<br>\n" [hamlet| +$newline always +$case url1 + $of Home + <br> + $of _ +$case url2 + $of Sub sub + $case sub + $of SubUrl + <br> + $of Home +|] + + it "pattern-match constructors: forall" $ do + let people = [Pair "Michael" 26, Pair "Miriam" 25] + helper "<dl><dt>Michael</dt><dd>26</dd><dt>Miriam</dt><dd>25</dd></dl>" [hamlet| +$newline text +<dl> + $forall Pair name age <- people + <dt>#{name} + <dd>#{show age} +|] + it "pattern-match constructors: maybe" $ do + let people = Just $ Pair "Michael" 26 + helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet| +$newline text +<dl> + $maybe Pair name age <- people + <dt>#{name} + <dd>#{show age} +|] + it "pattern-match constructors: with" $ do + let people = Pair "Michael" 26 + helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet| +$newline text +<dl> + $with Pair name age <- people + <dt>#{name} + <dd>#{show age} +|] + + it "multiline tags" $ helper + "<foo bar=\"baz\" bin=\"bin\">content</foo>\n" [hamlet| +<foo bar=baz + bin=bin>content +|] + it "*{...} attributes" $ + let attrs = [("bar", "baz"), ("bin", "<>\"&")] in helper + "<foo bar=\"baz\" bin=\"<>"&\">content</foo>\n" [hamlet| +<foo *{attrs}>content +|] + it "blank attr values" $ helper + "<foo bar=\"\" baz bin=\"\"></foo>\n" + [hamlet|<foo bar="" baz bin=>|] + it "greater than in attr" $ helper + "<button data-bind=\"enable: someFunction() > 5\">hello</button>\n" + [hamlet|<button data-bind="enable: someFunction() > 5">hello|] + it "normal doctype" $ helper + "<!DOCTYPE html>\n" + [hamlet|<!DOCTYPE html>|] + it "newline style" $ helper + "<p>foo</p>\n<pre>bar\nbaz\nbin</pre>\n" + [hamlet| +$newline always +<p>foo +<pre> + bar + baz + bin +|] + it "avoid newlines" $ helper + "<p>foo</p><pre>barbazbin</pre>" + [hamlet| +$newline always +<p>foo# +<pre># + bar# + baz# + bin# +|] + it "manual linebreaks" $ helper + "<p>foo</p><pre>bar\nbaz\nbin</pre>" + [hamlet| +$newline never +<p>foo +<pre> + bar + \ + baz + \ + bin +|] + it "indented newline" $ helper + "<p>foo</p><pre>bar\nbaz\nbin</pre>" + [hamlet| + $newline never + <p>foo + <pre> + bar + \ + baz + \ + bin +|] + it "case underscore" $ + let num = 3 + in helper "<p>Many</p>\n" [hamlet| +$case num + $of 1 + <p>1 + $of 2 + <p>2 + $of _ + <p>Many +|] + it "optional and missing classes" $ + helper "<i>foo</i>\n" [hamlet|<i :False:.not-present>foo|] + it "multiple optional and missing classes" $ + helper "<i>foo</i>\n" [hamlet|<i :False:.not-present :False:.also-not-here>foo|] + it "optional and present classes" $ + helper "<i class=\"present\">foo</i>\n" [hamlet|<i :False:.not-present :True:.present>foo|] + it "punctuation operators #115" $ + helper "foo" + [hamlet| + $if True && True + foo + $else + bar + |] + + it "list syntax" $ + helper "123" + [hamlet| + $forall x <- [] + ignored + $forall x <- [1, 2, 3] + #{show x} + |] + + it "list in attribute" $ + let myShow :: [Int] -> String + myShow = show + in helper "<a href=\"[]\">foo</a>\n<a href=\"[1,2]\">bar</a>\n" + [hamlet| + <a href=#{myShow []}>foo + <a href=#{myShow [1, 2]}>bar + |] + + it "AngularJS attribute values #122" $ + helper "<li ng-repeat=\"addr in msgForm.new.split(/\\\\s/)\">{{addr}}</li>\n" + [hamlet|<li ng-repeat="addr in msgForm.new.split(/\\s/)">{{addr}}|] + + it "Alpine.js multi-line attribute values #291" $ + helper "<div x-data=\"{\r\n search: '',\r\n\r\n items: ['foo', 'bar', 'baz'],\r\n\r\n get filteredItems() {\r\n return this.items.filter(\r\n i => i.startsWith(this.search)\r\n )\r\n }\r\n }\"></div>" + [hamlet| + $newline never + <div + x-data="{ + search: '', + + items: ['foo', 'bar', 'baz'], + + get filteredItems() { + return this.items.filter( + i => i.startsWith(this.search) + ) + } + }" + > + |] + + it "supports $component without binding" $ + let + container :: String -> HtmlUrl url -> HtmlUrl url + container clazz x = + [hamlet| + $newline never + <div class="container #{clazz}"> + ^{x} + |] + in + helper "<div class=\"container alert\"><p>Hello world</p></div><p>outside</p>" + [hamlet| + $newline never + $component container "alert" + <p>Hello world + <p>outside + |] + + it "supports $component with binding (modal example)" $ + let + modalWidget :: (ExampleModal (HtmlUrl url) -> HtmlUrl url) -> HtmlUrl url + modalWidget body = + let + exampleModal = + ExampleModal + { modalHeader = \content -> + [hamlet| + $newline never + <div class="modal-header"> + ^{content} + |], + modalContent = \content -> + [hamlet| + $newline never + <div class="modal-content"> + ^{content} + |] + } + in + [hamlet| + $newline never + <div class="modal"> + ^{body exampleModal} + |] + in + helper "<div class=\"modal\"><div class=\"modal-header\"><h1>This is the title</h1></div><div class=\"modal-content\"><p>This is the content</p></div></div><p>outside</p>" + [hamlet| + $newline never + $component modal <- modalWidget + $component modalHeader modal + <h1>This is the title + + $component modalContent modal + <p>This is the content + <p>outside + |] + + it "runtime Hamlet with caret interpolation" $ do + let toInclude render = render (5, [("hello", "world")]) + let renderer x y = pack $ show (x :: Int, y :: [(Text, Text)]) + template1 = "@?{url}" + template2 = "foo^{toInclude}bar" + toInclude <- parseHamletRT defaultHamletSettings template1 + hamletRT <- parseHamletRT defaultHamletSettings template2 + res <- renderHamletRT hamletRT + [ (["toInclude"], HDTemplate toInclude) + , (["url"], HDUrlParams 5 [(pack "hello", pack "world")]) + ] renderer + helperHtml "foo(5,[(\"hello\",\"world\")])bar" res + + it "Hash in attribute value" $ + helper "<a id=\"logoutbutton\" href=\"#\"></a>\n" + [hamlet|<a #logoutbutton href=#>|] + + it "Hash in attribute value" $ + helper "<a id=\"logoutbutton\" href=\"#\"></a>\n" + [hamlet|<a #logoutbutton href="#">|] + +data Pair = Pair String Int + +data Url = Home | Sub SubUrl +data SubUrl = SubUrl +render :: Url -> [(Text, Text)] -> Text +render Home qs = pack "url" `mappend` showParams qs +render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs + +showParams :: [(Text, Text)] -> Text +showParams [] = pack "" +showParams z = + pack $ '?' : intercalate "&" (map go z) + where + go (x, y) = go' x ++ '=' : go' y + go' = concatMap encodeUrlChar . unpack + +-- | Taken straight from web-encodings; reimplemented here to avoid extra +-- dependencies. +encodeUrlChar :: Char -> String +encodeUrlChar c + -- List of unreserved characters per RFC 3986 + -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding + | 'A' <= c && c <= 'Z' = [c] + | 'a' <= c && c <= 'z' = [c] + | '0' <= c && c <= '9' = [c] +encodeUrlChar c@'-' = [c] +encodeUrlChar c@'_' = [c] +encodeUrlChar c@'.' = [c] +encodeUrlChar c@'~' = [c] +encodeUrlChar ' ' = "+" +encodeUrlChar y = + let (a, c) = fromEnum y `divMod` 16 + b = a `mod` 16 + showHex' x + | x < 10 = toEnum $ x + (fromEnum '0') + | x < 16 = toEnum $ x - 10 + (fromEnum 'A') + | otherwise = error $ "Invalid argument to showHex: " ++ show x + in ['%', showHex' b, showHex' c] + +data Arg url = Arg + { getArg :: Arg url + , var :: Html + , url :: Url + , embed :: HtmlUrl url + , true :: Bool + , false :: Bool + , list :: [Arg url] + , nothing :: Maybe String + , just :: Maybe String + , urlParams :: (Url, [(Text, Text)]) + } + +theArg :: Arg url +theArg = Arg + { getArg = theArg + , var = toHtml "<var>" + , url = Home + , embed = [hamlet|embed|] + , true = True + , false = False + , list = [theArg, theArg, theArg] + , nothing = Nothing + , just = Just "just" + , urlParams = (Home, [(pack "foo", pack "bar"), (pack "foo1", pack "bar1")]) + } + +helperHtml :: String -> Html -> Assertion +helperHtml res h = do + let x = Text.Blaze.Html.Renderer.Text.renderHtml h + T.pack res @=? x + +helper :: String -> HtmlUrl Url -> Assertion +helper res h = do + let x = Text.Blaze.Html.Renderer.Text.renderHtml $ h render + T.pack res @=? x + +caseEmpty :: Assertion +caseEmpty = helper "" [hamlet||] + +caseStatic :: Assertion +caseStatic = helper "some static content" [hamlet|some static content|] + +caseTag :: Assertion +caseTag = do + helper "<p class=\"foo\"><div id=\"bar\">baz</div></p>" [hamlet| +$newline text +<p .foo> + <#bar>baz +|] + helper "<p class=\"foo.bar\"><div id=\"bar\">baz</div></p>" [hamlet| +$newline text +<p class=foo.bar> + <#bar>baz +|] + +caseVar :: Assertion +caseVar = do + helper "<var>" [hamlet|#{var theArg}|] + +caseVarChain :: Assertion +caseVarChain = do + helper "<var>" [hamlet|#{var (getArg (getArg (getArg theArg)))}|] + +caseUrl :: Assertion +caseUrl = do + helper (unpack $ render Home []) [hamlet|@{url theArg}|] + +caseUrlChain :: Assertion +caseUrlChain = do + helper (unpack $ render Home []) [hamlet|@{url (getArg (getArg (getArg theArg)))}|] + +caseEmbed :: Assertion +caseEmbed = do + helper "embed" [hamlet|^{embed theArg}|] + helper "embed" $(hamletFileReload "test/hamlets/embed.hamlet") + ihelper "embed" $(ihamletFileReload "test/hamlets/embed.hamlet") + +caseEmbedChain :: Assertion +caseEmbedChain = do + helper "embed" [hamlet|^{embed (getArg (getArg (getArg theArg)))}|] + +caseIf :: Assertion +caseIf = do + helper "if" [hamlet| +$if true theArg + if +|] + +caseIfChain :: Assertion +caseIfChain = do + helper "if" [hamlet| +$if true (getArg (getArg (getArg theArg))) + if +|] + +caseElse :: Assertion +caseElse = helper "else" [hamlet| +$if false theArg + if +$else + else +|] + +caseElseChain :: Assertion +caseElseChain = helper "else" [hamlet| +$if false (getArg (getArg (getArg theArg))) + if +$else + else +|] + +caseElseIf :: Assertion +caseElseIf = helper "elseif" [hamlet| +$if false theArg + if +$elseif true theArg + elseif +$else + else +|] + +caseElseIfChain :: Assertion +caseElseIfChain = helper "elseif" [hamlet| +$if false(getArg(getArg(getArg theArg))) + if +$elseif true(getArg(getArg(getArg theArg))) + elseif +$else + else +|] + +caseList :: Assertion +caseList = do + helper "xxx" [hamlet| +$forall _x <- (list theArg) + x +|] + +caseListChain :: Assertion +caseListChain = do + helper "urlurlurl" [hamlet| +$forall x <- list(getArg(getArg(getArg(getArg(getArg (theArg)))))) + @{url x} +|] + +caseWith :: Assertion +caseWith = do + helper "it's embedded" [hamlet| +$with n <- embed theArg + it's ^{n}ded +|] + +caseWithMulti :: Assertion +caseWithMulti = do + helper "it's embedded" [hamlet| +$with n <- embed theArg, m <- true theArg + $if m + it's ^{n}ded +|] + +caseWithChain :: Assertion +caseWithChain = do + helper "it's true" [hamlet| +$with n <- true(getArg(getArg(getArg(getArg theArg)))) + $if n + it's true +|] + +-- in multi-with binding, make sure that a comma in a string doesn't confuse the parser. +caseWithCommaString :: Assertion +caseWithCommaString = do + helper "it's , something" [hamlet| +$with n <- " , something" + it's #{n} +|] + +caseWithMultiBindingScope :: Assertion +caseWithMultiBindingScope = do + helper "it's , something" [hamlet| +$with n <- " , something", y <- n + it's #{y} +|] + +caseScriptNotEmpty :: Assertion +caseScriptNotEmpty = helper "<script></script>\n" [hamlet|<script>|] + +caseMetaEmpty :: Assertion +caseMetaEmpty = do + helper "<meta>\n" [hamlet|<meta>|] + helper "<meta/>\n" [xhamlet|<meta>|] + +caseInputEmpty :: Assertion +caseInputEmpty = do + helper "<input>\n" [hamlet|<input>|] + helper "<input/>\n" [xhamlet|<input>|] + +caseMultiClass :: Assertion +caseMultiClass = helper "<div class=\"foo bar\"></div>\n" [hamlet|<.foo.bar>|] + +caseAttribOrder :: Assertion +caseAttribOrder = + helper "<meta 1 2 3>\n" [hamlet|<meta 1 2 3>|] + +caseNothing :: Assertion +caseNothing = do + helper "" [hamlet| +$maybe _n <- nothing theArg + nothing +|] + helper "nothing" [hamlet| +$maybe _n <- nothing theArg + something +$nothing + nothing +|] + +caseNothingChain :: Assertion +caseNothingChain = helper "" [hamlet| +$maybe n <- nothing(getArg(getArg(getArg theArg))) + nothing #{n} +|] + +caseJust :: Assertion +caseJust = helper "it's just" [hamlet| +$maybe n <- just theArg + it's #{n} +|] + +caseJustChain :: Assertion +caseJustChain = helper "it's just" [hamlet| +$maybe n <- just(getArg(getArg(getArg theArg))) + it's #{n} +|] + +caseConstructor :: Assertion +caseConstructor = do + helper "url" [hamlet|@{Home}|] + helper "suburl" [hamlet|@{Sub SubUrl}|] + let text = "<raw text>" + helper "<raw text>" [hamlet|#{preEscapedString text}|] + +caseUrlParams :: Assertion +caseUrlParams = do + helper "url?foo=bar&foo1=bar1" [hamlet|@?{urlParams theArg}|] + +caseEscape :: Assertion +caseEscape = do + helper "#this is raw\n " [hamlet| +$newline never +\#this is raw +\ +\ +|] + helper "$@^" [hamlet|\$@^|] + +caseEmptyStatementList :: Assertion +caseEmptyStatementList = do + helper "" [hamlet|$if True|] + helper "" [hamlet|$maybe _x <- Nothing|] + let emptyList = [] + helper "" [hamlet|$forall _x <- emptyList|] + +caseAttribCond :: Assertion +caseAttribCond = do + helper "<select></select>\n" [hamlet|<select :False:selected>|] + helper "<select selected></select>\n" [hamlet|<select :True:selected>|] + helper "<meta var=\"foo:bar\">\n" [hamlet|<meta var=foo:bar>|] + helper "<select selected></select>\n" + [hamlet|<select :true theArg:selected>|] + + helper "<select></select>\n" [hamlet|<select :False:selected>|] + helper "<select selected></select>\n" [hamlet|<select :True:selected>|] + helper "<meta var=\"foo:bar\">\n" [hamlet|<meta var=foo:bar>|] + helper "<select selected></select>\n" + [hamlet|<select :true theArg:selected>|] + +caseNonAscii :: Assertion +caseNonAscii = do + helper "עִבְרִי" [hamlet|עִבְרִי|] + +caseMaybeFunction :: Assertion +caseMaybeFunction = do + helper "url?foo=bar&foo1=bar1" [hamlet| +$maybe x <- Just urlParams + @?{x theArg} +|] + +caseTrailingDollarSign :: Assertion +caseTrailingDollarSign = + helper "trailing space \ndollar sign #" [hamlet| +$newline never +trailing space # +\ +dollar sign #\ +|] + +caseNonLeadingPercent :: Assertion +caseNonLeadingPercent = + helper "<span style=\"height:100%\">foo</span>" [hamlet| +$newline never +<span style=height:100%>foo +|] + +caseQuotedAttribs :: Assertion +caseQuotedAttribs = + helper "<input type=\"submit\" value=\"Submit response\">" [hamlet| +$newline never +<input type=submit value="Submit response"> +|] + +caseSpacedDerefs :: Assertion +caseSpacedDerefs = do + helper "<var>" [hamlet|#{var theArg}|] + helper "<div class=\"<var>\"></div>\n" [hamlet|<.#{var theArg}>|] + +caseAttribVars :: Assertion +caseAttribVars = do + helper "<div id=\"<var>\"></div>\n" [hamlet|<##{var theArg}>|] + helper "<div class=\"<var>\"></div>\n" [hamlet|<.#{var theArg}>|] + helper "<div f=\"<var>\"></div>\n" [hamlet|< f=#{var theArg}>|] + + helper "<div id=\"<var>\"></div>\n" [hamlet|<##{var theArg}>|] + helper "<div class=\"<var>\"></div>\n" [hamlet|<.#{var theArg}>|] + helper "<div f=\"<var>\"></div>\n" [hamlet|< f=#{var theArg}>|] + +caseStringsAndHtml :: Assertion +caseStringsAndHtml = do + let str = "<string>" + let html = preEscapedString "<html>" + helper "<string> <html>" [hamlet|#{str} #{html}|] + +caseNesting :: Assertion +caseNesting = do + helper + "<table><tbody><tr><td>1</td></tr><tr><td>2</td></tr></tbody></table>" + [hamlet| +$newline never +<table> + <tbody> + $forall user <- users + <tr> + <td>#{user} +|] + helper + (concat + [ "<select id=\"foo\" name=\"foo\"><option selected></option>" + , "<option value=\"true\">Yes</option>" + , "<option value=\"false\">No</option>" + , "</select>" + ]) + [hamlet| +$newline never +<select #"#{name}" name=#{name}> + <option :isBoolBlank val:selected> + <option value=true :isBoolTrue val:selected>Yes + <option value=false :isBoolFalse val:selected>No +|] + where + users = ["1", "2"] + name = "foo" + val = 5 :: Int + isBoolBlank _ = True + isBoolTrue _ = False + isBoolFalse _ = False + +caseTrailingSpace :: Assertion +caseTrailingSpace = + helper "" [hamlet| |] + +caseCurrency :: Assertion +caseCurrency = + helper foo [hamlet|#{foo}|] + where + foo = "eg: 5, $6, €7.01, £75" + +caseExternal :: Assertion +caseExternal = do + helper "foo\n<br>\n" $(hamletFile "test/hamlets/external.hamlet") + helper "foo\n<br/>\n" $(xhamletFile "test/hamlets/external.hamlet") + helper "foo\n<br>\n" $(hamletFileReload "test/hamlets/external.hamlet") + where + foo = "foo" + +caseParens :: Assertion +caseParens = do + let plus = (++) + x = "x" + y = "y" + helper "xy" [hamlet|#{(plus x) y}|] + helper "xxy" [hamlet|#{plus (plus x x) y}|] + let alist = ["1", "2", "3"] + helper "123" [hamlet| +$forall x <- (id id id id alist) + #{x} +|] + +caseHamletLiterals :: Assertion +caseHamletLiterals = do + helper "123" [hamlet|#{show 123}|] + helper "123.456" [hamlet|#{show 123.456}|] + helper "-123" [hamlet|#{show -123}|] + helper "-123.456" [hamlet|#{show -123.456}|] + +helper' :: String -> Html -> Assertion +helper' res h = T.pack res @=? Text.Blaze.Html.Renderer.Text.renderHtml h + +caseHamlet' :: Assertion +caseHamlet' = do + helper' "foo" [shamlet|foo|] + helper' "foo" [xshamlet|foo|] + helper "<br>\n" $ const $ [shamlet|<br>|] + helper "<br/>\n" $ const $ [xshamlet|<br>|] + + -- new with generalized stuff + helper' "foo" [shamlet|foo|] + helper' "foo" [xshamlet|foo|] + helper "<br>\n" $ const $ [shamlet|<br>|] + helper "<br/>\n" $ const $ [xshamlet|<br>|] + + +instance Show Url where + show _ = "FIXME remove this instance show Url" + +caseDiffBindNames :: Assertion +caseDiffBindNames = do + let list = words "1 2 3" + -- FIXME helper "123123" $(hamletFileReload "test/hamlets/external-debug3.hamlet") + error "test has been disabled" + + +caseTrailingSpaces :: Assertion +caseTrailingSpaces = helper "" [hamlet| +$if True +$elseif False +$else +$maybe x <- Nothing +$nothing +$forall x <- empty +|] + where + empty = [] + + + +caseTuple :: Assertion +caseTuple = do + helper "(1,1)" [hamlet| #{("1","1")}|] + helper "foo" [hamlet| + $with (a,b) <- ("foo","bar") + #{a} + |] + helper "url" [hamlet| + $with (a,b) <- (Home,Home) + @{a} + |] + helper "url" [hamlet| + $with p <- (Home,[]) + @?{p} + |] + + + +caseComplex :: Assertion +caseComplex = do + let z :: ((Int,Int),Maybe Int,(),Bool,[[Int]]) + z = ((1,2),Just 3,(),True,[[4],[5,6]]) + helper "1 2 3 4 5 61 2 3 4 5 6" [hamlet| + $with ((a,b),Just c, () ,True,d@[[e],[f,g]]) <- z + $forall h <- d + #{a} #{b} #{c} #{e} #{f} #{g} + |] + +caseRecord :: Assertion +caseRecord = do + let z = ARecord 10 True + helper "10" [hamlet| + $with ARecord { field1, field2 = True } <- z + #{field1} + |] + +caseRecordWildCard :: Assertion +caseRecordWildCard = do + let z = ARecord 10 True + helper "10 True" [hamlet| + $with ARecord {..} <- z + #{field1} #{field2} + |] + +caseRecordWildCard1 :: Assertion +caseRecordWildCard1 = do + let z = ARecord 10 True + helper "10" [hamlet| + $with ARecord {field2 = True, ..} <- z + #{field1} + |] + +caseCaseRecord :: Assertion +caseCaseRecord = do + let z = ARecord 10 True + helper "10\nTrue" [hamlet| + $case z + $of ARecord { field1, field2 = x } + #{field1} + #{x} + |] + +data Msg = Hello | Goodbye + +ihelper :: String -> HtmlUrlI18n Msg Url -> Assertion +ihelper res h = do + let x = Text.Blaze.Html.Renderer.Text.renderHtml $ h showMsg render + T.pack res @=? x + where + showMsg Hello = preEscapedString "Hola" + showMsg Goodbye = preEscapedString "Adios" + +instance (ToMarkup a, ToMarkup b) => ToMarkup (a,b) where + toMarkup (a,b) = do + toMarkup "(" + toMarkup a + toMarkup "," + toMarkup b + toMarkup ")"
+ test/Text/JuliusSpec.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +module Text.JuliusSpec (spec) where + +import Test.HUnit hiding (Test) +import Test.Hspec + +import Prelude hiding (reverse) +#ifdef TEST_COFFEE +import Text.Coffee +#endif +import Text.Julius +import Quoter (quote, quoteFile, quoteFileReload) +import Data.List (intercalate) +import qualified Data.Text.Lazy as T +import qualified Data.List +import qualified Data.List as L +import Data.Text (Text, pack, unpack) +import Data.Monoid (mappend) +import Data.Aeson (toJSON) + +join :: [String] -> String +#ifdef TEST_COFFEE +join l = (intercalate ";\n" l) +#else +join = intercalate "\n" +#endif + +spec :: Spec +spec = do +#if !(defined TEST_COFFEE || defined TEST_ROY) + it "julius" $ do + let var = "x=2" + let urlp = (Home, [(pack "p", pack "q")]) + flip jelper [quote|['שלום', @{Home}, #{rawJS var}, '@?{urlp}', ^{jmixin} ]|] + $ intercalate " " + [ "['שלום'," + , "url, " ++ var ++ "," + , "'url?p=q'," + , "f(2) ]" + ] + + + it "juliusFile" $ do + let var = "x=2" + let urlp = (Home, [(pack "p", pack "q")]) + flip jelper $(quoteFile "test/juliuses/external1.julius") $ join + [ "שלום" + , var + , "url" + , "url?p=q" + , "f(2)" + ] ++ "\n" + + + it "juliusFileReload" $ do + let var = "x=2" + let urlp = (Home, [(pack "p", pack "q")]) + flip jelper $(quoteFileReload "test/juliuses/external1.julius") $ join + [ "שלום" + , var + , "url" + , "url?p=q" + , "f(2)" + ] ++ "\n" +#endif + +{- TODO + it "juliusFileDebugChange" $ do + let var = "somevar" + test result = jelper result $(juliusFileDebug "test/juliuses/external2.julius") + writeFile "test/juliuses/external2.julius" "var #{var} = 1;" + test "var somevar = 1;" + writeFile "test/juliuses/external2.julius" "var #{var} = 2;" + test "var somevar = 2;" + writeFile "test/juliuses/external2.julius" "var #{var} = 1;" + -} + + + it "julius module names" $ + let foo = "foo" + double = 3.14 :: Double + int = -5 :: Int +#ifdef TEST_COFFEE + in jelper "var _this = this;\n\n(function(shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint) {\n return [shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint];\n})(oof, oof, 3.14, -5);\n" +#else +# ifdef TEST_ROY + in jelper "(function(shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint) {\n return [shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint];\n})(oof, oof, 3.14, -5);\n" +# else + in jelper "[oof, oof, 3.14, -5]" +# endif +#endif + [quote|[#{rawJS $ Data.List.reverse foo}, #{rawJS $ L.reverse foo}, #{rawJS $ show double}, #{rawJS $ show int}]|] + + +-- not valid coffeescript +#if !(defined TEST_COFFEE || defined TEST_ROY) + it "single dollar at and caret" $ do + jelper "$@^" [quote|$@^|] + jelper "#{@{^{" [quote|#\{@\{^\{|] +#endif + + it "dollar operator" $ do + let val = (1 :: Int, (2 :: Int, 3 :: Int)) +#if (defined TEST_COFFEE) + jelper "var _this = this;\n\n(function(shakespeare_var_rawJSshowfstsndval) {\n return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|] + jelper "var _this = this;\n\n(function(shakespeare_var_rawJSshowfstsndval) {\n return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|] +#else + +# if (defined TEST_ROY) + jelper "(function(shakespeare_var_rawJSshowfstsndval) {\n return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|] + jelper "(function(shakespeare_var_rawJSshowfstsndval) {\n return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|] + +# else + jelper "2" [quote|#{ rawJS $ show $ fst $ snd val }|] + jelper "2" [quote|#{ rawJS $ show $ fst $ snd $ val}|] +# endif +#endif + +#if (defined TEST_ROY) + it "roy function wrapper" $ do + let royInsert = rawJS "\"royInsert\"" + jelper "(function(shakespeare_var_royInsert) {\n var roy = {\n \"royInsert\": shakespeare_var_royInsert\n };\n return console.log(roy);\n})(\"royInsert\");\n" [quote| +let roy = { royInsert: #{royInsert} } +console.log roy +|] +#endif + it "empty file" $ jelper "" [quote||] + + it "JSON data" $ jelper "\"Hello \\\"World!\\\"\"" [julius|#{toJSON "Hello \"World!\""}|] + + it "< escaping" $ jelper "\"\\u003c\"" [julius|#{toJSON "<"}|] + + it "> escaping" $ jelper "\"\\u003e\"" [julius|#{toJSON ">"}|] + + it "& escaping" $ jelper "\"\\u0026\"" [julius|#{toJSON "&"}|] + + it "boolean interpolation" $ jelper + "true false true false true false" + [julius|#{True} #{False} #{toJSON True} #{toJSON False} #{rawJS True} #{rawJS False}|] + + it "^\\ should not be escaped" $ jelper + "var re = /[^\\r]/;" + [julius|var re = /[^\r]/;|] + + it "^\\{ should be escaped" $ jelper + "var re = /[^{]/;" + [julius|var re = /[^\{]/;|] + + it "produces escaped JavaScript" $ jelper + "\"yay\"" + [julius|#{"yay"}|] + +data Url = Home | Sub SubUrl +data SubUrl = SubUrl +render :: Url -> [(Text, Text)] -> Text +render Home qs = pack "url" `mappend` showParams qs +render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs + +showParams :: [(Text, Text)] -> Text +showParams [] = pack "" +showParams z = + pack $ '?' : intercalate "&" (map go z) + where + go (x, y) = go' x ++ '=' : go' y + go' = concatMap encodeUrlChar . unpack + +-- | Taken straight from web-encodings; reimplemented here to avoid extra +-- dependencies. +encodeUrlChar :: Char -> String +encodeUrlChar c + -- List of unreserved characters per RFC 3986 + -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding + | 'A' <= c && c <= 'Z' = [c] + | 'a' <= c && c <= 'z' = [c] + | '0' <= c && c <= '9' = [c] +encodeUrlChar c@'-' = [c] +encodeUrlChar c@'_' = [c] +encodeUrlChar c@'.' = [c] +encodeUrlChar c@'~' = [c] +encodeUrlChar ' ' = "+" +encodeUrlChar y = + let (a, c) = fromEnum y `divMod` 16 + b = a `mod` 16 + showHex' x + | x < 10 = toEnum $ x + (fromEnum '0') + | x < 16 = toEnum $ x - 10 + (fromEnum 'A') + | otherwise = error $ "Invalid argument to showHex: " ++ show x + in ['%', showHex' b, showHex' c] + + + + +#ifndef TEST_ROY +jmixin :: JavascriptUrl u +jmixin = [quote|f(2)|] +#endif + +jelper :: String -> JavascriptUrl Url -> Assertion +jelper res h = do + T.pack res @=? renderJavascriptUrl render h + +instance Show Url where + show _ = "FIXME remove this instance show Url"
test/Text/Shakespeare/BaseSpec.hs view
@@ -3,18 +3,19 @@ import Test.Hspec import Text.Shakespeare--import Text.ParserCombinators.Parsec (parse, ParseError, (<|>))-import Text.Shakespeare.Base (parseVarString, parseUrlString, parseIntString)-import Text.Shakespeare (preFilter, defaultShakespeareSettings, ShakespeareSettings(..), PreConvert(..), PreConversion(..))+import Text.ParserCombinators.Parsec+ ((<|>), ParseError, parse, runParser)+import Text.Shakespeare.Base+ (Deref(..), Ident(..), parseDeref, parseVarString, parseUrlString,+ parseIntString) import Language.Haskell.TH.Syntax (Exp (VarE))-import Data.Text.Lazy.Builder (fromString, toLazyText, fromLazyText)+import Data.Text.Lazy.Builder (toLazyText, fromLazyText) import Data.Text.Lazy (pack) -- run :: Text.Parsec.Prim.Parsec Text.Parsec.Pos.SourceName () c -> Text.Parsec.Pos.SourceName -> c spec :: Spec-spec = describe "shakespeare-js" $ do+spec = do let preFilterN = preFilter Nothing {- it "parseStrings" $ do@@ -24,6 +25,32 @@ run (varString <|> urlString <|> intString) "@{url} #{var}" `shouldBe` Right "@{url}" -}++ it "parseDeref parse expressions with infix operator and trailing spaces" $ do+ runParser parseDeref () "" " a + b \t " `shouldBe`+ (Right+ (DerefBranch+ (DerefBranch (DerefIdent (Ident "+")) (DerefIdent (Ident "a")))+ (DerefIdent (Ident "b"))))++ it "parseDeref parse expressions with record dot" $ do+ runParser parseDeref () "" "x.y" `shouldBe`+ Right (DerefGetField (DerefIdent (Ident "x")) "y")++ it "parseDeref parse expressions with multiple record dots" $ do+ runParser parseDeref () "" "x.y.z" `shouldBe`+ Right (DerefGetField (DerefGetField (DerefIdent (Ident "x")) "y") "z")++ it "parseDeref dot surrounded by whitespace" $ do+ runParser parseDeref () "" "x . y" `shouldBe`+ Right+ (DerefBranch+ (DerefBranch (DerefIdent (Ident ".")) (DerefIdent (Ident "x")))+ (DerefIdent (Ident "y")))++ it "parseDeref parse expressions with parenthesized record dot" $ do+ runParser parseDeref () "" "(x).y" `shouldBe`+ Right (DerefGetField (DerefIdent (Ident "x")) "y") it "preFilter off" $ do preFilterN defaultShakespeareSettings template
+ test/Text/Shakespeare/BuilderQQ.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskellQuotes #-}+module Text.Shakespeare.BuilderQQ (builderQQ) where++import Prelude+import Language.Haskell.TH.Quote (QuasiQuoter(..))+import Language.Haskell.TH.Syntax (Exp(..))+import Text.Shakespeare+import Text.Shakespeare.Text (ToText(..))++builderQQ :: QuasiQuoter+builderQQ =+ shakespeare $+ defaultShakespeareSettings+ { justVarInterpolation = True+ , toBuilder = VarE 'toText+ , wrap = VarE 'id+ , unwrap = VarE 'id+ }
− test/Text/Shakespeare/CssSpec.hs
@@ -1,600 +0,0 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -O0 #-} -module Text.Shakespeare.CssSpec (spec) where - -import Test.HUnit hiding (Test) -import Test.Hspec - -import Prelude hiding (reverse) -import Text.Cassius -import Text.Lucius -import Data.List (intercalate) -import qualified Data.Text.Lazy as T -import qualified Data.Text as TS -import qualified Data.List -import qualified Data.List as L -import Data.Text (Text, pack, unpack) -import Data.Monoid (mappend) - -spec :: Spec -spec = do - describe "shakespeare-css" $ do - it "cassius" caseCassius - it "cassiusFile" caseCassiusFile - it "cassius single comment" caseCassiusSingleComment - it "cassius leading comment" caseCassiusLeadingComment - - it "cassiusFileDebug" $ do - let var = "var" - let selector = "foo" - let urlp = (Home, [(pack "p", pack "q")]) - flip celper $(cassiusFileDebug "test/cassiuses/external1.cassius") $ concat - [ "foo {\n background: #000;\n bar: baz;\n color: #F00;\n}\n" - , "bin {\n" - , " background-image: url(url);\n" - , " bar: bar;\n color: #7F6405;\n fvarx: someval;\n unicode-test: שלום;\n" - , " urlp: url(url?p=q);\n}\n" - ] - -{- TODO - it "cassiusFileDebugChange" $ do - let var = "var" - writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 1" - celper "foo{var:1}" $(cassiusFileDebug "test/cassiuses/external2.cassius") - writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 2" - celper "foo{var:2}" $(cassiusFileDebug "test/cassiuses/external2.cassius") - writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 1" - -} - - - it "comments" $ do - -- FIXME reconsider Hamlet comment syntax? - celper "" [cassius|/* this is a comment */ -/* another comment */ -/*a third one*/|] - - - it "cassius pseudo-class" $ - flip celper [cassius| -a:visited - color: blue -|] "a:visited{color:blue}" - - - it "ignores a blank line" $ do - celper "foo{bar:baz}" [cassius| -foo - - bar: baz - -|] - - - it "leading spaces" $ - celper "foo{bar:baz}" [cassius| - foo - bar: baz -|] - - - it "cassius all spaces" $ - celper "h1{color:green }" [cassius| - h1 - color: green - |] - - - it "cassius whitespace and colons" $ do - celper "h1:hover{color:green ;font-family:sans-serif}" [cassius| - h1:hover - color: green - font-family:sans-serif - |] - - - it "cassius trailing comments" $ - celper "h1:hover{color:green ;font-family:sans-serif}" [cassius| - h1:hover /* Please ignore this */ - color: green /* This is a comment. */ - /* Obviously this is ignored too. */ - font-family:sans-serif - |] - - it "cassius nesting" $ - celper "foo bar{baz:bin}" [cassius| - foo - bar - baz: bin - |] - - it "cassius variable" $ - celper "foo bar{baz:bin}" [cassius| - @binvar: bin - foo - bar - baz: #{binvar} - |] - - it "cassius trailing semicolon" $ - celper "foo bar{baz:bin}" [cassius| - @binvar: bin - foo - bar - baz: #{binvar}; - |] - - - - it "cassius module names" $ do - let foo = "foo" - dub = 3.14::Double - int = -5::Int - celper "sel{bar:oof oof 3.14 -5}" - [cassius| -sel - bar: #{Data.List.reverse foo} #{L.reverse foo} #{show dub} #{show int} -|] - - - - it "single dollar at and caret" $ do - celper "sel{att:$@^}" [cassius| -sel - att: $@^ -|] - - {- - celper "sel{att:#{@{^{}" [cassius| -sel - att: #\{@\{^{ -|] --} - - - it "dollar operator" $ do - let val = (1, (2, 3)) :: (Integer, (Integer, Integer)) - celper "sel{att:2}" [cassius| -sel - att: #{ show $ fst $ snd val } -|] - celper "sel{att:2}" [cassius| -sel - att: #{ show $ fst $ snd $ val} -|] - - - - it "embedded slash" $ do - celper "sel{att:///}" [cassius| -sel - att: /// -|] - - - - - - - it "multi cassius" $ do - celper "foo{bar:baz;bar:bin}" [cassius| -foo - bar: baz - bar: bin -|] - - - - - - - it "lucius" $ do - let var = "var" - let urlp = (Home, [(pack "p", pack "q")]) - flip celper [lucius| -foo { - background: #{colorBlack}; - bar: baz; - color: #{colorRed}; -} -bin { - background-image: url(@{Home}); - bar: bar; - color: #{(((Color 127) 100) 5)}; - f#{var}x: someval; - unicode-test: שלום; - urlp: url(@?{urlp}); -} -|] $ concat - [ "foo{background:#000;bar:baz;color:#F00}" - , "bin{" - , "background-image:url(url);" - , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" - , "urlp:url(url?p=q)}" - ] - - - - it "lucius file" $ do - let var = "var" - let urlp = (Home, [(pack "p", pack "q")]) - flip celper $(luciusFile "test/cassiuses/external1.lucius") $ concat - [ "foo{background:#000;bar:baz;color:#F00}" - , "bin{" - , "background-image:url(url);" - , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" - , "urlp:url(url?p=q)}" - ] - - it "lucius file debug" caseLuciusFileDebug - - - - - it "lucius nested" $ do - celper "foo bar{baz:bin}" $(luciusFile "test/cassiuses/external-nested.lucius") - celper "foo bar {\n baz: bin;\n}\n" $(luciusFileDebug "test/cassiuses/external-nested.lucius") - celper "foo bar{baz:bin}" [lucius| - foo { - bar { - baz: bin; - } - } - |] - celper "foo1 bar,foo2 bar{baz:bin}" [lucius| - foo1, foo2 { - bar { - baz: bin; - } - } - |] - - - it "lucius charset" $ do - celper (concat ["@charset \"utf-8\";" - , "#content ul{list-style:none;padding:0 5em}" - , "#content ul li{padding:1em 0}" - , "#content ul li a{color:#419a56;font-family:'TeXGyreHerosBold',helvetica,arial,sans-serif;font-weight:bold;text-transform:uppercase;white-space:nowrap}" - ]) [lucius| -@charset "utf-8"; -#content ul -{ - list-style: none; - padding: 0 5em; - li - { - padding: 1em 0; - a - { - color: #419a56; - font-family: 'TeXGyreHerosBold',helvetica,arial,sans-serif; - font-weight: bold; - text-transform: uppercase; - white-space: nowrap; - } - } -} -|] - - it "lucius media" $ do - celper "@media only screen{foo bar{baz:bin}}" $(luciusFile "test/cassiuses/external-media.lucius") - celper "@media only screen {\n foo bar {\n baz: bin;\n }\n}\n" $(luciusFileDebug "test/cassiuses/external-media.lucius") - celper "@media only screen{foo bar{baz:bin}}" [lucius| - @media only screen{ - foo { - bar { - baz: bin; - } - } - } - |] - - - {- - it "cassius removes whitespace" $ do - celper "foo{bar:baz}" [cassius| - foo - bar : baz - |] - -} - - - - - - it "lucius trailing comments" $ - celper "foo{bar:baz}" [lucius|foo{bar:baz;}/* ignored*/|] - - it "lucius variables" $ celper "foo{bar:baz}" [lucius| -@myvar: baz; -foo { - bar: #{myvar}; -} -|] - it "lucius CDO/CDC tokens" $ - celper "*{a:b}" [lucius| -<!-- --> <!-- -* { - a: b; -} ---> -|] - it "lucius @import statements" $ - celper "@import url(\"bla.css\");" [lucius| -@import url("bla.css"); -|] - it "lucius simple escapes" $ - celper "*{a:test}" [lucius| -* { - a: t\65 st; -} -|] - it "lucius bounded escapes" $ - celper "*{a:teft}" [lucius| -* { - a: t\000065ft; -} -|] - it "lucius case-insensitive keywords" $ - celper "@media foo {}" [lucius| -@MeDIa foo { -} -|] - it "lucius @page statements" $ - celper "@page :right{a:b;c:d}" [lucius| -@page :right { -a:b; -c:d; -} -|] - it "lucius @font-face statements" $ - celper "@font-face{a:b;c:d}" [lucius| -@font-face { -a:b; -c:d; -} -|] - it "lucius runtime" $ Right (T.pack "foo {\n bar: baz;\n}\n") @=? luciusRT (T.pack "foo { bar: #{myvar}}") [(TS.pack "myvar", TS.pack "baz")] - it "lucius runtime variables" $ Right (T.pack "foo {\n bar: baz;\n}\n") @=? luciusRT (T.pack "@dummy: dummy; @myvar: baz; @dummy2: dummy; foo { bar: #{myvar}}") [] - it "lucius whtiespace" $ Right (T.pack "@media foo {\n bar {\n baz: bin;\n baz2: bin2;\n }\n}\n") - @=? luciusRT (T.pack "@media foo{bar{baz:bin;baz2:bin2}}") [] - it "variables inside value" $ - celper "foo{foo:XbarY}" [lucius| -@bar: bar; -foo { foo:X#{bar}Y; } -|] - it "variables in media selector" $ - celper "@media (max-width: 400px){foo{color:red}}" [lucius| -@mobileWidth: 400px; -@media (max-width: #{mobileWidth}){ foo { color: red; } } -|] - it "URLs in import" $ celper - "@import url(\"suburl\");" [lucius| -@import url("@{Sub SubUrl}"); -|] - it "vars in charset" $ do - let charset = "mycharset" - celper "@charset mycharset;" [lucius| -@charset #{charset}; -|] - it "keyframes" $ celper - "@keyframes mymove {from{top:0px}to{top:200px}}" [lucius| -@keyframes mymove { - from { - top: 0px; - } - to { - top: 200px; - } -} -|] - it "prefixed keyframes" $ celper - "@-webkit-keyframes mymove {from{top:0px}to{top:200px}}" [lucius| -@-webkit-keyframes mymove { - from { - top: 0px; - } - to { - top: 200px; - } -} -|] - it "mixins" $ do - let bins = [luciusMixin| - bin:bin2; - /* FIXME not currently implementing sublocks in mixins - foo2 { - x: y - } - */ - |] :: Mixin - -- No sublocks celper "foo{bar:baz;bin:bin2}foo foo2{x:y}" [lucius| - celper "foo{bar:baz;bin:bin2}" [lucius| - foo { - bar: baz; - ^{bins} - } - |] - it "more complicated mixins" $ do - let transition val = - [luciusMixin| - -webkit-transition: #{val}; - -moz-transition: #{val}; - -ms-transition: #{val}; - -o-transition: #{val}; - transition: #{val}; - |] - - celper ".some-class{-webkit-transition:all 4s ease;-moz-transition:all 4s ease;-ms-transition:all 4s ease;-o-transition:all 4s ease;transition:all 4s ease}" - [lucius| - .some-class { - ^{transition "all 4s ease"} - } - |] - - it "runtime mixin" $ do - let bins = [luciusMixin| - bin:bin2; - /* FIXME not currently implementing sublocks in mixins - foo2 { - x: y - } - */ - |] :: Mixin - -- No sublocks celper "foo{bar:baz;bin:bin2}foo foo2{x:y}" [lucius| - Right (T.pack "foo{bar:baz;bin:bin2}") @=? luciusRTMixin - (T.pack "foo { bar: baz; ^{bins} }") - True - [(TS.pack "bins", RTVMixin bins)] - - it "luciusFileReload mixin" $ do - let mixin = [luciusMixin|foo:bar;baz:bin|] - flip celper $(luciusFileReload "test/cassiuses/mixin.lucius") $ concat - [ "selector {\n foo: bar;\n baz: bin;\n}\n" - ] - - it "cassiusFileReload with import URL" $ do - celper - "@import url(url);\n" - $(cassiusFileReload "test/cassiuses/reload-import.cassius") - - it "& subblocks" $ - celper "foo:bar{baz:bin}" - [lucius| - foo { - &:bar { - baz: bin; - } - } - |] - - describe "font-face #139" $ do - it "lucius" $ - celper "@font-face{font-family:myFirstFont;src:url(sansation_light.woff)}" - [lucius| - @font-face { - font-family: myFirstFont; - src: url(sansation_light.woff); - } - |] - it "cassius" $ - celper "@font-face{font-family:myFirstFont;src:url(sansation_light.woff)}" - [cassius| - @font-face - font-family: myFirstFont - src: url(sansation_light.woff) - |] - -data Url = Home | Sub SubUrl -data SubUrl = SubUrl -render :: Url -> [(Text, Text)] -> Text -render Home qs = pack "url" `mappend` showParams qs -render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs - -showParams :: [(Text, Text)] -> Text -showParams [] = pack "" -showParams z = - pack $ '?' : intercalate "&" (map go z) - where - go (x, y) = go' x ++ '=' : go' y - go' = concatMap encodeUrlChar . unpack - --- | Taken straight from web-encodings; reimplemented here to avoid extra --- dependencies. -encodeUrlChar :: Char -> String -encodeUrlChar c - -- List of unreserved characters per RFC 3986 - -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding - | 'A' <= c && c <= 'Z' = [c] - | 'a' <= c && c <= 'z' = [c] - | '0' <= c && c <= '9' = [c] -encodeUrlChar c@'-' = [c] -encodeUrlChar c@'_' = [c] -encodeUrlChar c@'.' = [c] -encodeUrlChar c@'~' = [c] -encodeUrlChar ' ' = "+" -encodeUrlChar y = - let (a, c) = fromEnum y `divMod` 16 - b = a `mod` 16 - showHex' x - | x < 10 = toEnum $ x + (fromEnum '0') - | x < 16 = toEnum $ x - 10 + (fromEnum 'A') - | otherwise = error $ "Invalid argument to showHex: " ++ show x - in ['%', showHex' b, showHex' c] - - - -celper :: String -> CssUrl Url -> Assertion -celper res h = do - let x = renderCssUrl render h - T.pack res @=? x - -caseCassius :: Assertion -caseCassius = do - let var = "var" - let urlp = (Home, [(pack "p", pack "q")]) - flip celper [cassius| -foo - background: #{colorBlack} - bar: baz - color: #{colorRed} -bin - background-image: url(@{Home}) - bar: bar - color: #{(((Color 127) 100) 5)} - f#{var}x: someval - unicode-test: שלום - urlp: url(@?{urlp}) -|] $ concat - [ "foo{background:#000;bar:baz;color:#F00}" - , "bin{" - , "background-image:url(url);" - , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" - , "urlp:url(url?p=q)}" - ] - -caseCassiusFile :: Assertion -caseCassiusFile = do - let var = "var" - let selector = "foo" - let urlp = (Home, [(pack "p", pack "q")]) - flip celper $(cassiusFile "test/cassiuses/external1.cassius") $ concat - [ "foo{background:#000;bar:baz;color:#F00}" - , "bin{" - , "background-image:url(url);" - , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" - , "urlp:url(url?p=q)}" - ] - -caseCassiusSingleComment :: Assertion -caseCassiusSingleComment = - flip celper [cassius| - /* - this is a comment - */ - |] "" - -caseCassiusLeadingComment :: Assertion -caseCassiusLeadingComment = - flip celper [cassius| - /* - this is a comment - */ - sel1 - foo: bar - sel2 - baz: bin - |] "sel1{foo:bar}sel2{baz:bin}" - -instance Show Url where - show _ = "FIXME remove this instance show Url" - - -caseLuciusFileDebug :: Assertion -caseLuciusFileDebug = do - let var = "var" - writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 1}" - celper "foo {\n var: 1;\n}\n" $(luciusFileDebug "test/cassiuses/external2.lucius") - writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 2}" - celper "foo {\n var: 2;\n}\n" $(luciusFileDebug "test/cassiuses/external2.lucius") - writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 1}"
− test/Text/Shakespeare/HamletSpec.hs
@@ -1,1068 +0,0 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -module Text.Shakespeare.HamletSpec (spec) where - -import HamletTestTypes (ARecord(..)) - -import Test.HUnit hiding (Test) -import Test.Hspec - -import Prelude hiding (reverse) -import Text.Hamlet -import Text.Hamlet.RT -import Data.List (intercalate) -import qualified Data.Text.Lazy as T -import qualified Data.List -import qualified Data.List as L -import qualified Data.Map as Map -import Data.Text (Text, pack, unpack) -import Data.Monoid (mappend,mconcat) -import qualified Data.Set as Set -import qualified Text.Blaze.Html.Renderer.Text -import Text.Blaze.Html (toHtml) -import Text.Blaze.Internal (preEscapedString) -import Text.Blaze - -spec = do - describe "hamlet" $ do - it "empty" caseEmpty - it "static" caseStatic - it "tag" caseTag - it "var" caseVar - it "var chain " caseVarChain - it "url" caseUrl - it "url chain " caseUrlChain - it "embed" caseEmbed - it "embed chain " caseEmbedChain - it "if" caseIf - it "if chain " caseIfChain - it "else" caseElse - it "else chain " caseElseChain - it "elseif" caseElseIf - it "elseif chain " caseElseIfChain - it "list" caseList - it "list chain" caseListChain - it "with" caseWith - it "with multi" caseWithMulti - it "with chain" caseWithChain - it "with comma string" caseWithCommaString - it "with multi scope" caseWithMultiBindingScope - it "script not empty" caseScriptNotEmpty - it "meta empty" caseMetaEmpty - it "input empty" caseInputEmpty - it "multiple classes" caseMultiClass - it "attrib order" caseAttribOrder - it "nothing" caseNothing - it "nothing chain " caseNothingChain - it "just" caseJust - it "just chain " caseJustChain - it "constructor" caseConstructor - it "url + params" caseUrlParams - it "escape" caseEscape - it "empty statement list" caseEmptyStatementList - it "attribute conditionals" caseAttribCond - it "non-ascii" caseNonAscii - it "maybe function" caseMaybeFunction - it "trailing dollar sign" caseTrailingDollarSign - it "non leading percent sign" caseNonLeadingPercent - it "quoted attributes" caseQuotedAttribs - it "spaced derefs" caseSpacedDerefs - it "attrib vars" caseAttribVars - it "strings and html" caseStringsAndHtml - it "nesting" caseNesting - it "trailing space" caseTrailingSpace - it "currency symbols" caseCurrency - it "external" caseExternal - it "parens" caseParens - it "hamlet literals" caseHamletLiterals - it "hamlet' and xhamlet'" caseHamlet' - it "hamlet tuple" caseTuple - it "complex pattern" caseComplex - it "record pattern" caseRecord - it "record wildcard pattern #1" caseRecordWildCard - it "record wildcard pattern #2" caseRecordWildCard1 - - - - it "comments" $ do - -- FIXME reconsider Hamlet comment syntax? - helper "" [hamlet|$# this is a comment -$# another comment -$#a third one|] - - - it "ignores a blank line" $ do - helper "<p>foo</p>\n" [hamlet| -<p> - - foo - - -|] - - - - - it "angle bracket syntax" $ - helper "<p class=\"foo\" height=\"100\"><span id=\"bar\" width=\"50\">HELLO</span></p>" - [hamlet| -$newline never -<p.foo height="100"> - <span #bar width=50>HELLO -|] - - - - it "hamlet module names" $ do - let foo = "foo" - helper "oof oof 3.14 -5" - [hamlet| -$newline never -#{Data.List.reverse foo} # -#{L.reverse foo} # -#{show 3.14} #{show -5}|] - - - - - - it "single dollar at and caret" $ do - helper "$@^" [hamlet|\$@^|] - - helper "#{@{^{" [hamlet|#\{@\{^\{|] - - - it "dollar operator" $ do - let val = (1, (2, 3)) - helper "2" [hamlet|#{ show $ fst $ snd val }|] - helper "2" [hamlet|#{ show $ fst $ snd $ val}|] - - - it "in a row" $ do - helper "1" [hamlet|#{ show $ const 1 2 }|] - - - it "embedded slash" $ do - helper "///" [hamlet|///|] - -{- compile-time error - it "tag with slash" $ do - helper "" [hamlet| -<p> - Text -</p> -|] --} - - it "string literals" $ do - helper "string" [hamlet|#{"string"}|] - helper "string" [hamlet|#{id "string"}|] - helper "gnirts" [hamlet|#{L.reverse $ id "string"}|] - helper "str"ing" [hamlet|#{"str\"ing"}|] - helper "str<ing" [hamlet|#{"str<ing"}|] - - - it "interpolated operators" $ do - helper "3" [hamlet|#{show $ (+) 1 2}|] - helper "6" [hamlet|#{show $ sum $ (:) 1 ((:) 2 $ return 3)}|] - - - it "HTML comments" $ do - helper "<p>1</p><p>2 not ignored</p>" [hamlet| -$newline never -<p>1 -<!-- ignored comment --> -<p> - 2 - <!-- ignored --> not ignored<!-- ignored --> -|] - - it "Keeps SSI includes" $ - helper "<!--# SSI -->" [hamlet|<!--# SSI -->|] - - - - it "nested maybes" $ do - let muser = Just "User" :: Maybe String - mprof = Nothing :: Maybe Int - m3 = Nothing :: Maybe String - helper "justnothing" [hamlet| -$maybe user <- muser - $maybe profile <- mprof - First two are Just - $maybe desc <- m3 - \ and left us a description: - <p>#{desc} - $nothing - and has left us no description. - $nothing - justnothing -$nothing - <h1>No such Person exists. - |] - - - it "maybe with qualified constructor" $ do - helper "5" [hamlet| - $maybe HamletTestTypes.ARecord x y <- Just $ ARecord 5 True - \#{x} - |] - - it "record with qualified constructor" $ do - helper "5" [hamlet| - $maybe HamletTestTypes.ARecord {..} <- Just $ ARecord 5 True - \#{field1} - |] - - - - - it "conditional class" $ do - helper "<p class=\"current\"></p>\n" - [hamlet|<p :False:.ignored :True:.current>|] - - helper "<p class=\"1 3 2 4\"></p>\n" - [hamlet|<p :True:.1 :True:class=2 :False:.a :False:class=b .3 class=4>|] - - helper "<p class=\"foo bar baz\"></p>\n" - [hamlet|<p class=foo class=bar class=baz>|] - - - - - it "forall on Foldable" $ do - let set = Set.fromList [1..5 :: Int] - helper "12345" [hamlet| -$forall x <- set - #{x} -|] - - - - it "non-poly HTML" $ do - helperHtml "<h1>HELLO WORLD</h1>\n" [shamlet| - <h1>HELLO WORLD - |] - helperHtml "<h1>HELLO WORLD</h1>\n" $(shamletFile "test/hamlets/nonpolyhtml.hamlet") - helper "<h1>HELLO WORLD</h1>\n" $(hamletFileReload "test/hamlets/nonpolyhtml.hamlet") - - - it "non-poly Hamlet" $ do - let embed = [hamlet|<p>EMBEDDED|] - helper "<h1>url</h1>\n<p>EMBEDDED</p>\n" [hamlet| - <h1>@{Home} - ^{embed} - |] - helper "<h1>url</h1>\n" $(hamletFile "test/hamlets/nonpolyhamlet.hamlet") - helper "<h1>url</h1>\n" $(hamletFileReload "test/hamlets/nonpolyhamlet.hamlet") - - it "non-poly IHamlet" $ do - let embed = [ihamlet|<p>EMBEDDED|] - ihelper "<h1>Adios</h1>\n<p>EMBEDDED</p>\n" [ihamlet| - <h1>_{Goodbye} - ^{embed} - |] - ihelper "<h1>Hola</h1>\n" $(ihamletFile "test/hamlets/nonpolyihamlet.hamlet") - ihelper "<h1>Hola</h1>\n" $(ihamletFileReload "test/hamlets/nonpolyihamlet.hamlet") - - it "pattern-match tuples: forall" $ do - let people = [("Michael", 26), ("Miriam", 25)] - helper "<dl><dt>Michael</dt><dd>26</dd><dt>Miriam</dt><dd>25</dd></dl>" [hamlet| -$newline never -<dl> - $forall (name, age) <- people - <dt>#{name} - <dd>#{show age} -|] - it "pattern-match tuples: maybe" $ do - let people = Just ("Michael", 26) - helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet| -$newline never -<dl> - $maybe (name, age) <- people - <dt>#{name} - <dd>#{show age} -|] - it "pattern-match tuples: with" $ do - let people = ("Michael", 26) - helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet| -$newline never -<dl> - $with (name, age) <- people - <dt>#{name} - <dd>#{show age} -|] - it "list syntax for interpolation" $ do - helper "<ul><li>1</li><li>2</li><li>3</li></ul>" [hamlet| -$newline never -<ul> - $forall num <- [1, 2, 3] - <li>#{show num} -|] - it "infix operators" $ - helper "5" [hamlet|#{show $ (4 + 5) - (2 + 2)}|] - it "infix operators with parens" $ - helper "5" [hamlet|#{show ((+) 1 1 + 3)}|] - it "doctypes" $ helper "<!DOCTYPE html>\n<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n" [hamlet| -$newline never -$doctype 5 -$doctype strict -|] - - it "case on Maybe" $ - let nothing = Nothing - justTrue = Just True - in helper "<br><br><br><br>" [hamlet| -$newline never -$case nothing - $of Just val - $of Nothing - <br> -$case justTrue - $of Just val - $if val - <br> - $of Nothing -$case (Just $ not False) - $of Nothing - $of Just val - $if val - <br> -$case Nothing - $of Just val - $of _ - <br> -|] - - it "case on Url" $ - let url1 = Home - url2 = Sub SubUrl - in helper "<br>\n<br>\n" [hamlet| -$newline always -$case url1 - $of Home - <br> - $of _ -$case url2 - $of Sub sub - $case sub - $of SubUrl - <br> - $of Home -|] - - it "pattern-match constructors: forall" $ do - let people = [Pair "Michael" 26, Pair "Miriam" 25] - helper "<dl><dt>Michael</dt><dd>26</dd><dt>Miriam</dt><dd>25</dd></dl>" [hamlet| -$newline text -<dl> - $forall Pair name age <- people - <dt>#{name} - <dd>#{show age} -|] - it "pattern-match constructors: maybe" $ do - let people = Just $ Pair "Michael" 26 - helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet| -$newline text -<dl> - $maybe Pair name age <- people - <dt>#{name} - <dd>#{show age} -|] - it "pattern-match constructors: with" $ do - let people = Pair "Michael" 26 - helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet| -$newline text -<dl> - $with Pair name age <- people - <dt>#{name} - <dd>#{show age} -|] - - it "multiline tags" $ helper - "<foo bar=\"baz\" bin=\"bin\">content</foo>\n" [hamlet| -<foo bar=baz - bin=bin>content -|] - it "*{...} attributes" $ - let attrs = [("bar", "baz"), ("bin", "<>\"&")] in helper - "<foo bar=\"baz\" bin=\"<>"&\">content</foo>\n" [hamlet| -<foo *{attrs}>content -|] - it "blank attr values" $ helper - "<foo bar=\"\" baz bin=\"\"></foo>\n" - [hamlet|<foo bar="" baz bin=>|] - it "greater than in attr" $ helper - "<button data-bind=\"enable: someFunction() > 5\">hello</button>\n" - [hamlet|<button data-bind="enable: someFunction() > 5">hello|] - it "normal doctype" $ helper - "<!DOCTYPE html>\n" - [hamlet|<!DOCTYPE html>|] - it "newline style" $ helper - "<p>foo</p>\n<pre>bar\nbaz\nbin</pre>\n" - [hamlet| -$newline always -<p>foo -<pre> - bar - baz - bin -|] - it "avoid newlines" $ helper - "<p>foo</p><pre>barbazbin</pre>" - [hamlet| -$newline always -<p>foo# -<pre># - bar# - baz# - bin# -|] - it "manual linebreaks" $ helper - "<p>foo</p><pre>bar\nbaz\nbin</pre>" - [hamlet| -$newline never -<p>foo -<pre> - bar - \ - baz - \ - bin -|] - it "indented newline" $ helper - "<p>foo</p><pre>bar\nbaz\nbin</pre>" - [hamlet| - $newline never - <p>foo - <pre> - bar - \ - baz - \ - bin -|] - it "case underscore" $ - let num = 3 - in helper "<p>Many</p>\n" [hamlet| -$case num - $of 1 - <p>1 - $of 2 - <p>2 - $of _ - <p>Many -|] - it "optional and missing classes" $ - helper "<i>foo</i>\n" [hamlet|<i :False:.not-present>foo|] - it "multiple optional and missing classes" $ - helper "<i>foo</i>\n" [hamlet|<i :False:.not-present :False:.also-not-here>foo|] - it "optional and present classes" $ - helper "<i class=\"present\">foo</i>\n" [hamlet|<i :False:.not-present :True:.present>foo|] - it "punctuation operators #115" $ - helper "foo" - [hamlet| - $if True && True - foo - $else - bar - |] - - it "list syntax" $ - helper "123" - [hamlet| - $forall x <- [] - ignored - $forall x <- [1, 2, 3] - #{show x} - |] - - it "list in attribute" $ - let myShow :: [Int] -> String - myShow = show - in helper "<a href=\"[]\">foo</a>\n<a href=\"[1,2]\">bar</a>\n" - [hamlet| - <a href=#{myShow []}>foo - <a href=#{myShow [1, 2]}>bar - |] - - it "AngularJS attribute values #122" $ - helper "<li ng-repeat=\"addr in msgForm.new.split(/\\\\s/)\">{{addr}}</li>\n" - [hamlet|<li ng-repeat="addr in msgForm.new.split(/\\s/)">{{addr}}|] - - it "runtime Hamlet with caret interpolation" $ do - let toInclude render = render (5, [("hello", "world")]) - let renderer x y = pack $ show (x :: Int, y :: [(Text, Text)]) - template1 = "@?{url}" - template2 = "foo^{toInclude}bar" - toInclude <- parseHamletRT defaultHamletSettings template1 - hamletRT <- parseHamletRT defaultHamletSettings template2 - res <- renderHamletRT hamletRT - [ (["toInclude"], HDTemplate toInclude) - , (["url"], HDUrlParams 5 [(pack "hello", pack "world")]) - ] renderer - helperHtml "foo(5,[(\"hello\",\"world\")])bar" res - -data Pair = Pair String Int - -data Url = Home | Sub SubUrl -data SubUrl = SubUrl -render :: Url -> [(Text, Text)] -> Text -render Home qs = pack "url" `mappend` showParams qs -render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs - -showParams :: [(Text, Text)] -> Text -showParams [] = pack "" -showParams z = - pack $ '?' : intercalate "&" (map go z) - where - go (x, y) = go' x ++ '=' : go' y - go' = concatMap encodeUrlChar . unpack - --- | Taken straight from web-encodings; reimplemented here to avoid extra --- dependencies. -encodeUrlChar :: Char -> String -encodeUrlChar c - -- List of unreserved characters per RFC 3986 - -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding - | 'A' <= c && c <= 'Z' = [c] - | 'a' <= c && c <= 'z' = [c] - | '0' <= c && c <= '9' = [c] -encodeUrlChar c@'-' = [c] -encodeUrlChar c@'_' = [c] -encodeUrlChar c@'.' = [c] -encodeUrlChar c@'~' = [c] -encodeUrlChar ' ' = "+" -encodeUrlChar y = - let (a, c) = fromEnum y `divMod` 16 - b = a `mod` 16 - showHex' x - | x < 10 = toEnum $ x + (fromEnum '0') - | x < 16 = toEnum $ x - 10 + (fromEnum 'A') - | otherwise = error $ "Invalid argument to showHex: " ++ show x - in ['%', showHex' b, showHex' c] - -data Arg url = Arg - { getArg :: Arg url - , var :: Html - , url :: Url - , embed :: HtmlUrl url - , true :: Bool - , false :: Bool - , list :: [Arg url] - , nothing :: Maybe String - , just :: Maybe String - , urlParams :: (Url, [(Text, Text)]) - } - -theArg :: Arg url -theArg = Arg - { getArg = theArg - , var = toHtml "<var>" - , url = Home - , embed = [hamlet|embed|] - , true = True - , false = False - , list = [theArg, theArg, theArg] - , nothing = Nothing - , just = Just "just" - , urlParams = (Home, [(pack "foo", pack "bar"), (pack "foo1", pack "bar1")]) - } - -helperHtml :: String -> Html -> Assertion -helperHtml res h = do - let x = Text.Blaze.Html.Renderer.Text.renderHtml h - T.pack res @=? x - -helper :: String -> HtmlUrl Url -> Assertion -helper res h = do - let x = Text.Blaze.Html.Renderer.Text.renderHtml $ h render - T.pack res @=? x - -caseEmpty :: Assertion -caseEmpty = helper "" [hamlet||] - -caseStatic :: Assertion -caseStatic = helper "some static content" [hamlet|some static content|] - -caseTag :: Assertion -caseTag = do - helper "<p class=\"foo\"><div id=\"bar\">baz</div></p>" [hamlet| -$newline text -<p .foo> - <#bar>baz -|] - helper "<p class=\"foo.bar\"><div id=\"bar\">baz</div></p>" [hamlet| -$newline text -<p class=foo.bar> - <#bar>baz -|] - -caseVar :: Assertion -caseVar = do - helper "<var>" [hamlet|#{var theArg}|] - -caseVarChain :: Assertion -caseVarChain = do - helper "<var>" [hamlet|#{var (getArg (getArg (getArg theArg)))}|] - -caseUrl :: Assertion -caseUrl = do - helper (unpack $ render Home []) [hamlet|@{url theArg}|] - -caseUrlChain :: Assertion -caseUrlChain = do - helper (unpack $ render Home []) [hamlet|@{url (getArg (getArg (getArg theArg)))}|] - -caseEmbed :: Assertion -caseEmbed = do - helper "embed" [hamlet|^{embed theArg}|] - helper "embed" $(hamletFileReload "test/hamlets/embed.hamlet") - ihelper "embed" $(ihamletFileReload "test/hamlets/embed.hamlet") - -caseEmbedChain :: Assertion -caseEmbedChain = do - helper "embed" [hamlet|^{embed (getArg (getArg (getArg theArg)))}|] - -caseIf :: Assertion -caseIf = do - helper "if" [hamlet| -$if true theArg - if -|] - -caseIfChain :: Assertion -caseIfChain = do - helper "if" [hamlet| -$if true (getArg (getArg (getArg theArg))) - if -|] - -caseElse :: Assertion -caseElse = helper "else" [hamlet| -$if false theArg - if -$else - else -|] - -caseElseChain :: Assertion -caseElseChain = helper "else" [hamlet| -$if false (getArg (getArg (getArg theArg))) - if -$else - else -|] - -caseElseIf :: Assertion -caseElseIf = helper "elseif" [hamlet| -$if false theArg - if -$elseif true theArg - elseif -$else - else -|] - -caseElseIfChain :: Assertion -caseElseIfChain = helper "elseif" [hamlet| -$if false(getArg(getArg(getArg theArg))) - if -$elseif true(getArg(getArg(getArg theArg))) - elseif -$else - else -|] - -caseList :: Assertion -caseList = do - helper "xxx" [hamlet| -$forall _x <- (list theArg) - x -|] - -caseListChain :: Assertion -caseListChain = do - helper "urlurlurl" [hamlet| -$forall x <- list(getArg(getArg(getArg(getArg(getArg (theArg)))))) - @{url x} -|] - -caseWith :: Assertion -caseWith = do - helper "it's embedded" [hamlet| -$with n <- embed theArg - it's ^{n}ded -|] - -caseWithMulti :: Assertion -caseWithMulti = do - helper "it's embedded" [hamlet| -$with n <- embed theArg, m <- true theArg - $if m - it's ^{n}ded -|] - -caseWithChain :: Assertion -caseWithChain = do - helper "it's true" [hamlet| -$with n <- true(getArg(getArg(getArg(getArg theArg)))) - $if n - it's true -|] - --- in multi-with binding, make sure that a comma in a string doesn't confuse the parser. -caseWithCommaString :: Assertion -caseWithCommaString = do - helper "it's , something" [hamlet| -$with n <- " , something" - it's #{n} -|] - -caseWithMultiBindingScope :: Assertion -caseWithMultiBindingScope = do - helper "it's , something" [hamlet| -$with n <- " , something", y <- n - it's #{y} -|] - -caseScriptNotEmpty :: Assertion -caseScriptNotEmpty = helper "<script></script>\n" [hamlet|<script>|] - -caseMetaEmpty :: Assertion -caseMetaEmpty = do - helper "<meta>\n" [hamlet|<meta>|] - helper "<meta/>\n" [xhamlet|<meta>|] - -caseInputEmpty :: Assertion -caseInputEmpty = do - helper "<input>\n" [hamlet|<input>|] - helper "<input/>\n" [xhamlet|<input>|] - -caseMultiClass :: Assertion -caseMultiClass = helper "<div class=\"foo bar\"></div>\n" [hamlet|<.foo.bar>|] - -caseAttribOrder :: Assertion -caseAttribOrder = - helper "<meta 1 2 3>\n" [hamlet|<meta 1 2 3>|] - -caseNothing :: Assertion -caseNothing = do - helper "" [hamlet| -$maybe _n <- nothing theArg - nothing -|] - helper "nothing" [hamlet| -$maybe _n <- nothing theArg - something -$nothing - nothing -|] - -caseNothingChain :: Assertion -caseNothingChain = helper "" [hamlet| -$maybe n <- nothing(getArg(getArg(getArg theArg))) - nothing #{n} -|] - -caseJust :: Assertion -caseJust = helper "it's just" [hamlet| -$maybe n <- just theArg - it's #{n} -|] - -caseJustChain :: Assertion -caseJustChain = helper "it's just" [hamlet| -$maybe n <- just(getArg(getArg(getArg theArg))) - it's #{n} -|] - -caseConstructor :: Assertion -caseConstructor = do - helper "url" [hamlet|@{Home}|] - helper "suburl" [hamlet|@{Sub SubUrl}|] - let text = "<raw text>" - helper "<raw text>" [hamlet|#{preEscapedString text}|] - -caseUrlParams :: Assertion -caseUrlParams = do - helper "url?foo=bar&foo1=bar1" [hamlet|@?{urlParams theArg}|] - -caseEscape :: Assertion -caseEscape = do - helper "#this is raw\n " [hamlet| -$newline never -\#this is raw -\ -\ -|] - helper "$@^" [hamlet|\$@^|] - -caseEmptyStatementList :: Assertion -caseEmptyStatementList = do - helper "" [hamlet|$if True|] - helper "" [hamlet|$maybe _x <- Nothing|] - let emptyList = [] - helper "" [hamlet|$forall _x <- emptyList|] - -caseAttribCond :: Assertion -caseAttribCond = do - helper "<select></select>\n" [hamlet|<select :False:selected>|] - helper "<select selected></select>\n" [hamlet|<select :True:selected>|] - helper "<meta var=\"foo:bar\">\n" [hamlet|<meta var=foo:bar>|] - helper "<select selected></select>\n" - [hamlet|<select :true theArg:selected>|] - - helper "<select></select>\n" [hamlet|<select :False:selected>|] - helper "<select selected></select>\n" [hamlet|<select :True:selected>|] - helper "<meta var=\"foo:bar\">\n" [hamlet|<meta var=foo:bar>|] - helper "<select selected></select>\n" - [hamlet|<select :true theArg:selected>|] - -caseNonAscii :: Assertion -caseNonAscii = do - helper "עִבְרִי" [hamlet|עִבְרִי|] - -caseMaybeFunction :: Assertion -caseMaybeFunction = do - helper "url?foo=bar&foo1=bar1" [hamlet| -$maybe x <- Just urlParams - @?{x theArg} -|] - -caseTrailingDollarSign :: Assertion -caseTrailingDollarSign = - helper "trailing space \ndollar sign #" [hamlet| -$newline never -trailing space # -\ -dollar sign #\ -|] - -caseNonLeadingPercent :: Assertion -caseNonLeadingPercent = - helper "<span style=\"height:100%\">foo</span>" [hamlet| -$newline never -<span style=height:100%>foo -|] - -caseQuotedAttribs :: Assertion -caseQuotedAttribs = - helper "<input type=\"submit\" value=\"Submit response\">" [hamlet| -$newline never -<input type=submit value="Submit response"> -|] - -caseSpacedDerefs :: Assertion -caseSpacedDerefs = do - helper "<var>" [hamlet|#{var theArg}|] - helper "<div class=\"<var>\"></div>\n" [hamlet|<.#{var theArg}>|] - -caseAttribVars :: Assertion -caseAttribVars = do - helper "<div id=\"<var>\"></div>\n" [hamlet|<##{var theArg}>|] - helper "<div class=\"<var>\"></div>\n" [hamlet|<.#{var theArg}>|] - helper "<div f=\"<var>\"></div>\n" [hamlet|< f=#{var theArg}>|] - - helper "<div id=\"<var>\"></div>\n" [hamlet|<##{var theArg}>|] - helper "<div class=\"<var>\"></div>\n" [hamlet|<.#{var theArg}>|] - helper "<div f=\"<var>\"></div>\n" [hamlet|< f=#{var theArg}>|] - -caseStringsAndHtml :: Assertion -caseStringsAndHtml = do - let str = "<string>" - let html = preEscapedString "<html>" - helper "<string> <html>" [hamlet|#{str} #{html}|] - -caseNesting :: Assertion -caseNesting = do - helper - "<table><tbody><tr><td>1</td></tr><tr><td>2</td></tr></tbody></table>" - [hamlet| -$newline never -<table> - <tbody> - $forall user <- users - <tr> - <td>#{user} -|] - helper - (concat - [ "<select id=\"foo\" name=\"foo\"><option selected></option>" - , "<option value=\"true\">Yes</option>" - , "<option value=\"false\">No</option>" - , "</select>" - ]) - [hamlet| -$newline never -<select #"#{name}" name=#{name}> - <option :isBoolBlank val:selected> - <option value=true :isBoolTrue val:selected>Yes - <option value=false :isBoolFalse val:selected>No -|] - where - users = ["1", "2"] - name = "foo" - val = 5 :: Int - isBoolBlank _ = True - isBoolTrue _ = False - isBoolFalse _ = False - -caseTrailingSpace :: Assertion -caseTrailingSpace = - helper "" [hamlet| |] - -caseCurrency :: Assertion -caseCurrency = - helper foo [hamlet|#{foo}|] - where - foo = "eg: 5, $6, €7.01, £75" - -caseExternal :: Assertion -caseExternal = do - helper "foo\n<br>\n" $(hamletFile "test/hamlets/external.hamlet") - helper "foo\n<br/>\n" $(xhamletFile "test/hamlets/external.hamlet") - helper "foo\n<br>\n" $(hamletFileReload "test/hamlets/external.hamlet") - where - foo = "foo" - -caseParens :: Assertion -caseParens = do - let plus = (++) - x = "x" - y = "y" - helper "xy" [hamlet|#{(plus x) y}|] - helper "xxy" [hamlet|#{plus (plus x x) y}|] - let alist = ["1", "2", "3"] - helper "123" [hamlet| -$forall x <- (id id id id alist) - #{x} -|] - -caseHamletLiterals :: Assertion -caseHamletLiterals = do - helper "123" [hamlet|#{show 123}|] - helper "123.456" [hamlet|#{show 123.456}|] - helper "-123" [hamlet|#{show -123}|] - helper "-123.456" [hamlet|#{show -123.456}|] - -helper' :: String -> Html -> Assertion -helper' res h = T.pack res @=? Text.Blaze.Html.Renderer.Text.renderHtml h - -caseHamlet' :: Assertion -caseHamlet' = do - helper' "foo" [shamlet|foo|] - helper' "foo" [xshamlet|foo|] - helper "<br>\n" $ const $ [shamlet|<br>|] - helper "<br/>\n" $ const $ [xshamlet|<br>|] - - -- new with generalized stuff - helper' "foo" [shamlet|foo|] - helper' "foo" [xshamlet|foo|] - helper "<br>\n" $ const $ [shamlet|<br>|] - helper "<br/>\n" $ const $ [xshamlet|<br>|] - - -instance Show Url where - show _ = "FIXME remove this instance show Url" - -caseDiffBindNames :: Assertion -caseDiffBindNames = do - let list = words "1 2 3" - -- FIXME helper "123123" $(hamletFileReload "test/hamlets/external-debug3.hamlet") - error "test has been disabled" - - -caseTrailingSpaces :: Assertion -caseTrailingSpaces = helper "" [hamlet| -$if True -$elseif False -$else -$maybe x <- Nothing -$nothing -$forall x <- empty -|] - where - empty = [] - - - -caseTuple :: Assertion -caseTuple = do - helper "(1,1)" [hamlet| #{("1","1")}|] - helper "foo" [hamlet| - $with (a,b) <- ("foo","bar") - #{a} - |] - helper "url" [hamlet| - $with (a,b) <- (Home,Home) - @{a} - |] - helper "url" [hamlet| - $with p <- (Home,[]) - @?{p} - |] - - - -caseComplex :: Assertion -caseComplex = do - let z :: ((Int,Int),Maybe Int,(),Bool,[[Int]]) - z = ((1,2),Just 3,(),True,[[4],[5,6]]) - helper "1 2 3 4 5 61 2 3 4 5 6" [hamlet| - $with ((a,b),Just c, () ,True,d@[[e],[f,g]]) <- z - $forall h <- d - #{a} #{b} #{c} #{e} #{f} #{g} - |] - -caseRecord :: Assertion -caseRecord = do - let z = ARecord 10 True - helper "10" [hamlet| - $with ARecord { field1, field2 = True } <- z - #{field1} - |] - -caseRecordWildCard :: Assertion -caseRecordWildCard = do - let z = ARecord 10 True - helper "10 True" [hamlet| - $with ARecord {..} <- z - #{field1} #{field2} - |] - -caseRecordWildCard1 :: Assertion -caseRecordWildCard1 = do - let z = ARecord 10 True - helper "10" [hamlet| - $with ARecord {field2 = True, ..} <- z - #{field1} - |] - -caseCaseRecord :: Assertion -caseCaseRecord = do - let z = ARecord 10 True - helper "10\nTrue" [hamlet| - $case z - $of ARecord { field1, field2 = x } - #{field1} - #{x} - |] - -data Msg = Hello | Goodbye - -ihelper :: String -> HtmlUrlI18n Msg Url -> Assertion -ihelper res h = do - let x = Text.Blaze.Html.Renderer.Text.renderHtml $ h showMsg render - T.pack res @=? x - where - showMsg Hello = preEscapedString "Hola" - showMsg Goodbye = preEscapedString "Adios" - -instance (ToMarkup a, ToMarkup b) => ToMarkup (a,b) where - toMarkup (a,b) = do - toMarkup "(" - toMarkup a - toMarkup "," - toMarkup b - toMarkup ")"
test/Text/Shakespeare/I18NSpec.hs view
@@ -1,16 +1,57 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+ module Text.Shakespeare.I18NSpec ( spec ) where import Data.Text (Text) import Text.Shakespeare.I18N+import Test.Hspec -spec :: Monad m => m ()-spec = return ()+class YesodSubApp master where -data Test = Test+instance YesodSubApp () -mkMessage "Test" "test-messages" "en"+newtype SubApp master = SubApp master++instance YesodSubApp (SubApp master)++data Test a b++mkMessage "(YesodSubApp master) => SubApp master" "other-messages" "en" ++mkMessage "Test a b" "test-messages" "en"++newtype SubAppNoRec master = SubAppNoRec master++instance YesodSubApp (SubAppNoRec master)++data TestNoRec++mkMessageOpts+ (setConPrefix "MsgNR" $ setUseRecordCons False defMakeMessageOpts)+ "(YesodSubApp master) => SubAppNoRec master"+ "(YesodSubApp master) => SubAppNoRec master"+ "other-messages"+ "en"++mkMessageOpts+ (setConPrefix "MsgNR" $ setUseRecordCons False defMakeMessageOpts)+ "TestNoRec"+ "TestNoRec"+ "test-messages"+ "en"++spec :: Spec+spec = do+ describe "I18N" $ do+ it "should generate messages with record constructors" $ do+ let msg = MsgEntryCreatedRR { subAppMessageTitle = "foo" }+ renderMessage (SubApp ()) [] msg `shouldBe` "Your new blog post, foo, has been created"++ it "should generate messages without record constructors" $ do+ let msg = MsgNREntryCreatedRR "bar"+ renderMessage (SubAppNoRec ()) [] msg `shouldBe` "Your new blog post, bar, has been created"
− test/Text/Shakespeare/JsSpec.hs
@@ -1,196 +0,0 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} -module Text.Shakespeare.JsSpec (spec) where - -import Test.HUnit hiding (Test) -import Test.Hspec - -import Prelude hiding (reverse) -#ifdef TEST_COFFEE -import Text.Coffee -#endif -import Text.Julius -import Quoter (quote, quoteFile, quoteFileReload) -import Data.List (intercalate) -import qualified Data.Text.Lazy as T -import qualified Data.List -import qualified Data.List as L -import Data.Text (Text, pack, unpack) -import Data.Monoid (mappend) -import Data.Aeson (toJSON) - -join :: [String] -> String -#ifdef TEST_COFFEE -join l = (intercalate ";\n" l) -#else -join = intercalate "\n" -#endif - -spec :: Spec -spec = describe "shakespeare-js" $ do -#if !(defined TEST_COFFEE || defined TEST_ROY) - it "julius" $ do - let var = "x=2" - let urlp = (Home, [(pack "p", pack "q")]) - flip jelper [quote|['שלום', @{Home}, #{rawJS var}, '@?{urlp}', ^{jmixin} ]|] - $ intercalate " " - [ "['שלום'," - , "url, " ++ var ++ "," - , "'url?p=q'," - , "f(2) ]" - ] - - - it "juliusFile" $ do - let var = "x=2" - let urlp = (Home, [(pack "p", pack "q")]) - flip jelper $(quoteFile "test/juliuses/external1.julius") $ join - [ "שלום" - , var - , "url" - , "url?p=q" - , "f(2)" - ] ++ "\n" - - - it "juliusFileReload" $ do - let var = "x=2" - let urlp = (Home, [(pack "p", pack "q")]) - flip jelper $(quoteFileReload "test/juliuses/external1.julius") $ join - [ "שלום" - , var - , "url" - , "url?p=q" - , "f(2)" - ] ++ "\n" -#endif - -{- TODO - it "juliusFileDebugChange" $ do - let var = "somevar" - test result = jelper result $(juliusFileDebug "test/juliuses/external2.julius") - writeFile "test/juliuses/external2.julius" "var #{var} = 1;" - test "var somevar = 1;" - writeFile "test/juliuses/external2.julius" "var #{var} = 2;" - test "var somevar = 2;" - writeFile "test/juliuses/external2.julius" "var #{var} = 1;" - -} - - - it "julius module names" $ - let foo = "foo" - double = 3.14 :: Double - int = -5 :: Int -#ifdef TEST_COFFEE - in jelper "var _this = this;\n\n(function(shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint) {\n return [shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint];\n})(oof, oof, 3.14, -5);\n" -#else -# ifdef TEST_ROY - in jelper "(function(shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint) {\n return [shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint];\n})(oof, oof, 3.14, -5);\n" -# else - in jelper "[oof, oof, 3.14, -5]" -# endif -#endif - [quote|[#{rawJS $ Data.List.reverse foo}, #{rawJS $ L.reverse foo}, #{rawJS $ show double}, #{rawJS $ show int}]|] - - --- not valid coffeescript -#if !(defined TEST_COFFEE || defined TEST_ROY) - it "single dollar at and caret" $ do - jelper "$@^" [quote|$@^|] - jelper "#{@{^{" [quote|#\{@\{^\{|] -#endif - - it "dollar operator" $ do - let val = (1 :: Int, (2 :: Int, 3 :: Int)) -#if (defined TEST_COFFEE) - jelper "var _this = this;\n\n(function(shakespeare_var_rawJSshowfstsndval) {\n return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|] - jelper "var _this = this;\n\n(function(shakespeare_var_rawJSshowfstsndval) {\n return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|] -#else - -# if (defined TEST_ROY) - jelper "(function(shakespeare_var_rawJSshowfstsndval) {\n return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|] - jelper "(function(shakespeare_var_rawJSshowfstsndval) {\n return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|] - -# else - jelper "2" [quote|#{ rawJS $ show $ fst $ snd val }|] - jelper "2" [quote|#{ rawJS $ show $ fst $ snd $ val}|] -# endif -#endif - -#if (defined TEST_ROY) - it "roy function wrapper" $ do - let royInsert = rawJS "\"royInsert\"" - jelper "(function(shakespeare_var_royInsert) {\n var roy = {\n \"royInsert\": shakespeare_var_royInsert\n };\n return console.log(roy);\n})(\"royInsert\");\n" [quote| -let roy = { royInsert: #{royInsert} } -console.log roy -|] -#endif - it "empty file" $ jelper "" [quote||] - - it "JSON data" $ jelper "\"Hello \\\"World!\\\"\"" [julius|#{toJSON "Hello \"World!\""}|] - - it "boolean interpolation" $ jelper - "true false true false true false" - [julius|#{True} #{False} #{toJSON True} #{toJSON False} #{rawJS True} #{rawJS False}|] - - it "^\\ should not be escaped" $ jelper - "var re = /[^\\r]/;" - [julius|var re = /[^\r]/;|] - - it "^\\{ should be escaped" $ jelper - "var re = /[^{]/;" - [julius|var re = /[^\{]/;|] - - -data Url = Home | Sub SubUrl -data SubUrl = SubUrl -render :: Url -> [(Text, Text)] -> Text -render Home qs = pack "url" `mappend` showParams qs -render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs - -showParams :: [(Text, Text)] -> Text -showParams [] = pack "" -showParams z = - pack $ '?' : intercalate "&" (map go z) - where - go (x, y) = go' x ++ '=' : go' y - go' = concatMap encodeUrlChar . unpack - --- | Taken straight from web-encodings; reimplemented here to avoid extra --- dependencies. -encodeUrlChar :: Char -> String -encodeUrlChar c - -- List of unreserved characters per RFC 3986 - -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding - | 'A' <= c && c <= 'Z' = [c] - | 'a' <= c && c <= 'z' = [c] - | '0' <= c && c <= '9' = [c] -encodeUrlChar c@'-' = [c] -encodeUrlChar c@'_' = [c] -encodeUrlChar c@'.' = [c] -encodeUrlChar c@'~' = [c] -encodeUrlChar ' ' = "+" -encodeUrlChar y = - let (a, c) = fromEnum y `divMod` 16 - b = a `mod` 16 - showHex' x - | x < 10 = toEnum $ x + (fromEnum '0') - | x < 16 = toEnum $ x - 10 + (fromEnum 'A') - | otherwise = error $ "Invalid argument to showHex: " ++ show x - in ['%', showHex' b, showHex' c] - - - - -#ifndef TEST_ROY -jmixin :: JavascriptUrl u -jmixin = [quote|f(2)|] -#endif - -jelper :: String -> JavascriptUrl Url -> Assertion -jelper res h = do - T.pack res @=? renderJavascriptUrl render h - -instance Show Url where - show _ = "FIXME remove this instance show Url"
test/Text/Shakespeare/TextSpec.hs view
@@ -1,22 +1,28 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module Text.Shakespeare.TextSpec (spec) where +import HamletTestTypes (ARecord(..)) + import Test.HUnit hiding (Test) import Test.Hspec import Prelude hiding (reverse) import Text.Shakespeare.Text import Data.List (intercalate) +import qualified Data.Text as T import qualified Data.Text.Lazy as TL +import Data.Text.Lazy.Builder (toLazyText) import qualified Data.List import qualified Data.List as L import Data.Text (Text, pack, unpack) import Data.Monoid (mappend) +import Text.Shakespeare.BuilderQQ + spec :: Spec spec = do - describe "shakespeare-text" $ do it "text" $ do let var = "var" let urlp = (Home, [(pack "p", pack "q")]) @@ -68,6 +74,9 @@ writeFile "test/texts/external2.text" "var #{var} = 1;" -} + it "stextFile" $ do + let var = "somevar" + TL.toStrict $(stextFile "test/texts/external2.text") @=? pack "var somevar = 2;" it "text module names" $ let foo = "foo" @@ -101,8 +110,32 @@ simpT "2" [stext|#{ show $ fst $ snd val }|] simpT "2" [stext|#{ show $ fst $ snd $ val}|] + it "aligned text with bar" $ do + let val = 3 :: Int + simpT "hoge\r\n3\r\n1\r\n" (TL.fromStrict [sbt|hoge + |#{val} + |1 + |]) + simpT "hoge\r\n3\r\n1\r\n" [lbt|hoge + |#{val} + |1 + |] + + it "caret operation with justVarInterpolation = True" $ do + let val = 2 :: Int + let bld = [builderQQ|#{ show val }|] + simpT "2" $ toLazyText [builderQQ|^{ bld }|] + +#if MIN_VERSION_template_haskell(2,18,0) + it "record dot" $ do + let z = ARecord 22 True + telper "221" [text|#{z.field1}#{fromEnum z.field2}|] +#endif + simpT :: String -> TL.Text -> Assertion -simpT a b = pack a @=? TL.toStrict b +simpT a b = nocrlf (pack a) @=? nocrlf (TL.toStrict b) + where + nocrlf = T.replace (pack "\r\n") (pack "\n") data Url = Home | Sub SubUrl
+ test/cassiuses/external-supports.lucius view
@@ -0,0 +1,7 @@+@supports only screen{+ hana {+ dul {+ set: net;+ }+ }+}