{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Codec.Xlsx.Types.DataValidation where

import Control.DeepSeq (NFData)
import Control.Lens.TH (makeLenses)
import Control.Monad ((>=>))
import Data.ByteString (ByteString)
import Data.Char (isSpace)
import Data.Default
import qualified Data.Map as M
import Data.Maybe (catMaybes, maybeToList)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Text.XML (Element(..), Node(..))
import Text.XML.Cursor (Cursor, ($/), element)

import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Writer.Internal

-- See 18.18.20 "ST_DataValidationOperator (Data Validation Operator)" (p. 2439/2449)
data ValidationExpression
    = ValBetween Formula Formula    -- ^ "Between" operator
    | ValEqual Formula              -- ^ "Equal to" operator
    | ValGreaterThan Formula        -- ^ "Greater than" operator
    | ValGreaterThanOrEqual Formula -- ^ "Greater than or equal to" operator
    | ValLessThan Formula           -- ^ "Less than" operator
    | ValLessThanOrEqual Formula    -- ^ "Less than or equal to" operator
    | ValNotBetween Formula Formula -- ^ "Not between" operator
    | ValNotEqual Formula           -- ^ "Not equal to" operator
    deriving (Eq, Show, Generic)
instance NFData ValidationExpression

-- See 18.18.21 "ST_DataValidationType (Data Validation Type)" (p. 2440/2450)
data ValidationType
    = ValidationTypeNone
    | ValidationTypeCustom     Formula
    | ValidationTypeDate       ValidationExpression
    | ValidationTypeDecimal    ValidationExpression
    | ValidationTypeList       [Text]
    | ValidationTypeTextLength ValidationExpression
    | ValidationTypeTime       ValidationExpression
    | ValidationTypeWhole      ValidationExpression
    deriving (Eq, Show, Generic)
instance NFData ValidationType

-- See 18.18.18 "ST_DataValidationErrorStyle (Data Validation Error Styles)" (p. 2438/2448)
data ErrorStyle
    = ErrorStyleInformation
    | ErrorStyleStop
    | ErrorStyleWarning
    deriving (Eq, Show, Generic)
instance NFData ErrorStyle

-- See 18.3.1.32 "dataValidation (Data Validation)" (p. 1614/1624)
data DataValidation = DataValidation
    { _dvAllowBlank       :: Bool
    , _dvError            :: Maybe Text
    , _dvErrorStyle       :: ErrorStyle
    , _dvErrorTitle       :: Maybe Text
    , _dvPrompt           :: Maybe Text
    , _dvPromptTitle      :: Maybe Text
    , _dvShowDropDown     :: Bool
    , _dvShowErrorMessage :: Bool
    , _dvShowInputMessage :: Bool
    , _dvValidationType   :: ValidationType
    } deriving (Eq, Show, Generic)
instance NFData DataValidation

makeLenses ''DataValidation

instance Default DataValidation where
    def = DataValidation
      False Nothing ErrorStyleStop Nothing Nothing Nothing False False False ValidationTypeNone

{-------------------------------------------------------------------------------
  Parsing
-------------------------------------------------------------------------------}

instance FromAttrVal ErrorStyle where
    fromAttrVal "information" = readSuccess ErrorStyleInformation
    fromAttrVal "stop"        = readSuccess ErrorStyleStop
    fromAttrVal "warning"     = readSuccess ErrorStyleWarning
    fromAttrVal t             = invalidText "ErrorStyle" t

instance FromAttrBs ErrorStyle where
    fromAttrBs "information" = return ErrorStyleInformation
    fromAttrBs "stop"        = return ErrorStyleStop
    fromAttrBs "warning"     = return ErrorStyleWarning
    fromAttrBs x             = unexpectedAttrBs "ErrorStyle" x

instance FromCursor DataValidation where
    fromCursor cur = do
        _dvAllowBlank       <- fromAttributeDef "allowBlank"       False          cur
        _dvError            <- maybeAttribute   "error"                           cur
        _dvErrorStyle       <- fromAttributeDef "errorStyle"       ErrorStyleStop cur
        _dvErrorTitle       <- maybeAttribute   "errorTitle"                      cur
        mop                 <- fromAttributeDef "operator"         "between"      cur
        _dvPrompt           <- maybeAttribute   "prompt"                          cur
        _dvPromptTitle      <- maybeAttribute   "promptTitle"                     cur
        _dvShowDropDown     <- fromAttributeDef "showDropDown"     False          cur
        _dvShowErrorMessage <- fromAttributeDef "showErrorMessage" False          cur
        _dvShowInputMessage <- fromAttributeDef "showInputMessage" False          cur
        mtype               <- fromAttributeDef "type"             "none"         cur
        _dvValidationType   <- readValidationType mop mtype                       cur
        return DataValidation{..}

instance FromXenoNode DataValidation where
  fromXenoNode root = do
    (op, atype, genDV) <- parseAttributes root $ do
      _dvAllowBlank <- fromAttrDef "allowBlank" False
      _dvError <- maybeAttr "error"
      _dvErrorStyle <- fromAttrDef "errorStyle" ErrorStyleStop
      _dvErrorTitle <- maybeAttr "errorTitle"
      _dvPrompt <- maybeAttr "prompt"
      _dvPromptTitle <- maybeAttr "promptTitle"
      _dvShowDropDown <- fromAttrDef "showDropDown" False
      _dvShowErrorMessage <- fromAttrDef "showErrorMessage" False
      _dvShowInputMessage <- fromAttrDef "showInputMessage" False
      op <- fromAttrDef "operator" "between"
      typ <- fromAttrDef "type" "none"
      return (op, typ, \_dvValidationType -> DataValidation {..})
    valType <- parseValidationType op atype
    return $ genDV valType
    where
      parseValidationType :: ByteString -> ByteString -> Either Text ValidationType
      parseValidationType op atype =
        case atype of
          "none" -> return ValidationTypeNone
          "custom" ->
            ValidationTypeCustom <$> formula1
          "list" -> do
            f <- formula1
            case readListFormulas f of
              Nothing -> Left "validation of type \"list\" with empty formula list"
              Just fs -> return $ ValidationTypeList fs
          "date" ->
            ValidationTypeDate <$> readOpExpression op
          "decimal"    ->
            ValidationTypeDecimal <$> readOpExpression op
          "textLength" ->
            ValidationTypeTextLength <$> readOpExpression op
          "time"       ->
            ValidationTypeTime <$> readOpExpression op
          "whole"      ->
            ValidationTypeWhole <$> readOpExpression op
          unexpected ->
            Left $ "unexpected type of data validation " <> T.pack (show unexpected)
      readOpExpression "between" = uncurry ValBetween <$> formulaPair
      readOpExpression "notBetween" = uncurry ValNotBetween <$> formulaPair
      readOpExpression "equal" = ValEqual <$> formula1
      readOpExpression "greaterThan" = ValGreaterThan <$> formula1
      readOpExpression "greaterThanOrEqual" = ValGreaterThanOrEqual <$> formula1
      readOpExpression "lessThan" = ValLessThan <$> formula1
      readOpExpression "lessThanOrEqual" = ValLessThanOrEqual <$> formula1
      readOpExpression "notEqual" = ValNotEqual <$> formula1
      readOpExpression op = Left $ "data validation, unexpected operator " <> T.pack (show op)
      formula1 = collectChildren root $ fromChild "formula1"
      formulaPair =
        collectChildren root $ (,) <$> fromChild "formula1" <*> fromChild "formula2"

readValidationType :: Text -> Text -> Cursor -> [ValidationType]
readValidationType _ "none"   _   = return ValidationTypeNone
readValidationType _ "custom" cur = do
    f <- fromCursor cur
    return $ ValidationTypeCustom f
readValidationType _ "list" cur = do
    f  <- cur $/ element (n_ "formula1") >=> fromCursor
    as <- maybeToList $ readListFormulas f
    return $ ValidationTypeList as
readValidationType op ty cur = do
    opExp <- readOpExpression2 op cur
    readValidationTypeOpExp ty opExp

readListFormulas :: Formula -> Maybe [Text]
readListFormulas (Formula f) = readQuotedList f
  where
    readQuotedList t
        | Just t'  <- T.stripPrefix "\"" (T.dropAround isSpace t)
        , Just t'' <- T.stripSuffix "\"" t'
        = Just $ map (T.dropAround isSpace) $ T.splitOn "," t''
        | otherwise = Nothing
  -- This parser expects a comma-separated list surrounded by quotation marks.
  -- Spaces around the quotation marks and commas are removed, but inner spaces
  -- are kept.
  --
  -- The parser seems to be consistent with how Excel treats list formulas, but
  -- I wasn't able to find a specification of the format.

readOpExpression2 :: Text -> Cursor -> [ValidationExpression]
readOpExpression2 op cur
    | op `elem` ["between", "notBetween"] = do
        f1 <- cur $/ element (n_ "formula1") >=> fromCursor
        f2 <- cur $/ element (n_ "formula2") >=> fromCursor
        readValExpression op [f1,f2]
readOpExpression2 op cur = do
    f <- cur $/ element (n_ "formula1") >=> fromCursor
    readValExpression op [f]

readValidationTypeOpExp :: Text -> ValidationExpression -> [ValidationType]
readValidationTypeOpExp "date"       oe = [ValidationTypeDate       oe]
readValidationTypeOpExp "decimal"    oe = [ValidationTypeDecimal    oe]
readValidationTypeOpExp "textLength" oe = [ValidationTypeTextLength oe]
readValidationTypeOpExp "time"       oe = [ValidationTypeTime       oe]
readValidationTypeOpExp "whole"      oe = [ValidationTypeWhole      oe]
readValidationTypeOpExp _ _             = []

readValExpression :: Text -> [Formula] -> [ValidationExpression]
readValExpression "between" [f1, f2]       = [ValBetween f1 f2]
readValExpression "equal" [f]              = [ValEqual f]
readValExpression "greaterThan" [f]        = [ValGreaterThan f]
readValExpression "greaterThanOrEqual" [f] = [ValGreaterThanOrEqual f]
readValExpression "lessThan" [f]           = [ValLessThan f]
readValExpression "lessThanOrEqual" [f]    = [ValLessThanOrEqual f]
readValExpression "notBetween" [f1, f2]    = [ValNotBetween f1 f2]
readValExpression "notEqual" [f]           = [ValNotEqual f]
readValExpression _ _                      = []

{-------------------------------------------------------------------------------
  Rendering
-------------------------------------------------------------------------------}

instance ToAttrVal ValidationType where
    toAttrVal ValidationTypeNone           = "none"
    toAttrVal (ValidationTypeCustom _)     = "custom"
    toAttrVal (ValidationTypeDate _)       = "date"
    toAttrVal (ValidationTypeDecimal _)    = "decimal"
    toAttrVal (ValidationTypeList _)       = "list"
    toAttrVal (ValidationTypeTextLength _) = "textLength"
    toAttrVal (ValidationTypeTime _)       = "time"
    toAttrVal (ValidationTypeWhole _)      = "whole"

instance ToAttrVal ErrorStyle where
    toAttrVal ErrorStyleInformation = "information"
    toAttrVal ErrorStyleStop        = "stop"
    toAttrVal ErrorStyleWarning     = "warning"

instance ToElement DataValidation where
    toElement nm DataValidation{..} = Element
        { elementName       = nm
        , elementAttributes = M.fromList . catMaybes $
            [ Just $ "allowBlank"       .=  _dvAllowBlank
            ,        "error"            .=? _dvError
            , Just $ "errorStyle"       .=  _dvErrorStyle
            ,        "errorTitle"       .=? _dvErrorTitle
            ,        "operator"         .=? op
            ,        "prompt"           .=? _dvPrompt
            ,        "promptTitle"      .=? _dvPromptTitle
            , Just $ "showDropDown"     .=  _dvShowDropDown
            , Just $ "showErrorMessage" .=  _dvShowErrorMessage
            , Just $ "showInputMessage" .=  _dvShowInputMessage
            , Just $ "type"             .=  _dvValidationType
            ]
        , elementNodes      = catMaybes
            [ fmap (NodeElement . toElement "formula1") f1
            , fmap (NodeElement . toElement "formula2") f2
            ]
        }
      where
        opExp (o,f1',f2') = (Just o, Just f1', f2')

        op    :: Maybe Text
        f1,f2 :: Maybe Formula
        (op,f1,f2) = case _dvValidationType of
          ValidationTypeNone         -> (Nothing, Nothing, Nothing)
          ValidationTypeCustom f     -> (Nothing, Just f, Nothing)
          ValidationTypeDate f       -> opExp $ viewValidationExpression f
          ValidationTypeDecimal f    -> opExp $ viewValidationExpression f
          ValidationTypeTextLength f -> opExp $ viewValidationExpression f
          ValidationTypeTime f       -> opExp $ viewValidationExpression f
          ValidationTypeWhole f      -> opExp $ viewValidationExpression f
          ValidationTypeList as      ->
            let f = Formula $ "\"" <> T.intercalate "," as <> "\""
            in  (Nothing, Just f, Nothing)

viewValidationExpression :: ValidationExpression -> (Text, Formula, Maybe Formula)
viewValidationExpression (ValBetween f1 f2)         = ("between",            f1, Just f2)
viewValidationExpression (ValEqual f)               = ("equal",              f,  Nothing)
viewValidationExpression (ValGreaterThan f)         = ("greaterThan",        f,  Nothing)
viewValidationExpression (ValGreaterThanOrEqual f)  = ("greaterThanOrEqual", f,  Nothing)
viewValidationExpression (ValLessThan f)            = ("lessThan",           f,  Nothing)
viewValidationExpression (ValLessThanOrEqual f)     = ("lessThanOrEqual",    f,  Nothing)
viewValidationExpression (ValNotBetween f1 f2)      = ("notBetween",         f1, Just f2)
viewValidationExpression (ValNotEqual f)            = ("notEqual",           f,  Nothing)