ustj/lib/parser.hoon

/-  tp=post, md=markdown
/+  sr=sortug, mdlib=markdown
|%
:: new! using wispem's lib
++  tokenise
|=  t=@t  ^-  (each content-list:tp @t)
  =/  parsed  (rush t markdown:de:md:mdlib)
  ?~  parsed  [%| 'parsing error']
  :-  %&
  %+  turn  u.parsed  de-node  
++  de-node  |=  =node:markdown:md  ^-  block:tp
  ?~  node  [%paragraph ~]
  ?-  -.node
    %leaf       (de-leaf +.node)
    %container  (de-cont +.node)
  ==

++  de-leaf  |=  =node:leaf:markdown:md  ^-  block:tp
  ?~  node  [%paragraph ~]
  ?-  -.node
    %heading              (de-heading node)
    %break                [%paragraph :~([%break ~])]
    %indent-codeblock     [%codeblock text.node '']
    %fenced-codeblock     [%codeblock text.node info-string.node]
    %html                 [%codeblock text.node 'html']
    %link-ref-definition  [%paragraph :~([%link '' label.node])]
    %paragraph            [%paragraph (de-inline contents.node)]
    %blank-line           [%paragraph :~([%break ~])]
    %table                [%paragraph :~([%break ~])]  :: TODO
  ==
++  de-heading  |=  h=heading:leaf:markdown:md
  :+  %heading  (flatten-inline contents.h)
  ?:  .=(1 level.h)  %h1
  ?:  .=(2 level.h)  %h2
  ?:  .=(3 level.h)  %h3
  ?:  .=(4 level.h)  %h4
  ?:  .=(5 level.h)  %h5  %h6
++  de-inline  |=  inls=contents:inline:md
  =|  res=(list inline:tp)
  |-  ?~  inls  (flop res)
    =/  inl  i.inls
    =/  r=inline:tp  ?-  -.inl
      %escape           [%codespan char.inl]
      %entity           [%codespan code.inl]
      %code-span        [%codespan text.inl]
      %line-break       [%break ~]
      %soft-line-break  [%break ~]
      %text             [%text text.inl]
      %emphasis         (de-strong +.inl)
      %strong           (de-strong +.inl)
      %link             [%link (de-target target.inl) (flatten-inline contents.inl)]
      %image            [%img (de-target target.inl) alt-text.inl]
      %autolink         [%text '']
      %html             [%codespan text.inl]
    ==
    $(inls t.inls, res [r res])
++  de-strong  |=  [char=@t inls=contents:inline:md]
?:  .=('_' char)  [%italic (flatten-inline inls)]
                  [%bold (flatten-inline inls)]
++  de-target  |=  tar=target:ln:md
:: TODO lotsa stuff here
  ?-  -.tar
    %direct  text.url.urlt.tar
    %ref     label.tar
  ==
++  flatten-inline  |=  inls=contents:inline:md  ^-  @t
  =/  res  ""
  |-  ?~  inls  (crip res)
    =/  inl  i.inls
    =/  r  ?+  -.inl  ""
      %escape           (trip char.inl)
      %entity           (trip code.inl)
      %code-span        (trip text.inl)
      %text             (trip text.inl)
      %emphasis         (trip (flatten-inline contents.inl))
      %strong           (trip (flatten-inline contents.inl))
      %link             (trip (flatten-inline contents.inl))
      %image            (trip (de-target target.inl))
      %html             (trip text.inl)
    ==
    $(inls t.inls, res "{res} {r}")
++  de-cont  |=  =node:container:markdown:md  ^-  block:tp
  ?~  node  [%paragraph ~]
  ?-  -.node
    %block-quote  [%blockquote (denest +.node)]
    %ol           [%list (de-list contents.node) .y]
    %ul           [%list (de-list contents.node) .n]
    %tl           [%tasklist (turn contents.node de-task)]
  ==
++  de-task  |=  [checked=? mde=markdown:md]  ^-  task:tp
  :_  checked  (denest mde)
++  de-list  |=  lmd=(list markdown:md)  ^-  (list li:tp)
  =|  res=(list li:tp)
  |-  ?~  lmd  (flop res)
    =/  nodelist  i.lmd
    =/  blocks  %+  turn  nodelist  de-node
    $(lmd t.lmd, res [blocks res])
++  denest  |=  mde=markdown:md  ^-  paragraph:tp
  =|  res=paragraph:tp
  |-  ?~  mde  (flop res)
    =/  block  (de-node i.mde)
    =/  r=paragraph:tp  (break-block block)
    =/  nr  (weld res r)
    $(mde t.mde, res nr)

