content: -- | 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 horizontal
  -- 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
  