{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}
module Clay.Property where

import Control.Arrow (second)
import Data.Fixed (Fixed, HasResolution (resolution), showFixed)
import Data.List (partition, sort)
import Data.List.NonEmpty (NonEmpty, toList)
import Data.Maybe
import Data.Semigroup
import Data.String
import Data.Text (Text, replace)

data Prefixed = Prefixed { Prefixed -> [(Text, Text)]
unPrefixed :: [(Text, Text)] } | Plain { Prefixed -> Text
unPlain :: Text }
  deriving (Int -> Prefixed -> ShowS
[Prefixed] -> ShowS
Prefixed -> String
(Int -> Prefixed -> ShowS)
-> (Prefixed -> String) -> ([Prefixed] -> ShowS) -> Show Prefixed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Prefixed] -> ShowS
$cshowList :: [Prefixed] -> ShowS
show :: Prefixed -> String
$cshow :: Prefixed -> String
showsPrec :: Int -> Prefixed -> ShowS
$cshowsPrec :: Int -> Prefixed -> ShowS
Show, Prefixed -> Prefixed -> Bool
(Prefixed -> Prefixed -> Bool)
-> (Prefixed -> Prefixed -> Bool) -> Eq Prefixed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Prefixed -> Prefixed -> Bool
$c/= :: Prefixed -> Prefixed -> Bool
== :: Prefixed -> Prefixed -> Bool
$c== :: Prefixed -> Prefixed -> Bool
Eq)

instance IsString Prefixed where
  fromString :: String -> Prefixed
fromString String
s = Text -> Prefixed
Plain (String -> Text
forall a. IsString a => String -> a
fromString String
s)

instance Semigroup Prefixed where
  <> :: Prefixed -> Prefixed -> Prefixed
(<>) = Prefixed -> Prefixed -> Prefixed
merge

instance Monoid Prefixed where
  mempty :: Prefixed
mempty  = Prefixed
""
  mappend :: Prefixed -> Prefixed -> Prefixed
mappend = Prefixed -> Prefixed -> Prefixed
forall a. Semigroup a => a -> a -> a
(<>)

merge :: Prefixed -> Prefixed -> Prefixed
merge :: Prefixed -> Prefixed -> Prefixed
merge (Plain    Text
x ) (Plain    Text
y ) = Text -> Prefixed
Plain (Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y)
merge (Plain    Text
x ) (Prefixed [(Text, Text)]
ys) = [(Text, Text)] -> Prefixed
Prefixed (((Text, Text) -> (Text, Text)) -> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text) -> (Text, Text) -> (Text, Text)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)) [(Text, Text)]
ys)
merge (Prefixed [(Text, Text)]
xs) (Plain    Text
y ) = [(Text, Text)] -> Prefixed
Prefixed (((Text, Text) -> (Text, Text)) -> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text) -> (Text, Text) -> (Text, Text)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y)) [(Text, Text)]
xs)
merge (Prefixed [(Text, Text)]
xs) (Prefixed [(Text, Text)]
ys) =
  let kys :: [Text]
kys = ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
forall a b. (a, b) -> a
fst [(Text, Text)]
ys
      kxs :: [Text]
kxs = ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
forall a b. (a, b) -> a
fst [(Text, Text)]
xs
   in [(Text, Text)] -> Prefixed
Prefixed ([(Text, Text)] -> Prefixed) -> [(Text, Text)] -> Prefixed
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> (Text, Text) -> (Text, Text))
-> [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Text
p, Text
a) (Text
_, Text
b) -> (Text
p, Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b))
        ([(Text, Text)] -> [(Text, Text)]
forall a. Ord a => [a] -> [a]
sort (([(Text, Text)], [(Text, Text)]) -> [(Text, Text)]
forall a b. (a, b) -> a
fst (((Text, Text) -> Bool)
-> [(Text, Text)] -> ([(Text, Text)], [(Text, Text)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
kys) (Text -> Bool) -> ((Text, Text) -> Text) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst) [(Text, Text)]
xs)))
        ([(Text, Text)] -> [(Text, Text)]
forall a. Ord a => [a] -> [a]
sort (([(Text, Text)], [(Text, Text)]) -> [(Text, Text)]
forall a b. (a, b) -> a
fst (((Text, Text) -> Bool)
-> [(Text, Text)] -> ([(Text, Text)], [(Text, Text)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
kxs) (Text -> Bool) -> ((Text, Text) -> Text) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst) [(Text, Text)]
ys)))

plain :: Prefixed -> Text
plain :: Prefixed -> Text
plain (Prefixed [(Text, Text)]
xs) = Text
"" Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
`fromMaybe` Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"" [(Text, Text)]
xs
plain (Plain    Text
p ) = Text
p

quote :: Text -> Text
quote :: Text -> Text
quote Text
t = Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text -> Text
replace Text
"\"" Text
"\\\"" Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""

