module Data.OrgMode (
Prefix(..), Drawer(..), Babel(..), Table(..), NodeChild(..), Node(..),
OrgFileProperty(..), OrgFileElement(..),
OrgDocView(..), NodeUpdate(..), OrgDoc(..), TextLine(..), LineNumber(..),
TextLineSource(..),
orgFile, generateDocView, getRawElements, updateNode,
addOrgLine, emptyZip, categorizeLines
) where
import Data.OrgMode.Text
import Data.OrgMode.Doc
import Data.OrgMode.OrgDocView
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
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
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) }
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
| 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)
addOrgLine :: OrgDocZipper -> OrgLine -> OrgDocZipper
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]
addOrgLine doczip@(OrgDocZipper path@(pn:pns) nodes props) orgline =
let
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
allRight :: Either a b -> b
allRight (Right b) = b
categorizeLines :: String -> [OrgLine]
categorizeLines text =
let fileLines = lines text
in map (\(nr, line) -> allRight $ parseLine nr line) $ zip [1..] fileLines
emptyZip = OrgDocZipper [] [] []
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)
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
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
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
classifyOrgLine :: Parsec String TextLine OrgLine
classifyOrgLine = do
textLine <- getState
res <- (try babelLine)
<|> (try fileProperty)
<|> (try nodeLine)
<|> (try propertyLine)
<|> bodyLine
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")