From 8c9e29d3716bcbbfc3144cf1f8af0569212a5878 Mon Sep 17 00:00:00 2001
From: dummy <dummy@example.com>
Date: Tue, 17 Dec 2013 06:33:03 +0000
Subject: [PATCH] remove more TH
---
Text/Cassius.hs | 23 ---------
Text/Css.hs | 151 ------------------------------------------------------
Text/CssCommon.hs | 4 --
Text/Lucius.hs | 46 +----------------
4 files changed, 2 insertions(+), 222 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 fb06dd2..954e574 100644
--- a/Text/Css.hs
+++ b/Text/Css.hs
@@ -169,22 +169,6 @@ cssUsedIdentifiers toi2b parseBlocks s' =
(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]
@@ -290,18 +274,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|]
- c VTMixin = [|CDMixin|]
-
getVars :: Monad m => [(String, String)] -> Content -> m [(Deref, VarType)]
getVars _ ContentRaw{} = return []
getVars scope (ContentVar d) =
@@ -345,111 +317,8 @@ compressBlock (Block x y blocks mixins) =
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
@@ -518,23 +387,3 @@ renderBlock haveWhiteSpace indent (Block sel attrs () ())
| haveWhiteSpace = fromString ";\n"
| otherwise = singleton ';'
-instance Lift Mixin where
- lift (Mixin a b) = [|Mixin a b|]
-instance Lift (Attr Unresolved) where
- lift (Attr k v) = [|Attr k v :: Attr Unresolved |]
-instance Lift (Attr Resolved) where
- lift (Attr k v) = [|Attr $(liftBuilder k) $(liftBuilder v) :: Attr Resolved |]
-
-liftBuilder :: Builder -> Q Exp
-liftBuilder b = [|fromText $ pack $(lift $ TL.unpack $ toLazyText b)|]
-
-instance Lift Content where
- lift (ContentRaw s) = [|ContentRaw s|]
- lift (ContentVar d) = [|ContentVar d|]
- lift (ContentUrl d) = [|ContentUrl d|]
- lift (ContentUrlParam d) = [|ContentUrlParam d|]
- lift (ContentMixin m) = [|ContentMixin m|]
-instance Lift (Block Unresolved) where
- lift (Block a b c d) = [|Block a b c d|]
-instance Lift (Block Resolved) where
- lift (Block a b () ()) = [|Block $(liftBuilder a) b () ()|]
diff --git a/Text/CssCommon.hs b/Text/CssCommon.hs
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 c2c4352..8b2bb9c 100644
--- a/Text/Lucius.hs
+++ b/Text/Lucius.hs
@@ -8,13 +8,9 @@
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
module Text.Lucius
( -- * Parsing
- lucius
- , luciusFile
- , luciusFileDebug
- , luciusFileReload
-- ** Mixins
- , luciusMixin
- , Mixin
+ -- luciusMixin
+ Mixin
-- ** Runtime
, luciusRT
, luciusRT'
@@ -40,11 +36,8 @@ module Text.Lucius
, AbsoluteUnit (..)
, AbsoluteSize (..)
, absoluteSize
- , EmSize (..)
- , ExSize (..)
, PercentageSize (..)
, percentageSize
- , PixelSize (..)
-- * Internal
, parseTopLevels
, luciusUsedIdentifiers
@@ -66,18 +59,6 @@ import Data.Monoid (mconcat)
import Data.List (isSuffixOf)
import Control.Arrow (second)
--- |
---
--- >>> 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 ()
@@ -217,17 +198,6 @@ parseComment = do
_ <- manyTill anyChar $ try $ string "*/"
return $ ContentRaw ""
-luciusFile :: FilePath -> Q Exp
-luciusFile fp = do
-#ifdef GHC_7_4
- qAddDependentFile fp
-#endif
- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
- luciusFromString contents
-
-luciusFileDebug, luciusFileReload :: FilePath -> Q Exp
-luciusFileDebug = cssFileDebug False [|parseTopLevels|] parseTopLevels
-luciusFileReload = luciusFileDebug
parseTopLevels :: Parser [TopLevel Unresolved]
parseTopLevels =
@@ -376,15 +346,3 @@ luciusRTMinified tl scope = either Left (Right . renderCss . CssNoWhitespace) $
-- creating systems like yesod devel.
luciusUsedIdentifiers :: String -> [(Deref, VarType)]
luciusUsedIdentifiers = cssUsedIdentifiers False parseTopLevels
-
-luciusMixin :: QuasiQuoter
-luciusMixin = QuasiQuoter { quoteExp = luciusMixinFromString }
-
-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', "}"]
--
1.8.5.1