]> git.wincent.com - docvim.git/blob - lib/Text/Docvim/Parse.hs
722d40219ff3f7138f3e752d03bf29928031863a
[docvim.git] / lib / Text / Docvim / Parse.hs
1 {-# LANGUAGE FlexibleContexts #-}
2
3 module Text.Docvim.Parse ( parse
4                          , rstrip
5                          , strip
6                          , unit
7                          ) where
8
9 import Control.Applicative hiding ((<|>), many, optional)
10 import Data.Char
11 import Data.List (groupBy, intercalate)
12 import System.Exit
13 import System.IO
14 import Text.Docvim.AST
15 import Text.Parsec hiding (newline, parse)
16 import Text.Parsec.String
17
18 -- | Given a `description` like "fu[nction]", returns a parser that matches
19 -- "fu", "fun", "func", "funct", "functi", "functio" and "function".
20 --
21 -- Beware, may explode at runtime if passed an invalid `description`, due to the
22 -- use of `init`.
23 --
24 -- Requires the FlexibleContexts extension, for reasons that I don't yet fully
25 -- understand.
26 command :: String -> Parser ()
27 command description =   try (string prefix >> remainder rest)
28                     <?> prefix ++ rest
29   where prefix           = takeWhile (/= '[') description
30         rest             = init (snd (splitAt (1 + length prefix) description))
31         remainder [r]    = optional (char r)
32         remainder (r:rs) = optional (char r >> remainder rs)
33         remainder []     = error "Unexpected empty remainder"
34
35 function :: Parser Node
36 function =   FunctionDeclaration
37          <$> (fu *> bang <* wsc)
38          <*> (name <* optional wsc)
39          <*> arguments
40          <*> (attributes <* optional wsc)
41          <*> (skippable *> many node <* (optional ws >> endfunction))
42   where
43     fu         = command "fu[nction]"
44     name       = choice [script, normal, autoloaded] <* optional wsc
45     script     = liftA2 (++) (try $ string "s:") (many $ oneOf identifier)
46     normal     = liftA2 (++) (many1 upper) (many $ oneOf identifier)
47     autoloaded = do
48       a <- many1 $ oneOf identifier
49       b <- string "#"
50       c <- sepBy1 (many1 $ oneOf identifier) (string "#")
51       return $ a ++ b ++ intercalate "#" c
52     identifier = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"
53     arguments  =  (char '(' >> optional wsc)
54                *> (ArgumentList <$> argument `sepBy` (char ',' >> optional wsc))
55                <* (optional wsc >> char ')' >> optional wsc)
56     argument   = Argument <$> (string "..." <|> many1 alphaNum) <* optional wsc
57     attributes = choice [string "abort", string "range", string "dict"] `sepEndBy` wsc
58
59 -- Disambiguate `:endf[unction]` and `:endfo[r]`
60 endfunction :: Parser ()
61 endfunction =  lookAhead (string "endf" >> notFollowedBy (string "o"))
62             >> command "endf[unction]"
63             <* eos
64
65 lStatement :: Parser Node
66 lStatement =  lookAhead (char 'l')
67            >> choice [ try (lookAhead (string "lw")) >> lwindow
68                      , try (lookAhead (string "let")) >> letStatement
69                      , lexpr
70                      ]
71
72 lwindow :: Parser Node
73 lwindow = LwindowStatement <$> (lw *> height <* eos)
74   where
75     lw     = command "l[window]"
76     height = optionMaybe (wsc *> number)
77     number = liftA read (many1 digit)
78
79 lexpr :: Parser Node
80 lexpr = LexprStatement
81       <$> (command "lex[pr]" *> bang <* wsc)
82       <*> restOfLine
83
84 -- "let" is a reserved word in Haskell, so we call this "letStatement" instead.
85 letStatement :: Parser Node
86 letStatement =   LetStatement
87     <$> (string "let" >> wsc >> lhs)
88     <*> (optional wsc >> char '=' >> optional wsc *> rhs <* eos)
89   where
90     -- Kludge alert! Until we get a full expression parser, we use this crude
91     -- thing.
92     lhs = many1 $ noneOf "\"\n="
93     rhs = many1 $ noneOf "\n"
94
95 unlet :: Parser Node
96 unlet =   UnletStatement
97       <$> (unl *> bang <* wsc)
98       <*> word
99       <*  eos
100   where
101     unl  = command "unl[et]"
102
103 quote :: Parser String
104 quote = string "\"" <?> "quote"
105
106 commentStart :: Parser String
107 commentStart  = quote <* (notFollowedBy quote >> optional ws)
108
109 docBlockStart :: Parser String
110 docBlockStart = (string "\"\"" <* optional ws) <?> "\"\""
111
112 separator :: Parser Node
113 separator = Separator <$ (try (string "---") >> optional ws) <?> "wat"
114
115 fenced :: Parser Node
116 fenced = fence >> newline >> Fenced <$> body
117   where
118     fence = try $ string "```" >> optional ws
119     body = do
120       lines' <- manyTill line (try $ (commentStart <|> docBlockStart) >> optional ws >> fence)
121       let indent = foldr countLeadingSpaces infinity lines'
122       return $ map (trimLeadingSpace indent) lines'
123       where
124         -- Find minimum count of leading spaces.
125         countLeadingSpaces line' = min (length (takeWhile (' ' ==) line'))
126         trimLeadingSpace count' = if count' > 0
127                                  then drop count'
128                                  else id
129         infinity = maxBound :: Int
130     line           = (commentStart' <|> docBlockStart') >> restOfLine <* newline
131     commentStart'  = quote <* notFollowedBy quote
132     docBlockStart' = string "\"\"" <?> "\"\""
133
134 blockquote :: Parser Node
135 blockquote =   lookAhead (char '>')
136            >>  Blockquote
137            <$> paragraph' `sepBy1` blankLine
138   where
139     paragraph' = Paragraph <$> body
140     body = paragraphBody firstLine otherLine
141     firstLine =  char '>'
142               >> optional ws
143               >> many1 (choice [phrasing, whitespace])
144     otherLine =  try $ newline
145               >> (commentStart <|> docBlockStart)
146               >> firstLine
147     blankLine =  try $ newline
148               >> (commentStart <|> docBlockStart)
149               >> many1 (try $ char '>'
150               >> optional ws
151               >> newline
152               >> (commentStart <|> docBlockStart))
153
154 list :: Parser Node
155 list =  lookAhead (char '-' >> notFollowedBy (char '-'))
156      >> List
157      <$> listItem `sepBy1` separator'
158   where
159     -- Yes, this is a bit hideous.
160     separator' =  try $ newline
161                >> (commentStart <|> docBlockStart)
162                >> optional ws
163                >> lookAhead (char '-')
164
165 listItem :: Parser Node
166 listItem =  lookAhead (char '-' >> notFollowedBy (char '-'))
167          >> ListItem
168          <$> body
169   where
170     body = paragraphBody firstLine otherLine
171     firstLine = char '-' >> optional ws >> many1 (choice [phrasing, whitespace])
172     otherLine =  try $ newline
173               >> (commentStart <|> docBlockStart)
174               -- TODO ^ DRY this up?
175               >> optional ws
176               >> lookAhead (noneOf "-")
177               >> many1 (choice [phrasing, whitespace])
178
179 -- | Newline (and slurps up following horizontal whitespace as well).
180 newline :: Parser ()
181 newline = (char '\n' >> optional ws) <|> eof
182
183 newlines :: Parser [()]
184 newlines =   many1 (char '\n' >> optional ws)
185          <|> (eof >> return [()])
186
187 -- | Whitespace (specifically, horizontal whitespace: spaces and tabs).
188 ws :: Parser String
189 ws = many1 (oneOf " \t")
190
191 -- | Continuation-aware whitespace (\).
192 wsc :: Parser String
193 wsc = many1 $ choice [whitespace', continuation]
194   where
195     whitespace'   = oneOf " \t"
196     continuation = try $ char '\n' >> ws >> char '\\'
197
198 -- TODO: string literals; some nasty lookahead might be required
199 comment :: Parser ()
200 comment = try
201         $ quote
202         >> notFollowedBy quote
203         >> restOfLine
204         >> skipMany (char '\n' >> optional ws)
205
206 -- | Optional bang suffix for VimL commands.
207 bang :: Parser Bool
208 bang = option False (True <$ char '!')
209
210 -- | End-of-statement.
211 -- TODO: see `:h :bar` for a list of commands which see | as an arg instead of a
212 -- command separator.
213 eos :: Parser ()
214 eos = optional ws >> choice [bar, ws', skipMany1 comment]
215   where
216     bar = char '|' >> optional wsc
217     ws' = newlines >> notFollowedBy wsc
218
219 node :: Parser Node
220 node =  choice [ docBlock
221                , vimL
222                ]
223      <* optional skippable
224
225 docBlock :: Parser Node
226 docBlock = lookAhead docBlockStart
227          >> (DocBlock <$> many1 blockElement)
228          <* trailingBlankCommentLines
229   where
230     blockElement =  try $ start
231                  >> skipMany emptyLines
232                  *> choice [ annotation
233                            , try subheading -- must come before heading
234                            , heading
235                            , linkTargets
236                            , separator
237                            , list
238                            , blockquote
239                            , fenced
240                            , paragraph -- must come last
241                            ]
242                  <* next
243     start = try docBlockStart <|> commentStart
244     emptyLines = try $ newline >> start
245     next = optional ws >> newline
246     trailingBlankCommentLines = skipMany $ start >> newline
247
248 paragraph :: Parser Node
249 paragraph = Paragraph <$> body
250   where
251     body = paragraphBody firstLine otherLine
252     firstLine = many1 $ choice [phrasing, whitespace]
253     otherLine =  try $ newline
254               >> (commentStart <|> docBlockStart)
255               >> optional ws
256               >> notFollowedBy special
257               >> firstLine
258
259 paragraphBody :: Parser [Node] -> Parser [Node] -> Parser [Node]
260 paragraphBody firstLine otherLine = do
261     first  <- firstLine
262     rest   <- many otherLine
263     -- Make every line end with whitespace.
264     let nodes = concatMap appendWhitespace (first:rest)
265     -- Collapse consecutive whitespace.
266     let compressed = compress nodes
267     -- Trim final whitespace.
268     return ( if last compressed == Whitespace
269              then init compressed
270              else compressed )
271
272 -- | Used in lookahead rules to make sure that we don't greedily consume special
273 -- tokens as if they were just phrasing content.
274 special :: Parser String
275 special = choice [ string "-" <* notFollowedBy (char '-')
276                  , string ">"
277                  , string "---"
278                  , string "-" <* string "--"
279                  , string "```"
280                  , string "`" <* string "``"
281                  , string "@"
282                  , string "#"
283                  ]
284
285 phrasing :: Parser Node
286 phrasing = choice [ br
287                   , link
288                   , code
289                   , plaintext
290                   ]
291
292 -- | Appends a Whitespace token to a list of nodes.
293 appendWhitespace :: [Node] -> [Node]
294 appendWhitespace xs = xs ++ [Whitespace]
295
296 -- | Compress whitespace.
297 -- Consecutive Whitespace tokens are replaced with a single token.
298 -- If a run of whitespace includes a BreakTag, the run is replaced with the
299 -- BreakTag.
300 compress :: [Node] -> [Node]
301 compress = map prioritizeBreakTag . group
302   where
303     group                    = groupBy fn
304     fn BreakTag Whitespace   = True
305     fn Whitespace BreakTag   = True
306     fn Whitespace Whitespace = True
307     fn _ _                   = False
308     prioritizeBreakTag xs = if hasBreakTag xs
309                             then BreakTag
310                             else head xs
311     hasBreakTag = elem BreakTag
312 -- similar to "word"... might end up replacing "word" later on...
313 -- something more sophisticated here with satisfy?
314 plaintext :: Parser Node
315 plaintext = Plaintext <$> wordChars
316   where
317     wordChars = many1 $ choice [ try $ char '<' <* notFollowedBy (string' "br")
318                                , noneOf " \n\t<|`"
319                                ]
320
321 -- | Case-insensitive char match.
322 --
323 -- Based on `caseChar` function in:
324 -- https://hackage.haskell.org/package/hsemail-1.3/docs/Text-ParserCombinators-Parsec-Rfc2234.html
325 char' :: Char -> Parser Char
326 char' c = satisfy $ \x -> toUpper x == toUpper c
327
328 -- | Case-insensitive string match.
329 --
330 -- Based on `caseString` function in:
331 -- https://hackage.haskell.org/package/hsemail-1.3/docs/Text-ParserCombinators-Parsec-Rfc2234.html
332 string' :: String -> Parser String
333 string' s = mapM_ char' s >> pure s <?> s
334
335 -- | Tokenized whitespace.
336 --
337 -- Most whitespace is insignificant and gets omitted from the AST, but
338 -- whitespace inside "phrasing content" is significant so is preserved (in
339 -- normalized form) in the AST.
340 whitespace :: Parser Node
341 whitespace = Whitespace <$ ws
342
343 br :: Parser Node
344 br = BreakTag <$ (try htmlTag <|> try xhtmlTag) <?> "<br />"
345   where
346     htmlTag = string' "<br>"
347     xhtmlTag = string' "<br" >> optional ws >> string "/>"
348
349 link :: Parser Node
350 link = Link <$> (bar *> linkText <* bar)
351   where
352     bar      = char '|'
353     linkText = many1 $ noneOf " \t\n|"
354
355 code :: Parser Node
356 code = Code <$> (backtick *> codeText <* backtick)
357   where
358     backtick = char '`'
359     codeText = many $ noneOf "\n`"
360
361 -- TODO: record this in symbol table similar to
362 -- https://github.com/wincent/docvim/blob/js/src/SymbolVisitor.js
363 -- (probably want to make this a post-processing step?)
364 linkTargets :: Parser Node
365 linkTargets = LinkTargets <$> many1 (star *> target <* (star >> optional ws))
366   where
367     star = char '*'
368     target = many1 $ noneOf " \t\n*"
369
370 vimL :: Parser Node
371 vimL = choice [ block
372               , statement
373               ]
374
375 block :: Parser Node
376 block = choice [ function ]
377
378 statement :: Parser Node
379 statement = choice [ lStatement
380                    , unlet
381                    , genericStatement
382                    ]
383
384 -- | Generic VimL node parser to represent stuff that we haven't built out full parsing
385 -- for yet.
386 genericStatement :: Parser Node
387 genericStatement = do
388   -- Make sure we never recognize `endfunction` as a generic statement. This is
389   -- necessary because we call `node` recursively inside `function` while
390   -- parsing the function body. We must stop `node` from consuming
391   -- `endfunction`, otherwise the `function` parse will fail to find it.
392   notFollowedBy endfunction
393   atoms <- sepEndBy1 word (optional wsc)
394   eos
395   return $ GenericStatement $ unwords atoms
396
397 -- | Remainder of the line up to but not including a newline.
398 -- Does not include any trailing whitespace.
399 restOfLine :: Parser String
400 restOfLine = do
401   rest <- many (noneOf "\n")
402   return $ rstrip rest
403
404 -- | Strip trailing and leading whitespace.
405 --
406 -- Not efficient, but chosen for readablility.
407 --
408 -- TODO: switch to Data.Text (http://stackoverflow.com/a/6270382/2103996) for
409 -- efficiency.
410 strip :: String -> String
411 strip = lstrip . rstrip
412
413 -- | Strip leading (left) whitespace.
414 lstrip :: String -> String
415 lstrip = dropWhile (`elem` " \n\t")
416
417 -- | Strip trailing (right) whitespace.
418 rstrip :: String -> String
419 rstrip = reverse . lstrip . reverse
420
421 heading :: Parser Node
422 heading =  char '#'
423         >> notFollowedBy (char '#')
424         >> optional ws
425         >> HeadingAnnotation <$> restOfLine
426
427 subheading :: Parser Node
428 subheading =  string "##"
429            >> optional ws
430            >> SubheadingAnnotation <$> restOfLine
431
432 -- | Match a "word" of non-whitespace characters.
433 word :: Parser String
434 word = many1 (noneOf " \n\t")
435
436 -- TODO: only allow these after "" and " at start of line
437 annotation :: Parser Node
438 annotation = char '@' *> annotationName
439   where
440     annotationName =
441       choice [ try $ string "commands" >> pure CommandsAnnotation -- must come before function
442              , command'
443              , string "dedent" >> pure DedentAnnotation
444              , try $ string "footer" >> pure FooterAnnotation -- must come before function'
445              , try $ string "functions" >> pure FunctionsAnnotation -- must come before function'
446              , function'
447              , string "indent" >> pure IndentAnnotation
448              , try $ string "mappings" >> pure MappingsAnnotation -- must come before mapping
449              , mapping
450              , try $ string "options" >> pure OptionsAnnotation -- must come before option'
451              , option'
452              , plugin
453              ]
454
455     command'          = string "command" >> ws >> CommandAnnotation <$> commandName <*> commandParameters
456     commandName       = char ':' *> many1 alphaNum <* optional ws
457     commandParameters = optionMaybe $ many1 (noneOf "\n")
458
459     function'         = string "function" >> ws >> FunctionAnnotation <$> word <* optional ws
460
461     mapping           = string "mapping" >> ws >> MappingAnnotation <$> mappingName
462     mappingName       = word <* optional ws
463
464     option'           = string "option" >> ws >> OptionAnnotation <$> optionName <*> optionType <*> optionDefault
465     optionName        = many1 (alphaNum <|> char ':') <* ws <?> "option name"
466     optionType        = many1 alphaNum <* optional ws <?> "option type"
467     optionDefault     = optionMaybe word <?> "option default value"
468
469     plugin            = string "plugin" >> ws >> PluginAnnotation <$> pluginName <*> plugInDescription
470     pluginName        = many1 alphaNum <* ws
471     plugInDescription = restOfLine
472
473 -- | Parses a translation unit (file contents) into an AST.
474 unit :: Parser Node
475 unit =   Unit
476      <$> (skippable >> many node)
477      <*  eof
478
479 skippable :: Parser [()]
480 skippable = many $ choice [ comment
481                           , skipMany1 ws
482                           , skipMany1 (char '\n')
483                           ]
484
485 parse :: String -> IO Node
486 parse fileName = parseFromFile unit fileName >>= either report return
487   where
488     report err = do
489       hPutStrLn stderr $ "Error: " ++ show err
490       exitFailure