{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module      : Network.Reddit.Types.Widget
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
module Network.Reddit.Types.Widget
    ( SubredditWidgets(..)
    , Widget(..)
    , WidgetID(WidgetID)
    , WidgetSection(..)
    , ShortName
    , mkShortName
    , WidgetList
    , WidgetStyles(..)
      -- * Individual widget types
      -- | All of the widget types in this module have a @widgetID@ field
      -- with the type @Maybe WidgetID@. This field /should/ be present
      -- when fetching existing widgets, but should be left as @Nothing@
      -- if creating a new widget
    , ButtonWidget(..)
    , Button(..)
    , ButtonImage(..)
    , ButtonText(..)
    , ButtonHover(..)
    , ImageHover(..)
    , TextHover(..)
    , CalendarWidget(..)
    , CalendarConfig(..)
    , defaultCalendarConfig
    , CommunityListWidget(..)
    , CommunityInfo(..)
    , mkCommunityInfo
    , CustomWidget(..)
    , ImageData(..)
    , IDCardWidget(..)
    , ImageWidget(..)
    , Image(..)
    , MenuWidget(..)
    , MenuChild(..)
    , MenuLink(..)
    , Submenu(..)
    , ModeratorsWidget(..)
    , ModInfo(..)
    , PostFlairWidget(..)
    , mkPostFlairWidget
    , PostFlairInfo(..)
    , PostFlairWidgetDisplay(..)
    , RulesWidget(..)
    , RulesDisplay(..)
    , TextAreaWidget(..)
    , mkTextAreaWidget
    ) where

import           Control.Applicative            ( optional )
import           Control.Monad                  ( guard )
import           Control.Monad.Catch            ( MonadThrow(throwM) )

import           Data.Aeson
                 ( (.:)
                 , (.:?)
                 , FromJSON(..)
                 , GToJSON'
                 , KeyValue((.=))
                 , Object
                 , Options(..)
                 , SumEncoding(UntaggedValue)
                 , ToJSON
                 , ToJSON(..)
                 , Value(..)
                 , Zero
                 , defaultOptions
                 , genericParseJSON
                 , genericToJSON
                 , object
                 , withObject
                 , withText
                 )
import           Data.Aeson.Types               ( Parser )
import           Data.Coerce                    ( coerce )
import qualified Data.HashMap.Strict            as HM
import           Data.HashMap.Strict            ( HashMap )
import           Data.Maybe
                 ( catMaybes
                 , fromMaybe
                 , mapMaybe
                 )
import           Data.Sequence                  ( Seq )
import           Data.Text                      ( Text )
import qualified Data.Text                      as T

import           GHC.Exts                       ( IsList(fromList) )
import           GHC.Generics                   ( Generic(Rep) )

import           Lens.Micro

import           Network.Reddit.Types.Flair
import           Network.Reddit.Types.Internal
import           Network.Reddit.Types.Subreddit

import           Web.HttpApiData                ( ToHttpApiData(..)
                                                , showTextData
                                                )

-- | An organized collection of a subreddit\'s widgets
data SubredditWidgets = SubredditWidgets
    { idCard       :: IDCardWidget
    , moderators   :: ModeratorsWidget
    , topbar       :: Seq Widget
    , sidebar      :: Seq Widget
    , topbarOrder  :: Seq WidgetID
    , sidebarOrder :: Seq WidgetID
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON SubredditWidgets where
    parseJSON = withObject "SubredditWidgets" $ \o -> do
        items :: Object <- o .: "items"
        layout <- o .: "layout"

        let lookupWidget :: FromJSON b => Text -> Parser b
            lookupWidget fld = maybe mempty parseJSON . (`HM.lookup` items)
                =<< layout .: fld

            lookupWidgets fld = fmap fromList
                . traverse parseJSON
                . mapMaybe (`HM.lookup` items)
                =<< (.: "order")
                =<< layout .: fld

        idCard <- lookupWidget "idCardWidget"
        moderators <- lookupWidget "moderatorWidget"
        topbar <- lookupWidgets "topbar"
        sidebar <- lookupWidgets "sidebar"
        topbarOrder <- (.: "order") =<< layout .: "topbar"
        sidebarOrder <- (.: "order") =<< layout .: "sidebar"
        pure SubredditWidgets { .. }

-- | Represents one of various kinds of widgets
data Widget
    = Buttons ButtonWidget
    | Calendar CalendarWidget
    | CommunityList CommunityListWidget
    | Custom CustomWidget
    | IDCard IDCardWidget
    | Images ImageWidget
    | Moderators ModeratorsWidget
    | Menu MenuWidget
    | PostFlair PostFlairWidget
    | Rules RulesWidget
    | TextArea TextAreaWidget
    deriving stock ( Show, Eq, Generic )

instance FromJSON Widget where
    parseJSON =
        genericParseJSON defaultOptions { sumEncoding = UntaggedValue }

instance ToJSON Widget where
    toJSON = genericToJSON defaultOptions { sumEncoding = UntaggedValue }

-- | A widget ID. These are usually prefixed with the type of widget it corresponds
-- to, e.g. @rules-2qh1i@ for a 'RulesWidget'
newtype WidgetID = WidgetID Text
    deriving stock ( Show, Generic )
    deriving ( Eq ) via CIText WidgetID

instance ToHttpApiData WidgetID where
    toQueryParam (WidgetID wid) = "widget_" <> wid

instance FromJSON WidgetID where
    parseJSON = withText "WidgetID" (breakOnType "widget")

instance ToJSON WidgetID where
    toJSON = String . toQueryParam

-- | The section in which certain 'Widget's appear
data WidgetSection
    = Topbar
    | Sidebar
    deriving stock ( Show, Eq, Generic )

instance ToHttpApiData WidgetSection where
    toUrlPiece = showTextData

-- | A \"short name\" for any widget. This name must be less than 30 characters
-- long
newtype ShortName = ShortName Text
    deriving stock ( Show, Generic )
    deriving newtype ( Eq, FromJSON, ToJSON )

-- | Smart constructor for 'ShortName's, which must be <= 30 characters long
mkShortName :: MonadThrow m => Text -> m ShortName
mkShortName t
    | T.length t > 30 =
        throwM $ OtherError "mkShortName: Name must be <= 30 characters long"
    | otherwise = pure $ coerce t

-- | Wrapper to parse a @HashMap WidgetID Widget@, discarding the ID keys
newtype WidgetList = WidgetList (Seq Widget)
    deriving stock ( Show, Generic )

instance FromJSON WidgetList where
    parseJSON = withObject "WidgetList" $ \o -> WidgetList
        <$> (getVals =<< o .: "items")

-- | Style options for an individual widget
data WidgetStyles = WidgetStyles
    { backgroundColor :: Maybe RGBText --
    , headerColor     :: Maybe RGBText
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON WidgetStyles where
    parseJSON = withObject "WidgetStyles" $ \o -> WidgetStyles
        <$> (maybe (pure Nothing) nothingTxtNull =<< o .: "backgroundColor")
        <*> (maybe (pure Nothing) nothingTxtNull =<< o .: "headerColor")

instance ToJSON WidgetStyles where
    toJSON = genericToJSON defaultOptions

-- | A widget containing buttons
data ButtonWidget = ButtonWidget
    { widgetID        :: Maybe WidgetID
    , shortName       :: ShortName
    , buttons         :: Seq Button
    , description     :: Body
    , descriptionHTML :: Maybe Body
    , styles          :: Maybe WidgetStyles
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON ButtonWidget where
    parseJSON = withWidgetKind ButtonType "ButtonWidget"
        $ genericParseJSON defaultOptions
                           { fieldLabelModifier = buttonWidgetModifier }

instance ToJSON ButtonWidget where
    toJSON = widgetToJSON buttonWidgetModifier ButtonType

buttonWidgetModifier :: Modifier
buttonWidgetModifier = \case
    "descriptionHTML" -> "descriptionHtml"
    s                 -> defaultWidgetModifier s

-- | An individual button in a 'ButtonWidget'
data Button
    = ImageButton ButtonImage
    | TextButton ButtonText
    deriving stock ( Show, Eq, Generic )

instance FromJSON Button where
    parseJSON =
        genericParseJSON defaultOptions { sumEncoding = UntaggedValue }

instance ToJSON Button where
    toJSON b = widgetToJSON defaultWidgetModifier buttonType b
      where
        buttonType = case b of
            ImageButton _ -> ImageType
            TextButton _  -> TextType

-- | Data for an 'ImageButton'
data ButtonImage = ButtonImage
    { text       :: ShortName
    , url        :: UploadURL
    , linkURL    :: URL
    , height     :: Int
    , width      :: Int
    , hoverState :: Maybe ButtonHover
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON ButtonImage where
    parseJSON =
        genericParseJSON defaultOptions
                         { fieldLabelModifier = imageButtonDataModifier }

instance ToJSON ButtonImage where
    toJSON = genericToJSON defaultOptions
                           { fieldLabelModifier = imageButtonDataModifier
                           , omitNothingFields  = True
                           }

imageButtonDataModifier :: Modifier
imageButtonDataModifier = \case
    "linkURL" -> "linkUrl"
    s         -> s

-- | Data for a 'TextButton'
data ButtonText = ButtonText
    { text       :: ShortName
    , url        :: URL
    , color      :: RGBText
    , fillColor  :: Maybe RGBText
    , textColor  :: Maybe RGBText
    , hoverState :: Maybe ButtonHover
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON ButtonText

instance ToJSON ButtonText where
    toJSON = genericToJSON defaultOptions { omitNothingFields = True }

-- | The state of the 'Button' when hovering over it
data ButtonHover
    = ImageButtonHover ImageHover
    | TextButtonHover TextHover
    deriving stock ( Show, Eq, Generic )

instance FromJSON ButtonHover where
    parseJSON =
        genericParseJSON defaultOptions { sumEncoding = UntaggedValue }

instance ToJSON ButtonHover where
    toJSON = genericToJSON defaultOptions { sumEncoding = UntaggedValue }

-- | The state of an 'ImageButton' when hovering over it
data ImageHover = ImageHover
    { url :: UploadURL, height :: Maybe Integer, width :: Maybe Integer }
    deriving stock ( Show, Eq, Generic )

instance FromJSON ImageHover

instance ToJSON ImageHover where
    toJSON = widgetToJSON id ImageType

-- | The state of a 'TextButton' when hovering over it
data TextHover = TextHover
    { text      :: ShortName
    , color     :: Maybe RGBText
    , fillColor :: Maybe RGBText
    , textColor :: Maybe RGBText
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON TextHover

instance ToJSON TextHover where
    toJSON = widgetToJSON id TextType

-- | A widget representing a calendar
data CalendarWidget = CalendarWidget
    { widgetID         :: Maybe WidgetID
    , shortName        :: ShortName
    , googleCalendarID :: Text
    , configuration    :: CalendarConfig
    , requiresSync     :: Bool
    , styles           :: Maybe WidgetStyles
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON CalendarWidget where
    parseJSON = withWidgetKind CalendarType "CalendarWidget"
        $ genericParseJSON defaultOptions
                           { fieldLabelModifier = calendarModifier }

instance ToJSON CalendarWidget where
    toJSON = widgetToJSON calendarModifier CalendarType

calendarModifier :: Modifier
calendarModifier = \case
    "googleCalendarID" -> "googleCalendarId"
    s                  -> defaultWidgetModifier s

-- | Configuration options for a 'CalendarWidget'
data CalendarConfig = CalendarConfig
    { -- | Between 1 and 50, defaulting to 10
      numEvents       :: Word
    , showDate        :: Bool
    , showDescription :: Bool
    , showLocation    :: Bool
    , showTime        :: Bool
    , showTitle       :: Bool
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON CalendarConfig

instance ToJSON CalendarConfig

-- | A calendar config with default values
defaultCalendarConfig :: CalendarConfig
defaultCalendarConfig = CalendarConfig
    { numEvents       = 10
    , showDate        = False
    , showDescription = False
    , showLocation    = False
    , showTime        = False
    , showTitle       = False
    }

-- | A widget listing related subreddits
data CommunityListWidget = CommunityListWidget
    { widgetID    :: Maybe WidgetID
    , shortName   :: ShortName
    , communities :: Seq CommunityInfo
    , styles      :: Maybe WidgetStyles
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON CommunityListWidget where
    parseJSON = withWidgetKind CommunityListType "CommunityListWidget"
        $ genericParseJSON defaultOptions { fieldLabelModifier }
      where
        fieldLabelModifier = \case
            "communities" -> "data"
            s             -> defaultWidgetModifier s

instance ToJSON CommunityListWidget where
    toJSON CommunityListWidget { .. } = object
        $ [ "shortName" .= shortName
            -- The @data@ field is not accepted in the same format as it is sent
          , "data" .= (communities <&> \CommunityInfo { name } -> name)
          , "kind" .= ("community-list" :: Text)
          ]
        <> foldMap pure (("styles" .=) <$> styles)

-- | Information about a single subreddit in a 'CommunityListWidget'. When
-- creating a new widget, only the @name@ field will be serialized
data CommunityInfo = CommunityInfo
    { name          :: SubredditName
    , subscribers   :: Maybe Integer
    , primaryColor  :: Maybe RGBText
    , iconURL       :: Maybe URL
    , communityIcon :: Maybe URL
      -- | If the authenticated user is subscribed to the subreddit
    , isSubscribed  :: Maybe Bool
    , isNSFW        :: Maybe Bool
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON CommunityInfo where
    parseJSON = withObject "CommunityInfo" $ \o -> CommunityInfo
        <$> o .: "name"
        <*> o .: "subscribers"
        <*> (nothingTxtNull =<< o .: "primaryColor")
        <*> (nothingTxtNull =<< o .: "iconUrl")
        <*> (nothingTxtNull =<< o .: "communityIcon")
        <*> o .: "isSubscribed"
        <*> o .:? "isNSFW"

instance ToJSON CommunityInfo where
    toJSON CommunityInfo { name } = object [ "name" .= name ]

-- | Convenience function for creating a new 'CommunityInfo', where
-- all but one of the fields should be @Nothing@
mkCommunityInfo :: SubredditName -> CommunityInfo
mkCommunityInfo name = CommunityInfo
    { name
    , subscribers   = Nothing
    , primaryColor  = Nothing
    , iconURL       = Nothing
    , communityIcon = Nothing
    , isSubscribed  = Nothing
    , isNSFW        = Nothing
    }

-- | A custom widget
data CustomWidget = CustomWidget
    { widgetID      :: Maybe WidgetID
    , shortName     :: ShortName
    , text          :: Body
    , imageData     :: Seq ImageData
      -- | Should be between 50 and 500
    , height        :: Int
      -- | Should be @Nothing@ when creating a new widget
    , textHTML      :: Maybe Body
    , css           :: Maybe Text
    , stylesheetURL :: Maybe URL
    , styles        :: Maybe WidgetStyles
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON CustomWidget where
    parseJSON = withWidgetKind CustomType "CustomWidget" customP
      where
        customP (Object o) = CustomWidget <$> o .: "id"
            <*> o .: "shortName"
            <*> o .: "text"
            <*> o .: "imageData"
            <*> o .: "height"
            <*> o .: "textHtml"
            <*> (nothingTxtNull =<< o .: "css")
            <*> o .: "stylesheetUrl"
            <*> o .: "styles"
        customP _          = mempty

instance ToJSON CustomWidget where
    toJSON CustomWidget { .. } = object
        $ [ "shortName" .= shortName
          , "text" .= text
          , "imageData" .= imageData
          , "height" .= height
            -- Reddit won't accept empty CSS, so this will prevent an error
            -- in case the @css@ field is empty
          , "css" .= fromMaybe "/**/" css
          , "kind" .= ("custom" :: Text)
          ]
        <> catMaybes [ ("stylesheetUrl" .=) <$> stylesheetURL
                     , ("styles" .=) <$> styles
                     ]

-- | Image data that belongs to a 'CustomWidget'
data ImageData = ImageData
    { name   :: Name
    , height :: Int
    , width  :: Int
      -- | This url must point to an image hosted by Reddit
    , url    :: UploadURL
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON ImageData

instance ToJSON ImageData

-- | An ID card displaying information about the subreddit
data IDCardWidget = IDCardWidget
    { widgetID              :: Maybe WidgetID
    , shortName             :: ShortName
    , description           :: Body
    , subscribersText       :: Text
    , currentlyViewingText  :: Text
    , subscribersCount      :: Maybe Integer
    , currentlyViewingCount :: Maybe Integer
    , styles                :: Maybe WidgetStyles
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON IDCardWidget where
    parseJSON = withWidgetKind IDCardType "IDCardWidget" idCardP
      where
        idCardP (Object o) = IDCardWidget <$> o .: "id"
            <*> o .: "shortName"
            -- This field is missing after updates
            <*> (fromMaybe mempty <$> optional (o .: "description"))
            <*> o .: "subscribersText"
            <*> o .: "currentlyViewingText"
            <*> o .:? "subscribersCount"
            <*> o .:? "currentlyViewingCount"
            <*> o .: "styles"
        idCardP _          = mempty

instance ToJSON IDCardWidget where
    toJSON = widgetToJSON defaultWidgetModifier IDCardType

-- | A widget composed of various 'Image's
data ImageWidget = ImageWidget
    { widgetID  :: Maybe WidgetID
    , shortName :: ShortName
    , images    :: Seq Image
    , styles    :: Maybe WidgetStyles
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON ImageWidget where
    parseJSON = withWidgetKind ImageType "ImageWidget"
        $ genericParseJSON defaultOptions
                           { fieldLabelModifier = imageWidgetModifier }

instance ToJSON ImageWidget where
    toJSON = widgetToJSON imageWidgetModifier ImageType

imageWidgetModifier :: Modifier
imageWidgetModifier = \case
    "images" -> "data"
    s        -> defaultWidgetModifier s

-- | An individual image in an 'ImageWidget'
data Image = Image
    { width   :: Integer
    , height  :: Integer
      -- | The reddit-hosted image URL
    , url     :: UploadURL
      -- | The link that is followed when clicking on the image
    , linkURL :: Maybe URL
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON Image where
    parseJSON = genericParseJSON --
        defaultOptions { fieldLabelModifier = imageModifier }

instance ToJSON Image where
    toJSON =
        genericToJSON defaultOptions { fieldLabelModifier = imageModifier }

imageModifier :: Modifier
imageModifier = \case
    "linkURL" -> "linkUrl"
    s         -> s

-- | A widget representing a menu
data MenuWidget =
    MenuWidget { widgetID :: Maybe WidgetID, children :: Seq MenuChild }
    deriving stock ( Show, Eq, Generic )

instance FromJSON MenuWidget where
    parseJSON = withWidgetKind MenuType "MenuWidget"
        $ genericParseJSON defaultOptions
                           { fieldLabelModifier = menuWidgetModifier }

instance ToJSON MenuWidget where
    toJSON = widgetToJSON menuWidgetModifier MenuType

menuWidgetModifier :: Modifier
menuWidgetModifier = \case
    "children" -> "data"
    s          -> defaultWidgetModifier s

-- | A child widget in a 'MenuWidget'
data MenuChild
    = SubmenuChild Submenu
    | MenuLinkChild MenuLink
    deriving stock ( Show, Eq, Generic )

instance FromJSON MenuChild where
    parseJSON =
        genericParseJSON defaultOptions { sumEncoding = UntaggedValue }

instance ToJSON MenuChild where
    toJSON = genericToJSON defaultOptions { sumEncoding = UntaggedValue }

-- | A submenu child in a 'MenuWidget' which contains 'MenuLink's
data Submenu = Submenu { children :: Seq MenuLink, text :: Text }
    deriving stock ( Show, Eq, Generic )

instance FromJSON Submenu

instance ToJSON Submenu

-- | A link in a 'MenuWidget' or 'Submenu'
data MenuLink = MenuLink { text :: Text, url :: URL }
    deriving stock ( Show, Eq, Generic )

instance FromJSON MenuLink

instance ToJSON MenuLink

-- | A widget listing the moderators of the subreddit. This widget cannot be
-- created. It can be updated by modifying the @styles@ field only
data ModeratorsWidget = ModeratorsWidget
    { widgetID  :: Maybe WidgetID
    , mods      :: Seq ModInfo
    , totalMods :: Maybe Int
    , styles    :: Maybe WidgetStyles
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON ModeratorsWidget where
    parseJSON = withWidgetKind ModeratorsType "ModeratorsWidget" modsP
      where
        modsP (Object o) = ModeratorsWidget <$> o .: "id"
            -- Apparently this field is occasionally missing from updated
            -- @ModeratorsWidget@s
            <*> fromOptional o "mods"
            -- This one too
            <*> optional (o .: "totalMods")
            <*> o .: "styles"
        modsP _          = mempty

instance ToJSON ModeratorsWidget where
    toJSON ModeratorsWidget { .. } = object
        $ [ "kind" .= ModeratorsType ]
        <> foldMap pure (("styles" .=) <$> styles)

-- | Information about a moderator as displayed in a 'ModeratorsWidget'
data ModInfo = ModInfo
    { name                 :: Username
    , flairText            :: Maybe FlairText
    , flairTextColor       :: Maybe ForegroundColor
    , flairBackgroundColor :: Maybe RGBText
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON ModInfo where
    parseJSON = withObject "ModInfo" $ \o -> ModInfo <$> o .: "name"
        <*> (maybe (pure Nothing) nothingTxtNull =<< o .:? "authorFlairText")
        <*> (maybe (pure Nothing) nothingTxtNull
             =<< o .:? "authorFlairTextColor")
        <*> (maybe (pure Nothing) nothingTxtNull
             =<< o .:? "authorFlairBackgroundColor")

instance ToJSON ModInfo where
    toJSON = genericToJSON defaultOptions
                           { fieldLabelModifier --
                           , omitNothingFields  = True
                           }
      where
        fieldLabelModifier = \case
            "flairText" -> "authorFlairText"
            "flairTextColor" -> "authorFlairTextColor"
            "flairBackgroundColor" -> "authorFlairBackgroundColor"
            s -> s

-- | A widget listing flair choices for submissions. When creating a new widget,
-- the 'FlairID's in the @order@ field must be valid template IDs for the given
-- subreddit. Existing flair templates can be obtained with
-- 'Network.Reddit.Subreddit.getSubmissionFlairTemplates', which can
-- then be mapped over to obtain the IDs. Once the flair IDs have been obtained,
-- 'mkPostFlairWidget' can be used to construct a widget with default values for
-- most fields
data PostFlairWidget = PostFlairWidget
    { widgetID  :: Maybe WidgetID
    , shortName :: ShortName
      -- | A container of 'FlairID's corresponding to the flair
      -- templates listed in the widget. Use this field when
      -- updating or creating 'PostFlairWidget's
    , order     :: Seq FlairID
      -- | A mapping of submission flair template IDs to
      -- brief information on each one. This field is /not/
      -- serialized when creating a new 'PostFlairWidget' or
      -- when updating an existing one, and can be left empty
      -- in those cases
    , templates :: HashMap FlairID PostFlairInfo
    , display   :: PostFlairWidgetDisplay
    , styles    :: Maybe WidgetStyles
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON PostFlairWidget where
    parseJSON = withWidgetKind PostFlairType "PostFlairWidget"
        $ genericParseJSON defaultOptions
                           { fieldLabelModifier = defaultWidgetModifier }

instance ToJSON PostFlairWidget where
    toJSON PostFlairWidget { .. } = object
        $ [ "id" .= widgetID
          , "shortName" .= shortName
          , "order" .= order
          , "display" .= display
          , "kind" .= ("post-flair" :: Text)
          ]
        <> foldMap pure (("styles" .=) <$> styles)

-- | Make a new 'PostFlairWidget' with default values for most fields
mkPostFlairWidget :: ShortName -> Seq FlairID -> PostFlairWidget
mkPostFlairWidget shortName order = PostFlairWidget
    { widgetID  = Nothing
    , templates = mempty
    , display   = ListDisplay
    , styles    = Nothing
    , ..
    }

-- | Information about submission flair templates in a 'PostFlairWidget'
data PostFlairInfo = PostFlairInfo
    { templateID      :: FlairID
    , text            :: Text
    , textColor       :: ForegroundColor
    , backgroundColor :: RGBText
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON PostFlairInfo where
    parseJSON =
        genericParseJSON defaultOptions
                         { fieldLabelModifier = postFlairInfoModifier }

postFlairInfoModifier :: Modifier
postFlairInfoModifier = \case
    "templateID" -> "templateId"
    s            -> s

-- | The display orientation for 'PostFlairWidget's
data PostFlairWidgetDisplay
    = CloudDisplay
    | ListDisplay
    deriving stock ( Show, Eq, Generic )

instance FromJSON PostFlairWidgetDisplay where
    parseJSON = genericParseJSON --
        defaultOptions { constructorTagModifier = postFlairWidgetModifier }

instance ToJSON PostFlairWidgetDisplay where
    toJSON = genericToJSON --
        defaultOptions { constructorTagModifier = postFlairWidgetModifier }

postFlairWidgetModifier :: Modifier
postFlairWidgetModifier = \case
    "CloudDisplay" -> "cloud"
    "ListDisplay"  -> "list"
    _              -> mempty

-- | A widget listing subreddit 'SubredditRule's. The @rules@ field cannot be
-- updated through widget endpoints, and are excluded during serialization
data RulesWidget = RulesWidget
    { widgetID  :: Maybe WidgetID
    , shortName :: ShortName
    , rules     :: Seq SubredditRule
    , display   :: RulesDisplay
    , styles    :: Maybe WidgetStyles
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON RulesWidget where
    parseJSON = withWidgetKind RulesType "RulesWidget" rulesP
      where
        rulesP (Object o) = RulesWidget <$> o .: "id"
            <*> o .: "shortName"
            -- This field may be missing after updating the widget
            <*> fromOptional o "data"
            <*> o .: "display"
            <*> o .: "styles"
        rulesP _          = mempty

instance ToJSON RulesWidget where
    toJSON RulesWidget { .. } =
        object [ "id" .= widgetID
               , "shortName" .= shortName
               , "display" .= display
               , "styles" .= styles
               , "kind" .= ("subreddit-rules" :: Text)
               ]

-- | Display style for a 'RulesWidget'
data RulesDisplay
    = FullDisplay
    | CompactDisplay
    deriving stock ( Show, Eq, Generic )

instance FromJSON RulesDisplay where
    parseJSON = genericParseJSON --
        defaultOptions { constructorTagModifier = rulesDisplayModifier }

instance ToJSON RulesDisplay where
    toJSON = genericToJSON --
        defaultOptions { constructorTagModifier = rulesDisplayModifier }

rulesDisplayModifier :: Modifier
rulesDisplayModifier = \case
    "FullDisplay"    -> "full"
    "CompactDisplay" -> "compact"
    _                -> mempty

-- | A widget composed of text. See 'mkTextAreaWidget' for constructing a new
-- widget
data TextAreaWidget = TextAreaWidget
    { widgetID  :: Maybe WidgetID
    , shortName :: ShortName
      -- | Markdown-formatted
    , text      :: Body
      -- | This is present in existing widgets, but should be
      -- left blank when creating a new one
    , textHTML  :: Maybe Body
    , styles    :: Maybe WidgetStyles
    }
    deriving stock ( Show, Eq, Generic )

instance FromJSON TextAreaWidget where
    parseJSON = withWidgetKind TextAreaType "TextAreaWidget"
        $ genericParseJSON defaultOptions
                           { fieldLabelModifier = textWidgetModifier }

instance ToJSON TextAreaWidget where
    toJSON = widgetToJSON textWidgetModifier TextAreaType

-- | Create a new 'TextAreaWidget', with default values for most fields
mkTextAreaWidget :: ShortName -> Body -> TextAreaWidget
mkTextAreaWidget shortName text = TextAreaWidget
    { widgetID = Nothing --
    , textHTML = Nothing
    , styles   = Nothing
    , ..
    }

textWidgetModifier :: Modifier
textWidgetModifier = \case
    "textHTML" -> "textHtml"
    s          -> defaultWidgetModifier s

-- Insert the @kind@ field into some JSON widget, while taking advantage of generic
-- @ToJSON@ deriving. An alternative would be to retain the field during encoding/
-- decoding . However, the user can only choose a single kind in each case
-- (e.g. a @ButtonWidget@ will always have the kind \"button\"), so that is perhaps
-- not the best choice as it would allow the construction of invalid widget values
widgetToJSON :: (Generic a, GToJSON' Value Zero (Rep a))
             => Modifier
             -> WidgetType
             -> a
             -> Value
widgetToJSON fieldLabelModifier ty x = case genericTo x of
    Object o -> Object $ HM.insert "kind" (toJSON ty) o
    v        -> v
  where
    genericTo = genericToJSON defaultOptions
                              { fieldLabelModifier
                              , omitNothingFields  = True
                              , sumEncoding        = UntaggedValue
                              }

defaultWidgetModifier :: Modifier
defaultWidgetModifier = \case
    "widgetID" -> "id"
    s          -> s

withWidgetKind
    :: WidgetType -> [Char] -> (Value -> Parser a) -> Value -> Parser a
withWidgetKind ty name f = withObject name $ \o -> do
    guard . (== ty) =<< o .: "kind"
    f $ Object o

data WidgetType
    = ImageType
    | TextType
    | ButtonType
    | CalendarType
    | CommunityListType
    | CustomType
    | IDCardType
    | MenuType
    | ModeratorsType
    | PostFlairType
    | RulesType
    | TextAreaType
    deriving stock ( Eq )

instance ToJSON WidgetType where
    toJSON = String . typeTag
      where
        typeTag = \case
            ImageType         -> "image"
            TextType          -> "text"
            ButtonType        -> "button"
            CalendarType      -> "calendar"
            CommunityListType -> "community-list"
            CustomType        -> "custom"
            IDCardType        -> "id-card"
            MenuType          -> "menu"
            ModeratorsType    -> "moderators"
            PostFlairType     -> "post-flair"
            RulesType         -> "subreddit-rules"
            TextAreaType      -> "textarea"

instance FromJSON WidgetType where
    parseJSON = withText "WidgetType" $ \case
        "image"           -> pure ImageType
        "text"            -> pure TextType
        "button"          -> pure ButtonType
        "calendar"        -> pure CalendarType
        "community-list"  -> pure CommunityListType
        "custom"          -> pure CustomType
        "id-card"         -> pure IDCardType
        "menu"            -> pure MenuType
        "moderators"      -> pure ModeratorsType
        "post-flair"      -> pure PostFlairType
        "subreddit-rules" -> pure RulesType
        "textarea"        -> pure TextAreaType
        _                 -> mempty