--------------------------------------------------------------------------------
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskell            #-}
module Patat.Presentation.Settings
    ( PresentationSettings (..)
    , defaultPresentationSettings

    , Wrap (..)
    , AutoOr (..)
    , MarginSettings (..)

    , ExtensionList (..)
    , defaultExtensionList

    , ImageSettings (..)

    , EvalSettingsMap (..)
    , EvalSettingsContainer (..)
    , EvalSettings (..)

    , SpeakerNotesSettings (..)

    , TransitionSettings (..)

    , LinkSettings (..)

    , parseSlideSettings
    ) where


--------------------------------------------------------------------------------
import           Control.Applicative    ((<|>))
import           Control.Monad          (mplus, unless)
import qualified Data.Aeson.Extended    as A
import qualified Data.Aeson.TH.Extended as A
import           Data.Bifunctor         (first)
import           Data.CaseInsensitive   (CI)
import qualified Data.CaseInsensitive   as CI
import qualified Data.Foldable          as Foldable
import           Data.Function          (on)
import qualified Data.HashMap.Strict    as HMS
import           Data.List              (intercalate)
import qualified Data.Text              as T
import qualified Patat.Theme            as Theme
import           Prelude
import qualified Text.Pandoc            as Pandoc
import           Text.Read              (readMaybe)


--------------------------------------------------------------------------------
-- | These are patat-specific settings.  That is where they differ from more
-- general metadata (author, title...)
data PresentationSettings = PresentationSettings
    { psRows              :: !(Maybe (A.FlexibleNum Int))
    , psColumns           :: !(Maybe (A.FlexibleNum Int))
    , psMargins           :: !(Maybe MarginSettings)
    , psWrap              :: !(Maybe Wrap)
    , psTabStop           :: !(Maybe (A.FlexibleNum Int))
    , psTheme             :: !(Maybe Theme.Theme)
    , psIncrementalLists  :: !(Maybe Bool)
    , psAutoAdvanceDelay  :: !(Maybe (A.FlexibleNum Int))
    , psSlideLevel        :: !(Maybe Int)
    , psPandocExtensions  :: !(Maybe ExtensionList)
    , psImages            :: !(Maybe ImageSettings)
    , psBreadcrumbs       :: !(Maybe Bool)
    , psEval              :: !(Maybe EvalSettingsMap)
    , psSlideNumber       :: !(Maybe Bool)
    , psSyntaxDefinitions :: !(Maybe [FilePath])
    , psSpeakerNotes      :: !(Maybe SpeakerNotesSettings)
    , psTransition        :: !(Maybe TransitionSettings)
    , psLinks             :: !(Maybe LinkSettings)
    } deriving (Eq, Show)


--------------------------------------------------------------------------------
instance Semigroup PresentationSettings where
    l <> r = PresentationSettings
        { psRows              = on mplus psRows              l r
        , psColumns           = on mplus psColumns           l r
        , psMargins           = on (<>)  psMargins           l r
        , psWrap              = on mplus psWrap              l r
        , psTabStop           = on mplus psTabStop           l r
        , psTheme             = on (<>)  psTheme             l r
        , psIncrementalLists  = on mplus psIncrementalLists  l r
        , psAutoAdvanceDelay  = on mplus psAutoAdvanceDelay  l r
        , psSlideLevel        = on mplus psSlideLevel        l r
        , psPandocExtensions  = on mplus psPandocExtensions  l r
        , psImages            = on mplus psImages            l r
        , psBreadcrumbs       = on mplus psBreadcrumbs       l r
        , psEval              = on (<>)  psEval              l r
        , psSlideNumber       = on mplus psSlideNumber       l r
        , psSyntaxDefinitions = on (<>)  psSyntaxDefinitions l r
        , psSpeakerNotes      = on mplus psSpeakerNotes      l r
        , psTransition        = on mplus psTransition        l r
        , psLinks             = on (<>)  psLinks             l r
        }


--------------------------------------------------------------------------------
instance Monoid PresentationSettings where
    mappend = (<>)
    mempty  = PresentationSettings
                Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
                Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
                Nothing Nothing


--------------------------------------------------------------------------------
defaultPresentationSettings :: PresentationSettings
defaultPresentationSettings = mempty
    { psMargins = Nothing
    , psTheme   = Just Theme.defaultTheme
    }


--------------------------------------------------------------------------------
data Wrap = NoWrap | AutoWrap | WrapAt Int deriving (Eq, Show)