-------------------------------------------------------------------------------

newtype Key a = Key { Key a -> Prefixed
unKeys :: Prefixed }
  deriving (Int -> Key a -> ShowS
[Key a] -> ShowS
Key a -> String
(Int -> Key a -> ShowS)
-> (Key a -> String) -> ([Key a] -> ShowS) -> Show (Key a)
forall a. Int -> Key a -> ShowS
forall a. [Key a] -> ShowS
forall a. Key a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Key a] -> ShowS
$cshowList :: forall a. [Key a] -> ShowS
show :: Key a -> String
$cshow :: forall a. Key a -> String
showsPrec :: Int -> Key a -> ShowS
$cshowsPrec :: forall a. Int -> Key a -> ShowS
Show, b -> Key a -> Key a
NonEmpty (Key a) -> Key a
Key a -> Key a -> Key a
(Key a -> Key a -> Key a)
-> (NonEmpty (Key a) -> Key a)
-> (forall b. Integral b => b -> Key a -> Key a)
-> Semigroup (Key a)
forall b. Integral b => b -> Key a -> Key a
forall a. NonEmpty (Key a) -> Key a
forall a. Key a -> Key a -> Key a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b. Integral b => b -> Key a -> Key a
stimes :: b -> Key a -> Key a
$cstimes :: forall a b. Integral b => b -> Key a -> Key a
sconcat :: NonEmpty (Key a) -> Key a
$csconcat :: forall a. NonEmpty (Key a) -> Key a
<> :: Key a -> Key a -> Key a
$c<> :: forall a. Key a -> Key a -> Key a
Semigroup, Semigroup (Key a)
Key a
Semigroup (Key a)
-> Key a
-> (Key a -> Key a -> Key a)
-> ([Key a] -> Key a)
-> Monoid (Key a)
[Key a] -> Key a
Key a -> Key a -> Key a
forall a. Semigroup (Key a)
forall a. Key a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. [Key a] -> Key a
forall a. Key a -> Key a -> Key a
mconcat :: [Key a] -> Key a
$cmconcat :: forall a. [Key a] -> Key a
mappend :: Key a -> Key a -> Key a
$cmappend :: forall a. Key a -> Key a -> Key a
mempty :: Key a
$cmempty :: forall a. Key a
$cp1Monoid :: forall a. Semigroup (Key a)
Monoid, String -> Key a
(String -> Key a) -> IsString (Key a)
forall a. String -> Key a
forall a. (String -> a) -> IsString a
fromString :: String -> Key a
$cfromString :: forall a. String -> Key a
IsString)

cast :: Key a -> Key ()
cast :: Key a -> Key ()
cast (Key Prefixed
k) = Prefixed -> Key ()
forall a. Prefixed -> Key a
Key Prefixed
k

-------------------------------------------------------------------------------

newtype Value = Value { Value -> Prefixed
unValue :: Prefixed }
  deriving (Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show, b -> Value -> Value
NonEmpty Value -> Value
Value -> Value -> Value
(Value -> Value -> Value)
-> (NonEmpty Value -> Value)
-> (forall b. Integral b => b -> Value -> Value)
-> Semigroup Value
forall b. Integral b => b -> Value -> Value
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Value -> Value
$cstimes :: forall b. Integral b => b -> Value -> Value
sconcat :: NonEmpty Value -> Value
$csconcat :: NonEmpty Value -> Value
<> :: Value -> Value -> Value
$c<> :: Value -> Value -> Value
Semigroup, Semigroup Value
Value
Semigroup Value
-> Value
-> (Value -> Value -> Value)
-> ([Value] -> Value)
-> Monoid Value
[Value] -> Value
Value -> Value -> Value
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Value] -> Value
$cmconcat :: [Value] -> Value
mappend :: Value -> Value -> Value
$cmappend :: Value -> Value -> Value
mempty :: Value
$cmempty :: Value
$cp1Monoid :: Semigroup Value
Monoid, String -> Value
(String -> Value) -> IsString Value
forall a. (String -> a) -> IsString a
fromString :: String -> Value
$cfromString :: String -> Value
IsString, Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq)

class Val a where
  value :: a -> Value

instance Val Text where
  value :: Text -> Value
value Text
t = Prefixed -> Value
Value (Text -> Prefixed
Plain Text
t)

