git.iko.soy/elk
on 267f708 help sign in
elk/src/Parse/Helpers.hs
682 lines 15 kB history raw
1module Parse.Helpers where
3import Prelude hiding (until)
4import Control.Monad (join)
5import Control.Monad.State (State)
6import Data.Char (isUpper)
7import qualified Data.Map as Map
8import qualified Language.GLSL.Parser as GLP
9import qualified Language.GLSL.Syntax as GLS
10import Text.Parsec hiding (newline, spaces, State)
11import Text.Parsec.Indent (indented, runIndent)
12import qualified Text.Parsec.Token as T
14import qualified AST.Declaration as Decl
15import qualified AST.Expression.General as E
16import qualified AST.Expression.Source as Source
17import qualified AST.Literal as L
18import qualified AST.Variable as Variable
19import qualified Reporting.Annotation as A
20import qualified Reporting.Error.Syntax as Syntax
21import qualified Reporting.Region as R
25reserveds :: [String]
26reserveds =
27 [ "if", "then", "else"
28 , "case", "of"
29 , "let", "in"
30 , "type"
31 , "module", "where"
32 , "import", "exposing"
33 , "as"
34 , "port"
35 ]
39-- ERROR HELP
42expecting = flip (<?>)
46-- SETUP
49type OpTable = Map.Map String (Int, Decl.Assoc)
50type SourceM = State SourcePos
51type IParser a = ParsecT String OpTable SourceM a
54iParse :: IParser a -> String -> Either ParseError a
55iParse parser source =
56 iParseWithTable "" Map.empty parser source
59iParseWithTable :: SourceName -> OpTable -> IParser a -> String -> Either ParseError a
60iParseWithTable sourceName table aParser input =
61 runIndent sourceName $ runParserT aParser table sourceName input
64-- VARIABLES
66var :: IParser String
67var =
68 makeVar (letter <|> char '_') <?> "a name"
71lowVar :: IParser String
72lowVar =
73 makeVar lower <?> "a lower case name"
76capVar :: IParser String
77capVar =
78 makeVar upper <?> "an upper case name"
81qualifiedVar :: IParser String
82qualifiedVar =
83 do vars <- many ((++) <$> capVar <*> string ".")
84 (++) (concat vars) <$> lowVar
87rLabel :: IParser String
88rLabel = lowVar
91innerVarChar :: IParser Char
92innerVarChar =
93 alphaNum <|> char '_' <|> char '\'' <?> "more letters in this name"
96makeVar :: IParser Char -> IParser String
97makeVar firstChar =
98 do variable <- (:) <$> firstChar <*> many innerVarChar
99 if variable `elem` reserveds
100 then fail (Syntax.keyword variable)
101 else return variable
104reserved :: String -> IParser String
105reserved word =
106 expecting ("reserved word `" ++ word ++ "`") $
107 do string word
108 notFollowedBy innerVarChar
109 return word
113-- COMMON SYMBOLS
116equals :: IParser String
117equals =
118 string "=" <?> "an equals sign '='"
121rightArrow :: IParser String
122rightArrow =
123 string "->" <?> "an arrow '->'"
126hasType :: IParser String
127hasType =
128 string ":" <?> "the \"has type\" symbol ':'"
131commitIf check p =
132 commit <|> try p
133 where
134 commit =
135 try (lookAhead check) >> p
139-- SEPARATORS
142spaceySepBy1 :: IParser b -> IParser a -> IParser [a]
143spaceySepBy1 sep parser =
144 do value <- parser
145 (value:) <$> spaceyPrefixBy sep parser
148spaceyPrefixBy :: IParser sep -> IParser a -> IParser [a]
149spaceyPrefixBy sep parser =
150 many (commitIf (whitespace >> sep) (padded sep >> parser))
153comma :: IParser Char
154comma =
155 char ',' <?> "a comma ','"
158commaSep1 :: IParser a -> IParser [a]
159commaSep1 =
160 spaceySepBy1 comma
163commaSep :: IParser a -> IParser [a]
164commaSep =
165 option [] . commaSep1
168semiSep1 :: IParser a -> IParser [a]
169semiSep1 =
170 spaceySepBy1 (char ';' <?> "a semicolon ';'")
173pipeSep1 :: IParser a -> IParser [a]
174pipeSep1 =
175 spaceySepBy1 (char '|' <?> "a vertical bar '|'")
178consSep1 :: IParser a -> IParser [a]
179consSep1 =
180 spaceySepBy1 (string "::" <?> "a cons operator '::'")
183dotSep1 :: IParser a -> IParser [a]
184dotSep1 p =
185 (:) <$> p <*> many (try (char '.') >> p)
188spaceSep1 :: IParser a -> IParser [a]
189spaceSep1 p =
190 (:) <$> p <*> spacePrefix p
193spacePrefix p =
194 constrainedSpacePrefix p (\_ -> return ())
197constrainedSpacePrefix parser constraint =
198 many $ choice
199 [ try (spacing >> lookAhead (oneOf "[({")) >> parser
200 , try (spacing >> parser)
201 ]
202 where
203 spacing = do
204 n <- whitespace
205 constraint n <?> Syntax.whitespace
206 indented
210-- SURROUNDED BY
213followedBy a b =
214 do x <- a
215 b
216 return x
219betwixt :: Char -> Char -> IParser a -> IParser a
220betwixt a b c =
221 do char a
222 out <- c
223 char b <?> "a closing '" ++ [b] ++ "'"
224 return out
227surround :: Char -> Char -> String -> IParser a -> IParser a
228surround a z name p = do
229 char a
230 v <- padded p
231 char z <?> unwords ["a closing", name, show z]
232 return v
235braces :: IParser a -> IParser a
236braces =
237 surround '[' ']' "brace"
240parens :: IParser a -> IParser a
241parens =
242 surround '(' ')' "paren"
245brackets :: IParser a -> IParser a
246brackets =
247 surround '{' '}' "bracket"
251-- HELPERS FOR EXPRESSIONS
254getMyPosition :: IParser R.Position
255getMyPosition =
256 R.fromSourcePos <$> getPosition
259addLocation :: IParser a -> IParser (A.Located a)
260addLocation expr =
261 do (start, e, end) <- located expr
262 return (A.at start end e)
265located :: IParser a -> IParser (R.Position, a, R.Position)
266located parser =
267 do start <- getMyPosition
268 value <- parser
269 end <- getMyPosition
270 return (start, value, end)
273accessible :: IParser Source.Expr -> IParser Source.Expr
274accessible exprParser =
275 do start <- getMyPosition
277 annotatedRootExpr@(A.A _ rootExpr) <- exprParser
279 access <- optionMaybe (try dot <?> "a field access like .name")
281 case access of
282 Nothing ->
283 return annotatedRootExpr
285 Just _ ->
286 accessible $
287 do v <- var
288 end <- getMyPosition
289 return . A.at start end $
290 case rootExpr of
291 E.Var (Variable.Raw name@(c:_))
292 | isUpper c ->
293 E.rawVar (name ++ '.' : v)
294 _ ->
295 E.Access annotatedRootExpr v
298dot :: IParser ()
299dot =
300 do char '.'
301 notFollowedBy (char '.')
305-- WHITESPACE
308padded :: IParser a -> IParser a
309padded p =
310 do whitespace
311 out <- p
312 whitespace
313 return out
316spaces :: IParser String
317spaces =
318 let space = string " " <|> multiComment <?> Syntax.whitespace
319 in
320 concat <$> many1 space
323forcedWS :: IParser String
324forcedWS =
325 do failIfTabFound
326 ws <- many1 (spaces <|> newline)
327 failIfTabFound
328 column <- sourceColumn <$> getPosition
329 if column == 1
330 then fail badWhiteSpaceMessage
331 else return (concat ws)
334badWhiteSpaceMessage :: String
335badWhiteSpaceMessage =
336 "I need whitespace, but got stuck on what looks like a new declaration.\n"
337 ++ "\n"
338 ++ "You are either missing some stuff in the declaration above or just need to add\n"
339 ++ "some spaces here:"
342failIfTabFound :: IParser ()
343failIfTabFound =
344 do foundTab <- option False (lookAhead (char '\t') >> return True) <?> Syntax.tab
345 if foundTab
346 then fail Syntax.tab
347 else return ()
350-- Just eats whitespace until the next meaningful character.
351dumbWhitespace :: IParser String
352dumbWhitespace =
353 concat <$> many (spaces <|> newline)
356whitespace :: IParser String
357whitespace =
358 option "" forcedWS
361freshLine :: IParser String
362freshLine =
363 try (
364 do ws <- many1 (spaces <|> newline)
365 column <- sourceColumn <$> getPosition
366 if column == 1
367 then return (concat ws)
368 else fail badFreshLineMessage
369 ) <?> Syntax.freshLine
372badFreshLineMessage :: String
373badFreshLineMessage =
374 "I need a fresh line to start a new declaration. This means a new line that\n"
375 ++ "starts with stuff, not with spaces or comments."
378newline :: IParser String
379newline =
380 simpleNewline <|> lineComment <?> Syntax.newline
383simpleNewline :: IParser String
384simpleNewline =
385 try (string "\r\n") <|> string "\n"
388lineComment :: IParser String
389lineComment =
390 do try (string "--")
391 comment <- anyUntil $ simpleNewline <|> (eof >> return "\n")
392 return ("--" ++ comment)
395docComment :: IParser String
396docComment =
397 do try (string "{-|")
398 contents <- closeComment
399 return (init (init contents))
402multiComment :: IParser String
403multiComment =
404 (++) <$> try (string "{-" <* notFollowedBy (string "|")) <*> closeComment
407closeComment :: IParser String
408closeComment =
409 anyUntil $
410 choice $
411 [ try (string "-}") <?> "the end of a comment -}"
412 , concat <$> sequence [ try (string "{-"), closeComment, closeComment ]
413 ]
417-- ODD COMBINATORS
420failure msg = do
421 inp <- getInput
422 setInput ('x':inp)
423 anyToken
424 fail msg
427until :: IParser a -> IParser b -> IParser b
428until p end =
429 go
430 where
431 go = end <|> (p >> go)
434anyUntil :: IParser String -> IParser String
435anyUntil end =
436 go
437 where
438 go =
439 end <|> (:) <$> anyChar <*> go
442ignoreUntil :: IParser a -> IParser (Maybe a)
443ignoreUntil end =
444 go
445 where
446 ignore p =
447 const () <$> p
449 filler =
450 choice
451 [ try (ignore chr) <|> ignore str
452 , ignore multiComment
453 , ignore docComment
454 , ignore anyChar
455 ]
457 go =
458 choice
459 [ Just <$> end
460 , filler `until` choice [ const Nothing <$> eof, newline >> go ]
461 ]
464onFreshLines :: (a -> b -> b) -> b -> IParser a -> IParser b
465onFreshLines insert init thing =
466 go init
467 where
468 go values =
469 do optionValue <- ignoreUntil thing
470 case optionValue of
471 Nothing -> return values
472 Just v -> go (insert v values)
475withSource :: IParser a -> IParser (String, a)
476withSource p =
477 do start <- getParserState
478 result <- p
479 endPos <- getPosition
480 setParserState start
481 raw <- anyUntilPos endPos
482 return (raw, result)
485anyUntilPos :: SourcePos -> IParser String
486anyUntilPos pos =
487 do currentPos <- getPosition
488 if currentPos == pos
489 then return []
490 else (:) <$> anyChar <*> anyUntilPos pos
494-- SHADERS
497shader :: IParser (String, L.GLShaderTipe)
498shader =
499 do try (string "[glsl|")
500 rawSrc <- closeShader id
501 case glSource rawSrc of
502 Left err -> parserFail . show $ err
503 Right tipe -> return (rawSrc, tipe)
506closeShader :: (String -> a) -> IParser a
507closeShader builder =
508 choice
509 [ do try (string "|]")
510 return (builder "")
511 , do c <- anyChar
512 closeShader (builder . (c:))
513 ]
516glSource :: String -> Either ParseError L.GLShaderTipe
517glSource src =
518 case GLP.parse src of
519 Left e -> Left e
520 Right (GLS.TranslationUnit decls) ->
521 map extractGLinputs decls
522 |> join
523 |> foldr addGLinput emptyDecls
524 |> Right
525 where
526 (|>) = flip ($)
528 emptyDecls = L.GLShaderTipe Map.empty Map.empty Map.empty
530 addGLinput (qual,tipe,name) glDecls =
531 case qual of
532 GLS.Attribute ->
533 glDecls { L.attribute = Map.insert name tipe $ L.attribute glDecls }
535 GLS.Uniform ->
536 glDecls { L.uniform = Map.insert name tipe $ L.uniform glDecls }
538 GLS.Varying ->
539 glDecls { L.varying = Map.insert name tipe $ L.varying glDecls }
541 _ -> error "Should never happen due to below filter"
543 extractGLinputs decl =
544 case decl of
545 GLS.Declaration
546 (GLS.InitDeclaration
547 (GLS.TypeDeclarator
548 (GLS.FullType
549 (Just (GLS.TypeQualSto qual))
550 (GLS.TypeSpec _prec (GLS.TypeSpecNoPrecision tipe _mexpr1))))
551 [GLS.InitDecl name _mexpr2 _mexpr3]
552 ) ->
553 case elem qual [GLS.Attribute, GLS.Varying, GLS.Uniform] of
554 False -> []
555 True ->
556 case tipe of
557 GLS.Int -> return (qual, L.Int,name)
558 GLS.Float -> return (qual, L.Float,name)
559 GLS.Vec2 -> return (qual, L.V2,name)
560 GLS.Vec3 -> return (qual, L.V3,name)
561 GLS.Vec4 -> return (qual, L.V4,name)
562 GLS.Mat4 -> return (qual, L.M4,name)
563 GLS.Sampler2D -> return (qual, L.Texture,name)
564 _ -> []
565 _ -> []
569-- STRINGS AND CHARACTERS
572str :: IParser String
573str =
574 expecting "a string like \"hello\"" $
575 do charSeq <- choice [ multiStr, singleStr ]
576 either (fail . show) return $
577 processAs T.stringLiteral ('"' : charSeq ++ "\"")
580delimitedSequence :: IParser a -> IParser String -> IParser String
581delimitedSequence quote insides =
582 do quote
583 concat <$> manyTill insides quote
586multiStr :: IParser String
587multiStr =
588 delimitedSequence (try (string "\"\"\"")) multilineStringChar
591singleStr :: IParser String
592singleStr =
593 delimitedSequence (char '"') (charWithin '"')
596chr :: IParser Char
597chr =
598 expecting "a character like 'x'" $
599 do char '\''
600 charSeq <- concat <$> many1 (charWithin '\'') <?> "a character"
601 case processAs T.charLiteral ("'" ++ charSeq ++ "'") of
602 Right character ->
603 do char '\''
604 return character
606 Left _ ->
607 failure $
608 "Elm uses double quotes for strings. Switch\
609 \ the ' to \" on both ends of the string and\
610 \ you should be all set!"
614-- CHARACTER HELPERS
617charWithin :: Char -> IParser String
618charWithin delim =
619 choice
620 [ escaped delim
621 , (:[]) <$> satisfy (/= delim)
622 ]
625multilineStringChar :: IParser String
626multilineStringChar =
627 do notFollowedBy (string "\"\"\"")
628 choice
629 [ newlineChar
630 , escaped '\"'
631 , escapeQuotes <$> anyChar
632 ]
635escapeQuotes :: Char -> String
636escapeQuotes c =
637 if c == '\"' then "\\\"" else [c]
640newlineChar :: IParser String
641newlineChar =
642 choice
643 [ char '\n' >> return "\\n"
644 , char '\r' >> return "\\r"
645 ]
648escaped :: Char -> IParser String
649escaped delim =
650 try $ do
651 char '\\'
652 c <- char '\\' <|> char delim
653 return ['\\', c]
656processAs
657 :: (T.GenTokenParser String u SourceM -> IParser a)
658 -> String
659 -> Either ParseError a
660processAs processor string =
661 iParse (processor lexer) string
662 where
663 lexer :: T.GenTokenParser String u SourceM
664 lexer =
665 T.makeTokenParser elmDef
667 -- I don't know how many of these are necessary for charLiteral/stringLiteral
668 elmDef :: T.GenLanguageDef String u SourceM
669 elmDef =
670 T.LanguageDef
671 { T.commentStart = "{-"
672 , T.commentEnd = "-}"
673 , T.commentLine = "--"
674 , T.nestedComments = True
675 , T.identStart = undefined
676 , T.identLetter = undefined
677 , T.opStart = undefined
678 , T.opLetter = undefined
679 , T.reservedNames = reserveds
680 , T.reservedOpNames = [":", "->", "|"]
681 , T.caseSensitive = True
682 }