]> git.wincent.com - docvim.git/blob - lib/Docvim/Parse.hs
Make unit tests a little more real
[docvim.git] / lib / Docvim / Parse.hs
1 {-# LANGUAGE FlexibleContexts #-}
2
3 module Docvim.Parse ( p
4                     , parse
5                     , parseUnit
6                     ) where
7
8 import Control.Applicative ( (*>)
9                            , (<$)
10                            , (<$>)
11                            , (<*)
12                            , (<*>)
13                            )
14 import Data.List (intercalate)
15 import System.Exit (exitFailure)
16 import System.FilePath (takeExtension)
17 import System.IO (hPutStrLn, stderr)
18 -- TODO: custom error messages with <?>
19 import Text.Parsec ( (<|>)
20                    , (<?>)
21                    , choice
22                    , lookAhead
23                    , many
24                    , many1
25                    , manyTill
26                    , notFollowedBy
27                    , option
28                    , optionMaybe
29                    , optional
30                    , parseTest
31                    , runParser
32                    , sepBy
33                    , sepEndBy
34                    , skipMany
35                    , try
36                    )
37 import Text.Parsec.String (Parser, parseFromFile)
38 import Text.Parsec.Combinator (eof)
39 import Text.ParserCombinators.Parsec.Char ( alphaNum
40                                           , anyChar
41                                           , char
42                                           , noneOf
43                                           , oneOf
44                                           , string
45                                           )
46
47 data Unit = Unit [Node] deriving (Eq, Show)
48
49 -- Note that VimL can contain a DocComment almost anywhere, so will
50 -- probably want to make DocComment into a real island parser, with the
51 -- VimL parser being the primary parser. Won't attach VimL info to
52 -- DocComment nodes during the parse; will likely need a separate pass of the
53 -- AST after that.
54 data Node
55           -- VimL nodes
56           = FunctionDeclaration { functionBang :: Bool
57                                 , functionName :: String
58                                 , functionArguments :: ArgumentList
59                                 , functionAttributes :: [String]
60                                 , functionBody :: [Node]
61                                 }
62           | LetStatement { letLexpr :: String
63                          , letValue :: String
64                          }
65           | UnletStatement { unletBang :: Bool
66                            , unletBody :: String
67                            }
68
69           -- docvim nodes
70           | PluginAnnotation Name Description
71           | FunctionAnnotation Name -- not sure if I will want more here
72           | IndentAnnotation
73           | DedentAnnotation
74           | CommandAnnotation Usage
75           | FooterAnnotation
76           | MappingsAnnotation
77           | MappingAnnotation Name
78           | OptionAnnotation Name Type (Maybe Default)
79           | HeadingAnnotation String
80   deriving (Eq, Show)
81
82 -- The VimScript (VimL) grammar is embodied in the implementation of
83 -- https://github.com/vim/vim/blob/master/src/eval.c; there is no formal
84 -- specification for it, and there are many ambiguities that can only be
85 -- resolved at runtime. We aim to parse a loose subset.
86
87 -- TODO: deal with bar |
88 --       note that `function X() |` does not work, and `endf` must be on a line
89 --       of its own too (not a syntax error to do `| endf`, but it doesn't work
90 --       , so you need to add another `endf`, which will blow up at runtime.
91 -- TODO: validate name = CapitalLetter or s:foo or auto#loaded
92
93 data ArgumentList = ArgumentList [Argument]
94   deriving (Eq)
95
96 instance Show ArgumentList where
97   show (ArgumentList arguments) = "(" ++ intercalate ", " argStrings ++ ")"
98     where
99       argStrings = map show arguments
100
101 data Argument = Argument String
102   deriving (Eq)
103
104 instance Show Argument where
105   show (Argument argument) = argument
106
107 -- | Given a `description` like "fu[nction]", returns a parser that matches
108 -- "fu", "fun", "func", "funct", "functi", "functio" and "function".
109 --
110 -- Beware, may explode at runtime if passed an invalid `description`, due to the
111 -- use of `init`.
112 --
113 -- Requires the FlexibleContexts extension, for reasons that I don't yet fully
114 -- understand.
115 command description =   try (string prefix >> remainder rest)
116                     <?> prefix ++ rest
117   where prefix           = takeWhile (/= '[') description
118         rest             = init (snd (splitAt (1 + length prefix) description))
119         remainder [r]    = optional (char r)
120         remainder (r:rs) = optional (char r >> remainder rs)
121
122 function =   FunctionDeclaration
123          <$> (fu *> bang <* wsc)
124          <*> (name <* optional wsc)
125          <*> arguments
126          <*> (attributes <* optional wsc)
127          <*> (newlines *> many node <* (optional ws >> endf))
128   where
129     fu         = command "fu[nction]"
130     name       = many1 alphaNum <* optional wsc
131     arguments  =  (char '(' >> optional wsc)
132                *> (ArgumentList <$> argument `sepBy` (char ',' >> optional wsc))
133                <* (optional wsc >> char ')' >> optional wsc)
134     argument   = Argument <$> many1 alphaNum <* optional wsc
135     attributes = choice [string "abort", string "range", string "dict"] `sepEndBy` wsc
136     endf       = command "endf[unction]" <* eos
137
138 -- "let" is a reserved word in Haskell, so we call this "letStatement" instead.
139 letStatement =   LetStatement
140     <$> (string "let" >> wsc >> word')
141     <*> (optional wsc >> char '=' >> optional wsc *> word' <* eos)
142   where
143     word' = many1 $ noneOf " \n\t="
144
145 unlet =   UnletStatement
146       <$> (unl *> bang <* wsc)
147       <*> word
148       <*  (optional ws >> eos)
149   where
150     unl  = command "unl[et]"
151
152 -- | Textual tokens recognized during parsing but not embedded in the AST.
153 data Token = Blockquote
154            | CommentStart
155            | DocBlockStart
156            | ListItem
157            | Newline
158            | Whitespace String
159            | EOF
160   deriving (Eq, Show)
161
162 type Default = String
163 type Description = String
164 type Name = String
165 type Type = String
166 type Usage = String
167
168 -- These cause type errors unless used...
169 -- blockquote    = string ">" >> return Blockquote
170 -- commentStart  = string "\"" >> return CommentStart
171 docBlockStart = DocBlockStart <$ (string "\"\"" <* optional ws) <?> "\"\""
172 -- listItem = string "-" >> return ListItem
173 newline = Newline <$ char '\n'
174 newlines = many1 newline
175 ws = Whitespace <$> many1 (oneOf " \t")
176
177 -- | Continuation-aware whitespace (\).
178 wsc = many1 $ choice [whitespace, continuation]
179   where whitespace = oneOf " \t"
180         continuation = try $ char '\n' >> ws >> char '\\'
181
182 -- | Optional bang suffix for VimL commands.
183 bang = option False (True <$ char '!')
184
185 -- | End-of-statement.
186 eos = choice [bar, ws', eof]
187   where
188     bar = char '|' >> optional wsc
189     ws' = newlines >> notFollowedBy wsc
190
191 node :: Parser Node
192 node = choice [ docBlock
193               , vimL
194               ]
195
196 docBlock = docBlockStart >> choice [ annotation
197                                    , heading
198                                    ]
199 vimL = choice [ block
200               , statement
201               ]
202
203 block = choice [ function ]
204 statement = choice [ letStatement
205                    , unlet
206                    ]
207
208 heading :: Parser Node
209 heading = HeadingAnnotation <$> (char '#' >> optional ws *> manyTill anyChar (newline <|> (eof >> return EOF)))
210 -- TODO: probably want to swallow the newline here; make it implicit
211 -- (and any trailing whitespace)
212
213 -- | Match a "word" of non-whitespace characters.
214 word = many1 (noneOf " \n\t")
215
216 -- | Run a parser and consume trailing whitespace.
217 lexeme parser = do
218   result <- parser
219   ws
220   return result -- could also just do (parser <* ws)
221 -- ^ not sure if I want to use this yet, as I have a few whitespace patterns
222 -- here:
223 --   * require but skip
224 --   * optional but consume if present
225
226 -- TODO: only allow these after "" and " at start of line
227 annotation :: Parser Node
228 annotation = char '@' *> annotationName
229   where
230     annotationName =
231       choice [ command
232              , string "dedent" >> return DedentAnnotation
233              , try $ string "footer" >> return FooterAnnotation -- must come before function
234              , function
235              , string "indent" >> return IndentAnnotation
236              , try $ string "mappings" >> return MappingsAnnotation -- must come before mapping
237              , mapping
238              , option
239              , plugin
240              ]
241
242     command           = string "command" >> ws >> CommandAnnotation <$> ((:) <$> char ':' <*> many1 (noneOf "\n"))
243
244     function          = string "function" >> ws >> FunctionAnnotation <$> word <* optional ws
245
246     mapping           = string "mapping" >> ws >> MappingAnnotation <$> mappingName
247     mappingName       = word <* optional ws
248
249     option            = string "option" >> ws >> OptionAnnotation <$> optionName <*> optionType <*> optionDefault
250     optionName        = many1 (alphaNum <|> char ':') <* ws <?> "option name"
251     optionType        = many1 alphaNum <* ws <?> "option type"
252     optionDefault     = optionMaybe word <?> "option default value"
253
254     plugin            = string "plugin" >> ws >> PluginAnnotation <$> pluginName <*> plugInDescription
255     pluginName        = many1 alphaNum <* ws
256     plugInDescription = manyTill anyChar (newline <|> (eof >> return EOF))
257
258 -- | Parses a translation unit (file contents) into an AST.
259 unit :: Parser Unit
260 unit =   Unit
261      <$> (ws' >> many node)
262      <*  eof
263   where
264     ws' = many $ choice [ws, newline]
265
266 parse :: String -> IO Unit
267 parse fileName = parseFromFile unit fileName >>= either report return
268   where
269     report err = do
270       hPutStrLn stderr $ "Error: " ++ show err
271       exitFailure
272
273 -- | To facilitate quick testing in the console.
274 -- import Parse (p)
275 -- p "test"
276 p = parseTest unit
277
278 -- | To facilitate unit-testing.
279 parseUnit = runParser unit () "(eval)"