newtype Literal = Literal Text
  deriving (Int -> Literal -> ShowS
[Literal] -> ShowS
Literal -> String
(Int -> Literal -> ShowS)
-> (Literal -> String) -> ([Literal] -> ShowS) -> Show Literal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Literal] -> ShowS
$cshowList :: [Literal] -> ShowS
show :: Literal -> String
$cshow :: Literal -> String
showsPrec :: Int -> Literal -> ShowS
$cshowsPrec :: Int -> Literal -> ShowS
Show, b -> Literal -> Literal
NonEmpty Literal -> Literal
Literal -> Literal -> Literal
(Literal -> Literal -> Literal)
-> (NonEmpty Literal -> Literal)
-> (forall b. Integral b => b -> Literal -> Literal)
-> Semigroup Literal
forall b. Integral b => b -> Literal -> Literal
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Literal -> Literal
$cstimes :: forall b. Integral b => b -> Literal -> Literal
sconcat :: NonEmpty Literal -> Literal
$csconcat :: NonEmpty Literal -> Literal
<> :: Literal -> Literal -> Literal
$c<> :: Literal -> Literal -> Literal
Semigroup, Semigroup Literal
Literal
Semigroup Literal
-> Literal
-> (Literal -> Literal -> Literal)
-> ([Literal] -> Literal)
-> Monoid Literal
[Literal] -> Literal
Literal -> Literal -> Literal
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Literal] -> Literal
$cmconcat :: [Literal] -> Literal
mappend :: Literal -> Literal -> Literal
$cmappend :: Literal -> Literal -> Literal
mempty :: Literal
$cmempty :: Literal
$cp1Monoid :: Semigroup Literal
Monoid, String -> Literal
(String -> Literal) -> IsString Literal
forall a. (String -> a) -> IsString a
fromString :: String -> Literal
$cfromString :: String -> Literal
IsString)

instance Val Literal where
  value :: Literal -> Value
value (Literal Text
t) = Prefixed -> Value
Value (Text -> Prefixed
Plain (Text -> Text
quote Text
t))

instance Val Integer where
  value :: Integer -> Value
value = String -> Value
forall a. IsString a => String -> a
fromString (String -> Value) -> (Integer -> String) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show

data E5 = E5
instance HasResolution E5 where resolution :: p E5 -> Integer
resolution p E5
_ = Integer
100000

instance Val Double where
  value :: Double -> Value
value = Prefixed -> Value
Value (Prefixed -> Value) -> (Double -> Prefixed) -> Double -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Prefixed
Plain (Text -> Prefixed) -> (Double -> Text) -> Double -> Prefixed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Text
cssDoubleText

cssDoubleText :: Double -> Text
cssDoubleText :: Double -> Text
cssDoubleText = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> (Double -> String) -> Double -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fixed E5 -> String
showFixed' (Fixed E5 -> String) -> (Double -> Fixed E5) -> Double -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Fixed E5
forall a b. (Real a, Fractional b) => a -> b
realToFrac
    where
      showFixed' :: Fixed E5 -> String
      showFixed' :: Fixed E5 -> String
showFixed' = Bool -> Fixed E5 -> String
forall k (a :: k). HasResolution a => Bool -> Fixed a -> String
showFixed Bool
True

instance Val Value where
  value :: Value -> Value
value = Value -> Value
forall a. a -> a
id

instance Val a => Val (Maybe a) where
  value :: Maybe a -> Value
value Maybe a
Nothing  = Value
""
  value (Just a
a) = a -> Value
forall a. Val a => a -> Value
value a
a

instance (Val a, Val b) => Val (a, b) where
  value :: (a, b) -> Value
value (a
a, b
b) = a -> Value
forall a. Val a => a -> Value
value a
a Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
" " Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> b -> Value
forall a. Val a => a -> Value
value b
b

instance (Val a, Val b) => Val (Either a b) where
  value :: Either a b -> Value
value (Left  a
a) = a -> Value
forall a. Val a => a -> Value
value a
a
  value (Right b
a) = b -> Value
forall a. Val a => a -> Value
value b
a

instance Val a => Val [a] where
  value :: [a] -> Value
value [a]
xs = Value -> [Value] -> Value
forall a. Monoid a => a -> [a] -> a
intercalate Value
"," ((a -> Value) -> [a] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map a -> Value
forall a. Val a => a -> Value
value [a]
xs)

instance Val a => Val (NonEmpty a) where
  value :: NonEmpty a -> Value
value = [a] -> Value
forall a. Val a => a -> Value
value ([a] -> Value) -> (NonEmpty a -> [a]) -> NonEmpty a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
toList

intercalate :: Monoid a => a -> [a] -> a
intercalate :: a -> [a] -> a
intercalate a
_ []     = a
forall a. Monoid a => a
mempty
intercalate a
s (a
x:[a]
xs) = (a -> a -> a) -> a -> [a] -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\a
a a
b -> a
a a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
s a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
b) a
x [a]
xs

-------------------------------------------------------------------------------

noCommas :: Val a => [a] -> Value
noCommas :: [a] -> Value
noCommas [a]
xs = Value -> [Value] -> Value
forall a. Monoid a => a -> [a] -> a
intercalate Value
" " ((a -> Value) -> [a] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map a -> Value
forall a. Val a => a -> Value
value [a]
xs)

infixr !

(!) :: a -> b -> (a, b)
(!) = (,)