260 lines
8.2 KiB
Diff
260 lines
8.2 KiB
Diff
From cb77113314702175f066cd801dee5c38d3e26576 Mon Sep 17 00:00:00 2001
|
|
From: Joey Hess <joey@kitenet.net>
|
|
Date: Thu, 28 Feb 2013 23:35:51 -0400
|
|
Subject: [PATCH] remove TH
|
|
|
|
---
|
|
Text/Cassius.hs | 23 ---------------
|
|
Text/Css.hs | 84 -----------------------------------------------------
|
|
Text/CssCommon.hs | 4 ---
|
|
Text/Lucius.hs | 30 +------------------
|
|
4 files changed, 1 insertion(+), 140 deletions(-)
|
|
|
|
diff --git a/Text/Cassius.hs b/Text/Cassius.hs
|
|
index ce05374..ae56b0a 100644
|
|
--- a/Text/Cassius.hs
|
|
+++ b/Text/Cassius.hs
|
|
@@ -13,10 +13,6 @@ module Text.Cassius
|
|
, renderCss
|
|
, renderCssUrl
|
|
-- * Parsing
|
|
- , cassius
|
|
- , cassiusFile
|
|
- , cassiusFileDebug
|
|
- , cassiusFileReload
|
|
-- * ToCss instances
|
|
-- ** Color
|
|
, Color (..)
|
|
@@ -27,11 +23,8 @@ module Text.Cassius
|
|
, AbsoluteUnit (..)
|
|
, AbsoluteSize (..)
|
|
, absoluteSize
|
|
- , EmSize (..)
|
|
- , ExSize (..)
|
|
, PercentageSize (..)
|
|
, percentageSize
|
|
- , PixelSize (..)
|
|
-- * Internal
|
|
, cassiusUsedIdentifiers
|
|
) where
|
|
@@ -42,25 +35,9 @@ import Language.Haskell.TH.Quote (QuasiQuoter (..))
|
|
import Language.Haskell.TH.Syntax
|
|
import qualified Data.Text.Lazy as TL
|
|
import Text.CssCommon
|
|
-import Text.Lucius (lucius)
|
|
import qualified Text.Lucius
|
|
import Text.IndentToBrace (i2b)
|
|
|
|
-cassius :: QuasiQuoter
|
|
-cassius = QuasiQuoter { quoteExp = quoteExp lucius . i2b }
|
|
-
|
|
-cassiusFile :: FilePath -> Q Exp
|
|
-cassiusFile fp = do
|
|
-#ifdef GHC_7_4
|
|
- qAddDependentFile fp
|
|
-#endif
|
|
- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
|
|
- quoteExp cassius contents
|
|
-
|
|
-cassiusFileDebug, cassiusFileReload :: FilePath -> Q Exp
|
|
-cassiusFileDebug = cssFileDebug True [|Text.Lucius.parseTopLevels|] Text.Lucius.parseTopLevels
|
|
-cassiusFileReload = cassiusFileDebug
|
|
-
|
|
-- | Determine which identifiers are used by the given template, useful for
|
|
-- creating systems like yesod devel.
|
|
cassiusUsedIdentifiers :: String -> [(Deref, VarType)]
|
|
diff --git a/Text/Css.hs b/Text/Css.hs
|
|
index 8e6fc09..401a166 100644
|
|
--- a/Text/Css.hs
|
|
+++ b/Text/Css.hs
|
|
@@ -108,19 +108,6 @@ cssUsedIdentifiers toi2b parseBlocks s' =
|
|
(scope, rest') = go rest
|
|
go' (k, v) = k ++ v
|
|
|
|
-cssFileDebug :: Bool -- ^ perform the indent-to-brace conversion
|
|
- -> Q Exp -> Parser [TopLevel] -> 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 :: Selector -> Selector -> Selector
|
|
combineSelectors a b = do
|
|
a' <- a
|
|
@@ -202,17 +189,6 @@ cssRuntime toi2b parseBlocks fp cd render' = unsafePerformIO $ do
|
|
|
|
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|]
|
|
-
|
|
getVars :: Monad m => [(String, String)] -> Content -> m [(Deref, VarType)]
|
|
getVars _ ContentRaw{} = return []
|
|
getVars scope (ContentVar d) =
|
|
@@ -268,68 +244,8 @@ compressBlock (Block x y blocks) =
|
|
cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c
|
|
cc (a:b) = a : cc b
|
|
|
|
-blockToCss :: Name -> Scope -> Block -> Q Exp
|
|
-blockToCss r scope (Block sel props subblocks) =
|
|
- [|(:) (Css' $(selectorToBuilder r scope sel) $(listE $ map go props))
|
|
- . foldr (.) id $(listE $ map subGo subblocks)
|
|
- |]
|
|
- where
|
|
- go (x, y) = tupE [contentsToBuilder r scope x, contentsToBuilder r scope y]
|
|
- subGo (Block sel' b c) =
|
|
- blockToCss r scope $ Block sel'' b c
|
|
- where
|
|
- sel'' = combineSelectors sel sel'
|
|
-
|
|
-selectorToBuilder :: Name -> Scope -> Selector -> 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))
|
|
-
|
|
type Scope = [(String, String)]
|
|
|
|
-topLevelsToCassius :: [TopLevel] -> 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 Css ($(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 <- [|(:) $ AtBlock $(lift name) $(s') $(blocksToCassius r scope b)|]
|
|
- es <- go r scope rest
|
|
- return $ e : es
|
|
- go r scope (TopAtDecl dec cs:rest) = do
|
|
- e <- [|(:) $ AtDecl $(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] -> 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-- FIXME use a foldr
|
|
diff --git a/Text/CssCommon.hs b/Text/CssCommon.hs
|
|
index 719e0a8..8c40e8c 100644
|
|
--- a/Text/CssCommon.hs
|
|
+++ b/Text/CssCommon.hs
|
|
@@ -1,4 +1,3 @@
|
|
-{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE CPP #-}
|
|
@@ -156,6 +155,3 @@ showSize :: Rational -> String -> String
|
|
showSize value' unit = printf "%f" value ++ unit
|
|
where value = fromRational value' :: Double
|
|
|
|
-mkSizeType "EmSize" "em"
|
|
-mkSizeType "ExSize" "ex"
|
|
-mkSizeType "PixelSize" "px"
|
|
diff --git a/Text/Lucius.hs b/Text/Lucius.hs
|
|
index b71614e..a902e1c 100644
|
|
--- a/Text/Lucius.hs
|
|
+++ b/Text/Lucius.hs
|
|
@@ -6,12 +6,8 @@
|
|
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
|
|
module Text.Lucius
|
|
( -- * Parsing
|
|
- lucius
|
|
- , luciusFile
|
|
- , luciusFileDebug
|
|
- , luciusFileReload
|
|
-- ** Runtime
|
|
- , luciusRT
|
|
+ luciusRT
|
|
, luciusRT'
|
|
, -- * Datatypes
|
|
Css
|
|
@@ -31,11 +27,8 @@ module Text.Lucius
|
|
, AbsoluteUnit (..)
|
|
, AbsoluteSize (..)
|
|
, absoluteSize
|
|
- , EmSize (..)
|
|
- , ExSize (..)
|
|
, PercentageSize (..)
|
|
, percentageSize
|
|
- , PixelSize (..)
|
|
-- * Internal
|
|
, parseTopLevels
|
|
, luciusUsedIdentifiers
|
|
@@ -57,18 +50,6 @@ import Data.Either (partitionEithers)
|
|
import Data.Monoid (mconcat)
|
|
import Data.List (isSuffixOf)
|
|
|
|
--- |
|
|
---
|
|
--- >>> 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 ()
|
|
|
|
@@ -179,15 +160,6 @@ parseComment = do
|
|
_ <- manyTill anyChar $ try $ string "*/"
|
|
return $ ContentRaw ""
|
|
|
|
-luciusFile :: FilePath -> Q Exp
|
|
-luciusFile fp = do
|
|
- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
|
|
- luciusFromString contents
|
|
-
|
|
-luciusFileDebug, luciusFileReload :: FilePath -> Q Exp
|
|
-luciusFileDebug = cssFileDebug False [|parseTopLevels|] parseTopLevels
|
|
-luciusFileReload = luciusFileDebug
|
|
-
|
|
parseTopLevels :: Parser [TopLevel]
|
|
parseTopLevels =
|
|
go id
|
|
--
|
|
1.7.10.4
|
|
|