++  break-block  |=  =block:tp  ^-  paragraph:tp
?+  -.block  ~
  %paragraph   p.block
  %blockquote  p.block
  %heading     :~([%text p.block])
  %codeblock   :~([%text code.block])
  %eval        :~([%text hoon.block])
  %list        (break-list p.block)
==
++  break-list  |=  lis=(list li:tp)  ^-  paragraph:tp
  =|  res=paragraph:tp
  |-  ?~  lis  (flop res)
    =/  par  (ibreak-list i.lis)
    =/  nr  (weld res par)
    $(lis t.lis, res nr)
++  ibreak-list  |=  blocks=(list block:tp)  ^-  paragraph:tp
  =|  res=paragraph:tp
  |-  ?~  blocks  (flop res)
    =/  par  (break-block i.blocks)
    =/  nr  (weld res par)
    $(blocks t.blocks, res nr)

::  tape -> post:trill, parsing user input from Sail
+$  heading  $?(%h1 %h2 %h3 %h4 %h5 %h6)

++  parse  :: Markdown parser. Actually udon parser but it'll do
  |=  s=tape  ^-  (unit marl:hoot) :: finally
  :: Annoying it requires a line break but then parses it as a space wtf
  =,  vast
  (rust s cram:(sail .y))
++  tokenize  
|=  s=@t  ^-  content-list:tp
  =/  t  (weld (trip s) "\0a")
  =/  parsed  (parse t)
  :: =/  parsed2  (parse:md t)
  :: ~&  >    diary-parser=parsed2
  ::  \0a can't be followed by a space. ever. those are the rules
  ?~  parsed  ~&  error-parsing-markdown=t  ~
  (marl-to-cl u.parsed)
++  marl-to-cl
|=  =marl:hoot  ^-  content-list:tp
  %-  flop
  %+  roll  marl
  |=  [=tuna:hoot acc=content-list:tp]
  :: man this is an annoying type if I ever saw one
  ?@  -.tuna  acc
  =/  blk  (manx-to-block tuna)
  ?~  blk  acc  :_  acc  u.blk
++  manx-to-block
  |=  =manx:hoot  ^-  (unit block:tp)
  ?+  n.g.manx  ~
  heading      %-  some   [%heading (phead n.g.manx c.manx)]
  %p           %-  some   [%paragraph (inline-list c.manx)]
  %blockquote  %-  some   [%blockquote (inline-list c.manx)]
  %pre         %-  some   [%codeblock (pre c.manx)]
  %hr          %-  some   [%paragraph ~[[%break ~]]]
  %ul          %-  some   [%list (list-items c.manx) .n]
  %ol          %-  some   [%list (list-items c.manx) .y]
  :: %table       %-  some   (table-rows c.manx)
  ==
++  list-items
|=  =marl:hoot  ^-  (list li:clist:tp)
%-  flop
  %+  roll  marl  |=  [=tuna:hoot acc=(list li:clist:tp)]
  ?@  -.tuna  acc
  ?.  ?=(%li n.g.tuna)  acc  :_  acc  (marl-to-cl c.tuna)
  ++  phead
  |=  [h=heading c=marl:hoot]  ^-  [p=cord q=heading]
  :-  (get-tag-text c)  h
++  inline-list
  |=  c=marl:hoot  ^-  (list inline:tp)
  %-  flop
  %+  roll  c
  |=  [=tuna:hoot acc=(list inline:tp)]
  ?@  -.tuna  acc  :_  acc  (inline tuna)
  ++  inline
  |=  =manx:hoot  ^-  inline:tp
  ?:  ?=(%$ n.g.manx)  [%text (get-attrs-text a.g.manx)]
  =/  text=@t  (get-tag-text c.manx)
  ?+  n.g.manx  [%text text]
  %i     [%italic text]
  %b     [%bold text]
  %code  [%codespan text]
  %br    [%break ~]
  %a    :+  %link  (get-attrs-text a.g.manx)  (get-tag-text c.manx)
  %img  :+  %link  (get-attr-text a.g.manx %src)  (get-attr-text a.g.manx %alt)
  ==
::
++  reduce-block
|=  c=marl:hoot  ^-  @t
  %+  roll  c
  |=  [=tuna:hoot acc=@t]
  ?@  -.tuna  acc
  ?+  n.g.tuna  acc
  %p  (get-tag-text c.tuna)
  ==
++  get-attr-text
|=  [a=mart:hoot attr=@tas]  ^-  @t
  %-  crip  %-  flop
  %+  roll  a
  |=  [[n=mane v=(list beer:hoot)] acc=tape]
  ?.  .=(attr n)  acc
  %+  roll  v
  |=  [b=beer:hoot acc=tape]
  ?^  b  acc  [b acc]
