diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/orgmode.cabal b/orgmode.cabal new file mode 100644 --- /dev/null +++ b/orgmode.cabal @@ -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 + + diff --git a/src/Data/OrgMode.hs b/src/Data/OrgMode.hs new file mode 100644 --- /dev/null +++ b/src/Data/OrgMode.hs @@ -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") + + diff --git a/src/Data/OrgMode/Doc.hs b/src/Data/OrgMode/Doc.hs new file mode 100644 --- /dev/null +++ b/src/Data/OrgMode/Doc.hs @@ -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 } diff --git a/src/Data/OrgMode/OrgDocView.hs b/src/Data/OrgMode/OrgDocView.hs new file mode 100644 --- /dev/null +++ b/src/Data/OrgMode/OrgDocView.hs @@ -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 } + diff --git a/src/Data/OrgMode/Text.hs b/src/Data/OrgMode/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/OrgMode/Text.hs @@ -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 diff --git a/tests/MainTestSuite.hs b/tests/MainTestSuite.hs new file mode 100644 --- /dev/null +++ b/tests/MainTestSuite.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +