diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,22 @@ # Changelog +## 1.1.0 (2020-03-13) + +If you're reading this from the future, everyone is being silly about the Corona +Virus right now. + +#### Added + +- Support for heading tags, like `:foo:`. + +#### Changed + +- `OrgFile` now contains a raw `Map Text Text` for all metadata key-value pairs. + +#### Removed + +- The `Meta` type has been removed. + ## 1.0.1 (2020-03-06) #### Fixed diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,13 +5,14 @@ ## Assumptions -- File metadata appears at the top of the file in a specific order. +- File metadata like [In-buffer + Settings](https://orgmode.org/manual/In_002dbuffer-Settings.html#In_002dbuffer-Settings) + appears at the top of the file. ## 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 +- `:PROPERTIES:` diff --git a/lib/Data/Org.hs b/lib/Data/Org.hs --- a/lib/Data/Org.hs +++ b/lib/Data/Org.hs @@ -17,8 +17,6 @@ ( -- * Types OrgFile(..) , emptyOrgFile - , Meta(..) - , emptyMeta , OrgDoc(..) , emptyDoc , Section(..) @@ -50,51 +48,40 @@ import Control.Applicative.Combinators.NonEmpty import Control.Monad (void, when) +import Data.Bool (bool) import Data.Functor (($>)) import Data.Hashable (Hashable(..)) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL +import qualified Data.Map.Strict as M 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 + { orgMeta :: M.Map Text Text + -- ^ Top-level fields like: + -- + -- @ + -- #+TITLE: Curing Cancer with Haskell + -- #+DATE: 2020-02-25 + -- #+AUTHOR: Colin + -- @ , 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 +emptyOrgFile = OrgFile mempty emptyDoc -- | A recursive Org document. These are zero or more blocks of markup, followed -- by zero or more subsections. @@ -136,6 +123,7 @@ -- @ data Section = Section { sectionHeading :: NonEmpty Words + , sectionTags :: [Text] , sectionDoc :: OrgDoc } deriving stock (Eq, Show, Generic) deriving anyclass (Hashable) @@ -187,6 +175,7 @@ | Strike Text | Link URL (Maybe Text) | Image URL + | Tags (NonEmpty Text) | Punct Char | Plain Text deriving stock (Eq, Show, Generic) @@ -214,19 +203,16 @@ 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) +meta :: Parser (M.Map Text Text) +meta = L.lexeme space $ M.fromList <$> keyword `sepEndBy` newline where - date :: Parser Day - date = fromGregorian - <$> (L.decimal <* char '-') - <*> (L.decimal <* char '-') - <*> L.decimal + keyword :: Parser (Text, Text) + keyword = do + void $ string "#+" + key <- someTill' ':' + void $ string ": " + val <- someTillEnd + pure (key, val) orgP :: Parser OrgDoc orgP = orgP' 1 @@ -246,19 +232,22 @@ , 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' +heading :: Parser (T.Text, NonEmpty Words, [Text]) +heading = do + stars <- someOf '*' <* char ' ' + ws <- line '\n' + case nelUnsnoc ws of + (Tags ts, Just rest) -> pure (stars, rest, NEL.toList ts) + _ -> pure (stars, ws, []) section :: Int -> Parser Section section depth = L.lexeme space $ do - (stars, ws) <- heading + (stars, ws, ts) <- 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) + Section ws ts <$> orgP' (succ depth) quote :: Parser Block quote = L.lexeme space $ do @@ -365,6 +354,7 @@ , try $ Strike <$> between (char '+') (char '+') (someTill' '+') <* pOrS , try image , try link + , try tags , try $ Punct <$> oneOf punc , Plain <$> takeWhile1P (Just "plain text") (\c -> c /= ' ' && c /= end) ] where @@ -374,6 +364,11 @@ punc :: String punc = ".,!?():;'" +tags :: Parser Words +tags = do + void $ char ':' + Tags <$> (T.pack . NEL.toList <$> some letterChar) `sepEndBy1` char ':' + image :: Parser Words image = between (char '[') (char ']') $ between (char '[') (char ']') $ do @@ -409,15 +404,9 @@ 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 + metas = T.intercalate "\n" + $ map (\(l, t) -> "#+" <> l <> ": " <> t) + $ M.toList m prettyOrg :: OrgDoc -> Text prettyOrg = prettyOrg' 1 @@ -427,9 +416,15 @@ T.intercalate "\n\n" $ map prettyBlock bs <> map (prettySection depth) ss prettySection :: Int -> Section -> Text -prettySection depth (Section ws od) = headig <> "\n\n" <> subdoc +prettySection depth (Section ws ts od) = headig <> "\n\n" <> subdoc where - headig = T.unwords $ T.replicate depth "*" : NEL.toList (NEL.map prettyWords ws) + -- TODO There is likely a punctuation bug here. + headig = T.unwords + $ T.replicate depth "*" + : NEL.toList (NEL.map prettyWords ws) + <> bool [":" <> T.intercalate ":" ts <> ":"] [] (null ts) + + subdoc :: Text subdoc = prettyOrg' (succ depth) od prettyBlock :: Block -> Text @@ -484,5 +479,9 @@ Link (URL url) Nothing -> "[[" <> url <> "]]" Link (URL url) (Just t) -> "[[" <> url <> "][" <> t <> "]]" Image (URL url) -> "[[" <> url <> "]]" + Tags ts -> ":" <> T.intercalate ":" (NEL.toList ts) <> ":" Punct c -> T.singleton c Plain t -> t + +nelUnsnoc :: NonEmpty a -> (a, Maybe (NonEmpty a)) +nelUnsnoc ne = (NEL.last ne, NEL.nonEmpty $ NEL.init ne) diff --git a/org-mode.cabal b/org-mode.cabal --- a/org-mode.cabal +++ b/org-mode.cabal @@ -1,7 +1,9 @@ cabal-version: 2.2 name: org-mode -version: 1.0.1 +version: 1.1.0 +synopsis: Parser for Emacs org-mode files. description: Parser for Emacs org-mode files. +category: Data homepage: https://github.com/fosskers/org-mode author: Colin Woodbury maintainer: colin@fosskers.ca @@ -21,18 +23,19 @@ ghc-options: -Wall -Wpartial-fields -Wincomplete-record-updates -Wincomplete-uni-patterns -Widentities + -funclutter-valid-hole-fits 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: + , containers >=0.6 , filepath , hashable >=1.2 && <1.4 , parser-combinators >=1.1 && <1.3 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -7,7 +7,6 @@ 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 @@ -29,18 +28,27 @@ suite simple full = testGroup "Unit Tests" [ testGroup "Basic Markup" [ testCase "Header" $ parseMaybe (section 1) "* A" - @?= Just (Section [Plain "A"] emptyDoc) + @?= Just (Section [Plain "A"] [] emptyDoc) , testCase "Header - Subsection" $ parseMaybe (section 1) "* A\n** B" - @?= Just (Section [Plain "A"] (OrgDoc [] [Section [Plain "B"] emptyDoc])) + @?= 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 ] + $ 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 ] + [ Section [Plain "A"] [] (OrgDoc [Paragraph [Plain "D"]] [Section [Plain "B"] [] emptyDoc]) + , Section [Plain "C"] [] emptyDoc ] + , testCase "Header - Tags" + $ testPretty orgP "Header" "* A :this:that:" + $ OrgDoc [] [Section [Plain "A"] ["this", "that"] emptyDoc] + , testCase "Header - More Tags" + $ testPretty orgP "Header" "* A :this:that:\n** B :other:\n* C" + $ OrgDoc [] + [ Section [Plain "A"] ["this", "that"] (OrgDoc [] [Section [Plain "B"] ["other"] emptyDoc]) + , Section [Plain "C"] [] emptyDoc + ] , testCase "Bold" $ parseMaybe orgP "*Bold*" @?= Just (OrgDoc [Paragraph [Bold "Bold"]] []) @@ -160,12 +168,13 @@ , 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 + [("TITLE", "Test")] , 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 + [("TITLE", "Test"), ("DATE", "2020-02-17"), ("AUTHOR", "Colin")] ] , testGroup "Pretty Printing" [ testCase "Punctuation" $ do