{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Style
( style
, handleCSS
, parseLine
, parseCSS
, Brace (..)
)
where
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Data.Text (pack, unpack, replace)
import Data.Bits
import Data.List
import Component (Attributes ( Style ), Purview ( Attribute ))
style :: QuasiQuoter
style :: QuasiQuoter
style = QuasiQuoter
{ quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"quoteDec not implemented"
, quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"quoteType not implemented"
, quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"quotePat not implemented"
, quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
style'
}
clean :: String -> String
clean :: String -> String
clean [] = String
""
clean (Char
'\n':String
rest) = String -> String
clean String
rest
clean (Char
';':String
rest) = Char
';'Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
clean ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Char -> String -> Bool) -> String -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char
' ', Char
'\n']) String
rest)
clean (Char
c:String
rest) = Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String -> String
clean String
rest
data Brace = Open | Close | None
deriving (Int -> Brace -> String -> String
[Brace] -> String -> String
Brace -> String
(Int -> Brace -> String -> String)
-> (Brace -> String) -> ([Brace] -> String -> String) -> Show Brace
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Brace -> String -> String
showsPrec :: Int -> Brace -> String -> String
$cshow :: Brace -> String
show :: Brace -> String
$cshowList :: [Brace] -> String -> String
showList :: [Brace] -> String -> String
Show, Brace -> Brace -> Bool
(Brace -> Brace -> Bool) -> (Brace -> Brace -> Bool) -> Eq Brace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Brace -> Brace -> Bool
== :: Brace -> Brace -> Bool
$c/= :: Brace -> Brace -> Bool
/= :: Brace -> Brace -> Bool
Eq)
parseLine' :: (String, String) -> (Brace, String, String)
parseLine' :: (String, String) -> (Brace, String, String)
parseLine' (String
line, Char
'\n':String
rest) = (String, String) -> (Brace, String, String)
parseLine' (String
line, String
rest)
parseLine' (String
line, Char
';':String
rest) = (Brace
None, String
line String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Char
';'], String
rest)
parseLine' (String
line, Char
'{':String
rest) = (Brace
Open, String
line String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Char
'{'], String
rest)
parseLine' (String
line, Char
'}':String
rest) = (Brace
Close, String
line String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Char
'{'], String
rest)
parseLine' (String
line, Char
c:String
rest) = (String, String) -> (Brace, String, String)
parseLine' (String
line String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Char
c], String
rest)
parseLine' (String
line, String
"") = (Brace
None, String
line, String
"")
preParseLine :: String -> String
preParseLine :: String -> String
preParseLine = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Char -> String -> Bool) -> String -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char
' ', Char
'\n'])
parseLine :: String -> (Brace, String, String)
parseLine String
css =
let cleaned :: String
cleaned = String -> String
preParseLine String
css
in (String, String) -> (Brace, String, String)
parseLine' (String
"", String
cleaned)
parseNewLevel :: String -> String
parseNewLevel = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'{')
parseCSS :: [String] -> String -> [(String, String)]
parseCSS :: [String] -> String -> [(String, String)]
parseCSS [String]
_ String
"" = []
parseCSS [String]
path String
css =
let (Brace
brace, String
line, String
remaining) = String -> (Brace, String, String)
parseLine String
css
in case Brace
brace of
Brace
Open -> [String] -> String -> [(String, String)]
parseCSS ([String]
path [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String -> String
parseNewLevel String
line]) String
remaining
Brace
Close -> [String] -> String -> [(String, String)]
parseCSS (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
path Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [String]
path) String
remaining
Brace
None ->
if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
line
then []
else ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
path, String
line) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: [String] -> String -> [(String, String)]
parseCSS [String]
path String
remaining
joinOnClass :: [(String, String)] -> (String, String)
joinOnClass :: [(String, String)] -> (String, String)
joinOnClass cs :: [(String, String)]
cs@((String
name, String
_):[(String, String)]
_) = (String
name, ((String, String) -> String) -> [(String, String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, String) -> String
forall a b. (a, b) -> b
snd [(String, String)]
cs)
joinOnClass [] = (String
"", String
"")
handleCSS :: String -> [(String, String)]
handleCSS :: String -> [(String, String)]
handleCSS String
css =
([(String, String)] -> (String, String))
-> [[(String, String)]] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(String, String)] -> (String, String)
joinOnClass ([[(String, String)]] -> [(String, String)])
-> [[(String, String)]] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ ((String, String) -> (String, String) -> Bool)
-> [(String, String)] -> [[(String, String)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\(String, String)
a (String, String)
b -> (String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
b) ([(String, String)] -> [[(String, String)]])
-> [(String, String)] -> [[(String, String)]]
forall a b. (a -> b) -> a -> b
$ ((String, String) -> String)
-> [(String, String)] -> [(String, String)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (String, String) -> String
forall a b. (a, b) -> a
fst ([(String, String)] -> [(String, String)])
-> [(String, String)] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ [String] -> String -> [(String, String)]
parseCSS [] String
css
handlePseudo :: String -> String -> String
handlePseudo String
hash (Char
'&':String
newClass) =
String
hash String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
newClass
handlePseudo String
hash String
newClass =
String
hash String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
replace Text
" &:" Text
":" (String -> Text
pack String
newClass))
combineClasses :: String -> String -> String
combineClasses String
hash String
newClass =
if Char
'&' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
newClass
then String -> String -> String
handlePseudo String
hash String
newClass
else String
hash String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
newClass
toAttributes :: String -> String -> (Purview event m -> Purview event m)
toAttributes :: forall event (m :: * -> *).
String -> String -> Purview event m -> Purview event m
toAttributes String
hashed String
css =
let ((String
_, String
baseCss):[(String, String)]
rest) = String -> [(String, String)]
handleCSS String
css
in ((String, String)
-> (Purview event m -> Purview event m)
-> Purview event m
-> Purview event m)
-> (Purview event m -> Purview event m)
-> [(String, String)]
-> Purview event m
-> Purview event m
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(\(String
newClass, String
newCss) Purview event m -> Purview event m
acc ->
Purview event m -> Purview event m
acc (Purview event m -> Purview event m)
-> (Purview event m -> Purview event m)
-> Purview event m
-> Purview event m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes event -> Purview event m -> Purview event m
forall event (m :: * -> *).
Attributes event -> Purview event m -> Purview event m
Attribute ((String, String) -> Attributes event
forall event. (String, String) -> Attributes event
Style (String -> String -> String
combineClasses String
hashed String
newClass, String
newCss))
)
(Attributes event -> Purview event m -> Purview event m
forall event (m :: * -> *).
Attributes event -> Purview event m -> Purview event m
Attribute ((String, String) -> Attributes event
forall event. (String, String) -> Attributes event
Style (String
hashed, String
baseCss))) [(String, String)]
rest
style' :: String -> Q Exp
style' :: String -> Q Exp
style' String
css =
let
hashed :: String
hashed = Char
'p' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show (String -> Int
hash String
css)
in [| toAttributes hashed css |]
hash :: String -> Int
hash :: String -> Int
hash = (Int -> Char -> Int) -> Int -> String -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
h Char
c -> Int
33 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
h Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c) Int
5381