diff --git a/Text/Cassius.hs b/Text/Cassius.hs --- a/Text/Cassius.hs +++ b/Text/Cassius.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Cassius ( -- * Datatypes Cassius @@ -40,16 +41,14 @@ import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax import Language.Haskell.TH -import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText, singleton) +import Data.Text.Lazy.Builder (fromText, fromLazyText) import Data.Maybe (catMaybes) -import Data.Monoid import Data.Word (Word8) import Data.Bits -import System.IO.Unsafe (unsafePerformIO) import qualified Data.Text as TS import qualified Data.Text.Lazy as TL import Text.Hamlet.Quasi (readUtf8File) -import Data.List (intersperse) +import Data.Char (isSpace) data Color = Color Word8 Word8 Word8 deriving Show @@ -58,7 +57,7 @@ let (r1, r2) = toHex r (g1, g2) = toHex g (b1, b2) = toHex b - in TL.pack $ '#' : + in fromText $ TS.pack $ '#' : if r1 == r2 && g1 == g2 && b1 == b2 then [r1, g1, b1] else [r1, r2, g1, g2, b1, b2] @@ -79,56 +78,14 @@ colorBlack :: Color colorBlack = Color 0 0 0 -renderCss :: Css -> TL.Text -renderCss = - toLazyText . mconcat . map go - where - go (Css' x y) = mconcat - [ x - , singleton '{' - , mconcat $ intersperse (singleton ';') $ map go' y - , singleton '}' - ] - go' (k, v) = mconcat - [ fromLazyText k - , singleton ':' - , v - ] - -renderCassius :: (url -> [(String, String)] -> String) -> Cassius url -> TL.Text +renderCassius :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Cassius url -> TL.Text renderCassius r s = renderCss $ s r -type Css = [Css'] - -type Cassius url = (url -> [(String, String)] -> String) -> Css - -class ToCss a where - toCss :: a -> TL.Text -instance ToCss [Char] where toCss = TL.pack -instance ToCss TS.Text where toCss = TL.fromChunks . return -instance ToCss TL.Text where toCss = id - -data Content = ContentRaw String - | ContentVar Deref - | ContentUrl Deref - | ContentUrlParam Deref - deriving (Show, Eq) -type Contents = [Content] -type ContentPair = (Contents, Contents) -type Block = (Contents, [ContentPair]) +type Cassius url = (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Css parseBlocks :: Parser [Block] parseBlocks = (map compressBlock . catMaybes) `fmap` many parseBlock -compressBlock :: Block -> Block -compressBlock (x, y) = - (cc x, map go y) - where - go (k, v) = (cc k, cc v) - cc [] = [] - cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c - cc (a:b) = a : cc b - parseEmptyLine :: Parser () parseEmptyLine = do try $ skipMany $ oneOf " \t" @@ -161,7 +118,7 @@ pairs <- fmap catMaybes $ many $ parsePair' indent case pairs of [] -> return Nothing - _ -> return $ Just (name, pairs) + _ -> return $ Just $ Block [name] pairs [] parsePair' indent = try (parseEmptyLine >> return Nothing) <|> try (Just `fmap` parsePair indent) @@ -172,14 +129,26 @@ key <- manyTill (parseContent False) $ char ':' spaces value <- manyTill (parseContent True) $ eol <|> eof - return (key, value) + return (trim key, value) -- FIXME consider trimming value as well +trim :: Contents -> Contents +trim = + reverse . go . reverse . go + where + go [] = [] + go (ContentRaw x:xs) = + case dropWhile isSpace x of + [] -> go xs + y -> ContentRaw y:xs + go x = x + + eol :: Parser () eol = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) parseContent :: Bool -> Parser Content parseContent allowColon = - parseHash' <|> parseAt' <|> parseComment <|> parseChar + parseHash' <|> parseAt' <|> parseComment' <|> parseChar where parseHash' = either ContentRaw ContentVar `fmap` parseHash parseAt' = @@ -189,115 +158,31 @@ go (d, True) = ContentUrlParam d parseChar = (ContentRaw . return) `fmap` noneOf restricted restricted = (if allowColon then id else (:) ':') "\r\n" - parseComment = do + parseComment' = do _ <- try $ string "/*" _ <- manyTill anyChar $ try $ string "*/" return $ ContentRaw "" -blocksToCassius :: [(Contents, [ContentPair])] -> Q Exp -blocksToCassius a = do - r <- newName "_render" - lamE [varP r] $ listE $ map (blockToCss r) a - cassius :: QuasiQuoter cassius = QuasiQuoter { quoteExp = cassiusFromString } cassiusFromString :: String -> Q Exp cassiusFromString s = - blocksToCassius + topLevelsToCassius $ map TopBlock $ either (error . show) id $ parse parseBlocks s s - -blockToCss :: Name -> (Contents, [ContentPair]) -> Q Exp -blockToCss r (sel, props) = do - css' <- [|Css'|] - let sel' = contentsToBuilder r sel - props' <- listE (map go props) - return css' `appE` sel' `appE` return props' - where - go (x, y) = tupE [tlt $ contentsToBuilder r x, contentsToBuilder r y] - tlt = appE [|toLazyText|] - -contentsToBuilder :: Name -> [Content] -> Q Exp -contentsToBuilder r contents = - appE [|mconcat|] $ listE $ map (contentToBuilder r) contents - -contentToBuilder :: Name -> Content -> Q Exp -contentToBuilder _ (ContentRaw x) = - [|fromText . TS.pack|] `appE` litE (StringL x) -contentToBuilder _ (ContentVar d) = - [|fromLazyText . toCss|] `appE` return (derefToExp [] d) -contentToBuilder r (ContentUrl u) = - [|fromText . TS.pack|] `appE` - (varE r `appE` return (derefToExp [] u) `appE` listE []) -contentToBuilder r (ContentUrlParam u) = - [|fromText . TS.pack|] `appE` - ([|uncurry|] `appE` varE r `appE` return (derefToExp [] u)) - cassiusFile :: FilePath -> Q Exp cassiusFile fp = do contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp cassiusFromString contents -data VarType = VTPlain | VTUrl | VTUrlParam - -getVars :: Content -> [(Deref, VarType)] -getVars ContentRaw{} = [] -getVars (ContentVar d) = [(d, VTPlain)] -getVars (ContentUrl d) = [(d, VTUrl)] -getVars (ContentUrlParam d) = [(d, VTUrlParam)] - -data CDData url = CDPlain TL.Text - | CDUrl url - | CDUrlParam (url, [(String, String)]) - -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|] - cassiusFileDebug :: FilePath -> Q Exp -cassiusFileDebug fp = do - s <- fmap TL.unpack $ qRunIO $ readUtf8File fp - let a = either (error . show) id $ parse parseBlocks s s - c <- mapM vtToExp $ concatMap getVars $ concatMap go a - cr <- [|cassiusRuntime|] - return $ cr `AppE` (LitE $ StringL fp) `AppE` ListE c - where - go (x, y) = x ++ concatMap go' y - go' (k, v) = k ++ v - -cassiusRuntime :: FilePath -> [(Deref, CDData url)] -> Cassius url -cassiusRuntime fp cd render' = unsafePerformIO $ do - s <- fmap TL.unpack $ qRunIO $ readUtf8File fp - let a = either (error . show) id $ parse parseBlocks s s - return $ map go a - where - go :: (Contents, [ContentPair]) -> Css' - go (x, y) = Css' (mconcat $ map go' x) $ map go'' y - go' :: Content -> Builder - go' (ContentRaw s) = fromText $ TS.pack s - go' (ContentVar d) = - case lookup d cd of - Just (CDPlain s) -> fromLazyText s - _ -> error $ show d ++ ": expected CDPlain" - go' (ContentUrl d) = - case lookup d cd of - Just (CDUrl u) -> fromText $ TS.pack $ render' u [] - _ -> error $ show d ++ ": expected CDUrl" - go' (ContentUrlParam d) = - case lookup d cd of - Just (CDUrlParam (u, p)) -> - fromText $ TS.pack $ render' u p - _ -> error $ show d ++ ": expected CDUrlParam" - go'' (k, v) = (toLazyText $ mconcat $ map go' k, mconcat $ map go' v) +cassiusFileDebug = cssFileDebug [|parseTopLevels|] parseTopLevels +parseTopLevels :: Parser [TopLevel] +parseTopLevels = do + x <- parseBlocks + return $ map TopBlock x -- CSS size wrappers @@ -316,6 +201,7 @@ "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. @@ -373,7 +259,7 @@ fromRational x = AbsoluteSize Centimeter (fromRational x) instance ToCss AbsoluteSize where - toCss = TL.pack . show + toCss = fromText . TS.pack . show -- | Not intended for direct use, see 'mkSize'. data PercentageSize = PercentageSize @@ -402,7 +288,7 @@ fromRational x = PercentageSize (fromRational x) instance ToCss PercentageSize where - toCss = TL.pack . show + toCss = fromText . TS.pack . show -- | Converts number and unit suffix to CSS format. showSize :: Rational -> String -> String diff --git a/Text/Coffee.hs b/Text/Coffee.hs new file mode 100644 --- /dev/null +++ b/Text/Coffee.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +module Text.Coffee + ( ToCoffee (..) + , Coffee + , coffee + , coffeeFile + , coffeeFileDebug + , renderCoffee + ) where + +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Language.Haskell.TH.Syntax +import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText) +import qualified Data.Text as TS +import qualified Data.Text.Lazy as TL +import System.Process (readProcess) +import Data.Monoid +import Text.Romeo + +renderCoffee :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Coffee url -> IO TL.Text +renderCoffee r s = do + out <- readProcess "coffee" ["-epb", TL.unpack $ toLazyText $ unCoffee $ s r] [] + return $ TL.pack out + where unCoffee (Coffeescript c) = c + +newtype Coffeescript = Coffeescript { unCoffeescript :: Builder } + deriving Monoid + +type Coffee url = (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Coffeescript + +-- the types that can be placed in a template +class ToCoffee c where + toCoffee :: c -> Builder +instance ToCoffee [Char] where toCoffee = fromLazyText . TL.pack +instance ToCoffee TS.Text where toCoffee = fromText +instance ToCoffee TL.Text where toCoffee = fromLazyText + +settings :: Q RomeoSettings +settings = do + toExp <- [|toCoffee|] + wrapExp <- [|Coffeescript|] + unWrapExp <- [|unCoffeescript|] + return $ defaultRomeoSettings { varChar = '%' + , toBuilder = toExp + , wrap = wrapExp + , unwrap = unWrapExp + } + +coffee :: QuasiQuoter +coffee = QuasiQuoter { quoteExp = \s -> do + rs <- settings + quoteExp (romeo rs) s + } + +coffeeFile :: FilePath -> Q Exp +coffeeFile fp = do + rs <- settings + romeoFile rs fp + +coffeeFileDebug :: FilePath -> Q Exp +coffeeFileDebug fp = do + rs <- settings + romeoFileDebug rs fp diff --git a/Text/Css.hs b/Text/Css.hs --- a/Text/Css.hs +++ b/Text/Css.hs @@ -1,11 +1,215 @@ -module Text.Css - ( Css' (..) - ) where +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +module Text.Css where -import Data.Text.Lazy.Builder (Builder) +import Data.List (intersperse, intercalate) +import Data.Text.Lazy.Builder (Builder, fromText, singleton, toLazyText, fromLazyText) import qualified Data.Text.Lazy as TL +import Data.Monoid (mconcat, mappend, mempty) +import Data.Text (Text, pack) +import Language.Haskell.TH.Syntax +import System.IO.Unsafe (unsafePerformIO) +import Text.Hamlet.Quasi (readUtf8File) +import Text.ParserCombinators.Parsec (Parser, parse) +import Text.Shakespeare +import Language.Haskell.TH +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 + data Css' = Css' { _cssSelectors :: Builder - , _cssAttributes :: [(TL.Text, Builder)] + , _cssAttributes :: [(Builder, Builder)] } +data CssTop = Media String [Css'] | Css Css' + +type Css = [CssTop] + +data Content = ContentRaw String + | ContentVar Deref + | ContentUrl Deref + | ContentUrlParam Deref + deriving (Show, Eq) + +type Contents = [Content] +type ContentPair = (Contents, Contents) + +data VarType = VTPlain | VTUrl | VTUrlParam + +data CDData url = CDPlain Builder + | CDUrl url + | CDUrlParam (url, [(Text, Text)]) + +cssFileDebug :: Q Exp -> Parser [TopLevel] -> FilePath -> Q Exp +cssFileDebug parseBlocks' parseBlocks fp = do + s <- fmap TL.unpack $ qRunIO $ readUtf8File fp + let a = either (error . show) id $ parse parseBlocks s s + c <- mapM vtToExp $ concatMap getVars $ concatMap go a + cr <- [|cssRuntime|] + parseBlocks'' <- parseBlocks' + return $ cr `AppE` parseBlocks'' `AppE` (LitE $ StringL fp) `AppE` ListE c + where + go :: TopLevel -> [Content] -- FIXME use blockToCss + go (MediaBlock _ blocks) = concatMap (go . TopBlock) blocks + go (TopBlock (Block x y z)) = + intercalate [ContentRaw ","] x ++ + concatMap go' y ++ + concatMap (go . TopBlock) z + go' (k, v) = k ++ v + +combineSelectors :: Selector -> Selector -> Selector +combineSelectors a b = do + a' <- a + b' <- b + return $ a' ++ ContentRaw " " : b' + +cssRuntime :: Parser [TopLevel] + -> FilePath + -> [(Deref, CDData url)] + -> (url -> [(Text, Text)] -> Text) + -> Css +cssRuntime parseBlocks fp cd render' = unsafePerformIO $ do + s <- fmap TL.unpack $ qRunIO $ readUtf8File fp + let a = either (error . show) id $ parse parseBlocks s s + return $ foldr ($) [] $ map goTop a + where + goTop :: TopLevel -> Css -> Css + goTop (TopBlock b) x = map Css (go b []) ++ x + goTop (MediaBlock s b) x = Media s (foldr go [] b) : x + go :: Block -> [Css'] -> [Css'] + -- FIXME share code with blockToCss + go (Block x y z) = + (:) (Css' (mconcat $ map go' $ intercalate [ContentRaw "," ] x) (map go'' y)) + . foldr (.) id (map (subGo x) z) + subGo :: Selector -> Block -> [Css'] -> [Css'] + subGo x (Block a b c) = + go (Block a' b c) + where + a' = combineSelectors x a + go' :: Content -> Builder + go' (ContentRaw s) = fromText $ pack s + go' (ContentVar d) = + case lookup d cd of + Just (CDPlain s) -> s + _ -> error $ show d ++ ": expected CDPlain" + go' (ContentUrl d) = + case lookup d cd of + Just (CDUrl u) -> fromText $ render' u [] + _ -> error $ show d ++ ": expected CDUrl" + go' (ContentUrlParam d) = + case lookup d cd of + Just (CDUrlParam (u, p)) -> + fromText $ render' u p + _ -> error $ show d ++ ": expected CDUrlParam" + go'' (k, v) = (mconcat $ map go' k, mconcat $ map go' v) + +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 :: Content -> [(Deref, VarType)] +getVars ContentRaw{} = [] +getVars (ContentVar d) = [(d, VTPlain)] +getVars (ContentUrl d) = [(d, VTUrl)] +getVars (ContentUrlParam d) = [(d, VTUrlParam)] + +data Block = Block Selector Pairs [Block] + +data TopLevel = TopBlock Block | MediaBlock String [Block] + +type Pairs = [Pair] + +type Pair = (Contents, Contents) + +type Selector = [Contents] + +compressTopLevel :: TopLevel -> TopLevel +compressTopLevel (TopBlock b) = TopBlock $ compressBlock b +compressTopLevel (MediaBlock s b) = MediaBlock s $ map compressBlock b + +compressBlock :: Block -> Block +compressBlock (Block x y blocks) = + Block (map cc x) (map go y) (map compressBlock blocks) + where + go (k, v) = (cc k, cc v) + cc [] = [] + cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c + cc (a:b) = a : cc b + +blockToCss :: Name -> Block -> Q Exp +blockToCss r (Block sel props subblocks) = + [|(:) (Css' $(selectorToBuilder r sel) $(listE $ map go props)) + . foldr (.) id $(listE $ map subGo subblocks) + |] + where + go (x, y) = tupE [contentsToBuilder r x, contentsToBuilder r y] + subGo (Block sel' b c) = + blockToCss r $ Block sel'' b c + where + sel'' = combineSelectors sel sel' + +selectorToBuilder :: Name -> Selector -> Q Exp +selectorToBuilder r sels = + contentsToBuilder r $ intercalate [ContentRaw ","] sels + +contentsToBuilder :: Name -> [Content] -> Q Exp +contentsToBuilder r contents = + appE [|mconcat|] $ listE $ map (contentToBuilder r) contents + +contentToBuilder :: Name -> Content -> Q Exp +contentToBuilder _ (ContentRaw x) = + [|fromText . pack|] `appE` litE (StringL x) +contentToBuilder _ (ContentVar d) = + [|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)) + +topLevelsToCassius :: [TopLevel] -> Q Exp +topLevelsToCassius a = do + r <- newName "_render" + lamE [varP r] $ appE [|foldr ($) []|] $ listE $ map (go r) a + where + go r (TopBlock b) = [|(++) $ map Css ($(blockToCss r b) [])|] + go r (MediaBlock s b) = [|(:) $ Media $(lift s) $(blocksToCassius r b)|] + +blocksToCassius :: Name -> [Block] -> Q Exp +blocksToCassius r a = do + appE [|foldr ($) []|] $ listE $ map (blockToCss r) a + +renderCss :: Css -> TL.Text +renderCss = + toLazyText . mconcat . map go -- FIXME use a foldr + where + go (Css x) = renderCss' x + go (Media s x) = + fromText (pack "@media ") `mappend` + fromText (pack s) `mappend` + singleton '{' `mappend` + foldr mappend (singleton '}') (map renderCss' x) + +renderCss' :: Css' -> Builder +renderCss' (Css' _x []) = mempty +renderCss' (Css' x y) = + x + `mappend` singleton '{' + `mappend` mconcat (intersperse (singleton ';') $ map go' y) + `mappend` singleton '}' + where + go' (k, v) = k `mappend` singleton ':' `mappend` v diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs --- a/Text/Hamlet.hs +++ b/Text/Hamlet.hs @@ -24,6 +24,7 @@ , string , unsafeByteString , cdata + , toHtml -- * Rendering -- ** ByteString , renderHamlet @@ -50,13 +51,14 @@ import qualified Data.Text.Encoding.Error as T import Text.Blaze.Renderer.Utf8 (renderHtml) import qualified Text.Blaze.Renderer.Text as BT -import Text.Blaze (preEscapedText, preEscapedString, string, unsafeByteString) +import Text.Blaze (preEscapedText, preEscapedString, string, unsafeByteString, toHtml) +import Data.Text (Text) -- | Converts a 'Hamlet' to lazy bytestring. -renderHamlet :: (url -> [(String, String)] -> String) -> Hamlet url -> L.ByteString +renderHamlet :: (url -> [(Text, Text)] -> Text) -> Hamlet url -> L.ByteString renderHamlet render h = renderHtml $ h render -renderHamletText :: (url -> [(String, String)] -> String) -> Hamlet url +renderHamletText :: (url -> [(Text, Text)] -> Text) -> Hamlet url -> T.Text renderHamletText render h = T.decodeUtf8With T.lenientDecode $ renderHtml $ h render diff --git a/Text/Hamlet/Debug.hs b/Text/Hamlet/Debug.hs --- a/Text/Hamlet/Debug.hs +++ b/Text/Hamlet/Debug.hs @@ -13,9 +13,10 @@ import Control.Monad (forM) import qualified Data.Text.Lazy as T import Text.Blaze (toHtml) +import Data.Text (Text) unsafeRenderTemplate :: FilePath -> HamletMap url - -> (url -> [(String, String)] -> String) -> Html + -> (url -> [(Text, Text)] -> Text) -> Html unsafeRenderTemplate fp hd render = unsafePerformIO $ do contents <- fmap T.unpack $ readUtf8File fp temp <- parseHamletRT defaultHamletSettings contents diff --git a/Text/Hamlet/Parse.hs b/Text/Hamlet/Parse.hs --- a/Text/Hamlet/Parse.hs +++ b/Text/Hamlet/Parse.hs @@ -18,7 +18,6 @@ import Control.Monad import Control.Arrow import Data.Data -import Data.List (intercalate) import Text.ParserCombinators.Parsec hiding (Line) import Data.Set (Set) import qualified Data.Set as Set @@ -47,6 +46,7 @@ | LineIf Deref | LineElseIf Deref | LineElse + | LineWith [(Deref, Ident)] | LineMaybe Deref Ident | LineNothing | LineTag @@ -74,10 +74,11 @@ backslash <|> controlIf <|> controlElseIf <|> - (try (string "$else") >> many (oneOf " \t") >> eol >> return LineElse) <|> + (try (string "$else") >> spaceTabs >> eol >> return LineElse) <|> controlMaybe <|> - (try (string "$nothing") >> many (oneOf " \t") >> eol >> return LineNothing) <|> + (try (string "$nothing") >> spaceTabs >> eol >> return LineNothing) <|> controlForall <|> + controlWith <|> angle <|> (eol' >> return (LineContent [])) <|> (do @@ -90,6 +91,7 @@ where eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) eol = eof <|> eol' + spaceTabs = many $ oneOf " \t" doctype = do try $ string "!!!" >> eol return $ LineContent [ContentRaw $ hamletDoctype set ++ "\n"] @@ -111,38 +113,42 @@ _ <- try $ string "$if" spaces x <- parseDeref - _ <- many $ oneOf " \t" + _ <- spaceTabs eol return $ LineIf x controlElseIf = do _ <- try $ string "$elseif" spaces x <- parseDeref - _ <- many $ oneOf " \t" + _ <- spaceTabs eol return $ LineElseIf x - controlMaybe = do - _ <- try $ string "$maybe" - spaces + binding = do y <- ident spaces _ <- string "<-" spaces x <- parseDeref - _ <- many $ oneOf " \t" + _ <- spaceTabs + return (x,y) + bindingSep = char ',' >> spaceTabs + controlMaybe = do + _ <- try $ string "$maybe" + spaces + (x,y) <- binding eol return $ LineMaybe x y controlForall = do _ <- try $ string "$forall" spaces - y <- ident - spaces - _ <- string "<-" - spaces - x <- parseDeref - _ <- many $ oneOf " \t" + (x,y) <- binding eol return $ LineForall x y + controlWith = do + _ <- try $ string "$with" + spaces + bindings <- (binding `sepBy` bindingSep) `endBy` eol + return $ LineWith $ concat bindings -- concat because endBy returns a [[(Deref,Ident)]] content cr = do x <- many $ content' cr case cr of @@ -230,6 +236,7 @@ in Nest l (nestLines deeper) : nestLines rest' data Doc = DocForall Deref Ident [Doc] + | DocWith [(Deref,Ident)] [Doc] | DocCond [(Deref, [Doc])] (Maybe [Doc]) | DocMaybe Deref Ident [Doc] (Maybe [Doc]) | DocContent Content @@ -241,6 +248,10 @@ inside' <- nestToDoc set inside rest' <- nestToDoc set rest Ok $ DocForall d i inside' : rest' +nestToDoc set (Nest (LineWith dis) inside:rest) = do + inside' <- nestToDoc set inside + rest' <- nestToDoc set rest + Ok $ DocWith dis inside' : rest' nestToDoc set (Nest (LineIf d) inside:rest) = do inside' <- nestToDoc set inside (ifs, el, rest') <- parseConds set ((:) (d, inside')) rest @@ -305,6 +316,8 @@ compressDoc [] = [] compressDoc (DocForall d i doc:rest) = DocForall d i (compressDoc doc) : compressDoc rest +compressDoc (DocWith dis doc:rest) = + DocWith dis (compressDoc doc) : compressDoc rest compressDoc (DocMaybe d i doc mnothing:rest) = DocMaybe d i (compressDoc doc) (fmap compressDoc mnothing) : compressDoc rest diff --git a/Text/Hamlet/Quasi.hs b/Text/Hamlet/Quasi.hs --- a/Text/Hamlet/Quasi.hs +++ b/Text/Hamlet/Quasi.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE EmptyDataDecls #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Hamlet.Quasi ( hamlet , xhamlet @@ -28,10 +29,12 @@ import Data.Char (isUpper, isDigit) import Data.Monoid (Monoid (..)) import Data.Maybe (fromMaybe) +import Data.Text (Text) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as TIO import qualified System.IO as SIO -import Text.Blaze (Html, preEscapedString, string, toHtml) +import Text.Blaze (Html, preEscapedString, toHtml) +import qualified Data.Foldable as F readUtf8File :: FilePath -> IO TL.Text readUtf8File fp = do @@ -52,10 +55,20 @@ let list' = derefToExp scope list name' <- newName name let scope' = (ident, VarE name') : scope - mh <- [|mapM_|] + mh <- [|F.mapM_|] inside' <- docsToExp scope' inside let lam = LamE [VarP name'] inside' return $ mh `AppE` lam `AppE` list' +docToExp scope (DocWith [] inside) = do + inside' <- docsToExp scope inside + return $ inside' +docToExp scope (DocWith ((deref,ident@(Ident name)):dis) inside) = do + let deref' = derefToExp scope deref + name' <- newName name + let scope' = (ident, VarE name') : scope + inside' <- docToExp scope' (DocWith dis inside) + let lam = LamE [VarP name'] inside' + return $ lam `AppE` deref' docToExp scope (DocMaybe val ident@(Ident name) inside mno) = do let val' = derefToExp scope val name' <- newName name @@ -193,17 +206,17 @@ maybeH (Just v) f _ = f v -- | An function generating an 'Html' given a URL-rendering function. -type Hamlet url = (url -> [(String, String)] -> String) -> Html +type Hamlet url = (url -> [(Text, Text)] -> Text) -> Html class Monad (HamletMonad a) => HamletValue a where data HamletMonad a :: * -> * type HamletUrl a toHamletValue :: HamletMonad a () -> a htmlToHamletMonad :: Html -> HamletMonad a () - urlToHamletMonad :: HamletUrl a -> [(String, String)] -> HamletMonad a () + urlToHamletMonad :: HamletUrl a -> [(Text, Text)] -> HamletMonad a () fromHamletValue :: a -> HamletMonad a () -type Render url = url -> [(String, String)] -> String +type Render url = url -> [(Text, Text)] -> Text instance HamletValue (Hamlet url) where newtype HamletMonad (Hamlet url) a = HMonad { runHMonad :: Render url -> (Html, a) } @@ -211,7 +224,7 @@ toHamletValue = fmap fst . runHMonad htmlToHamletMonad x = HMonad $ const (x, ()) urlToHamletMonad url pairs = HMonad $ \r -> - (string $ r url pairs, ()) + (toHtml $ r url pairs, ()) fromHamletValue f = HMonad $ \r -> (f r, ()) instance Monad (HamletMonad (Hamlet url)) where return x = HMonad $ const (mempty, x) diff --git a/Text/Hamlet/RT.hs b/Text/Hamlet/RT.hs --- a/Text/Hamlet/RT.hs +++ b/Text/Hamlet/RT.hs @@ -23,19 +23,21 @@ import Text.Hamlet.Parse import Text.Hamlet.Quasi (Html) import Data.List (intercalate) -import Text.Blaze (preEscapedString) +import Text.Blaze (preEscapedString, preEscapedText) +import Data.Text (Text) type HamletMap url = [([String], HamletData url)] data HamletData url = HDHtml Html | HDUrl url - | HDUrlParams url [(String, String)] + | HDUrlParams url [(Text, Text)] | HDTemplate HamletRT | HDBool Bool | HDMaybe (Maybe (HamletMap url)) | HDList [HamletMap url] +-- FIXME switch to Text? data SimpleDoc = SDRaw String | SDVar [String] | SDUrl Bool [String] @@ -91,7 +93,7 @@ renderHamletRT :: Failure HamletException m => HamletRT -> HamletMap url - -> (url -> [(String, String)] -> String) + -> (url -> [(Text, Text)] -> Text) -> m Html renderHamletRT = renderHamletRT' False @@ -99,7 +101,7 @@ => Bool -> HamletRT -> HamletMap url - -> (url -> [(String, String)] -> String) + -> (url -> [(Text, Text)] -> Text) -> m Html renderHamletRT' tempAsHtml (HamletRT docs) scope0 renderUrl = liftM mconcat $ mapM (go scope0) docs @@ -113,9 +115,9 @@ go scope (SDUrl p n) = do v <- lookup' n n scope case (p, v) of - (False, HDUrl u) -> return $ preEscapedString $ renderUrl u [] + (False, HDUrl u) -> return $ preEscapedText $ renderUrl u [] (True, HDUrlParams u q) -> - return $ preEscapedString $ renderUrl u q + return $ preEscapedText $ renderUrl u q (False, _) -> fa $ showName n ++ ": expected HDUrl" (True, _) -> fa $ showName n ++ ": expected HDUrlParams" go scope (SDTemplate n) = do diff --git a/Text/Julius.hs b/Text/Julius.hs --- a/Text/Julius.hs +++ b/Text/Julius.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Julius ( Julius , Javascript (..) @@ -12,171 +13,52 @@ , juliusFileDebug ) where -import Text.ParserCombinators.Parsec hiding (Line) import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText) import Data.Monoid -import System.IO.Unsafe (unsafePerformIO) import qualified Data.Text as TS import qualified Data.Text.Lazy as TL -import Text.Hamlet.Quasi (readUtf8File) -import Text.Shakespeare -import qualified Data.JSON.Types as J -import qualified Text.JSON.Enumerator as JE -import Data.Text.Lazy.Encoding (decodeUtf8) -import Blaze.ByteString.Builder (toLazyByteString) +import Text.Romeo renderJavascript :: Javascript -> TL.Text renderJavascript (Javascript b) = toLazyText b -renderJulius :: (url -> [(String, String)] -> String) -> Julius url -> TL.Text +renderJulius :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Julius url -> TL.Text renderJulius r s = renderJavascript $ s r -newtype Javascript = Javascript Builder +newtype Javascript = Javascript { unJavascript :: Builder } deriving Monoid -type Julius url = (url -> [(String, String)] -> String) -> Javascript +type Julius url = (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Javascript class ToJavascript a where toJavascript :: a -> Builder instance ToJavascript [Char] where toJavascript = fromLazyText . TL.pack instance ToJavascript TS.Text where toJavascript = fromText instance ToJavascript TL.Text where toJavascript = fromLazyText -instance ToJavascript J.Root where - toJavascript (J.RootObject o) = toJavascript $ J.ValueObject o - toJavascript (J.RootArray o) = toJavascript $ J.ValueArray o -instance ToJavascript J.Value where - toJavascript = fromLazyText . decodeUtf8 . toLazyByteString . JE.renderValue -data Content = ContentRaw String - | ContentVar Deref - | ContentUrl Deref - | ContentUrlParam Deref - | ContentMix Deref - deriving (Show, Eq) -type Contents = [Content] - -parseContents :: Parser Contents -parseContents = many1 parseContent - -parseContent :: Parser Content -parseContent = - parseHash' <|> parseAt' <|> parseCaret' <|> 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 - parseCaret' = either ContentRaw ContentMix `fmap` parseCaret - parseChar = (ContentRaw . return) `fmap` anyChar - -compressContents :: Contents -> Contents -compressContents [] = [] -compressContents (ContentRaw x:ContentRaw y:z) = - compressContents $ ContentRaw (x ++ y) : z -compressContents (x:y) = x : compressContents y - -contentsToJulius :: [Content] -> Q Exp -contentsToJulius a = do - r <- newName "_render" - c <- mapM (contentToJavascript r) a - d <- case c of - [] -> [|mempty|] - [x] -> return x - _ -> do - mc <- [|mconcat|] - return $ mc `AppE` ListE c - return $ LamE [VarP r] d +settings :: Q RomeoSettings +settings = do + toJExp <- [|toJavascript|] + wrapExp <- [|Javascript|] + unWrapExp <- [|unJavascript|] + return $ defaultRomeoSettings { toBuilder = toJExp + , wrap = wrapExp + , unwrap = unWrapExp + } julius :: QuasiQuoter -julius = QuasiQuoter { quoteExp = juliusFromString } - -juliusFromString :: String -> Q Exp -juliusFromString s = do - let a = either (error . show) id $ parse parseContents s s - contentsToJulius $ compressContents a - -contentToJavascript :: Name -> Content -> Q Exp -contentToJavascript _ (ContentRaw s') = do - ts <- [|Javascript . fromText . TS.pack|] - return $ ts `AppE` LitE (StringL s') -contentToJavascript _ (ContentVar d) = do - ts <- [|Javascript . toJavascript|] - return $ ts `AppE` derefToExp [] d -contentToJavascript r (ContentUrl d) = do - ts <- [|Javascript . fromText . TS.pack|] - return $ ts `AppE` (VarE r `AppE` derefToExp [] d `AppE` ListE []) -contentToJavascript r (ContentUrlParam d) = do - ts <- [|Javascript . fromText . TS.pack|] - up <- [|\r' (u, p) -> r' u p|] - return $ ts `AppE` (up `AppE` VarE r `AppE` derefToExp [] d) -contentToJavascript r (ContentMix d) = do - return $ derefToExp [] d `AppE` VarE r +julius = QuasiQuoter { quoteExp = \s -> do + rs <- settings + quoteExp (romeo rs) s + } juliusFile :: FilePath -> Q Exp juliusFile fp = do - contents <- qRunIO $ readUtf8File fp - juliusFromString $ TL.unpack contents - -data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin - -getVars :: Content -> [(Deref, VarType)] -getVars ContentRaw{} = [] -getVars (ContentVar d) = [(d, VTPlain)] -getVars (ContentUrl d) = [(d, VTUrl)] -getVars (ContentUrlParam d) = [(d, VTUrlParam)] -getVars (ContentMix d) = [(d, VTMixin)] - -data JDData url = JDPlain Builder - | JDUrl url - | JDUrlParam (url, [(String, String)]) - | JDMixin (Julius url) - -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 = [|JDPlain . toJavascript|] - c VTUrl = [|JDUrl|] - c VTUrlParam = [|JDUrlParam|] - c VTMixin = [|JDMixin|] + rs <- settings + romeoFile rs fp juliusFileDebug :: FilePath -> Q Exp juliusFileDebug fp = do - s <- qRunIO $ fmap TL.unpack $ readUtf8File fp - let a = either (error . show) id $ parse parseContents s s - b = concatMap getVars a - c <- mapM vtToExp b - cr <- [|juliusRuntime|] - return $ cr `AppE` (LitE $ StringL fp) `AppE` ListE c - -juliusRuntime :: FilePath -> [(Deref, JDData url)] -> Julius url -juliusRuntime fp cd render' = unsafePerformIO $ do - s <- fmap TL.unpack $ readUtf8File fp - let a = either (error . show) id $ parse parseContents s s - return $ mconcat $ map go a - where - go :: Content -> Javascript - go (ContentRaw s) = Javascript $ fromText $ TS.pack s - go (ContentVar d) = - case lookup d cd of - Just (JDPlain s) -> Javascript s - _ -> error $ show d ++ ": expected JDPlain" - go (ContentUrl d) = - case lookup d cd of - Just (JDUrl u) -> Javascript $ fromText $ TS.pack $ render' u [] - _ -> error $ show d ++ ": expected JDUrl" - go (ContentUrlParam d) = - case lookup d cd of - Just (JDUrlParam (u, p)) -> - Javascript $ fromText $ TS.pack $ render' u p - _ -> error $ show d ++ ": expected JDUrlParam" - go (ContentMix d) = - case lookup d cd of - Just (JDMixin m) -> m render' - _ -> error $ show d ++ ": expected JDMixin" + rs <- settings + romeoFileDebug rs fp diff --git a/Text/Lucius.hs b/Text/Lucius.hs --- a/Text/Lucius.hs +++ b/Text/Lucius.hs @@ -2,6 +2,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Lucius ( -- * Datatypes Lucius @@ -9,6 +11,8 @@ , renderLucius -- * Parsing , lucius + , luciusFile + , luciusFileDebug -- * Re-export cassius , module Text.Cassius ) where @@ -17,88 +21,36 @@ import Text.Shakespeare import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax -import Language.Haskell.TH -import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText, singleton) -import Data.Maybe (catMaybes) -import Data.Monoid -import Data.Word (Word8) -import Data.Bits -import System.IO.Unsafe (unsafePerformIO) import qualified Data.Text as TS import qualified Data.Text.Lazy as TL -import Text.Hamlet.Quasi (readUtf8File) -import Data.List (intersperse) import qualified Text.Cassius as C import Text.ParserCombinators.Parsec hiding (Line) import Text.Css -import Text.Shakespeare import Data.Char (isSpace) +import Text.Hamlet.Quasi (readUtf8File) +import Control.Applicative ((<$>)) +import Data.Either (partitionEithers) type Lucius a = C.Cassius a +renderLucius :: (url -> [(TS.Text, TS.Text)] -> TS.Text) + -> Lucius url + -> TL.Text renderLucius = C.renderCassius +-- | +-- +-- >>> renderLucius undefined [lucius|foo{bar:baz}|] +-- "foo{bar:baz}" lucius :: QuasiQuoter lucius = QuasiQuoter { quoteExp = luciusFromString } luciusFromString :: String -> Q Exp luciusFromString s = - blocksToLucius - $ either (error . show) id $ parse (parseBlocks id) s s - -type Block = (Selector, Pairs) - -type Pairs = [Pair] - -type Pair = (Contents, Contents) - -type Selector = Contents - -blocksToLucius :: [Block] -> Q Exp -blocksToLucius blocks = do - r <- newName "_render" - lamE [varP r] $ listE $ map (blockToCss r) blocks - -blockToCss :: Name -> Block -> Q Exp -blockToCss r (sel, pairs) = do - css' <- [|Css'|] - let sel' = contentsToBuilder r sel - props' <- listE (map go pairs) - return css' `appE` sel' `appE` return props' - where - go (x, y) = tupE [tlt $ contentsToBuilder r x, contentsToBuilder r y] - tlt = appE [|toLazyText|] - -data Content = ContentRaw String - | ContentVar Deref - | ContentUrl Deref - | ContentUrlParam Deref - deriving (Show, Eq) -type Contents = [Content] - -contentsToBuilder :: Name -> [Content] -> Q Exp -contentsToBuilder r contents = - appE [|mconcat|] $ listE $ map (contentToBuilder r) contents - -contentToBuilder :: Name -> Content -> Q Exp -contentToBuilder _ (ContentRaw x) = - [|fromText . TS.pack|] `appE` litE (StringL x) -contentToBuilder _ (ContentVar d) = - [|fromLazyText . toCss|] `appE` return (derefToExp [] d) -contentToBuilder r (ContentUrl u) = - [|fromText . TS.pack|] `appE` - (varE r `appE` return (derefToExp [] u) `appE` listE []) -contentToBuilder r (ContentUrlParam u) = - [|fromText . TS.pack|] `appE` - ([|uncurry|] `appE` varE r `appE` return (derefToExp [] u)) - -parseBlocks :: ([Block] -> [Block]) -> Parser [Block] -parseBlocks front = do - whiteSpace - (parseBlock >>= (\b -> parseBlocks (front . (:) b))) <|> (return $ map compressBlock $ front []) - -compressBlock = id -- FIXME + topLevelsToCassius + $ either (error . show) id $ parse parseTopLevels s s +whiteSpace :: Parser () whiteSpace = many (oneOf " \t\n\r" >> return ()) >> return () -- FIXME comments, don't use many parseBlock :: Parser Block @@ -106,12 +58,19 @@ sel <- parseSelector _ <- char '{' whiteSpace - pairs <- parsePairs id + pairsBlocks <- parsePairsBlocks id + let (pairs, blocks) = partitionEithers pairsBlocks whiteSpace - return (sel, pairs) + return $ Block sel pairs blocks parseSelector :: Parser Selector -parseSelector = fmap trim $ parseContents "{" +parseSelector = + go id + where + go front = do + c <- parseContents "{," + let front' = front . (:) (trim c) + (char ',' >> go front') <|> return (front' []) trim :: Contents -> Contents trim = @@ -125,10 +84,26 @@ trimS True = dropWhile isSpace trimS False = reverse . dropWhile isSpace . reverse -parsePairs :: ([Pair] -> [Pair]) -> Parser [Pair] -parsePairs front = (char '}' >> return (front [])) <|> (do - x <- parsePair - parsePairs $ front . (:) x) +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 @@ -158,3 +133,30 @@ _ <- 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 + ((media <|> fmap TopBlock parseBlock) >>= \x -> go (front . (:) x)) + <|> (return $ map compressTopLevel $ front []) + media = do + try $ string "@media " + name <- many1 $ noneOf "{" + _ <- char '{' + b <- parseBlocks id + return $ MediaBlock name b + parseBlocks front = do + whiteSpace + (char '}' >> return (map compressBlock $ front [])) + <|> (parseBlock >>= \x -> parseBlocks (front . (:) x)) diff --git a/Text/MkSizeType.hs b/Text/MkSizeType.hs --- a/Text/MkSizeType.hs +++ b/Text/MkSizeType.hs @@ -38,10 +38,12 @@ toCssInstanceDec :: Name -> Dec toCssInstanceDec name = InstanceD [] (instanceType "ToCss" name) [toCssDec] where toCssDec = FunD (mkName "toCss") [Clause [] showBody []] - showBody = NormalB $ AppE (AppE dot pack) show + showBody = NormalB $ (AppE dot from) `AppE` ((AppE dot pack) `AppE` show') + -- FIXME this whole section makes me a little nervous + from = VarE (mkName "fromLazyText") pack = VarE (mkName "TL.pack") dot = VarE (mkName ".") - show = VarE (mkName "show") + show' = VarE (mkName "show") instanceType :: String -> Name -> Type instanceType className name = AppT (ConT $ mkName className) (ConT name) diff --git a/Text/Romeo.hs b/Text/Romeo.hs new file mode 100644 --- /dev/null +++ b/Text/Romeo.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +-- | For lack of a better name... a parameterized version of Julius. +module Text.Romeo + ( RomeoSettings (..) + , defaultRomeoSettings + , romeo + , romeoFile + , romeoFileDebug + ) where + +import Text.ParserCombinators.Parsec hiding (Line) +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Syntax.Internals +import Data.Text.Lazy.Builder (Builder, fromText) +import Data.Monoid +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Text as TS +import qualified Data.Text.Lazy as TL +import Text.Hamlet.Quasi (readUtf8File) +import Text.Shakespeare + +-- move to Shakespeare? +readFileQ :: FilePath -> Q [Char] +readFileQ fp = do + qRunIO $ readFileUtf8 fp + +-- move to Shakespeare? +readFileUtf8 :: FilePath -> IO String +readFileUtf8 fp = fmap TL.unpack $ readUtf8File fp + +data RomeoSettings = RomeoSettings + { varChar :: Char + , urlChar :: Char + , intChar :: Char + , toBuilder :: Exp + , wrap :: Exp + , unwrap :: Exp + } +defaultRomeoSettings :: RomeoSettings +defaultRomeoSettings = RomeoSettings { + varChar = '#' + , urlChar = '@' + , intChar = '^' +} + + +instance Lift RomeoSettings where + lift (RomeoSettings x1 x2 x3 x4 x5 x6) = + [|RomeoSettings + $(lift x1) $(lift x2) $(lift x3) + $(liftExp x4) $(liftExp x5) $(liftExp x6)|] + where + liftExp (VarE n) = [|VarE $(liftName n)|] + liftExp (ConE n) = [|ConE $(liftName n)|] + liftExp _ = error "liftExp only supports VarE and ConE" + liftName (Name (OccName a) b) = [|Name (OccName $(lift a)) $(liftFlavour b)|] + liftFlavour NameS = [|NameS|] + liftFlavour (NameQ (ModName a)) = [|NameQ (ModName $(lift a))|] + liftFlavour (NameU _) = error "liftFlavour NameU" -- [|NameU $(lift $ fromIntegral a)|] + liftFlavour (NameL _) = error "liftFlavour NameL" -- [|NameU $(lift $ fromIntegral a)|] + liftFlavour (NameG ns (PkgName p) (ModName m)) = [|NameG $(liftNS ns) (PkgName $(lift p)) (ModName $(lift m))|] + liftNS VarName = [|VarName|] + liftNS DataName = [|DataName|] + +type Romeo url = (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Builder + +data Content = ContentRaw String + | ContentVar Deref + | ContentUrl Deref + | ContentUrlParam Deref + | ContentMix Deref + deriving (Show, Eq) +type Contents = [Content] + +contentFromString :: RomeoSettings -> (String -> [Content]) +contentFromString rs s = do + compressContents $ either (error . show) id $ parse (parseContents rs) s s + where + compressContents :: Contents -> Contents + compressContents [] = [] + compressContents (ContentRaw x:ContentRaw y:z) = + compressContents $ ContentRaw (x ++ y) : z + compressContents (x:y) = x : compressContents y + +parseContents :: RomeoSettings -> Parser Contents +parseContents = many1 . parseContent + where + parseContent :: RomeoSettings -> Parser Content + parseContent RomeoSettings {..} = + parseHash' <|> parseAt' <|> parseCaret' <|> parseChar + where + parseHash' = either ContentRaw ContentVar `fmap` parseVar varChar + parseAt' = + either ContentRaw go `fmap` parseUrl urlChar '?' + where + go (d, False) = ContentUrl d + go (d, True) = ContentUrlParam d + parseCaret' = either ContentRaw ContentMix `fmap` parseInt intChar + parseChar = ContentRaw `fmap` (many1 $ noneOf [varChar, urlChar, intChar]) + +contentsToRomeo :: RomeoSettings -> [Content] -> Q Exp +contentsToRomeo rs a = do + r <- newName "_render" + c <- mapM (contentToBuilder r) a + d <- case c of + [] -> [|mempty|] + [x] -> return x + _ -> do + mc <- [|mconcat|] + return $ mc `AppE` ListE c + return $ LamE [VarP r] d + where + contentToBuilder :: Name -> Content -> Q Exp + contentToBuilder _ (ContentRaw s') = do + ts <- [|fromText . TS.pack|] + return $ (wrap rs) `AppE` (ts `AppE` LitE (StringL s')) + contentToBuilder _ (ContentVar d) = do + return $ (wrap rs) `AppE` ((toBuilder rs) `AppE` derefToExp [] d) + contentToBuilder r (ContentUrl d) = do + ts <- [|fromText|] + return $ (wrap rs) `AppE` (ts `AppE` (VarE r `AppE` derefToExp [] d `AppE` ListE [])) + contentToBuilder r (ContentUrlParam d) = do + ts <- [|fromText|] + up <- [|\r' (u, p) -> r' u p|] + return $ (wrap rs) `AppE` (ts `AppE` (up `AppE` VarE r `AppE` derefToExp [] d)) + contentToBuilder r (ContentMix d) = do + return $ derefToExp [] d `AppE` VarE r + +romeo :: RomeoSettings -> QuasiQuoter +romeo r = QuasiQuoter { quoteExp = romeoFromString r } + +romeoFromString :: RomeoSettings -> String -> Q Exp +romeoFromString r s = do + contentsToRomeo r $ contentFromString r s + +romeoFile :: RomeoSettings -> FilePath -> Q Exp +romeoFile r fp = readFileQ fp >>= romeoFromString r + +data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin + +getVars :: Content -> [(Deref, VarType)] +getVars ContentRaw{} = [] +getVars (ContentVar d) = [(d, VTPlain)] +getVars (ContentUrl d) = [(d, VTUrl)] +getVars (ContentUrlParam d) = [(d, VTUrlParam)] +getVars (ContentMix d) = [(d, VTMixin)] + +data VarExp url = EPlain Builder + | EUrl url + | EUrlParam (url, [(TS.Text, TS.Text)]) + | EMixin (Romeo url) + +romeoFileDebug :: RomeoSettings -> FilePath -> Q Exp +romeoFileDebug rs fp = do + s <- readFileQ fp + let b = concatMap getVars $ contentFromString rs s + c <- mapM vtToExp b + rt <- [|romeoRuntime|] + wrap' <- [|\x -> $(return $ wrap rs) . x|] + r' <- lift rs + return $ wrap' `AppE` (rt `AppE` r' `AppE` (LitE $ StringL fp) `AppE` ListE c) + where + 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 = [|EPlain . $(return $ toBuilder rs)|] + c VTUrl = [|EUrl|] + c VTUrlParam = [|EUrlParam|] + c VTMixin = [|\x -> EMixin $ \r -> $(return $ unwrap rs) $ x r|] + + +romeoRuntime :: RomeoSettings -> FilePath -> [(Deref, VarExp url)] -> Romeo url +romeoRuntime rs fp cd render' = unsafePerformIO $ do + s <- readFileUtf8 fp + return $ mconcat $ map go $ contentFromString rs s + where + go :: Content -> Builder + go (ContentRaw s) = fromText $ TS.pack s + go (ContentVar d) = + case lookup d cd of + Just (EPlain s) -> s + _ -> error $ show d ++ ": expected EPlain" + go (ContentUrl d) = + case lookup d cd of + Just (EUrl u) -> fromText $ render' u [] + _ -> error $ show d ++ ": expected EUrl" + go (ContentUrlParam d) = + case lookup d cd of + Just (EUrlParam (u, p)) -> + fromText $ render' u p + _ -> error $ show d ++ ": expected EUrlParam" + go (ContentMix d) = + case lookup d cd of + Just (EMixin m) -> m render' + _ -> error $ show d ++ ": expected EMixin" diff --git a/Text/Shakespeare.hs b/Text/Shakespeare.hs --- a/Text/Shakespeare.hs +++ b/Text/Shakespeare.hs @@ -9,8 +9,11 @@ , Scope , parseDeref , parseHash + , parseVar , parseAt + , parseUrl , parseCaret + , parseInt , derefToExp , flattenDeref ) where @@ -20,7 +23,7 @@ import Data.Char (isUpper) import Text.ParserCombinators.Parsec import Data.List (intercalate) -import Data.Ratio (numerator, denominator, (%)) +import Data.Ratio (Ratio, numerator, denominator, (%)) import Data.Data (Data) import Data.Typeable (Typeable) @@ -58,7 +61,7 @@ lift (DerefRational r) = do n <- lift $ numerator r d <- lift $ denominator r - per <- [|(%)|] + per <- [|(%) :: Int -> Int -> Ratio Int|] dr <- [|DerefRational|] return $ dr `AppE` (InfixE (Just n) per (Just d)) lift (DerefString s) = [|DerefString|] `appE` lift s @@ -159,9 +162,12 @@ flattenDeref _ = Nothing parseHash :: Parser (Either String Deref) -parseHash = do - _ <- char '#' - (char '\\' >> return (Left "#")) <|> (do +parseHash = parseVar '#' + +parseVar :: Char -> Parser (Either String Deref) +parseVar c = do + _ <- char c + (char '\\' >> return (Left [c])) <|> (do _ <- char '{' deref <- parseDeref _ <- char '}' @@ -169,25 +175,31 @@ -- Check for hash just before newline _ <- lookAhead (oneOf "\r\n" >> return ()) <|> eof return $ Left "" - ) <|> return (Left "#") + ) <|> return (Left [c]) parseAt :: Parser (Either String (Deref, Bool)) -parseAt = do - _ <- char '@' - (char '\\' >> return (Left "@")) <|> (do - x <- (char '?' >> return True) <|> return False +parseAt = parseUrl '@' '?' + +parseUrl :: Char -> Char -> Parser (Either String (Deref, Bool)) +parseUrl c d = do + _ <- char c + (char '\\' >> return (Left [c])) <|> (do + x <- (char d >> return True) <|> return False (do _ <- char '{' deref <- parseDeref _ <- char '}' return $ Right (deref, x)) - <|> return (Left $ if x then "@?" else "@")) + <|> return (Left $ if x then [c, d] else [c])) parseCaret :: Parser (Either String Deref) -parseCaret = do - _ <- char '^' - (char '\\' >> return (Left "^")) <|> (do +parseCaret = parseInt '^' + +parseInt :: Char -> Parser (Either String Deref) +parseInt c = do + _ <- char c + (char '\\' >> return (Left [c])) <|> (do _ <- char '{' deref <- parseDeref _ <- char '}' - return $ Right deref) <|> return (Left "^") + return $ Right deref) <|> return (Left [c]) diff --git a/hamlet.cabal b/hamlet.cabal --- a/hamlet.cabal +++ b/hamlet.cabal @@ -1,5 +1,5 @@ name: hamlet -version: 0.7.3 +version: 0.8.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -23,7 +23,7 @@ > Not married category: Web, Yesod stability: Stable -cabal-version: >= 1.6 +cabal-version: >= 1.8 build-type: Simple homepage: http://docs.yesodweb.com/ @@ -32,6 +32,8 @@ default: False library + if flag(test) + Buildable: False build-depends: base >= 4 && < 5 , bytestring >= 0.9 && < 0.10 , template-haskell @@ -40,14 +42,15 @@ , failure >= 0.1 && < 0.2 , text >= 0.7 && < 0.12 , containers >= 0.2 && < 0.5 - , json-types >= 0.1 && < 0.2 - , json-enumerator >= 0.0 && < 0.1 - , blaze-builder >= 0.2 && < 0.3 + , blaze-builder >= 0.2 && < 0.4 + , process >= 1.0 && < 1.1 exposed-modules: Text.Hamlet Text.Hamlet.RT Text.Cassius Text.Lucius Text.Julius + Text.Coffee + Text.Romeo other-modules: Text.Hamlet.Parse Text.Hamlet.Quasi Text.Hamlet.Debug @@ -56,17 +59,6 @@ Text.Css ghc-options: -Wall -executable runtests - if flag(test) - Buildable: True - cpp-options: -DTEST - build-depends: QuickCheck >= 2 && < 3, - HUnit, - test-framework-hunit, - test-framework - else - Buildable: False - main-is: runtests.hs source-repository head type: git diff --git a/runtests.hs b/runtests.hs deleted file mode 100644 --- a/runtests.hs +++ /dev/null @@ -1,990 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -import Test.Framework (defaultMain, testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) - -import Prelude hiding (reverse) -import Text.Hamlet -import Text.Cassius -import Text.Lucius -import Text.Julius -import Data.List (intercalate) -import qualified Data.Text.Lazy as T -import qualified Data.List -import qualified Data.List as L -import qualified Data.JSON.Types as J -import qualified Data.Map as Map - -main :: IO () -main = defaultMain [testSuite] - -testSuite :: Test -testSuite = testGroup "Text.Hamlet" - [ testCase "empty" caseEmpty - , testCase "static" caseStatic - , testCase "tag" caseTag - , testCase "var" caseVar - , testCase "var chain " caseVarChain - , testCase "url" caseUrl - , testCase "url chain " caseUrlChain - , testCase "embed" caseEmbed - , testCase "embed chain " caseEmbedChain - , testCase "if" caseIf - , testCase "if chain " caseIfChain - , testCase "else" caseElse - , testCase "else chain " caseElseChain - , testCase "elseif" caseElseIf - , testCase "elseif chain " caseElseIfChain - , testCase "list" caseList - , testCase "list chain" caseListChain - , testCase "script not empty" caseScriptNotEmpty - , testCase "meta empty" caseMetaEmpty - , testCase "input empty" caseInputEmpty - , testCase "multiple classes" caseMultiClass - , testCase "attrib order" caseAttribOrder - , testCase "nothing" caseNothing - , testCase "nothing chain " caseNothingChain - , testCase "just" caseJust - , testCase "just chain " caseJustChain - , testCase "constructor" caseConstructor - , testCase "url + params" caseUrlParams - , testCase "escape" caseEscape - , testCase "empty statement list" caseEmptyStatementList - , testCase "attribute conditionals" caseAttribCond - , testCase "non-ascii" caseNonAscii - , testCase "maybe function" caseMaybeFunction - , testCase "trailing dollar sign" caseTrailingDollarSign - , testCase "non leading percent sign" caseNonLeadingPercent - , testCase "quoted attributes" caseQuotedAttribs - , testCase "spaced derefs" caseSpacedDerefs - , testCase "attrib vars" caseAttribVars - , testCase "strings and html" caseStringsAndHtml - , testCase "nesting" caseNesting - , testCase "trailing space" caseTrailingSpace - , testCase "currency symbols" caseCurrency - , testCase "external" caseExternal - , testCase "parens" caseParens - , testCase "hamlet literals" caseHamletLiterals - , testCase "hamlet' and xhamlet'" caseHamlet' - , testCase "hamletDebug" caseHamletDebug - , testCase "hamlet runtime" caseHamletRT - , testCase "hamletFileDebug- changing file" caseHamletFileDebugChange - , testCase "hamletFileDebug- features" caseHamletFileDebugFeatures - , testCase "cassius" caseCassius - , testCase "cassiusFile" caseCassiusFile - , testCase "cassiusFileDebug" caseCassiusFileDebug - , testCase "cassiusFileDebugChange" caseCassiusFileDebugChange - , testCase "julius" caseJulius - , testCase "juliusFile" caseJuliusFile - , testCase "juliusFileDebug" caseJuliusFileDebug - , testCase "juliusFileDebugChange" caseJuliusFileDebugChange - , testCase "comments" caseComments - , testCase "hamletFileDebug double foralls" caseDoubleForalls - , testCase "cassius pseudo-class" casePseudo - -- FIXME test is disabled , testCase "different binding names" caseDiffBindNames - , testCase "blank line" caseBlankLine - , testCase "leading spaces" caseLeadingSpaces - , testCase "cassius all spaces" caseCassiusAllSpaces - , testCase "cassius whitespace and colons" caseCassiusWhitespaceColons - , testCase "cassius trailing comments" caseCassiusTrailingComments - , testCase "hamlet angle bracket syntax" caseHamletAngleBrackets - , testCase "hamlet module names" caseHamletModuleNames - , testCase "cassius module names" caseCassiusModuleNames - , testCase "julius module names" caseJuliusModuleNames - , testCase "single dollar at and caret" caseSingleDollarAtCaret - , testCase "dollar operator" caseDollarOperator - , testCase "in a row" caseInARow - , testCase "embedded slash" caseEmbeddedSlash - , testCase "string literals" caseStringLiterals - , testCase "embed json" caseEmbedJson - , testCase "interpolated operators" caseOperators - , testCase "HTML comments" caseHtmlComments - , testCase "multi cassius" caseMultiCassius - , testCase "nested maybes" caseNestedMaybes - , testCase "lucius" caseLucius - , testCase "conditional class" caseCondClass - ] - -data Url = Home | Sub SubUrl -data SubUrl = SubUrl -render :: Url -> [(String, String)] -> String -render Home qs = "url" ++ showParams qs -render (Sub SubUrl) qs = "suburl" ++ showParams qs - -showParams :: [(String, String)] -> String -showParams [] = "" -showParams z = - '?' : intercalate "&" (map go z) - where - go (x, y) = go' x ++ '=' : go' y - go' = concatMap encodeUrlChar - --- | Taken straight from web-encodings; reimplemented here to avoid extra --- dependencies. -encodeUrlChar :: Char -> String -encodeUrlChar c - -- List of unreserved characters per RFC 3986 - -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding - | 'A' <= c && c <= 'Z' = [c] - | 'a' <= c && c <= 'z' = [c] - | '0' <= c && c <= '9' = [c] -encodeUrlChar c@'-' = [c] -encodeUrlChar c@'_' = [c] -encodeUrlChar c@'.' = [c] -encodeUrlChar c@'~' = [c] -encodeUrlChar ' ' = "+" -encodeUrlChar y = - let (a, c) = fromEnum y `divMod` 16 - b = a `mod` 16 - showHex' x - | x < 10 = toEnum $ x + (fromEnum '0') - | x < 16 = toEnum $ x - 10 + (fromEnum 'A') - | otherwise = error $ "Invalid argument to showHex: " ++ show x - in ['%', showHex' b, showHex' c] - -data Arg url = Arg - { getArg :: Arg url - , var :: Html - , url :: Url - , embed :: Hamlet url - , true :: Bool - , false :: Bool - , list :: [Arg url] - , nothing :: Maybe String - , just :: Maybe String - , urlParams :: (Url, [(String, String)]) - } - -theArg :: Arg url -theArg = Arg - { getArg = theArg - , var = string "" - , url = Home - , embed = [$hamlet|embed|] - , true = True - , false = False - , list = [theArg, theArg, theArg] - , nothing = Nothing - , just = Just "just" - , urlParams = (Home, [("foo", "bar"), ("foo1", "bar1")]) - } - -helper :: String -> Hamlet Url -> Assertion -helper res h = do - let x = renderHamletText render h - T.pack res @=? x - -caseEmpty :: Assertion -caseEmpty = helper "" [$hamlet||] - -caseStatic :: Assertion -caseStatic = helper "some static content" [$hamlet|some static content|] - -caseTag :: Assertion -caseTag = do - helper "

baz

" [$hamlet| -

baz -|] - helper "

baz

" [$hamlet| -

baz -|] - -caseVar :: Assertion -caseVar = do - helper "<var>" [$hamlet|#{var theArg}|] - -caseVarChain :: Assertion -caseVarChain = do - helper "<var>" [$hamlet|#{var (getArg (getArg (getArg theArg)))}|] - -caseUrl :: Assertion -caseUrl = do - helper (render Home []) [$hamlet|@{url theArg}|] - -caseUrlChain :: Assertion -caseUrlChain = do - helper (render Home []) [$hamlet|@{url (getArg (getArg (getArg theArg)))}|] - -caseEmbed :: Assertion -caseEmbed = do - helper "embed" [$hamlet|^{embed theArg}|] - -caseEmbedChain :: Assertion -caseEmbedChain = do - helper "embed" [$hamlet|^{embed (getArg (getArg (getArg theArg)))}|] - -caseIf :: Assertion -caseIf = do - helper "if" [$hamlet| -$if true theArg - if -|] - -caseIfChain :: Assertion -caseIfChain = do - helper "if" [$hamlet| -$if true (getArg (getArg (getArg theArg))) - if -|] - -caseElse :: Assertion -caseElse = helper "else" [$hamlet| -$if false theArg - if -$else - else -|] - -caseElseChain :: Assertion -caseElseChain = helper "else" [$hamlet| -$if false (getArg (getArg (getArg theArg))) - if -$else - else -|] - -caseElseIf :: Assertion -caseElseIf = helper "elseif" [$hamlet| -$if false theArg - if -$elseif true theArg - elseif -$else - else -|] - -caseElseIfChain :: Assertion -caseElseIfChain = helper "elseif" [$hamlet| -$if false(getArg(getArg(getArg theArg))) - if -$elseif true(getArg(getArg(getArg theArg))) - elseif -$else - else -|] - -caseList :: Assertion -caseList = do - helper "xxx" [$hamlet| -$forall _x <- (list theArg) - x -|] - -caseListChain :: Assertion -caseListChain = do - helper "urlurlurl" [$hamlet| -$forall x <- list(getArg(getArg(getArg(getArg(getArg (theArg)))))) - @{url x} -|] - -caseScriptNotEmpty :: Assertion -caseScriptNotEmpty = helper "" [$hamlet|" [$hamlet|" [$xhamlet|" [$hamlet||] - helper "" [$xhamlet||] - -caseInputEmpty :: Assertion -caseInputEmpty = do - helper "" [$hamlet|" [$xhamlet|" [$hamlet||] - helper "" [$xhamlet||] - -caseMultiClass :: Assertion -caseMultiClass = do - helper "

" [$hamlet|<.foo.bar|] - helper "
" [$hamlet|<.foo.bar>|] - -caseAttribOrder :: Assertion -caseAttribOrder = do - helper "" [$hamlet|" [$hamlet||] - -caseNothing :: Assertion -caseNothing = do - helper "" [$hamlet| -$maybe _n <- nothing theArg - nothing -|] - helper "nothing" [$hamlet| -$maybe _n <- nothing theArg - something -$nothing - nothing -|] - -caseNothingChain :: Assertion -caseNothingChain = helper "" [$hamlet| -$maybe n <- nothing(getArg(getArg(getArg theArg))) - nothing #{n} -|] - -caseJust :: Assertion -caseJust = helper "it's just" [$hamlet| -$maybe n <- just theArg - it's #{n} -|] - -caseJustChain :: Assertion -caseJustChain = helper "it's just" [$hamlet| -$maybe n <- just(getArg(getArg(getArg theArg))) - it's #{n} -|] - -caseConstructor :: Assertion -caseConstructor = do - helper "url" [$hamlet|@{Home}|] - helper "suburl" [$hamlet|@{Sub SubUrl}|] - let text = "" - helper "" [$hamlet|#{preEscapedString text}|] - -caseUrlParams :: Assertion -caseUrlParams = do - helper "url?foo=bar&foo1=bar1" [$hamlet|@?{urlParams theArg}|] - -caseEscape :: Assertion -caseEscape = do - helper "#this is raw\n " [$hamlet| -\#this is raw -\ -\ -|] - helper "$@^" [$hamlet|$@^|] - -caseEmptyStatementList :: Assertion -caseEmptyStatementList = do - helper "" [$hamlet|$if True|] - helper "" [$hamlet|$maybe _x <- Nothing|] - let emptyList = [] - helper "" [$hamlet|$forall _x <- emptyList|] - -caseAttribCond :: Assertion -caseAttribCond = do - helper "" [$hamlet|" [$hamlet|" - [$hamlet|" [$hamlet|" [$hamlet|" - [$hamlet|" [$hamlet| -" [$hamlet|<.#{var theArg}|] - -caseAttribVars :: Assertion -caseAttribVars = do - helper "
" [$hamlet|<##{var theArg}|] - helper "
" [$hamlet|<.#{var theArg}|] - helper "
" [$hamlet|< f=#{var theArg}|] - - helper "
" [$hamlet|<##{var theArg}>|] - helper "
" [$hamlet|<.#{var theArg}>|] - helper "
" [$hamlet|< f=#{var theArg}>|] - -caseStringsAndHtml :: Assertion -caseStringsAndHtml = do - let str = "" - let html = preEscapedString "" - helper "<string> " [$hamlet|#{str} #{html}|] - -caseNesting :: Assertion -caseNesting = do - helper - "
1
2
" - [$hamlet| -#{user} -|] - helper - (concat - [ "" - ]) - [$hamlet| -