@@ -20,6 +20,7 @@ import qualified AST.Helpers as Help
2020import qualified AST.Literal as L
2121import qualified AST.PrettyPrint as P
2222import qualified AST.Variable as Variable
23+import Elm.Utils ((|>))
2324
2425reserveds :: [String]
2526reserveds =
@@ -33,66 +34,91 @@ reserveds =
3334 , "deriving", "port"
3435 ]
3536
37+
3638expecting = flip (<?>)
3739
40+
3841type OpTable = Map.Map String (Int, Decl.Assoc)
3942type SourceM = State SourcePos
4043type IParser a = ParsecT String OpTable SourceM a
4144
45+
4246iParse :: IParser a -> String -> Either ParseError a
43−iParse = iParseWithTable "" Map.empty
47+iParse parser source =
48+ iParseWithTable "" Map.empty parser source
49+
4450
4551iParseWithTable :: SourceName -> OpTable -> IParser a -> String -> Either ParseError a
4652iParseWithTable sourceName table aParser input =
4753 runIndent sourceName $ runParserT aParser table sourceName input
4854
55+
56+-- VARIABLES
57+
4958var :: IParser String
50−var = makeVar (letter <|> char '_' <?> "variable")
59+var =
60+ makeVar (letter <|> char '_' <?> "variable")
61+
5162
5263lowVar :: IParser String
53−lowVar = makeVar (lower <?> "lower case variable")
64+lowVar =
65+ makeVar (lower <?> "lower case variable")
66+
67+
5468capVar :: IParser String
55−capVar = makeVar (upper <?> "upper case variable")
69+capVar =
70+ makeVar (upper <?> "upper case variable")
71+
5672
5773qualifiedVar :: IParser String
58−qualifiedVar = do
59− vars <- many ((++) <$> capVar <*> string ".")
60− (++) (concat vars) <$> lowVar
74+qualifiedVar =
75+ do vars <- many ((++) <$> capVar <*> string ".")
76+ (++) (concat vars) <$> lowVar
77+
6178
6279rLabel :: IParser String
6380rLabel = lowVar
6481
82+
6583innerVarChar :: IParser Char
66−innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""
84+innerVarChar =
85+ alphaNum <|> char '_' <|> char '\'' <?> ""
86+
6787
6888makeVar :: IParser Char -> IParser String
69−makeVar p = do
70− v <- (:) <$> p <*> many innerVarChar
71− if v `elem` reserveds
72− then fail $ "unexpected keyword '" ++ v ++ "', variables cannot be keywords"
73− else return v
89+makeVar p =
90+ do v <- (:) <$> p <*> many innerVarChar
91+ if v `elem` reserveds
92+ then fail $ "unexpected keyword '" ++ v ++ "', variables cannot be keywords"
93+ else return v
94+
7495
7596reserved :: String -> IParser String
7697reserved word =
77− try (string word >> notFollowedBy innerVarChar) >> return word
98+ (try (string word >> notFollowedBy innerVarChar) >> return word)
7899 <?> "reserved word '" ++ word ++ "'"
79100
101+
102+-- INFIX OPERATORS
103+
80104anyOp :: IParser String
81−anyOp = betwixt '`' '`' qualifiedVar <|> symOp <?> "infix operator (e.g. +, *, ||)"
105+anyOp =
106+ betwixt '`' '`' qualifiedVar
107+ <|> symOp
108+ <?> "infix operator"
109+
82110
83111symOp :: IParser String
84−symOp = do op <- many1 (satisfy Help.isSymbol)
85− guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ])
86− case op of
87− "." -> notFollowedBy lower >> return op
88− "\8728" -> return "."
89− _ -> return op
112+symOp =
113+ do op <- many1 (satisfy Help.isSymbol)
114+ guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ])
115+ case op of
116+ "." -> notFollowedBy lower >> return op
117+ "\8728" -> return "."
118+ _ -> return op
90119
91−padded :: IParser a -> IParser a
92−padded p = do whitespace
93− out <- p
94− whitespace
95− return out
120+
121+-- COMMON SYMBOLS
96122
97123equals :: IParser String
98124equals = string "="
@@ -104,58 +130,86 @@ hasType :: IParser String
104130hasType = string ":" <?> "':' (a type annotation)'"
105131
106132
107−commitIf check p = commit <|> try p
108− where commit = do (try $ lookAhead check) >> p
133+commitIf check p =
134+ commit <|> try p
135+ where
136+ commit =
137+ try (lookAhead check) >> p
138+
139+
140+-- SEPARATORS
109141
110142spaceySepBy1 :: IParser b -> IParser a -> IParser [a]
111−spaceySepBy1 sep p = do
112− a <- p
113− (a:) <$> many (commitIf (whitespace >> sep) (padded sep >> p))
143+spaceySepBy1 sep p =
144+ do a <- p
145+ (a:) <$> many (commitIf (whitespace >> sep) (padded sep >> p))
114146
115147
116148commaSep1 :: IParser a -> IParser [a]
117−commaSep1 = spaceySepBy1 (char ',' <?> "comma ','")
149+commaSep1 =
150+ spaceySepBy1 (char ',' <?> "comma ','")
151+
118152
119153commaSep :: IParser a -> IParser [a]
120−commaSep = option [] . commaSep1
154+commaSep =
155+ option [] . commaSep1
156+
121157
122158semiSep1 :: IParser a -> IParser [a]
123−semiSep1 = spaceySepBy1 (char ';' <?> "semicolon ';'")
159+semiSep1 =
160+ spaceySepBy1 (char ';' <?> "semicolon ';'")
161+
124162
125163pipeSep1 :: IParser a -> IParser [a]
126−pipeSep1 = spaceySepBy1 (char '|' <?> "type divider '|'")
164+pipeSep1 =
165+ spaceySepBy1 (char '|' <?> "type divider '|'")
166+
127167
128168consSep1 :: IParser a -> IParser [a]
129−consSep1 = spaceySepBy1 (string "::" <?> "cons operator '::'")
169+consSep1 =
170+ spaceySepBy1 (string "::" <?> "cons operator '::'")
171+
130172
131173dotSep1 :: IParser a -> IParser [a]
132−dotSep1 p = (:) <$> p <*> many (try (char '.') >> p)
174+dotSep1 p =
175+ (:) <$> p <*> many (try (char '.') >> p)
176+
133177
134178spaceSep1 :: IParser a -> IParser [a]
135−spaceSep1 p = (:) <$> p <*> spacePrefix p
179+spaceSep1 p =
180+ (:) <$> p <*> spacePrefix p
181+
182+
183+spacePrefix p =
184+ constrainedSpacePrefix p (\_ -> return ())
136185
137−spacePrefix p = constrainedSpacePrefix p (\_ -> return ())
138186
139187constrainedSpacePrefix p constraint =
140− many $ choice [ try (spacing >> lookAhead (oneOf "[({")) >> p
141− , try (spacing >> p)
142− ]
188+ many $ choice
189+ [ try (spacing >> lookAhead (oneOf "[({")) >> p
190+ , try (spacing >> p)
191+ ]
143192 where
144193 spacing = do
145194 n <- whitespace
146195 constraint n
147196 indented
148197
149−failure msg = do
150− inp <- getInput
151− setInput ('x':inp)
152− anyToken
153− fail msg
154198
155−followedBy a b = do x <- a ; b ; return x
199+-- SURROUNDED BY
200+
201+followedBy a b =
202+ do x <- a
203+ b
204+ return x
205+
206+
207+betwixt a b c =
208+ do char a
209+ out <- c
210+ char b <?> "closing '" ++ [b] ++ "'"
211+ return out
156212
157−betwixt a b c = do char a ; out <- c
158− char b <?> "closing '" ++ [b] ++ "'" ; return out
159213
160214surround a z name p = do
161215 char a
@@ -163,170 +217,252 @@ surround a z name p = do
163217 char z <?> unwords ["closing", name, show z]
164218 return v
165219
166−braces :: IParser a -> IParser a
167−braces = surround '[' ']' "brace"
168220
169−parens :: IParser a -> IParser a
170−parens = surround '(' ')' "paren"
221+braces :: IParser a -> IParser a
222+braces =
223+ surround '[' ']' "brace"
224+
225+
226+parens :: IParser a -> IParser a
227+parens =
228+ surround '(' ')' "paren"
229+
171230
172231brackets :: IParser a -> IParser a
173−brackets = surround '{' '}' "bracket"
232+brackets =
233+ surround '{' '}' "bracket"
234+
235+
236+-- HELPERS FOR EXPRESSIONS
174237
175238addLocation :: (P.Pretty a) => IParser a -> IParser (Annotation.Located a)
176−addLocation expr = do
177− (start, e, end) <- located expr
178− return (Annotation.at start end e)
239+addLocation expr =
240+ do (start, e, end) <- located expr
241+ return (Annotation.at start end e)
242+
179243
180244located :: IParser a -> IParser (SourcePos, a, SourcePos)
181−located p = do
182− start <- getPosition
183− e <- p
184− end <- getPosition
185− return (start, e, end)
245+located p =
246+ do start <- getPosition
247+ e <- p
248+ end <- getPosition
249+ return (start, e, end)
250+
186251
187252accessible :: IParser Source.Expr -> IParser Source.Expr
188−accessible expr = do
189− start <- getPosition
190− ce@(Annotation.A _ e) <- expr
191− let rest f = do
192− let dot = char '.' >> notFollowedBy (char '.')
193− access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
194− case access of
195− Nothing -> return ce
196− Just _ -> accessible $ do
197− v <- var <?> "field access (e.g. List.map)"
198− end <- getPosition
199− return (Annotation.at start end (f v))
200− case e of
201− E.Var (Variable.Raw (c:cs))
202− | isUpper c -> rest (\v -> E.rawVar (c:cs ++ '.':v))
203− | otherwise -> rest (E.Access ce)
204− _ -> rest (E.Access ce)
253+accessible expr =
254+ do start <- getPosition
255+ ce@(Annotation.A _ e) <- expr
256+ let rest f = do
257+ let dot = char '.' >> notFollowedBy (char '.')
258+ access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
259+ case access of
260+ Nothing -> return ce
261+ Just _ -> accessible $ do
262+ v <- var <?> "field access (e.g. List.map)"
263+ end <- getPosition
264+ return (Annotation.at start end (f v))
265+ case e of
266+ E.Var (Variable.Raw (c:cs))
267+ | isUpper c -> rest (\v -> E.rawVar (c:cs ++ '.':v))
268+ | otherwise -> rest (E.Access ce)
269+ _ -> rest (E.Access ce)
270+
271+
272+-- WHITESPACE
273+
274+padded :: IParser a -> IParser a
275+padded p =
276+ do whitespace
277+ out <- p
278+ whitespace
279+ return out
205280
206281
207282spaces :: IParser String
208−spaces = concat <$> many1 (multiComment <|> string " ") <?> "spaces"
283+spaces =
284+ concat <$> many1 (string " " <|> multiComment) <?> "spaces"
285+
209286
210287forcedWS :: IParser String
211−forcedWS = choice [ try $ (++) <$> spaces <*> (concat <$> many nl_space)
212− , try $ concat <$> many1 nl_space ]
213− where nl_space = try ((++) <$> (concat <$> many1 newline) <*> spaces)
288+forcedWS =
289+ choice
290+ [ try $ (++) <$> spaces <*> (concat <$> many nl_space)
291+ , try $ concat <$> many1 nl_space
292+ ]
293+ where
294+ nl_space =
295+ try ((++) <$> (concat <$> many1 newline) <*> spaces)
296+
214297
215298-- Just eats whitespace until the next meaningful character.
216299dumbWhitespace :: IParser String
217−dumbWhitespace = concat <$> many (spaces <|> newline)
300+dumbWhitespace =
301+ concat <$> many (spaces <|> newline)
302+
218303
219304whitespace :: IParser String
220−whitespace = option "" forcedWS <?> "whitespace"
305+whitespace =
306+ option "" forcedWS
307+
221308
222309freshLine :: IParser [[String]]
223−freshLine = try (many1 newline >> many space_nl) <|> try (many1 space_nl) <?> ""
224− where space_nl = try $ spaces >> many1 newline
310+freshLine =
311+ try (many1 newline >> many space_nl) <|> try (many1 space_nl) <?> ""
312+ where
313+ space_nl = try $ spaces >> many1 newline
314+
225315
226316newline :: IParser String
227−newline = simpleNewline <|> lineComment <?> "newline"
317+newline =
318+ simpleNewline <|> lineComment <?> "newline"
319+
228320
229321simpleNewline :: IParser String
230−simpleNewline = try (string "\r\n") <|> string "\n"
322+simpleNewline =
323+ try (string "\r\n") <|> string "\n"
324+
231325
232326lineComment :: IParser String
233−lineComment = do
234− try (string "--")
235− comment <- anyUntil $ simpleNewline <|> (eof >> return "\n")
236− return ("--" ++ comment)
327+lineComment =
328+ do try (string "--")
329+ comment <- anyUntil $ simpleNewline <|> (eof >> return "\n")
330+ return ("--" ++ comment)
331+
237332
238333multiComment :: IParser String
239−multiComment = (++) <$> try (string "{-") <*> closeComment
334+multiComment =
335+ (++) <$> try (string "{-") <*> closeComment
336+
240337
241338closeComment :: IParser String
242339closeComment =
243− anyUntil . choice $
244− [ try (string "-}") <?> "close comment"
245− , concat <$> sequence [ try (string "{-"), closeComment, closeComment ]
246− ]
340+ anyUntil $
341+ choice $
342+ [ try (string "-}") <?> "close comment"
343+ , concat <$> sequence [ try (string "{-"), closeComment, closeComment ]
344+ ]
345+
346+
347+-- ODD COMBINATORS
348+
349+failure msg = do
350+ inp <- getInput
351+ setInput ('x':inp)
352+ anyToken
353+ fail msg
354+
247355
248356until :: IParser a -> IParser b -> IParser b
249−until p end = go
250− where
251− go = end <|> (p >> go)
357+until p end =
358+ go
359+ where
360+ go = end <|> (p >> go)
361+
252362
253363anyUntil :: IParser String -> IParser String
254−anyUntil end = go
255− where
256− go = end <|> (:) <$> anyChar <*> go
364+anyUntil end =
365+ go
366+ where
367+ go =
368+ end <|> (:) <$> anyChar <*> go
369+
257370
258371ignoreUntil :: IParser a -> IParser (Maybe a)
259−ignoreUntil end = go
260− where
261− ignore p = const () <$> p
262− filler = choice [ try (ignore chr) <|> ignore str
263− , ignore multiComment
264− , ignore markdown
265− , ignore anyChar
266− ]
267− go = choice [ Just <$> end
268− , filler `until` choice [ const Nothing <$> eof, newline >> go ]
269− ]
372+ignoreUntil end =
373+ go
374+ where
375+ ignore p =
376+ const () <$> p
377+
378+ filler =
379+ choice
380+ [ try (ignore chr) <|> ignore str
381+ , ignore multiComment
382+ , ignore markdown
383+ , ignore anyChar
384+ ]
385+
386+ go =
387+ choice
388+ [ Just <$> end
389+ , filler `until` choice [ const Nothing <$> eof, newline >> go ]
390+ ]
391+
270392
271393onFreshLines :: (a -> b -> b) -> b -> IParser a -> IParser b
272−onFreshLines insert init thing = go init
273− where
274− go values = do
275− optionValue <- ignoreUntil thing
276− case optionValue of
277− Nothing -> return values
278− Just v -> go (insert v values)
394+onFreshLines insert init thing =
395+ go init
396+ where
397+ go values =
398+ do optionValue <- ignoreUntil thing
399+ case optionValue of
400+ Nothing -> return values
401+ Just v -> go (insert v values)
402+
279403
280404withSource :: IParser a -> IParser (String, a)
281−withSource p = do
282− start <- getParserState
283− result <- p
284− endPos <- getPosition
285− setParserState start
286− raw <- anyUntilPos endPos
287− return (raw, result)
405+withSource p =
406+ do start <- getParserState
407+ result <- p
408+ endPos <- getPosition
409+ setParserState start
410+ raw <- anyUntilPos endPos
411+ return (raw, result)
412+
288413
289414anyUntilPos :: SourcePos -> IParser String
290−anyUntilPos pos = go
291− where
292− go = do currentPos <- getPosition
293− case currentPos == pos of
294− True -> return []
295− False -> (:) <$> anyChar <*> go
415+anyUntilPos pos =
416+ go
417+ where
418+ go = do currentPos <- getPosition
419+ case currentPos == pos of
420+ True -> return []
421+ False -> (:) <$> anyChar <*> go
422+
423+
424+-- BASIC LANGUAGE LITERALS
296425
297426markdown :: IParser String
298427markdown =
299− do try (string "[markdown|")
300− closeMarkdown id
301− where
302− closeMarkdown markdownBuilder =
303− choice [ do try (string "|]")
304− return (markdownBuilder "")
305− , do c <- anyChar
306− closeMarkdown (markdownBuilder . (c:))
307− ]
428+ do try (string "[markdown|")
429+ closeMarkdown id
430+ where
431+ closeMarkdown markdownBuilder =
432+ choice
433+ [ do try (string "|]")
434+ return (markdownBuilder "")
435+ , do c <- anyChar
436+ closeMarkdown (markdownBuilder . (c:))
437+ ]
438+
308439
309440shader :: IParser (String, L.GLShaderTipe)
310441shader =
311− do try (string "[glsl|")
312− rawSrc <- closeShader id
313− case glSource rawSrc of
314− Left err -> parserFail . show $ err
315− Right tipe -> return (rawSrc, tipe)
442+ do try (string "[glsl|")
443+ rawSrc <- closeShader id
444+ case glSource rawSrc of
445+ Left err -> parserFail . show $ err
446+ Right tipe -> return (rawSrc, tipe)
316447 where
317− closeShader builder = choice
318− [ do try (string "|]")
319− return (builder "")
320− , do c <- anyChar
321− closeShader (builder . (c:))
448+ closeShader builder =
449+ choice
450+ [ do try (string "|]")
451+ return (builder "")
452+ , do c <- anyChar
453+ closeShader (builder . (c:))
322454 ]
323455
456+
324457glSource :: String -> Either ParseError L.GLShaderTipe
325458glSource src =
326459 case GLP.parse src of
327− Right (GLS.TranslationUnit decls) ->
328− Right . foldr addGLinput emptyDecls . join . map extractGLinputs $ decls
329460 Left e -> Left e
461+ Right (GLS.TranslationUnit decls) ->
462+ map extractGLinputs decls
463+ |> join
464+ |> foldr addGLinput emptyDecls
465+ |> Right
330466 where
331467 emptyDecls = L.GLShaderTipe Map.empty Map.empty Map.empty
332468
@@ -367,6 +503,7 @@ glSource src =
367503 _ -> []
368504 _ -> []
369505
506+
370507str :: IParser String
371508str = expecting "String" $ do
372509 s <- choice [ multiStr, singleStr ]
@@ -394,46 +531,60 @@ str = expecting "String" $ do
394531 choice [ char '\n' >> return "\\n"
395532 , char '\r' >> return "\\r" ]
396533
534+
397535sandwich :: Char -> String -> String
398−sandwich delim s = delim : s ++ [delim]
536+sandwich delim s =
537+ delim : s ++ [delim]
538+
399539
400540escaped :: Char -> IParser String
401−escaped delim = try $ do
402− char '\\'
403− c <- char '\\' <|> char delim
404− return ['\\', c]
541+escaped delim =
542+ try $ do
543+ char '\\'
544+ c <- char '\\' <|> char delim
545+ return ['\\', c]
546+
405547
406548chr :: IParser Char
407−chr = betwixt '\'' '\'' character <?> "character"
408− where
409− nonQuote = satisfy (/='\'')
410− character = do
411− c <- choice [ escaped '\''
412− , (:) <$> char '\\' <*> many1 nonQuote
413− , (:[]) <$> nonQuote ]
414− processAs T.charLiteral $ sandwich '\'' c
549+chr =
550+ betwixt '\'' '\'' character <?> "character"
551+ where
552+ nonQuote = satisfy (/='\'')
553+
554+ character =
555+ do c <- choice
556+ [ escaped '\''
557+ , (:) <$> char '\\' <*> many1 nonQuote
558+ , (:[]) <$> nonQuote
559+ ]
560+
561+ processAs T.charLiteral $ sandwich '\'' c
562+
415563
416564processAs :: (T.GenTokenParser String u SourceM -> IParser a) -> String -> IParser a
417−processAs processor s = calloutParser s (processor lexer)
418− where
419− calloutParser :: String -> IParser a -> IParser a
420− calloutParser inp p = either (fail . show) return (iParse p inp)
421−
422− lexer :: T.GenTokenParser String u SourceM
423− lexer = T.makeTokenParser elmDef
424−
425− -- I don't know how many of these are necessary for charLiteral/stringLiteral
426− elmDef :: T.GenLanguageDef String u SourceM
427− elmDef = T.LanguageDef
428− { T.commentStart = "{-"
429− , T.commentEnd = "-}"
430− , T.commentLine = "--"
431− , T.nestedComments = True
432− , T.identStart = undefined
433− , T.identLetter = undefined
434− , T.opStart = undefined
435− , T.opLetter = undefined
436− , T.reservedNames = reserveds
437− , T.reservedOpNames = [":", "->", "<-", "|"]
438− , T.caseSensitive = True
439− }
565+processAs processor s =
566+ calloutParser s (processor lexer)
567+ where
568+ calloutParser :: String -> IParser a -> IParser a
569+ calloutParser inp p =
570+ either (fail . show) return (iParse p inp)
571+
572+ lexer :: T.GenTokenParser String u SourceM
573+ lexer = T.makeTokenParser elmDef
574+
575+ -- I don't know how many of these are necessary for charLiteral/stringLiteral
576+ elmDef :: T.GenLanguageDef String u SourceM
577+ elmDef =
578+ T.LanguageDef
579+ { T.commentStart = "{-"
580+ , T.commentEnd = "-}"
581+ , T.commentLine = "--"
582+ , T.nestedComments = True
583+ , T.identStart = undefined
584+ , T.identLetter = undefined
585+ , T.opStart = undefined
586+ , T.opLetter = undefined
587+ , T.reservedNames = reserveds
588+ , T.reservedOpNames = [":", "->", "<-", "|"]
589+ , T.caseSensitive = True
590+ }