Source

pico-org / org.l

Full commit
(de collectUntil (Lst Func)
  (let (Ret NIL) (find '((X) (if (Func X) T (push 'Ret X) NIL)) Lst) (reverse Ret)))

(de union (Lst1 Lst2)
   (filter prog (fish atom (list Lst1 Lst2))))

(de *Org-special-props
   ~(mapcar chop (list "ID", "TODO", "TAGS", "ALLTAGS", "CATEGORY", "PRIORITY", 
                  "DEADLINE", "SCHEDULED", "CLOSED", "TIMESTAMP", "TIMESTAMP_IA", 
                  "CLOCKSUM", "CLOCKSUM_T", "BLOCKED", "ITEM", "FILE")))

(off *Org-hook-parse-body)
(off *Org-hook-add-heading)

(de org-parse-level (Line)
 (- (length (split (chop Line) "*")) 1))

(de org-parse-body (Lines)
  (let Body (collectUntil Lines '((Line) (> (org-parse-level Line) 0)))
      (if *Org-hook-parse-body (mapcar *Org-hook-parse-body Body) Body)))

(de org-parse-children (Lines Level)
  (let Children (collectUntil Lines '((X) (= Level (org-parse-level X))))
    (if Children (org-parse Children Level))))

(de org-val (Key Lst) (cadr (seek '((X) (= Key (car X))) Lst)))

(de org-flatten (Lst)
   (make
      (recur (Lst)
         (for Header Lst
            (link Header)
            (recurse (org-val 'children Header))))))

(de org-header-to-text (Header)
   (let (Name (org-val 'name Header)
         Level (org-val 'level Header)
         Tags (org-val 'tags Header)
         TagText (mapcar '((X) (if X (pack ":" X))) Tags))
      (list (need Level "*") " " Name (if TagText (pack TagText ":")))))

(de org-to-text (Lst)
   (pack (make
      (let (Flat (org-flatten Lst))
         (for X Flat
            (let (Body (org-val 'body X)
                  Properties (org-val 'props X))
               (link (pack (org-header-to-text X) "^J"))
               (when Properties
                  (link ":PROPERTIES:^J")
                  (for (Prop Properties Prop (cddr Prop))
                     (link ":" (car Prop) ":" " " (cadr Prop)  "^J"))
                  (link ":END:^J"))
               (for Y Body (link Y "^J"))))))))


(de org-next-sibling (Level Lines)
  (seek '((Line) (= Level (org-parse-level (car Line)))) Lines))

(de org-remove-header-prefix (Line)
   (pack (cdr (diff (chop Line) "*"))))

(de org-parse-header-text (Line)
   (let (Text (org-remove-header-prefix Line) 
         TagSplit (split (chop Text) ":")
         Heading (pack (car TagSplit))
         Tags (mapcar pack (cdr TagSplit)))
      (cons Heading Tags)))


# returns the Special props as a list and also the body without them (not currently used)
(de org-parse-special-props (Body)
   (let (NewBody NIL 
         Props NIL
         Special *Org-special-props)
      (for Line Body
         (let (LineC (chop Line) Matched NIL)
            (for Prop Special
               (when (match (fish atom (list Prop ":" " " '@A)) LineC) 
                  (setq Matched T)
                  (push 'Props (pack @A))
                  (push 'Props (pack Prop)))))
            (ifn Matched (push 'NewBody Line)))
      (cons Props (reverse NewBody))))

(de org-parse-properties (Body)
   (let  (PropertyStart (cdr (seek '((Line) (match '(@A ~(chop ":PROPERTIES:")) (chop (car Line)))) Body))
         Properties (collectUntil PropertyStart '((Line) (match '(@A ~(chop ":END:")) (chop (car Line)))))
         Props (mapcar '((X) (match '(":" @A ":" " " @B) (chop X)) (list (pack @A) (pack @B)))  Properties)
         NewBody (if Properties (cdr (seek '((Line) (match '(@A ~(chop ":END:")) (chop (car Line)))) Body)) Body)
         SpecialPropsRet (org-parse-special-props NewBody))
   (list (union Props) (car SpecialPropsRet) NewBody)))

(de org-parse-heading (Line Level Lines)
  (when (> Level 0)
    (let (AllBody (org-parse-body Lines)
         PropertiesFunc (org-parse-properties AllBody)
         Properties (car PropertiesFunc)
         Special (cadr PropertiesFunc)
         Body (caddr PropertiesFunc)
         Children (org-parse-children Lines Level)
         ParsedHeader (org-parse-header-text Line)
         Header (car ParsedHeader)
         Tags (cdr ParsedHeader)
         Key (inc '*Key)
         Heading (list 'key Key 'level Level 'name Header 'tags Tags 'special Special 'body Body 'props Properties 'children Children)
         NextPosition (org-next-sibling Level Lines))
      (if *Org-hook-add-heading (*Org-hook-add-heading Heading))
      (cons Heading NextPosition))))

(de org-parse (Lines Until)
  (let (Lst NIL)
    (while Lines 
      (let (Line (car Lines)
            Level (org-parse-level Line)
            IsBody (= 0 Level)
            Sibling (<= Level Until)
            ShouldParse (and (not Sibling) (not IsBody)) 
            ParsedHeading (if ShouldParse (org-parse-heading Line Level (cdr Lines)))
            Heading (car ParsedHeading)
            NextPosition (cdr ParsedHeading))
       (if (and Sibling (not IsBody)) (setq Lines NIL))
       (if (and Lines ParsedHeading)
         (prog
           (setq Lst (cons Heading Lst))
           (setq Lines NextPosition))
         (setq Lines (cdr Lines)))))
       (reverse Lst)))

(de org-parse-text (Text)
   (let (L (split (chop Text) "^J")
         Lines (filter prog (mapcar pack L))
             *Key 0)
         (org-parse Lines 0)))


(de org-delete-by-key (Tree Key)
   (make 
      (recur (Tree)
         (for X Tree
            (unless (= (org-val 'key X) Key)
               (link (make 
                  (for (Prop X Prop (cddr Prop))
                     (unless (= (car Prop) 'children)
                        (link (car Prop))
                        (link (cadr Prop))))
                        (link 'children)
                        (link (make (recurse (org-val 'children X)))))))))))

# not implemented
(de org-move-by-key (Tree Key Steps) NIL)

# not implemented
(de org-add-sibling-by-key (Tree Key Sibling) NIL)

# not implemented
(de org-add-promote-by-key (Tree Key) NIL)

# not implemented
(de org-add-demote (Tree Key) NIL)