org-mode 1.0.1 → 1.1.0
raw patch · 5 files changed
+96/−67 lines, 5 filesdep +containersdep −time
Dependencies added: containers
Dependencies removed: time
Files
- CHANGELOG.md +17/−0
- README.md +4/−3
- lib/Data/Org.hs +52/−53
- org-mode.cabal +5/−2
- test/Test.hs +18/−9
CHANGELOG.md view
@@ -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
README.md view
@@ -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:`
lib/Data/Org.hs view
@@ -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)
org-mode.cabal view
@@ -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
test/Test.hs view
@@ -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