{-# 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 = forall a. HasCallStack => String -> a
error String
"quoteDec not implemented"
  , quoteType :: String -> Q Type
quoteType = forall a. HasCallStack => String -> a
error String
"quoteType not implemented"
  , quotePat :: String -> Q Pat
quotePat = 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
';'forall a. a -> [a] -> [a]
:String -> String
clean (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char
' ', Char
'\n']) String
rest)
clean (Char
c:String
rest)    = Char
cforall a. a -> [a] -> [a]
:String -> String
clean String
rest

data Brace = Open | Close | None
  deriving (Int -> Brace -> String -> String
[Brace] -> String -> String
Brace -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Brace] -> String -> String
$cshowList :: [Brace] -> String -> String
show :: Brace -> String
$cshow :: Brace -> String
showsPrec :: Int -> Brace -> String -> String
$cshowsPrec :: Int -> Brace -> String -> String
Show, Brace -> Brace -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Brace -> Brace -> Bool
$c/= :: Brace -> Brace -> Bool
== :: Brace -> Brace -> Bool
$c== :: 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 forall a. Semigroup a => a -> a -> a
<> [Char
';'], String
rest)
parseLine' (String
line, Char
'{':String
rest)  = (Brace
Open, String
line forall a. Semigroup a => a -> a -> a
<> [Char
'{'], String
rest)
parseLine' (String
line, Char
'}':String
rest)  = (Brace
Close, String
line 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 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 = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (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 forall a. Semigroup a => a -> a -> a
<> [String -> String
parseNewLevel String
line]) String
remaining
    Brace
Close -> [String] -> String -> [(String, String)]
parseCSS (forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
path forall a. Num a => a -> a -> a
- Int
1) [String]
path) String
remaining
    Brace
None  ->
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
line
      then []
      else (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
path, String
line) 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, forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(String, String)]
cs)
joinOnClass [] = (String
"", String
"")

handleCSS :: String -> [(String, String)]
handleCSS :: String -> [(String, String)]
handleCSS String
css =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(String, String)] -> (String, String)
joinOnClass forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\(String, String)
a (String, String)
b -> forall a b. (a, b) -> a
fst (String, String)
a forall a. Eq a => a -> a -> Bool
== forall a b. (a, b) -> a
fst (String, String)
b) forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst 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 forall a. Semigroup a => a -> a -> a
<> String
newClass
-- for the nested pseudos
handlePseudo String
hash String
newClass =
  String
hash forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> (Text -> String
unpack forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
replace Text
" &:" Text
":" (String -> Text
pack String
newClass))

combineClasses :: String -> String -> String
combineClasses String
hash String
newClass =
  if Char
'&' 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 forall a. Semigroup a => a -> a -> a
<> 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall event (m :: * -> *).
Attributes event -> Purview event m -> Purview event m
Attribute (forall event. (String, String) -> Attributes event
Style (String -> String -> String
combineClasses String
hashed String
newClass, String
newCss))
      )
      (forall event (m :: * -> *).
Attributes event -> Purview event m -> Purview event m
Attribute (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' forall a. a -> [a] -> [a]
: 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
h Char
c -> Int
33 forall a. Num a => a -> a -> a
* Int
h forall a. Bits a => a -> a -> a
`xor` forall a. Enum a => a -> Int
fromEnum Char
c) Int
5381