content: --------------------------------------------------------------------------------
  {-# LANGUAGE CPP                        #-}
  {-# 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_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 _    _                        -> []
  