{-# 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.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)
(!) = (,)