{-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module      : Hasmin.Types.Value
-- Copyright   : (c) 2017 Cristian Adrián Ontivero
-- License     : BSD3
-- Stability   : experimental
-- Portability : unknown
--
-----------------------------------------------------------------------------
module Hasmin.Types.Value
    ( Value(..)
    , Values(..)
    , TextV(..)
    , Separator(..)
    , Url(..)
    , mkOther
    , mkValues
    , valuesToList
    , optimizeFontFamily
    , lowercaseText
    ) where

import Control.Monad.Reader (ask, Reader, mapReader)
import Data.Monoid ((<>))
import Data.Maybe (isJust, catMaybes, isNothing)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Lazy.Builder (fromText, singleton, Builder)
import Data.String (IsString)

import Hasmin.Class
import Hasmin.Config
import Hasmin.Types.BgSize
import Hasmin.Types.BasicShape
import Hasmin.Types.BorderRadius
import Hasmin.Types.Color
import Hasmin.Types.Dimension
import Hasmin.Types.FilterFunction
import Hasmin.Types.Gradient
import Hasmin.Types.Numeric
import Hasmin.Types.Position
import Hasmin.Types.RepeatStyle
import Hasmin.Types.Shadow
import Hasmin.Types.String
import Hasmin.Types.TimingFunction
import Hasmin.Types.TransformFunction
import Hasmin.Utils

-- | A CSS <https://www.w3.org/TR/css-values-3/#value-defs value>.
data Value = Inherit
           | Initial
           | Unset
           | NumberV Number
           | PercentageV Percentage
           | LengthV Length
           | AngleV Angle
           | TimeV Time
           | FrequencyV Frequency
           | ResolutionV Resolution
           | ColorV Color
           | GradientV Text Gradient -- the Text is just to handle function prefixes
           | GenericFunc Text Values
           | TransformV TransformFunction
           | TimingFuncV TimingFunction
           | FilterV FilterFunction
           | ShadowV Shadow
           | ShadowText Length Length (Maybe Length) (Maybe Color) -- <shadow-t> type
           | PositionV Position
           | RepeatStyleV RepeatStyle
           | BorderRadiusV BorderRadius
           | BasicShapeV BasicShape
           | BgSizeV BgSize
           -- <bg-image> || <position> [ / <bg-size> ]? || <repeat-style> || <attachment> || <box>{1,2}
           | BgLayer
              { _bgimage      :: Maybe Value
              , _bgposition   :: Maybe Position
              , _bgsize       :: Maybe BgSize
              , _bgrepeat     :: Maybe RepeatStyle
              , _bgattachment :: Maybe TextV
              , _bgbox1       :: Maybe TextV
              , _bgbox2       :: Maybe TextV
              }
           --              <bg-image> || <position> [ / <bg-size> ]? || <repeat-style> || <attachment> || <box> || <box> || <'background-color'>
           | FinalBgLayer (Maybe Value) (Maybe Position) (Maybe BgSize) (Maybe RepeatStyle) (Maybe TextV) (Maybe TextV) (Maybe TextV) (Maybe Color)
           -- [ none | <single-transition-property> ] || <time> || <single-transition-timing-function> || <time>
           | SingleTransition
              { _transitionproperty :: Maybe TextV
              , _time1 :: Maybe Time
              , _transitiontimingfunction :: Maybe TimingFunction
              , _time2 :: Maybe Time
              }
           --                         <time> || <timing-function> || <time> || <iteration-count> || <animation-direction> || <animation-fill-mode> || <animation-play-state> || [ none | <keyframes-name> ]
           | SingleAnimation (Maybe Time) (Maybe TimingFunction) (Maybe Time) (Maybe Value)  (Maybe TextV) (Maybe TextV) (Maybe TextV) (Maybe Value)
           -- [ [ <'font-style'> || <font-variant-css21> || <'font-weight'> || <'font-stretch'> ]? <'font-size'> [ / <'line-height'> ]? <'font-family'> ] |
           | FontV (Maybe TextV) (Maybe TextV) (Maybe Value) (Maybe TextV) Value (Maybe Value) [Value]
           | StringV StringType
           | UrlV Url
           | Format [StringType]
           | Local (Either Text StringType)
           | Rect Length Length Length Length -- Should be in <shape>, but that accepts only rect()
           | Other TextV -- ^ Unrecognized text
  deriving (Eq, Show)

-- | Redefines equality to be case-insensitive, since CSS literal values such as
-- "auto", "none", etc. are so.
newtype TextV = TextV { getText :: Text }
  deriving (Show, Ord, IsString)

instance Eq TextV where
  TextV t1 == TextV t2 = T.toLower t1 == T.toLower t2
instance ToText TextV where
  toText = getText

mkOther :: Text -> Value
mkOther = Other . TextV

-- A <https://drafts.csswg.org/css-values-3/#urls \<url\>> value, which can
-- contain either a CSS <https://drafts.csswg.org/css-values-3/#string-value \<string\>>
-- (i.e. text surrounded by single or double quotes), or an unquoted string.
newtype Url = Url (Either Text StringType)
  deriving (Eq, Show)
instance ToText Url where
  toBuilder (Url x) = "url(" <> toBuilder x <> singleton ')'
instance Minifiable Url where
  minify u@(Url x) = do
      conf <- ask
      pure $ if shouldRemoveQuotes conf
                then Url $ either Left unquoteUrl x
                else u

instance ToText Value where
  toBuilder Initial         = "initial"
  toBuilder Inherit         = "inherit"
  toBuilder Unset           = "unset"
  toBuilder (NumberV n)     = toBuilder n
  toBuilder (PercentageV p) = (fromText . toText) p
  toBuilder (ColorV c)      = toBuilder c
  toBuilder (LengthV d)     = toBuilder d
  toBuilder (AngleV a)      = toBuilder a
  toBuilder (TimeV d)       = toBuilder d
  toBuilder (FrequencyV f)  = toBuilder f
  toBuilder (ResolutionV r) = toBuilder r
  toBuilder (FilterV f)     = toBuilder f
  toBuilder (ShadowV s)     = toBuilder s
  toBuilder (StringV s)     = toBuilder s
  toBuilder (Other t)       = fromText (getText t)
  toBuilder (UrlV u)        = toBuilder u
  toBuilder (GenericFunc n vs) = toBuilder n <> singleton '(' <> toBuilder vs <> singleton ')'
  toBuilder (Local x)       = "local(" <> toBuilder x <> singleton ')'
  toBuilder (Format x)      = "format(" <> formatString <> singleton ')'
    where formatString = mconcatIntersperse id (singleton ',') (fmap toBuilder x)
  toBuilder (GradientV t g) = fromText t <> singleton '(' <> toBuilder g <> singleton ')'
  toBuilder (TransformV x)  = toBuilder x
  toBuilder (TimingFuncV x) = toBuilder x
  toBuilder (Rect a b c d)  = "rect(" <> funcValues <> singleton ')'
    where funcValues = mconcatIntersperse toBuilder (singleton ',') [a, b, c, d]
  toBuilder (PositionV p)   = toBuilder p
  toBuilder (RepeatStyleV r) = toBuilder r
  toBuilder (BorderRadiusV b) = toBuilder b
  toBuilder (BasicShapeV b)   = toBuilder b
  toBuilder (BgSizeV b)     = toBuilder b
  toBuilder (BgLayer a b c d e f g) =
      let sz  = maybe mempty (\x -> singleton '/' <> toBuilder x) c
          list = catMaybes [bld a, bld d, bld e, bld f, bld g]
      in if null list
            then maybe mempty toBuilder b <> sz
            else mconcatIntersperse id (singleton ' ') list <> maybe mempty (\x -> singleton ' ' <> toBuilder x) b <> sz
  toBuilder (FinalBgLayer a b c d e f g col) =
      let sz  = maybe mempty (\x -> singleton '/' <> toBuilder x) c
          list = catMaybes [bld a, bld d, bld e, bld f, bld g]
      in if null list
            then let posAndSize = maybe mempty toBuilder b <> sz
                 in if mempty == posAndSize
                       then maybe mempty toBuilder col
                       else posAndSize <> spacePrefixed col
            else mconcatIntersperse id (singleton ' ') list <> spacePrefixed b <> sz <> spacePrefixed col
    where spacePrefixed :: ToText a => Maybe a -> Builder
          spacePrefixed = maybe mempty (\x -> singleton ' ' <> toBuilder x)
  toBuilder (SingleTransition prop t1 tf t2) =
      mconcatIntersperse id (singleton ' ') $ catMaybes [bld tf, bld t1, bld t2, bld prop]
  toBuilder (SingleAnimation t1 tf t2 ic ad af ap kf) =
      let list = catMaybes [bld t1, bld t2, bld tf, bld ic, bld ad, bld af, bld ap, bld kf]
      in mconcatIntersperse id (singleton ' ') list
  toBuilder (FontV fsty fvar fwgt fstr fsz lh ff) =
      let bldLh = maybe mempty (\x -> singleton '/' <> toBuilder x) lh
          list  = catMaybes [bld fsty, bld fvar, bld fwgt, bld fstr]
          ffam  = singleton ' ' <> mconcatIntersperse toBuilder (singleton ',') ff
      in if null list
            then toBuilder fsz <> bldLh <> ffam
            else mconcatIntersperse id (singleton ' ') list <> singleton ' ' <> toBuilder fsz <> bldLh <> ffam
  toBuilder (ShadowText l1 l2 ml mc) =
      let maybeToBuilder :: ToText a => Maybe a -> Builder
          maybeToBuilder = maybe mempty (\x -> singleton ' ' <> toBuilder x)
      in toBuilder l1 <> singleton ' ' <> toBuilder l2
       <> maybeToBuilder ml <> maybeToBuilder mc

instance Minifiable Value where
  minify (ColorV c)        = ColorV <$> minify c
  minify (LengthV d)       = LengthV <$> minify d
  minify (AngleV a)        = AngleV <$> minify a
  minify (TimeV d)         = TimeV <$> minify d
  minify (FrequencyV f)    = FrequencyV <$> minify f
  minify (ResolutionV r)   = ResolutionV <$> minify r
  minify (GradientV t g)   = GradientV t <$> minify g
  minify (FilterV f)       = FilterV <$> minify f
  minify (TransformV tf)   = TransformV <$> minify tf
  minify (TimingFuncV tf)  = TimingFuncV <$> minify tf
  minify (StringV s)       = StringV <$> minify s
  minify (UrlV u)          = UrlV <$> minify u
  minify (Format x)        = Format <$> mapM minify x
  minify (PositionV p)     = PositionV <$> minify p
  minify (RepeatStyleV r)  = RepeatStyleV <$> minify r
  minify (BgSizeV b)       = BgSizeV <$> minify b
  minify (BasicShapeV b)    = BasicShapeV <$> minify b
  minify (BorderRadiusV b) = BorderRadiusV <$> minify b
  minify (ShadowV s)      = ShadowV <$> minify s
  minify (ShadowText l1 l2 ml mc) = minifyPseudoShadow ShadowText l1 l2 ml mc
  minify (BgLayer img pos sz rst att b1 b2) = do
      -- conf <- ask
      (i,s,p,r,a) <- minifyBgLayer img pos sz rst att
      (bgOrigin, bgClip) <- handleBoxes b1 b2
      pure $ if isNothing i && isNothing p && isNothing s && isNothing r
                && isNothing a && isNothing bgOrigin && isNothing bgClip
                -- Shortest would be a '0 0' position, but 'none' compresses
                -- better because it is more frequent.
                then BgLayer (Just $ mkOther "none") p s r a bgOrigin bgClip
                else BgLayer i p s r a bgOrigin bgClip
  minify (FinalBgLayer img pos sz rst att b1 b2 col) = do
      -- conf <- ask
      (i,s,p,r,a) <- minifyBgLayer img pos sz rst att
      c <- handleColor col
      (bgOrigin, bgClip) <- handleBoxes b1 b2
      pure $ if isNothing i && isNothing p && isNothing s && isNothing r
                && isNothing a && isNothing bgOrigin && isNothing bgClip && isNothing c
                -- Shortest would be a '0 0' position, but 'none' compresses
                -- better because it is more frequent.
                then FinalBgLayer (Just $ mkOther "none") p s r a bgOrigin bgClip c
                else FinalBgLayer i p s r a bgOrigin bgClip c
  minify (SingleTransition prop tdur tf tdel) = do
      let p = if prop == Just "all"
                 then Nothing
                 else prop -- TODO lowercase here
      (tTime, tDelay) <- handleTime tdur tdel
      tfunc           <- handleTimingFunction tf
      pure $ if isNothing p && isNothing tTime && isNothing tDelay && isNothing tfunc
                then SingleTransition p (Just $ Time 0 S) tfunc tDelay
                else SingleTransition p tTime tfunc tDelay
  minify (SingleAnimation t1 tf t2 ic ad af ap kf) = do
      (tdur, tdel) <- handleTime t1 t2
      tfunc        <- handleTimingFunction tf
      icount       <- handleIterationCount ic
      (kfrms, adir, afm, p) <- handleKeywords kf ad af ap
      if isNothing tdur && isNothing tdel && isNothing tfunc && isNothing
         icount && isNothing kfrms && isNothing adir && isNothing afm && isNothing p
         then pure $ SingleAnimation tdur tfunc tdel (Just $ NumberV 1) adir afm p kfrms
         else pure $ SingleAnimation tdur tfunc tdel icount adir afm p kfrms
    where handleIterationCount :: Maybe Value -> Reader Config (Maybe Value)
          handleIterationCount Nothing  = pure Nothing
          handleIterationCount (Just x) =
              case x of
              NumberV 1 -> pure Nothing
              _         -> pure (Just x)
          handleKeywords Nothing x y z = pure (Nothing, simplifyDirection x, simplifyFillMode y, simplifyPauseState z)
          handleKeywords v@(Just w) x y z
              | w `elem` fmap mkOther ["normal", "reverse", "alternate", "alternate-reverse"] =
                  pure (Just w, x, simplifyFillMode y, simplifyPauseState z)
              | w == mkOther "none" && v == (Other <$> y) =
                  pure (Nothing, simplifyDirection x, Nothing, simplifyPauseState z)
              | w `elem` fmap mkOther ["forwards", "backwards", "both"] =
                  pure (Just w, simplifyDirection x, y, simplifyPauseState z)
              | w `elem` fmap mkOther ["running", "paused"] =
                  pure (Just w, simplifyDirection x, simplifyFillMode y, z)
              | otherwise = pure (Just w, simplifyDirection x, simplifyFillMode y, simplifyPauseState z)
          simplifyDirection  = removeIfEqualTo "normal"
          simplifyPauseState = removeIfEqualTo "running"
          simplifyFillMode   = removeIfEqualTo "none"
  minify (FontV fsty fvar fwgt fstr fsz lh ff) = do
      let sty = removeIfEqualTo "normal" fsty
          var = removeIfEqualTo "normal" fvar
          str = removeIfEqualTo "normal" fstr
      wgt <- optimizeFontWeight fwgt
      sz  <- minify fsz
      l   <- optimizeLineHeight lh
      fam <- traverse optimizeFontFamily ff
      pure $ FontV sty var wgt str sz l fam
    where optimizeFontWeight :: Maybe Value -> Reader Config (Maybe Value)
          optimizeFontWeight Nothing = pure Nothing
          optimizeFontWeight (Just x) = do
              conf <- ask
              pure $ replaceForSynonym (fontweightSettings conf) x
            where replaceForSynonym s (Other t)
                    | t == "normal"                       = Nothing
                    | t == "bold" && s == FontWeightMinOn = Just $ NumberV 700
                    | otherwise                           = Just $ Other t
                  replaceForSynonym _ (NumberV 400) = Nothing
                  replaceForSynonym _ y = Just y
          optimizeLineHeight Nothing                 = pure Nothing
          optimizeLineHeight (Just (Other "normal")) = pure Nothing
          optimizeLineHeight (Just x)                = Just <$> minify x

  minify (GenericFunc n vs) = GenericFunc n <$> minify vs
  minify (Local x) = do
      conf <- ask
      v <- lowercaseParameters x
      pure . Local $ if shouldRemoveQuotes conf
                        then case v of
                               Right s -> unquoteFontFamily s
                               _       -> v
                        else v
    where lowercaseParameters :: Either Text StringType -> Reader Config (Either Text StringType)
          lowercaseParameters y = do
            conf <- ask
            case letterCase conf of
              Lowercase -> case y of
                             Left  a -> mapReader Left $ lowercaseText a
                             Right b -> mapReader Right $ mapString lowercaseText b >>= minify
              Original  -> pure y
  minify x = pure x

handleRepeatStyle :: Maybe RepeatStyle -> Reader Config (Maybe RepeatStyle)
handleRepeatStyle (Just x)
    | x == RepeatStyle1 RsRepeat = pure Nothing
    | otherwise                  = Just <$> minify x
handleRepeatStyle Nothing = pure Nothing

handleImage :: Maybe Value -> Reader Config (Maybe Value)
handleImage (Just x)
    | x == Other "none" = pure Nothing
    | otherwise         = Just <$> minify x
handleImage Nothing = pure Nothing

handleBoxes :: Maybe TextV -> Maybe TextV -> Reader Config (Maybe TextV, Maybe TextV)
handleBoxes (Just o) (Just c)
    | o == c = pure (Just o, Nothing) -- TODO need lowercasing here too.
    | o == "padding-box" && c == "border-box" = pure (Nothing, Nothing)
    | otherwise = pure (Just o, Just c)
handleBoxes x y = pure (x, y)

handleAttachment :: Maybe TextV -> Reader Config (Maybe TextV)
handleAttachment = maybe (pure Nothing) f
  where f x = pure $ if x == "scroll"
                        then Nothing
                        else Just x -- TODO might need to lowercase here.

handleColor :: Maybe Color -> Reader Config (Maybe Color)
handleColor = maybe (pure Nothing) f
  where f x = if x == Named "transparent"
                 then pure Nothing
                 else Just <$> minify x

handleBgSize :: Maybe BgSize -> Reader Config (Maybe BgSize)
handleBgSize (Just b) = do
    minb <- minify b
    pure $ if minb == BgSize1 (Right Auto)
              then Nothing
              else Just minb
handleBgSize x = pure x

handlePosition :: Bool -> Maybe Position -> Reader Config (Maybe Position)
handlePosition _ Nothing = pure Nothing
handlePosition cannotRemovePos (Just p)
    | cannotRemovePos = Just <$> minify p
    | otherwise    = do
        -- conf <- ask
        mp   <- minify p
        pure $ if mp == Position Nothing l0 Nothing l0
                  then Nothing
                  else Just $ if True {- shouldMinifyPosition conf -}
                                 then mp
                                 else p

-- Represents a list of values, an the separators used between them.
data Values = Values Value [(Separator, Value)]
  deriving (Show, Eq)
instance ToText Values where
  toBuilder (Values v vs) = toBuilder v <> foldr f mempty vs
    where f (sep, val) z = toBuilder sep <> toBuilder val <> z
instance Minifiable Values where
  minify (Values v vs) = do
      newV  <- minify v
      newVs <- (mapM . mapM) minify vs
      pure $ Values newV newVs

-- | A value separator.
data Separator = Space | Slash | Comma
  deriving (Show, Eq)
instance ToText Separator where
  toText Space = " "
  toText Comma = ","
  toText Slash = "/" -- Used, for example, by font to separate font-size and line-height

valuesToList :: Values -> [Value]
valuesToList (Values v vs) = v : map snd vs

lowercaseText :: Text -> Reader Config Text
lowercaseText t = do
    conf <- ask
    pure $ case letterCase conf of
             Lowercase -> T.toLower t
             Original  -> t

-- Used to rewrap a list of values into the Values data type.
-- Only call it with non-empty lists!
mkValues :: [Value] -> Values
mkValues (x:xs) = Values x (zip (repeat Space) xs)
mkValues [ ]    = error "An empty list of values isn't valid"

bld :: ToText a => Maybe a -> Maybe Builder
bld = fmap toBuilder

-- Used for SingleAnimation and SingleTransition minification.
handleTimingFunction :: Maybe TimingFunction -> Reader Config (Maybe TimingFunction)
handleTimingFunction Nothing = pure Nothing
handleTimingFunction (Just tfunc)
    | tfunc == Ease = pure Nothing
    | otherwise = Just <$> minify tfunc

-- Used for SingleAnimation and SingleTransition minification.
handleTime :: Maybe Time -> Maybe Time -> Reader Config (Maybe Time, Maybe Time)
handleTime (Just t) Nothing
    | t == Time 0 S = pure (Nothing, Nothing)
    | otherwise     = mzip (Just <$> minify t) (pure Nothing)
handleTime (Just t1) (Just t2)
    | t1 == Time 0 S = if t2 == t1
                          then pure (Nothing, Nothing)
                          else do newT2 <- minify t2
                                  newT1 <- minify t1
                                  pure (Just newT1, Just newT2)
    | otherwise = do newT1 <- minify t1
                     if t2 == Time 0 S
                        then pure (Just t1, Nothing)
                        else do newT2 <- minify t2
                                pure (Just newT1, Just newT2)
handleTime _ _ = pure (Nothing, Nothing)

removeIfEqualTo :: Text -> Maybe TextV -> Maybe TextV
removeIfEqualTo _ Nothing = Nothing
removeIfEqualTo s (Just x)
    | x == TextV s = Nothing
    | otherwise    = Just x

-- Unquotes font family names when possible
optimizeFontFamily :: Value -> Reader Config Value
optimizeFontFamily (Other t)   = mkOther <$> lowercaseText (getText t)
optimizeFontFamily (StringV s) = do
    conf <- ask
    ffamily <- mapString lowercaseText s
    pure $ if shouldRemoveQuotes conf
              then either mkOther StringV (unquoteFontFamily ffamily)
              else StringV ffamily
optimizeFontFamily x = pure x

minifyBgLayer :: Maybe Value -> Maybe Position -> Maybe BgSize
              -> Maybe RepeatStyle -> Maybe TextV
              -> Reader Config (Maybe Value, Maybe BgSize, Maybe Position, Maybe RepeatStyle, Maybe TextV)
minifyBgLayer img pos sz rst att = do
      i <- handleImage img
      s <- handleBgSize sz
      p <- let cannotRemovePos = isJust s -- can only be removed if there is no later <bg-size>
           in handlePosition cannotRemovePos pos
      r <- handleRepeatStyle rst
      a <- handleAttachment att
      pure (i,s,p,r,a)