--------------------------------------------------------------------------------
instance A.FromJSON Wrap where
    parseJSON val =
        ((\w -> if w then AutoWrap else NoWrap) <$> A.parseJSON val) <|>
        (WrapAt <$> A.parseJSON val)


--------------------------------------------------------------------------------
data AutoOr a = Auto | NotAuto a deriving (Eq, Show)


--------------------------------------------------------------------------------
instance A.FromJSON a => A.FromJSON (AutoOr a) where
    parseJSON (A.String "auto") = pure Auto
    parseJSON val               = NotAuto <$> A.parseJSON val


--------------------------------------------------------------------------------
data MarginSettings = MarginSettings
    { msTop   :: !(Maybe (AutoOr (A.FlexibleNum Int)))
    , msLeft  :: !(Maybe (AutoOr (A.FlexibleNum Int)))
    , msRight :: !(Maybe (AutoOr (A.FlexibleNum Int)))
    } deriving (Eq, Show)


--------------------------------------------------------------------------------
instance Semigroup MarginSettings where
    l <> r = MarginSettings
        { msTop   = on mplus msTop   l r
        , msLeft  = on mplus msLeft  l r
        , msRight = on mplus msRight l r
        }


--------------------------------------------------------------------------------
instance Monoid MarginSettings where
    mappend = (<>)
    mempty  = MarginSettings Nothing Nothing Nothing


--------------------------------------------------------------------------------
newtype ExtensionList = ExtensionList {unExtensionList :: Pandoc.Extensions}
    deriving (Eq, Show)


--------------------------------------------------------------------------------
instance A.FromJSON ExtensionList where
    parseJSON = A.withArray "FromJSON ExtensionList" $
        fmap (ExtensionList . mconcat) . mapM parseExt . Foldable.toList
      where
        parseExt = A.withText "FromJSON ExtensionList" $ \txt -> case txt of
            -- Our default extensions
            "patat_extensions" -> return (unExtensionList defaultExtensionList)

            -- Individuals
            _ -> case readMaybe ("Ext_" ++ T.unpack txt) of
                Just e  -> return $ Pandoc.extensionsFromList [e]
                Nothing -> fail $
                    "Unknown extension: " ++ show txt ++
                    ", known extensions are: " ++
                    intercalate ", " (map (drop 4 . show) allExts)
          where
            -- This is an approximation since we can't enumerate extensions
            -- anymore in the latest pandoc...
            allExts = Pandoc.extensionsToList $
                Pandoc.getAllExtensions "markdown"


--------------------------------------------------------------------------------
defaultExtensionList :: ExtensionList
defaultExtensionList = ExtensionList $
    Pandoc.readerExtensions Pandoc.def `mappend` Pandoc.extensionsFromList
    [ Pandoc.Ext_yaml_metadata_block
    , Pandoc.Ext_table_captions
    , Pandoc.Ext_simple_tables
    , Pandoc.Ext_multiline_tables
    , Pandoc.Ext_grid_tables
    , Pandoc.Ext_pipe_tables
    , Pandoc.Ext_raw_html
    , Pandoc.Ext_tex_math_dollars
    , Pandoc.Ext_fenced_code_blocks
    , Pandoc.Ext_fenced_code_attributes
    , Pandoc.Ext_backtick_code_blocks
    , Pandoc.Ext_inline_code_attributes
    , Pandoc.Ext_fancy_lists
    , Pandoc.Ext_four_space_rule
    , Pandoc.Ext_definition_lists
    , Pandoc.Ext_compact_definition_lists
    , Pandoc.Ext_example_lists
    , Pandoc.Ext_strikeout
    , Pandoc.Ext_superscript
    , Pandoc.Ext_subscript
    , Pandoc.Ext_shortcut_reference_links
    ]


--------------------------------------------------------------------------------
data ImageSettings = ImageSettings
    { isBackend :: !T.Text
    , isParams  :: !A.Object
    } deriving (Eq, Show)


--------------------------------------------------------------------------------
instance A.FromJSON ImageSettings where
    parseJSON = A.withObject "FromJSON ImageSettings" $ \o -> do
        t <- o A..: "backend"
        return ImageSettings {isBackend = t, isParams = o}


--------------------------------------------------------------------------------
newtype EvalSettingsMap = EvalSettingsMap (HMS.HashMap (CI T.Text) EvalSettings)
    deriving (Eq, Show, Semigroup)


--------------------------------------------------------------------------------
instance A.FromJSON EvalSettingsMap where
    parseJSON =
        fmap (EvalSettingsMap . HMS.fromList . map (first CI.mk) . HMS.toList) .
        A.parseJSON


--------------------------------------------------------------------------------
data EvalSettingsContainer
    = EvalContainerCode
    | EvalContainerNone
    | EvalContainerInline
    deriving (Eq, Show)


--------------------------------------------------------------------------------
instance A.FromJSON EvalSettingsContainer where
    parseJSON = A.withText "FromJSON EvalSettingsContainer" $ \t -> case t of
        "code"      -> pure EvalContainerCode
        "none"      -> pure EvalContainerNone
        "inline"    -> pure EvalContainerInline
        -- Deprecated names
        "raw"       -> pure EvalContainerNone
        "rawInline" -> pure EvalContainerInline
        _           -> fail $ "unknown container: " <> show t


--------------------------------------------------------------------------------
data EvalSettings = EvalSettings
    { evalCommand   :: !T.Text
    , evalReplace   :: !Bool
    , evalReveal    :: !Bool
    , evalContainer :: !EvalSettingsContainer
    , evalStderr    :: !Bool
    , evalSyntax    :: !(Maybe (CI T.Text))
    } deriving (Eq, Show)


--------------------------------------------------------------------------------
instance A.FromJSON EvalSettings where
    parseJSON = A.withObject "FromJSON EvalSettings" $ \o -> EvalSettings
        <$> o A..:  "command"
        <*> o A..:? "replace"  A..!= False
        <*> deprecated "fragment" "reveal" True o
        <*> deprecated "wrap" "container" EvalContainerCode o
        <*> o A..:? "stderr" A..!= True
        <*> (fmap CI.mk <$> o A..:? "syntax")
      where
        deprecated old new def obj = do
            mo <- obj A..:? old
            mn <- obj A..:? new
            case (mo, mn) of
                (Just _, Just _)   -> fail $
                    show old ++ " (deprecated) and " ++ show new ++ " " ++
                    "are both specified, please remove " ++ show old
                (Just o, Nothing)  -> pure o
                (Nothing, Just n)  -> pure n
                (Nothing, Nothing) -> pure def


--------------------------------------------------------------------------------
data SpeakerNotesSettings = SpeakerNotesSettings
    { snsFile :: !FilePath
    } deriving (Eq, Show)


--------------------------------------------------------------------------------
data TransitionSettings = TransitionSettings
    { tsType   :: !T.Text
    , tsParams :: !A.Object
    } deriving (Eq, Show)


--------------------------------------------------------------------------------
instance A.FromJSON TransitionSettings where
    parseJSON = A.withObject "FromJSON TransitionSettings" $ \o ->
        TransitionSettings <$> o A..: "type" <*> pure o


--------------------------------------------------------------------------------
data LinkSettings = LinkSettings
    { lsOSC8 :: !(Maybe Bool)
    } deriving (Eq, Show)


--------------------------------------------------------------------------------
instance Semigroup LinkSettings where
    l <> r = LinkSettings
        { lsOSC8 = on mplus lsOSC8 l r
        }


--------------------------------------------------------------------------------
instance A.FromJSON LinkSettings where
    parseJSON = A.withObject "FromJSON LinkSettings" $ \o ->
        LinkSettings <$> o A..:? "osc8"


--------------------------------------------------------------------------------
$(A.deriveFromJSON A.dropPrefixOptions ''MarginSettings)
$(A.deriveFromJSON A.dropPrefixOptions ''SpeakerNotesSettings)
$(A.deriveFromJSON A.dropPrefixOptions ''PresentationSettings)


--------------------------------------------------------------------------------
data Setting where
    Setting :: String -> (PresentationSettings -> Maybe a) -> Setting


--------------------------------------------------------------------------------
unsupportedSlideSettings :: [Setting]
unsupportedSlideSettings =
    [ Setting "incrementalLists" psIncrementalLists
    , Setting "autoAdvanceDelay" psAutoAdvanceDelay
    , Setting "slideLevel"       psSlideLevel
    , Setting "pandocExtensions" psPandocExtensions
    , Setting "images"           psImages
    , Setting "eval"             psEval
    , Setting "speakerNotes"     psSpeakerNotes
    ]


--------------------------------------------------------------------------------
parseSlideSettings :: PresentationSettings -> Either String PresentationSettings
parseSlideSettings settings = do
    unless (null unsupported) $ Left $
        "the following settings are not supported in slide config blocks: " ++
        intercalate ", " unsupported
    pure settings
  where
    unsupported = do
        setting <- unsupportedSlideSettings
        case setting of
            Setting name f | Just _ <- f settings -> [name]
            Setting _    _                        -> []
