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  <- firstLine
 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     firstLine = char '-'
 213               >> optional ws
 214               >> many1 (choice [phrasing, whitespace])
 215     otherLine =  try $ newline
 216               >> (commentStart <|> docBlockStart)
 217               -- TODO ^ DRY this up?
 218               >> optional ws
 219               >> lookAhead (noneOf "-")
 220               >> many1 (choice [phrasing, whitespace])
 221
 222 -- | Newline (and slurps up following horizontal whitespace as well).
 223 newline = (char '\n' >> optional ws) <|> eof
 224 newlines =   many1 (char '\n' >> optional ws)
 225          <|> (eof >> return [()])
 226
 227 -- | Whitespace (specifically, horizontal whitespace: spaces and tabs).
 228 ws = many1 (oneOf " \t")
 229
 230 -- | Continuation-aware whitespace (\).
 231 wsc = many1 $ choice [whitespace, continuation]
 232   where
 233     whitespace   = oneOf " \t"
 234     continuation = try $ char '\n' >> ws >> char '\\'
 235
 236 -- TODO: string literals; some nasty lookahead might be required
 237 comment = try
 238         $ quote
 239         >> notFollowedBy quote
 240         >> restOfLine
 241         >> skipMany (char '\n' >> optional ws)
 242
 243 -- | Optional bang suffix for VimL commands.
 244 bang = option False (True <$ char '!')
 245
 246 -- | End-of-statement.
 247 -- TODO: see `:h :bar` for a list of commands which see | as an arg instead of a
 248 -- command separator.
 249 eos = optional ws >> choice [bar, ws', skipMany1 comment]
 250   where
 251     bar = char '|' >> optional wsc
 252     ws' = newlines >> notFollowedBy wsc
 253
 254 node :: Parser Node
 255 node =  choice [ docBlock
 256                , vimL
 257                ]
 258      <* optional skippable
 259
 260 docBlock = lookAhead docBlockStart
 261          >> (DocBlock <$> many1 blockElement)
 262          <* trailingBlankCommentLines
 263   where
 264     blockElement =  try $ start
 265                  >> skipMany emptyLines
 266                  *> choice [ annotation
 267                            , try subheading -- must come before heading
 268                            , heading
 269                            , linkTargets
 270                            , separator
 271                            , list
 272                            , blockquote
 273                            , fenced
 274                            , paragraph -- must come last
 275                            ]
 276                  <* next
 277     start = try docBlockStart <|> commentStart
 278     emptyLines = try $ newline >> start
 279     next = optional ws >> newline
 280     trailingBlankCommentLines = skipMany $ start >> newline
 281
 282 paragraph = Paragraph <$> body
 283   where
 284     body = do
 285       first <- firstLine
 286       rest <- many otherLine
 287       -- Make every line end with whitespace
 288       let nodes = concatMap appendWhitespace (first:rest)
 289       -- Collapse consecutive whitespace
 290       let compressed = compress nodes
 291       -- Trim final whitespace
 292       return ( if last compressed == Whitespace
 293                then init compressed
 294                else compressed )
 295     firstLine = many1 $ choice [phrasing, whitespace]
 296     otherLine =  try $ newline
 297               >> (commentStart <|> docBlockStart)
 298               >> optional ws
 299               >> notFollowedBy special
 300               >> firstLine
 301
 302 -- | Used in lookahead rules to make sure that we don't greedily consume special
 303 -- tokens as if they were just phrasing content.
 304 special :: Parser String
 305 special = choice [ string "-" <* notFollowedBy (char '-')
 306                  , string ">"
 307                  , string "---"
 308                  , string "-" <* string "--"
 309                  , string "```"
 310                  , string "`" <* string "``"
 311                  , string "@"
 312                  , string "#"
 313                  ]
 314
 315 phrasing = choice [ br
 316                   , link
 317                   , code
 318                   , plaintext
 319                   ]
 320
 321 -- | Appends a Whitespace token to a list of nodes.
 322 appendWhitespace :: [Node] -> [Node]
 323 appendWhitespace xs = xs ++ [Whitespace]
 324
 325 -- | Compress whitespace.
 326 -- Consecutive Whitespace tokens are replaced with a single token.
 327 -- If a run of whitespace includes a BreakTag, the run is replaced with the
 328 -- BreakTag.
 329 compress :: [Node] -> [Node]
 330 compress = map prioritizeBreakTag . group
 331   where
 332     group                    = groupBy fn
 333     fn BreakTag Whitespace   = True
 334     fn Whitespace BreakTag   = True
 335     fn Whitespace Whitespace = True
 336     fn _ _                   = False
 337     prioritizeBreakTag xs = if hasBreakTag xs
 338                             then BreakTag
 339                             else head xs
 340     hasBreakTag = elem BreakTag
 341 -- similar to "word"... might end up replacing "word" later on...
 342 -- something more sophisticated here with satisfy?
 343 plaintext = Plaintext <$> wordChars
 344   where
 345     wordChars = many1 $ choice [ try $ char '<' <* notFollowedBy (string' "br")
 346                                , noneOf " \n\t<|`"
 347                                ]
 348
 349 -- | Case-insensitive char match.
 350 --
 351 -- Based on `caseChar` function in:
 352 -- https://hackage.haskell.org/package/hsemail-1.3/docs/Text-ParserCombinators-Parsec-Rfc2234.html
 353 char' c = satisfy $ \x -> toUpper x == toUpper c
 354
 355 -- | Case-insensitive string match.
 356 --
 357 -- Based on `caseString` function in:
 358 -- https://hackage.haskell.org/package/hsemail-1.3/docs/Text-ParserCombinators-Parsec-Rfc2234.html
 359 string' s = mapM_ char' s >> pure s <?> s
 360
 361 -- | Tokenized whitespace.
 362 --
 363 -- Most whitespace is insignificant and gets omitted from the AST, but
 364 -- whitespace inside "phrasing content" is significant so is preserved (in
 365 -- normalized form) in the AST.
 366 whitespace = Whitespace <$ ws
 367
 368 br = BreakTag <$ (try htmlTag <|> try xhtmlTag) <?> "<br />"
 369   where
 370     htmlTag = string' "<br>"
 371     xhtmlTag = string' "<br" >> optional ws >> string "/>"
 372
 373 link = Link <$> (bar *> linkText <* bar)
 374   where
 375     bar      = char '|'
 376     linkText = many1 $ noneOf " \t\n|"
 377
 378 code = Code <$> (backtick *> codeText <* backtick)
 379   where
 380     backtick = char '`'
 381     codeText = many $ noneOf "\n`"
 382
 383 -- TODO: record this in symbol table similar to
 384 -- https://github.com/wincent/docvim/blob/js/src/SymbolVisitor.js
 385 -- (probably want to make this a post-processing step?)
 386 linkTargets = LinkTargets <$> many1 (star *> target <* (star >> optional ws))
 387   where
 388     star = char '*'
 389     target = many1 $ noneOf " \t\n*"
 390
 391 vimL = choice [ block
 392               , statement
 393               ]
 394
 395 block = choice [ function ]
 396 statement = choice [ lStatement
 397                    , unlet
 398                    , genericStatement
 399                    ]
 400
 401 -- | Generic VimL node parser to represent stuff that we haven't built out full parsing
 402 -- for yet.
 403 genericStatement = do
 404   -- Make sure we never recognize `endfunction` as a generic statement. This is
 405   -- necessary because we call `node` recursively inside `function` while
 406   -- parsing the function body. We must stop `node` from consuming
 407   -- `endfunction`, otherwise the `function` parse will fail to find it.
 408   notFollowedBy endfunction
 409   atoms <- sepEndBy1 word (optional wsc)
 410   eos
 411   return $ GenericStatement $ unwords atoms
 412
 413 -- | Remainder of the line up to but not including a newline.
 414 -- Does not include any trailing whitespace.
 415 restOfLine :: Parser String
 416 restOfLine = do
 417   rest <- many (noneOf "\n")
 418   return $ rstrip rest
 419
 420 -- | Strip trailing and leading whitespace.
 421 --
 422 -- Not efficient, but chosen for readablility.
 423 --
 424 -- TODO: switch to Data.Text (http://stackoverflow.com/a/6270382/2103996) for
 425 -- efficiency.
 426 strip = lstrip . rstrip
 427
 428 -- | Strip leading (left) whitespace.
 429 lstrip = dropWhile (`elem` " \n\t")
 430
 431 -- | Strip trailing (right) whitespace.
 432 rstrip = reverse . lstrip . reverse
 433
 434 heading :: Parser Node
 435 heading =  char '#'
 436         >> notFollowedBy (char '#')
 437         >> optional ws
 438         >> HeadingAnnotation <$> restOfLine
 439
 440 subheading :: Parser Node
 441 subheading =  string "##"
 442            >> optional ws
 443            >> SubheadingAnnotation <$> restOfLine
 444
 445 -- | Match a "word" of non-whitespace characters.
 446 word = many1 (noneOf " \n\t")
 447
 448 -- TODO: only allow these after "" and " at start of line
 449 annotation :: Parser Node
 450 annotation = char '@' *> annotationName
 451   where
 452     annotationName =
 453       choice [ try $ string "commands" >> pure CommandsAnnotation -- must come before function
 454              , command
 455              , string "dedent" >> pure DedentAnnotation
 456              , try $ string "footer" >> pure FooterAnnotation -- must come before function
 457              , try $ string "functions" >> pure FunctionsAnnotation -- must come before function
 458              , function
 459              , string "indent" >> pure IndentAnnotation
 460              , try $ string "mappings" >> pure MappingsAnnotation -- must come before mapping
 461              , mapping
 462              , try $ string "options" >> pure OptionsAnnotation -- must come before option
 463              , option
 464              , plugin
 465              ]
 466
 467     command           = string "command" >> ws >> CommandAnnotation <$> ((:) <$> char ':' <*> many1 (noneOf "\n"))
 468
 469     function          = string "function" >> ws >> FunctionAnnotation <$> word <* optional ws
 470
 471     mapping           = string "mapping" >> ws >> MappingAnnotation <$> mappingName
 472     mappingName       = word <* optional ws
 473
 474     option            = string "option" >> ws >> OptionAnnotation <$> optionName <*> optionType <*> optionDefault
 475     optionName        = many1 (alphaNum <|> char ':') <* ws <?> "option name"
 476     optionType        = many1 alphaNum <* ws <?> "option type"
 477     -- BUG: this is not optional, it would seem (see tests/fixtures/vim/options.vim)
 478     optionDefault     = optionMaybe word <?> "option default value"
 479
 480     plugin            = string "plugin" >> ws >> PluginAnnotation <$> pluginName <*> plugInDescription
 481     pluginName        = many1 alphaNum <* ws
 482     plugInDescription = restOfLine
 483
 484 -- | Parses a translation unit (file contents) into an AST.
 485 unit :: Parser Node
 486 unit =   Unit
 487      <$> (skippable >> many node)
 488      <*  eof
 489
 490 skippable = many $ choice [ comment
 491                           , skipMany1 ws
 492                           , skipMany1 (char '\n')
 493                           ]
 494
 495 parse :: String -> IO Node
 496 parse fileName = parseFromFile unit fileName >>= either report return
 497   where
 498     report err = do
 499       hPutStrLn stderr $ "Error: " ++ show err
 500       exitFailure