    {-# LANGUAGE TupleSections #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE DeriveAnyClass #-}
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE TemplateHaskell #-}
    -- | Support for representing attribute themes and loading and saving
    -- theme customizations in INI-style files.
    --
    -- The file format is as follows:
    --
    -- Customization files are INI-style files with two sections, both
    -- optional: @"default"@ and @"other"@.
    --
    -- The @"default"@ section specifies three optional fields:
    --
    --  * @"default.fg"@ - a color specification
    --  * @"default.bg"@ - a color specification
    --  * @"default.style"@ - a style specification
    --
    -- A color specification can be any of the strings @black@, @red@,
    -- @green@, @yellow@, @blue@, @magenta@, @cyan@, @white@, @brightBlack@,
    -- @brightRed@, @brightGreen@, @brightYellow@, @brightBlue@,
    -- @brightMagenta@, @brightCyan@, @brightWhite@, or @default@.
    --
    -- We also support color specifications in the common hex format @#RRGGBB@, but
    -- note that this specification is lossy: terminals can only display 256 colors,
    -- but hex codes can specify @256^3 = 16777216@ colors.
    --
    -- A style specification can be either one of the following values
    -- (without quotes) or a comma-delimited list of one or more of the
    -- following values (e.g. @"[bold,underline]"@) indicating that all
    -- of the specified styles be used. Valid styles are @standout@,
    -- @underline@, @reverseVideo@, @blink@, @dim@, @italic@, and @bold@.
    --
    -- The @other@ section specifies for each attribute name in the theme
    -- the same @fg@, @bg@, and @style@ settings as for the default
    -- attribute. Furthermore, if an attribute name has multiple components,
    -- the fields in the INI file should use periods as delimiters. For
    -- example, if a theme has an attribute name (@"foo" <> "bar"@), then
    -- the file may specify three fields:
    --
    --  * @foo.bar.fg@ - a color specification
    --  * @foo.bar.bg@ - a color specification
    --  * @foo.bar.style@ - a style specification
    --
    -- Any color or style specifications omitted from the file mean that
    -- those attribute or style settings will use the theme's default value
    -- instead.
    --
    -- Attribute names with multiple components (e.g. @attr1 <> attr2@) can
    -- be referenced in customization files by separating the names with
    -- a dot. For example, the attribute name @"list" <> "selected"@ can be
    -- referenced by using the string "list.selected".
    module Brick.Themes
      ( CustomAttr(..)
      , customFgL
      , customBgL
      , customStyleL

      , Theme(..)
      , newTheme
      , themeDefaultAttrL
      , themeDefaultMappingL
      , themeCustomMappingL
      , themeCustomDefaultAttrL

      , ThemeDocumentation(..)
      , themeDescriptionsL

      , themeToAttrMap
      , applyCustomizations
      , loadCustomizations
      , saveCustomizations
      , saveTheme
      )
    where

    import GHC.Generics (Generic)
    import Graphics.Vty hiding ((<|>))
    import Control.DeepSeq
    import Control.Monad (forM, join)
    import Control.Applicative ((<|>))
    import qualified Data.Text as T
    import qualified Data.Text.Read as T
    import qualified Data.Text.IO as T
    import qualified Data.Map as M
    import qualified Data.Semigroup as Sem
    import Data.Tuple (swap)
    import Data.List (intercalate)
    import Data.Bits ((.|.), (.&.))
    import Data.Maybe (fromMaybe, isNothing, catMaybes, mapMaybe)
    import Data.Monoid ((<>))
    import qualified Data.Foldable as F

    import Data.Ini.Config

    import Brick.AttrMap (AttrMap, AttrName, attrMap, attrNameComponents)
    import Brick.Types.TH (suffixLenses)

    import Text.Printf

    -- | An attribute customization can specify which aspects of an
    -- attribute to customize.
    data CustomAttr =
        CustomAttr { customFg    :: Maybe (MaybeDefault Color)
                   -- ^ The customized foreground, if any.
                   , customBg    :: Maybe (MaybeDefault Color)
                   -- ^ The customized background, if any.
                   , customStyle :: Maybe Style
                   -- ^ The customized style, if any.
                   }
                   deriving (Eq, Read, Show, Generic, NFData)

    instance Sem.Semigroup CustomAttr where
        a <> b =
            CustomAttr { customFg    = customFg a    <|> customFg b
                       , customBg    = customBg a    <|> customBg b
                       , customStyle = customStyle a <|> customStyle b
                       }

    instance Monoid CustomAttr where
        mempty = CustomAttr Nothing Nothing Nothing
        mappend = (Sem.<>)

    -- | Documentation for a theme's attributes.
    data ThemeDocumentation =
        ThemeDocumentation { themeDescriptions :: M.Map AttrName T.Text
                           -- ^ The per-attribute documentation for a theme
                           -- so e.g. documentation for theme customization
                           -- can be generated mechanically.
                           }
                           deriving (Eq, Read, Show, Generic, NFData)

    -- | A theme provides a set of default attribute mappings, a default
    -- attribute, and a set of customizations for the default mapping
    -- and default attribute. The idea here is that the application will
    -- always need to provide a complete specification of its attribute
    -- mapping, but if the user wants to customize any aspect of that
    -- default mapping, it can be contained here and then built into an
    -- 'AttrMap' (see 'themeToAttrMap'). We keep the defaults separate
    -- from customizations to permit users to serialize themes and their
    -- customizations to, say, disk files.
    data Theme =
        Theme { themeDefaultAttr :: Attr
              -- ^ The default attribute to use.
              , themeDefaultMapping :: M.Map AttrName Attr
              -- ^ The default attribute mapping to use.
              , themeCustomDefaultAttr :: Maybe CustomAttr
              -- ^ Customization for the theme's default attribute.
              , themeCustomMapping :: M.Map AttrName CustomAttr
              -- ^ Customizations for individual entries of the default
              -- mapping. Note that this will only affect entries in the
              -- default mapping; any attributes named here that are not
              -- present in the default mapping will not be considered.
              }
              deriving (Eq, Read, Show, Generic, NFData)

    suffixLenses ''CustomAttr
    suffixLenses ''Theme
    suffixLenses ''ThemeDocumentation

    defaultSectionName :: T.Text
    defaultSectionName = "default"

    otherSectionName :: T.Text
    otherSectionName = "other"

    -- | Create a new theme with the specified default attribute and
    -- attribute mapping. The theme will have no customizations.
    newTheme :: Attr -> [(AttrName, Attr)] -> Theme
    newTheme def mapping =
        Theme { themeDefaultAttr       = def
              , themeDefaultMapping    = M.fromList mapping
              , themeCustomDefaultAttr = Nothing
              , themeCustomMapping     = mempty
              }

    -- | Build an 'AttrMap' from a 'Theme'. This applies all customizations
    -- in the returned 'AttrMap'.
    themeToAttrMap :: Theme -> AttrMap
    themeToAttrMap t =
        attrMap (customizeAttr (themeCustomDefaultAttr t) (themeDefaultAttr t)) customMap
        where
            customMap = F.foldr f [] (M.toList $ themeDefaultMapping t)
            f (aName, attr) mapping =
                let a' = customizeAttr (M.lookup aName (themeCustomMapping t)) attr
                in (aName, a'):mapping

    customizeAttr :: Maybe CustomAttr -> Attr -> Attr
    customizeAttr Nothing a = a
    customizeAttr (Just c) a =
        let fg = fromMaybe (attrForeColor a) (customFg c)
            bg = fromMaybe (attrBackColor a) (customBg c)
            sty = maybe (attrStyle a) SetTo (customStyle c)
        in a { attrForeColor = fg
             , attrBackColor = bg
             , attrStyle = sty
             }

    isNullCustomization :: CustomAttr -> Bool
    isNullCustomization c =
        isNothing (customFg c) &&
        isNothing (customBg c) &&
        isNothing (customStyle c)

    -- |  This function is lossy in the sense that we only internally support 240 colors but
    -- the #RRGGBB format supports 16^3 colors.
    parseColor :: T.Text -> Either String (MaybeDefault Color)
    parseColor s =
        let stripped = T.strip $ T.toLower s
            normalize (t, c) = (T.toLower t, c)
        in if stripped == "default"
              then Right Default
              else case parseRGB stripped of
                  Just c  -> Right (SetTo c)
                  Nothing -> maybe (Left $ "Invalid color: " <> show stripped) (Right . SetTo) $
                                 lookup stripped (normalize <$> swap <$> allColors)
      where
        parseRGB t = if T.head t /= '#'
                        then Nothing
                        else case mapMaybe readHex (T.chunksOf 2 (T.tail t)) of
                                [r,g,b] -> Just (rgbColor r g b)
                                _ -> Nothing

        readHex :: T.Text -> Maybe Int
        readHex t = either (const Nothing) (Just . fst) (T.hexadecimal t)

    allColors :: [(Color, T.Text)]
    allColors =
        [ (black, "black")
        , (red, "red")
        , (green, "green")
        , (yellow, "yellow")
        , (blue, "blue")
        , (magenta, "magenta")
        , (cyan, "cyan")
        , (white, "white")
        , (brightBlack, "brightBlack")
        , (brightRed, "brightRed")
        , (brightGreen, "brightGreen")
        , (brightYellow, "brightYellow")
        , (brightBlue, "brightBlue")
        , (brightMagenta, "brightMagenta")
        , (brightCyan, "brightCyan")
        , (brightWhite, "brightWhite")
        ]

    allStyles :: [(T.Text, Style)]
    allStyles =
        [ ("standout", standout)
        , ("underline", underline)
        , ("reversevideo", reverseVideo)
        , ("blink", blink)
        , ("dim", dim)
        , ("bold", bold)
        , ("italic", italic)
        ]

    parseStyle :: T.Text -> Either String Style
    parseStyle s =
        let lookupStyle "" = Right Nothing
            lookupStyle n = case lookup n normalizedStyles of
                Just sty -> Right $ Just sty
                Nothing  -> Left $ T.unpack $ "Invalid style: " <> n
            stripped = T.strip $ T.toLower s
            normalize (n, a) = (T.toLower n, a)
            normalizedStyles = normalize <$> allStyles
            bracketed = "[" `T.isPrefixOf` stripped &&
                        "]" `T.isSuffixOf` stripped
            unbracketed = T.tail $ T.init stripped
            parseStyleList = do
                ss <- mapM lookupStyle $ T.strip <$> T.splitOn "," unbracketed
                return $ foldr (.|.) 0 $ catMaybes ss

        in if bracketed
           then parseStyleList
           else do
               result <- lookupStyle stripped
               case result of
                   Nothing -> Left $ "Invalid style: " <> show stripped
                   Just sty -> Right sty

    themeParser :: Theme -> IniParser (Maybe CustomAttr, M.Map AttrName CustomAttr)
    themeParser t = do
        let parseCustomAttr basename = do
              c <- CustomAttr <$> fieldMbOf (basename <> ".fg")    parseColor
                              <*> fieldMbOf (basename <> ".bg")    parseColor
                              <*> fieldMbOf (basename <> ".style") parseStyle
              return $ if isNullCustomization c then Nothing else Just c

        defCustom <- sectionMb defaultSectionName $ do
            parseCustomAttr "default"

        customMap <- sectionMb otherSectionName $ do
            catMaybes <$> (forM (M.keys $ themeDefaultMapping t) $ \an ->
                (fmap (an,)) <$> parseCustomAttr (makeFieldName $ attrNameComponents an)
                )

        return (join defCustom, M.fromList $ fromMaybe [] customMap)

    -- | Apply customizations using a custom lookup function. Customizations
    -- are obtained for each attribute name in the theme. Any customizations
    -- already set are lost.
    applyCustomizations :: Maybe CustomAttr
                        -- ^ An optional customization for the theme's
                        -- default attribute.
                        -> (AttrName -> Maybe CustomAttr)
                        -- ^ A function to obtain a customization for the
                        -- specified attribute.
                        -> Theme
                        -- ^ The theme to customize.
                        -> Theme
    applyCustomizations customDefAttr lookupAttr t =
        let customMap = foldr nextAttr mempty (M.keys $ themeDefaultMapping t)
            nextAttr an m = case lookupAttr an of
                Nothing     -> m
                Just custom -> M.insert an custom m
        in t { themeCustomDefaultAttr = customDefAttr
             , themeCustomMapping = customMap
             }

    -- | Load an INI file containing theme customizations. Use the specified
    -- theme to determine which customizations to load. Return the specified
    -- theme with customizations set. See the module documentation for the
    -- theme file format.
    loadCustomizations :: FilePath -> Theme -> IO (Either String Theme)
    loadCustomizations path t = do
        content <- T.readFile path
        case parseIniFile content (themeParser t) of
            Left e -> return $ Left e
            Right (customDef, customMap) ->
                return $ Right $ applyCustomizations customDef (flip M.lookup customMap) t

    vtyColorName :: Color -> T.Text
    vtyColorName c@(Color240 n) = case color240CodeToRGB (fromIntegral n) of
        Just (r,g,b) -> T.pack (printf "#%02x%02x%02x" r g b)
        Nothing -> (error $ "Invalid color: " <> show c)
    vtyColorName c =
        fromMaybe (error $ "Invalid color: " <> show c)
                  (lookup c allColors)

    makeFieldName :: [String] -> T.Text
    makeFieldName cs = T.pack $ intercalate "." cs

    serializeCustomColor :: [String] -> MaybeDefault Color -> T.Text
    serializeCustomColor cs cc =
        let cName = case cc of
              Default -> "default"
              SetTo c -> vtyColorName c
              KeepCurrent -> error "serializeCustomColor does not support KeepCurrent"
        in makeFieldName cs <> " = " <> cName

    serializeCustomStyle :: [String] -> Style -> T.Text
    serializeCustomStyle cs s =
        let activeStyles = filter (\(_, a) -> a .&. s == a) allStyles
            styleStr = case activeStyles of
                [(single, _)] -> single
                many -> "[" <> (T.intercalate ", " $ fst <$> many) <> "]"
        in makeFieldName cs <> " = " <> styleStr

    serializeCustomAttr :: [String] -> CustomAttr -> [T.Text]
    serializeCustomAttr cs c =
        catMaybes [ serializeCustomColor (cs <> ["fg"]) <$> customFg c
                  , serializeCustomColor (cs <> ["bg"]) <$> customBg c
                  , serializeCustomStyle (cs <> ["style"]) <$> customStyle c
                  ]

    emitSection :: T.Text -> [T.Text] -> [T.Text]
    emitSection _ [] = []
    emitSection secName ls = ("[" <> secName <> "]") : ls

    -- | Save an INI file containing theme customizations. Use the specified
    -- theme to determine which customizations to save. See the module
    -- documentation for the theme file format.
    saveCustomizations :: FilePath -> Theme -> IO ()
    saveCustomizations path t = do
        let defSection = fromMaybe [] $
                         serializeCustomAttr ["default"] <$> themeCustomDefaultAttr t
            mapSection = concat $ flip map (M.keys $ themeDefaultMapping t) $ \an ->
                maybe [] (serializeCustomAttr (attrNameComponents an)) $
                         M.lookup an $ themeCustomMapping t
            content = T.unlines $ (emitSection defaultSectionName defSection) <>
                                  (emitSection otherSectionName mapSection)
        T.writeFile path content

    -- | Save an INI file containing all attributes from the specified
    -- theme. Customized attributes are saved, but if an attribute is not
    -- customized, its default is saved instead. The file can later be
    -- re-loaded as a customization file.
    saveTheme :: FilePath -> Theme -> IO ()
    saveTheme path t = do
        let defSection = serializeCustomAttr ["default"] $
                         fromMaybe (attrToCustom $ themeDefaultAttr t) (themeCustomDefaultAttr t)
            mapSection = concat $ flip map (M.toList $ themeDefaultMapping t) $ \(an, def) ->
                serializeCustomAttr (attrNameComponents an) $
                    fromMaybe (attrToCustom def) (M.lookup an $ themeCustomMapping t)
            content = T.unlines $ (emitSection defaultSectionName defSection) <>
                                  (emitSection otherSectionName mapSection)
        T.writeFile path content

    attrToCustom :: Attr -> CustomAttr
    attrToCustom a =
        CustomAttr { customFg    = Just $ attrForeColor a
                   , customBg    = Just $ attrForeColor a
                   , customStyle = case attrStyle a of
                       SetTo s -> Just s
                       _       -> Nothing
                   }