@@ -1,20 +1,30 @@
1−module Parse.Helpers where
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2+module Parse.Helpers
3+ ( expecting, failure, anyUntil
4+ , OpTable
5+ , IParser, SourceM, iParse
6+ , var, lowVar, capVar, rLabel, reserved, reserveds
7+ , equals, rightArrow, hasType
8+ , commitIf
9+ , followedBy, comma, commaSep1, commaSep
10+ , pipeSep1, consSep1, dotSep1, spaceSep1, spacePrefix, constrainedSpacePrefix
11+ , braces, parens, brackets
12+ , accessible
13+ , getMyPosition, addLocation, located
14+ , whitespace, freshLine, simpleNewline, newline, spaces
15+ , forcedWS, padded, dumbWhitespace, docComment
16+ )
17+ where
218
3−import Prelude hiding (until)
4−import Control.Monad (join)
519import Control.Monad.State (State)
620import Data.Char (isUpper)
721import qualified Data.Map as Map
8−import qualified Language.GLSL.Parser as GLP
9−import qualified Language.GLSL.Syntax as GLS
10−import Text.Parsec hiding (newline, spaces, State)
22+import Text.Parsec hiding (State, newline, space, spaces)
1123import Text.Parsec.Indent (indented, runIndent)
12−import qualified Text.Parsec.Token as T
1324
1425import qualified AST.Declaration as Decl
1526import qualified AST.Expression.General as E
1627import qualified AST.Expression.Source as Source
17−import qualified AST.Literal as L
1828import qualified AST.Variable as Variable
1929import qualified Reporting.Annotation as A
2030import qualified Reporting.Error.Syntax as Syntax
@@ -22,33 +32,39 @@ import qualified Reporting.Region as R
2232
2333
2434
25−reserveds :: [String]
26−reserveds =
27− [ "if", "then", "else"
28− , "case", "of"
29− , "let", "in"
30− , "type"
31− , "module", "where"
32− , "import", "exposing"
33− , "as"
34− , "port"
35− ]
35+-- ERROR HELP
3636
3737
38+expecting :: String -> IParser a -> IParser a
39+expecting =
40+ flip (<?>)
3841
39−-- ERROR HELP
42+
43+failure :: String -> IParser a
44+failure msg = do
45+ inp <- getInput
46+ setInput ('x':inp)
47+ anyToken
48+ fail msg
4049
4150
42−expecting = flip (<?>)
51+anyUntil :: IParser String -> IParser String
52+anyUntil end =
53+ go
54+ where
55+ go =
56+ end <|> (:) <$> anyChar <*> go
4357
4458
4559
4660-- SETUP
4761
4862
63+type IParser a = ParsecT String OpTable SourceM a
64+
4965type OpTable = Map.Map String (Int, Decl.Assoc)
66+
5067type SourceM = State SourcePos
51−type IParser a = ParsecT String OpTable SourceM a
5268
5369
5470iParse :: IParser a -> String -> Either ParseError a
@@ -61,8 +77,10 @@ iParseWithTable sourceName table aParser input =
6177 runIndent sourceName $ runParserT aParser table sourceName input
6278
6379
80+
6481-- VARIABLES
6582
83+
6684var :: IParser String
6785var =
6886 makeVar (letter <|> char '_') <?> "a name"
@@ -78,14 +96,9 @@ capVar =
7896 makeVar upper <?> "an upper case name"
7997
8098
81−qualifiedVar :: IParser String
82−qualifiedVar =
83− do vars <- many ((++) <$> capVar <*> string ".")
84− (++) (concat vars) <$> lowVar
85−
86−
8799rLabel :: IParser String
88−rLabel = lowVar
100+rLabel =
101+ lowVar
89102
90103
91104innerVarChar :: IParser Char
@@ -118,6 +131,19 @@ reserved word =
118131 ]
119132
120133
134+reserveds :: [String]
135+reserveds =
136+ [ "if", "then", "else"
137+ , "case", "of"
138+ , "let", "in"
139+ , "type"
140+ , "module", "where"
141+ , "import", "exposing"
142+ , "as"
143+ , "port"
144+ ]
145+
146+
121147
122148-- COMMON SYMBOLS
123149
@@ -137,6 +163,11 @@ hasType =
137163 string ":" <?> "the \"has type\" symbol ':'"
138164
139165
166+
167+-- SEPARATORS
168+
169+
170+commitIf :: IParser a -> IParser b -> IParser b
140171commitIf check p =
141172 commit <|> try p
142173 where
@@ -144,10 +175,6 @@ commitIf check p =
144175 try (lookAhead check) >> p
145176
146177
147−
148−-- SEPARATORS
149−
150−
151178spaceySepBy1 :: IParser b -> IParser a -> IParser [a]
152179spaceySepBy1 sep parser =
153180 do value <- parser
@@ -174,11 +201,6 @@ commaSep =
174201 option [] . commaSep1
175202
176203
177−semiSep1 :: IParser a -> IParser [a]
178−semiSep1 =
179− spaceySepBy1 (char ';' <?> "a semicolon ';'")
180−
181−
182204pipeSep1 :: IParser a -> IParser [a]
183205pipeSep1 =
184206 spaceySepBy1 (char '|' <?> "a vertical bar '|'")
@@ -199,10 +221,12 @@ spaceSep1 p =
199221 (:) <$> p <*> spacePrefix p
200222
201223
224+spacePrefix :: IParser a -> IParser [a]
202225spacePrefix p =
203226 constrainedSpacePrefix p (\_ -> return ())
204227
205228
229+constrainedSpacePrefix :: IParser a -> (String -> IParser ()) -> IParser [a]
206230constrainedSpacePrefix parser constraint =
207231 many $ choice
208232 [ try (spacing >> lookAhead (oneOf "[({")) >> parser
@@ -219,20 +243,13 @@ constrainedSpacePrefix parser constraint =
219243-- SURROUNDED BY
220244
221245
246+followedBy :: IParser a -> IParser b -> IParser a
222247followedBy a b =
223248 do x <- a
224249 b
225250 return x
226251
227252
228−betwixt :: Char -> Char -> IParser a -> IParser a
229−betwixt a b c =
230− do char a
231− out <- c
232− char b <?> "a closing '" ++ [b] ++ "'"
233− return out
234−
235−
236253surround :: Char -> Char -> String -> IParser a -> IParser a
237254surround a z name p = do
238255 char a
@@ -420,272 +437,3 @@ closeComment =
420437 [ try (string "-}") <?> "the end of a comment -}"
421438 , concat <$> sequence [ try (string "{-"), closeComment, closeComment ]
422439 ]
423−
424−
425−
426−-- ODD COMBINATORS
427−
428−
429−failure msg = do
430− inp <- getInput
431− setInput ('x':inp)
432− anyToken
433− fail msg
434−
435−
436−until :: IParser a -> IParser b -> IParser b
437−until p end =
438− go
439− where
440− go = end <|> (p >> go)
441−
442−
443−anyUntil :: IParser String -> IParser String
444−anyUntil end =
445− go
446− where
447− go =
448− end <|> (:) <$> anyChar <*> go
449−
450−
451−ignoreUntil :: IParser a -> IParser (Maybe a)
452−ignoreUntil end =
453− go
454− where
455− ignore p =
456− const () <$> p
457−
458− filler =
459− choice
460− [ try (ignore chr) <|> ignore str
461− , ignore multiComment
462− , ignore docComment
463− , ignore anyChar
464− ]
465−
466− go =
467− choice
468− [ Just <$> end
469− , filler `until` choice [ const Nothing <$> eof, newline >> go ]
470− ]
471−
472−
473−onFreshLines :: (a -> b -> b) -> b -> IParser a -> IParser b
474−onFreshLines insert init thing =
475− go init
476− where
477− go values =
478− do optionValue <- ignoreUntil thing
479− case optionValue of
480− Nothing -> return values
481− Just v -> go (insert v values)
482−
483−
484−withSource :: IParser a -> IParser (String, a)
485−withSource p =
486− do start <- getParserState
487− result <- p
488− endPos <- getPosition
489− setParserState start
490− raw <- anyUntilPos endPos
491− return (raw, result)
492−
493−
494−anyUntilPos :: SourcePos -> IParser String
495−anyUntilPos pos =
496− do currentPos <- getPosition
497− if currentPos == pos
498− then return []
499− else (:) <$> anyChar <*> anyUntilPos pos
500−
501−
502−
503−-- SHADERS
504−
505−
506−shader :: IParser (String, L.GLShaderTipe)
507−shader =
508− do try (string "[glsl|")
509− rawSrc <- closeShader id
510− case glSource rawSrc of
511− Left err -> parserFail . show $ err
512− Right tipe -> return (rawSrc, tipe)
513−
514−
515−closeShader :: (String -> a) -> IParser a
516−closeShader builder =
517− choice
518− [ do try (string "|]")
519− return (builder "")
520− , do c <- anyChar
521− closeShader (builder . (c:))
522− ]
523−
524−
525−glSource :: String -> Either ParseError L.GLShaderTipe
526−glSource src =
527− case GLP.parse src of
528− Left e -> Left e
529− Right (GLS.TranslationUnit decls) ->
530− map extractGLinputs decls
531− |> join
532− |> foldr addGLinput emptyDecls
533− |> Right
534− where
535− (|>) = flip ($)
536−
537− emptyDecls = L.GLShaderTipe Map.empty Map.empty Map.empty
538−
539− addGLinput (qual,tipe,name) glDecls =
540− case qual of
541− GLS.Attribute ->
542− glDecls { L.attribute = Map.insert name tipe $ L.attribute glDecls }
543−
544− GLS.Uniform ->
545− glDecls { L.uniform = Map.insert name tipe $ L.uniform glDecls }
546−
547− GLS.Varying ->
548− glDecls { L.varying = Map.insert name tipe $ L.varying glDecls }
549−
550− _ -> error "Should never happen due to below filter"
551−
552− extractGLinputs decl =
553− case decl of
554− GLS.Declaration
555− (GLS.InitDeclaration
556− (GLS.TypeDeclarator
557− (GLS.FullType
558− (Just (GLS.TypeQualSto qual))
559− (GLS.TypeSpec _prec (GLS.TypeSpecNoPrecision tipe _mexpr1))))
560− [GLS.InitDecl name _mexpr2 _mexpr3]
561− ) ->
562− case elem qual [GLS.Attribute, GLS.Varying, GLS.Uniform] of
563− False -> []
564− True ->
565− case tipe of
566− GLS.Int -> return (qual, L.Int,name)
567− GLS.Float -> return (qual, L.Float,name)
568− GLS.Vec2 -> return (qual, L.V2,name)
569− GLS.Vec3 -> return (qual, L.V3,name)
570− GLS.Vec4 -> return (qual, L.V4,name)
571− GLS.Mat4 -> return (qual, L.M4,name)
572− GLS.Sampler2D -> return (qual, L.Texture,name)
573− _ -> []
574− _ -> []
575−
576−
577−
578−-- STRINGS AND CHARACTERS
579−
580−
581−str :: IParser String
582−str =
583− expecting "a string like \"hello\"" $
584− do charSeq <- choice [ multiStr, singleStr ]
585− either (fail . show) return $
586− processAs T.stringLiteral ('"' : charSeq ++ "\"")
587−
588−
589−delimitedSequence :: IParser a -> IParser String -> IParser String
590−delimitedSequence quote insides =
591− do quote
592− concat <$> manyTill insides quote
593−
594−
595−multiStr :: IParser String
596−multiStr =
597− delimitedSequence (try (string "\"\"\"")) multilineStringChar
598−
599−
600−singleStr :: IParser String
601−singleStr =
602− delimitedSequence (char '"') (charWithin '"')
603−
604−
605−chr :: IParser Char
606−chr =
607− expecting "a character like 'x'" $
608− do char '\''
609− charSeq <- concat <$> many1 (charWithin '\'') <?> "a character"
610− case processAs T.charLiteral ("'" ++ charSeq ++ "'") of
611− Right character ->
612− do char '\''
613− return character
614−
615− Left _ ->
616− failure $
617− "Elm uses double quotes for strings. Switch\
618− \ the ' to \" on both ends of the string and\
619− \ you should be all set!"
620−
621−
622−
623−-- CHARACTER HELPERS
624−
625−
626−charWithin :: Char -> IParser String
627−charWithin delim =
628− choice
629− [ escaped delim
630− , (:[]) <$> satisfy (/= delim)
631− ]
632−
633−
634−multilineStringChar :: IParser String
635−multilineStringChar =
636− do notFollowedBy (string "\"\"\"")
637− choice
638− [ newlineChar
639− , escaped '\"'
640− , escapeQuotes <$> anyChar
641− ]
642−
643−
644−escapeQuotes :: Char -> String
645−escapeQuotes c =
646− if c == '\"' then "\\\"" else [c]
647−
648−
649−newlineChar :: IParser String
650−newlineChar =
651− choice
652− [ char '\n' >> return "\\n"
653− , char '\r' >> return "\\r"
654− ]
655−
656−
657−escaped :: Char -> IParser String
658−escaped delim =
659− try $ do
660− char '\\'
661− c <- char '\\' <|> char delim
662− return ['\\', c]
663−
664−
665−processAs
666− :: (T.GenTokenParser String u SourceM -> IParser a)
667− -> String
668− -> Either ParseError a
669−processAs processor string =
670− iParse (processor lexer) string
671− where
672− lexer :: T.GenTokenParser String u SourceM
673− lexer =
674− T.makeTokenParser elmDef
675−
676− -- I don't know how many of these are necessary for charLiteral/stringLiteral
677− elmDef :: T.GenLanguageDef String u SourceM
678− elmDef =
679− T.LanguageDef
680− { T.commentStart = "{-"
681− , T.commentEnd = "-}"
682− , T.commentLine = "--"
683− , T.nestedComments = True
684− , T.identStart = undefined
685− , T.identLetter = undefined
686− , T.opStart = undefined
687− , T.opLetter = undefined
688− , T.reservedNames = reserveds
689− , T.reservedOpNames = [":", "->", "|"]
690− , T.caseSensitive = True
691− }