
   0 | module Text.Markdown.Parser
   1 | 
   2 | import Text.Markdown.Lexer
   3 | import Text.Markdown.Data
   4 | import Text.Parser
   5 | import Text.Token
   6 | import Data.List
   7 | 
   8 | import public Text.Markdown.Tokens
   9 | 
  10 | %default total
  11 | 
  12 | mutual
  13 |   private
  14 |   covering
  15 |   markdown : Grammar state MarkdownToken False Markdown
  16 |   markdown =
  17 |     do
  18 |       els <- many (
  19 |               (map Just horizontalRules)
  20 |           <|> (map (const Nothing) $ blankLine)
  21 |           <|> (map Just header)
  22 |           <|> (map Just paragraph)
  23 |         )
  24 |       pure $ Doc (mapMaybe id els)
  25 | 
  26 |   private
  27 |   covering
  28 |   inline : Grammar state MarkdownToken True Inline
  29 |   inline =
  30 |     (
  31 |           text
  32 |       <|> pre
  33 |       <|> codeBlock
  34 |       <|> bold
  35 |       <|> italics
  36 |       <|> image
  37 |       <|> link
  38 |       <|> html
  39 |       <|> parts
  40 |       <|> newLineInline
  41 |     )
  42 | 
  43 |   -- TODO: Handle other incomplete parts
  44 |   parts : Grammar state MarkdownToken True Inline
  45 |   parts =
  46 |     map (const $ Text "!") (match ImageSym)
  47 | 
  48 |   covering
  49 |   wrapInline : MarkdownTokenKind -> (List Inline -> a) -> Grammar state MarkdownToken True a
  50 |   wrapInline sym tok =
  51 |     do
  52 |       start <- match sym
  53 |       contents <- some inline
  54 |       end <- match sym
  55 |       pure $ tok $ toList contents
  56 | 
  57 |   private
  58 |   blankLine : Grammar state MarkdownToken True ()
  59 |   blankLine =
  60 |     map (const ()) (match BlankLine)
  61 | 
  62 |   private
  63 |   covering
  64 |   header : Grammar state MarkdownToken True Block
  65 |   header =
  66 |     do
  67 |       level <- match HeadingSym
  68 |       commit -- TODO: Should we commit here?
  69 |       contents <- someTill blockTerminal inline
  70 |       pure $ Header level $ toList contents
  71 | 
  72 |   ||| Parses horizontal rules.
  73 |   private
  74 |   horizontalRules : Grammar state MarkdownToken True Block
  75 |   horizontalRules = do
  76 |     match MdHorizontalRules
  77 |     pure HorizontalRules
  78 | 
  79 |   ||| Terminates a paragraph.
  80 |   |||
  81 |   ||| It can be:
  82 |   |||
  83 |   ||| - a blank line; or
  84 |   ||| - horizontal rules; or
  85 |   ||| - the end of the file.
  86 |   blockTerminal : Grammar state MarkdownToken False ()
  87 |   blockTerminal =
  88 |         (map (const ()) $ (some blankLine))
  89 |     <|> (map (const ()) $ (some horizontalRules))
  90 |     <|> eof
  91 | 
  92 |   ||| Matches newlines which are part of an inline text.
  93 |   |||
  94 |   ||| This typically happens when splitting a same paragraph accross multiple
  95 |   ||| Lines.
  96 |   private
  97 |   newLineInline : Grammar state MarkdownToken True Inline
  98 |   newLineInline =
  99 |     map (\_ => NewLine) (match MdNewLine)
 100 | 
 101 |   private
 102 |   covering
 103 |   paragraph : Grammar state MarkdownToken True Block
 104 |   paragraph =
 105 |     do
 106 |       contents <- some inline
 107 |       pure $ Paragraph $ toList contents
 108 | 
 109 |   private
 110 |   text : Grammar state MarkdownToken True Inline
 111 |   text =
 112 |     map Text (match MdText)
 113 | 
 114 |   private
 115 |   pre : Grammar state MarkdownToken True Inline
 116 |   pre =
 117 |     map Pre (match MdPre)
 118 | 
 119 |   private
 120 |   codeBlock : Grammar state MarkdownToken True Inline
 121 |   codeBlock =
 122 |     map (uncurry CodeBlock) (match MdCodeBlock)
 123 | 
 124 |   private
 125 |   covering
 126 |   bold : Grammar state MarkdownToken True Inline
 127 |   bold =
 128 |     wrapInline BoldSym Bold
 129 | 
 130 |   private
 131 |   covering
 132 |   italics : Grammar state MarkdownToken True Inline
 133 |   italics =
 134 |     wrapInline ItalicsSym Italics
 135 | 
 136 |   private
 137 |   image : Grammar state MarkdownToken True Inline
 138 |   image =
 139 |     do
 140 |       match ImageSym
 141 |       r <- match MdLink
 142 |       buildImage r
 143 | 
 144 |   private
 145 |   buildImage : (String, String) -> Grammar state MarkdownToken False Inline
 146 |   buildImage (alt, src) =
 147 |     pure $ Image alt src
 148 | 
 149 |   private
 150 |   link : Grammar state MarkdownToken True Inline
 151 |   link =
 152 |     map (\(href, desc) => Link href desc) (match MdLink)
 153 | 
 154 |   private
 155 |   covering
 156 |   html : Grammar state MarkdownToken True Inline
 157 |   html =
 158 |     do
 159 |       openTag <- match HtmlOpenTag
 160 |       contents <- many inline
 161 |       closer openTag -- TODO: Is this inefficient?
 162 |       pure $ Html openTag contents
 163 | 
 164 |   private
 165 |   closer : String -> Grammar state MarkdownToken True ()
 166 |   closer tag =
 167 |     do
 168 |       closeTag <- match HtmlCloseTag
 169 |       checkTag closeTag tag
 170 | 
 171 |   private
 172 |   checkTag : String -> String -> Grammar state MarkdownToken False ()
 173 |   checkTag x y =
 174 |     if x == y
 175 |       then pure ()
 176 |       else fail "tag mismatch"
 177 | 
 178 | export
 179 | covering
 180 | parseMarkdown : List MarkdownToken -> Maybe Markdown
 181 | parseMarkdown toks =
 182 |   let
 183 |     bounds = MkBounds 0 0 10000000 80
 184 |     boundedToks = map (\tok => MkBounded tok True bounds) toks
 185 |   in
 186 |   case parse markdown boundedToks of
 187 |     Right (j, []) => Just j
 188 |     _ => Nothing
 189 |