module Text.Lucius
(
lucius
, luciusFile
, luciusFileDebug
, luciusRT
, luciusRT'
, module Text.Cassius
) where
import Text.Cassius hiding (cassius, cassiusFile, cassiusFileDebug)
import Text.Shakespeare.Base
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Language.Haskell.TH.Syntax
import Data.Text (Text, pack, unpack)
import qualified Data.Text.Lazy as TL
import Text.ParserCombinators.Parsec hiding (Line)
import Text.Css
import Data.Char (isSpace)
import Control.Applicative ((<$>))
import Data.Either (partitionEithers)
import Data.Text.Lazy.Builder (fromText)
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
((oneOf " \t\n\r" >> return ()) <|> (parseComment >> return ()))
>> return ()
parseBlock :: Parser Block
parseBlock = do
sel <- parseSelector
_ <- char '{'
whiteSpace
pairsBlocks <- parsePairsBlocks id
let (pairs, blocks) = partitionEithers pairsBlocks
whiteSpace
return $ Block sel pairs blocks
parseSelector :: Parser Selector
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
type PairBlock = Either Pair Block
parsePairsBlocks :: ([PairBlock] -> [PairBlock]) -> Parser [PairBlock]
parsePairsBlocks front = (char '}' >> return (front [])) <|> (do
isBlock <- lookAhead checkIfBlock
x <- if isBlock
then (do
b <- parseBlock
whiteSpace
return $ Right b)
else Left <$> parsePair
parsePairsBlocks $ front . (:) x)
where
checkIfBlock = do
skipMany $ noneOf "#@{};"
(parseHash >> checkIfBlock)
<|> (parseAt >> checkIfBlock)
<|> (char '{' >> return True)
<|> (oneOf ";}" >> return False)
<|> (anyChar >> checkIfBlock)
<|> fail "checkIfBlock"
parsePair :: Parser Pair
parsePair = do
key <- parseContents ":"
_ <- char ':'
whiteSpace
val <- parseContents ";}"
(char ';' >> return ()) <|> return ()
whiteSpace
return (key, val)
parseContents :: String -> Parser Contents
parseContents = many1 . parseContent
parseContent :: String -> Parser Content
parseContent restricted =
parseHash' <|> parseAt' <|> parseComment <|> 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
parseChar = (ContentRaw . return) `fmap` noneOf restricted
parseComment :: Parser Content
parseComment = do
_ <- try $ string "/*"
_ <- manyTill anyChar $ try $ string "*/"
return $ ContentRaw ""
luciusFile :: FilePath -> Q Exp
luciusFile fp = do
contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
luciusFromString contents
luciusFileDebug :: FilePath -> Q Exp
luciusFileDebug = cssFileDebug [|parseTopLevels|] parseTopLevels
parseTopLevels :: Parser [TopLevel]
parseTopLevels =
go id
where
go front = do
whiteSpace
((charset <|> media <|> var <|> fmap TopBlock parseBlock) >>= \x -> go (front . (:) x))
<|> (return $ map compressTopLevel $ front [])
charset = do
_ <- try $ string "@charset "
cs <- many1 $ noneOf ";"
_ <- char ';'
return $ TopCharset cs
media = do
_ <- try $ string "@media "
name <- many1 $ noneOf "{"
_ <- char '{'
b <- parseBlocks id
return $ MediaBlock name b
var = try $ do
_ <- char '@'
k <- many1 $ noneOf ":"
_ <- char ':'
v <- many1 $ noneOf ";"
_ <- char ';'
let trimS = reverse . dropWhile isSpace . reverse . dropWhile isSpace
return $ TopVar (trimS k) (trimS v)
parseBlocks front = do
whiteSpace
(char '}' >> return (map compressBlock $ front []))
<|> (parseBlock >>= \x -> parseBlocks (front . (:) x))
luciusRT' :: TL.Text -> Either String ([(Text, Text)] -> Either String Css)
luciusRT' 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, Text)] -> [TopLevel] -> Either String Css
go _ [] = Right []
go scope (TopCharset cs:rest) = do
rest' <- go scope rest
Right $ Charset cs : rest'
go scope (TopBlock b:rest) = do
b' <- goBlock scope b
rest' <- go scope rest
Right $ map Css b' ++ rest'
go scope (MediaBlock m bs:rest) = do
bs' <- mapM (goBlock scope) bs
rest' <- go scope rest
Right $ Media m (concat bs') : rest'
go scope (TopVar k v:rest) = go ((pack k, pack v):scope) rest
goBlock :: [(Text, Text)] -> Block -> Either String [Css']
goBlock scope =
either Left (Right . ($[])) . blockRuntime scope' (error "luciusRT has no URLs")
where
scope' = map goScope scope
goScope (k, v) = (DerefIdent (Ident $ unpack k), CDPlain $ fromText v)
luciusRT :: TL.Text -> [(Text, Text)] -> Either String TL.Text
luciusRT tl scope = either Left (Right . renderCss) $ either Left ($ scope) (luciusRT' tl)