test/Tests/Readers/Org/Block/Header.hs - main - githubmirror/pandoc

test/Tests/Readers/Org/Block/Header.hs
279 строк10 KB
Ryan Gibb
Org reader: Recognize "fast access" characters in TODO state definitions (#10990)
24 июл 2025, 23:40
24 июл 2025, 23:40b84fa66
{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Tests.Readers.Org.Block.Header
   Copyright   : © 2014-2024 Albert Krewinkel
   License     : GNU GPL, version 2 or above

   Maintainer  : Albert Krewinkel <albert+pandoc@tarleb.com>
   Stability   : alpha
   Portability : portable

Test parsing of org header blocks.
-}
module Tests.Readers.Org.Block.Header (tests) where

import Test.Tasty (TestTree, testGroup)
import Tests.Helpers ((=?>))
import Tests.Readers.Org.Shared ((=:), spcSep, tagSpan)
import Text.Pandoc.Builder
import qualified Data.Text as T

tests :: [TestTree]
tests =
  [ "First Level Header" =:
      "* Headline\n" =?>
      headerWith ("headline", [], []) 1 "Headline"

  , "Third Level Header" =:
      "*** Third Level Headline\n" =?>
      headerWith ("third-level-headline", [], [])
                 3
                 ("Third" <> space <> "Level" <> space <> "Headline")

  , "Compact Headers with Paragraph" =:
      T.unlines [ "* First Level"
                , "** Second Level"
                , "   Text"
                ] =?>
      mconcat [ headerWith ("first-level", [], [])
                           1
                           ("First" <> space <> "Level")
              , headerWith ("second-level", [], [])
                           2
                           ("Second" <> space <> "Level")
              , para "Text"
              ]

  , "Separated Headers with Paragraph" =:
      T.unlines [ "* First Level"
                , ""
                , "** Second Level"
                , ""
                , "   Text"
                ] =?>
      mconcat [ headerWith ("first-level", [], [])
                           1
                           ("First" <> space <> "Level")
              , headerWith ("second-level", [], [])
                           2
                           ("Second" <> space <> "Level")
              , para "Text"
              ]

  , "Headers not preceded by a blank line" =:
      T.unlines [ "** eat dinner"
                , "Spaghetti and meatballs tonight."
                , "** walk dog"
                ] =?>
      mconcat [ headerWith ("eat-dinner", [], [])
                           2
                           ("eat" <> space <> "dinner")
              , para $ spcSep [ "Spaghetti", "and", "meatballs", "tonight." ]
              , headerWith ("walk-dog", [], [])
                           2
                           ("walk" <> space <> "dog")
              ]

  , testGroup "Todo keywords"
    [ "Header with known todo keyword" =:
        "* TODO header" =?>
        let todoSpan = spanWith ("", ["todo", "TODO"], []) "TODO"
        in headerWith ("header", [], []) 1 (todoSpan <> space <> "header")

    , "Header marked as done" =:
        "* DONE header" =?>
        let todoSpan = spanWith ("", ["done", "DONE"], []) "DONE"
        in headerWith ("header", [], []) 1 (todoSpan <> space <> "header")

    , "emphasis in first word" =:
        "** TODO /fix/ this" =?>
        let todoSpan = spanWith ("", ["todo", "TODO"], []) "TODO"
        in headerWith ("fix-this", [], [])
                      2
                      (todoSpan <> space <> emph "fix" <> space <> "this")

    , "Header with unknown todo keyword" =:
        "* WAITING header" =?>
        headerWith ("waiting-header", [], []) 1 "WAITING header"

    , "Custom todo keywords" =:
        T.unlines [ "#+todo: WAITING CANCELLED"
                  , "* WAITING compile"
                  , "* CANCELLED lunch"
                  ] =?>
        let todoSpan = spanWith ("", ["todo", "WAITING"], []) "WAITING"
            doneSpan = spanWith ("", ["done", "CANCELLED"], []) "CANCELLED"
        in headerWith ("compile", [], []) 1 (todoSpan <> space <> "compile")
        <> headerWith ("lunch", [], []) 1 (doneSpan <> space <> "lunch")

    , "Custom todo keywords with multiple done-states" =:
        T.unlines [ "#+todo: WAITING | DONE CANCELLED "
                  , "* WAITING compile"
                  , "* CANCELLED lunch"
                  , "* DONE todo-feature"
                  ] =?>
        let waiting = spanWith ("", ["todo", "WAITING"], []) "WAITING"
            cancelled = spanWith ("", ["done", "CANCELLED"], []) "CANCELLED"
            done = spanWith ("", ["done", "DONE"], []) "DONE"
        in headerWith ("compile", [], []) 1 (waiting <> space <> "compile")
        <> headerWith ("lunch", [], []) 1 (cancelled <> space <> "lunch")
        <> headerWith ("todo-feature", [], []) 1 (done <> space <> "todo-feature")

    , "Fast access TODO states" =:
        T.unlines [ "#+TODO: TODO(t) | DONE(d)"
                  , "* TODO test"
                  ] =?>
        let todoSpan = spanWith ("", ["todo", "TODO"], []) "TODO"
        in headerWith ("test", [], []) 1 (todoSpan <> space <> "test")
    ]

  , "Tagged headers" =:
      T.unlines [ "* Personal       :PERSONAL:"
                , "** Call Mom      :@PHONE:"
                , "** Call John     :@PHONE:JOHN: "
                ] =?>
      mconcat [ headerWith ("personal", [], [])
                           1
                           ("Personal " <> tagSpan "PERSONAL")
              , headerWith ("call-mom", [], [])
                           2
                           ("Call Mom " <> tagSpan "@PHONE")
              , headerWith ("call-john", [], [])
                           2
                           ("Call John " <> tagSpan "@PHONE" <> "\160" <> tagSpan "JOHN")
              ]

  , "Untagged header containing colons" =:
      "* This: is not: tagged" =?>
      headerWith ("this-is-not-tagged", [], []) 1 "This: is not: tagged"

  , "Untagged header time followed by colon" =:
      "** Meeting at 5:23: free food" =?>
      let attr = ("meeting-at-523-free-food", [], [])
      in headerWith attr 2 "Meeting at 5:23: free food"

  , "tag followed by text" =:
      "*** Looks like a :tag: but isn't" =?>
      let attr = ("looks-like-a-tag-but-isnt", [], [])
      in headerWith attr 3 "Looks like a :tag: but isn't"

  , "Header starting with strokeout text" =:
      T.unlines [ "foo"
                , ""
                , "* +thing+ other thing"
                ] =?>
      mconcat [ para "foo"
              , headerWith ("thing-other-thing", [], [])
                           1
                           (strikeout "thing" <> " other thing")
              ]

  , "Comment Trees" =:
      T.unlines [ "* COMMENT A comment tree"
                , "  Not much going on here"
                , "** This will be dropped"
                , "* Comment tree above"
                ] =?>
      headerWith ("comment-tree-above", [], []) 1 "Comment tree above"

  , "Nothing but a COMMENT header" =:
      "* COMMENT Test" =?>
      (mempty::Blocks)

  , "Tree with :noexport:" =:
      T.unlines [ "* Should be ignored :archive:noexport:old:"
                , "** Old stuff"
                , "   This is not going to be exported"
                ] =?>
      (mempty::Blocks)

  , "Subtree with :noexport:" =:
      T.unlines [ "* Exported"
                , "** This isn't exported :noexport:"
                , "*** This neither"
                , "** But this is"
                ] =?>
      mconcat [ headerWith ("exported", [], []) 1 "Exported"
              , headerWith ("but-this-is", [], []) 2 "But this is"
              ]

  , "Preferences are treated as header attributes" =:
      T.unlines [ "* foo"
                , "  :PROPERTIES:"
                , "  :custom_id: fubar"
                , "  :bar: baz"
                , "  :END:"
                ] =?>
      headerWith ("fubar", [], [("bar", "baz")]) 1 "foo"


  , "Headers marked with a unnumbered property get a class of the same name" =:
      T.unlines [ "* Not numbered"
                , "  :PROPERTIES:"
                , "  :UNNUMBERED: t"
                , "  :END:"
                ] =?>
      headerWith ("not-numbered", ["unnumbered"], []) 1 "Not numbered"

  , testGroup "planning information"
    [ "Planning info is not included in output" =:
      T.unlines [ "* important"
                , T.unwords
                  [ "CLOSED: [2018-09-05 Wed 13:58]"
                  , "DEADLINE: <2018-09-17 Mon>"
                  , "SCHEDULED: <2018-09-10 Mon>"
                  ]
                ] =?>
      headerWith ("important", [], []) 1 "important"

    , "Properties after planning info are recognized" =:
      T.unlines [ "* important "
                , "  " <> T.unwords
                  [ "CLOSED: [2018-09-05 Wed 13:58]"
                  , "DEADLINE: <2018-09-17 Mon>"
                  , "SCHEDULED: <2018-09-10 Mon>"
                  ]
                , "  :PROPERTIES:"
                , "  :custom_id: look"
                , "  :END:"
                ] =?>
      headerWith ("look", [], []) 1 "important"

    , "Planning info followed by test" =:
      T.unlines [ "* important "
                , "  " <> T.unwords
                  [ "CLOSED: [2018-09-05 Wed 13:58]"
                  , "DEADLINE: <2018-09-17 Mon>"
                  , "SCHEDULED: <2018-09-10 Mon>"
                  ]
                , "  :PROPERTIES:"
                , "  :custom_id: look"
                , "  :END:"
                ] =?>
      headerWith ("look", [], []) 1 "important"

    , "third and forth level headers" =:
      T.unlines [ "#+options: p:t h:3"
                , "*** Third"
                , "    CLOSED: [2018-09-05 Wed 13:58]"
                , "    Text 3"
                , "**** Fourth"
                , "SCHEDULED: <2019-05-13 Mon 22:42>"
                , "Text 4"
                ] =?>
      mconcat
      [ headerWith ("third", [], mempty) 3 "Third"
      , plain $
        strong "CLOSED:" <> space <> emph (str "[2018-09-05 Wed 13:58]")
      , para "Text 3"
      , orderedList [
          mconcat
          [ para "Fourth"
          , plain $ strong "SCHEDULED:"
                    <> space
                    <> emph (str "<2019-05-13 Mon 22:42>")
          , para "Text 4"
          ]]
      ]
    ]
  ]