orgmode (empty) → 0.1.0.0
raw patch · 8 files changed
+796/−0 lines, 8 filesdep +HStringTemplatedep +QuickCheckdep +basesetup-changed
Dependencies added: HStringTemplate, QuickCheck, base, containers, hspec, network, network-uri, parsec, random, regex-posix, syb, text
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- orgmode.cabal +45/−0
- src/Data/OrgMode.hs +372/−0
- src/Data/OrgMode/Doc.hs +108/−0
- src/Data/OrgMode/OrgDocView.hs +101/−0
- src/Data/OrgMode/Text.hs +136/−0
- tests/MainTestSuite.hs +2/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Lally Singh++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 Lally Singh 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ orgmode.cabal view
@@ -0,0 +1,45 @@+-- Initial orgmode.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: orgmode+version: 0.1.0.0+synopsis: Org Mode library for haskell+description: A library to read and write emacs org-mode documents.+license: BSD3+license-file: LICENSE+author: Lally Singh+maintainer: yell@lal.ly+-- copyright: +category: Data+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++flag network-uri+ description: Get Network.URI from the network-uri package+ default: True++library+ exposed-modules: Data.OrgMode, Data.OrgMode.Text, Data.OrgMode.Doc, Data.OrgMode.OrgDocView+ -- other-modules: + -- other-extensions: + build-depends: base >=4.7 && <4.8, parsec, text, regex-posix, containers, HStringTemplate >= 0.7.3,+ syb+ hs-source-dirs: src+ default-language: Haskell2010++Test-Suite spec+ type: exitcode-stdio-1.0+ hs-source-dirs: tests, src+ main-is: MainTestSuite.hs+ build-depends: base >=4.7 && <4.8, parsec, text, regex-posix, containers, HStringTemplate >= 0.7.3,+ syb, QuickCheck, hspec >= 1.3, random+ if flag(network-uri)+ build-depends: network-uri >= 2.6, network >= 2.6+ else+ build-depends: network-uri < 2.6, network < 2.6++ -- Base language which the package is written in.+ default-language: Haskell2010++
+ src/Data/OrgMode.hs view
@@ -0,0 +1,372 @@+{-# LANGUAGE BangPatterns #-}+{-|+Module : Data.OrgMode+Description : Parser and Serializer for Emacs OrgMode+Copyright : (c) Lally Singh, 2015+License : BSD3+Maintainer : yell@lal.ly+Stability : experimental+Portability : BangPatterns, GADTs, DeriveDataTypeable, StandaloneDeriving++A package to parse and interpret Emacs Org-Mode documents. It also supports+arbitrary types that map back and forth with 'Node'. Create an instance of+@NodeUpdate a@ and use @OrgDocView a@ to read/write values of @a@ in an+org-mode file. Property drawers are great for this mapping.+-}++module Data.OrgMode (+ Prefix(..), Drawer(..), Babel(..), Table(..), NodeChild(..), Node(..),+ OrgFileProperty(..), OrgFileElement(..),+ OrgDocView(..), NodeUpdate(..), OrgDoc(..), TextLine(..), LineNumber(..),+ TextLineSource(..),+-- toNumber, isNumber, linesStartingFrom, hasNumber, makeDrawerLines,+-- makeNodeLine, parseLine,+ orgFile, generateDocView, getRawElements, updateNode, + addOrgLine, emptyZip, categorizeLines+ ) where+-- TODO(lally): only export the interesting things!++import Data.OrgMode.Text+import Data.OrgMode.Doc+import Data.OrgMode.OrgDocView+-- import Sync.Issue++import Control.Monad+import Data.Char (toUpper, isAlphaNum)+import Data.List+import Data.Maybe (mapMaybe, fromJust, catMaybes, isJust, isNothing)+import Data.Monoid+import Debug.Trace (trace)+import Text.Parsec+import Text.Regex.Posix+import Text.StringTemplate++-- ** Zipper Facilities+-- | The document is a forest of Nodes, with properties. The Node+-- Path is the currently-constructing tree of nodes. The path is+-- sorted by 'nDepth', in descending order, with each element's parent+-- after it in the list.+data OrgDocZipper = OrgDocZipper+ { ozNodePath :: [Node]+ , ozNodes :: [Node]+ , ozProperties :: [OrgFileProperty]+ } deriving (Eq, Show)+++printChild (ChildNode n) = Just $ nTopic n+printChild _ = Nothing++printChildren = (intercalate ",") . catMaybes . (map printChild) . nChildren++-- | Closes up the path for the zipper, up through to (e.g., >=) the+-- specified depth. Returns the new path, and roots that have been+-- fully closed in the process.+appendChildrenUpPathThroughDepth :: Int -> [Node] -> ([Node], [Node])+appendChildrenUpPathThroughDepth _ [] = ([], [])+appendChildrenUpPathThroughDepth depth [n]+ | nDepth n >= depth =+ let res = [n { nChildren = reverse $ nChildren n }]+ in ([], res)+ | otherwise = ([n], [])++appendChildrenUpPathThroughDepth depth (n:ns)+ | nDepth n >= depth =+ let parent = head ns+ parentChildren = nChildren parent+ fixedUpChild = n { nChildren = reverse $ nChildren n }+ updatedParent = parent { nChildren = (ChildNode fixedUpChild):parentChildren }+ updatedPath = updatedParent : (tail ns)+ in appendChildrenUpPathThroughDepth depth updatedPath+ | otherwise = (n:ns, [])++addNode node doczip path@(pn:pns)+ | nDepth node > nDepth pn = doczip { ozNodePath = node:path }+ | nDepth node <= nDepth (last path) =+ let closed = closeZipPath doczip+ in closed { ozNodePath = [node] }+ | otherwise =+ let (parentPath, newnodes) = appendChildrenUpPathThroughDepth (nDepth node) path+ newpath = node:parentPath+ in doczip { ozNodePath = newpath, ozNodes = newnodes ++ (ozNodes doczip) }++-- | Closes up the path for the zipper, reversing the child-lists as we+-- go (to get them into first->last order).+closeZipPath doczip@(OrgDocZipper path nodes properties) =+ doczip { ozNodePath = [],+ ozNodes = nodes ++ (snd (appendChildrenUpPathThroughDepth (-1) path)) }++isEndLine line = ":END:" == (trim $ tlText line)+openDrawer (Just (ChildDrawer (Drawer _ _ []))) = True+openDrawer (Just (ChildDrawer (Drawer _ _ lines))) =+ not $ isEndLine $ last lines+openDrawer _ = False+parseDrawerName tline =+ let matches = (tlText tline) =~ " *:([A-Za-z]*): *" :: [[String]]+ in if length matches > 0+ then matches !! 0 !! 1+ else ""+parseDrawerProperty tline =+ let matches = (tlText tline) =~ " *:([-_A-Za-z]*):(.*)" :: [[String]]+ in if length matches > 0+ then [(matches !! 0 !! 1, trim $ matches !! 0 !! 2)]+ else []++addChildToNode n c = n { nChildren = c:(nChildren n) }+addChildToLastNode c doczip path@(pn:pns) =+ doczip { ozNodePath = (addChildToNode pn c):pns }+updateLastChildOfLastNode c doczip path@(pn:pns) =+ let updatedPn = pn { nChildren = c:(tail $ nChildren pn) }+ in doczip { ozNodePath = updatedPn:pns }++addBabel :: TextLine -> Maybe NodeChild -> (NodeChild -> OrgDocZipper) -> OrgDocZipper+addBabel line lastChild adder = case lastChild of+ Just (ChildBabel (Babel lines)) ->+ adder $ ChildBabel $ Babel $ lines ++ [line]+ Nothing -> adder (ChildBabel $ Babel [line])++addTable :: TextLine -> Maybe NodeChild -> (NodeChild -> OrgDocZipper) -> OrgDocZipper+addTable line lastChild adder = case lastChild of+ Just (ChildTable (Table lines)) ->+ adder $ ChildTable $ Table $ lines ++ [line]+ Nothing -> adder (ChildTable $ Table [line])++addDrawer :: TextLine -> Maybe NodeChild -> OrgDocZipper -> OrgDocZipper+addDrawer line lastChild doczip@(OrgDocZipper path _ _)+ | not (openDrawer lastChild) =+ let drawer = Drawer (parseDrawerName line) [] [line]+ in addChildToLastNode (ChildDrawer drawer) doczip path+ -- Parse to get drProperties, and ignore :END:.+ | otherwise =+ let Just (ChildDrawer (Drawer n p lines)) = lastChild+ props = parseDrawerProperty line+ dlines = lines ++ [line]+ update n p =+ let drawer = ChildDrawer $ Drawer n p dlines+ in updateLastChildOfLastNode drawer doczip path+ in if isEndLine line+ then update n p+ else update n (p ++ props)++-- | Adds a pre-classified OrgLine to an OrgDocZipper, possibly adding+-- it to some existing part of the OrgDocZipper.+addOrgLine :: OrgDocZipper -> OrgLine -> OrgDocZipper+-- First, the simple base case. Creates a pseudo-root for unattached+-- lines, and inserts the first node into the path. There can only be+-- one pseudo-root, for lines before the first Node.+addOrgLine doczip@(OrgDocZipper [] nodes properties) orgline =+ let pseudo_root = Node (-1) Nothing [] [] "" emptyTextLine+ pseudRootWithChild c = doczip { ozNodePath = [pseudo_root { nChildren = [c] }] }+ in case orgline of+ (OrgText line) -> pseudRootWithChild $ ChildText line+ (OrgHeader line node) -> doczip { ozNodePath = [node] }+ (OrgDrawer line) -> pseudRootWithChild $ ChildDrawer $ Drawer "" [] [line]+ (OrgPragma line prop) -> doczip { ozProperties = (ozProperties doczip) ++ [prop] }+ (OrgBabel line) -> pseudRootWithChild $ ChildBabel $ Babel [line]+ (OrgTable line) -> pseudRootWithChild $ ChildTable $ Table [line]++-- TODO(lally): Add a few args and split out all these inner functions!+addOrgLine doczip@(OrgDocZipper path@(pn:pns) nodes props) orgline =+ let -- addDrawer should parse as it goes. But, we have the problem of :END:+ -- followed with more properties. We can detect this, expensively, by+ -- scanning for :END: in the last line of the existing drawer.+ -- Correctness over speed!+ lastChild = let children = nChildren pn+ in if null children then Nothing else Just $ last children+ adder cld = addChildToLastNode cld doczip path++ in case orgline of+ (OrgText line) -> adder $ ChildText line+ (OrgHeader line node) -> addNode node doczip path+ (OrgDrawer line) -> addDrawer line lastChild doczip+ (OrgPragma line prop) ->+ doczip { ozProperties = (ozProperties doczip) ++ [prop] }+ (OrgBabel line) -> addBabel line lastChild adder+ (OrgTable line) -> addTable line lastChild adder++-- | Intentionally fail when we don't have a parse success, which+-- shouldn't happen...+allRight :: Either a b -> b+allRight (Right b) = b++-- * Primary File Parser++categorizeLines :: String -> [OrgLine]+categorizeLines text =+ let fileLines = lines text+ in map (\(nr, line) -> allRight $ parseLine nr line) $ zip [1..] fileLines++emptyZip = OrgDocZipper [] [] []++-- | We have one of these per input line of the file. Some of these+-- we just keep as the input text, in the TextLine (as they need+-- multi-line parsing to understand).+data OrgLine = OrgText TextLine+ | OrgHeader TextLine Node+ | OrgDrawer TextLine+ | OrgPragma TextLine OrgFileProperty+ | OrgBabel TextLine+ | OrgTable TextLine+ deriving (Eq, Show)++instance TextLineSource OrgLine where+ getTextLines (OrgText t) = [t]+ getTextLines (OrgHeader t _) = [t]+ getTextLines (OrgDrawer t) = [t]+ getTextLines (OrgPragma t _) = [t]+ getTextLines (OrgBabel t) = [t]+ getTextLines (OrgTable t) = [t]+++data OrgFileElement = OrgTopProperty OrgFileProperty+ | OrgTopLevel { tlNode :: Node }+ deriving (Eq, Show)+++-- | Parsing the file efficiently. Let's keep it non-quadratic.+--+-- * Split it up into lines+-- * Identify each line, as part of one of the big structure types:+--+-- * Node headers+-- * Drawers+-- * File-level properties+-- * Babel headers+-- * Lines who's type depend on context (e.g., babel entries or node+-- text)+--+-- * Then fold the lines over a builder function and a zipper of the+-- tree.+orgFile :: String -> OrgDoc+orgFile fileContents =+ let lines = categorizeLines fileContents+ (OrgDocZipper path nodes props) = foldl addOrgLine emptyZip lines+ allNodes = nodes ++ (snd $ appendChildrenUpPathThroughDepth (-1) path)+ in OrgDoc allNodes props (concatMap getTextLines lines)++rstrip xs = reverse $ lstrip $ reverse xs+lstrip = dropWhile (== ' ')+strip xs = lstrip $ rstrip xs++orgPropDrawer :: Parsec String st NodeChild+orgPropDrawer = do manyTill space (char ':') <?> "Property Drawer"+ drawerName <- many1 letter+ char ':'+ manyTill space newline+ let orgProperty = do+ manyTill space (char ':')+ propName <- many1 letter+ char ':'+ value <- manyTill (satisfy (/= '\n')) (try newline)+ return (propName, rstrip $ lstrip value)+ props <- manyTill orgProperty (+ try $ manyTill space (string ":END:"))+ manyTill space newline+ return $ ChildDrawer $ Drawer drawerName props []++emptyTextLine = TextLine 0 "" Nothing++-- Any line that isn't a node.+orgBodyLine :: Parsec String st NodeChild+orgBodyLine = do firstChar <- satisfy (\a -> (a /= '*') && (a /= '#'))+ if firstChar /= '\n'+ then do rest <- manyTill anyChar newline+ let allText = (firstChar : rest)+ indent = length $ takeWhile (== ' ') allText+ return $ ChildText $ TextLine indent allText Nothing+ else return $ ChildText emptyTextLine++orgProperty :: Parsec String st OrgFileElement+orgProperty = do string "#+"+ name <- many1 letter+ char ':'+ many space+ value <- manyTill anyChar (try newline)+ return $ OrgTopProperty $ OrgFileProperty name value++babelLine :: Parsec String TextLine OrgLine+babelLine = do+ (string "#+begin_src:") <|> (string "#+end_src") <|>+ (string "#+BEGIN_SRC:") <|> (string "#+END_SRC")+ textLine <- getState+ return $ OrgBabel textLine++fileProperty :: Parsec String TextLine OrgLine+fileProperty = do+ string "#+"+ name <- many1 letter+ char ':'+ many space+ value <- manyTill anyChar (try newline)+ line <- getState+ return $ OrgPragma line $ OrgFileProperty name value++nodeLine :: Parsec String TextLine OrgLine+nodeLine = do+ let tagList = char ':' >> word `endBy1` char ':'+ where word = many1 (letter <|> char '-' <|> digit <|> char '_' <|> char '@')+ validPrefixes = ["TODO", "DONE", "OPEN", "CLOSED", "ACTIVE"]+ orgSuffix = (do tags <- tagList+ char '\n'+ return tags) <|> (char '\n' >> return [])+ stars <- many1 $ char '*'+ let depth = length stars+ many1 space+ -- stop this sillyness on the prefix. just pull the first word of the topic.+ -- TODO(lally): don't hard-code the list of prefixes.+ many space+ topic <- manyTill anyChar (try $ lookAhead orgSuffix)+ let topic_words = words topic+ first_word_is_prefix =+ length topic_words > 0 && (head topic_words `elem` validPrefixes)+ prefix = if first_word_is_prefix+ then Just $ Prefix $ head topic_words+ else Nothing+ topic_remain = if first_word_is_prefix+ then snd $ splitAt (length $ head topic_words) topic+ else topic+ tags <- orgSuffix+ loc <- getState+ let fxloc = loc { tlIndent = depth }+ line = OrgHeader loc $ Node depth prefix tags [] (strip topic_remain) fxloc+ return line++propertyLine :: Parsec String TextLine OrgLine+propertyLine = do+ manyTill space (char ':')+ propName <- many1 (letter <|> char '-' <|> digit <|> char '_' <|> char '@')+ char ':'+ remain <- manyTill (satisfy (/= '\n')) (try newline)+ line <- getState+ return $ OrgDrawer line++bodyLine :: Parsec String TextLine OrgLine+bodyLine = do+ text <- getState+ return $ OrgText text++-- |The incoming state has TextLine within it.+-- TODO(lally): update the state here to hold options we get in the+-- ORG file, like TODO states.+classifyOrgLine :: Parsec String TextLine OrgLine+classifyOrgLine = do+ textLine <- getState+ -- Possibilities:+ -- - #+begin_src:+ -- - #+other:+ -- - ** blah+ -- - :PROPERTY:+ -- - anything else.+ res <- (try babelLine)+ <|> (try fileProperty)+ <|> (try nodeLine)+ <|> (try propertyLine)+ <|> bodyLine -- always matches.+ return res++parseLine :: Int -> String -> Either ParseError OrgLine+parseLine lineno s = do+ let indent = length $ takeWhile (== ' ') s+ line = TextLine indent s (Just lineno)+ in runParser classifyOrgLine line "input" (s ++ "\n")++
+ src/Data/OrgMode/Doc.hs view
@@ -0,0 +1,108 @@+module Data.OrgMode.Doc (Node(..), Prefix(..), Drawer(..),+ OrgFileProperty(..), Babel(..), Table(..),+ OrgDoc(..), NodeChild(..), updateNode, trim,+ makeNodeLine) where+import Data.List (intercalate)+import Data.OrgMode.Text++--+-- * Data Decls+--++-- |A keyword at the front of a node heading, like TODO or DONE.+data Prefix = Prefix String deriving (Eq, Show)++data Drawer = Drawer+ { drName :: String -- ^ :PROPERTIES: or another name.+ , drProperties :: [(String, String)] -- ^ Key-value pairs.+ , drLines :: [TextLine] -- ^ Literal text of the entire drawer.+ } deriving (Eq, Show)++-- |Currently underimplemented: stores the lines of the babel environment.+data Babel = Babel [TextLine] deriving (Eq, Show)++-- |Currently underimplemented: stores the lines of the table.+data Table = Table [TextLine] deriving (Eq, Show)++-- |Children of top-level Org Nodes.+data NodeChild = ChildText TextLine -- ^ Regular text.+ | ChildDrawer Drawer+ | ChildNode Node -- ^ outline nodes of higher depth.+ | ChildBabel Babel+ | ChildTable Table+ deriving (Eq, Show)++-- |An outline node in org-mode. For a node @** TODO Foo a bar :FOOBAR:@+--+-- * @nDepth@ is 2+-- * @nPrefix@ is @Just "TODO"@+-- * @nTags@ is @["FOOBAR"]@+-- * @nTopic@ is @"Foo a bar"@, note the stripped whitespace on the front and back.+-- * @nChildren@ aren't determined by this line, but by the lines after.+data Node = Node+ { nDepth :: Int -- ^ Number of stars on the left.+ , nPrefix :: Maybe Prefix -- ^ E.g., TODO or DONE.+ , nTags :: [String] -- ^:TAGS:AT:END:+ , nChildren :: [NodeChild] -- ^ Everything hierarchially under the node.+ , nTopic :: String -- ^ Text of he header line, minus prefix and tags.+ , nLine :: TextLine -- ^ Literal text of the node header.+ } deriving (Eq, Show)++-- |Properties within the org file. Examples include @#+TITLE:@+data OrgFileProperty = OrgFileProperty { fpName :: String+ , fpValue :: String+ } deriving (Eq, Show)+-- |Full contents of an org file.+data OrgDoc = OrgDoc+ { odNodes :: [Node]+ , odProperties :: [OrgFileProperty]+ , odLines :: [TextLine]+ } deriving (Eq, Show)+--+-- * Instance Decls+--++instance TextLineSource NodeChild where+ getTextLines (ChildText l) = [l]+ getTextLines (ChildDrawer d) = drLines d+ getTextLines (ChildNode n) = getTextLines n+ getTextLines (ChildBabel (Babel lines)) = lines+ getTextLines (ChildTable (Table lines)) = lines++instance TextLineSource Node where+ getTextLines node =+ (nLine node) : (concatMap getTextLines $ nChildren node)++instance TextLineSource OrgFileProperty where+ getTextLines prop =+ [TextLine 0 ("#+" ++ (fpName prop) ++ ": " ++ (fpValue prop)) Nothing]++-- ** Utilities+trim xs =+ let rstrip xs = reverse $ lstrip $ reverse xs+ lstrip = dropWhile (== ' ')+ in lstrip $ rstrip xs++makeNodeLine :: Node -> String+makeNodeLine (Node depth prefix tags children topic _) =+ stars ++ " " ++ pfx ++ topic ++ " " ++ tgs+ where+ stars = take depth $ repeat '*'+ pfx = case prefix of+ Just (Prefix s) -> (s ++ " ")+ Nothing -> ""+ tgs = if length tags > 0+ then ":" ++ (intercalate ":" tags) ++ ":"+ else ""++updateNode :: (Node -> Maybe Node) -> Node -> Node+updateNode fn root =+ let top = case (fn root) of+ Nothing -> root+ Just t -> t+ all_children = nChildren top+ updateChild c =+ case c of+ (ChildNode n) -> ChildNode $ updateNode fn n+ otherwise -> c+ in top { nChildren = map updateChild $ all_children }
+ src/Data/OrgMode/OrgDocView.hs view
@@ -0,0 +1,101 @@+module Data.OrgMode.OrgDocView (+ OrgDocView(..), generateDocView, getRawElements,+ updateDoc, NodeUpdate(..)+ ) where++import Data.OrgMode.Doc+import Data.OrgMode.Text++import Data.Set (Set(..), member, lookupLE)+import Data.Maybe (mapMaybe, fromJust, catMaybes)++data OrgDocView a = OrgDocView+ { ovElements :: [(a, Node)]+ , ovDocument :: OrgDoc+ }++-- | Generic visitor for updating a Node's values. Intentionally, we+-- don't allow node deletion, just update. Preferably, if you want to+-- delete a Node, you should control the parent. We also have+-- findItemInNode which will construct an 'a' from the Node, which we+-- may then update against a list.+class (Eq a) => NodeUpdate a where+ findItemInNode :: Node -> Maybe a+ updateNodeLine :: a -> Node -> Maybe Node++-- Doesn't assume that xs or ys are individually sorted, which works+-- well for TextLines with no line number mid-stream.+mergeSorted :: (Ord a) => [a] -> [a] -> [a]+mergeSorted [] [] = []+mergeSorted xs [] = xs+mergeSorted [] ys = ys+mergeSorted xl@(x:xs) yl@(y:ys) =+ case compare x y of+ EQ -> x:(mergeSorted xs yl)+ LT -> x:(mergeSorted xs yl)+ GT -> y:(mergeSorted xl ys)++instance TextLineSource OrgDoc where+ getTextLines doc =+ let docLines = concatMap getTextLines $ odNodes doc+ propLines = concatMap getTextLines $ odProperties doc+ in mergeSorted docLines propLines++instance TextLineSource (OrgDocView a) where+ getTextLines = getTextLines . ovDocument++-- * Constructors+generateDocView :: (NodeUpdate a) => OrgDoc -> OrgDocView a+generateDocView doc =+ let childNode (ChildNode n) = Just n+ childNode _ = Nothing+ childNodes n = mapMaybe childNode $ nChildren n+ scanNode :: (Node -> Maybe a) -> Node -> [(a, Node)]+ scanNode fn n = let hd = fn n+ entry = maybe [] (\a -> [(a,n)]) hd+ rest = (concatMap (scanNode fn) $ childNodes n)+ in (entry++rest)+ scanOrgForest :: (NodeUpdate a) => [Node] -> [(a, Node)]+ scanOrgForest forest =+ concatMap (scanNode findItemInNode) forest++ forest = odNodes doc+ elements = scanOrgForest forest+ in OrgDocView elements doc++getRawElements :: OrgDocView a -> [a]+getRawElements docview =+ map fst $ ovElements docview++-- * Update an OrgMode doc++-- Algorithm: sort the issues by textline line #. Then, get the+-- textlines of the entire tree, which shall be in ascending order.+-- Replace them as we match the node.++updateElementList :: (NodeUpdate a) => [Node] -> [(a, Node)]+updateElementList nodes =+ let nodeChildScan (ChildNode nd) = nodeScan nd+ nodeChildScan _ = []+ nodeScan nd =+ let children = concatMap nodeChildScan (nChildren nd)+ in case findItemInNode nd of+ Just item -> (item, nd):children+ Nothing -> children+ in concatMap nodeScan nodes++updateDoc :: (Ord a, NodeUpdate a) => Set a -> OrgDocView a -> OrgDocView a+updateDoc new_items doc =+ let nodeUpdater node =+ case findItemInNode node of+ Just item ->+ if member item new_items+ then let new_item = fromJust $ lookupLE item new_items+ in updateNodeLine new_item node+ else Nothing+ Nothing -> Nothing+ new_nodes =+ map (updateNode nodeUpdater) $ odNodes $ ovDocument doc+ new_doc = (ovDocument doc) { odNodes = new_nodes }+ in doc { ovDocument = new_doc }+
+ src/Data/OrgMode/Text.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE BangPatterns, GADTs, DeriveDataTypeable, StandaloneDeriving #-}++module Data.OrgMode.Text (+ LineNumber(..), toNumber, TextLine(..), isNumber, TextLineSource(..), normalizeInputText, lineAdd,+ linesStartingFrom, hasNumber, makeDrawerLines, wrapLine, prefixLine, tlPrint, tlFormat, wrapStringVarLines+ ) where++import Data.List (intercalate)+import Data.Monoid+import Data.Typeable+import Data.Generics (Generic(..))+import Data.Char (isSpace, toUpper, isPrint)+import Text.Printf+import System.IO++-- | Line numbers, where we can have an unattached root.+type LineNumber = Maybe Int++lineAdd Nothing _ = Nothing+lineAdd _ Nothing = Nothing+lineAdd (Just a) (Just b) = Just (a+b)++toNumber :: Int -> LineNumber -> Int+toNumber n Nothing = n+toNumber _ (Just a) = a++isNumber :: LineNumber -> Bool+isNumber Nothing = False+isNumber (Just _) = True++linesStartingFrom :: LineNumber -> [LineNumber]+linesStartingFrom Nothing = repeat Nothing+linesStartingFrom (Just l) = map Just [l..]++-- | Raw data about each line of text. Lines with 'tlLineNum == None'+-- are generated and don't exist within the Org file (yet).+data TextLine = TextLine+ { tlIndent :: Int+ -- ^how long of a whitespace (or asterisk, for 'Node') prefix is in tlText?+ , tlText :: String+ , tlLineNum :: LineNumber+ } deriving (Eq, Typeable)++hasNumber :: TextLine -> Bool+hasNumber (TextLine _ _ (Just _)) = True+hasNumber _ = False+formatLine tl =+ (printf "[%3d] " (tlIndent tl)) +++ (printf "%-8s" $ (show $ tlLineNum tl)) ++ "|" ++ (tlText tl)++instance Show TextLine where+ show tl = "<" ++ (formatLine tl) ++ ">"++instance Ord TextLine where+ compare a b = compare (tlLineNum a) (tlLineNum b)++-- | Implements an API for getting text lines. Useful for Org file+-- generation or mutation.+class TextLineSource s where+ getTextLines :: s -> [TextLine]++-- | Normalizes out newlines to UNIX format. CR -> LF, CRLF -> LF+normalizeInputText :: String -> String+normalizeInputText text =+ -- Operators that work on reversed strings.+ let swapCrLf :: String -> Char -> String+ swapCrLf ('\r':cs) '\n' = '\n':cs+ swapCrLf ('\n':cs) '\r' = '\n':cs+ swapCrLf cs c = c:cs+ -- A good place for fixing unprintable chars, but we have to+ -- identify them.+ swapCr :: String -> Char -> String+ swapCr cs '\r' = '\n':cs+ swapCr cs c = c:cs+ revStr = reverse text+ swappedCrLf = foldl swapCrLf "" revStr+ swappedCr = foldl swapCr "" swappedCrLf+ in reverse swappedCr++trimEndOfLine :: String -> String+trimEndOfLine f = reverse $ dropWhile isSpace $ reverse f++wrapStringVarLines :: [Int] -> String -> String+wrapStringVarLines _ [] = []+wrapStringVarLines lens str+ | length str < (head lens) = str+ | otherwise =+ let first_word = takeWhile (not . isSpace) str+ len = head lens+ is_first_too_long = length first_word >= len+ wrapped_back =+ if is_first_too_long+ then first_word+ else reverse $ dropWhile (not . isSpace) $ reverse $ take len str+ remain = drop (length wrapped_back) str+ in if length wrapped_back > 0 || length remain > 0+ then wrapped_back ++ "\n" ++ wrapStringVarLines (drop 1 lens) remain+ else ""++wrapString :: Int -> String -> String+wrapString len str = wrapStringVarLines (repeat len) str+wrapLine :: Int -> TextLine -> [TextLine]+wrapLine width (TextLine indent string linenum) =+ let desired_len = width - indent+ strings = concatMap lines $ map (wrapString desired_len) $ lines string+ line_nrs = linesStartingFrom linenum+ makeTextLine (str, nr) = TextLine indent (trimEndOfLine str) nr+ in map makeTextLine $ zip strings line_nrs++prefixLine :: String -> TextLine -> TextLine+prefixLine pfx (TextLine indent string linenum) =+ let new_str = pfx ++ string+ new_indent = length $ takeWhile isSpace new_str+ in TextLine new_indent new_str linenum++makeDrawerLines :: LineNumber -> Int -> String -> [(String, String)] -> [TextLine]+makeDrawerLines fstLine depth name props =+ let !indent = take depth $ repeat ' '+ headline =+ TextLine depth (indent ++ ":" ++ (map toUpper name) ++ ":") fstLine+ mAdd (Just x) y = Just (x + y)+ mAdd Nothing y = Nothing+ lastline =+ TextLine depth (indent ++ ":END:") (lineAdd fstLine $ Just (length props + 1))+ makePropLine ((prop, value), nr) =+ TextLine depth (indent ++ ":" ++ prop ++ ": " ++ value) (lineAdd fstLine $ Just nr)+ proplines = map makePropLine $ zip props [1..]+ in (headline:(proplines)) ++ [lastline]++tlFormat :: (TextLineSource s) => s -> String+tlFormat s =+ let lines = getTextLines s+ in intercalate "\n" $ map formatLine lines++tlPrint :: (TextLineSource s) => s -> IO ()+tlPrint s = putStrLn $ tlFormat s
+ tests/MainTestSuite.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+