Hello community, here is the log from the commit of package ghc-shakespeare for openSUSE:Factory checked in at 2017-06-04 01:55:17 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-shakespeare (Old) and /work/SRC/openSUSE:Factory/.ghc-shakespeare.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-shakespeare" Sun Jun 4 01:55:17 2017 rev:11 rq:494187 version:2.0.13 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-shakespeare/ghc-shakespeare.changes 2017-03-18 20:50:01.498345821 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-shakespeare.new/ghc-shakespeare.changes 2017-06-04 01:55:20.678212647 +0200 @@ -1,0 +2,5 @@ +Mon Apr 24 12:26:48 UTC 2017 - [email protected] + +- Update to version 2.0.13 with cabal2obs. + +------------------------------------------------------------------- Old: ---- shakespeare-2.0.12.1.tar.gz New: ---- shakespeare-2.0.13.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-shakespeare.spec ++++++ --- /var/tmp/diff_new_pack.yTtVUe/_old 2017-06-04 01:55:21.222135801 +0200 +++ /var/tmp/diff_new_pack.yTtVUe/_new 2017-06-04 01:55:21.226135236 +0200 @@ -19,7 +19,7 @@ %global pkg_name shakespeare %bcond_with tests Name: ghc-%{pkg_name} -Version: 2.0.12.1 +Version: 2.0.13 Release: 0 Summary: A toolkit for making compile-time interpolated templates License: MIT ++++++ shakespeare-2.0.12.1.tar.gz -> shakespeare-2.0.13.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/shakespeare-2.0.12.1/ChangeLog.md new/shakespeare-2.0.13/ChangeLog.md --- old/shakespeare-2.0.12.1/ChangeLog.md 2016-12-28 10:13:50.000000000 +0100 +++ new/shakespeare-2.0.13/ChangeLog.md 2017-04-19 16:59:58.000000000 +0200 @@ -1,3 +1,7 @@ +### 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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/shakespeare-2.0.12.1/Text/Cassius.hs new/shakespeare-2.0.13/Text/Cassius.hs --- old/shakespeare-2.0.12.1/Text/Cassius.hs 2016-12-28 10:13:50.000000000 +0100 +++ new/shakespeare-2.0.13/Text/Cassius.hs 2017-04-19 16:59:33.000000000 +0200 @@ -40,13 +40,13 @@ , cassiusUsedIdentifiers ) where -import Text.Css +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.CssCommon +import Text.Internal.CssCommon import Text.Lucius (lucius) import qualified Text.Lucius import Text.IndentToBrace (i2b) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/shakespeare-2.0.12.1/Text/Css.hs new/shakespeare-2.0.13/Text/Css.hs --- old/shakespeare-2.0.12.1/Text/Css.hs 2016-12-28 10:13:50.000000000 +0100 +++ new/shakespeare-2.0.13/Text/Css.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,537 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE EmptyDataDecls #-} -module Text.Css where - -import Data.List (intersperse, intercalate) -import Data.Text.Lazy.Builder (Builder, singleton, toLazyText, fromLazyText, fromString) -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB -import Data.Monoid (Monoid, mconcat, mappend, mempty) -import Data.Text (Text) -import qualified Data.Text as T -import Language.Haskell.TH.Syntax -import System.IO.Unsafe (unsafePerformIO) -import Text.ParserCombinators.Parsec (Parser, parse) -import Text.Shakespeare.Base hiding (Scope) -import Language.Haskell.TH -import Control.Applicative ((<$>), (<*>)) -import Control.Arrow ((***), second) -import Text.IndentToBrace (i2b) -import Data.Functor.Identity (runIdentity) -import Text.Shakespeare (VarType (..)) - -#if MIN_VERSION_base(4,5,0) -import Data.Monoid ((<>)) -#else -(<>) :: Monoid m => m -> m -> m -(<>) = mappend -{-# INLINE (<>) #-} -#endif - -type CssUrl url = (url -> [(T.Text, T.Text)] -> T.Text) -> Css - -type DList a = [a] -> [a] - --- FIXME great use case for data kinds -data Resolved -data Unresolved - -type family Selector a -type instance Selector Resolved = Builder -type instance Selector Unresolved = [Contents] - -type family ChildBlocks a -type instance ChildBlocks Resolved = () -type instance ChildBlocks Unresolved = [(HasLeadingSpace, Block Unresolved)] - -type HasLeadingSpace = Bool - -type family Str a -type instance Str Resolved = Builder -type instance Str Unresolved = Contents - -type family Mixins a -type instance Mixins Resolved = () -type instance Mixins Unresolved = [Deref] - -data Block a = Block - { blockSelector :: !(Selector a) - , blockAttrs :: ![Attr a] - , blockBlocks :: !(ChildBlocks a) - , blockMixins :: !(Mixins a) - } - -data Mixin = Mixin - { mixinAttrs :: ![Attr Resolved] - , mixinBlocks :: ![Block Resolved] - } -instance Monoid Mixin where - mempty = Mixin mempty mempty - mappend (Mixin a x) (Mixin b y) = Mixin (a ++ b) (x ++ y) - -data TopLevel a where - TopBlock :: !(Block a) -> TopLevel a - TopAtBlock :: !String -- name e.g., media - -> !(Str a) -- selector - -> ![Block a] - -> TopLevel a - TopAtDecl :: !String -> !(Str a) -> TopLevel a - TopVar :: !String -> !String -> TopLevel Unresolved - -data Attr a = Attr - { attrKey :: !(Str a) - , attrVal :: !(Str a) - } - -data Css = CssWhitespace ![TopLevel Resolved] - | CssNoWhitespace ![TopLevel Resolved] - -data Content = ContentRaw String - | ContentVar Deref - | ContentUrl Deref - | ContentUrlParam Deref - | ContentMixin Deref - deriving (Show, Eq) - -type Contents = [Content] - -data CDData url = CDPlain Builder - | CDUrl url - | CDUrlParam (url, [(Text, Text)]) - | CDMixin Mixin - -pack :: String -> Text -pack = T.pack -#if !MIN_VERSION_text(0, 11, 2) -{-# NOINLINE pack #-} -#endif - -fromText :: Text -> Builder -fromText = TLB.fromText -{-# NOINLINE fromText #-} - -class ToCss a where - toCss :: a -> Builder - -instance ToCss [Char] where toCss = fromLazyText . TL.pack -instance ToCss Text where toCss = fromText -instance ToCss TL.Text where toCss = fromLazyText - --- | Determine which identifiers are used by the given template, useful for --- creating systems like yesod devel. -cssUsedIdentifiers :: Bool -- ^ perform the indent-to-brace conversion - -> Parser [TopLevel Unresolved] - -> String - -> [(Deref, VarType)] -cssUsedIdentifiers toi2b parseBlocks s' = - concat $ runIdentity $ mapM (getVars scope0) contents - where - s = if toi2b then i2b s' else s' - a = either (error . show) id $ parse parseBlocks s s - (scope0, contents) = go a - - go :: [TopLevel Unresolved] - -> (Scope, [Content]) - go [] = ([], []) - go (TopAtDecl dec cs:rest) = - (scope, rest'') - where - (scope, rest') = go rest - rest'' = - ContentRaw ('@' : dec ++ " ") - : cs - ++ ContentRaw ";" - : rest' - go (TopAtBlock _ _ blocks:rest) = - (scope1 ++ scope2, rest1 ++ rest2) - where - (scope1, rest1) = go (map TopBlock blocks) - (scope2, rest2) = go rest - go (TopBlock (Block x y z mixins):rest) = - (scope1 ++ scope2, rest0 ++ rest1 ++ rest2 ++ restm) - where - rest0 = intercalate [ContentRaw ","] x ++ concatMap go' y - (scope1, rest1) = go (map (TopBlock . snd) z) - (scope2, rest2) = go rest - restm = map ContentMixin mixins - go (TopVar k v:rest) = - ((k, v):scope, rest') - where - (scope, rest') = go rest - go' (Attr k v) = k ++ v - -cssFileDebug :: Bool -- ^ perform the indent-to-brace conversion - -> Q Exp - -> Parser [TopLevel Unresolved] - -> FilePath - -> Q Exp -cssFileDebug toi2b parseBlocks' parseBlocks fp = do - s <- fmap TL.unpack $ qRunIO $ readUtf8File fp -#ifdef GHC_7_4 - qAddDependentFile fp -#endif - let vs = cssUsedIdentifiers toi2b parseBlocks s - c <- mapM vtToExp vs - cr <- [|cssRuntime toi2b|] - parseBlocks'' <- parseBlocks' - return $ cr `AppE` parseBlocks'' `AppE` (LitE $ StringL fp) `AppE` ListE c - -combineSelectors :: HasLeadingSpace - -> [Contents] - -> [Contents] - -> [Contents] -combineSelectors hsl a b = do - a' <- a - b' <- b - return $ a' ++ addSpace b' - where - addSpace - | hsl = (ContentRaw " " :) - | otherwise = id - -blockRuntime :: [(Deref, CDData url)] - -> (url -> [(Text, Text)] -> Text) - -> Block Unresolved - -> Either String (DList (Block Resolved)) --- FIXME share code with blockToCss -blockRuntime cd render' (Block x attrs z mixinsDerefs) = do - mixins <- mapM getMixin mixinsDerefs - x' <- mapM go' $ intercalate [ContentRaw ","] x - attrs' <- mapM resolveAttr attrs - z' <- mapM (subGo x) z -- FIXME use difflists again - Right $ \rest -> Block - { blockSelector = mconcat x' - , blockAttrs = concat $ attrs' : map mixinAttrs mixins - , blockBlocks = () - , blockMixins = () - } : foldr ($) rest z' - {- - (:) (Css' (mconcat $ map go' $ intercalate [ContentRaw "," ] x) (map go'' y)) - . foldr (.) id (map (subGo x) z) - -} - where - go' = contentToBuilderRT cd render' - - getMixin d = - case lookup d cd of - Nothing -> Left $ "Mixin not found: " ++ show d - Just (CDMixin m) -> Right m - Just _ -> Left $ "For " ++ show d ++ ", expected Mixin" - - resolveAttr :: Attr Unresolved -> Either String (Attr Resolved) - resolveAttr (Attr k v) = Attr <$> (mconcat <$> mapM go' k) <*> (mconcat <$> mapM go' v) - - subGo :: [Contents] -- ^ parent selectors - -> (HasLeadingSpace, Block Unresolved) - -> Either String (DList (Block Resolved)) - subGo x' (hls, Block a b c d) = - blockRuntime cd render' (Block a' b c d) - where - a' = combineSelectors hls x' a - -contentToBuilderRT :: [(Deref, CDData url)] - -> (url -> [(Text, Text)] -> Text) - -> Content - -> Either String Builder -contentToBuilderRT _ _ (ContentRaw s) = Right $ fromText $ pack s -contentToBuilderRT cd _ (ContentVar d) = - case lookup d cd of - Just (CDPlain s) -> Right s - _ -> Left $ show d ++ ": expected CDPlain" -contentToBuilderRT cd render' (ContentUrl d) = - case lookup d cd of - Just (CDUrl u) -> Right $ fromText $ render' u [] - _ -> Left $ show d ++ ": expected CDUrl" -contentToBuilderRT cd render' (ContentUrlParam d) = - case lookup d cd of - Just (CDUrlParam (u, p)) -> - Right $ fromText $ render' u p - _ -> Left $ show d ++ ": expected CDUrlParam" -contentToBuilderRT _ _ ContentMixin{} = Left "contentToBuilderRT ContentMixin" - -cssRuntime :: Bool -- ^ i2b? - -> Parser [TopLevel Unresolved] - -> FilePath - -> [(Deref, CDData url)] - -> (url -> [(Text, Text)] -> Text) - -> Css -cssRuntime toi2b parseBlocks fp cd render' = unsafePerformIO $ do - s' <- fmap TL.unpack $ qRunIO $ readUtf8File fp - let s = if toi2b then i2b s' else s' - let a = either (error . show) id $ parse parseBlocks s s - return $ CssWhitespace $ goTop [] a - where - goTop :: [(String, String)] -- ^ scope - -> [TopLevel Unresolved] - -> [TopLevel Resolved] - goTop _ [] = [] - goTop scope (TopAtDecl dec cs':rest) = - TopAtDecl dec cs : goTop scope rest - where - cs = either error mconcat $ mapM (contentToBuilderRT cd render') cs' - goTop scope (TopBlock b:rest) = - map TopBlock (either error ($[]) $ blockRuntime (addScope scope) render' b) ++ - goTop scope rest - goTop scope (TopAtBlock name s' b:rest) = - TopAtBlock name s (foldr (either error id . blockRuntime (addScope scope) render') [] b) : - goTop scope rest - where - s = either error mconcat $ mapM (contentToBuilderRT cd render') s' - goTop scope (TopVar k v:rest) = goTop ((k, v):scope) rest - - addScope scope = map (DerefIdent . Ident *** CDPlain . fromString) scope ++ cd - -vtToExp :: (Deref, VarType) -> Q Exp -vtToExp (d, vt) = do - d' <- lift d - c' <- c vt - return $ TupE [d', c' `AppE` derefToExp [] d] - where - c :: VarType -> Q Exp - c VTPlain = [|CDPlain . toCss|] - c VTUrl = [|CDUrl|] - c VTUrlParam = [|CDUrlParam|] - c VTMixin = [|CDMixin|] - -getVars :: Monad m => [(String, String)] -> Content -> m [(Deref, VarType)] -getVars _ ContentRaw{} = return [] -getVars scope (ContentVar d) = - case lookupD d scope of - Just _ -> return [] - Nothing -> return [(d, VTPlain)] -getVars scope (ContentUrl d) = - case lookupD d scope of - Nothing -> return [(d, VTUrl)] - Just s -> fail $ "Expected URL for " ++ s -getVars scope (ContentUrlParam d) = - case lookupD d scope of - Nothing -> return [(d, VTUrlParam)] - Just s -> fail $ "Expected URLParam for " ++ s -getVars scope (ContentMixin d) = - case lookupD d scope of - Nothing -> return [(d, VTMixin)] - Just s -> fail $ "Expected Mixin for " ++ s - -lookupD :: Deref -> [(String, b)] -> Maybe String -lookupD (DerefIdent (Ident s)) scope = - case lookup s scope of - Nothing -> Nothing - Just _ -> Just s -lookupD _ _ = Nothing - -compressTopLevel :: TopLevel Unresolved - -> TopLevel Unresolved -compressTopLevel (TopBlock b) = TopBlock $ compressBlock b -compressTopLevel (TopAtBlock name s b) = TopAtBlock name s $ map compressBlock b -compressTopLevel x@TopAtDecl{} = x -compressTopLevel x@TopVar{} = x - -compressBlock :: Block Unresolved - -> Block Unresolved -compressBlock (Block x y blocks mixins) = - Block (map cc x) (map go y) (map (second compressBlock) blocks) mixins - where - go (Attr k v) = Attr (cc k) (cc v) - cc [] = [] - cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c - cc (a:b) = a : cc b - -blockToMixin :: Name - -> Scope - -> Block Unresolved - -> Q Exp -blockToMixin r scope (Block _sel props subblocks mixins) = - [|Mixin - { mixinAttrs = concat - $ $(listE $ map go props) - : map mixinAttrs $mixinsE - -- FIXME too many complications to implement sublocks for now... - , mixinBlocks = [] -- foldr (.) id $(listE $ map subGo subblocks) [] - }|] - {- - . foldr (.) id $(listE $ map subGo subblocks) - . (concatMap mixinBlocks $mixinsE ++) - |] - -} - where - mixinsE = return $ ListE $ map (derefToExp []) mixins - go (Attr x y) = conE 'Attr - `appE` (contentsToBuilder r scope x) - `appE` (contentsToBuilder r scope y) - subGo (Block sel' b c d) = blockToCss r scope $ Block sel' b c d - -blockToCss :: Name - -> Scope - -> Block Unresolved - -> Q Exp -blockToCss r scope (Block sel props subblocks mixins) = - [|((Block - { blockSelector = $(selectorToBuilder r scope sel) - , blockAttrs = concat - $ $(listE $ map go props) - : map mixinAttrs $mixinsE - , blockBlocks = () - , blockMixins = () - } :: Block Resolved):) - . foldr (.) id $(listE $ map subGo subblocks) - . (concatMap mixinBlocks $mixinsE ++) - |] - where - mixinsE = return $ ListE $ map (derefToExp []) mixins - go (Attr x y) = conE 'Attr - `appE` (contentsToBuilder r scope x) - `appE` (contentsToBuilder r scope y) - subGo (hls, Block sel' b c d) = - blockToCss r scope $ Block sel'' b c d - where - sel'' = combineSelectors hls sel sel' - -selectorToBuilder :: Name -> Scope -> [Contents] -> Q Exp -selectorToBuilder r scope sels = - contentsToBuilder r scope $ intercalate [ContentRaw ","] sels - -contentsToBuilder :: Name -> Scope -> [Content] -> Q Exp -contentsToBuilder r scope contents = - appE [|mconcat|] $ listE $ map (contentToBuilder r scope) contents - -contentToBuilder :: Name -> Scope -> Content -> Q Exp -contentToBuilder _ _ (ContentRaw x) = - [|fromText . pack|] `appE` litE (StringL x) -contentToBuilder _ scope (ContentVar d) = - case d of - DerefIdent (Ident s) - | Just val <- lookup s scope -> [|fromText . pack|] `appE` litE (StringL val) - _ -> [|toCss|] `appE` return (derefToExp [] d) -contentToBuilder r _ (ContentUrl u) = - [|fromText|] `appE` - (varE r `appE` return (derefToExp [] u) `appE` listE []) -contentToBuilder r _ (ContentUrlParam u) = - [|fromText|] `appE` - ([|uncurry|] `appE` varE r `appE` return (derefToExp [] u)) -contentToBuilder _ _ ContentMixin{} = error "contentToBuilder on ContentMixin" - -type Scope = [(String, String)] - -topLevelsToCassius :: [TopLevel Unresolved] - -> Q Exp -topLevelsToCassius a = do - r <- newName "_render" - lamE [varP r] $ appE [|CssNoWhitespace . foldr ($) []|] $ fmap ListE $ go r [] a - where - go _ _ [] = return [] - go r scope (TopBlock b:rest) = do - e <- [|(++) $ map TopBlock ($(blockToCss r scope b) [])|] - es <- go r scope rest - return $ e : es - go r scope (TopAtBlock name s b:rest) = do - let s' = contentsToBuilder r scope s - e <- [|(:) $ TopAtBlock $(lift name) $(s') $(blocksToCassius r scope b)|] - es <- go r scope rest - return $ e : es - go r scope (TopAtDecl dec cs:rest) = do - e <- [|(:) $ TopAtDecl $(lift dec) $(contentsToBuilder r scope cs)|] - es <- go r scope rest - return $ e : es - go r scope (TopVar k v:rest) = go r ((k, v) : scope) rest - -blocksToCassius :: Name - -> Scope - -> [Block Unresolved] - -> Q Exp -blocksToCassius r scope a = do - appE [|foldr ($) []|] $ listE $ map (blockToCss r scope) a - -renderCss :: Css -> TL.Text -renderCss css = - toLazyText $ mconcat $ map go tops - where - (haveWhiteSpace, tops) = - case css of - CssWhitespace x -> (True, x) - CssNoWhitespace x -> (False, x) - go (TopBlock x) = renderBlock haveWhiteSpace mempty x - go (TopAtBlock name s x) = - fromText (pack $ concat ["@", name, " "]) `mappend` - s `mappend` - startBlock `mappend` - foldr mappend endBlock (map (renderBlock haveWhiteSpace (fromString " ")) x) - go (TopAtDecl dec cs) = fromText (pack $ concat ["@", dec, " "]) `mappend` - cs `mappend` - endDecl - - startBlock - | haveWhiteSpace = fromString " {\n" - | otherwise = singleton '{' - - endBlock - | haveWhiteSpace = fromString "}\n" - | otherwise = singleton '}' - - endDecl - | haveWhiteSpace = fromString ";\n" - | otherwise = singleton ';' - -renderBlock :: Bool -- ^ have whitespace? - -> Builder -- ^ indentation - -> Block Resolved - -> Builder -renderBlock haveWhiteSpace indent (Block sel attrs () ()) - | null attrs = mempty - | otherwise = startSelect - <> sel - <> startBlock - <> mconcat (intersperse endDecl $ map renderAttr attrs) - <> endBlock - where - renderAttr (Attr k v) = startDecl <> k <> colon <> v - - colon - | haveWhiteSpace = fromString ": " - | otherwise = singleton ':' - - startSelect - | haveWhiteSpace = indent - | otherwise = mempty - - startBlock - | haveWhiteSpace = fromString " {\n" - | otherwise = singleton '{' - - endBlock - | haveWhiteSpace = fromString ";\n" `mappend` indent `mappend` fromString "}\n" - | otherwise = singleton '}' - - startDecl - | haveWhiteSpace = indent `mappend` fromString " " - | otherwise = mempty - - endDecl - | haveWhiteSpace = fromString ";\n" - | otherwise = singleton ';' - -instance Lift Mixin where - lift (Mixin a b) = [|Mixin a b|] -instance Lift (Attr Unresolved) where - lift (Attr k v) = [|Attr k v :: Attr Unresolved |] -instance Lift (Attr Resolved) where - lift (Attr k v) = [|Attr $(liftBuilder k) $(liftBuilder v) :: Attr Resolved |] - -liftBuilder :: Builder -> Q Exp -liftBuilder b = [|fromText $ pack $(lift $ TL.unpack $ toLazyText b)|] - -instance Lift Content where - lift (ContentRaw s) = [|ContentRaw s|] - lift (ContentVar d) = [|ContentVar d|] - lift (ContentUrl d) = [|ContentUrl d|] - lift (ContentUrlParam d) = [|ContentUrlParam d|] - lift (ContentMixin m) = [|ContentMixin m|] -instance Lift (Block Unresolved) where - lift (Block a b c d) = [|Block a b c d|] -instance Lift (Block Resolved) where - lift (Block a b () ()) = [|Block $(liftBuilder a) b () ()|] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/shakespeare-2.0.12.1/Text/CssCommon.hs new/shakespeare-2.0.13/Text/CssCommon.hs --- old/shakespeare-2.0.12.1/Text/CssCommon.hs 2016-12-28 10:13:50.000000000 +0100 +++ new/shakespeare-2.0.13/Text/CssCommon.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,160 +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 qualified Data.Text.Lazy as TL - -renderCssUrl :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> CssUrl url -> TL.Text -renderCssUrl r s = renderCss $ s r - -data Color = Color Word8 Word8 Word8 - deriving Show -instance ToCss Color where - toCss (Color r g b) = - let (r1, r2) = toHex r - (g1, g2) = toHex g - (b1, b2) = toHex b - in fromText $ TS.pack $ '#' : - if r1 == r2 && g1 == g2 && b1 == b2 - then [r1, g1, b1] - else [r1, r2, g1, g2, b1, b2] - where - toHex :: Word8 -> (Char, Char) - toHex x = (toChar $ shiftR x 4, toChar $ x .&. 15) - toChar :: Word8 -> Char - toChar c - | c < 10 = mkChar c 0 '0' - | otherwise = mkChar c 10 'A' - mkChar :: Word8 -> Word8 -> Char -> Char - mkChar a b' c = - toEnum $ fromIntegral $ a - b' + fromIntegral (fromEnum c) - -colorRed :: Color -colorRed = Color 255 0 0 - -colorBlack :: Color -colorBlack = Color 0 0 0 - --- CSS size wrappers - --- | Create a CSS size, e.g. $(mkSize "100px"). -mkSize :: String -> ExpQ -mkSize s = appE nameE valueE - where [(value, unit)] = reads s :: [(Double, String)] - absoluteSizeE = varE $ mkName "absoluteSize" - nameE = case unit of - "cm" -> appE absoluteSizeE (conE $ mkName "Centimeter") - "em" -> conE $ mkName "EmSize" - "ex" -> conE $ mkName "ExSize" - "in" -> appE absoluteSizeE (conE $ mkName "Inch") - "mm" -> appE absoluteSizeE (conE $ mkName "Millimeter") - "pc" -> appE absoluteSizeE (conE $ mkName "Pica") - "pt" -> appE absoluteSizeE (conE $ mkName "Point") - "px" -> conE $ mkName "PixelSize" - "%" -> varE $ mkName "percentageSize" - _ -> error $ "In mkSize, invalid unit: " ++ unit - valueE = litE $ rationalL (toRational value) - --- | Absolute size units. -data AbsoluteUnit = Centimeter - | Inch - | Millimeter - | Pica - | Point - deriving (Eq, Show) - --- | Not intended for direct use, see 'mkSize'. -data AbsoluteSize = AbsoluteSize - { absoluteSizeUnit :: AbsoluteUnit -- ^ Units used for text formatting. - , absoluteSizeValue :: Rational -- ^ Normalized value in centimeters. - } - --- | Absolute size unit convertion rate to centimeters. -absoluteUnitRate :: AbsoluteUnit -> Rational -absoluteUnitRate Centimeter = 1 -absoluteUnitRate Inch = 2.54 -absoluteUnitRate Millimeter = 0.1 -absoluteUnitRate Pica = 12 * absoluteUnitRate Point -absoluteUnitRate Point = 1 / 72 * absoluteUnitRate Inch - --- | Constructs 'AbsoluteSize'. Not intended for direct use, see 'mkSize'. -absoluteSize :: AbsoluteUnit -> Rational -> AbsoluteSize -absoluteSize unit value = AbsoluteSize unit (value * absoluteUnitRate unit) - -instance Show AbsoluteSize where - show (AbsoluteSize unit value') = printf "%f" value ++ suffix - where value = fromRational (value' / absoluteUnitRate unit) :: Double - suffix = case unit of - Centimeter -> "cm" - Inch -> "in" - Millimeter -> "mm" - Pica -> "pc" - Point -> "pt" - -instance Eq AbsoluteSize where - (AbsoluteSize _ v1) == (AbsoluteSize _ v2) = v1 == v2 - -instance Ord AbsoluteSize where - compare (AbsoluteSize _ v1) (AbsoluteSize _ v2) = compare v1 v2 - -instance Num AbsoluteSize where - (AbsoluteSize u1 v1) + (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 + v2) - (AbsoluteSize u1 v1) * (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 * v2) - (AbsoluteSize u1 v1) - (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 - v2) - abs (AbsoluteSize u v) = AbsoluteSize u (abs v) - signum (AbsoluteSize u v) = AbsoluteSize u (abs v) - fromInteger x = AbsoluteSize Centimeter (fromInteger x) - -instance Fractional AbsoluteSize where - (AbsoluteSize u1 v1) / (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 / v2) - fromRational x = AbsoluteSize Centimeter (fromRational x) - -instance ToCss AbsoluteSize where - toCss = fromText . TS.pack . show - --- | Not intended for direct use, see 'mkSize'. -data PercentageSize = PercentageSize - { percentageSizeValue :: Rational -- ^ Normalized value, 1 == 100%. - } - deriving (Eq, Ord) - --- | Constructs 'PercentageSize'. Not intended for direct use, see 'mkSize'. -percentageSize :: Rational -> PercentageSize -percentageSize value = PercentageSize (value / 100) - -instance Show PercentageSize where - show (PercentageSize value') = printf "%f" value ++ "%" - where value = fromRational (value' * 100) :: Double - -instance Num PercentageSize where - (PercentageSize v1) + (PercentageSize v2) = PercentageSize (v1 + v2) - (PercentageSize v1) * (PercentageSize v2) = PercentageSize (v1 * v2) - (PercentageSize v1) - (PercentageSize v2) = PercentageSize (v1 - v2) - abs (PercentageSize v) = PercentageSize (abs v) - signum (PercentageSize v) = PercentageSize (abs v) - fromInteger x = PercentageSize (fromInteger x) - -instance Fractional PercentageSize where - (PercentageSize v1) / (PercentageSize v2) = PercentageSize (v1 / v2) - fromRational x = PercentageSize (fromRational x) - -instance ToCss PercentageSize where - toCss = fromText . TS.pack . show - --- | Converts number and unit suffix to CSS format. -showSize :: Rational -> String -> String -showSize value' unit = printf "%f" value ++ unit - where value = fromRational value' :: Double - -mkSizeType "EmSize" "em" -mkSizeType "ExSize" "ex" -mkSizeType "PixelSize" "px" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/shakespeare-2.0.12.1/Text/Internal/Css.hs new/shakespeare-2.0.13/Text/Internal/Css.hs --- old/shakespeare-2.0.12.1/Text/Internal/Css.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/shakespeare-2.0.13/Text/Internal/Css.hs 2017-04-19 16:59:33.000000000 +0200 @@ -0,0 +1,540 @@ +{-# OPTIONS_HADDOCK hide #-} +-- | This module is only being exposed to work around a GHC bug, its API is not stable + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE CPP #-} +{-# 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.Text (Text) +import qualified Data.Text as T +import Language.Haskell.TH.Syntax +import System.IO.Unsafe (unsafePerformIO) +import Text.ParserCombinators.Parsec (Parser, parse) +import Text.Shakespeare.Base hiding (Scope) +import Language.Haskell.TH +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow ((***), second) +import Text.IndentToBrace (i2b) +import Data.Functor.Identity (runIdentity) +import Text.Shakespeare (VarType (..)) + +#if MIN_VERSION_base(4,5,0) +import Data.Monoid ((<>)) +#else +(<>) :: Monoid m => m -> m -> m +(<>) = mappend +{-# INLINE (<>) #-} +#endif + +type CssUrl url = (url -> [(T.Text, T.Text)] -> T.Text) -> Css + +type DList a = [a] -> [a] + +-- FIXME great use case for data kinds +data Resolved +data Unresolved + +type family Selector a +type instance Selector Resolved = Builder +type instance Selector Unresolved = [Contents] + +type family ChildBlocks a +type instance ChildBlocks Resolved = () +type instance ChildBlocks Unresolved = [(HasLeadingSpace, Block Unresolved)] + +type HasLeadingSpace = Bool + +type family Str a +type instance Str Resolved = Builder +type instance Str Unresolved = Contents + +type family Mixins a +type instance Mixins Resolved = () +type instance Mixins Unresolved = [Deref] + +data Block a = Block + { blockSelector :: !(Selector a) + , blockAttrs :: ![Attr a] + , blockBlocks :: !(ChildBlocks a) + , blockMixins :: !(Mixins a) + } + +data Mixin = Mixin + { mixinAttrs :: ![Attr Resolved] + , mixinBlocks :: ![Block Resolved] + } +instance Monoid Mixin where + mempty = Mixin mempty mempty + mappend (Mixin a x) (Mixin b y) = Mixin (a ++ b) (x ++ y) + +data TopLevel a where + TopBlock :: !(Block a) -> TopLevel a + TopAtBlock :: !String -- name e.g., media + -> !(Str a) -- selector + -> ![Block a] + -> TopLevel a + TopAtDecl :: !String -> !(Str a) -> TopLevel a + TopVar :: !String -> !String -> TopLevel Unresolved + +data Attr a = Attr + { attrKey :: !(Str a) + , attrVal :: !(Str a) + } + +data Css = CssWhitespace ![TopLevel Resolved] + | CssNoWhitespace ![TopLevel Resolved] + +data Content = ContentRaw String + | ContentVar Deref + | ContentUrl Deref + | ContentUrlParam Deref + | ContentMixin Deref + deriving (Show, Eq) + +type Contents = [Content] + +data CDData url = CDPlain Builder + | CDUrl url + | CDUrlParam (url, [(Text, Text)]) + | CDMixin Mixin + +pack :: String -> Text +pack = T.pack +#if !MIN_VERSION_text(0, 11, 2) +{-# NOINLINE pack #-} +#endif + +fromText :: Text -> Builder +fromText = TLB.fromText +{-# NOINLINE fromText #-} + +class ToCss a where + toCss :: a -> Builder + +instance ToCss [Char] where toCss = fromLazyText . TL.pack +instance ToCss Text where toCss = fromText +instance ToCss TL.Text where toCss = fromLazyText + +-- | Determine which identifiers are used by the given template, useful for +-- creating systems like yesod devel. +cssUsedIdentifiers :: Bool -- ^ perform the indent-to-brace conversion + -> Parser [TopLevel Unresolved] + -> String + -> [(Deref, VarType)] +cssUsedIdentifiers toi2b parseBlocks s' = + concat $ runIdentity $ mapM (getVars scope0) contents + where + s = if toi2b then i2b s' else s' + a = either (error . show) id $ parse parseBlocks s s + (scope0, contents) = go a + + go :: [TopLevel Unresolved] + -> (Scope, [Content]) + go [] = ([], []) + go (TopAtDecl dec cs:rest) = + (scope, rest'') + where + (scope, rest') = go rest + rest'' = + ContentRaw ('@' : dec ++ " ") + : cs + ++ ContentRaw ";" + : rest' + go (TopAtBlock _ _ blocks:rest) = + (scope1 ++ scope2, rest1 ++ rest2) + where + (scope1, rest1) = go (map TopBlock blocks) + (scope2, rest2) = go rest + go (TopBlock (Block x y z mixins):rest) = + (scope1 ++ scope2, rest0 ++ rest1 ++ rest2 ++ restm) + where + rest0 = intercalate [ContentRaw ","] x ++ concatMap go' y + (scope1, rest1) = go (map (TopBlock . snd) z) + (scope2, rest2) = go rest + restm = map ContentMixin mixins + go (TopVar k v:rest) = + ((k, v):scope, rest') + where + (scope, rest') = go rest + go' (Attr k v) = k ++ v + +cssFileDebug :: Bool -- ^ perform the indent-to-brace conversion + -> Q Exp + -> Parser [TopLevel Unresolved] + -> FilePath + -> Q Exp +cssFileDebug toi2b parseBlocks' parseBlocks fp = do + s <- fmap TL.unpack $ qRunIO $ readUtf8File fp +#ifdef GHC_7_4 + qAddDependentFile fp +#endif + let vs = cssUsedIdentifiers toi2b parseBlocks s + c <- mapM vtToExp vs + cr <- [|cssRuntime toi2b|] + parseBlocks'' <- parseBlocks' + return $ cr `AppE` parseBlocks'' `AppE` (LitE $ StringL fp) `AppE` ListE c + +combineSelectors :: HasLeadingSpace + -> [Contents] + -> [Contents] + -> [Contents] +combineSelectors hsl a b = do + a' <- a + b' <- b + return $ a' ++ addSpace b' + where + addSpace + | hsl = (ContentRaw " " :) + | otherwise = id + +blockRuntime :: [(Deref, CDData url)] + -> (url -> [(Text, Text)] -> Text) + -> Block Unresolved + -> Either String (DList (Block Resolved)) +-- FIXME share code with blockToCss +blockRuntime cd render' (Block x attrs z mixinsDerefs) = do + mixins <- mapM getMixin mixinsDerefs + x' <- mapM go' $ intercalate [ContentRaw ","] x + attrs' <- mapM resolveAttr attrs + z' <- mapM (subGo x) z -- FIXME use difflists again + Right $ \rest -> Block + { blockSelector = mconcat x' + , blockAttrs = concat $ attrs' : map mixinAttrs mixins + , blockBlocks = () + , blockMixins = () + } : foldr ($) rest z' + {- + (:) (Css' (mconcat $ map go' $ intercalate [ContentRaw "," ] x) (map go'' y)) + . foldr (.) id (map (subGo x) z) + -} + where + go' = contentToBuilderRT cd render' + + getMixin d = + case lookup d cd of + Nothing -> Left $ "Mixin not found: " ++ show d + Just (CDMixin m) -> Right m + Just _ -> Left $ "For " ++ show d ++ ", expected Mixin" + + resolveAttr :: Attr Unresolved -> Either String (Attr Resolved) + resolveAttr (Attr k v) = Attr <$> (mconcat <$> mapM go' k) <*> (mconcat <$> mapM go' v) + + subGo :: [Contents] -- ^ parent selectors + -> (HasLeadingSpace, Block Unresolved) + -> Either String (DList (Block Resolved)) + subGo x' (hls, Block a b c d) = + blockRuntime cd render' (Block a' b c d) + where + a' = combineSelectors hls x' a + +contentToBuilderRT :: [(Deref, CDData url)] + -> (url -> [(Text, Text)] -> Text) + -> Content + -> Either String Builder +contentToBuilderRT _ _ (ContentRaw s) = Right $ fromText $ pack s +contentToBuilderRT cd _ (ContentVar d) = + case lookup d cd of + Just (CDPlain s) -> Right s + _ -> Left $ show d ++ ": expected CDPlain" +contentToBuilderRT cd render' (ContentUrl d) = + case lookup d cd of + Just (CDUrl u) -> Right $ fromText $ render' u [] + _ -> Left $ show d ++ ": expected CDUrl" +contentToBuilderRT cd render' (ContentUrlParam d) = + case lookup d cd of + Just (CDUrlParam (u, p)) -> + Right $ fromText $ render' u p + _ -> Left $ show d ++ ": expected CDUrlParam" +contentToBuilderRT _ _ ContentMixin{} = Left "contentToBuilderRT ContentMixin" + +cssRuntime :: Bool -- ^ i2b? + -> Parser [TopLevel Unresolved] + -> FilePath + -> [(Deref, CDData url)] + -> (url -> [(Text, Text)] -> Text) + -> Css +cssRuntime toi2b parseBlocks fp cd render' = unsafePerformIO $ do + s' <- fmap TL.unpack $ qRunIO $ readUtf8File fp + let s = if toi2b then i2b s' else s' + let a = either (error . show) id $ parse parseBlocks s s + return $ CssWhitespace $ goTop [] a + where + goTop :: [(String, String)] -- ^ scope + -> [TopLevel Unresolved] + -> [TopLevel Resolved] + goTop _ [] = [] + goTop scope (TopAtDecl dec cs':rest) = + TopAtDecl dec cs : goTop scope rest + where + cs = either error mconcat $ mapM (contentToBuilderRT cd render') cs' + goTop scope (TopBlock b:rest) = + map TopBlock (either error ($[]) $ blockRuntime (addScope scope) render' b) ++ + goTop scope rest + goTop scope (TopAtBlock name s' b:rest) = + TopAtBlock name s (foldr (either error id . blockRuntime (addScope scope) render') [] b) : + goTop scope rest + where + s = either error mconcat $ mapM (contentToBuilderRT cd render') s' + goTop scope (TopVar k v:rest) = goTop ((k, v):scope) rest + + addScope scope = map (DerefIdent . Ident *** CDPlain . fromString) scope ++ cd + +vtToExp :: (Deref, VarType) -> Q Exp +vtToExp (d, vt) = do + d' <- lift d + c' <- c vt + return $ TupE [d', c' `AppE` derefToExp [] d] + where + c :: VarType -> Q Exp + c VTPlain = [|CDPlain . toCss|] + c VTUrl = [|CDUrl|] + c VTUrlParam = [|CDUrlParam|] + c VTMixin = [|CDMixin|] + +getVars :: Monad m => [(String, String)] -> Content -> m [(Deref, VarType)] +getVars _ ContentRaw{} = return [] +getVars scope (ContentVar d) = + case lookupD d scope of + Just _ -> return [] + Nothing -> return [(d, VTPlain)] +getVars scope (ContentUrl d) = + case lookupD d scope of + Nothing -> return [(d, VTUrl)] + Just s -> fail $ "Expected URL for " ++ s +getVars scope (ContentUrlParam d) = + case lookupD d scope of + Nothing -> return [(d, VTUrlParam)] + Just s -> fail $ "Expected URLParam for " ++ s +getVars scope (ContentMixin d) = + case lookupD d scope of + Nothing -> return [(d, VTMixin)] + Just s -> fail $ "Expected Mixin for " ++ s + +lookupD :: Deref -> [(String, b)] -> Maybe String +lookupD (DerefIdent (Ident s)) scope = + case lookup s scope of + Nothing -> Nothing + Just _ -> Just s +lookupD _ _ = Nothing + +compressTopLevel :: TopLevel Unresolved + -> TopLevel Unresolved +compressTopLevel (TopBlock b) = TopBlock $ compressBlock b +compressTopLevel (TopAtBlock name s b) = TopAtBlock name s $ map compressBlock b +compressTopLevel x@TopAtDecl{} = x +compressTopLevel x@TopVar{} = x + +compressBlock :: Block Unresolved + -> Block Unresolved +compressBlock (Block x y blocks mixins) = + Block (map cc x) (map go y) (map (second compressBlock) blocks) mixins + where + go (Attr k v) = Attr (cc k) (cc v) + cc [] = [] + cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c + cc (a:b) = a : cc b + +blockToMixin :: Name + -> Scope + -> Block Unresolved + -> Q Exp +blockToMixin r scope (Block _sel props subblocks mixins) = + [|Mixin + { mixinAttrs = concat + $ $(listE $ map go props) + : map mixinAttrs $mixinsE + -- FIXME too many complications to implement sublocks for now... + , mixinBlocks = [] -- foldr (.) id $(listE $ map subGo subblocks) [] + }|] + {- + . foldr (.) id $(listE $ map subGo subblocks) + . (concatMap mixinBlocks $mixinsE ++) + |] + -} + where + mixinsE = return $ ListE $ map (derefToExp []) mixins + go (Attr x y) = conE 'Attr + `appE` (contentsToBuilder r scope x) + `appE` (contentsToBuilder r scope y) + subGo (Block sel' b c d) = blockToCss r scope $ Block sel' b c d + +blockToCss :: Name + -> Scope + -> Block Unresolved + -> Q Exp +blockToCss r scope (Block sel props subblocks mixins) = + [|((Block + { blockSelector = $(selectorToBuilder r scope sel) + , blockAttrs = concat + $ $(listE $ map go props) + : map mixinAttrs $mixinsE + , blockBlocks = () + , blockMixins = () + } :: Block Resolved):) + . foldr (.) id $(listE $ map subGo subblocks) + . (concatMap mixinBlocks $mixinsE ++) + |] + where + mixinsE = return $ ListE $ map (derefToExp []) mixins + go (Attr x y) = conE 'Attr + `appE` (contentsToBuilder r scope x) + `appE` (contentsToBuilder r scope y) + subGo (hls, Block sel' b c d) = + blockToCss r scope $ Block sel'' b c d + where + sel'' = combineSelectors hls sel sel' + +selectorToBuilder :: Name -> Scope -> [Contents] -> Q Exp +selectorToBuilder r scope sels = + contentsToBuilder r scope $ intercalate [ContentRaw ","] sels + +contentsToBuilder :: Name -> Scope -> [Content] -> Q Exp +contentsToBuilder r scope contents = + appE [|mconcat|] $ listE $ map (contentToBuilder r scope) contents + +contentToBuilder :: Name -> Scope -> Content -> Q Exp +contentToBuilder _ _ (ContentRaw x) = + [|fromText . pack|] `appE` litE (StringL x) +contentToBuilder _ scope (ContentVar d) = + case d of + DerefIdent (Ident s) + | Just val <- lookup s scope -> [|fromText . pack|] `appE` litE (StringL val) + _ -> [|toCss|] `appE` return (derefToExp [] d) +contentToBuilder r _ (ContentUrl u) = + [|fromText|] `appE` + (varE r `appE` return (derefToExp [] u) `appE` listE []) +contentToBuilder r _ (ContentUrlParam u) = + [|fromText|] `appE` + ([|uncurry|] `appE` varE r `appE` return (derefToExp [] u)) +contentToBuilder _ _ ContentMixin{} = error "contentToBuilder on ContentMixin" + +type Scope = [(String, String)] + +topLevelsToCassius :: [TopLevel Unresolved] + -> Q Exp +topLevelsToCassius a = do + r <- newName "_render" + lamE [varP r] $ appE [|CssNoWhitespace . foldr ($) []|] $ fmap ListE $ go r [] a + where + go _ _ [] = return [] + go r scope (TopBlock b:rest) = do + e <- [|(++) $ map TopBlock ($(blockToCss r scope b) [])|] + es <- go r scope rest + return $ e : es + go r scope (TopAtBlock name s b:rest) = do + let s' = contentsToBuilder r scope s + e <- [|(:) $ TopAtBlock $(lift name) $(s') $(blocksToCassius r scope b)|] + es <- go r scope rest + return $ e : es + go r scope (TopAtDecl dec cs:rest) = do + e <- [|(:) $ TopAtDecl $(lift dec) $(contentsToBuilder r scope cs)|] + es <- go r scope rest + return $ e : es + go r scope (TopVar k v:rest) = go r ((k, v) : scope) rest + +blocksToCassius :: Name + -> Scope + -> [Block Unresolved] + -> Q Exp +blocksToCassius r scope a = do + appE [|foldr ($) []|] $ listE $ map (blockToCss r scope) a + +renderCss :: Css -> TL.Text +renderCss css = + toLazyText $ mconcat $ map go tops + where + (haveWhiteSpace, tops) = + case css of + CssWhitespace x -> (True, x) + CssNoWhitespace x -> (False, x) + go (TopBlock x) = renderBlock haveWhiteSpace mempty x + go (TopAtBlock name s x) = + fromText (pack $ concat ["@", name, " "]) `mappend` + s `mappend` + startBlock `mappend` + foldr mappend endBlock (map (renderBlock haveWhiteSpace (fromString " ")) x) + go (TopAtDecl dec cs) = fromText (pack $ concat ["@", dec, " "]) `mappend` + cs `mappend` + endDecl + + startBlock + | haveWhiteSpace = fromString " {\n" + | otherwise = singleton '{' + + endBlock + | haveWhiteSpace = fromString "}\n" + | otherwise = singleton '}' + + endDecl + | haveWhiteSpace = fromString ";\n" + | otherwise = singleton ';' + +renderBlock :: Bool -- ^ have whitespace? + -> Builder -- ^ indentation + -> Block Resolved + -> Builder +renderBlock haveWhiteSpace indent (Block sel attrs () ()) + | null attrs = mempty + | otherwise = startSelect + <> sel + <> startBlock + <> mconcat (intersperse endDecl $ map renderAttr attrs) + <> endBlock + where + renderAttr (Attr k v) = startDecl <> k <> colon <> v + + colon + | haveWhiteSpace = fromString ": " + | otherwise = singleton ':' + + startSelect + | haveWhiteSpace = indent + | otherwise = mempty + + startBlock + | haveWhiteSpace = fromString " {\n" + | otherwise = singleton '{' + + endBlock + | haveWhiteSpace = fromString ";\n" `mappend` indent `mappend` fromString "}\n" + | otherwise = singleton '}' + + startDecl + | haveWhiteSpace = indent `mappend` fromString " " + | otherwise = mempty + + endDecl + | haveWhiteSpace = fromString ";\n" + | otherwise = singleton ';' + +instance Lift Mixin where + lift (Mixin a b) = [|Mixin a b|] +instance Lift (Attr Unresolved) where + lift (Attr k v) = [|Attr k v :: Attr Unresolved |] +instance Lift (Attr Resolved) where + lift (Attr k v) = [|Attr $(liftBuilder k) $(liftBuilder v) :: Attr Resolved |] + +liftBuilder :: Builder -> Q Exp +liftBuilder b = [|fromText $ pack $(lift $ TL.unpack $ toLazyText b)|] + +instance Lift Content where + lift (ContentRaw s) = [|ContentRaw s|] + lift (ContentVar d) = [|ContentVar d|] + lift (ContentUrl d) = [|ContentUrl d|] + lift (ContentUrlParam d) = [|ContentUrlParam d|] + lift (ContentMixin m) = [|ContentMixin m|] +instance Lift (Block Unresolved) where + lift (Block a b c d) = [|Block a b c d|] +instance Lift (Block Resolved) where + lift (Block a b () ()) = [|Block $(liftBuilder a) b () ()|] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/shakespeare-2.0.12.1/Text/Internal/CssCommon.hs new/shakespeare-2.0.13/Text/Internal/CssCommon.hs --- old/shakespeare-2.0.12.1/Text/Internal/CssCommon.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/shakespeare-2.0.13/Text/Internal/CssCommon.hs 2017-04-19 16:59:33.000000000 +0200 @@ -0,0 +1,163 @@ +{-# 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 #-} +{-# LANGUAGE CPP #-} +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" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/shakespeare-2.0.12.1/Text/Lucius.hs new/shakespeare-2.0.13/Text/Lucius.hs --- old/shakespeare-2.0.12.1/Text/Lucius.hs 2016-12-28 10:13:50.000000000 +0100 +++ new/shakespeare-2.0.13/Text/Lucius.hs 2017-04-19 16:59:33.000000000 +0200 @@ -51,14 +51,14 @@ , luciusUsedIdentifiers ) where -import Text.CssCommon +import Text.Internal.CssCommon 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.Css +import Text.Internal.Css import Data.Char (isSpace, toLower, toUpper) import Numeric (readHex) import Control.Applicative ((<$>)) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/shakespeare-2.0.12.1/shakespeare.cabal new/shakespeare-2.0.13/shakespeare.cabal --- old/shakespeare-2.0.12.1/shakespeare.cabal 2016-12-28 10:13:50.000000000 +0100 +++ new/shakespeare-2.0.13/shakespeare.cabal 2017-04-19 17:00:02.000000000 +0200 @@ -1,5 +1,5 @@ name: shakespeare -version: 2.0.12.1 +version: 2.0.13 license: MIT license-file: LICENSE author: Michael Snoyman <[email protected]> @@ -66,11 +66,12 @@ Text.Shakespeare.Base Text.Shakespeare Text.TypeScript + Text.Internal.Css + Text.Internal.CssCommon other-modules: Text.Hamlet.Parse - Text.Css Text.MkSizeType Text.IndentToBrace - Text.CssCommon + ghc-options: -Wall if flag(test_export)
