Source

pico-org / org.l

Full commit
Joe Bogner 5b1572c 
Joe Bogner 0c3aeba 
Joe Bogner 5b1572c 
Joe Bogner e678a98 








Joe Bogner 0453566 



Joe Bogner 0c3aeba 
Joe Bogner 0453566 

Joe Bogner 0c3aeba 

Joe Bogner 0453566 

Joe Bogner 0c3aeba 
Joe Bogner 0453566 
Joe Bogner e678a98 


Joe Bogner 9285e7e 






Joe Bogner e678a98 













Joe Bogner 59ccc68 
Joe Bogner e678a98 







Joe Bogner 0453566 

Joe Bogner e678a98 



Joe Bogner 0c3aeba 
Joe Bogner 9285e7e 



Joe Bogner 0c3aeba 

Joe Bogner 0453566 

Joe Bogner 0c3aeba 















Joe Bogner 0453566 
(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-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)))

(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)
         ParsedHeader (org-parse-header-text Line)
         Header (car ParsedHeader)
         Tags (cdr ParsedHeader)
         Heading (list 'level Level 'name Header 'tags Tags '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)))