diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Changelog + +## 1.0.0 (2020-03-05) + +#### Added + +- Initial version of all types, parsers, and pretty-printers. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Colin Woodbury (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,17 @@ +# org-mode + +`org-mode` is a library for parsing text in the [Emacs +org-mode](https://orgmode.org/) format. + +## Assumptions + +- File metadata appears at the top of the file in a specific order. + +## Unimplemented + +The following don't parse as of yet: + +- Table Formulas +- Heading tags +- Certain top-level document metadata +- Anything involving the TODO system or clocking-in diff --git a/lib/Data/Org.hs b/lib/Data/Org.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Org.hs @@ -0,0 +1,488 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | +-- Module : Data.Org +-- Copyright : (c) Colin Woodbury, 2020 +-- License : BSD3 +-- Maintainer: Colin Woodbury +-- +-- This library parses text in the format. +-- +-- Use the `org` function to parse a `T.Text` value. + +module Data.Org + ( -- * Types + OrgFile(..) + , emptyOrgFile + , Meta(..) + , emptyMeta + , OrgDoc(..) + , emptyDoc + , Section(..) + , Block(..) + , Words(..) + , ListItems(..) + , Item(..) + , Row(..) + , Column(..) + , URL(..) + , Language(..) + -- * Parsing + , org + -- ** Internal Parsers + -- | These are exposed for testing purposes. + , orgFile + , meta + , orgP + , section + , paragraph + , table + , list + , line + -- * Pretty Printing + , prettyOrgFile + , prettyOrg + , prettyWords + ) where + +import Control.Applicative.Combinators.NonEmpty +import Control.Monad (void, when) +import Data.Functor (($>)) +import Data.Hashable (Hashable(..)) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NEL +import Data.Semigroup (sconcat) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day, fromGregorian, toGregorian) +import Data.Void (Void) +import GHC.Generics (Generic) +import System.FilePath (takeExtension) +import Text.Megaparsec hiding (sepBy1, sepEndBy1, some, someTill) +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L +import Text.Printf (printf) + +-------------------------------------------------------------------------------- +-- Types + +-- | A complete @.org@ file with metadata. +data OrgFile = OrgFile + { orgMeta :: Meta + , orgDoc :: OrgDoc } + deriving stock (Eq, Show, Generic) + +emptyOrgFile :: OrgFile +emptyOrgFile = OrgFile emptyMeta emptyDoc + +-- | Top-level fields like: +-- +-- @ +-- #+TITLE: Curing Cancer with Haskell +-- #+DATE: 2020-02-25 +-- #+AUTHOR: Colin +-- @ +data Meta = Meta + { metaTitle :: Maybe Text + , metaDate :: Maybe Day + , metaAuthor :: Maybe Text + , metaHtmlHead :: Maybe Text + , metaOptions :: Maybe Text } + deriving stock (Eq, Show, Generic) + +emptyMeta :: Meta +emptyMeta = Meta Nothing Nothing Nothing Nothing Nothing + +-- | A recursive Org document. These are zero or more blocks of markup, followed +-- by zero or more subsections. +-- +-- @ +-- This is some top-level text. +-- +-- * Important heading +-- +-- ** Less important subheading +-- @ +data OrgDoc = OrgDoc + { docBlocks :: [Block] + , docSections :: [Section] } + deriving stock (Eq, Show, Generic) + deriving anyclass (Hashable) + +emptyDoc :: OrgDoc +emptyDoc = OrgDoc [] [] + +-- | Some logically distinct block of Org content. +data Block + = Quote Text + | Example Text + | Code (Maybe Language) Text + | List ListItems + | Table (NonEmpty Row) + | Paragraph (NonEmpty Words) + deriving stock (Eq, Show, Generic) + deriving anyclass (Hashable) + +-- | A subsection, marked by a heading line and followed recursively by an +-- `OrgDoc`. +-- +-- @ +-- * This is a Heading +-- +-- This is content in the sub ~OrgDoc~. +-- @ +data Section = Section + { sectionHeading :: NonEmpty Words + , sectionDoc :: OrgDoc } + deriving stock (Eq, Show, Generic) + deriving anyclass (Hashable) + +-- | An org list constructed of @-@ characters. +-- +-- @ +-- - Feed the cat +-- - The good stuff +-- - Feed the dog +-- - He'll eat anything +-- - Feed the bird +-- - Feed the alligator +-- - Feed the elephant +-- @ +newtype ListItems = ListItems (NonEmpty Item) + deriving stock (Eq, Show, Generic) + deriving anyclass (Hashable) + +-- | A line in a bullet-list. Can contain sublists, as shown in `ListItems`. +data Item = Item (NonEmpty Words) (Maybe ListItems) + deriving stock (Eq, Show, Generic) + deriving anyclass (Hashable) + +-- | A row in an org table. Can have content or be a horizontal rule. +-- +-- @ +-- | A | B | C | +-- |---+---+---| +-- | D | E | F | +-- @ +data Row = Break | Row (NonEmpty Column) + deriving stock (Eq, Show, Generic) + deriving anyclass (Hashable) + +-- | A possibly empty column in an org table. +data Column = Empty | Column (NonEmpty Words) + deriving stock (Eq, Show, Generic) + deriving anyclass (Hashable) + +-- | The fundamental unit of Org text content. `Plain` units are split +-- word-by-word. +data Words + = Bold Text + | Italic Text + | Highlight Text + | Underline Text + | Verbatim Text + | Strike Text + | Link URL (Maybe Text) + | Image URL + | Punct Char + | Plain Text + deriving stock (Eq, Show, Generic) + deriving anyclass (Hashable) + +-- | The url portion of a link. +newtype URL = URL Text + deriving stock (Eq, Show, Generic) + deriving anyclass (Hashable) + +-- | The programming language some source code block was written in. +newtype Language = Language Text + deriving stock (Eq, Show, Generic) + deriving anyclass (Hashable) + +-------------------------------------------------------------------------------- +-- Parser + +-- | Attempt to parse an `OrgFile`. +org :: Text -> Maybe OrgFile +org = parseMaybe orgFile + +type Parser = Parsec Void Text + +orgFile :: Parser OrgFile +orgFile = space *> L.lexeme space (OrgFile <$> meta <*> orgP) <* eof + +meta :: Parser Meta +meta = L.lexeme space $ Meta + <$> optional (string "#+TITLE: " *> someTillEnd <* space) + <*> optional (string "#+DATE: " *> date <* space) + <*> optional (string "#+AUTHOR: " *> someTillEnd <* space) + <*> optional (string "#+HTML_HEAD: " *> someTillEnd <* space) + <*> optional (string "#+OPTIONS: " *> someTillEnd <* space) + where + date :: Parser Day + date = fromGregorian + <$> (L.decimal <* char '-') + <*> (L.decimal <* char '-') + <*> L.decimal + +orgP :: Parser OrgDoc +orgP = orgP' 1 + +orgP' :: Int -> Parser OrgDoc +orgP' depth = L.lexeme space $ OrgDoc + <$> many block + <*> many (try $ section depth) + where + block :: Parser Block + block = choice + [ try code + , try example + , try quote + , try list + , try table + , paragraph ] -- TODO Paragraph needs to fail if it detects a heading. + +-- | If a line stars with @*@ and a space, it is a `Section` heading. +heading :: Parser (T.Text, NonEmpty Words) +heading = (,) + <$> someOf '*' <* char ' ' + <*> line '\n' + +section :: Int -> Parser Section +section depth = L.lexeme space $ do + (stars, ws) <- heading + -- Fail if we've found a parent heading -- + when (T.length stars < depth) $ failure Nothing mempty + -- Otherwise continue -- + void space + Section ws <$> orgP' (succ depth) + +quote :: Parser Block +quote = L.lexeme space $ do + void top <* newline + ls <- manyTill (manyTillEnd <* newline) bot + pure . Quote $ T.intercalate "\n" ls + where + top = string "#+" *> (string "BEGIN_QUOTE" <|> string "begin_quote") + bot = string "#+" *> (string "END_QUOTE" <|> string "end_quote") + +example :: Parser Block +example = L.lexeme space $ do + void top <* newline + ls <- manyTill (manyTillEnd <* newline) bot + pure . Example $ T.intercalate "\n" ls + where + top = string "#+" *> (string "BEGIN_EXAMPLE" <|> string "begin_example") + bot = string "#+" *> (string "END_EXAMPLE" <|> string "end_example") + +code :: Parser Block +code = L.lexeme space $ do + lang <- top *> optional lng <* newline + ls <- manyTill (manyTillEnd <* newline) bot + pure . Code (Language <$> lang) $ T.intercalate "\n" ls + where + top = string "#+" *> (string "BEGIN_SRC" <|> string "begin_src") + bot = string "#+" *> (string "END_SRC" <|> string "end_src") + lng = char ' ' *> someTillEnd + +list :: Parser Block +list = L.lexeme space $ List <$> listItems 0 + +listItems :: Int -> Parser ListItems +listItems indent = ListItems + <$> sepBy1 (item indent) (try $ newline *> lookAhead (nextItem indent)) + +nextItem :: Int -> Parser () +nextItem indent = do + void . string $ T.replicate indent " " + void $ string "- " + +-- | Conditions for ending the current bullet: +-- +-- 1. You find two '\n' at the end of a line. +-- 2. The first two non-space characters of the next line are "- ". +item :: Int -> Parser Item +item indent = do + leading <- string $ T.replicate indent " " + void $ string "- " + l <- bullet + let !nextInd = T.length leading + 2 + Item l <$> optional (try $ newline *> listItems nextInd) + where + bullet :: Parser (NonEmpty Words) + bullet = do + l <- line '\n' + try (lookAhead keepGoing *> space *> ((l <>) <$> bullet)) <|> pure l + + keepGoing :: Parser () + keepGoing = void $ char '\n' *> manyOf ' ' *> noneOf ['-', '\n'] + +table :: Parser Block +table = L.lexeme space $ Table <$> sepEndBy1 row (char '\n') + where + row :: Parser Row + row = do + void $ char '|' + brk <|> (Row <$> sepEndBy1 column (char '|')) + + -- | If the line starts with @|-@, assume its a break regardless of what + -- chars come after that. + brk :: Parser Row + brk = char '-' *> manyTillEnd $> Break + + column :: Parser Column + column = do + void $ someOf ' ' + (lookAhead (char '|') $> Empty) <|> (Column <$> line '|') + +paragraph :: Parser Block +paragraph = L.lexeme space $ do + notFollowedBy heading + Paragraph . sconcat <$> sepEndBy1 (line '\n') newline + +line :: Char -> Parser (NonEmpty Words) +line end = sepEndBy1 (wordChunk end) (manyOf ' ') + +-- | RULES +-- +-- 1. In-lined markup is not recognized: This is not*bold*. Neither is *this*here. +-- 2. Punctuation immediately after markup close /is/ allowed: *This*, in fact, is bold. +-- 3. Otherwise, a space, newline or EOF is necessary after the close. +-- 4. Any char after a link is fine. +-- 5. When rerendering, a space must not appear between the end of a markup close and +-- a punctuation/newline character. +-- 6. But any other character must have a space before it. +wordChunk :: Char -> Parser Words +wordChunk end = choice + [ try $ Bold <$> between (char '*') (char '*') (someTill' '*') <* pOrS + , try $ Italic <$> between (char '/') (char '/') (someTill' '/') <* pOrS + , try $ Highlight <$> between (char '~') (char '~') (someTill' '~') <* pOrS + , try $ Verbatim <$> between (char '=') (char '=') (someTill' '=') <* pOrS + , try $ Underline <$> between (char '_') (char '_') (someTill' '_') <* pOrS + , try $ Strike <$> between (char '+') (char '+') (someTill' '+') <* pOrS + , try image + , try link + , try $ Punct <$> oneOf punc + , Plain <$> takeWhile1P (Just "plain text") (\c -> c /= ' ' && c /= end) ] + where + pOrS :: Parser () + pOrS = lookAhead $ void (oneOf $ end : ' ' : punc) <|> eof + +punc :: String +punc = ".,!?():;'" + +image :: Parser Words +image = between (char '[') (char ']') $ + between (char '[') (char ']') $ do + path <- someTill' ']' + let !ext = takeExtension $ T.unpack path + when (ext `notElem` [".jpg", ".jpeg", ".png"]) $ failure Nothing mempty + pure . Image $ URL path + +link :: Parser Words +link = between (char '[') (char ']') $ Link + <$> between (char '[') (char ']') (URL <$> someTill' ']') + <*> optional (between (char '[') (char ']') (someTill' ']')) + +someTillEnd :: Parser Text +someTillEnd = someTill' '\n' + +manyTillEnd :: Parser Text +manyTillEnd = takeWhileP (Just "many until the end of the line") (/= '\n') + +someTill' :: Char -> Parser Text +someTill' c = takeWhile1P (Just $ "some until " <> [c]) (/= c) + +-- | Fast version of `some` specialized to `Text`. +someOf :: Char -> Parser Text +someOf c = takeWhile1P (Just $ "some of " <> [c]) (== c) + +manyOf :: Char -> Parser Text +manyOf c = takeWhileP (Just $ "many of " <> [c]) (== c) + +-------------------------------------------------------------------------------- +-- Pretty Printing + +prettyOrgFile :: OrgFile -> Text +prettyOrgFile (OrgFile m os) = metas <> "\n\n" <> prettyOrg os + where + metas = T.intercalate "\n" $ + maybe [] (\t -> ["#+TITLE: " <> t]) (metaTitle m) + <> maybe [] (pure . T.pack . day) (metaDate m) + <> maybe [] (\a -> ["#+AUTHOR: " <> a]) (metaAuthor m) + <> maybe [] (\h -> ["#+HTML_HEAD: " <> h]) (metaHtmlHead m) + + day :: Day -> String + day d = case toGregorian d of + (yr, mn, dy) -> printf "#+DATE: %d-%02d-%02d" yr mn dy + +prettyOrg :: OrgDoc -> Text +prettyOrg = prettyOrg' 1 + +prettyOrg' :: Int -> OrgDoc -> Text +prettyOrg' depth (OrgDoc bs ss) = + T.intercalate "\n\n" $ map prettyBlock bs <> map (prettySection depth) ss + +prettySection :: Int -> Section -> Text +prettySection depth (Section ws od) = headig <> "\n\n" <> subdoc + where + headig = T.unwords $ T.replicate depth "*" : NEL.toList (NEL.map prettyWords ws) + subdoc = prettyOrg' (succ depth) od + +prettyBlock :: Block -> Text +prettyBlock o = case o of + Code l t -> "#+begin_src" <> maybe "" (\(Language l') -> " " <> l' <> "\n") l + <> t + <> "\n#+end_src" + Quote t -> "#+begin_quote\n" <> t <> "\n#+end_quote" + Example t -> "#+begin_example\n" <> t <> "\n#+end_example" + Paragraph ht -> par ht + List items -> lis 0 items + Table rows -> T.intercalate "\n" . map row $ NEL.toList rows + where + lis :: Int -> ListItems -> Text + lis indent (ListItems is) = T.intercalate "\n" . map (f indent) $ NEL.toList is + + f :: Int -> Item -> Text + f indent (Item ws li) = + T.replicate indent " " <> "- " <> par ws + <> maybe "" (\is -> "\n" <> lis (indent + 2) is) li + + par :: NonEmpty Words -> Text + par (h :| t) = prettyWords h <> para h t + + -- | Stick punctuation directly behind the chars in front of it, while + -- paying special attention to parentheses. + para :: Words -> [Words] -> Text + para _ [] = "" + para pr (w:ws) = case pr of + Punct '(' -> prettyWords w <> para w ws + _ -> case w of + Punct '(' -> " " <> prettyWords w <> para w ws + Punct _ -> prettyWords w <> para w ws + _ -> " " <> prettyWords w <> para w ws + + row :: Row -> Text + row Break = "|-|" + row (Row cs) = "| " <> (T.intercalate " | " . map col $ NEL.toList cs) <> " |" + + col :: Column -> Text + col Empty = "" + col (Column ws) = T.unwords . map prettyWords $ NEL.toList ws + +prettyWords :: Words -> Text +prettyWords w = case w of + Bold t -> "*" <> t <> "*" + Italic t -> "/" <> t <> "/" + Highlight t -> "~" <> t <> "~" + Underline t -> "_" <> t <> "_" + Verbatim t -> "=" <> t <> "=" + Strike t -> "+" <> t <> "+" + Link (URL url) Nothing -> "[[" <> url <> "]]" + Link (URL url) (Just t) -> "[[" <> url <> "][" <> t <> "]]" + Image (URL url) -> "[[" <> url <> "]]" + Punct c -> T.singleton c + Plain t -> t diff --git a/org-mode.cabal b/org-mode.cabal new file mode 100644 --- /dev/null +++ b/org-mode.cabal @@ -0,0 +1,47 @@ +cabal-version: 2.2 +name: org-mode +version: 1.0.0 +description: Parser for Emacs org-mode files. +homepage: https://github.com/fosskers/org-mode +author: Colin Woodbury +maintainer: colin@fosskers.ca +copyright: 2020 Colin Woodbury +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +common commons + default-language: Haskell2010 + default-extensions: OverloadedStrings + ghc-options: + -Wall -Wpartial-fields -Wincomplete-record-updates + -Wincomplete-uni-patterns -Widentities + + build-depends: + , base >=4.12 && <5 + , megaparsec >=7 && <9 + , text + , time >=1.8 && <1.10 + +library + import: commons + hs-source-dirs: lib + exposed-modules: Data.Org + build-depends: + , filepath + , hashable >=1.2 && <1.4 + , parser-combinators >=1.1 && <1.3 + +test-suite org-mode-test + import: commons + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , org-mode + , tasty ^>=1.2 + , tasty-hunit ^>=0.10 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedLists #-} + +module Main where + +import Data.Org +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Time.Calendar (fromGregorian) +import Data.Void (Void) +import Test.Tasty +import Test.Tasty.HUnit +import Text.Megaparsec +import Text.Megaparsec.Char + +--- + +main :: IO () +main = do + simple <- T.readFile "test/simple.org" + full <- T.readFile "test/test.org" + let fl = parseMaybe orgFile full + -- pPrintNoColor fl + maybe (putStrLn "COULDN'T PARSE") T.putStrLn $ prettyOrgFile <$> fl + defaultMain $ suite simple full + +suite :: T.Text -> T.Text -> TestTree +suite simple full = testGroup "Unit Tests" + [ testGroup "Basic Markup" + [ testCase "Header" $ parseMaybe (section 1) "* A" + @?= Just (Section [Plain "A"] emptyDoc) + , testCase "Header - Subsection" $ parseMaybe (section 1) "* A\n** B" + @?= Just (Section [Plain "A"] (OrgDoc [] [Section [Plain "B"] emptyDoc])) + , testCase "Header - Back again" + $ testPretty orgP "Header" "* A\n** B\n* C" + $ OrgDoc [] [ Section [Plain "A"] (OrgDoc [] [Section [Plain "B"] emptyDoc]) + , Section [Plain "C"] emptyDoc ] + , testCase "Header - Contents" + $ testPretty orgP "Header" "* A\nD\n\n** B\n* C" -- TODO Requires an extra newline! + $ OrgDoc [] + [ Section [Plain "A"] (OrgDoc [Paragraph [Plain "D"]] [Section [Plain "B"] emptyDoc]) + , Section [Plain "C"] emptyDoc ] + + , testCase "Bold" $ parseMaybe orgP "*Bold*" + @?= Just (OrgDoc [Paragraph [Bold "Bold"]] []) + , testCase "Italics" $ parseMaybe orgP "/Italic/" + @?= Just (OrgDoc [Paragraph [Italic "Italic"]] []) + , testCase "Highlight" $ parseMaybe orgP "~Highlight~" + @?= Just (OrgDoc [Paragraph [Highlight "Highlight"]] []) + , testCase "Verbatim" $ parseMaybe orgP "=Verbatim=" + @?= Just (OrgDoc [Paragraph [Verbatim "Verbatim"]] []) + , testCase "Underline" $ parseMaybe orgP "_Underline_" + @?= Just (OrgDoc [Paragraph [Underline "Underline"]] []) + , testCase "Strike" $ parseMaybe orgP "+Strike+" + @?= Just (OrgDoc [Paragraph [Strike "Strike"]] []) + + , testCase "Link" $ parseMaybe orgP "[[https://www.fosskers.ca][Site]]" + @?= Just (OrgDoc [Paragraph [Link (URL "https://www.fosskers.ca") (Just "Site")]] []) + , testCase "Link (no desc)" $ parseMaybe orgP "[[https://www.fosskers.ca]]" + @?= Just (OrgDoc [Paragraph [Link (URL "https://www.fosskers.ca") Nothing]] []) + + , testCase "Image" $ parseMaybe orgP "[[/path/to/img.jpeg]]" + @?= Just (OrgDoc [Paragraph [Image (URL "/path/to/img.jpeg")]] []) + , testCase "Image - False Positive" + $ testPretty paragraph "Image" "[[http://a.ca][hi]] [[a.png]]" + $ Paragraph [Link (URL "http://a.ca") (Just "hi"), Image (URL "a.png")] + + , testCase "Plain" $ parseMaybe orgP "This is a line" + @?= Just (OrgDoc [Paragraph [Plain "This", Plain "is", Plain "a", Plain "line"]] []) + ] + , testGroup "Markup Edge Cases" + [ testCase "Before" $ parseMaybe orgP "This is *not*bold." + @?= Just (OrgDoc [Paragraph [Plain "This", Plain "is", Plain "*not*bold."]] []) + , testCase "After" $ parseMaybe orgP "Neither is *this*here." + @?= Just (OrgDoc [Paragraph [Plain "Neither", Plain "is", Plain "*this*here."]] []) + , testCase "Punctuation - Comma" $ parseMaybe orgP "*This*, is bold." + @?= Just (OrgDoc [Paragraph [Bold "This", Punct ',', Plain "is", Plain "bold."]] []) + + , testCase "Punctuation - Paren" $ parseMaybe orgP "(the ~be~)" + @?= Just (OrgDoc [Paragraph [Punct '(', Plain "the", Highlight "be", Punct ')']] []) + + , testCase "Punctuation - Double parens" + $ testPretty paragraph "Parens" "(~Hello~)" + $ Paragraph [Punct '(', Highlight "Hello", Punct ')'] + + , testCase "Line - Plain" $ testPretty (line '\n') "Line" "A" [Plain "A"] + , testCase "Line - Wide Gap" $ testPretty (line '\n') "Line" "A B" + [Plain "A", Plain "B"] + , testCase "Line - Newline" $ testPretty (line '\n') "Line" "A\n" [Plain "A"] + , testCase "Line - Space at end" $ testPretty (line '\n') "Line" "A \n" [Plain "A"] + , testCase "Line - Dummy markup symbol" $ testPretty (line '\n') "Line" "A ~ B" + [Plain "A", Plain "~", Plain "B"] + ] + , testGroup "Composite Structures" + [ testCase "Example" $ parseMaybe orgP "#+begin_example\nHi!\n\nHo\n#+end_example" + @?= Just (OrgDoc [Example "Hi!\n\nHo"] []) + , testCase "Example - Empty" $ parseMaybe orgP "#+begin_example\n#+end_example" + @?= Just (OrgDoc [Example ""] []) + , testCase "Quote" $ parseMaybe orgP "#+begin_quote\nHi!\n\nHo\n#+end_quote" + @?= Just (OrgDoc [Quote "Hi!\n\nHo"] []) + , testCase "Quote - Empty" $ parseMaybe orgP "#+begin_quote\n#+end_quote" + @?= Just (OrgDoc [Quote ""] []) + , testCase "Code" $ parseMaybe orgP "#+begin_src haskell\n1 + 1\n#+end_src" + @?= Just (OrgDoc [Code (Just $ Language "haskell") "1 + 1"] []) + , testCase "Code - Empty" $ parseMaybe orgP "#+begin_src haskell\n#+end_src" + @?= Just (OrgDoc [Code (Just $ Language "haskell") ""] []) + , testCase "Code - No Language" $ parseMaybe orgP "#+begin_src\n1 + 1\n#+end_src" + @?= Just (OrgDoc [Code Nothing "1 + 1"] []) + + , testCase "List - Single Indent" + $ testPretty list "List" "- A\n - B" + $ List (ListItems [Item [Plain "A"] (Just $ ListItems [Item [Plain "B"] Nothing])]) + + , testCase "List - Indent and Back" + $ testPretty list "List" "- A\n - B\n- C" + $ List (ListItems + [ Item [Plain "A"] (Just $ ListItems [Item [Plain "B"] Nothing]) + , Item [Plain "C"] Nothing ]) + + , testCase "List - Double Indent and Back" + $ testPretty list "List" "- A\n - B\n - C\n- D" + $ List (ListItems + [ Item [Plain "A"] (Just $ ListItems [Item [Plain "B"] Nothing, Item [Plain "C"] Nothing]) + , Item [Plain "D"] Nothing ]) + + , testCase "List - Things after" $ parseMaybe orgP "- A\n - B\n- C\n\nD" + @?= Just (OrgDoc [ List (ListItems + [ Item [Plain "A"] (Just $ ListItems [Item [Plain "B"] Nothing]) + , Item [Plain "C"] Nothing]) + , Paragraph [Plain "D"]] []) + + , testCase "List - Multiline" + $ testPretty list "List" "- A\n B\n- C" + $ List (ListItems [Item [Plain "A", Plain "B"] Nothing, Item [Plain "C"] Nothing]) + + , testCase "Table - One Row" + $ testPretty table "Table" "| A | B | C |" + $ Table [Row [Column [Plain "A"], Column [Plain "B"], Column [Plain "C"]]] + + , testCase "Table - One Row and Break" + $ testPretty table "Table" "| A | B | C |\n|---+---+---|" + $ Table [ Row [Column [Plain "A"], Column [Plain "B"], Column [Plain "C"]] + , Break ] + , testCase "Table - Row, Break, Row" + $ testPretty table "Table" "| A | B | C |\n|---+---+---|\n| D | E | F |" + $ Table [ Row [Column [Plain "A"], Column [Plain "B"], Column [Plain "C"]] + , Break + , Row [Column [Plain "D"], Column [Plain "E"], Column [Plain "F"]]] + , testCase "Table - Markup" + $ testPretty table "Table" "| *A* Yes | /B/ No |" + $ Table [Row [Column [Bold "A", Plain "Yes"], Column [Italic "B", Plain "No"]]] + , testCase "Table - Empty Column" + $ testPretty table "Table" "| A | | C |" + $ Table [Row [Column [Plain "A"], Empty, Column [Plain "C"]]] + , testCase "Meta - Title" + $ testPretty meta "Meta" "#+TITLE: Test" + $ Meta (Just "Test") Nothing Nothing Nothing Nothing + , testCase "Meta - Full" + $ testPretty meta "Meta" "#+TITLE: Test\n#+DATE: 2020-02-17\n#+AUTHOR: Colin" + $ Meta (Just "Test") (Just $ fromGregorian 2020 2 17) (Just "Colin") Nothing Nothing + ] + , testGroup "Pretty Printing" + [ testCase "Punctuation" $ do + let !orig = parseMaybe orgP "A /B/. C?" + (prettyOrg <$> orig) @?= Just "A /B/. C?" + ] + , testGroup "Full Files" + [ testCase "Simple" $ case parse orgFile "simple.org" simple of + Left eb -> assertFailure $ errorBundlePretty eb + Right r -> case parse orgFile "simple.org - reparse" (prettyOrgFile r) of + Left eb' -> assertFailure $ errorBundlePretty eb' + Right r' -> r' @?= r + , testCase "Full" $ case parse orgFile "test.org" full of + Left eb -> assertFailure $ errorBundlePretty eb + Right r -> case parse orgFile "test.org - reparse" (prettyOrgFile r) of + Left eb' -> assertFailure $ errorBundlePretty eb' + Right r' -> r' @?= r + ] + , testGroup "Megaparsec Sanity" + [ testCase "sepEndBy1" $ testPretty sepTest "sepBy1" "A.A.A.B" ['A', 'A', 'A'] + ] + ] + +testPretty :: (Eq a, Show a) => Parsec Void Text a -> String -> Text -> a -> Assertion +testPretty parser labl src expt = case parse parser labl src of + Left eb -> assertFailure $ errorBundlePretty eb + Right r -> r @?= expt + +-- | Conclusion: If the separator appears but the next parse attempt fails, the +-- /whole/ thing fails. +sepTest :: Parsec Void Text String +sepTest = char 'A' `sepEndBy1` char '.'