-- | Read a presentation from disk.
{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module Patat.Presentation.Read
    ( readPresentation

      -- Exposed for testing mostly.
    , detectSlideLevel
    , readMetaSettings
    ) where


--------------------------------------------------------------------------------
import           Control.Monad                   (guard)
import           Control.Monad.Except            (ExceptT (..), runExceptT,
                                                  throwError)
import           Control.Monad.Trans             (liftIO)
import qualified Data.Aeson.Extended             as A
import qualified Data.Aeson.KeyMap               as AKM
import           Data.Bifunctor                  (first)
import           Data.Maybe                      (fromMaybe)
import           Data.Sequence.Extended          (Seq)
import qualified Data.Sequence.Extended          as Seq
import qualified Data.Text                       as T
import qualified Data.Text.Encoding              as T
import           Data.Traversable                (for)
import qualified Data.Yaml                       as Yaml
import           Patat.EncodingFallback          (EncodingFallback)
import qualified Patat.EncodingFallback          as EncodingFallback
import qualified Patat.Eval                      as Eval
import           Patat.Presentation.Fragment
import           Patat.Presentation.Internal
import qualified Patat.Presentation.SpeakerNotes as SpeakerNotes
import           Patat.Presentation.Syntax
import           Patat.Transition                (parseTransitionSettings)
import           Patat.Unique
import           Prelude
import qualified Skylighting                     as Skylighting
import           System.Directory                (XdgDirectory (XdgConfig),
                                                  doesFileExist,
                                                  getHomeDirectory,
                                                  getXdgDirectory)
import           System.FilePath                 (splitFileName, takeExtension,
                                                  (</>))
import qualified Text.Pandoc.Error               as Pandoc
import qualified Text.Pandoc.Extended            as Pandoc


--------------------------------------------------------------------------------
readPresentation :: UniqueGen -> FilePath -> IO (Either String Presentation)
readPresentation uniqueGen filePath = runExceptT $ do
    -- We need to read the settings first.
    (enc, src)   <- liftIO $ EncodingFallback.readFile filePath
    homeSettings <- ExceptT readHomeSettings
    xdgSettings  <- ExceptT readXdgSettings
    metaSettings <- ExceptT $ return $ readMetaSettings src
    let settings =
            metaSettings <>
            xdgSettings  <>
            homeSettings <>
            defaultPresentationSettings

    syntaxMap <- ExceptT $ readSyntaxMap $ fromMaybe [] $
        psSyntaxDefinitions settings
    let pexts = fromMaybe defaultExtensionList (psPandocExtensions settings)
    reader <- case readExtension pexts ext of
        Nothing -> throwError $ "Unknown file extension: " ++ show ext
        Just x  -> return x
    doc <- case reader src of
        Left  e -> throwError $ "Could not parse document: " ++ show e
        Right x -> return x

    pres <- ExceptT $ pure $
        pandocToPresentation uniqueGen filePath enc settings syntaxMap doc
    pure $ fragmentPresentation $ Eval.parseEvalBlocks pres
  where
    ext = takeExtension filePath


--------------------------------------------------------------------------------
readSyntaxMap :: [FilePath] -> IO (Either String Skylighting.SyntaxMap)
readSyntaxMap =
    runExceptT .
    fmap (foldr Skylighting.addSyntaxDefinition mempty) .
    traverse (ExceptT . Skylighting.loadSyntaxFromFile)


--------------------------------------------------------------------------------
readExtension
    :: ExtensionList -> String
    -> Maybe (T.Text -> Either Pandoc.PandocError Pandoc.Pandoc)
readExtension (ExtensionList extensions) fileExt = case fileExt of
    ".markdown" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
    ".md"       -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
    ".mdown"    -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
    ".mdtext"   -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
    ".mdtxt"    -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
    ".mdwn"     -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
    ".mkd"      -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
    ".mkdn"     -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
    ".lhs"      -> Just $ Pandoc.runPure . Pandoc.readMarkdown lhsOpts
    ""          -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
    ".org"      -> Just $ Pandoc.runPure . Pandoc.readOrg      readerOpts
    ".txt"      -> Just $ pure . Pandoc.readPlainText
    _           -> Nothing

  where
    readerOpts = Pandoc.def
        { Pandoc.readerExtensions =
            extensions <> absolutelyRequiredExtensions
        }

    lhsOpts = readerOpts
        { Pandoc.readerExtensions =
            Pandoc.readerExtensions readerOpts <>
            Pandoc.extensionsFromList [Pandoc.Ext_literate_haskell]
        }

    absolutelyRequiredExtensions =
        Pandoc.extensionsFromList [Pandoc.Ext_yaml_metadata_block]


--------------------------------------------------------------------------------
pandocToPresentation
    :: UniqueGen -> FilePath -> EncodingFallback -> PresentationSettings
    -> Skylighting.SyntaxMap -> Pandoc.Pandoc -> Either String Presentation
pandocToPresentation pUniqueGen pFilePath pEncodingFallback pSettings pSyntaxMap
        pandoc@(Pandoc.Pandoc meta _) = do
    let !pTitle          = case Pandoc.docTitle meta of
            []    -> [Str . T.pack . snd $ splitFileName pFilePath]
            title -> fromPandocInlines title
        !pSlides         = pandocToSlides pSettings pandoc
        !pBreadcrumbs    = collectBreadcrumbs pSlides
        !pActiveFragment = (0, 0)
        !pAuthor         = fromPandocInlines $ concat $ Pandoc.docAuthors meta
        !pEvalBlocks     = mempty
        !pVars           = mempty
    pSlideSettings <- Seq.traverseWithIndex
        (\i slide -> case slideSettings slide of
            Left err  -> Left $ "on slide " ++ show (i + 1) ++ ": " ++ err
            Right cfg -> pure cfg)
        pSlides
    pTransitionGens <- for pSlideSettings $ \slideSettings ->
        case psTransition (slideSettings <> pSettings) of
            Nothing -> pure Nothing
            Just ts -> Just <$> parseTransitionSettings ts
    return $ Presentation {..}


--------------------------------------------------------------------------------
-- | This re-parses the pandoc metadata block using the YAML library.  This
-- avoids the problems caused by pandoc involving rendering Markdown.  This
-- should only be used for settings though, not things like title / authors
-- since those /can/ contain markdown.
parseMetadataBlock :: T.Text -> Maybe (Either String A.Value)
parseMetadataBlock src = case T.lines src of
    ("---" : ls) -> case break (`elem` ["---", "..."]) ls of
        (_,     [])      -> Nothing
        (block, (_ : _)) -> Just . first Yaml.prettyPrintParseException .
            Yaml.decodeEither' . T.encodeUtf8 . T.unlines $! block
    _            -> Nothing


--------------------------------------------------------------------------------
-- | Read settings from the metadata block in the Pandoc document.
readMetaSettings :: T.Text -> Either String PresentationSettings
readMetaSettings src = case parseMetadataBlock src of
    Nothing -> Right mempty
    Just (Left err) -> Left err
    Just (Right (A.Object obj)) | Just val <- AKM.lookup "patat" obj ->
       first (\err -> "Error parsing patat settings from metadata: " ++ err) $!
       A.resultToEither $! A.fromJSON val
    Just (Right _) -> Right mempty


--------------------------------------------------------------------------------
-- | Read settings from "$HOME/.patat.yaml".
readHomeSettings :: IO (Either String PresentationSettings)
readHomeSettings = do
    home <- getHomeDirectory
    readSettings $ home </> ".patat.yaml"


--------------------------------------------------------------------------------
-- | Read settings from "$XDG_CONFIG_DIRECTORY/patat/config.yaml".
readXdgSettings :: IO (Either String PresentationSettings)
readXdgSettings =
    getXdgDirectory XdgConfig ("patat" </> "config.yaml") >>= readSettings


--------------------------------------------------------------------------------
-- | Read settings from the specified path, if it exists.
readSettings :: FilePath -> IO (Either String PresentationSettings)
readSettings path = do
    exists <- doesFileExist path
    if not exists
        then return (Right mempty)
        else do
            errOrPs <- Yaml.decodeFileEither path
            return $! case errOrPs of
                Left  err -> Left (show err)
                Right ps  -> Right ps


--------------------------------------------------------------------------------
pandocToSlides :: PresentationSettings -> Pandoc.Pandoc -> Seq.Seq Slide
pandocToSlides settings (Pandoc.Pandoc _meta pblocks) =
    let blocks       = fromPandocBlocks pblocks
        slideLevel   = fromMaybe (detectSlideLevel blocks) (psSlideLevel settings)
        unfragmented = splitSlides slideLevel blocks in
    Seq.fromList unfragmented


--------------------------------------------------------------------------------
-- | Find level of header that starts slides.  This is defined as the least
-- header that occurs before a non-header in the blocks.
detectSlideLevel :: [Block] -> Int
detectSlideLevel blocks0 =
    go 6 $ filter (not . isComment) blocks0
  where
    go level (Header n _ _ : x : xs)
        | n < level && not (isHeader x) = go n xs
        | otherwise                     = go level (x:xs)
    go level (_ : xs)                   = go level xs
    go level []                         = level

    isHeader (Header _ _ _) = True
    isHeader _              = False


--------------------------------------------------------------------------------
-- | Split a pandoc document into slides.  If the document contains horizonal
-- rules, we use those as slide delimiters.  If there are no horizontal rules,
-- we split using headers, determined by the slide level (see
-- 'detectSlideLevel').
splitSlides :: Int -> [Block] -> [Slide]
splitSlides slideLevel blocks0
    | any isHorizontalRule blocks0 = splitAtRules   blocks0
    | otherwise                    = splitAtHeaders [] blocks0
  where
    mkContentSlide :: [Block] -> [Slide]
    mkContentSlide bs0 = do
        let bs1  = filter (not . isComment) bs0
            sns  = SpeakerNotes.SpeakerNotes [s | SpeakerNote s <- bs0]
            cfgs = concatCfgs [cfg | Config cfg <- bs0]
        guard $ not $ null bs1  -- Never create empty slides
        pure $ Slide sns cfgs $ ContentSlide bs1

    splitAtRules blocks = case break isHorizontalRule blocks of
        (xs, [])           -> mkContentSlide xs
        (xs, (_rule : ys)) -> mkContentSlide xs ++ splitAtRules ys

    splitAtHeaders acc [] =
        mkContentSlide (reverse acc)
    splitAtHeaders acc (b@(Header i _ txt) : bs0)
        | i > slideLevel  = splitAtHeaders (b : acc) bs0
        | i == slideLevel =
            mkContentSlide (reverse acc) ++ splitAtHeaders [b] bs0
        | otherwise       =
            let (cmnts, bs1) = break (not . isComment) bs0
                sns  = SpeakerNotes.SpeakerNotes [s | SpeakerNote s <- cmnts]
                cfgs = concatCfgs [cfg | Config cfg <- cmnts] in
            mkContentSlide (reverse acc) ++
            [Slide sns cfgs $ TitleSlide i txt] ++
            splitAtHeaders [] bs1
    splitAtHeaders acc (b : bs) =
        splitAtHeaders (b : acc) bs

    concatCfgs
        :: [Either String PresentationSettings]
        -> Either String PresentationSettings
    concatCfgs = fmap mconcat . sequence


--------------------------------------------------------------------------------
collectBreadcrumbs :: Seq Slide -> Seq Breadcrumbs
collectBreadcrumbs = go [] . fmap slideContent
  where
    go breadcrumbs slides0 = case Seq.viewl slides0 of
        Seq.EmptyL -> Seq.empty
        ContentSlide _ Seq.:< slides ->
            breadcrumbs `Seq.cons` go breadcrumbs slides
        TitleSlide lvl inlines Seq.:< slides ->
            let parent = filter ((< lvl) . fst) breadcrumbs in
            parent `Seq.cons` go (parent ++ [(lvl, inlines)]) slides