{-# 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 ))

-- thanks https://stackoverflow.com/questions/59399050/haskell-making-quasi-quoted-values-strict-evaluated-at-compile-time

{-|
Components styled with this QuasiQuoter will have a class added
to them and the CSS added to the stylesheet.  Basic support is
provided for easily styling nested components and for pseudo
selectors.

__Examples:__

Styling a button:

@
blue = [style|
  background-color: blue;
|]

blueButton = blue $ button []
@

Styling a list with a pseudo selector to get the right cursor on hover:

@
listStyle = [style|
  width: 250px;
  li {
    padding: 25px;
    &:hover {
      cursor: pointer;
    }
  }
|]

list = listStyle $ ul [ li [ text "an item" ] ]
@
-}
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'
  }

{-

This is all kind of a mess and could definitely use some love. I don't think
it's quite doing what is wanted, looking at the dumped splices, as ideally
that would be a list of Attributes instead of a call to a function.  I ran
into implementing Lift for Purview -> Purview, for the attributes, and this
at least works.

If it catches anyone's eye by all means rewrite it

-}
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)

-- Takes a chunk of CSS and returns a line, the remainder to parse, and if
-- it contains an opening brace
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

-- for handling top level pseudos
handlePseudo :: String -> String -> String
handlePseudo String
hash (Char
'&':String
newClass) =
  String
hash String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
newClass
-- for the nested pseudos
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 =
  -- pretty funny, css needs a leading character (not number)
  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 |]

-- snagged from https://stackoverflow.com/a/9263004/1361890
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