Style.hs

{-# LANGUAGE AllowAmbiguousTypes #-}

module Web.Atomic.Types.Style where

import Data.String (IsString (..))
import Data.Text (Text, pack, unpack)
import Data.Text qualified as T
import Numeric (showFFloat)
import Text.Casing (kebab)
import Web.Atomic.Types.ClassName (ToClassName (..), className)


newtype Property = Property Text
  deriving newtype (Show, Eq, Ord, IsString, Semigroup)


data Declaration = Property :. Style
  deriving (Show, Ord, Eq)


newtype Style = Style String
  deriving newtype (IsString, Show, Eq, Monoid, Semigroup, Ord)


{- | Convert a type to a css style value

@
data Float = Right | Left

instance ToStyle Float where
  style Right = "right"
  style Left = "left"
@
-}
class ToStyle a where
  style :: a -> Style
  default style :: (Show a) => a -> Style
  style = Style . kebab . show


instance ToStyle String where
  style = Style
instance ToStyle Text where
  style = Style . unpack
instance ToStyle Int
instance ToStyle Float where
  -- this does not convert to a percent, just a ratio
  style n = Style $ showFFloat (Just 2) n ""
instance ToStyle Style where
  style = id


{- | Reuse types that belong to more than one css property

@
data None = None
  deriving (Show, ToClassName, ToStyle)

data Display
  = Block
  | Flex
  deriving (Show, ToClassName, ToStyle)
instance PropertyStyle Display Display
instance PropertyStyle Display None

display :: (PropertyStyle Display d, ToClassName d, Styleable h) => d -> CSS h -> CSS h
display disp =
  utility ("disp" -. disp) ["display" :. propertyStyle @Display disp]
@
-}
class PropertyStyle property value where
  propertyStyle :: value -> Style
  default propertyStyle :: (ToStyle value) => value -> Style
  propertyStyle = style


data None = None
  deriving (Show, ToClassName, ToStyle)


data Normal = Normal
  deriving (Show, ToStyle)
instance ToClassName Normal where
  toClassName Normal = "norm"


data Auto = Auto
  deriving (Show, ToStyle, ToClassName)


-- -- | Convert a type to a prop name
-- class ToProp a where
--   toProp :: a -> Text
--   default toProp :: (Show a) => a -> Text
--   toProp = pack . kebab . show

data Length
  = PxRem PxRem
  | Pct Float
  deriving (Show)


instance ToClassName Length where
  toClassName (PxRem p) = toClassName p
  toClassName (Pct p) = toClassName p


-- | Px, converted to Rem. Allows for the user to change the document font size and have the app scale accordingly. But allows the programmer to code in pixels to match a design
newtype PxRem = PxRem' Int
  deriving newtype (Show, ToClassName, Num, Eq, Integral, Real, Ord, Enum)


instance Num Length where
  PxRem p1 + PxRem p2 = PxRem $ p1 + p2
  -- 10 + 10% = 10 + 10% of 10 = 11
  PxRem p1 + Pct pct = PxRem $ round $ fromIntegral p1 * (1 + pct)
  Pct pct + PxRem p1 = PxRem p1 + Pct pct
  Pct p1 + Pct p2 = Pct $ p1 + p2


  PxRem p1 * PxRem p2 = PxRem $ p1 + p2
  PxRem p1 * Pct pct = PxRem $ round $ fromIntegral p1 * pct
  Pct pct * PxRem p1 = PxRem p1 * Pct pct
  Pct p1 * Pct p2 = Pct $ p1 * p2


  abs (PxRem a) = PxRem (abs a)
  abs (Pct a) = Pct (abs a)
  signum (PxRem a) = PxRem (signum a)
  signum (Pct a) = Pct (signum a)
  negate (PxRem a) = PxRem (negate a)
  negate (Pct a) = Pct (negate a)
  fromInteger n = PxRem (fromInteger n)


instance ToStyle PxRem where
  style (PxRem' 0) = "0px"
  style (PxRem' 1) = "1px"
  style (PxRem' n) = Style $ showFFloat (Just 3) ((fromIntegral n :: Float) / 16.0) "" <> "rem"


instance ToStyle Length where
  style (PxRem p) = style p
  style (Pct n) = Style $ showFFloat (Just 1) (n * 100) "" <> "%"


-- | Milliseconds, used for transitions
newtype Ms = Ms Int
  deriving (Show)
  deriving newtype (Num, ToClassName)


instance ToStyle Ms where
  style (Ms n) = Style $ show n <> "ms"


data Wrap
  = Wrap
  | NoWrap
  deriving (Show, ToClassName)
instance ToStyle Wrap where
  style Wrap = "wrap"
  style NoWrap = "nowrap"


{- | Options for styles that support specifying various sides

> border 5
> border (X 2)
> border (TRBL 0 5 0 0)
-}
data Sides a
  = All a
  | TRBL a a a a
  | X a
  | Y a
  | XY a a
  | T a
  | R a
  | B a
  | L a
  | TR a a
  | TL a a
  | BR a a
  | BL a a


-- Num instance is just to support literals
instance (Num a) => Num (Sides a) where
  a + _ = a
  a * _ = a
  abs a = a
  negate a = a
  signum a = a
  fromInteger n = All (fromInteger n)


-- ** Colors


{- | ToColor allows you to create a type containing your application's colors:

> data AppColor
>   = White
>   | Primary
>   | Dark
>   deriving (Show)
>
> instance ToColor AppColor where
>   colorValue White = "#FFF"
>   colorValue Dark = "#333"
>   colorValue Primary = "#00F"
>
> hello = el ~ bg Primary . color White $ "Hello"
-}
class ToColor a where
  colorValue :: a -> HexColor
  colorName :: a -> Text
  default colorName :: (Show a) => a -> Text
  colorName = T.toLower . pack . show


-- | Hexidecimal Color. Can be specified with or without the leading '#'. Recommended to use an AppColor type instead of manually using hex colors. See 'ToColor'
newtype HexColor = HexColor Text
  deriving (Show)


instance ToColor HexColor where
  colorValue c = c
  colorName (HexColor a) = T.dropWhile (== '#') a


instance ToStyle HexColor where
  style (HexColor s) = Style $ "#" <> unpack (T.dropWhile (== '#') s)


instance IsString HexColor where
  fromString = HexColor . T.dropWhile (== '#') . T.pack


instance ToClassName HexColor where
  toClassName = className . colorName