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