shakespeare 2.0.29 → 2.0.30
raw patch · 10 files changed
+1710/−506 lines, 10 files
Files
- ChangeLog.md +31/−33
- Text/Cassius.hs +17/−34
- Text/Cassius/Ordered.hs +98/−0
- Text/Internal/Cassius.hs +26/−0
- Text/Internal/Css.hs +147/−127
- Text/Internal/Lucius.hs +357/−0
- Text/Lucius.hs +16/−308
- Text/Lucius/Ordered.hs +121/−0
- shakespeare.cabal +5/−1
- test/Text/CssSpec.hs +892/−3
ChangeLog.md view
@@ -1,5 +1,9 @@ # ChangeLog for shakespeare +### 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)@@ -46,9 +50,11 @@ * 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@@ -150,48 +156,40 @@ ### Hamlet 0.5.0 (August 29, 2010) * Use can use parantheses when referencing variables. This allows you to have-functions applied to multiple arguments.-+ functions applied to multiple arguments. * Added the hamlet' and xhamlet' quasiquoters for generating plain Html-values.-+ 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.-+ 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.+ 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.-+ 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"|].-+ 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\$|].-+ 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.-+ 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.+ 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 FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-}+ module Text.Cassius ( -- * Datatypes Css@@ -39,58 +40,40 @@ , cassiusUsedIdentifiers ) where -import Text.Internal.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.Internal.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 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 Text.Lucius.luciusMixin . i2bMixin+ { quoteExp = quoteExp Lucius.luciusMixin . i2bMixin }--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/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/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
@@ -2,7 +2,9 @@ -- | 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 #-}@@ -36,38 +38,31 @@ 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]+data Resolved = Resolved | Unresolved -type family ChildBlocks a-type instance ChildBlocks Resolved = ()-type instance ChildBlocks Unresolved = [(HasLeadingSpace, Block Unresolved)]+-- Should mixins keep order (new version) or not (deprecated version)+data Order = Ordered | Unordered deriving (Lift) 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]+type family Str (a :: Resolved)+type instance Str 'Resolved = Builder+type instance Str 'Unresolved = Contents -data Block a = Block- { blockSelector :: !(Selector a)- , blockAttrs :: ![Attr a]- , blockBlocks :: !(ChildBlocks a)- , blockMixins :: !(Mixins a)- }+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)]+ { mixinAttrs :: ![Attr 'Resolved]+ , mixinBlocks :: ![(HasLeadingSpace, Block 'Resolved)] } deriving Lift instance Semigroup Mixin where@@ -75,22 +70,27 @@ instance Monoid Mixin where mempty = Mixin mempty mempty -data TopLevel a where+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+ TopVar :: !String -> !String -> TopLevel 'Unresolved -data Attr a = Attr- { attrKey :: !(Str a)- , attrVal :: !(Str a)- }+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 Css = CssWhitespace ![TopLevel 'Resolved]+ | CssNoWhitespace ![TopLevel 'Resolved] data Content = ContentRaw String | ContentVar Deref@@ -123,7 +123,7 @@ -- | 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]+ -> Parser [TopLevel 'Unresolved] -> String -> [(Deref, VarType)] cssUsedIdentifiers toi2b parseBlocks s' =@@ -133,8 +133,7 @@ a = either (error . show) id $ parse parseBlocks s s (scope0, contents) = go a - go :: [TopLevel Unresolved]- -> (Scope, [Content])+ go :: [TopLevel 'Unresolved] -> (Scope, [Content]) go [] = ([], []) go (TopAtDecl dec cs:rest) = (scope, rest'')@@ -150,22 +149,23 @@ 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)+ 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- restm = map ContentMixin mixins go (TopVar k v:rest) = ((k, v):scope, rest') where (scope, rest') = go rest- go' (Attr k v) = k ++ v+ 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+cssFileDebug :: Bool -- ^ perform the indent-to-brace conversion -> Q Exp- -> Parser [TopLevel Unresolved]+ -> Parser [TopLevel 'Unresolved] -> FilePath -> Q Exp cssFileDebug toi2b parseBlocks' parseBlocks fp = do@@ -176,9 +176,9 @@ parseBlocks'' <- parseBlocks' return $ cr `AppE` parseBlocks'' `AppE` (LitE $ StringL fp) `AppE` ListE c -runtimePrependSelector :: Builder -> (HasLeadingSpace, Block Resolved) -> Block Resolved-runtimePrependSelector builder (hsl, Block x b () ()) =- Block (builder <> addSpace x) b () ()+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 @@ -197,21 +197,19 @@ blockRuntime :: [(Deref, CDData url)] -> (url -> [(Text, Text)] -> Text)- -> Block Unresolved- -> Either String (DList (Block Resolved))+ -> 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+blockRuntime cd render' (BlockUnresolved x attrsAndMixins z) = do x' <- mapM go' $ intercalate [ContentRaw ","] x- attrs' <- mapM resolveAttr attrs+ attrs' <- mapM (either resolveAttr getMixinAttrs) attrsAndMixins+ blocks' <- mapM (either (const $ Right []) getMixinBlocks) attrsAndMixins z' <- mapM (subGo x) z -- FIXME use difflists again- Right $ \rest -> Block- { blockSelector = mconcat x'- , blockAttrs = concat $ attrs' : map mixinAttrs mixins- , blockBlocks = ()- , blockMixins = ()+ Right $ \rest -> BlockResolved+ { brSelectors = mconcat x'+ , brAttrs = concat attrs' }- : fmap (runtimePrependSelector $ mconcat x') (concatMap mixinBlocks mixins)+ : map (runtimePrependSelector $ mconcat x') (concat blocks') ++ foldr ($) rest z' {- (:) (Css' (mconcat $ map go' $ intercalate [ContentRaw "," ] x) (map go'' y))@@ -220,22 +218,30 @@ 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" - resolveAttr :: Attr Unresolved -> Either String (Attr Resolved)- resolveAttr (Attr k v) = Attr <$> (mconcat <$> mapM go' k) <*> (mconcat <$> mapM go' v)+ 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, Block a b c d) =- blockRuntime cd render' (Block a' b c d)- where- a' = combineSelectors hls x' a+ -> (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)@@ -258,7 +264,7 @@ contentToBuilderRT _ _ ContentMixin{} = Left "contentToBuilderRT ContentMixin" cssRuntime :: Bool -- ^ i2b?- -> Parser [TopLevel Unresolved]+ -> Parser [TopLevel 'Unresolved] -> FilePath -> [(Deref, CDData url)] -> (url -> [(Text, Text)] -> Text)@@ -270,8 +276,8 @@ return $ CssWhitespace $ goTop [] a where goTop :: [(String, String)] -- ^ scope- -> [TopLevel Unresolved]- -> [TopLevel Resolved]+ -> [TopLevel 'Unresolved]+ -> [TopLevel 'Resolved] goTop _ [] = [] goTop scope (TopAtDecl dec cs':rest) = TopAtDecl dec cs : goTop scope rest@@ -331,79 +337,91 @@ Just _ -> Just s lookupD _ _ = Nothing -compressTopLevel :: TopLevel Unresolved- -> TopLevel Unresolved+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+compressBlock :: Block 'Unresolved+ -> Block 'Unresolved+compressBlock (BlockUnresolved x y blocks) =+ BlockUnresolved (map cc x) (map go y) (map (second compressBlock) blocks) where- go (Attr k v) = Attr (cc k) (cc v)+ 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+ -> Block 'Unresolved -> Q Exp-blockToMixin r scope (Block _sel props subblocks mixins) =+blockToMixin r scope (BlockUnresolved _sel props subblocks) = -- TODO: preserve the CPS in @mixinBlocks@ below- [|Mixin- { mixinAttrs = concat- $ $(listE $ map go props)- : map mixinAttrs $mixinsE- , mixinBlocks = concat $(listE $ map subGo subblocks)- }+ [| 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- mixinsE = return $ ListE $ map (derefToExp []) mixins- go (Attr x y) = conE 'Attr- `appE` (contentsToBuilder r scope x)- `appE` (contentsToBuilder r scope y) -- 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, Block sel' b c d) =+ subGo (hls, BlockUnresolved sel' b c) = [| map (\x -> ($(lift hls), x))- $ $(blockToCss r scope $ Block sel' b c d) []+ $ $(blockToCss r scope $ BlockUnresolved sel' b c) [] |]-+ 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)- . (fmap (runtimePrependSelector $(selectorToBuilder r scope sel))- (concatMap mixinBlocks $mixinsE)- ++)+ -> 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- 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'+ 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@@ -430,7 +448,7 @@ type Scope = [(String, String)] -topLevelsToCassius :: [TopLevel Unresolved]+topLevelsToCassius :: [TopLevel 'Unresolved] -> Q Exp topLevelsToCassius a = do r <- newName "_render"@@ -454,7 +472,7 @@ blocksToCassius :: Name -> Scope- -> [Block Unresolved]+ -> [Block 'Unresolved] -> Q Exp blocksToCassius r scope a = do appE [|foldr ($) []|] $ listE $ map (blockToCss r scope) a@@ -491,9 +509,9 @@ renderBlock :: Bool -- ^ have whitespace? -> Builder -- ^ indentation- -> Block Resolved+ -> Block 'Resolved -> Builder-renderBlock haveWhiteSpace indent (Block sel attrs () ())+renderBlock haveWhiteSpace indent (BlockResolved sel attrs) | null attrs = mempty | otherwise = startSelect <> sel@@ -501,7 +519,7 @@ <> mconcat (intersperse endDecl $ map renderAttr attrs) <> endBlock where- renderAttr (Attr k v) = startDecl <> k <> colon <> v+ renderAttr (AttrResolved k v) = startDecl <> k <> colon <> v colon | haveWhiteSpace = fromString ": "@@ -527,13 +545,14 @@ | haveWhiteSpace = fromString ";\n" | otherwise = singleton ';' -deriving instance Lift (Attr Unresolved)-instance Lift (Attr Resolved) where- lift (Attr k v) = [|Attr $(liftBuilder k) $(liftBuilder v) :: Attr Resolved |]+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+ liftTyped = unsafeCodeCoerce . lift #elif MIN_VERSION_template_haskell(2,16,0)- liftTyped = unsafeTExpCoerce . lift+ liftTyped = unsafeTExpCoerce . lift #endif #if MIN_VERSION_template_haskell(2,17,0)@@ -543,11 +562,12 @@ #endif liftBuilder b = [|fromText $ pack $(lift $ TL.unpack $ toLazyText b)|] -deriving instance Lift (Block Unresolved)-instance Lift (Block Resolved) where- lift (Block a b () ()) = [|Block $(liftBuilder a) 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+ liftTyped = unsafeCodeCoerce . lift #elif MIN_VERSION_template_haskell(2,16,0)- liftTyped = unsafeTExpCoerce . lift+ liftTyped = unsafeTExpCoerce . lift #endif
+ 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/Lucius.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -51,310 +52,38 @@ ) where import Text.Internal.CssCommon-import Text.Shakespeare.Base+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.Internal.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) -- | -- -- >>> 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- (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 $ 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- contents <- readFileRecompileQ 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 <|> supports <|> 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- 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 >>= \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@@ -362,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
shakespeare.cabal view
@@ -1,5 +1,5 @@ name: shakespeare-version: 2.0.29+version: 2.0.30 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -65,12 +65,16 @@ 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.MkSizeType Text.IndentToBrace
test/Text/CssSpec.hs view
@@ -8,17 +8,19 @@ 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) -import Data.Monoid (mappend) spec :: Spec spec = do + describe "Unordered parsers" $ do it "cassius" caseCassius it "cassiusFile" caseCassiusFile it "cassius single comment" caseCassiusSingleComment @@ -47,13 +49,12 @@ -} - it "comments" $ do + 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 @@ -451,6 +452,23 @@ ^{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| @@ -497,6 +515,114 @@ } |] + 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; @@ -562,6 +688,703 @@ ^{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 @@ -630,6 +1453,30 @@ , "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" @@ -643,6 +1490,19 @@ , "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| @@ -651,6 +1511,14 @@ */ |] "" +caseCassiusSingleCommentOrd :: Assertion +caseCassiusSingleCommentOrd = + flip celper [Ordered.cassius| + /* + this is a comment + */ + |] "" + caseCassiusLeadingComment :: Assertion caseCassiusLeadingComment = flip celper [cassius| @@ -663,6 +1531,18 @@ 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" @@ -674,4 +1554,13 @@ 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}"