{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Css.Internal
(
Rule(..)
, Css(..)
, Config(..)
, pretty
, compact
, renderRule
, renderRuleWith
, renderRuleWith'
, renderCss
, renderCssWith
, putCss
, putCssWith
, renderCssToFile
, renderCssToFileWith
, (?)
, rule
, (|>)
, declaration
, getRules
) where
import Control.Monad.Writer (MonadWriter, Writer, listen, pass,
runWriter, tell)
import Data.String (IsString (fromString))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Text.Builder (Builder, run, text)
data Rule
= Rule !Text !Rule !Rule
| Declaration !Text !Text !Rule
| Leaf !Text
| Empty
instance Semigroup Rule where
Rule Text
selector Rule
inner Rule
next <> :: Rule -> Rule -> Rule
<> Rule
a =
Text -> Rule -> Rule -> Rule
Rule Text
selector Rule
inner (Rule
next Rule -> Rule -> Rule
forall a. Semigroup a => a -> a -> a
<> Rule
a)
Declaration Text
property Text
value Rule
next <> Rule
a =
Text -> Text -> Rule -> Rule
Declaration Text
property Text
value (Rule
next Rule -> Rule -> Rule
forall a. Semigroup a => a -> a -> a
<> Rule
a)
Rule
_ <> Rule
a = Rule
a
instance Monoid Rule where
mempty :: Rule
mempty = Rule
Empty
instance Show Rule where
show :: Rule -> String
show = Text -> String
T.unpack (Text -> String) -> (Rule -> Text) -> Rule -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> Text
renderRule
newtype Css a = Css
{ forall a. Css a -> Writer Rule a
runCss :: Writer Rule a }
deriving ((forall a b. (a -> b) -> Css a -> Css b)
-> (forall a b. a -> Css b -> Css a) -> Functor Css
forall a b. a -> Css b -> Css a
forall a b. (a -> b) -> Css a -> Css b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Css b -> Css a
$c<$ :: forall a b. a -> Css b -> Css a
fmap :: forall a b. (a -> b) -> Css a -> Css b
$cfmap :: forall a b. (a -> b) -> Css a -> Css b
Functor, Functor Css
Functor Css
-> (forall a. a -> Css a)
-> (forall a b. Css (a -> b) -> Css a -> Css b)
-> (forall a b c. (a -> b -> c) -> Css a -> Css b -> Css c)
-> (forall a b. Css a -> Css b -> Css b)
-> (forall a b. Css a -> Css b -> Css a)
-> Applicative Css
forall a. a -> Css a
forall a b. Css a -> Css b -> Css a
forall a b. Css a -> Css b -> Css b
forall a b. Css (a -> b) -> Css a -> Css b
forall a b c. (a -> b -> c) -> Css a -> Css b -> Css c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Css a -> Css b -> Css a
$c<* :: forall a b. Css a -> Css b -> Css a
*> :: forall a b. Css a -> Css b -> Css b
$c*> :: forall a b. Css a -> Css b -> Css b
liftA2 :: forall a b c. (a -> b -> c) -> Css a -> Css b -> Css c
$cliftA2 :: forall a b c. (a -> b -> c) -> Css a -> Css b -> Css c
<*> :: forall a b. Css (a -> b) -> Css a -> Css b
$c<*> :: forall a b. Css (a -> b) -> Css a -> Css b
pure :: forall a. a -> Css a
$cpure :: forall a. a -> Css a
Applicative, Applicative Css
Applicative Css
-> (forall a b. Css a -> (a -> Css b) -> Css b)
-> (forall a b. Css a -> Css b -> Css b)
-> (forall a. a -> Css a)
-> Monad Css
forall a. a -> Css a
forall a b. Css a -> Css b -> Css b
forall a b. Css a -> (a -> Css b) -> Css b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Css a
$creturn :: forall a. a -> Css a
>> :: forall a b. Css a -> Css b -> Css b
$c>> :: forall a b. Css a -> Css b -> Css b
>>= :: forall a b. Css a -> (a -> Css b) -> Css b
$c>>= :: forall a b. Css a -> (a -> Css b) -> Css b
Monad)
instance MonadWriter Rule Css where
tell :: Rule -> Css ()
tell = Writer Rule () -> Css ()
forall a. Writer Rule a -> Css a
Css (Writer Rule () -> Css ())
-> (Rule -> Writer Rule ()) -> Rule -> Css ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> Writer Rule ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
listen :: forall a. Css a -> Css (a, Rule)
listen = Writer Rule (a, Rule) -> Css (a, Rule)
forall a. Writer Rule a -> Css a
Css (Writer Rule (a, Rule) -> Css (a, Rule))
-> (Css a -> Writer Rule (a, Rule)) -> Css a -> Css (a, Rule)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT Rule Identity a -> Writer Rule (a, Rule)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (WriterT Rule Identity a -> Writer Rule (a, Rule))
-> (Css a -> WriterT Rule Identity a)
-> Css a
-> Writer Rule (a, Rule)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Css a -> WriterT Rule Identity a
forall a. Css a -> Writer Rule a
runCss
pass :: forall a. Css (a, Rule -> Rule) -> Css a
pass = Writer Rule a -> Css a
forall a. Writer Rule a -> Css a
Css (Writer Rule a -> Css a)
-> (Css (a, Rule -> Rule) -> Writer Rule a)
-> Css (a, Rule -> Rule)
-> Css a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT Rule Identity (a, Rule -> Rule) -> Writer Rule a
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (WriterT Rule Identity (a, Rule -> Rule) -> Writer Rule a)
-> (Css (a, Rule -> Rule)
-> WriterT Rule Identity (a, Rule -> Rule))
-> Css (a, Rule -> Rule)
-> Writer Rule a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Css (a, Rule -> Rule) -> WriterT Rule Identity (a, Rule -> Rule)
forall a. Css a -> Writer Rule a
runCss
instance Semigroup (Css ()) where
Css ()
css <> :: Css () -> Css () -> Css ()
<> Css ()
a = Rule -> Css ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Rule -> Css ()) -> Rule -> Css ()
forall a b. (a -> b) -> a -> b
$ Css () -> Rule
getRules Css ()
css Rule -> Rule -> Rule
forall a. Semigroup a => a -> a -> a
<> Css () -> Rule
getRules Css ()
a
instance Monoid (Css ()) where
mempty :: Css ()
mempty = Rule -> Css ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Rule
Empty
instance IsString (Css ()) where
fromString :: String -> Css ()
fromString :: String -> Css ()
fromString = Rule -> Css ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Rule -> Css ()) -> (String -> Rule) -> String -> Css ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Rule
Leaf (Text -> Rule) -> (String -> Text) -> String -> Rule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
{-# INLINE fromString #-}
instance (a ~ Css (), b ~ Css ()) => IsString (a -> b) where
fromString :: String -> Css () -> Css ()
fromString :: String -> Css () -> Css ()
fromString String
strSelector Css ()
css = case Css () -> Rule
getRules Css ()
css of
Leaf Text
txt -> Text -> Text -> Css ()
declaration (String -> Text
T.pack String
strSelector) Text
txt
Rule
inner -> Text -> Css () -> Css ()
rule (String -> Text
T.pack String
strSelector) (Rule -> Css ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Rule
inner)
{-# INLINE fromString #-}
instance Show (Css ()) where
show :: Css () -> String
show = Text -> String
T.unpack (Text -> String) -> (Css () -> Text) -> Css () -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Css () -> Text
renderCss
rule
:: Text
-> Css ()
-> Css ()
rule :: Text -> Css () -> Css ()
rule Text
selector Css ()
inner =
Rule -> Css ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Rule -> Css ()) -> Rule -> Css ()
forall a b. (a -> b) -> a -> b
$ Text -> Rule -> Rule -> Rule
Rule Text
selector (Css () -> Rule
getRules Css ()
inner) Rule
forall a. Monoid a => a
mempty
{-# INLINE rule #-}
(?)
:: Text
-> Css ()
-> Css ()
? :: Text -> Css () -> Css ()
(?) = Text -> Css () -> Css ()
rule
{-# INLINE (?) #-}
declaration
:: Text
-> Text
-> Css ()
declaration :: Text -> Text -> Css ()
declaration Text
property Text
value =
Rule -> Css ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Rule -> Css ()) -> Rule -> Css ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Rule -> Rule
Declaration Text
property Text
value Rule
forall a. Monoid a => a
mempty
{-# INLINE declaration #-}
(|>)
:: Text
-> Text
-> Css ()
|> :: Text -> Text -> Css ()
(|>) = Text -> Text -> Css ()
declaration
{-# INLINE (|>) #-}
data Config = Config
{ Config -> Text
_newline :: !Text
, Config -> Text
_indent :: !Text
, Config -> Text
_spacing :: !Text
}
pretty :: Config
pretty :: Config
pretty = Text -> Text -> Text -> Config
Config Text
"\n" Text
" " Text
" "
compact :: Config
compact :: Config
compact = Text -> Text -> Text -> Config
Config Text
"" Text
"" Text
""
renderRule
:: Rule
-> Text
renderRule :: Rule -> Text
renderRule = (Rule -> Config -> Text
`renderRuleWith` Config
pretty)
renderRuleWith
:: Rule
-> Config
-> Text
renderRuleWith :: Rule -> Config -> Text
renderRuleWith Rule
rule Config
config =
Builder -> Text
run (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Rule -> Config -> Builder -> Builder
renderRuleWith' Rule
rule Config
config Builder
""
renderRuleWith'
:: Rule
-> Config
-> Builder
-> Builder
renderRuleWith' :: Rule -> Config -> Builder -> Builder
renderRuleWith' (Rule Text
selector Rule
inner Rule
Empty) Config
config Builder
prefix =
Builder
prefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
text Text
selector Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Builder
text (Text -> Builder) -> (Config -> Text) -> Config -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Text
_spacing) Config
config Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"{"
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Builder
text (Text -> Builder) -> (Config -> Text) -> Config -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Text
_newline) Config
config
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Rule -> Config -> Builder -> Builder
renderRuleWith' Rule
inner Config
config (Builder
prefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Builder
text (Text -> Builder) -> (Config -> Text) -> Config -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Text
_indent) Config
config)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Builder
text (Text -> Builder) -> (Config -> Text) -> Config -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Text
_newline) Config
config Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
prefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"}"
renderRuleWith' (Rule Text
selector Rule
inner Rule
next) Config
config Builder
prefix =
Builder
prefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
text Text
selector Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Builder
text (Text -> Builder) -> (Config -> Text) -> Config -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Text
_spacing) Config
config Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"{"
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Builder
text (Text -> Builder) -> (Config -> Text) -> Config -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Text
_newline) Config
config
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Rule -> Config -> Builder -> Builder
renderRuleWith' Rule
inner Config
config (Builder
prefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Builder
text (Text -> Builder) -> (Config -> Text) -> Config -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Text
_indent) Config
config)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Builder
text (Text -> Builder) -> (Config -> Text) -> Config -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Text
_newline) Config
config Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
prefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"}" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Builder
text (Text -> Builder) -> (Config -> Text) -> Config -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Text
_newline) Config
config
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Rule -> Config -> Builder -> Builder
renderRuleWith' Rule
next Config
config Builder
prefix
renderRuleWith' (Declaration Text
property Text
value Rule
Empty) Config
config Builder
prefix =
Builder
prefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
text Text
property Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Builder
text (Text -> Builder) -> (Config -> Text) -> Config -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Text
_spacing) Config
config Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
text Text
value
renderRuleWith' (Declaration Text
property Text
value Rule
next) Config
config Builder
prefix =
Builder
prefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
text Text
property Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Builder
text (Text -> Builder) -> (Config -> Text) -> Config -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Text
_spacing) Config
config Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
text Text
value
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
";" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Builder
text (Text -> Builder) -> (Config -> Text) -> Config -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Text
_newline) Config
config
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Rule -> Config -> Builder -> Builder
renderRuleWith' Rule
next Config
config Builder
prefix
renderRuleWith' Rule
_ Config
_ Builder
_ = Builder
""
renderCss
:: Css ()
-> Text
renderCss :: Css () -> Text
renderCss = Rule -> Text
renderRule (Rule -> Text) -> (Css () -> Rule) -> Css () -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Css () -> Rule
getRules
putCss
:: Css ()
-> IO ()
putCss :: Css () -> IO ()
putCss = Text -> IO ()
TIO.putStrLn (Text -> IO ()) -> (Css () -> Text) -> Css () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> Text
renderRule (Rule -> Text) -> (Css () -> Rule) -> Css () -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Css () -> Rule
getRules
renderCssToFile
:: Css ()
-> FilePath
-> IO ()
renderCssToFile :: Css () -> String -> IO ()
renderCssToFile Css ()
css String
filePath =
String -> Text -> IO ()
TIO.writeFile String
filePath (Text -> IO ()) -> (Css () -> Text) -> Css () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> Text
renderRule (Rule -> Text) -> (Css () -> Rule) -> Css () -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Css () -> Rule
getRules (Css () -> IO ()) -> Css () -> IO ()
forall a b. (a -> b) -> a -> b
$ Css ()
css
renderCssWith
:: Css ()
-> Config
-> Text
renderCssWith :: Css () -> Config -> Text
renderCssWith = Rule -> Config -> Text
renderRuleWith (Rule -> Config -> Text)
-> (Css () -> Rule) -> Css () -> Config -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Css () -> Rule
getRules
putCssWith
:: Css ()
-> Config
-> IO ()
putCssWith :: Css () -> Config -> IO ()
putCssWith Css ()
css Config
config = Text -> IO ()
TIO.putStrLn (Rule -> Config -> Text
renderRuleWith (Css () -> Rule
getRules Css ()
css) Config
config)
renderCssToFileWith
:: Css ()
-> Config
-> FilePath
-> IO ()
renderCssToFileWith :: Css () -> Config -> String -> IO ()
renderCssToFileWith Css ()
css Config
config String
filePath =
String -> Text -> IO ()
TIO.writeFile String
filePath (Rule -> Config -> Text
renderRuleWith (Css () -> Rule
getRules Css ()
css) Config
config)
getRules :: Css () -> Rule
getRules :: Css () -> Rule
getRules = ((), Rule) -> Rule
forall a b. (a, b) -> b
snd (((), Rule) -> Rule) -> (Css () -> ((), Rule)) -> Css () -> Rule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Writer Rule () -> ((), Rule)
forall w a. Writer w a -> (a, w)
runWriter (Writer Rule () -> ((), Rule))
-> (Css () -> Writer Rule ()) -> Css () -> ((), Rule)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Css () -> Writer Rule ()
forall a. Css a -> Writer Rule a
runCss
{-# INLINE getRules #-}