Source

pico-org / org.l

(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")))


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

(de org-parse-body (Lines)
  (collectUntil Lines '((Line) (> (org-parse-level Line) 0))))

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

(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-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 (cons (pack Prop) @A))))
            (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) (pre? ":END:" Line)))
         Props (mapcar '((X) (match '(":" @A ":" " " @B) (chop X)) (list (pack @A) (pack @B)))  Properties)
         NewBody (if Properties (cdr (seek '((Line) (pre? ":END:" Line)) Body)) Body)
         SpecialPropsRet (org-parse-special-props NewBody)
         AllProps (union Props (car SpecialPropsRet))
         NewBody (cdr SpecialPropsRet))
   (cons AllProps 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)
         Body (cdr PropertiesFunc)
         Children (org-parse-children Lines Level)
         Header (org-remove-header-prefix Line)
         Heading (list 'level Level 'name Header 'body Body 'props Properties 'children Children)
         NextPosition (org-next-sibling Level Lines))
     (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)))