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