++  get-attrs-text  :: this assumes we don't care about which attr, which we usually don't
|=  a=mart:hoot  ^-  @t
  :: ?:  (gte (lent a) 1)  
  %-  crip  %-  flop
  %+  roll  a
  |=  [[n=mane v=(list beer:hoot)] acc=tape]
  %+  roll  v
  |=  [b=beer:hoot acc=tape]
  ?^  b  acc  [b acc]
++  get-tag-text
|=  c=marl:hoot  ^-  @t
::  there's only really one child in these things
  %+  roll  c
  |=  [=tuna:hoot acc=@t]
  ?@  -.tuna  acc
  %-  crip
  %-  flop
  %+  roll  a.g.tuna
  |=  [[n=mane v=(list beer:hoot)] acc=tape]
  %+  roll  v
  |=  [b=beer:hoot acc=tape]
  ?^  b  acc  [b acc]

++  pre
  |=  c=marl:hoot  ^-  [cord cord]
  :_  ''  :: lang not supported, duh
  %+  roll  c
  |=  [=tuna:hoot acc=@t]
  ?@  -.tuna  acc
  (get-attrs-text a.g.tuna)

++  parse-tags
|=  t=@t  ^-  (unit (set @t))
  =/  lst  (rush t (csplit:sr com))
  ?~  lst  ~  (some (sy u.lst))
:: post:trill -> (markdown) tape for display on sail
++  block-to-md
|=  b=block:tp  ^-  tape
  ?+  -.b  ""
%paragraph    
  %^  foldi:sr  p.b  ""  |=  [in=@ud i=inline:tp acc=tape]
    =/  il  (inline-to-tape i)  
    ?:  .=(+(in) (lent p.b))
    "{acc}{il}"
    "{acc}{il} "
%blockquote   
  %+  weld  "> "
  %^  foldi:sr  p.b  ""  |=  [in=@ud i=inline:tp acc=tape]
  =/  il  (inline-to-tape i)  
  ?:  .=(+(in) (lent p.b))
  "{acc}{il}"
  "{acc}{il} "
%list  
  %^  foldi:sr  p.b  ""  |=  [in=@ud =li:tp acc=tape]
  =/  li-tape  (content-list-to-md li)
  =/  line  ?:  ordered.b  
  "{<+(in)>}. {li-tape}"
  "- {li-tape}"
  ?:  .=(+(in) (lent p.b))
  "{acc}{line}"
  "{acc}{line}\0a"
%media  
  ?+  -.media.b  "![{(trip p.media.b)}]({(trip p.media.b)})"
%images  %^  foldi:sr  p.media.b  ""  |=  [i=@ud [url=@t caption=@t] acc=tape]
  =/  line  "![{(trip caption)}]({(trip url)})"
  ?:  .=(+(i) (lent p.media.b))
  "{acc}{line}"
  "{acc}{line}\0a"
  ==
%codeblock
  """
  ```
  {(trip code.b)}
  ```
  """
%heading  =/  dashes=tape  ?-  q.b
  %h1  "# "
  %h2  "## "
  %h3  "### "
  %h4  "#### "
  %h5  "##### "
  %h6  "###### "
  ==  "{dashes}{(trip p.b)}"
%tasklist  ""  ::TODO
  ::
  :: %table  acc
  :: %eval  acc
  :: %ref   acc
  :: %json  acc
  ==  
++  content-list-to-md
|=  =content-list:tp  ^-  tape
  %^  foldi:sr  content-list  ""  |=  [i=@ud b=block:tp acc=tape]
  =/  block-tape  (block-to-md b)
  ?:  .=(+(i) (lent content-list))
  "{acc}{block-tape}"
  "{acc}{block-tape}\0a\0a"
++  inline-to-tape
|=  i=inline:tp  ^-  tape
  ?-  -.i  
  %text  (trip p.i)
  %italic  "_{(trip p.i)}_"
  %bold    "*{(trip p.i)}*" 
  %strike   "~~{(trip p.i)}~~"
  %ship     (scow %p p.i)
  %codespan   "`{(trip p.i)}`"  
  %link   "[{(trip show.i)}]({(trip href.i)})"
  %img    "![{(trip alt.i)}]({(trip src.i)})"
  %break  "\0a"
  ==
++  tags-to-tape
|=  t=(set @t)  ^-  tape
  %^  foldi:sr  ~(tap in t)  ""  |=  [i=@ud c=@t acc=tape]
  ?:  .=(+(i) ~(wyt in t))
  "{acc}{(trip c)}"
  "{acc}{(trip c)},"
--