git.iko.soy/elk
on master help sign in
Update all the parser code for the new Parser.Primitives
f4b2de3Evan Czaplicki
compiler/src/Parse/Declaration.hs+110−90
compare with master
unifiedsplit
@@ -1,117 +1,139 @@
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Parse.Declaration
3module Parse.Declaration
4+ ( Decl(..)
4− ( declaration
5+ , declaration
5 , infix_
6 , infix_
6 )
7 )
7 where
8 where
8
9
9
10
10import qualified Data.Name as Name
11import qualified Data.Name as Name
11−import qualified Data.Text.Encoding as Text
12
12
13import qualified AST.Source as Src
13import qualified AST.Source as Src
14import qualified AST.Utils.Binop as Binop
14import qualified AST.Utils.Binop as Binop
15import qualified Parse.Expression as Expr
15import qualified Parse.Expression as Expr
16import qualified Parse.Pattern as Pattern
16import qualified Parse.Pattern as Pattern
17−import Parse.Primitives
18−import qualified Parse.Primitives.Keyword as Keyword
17+import qualified Parse.Keyword as Keyword
19−import qualified Parse.Primitives.Number as Number
18+import qualified Parse.Number as Number
20−import qualified Parse.Primitives.Symbol as Symbol
19+import qualified Parse.Symbol as Symbol
21−import qualified Parse.Primitives.Variable as Var
22−import qualified Parse.Primitives.Whitespace as W
23import qualified Parse.Type as Type
20import qualified Parse.Type as Type
21+import qualified Parse.Variable as Var
22+import Parse.Utils
23+import Parse.Primitives hiding (Parser, State)
24+import qualified Parse.Primitives as P
24import qualified Reporting.Annotation as A
25import qualified Reporting.Annotation as A
25import qualified Reporting.Error.Syntax as E
26import qualified Reporting.Error.Syntax as E
26−import qualified Reporting.Region as R
27
27
28
28
29
29
30-- DECLARATION
30-- DECLARATION
31
31
32
32
33+data Decl
34+ = Value (A.Located Src.Value)
35+ | Union (A.Located Src.Union)
36+ | Alias (A.Located Src.Alias)
37+ | Port Src.Port
38+
39+
33−declaration :: SParser Src.Decl
40+declaration :: SParser Decl
34declaration =
41declaration =
35− hint E.Decl $
36 do start <- getPosition
42 do start <- getPosition
37− oneOf
43+ oneOf E.XXX
38− [ doc_ start
39− , type_ start
44+ [ typeDecl start
40− , port_ start
45+ , portDecl
41− , def_ start
46+ , valueDecl start
42 ]
47 ]
43
48
44
49
45
50
46−-- DOC COMMENTS
47−
48−
49−{-# INLINE doc_ #-}
50−doc_ :: R.Position -> SParser Src.Decl
51−doc_ start =
52− do doc <- W.docComment
53− end <- getPosition
54− pos <- W.whitespace
55− return ( A.at start end (Src.Docs (Text.decodeUtf8 doc)), end, pos )
56−
57−
58−
59-- DEFINITION and ANNOTATION
51-- DEFINITION and ANNOTATION
60
52
61
53
62−{-# INLINE def_ #-}
54+{-# INLINE valueDecl #-}
63−def_ :: R.Position -> SParser Src.Decl
55+valueDecl :: A.Position -> SParser Decl
64−def_ start =
56+valueDecl start =
65 do name <- Var.lower
57 do name <- Var.lower
66− nameEnd <- getPosition
58+ end <- getPosition
67− let locatedName = A.at start nameEnd name
68 spaces
59 spaces
69− oneOf
60+ oneOf E.XXX
70− [ do Symbol.hasType
61+ [
62+ do word1 0x3A {-:-} E.XXX
71− inContext start (E.Annotation name) $
63+ pushContext start (E.Annotation name)
72− do spaces
64+ spaces
73− (tipe, end, space) <- Type.expression
65+ (tipe, _, space) <- Type.expression
74− return ( A.at start end (Src.Annotation locatedName tipe), end, space )
66+ popContext ()
75− , inContext start (E.Definition name) $
67+ checkAligned space
76− definitionHelp start locatedName []
68+ defName <- matchingName name
69+ let (A.At (A.Region defStart _) _) = defName
70+ pushContext defStart (E.Definition name)
71+ spaces
72+ decl <- valueHelp start defName (Just tipe) []
73+ popContext decl
74+ ,
75+ do pushContext start (E.Definition name)
76+ decl <- valueHelp start (A.at start end name) Nothing []
77+ popContext decl
77 ]
78 ]
78
79
79
80
80−definitionHelp :: R.Position -> A.Located Name.Name -> [Src.Pattern] -> SParser Src.Decl
81+valueHelp :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> SParser Decl
81−definitionHelp start name revArgs =
82+valueHelp start name tipe revArgs =
82− oneOf
83+ oneOf E.XXX
83− [ do arg <- hint E.Arg Pattern.term
84+ [ do arg <- Pattern.term
84 spaces
85 spaces
85− definitionHelp start name (arg : revArgs)
86+ valueHelp start name tipe (arg : revArgs)
86− , do Symbol.equals
87+ , do word1 0x3D {-=-} E.XXX
87 spaces
88 spaces
88 (body, end, space) <- Expr.expression
89 (body, end, space) <- Expr.expression
89− let def = A.at start end (Src.Definition name (reverse revArgs) body)
90+ let value = A.at start end (Src.Value name (reverse revArgs) body tipe)
90− return ( def, end, space )
91+ return ( Value value, end, space )
91 ]
92 ]
92
93
93
94
95+matchingName :: Name.Name -> Parser (A.Located Name.Name)
96+matchingName expectedName =
97+ let (P.Parser parserL) = Var.lower in
98+ P.Parser $ \state@(P.State _ _ _ sr sc ctx) cok eok cerr eerr ->
99+ let
100+ cokL name newState@(P.State _ _ _ er ec _) =
101+ if expectedName == name
102+ then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
103+ else cerr sr sc ctx (E.MatchingName expectedName)
104+
105+ eokL name newState@(P.State _ _ _ er ec _) =
106+ if expectedName == name
107+ then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
108+ else eerr sr sc ctx (E.MatchingName expectedName)
109+ in
110+ parserL state cokL eokL cerr eerr
111+
112+
94
113
95-- TYPE ALIAS and UNION TYPES
114-- TYPE ALIAS and UNION TYPES
96
115
97
116
98−{-# INLINE type_ #-}
117+{-# INLINE typeDecl #-}
99−type_ :: R.Position -> SParser Src.Decl
118+typeDecl :: A.Position -> SParser Decl
100−type_ start =
119+typeDecl start =
101 do Keyword.type_
120 do Keyword.type_
102 spaces
121 spaces
103− oneOf
122+ oneOf E.XXX
123+ [
104− [ do Keyword.alias_
124+ inContext E.TypeAlias Keyword.alias_ $
105− inContext start E.TypeAlias $
106− do spaces
125+ do spaces
107− (name, args) <- nameArgsEquals
126+ (name, args) <- nameArgsEquals
108− (tipe, end, pos) <- Type.expression
127+ (tipe, end, pos) <- Type.expression
109− return ( A.at start end (Src.Alias name args tipe), end, pos )
128+ let alias = A.at start end (Src.Alias name args tipe)
129+ return (Alias alias, end, pos)
130+ ,
110− , inContext start E.TypeUnion $
131+ do pushContext start E.TypeUnion
111− do (name, args) <- nameArgsEquals
132+ (name, args) <- nameArgsEquals
112− (firstCtor, firstEnd, firstSpace) <- Type.unionConstructor
133+ (firstCtor, firstEnd, firstSpace) <- Type.unionConstructor
113− (ctors, end, pos) <- chompConstructors [firstCtor] firstEnd firstSpace
134+ (ctors, end, pos) <- chompConstructors [firstCtor] firstEnd firstSpace
114− return ( A.at start end (Src.Union name args ctors), end, pos )
135+ let union = A.at start end (Src.Union name args ctors)
136+ popContext (Union union, end, pos)
115 ]
137 ]
116
138
117
139
@@ -124,21 +146,21 @@ nameArgsEquals =
124
146
125nameArgsEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser (A.Located Name.Name, [A.Located Name.Name])
147nameArgsEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser (A.Located Name.Name, [A.Located Name.Name])
126nameArgsEqualsHelp name args =
148nameArgsEqualsHelp name args =
127− oneOf
149+ oneOf E.XXX
128 [ do arg <- addLocation Var.lower
150 [ do arg <- addLocation Var.lower
129 spaces
151 spaces
130 nameArgsEqualsHelp name (arg:args)
152 nameArgsEqualsHelp name (arg:args)
131− , do Symbol.equals
153+ , do word1 0x3D {-=-} E.XXX
132 spaces
154 spaces
133 return ( name, reverse args )
155 return ( name, reverse args )
134 ]
156 ]
135
157
136
158
137−chompConstructors :: [(A.Located Name.Name, [Src.Type])] -> R.Position -> SPos -> SParser [(A.Located Name.Name, [Src.Type])]
159+chompConstructors :: [(A.Located Name.Name, [Src.Type])] -> A.Position -> SPos -> SParser [(A.Located Name.Name, [Src.Type])]
138chompConstructors ctors end pos =
160chompConstructors ctors end pos =
139− oneOf
161+ oneOf E.XXX
140 [ do checkSpace pos
162 [ do checkSpace pos
141− Symbol.pipe
163+ word1 0x7C {-|-} E.XXX
142 spaces
164 spaces
143 (ctor, newEnd, newSpace) <- Type.unionConstructor
165 (ctor, newEnd, newSpace) <- Type.unionConstructor
144 chompConstructors (ctor:ctors) newEnd newSpace
166 chompConstructors (ctor:ctors) newEnd newSpace
@@ -150,18 +172,17 @@ chompConstructors ctors end pos =
150-- PORT
172-- PORT
151
173
152
174
153−{-# INLINE port_ #-}
175+{-# INLINE portDecl #-}
154−port_ :: R.Position -> SParser Src.Decl
176+portDecl :: SParser Decl
155−port_ start =
177+portDecl =
156− do Keyword.port_
157− inContext start E.Port $
178+ inContext E.Port Keyword.port_ $
158− do spaces
179+ do spaces
159− name <- addLocation Var.lower
180+ name <- addLocation Var.lower
160− spaces
181+ spaces
161− Symbol.hasType
182+ word1 0x3A {-:-} E.XXX
162− spaces
183+ spaces
163− (tipe, end, pos) <- Type.expression
184+ (tipe, end, pos) <- Type.expression
164− return ( A.at start end (Src.Port name tipe), end, pos )
185+ return ( Port (Src.Port name tipe), end, pos )
165
186
166
187
167
188
@@ -170,14 +191,13 @@ port_ start =
170
191
171-- INVARIANT: always chomps to a freshline
192-- INVARIANT: always chomps to a freshline
172--
193--
173−infix_ :: Parser Src.Decl
194+infix_ :: Parser (A.Located Src.Binop)
174infix_ =
195infix_ =
175 do start <- getPosition
196 do start <- getPosition
176− Keyword.infix_
177− inContext start E.Infix $
197+ inContext E.Infix Keyword.infix_ $
178 do spaces
198 do spaces
179 associativity <-
199 associativity <-
180− oneOf
200+ oneOf E.XXX
181 [ Keyword.left_ >> return Binop.Left
201 [ Keyword.left_ >> return Binop.Left
182 , Keyword.right_ >> return Binop.Right
202 , Keyword.right_ >> return Binop.Right
183 , Keyword.non_ >> return Binop.Non
203 , Keyword.non_ >> return Binop.Non
@@ -185,13 +205,13 @@ infix_ =
185 spaces
205 spaces
186 precedence <- Number.precedence
206 precedence <- Number.precedence
187 spaces
207 spaces
188− Symbol.leftParen
208+ word1 0x28 {-(-} E.XXX
189 op <- Symbol.binop
209 op <- Symbol.binop
190− Symbol.rightParen
210+ word1 0x29 {-)-} E.XXX
191 spaces
211 spaces
192− Symbol.equals
212+ word1 0x3D {-=-} E.XXX
193 spaces
213 spaces
194 name <- Var.lower
214 name <- Var.lower
195 end <- getPosition
215 end <- getPosition
196− checkFreshLine =<< W.whitespace
216+ checkFreshLine =<< whitespace
197 return (A.at start end (Src.Binop op associativity precedence name))
217 return (A.at start end (Src.Binop op associativity precedence name))
compiler/src/Parse/Docs.hsnew file+275
@@ -0,0 +1,275 @@
1+module Parse.Docs
2+ ( Docs(..)
3+ , parser
4+ )
5+ where
6+
7+
8+
9+-- DOCS
10+
11+
12+data Docs =
13+ Docs
14+ { _exposed :: [A.Located Name.Name]
15+ , _overview :: Utf8.String
16+ , _listed :: [A.Located Name.Name]
17+ , _comments :: Map.Map Name.Name Utf8.String
18+ }
19+
20+
21+
22+-- PARSER
23+
24+
25+parser :: Parser Docs
26+parser =
27+ error "TODO implement docs parser"
28+
29+
30+chompUntilDocs :: Parser Bool
31+chompUntilDocs =
32+ P.Parser $ \(P.State fp offset terminal indent row col ctx) cok _ _ _ ->
33+ let
34+ (# isStart, newOffset, newRow, newCol #) =
35+ eatDocs fp offset terminal row col
36+
37+ !newState =
38+ P.State fp newOffset terminal indent newRow newCol ctx
39+ in
40+ cok isStart newState
41+
42+
43+eatDocs :: ForeignPtr Word8 -> Int -> Int -> Word16 -> Word16 -> (# Bool, Int, Word16, Word16 #)
44+eatDocs fp offset terminal row col =
45+ if offset >= terminal then
46+ (# False, offset, row, col #)
47+
48+ else if isDocsStart fp offset terminal then
49+ (# True, offset + 5, row, col + 5 #)
50+
51+ else
52+ let !word = P.unsafeIndex fp offset in
53+ if word == 0x0A {- \n -} then
54+ eatDocs fp (offset + 1) terminal (row + 1) 1
55+
56+ else
57+ let !newOffset = offset + P.getCharWidth fp offset terminal word in
58+ eatDocs fp newOffset terminal row (col + 1)
59+
60+
61+isDocsStart :: ForeignPtr Word8 -> Int -> Int -> Bool
62+isDocsStart =
63+ let (B.PS dfp doff dlen) = docsStart in
64+ P.isSubstring dfp doff dlen
65+
66+
67+{-# NOINLINE docsStart #-}
68+docsStart :: B.ByteString
69+docsStart =
70+ "@docs"
71+
72+
73+chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
74+chompOverview names =
75+ do isDocs <- chompUntilDocs
76+ if isDocs
77+ then chompOverviewHelp names
78+ else return names
79+
80+
81+chompOverviewHelp :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
82+chompOverviewHelp names =
83+ do pos <- getPosition
84+ (SPos spos) <- whitespace
85+ if pos == spos
86+ then chompOverview names
87+ else chompOverview =<< chompDocs names
88+
89+
90+chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
91+chompDocs names =
92+ do name <- addLocation (oneOf SE.XXX [ Var.lower, Var.upper, chompBinop ])
93+ spos <- whitespace
94+ oneOf SE.XXX
95+ [ do checkSpace spos
96+ word1 0x2C {-,-} SE.XXX
97+ spaces
98+ chompDocs (name:names)
99+ , return (name:names)
100+ ]
101+
102+
103+chompBinop :: Parser Name.Name
104+chompBinop =
105+ do word1 0x28 {-(-} SE.XXX
106+ name <- Symbol.binop
107+ word1 0x29 {-)-} SE.XXX
108+ return name
109+
110+
111+
112+
113+-- CHECK NAMES
114+
115+
116+type Result i w a =
117+ Result.Result i w E.Error a
118+
119+
120+type Dups =
121+ Map.Map Name.Name (OneOrMore.OneOrMore A.Region)
122+
123+
124+checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()
125+checkNames exports names =
126+ do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)
127+ let overlap = Map.size (Map.intersection docs exports)
128+ if Map.size exports == overlap && overlap == Map.size docs
129+ then Result.ok ()
130+ else
131+ do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)
132+ _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)
133+ Result.ok ()
134+
135+
136+addName :: Dups -> A.Located Name.Name -> Dups
137+addName dict (A.At region name) =
138+ Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
139+
140+
141+isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result i w A.Region
142+isUnique name regions =
143+ case regions of
144+ OneOrMore.One region ->
145+ Result.ok region
146+
147+ OneOrMore.More _ _ ->
148+ let (r1:r2:_) = OneOrMore.toList regions in
149+ Result.throw (E.Duplicate name r1 r2)
150+
151+
152+onlyInDocs :: Name.Name -> A.Region -> Result i w a
153+onlyInDocs name region =
154+ Result.throw $ E.OnlyInDocs name region
155+
156+
157+onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a
158+onlyInExports name (A.At region _) =
159+ Result.throw $ E.OnlyInExports name region
160+
161+
162+
163+-- CHECK EXPORTS
164+
165+
166+data Info =
167+ Info
168+ { _iComments :: Map.Map Name.Name Comment
169+ , _iValues :: Types
170+ , _iUnions :: Map.Map Name.Name Can.Union
171+ , _iAliases :: Map.Map Name.Name Can.Alias
172+ , _iBinops :: Map.Map Name.Name Can.Binop
173+ , _iEffects :: Can.Effects
174+ }
175+
176+
177+checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)
178+checkExport info name (A.At region export) =
179+ case export of
180+ Can.ExportValue ->
181+ do tipe <- getType name info
182+ comment <- getComment region name info
183+ Result.ok $ \m ->
184+ m { _values = Map.insert name (Value comment tipe) (_values m) }
185+
186+ Can.ExportBinop ->
187+ do let (Can.Binop_ assoc prec realName) = _iBinops info ! name
188+ tipe <- getType realName info
189+ comment <- getComment region realName info
190+ Result.ok $ \m ->
191+ m { _binops = Map.insert name (Binop comment tipe assoc prec) (_binops m) }
192+
193+ Can.ExportAlias ->
194+ do let (Can.Alias tvars tipe) = _iAliases info ! name
195+ comment <- getComment region name info
196+ Result.ok $ \m ->
197+ m { _aliases = Map.insert name (Alias comment tvars (Extract.fromType tipe)) (_aliases m) }
198+
199+ Can.ExportUnionOpen ->
200+ do let (Can.Union tvars ctors _ _) = _iUnions info ! name
201+ comment <- getComment region name info
202+ Result.ok $ \m ->
203+ m { _unions = Map.insert name (Union comment tvars (map dector ctors)) (_unions m) }
204+
205+ Can.ExportUnionClosed ->
206+ do let (Can.Union tvars _ _ _) = _iUnions info ! name
207+ comment <- getComment region name info
208+ Result.ok $ \m ->
209+ m { _unions = Map.insert name (Union comment tvars []) (_unions m) }
210+
211+ Can.ExportPort ->
212+ do tipe <- getType name info
213+ comment <- getComment region name info
214+ Result.ok $ \m ->
215+ m { _values = Map.insert name (Value comment tipe) (_values m) }
216+
217+
218+getComment :: A.Region -> Name.Name -> Info -> Result i w Comment
219+getComment region name info =
220+ case Map.lookup name (_iComments info) of
221+ Nothing ->
222+ Result.throw (E.NoComment name region)
223+
224+ Just comment ->
225+ Result.ok comment
226+
227+
228+getType :: Name.Name -> Info -> Result i w Type.Type
229+getType name info =
230+ case _iValues info ! name of
231+ A.At defRegion Nothing ->
232+ Result.throw (E.NoAnnotation name defRegion)
233+
234+ A.At _ (Just tipe) ->
235+ Result.ok (Extract.fromType tipe)
236+
237+
238+dector :: Can.Ctor -> (Name.Name, [Type.Type])
239+dector (Can.Ctor name _ _ args) =
240+ ( name, map Extract.fromType args )
241+
242+
243+
244+-- GATHER TYPES
245+
246+
247+type Types =
248+ Map.Map Name.Name (A.Located (Maybe Can.Type))
249+
250+
251+gatherTypes :: Can.Decls -> Types -> Types
252+gatherTypes decls types =
253+ case decls of
254+ Can.Declare def subDecls ->
255+ gatherTypes subDecls (addDef types def)
256+
257+ Can.DeclareRec defs subDecls ->
258+ gatherTypes subDecls (List.foldl' addDef types defs)
259+
260+ Can.SaveTheEnvironment ->
261+ types
262+
263+
264+addDef :: Types -> Can.Def -> Types
265+addDef types def =
266+ case def of
267+ Can.Def (A.At region name) _ _ ->
268+ Map.insert name (A.At region Nothing) types
269+
270+ Can.TypedDef (A.At region name) _ typedArgs _ resultType ->
271+ let
272+ tipe =
273+ foldr Can.TLambda resultType (map snd typedArgs)
274+ in
275+ Map.insert name (A.At region (Just tipe)) types
compiler/src/Parse/Expression.hs+183−161
@@ -7,21 +7,22 @@ module Parse.Expression
7
7
8
8
9import qualified Data.Name as Name
9import qualified Data.Name as Name
10+import Data.Word (Word16)
10
11
11import qualified AST.Source as Src
12import qualified AST.Source as Src
12−import Parse.Primitives
13−import qualified Parse.Primitives.Keyword as Keyword
13+import qualified Parse.Keyword as Keyword
14−import qualified Parse.Primitives.Number as Number
14+import qualified Parse.Number as Number
15−import qualified Parse.Primitives.Symbol as Symbol
16−import qualified Parse.Primitives.Utf8 as Utf8
17−import qualified Parse.Primitives.Variable as Var
18−import qualified Parse.Primitives.Whitespace as W
19import qualified Parse.Pattern as Pattern
15import qualified Parse.Pattern as Pattern
20import qualified Parse.Shader as Shader
16import qualified Parse.Shader as Shader
17+import qualified Parse.Symbol as Symbol
21import qualified Parse.Type as Type
18import qualified Parse.Type as Type
19+import qualified Parse.Utf8 as Utf8
20+import qualified Parse.Variable as Var
21+import Parse.Utils
22+import Parse.Primitives hiding (Parser, State)
23+import qualified Parse.Primitives as P
22import qualified Reporting.Annotation as A
24import qualified Reporting.Annotation as A
23import qualified Reporting.Error.Syntax as E
25import qualified Reporting.Error.Syntax as E
24−import qualified Reporting.Region as R
25
26
26
27
27
28
@@ -30,9 +31,8 @@ import qualified Reporting.Region as R
30
31
31term :: Parser Src.Expr
32term :: Parser Src.Expr
32term =
33term =
33− hint E.Expr $
34 do start <- getPosition
34 do start <- getPosition
35− oneOf
35+ oneOf E.XXX
36 [ variable start >>= accessible start
36 [ variable start >>= accessible start
37 , string start
37 , string start
38 , number start
38 , number start
@@ -45,21 +45,21 @@ term =
45 ]
45 ]
46
46
47
47
48−string :: R.Position -> Parser Src.Expr
48+string :: A.Position -> Parser Src.Expr
49string start =
49string start =
50 do str <- Utf8.string
50 do str <- Utf8.string
51 end <- getPosition
51 end <- getPosition
52 return (A.at start end (Src.Str str))
52 return (A.at start end (Src.Str str))
53
53
54
54
55−character :: R.Position -> Parser Src.Expr
55+character :: A.Position -> Parser Src.Expr
56character start =
56character start =
57 do chr <- Utf8.character
57 do chr <- Utf8.character
58 end <- getPosition
58 end <- getPosition
59 return (A.at start end (Src.Chr chr))
59 return (A.at start end (Src.Chr chr))
60
60
61
61
62−number :: R.Position -> Parser Src.Expr
62+number :: A.Position -> Parser Src.Expr
63number start =
63number start =
64 do nmbr <- Number.number
64 do nmbr <- Number.number
65 end <- getPosition
65 end <- getPosition
@@ -72,25 +72,25 @@ number start =
72 Src.Float float
72 Src.Float float
73
73
74
74
75−accessor :: R.Position -> Parser Src.Expr
75+accessor :: A.Position -> Parser Src.Expr
76accessor start =
76accessor start =
77− do Symbol.dot
77+ do word1 0x2E {-.-} E.XXX
78 field <- Var.lower
78 field <- Var.lower
79 end <- getPosition
79 end <- getPosition
80 return (A.at start end (Src.Accessor field))
80 return (A.at start end (Src.Accessor field))
81
81
82
82
83−variable :: R.Position -> Parser Src.Expr
83+variable :: A.Position -> Parser Src.Expr
84variable start =
84variable start =
85 do var <- Var.foreignAlpha
85 do var <- Var.foreignAlpha
86 end <- getPosition
86 end <- getPosition
87 return (A.at start end var)
87 return (A.at start end var)
88
88
89
89
90−accessible :: R.Position -> Src.Expr -> Parser Src.Expr
90+accessible :: A.Position -> Src.Expr -> Parser Src.Expr
91accessible start expr =
91accessible start expr =
92− oneOf
92+ oneOf E.XXX
93− [ do Symbol.dot
93+ [ do word1 0x2E {-.-} E.XXX
94 pos <- getPosition
94 pos <- getPosition
95 field <- Var.lower
95 field <- Var.lower
96 end <- getPosition
96 end <- getPosition
@@ -104,30 +104,29 @@ accessible start expr =
104-- LISTS
104-- LISTS
105
105
106
106
107−list :: R.Position -> Parser Src.Expr
107+list :: A.Position -> Parser Src.Expr
108list start =
108list start =
109− do Symbol.leftSquare
110− inContext start E.ExprList $
109+ inContext E.ExprList (word1 0x5B {-[-} E.XXX) $
111− do spaces
110+ do spaces
112− oneOf
111+ oneOf E.XXX
113− [ do (entry, _, pos) <- expression
112+ [ do (entry, _, pos) <- expression
114− checkSpace pos
113+ checkSpace pos
115− listHelp start [entry]
114+ listHelp start [entry]
116− , do Symbol.rightSquare
115+ , do word1 0x5D {-]-} E.XXX
117− end <- getPosition
116+ end <- getPosition
118− return (A.at start end (Src.List []))
117+ return (A.at start end (Src.List []))
119− ]
118+ ]
120−
119+
121−
120+
122−listHelp :: R.Position -> [Src.Expr] -> Parser Src.Expr
121+listHelp :: A.Position -> [Src.Expr] -> Parser Src.Expr
123listHelp start entries =
122listHelp start entries =
124− oneOf
123+ oneOf E.XXX
125− [ do Symbol.comma
124+ [ do word1 0x2C {-,-} E.XXX
126 spaces
125 spaces
127 (entry, _, pos) <- expression
126 (entry, _, pos) <- expression
128 checkSpace pos
127 checkSpace pos
129 listHelp start (entry:entries)
128 listHelp start (entry:entries)
130− , do Symbol.rightSquare
129+ , do word1 0x5D {-]-} E.XXX
131 end <- getPosition
130 end <- getPosition
132 return (A.at start end (Src.List (reverse entries)))
131 return (A.at start end (Src.List (reverse entries)))
133 ]
132 ]
@@ -137,14 +136,14 @@ listHelp start entries =
137-- TUPLES
136-- TUPLES
138
137
139
138
140−tuple :: R.Position -> Parser Src.Expr
139+tuple :: A.Position -> Parser Src.Expr
141tuple start =
140tuple start =
142− do Symbol.leftParen
141+ inContext E.ExprTuple (word1 0x28 {-(-} E.XXX) $
143− pos <- getPosition
142+ do pos <- getPosition
144− spos <- W.whitespace
143+ spos <- whitespace
145− inContext start E.ExprTuple $ oneOf $
144+ oneOf E.XXX
146 [ do noSpace pos spos
145 [ do noSpace pos spos
147− try (Symbol.minus >> Symbol.rightParen)
146+ word2 0x2D 0x29 {--)-} E.XXX
148 end <- getPosition
147 end <- getPosition
149 return $ A.at start end (Src.Op "-")
148 return $ A.at start end (Src.Op "-")
150
149
@@ -155,27 +154,27 @@ tuple start =
155
154
156 , do noSpace pos spos
155 , do noSpace pos spos
157 op <- Symbol.binop
156 op <- Symbol.binop
158− Symbol.rightParen
157+ word1 0x29 {-)-} E.XXX
159 end <- getPosition
158 end <- getPosition
160 return $ A.at start end (Src.Op op)
159 return $ A.at start end (Src.Op op)
161
160
162 , do noSpace pos spos
161 , do noSpace pos spos
163− Symbol.rightParen
162+ word1 0x29 {-)-} E.XXX
164 end <- getPosition
163 end <- getPosition
165 return (A.at start end Src.Unit)
164 return (A.at start end Src.Unit)
166
165
167 ]
166 ]
168
167
169
168
170−tupleHelp :: R.Position -> Src.Expr -> [Src.Expr] -> Parser Src.Expr
169+tupleHelp :: A.Position -> Src.Expr -> [Src.Expr] -> Parser Src.Expr
171tupleHelp start firstExpr revExprs =
170tupleHelp start firstExpr revExprs =
172− oneOf
171+ oneOf E.XXX
173− [ do Symbol.comma
172+ [ do word1 0x2C {-,-} E.XXX
174 spaces
173 spaces
175 (entry, _, pos) <- expression
174 (entry, _, pos) <- expression
176 checkSpace pos
175 checkSpace pos
177 tupleHelp start firstExpr (entry : revExprs)
176 tupleHelp start firstExpr (entry : revExprs)
178− , do Symbol.rightParen
177+ , do word1 0x29 {-)-} E.XXX
179 end <- getPosition
178 end <- getPosition
180 case reverse revExprs of
179 case reverse revExprs of
181 [] ->
180 [] ->
@@ -190,33 +189,32 @@ tupleHelp start firstExpr revExprs =
190-- RECORDS
189-- RECORDS
191
190
192
191
193−record :: R.Position -> Parser Src.Expr
192+record :: A.Position -> Parser Src.Expr
194record start =
193record start =
195− do Symbol.leftCurly
196− inContext start E.ExprRecord $
194+ inContext E.ExprRecord (word1 0x7B {- { -} E.XXX) $
197− do spaces
195+ do spaces
198− oneOf
196+ oneOf E.XXX
199− [ do Symbol.rightCurly
197+ [ do word1 0x7D {-}-} E.XXX
200− end <- getPosition
198+ end <- getPosition
201− return (A.at start end (Src.Record []))
199+ return (A.at start end (Src.Record []))
202− , do starter <- addLocation Var.lower
200+ , do starter <- addLocation Var.lower
203− spaces
201+ spaces
204− oneOf
202+ oneOf E.XXX
205− [ do Symbol.pipe
203+ [ do word1 0x7C {-|-} E.XXX
206− spaces
204+ spaces
207− firstField <- chompField
205+ firstField <- chompField
208− fields <- chompFields [firstField]
206+ fields <- chompFields [firstField]
209− end <- getPosition
207+ end <- getPosition
210− return (A.at start end (Src.Update starter fields))
208+ return (A.at start end (Src.Update starter fields))
211− , do Symbol.equals
209+ , do word1 0x3D {-=-} E.XXX
212− spaces
210+ spaces
213− (value, _, nextPos) <- expression
211+ (value, _, nextPos) <- expression
214− checkSpace nextPos
212+ checkSpace nextPos
215− fields <- chompFields [(starter, value)]
213+ fields <- chompFields [(starter, value)]
216− end <- getPosition
214+ end <- getPosition
217− return (A.at start end (Src.Record fields))
215+ return (A.at start end (Src.Record fields))
218− ]
216+ ]
219− ]
217+ ]
220
218
221
219
222type Field = ( A.Located Name.Name, Src.Expr )
220type Field = ( A.Located Name.Name, Src.Expr )
@@ -224,12 +222,12 @@ type Field = ( A.Located Name.Name, Src.Expr )
224
222
225chompFields :: [Field] -> Parser [Field]
223chompFields :: [Field] -> Parser [Field]
226chompFields fields =
224chompFields fields =
227− oneOf
225+ oneOf E.XXX
228− [ do Symbol.comma
226+ [ do word1 0x2C {-,-} E.XXX
229 spaces
227 spaces
230 f <- chompField
228 f <- chompField
231 chompFields (f : fields)
229 chompFields (f : fields)
232− , do Symbol.rightCurly
230+ , do word1 0x7D {-}-} E.XXX
233 return (reverse fields)
231 return (reverse fields)
234 ]
232 ]
235
233
@@ -238,7 +236,7 @@ chompField :: Parser Field
238chompField =
236chompField =
239 do key <- addLocation Var.lower
237 do key <- addLocation Var.lower
240 spaces
238 spaces
241− Symbol.equals
239+ word1 0x3D {-=-} E.XXX
242 spaces
240 spaces
243 (value, _, pos) <- expression
241 (value, _, pos) <- expression
244 checkSpace pos
242 checkSpace pos
@@ -255,16 +253,15 @@ type ExprParser =
255
253
256expression :: ExprParser
254expression :: ExprParser
257expression =
255expression =
258− hint E.Expr $
259 do start <- getPosition
256 do start <- getPosition
260− oneOf
257+ oneOf E.XXX
261 [ let_ start
258 [ let_ start
262 , if_ start
259 , if_ start
263 , case_ start
260 , case_ start
264 , function start
261 , function start
265 , do expr <- possiblyNegativeTerm start
262 , do expr <- possiblyNegativeTerm start
266 end <- getPosition
263 end <- getPosition
267− space <- W.whitespace
264+ space <- whitespace
268 exprHelp start (State [] expr [] end space)
265 exprHelp start (State [] expr [] end space)
269 ]
266 ]
270
267
@@ -274,20 +271,19 @@ data State =
274 { _ops :: ![(Src.Expr, A.Located Name.Name)]
271 { _ops :: ![(Src.Expr, A.Located Name.Name)]
275 , _expr :: !Src.Expr
272 , _expr :: !Src.Expr
276 , _args :: ![Src.Expr]
273 , _args :: ![Src.Expr]
277− , _end :: !R.Position
274+ , _end :: !A.Position
278 , _pos :: !SPos
275 , _pos :: !SPos
279 }
276 }
280
277
281
278
282−exprHelp :: R.Position -> State -> ExprParser
279+exprHelp :: A.Position -> State -> ExprParser
283exprHelp start (State ops expr args end pos) =
280exprHelp start (State ops expr args end pos) =
284− oneOf
281+ oneOf E.XXX
285 [ -- argument
282 [ -- argument
286− hint E.Arg $
287 do checkSpace pos
283 do checkSpace pos
288 arg <- term
284 arg <- term
289 newEnd <- getPosition
285 newEnd <- getPosition
290− newPos <- W.whitespace
286+ newPos <- whitespace
291 exprHelp start (State ops expr (arg:args) newEnd newPos)
287 exprHelp start (State ops expr (arg:args) newEnd newPos)
292
288
293 , -- infix operator
289 , -- infix operator
@@ -296,30 +292,29 @@ exprHelp start (State ops expr args end pos) =
296 opName <- Symbol.binop
292 opName <- Symbol.binop
297 opEnd <- getPosition
293 opEnd <- getPosition
298 let op = A.at opStart opEnd opName
294 let op = A.at opStart opEnd opName
299− spos <- W.whitespace
295+ spos <- whitespace
300− hint (E.AfterOpExpr opName) (checkSpace spos)
296+ checkSpace spos
301 newStart <- getPosition
297 newStart <- getPosition
302− hint (E.AfterOpExpr opName) $
303− if "-" == opName && end /= opStart && opEnd == newStart
298+ if "-" == opName && end /= opStart && opEnd == newStart
304 then
299 then
305 -- negative terms
300 -- negative terms
306 do rawTerm <- term
301 do rawTerm <- term
307 newEnd <- getPosition
302 newEnd <- getPosition
308− newPos <- W.whitespace
303+ newPos <- whitespace
309 let arg = A.at opStart newEnd (Src.Negate rawTerm)
304 let arg = A.at opStart newEnd (Src.Negate rawTerm)
310 exprHelp start (State ops expr (arg:args) newEnd newPos)
305 exprHelp start (State ops expr (arg:args) newEnd newPos)
311 else
306 else
312− oneOf
307+ oneOf E.XXX
313 [ -- term
308 [ -- term
314 do newExpr <- possiblyNegativeTerm newStart
309 do newExpr <- possiblyNegativeTerm newStart
315 newEnd <- getPosition
310 newEnd <- getPosition
316− newPos <- W.whitespace
311+ newPos <- whitespace
317 let newOps = (toCall expr args, op) : ops
312 let newOps = (toCall expr args, op) : ops
318 exprHelp start (State newOps newExpr [] newEnd newPos)
313 exprHelp start (State newOps newExpr [] newEnd newPos)
319
314
320 , -- final term
315 , -- final term
321 do (newLast, newEnd, newPos) <-
316 do (newLast, newEnd, newPos) <-
322− oneOf
317+ oneOf E.XXX
323 [ let_ newStart
318 [ let_ newStart
324 , case_ newStart
319 , case_ newStart
325 , if_ newStart
320 , if_ newStart
@@ -341,10 +336,10 @@ exprHelp start (State ops expr args end pos) =
341 ]
336 ]
342
337
343
338
344−possiblyNegativeTerm :: R.Position -> Parser Src.Expr
339+possiblyNegativeTerm :: A.Position -> Parser Src.Expr
345possiblyNegativeTerm start =
340possiblyNegativeTerm start =
346− oneOf
341+ oneOf E.XXX
347− [ do Symbol.minus
342+ [ do word1 0x2D {---} E.XXX
348 expr <- term
343 expr <- term
349 end <- getPosition
344 end <- getPosition
350 return (A.at start end (Src.Negate expr))
345 return (A.at start end (Src.Negate expr))
@@ -366,13 +361,13 @@ toCall func revArgs =
366-- IF EXPRESSION
361-- IF EXPRESSION
367
362
368
363
369−if_ :: R.Position -> ExprParser
364+if_ :: A.Position -> ExprParser
370if_ start =
365if_ start =
371− do Keyword.if_
372− inContext start E.ExprIf $ ifHelp start []
366+ inContext E.ExprIf Keyword.if_ $
367+ ifHelp start []
373
368
374
369
375−ifHelp :: R.Position -> [(Src.Expr, Src.Expr)] -> ExprParser
370+ifHelp :: A.Position -> [(Src.Expr, Src.Expr)] -> ExprParser
376ifHelp start branches =
371ifHelp start branches =
377 do spaces
372 do spaces
378 (condition, _, condPos) <- expression
373 (condition, _, condPos) <- expression
@@ -380,11 +375,11 @@ ifHelp start branches =
380 Keyword.then_
375 Keyword.then_
381 spaces
376 spaces
382 (thenBranch, _, thenPos) <- expression
377 (thenBranch, _, thenPos) <- expression
383− hint E.ElseBranch $ checkSpace thenPos
378+ checkSpace thenPos
384− hint E.ElseBranch $ Keyword.else_
379+ Keyword.else_
385 spaces
380 spaces
386 let newBranches = (condition, thenBranch) : branches
381 let newBranches = (condition, thenBranch) : branches
387− oneOf
382+ oneOf E.XXX
388 [ do Keyword.if_
383 [ do Keyword.if_
389 ifHelp start newBranches
384 ifHelp start newBranches
390 , do (elseBranch, elseEnd, elseSpace) <- expression
385 , do (elseBranch, elseEnd, elseSpace) <- expression
@@ -397,27 +392,26 @@ ifHelp start branches =
397-- LAMBDA EXPRESSION
392-- LAMBDA EXPRESSION
398
393
399
394
400−function :: R.Position -> ExprParser
395+function :: A.Position -> ExprParser
401function start =
396function start =
402− do Symbol.lambda
403− inContext start E.ExprFunc $
397+ inContext E.ExprFunc (word1 0x5C {-\-} E.XXX) $
404− do spaces
398+ do spaces
405− arg <- Pattern.term
399+ arg <- Pattern.term
406− spaces
400+ spaces
407− revArgs <- gatherArgs [arg]
401+ revArgs <- gatherArgs [arg]
408− spaces
402+ spaces
409− (body, end, space) <- expression
403+ (body, end, space) <- expression
410− let func = A.at start end (Src.Lambda (reverse revArgs) body)
404+ let func = A.at start end (Src.Lambda (reverse revArgs) body)
411− return ( func, end, space )
405+ return ( func, end, space )
412
406
413
407
414gatherArgs :: [Src.Pattern] -> Parser [Src.Pattern]
408gatherArgs :: [Src.Pattern] -> Parser [Src.Pattern]
415gatherArgs args =
409gatherArgs args =
416− oneOf
410+ oneOf E.XXX
417 [ do arg <- Pattern.term
411 [ do arg <- Pattern.term
418 spaces
412 spaces
419 gatherArgs (arg:args)
413 gatherArgs (arg:args)
420− , do Symbol.rightArrow
414+ , do word2 0x2D 0x3E {-->-} E.XXX
421 return args
415 return args
422 ]
416 ]
423
417
@@ -426,41 +420,40 @@ gatherArgs args =
426-- CASE EXPRESSIONS
420-- CASE EXPRESSIONS
427
421
428
422
429−case_ :: R.Position -> ExprParser
423+case_ :: A.Position -> ExprParser
430case_ start =
424case_ start =
431− do Keyword.case_
432− inContext start E.ExprCase $
425+ inContext E.ExprCase Keyword.case_ $
433− do spaces
426+ do spaces
434− (switcher, _, switcherPos) <- expression
427+ (switcher, _, switcherPos) <- expression
435− checkSpace switcherPos
428+ checkSpace switcherPos
436− Keyword.of_
429+ Keyword.of_
437− spaces
430+ spaces
438− oldIndent <- getIndent
431+ oldIndent <- getIndent
439− newIndent <- getCol
432+ newIndent <- getCol
440− setIndent newIndent
433+ setIndent newIndent
441− (firstBranch, firstEnd, firstPos) <- branchHelp
434+ (firstBranch, firstEnd, firstPos) <- branchHelp
442− (branches, end, pos) <- caseHelp [firstBranch] firstEnd firstPos
435+ (branches, end, pos) <- caseHelp [firstBranch] firstEnd firstPos
443− setIndent oldIndent
436+ setIndent oldIndent
444− return
437+ return
445− ( A.at start end (Src.Case switcher branches)
438+ ( A.at start end (Src.Case switcher branches)
446− , end
439+ , end
447− , pos
440+ , pos
448− )
441+ )
449
442
450
443
451branchHelp :: SParser (Src.Pattern, Src.Expr)
444branchHelp :: SParser (Src.Pattern, Src.Expr)
452branchHelp =
445branchHelp =
453 do (pattern, patternPos) <- Pattern.expression
446 do (pattern, patternPos) <- Pattern.expression
454 checkSpace patternPos
447 checkSpace patternPos
455− Symbol.rightArrow
448+ word2 0x2D 0x3E {-->-} E.XXX
456 spaces
449 spaces
457 (branchExpr, end, pos) <- expression
450 (branchExpr, end, pos) <- expression
458 return ( (pattern, branchExpr), end, pos )
451 return ( (pattern, branchExpr), end, pos )
459
452
460
453
461−caseHelp :: [(Src.Pattern, Src.Expr)] -> R.Position -> SPos -> SParser [(Src.Pattern, Src.Expr)]
454+caseHelp :: [(Src.Pattern, Src.Expr)] -> A.Position -> SPos -> SParser [(Src.Pattern, Src.Expr)]
462caseHelp branches end pos =
455caseHelp branches end pos =
463− oneOf
456+ oneOf E.XXX
464 [ do checkAligned pos
457 [ do checkAligned pos
465 (branch, newEnd, newPos) <- branchHelp
458 (branch, newEnd, newPos) <- branchHelp
466 caseHelp (branch:branches) newEnd newPos
459 caseHelp (branch:branches) newEnd newPos
@@ -472,7 +465,7 @@ caseHelp branches end pos =
472-- LET EXPRESSION
465-- LET EXPRESSION
473
466
474
467
475−let_ :: R.Position -> ExprParser
468+let_ :: A.Position -> ExprParser
476let_ start =
469let_ start =
477 do oldIndent <- getIndent
470 do oldIndent <- getIndent
478 letIndent <- getCol
471 letIndent <- getCol
@@ -486,9 +479,9 @@ let_ start =
486 letHelp start oldIndent [def] end space
479 letHelp start oldIndent [def] end space
487
480
488
481
489−letHelp :: R.Position -> Int -> [A.Located Src.Def] -> R.Position -> SPos -> ExprParser
482+letHelp :: A.Position -> Word16 -> [A.Located Src.Def] -> A.Position -> SPos -> ExprParser
490letHelp start oldIndent revDefs end pos =
483letHelp start oldIndent revDefs end pos =
491− oneOf
484+ oneOf E.XXX
492 [ do checkAligned pos
485 [ do checkAligned pos
493 (def, newEnd, newPos) <- letDef
486 (def, newEnd, newPos) <- letDef
494 letHelp start oldIndent (def:revDefs) newEnd newPos
487 letHelp start oldIndent (def:revDefs) newEnd newPos
@@ -510,7 +503,7 @@ letHelp start oldIndent revDefs end pos =
510
503
511letDef :: SParser (A.Located Src.Def)
504letDef :: SParser (A.Located Src.Def)
512letDef =
505letDef =
513− oneOf
506+ oneOf E.XXX
514 [ definition
507 [ definition
515 , destructure
508 , destructure
516 ]
509 ]
@@ -524,33 +517,62 @@ definition :: SParser (A.Located Src.Def)
524definition =
517definition =
525 do start <- getPosition
518 do start <- getPosition
526 name <- Var.lower
519 name <- Var.lower
527− nameEnd <- getPosition
520+ end <- getPosition
528 spaces
521 spaces
529− oneOf
522+ oneOf E.XXX
530− [ do Symbol.hasType
523+ [
524+ do word1 0x3A {-:-} E.XXX
531− inContext start (E.Annotation name) $
525+ pushContext start (E.Annotation name)
532− do spaces
526+ spaces
533− (tipe, end, space) <- Type.expression
527+ (tipe, _, space) <- Type.expression
534− return ( A.at start end (Src.Annotate name tipe), end, space )
528+ popContext ()
529+ checkAligned space
530+ defName <- matchingName name
531+ let (A.At (A.Region defStart _) _) = defName
532+ pushContext defStart (E.Definition name)
533+ spaces
534+ def <- definitionHelp start defName (Just tipe) []
535+ popContext def
536+ ,
535− , inContext start (E.Definition name) $
537+ do pushContext start (E.Definition name)
536− definitionHelp start (A.at start nameEnd name) []
538+ def <- definitionHelp start (A.at start end name) Nothing []
539+ popContext def
537 ]
540 ]
538
541
539
542
540−definitionHelp :: R.Position -> A.Located Name.Name -> [Src.Pattern] -> SParser (A.Located Src.Def)
543+definitionHelp :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> SParser (A.Located Src.Def)
541−definitionHelp start name revArgs =
544+definitionHelp start name tipe revArgs =
542− oneOf
545+ oneOf E.XXX
543− [ do arg <- hint E.Arg Pattern.term
546+ [ do arg <- Pattern.term
544 spaces
547 spaces
545− definitionHelp start name (arg : revArgs)
548+ definitionHelp start name tipe (arg : revArgs)
546− , do Symbol.equals
549+ , do word1 0x3D {-=-} E.XXX
547 spaces
550 spaces
548 (body, end, space) <- expression
551 (body, end, space) <- expression
549− let def = A.at start end (Src.Define name (reverse revArgs) body)
552+ let def = A.at start end (Src.Define name (reverse revArgs) body tipe)
550 return ( def, end, space )
553 return ( def, end, space )
551 ]
554 ]
552
555
553
556
557+matchingName :: Name.Name -> Parser (A.Located Name.Name)
558+matchingName expectedName =
559+ let (P.Parser parserL) = Var.lower in
560+ P.Parser $ \state@(P.State _ _ _ sr sc ctx) cok eok cerr eerr ->
561+ let
562+ cokL name newState@(P.State _ _ _ er ec _) =
563+ if expectedName == name
564+ then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
565+ else cerr sr sc ctx (E.MatchingName expectedName)
566+
567+ eokL name newState@(P.State _ _ _ er ec _) =
568+ if expectedName == name
569+ then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
570+ else eerr sr sc ctx (E.MatchingName expectedName)
571+ in
572+ parserL state cokL eokL cerr eerr
573+
574+
575+
554
576
555-- DESTRUCTURE
577-- DESTRUCTURE
556
578
@@ -560,7 +582,7 @@ destructure =
560 do start <- getPosition
582 do start <- getPosition
561 pattern <- Pattern.term
583 pattern <- Pattern.term
562 spaces
584 spaces
563− Symbol.equals
585+ word1 0x3D {-=-} E.XXX
564 spaces
586 spaces
565 (expr, end, space) <- expression
587 (expr, end, space) <- expression
566 return ( A.at start end (Src.Destruct pattern expr), end, space )
588 return ( A.at start end (Src.Destruct pattern expr), end, space )
compiler/src/Parse/Keyword.hsnew file+266
@@ -0,0 +1,266 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns #-}
3+module Parse.Keyword
4+ ( type_, alias_, port_
5+ , if_, then_, else_
6+ , case_, of_
7+ , let_, in_
8+ , infix_, left_, right_, non_
9+ , module_, import_, exposing_, as_
10+ , effect_, where_, command_, subscription_
11+ , k4, k5
12+ )
13+ where
14+
15+
16+import Foreign.Ptr (plusPtr)
17+import Data.Word (Word8)
18+
19+import Parse.Utils (Parser)
20+import qualified Parse.Variable as Var
21+import qualified Parse.Primitives as P
22+import qualified Reporting.Error.Syntax as E
23+
24+
25+
26+-- DECLARATIONS
27+
28+
29+type_ :: Parser ()
30+type_ = k4 0x74 0x79 0x70 0x65 E.KeywordType
31+
32+alias_ :: Parser ()
33+alias_ = k5 0x61 0x6C 0x69 0x61 0x73 E.KeywordAlias
34+
35+port_ :: Parser ()
36+port_ = k4 0x70 0x6F 0x72 0x74 E.KeywordPort
37+
38+
39+
40+-- IF EXPRESSIONS
41+
42+
43+if_ :: Parser ()
44+if_ = k2 0x69 0x66 E.KeywordIf
45+
46+then_ :: Parser ()
47+then_ = k4 0x74 0x68 0x65 0x6E E.KeywordThen
48+
49+else_ :: Parser ()
50+else_ = k4 0x65 0x6C 0x73 0x65 E.KeywordElse
51+
52+
53+
54+-- CASE EXPRESSIONS
55+
56+
57+case_ :: Parser ()
58+case_ = k4 0x63 0x61 0x73 0x65 E.KeywordCase
59+
60+of_ :: Parser ()
61+of_ = k2 0x6F 0x66 E.KeywordOf
62+
63+
64+
65+-- LET EXPRESSIONS
66+
67+
68+let_ :: Parser ()
69+let_ = k3 0x6C 0x65 0x74 E.KeywordLet
70+
71+in_ :: Parser ()
72+in_ = k2 0x69 0x6E E.KeywordIn
73+
74+
75+
76+-- INFIXES
77+
78+
79+infix_ :: Parser ()
80+infix_ = k5 0x69 0x6E 0x66 0x69 0x78 E.KeywordInfix
81+
82+left_ :: Parser ()
83+left_ = k4 0x6C 0x65 0x66 0x74 E.Associativity
84+
85+right_ :: Parser ()
86+right_ = k5 0x72 0x69 0x67 0x68 0x74 E.Associativity
87+
88+non_ :: Parser ()
89+non_ = k3 0x6E 0x6F 0x6E E.Associativity
90+
91+
92+
93+-- IMPORTS
94+
95+
96+module_ :: Parser ()
97+module_ = k6 0x6D 0x6F 0x64 0x75 0x6C 0x65 E.KeywordModule
98+
99+import_ :: Parser ()
100+import_ = k6 0x69 0x6D 0x70 0x6F 0x72 0x74 E.KeywordImport
101+
102+exposing_ :: Parser ()
103+exposing_ = k8 0x65 0x78 0x70 0x6F 0x73 0x69 0x6E 0x67 E.KeywordExposing
104+
105+as_ :: Parser ()
106+as_ = k2 0x61 0x73 E.KeywordAs
107+
108+
109+
110+-- EFFECTS
111+
112+
113+effect_ :: Parser ()
114+effect_ = k6 0x65 0x66 0x66 0x65 0x63 0x74 E.EffectStuff
115+
116+where_ :: Parser ()
117+where_ = k5 0x77 0x68 0x65 0x72 0x65 E.EffectStuff
118+
119+command_ :: Parser ()
120+command_ = k7 0x63 0x6F 0x6D 0x6D 0x61 0x6E 0x64 E.EffectStuff
121+
122+subscription_ :: Parser ()
123+subscription_ =
124+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
125+ let !pos12 = plusPtr pos 12 in
126+ if pos12 <= end
127+ && P.unsafeIndex ( pos ) == 0x73
128+ && P.unsafeIndex (plusPtr pos 1) == 0x75
129+ && P.unsafeIndex (plusPtr pos 2) == 0x62
130+ && P.unsafeIndex (plusPtr pos 3) == 0x73
131+ && P.unsafeIndex (plusPtr pos 4) == 0x63
132+ && P.unsafeIndex (plusPtr pos 5) == 0x72
133+ && P.unsafeIndex (plusPtr pos 6) == 0x69
134+ && P.unsafeIndex (plusPtr pos 7) == 0x70
135+ && P.unsafeIndex (plusPtr pos 8) == 0x74
136+ && P.unsafeIndex (plusPtr pos 9) == 0x69
137+ && P.unsafeIndex (plusPtr pos 10) == 0x6F
138+ && P.unsafeIndex (plusPtr pos 11) == 0x6E
139+ && Var.getInnerWidth pos12 end == 0
140+ then
141+ let !s = P.State pos12 end indent row (col + 12) ctx in cok () s
142+ else
143+ eerr row col ctx E.EffectStuff
144+
145+
146+
147+-- KEYWORDS
148+
149+
150+k2 :: Word8 -> Word8 -> x -> P.Parser c x ()
151+k2 w1 w2 x =
152+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
153+ let !pos2 = plusPtr pos 2 in
154+ if pos2 <= end
155+ && P.unsafeIndex ( pos ) == w1
156+ && P.unsafeIndex (plusPtr pos 1) == w2
157+ && Var.getInnerWidth pos2 end == 0
158+ then
159+ let !s = P.State pos2 end indent row (col + 2) ctx in cok () s
160+ else
161+ eerr row col ctx x
162+
163+
164+k3 :: Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
165+k3 w1 w2 w3 x =
166+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
167+ let !pos3 = plusPtr pos 3 in
168+ if pos3 <= end
169+ && P.unsafeIndex ( pos ) == w1
170+ && P.unsafeIndex (plusPtr pos 1) == w2
171+ && P.unsafeIndex (plusPtr pos 2) == w3
172+ && Var.getInnerWidth pos3 end == 0
173+ then
174+ let !s = P.State pos3 end indent row (col + 3) ctx in cok () s
175+ else
176+ eerr row col ctx x
177+
178+
179+k4 :: Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
180+k4 w1 w2 w3 w4 x =
181+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
182+ let !pos4 = plusPtr pos 4 in
183+ if pos4 <= end
184+ && P.unsafeIndex ( pos ) == w1
185+ && P.unsafeIndex (plusPtr pos 1) == w2
186+ && P.unsafeIndex (plusPtr pos 2) == w3
187+ && P.unsafeIndex (plusPtr pos 3) == w4
188+ && Var.getInnerWidth pos4 end == 0
189+ then
190+ let !s = P.State pos4 end indent row (col + 4) ctx in cok () s
191+ else
192+ eerr row col ctx x
193+
194+
195+k5 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
196+k5 w1 w2 w3 w4 w5 x =
197+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
198+ let !pos5 = plusPtr pos 5 in
199+ if pos5 <= end
200+ && P.unsafeIndex ( pos ) == w1
201+ && P.unsafeIndex (plusPtr pos 1) == w2
202+ && P.unsafeIndex (plusPtr pos 2) == w3
203+ && P.unsafeIndex (plusPtr pos 3) == w4
204+ && P.unsafeIndex (plusPtr pos 4) == w5
205+ && Var.getInnerWidth pos5 end == 0
206+ then
207+ let !s = P.State pos5 end indent row (col + 5) ctx in cok () s
208+ else
209+ eerr row col ctx x
210+
211+
212+k6 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
213+k6 w1 w2 w3 w4 w5 w6 x =
214+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
215+ let !pos6 = plusPtr pos 6 in
216+ if pos6 <= end
217+ && P.unsafeIndex ( pos ) == w1
218+ && P.unsafeIndex (plusPtr pos 1) == w2
219+ && P.unsafeIndex (plusPtr pos 2) == w3
220+ && P.unsafeIndex (plusPtr pos 3) == w4
221+ && P.unsafeIndex (plusPtr pos 4) == w5
222+ && P.unsafeIndex (plusPtr pos 5) == w6
223+ && Var.getInnerWidth pos6 end == 0
224+ then
225+ let !s = P.State pos6 end indent row (col + 6) ctx in cok () s
226+ else
227+ eerr row col ctx x
228+
229+
230+k7 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
231+k7 w1 w2 w3 w4 w5 w6 w7 x =
232+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
233+ let !pos7 = plusPtr pos 7 in
234+ if pos7 <= end
235+ && P.unsafeIndex ( pos ) == w1
236+ && P.unsafeIndex (plusPtr pos 1) == w2
237+ && P.unsafeIndex (plusPtr pos 2) == w3
238+ && P.unsafeIndex (plusPtr pos 3) == w4
239+ && P.unsafeIndex (plusPtr pos 4) == w5
240+ && P.unsafeIndex (plusPtr pos 5) == w6
241+ && P.unsafeIndex (plusPtr pos 6) == w7
242+ && Var.getInnerWidth pos7 end == 0
243+ then
244+ let !s = P.State pos7 end indent row (col + 7) ctx in cok () s
245+ else
246+ eerr row col ctx x
247+
248+
249+k8 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
250+k8 w1 w2 w3 w4 w5 w6 w7 w8 x =
251+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
252+ let !pos8 = plusPtr pos 8 in
253+ if pos8 <= end
254+ && P.unsafeIndex ( pos ) == w1
255+ && P.unsafeIndex (plusPtr pos 1) == w2
256+ && P.unsafeIndex (plusPtr pos 2) == w3
257+ && P.unsafeIndex (plusPtr pos 3) == w4
258+ && P.unsafeIndex (plusPtr pos 4) == w5
259+ && P.unsafeIndex (plusPtr pos 5) == w6
260+ && P.unsafeIndex (plusPtr pos 6) == w7
261+ && P.unsafeIndex (plusPtr pos 7) == w8
262+ && Var.getInnerWidth pos8 end == 0
263+ then
264+ let !s = P.State pos8 end indent row (col + 8) ctx in cok () s
265+ else
266+ eerr row col ctx x
compiler/src/Parse/Module.hs+292−173
@@ -1,136 +1,284 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Parse.Module
3module Parse.Module
4− ( module_
4+ ( fromByteString
5+ , Header(..)
6+ , Effects(..)
7+ , chompHeader
5 , chompImports
8 , chompImports
6 , freshLine
9 , freshLine
7− , exposing
8 )
10 )
9 where
11 where
10
12
11
13
14+import qualified Data.ByteString as B
12import qualified Data.Name as Name
15import qualified Data.Name as Name
13
16
14import qualified AST.Source as Src
17import qualified AST.Source as Src
15import qualified Elm.Compiler.Imports as Imports
18import qualified Elm.Compiler.Imports as Imports
16import qualified Elm.Package as Pkg
19import qualified Elm.Package as Pkg
17−import Parse.Primitives (Parser, oneOf)
20+import qualified Parse.Declaration as Decl
21+import qualified Parse.Keyword as Keyword
22+import qualified Parse.Symbol as Symbol
23+import qualified Parse.Variable as Var
18import qualified Parse.Primitives as P
24import qualified Parse.Primitives as P
19−import qualified Parse.Primitives.Keyword as Keyword
25+import Parse.Primitives hiding (Parser, State, fromByteString)
20−import qualified Parse.Primitives.Symbol as Symbol
26+import Parse.Utils
21−import qualified Parse.Primitives.Variable as Var
22−import qualified Parse.Primitives.Whitespace as W
23import qualified Reporting.Annotation as A
27import qualified Reporting.Annotation as A
24import qualified Reporting.Error.Syntax as E
28import qualified Reporting.Error.Syntax as E
25−import qualified Reporting.Region as R
29+import qualified Reporting.Result as Result
30+
31+
32+
33+-- FROM BYTE STRING
34+
35+
36+fromByteString :: Pkg.Name -> B.ByteString -> Result.Result i w E.Error Src.Module
37+fromByteString pkg source =
38+ let
39+ parser
40+ | pkg == Pkg.core = core
41+ | Pkg.isKernel pkg = platform
42+ | otherwise = normal
43+ in
44+ case P.fromByteString parser source of
45+ P.Ok outcome _ ->
46+ case outcome of
47+ Right modul -> Result.ok modul
48+ Left err -> Result.throw err
49+
50+ P.Err row col ctx err ->
51+ Result.throw (E.ParseError row col ctx err)
26
52
27
53
28
54
29-- MODULE
55-- MODULE
30
56
31
57
32−module_ :: Pkg.Name -> Parser decls -> Parser (Src.Module decls)
58+normal :: Parser (Either E.Error Src.Module)
33−module_ pkgName chompDecls =
59+normal =
34 do freshLine
60 do freshLine
35− header <- oneOf [ Just <$> chompHeader, return Nothing ]
61+ header <- chompHeader
36− imports <- Imports.addDefaults pkgName <$> chompImports []
62+ imports <- chompImports []
37− decls <- chompDecls
63+ decls <- chompDecls []
64+ endOfFile
38− return (Src.Module header imports decls)
65+ return (checkModule header (Imports.addDefaults imports) [] decls)
39
66
40
67
41−chompHeader :: Parser Src.Header
68+core :: Parser (Either E.Error Src.Module)
42−chompHeader =
69+core =
43− do start <- P.getPosition
70+ do freshLine
44− P.pushContext start E.Module
71+ header <- chompHeader
45− (name, effects) <- chompNameAndEffects
72+ imports <- chompImports []
46− P.hint E.Exposing $ Keyword.exposing_
73+ binops <- chompBinops []
47− P.spaces
74+ decls <- chompDecls []
48− exports <- P.addLocation exposing
75+ endOfFile
49− P.popContext ()
76+ return (checkModule header imports binops decls)
50− docs <- chompDocComment
77+
51− return (Src.Header name effects exports docs)
78+
52−
79+platform :: Parser (Either E.Error Src.Module)
53−
80+platform =
54−
81+ do freshLine
82+ header <- chompHeader
83+ imports <- chompImports []
84+ binops <- chompBinops []
85+ decls <- chompDecls []
86+ endOfFile
87+ return (checkModule header (Imports.addDefaults imports) binops decls)
88+
89+
90+
55−-- MODULE NAME
91+-- CHECK MODULE
56−--
92+
57−-- module MyThing
93+
58−-- port module MyThing
94+checkModule :: Maybe Header -> [Src.Import] -> [A.Located Src.Binop] -> [Decl.Decl] -> Either E.Error Src.Module
59−-- effect module MyThing where { command = MyCmd }
95+checkModule maybeHeader imports binops decls =
60−--
96+ let
61−chompNameAndEffects :: Parser (Name.Name, Src.Effects)
97+ (Header name effects exports) = maybe (Header "Main" NoEffects (A.At A.one Src.Open)) id maybeHeader
62−chompNameAndEffects =
98+ (values, unions, aliases, ports) = categorizeDecls [] [] [] [] decls
63− oneOf
99+ in
100+ Src.Module name exports imports values unions aliases binops
101+ <$> checkEffects ports effects
102+
103+
104+checkEffects :: [Src.Port] -> Effects -> Either E.Error Src.Effects
105+checkEffects ports effects =
106+ case effects of
107+ NoEffects ->
108+ case ports of
109+ [] -> Right Src.NoEffects
110+ _:_ -> Left (error "TODO no ports")
111+
112+ Ports region ->
113+ case ports of
114+ [] -> Left (error "TODO no ports in port module" region)
115+ _:_ -> Right (Src.Ports ports)
116+
117+ Manager region manager ->
118+ case ports of
119+ [] -> Right (Src.Manager region manager)
120+ _:_ -> Left (error "TODO ports in effect manager")
121+
122+
123+categorizeDecls :: [A.Located Src.Value] -> [A.Located Src.Union] -> [A.Located Src.Alias] -> [Src.Port] -> [Decl.Decl] -> ( [A.Located Src.Value], [A.Located Src.Union], [A.Located Src.Alias], [Src.Port] )
124+categorizeDecls values unions aliases ports decls =
125+ case decls of
64− [
126+ [] ->
65− do Keyword.module_
127+ (values, unions, aliases, ports)
66− P.spaces
128+
67− name <- Var.moduleName
129+ decl:otherDecls ->
68− P.spaces
130+ case decl of
69− return ( name, Src.NoEffects )
131+ Decl.Value value -> categorizeDecls (value:values) unions aliases ports otherDecls
70− ,
132+ Decl.Union union -> categorizeDecls values (union:unions) aliases ports otherDecls
71− do start <- P.getPosition
133+ Decl.Alias alias -> categorizeDecls values unions (alias:aliases) ports otherDecls
72− Keyword.port_
134+ Decl.Port port_ -> categorizeDecls values unions aliases (port_:ports) otherDecls
73− P.spaces
135+
74− Keyword.module_
136+
75− end <- P.getPosition
137+
76− P.spaces
138+-- FRESH LINES
77− name <- Var.moduleName
139+
78− P.spaces
140+
79− return ( name, Src.Ports (R.Region start end) )
141+freshLine :: Parser ()
80− ,
142+freshLine =
81− do start <- P.getPosition
143+ checkFreshLine =<< whitespace
82− Keyword.effect_
144+
83− P.spaces
145+
84− Keyword.module_
146+endOfFile :: Parser ()
85− end <- P.getPosition
147+endOfFile =
86− P.spaces
148+ P.Parser $ \state@(P.State pos end _ row col ctx) _ eok _ eerr ->
87− name <- Var.moduleName
149+ if pos < end then
88− P.spaces
150+ eerr row col ctx E.EndOfFile
89− manager <- chompManager
151+ else
90− return ( name, Src.Manager (R.Region start end) manager )
152+ eok () state
153+
154+
155+
156+-- CHOMP DECLARATIONS
157+
158+
159+chompDecls :: [Decl.Decl] -> Parser [Decl.Decl]
160+chompDecls decls =
161+ do (decl, _, pos) <- Decl.declaration
162+ oneOf E.XXX
163+ [ do checkFreshLine pos
164+ chompDecls (decl:decls)
165+ , return (reverse (decl:decls))
166+ ]
167+
168+
169+chompBinops :: [A.Located Src.Binop] -> Parser [A.Located Src.Binop]
170+chompBinops binops =
171+ oneOf E.XXX
172+ [ do binop <- Decl.infix_
173+ chompBinops (binop:binops)
174+ , return binops
91 ]
175 ]
92
176
93
177
94
178
95−-- MANAGER
179+-- HEADER
96−--
180+
181+
182+data Header =
183+ Header Name.Name Effects (A.Located Src.Exposing)
184+
185+
186+data Effects
187+ = NoEffects
188+ | Ports A.Region
189+ | Manager A.Region Src.Manager
190+
191+
192+chompHeader :: Parser (Maybe Header)
193+chompHeader =
194+ do start <- getPosition
195+ oneOf E.XXX
196+ [
197+ -- module MyThing exposing (..)
198+ do Keyword.module_
199+ pushContext start E.Module
200+ spaces
201+ name <- Var.moduleName
202+ spaces
203+ Keyword.exposing_
204+ spaces
205+ exports <- addLocation exposing
206+ popContext ()
207+ freshLine
208+ return (Just (Header name NoEffects exports))
209+ ,
210+ -- port module MyThing exposing (..)
211+ do Keyword.port_
212+ pushContext start E.Module
213+ spaces
214+ Keyword.module_
215+ end <- getPosition
216+ spaces
217+ name <- Var.moduleName
218+ spaces
219+ Keyword.exposing_
220+ spaces
221+ exports <- addLocation exposing
222+ popContext ()
223+ freshLine
224+ return (Just (Header name (Ports (A.Region start end)) exports))
225+ ,
97−-- where { command = MyCmd }
226+ -- effect module MyThing where { command = MyCmd } exposing (..)
98−-- where { subscription = MySub }
227+ do Keyword.effect_
99−-- where { command = MyCmd, subscription = MySub }
228+ pushContext start E.Module
100−--
229+ spaces
230+ Keyword.module_
231+ end <- getPosition
232+ spaces
233+ name <- Var.moduleName
234+ spaces
235+ Keyword.where_
236+ spaces
237+ manager <- chompManager
238+ spaces
239+ Keyword.exposing_
240+ spaces
241+ exports <- addLocation exposing
242+ popContext ()
243+ freshLine
244+ return (Just (Header name (Manager (A.Region start end) manager) exports))
245+ ,
246+ -- default header
247+ return Nothing
248+ ]
249+
250+
101chompManager :: Parser Src.Manager
251chompManager :: Parser Src.Manager
102chompManager =
252chompManager =
103− do Keyword.where_
253+ do word1 0x7B {- { -} E.XXX
104− P.spaces
105− Symbol.leftCurly
106− P.spaces
254+ spaces
107− oneOf
255+ oneOf E.XXX
108 [ do cmd <- chompCommand
256 [ do cmd <- chompCommand
109− P.spaces
257+ spaces
110− oneOf
258+ oneOf E.XXX
111− [ do Symbol.rightCurly
259+ [ do word1 0x7D {-}-} E.XXX
112− P.spaces
260+ spaces
113 return (Src.Cmd cmd)
261 return (Src.Cmd cmd)
114− , do Symbol.comma
262+ , do word1 0x2C {-,-} E.XXX
115− P.spaces
263+ spaces
116 sub <- chompSubscription
264 sub <- chompSubscription
117− P.spaces
265+ spaces
118− Symbol.rightCurly
266+ word1 0x7D {-}-} E.XXX
119− P.spaces
267+ spaces
120 return (Src.Fx cmd sub)
268 return (Src.Fx cmd sub)
121 ]
269 ]
122 , do sub <- chompSubscription
270 , do sub <- chompSubscription
123− P.spaces
271+ spaces
124− oneOf
272+ oneOf E.XXX
125− [ do Symbol.rightCurly
273+ [ do word1 0x7D {-}-} E.XXX
126− P.spaces
274+ spaces
127 return (Src.Sub sub)
275 return (Src.Sub sub)
128− , do Symbol.comma
276+ , do word1 0x2C {-,-} E.XXX
129− P.spaces
277+ spaces
130 cmd <- chompCommand
278 cmd <- chompCommand
131− P.spaces
279+ spaces
132− Symbol.rightCurly
280+ word1 0x7D {-}-} E.XXX
133− P.spaces
281+ spaces
134 return (Src.Fx cmd sub)
282 return (Src.Fx cmd sub)
135 ]
283 ]
136 ]
284 ]
@@ -139,37 +287,19 @@ chompManager =
139chompCommand :: Parser (A.Located Name.Name)
287chompCommand :: Parser (A.Located Name.Name)
140chompCommand =
288chompCommand =
141 do Keyword.command_
289 do Keyword.command_
142− P.spaces
290+ spaces
143− Symbol.equals
291+ word1 0x3D {-=-} E.XXX
144− P.spaces
292+ spaces
145− P.addLocation Var.upper
293+ addLocation Var.upper
146
294
147
295
148chompSubscription :: Parser (A.Located Name.Name)
296chompSubscription :: Parser (A.Located Name.Name)
149chompSubscription =
297chompSubscription =
150 do Keyword.subscription_
298 do Keyword.subscription_
151− P.spaces
299+ spaces
152− Symbol.equals
300+ word1 0x3D {-=-} E.XXX
153− P.spaces
301+ spaces
154− P.addLocation Var.upper
302+ addLocation Var.upper
155−
156−
157−
158−-- DOC COMMENTS
159−
160−
161−chompDocComment :: Parser Src.Docs
162−chompDocComment =
163− do endOfExposing <- P.getPosition
164− freshLine
165− nextStart <- P.getPosition
166− oneOf
167− [ do doc <- W.docComment
168− docEnd <- P.getPosition
169− freshLine
170− return (Src.YesDocs (R.Region nextStart docEnd) doc)
171− , return (Src.NoDocs (R.Region endOfExposing nextStart))
172− ]
173
303
174
304
175
305
@@ -178,20 +308,20 @@ chompDocComment =
178
308
179chompImports :: [Src.Import] -> Parser [Src.Import]
309chompImports :: [Src.Import] -> Parser [Src.Import]
180chompImports imports =
310chompImports imports =
181− oneOf
311+ oneOf E.XXX
182− [ do start <- P.getPosition
312+ [ do start <- getPosition
183 Keyword.import_
313 Keyword.import_
184− P.pushContext start E.Import
314+ pushContext start E.Import
185− P.spaces
315+ spaces
186− name <- P.addLocation Var.moduleName
316+ name <- addLocation Var.moduleName
187− pos <- W.whitespace
317+ pos <- whitespace
188− oneOf
318+ oneOf E.XXX
189− [ do P.checkFreshLine pos
319+ [ do checkFreshLine pos
190− P.popContext ()
320+ popContext ()
191 chompImports $
321 chompImports $
192 Src.Import name Nothing (Src.Explicit []) : imports
322 Src.Import name Nothing (Src.Explicit []) : imports
193− , do P.checkSpace pos
323+ , do checkSpace pos
194− oneOf
324+ oneOf E.XXX
195 [ chompAs name imports
325 [ chompAs name imports
196 , chompExposing name Nothing imports
326 , chompExposing name Nothing imports
197 ]
327 ]
@@ -203,15 +333,15 @@ chompImports imports =
203chompAs :: A.Located Name.Name -> [Src.Import] -> Parser [Src.Import]
333chompAs :: A.Located Name.Name -> [Src.Import] -> Parser [Src.Import]
204chompAs name imports =
334chompAs name imports =
205 do Keyword.as_
335 do Keyword.as_
206− P.spaces
336+ spaces
207 alias <- Var.upper
337 alias <- Var.upper
208− pos <- W.whitespace
338+ pos <- whitespace
209− oneOf
339+ oneOf E.XXX
210− [ do P.checkFreshLine pos
340+ [ do checkFreshLine pos
211− P.popContext ()
341+ popContext ()
212 chompImports $
342 chompImports $
213 Src.Import name (Just alias) (Src.Explicit []) : imports
343 Src.Import name (Just alias) (Src.Explicit []) : imports
214− , do P.checkSpace pos
344+ , do checkSpace pos
215 chompExposing name (Just alias) imports
345 chompExposing name (Just alias) imports
216 ]
346 ]
217
347
@@ -219,10 +349,10 @@ chompAs name imports =
219chompExposing :: A.Located Name.Name -> Maybe Name.Name -> [Src.Import] -> Parser [Src.Import]
349chompExposing :: A.Located Name.Name -> Maybe Name.Name -> [Src.Import] -> Parser [Src.Import]
220chompExposing name maybeAlias imports =
350chompExposing name maybeAlias imports =
221 do Keyword.exposing_
351 do Keyword.exposing_
222− P.spaces
352+ spaces
223 exposed <- exposing
353 exposed <- exposing
224 freshLine
354 freshLine
225− P.popContext ()
355+ popContext ()
226 chompImports $
356 chompImports $
227 Src.Import name maybeAlias exposed : imports
357 Src.Import name maybeAlias exposed : imports
228
358
@@ -233,65 +363,54 @@ chompExposing name maybeAlias imports =
233
363
234exposing :: Parser Src.Exposing
364exposing :: Parser Src.Exposing
235exposing =
365exposing =
236− P.hint E.Listing $
366+ do word1 0x28 {-(-} E.XXX
237− do Symbol.leftParen
238− P.spaces
367+ spaces
239− oneOf
368+ oneOf E.XXX
240− [ do Symbol.doubleDot
369+ [ do word2 0x2E 0x2E {-..-} E.XXX
241− P.spaces
370+ spaces
242− Symbol.rightParen
371+ word1 0x29 {-)-} E.XXX
243 return Src.Open
372 return Src.Open
244− , do entry <- P.addLocation chompEntry
373+ , do entry <- addLocation chompEntry
245− P.spaces
374+ spaces
246 exposingHelp [entry]
375 exposingHelp [entry]
247 ]
376 ]
248
377
249
378
250exposingHelp :: [A.Located Src.Exposed] -> Parser Src.Exposing
379exposingHelp :: [A.Located Src.Exposed] -> Parser Src.Exposing
251exposingHelp revEntries =
380exposingHelp revEntries =
252− oneOf
381+ oneOf E.XXX
253− [ do Symbol.comma
382+ [ do word1 0x2C {-,-} E.XXX
254− P.spaces
383+ spaces
255− entry <- P.addLocation chompEntry
384+ entry <- addLocation chompEntry
256− P.spaces
385+ spaces
257 exposingHelp (entry:revEntries)
386 exposingHelp (entry:revEntries)
258− , do Symbol.rightParen
387+ , do word1 0x29 {-)-} E.XXX
259 return (Src.Explicit (reverse revEntries))
388 return (Src.Explicit (reverse revEntries))
260 ]
389 ]
261
390
262
391
263chompEntry :: Parser Src.Exposed
392chompEntry :: Parser Src.Exposed
264chompEntry =
393chompEntry =
265− oneOf
394+ oneOf E.XXX
266 [ Src.Lower <$> Var.lower
395 [ Src.Lower <$> Var.lower
267− , do Symbol.leftParen
396+ , do word1 0x28 {-(-} E.XXX
268 op <- Symbol.binop
397 op <- Symbol.binop
269− Symbol.rightParen
398+ word1 0x29 {-)-} E.XXX
270 return (Src.Operator op)
399 return (Src.Operator op)
271 , do name <- Var.upper
400 , do name <- Var.upper
272− P.spaces
401+ spaces
273 Src.Upper name <$> privacy
402 Src.Upper name <$> privacy
274 ]
403 ]
275
404
276
405
277privacy :: Parser Src.Privacy
406privacy :: Parser Src.Privacy
278privacy =
407privacy =
279− oneOf
408+ oneOf E.XXX
280− [ do Symbol.leftParen
409+ [ do word1 0x28 {-(-} E.XXX
281− P.spaces
410+ spaces
282− Symbol.doubleDot
411+ word2 0x2E 0x2E {-..-} E.XXX
283− P.spaces
412+ spaces
284− Symbol.rightParen
413+ word1 0x29 {-)-} E.XXX
285 return Src.Public
414 return Src.Public
286 , return Src.Private
415 , return Src.Private
287 ]
416 ]
288−
289−
290−
291−-- FRESH LINES
292−
293−
294−freshLine :: Parser ()
295−freshLine =
296− P.checkFreshLine =<< W.whitespace
297−
compiler/src/Parse/Number.hsnew file+302
@@ -0,0 +1,302 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns, UnboxedTuples #-}
3+module Parse.Number
4+ ( Number(..)
5+ , number
6+ , Outcome(..)
7+ , chompInt
8+ , chompHex
9+ , precedence
10+ )
11+ where
12+
13+
14+import qualified Data.Utf8 as Utf8
15+import Data.Word (Word8)
16+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
17+
18+import qualified AST.Utils.Binop as Binop
19+import Parse.Utils (Parser)
20+import qualified Parse.Variable as Var
21+import qualified Parse.Primitives as P
22+import qualified Reporting.Error.Syntax as E
23+
24+
25+
26+-- HELPERS
27+
28+
29+isDirtyEnd :: Ptr Word8 -> Ptr Word8 -> Word8 -> Bool
30+isDirtyEnd pos end word =
31+ Var.getInnerWidthHelp pos end word > 0
32+
33+
34+{-# INLINE isDecimalDigit #-}
35+isDecimalDigit :: Word8 -> Bool
36+isDecimalDigit word =
37+ word <= 0x39 {-9-} && word >= 0x30 {-0-}
38+
39+
40+
41+-- NUMBERS
42+
43+
44+data Number
45+ = Int Int
46+ | Float (Utf8.Under256 Float)
47+
48+
49+number :: Parser Number
50+number =
51+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->
52+ if pos >= end then
53+ eerr row col ctx E.Number
54+
55+ else
56+ let !word = P.unsafeIndex pos in
57+ if not (isDecimalDigit word) then
58+ eerr row col ctx E.Number
59+
60+ else
61+ let
62+ outcome =
63+ if word == 0x30 {-0-} then
64+ chompZero (plusPtr pos 1) end
65+ else
66+ chompInt (plusPtr pos 1) end (fromIntegral (word - 0x30 {-0-}))
67+ in
68+ case outcome of
69+ Err newPos problem ->
70+ let
71+ !newCol = col + fromIntegral (minusPtr newPos pos)
72+ in
73+ cerr row newCol ctx problem
74+
75+ OkInt newPos n ->
76+ let
77+ !newCol = col + fromIntegral (minusPtr newPos pos)
78+ !integer = Int n
79+ !newState = P.State newPos end indent row newCol ctx
80+ in
81+ cok integer newState
82+
83+ OkFloat newPos ->
84+ let
85+ !newCol = col + fromIntegral (minusPtr newPos pos)
86+ !copy = Utf8.fromPtr pos newPos
87+ !float = Float copy
88+ !newState = P.State newPos end indent row newCol ctx
89+ in
90+ cok float newState
91+
92+
93+
94+-- CHOMP OUTCOME
95+
96+
97+-- first Int is newPos
98+--
99+data Outcome
100+ = Err (Ptr Word8) E.Expectation
101+ | OkInt (Ptr Word8) Int
102+ | OkFloat (Ptr Word8)
103+
104+
105+
106+-- CHOMP INT
107+
108+
109+chompInt :: Ptr Word8 -> Ptr Word8 -> Int -> Outcome
110+chompInt !pos end !n =
111+ if pos >= end then
112+
113+ OkInt pos n
114+
115+ else
116+
117+ let
118+ !word = P.unsafeIndex pos
119+ in
120+ if isDecimalDigit word then
121+ chompInt (plusPtr pos 1) end (10 * n + fromIntegral (word - 0x30 {-0-}))
122+
123+ else if word == 0x2E {-.-} then
124+ chompFraction (plusPtr pos 1) end n
125+
126+ else if word == 0x65 {-e-} || word == 0x45 {-E-} then
127+ chompExponent (plusPtr pos 1) end
128+
129+ else if isDirtyEnd pos end word then
130+ Err pos E.Number_End
131+
132+ else
133+ OkInt pos n
134+
135+
136+
137+-- CHOMP FRACTION
138+
139+
140+chompFraction :: Ptr Word8 -> Ptr Word8 -> Int -> Outcome
141+chompFraction pos end n =
142+ if pos >= end then
143+ Err pos (E.Number_Dot n)
144+
145+ else if isDecimalDigit (P.unsafeIndex pos) then
146+ chompFractionHelp (plusPtr pos 1) end
147+
148+ else
149+ Err pos (E.Number_Dot n)
150+
151+
152+chompFractionHelp :: Ptr Word8 -> Ptr Word8 -> Outcome
153+chompFractionHelp pos end =
154+ if pos >= end then
155+ OkFloat pos
156+
157+ else
158+ let !word = P.unsafeIndex pos in
159+ if isDecimalDigit word then
160+ chompFractionHelp (plusPtr pos 1) end
161+
162+ else if word == 0x65 {-e-} || word == 0x45 {-E-} then
163+ chompExponent (plusPtr pos 1) end
164+
165+ else if isDirtyEnd pos end word then
166+ Err pos E.Number_End
167+
168+ else
169+ OkFloat pos
170+
171+
172+
173+-- CHOMP EXPONENT
174+
175+
176+chompExponent :: Ptr Word8 -> Ptr Word8 -> Outcome
177+chompExponent pos end =
178+ if pos >= end then
179+ Err pos E.Number_Exp
180+
181+ else
182+ let !word = P.unsafeIndex pos in
183+ if isDecimalDigit word then
184+ chompExponentHelp (plusPtr pos 1) end
185+
186+ else if word == 0x2B {-+-} || word == 0x2D {---} then
187+
188+ let !pos1 = plusPtr pos 1 in
189+ if pos1 < end && isDecimalDigit (P.unsafeIndex pos1) then
190+ chompExponentHelp (plusPtr pos 2) end
191+ else
192+ Err pos E.Number_Exp
193+
194+ else
195+ Err pos E.Number_Exp
196+
197+
198+chompExponentHelp :: Ptr Word8 -> Ptr Word8 -> Outcome
199+chompExponentHelp pos end =
200+ if pos >= end then
201+ OkFloat pos
202+
203+ else if isDecimalDigit (P.unsafeIndex pos) then
204+ chompExponentHelp (plusPtr pos 1) end
205+
206+ else
207+ OkFloat pos
208+
209+
210+
211+-- CHOMP ZERO
212+
213+
214+chompZero :: Ptr Word8 -> Ptr Word8 -> Outcome
215+chompZero pos end =
216+ if pos >= end then
217+ OkInt pos 0
218+
219+ else
220+ let !word = P.unsafeIndex pos in
221+ if word == 0x78 {-x-} then
222+ chompHexInt (plusPtr pos 1) end
223+
224+ else if word == 0x2E {-.-} then
225+ chompFraction (plusPtr pos 1) end 0
226+
227+ else if isDecimalDigit word then
228+ Err pos E.Number_NoLeadingZero
229+
230+ else if isDirtyEnd pos end word then
231+ Err pos E.Number_End
232+
233+ else
234+ OkInt pos 0
235+
236+
237+chompHexInt :: Ptr Word8 -> Ptr Word8 -> Outcome
238+chompHexInt pos end =
239+ let (# newPos, answer #) = chompHex pos end in
240+ if answer < 0 then
241+ Err newPos E.Number_HexDigit
242+ else
243+ OkInt newPos answer
244+
245+
246+
247+-- CHOMP HEX
248+
249+
250+-- Return -1 if it has NO digits
251+-- Return -2 if it has BAD digits
252+
253+{-# INLINE chompHex #-}
254+chompHex :: Ptr Word8 -> Ptr Word8 -> (# Ptr Word8, Int #)
255+chompHex pos end =
256+ chompHexHelp pos end (-1) 0
257+
258+
259+chompHexHelp :: Ptr Word8 -> Ptr Word8 -> Int -> Int -> (# Ptr Word8, Int #)
260+chompHexHelp pos end answer accumulator =
261+ if pos >= end then
262+ (# pos, answer #)
263+ else
264+ let
265+ !newAnswer =
266+ stepHex pos end (P.unsafeIndex pos) accumulator
267+ in
268+ if newAnswer < 0 then
269+ (# pos, if newAnswer == -1 then answer else -2 #)
270+ else
271+ chompHexHelp (plusPtr pos 1) end newAnswer newAnswer
272+
273+
274+{-# INLINE stepHex #-}
275+stepHex :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int -> Int
276+stepHex pos end word acc
277+ | 0x30 {-0-} <= word && word <= 0x39 {-9-} = 16 * acc + fromIntegral (word - 0x30 {-0-})
278+ | 0x61 {-a-} <= word && word <= 0x66 {-f-} = 16 * acc + 10 + fromIntegral (word - 0x61 {-a-})
279+ | 0x41 {-A-} <= word && word <= 0x46 {-F-} = 16 * acc + 10 + fromIntegral (word - 0x41 {-A-})
280+ | isDirtyEnd pos end word = -2
281+ | True = -1
282+
283+
284+
285+-- PRECEDENCE
286+
287+
288+precedence :: Parser Binop.Precedence
289+precedence =
290+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
291+ if pos >= end then
292+ eerr row col ctx E.Precedence
293+
294+ else
295+ let !word = P.unsafeIndex pos in
296+ if isDecimalDigit word then
297+ cok
298+ (Binop.Precedence (fromIntegral (word - 0x30 {-0-})))
299+ (P.State (plusPtr pos 1) end indent row (col + 1) ctx)
300+
301+ else
302+ eerr row col ctx E.Precedence
compiler/src/Parse/Parse.hsdeleted−65
@@ -1,65 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Parse.Parse
3− ( program
4− )
5− where
6−
7−
8−import qualified Data.ByteString as B
9−
10−import qualified AST.Source as Src
11−import qualified AST.Valid as Valid
12−import qualified Elm.Package as Pkg
13−import qualified Parse.Declaration as Decl
14−import qualified Parse.Module as Module
15−import qualified Parse.Primitives as P
16−import qualified Reporting.Error.Syntax as Error
17−import qualified Reporting.Result as Result
18−import qualified Validate
19−
20−
21−
22−-- PROGRAM
23−
24−
25−program :: Pkg.Name -> B.ByteString -> Result.Result i w Error.Error Valid.Module
26−program pkg src =
27− let
28− bodyParser =
29− if Pkg.isKernel pkg then
30− chompDeclarations =<< chompInfixes []
31− else
32− chompDeclarations []
33−
34− parser =
35− Module.module_ pkg bodyParser <* P.endOfFile
36− in
37− case P.run parser src of
38− Right modul ->
39− Validate.validate modul
40−
41− Left syntaxError ->
42− Result.throw syntaxError
43−
44−
45−
46−-- CHOMP DECLARATIONS
47−
48−
49−chompDeclarations :: [Src.Decl] -> P.Parser [Src.Decl]
50−chompDeclarations decls =
51− do (decl, _, pos) <- Decl.declaration
52− P.oneOf
53− [ do P.checkFreshLine pos
54− chompDeclarations (decl:decls)
55− , return (reverse (decl:decls))
56− ]
57−
58−
59−chompInfixes :: [Src.Decl] -> P.Parser [Src.Decl]
60−chompInfixes decls =
61− P.oneOf
62− [ do decl <- Decl.infix_
63− chompInfixes (decl:decls)
64− , return decls
65− ]
compiler/src/Parse/Pattern.hs+86−88
@@ -11,17 +11,16 @@ import qualified Data.List as List
11import qualified Data.Name as Name
11import qualified Data.Name as Name
12
12
13import qualified AST.Source as Src
13import qualified AST.Source as Src
14−import Parse.Primitives (Parser, SParser, SPos, addLocation, checkSpace, getPosition, hint, inContext, spaces, oneOf)
14+import Parse.Utils (Parser, SParser, SPos, checkSpace, spaces, whitespace)
15+import qualified Parse.Keyword as Keyword
16+import qualified Parse.Number as Number
17+import qualified Parse.Symbol as Symbol
18+import qualified Parse.Utf8 as Utf8
19+import qualified Parse.Variable as Var
15import qualified Parse.Primitives as P
20import qualified Parse.Primitives as P
16−import qualified Parse.Primitives.Keyword as Keyword
21+import Parse.Primitives (addLocation, getPosition, inContext, oneOf, word1)
17−import qualified Parse.Primitives.Number as Number
18−import qualified Parse.Primitives.Symbol as Symbol
19−import qualified Parse.Primitives.Utf8 as Utf8
20−import qualified Parse.Primitives.Variable as Var
21−import Parse.Primitives.Whitespace (whitespace)
22import qualified Reporting.Annotation as A
22import qualified Reporting.Annotation as A
23import qualified Reporting.Error.Syntax as E
23import qualified Reporting.Error.Syntax as E
24−import qualified Reporting.Region as R
25
24
26
25
27
26
@@ -30,19 +29,18 @@ import qualified Reporting.Region as R
30
29
31term :: Parser Src.Pattern
30term :: Parser Src.Pattern
32term =
31term =
33− hint E.Pattern $
34− do start <- getPosition
32+ do start <- getPosition
35− oneOf
33+ oneOf E.XXX
36− [ record start
34+ [ record start
37− , tuple start
35+ , tuple start
38− , list start
36+ , list start
39− , termHelp start
37+ , termHelp start
40− ]
38+ ]
41
39
42
40
43−termHelp :: R.Position -> Parser Src.Pattern
41+termHelp :: A.Position -> Parser Src.Pattern
44termHelp start =
42termHelp start =
45− oneOf
43+ oneOf E.XXX
46 [
44 [
47 do Symbol.underscore
45 do Symbol.underscore
48 end <- getPosition
46 end <- getPosition
@@ -54,7 +52,7 @@ termHelp start =
54 ,
52 ,
55 do upper <- Var.foreignUpper
53 do upper <- Var.foreignUpper
56 end <- getPosition
54 end <- getPosition
57− let region = R.Region start end
55+ let region = A.Region start end
58 return $ A.at start end $
56 return $ A.at start end $
59 case upper of
57 case upper of
60 Var.Unqualified name ->
58 Var.Unqualified name ->
@@ -70,7 +68,7 @@ termHelp start =
70 return (A.at start end (Src.PInt int))
68 return (A.at start end (Src.PInt int))
71
69
72 Number.Float _ ->
70 Number.Float _ ->
73− P.noFloatsAllowedInPatterns
71+ noFloatsAllowedInPatterns
74 ,
72 ,
75 do str <- Utf8.string
73 do str <- Utf8.string
76 end <- getPosition
74 end <- getPosition
@@ -82,36 +80,39 @@ termHelp start =
82 ]
80 ]
83
81
84
82
83+noFloatsAllowedInPatterns :: Parser a
84+noFloatsAllowedInPatterns =
85+ P.Parser $ \(P.State _ _ _ row col ctx) _ _ cerr _ ->
86+ cerr row col ctx E.FloatInPattern
85
87
86
88
87
89
88-- RECORDS
90-- RECORDS
89
91
90
92
91−record :: R.Position -> Parser Src.Pattern
93+record :: A.Position -> Parser Src.Pattern
92record start =
94record start =
93− do Symbol.leftCurly
94− inContext start E.ExprRecord $
95+ inContext E.ExprRecord (word1 0x7B {- { -} E.XXX) $
95− do spaces
96+ do spaces
96− oneOf
97+ oneOf E.XXX
97− [ do var <- addLocation Var.lower
98+ [ do var <- addLocation Var.lower
98− spaces
99+ spaces
99− recordHelp start [var]
100+ recordHelp start [var]
100− , do Symbol.rightCurly
101+ , do word1 0x7D {-}-} E.XXX
101− end <- getPosition
102+ end <- getPosition
102− return (A.at start end (Src.PRecord []))
103+ return (A.at start end (Src.PRecord []))
103− ]
104+ ]
104−
105+
105−
106+
106−recordHelp :: R.Position -> [A.Located Name.Name] -> Parser Src.Pattern
107+recordHelp :: A.Position -> [A.Located Name.Name] -> Parser Src.Pattern
107recordHelp start vars =
108recordHelp start vars =
108− oneOf
109+ oneOf E.XXX
109− [ do Symbol.comma
110+ [ do word1 0x2C {-,-} E.XXX
110 spaces
111 spaces
111 var <- addLocation Var.lower
112 var <- addLocation Var.lower
112 spaces
113 spaces
113 recordHelp start (var:vars)
114 recordHelp start (var:vars)
114− , do Symbol.rightCurly
115+ , do word1 0x7D {-}-} E.XXX
115 end <- getPosition
116 end <- getPosition
116 return (A.at start end (Src.PRecord vars))
117 return (A.at start end (Src.PRecord vars))
117 ]
118 ]
@@ -121,30 +122,29 @@ recordHelp start vars =
121-- TUPLES
122-- TUPLES
122
123
123
124
124−tuple :: R.Position -> Parser Src.Pattern
125+tuple :: A.Position -> Parser Src.Pattern
125tuple start =
126tuple start =
126− do Symbol.leftParen
127− inContext start E.ExprTuple $
127+ inContext E.ExprTuple (word1 0x28 {-(-} E.XXX) $
128− do spaces
128+ do spaces
129− oneOf
129+ oneOf E.XXX
130− [ do (pattern, sPos) <- expression
130+ [ do (pattern, sPos) <- expression
131− checkSpace sPos
131+ checkSpace sPos
132− tupleHelp start pattern []
132+ tupleHelp start pattern []
133− , do Symbol.rightParen
133+ , do word1 0x29 {-)-} E.XXX
134− end <- getPosition
134+ end <- getPosition
135− return (A.at start end Src.PUnit)
135+ return (A.at start end Src.PUnit)
136− ]
136+ ]
137−
137+
138−
138+
139−tupleHelp :: R.Position -> Src.Pattern -> [Src.Pattern] -> Parser Src.Pattern
139+tupleHelp :: A.Position -> Src.Pattern -> [Src.Pattern] -> Parser Src.Pattern
140tupleHelp start firstPattern revPatterns =
140tupleHelp start firstPattern revPatterns =
141− oneOf
141+ oneOf E.XXX
142− [ do Symbol.comma
142+ [ do word1 0x2C {-,-} E.XXX
143 spaces
143 spaces
144 (pattern, sPos) <- expression
144 (pattern, sPos) <- expression
145 checkSpace sPos
145 checkSpace sPos
146 tupleHelp start firstPattern (pattern : revPatterns)
146 tupleHelp start firstPattern (pattern : revPatterns)
147− , do Symbol.rightParen
147+ , do word1 0x29 {-)-} E.XXX
148 case reverse revPatterns of
148 case reverse revPatterns of
149 [] ->
149 [] ->
150 return firstPattern
150 return firstPattern
@@ -159,30 +159,29 @@ tupleHelp start firstPattern revPatterns =
159-- LIST
159-- LIST
160
160
161
161
162−list :: R.Position -> Parser Src.Pattern
162+list :: A.Position -> Parser Src.Pattern
163list start =
163list start =
164− do Symbol.leftSquare
165− inContext start E.PatternList $
164+ inContext E.PatternList (word1 0x5B {-[-} E.XXX) $
166− do spaces
165+ do spaces
167− oneOf
166+ oneOf E.XXX
168− [ do (pattern, sPos) <- expression
167+ [ do (pattern, sPos) <- expression
169− checkSpace sPos
168+ checkSpace sPos
170− listHelp start [pattern]
169+ listHelp start [pattern]
171− , do Symbol.rightSquare
170+ , do word1 0x5D {-]-} E.XXX
172− end <- getPosition
171+ end <- getPosition
173− return (A.at start end (Src.PList []))
172+ return (A.at start end (Src.PList []))
174− ]
173+ ]
175−
174+
176−
175+
177−listHelp :: R.Position -> [Src.Pattern] -> Parser Src.Pattern
176+listHelp :: A.Position -> [Src.Pattern] -> Parser Src.Pattern
178listHelp start patterns =
177listHelp start patterns =
179− oneOf
178+ oneOf E.XXX
180− [ do Symbol.comma
179+ [ do word1 0x2C {-,-} E.XXX
181 spaces
180 spaces
182 (pattern, sPos) <- expression
181 (pattern, sPos) <- expression
183 checkSpace sPos
182 checkSpace sPos
184 listHelp start (pattern:patterns)
183 listHelp start (pattern:patterns)
185− , do Symbol.rightSquare
184+ , do word1 0x5D {-]-} E.XXX
186 end <- getPosition
185 end <- getPosition
187 return (A.at start end (Src.PList (reverse patterns)))
186 return (A.at start end (Src.PList (reverse patterns)))
188 ]
187 ]
@@ -194,17 +193,16 @@ listHelp start patterns =
194
193
195expression :: Parser (Src.Pattern, SPos)
194expression :: Parser (Src.Pattern, SPos)
196expression =
195expression =
197− hint E.Pattern $
198− do start <- getPosition
196+ do start <- getPosition
199− cTerm <- exprTerm
197+ cTerm <- exprTerm
200− exprHelp start [] cTerm
198+ exprHelp start [] cTerm
201
199
202
200
203−exprHelp :: R.Position -> [Src.Pattern] -> (Src.Pattern, R.Position, SPos) -> Parser (Src.Pattern, SPos)
201+exprHelp :: A.Position -> [Src.Pattern] -> (Src.Pattern, A.Position, SPos) -> Parser (Src.Pattern, SPos)
204exprHelp start patterns (pattern, _end, sPos) =
202exprHelp start patterns (pattern, _end, sPos) =
205− oneOf
203+ oneOf E.XXX
206 [ do checkSpace sPos
204 [ do checkSpace sPos
207− Symbol.cons
205+ word1 0x3A {-:-} E.XXX
208 spaces
206 spaces
209 cTerm <- exprTerm
207 cTerm <- exprTerm
210 exprHelp start (pattern:patterns) cTerm
208 exprHelp start (pattern:patterns) cTerm
@@ -228,8 +226,8 @@ exprHelp start patterns (pattern, _end, sPos) =
228
226
229
227
230cons :: Src.Pattern -> Src.Pattern -> Src.Pattern
228cons :: Src.Pattern -> Src.Pattern -> Src.Pattern
231−cons tl@(A.At (R.Region _ end) _) hd@(A.At (R.Region start _) _) =
229+cons tl hd =
232− A.at start end (Src.PCons hd tl)
230+ A.merge hd tl (Src.PCons hd tl)
233
231
234
232
235
233
@@ -238,24 +236,24 @@ cons tl@(A.At (R.Region _ end) _) hd@(A.At (R.Region start _) _) =
238
236
239exprTerm :: SParser Src.Pattern
237exprTerm :: SParser Src.Pattern
240exprTerm =
238exprTerm =
241− oneOf
239+ oneOf E.XXX
242 [
240 [
243 do start <- getPosition
241 do start <- getPosition
244 upper <- Var.foreignUpper
242 upper <- Var.foreignUpper
245 end <- getPosition
243 end <- getPosition
246− exprTermHelp (R.Region start end) upper start []
244+ exprTermHelp (A.Region start end) upper start []
247 ,
245 ,
248− do t@(A.At (R.Region _ end) _) <- term
246+ do t@(A.At (A.Region _ end) _) <- term
249 pos <- whitespace
247 pos <- whitespace
250 return (t, end, pos)
248 return (t, end, pos)
251 ]
249 ]
252
250
253
251
254−exprTermHelp :: R.Region -> Var.Upper -> R.Position -> [Src.Pattern] -> SParser Src.Pattern
252+exprTermHelp :: A.Region -> Var.Upper -> A.Position -> [Src.Pattern] -> SParser Src.Pattern
255exprTermHelp region upper start revArgs =
253exprTermHelp region upper start revArgs =
256 do end <- getPosition
254 do end <- getPosition
257 sPos <- whitespace
255 sPos <- whitespace
258− oneOf
256+ oneOf E.XXX
259 [ do checkSpace sPos
257 [ do checkSpace sPos
260 arg <- term
258 arg <- term
261 exprTermHelp region upper start (arg:revArgs)
259 exprTermHelp region upper start (arg:revArgs)
compiler/src/Parse/Primitives/Kernel.hsdeleted−116
@@ -1,116 +0,0 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}
3−module Parse.Primitives.Kernel
4− ( Special(..)
5− , chunk
6− )
7− where
8−
9−
10−import Prelude hiding (length)
11−import qualified Data.ByteString.Internal as B
12−import qualified Data.Name as Name
13−import Data.Word (Word8)
14−import Foreign.ForeignPtr (ForeignPtr)
15−
16−import Parse.Primitives.Internals (Parser(..), State(..), noError)
17−import qualified Parse.Primitives.Internals as I
18−import qualified Parse.Primitives.Variable as Var
19−
20−
21−
22−-- SPECIAL
23−
24−
25−data Special
26− = Enum Word8 Name.Name
27− | Prod
28− | Debug
29− | Import Name.Name
30− | JsField Name.Name
31− | ElmField Name.Name
32−
33−
34−
35−-- CHUNK
36−
37−
38−chunk :: Parser (B.ByteString, Maybe Special)
39−chunk =
40− Parser $ \(State fp offset terminal indent row col ctx) cok _ _ _ ->
41− let
42− (# maybeSpecial, jsOffset, newOffset, newRow, newCol #) =
43− chompChunk fp offset terminal row col
44−
45− !javascript = B.PS fp offset (jsOffset - offset)
46− !newState = State fp newOffset terminal indent newRow newCol ctx
47− in
48− cok (javascript, maybeSpecial) newState noError
49−
50−
51−
52−-- CHOMP CHUNK
53−
54−
55−chompChunk :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> (# Maybe Special, Int, Int, Int, Int #)
56−chompChunk fp offset terminal row col =
57− if offset >= terminal then
58− (# Nothing, offset, offset, row, col #)
59−
60− else
61− let !word = I.unsafeIndex fp offset in
62− if word == 0x5F {- _ -} then
63−
64− let
65− !offset1 = offset + 1
66− !offset3 = offset + 3
67− in
68− if offset3 <= terminal && I.unsafeIndex fp offset1 == 0x5F {- _ -} then
69− chompSpecial fp offset3 terminal row (col + 3) offset
70− else
71− chompChunk fp offset1 terminal row (col + 1)
72−
73− else if word == 0x0A {- \n -} then
74− chompChunk fp (offset + 1) terminal (row + 1) 1
75−
76− else
77− let !newOffset = offset + I.getCharWidth fp offset terminal word in
78− chompChunk fp newOffset terminal row (col + 1)
79−
80−
81−
82−-- CHOMP TAG
83−
84−
85−-- relies on external checks in chompChunk
86−chompSpecial :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Int -> (# Maybe Special, Int, Int, Int, Int #)
87−chompSpecial fp offset terminal row col jsOffset =
88− let
89− (# newOffset, newCol #) =
90− Var.chompInnerChars fp offset terminal col
91−
92− !tagOffset = offset - 1
93− !word = I.unsafeIndex fp tagOffset
94−
95− !special =
96− if word == 0x24 {- $ -} then
97− ElmField (Name.fromByteString fp offset (newOffset - offset))
98−
99− else
100− let !name = Name.fromByteString fp tagOffset (newOffset - tagOffset) in
101− if 0x30 <= word && word <= 0x39 then
102− Enum (fromIntegral (word - 0x30)) name
103−
104− else if 0x61 {- a -} <= word && word <= 0x7A {- z -} then
105− JsField name
106−
107− else if name == "DEBUG" then
108− Debug
109−
110− else if name == "PROD" then
111− Prod
112−
113− else
114− Import name
115− in
116− (# Just special, jsOffset, newOffset, row, newCol #)
compiler/src/Parse/Primitives/Keyword.hsdeleted−235
@@ -1,235 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, OverloadedStrings #-}
3−module Parse.Primitives.Keyword
4− ( type_, alias_, port_
5− , if_, then_, else_
6− , case_, of_
7− , let_, in_
8− , infix_, left_, right_, non_
9− , module_, import_, exposing_, as_, where_, effect_
10− , command_, subscription_
11− , jsonTrue, jsonFalse, jsonNull
12− )
13− where
14−
15−
16−import Control.Exception (assert)
17−import qualified Data.ByteString.Internal as B
18−import qualified Data.ByteString.Char8 as Char8
19−
20−import Parse.Primitives.Internals (Parser(..), State(..), expect, noError)
21−import qualified Parse.Primitives.Internals as I
22−import qualified Parse.Primitives.Variable as Var
23−import qualified Reporting.Error.Syntax as E
24−
25−
26−
27−-- PRIVATE IMPLEMENTATION
28−
29−
30−{- We can some avoid allocation by declaring all available keywords here.
31−That means the `keyword` function should only be used within this file on
32−values tagged as NOINLINE.
33−-}
34−keyword :: B.ByteString -> Parser ()
35−keyword kwd@(B.PS kwdFp kwdOffset kwdLength) =
36− let
37− !theory =
38− assert
39− (I.isNonNewlineAscii kwdFp kwdOffset (kwdOffset + kwdLength))
40− (E.Keyword (Char8.unpack kwd))
41− in
42− Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr ->
43− if I.isSubstring kwdFp kwdOffset kwdLength fp offset terminal
44− && Var.getInnerWidth fp (offset + kwdLength) terminal == 0
45− then
46− let
47− !newState =
48− State fp (offset + kwdLength) terminal indent row (col + kwdLength) ctx
49− in
50− cok () newState noError
51−
52− else
53− eerr (expect row col ctx theory)
54−
55−
56−
57−-- DECLARATIONS
58−
59−
60−{-# NOINLINE type_ #-}
61−type_ :: Parser ()
62−type_ =
63− keyword "type"
64−
65−
66−{-# NOINLINE alias_ #-}
67−alias_ :: Parser ()
68−alias_ =
69− keyword "alias"
70−
71−
72−{-# NOINLINE port_ #-}
73−port_ :: Parser ()
74−port_ =
75− keyword "port"
76−
77−
78−
79−-- IF EXPRESSIONS
80−
81−
82−{-# NOINLINE if_ #-}
83−if_ :: Parser ()
84−if_ =
85− keyword "if"
86−
87−
88−{-# NOINLINE then_ #-}
89−then_ :: Parser ()
90−then_ =
91− keyword "then"
92−
93−
94−{-# NOINLINE else_ #-}
95−else_ :: Parser ()
96−else_ =
97− keyword "else"
98−
99−
100−
101−-- CASE EXPRESSIONS
102−
103−
104−{-# NOINLINE case_ #-}
105−case_ :: Parser ()
106−case_ =
107− keyword "case"
108−
109−
110−{-# NOINLINE of_ #-}
111−of_ :: Parser ()
112−of_ =
113− keyword "of"
114−
115−
116−
117−-- LET EXPRESSIONS
118−
119−
120−{-# NOINLINE let_ #-}
121−let_ :: Parser ()
122−let_ =
123− keyword "let"
124−
125−
126−{-# NOINLINE in_ #-}
127−in_ :: Parser ()
128−in_ =
129− keyword "in"
130−
131−
132−
133−-- INFIXES
134−
135−
136−{-# NOINLINE infix_ #-}
137−infix_ :: Parser ()
138−infix_ =
139− keyword "infix"
140−
141−
142−{-# NOINLINE left_ #-}
143−left_ :: Parser ()
144−left_ =
145− keyword "left"
146−
147−
148−{-# NOINLINE right_ #-}
149−right_ :: Parser ()
150−right_ =
151− keyword "right"
152−
153−
154−{-# NOINLINE non_ #-}
155−non_ :: Parser ()
156−non_ =
157− keyword "non"
158−
159−
160−
161−-- IMPORTS
162−
163−
164−{-# NOINLINE module_ #-}
165−module_ :: Parser ()
166−module_ =
167− keyword "module"
168−
169−
170−{-# NOINLINE import_ #-}
171−import_ :: Parser ()
172−import_ =
173− keyword "import"
174−
175−
176−{-# NOINLINE exposing_ #-}
177−exposing_ :: Parser ()
178−exposing_ =
179− keyword "exposing"
180−
181−
182−{-# NOINLINE as_ #-}
183−as_ :: Parser ()
184−as_ =
185− keyword "as"
186−
187−
188−{-# NOINLINE where_ #-}
189−where_ :: Parser ()
190−where_ =
191− keyword "where"
192−
193−
194−{-# NOINLINE effect_ #-}
195−effect_ :: Parser ()
196−effect_ =
197− keyword "effect"
198−
199−
200−
201−-- EFFECTS
202−
203−
204−{-# NOINLINE command_ #-}
205−command_ :: Parser ()
206−command_ =
207− keyword "command"
208−
209−
210−{-# NOINLINE subscription_ #-}
211−subscription_ :: Parser ()
212−subscription_ =
213− keyword "subscription"
214−
215−
216−
217−-- JSON
218−
219−
220−{-# NOINLINE jsonTrue #-}
221−jsonTrue :: Parser ()
222−jsonTrue =
223− keyword "true"
224−
225−
226−{-# NOINLINE jsonFalse #-}
227−jsonFalse :: Parser ()
228−jsonFalse =
229− keyword "false"
230−
231−
232−{-# NOINLINE jsonNull #-}
233−jsonNull :: Parser ()
234−jsonNull =
235− keyword "null"
compiler/src/Parse/Primitives/Number.hsdeleted−297
@@ -1,297 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, UnboxedTuples #-}
3−module Parse.Primitives.Number
4− ( Number(..)
5− , number
6− , Outcome(..)
7− , chompInt
8− , chompHex
9− , precedence
10− )
11− where
12−
13−
14−import Prelude hiding (length)
15−import qualified Data.ByteString.Char8 as Char8
16−import qualified Data.ByteString.Internal as B
17−import Foreign.ForeignPtr (ForeignPtr)
18−import GHC.Word (Word8)
19−
20−import qualified AST.Utils.Binop as Binop
21−import Parse.Primitives.Internals (Parser(..), State(..), noError)
22−import qualified Parse.Primitives.Internals as I
23−import qualified Parse.Primitives.Variable as Var
24−import qualified Reporting.Error.Syntax as E
25−
26−
27−
28−-- HELPERS
29−
30−
31−isDirtyEnd :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Bool
32−isDirtyEnd fp offset terminal word =
33− Var.getInnerWidthHelp fp offset terminal word > 0
34−
35−
36−{-# INLINE isDecimalDigit #-}
37−isDecimalDigit :: Word8 -> Bool
38−isDecimalDigit word =
39− word <= 0x39 {- 9 -} && word >= 0x30 {- 0 -}
40−
41−
42−
43−-- NUMBERS
44−
45−
46−data Number
47− = Int Int
48− | Float Double
49−
50−
51−number :: Parser Number
52−number =
53− Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr ->
54− if offset >= terminal then
55− eerr noError
56−
57− else
58− let !word = I.unsafeIndex fp offset in
59− if not (isDecimalDigit word) then
60− eerr noError
61−
62− else
63− let
64− outcome =
65− if word == 0x30 {- 0 -} then
66− chompZero fp (offset + 1) terminal
67− else
68− chompInt fp (offset + 1) terminal (fromIntegral (word - 0x30 {- 0 -}))
69− in
70− case outcome of
71− Err newOffset problem ->
72− cerr (E.ParseError row (col + (newOffset - offset)) problem)
73−
74− OkInt newOffset n ->
75− let
76− !integer = Int n
77− !newState = State fp newOffset terminal indent row (col + (newOffset - offset)) ctx
78− in
79− cok integer newState noError
80−
81− OkFloat newOffset ->
82− let
83− !length = newOffset - offset
84− !float = Float $ read $ Char8.unpack $ B.PS fp offset length
85− !newState = State fp newOffset terminal indent row (col + length) ctx
86− in
87− cok float newState noError
88−
89−
90−
91−-- CHOMP OUTCOME
92−
93−
94−data Outcome
95− = Err { _offset :: Int, _problem :: E.Problem }
96− | OkInt { _offset :: Int, _value :: Int }
97− | OkFloat { _offset :: Int }
98−
99−
100−
101−-- CHOMP INT
102−
103−
104−chompInt :: ForeignPtr Word8 -> Int -> Int -> Int -> Outcome
105−chompInt fp !offset terminal !n =
106− if offset >= terminal then
107−
108− OkInt offset n
109−
110− else
111−
112− let
113− !word = I.unsafeIndex fp offset
114− in
115− if isDecimalDigit word then
116− chompInt fp (offset + 1) terminal (10 * n + fromIntegral (word - 0x30 {- 0 -}))
117−
118− else if word == 0x2E {- . -} then
119− chompFraction fp (offset + 1) terminal n
120−
121− else if word == 0x65 {- e -} || word == 0x45 {- E -} then
122− chompExponent fp (offset + 1) terminal
123−
124− else if isDirtyEnd fp offset terminal word then
125− Err offset E.BadNumberEnd
126−
127− else
128− OkInt offset n
129−
130−
131−
132−-- CHOMP FRACTION
133−
134−
135−chompFraction :: ForeignPtr Word8 -> Int -> Int -> Int -> Outcome
136−chompFraction fp offset terminal n =
137− if offset >= terminal then
138− Err offset (E.BadNumberDot n)
139−
140− else if isDecimalDigit (I.unsafeIndex fp offset) then
141− chompFractionHelp fp (offset + 1) terminal
142−
143− else
144− Err offset (E.BadNumberDot n)
145−
146−
147−chompFractionHelp :: ForeignPtr Word8 -> Int -> Int -> Outcome
148−chompFractionHelp fp offset terminal =
149− if offset >= terminal then
150− OkFloat offset
151−
152− else
153− let !word = I.unsafeIndex fp offset in
154− if isDecimalDigit word then
155− chompFractionHelp fp (offset + 1) terminal
156−
157− else if word == 0x65 {- e -} || word == 0x45 {- E -} then
158− chompExponent fp (offset + 1) terminal
159−
160− else if isDirtyEnd fp offset terminal word then
161− Err offset E.BadNumberEnd
162−
163− else
164− OkFloat offset
165−
166−
167−
168−-- CHOMP EXPONENT
169−
170−
171−chompExponent :: ForeignPtr Word8 -> Int -> Int -> Outcome
172−chompExponent fp offset terminal =
173− if offset >= terminal then
174− Err offset E.BadNumberExp
175−
176− else
177− let !word = I.unsafeIndex fp offset in
178− if isDecimalDigit word then
179− chompExponentHelp fp (offset + 1) terminal
180−
181− else if word == 0x2B {- + -} || word == 0x2D {- - -} then
182−
183− let !offset1 = offset + 1 in
184− if offset1 < terminal && isDecimalDigit (I.unsafeIndex fp offset1) then
185− chompExponentHelp fp (offset + 2) terminal
186− else
187− Err offset E.BadNumberExp
188−
189− else
190− Err offset E.BadNumberExp
191−
192−
193−chompExponentHelp :: ForeignPtr Word8 -> Int -> Int -> Outcome
194−chompExponentHelp fp offset terminal =
195− if offset >= terminal then
196− OkFloat offset
197−
198− else if isDecimalDigit (I.unsafeIndex fp offset) then
199− chompExponentHelp fp (offset + 1) terminal
200−
201− else
202− OkFloat offset
203−
204−
205−
206−-- CHOMP ZERO
207−
208−
209−chompZero :: ForeignPtr Word8 -> Int -> Int -> Outcome
210−chompZero fp offset terminal =
211− if offset >= terminal then
212− OkInt offset 0
213−
214− else
215− let !word = I.unsafeIndex fp offset in
216− if word == 0x78 {- x -} then
217− chompHexInt fp (offset + 1) terminal
218−
219− else if word == 0x2E {- . -} then
220− chompFraction fp (offset + 1) terminal 0
221−
222− else if isDecimalDigit word then
223− Err offset E.BadNumberZero
224−
225− else if isDirtyEnd fp offset terminal word then
226− Err offset E.BadNumberEnd
227−
228− else
229− OkInt offset 0
230−
231−
232−chompHexInt :: ForeignPtr Word8 -> Int -> Int -> Outcome
233−chompHexInt fp offset terminal =
234− let (# newOffset, answer #) = chompHex fp offset terminal in
235− if answer < 0 then
236− Err newOffset E.BadNumberHex
237− else
238− OkInt newOffset answer
239−
240−
241−
242−-- CHOMP HEX
243−
244−
245−-- Return -1 if it has NO digits
246−-- Return -2 if it has BAD digits
247−
248−{-# INLINE chompHex #-}
249−chompHex :: ForeignPtr Word8 -> Int -> Int -> (# Int, Int #)
250−chompHex fp offset terminal =
251− chompHexHelp fp offset terminal (-1) 0
252−
253−
254−chompHexHelp :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> (# Int, Int #)
255−chompHexHelp fp offset terminal answer accumulator =
256− if offset >= terminal then
257− (# offset, answer #)
258− else
259− let
260− !newAnswer =
261− stepHex fp offset terminal (I.unsafeIndex fp offset) accumulator
262− in
263− if newAnswer < 0 then
264− (# offset, if newAnswer == -1 then answer else -2 #)
265− else
266− chompHexHelp fp (offset + 1) terminal newAnswer newAnswer
267−
268−
269−{-# INLINE stepHex #-}
270−stepHex :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Int -> Int
271−stepHex fp offset terminal word acc
272− | 0x30 {- 0 -} <= word && word <= 0x39 {- 9 -} = 16 * acc + fromIntegral (word - 0x30 {- 0 -})
273− | 0x61 {- a -} <= word && word <= 0x66 {- f -} = 16 * acc + 10 + fromIntegral (word - 0x61 {- a -})
274− | 0x41 {- A -} <= word && word <= 0x46 {- F -} = 16 * acc + 10 + fromIntegral (word - 0x41 {- A -})
275− | isDirtyEnd fp offset terminal word = -2
276− | True = -1
277−
278−
279−
280−-- PRECEDENCE
281−
282−
283−precedence :: Parser Binop.Precedence
284−precedence =
285− Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr ->
286− if offset >= terminal then
287− eerr noError
288−
289− else
290− let !word = I.unsafeIndex fp offset in
291− if isDecimalDigit word then
292− cok
293− (Binop.Precedence (fromIntegral (word - 0x30 {- 0 -})))
294− (State fp (offset + 1) terminal indent row (col + 1) ctx)
295− noError
296− else
297− eerr noError
compiler/src/Parse/Primitives/Shader.hsdeleted−69
@@ -1,69 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns #-}
3−module Parse.Primitives.Shader
4− ( block
5− , failure
6− )
7− where
8−
9−
10−import qualified Data.ByteString.Internal as B
11−import qualified Data.Text as Text
12−import qualified Data.Text.Encoding as Text
13−import Foreign.ForeignPtr (ForeignPtr)
14−import GHC.Word (Word8)
15−
16−import Parse.Primitives.Internals (Parser(..), State(..), noError)
17−import qualified Parse.Primitives.Internals as I
18−import qualified Parse.Primitives.Symbol as Symbol
19−import qualified Reporting.Error.Syntax as E
20−
21−
22−
23−-- SHADER
24−
25−
26−failure :: Int -> Int -> Text.Text -> Parser a
27−failure row col msg =
28− Parser $ \_ _ cerr _ _ ->
29− cerr (E.ParseError row col (E.BadShader msg))
30−
31−
32−block :: Parser Text.Text
33−block =
34− do Symbol.shaderBlockOpen
35− Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ _ ->
36− case eatShader fp offset terminal row col of
37− Err ->
38− cerr (E.ParseError row col E.EndOfFile_Shader)
39−
40− Ok newOffset newRow newCol ->
41− let
42− !size = newOffset - offset
43− !shader = Text.decodeUtf8 (B.PS fp offset size)
44− !newState = State fp (newOffset + 2) terminal indent newRow newCol ctx
45− in
46− cok shader newState noError
47−
48−
49−data Result
50− = Err
51− | Ok Int Int Int
52−
53−
54−eatShader :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Result
55−eatShader fp offset terminal row col =
56− if offset >= terminal then
57− Err
58−
59− else
60− let !word = I.unsafeIndex fp offset in
61− if word == 0x007C {- | -} && I.isWord fp (offset + 1) terminal 0x5D {- ] -} then
62− Ok offset row (col + 2)
63−
64− else if word == 0x0A {- \n -} then
65− eatShader fp (offset + 1) terminal (row + 1) 1
66−
67− else
68− let !newOffset = offset + I.getCharWidth fp offset terminal word in
69− eatShader fp newOffset terminal row (col + 1)
compiler/src/Parse/Primitives/Symbol.hsdeleted−259
@@ -1,259 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}
3−module Parse.Primitives.Symbol
4− ( underscore
5− , binop
6− , equals, rightArrow, hasType, comma, pipe, cons, dot, doubleDot, minus, lambda
7− , leftParen, rightParen, leftSquare, rightSquare, leftCurly, rightCurly
8− , elmDocCommentOpen, jsMultiCommentOpen, jsMultiCommentClose
9− , shaderBlockOpen
10− )
11− where
12−
13−import Prelude hiding (length)
14−import Control.Exception (assert)
15−import qualified Data.ByteString.Internal as B
16−import qualified Data.ByteString.Char8 as Char8
17−import qualified Data.Char as Char
18−import qualified Data.IntSet as IntSet
19−import qualified Data.Name as Name
20−import qualified Data.Vector as Vector
21−import Foreign.ForeignPtr (ForeignPtr)
22−import GHC.Word (Word8)
23−
24−import Parse.Primitives.Internals (Parser(..), State(..), expect, noError)
25−import qualified Parse.Primitives.Internals as I
26−import qualified Parse.Primitives.Variable as Var
27−import qualified Reporting.Error.Syntax as E
28−import Reporting.Error.Syntax (Theory(..), BadOp(..))
29−
30−
31−
32−-- UNDERSCORE
33−
34−
35−underscore :: Parser ()
36−underscore =
37− Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr ->
38− if offset == terminal || I.unsafeIndex fp offset /= 0x5F {- _ -} then
39− eerr noError
40− else
41− let
42− !newOffset = offset + 1
43− !newCol = col + 1
44− in
45− if Var.getInnerWidth fp newOffset terminal > 0 then
46− let (# _, badCol #) = Var.chompInnerChars fp newOffset terminal newCol in
47− cerr (E.ParseError row newCol (E.BadUnderscore badCol))
48− else
49− let !newState = State fp newOffset terminal indent row newCol ctx in
50− cok () newState noError
51−
52−
53−
54−-- BINOP
55−
56−
57−binop :: Parser Name.Name
58−binop =
59− Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr ->
60− let !newOffset = chompOps fp offset terminal in
61− if offset == newOffset then
62− eerr (expect row col ctx E.InfixOp)
63−
64− else
65− let !length = newOffset - offset in
66− case Name.fromByteString fp offset length of
67− "." -> cerr (E.ParseError row col (E.BadOp Dot ctx))
68− "|" -> cerr (E.ParseError row col (E.BadOp Pipe ctx))
69− "->" -> cerr (E.ParseError row col (E.BadOp Arrow ctx))
70− "=" -> cerr (E.ParseError row col (E.BadOp Equals ctx))
71− ":" -> cerr (E.ParseError row col (E.BadOp HasType ctx))
72− op -> cok op (State fp newOffset terminal indent row (col + length) ctx) noError
73−
74−
75−chompOps :: ForeignPtr Word8 -> Int -> Int -> Int
76−chompOps fp offset terminal =
77− if offset < terminal && isBinopCharHelp (I.unsafeIndex fp offset) then
78− chompOps fp (offset + 1) terminal
79− else
80− offset
81−
82−
83−{-# INLINE isBinopCharHelp #-}
84−isBinopCharHelp :: Word8 -> Bool
85−isBinopCharHelp word =
86− word < 128 && Vector.unsafeIndex binopCharVector (fromIntegral word)
87−
88−
89−{-# NOINLINE binopCharVector #-}
90−binopCharVector :: Vector.Vector Bool
91−binopCharVector =
92− Vector.generate 128 (\i -> IntSet.member i binopCharSet)
93−
94−
95−{-# NOINLINE binopCharSet #-}
96−binopCharSet :: IntSet.IntSet
97−binopCharSet =
98− IntSet.fromList (map Char.ord "+-/*=.<>:&|^?%!")
99−
100−
101−
102−-- PRIVATE SYMBOL IMPLEMENTATION
103−
104−
105−{- We can some avoid allocation by declaring all available symbols here.
106−That means the `symbol` function should only be used within this file on
107−values tagged as NOINLINE.
108−-}
109−symbol :: B.ByteString -> Parser ()
110−symbol sym@(B.PS symFp symOffset symLength) =
111− let
112− !theory =
113− assert
114− (I.isNonNewlineAscii symFp symOffset (symOffset + symLength))
115− (Symbol (Char8.unpack sym))
116− in
117− Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr ->
118− if I.isSubstring symFp symOffset symLength fp offset terminal then
119− let !newState = State fp (offset + symLength) terminal indent row (col + symLength) ctx in
120− cok () newState noError
121−
122− else
123− eerr (expect row col ctx theory)
124−
125−
126−
127−-- COMMON SYMBOLS
128−
129−
130−{-# NOINLINE equals #-}
131−equals :: Parser ()
132−equals =
133− symbol "="
134−
135−
136−{-# NOINLINE rightArrow #-}
137−rightArrow :: Parser ()
138−rightArrow =
139− symbol "->"
140−
141−
142−{-# NOINLINE hasType #-}
143−hasType :: Parser ()
144−hasType =
145− symbol ":"
146−
147−
148−{-# NOINLINE comma #-}
149−comma :: Parser ()
150−comma =
151− symbol ","
152−
153−
154−{-# NOINLINE pipe #-}
155−pipe :: Parser ()
156−pipe =
157− symbol "|"
158−
159−
160−{-# NOINLINE cons #-}
161−cons :: Parser ()
162−cons =
163− symbol "::"
164−
165−
166−{-# NOINLINE dot #-}
167−dot :: Parser ()
168−dot =
169− symbol "."
170−
171−
172−{-# NOINLINE doubleDot #-}
173−doubleDot :: Parser ()
174−doubleDot =
175− symbol ".."
176−
177−
178−{-# NOINLINE minus #-}
179−minus :: Parser ()
180−minus =
181− symbol "-"
182−
183−
184−{-# NOINLINE lambda #-}
185−lambda :: Parser ()
186−lambda =
187− symbol "\\"
188−
189−
190−
191−-- ENCLOSURES
192−
193−
194−{-# NOINLINE leftParen #-}
195−leftParen :: Parser ()
196−leftParen =
197− symbol "("
198−
199−
200−{-# NOINLINE rightParen #-}
201−rightParen :: Parser ()
202−rightParen =
203− symbol ")"
204−
205−
206−{-# NOINLINE leftSquare #-}
207−leftSquare :: Parser ()
208−leftSquare =
209− symbol "["
210−
211−
212−{-# NOINLINE rightSquare #-}
213−rightSquare :: Parser ()
214−rightSquare =
215− symbol "]"
216−
217−
218−{-# NOINLINE leftCurly #-}
219−leftCurly :: Parser ()
220−leftCurly =
221− symbol "{"
222−
223−
224−{-# NOINLINE rightCurly #-}
225−rightCurly :: Parser ()
226−rightCurly =
227− symbol "}"
228−
229−
230−
231−-- COMMENTS
232−
233−
234−{-# NOINLINE elmDocCommentOpen #-}
235−elmDocCommentOpen :: Parser ()
236−elmDocCommentOpen =
237− symbol "{-|"
238−
239−
240−{-# NOINLINE jsMultiCommentOpen #-}
241−jsMultiCommentOpen :: Parser ()
242−jsMultiCommentOpen =
243− symbol "/*"
244−
245−
246−{-# NOINLINE jsMultiCommentClose #-}
247−jsMultiCommentClose :: Parser ()
248−jsMultiCommentClose =
249− symbol "*/"
250−
251−
252−
253−-- SHADER
254−
255−
256−{-# NOINLINE shaderBlockOpen #-}
257−shaderBlockOpen :: Parser ()
258−shaderBlockOpen =
259− symbol "[glsl|"
compiler/src/Parse/Primitives/Utf8.hsdeleted−323
@@ -1,323 +0,0 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
3−module Parse.Primitives.Utf8
4− ( string
5− , character
6− )
7− where
8−
9−
10−import Prelude hiding (length)
11−import qualified Data.ByteString.Internal as B
12−import qualified Data.ByteString.UTF8 as BS_UTF8
13−import qualified Data.Utf8 as Utf8
14−import Foreign.ForeignPtr (ForeignPtr)
15−import GHC.Word (Word8(..))
16−
17−import Parse.Primitives.Internals (Parser(..), State(..), noError)
18−import qualified Parse.Primitives.Internals as I
19−import qualified Parse.Primitives.Number as Number
20−import qualified Reporting.Error.Syntax as E
21−
22−
23−
24−-- CHARACTER
25−
26−
27−character :: Parser Utf8.Utf8
28−character =
29− Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr ->
30− if offset >= terminal || I.unsafeIndex fp offset /= 0x27 {- ' -} then
31− eerr noError
32−
33− else
34− case chompChar fp (offset + 1) terminal (col + 1) 0 placeholder of
35− Bad newCol problem ->
36− cerr (E.ParseError row newCol problem)
37−
38− Good newOffset newCol numChars mostRecent ->
39− if numChars /= 1 then
40− cerr (E.ParseError row col (E.BadChar newCol))
41− else
42− let !newState = State fp newOffset terminal indent row newCol ctx in
43− cok (Utf8.fromChunks fp [mostRecent]) newState noError
44−
45−
46−data CharResult
47− = Bad Int E.Problem
48− | Good Int Int Int Utf8.Chunk
49−
50−
51−chompChar :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Utf8.Chunk -> CharResult
52−chompChar fp offset terminal col numChars mostRecent =
53− if offset >= terminal then
54− Bad col E.EndOfFile_Char
55−
56− else
57− let
58− !word = I.unsafeIndex fp offset
59− in
60− if word == 0x27 {- ' -} then
61− Good (offset + 1) (col + 1) numChars mostRecent
62−
63− else if word == 0x0A {- \n -} then
64− Bad col E.NewLineInChar
65−
66− else if word == 0x22 {- " -} then
67− chompChar fp (offset + 1) terminal (col + 1) (numChars + 1) doubleQuote
68−
69− else if word == 0x5C {- \ -} then
70− case eatEscape fp (offset + 1) terminal of
71− EscapeNormal ->
72− chompChar fp (offset + 2) terminal (col + 2) (numChars + 1) (Utf8.Slice offset 2)
73−
74− EscapeUnicode delta code ->
75− chompChar fp (offset + delta) terminal (col + delta) (numChars + 1) (Utf8.CodePoint code)
76−
77− EscapeProblem newOffset problem ->
78− Bad col (E.BadEscape (newOffset - offset) problem)
79−
80− EscapeEndOfFile ->
81− Bad col E.EndOfFile_Char
82−
83− else
84− let !width = I.getCharWidth fp offset terminal word in
85− chompChar fp (offset + width) terminal (col + 1) (numChars + 1) (Utf8.Slice offset width)
86−
87−
88−
89−-- STRINGS
90−
91−
92−string :: Parser Utf8.Utf8
93−string =
94− Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr ->
95− if isDoubleQuote fp offset terminal then
96−
97− let
98− !offset1 = offset + 1
99− result =
100− if isDoubleQuote fp offset1 terminal && isDoubleQuote fp (offset + 2) terminal then
101− multiString fp (offset + 3) terminal row (col + 3) (offset + 3) mempty
102− else
103− singleString fp offset1 terminal row (col + 1) offset1 mempty
104− in
105− case result of
106− Err err ->
107− cerr err
108−
109− Ok newOffset newRow newCol utf8 ->
110− let
111− !newState = State fp newOffset terminal indent newRow newCol ctx
112− in
113− cok utf8 newState noError
114−
115− else
116− eerr noError
117−
118−
119−{-# INLINE isDoubleQuote #-}
120−isDoubleQuote :: ForeignPtr Word8 -> Int -> Int -> Bool
121−isDoubleQuote fp offset terminal =
122− offset < terminal && I.unsafeIndex fp offset == 0x22 {- " -}
123−
124−
125−data StringResult
126− = Err E.ParseError
127− | Ok !Int !Int !Int !Utf8.Utf8
128−
129−
130−finalize :: ForeignPtr Word8 -> Int -> Int -> [Utf8.Chunk] -> Utf8.Utf8
131−finalize fp start end revChunks =
132− Utf8.fromChunks fp $ reverse $
133− if start == end then
134− revChunks
135− else
136− Utf8.Slice start (end - start) : revChunks
137−
138−
139−addEscape :: Utf8.Chunk -> Int -> Int -> [Utf8.Chunk] -> [Utf8.Chunk]
140−addEscape chunk start end revChunks =
141− if start == end then
142− chunk : revChunks
143− else
144− chunk : Utf8.Slice start (end - start) : revChunks
145−
146−
147−
148−-- SINGLE STRINGS
149−
150−
151−singleString :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Int -> [Utf8.Chunk] -> StringResult
152−singleString fp offset terminal row col initialOffset revChunks =
153− if offset >= terminal then
154− Err (E.ParseError row col E.EndOfFile_String)
155−
156− else
157− let
158− !word = I.unsafeIndex fp offset
159− in
160− if word == 0x22 {- " -} then
161− Ok (offset + 1) row (col + 1) $
162− finalize fp initialOffset offset revChunks
163−
164− else if word == 0x0A {- \n -} then
165− Err (E.ParseError row col E.NewLineInString)
166−
167− else if word == 0x27 {- ' -} then
168− let !newOffset = offset + 1 in
169− singleString fp newOffset terminal row (col + 1) newOffset $
170− addEscape singleQuote initialOffset offset revChunks
171−
172− else if word == 0x5C {- \ -} then
173− case eatEscape fp (offset + 1) terminal of
174− EscapeNormal ->
175− singleString fp (offset + 2) terminal row (col + 2) initialOffset revChunks
176−
177− EscapeUnicode delta code ->
178− let !newOffset = offset + delta in
179− singleString fp newOffset terminal row (col + delta) newOffset $
180− addEscape (Utf8.CodePoint code) initialOffset offset revChunks
181−
182− EscapeProblem newOffset problem ->
183− Err (E.ParseError row col (E.BadEscape (newOffset - offset) problem))
184−
185− EscapeEndOfFile ->
186− Err (E.ParseError row (col + 1) E.EndOfFile_String)
187−
188− else
189− let !newOffset = offset + I.getCharWidth fp offset terminal word in
190− singleString fp newOffset terminal row (col + 1) initialOffset revChunks
191−
192−
193−
194−-- MULTI STRINGS
195−
196−
197−multiString :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Int -> [Utf8.Chunk] -> StringResult
198−multiString fp offset terminal row col initialOffset revChunks =
199− if offset >= terminal then
200− Err (E.ParseError row col E.EndOfFile_MultiString)
201−
202− else
203− let !word = I.unsafeIndex fp offset in
204− if word == 0x22 {- " -} && isDoubleQuote fp (offset + 1) terminal && isDoubleQuote fp (offset + 2) terminal then
205− Ok (offset + 3) row (col + 3) $
206− finalize fp initialOffset offset revChunks
207−
208− else if word == 0x27 {- ' -} then
209− let !offset1 = offset + 1 in
210− multiString fp offset1 terminal row (col + 1) offset1 $
211− addEscape singleQuote initialOffset offset revChunks
212−
213− else if word == 0x0A {- \n -} then
214− let !offset1 = offset + 1 in
215− multiString fp offset1 terminal (row + 1) 1 offset1 $
216− addEscape newline initialOffset offset revChunks
217−
218− else if word == 0x0D {- \r -} then
219− let !offset1 = offset + 1 in
220− multiString fp offset1 terminal row col offset1 $
221− addEscape carriageReturn initialOffset offset revChunks
222−
223− else if word == 0x5C {- \ -} then
224− case eatEscape fp (offset + 1) terminal of
225− EscapeNormal ->
226− multiString fp (offset + 2) terminal row (col + 2) initialOffset revChunks
227−
228− EscapeUnicode delta code ->
229− let !newOffset = offset + delta in
230− multiString fp newOffset terminal row (col + delta) newOffset $
231− addEscape (Utf8.CodePoint code) initialOffset offset revChunks
232−
233− EscapeProblem newOffset problem ->
234− Err (E.ParseError row col (E.BadEscape (newOffset - offset) problem))
235−
236− EscapeEndOfFile ->
237− Err (E.ParseError row (col + 1) E.EndOfFile_MultiString)
238−
239− else
240− let !newOffset = offset + I.getCharWidth fp offset terminal word in
241− multiString fp newOffset terminal row (col + 1) initialOffset revChunks
242−
243−
244−
245−-- ESCAPE CHARACTERS
246−
247−
248−data Escape
249− = EscapeNormal
250− | EscapeUnicode !Int !Int
251− | EscapeProblem !Int E.EscapeProblem
252− | EscapeEndOfFile
253−
254−
255−eatEscape :: ForeignPtr Word8 -> Int -> Int -> Escape
256−eatEscape fp offset terminal =
257− if offset >= terminal then
258− EscapeEndOfFile
259−
260− else
261− case I.unsafeIndex fp offset of
262− 0x6E {- n -} -> EscapeNormal
263− 0x72 {- r -} -> EscapeNormal
264− 0x74 {- t -} -> EscapeNormal
265− 0x22 {- " -} -> EscapeNormal
266− 0x27 {- ' -} -> EscapeNormal
267− 0x5C {- \ -} -> EscapeNormal
268− 0x75 {- u -} -> eatUnicode fp (offset + 1) terminal
269− _ -> EscapeProblem offset E.UnknownEscape
270−
271−
272−eatUnicode :: ForeignPtr Word8 -> Int -> Int -> Escape
273−eatUnicode fp offset terminal =
274− if offset >= terminal || I.unsafeIndex fp offset /= 0x7B {- { -} then
275− EscapeProblem offset E.UnicodeSyntax
276− else
277− let
278− !digitOffset = offset + 1
279− (# newOffset, code #) = Number.chompHex fp digitOffset terminal
280− !numDigits = newOffset - digitOffset
281− in
282− if newOffset >= terminal || I.unsafeIndex fp newOffset /= 0x7D {- } -} then
283− EscapeProblem newOffset E.UnicodeSyntax
284−
285− else if code < 0 || 0x10FFFF < code then
286− EscapeProblem (newOffset + 1) E.UnicodeRange
287−
288− else if numDigits < 4 || 6 < numDigits then
289− EscapeProblem (newOffset + 1) $
290− E.UnicodeLength numDigits (BS_UTF8.toString (B.PS fp digitOffset numDigits))
291−
292− else
293− EscapeUnicode (numDigits + 4) code
294−
295−
296−{-# NOINLINE singleQuote #-}
297−singleQuote :: Utf8.Chunk
298−singleQuote =
299− Utf8.Escape 0x27 {- ' -}
300−
301−
302−{-# NOINLINE doubleQuote #-}
303−doubleQuote :: Utf8.Chunk
304−doubleQuote =
305− Utf8.Escape 0x22 {- " -}
306−
307−
308−{-# NOINLINE newline #-}
309−newline :: Utf8.Chunk
310−newline =
311− Utf8.Escape 0x6E {- n -}
312−
313−
314−{-# NOINLINE carriageReturn #-}
315−carriageReturn :: Utf8.Chunk
316−carriageReturn =
317− Utf8.Escape 0x72 {- \r -}
318−
319−
320−{-# NOINLINE placeholder #-}
321−placeholder :: Utf8.Chunk
322−placeholder =
323− Utf8.CodePoint 0xFFFD {- replacement character -}
compiler/src/Parse/Primitives/Variable.hsdeleted−376
@@ -1,376 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}
3−module Parse.Primitives.Variable
4− ( lower
5− , upper
6− , moduleName
7− , Upper(..)
8− , foreignUpper
9− , foreignAlpha
10− , chompInnerChars
11− , getInnerWidth
12− , getInnerWidthHelp
13− )
14− where
15−
16−
17−import Control.Exception (assert)
18−import Data.Bits ((.&.), (.|.), shiftL)
19−import qualified Data.Char as Char
20−import qualified Data.Name as Name
21−import qualified Data.Set as Set
22−import Foreign.ForeignPtr (ForeignPtr)
23−import GHC.Word (Word8)
24−
25−import qualified AST.Source as Src
26−import Parse.Primitives.Internals (Parser(..), State(..), expect, noError, unsafeIndex)
27−import qualified Reporting.Error.Syntax as E
28−
29−
30−
31−-- LOCAL UPPER
32−
33−
34−upper :: Parser Name.Name
35−upper =
36− Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr ->
37− let (# newOffset, newCol #) = chompUpper fp offset terminal col in
38− if offset == newOffset then
39− eerr (expect row col ctx E.CapVar)
40− else
41− let !name = Name.fromByteString fp offset (newOffset - offset) in
42− cok name (State fp newOffset terminal indent row newCol ctx) noError
43−
44−
45−
46−-- LOCAL LOWER
47−
48−
49−lower :: Parser Name.Name
50−lower =
51− Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr ->
52− let (# newOffset, newCol #) = chompLower fp offset terminal col in
53− if offset == newOffset then
54− eerr (expect row col ctx E.LowVar)
55− else
56− let !name = Name.fromByteString fp offset (newOffset - offset) in
57− if Set.member name reservedWords then
58− eerr (expect row col ctx E.LowVar)
59− else
60− cok name (State fp newOffset terminal indent row newCol ctx) noError
61−
62−
63−{-# NOINLINE reservedWords #-}
64−reservedWords :: Set.Set Name.Name
65−reservedWords =
66− Set.fromList
67− [ "if", "then", "else"
68− , "case", "of"
69− , "let", "in"
70− , "type"
71− , "module", "where"
72− , "import", "exposing"
73− , "as"
74− , "port"
75− ]
76−
77−
78−
79−-- MODULE NAME
80−
81−
82−moduleName :: Parser Name.Name
83−moduleName =
84− Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr ->
85− let (# newOffset, newCol #) = chompUpper fp offset terminal col in
86− case moduleNameHelp fp newOffset terminal newCol of
87− Bad badCol ->
88− eerr (expect row badCol ctx E.CapVar)
89−
90− Good end endCol ->
91− let
92− !name = Name.fromByteString fp offset (end - offset)
93− !newState = State fp end terminal indent row endCol ctx
94− in
95− cok name newState noError
96−
97−
98−data ModuleName = Bad Int | Good Int Int
99−
100−
101−moduleNameHelp :: ForeignPtr Word8 -> Int -> Int -> Int -> ModuleName
102−moduleNameHelp fp offset terminal col =
103− if isDot fp offset terminal then
104− let
105− !offset1 = offset + 1
106− (# newOffset, newCol #) = chompUpper fp offset1 terminal (col + 1)
107− in
108− if offset1 == newOffset then
109− Bad newCol
110− else
111− moduleNameHelp fp newOffset terminal newCol
112−
113− else
114− Good offset col
115−
116−
117−
118−-- FOREIGN UPPER
119−
120−
121−data Upper
122− = Unqualified Name.Name
123− | Qualified Name.Name Name.Name
124−
125−
126−foreignUpper :: Parser Upper
127−foreignUpper =
128− Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr ->
129− let (# start, end, newCol #) = foreignUpperHelp fp offset terminal col in
130− if start == end then
131− eerr (expect row newCol ctx E.CapVar)
132− else
133− let
134− !newState = State fp end terminal indent row newCol ctx
135− !name = Name.fromByteString fp start (end - start)
136− !foreign =
137− if start == offset then
138− Unqualified name
139− else
140− let !home = Name.fromByteString fp offset ((start - 1) - offset) in
141− Qualified home name
142− in
143− cok foreign newState noError
144−
145−
146−foreignUpperHelp :: ForeignPtr Word8 -> Int -> Int -> Int -> (# Int, Int, Int #)
147−foreignUpperHelp fp offset terminal col =
148− let
149− (# newOffset, newCol #) = chompUpper fp offset terminal col
150− in
151− if offset == newOffset then
152− (# offset, offset, col #)
153−
154− else if isDot fp newOffset terminal then
155− foreignUpperHelp fp (newOffset + 1) terminal (newCol + 1)
156−
157− else
158− (# offset, newOffset, newCol #)
159−
160−
161−
162−-- FOREIGN ALPHA
163−
164−
165−foreignAlpha :: Parser Src.Expr_
166−foreignAlpha =
167− Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr ->
168− let (# start, end, newCol, varType #) = foreignAlphaHelp fp offset terminal col in
169− if start == end then
170− eerr (E.ParseError row newCol (E.Theories ctx [E.LowVar, E.CapVar]))
171− else
172− let
173− !newState = State fp end terminal indent row newCol ctx
174− !name = Name.fromByteString fp start (end - start)
175− in
176− if start == offset then
177− if Set.member name reservedWords then
178− eerr noError
179− else
180− cok (Src.Var varType name) newState noError
181− else
182− let !home = Name.fromByteString fp offset ((start - 1) - offset) in
183− cok (Src.VarQual varType home name) newState noError
184−
185−
186−foreignAlphaHelp :: ForeignPtr Word8 -> Int -> Int -> Int -> (# Int, Int, Int, Src.VarType #)
187−foreignAlphaHelp fp offset terminal col =
188− let
189− (# lowerOffset, lowerCol #) = chompLower fp offset terminal col
190− in
191− if offset < lowerOffset then
192− (# offset, lowerOffset, lowerCol, Src.Value #)
193−
194− else
195− let
196− (# upperOffset, upperCol #) = chompUpper fp offset terminal col
197− in
198− if offset == upperOffset then
199− (# offset, offset, col, Src.Ctor #)
200−
201− else if isDot fp upperOffset terminal then
202− foreignAlphaHelp fp (upperOffset + 1) terminal (upperCol + 1)
203−
204− else
205− (# offset, upperOffset, upperCol, Src.Ctor #)
206−
207−
208−
209−---- CHAR CHOMPERS ----
210−
211−
212−
213−-- DOTS
214−
215−
216−{-# INLINE isDot #-}
217−isDot :: ForeignPtr Word8 -> Int -> Int -> Bool
218−isDot fp offset terminal =
219− offset < terminal && unsafeIndex fp offset == 0x2e {- . -}
220−
221−
222−
223−-- UPPER CHARS
224−
225−
226−chompUpper :: ForeignPtr Word8 -> Int -> Int -> Int -> (# Int, Int #)
227−chompUpper fp offset terminal col =
228− let !width = getUpperWidth fp offset terminal in
229− if width == 0 then
230− (# offset, col #)
231− else
232− chompInnerChars fp (offset + width) terminal (col + 1)
233−
234−
235−{-# INLINE getUpperWidth #-}
236−getUpperWidth :: ForeignPtr Word8 -> Int -> Int -> Int
237−getUpperWidth fp offset terminal =
238− if offset < terminal then
239− getUpperWidthHelp fp offset terminal (unsafeIndex fp offset)
240− else
241− 0
242−
243−
244−{-# INLINE getUpperWidthHelp #-}
245−getUpperWidthHelp :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Int
246−getUpperWidthHelp fp offset terminal word
247− | 0x41 {- A -} <= word && word <= 0x5A {- Z -} = 1
248− | word < 0xc0 = 0
249− | word < 0xe0 = if Char.isUpper (getChar2 fp offset terminal word) then 2 else 0
250− | word < 0xf0 = if Char.isUpper (getChar3 fp offset terminal word) then 3 else 0
251− | word < 0xf8 = if Char.isUpper (getChar4 fp offset terminal word) then 4 else 0
252− | True = 0
253−
254−
255−
256−-- LOWER CHARS
257−
258−
259−chompLower :: ForeignPtr Word8 -> Int -> Int -> Int -> (# Int, Int #)
260−chompLower fp offset terminal col =
261− let !width = getLowerWidth fp offset terminal in
262− if width == 0 then
263− (# offset, col #)
264− else
265− chompInnerChars fp (offset + width) terminal (col + 1)
266−
267−
268−{-# INLINE getLowerWidth #-}
269−getLowerWidth :: ForeignPtr Word8 -> Int -> Int -> Int
270−getLowerWidth fp offset terminal =
271− if offset < terminal then
272− getLowerWidthHelp fp offset terminal (unsafeIndex fp offset)
273− else
274− 0
275−
276−
277−{-# INLINE getLowerWidthHelp #-}
278−getLowerWidthHelp :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Int
279−getLowerWidthHelp fp offset terminal word
280− | 0x61 {- a -} <= word && word <= 0x7A {- z -} = 1
281− | word < 0xc0 = 0
282− | word < 0xe0 = if Char.isLower (getChar2 fp offset terminal word) then 2 else 0
283− | word < 0xf0 = if Char.isLower (getChar3 fp offset terminal word) then 3 else 0
284− | word < 0xf8 = if Char.isLower (getChar4 fp offset terminal word) then 4 else 0
285− | True = 0
286−
287−
288−
289−-- INNER CHARS
290−
291−
292−chompInnerChars :: ForeignPtr Word8 -> Int -> Int -> Int -> (# Int, Int #)
293−chompInnerChars fp !offset terminal !col =
294− let !width = getInnerWidth fp offset terminal in
295− if width == 0 then
296− (# offset, col #)
297− else
298− chompInnerChars fp (offset + width) terminal (col + 1)
299−
300−
301−getInnerWidth :: ForeignPtr Word8 -> Int -> Int -> Int
302−getInnerWidth fp offset terminal =
303− if offset < terminal then
304− getInnerWidthHelp fp offset terminal (unsafeIndex fp offset)
305− else
306− 0
307−
308−
309−{-# INLINE getInnerWidthHelp #-}
310−getInnerWidthHelp :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Int
311−getInnerWidthHelp fp offset terminal word
312− | 0x61 {- a -} <= word && word <= 0x7A {- z -} = 1
313− | 0x41 {- A -} <= word && word <= 0x5A {- Z -} = 1
314− | 0x30 {- 0 -} <= word && word <= 0x39 {- 9 -} = 1
315− | word == 0x5F {- _ -} = 1
316− | word < 0xc0 = 0
317− | word < 0xe0 = if Char.isAlpha (getChar2 fp offset terminal word) then 2 else 0
318− | word < 0xf0 = if Char.isAlpha (getChar3 fp offset terminal word) then 3 else 0
319− | word < 0xf8 = if Char.isAlpha (getChar4 fp offset terminal word) then 4 else 0
320− | True = 0
321−
322−
323−
324−-- EXTRACT CHARACTERS
325−
326−
327−push :: Word8 -> Int -> Int
328−push word code =
329− assert (word .&. 0xc0 == 0x80) (
330− shiftL code 6 .|. fromEnum (word .&. 0x3f)
331− )
332−
333−
334−getChar2 :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Char
335−getChar2 fp offset terminal word =
336− assert (offset + 2 <= terminal) (
337− let
338− !word1 = word .&. 0x1f
339− !word2 = unsafeIndex fp (offset + 1)
340− !code = push word2 (fromEnum word1)
341− in
342− assert (0x80 <= code) (
343− toEnum code
344− )
345− )
346−
347−
348−getChar3 :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Char
349−getChar3 fp offset terminal word =
350− assert (offset + 3 <= terminal) (
351− let
352− !word1 = word .&. 0x0f
353− !word2 = unsafeIndex fp (offset + 1)
354− !word3 = unsafeIndex fp (offset + 2)
355− !code = push word3 (push word2 (fromEnum word1))
356− in
357− assert ((0x800 <= code && code < 0xd800) || (0xdfff < code && code < 0xfffe)) (
358− toEnum code
359− )
360− )
361−
362−
363−getChar4 :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Char
364−getChar4 fp offset terminal word =
365− assert (offset + 4 <= terminal) (
366− let
367− !word1 = word .&. 0x07
368− !word2 = unsafeIndex fp (offset + 1)
369− !word3 = unsafeIndex fp (offset + 2)
370− !word4 = unsafeIndex fp (offset + 3)
371− !code = push word4 (push word3 (push word2 (fromEnum word1)))
372− in
373− assert (0x10000 <= code && code < 0x110000) (
374− toEnum code
375− )
376− )
compiler/src/Parse/Primitives/Whitespace.hsdeleted−223
@@ -1,223 +0,0 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}
3−module Parse.Primitives.Whitespace
4− ( SPos(..)
5− , whitespace
6− , docComment
7− , chompUntilDocs
8− )
9− where
10−
11−
12−import qualified Data.ByteString.Internal as B
13−import Foreign.ForeignPtr (ForeignPtr)
14−import GHC.Word (Word8)
15−
16−import Parse.Primitives.Internals (Parser(..), State(..), noError)
17−import qualified Parse.Primitives.Internals as I
18−import qualified Parse.Primitives.Symbol as Symbol
19−import qualified Reporting.Error.Syntax as E
20−import qualified Reporting.Region as R
21−
22−
23−
24−-- WHITESPACE
25−
26−
27−newtype SPos = SPos R.Position
28−
29−
30−whitespace :: Parser SPos
31−whitespace =
32− Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ _ ->
33− case eatSpaces fp offset terminal row col of
34− Err err ->
35− cerr err
36−
37− Ok newOffset newRow newCol ->
38− let
39− !spos = SPos (R.Position newRow newCol)
40− !newState = State fp newOffset terminal indent newRow newCol ctx
41− in
42− cok spos newState noError
43−
44−
45−data Result
46− = Err E.ParseError
47− | Ok Int Int Int
48−
49−
50−
51−-- EAT SPACES
52−
53−
54−eatSpaces :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Result
55−eatSpaces fp offset terminal row col =
56− if offset >= terminal then
57− Ok offset row col
58−
59− else
60− case I.unsafeIndex fp offset of
61− 0x20 {- -} ->
62− eatSpaces fp (offset + 1) terminal row (col + 1)
63−
64− 0x0A {- \n -} ->
65− eatSpaces fp (offset + 1) terminal (row + 1) 1
66−
67− 0x7B {- { -} ->
68− eatMultiComment fp offset terminal row col
69−
70− 0x2D {- - -} ->
71− let !offset1 = offset + 1 in
72− if offset1 < terminal && I.unsafeIndex fp offset1 == 0x2D {- - -} then
73− eatLineComment fp (offset + 2) terminal row (col + 2)
74− else
75− Ok offset row col
76−
77− 0x0D {- \r -} ->
78− eatSpaces fp (offset + 1) terminal row col
79−
80− 0x09 {- \t -} ->
81− Err (E.ParseError row col E.Tab)
82−
83− _ ->
84− Ok offset row col
85−
86−
87−
88−-- LINE COMMENTS
89−
90−
91−eatLineComment :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Result
92−eatLineComment fp offset terminal row col =
93− if offset >= terminal then
94− Ok offset row col
95−
96− else
97− let !word = I.unsafeIndex fp offset in
98− if word == 0x0A {- \n -} then
99− eatSpaces fp (offset + 1) terminal (row + 1) 1
100− else
101− let !newOffset = offset + I.getCharWidth fp offset terminal word in
102− eatLineComment fp newOffset terminal row (col + 1)
103−
104−
105−
106−-- MULTI COMMENTS
107−
108−
109−eatMultiComment :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Result
110−eatMultiComment fp offset terminal row col =
111− let
112− !offset1 = offset + 1
113− !offset2 = offset + 2
114− in
115− if offset2 >= terminal then
116− Ok offset row col
117−
118− else
119− let
120− !yesDash = I.unsafeIndex fp offset1 == 0x2D {- - -}
121− !noBar = I.unsafeIndex fp offset2 /= 0x7C {- | -}
122− in
123− if yesDash && noBar then
124− case eatMultiCommentHelp fp offset2 terminal row (col + 2) 1 of
125− Ok newOffset newRow newCol ->
126− eatSpaces fp newOffset terminal newRow newCol
127−
128− err@(Err _) ->
129− err
130−
131− else
132− Ok offset row col
133−
134−
135−eatMultiCommentHelp :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Int -> Result
136−eatMultiCommentHelp fp offset terminal row col openComments =
137− if offset >= terminal then
138− Err (E.ParseError row col E.EndOfFile_Comment)
139−
140− else
141− let !word = I.unsafeIndex fp offset in
142− if word == 0x0A {- \n -} then
143− eatMultiCommentHelp fp (offset + 1) terminal (row + 1) 1 openComments
144−
145− else if word == 0x2D {- - -} && I.isWord fp (offset + 1) terminal 0x7D {- } -} then
146− if openComments == 1 then
147− Ok (offset + 2) row (col + 2)
148− else
149− eatMultiCommentHelp fp (offset + 2) terminal row (col + 2) (openComments - 1)
150−
151− else if word == 0x7B {- { -} && I.isWord fp (offset + 1) terminal 0x2D {- - -} then
152− eatMultiCommentHelp fp (offset + 2) terminal row (col + 2) (openComments + 1)
153−
154− else
155− let !newOffset = offset + I.getCharWidth fp offset terminal word in
156− eatMultiCommentHelp fp newOffset terminal row (col + 1) openComments
157−
158−
159−
160−-- DOCUMENTATION COMMENT
161−
162−
163−docComment :: Parser B.ByteString
164−docComment =
165− do Symbol.elmDocCommentOpen
166− Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ _ ->
167− case eatMultiCommentHelp fp offset terminal row col 1 of
168− Err err ->
169− cerr err
170−
171− Ok newOffset newRow newCol ->
172− let
173− !comment = B.PS fp offset (newOffset - offset - 2)
174− !newState = State fp newOffset terminal indent newRow newCol ctx
175− in
176− cok comment newState noError
177−
178−
179−
180−-- PARSING DOCS
181−
182−
183−chompUntilDocs :: Parser Bool
184−chompUntilDocs =
185− Parser $ \(State fp offset terminal indent row col ctx) cok _ _ _ ->
186− let
187− (# isStart, newOffset, newRow, newCol #) =
188− eatDocs fp offset terminal row col
189−
190− !newState =
191− State fp newOffset terminal indent newRow newCol ctx
192− in
193− cok isStart newState noError
194−
195−
196−eatDocs :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> (# Bool, Int, Int, Int #)
197−eatDocs fp offset terminal row col =
198− if offset >= terminal then
199− (# False, offset, row, col #)
200−
201− else if isDocsStart fp offset terminal then
202− (# True, offset + 5, row, col + 5 #)
203−
204− else
205− let !word = I.unsafeIndex fp offset in
206− if word == 0x0A {- \n -} then
207− eatDocs fp (offset + 1) terminal (row + 1) 1
208−
209− else
210− let !newOffset = offset + I.getCharWidth fp offset terminal word in
211− eatDocs fp newOffset terminal row (col + 1)
212−
213−
214−isDocsStart :: ForeignPtr Word8 -> Int -> Int -> Bool
215−isDocsStart =
216− let (B.PS dfp doff dlen) = docsStart in
217− I.isSubstring dfp doff dlen
218−
219−
220−{-# NOINLINE docsStart #-}
221−docsStart :: B.ByteString
222−docsStart =
223− "@docs"
compiler/src/Parse/Repl.hs+37−48
@@ -8,18 +8,11 @@ module Parse.Repl
8
8
9
9
10import qualified Data.ByteString.UTF8 as BS_UTF8
10import qualified Data.ByteString.UTF8 as BS_UTF8
11−import qualified Data.Text as Text
12−import Data.Text (Text)
13import Data.Name (Name)
11import Data.Name (Name)
14
12
15import qualified AST.Source as Src
13import qualified AST.Source as Src
16−import qualified Parse.Module as Module
14+import qualified Parse.Primitives as P
17−import Parse.Primitives
15+import Parse.Utils
18−import qualified Parse.Primitives.Keyword as Keyword
19−import qualified Parse.Primitives.Symbol as Symbol
20−import qualified Parse.Primitives.Variable as Var
21−import qualified Parse.Pattern as Pattern
22−import qualified Reporting.Annotation as A
23
16
24
17
25
18
@@ -27,10 +20,10 @@ import qualified Reporting.Annotation as A
27
20
28
21
29data Entry
22data Entry
30− = Import Name (Maybe Name) Src.Exposing Text
23+ = Import Name (Maybe Name) Src.Exposing String
31− | Type Name Text
24+ | Type Name String
32− | Def (Maybe Name) Text
25+ | Def (Maybe Name) String
33− | Other Text
26+ | Other String
34 | Annotation
27 | Annotation
35 | Port
28 | Port
36
29
@@ -40,33 +33,40 @@ data Entry
40
33
41
34
42parseEntry :: String -> Entry
35parseEntry :: String -> Entry
43−parseEntry rawEntry =
36+parseEntry source =
44− let
45− source =
46− Text.pack rawEntry
47− in
48− case run (entryParser source) (BS_UTF8.fromString rawEntry) of
37+ case P.fromByteString parser (BS_UTF8.fromString source) of
49− Right entry ->
38+ P.Ok entry _ ->
50− entry
39+ entry
51
40
52− Left _ ->
41+ P.Err _ _ _ _ ->
53− Other source
42+ Other source
54
43
55
44
56−entryParser :: Text -> Parser Entry
45+parser :: Parser Entry
57−entryParser source =
46+parser =
47+ error "TODO parse the REPL stuff"
48+
49+{-
58 oneOf
50 oneOf
51+ [
59− [ do Keyword.import_
52+ do Keyword.import_
60 spaces
53 spaces
61 name <- Var.moduleName
54 name <- Var.moduleName
62 alias <- tryAlias
55 alias <- tryAlias
63− exposing <- tryExposing
56+ exposing <-
57+ oneOf
58+ [ do spaces
59+ Keyword.exposing_
60+ spaces
61+ Module.exposing
62+ , return (Src.Explicit [])
63+ ]
64 return (Import name alias exposing source)
64 return (Import name alias exposing source)
65−
65+ ,
66− , do Keyword.port_
66+ do Keyword.port_
67 return Port
67 return Port
68−
68+ ,
69− , do Keyword.type_
69+ do Keyword.type_
70 spaces
70 spaces
71 oneOf
71 oneOf
72 [ do Keyword.alias_
72 [ do Keyword.alias_
@@ -75,20 +75,20 @@ entryParser source =
75 ]
75 ]
76 name <- Var.upper
76 name <- Var.upper
77 return (Type name source)
77 return (Type name source)
78−
78+ ,
79− , do root <- Pattern.term
79+ do root <- Pattern.term
80 spaces
80 spaces
81 case A.toValue root of
81 case A.toValue root of
82 Src.PVar name ->
82 Src.PVar name ->
83 oneOf
83 oneOf
84− [ do Symbol.hasType
84+ [ do word1 0x3A {-:-} E.XXX
85 return Annotation
85 return Annotation
86 , do chompArgs
86 , do chompArgs
87 return (Def (Just name) source)
87 return (Def (Just name) source)
88 ]
88 ]
89
89
90 _ ->
90 _ ->
91− do Symbol.equals
91+ do word1 0x3D {-=-} E.XXX
92 return (Def Nothing source)
92 return (Def Nothing source)
93 ]
93 ]
94
94
@@ -99,7 +99,7 @@ chompArgs =
99 [ do Pattern.term
99 [ do Pattern.term
100 spaces
100 spaces
101 chompArgs
101 chompArgs
102− , do Symbol.equals
102+ , do word1 0x3D {-=-} E.XXX
103 return ()
103 return ()
104 ]
104 ]
105
105
@@ -114,15 +114,4 @@ tryAlias =
114 Just <$> Var.upper
114 Just <$> Var.upper
115 , return Nothing
115 , return Nothing
116 ]
116 ]
117−
117+-}
118−
119−tryExposing :: Parser Src.Exposing
120−tryExposing =
121− oneOf
122− [ try $
123− do spaces
124− Keyword.exposing_
125− spaces
126− Module.exposing
127− , return (Src.Explicit [])
128− ]
compiler/src/Parse/Shader.hs+106−28
@@ -1,5 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, UnboxedTuples #-}
3module Parse.Shader
3module Parse.Shader
4 ( shader
4 ( shader
5 )
5 )
@@ -9,7 +9,9 @@ module Parse.Shader
9import qualified Data.List as List
9import qualified Data.List as List
10import qualified Data.Map as Map
10import qualified Data.Map as Map
11import qualified Data.Name as Name
11import qualified Data.Name as Name
12−import qualified Data.Text as Text
12+import qualified Data.Utf8 as Utf8
13+import Data.Word (Word8, Word16)
14+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
13import qualified Language.GLSL.Parser as GLP
15import qualified Language.GLSL.Parser as GLP
14import qualified Language.GLSL.Syntax as GLS
16import qualified Language.GLSL.Syntax as GLS
15import qualified Text.Parsec as Parsec
17import qualified Text.Parsec as Parsec
@@ -17,37 +19,101 @@ import qualified Text.Parsec.Error as Parsec
17
19
18import qualified AST.Source as Src
20import qualified AST.Source as Src
19import qualified AST.Utils.Shader as Shader
21import qualified AST.Utils.Shader as Shader
22+import Parse.Utils (Parser)
23+import qualified Parse.Primitives as P
20import qualified Reporting.Annotation as A
24import qualified Reporting.Annotation as A
21−import qualified Reporting.Region as R
25+import qualified Reporting.Error.Syntax as E
22−import Parse.Primitives (Parser, getPosition)
23−import qualified Parse.Primitives.Shader as Shader
24
26
25
27
26
28
27−-- SHADERS
29+-- SHADER
28
30
29
31
30−shader :: R.Position -> Parser Src.Expr
32+shader :: A.Position -> Parser Src.Expr
31−shader start@(R.Position row col) =
33+shader start@(A.Position row col) =
32− do block <- Shader.block
34+ do block <- parseBlock
33− shdr <- parseSource row col (Text.unpack block)
35+ shdr <- parseGlsl row col block
34− end@(R.Position row2 col2) <- getPosition
36+ end <- P.getPosition
35− let uid = List.intercalate ":" (map show [row, col, row2, col2])
37+ let src = List.intercalate "\\n" (lines block)
36− let src = Text.replace "\n" "\\n" (Text.replace "\r\n" "\\n" block)
37− return (A.at start end (Src.Shader (Text.pack uid) src shdr))
38+ return (A.at start end (Src.Shader (Utf8.fromChars src) shdr))
38
39
39
40
41+
42+-- BLOCK
43+
44+
45+parseBlock :: Parser String
46+parseBlock =
47+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->
48+ let
49+ !pos6 = plusPtr pos 6
50+ in
51+ if pos6 <= end
52+ && P.unsafeIndex ( pos ) == 0x5B {- [ -}
53+ && P.unsafeIndex (plusPtr pos 1) == 0x67 {- g -}
54+ && P.unsafeIndex (plusPtr pos 2) == 0x6C {- l -}
55+ && P.unsafeIndex (plusPtr pos 3) == 0x73 {- s -}
56+ && P.unsafeIndex (plusPtr pos 4) == 0x6C {- l -}
57+ && P.unsafeIndex (plusPtr pos 5) == 0x7C {- | -}
58+ then
59+ let
60+ (# status, newPos, newRow, newCol #) =
61+ eatShader pos6 end row col
62+ in
63+ case status of
64+ Good ->
65+ let
66+ !size = minusPtr newPos pos
67+ !block = error "TODO get a GLSL block" size
68+ !newState = P.State (plusPtr newPos 2) end indent newRow newCol ctx
69+ in
70+ cok block newState
71+
72+ Unending ->
73+ cerr row col ctx E.ShaderEnd
74+
75+ else
76+ eerr row col ctx E.ShaderStart
77+
78+
79+data Status
80+ = Good
81+ | Unending
82+
83+
84+eatShader :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Status, Ptr Word8, Word16, Word16 #)
85+eatShader pos end row col =
86+ if pos >= end then
87+ (# Unending, pos, row, col #)
88+
89+ else
90+ let !word = P.unsafeIndex pos in
91+ if word == 0x007C {- | -} && P.isWord (plusPtr pos 1) end 0x5D {- ] -} then
92+ (# Good, pos, row, col + 2 #)
93+
94+ else if word == 0x0A {- \n -} then
95+ eatShader (plusPtr pos 1) end (row + 1) 1
96+
97+ else
98+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
99+ eatShader newPos end row (col + 1)
100+
101+
102+
103+-- GLSL
104+
105+
40−parseSource :: Int -> Int -> String -> Parser Shader.Shader
106+parseGlsl :: Word16 -> Word16 -> String -> Parser Shader.Types
41−parseSource startRow startCol src =
107+parseGlsl startRow startCol src =
42 case GLP.parse src of
108 case GLP.parse src of
43 Right (GLS.TranslationUnit decls) ->
109 Right (GLS.TranslationUnit decls) ->
44− return (foldr addInput emptyShader (concatMap extractInputs decls))
110+ return (foldr addInput emptyTypes (concatMap extractInputs decls))
45
111
46 Left err ->
112 Left err ->
47 let
113 let
48 pos = Parsec.errorPos err
114 pos = Parsec.errorPos err
49− row = Parsec.sourceLine pos
115+ row = fromIntegral (Parsec.sourceLine pos)
50− col = Parsec.sourceColumn pos
116+ col = fromIntegral (Parsec.sourceColumn pos)
51 msg =
117 msg =
52 Parsec.showErrorMessages
118 Parsec.showErrorMessages
53 "or"
119 "or"
@@ -58,22 +124,32 @@ parseSource startRow startCol src =
58 (Parsec.errorMessages err)
124 (Parsec.errorMessages err)
59 in
125 in
60 if row == 1 then
126 if row == 1 then
61− Shader.failure startRow (startCol + 6 + col) (Text.pack msg)
127+ failure startRow (startCol + 6 + col) msg
62 else
128 else
63− Shader.failure (startRow + row - 1) col (Text.pack msg)
129+ failure (startRow + row - 1) col msg
130+
64
131
132+failure :: Word16 -> Word16 -> String -> Parser a
133+failure row col msg =
134+ P.Parser $ \(P.State _ _ _ _ _ ctx) _ _ cerr _ ->
135+ cerr row col ctx (E.ShaderValid msg)
65
136
66−emptyShader :: Shader.Shader
67−emptyShader =
68− Shader.Shader Map.empty Map.empty Map.empty
69
137
70
138
139+-- INPUTS
140+
141+
142+emptyTypes :: Shader.Types
143+emptyTypes =
144+ Shader.Types Map.empty Map.empty Map.empty
145+
146+
71−addInput :: (GLS.StorageQualifier, Shader.Type, String) -> Shader.Shader -> Shader.Shader
147+addInput :: (GLS.StorageQualifier, Shader.Type, String) -> Shader.Types -> Shader.Types
72addInput (qual, tipe, name) glDecls =
148addInput (qual, tipe, name) glDecls =
73 case qual of
149 case qual of
74− GLS.Attribute -> glDecls { Shader._attribute = Map.insert (Name.fromString name) tipe (Shader._attribute glDecls) }
150+ GLS.Attribute -> glDecls { Shader._attribute = Map.insert (Name.fromChars name) tipe (Shader._attribute glDecls) }
75− GLS.Uniform -> glDecls { Shader._uniform = Map.insert (Name.fromString name) tipe (Shader._uniform glDecls) }
151+ GLS.Uniform -> glDecls { Shader._uniform = Map.insert (Name.fromChars name) tipe (Shader._uniform glDecls) }
76− GLS.Varying -> glDecls { Shader._varying = Map.insert (Name.fromString name) tipe (Shader._varying glDecls) }
152+ GLS.Varying -> glDecls { Shader._varying = Map.insert (Name.fromChars name) tipe (Shader._varying glDecls) }
77 _ -> error "Should never happen due to `extractInputs` function"
153 _ -> error "Should never happen due to `extractInputs` function"
78
154
79
155
@@ -101,3 +177,5 @@ extractInputs decl =
101 GLS.Sampler2D -> [(qual, Shader.Texture, name)]
177 GLS.Sampler2D -> [(qual, Shader.Texture, name)]
102 _ -> []
178 _ -> []
103 _ -> []
179 _ -> []
180+
181+
compiler/src/Parse/Symbol.hsnew file+94
@@ -0,0 +1,94 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}
3+module Parse.Symbol
4+ ( underscore
5+ , binop
6+ )
7+ where
8+
9+
10+import qualified Data.Char as Char
11+import qualified Data.IntSet as IntSet
12+import qualified Data.Name as Name
13+import qualified Data.Vector as Vector
14+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
15+import GHC.Word (Word8)
16+
17+import Parse.Utils
18+import qualified Parse.Variable as Var
19+import qualified Parse.Primitives as P
20+import qualified Reporting.Error.Syntax as E
21+
22+
23+
24+-- UNDERSCORE
25+
26+
27+underscore :: Parser ()
28+underscore =
29+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->
30+ if pos == end || P.unsafeIndex pos /= 0x5F {- _ -} then
31+ eerr row col ctx E.Underscore
32+ else
33+ let
34+ !newPos = plusPtr pos 1
35+ !newCol = col + 1
36+ in
37+ if Var.getInnerWidth newPos end > 0 then
38+ let (# _, badCol #) = Var.chompInnerChars newPos end newCol in
39+ cerr row newCol ctx (E.UnderscoreNotVar (fromIntegral (badCol - newCol)))
40+ else
41+ let !newState = P.State newPos end indent row newCol ctx in
42+ cok () newState
43+
44+
45+
46+-- BINOP
47+
48+
49+binop :: Parser Name.Name
50+binop =
51+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->
52+ let !newPos = chompOps pos end in
53+ if pos == newPos then
54+ eerr row col ctx E.Binop
55+
56+ else
57+ case Name.fromPtr pos newPos of
58+ "." -> cerr row col ctx (E.ReservedBinop E.Dot)
59+ "|" -> cerr row col ctx (E.ReservedBinop E.Pipe)
60+ "->" -> cerr row col ctx (E.ReservedBinop E.Arrow)
61+ "=" -> cerr row col ctx (E.ReservedBinop E.Equals)
62+ ":" -> cerr row col ctx (E.ReservedBinop E.HasType)
63+ op ->
64+ let
65+ !newCol = col + fromIntegral (minusPtr newPos pos)
66+ !newState = P.State newPos end indent row newCol ctx
67+ in
68+ cok op newState
69+
70+
71+chompOps :: Ptr Word8 -> Ptr Word8 -> Ptr Word8
72+chompOps pos end =
73+ if pos < end && isBinopCharHelp (P.unsafeIndex pos) then
74+ chompOps (plusPtr pos 1) end
75+ else
76+ pos
77+
78+
79+{-# INLINE isBinopCharHelp #-}
80+isBinopCharHelp :: Word8 -> Bool
81+isBinopCharHelp word =
82+ word < 128 && Vector.unsafeIndex binopCharVector (fromIntegral word)
83+
84+
85+{-# NOINLINE binopCharVector #-}
86+binopCharVector :: Vector.Vector Bool
87+binopCharVector =
88+ Vector.generate 128 (\i -> IntSet.member i binopCharSet)
89+
90+
91+{-# NOINLINE binopCharSet #-}
92+binopCharSet :: IntSet.IntSet
93+binopCharSet =
94+ IntSet.fromList (map Char.ord "+-/*=.<>:&|^?%!")
compiler/src/Parse/Type.hs+76−100
@@ -10,14 +10,11 @@ module Parse.Type
10import qualified Data.Name as Name
10import qualified Data.Name as Name
11
11
12import qualified AST.Source as Src
12import qualified AST.Source as Src
13+import Parse.Primitives (addLocation, getPosition, inContext, oneOf, word1, word2)
13−import Parse.Primitives (Parser, SParser, addLocation, checkSpace, getPosition, hint, spaces, oneOf)
14+import Parse.Utils (Parser, SParser, SPos, checkSpace, spaces, whitespace)
14−import qualified Parse.Primitives as P
15+import qualified Parse.Variable as Var
15−import qualified Parse.Primitives.Symbol as Symbol
16−import qualified Parse.Primitives.Variable as Var
17−import Parse.Primitives.Whitespace (SPos, whitespace)
18import qualified Reporting.Annotation as A
16import qualified Reporting.Annotation as A
19import qualified Reporting.Error.Syntax as E
17import qualified Reporting.Error.Syntax as E
20−import qualified Reporting.Region as R
21
18
22
19
23
20
@@ -26,25 +23,64 @@ import qualified Reporting.Region as R
26
23
27term :: Parser Src.Type
24term :: Parser Src.Type
28term =
25term =
29− hint E.Type $
30− do start <- getPosition
26+ do start <- getPosition
31− oneOf
27+ oneOf E.XXX
32− [ app0
28+ [
33− , variable start
29+ -- types with no arguments (Int, Float, etc.)
34− , tuple start
30+ do upper <- Var.foreignUpper
35− , record start
31+ end <- getPosition
36− ]
32+ let region = A.Region start end
37−
33+ return $ A.At region $
38−
34+ case upper of
39−
35+ Var.Unqualified name ->
40−-- TYPE VARIABLES
36+ Src.TType region name []
41−
37+
42−
38+ Var.Qualified home name ->
43−variable :: R.Position -> Parser Src.Type
39+ Src.TTypeQual region home name []
44−variable start =
40+ ,
41+ -- type variables
45− do var <- Var.lower
42+ do var <- Var.lower
46− end <- getPosition
43+ end <- getPosition
47− return (A.at start end (Src.TVar var))
44+ return (A.at start end (Src.TVar var))
45+ ,
46+ -- tuples
47+ inContext E.TypeTuple (word1 0x28 {-(-} E.XXX) $
48+ oneOf E.XXX
49+ [ do word1 0x29 {-)-} E.XXX
50+ end <- getPosition
51+ return (A.at start end Src.TUnit)
52+ , do spaces
53+ (tipe, _, pos) <- expression
54+ checkSpace pos
55+ tupleEnding start tipe []
56+ ]
57+ ,
58+ -- records
59+ inContext E.TypeRecord (word1 0x7B {- { -} E.XXX) $
60+ do spaces
61+ oneOf E.XXX
62+ [ do word1 0x7D {-}-} E.XXX
63+ end <- getPosition
64+ return (A.at start end (Src.TRecord [] Nothing))
65+ , do var <- addLocation Var.lower
66+ spaces
67+ oneOf E.XXX
68+ [ do word1 0x7C {-|-} E.XXX
69+ spaces
70+ firstField <- field
71+ fields <- chompFields [firstField]
72+ end <- getPosition
73+ return (A.at start end (Src.TRecord fields (Just var)))
74+ , do word1 0x3A {-:-} E.XXX
75+ spaces
76+ (tipe, _, nextPos) <- expression
77+ checkSpace nextPos
78+ fields <- chompFields [(var, tipe)]
79+ end <- getPosition
80+ return (A.at start end (Src.TRecord fields Nothing))
81+ ]
82+ ]
83+ ]
48
84
49
85
50
86
@@ -53,16 +89,15 @@ variable start =
53
89
54expression :: SParser Src.Type
90expression :: SParser Src.Type
55expression =
91expression =
56− hint E.Type $
57 do start <- getPosition
92 do start <- getPosition
58 (tipe1, end1, pos1) <-
93 (tipe1, end1, pos1) <-
59− oneOf
94+ oneOf E.XXX
60 [ app start
95 [ app start
61 , (,,) <$> term <*> getPosition <*> whitespace
96 , (,,) <$> term <*> getPosition <*> whitespace
62 ]
97 ]
63− oneOf
98+ oneOf E.XXX
64 [ do checkSpace pos1
99 [ do checkSpace pos1
65− Symbol.rightArrow
100+ word2 0x2D 0x3E {-->-} E.XXX
66 spaces
101 spaces
67 (tipe2, end2, pos2) <- expression
102 (tipe2, end2, pos2) <- expression
68 let tipe = A.at start end2 (Src.TLambda tipe1 tipe2)
103 let tipe = A.at start end2 (Src.TLambda tipe1 tipe2)
@@ -75,29 +110,14 @@ expression =
75-- TYPE CONSTRUCTORS
110-- TYPE CONSTRUCTORS
76
111
77
112
78−app0 :: Parser Src.Type
79−app0 =
80− do start <- getPosition
81− upper <- Var.foreignUpper
82− end <- getPosition
83− let region = R.Region start end
84− return $ A.At region $
85− case upper of
86− Var.Unqualified name ->
87− Src.TType region name []
88−
89− Var.Qualified home name ->
90− Src.TTypeQual region home name []
91−
92−
93−app :: R.Position -> SParser Src.Type
113+app :: A.Position -> SParser Src.Type
94app start =
114app start =
95 do upper <- Var.foreignUpper
115 do upper <- Var.foreignUpper
96 nameEnd <- getPosition
116 nameEnd <- getPosition
97 namePos <- whitespace
117 namePos <- whitespace
98 (args, end, pos) <- eatArgs [] nameEnd namePos
118 (args, end, pos) <- eatArgs [] nameEnd namePos
99
119
100− let region = R.Region start nameEnd
120+ let region = A.Region start nameEnd
101 let tipe =
121 let tipe =
102 case upper of
122 case upper of
103 Var.Unqualified name ->
123 Var.Unqualified name ->
@@ -119,9 +139,9 @@ unionConstructor =
119 return ( (A.at start nameEnd name, args), end, pos )
139 return ( (A.at start nameEnd name, args), end, pos )
120
140
121
141
122−eatArgs :: [Src.Type] -> R.Position -> SPos -> SParser [Src.Type]
142+eatArgs :: [Src.Type] -> A.Position -> SPos -> SParser [Src.Type]
123eatArgs args end pos =
143eatArgs args end pos =
124− oneOf
144+ oneOf E.XXX
125 [ do checkSpace pos
145 [ do checkSpace pos
126 arg <- term
146 arg <- term
127 newEnd <- getPosition
147 newEnd <- getPosition
@@ -135,30 +155,15 @@ eatArgs args end pos =
135-- TUPLES
155-- TUPLES
136
156
137
157
138−tuple :: R.Position -> Parser Src.Type
139−tuple start =
140− do Symbol.leftParen
141− P.inContext start E.TypeTuple $
142− oneOf
143− [ do Symbol.rightParen
144− end <- getPosition
145− return (A.at start end Src.TUnit)
146− , do spaces
147− (tipe, _, pos) <- expression
148− checkSpace pos
149− tupleEnding start tipe []
150− ]
151−
152−
153−tupleEnding :: R.Position -> Src.Type -> [Src.Type] -> Parser Src.Type
158+tupleEnding :: A.Position -> Src.Type -> [Src.Type] -> Parser Src.Type
154tupleEnding start firstType revTypes =
159tupleEnding start firstType revTypes =
155− oneOf
160+ oneOf E.XXX
156− [ do Symbol.comma
161+ [ do word1 0x2C {-,-} E.XXX
157 spaces
162 spaces
158 (tipe, _, pos) <- expression
163 (tipe, _, pos) <- expression
159 checkSpace pos
164 checkSpace pos
160 tupleEnding start firstType (tipe : revTypes)
165 tupleEnding start firstType (tipe : revTypes)
161− , do Symbol.rightParen
166+ , do word1 0x29 {-)-} E.XXX
162 end <- getPosition
167 end <- getPosition
163 case reverse revTypes of
168 case reverse revTypes of
164 [] ->
169 [] ->
@@ -174,46 +179,17 @@ tupleEnding start firstType revTypes =
174-- RECORD
179-- RECORD
175
180
176
181
177−record :: R.Position -> Parser Src.Type
178−record start =
179− do Symbol.leftCurly
180− P.inContext start E.TypeRecord $
181− do spaces
182− oneOf
183− [ do Symbol.rightCurly
184− end <- getPosition
185− return (A.at start end (Src.TRecord [] Nothing))
186− , do var <- addLocation Var.lower
187− spaces
188− oneOf
189− [ do Symbol.pipe
190− spaces
191− firstField <- field
192− fields <- chompFields [firstField]
193− end <- getPosition
194− return (A.at start end (Src.TRecord fields (Just var)))
195− , do Symbol.hasType
196− spaces
197− (tipe, _, nextPos) <- expression
198− checkSpace nextPos
199− fields <- chompFields [(var, tipe)]
200− end <- getPosition
201− return (A.at start end (Src.TRecord fields Nothing))
202− ]
203− ]
204−
205−
206type Field = ( A.Located Name.Name, Src.Type )
182type Field = ( A.Located Name.Name, Src.Type )
207
183
208
184
209chompFields :: [Field] -> Parser [Field]
185chompFields :: [Field] -> Parser [Field]
210chompFields fields =
186chompFields fields =
211− oneOf
187+ oneOf E.XXX
212− [ do Symbol.comma
188+ [ do word1 0x2C {-,-} E.XXX
213 spaces
189 spaces
214 f <- field
190 f <- field
215 chompFields (f : fields)
191 chompFields (f : fields)
216− , do Symbol.rightCurly
192+ , do word1 0x7D {-}-} E.XXX
217 return (reverse fields)
193 return (reverse fields)
218 ]
194 ]
219
195
@@ -222,7 +198,7 @@ field :: Parser Field
222field =
198field =
223 do name <- addLocation Var.lower
199 do name <- addLocation Var.lower
224 spaces
200 spaces
225− Symbol.hasType
201+ word1 0x3A {-:-} E.XXX
226 spaces
202 spaces
227 (tipe, _, endPos) <- expression
203 (tipe, _, endPos) <- expression
228 checkSpace endPos
204 checkSpace endPos
compiler/src/Parse/Utf8.hsnew file+333
@@ -0,0 +1,333 @@
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2+{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
3+module Parse.Utf8
4+ ( string
5+ , character
6+ )
7+ where
8+
9+
10+import qualified Data.Utf8 as Utf8
11+import Data.Word (Word8, Word16)
12+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
13+
14+import Parse.Utils (Parser)
15+import qualified Parse.Number as Number
16+import qualified Parse.Primitives as P
17+import qualified Reporting.Error.Syntax as E
18+
19+
20+
21+-- CHARACTER
22+
23+
24+character :: Parser Utf8.String
25+character =
26+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->
27+ if pos >= end || P.unsafeIndex pos /= 0x27 {- ' -} then
28+ eerr row col ctx E.CharStart
29+
30+ else
31+ case chompChar (plusPtr pos 1) end (col + 1) 0 placeholder of
32+ Good newPos newCol numChars mostRecent ->
33+ if numChars /= 1 then
34+ cerr row col ctx (E.CharNotString col newCol)
35+ else
36+ let
37+ !newState = P.State newPos end indent row newCol ctx
38+ !char = Utf8.fromChunks [mostRecent]
39+ in
40+ cok char newState
41+
42+ Bad newCol x ->
43+ cerr row newCol ctx x
44+
45+
46+data CharResult
47+ = Good (Ptr Word8) Word16 Int Utf8.Chunk
48+ | Bad Word16 E.Expectation
49+
50+
51+chompChar :: Ptr Word8 -> Ptr Word8 -> Word16 -> Int -> Utf8.Chunk -> CharResult
52+chompChar pos end col numChars mostRecent =
53+ if pos >= end then
54+ Bad col E.CharEnd
55+
56+ else
57+ let
58+ !word = P.unsafeIndex pos
59+ in
60+ if word == 0x27 {- ' -} then
61+ Good (plusPtr pos 1) (col + 1) numChars mostRecent
62+
63+ else if word == 0x0A {- \n -} then
64+ Bad col E.CharEnd
65+
66+ else if word == 0x22 {- " -} then
67+ chompChar (plusPtr pos 1) end (col + 1) (numChars + 1) doubleQuote
68+
69+ else if word == 0x5C {- \ -} then
70+ case eatEscape (plusPtr pos 1) end col of
71+ EscapeNormal ->
72+ chompChar (plusPtr pos 2) end (col + 2) (numChars + 1) (Utf8.Slice pos 2)
73+
74+ EscapeUnicode delta code ->
75+ chompChar (plusPtr pos delta) end (col + fromIntegral delta) (numChars + 1) (Utf8.CodePoint code)
76+
77+ EscapeProblem x ->
78+ Bad col x
79+
80+ EscapeEndOfFile ->
81+ Bad (col + 1) E.CharEnd
82+
83+ else
84+ let
85+ !width = P.getCharWidth pos end word
86+ !newPos = plusPtr pos width
87+ in
88+ chompChar newPos end (col + 1) (numChars + 1) (Utf8.Slice pos width)
89+
90+
91+
92+-- STRINGS
93+
94+
95+string :: Parser Utf8.String
96+string =
97+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->
98+ if isDoubleQuote pos end then
99+
100+ let
101+ !pos1 = plusPtr pos 1
102+ result =
103+ if isDoubleQuote pos1 end && isDoubleQuote (plusPtr pos 2) end then
104+ multiString (plusPtr pos 3) end row (col + 3) (plusPtr pos 3) mempty
105+ else
106+ singleString pos1 end row (col + 1) pos1 mempty
107+ in
108+ case result of
109+ Ok newPos newRow newCol utf8 ->
110+ let
111+ !newState =
112+ P.State newPos end indent newRow newCol ctx
113+ in
114+ cok utf8 newState
115+
116+ Err r c x ->
117+ cerr r c ctx x
118+
119+ else
120+ eerr row col ctx E.StringStart
121+
122+
123+{-# INLINE isDoubleQuote #-}
124+isDoubleQuote :: Ptr Word8 -> Ptr Word8 -> Bool
125+isDoubleQuote pos end =
126+ pos < end && P.unsafeIndex pos == 0x22 {- " -}
127+
128+
129+data StringResult
130+ = Ok (Ptr Word8) Word16 Word16 Utf8.String
131+ | Err Word16 Word16 E.Expectation
132+
133+
134+finalize :: Ptr Word8 -> Ptr Word8 -> [Utf8.Chunk] -> Utf8.String
135+finalize start end revChunks =
136+ Utf8.fromChunks $ reverse $
137+ if start == end then
138+ revChunks
139+ else
140+ Utf8.Slice start (minusPtr end start) : revChunks
141+
142+
143+addEscape :: Utf8.Chunk -> Ptr Word8 -> Ptr Word8 -> [Utf8.Chunk] -> [Utf8.Chunk]
144+addEscape chunk start end revChunks =
145+ if start == end then
146+ chunk : revChunks
147+ else
148+ chunk : Utf8.Slice start (minusPtr end start) : revChunks
149+
150+
151+
152+-- SINGLE STRINGS
153+
154+
155+singleString :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> [Utf8.Chunk] -> StringResult
156+singleString pos end row col initialPos revChunks =
157+ if pos >= end then
158+ Err row col E.StringEnd_Single
159+
160+ else
161+ let
162+ !word = P.unsafeIndex pos
163+ in
164+ if word == 0x22 {- " -} then
165+ Ok (plusPtr pos 1) row (col + 1) $
166+ finalize initialPos pos revChunks
167+
168+ else if word == 0x0A {- \n -} then
169+ Err row col E.StringEnd_Single
170+
171+ else if word == 0x27 {- ' -} then
172+ let !newPos = plusPtr pos 1 in
173+ singleString newPos end row (col + 1) newPos $
174+ addEscape singleQuote initialPos pos revChunks
175+
176+ else if word == 0x5C {- \ -} then
177+ case eatEscape (plusPtr pos 1) end col of
178+ EscapeNormal ->
179+ singleString (plusPtr pos 2) end row (col + 2) initialPos revChunks
180+
181+ EscapeUnicode delta code ->
182+ let !newPos = plusPtr pos delta in
183+ singleString newPos end row (col + fromIntegral delta) newPos $
184+ addEscape (Utf8.CodePoint code) initialPos pos revChunks
185+
186+ EscapeProblem x ->
187+ Err row col x
188+
189+ EscapeEndOfFile ->
190+ Err row (col + 1) E.StringEnd_Single
191+
192+ else
193+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
194+ singleString newPos end row (col + 1) initialPos revChunks
195+
196+
197+
198+-- MULTI STRINGS
199+
200+
201+multiString :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> [Utf8.Chunk] -> StringResult
202+multiString pos end row col initialPos revChunks =
203+ if pos >= end then
204+ Err row col E.StringEnd_Multi
205+
206+ else
207+ let !word = P.unsafeIndex pos in
208+ if word == 0x22 {- " -} && isDoubleQuote (plusPtr pos 1) end && isDoubleQuote (plusPtr pos 2) end then
209+ Ok (plusPtr pos 3) row (col + 3) $
210+ finalize initialPos pos revChunks
211+
212+ else if word == 0x27 {- ' -} then
213+ let !pos1 = plusPtr pos 1 in
214+ multiString pos1 end row (col + 1) pos1 $
215+ addEscape singleQuote initialPos pos revChunks
216+
217+ else if word == 0x0A {- \n -} then
218+ let !pos1 = plusPtr pos 1 in
219+ multiString pos1 end (row + 1) 1 pos1 $
220+ addEscape newline initialPos pos revChunks
221+
222+ else if word == 0x0D {- \r -} then
223+ let !pos1 = plusPtr pos 1 in
224+ multiString pos1 end row col pos1 $
225+ addEscape carriageReturn initialPos pos revChunks
226+
227+ else if word == 0x5C {- \ -} then
228+ case eatEscape (plusPtr pos 1) end col of
229+ EscapeNormal ->
230+ multiString (plusPtr pos 2) end row (col + 2) initialPos revChunks
231+
232+ EscapeUnicode delta code ->
233+ let !newPos = plusPtr pos delta in
234+ multiString newPos end row (col + fromIntegral delta) newPos $
235+ addEscape (Utf8.CodePoint code) initialPos pos revChunks
236+
237+ EscapeProblem x ->
238+ Err row col x
239+
240+ EscapeEndOfFile ->
241+ Err row (col + 1) E.StringEnd_Multi
242+
243+ else
244+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
245+ multiString newPos end row (col + 1) initialPos revChunks
246+
247+
248+
249+-- ESCAPE CHARACTERS
250+
251+
252+data Escape
253+ = EscapeNormal
254+ | EscapeUnicode !Int !Int
255+ | EscapeEndOfFile
256+ | EscapeProblem E.Expectation
257+
258+
259+eatEscape :: Ptr Word8 -> Ptr Word8 -> Word16 -> Escape
260+eatEscape pos end startCol =
261+ if pos >= end then
262+ EscapeEndOfFile
263+
264+ else
265+ case P.unsafeIndex pos of
266+ 0x6E {- n -} -> EscapeNormal
267+ 0x72 {- r -} -> EscapeNormal
268+ 0x74 {- t -} -> EscapeNormal
269+ 0x22 {- " -} -> EscapeNormal
270+ 0x27 {- ' -} -> EscapeNormal
271+ 0x5C {- \ -} -> EscapeNormal
272+ 0x75 {- u -} -> eatUnicode (plusPtr pos 1) end startCol
273+ _ -> EscapeProblem (E.EscapeUnknown startCol (startCol + 1))
274+
275+
276+eatUnicode :: Ptr Word8 -> Ptr Word8 -> Word16 -> Escape
277+eatUnicode pos end startCol =
278+ if pos >= end || P.unsafeIndex pos /= 0x7B {- { -} then
279+ EscapeProblem $ E.BadUnicodeStart startCol (startCol + 1)
280+ else
281+ let
282+ !digitPos = plusPtr pos 1
283+ (# newPos, code #) = Number.chompHex digitPos end
284+ !numDigits = minusPtr newPos digitPos
285+ in
286+ if newPos >= end || P.unsafeIndex newPos /= 0x7D {- } -} then
287+ EscapeProblem $ E.BadUnicodeEnd startCol $
288+ startCol + fromIntegral (minusPtr newPos pos)
289+
290+ else if code < 0 || 0x10FFFF < code then
291+ EscapeProblem $ E.BadUnicodeRange startCol $
292+ startCol + fromIntegral (minusPtr newPos pos) + 1
293+
294+ else if numDigits < 4 || 6 < numDigits then
295+ EscapeProblem $
296+ E.BadUnicodeFormat
297+ startCol
298+ (startCol + fromIntegral (minusPtr newPos pos) + 1)
299+ numDigits
300+ (Utf8.fromPtr digitPos newPos)
301+
302+ else
303+ EscapeUnicode (numDigits + 4) code
304+
305+
306+{-# NOINLINE singleQuote #-}
307+singleQuote :: Utf8.Chunk
308+singleQuote =
309+ Utf8.Escape 0x27 {- ' -}
310+
311+
312+{-# NOINLINE doubleQuote #-}
313+doubleQuote :: Utf8.Chunk
314+doubleQuote =
315+ Utf8.Escape 0x22 {- " -}
316+
317+
318+{-# NOINLINE newline #-}
319+newline :: Utf8.Chunk
320+newline =
321+ Utf8.Escape 0x6E {- n -}
322+
323+
324+{-# NOINLINE carriageReturn #-}
325+carriageReturn :: Utf8.Chunk
326+carriageReturn =
327+ Utf8.Escape 0x72 {- \r -}
328+
329+
330+{-# NOINLINE placeholder #-}
331+placeholder :: Utf8.Chunk
332+placeholder =
333+ Utf8.CodePoint 0xFFFD {- replacement character -}
compiler/src/Parse/Utils.hsnew file+256
@@ -0,0 +1,256 @@
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2+{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}
3+module Parse.Utils
4+ ( Parser
5+ , SParser
6+ , SPos(..)
7+ , spaces, noSpace, checkSpace, checkAligned, checkFreshLine
8+ , whitespace
9+ , docComment
10+ )
11+ where
12+
13+
14+import Data.Word (Word8, Word16)
15+import Foreign.Ptr (Ptr, plusPtr)
16+
17+import qualified Parse.Primitives as P
18+import qualified Reporting.Annotation as A
19+import qualified Reporting.Error.Syntax as E
20+
21+
22+
23+-- PARSERS
24+
25+
26+type Parser a =
27+ P.Parser E.Context E.Expectation a
28+
29+
30+type SParser a =
31+ P.Parser E.Context E.Expectation (a, A.Position, SPos)
32+
33+
34+
35+-- WHITESPACE VARIATIONS
36+
37+
38+spaces :: Parser ()
39+spaces =
40+ checkSpace =<< whitespace
41+
42+
43+noSpace :: A.Position -> SPos -> Parser ()
44+noSpace pos (SPos spos) =
45+ if pos == spos
46+ then return ()
47+ else error "TODO what is this again? can it be written better?"
48+
49+
50+checkSpace :: SPos -> Parser ()
51+checkSpace (SPos (A.Position _ col)) =
52+ do indent <- P.getIndent
53+ if col > indent && col > 1
54+ then return ()
55+ else error "TODO what is this again? can it be written better?"
56+
57+
58+checkAligned :: SPos -> Parser ()
59+checkAligned (SPos (A.Position _ col)) =
60+ do indent <- P.getIndent
61+ if col == indent
62+ then return ()
63+ else error "TODO what is this again? can it be written better?"
64+
65+
66+checkFreshLine :: SPos -> Parser ()
67+checkFreshLine (SPos (A.Position _ col)) =
68+ if col == 1
69+ then return ()
70+ else error "TODO what is this again?"
71+
72+
73+-- WHITESPACE
74+
75+
76+newtype SPos = SPos A.Position
77+
78+
79+whitespace :: Parser SPos
80+whitespace =
81+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
82+ let
83+ (# status, newPos, newRow, newCol #) =
84+ eatSpaces pos end row col
85+ in
86+ case status of
87+ Good ->
88+ let
89+ !spos = SPos (A.Position newRow newCol)
90+ !newState = P.State newPos end indent newRow newCol ctx
91+ in
92+ cok spos newState
93+
94+ HasTab ->
95+ eerr newRow newCol ctx E.NoTabs
96+
97+ UnendingMultiComment ->
98+ eerr newRow newCol ctx E.MultiCommentEnd
99+
100+
101+data Status
102+ = Good
103+ | HasTab
104+ | UnendingMultiComment
105+
106+
107+
108+-- EAT SPACES
109+
110+
111+eatSpaces :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Status, Ptr Word8, Word16, Word16 #)
112+eatSpaces pos end row col =
113+ if pos >= end then
114+ (# Good, pos, row, col #)
115+
116+ else
117+ case P.unsafeIndex pos of
118+ 0x20 {- -} ->
119+ eatSpaces (plusPtr pos 1) end row (col + 1)
120+
121+ 0x0A {- \n -} ->
122+ eatSpaces (plusPtr pos 1) end (row + 1) 1
123+
124+ 0x7B {- { -} ->
125+ eatMultiComment pos end row col
126+
127+ 0x2D {- - -} ->
128+ let !pos1 = plusPtr pos 1 in
129+ if pos1 < end && P.unsafeIndex pos1 == 0x2D {- - -} then
130+ eatLineComment (plusPtr pos 2) end row (col + 2)
131+ else
132+ (# Good, pos, row, col #)
133+
134+ 0x0D {- \r -} ->
135+ eatSpaces (plusPtr pos 1) end row col
136+
137+ 0x09 {- \t -} ->
138+ (# HasTab, pos, row, col #)
139+
140+ _ ->
141+ (# Good, pos, row, col #)
142+
143+
144+
145+-- LINE COMMENTS
146+
147+
148+eatLineComment :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Status, Ptr Word8, Word16, Word16 #)
149+eatLineComment pos end row col =
150+ if pos >= end then
151+ (# Good, pos, row, col #)
152+
153+ else
154+ let !word = P.unsafeIndex pos in
155+ if word == 0x0A {- \n -} then
156+ eatSpaces (plusPtr pos 1) end (row + 1) 1
157+ else
158+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
159+ eatLineComment newPos end row (col + 1)
160+
161+
162+
163+-- MULTI COMMENTS
164+
165+
166+eatMultiComment :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Status, Ptr Word8, Word16, Word16 #)
167+eatMultiComment pos end row col =
168+ let
169+ !pos1 = plusPtr pos 1
170+ !pos2 = plusPtr pos 2
171+ in
172+ if pos2 >= end then
173+ (# Good, pos, row, col #)
174+
175+ else
176+ let
177+ !yesDash = P.unsafeIndex pos1 == 0x2D {- - -}
178+ !noBar = P.unsafeIndex pos2 /= 0x7C {- | -}
179+ in
180+ if yesDash && noBar then
181+ let
182+ (# status, newPos, newRow, newCol #) =
183+ eatMultiCommentHelp pos2 end row (col + 2) 1
184+ in
185+ case status of
186+ Good ->
187+ eatSpaces newPos end newRow newCol
188+
189+ HasTab ->
190+ (# status, newPos, newRow, newCol #)
191+
192+ UnendingMultiComment ->
193+ (# status, newPos, newRow, newCol #)
194+
195+ else
196+ (# Good, pos, row, col #)
197+
198+
199+eatMultiCommentHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Int -> (# Status, Ptr Word8, Word16, Word16 #)
200+eatMultiCommentHelp pos end row col openComments =
201+ if pos >= end then
202+ (# UnendingMultiComment, pos, row, col #)
203+
204+ else
205+ let !word = P.unsafeIndex pos in
206+ if word == 0x0A {- \n -} then
207+ eatMultiCommentHelp (plusPtr pos 1) end (row + 1) 1 openComments
208+
209+ else if word == 0x2D {- - -} && P.isWord (plusPtr pos 1) end 0x7D {- } -} then
210+ if openComments == 1 then
211+ (# Good, plusPtr pos 2, row, col + 2 #)
212+ else
213+ eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments - 1)
214+
215+ else if word == 0x7B {- { -} && P.isWord (plusPtr pos 1) end 0x2D {- - -} then
216+ eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments + 1)
217+
218+ else
219+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
220+ eatMultiCommentHelp newPos end row (col + 1) openComments
221+
222+
223+
224+-- DOCUMENTATION COMMENT
225+
226+
227+docComment :: Parser ()
228+docComment =
229+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
230+ let
231+ !pos3 = plusPtr pos 3
232+ in
233+ if pos3 <= end
234+ && P.unsafeIndex ( pos ) == 0x7B {- { -}
235+ && P.unsafeIndex (plusPtr pos 1) == 0x2D {- - -}
236+ && P.unsafeIndex (plusPtr pos 2) == 0x7C {- | -}
237+ then
238+ let
239+ (# status, newPos, newRow, newCol #) =
240+ eatMultiCommentHelp pos3 end row col 1
241+ in
242+ case status of
243+ Good ->
244+ let
245+ !newState = P.State newPos end indent newRow newCol ctx
246+ in
247+ cok () newState
248+
249+ HasTab ->
250+ eerr newRow newCol ctx E.NoTabs
251+
252+ UnendingMultiComment ->
253+ eerr newRow newCol ctx E.MultiCommentEnd
254+
255+ else
256+ eerr row col ctx E.DocComment
compiler/src/Parse/Variable.hsnew file+382
@@ -0,0 +1,382 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, OverloadedStrings #-}
3+module Parse.Variable
4+ ( lower
5+ , upper
6+ , moduleName
7+ , Upper(..)
8+ , foreignUpper
9+ , foreignAlpha
10+ , chompInnerChars
11+ , getInnerWidth
12+ , getInnerWidthHelp
13+ )
14+ where
15+
16+
17+import qualified Data.Char as Char
18+import qualified Data.Name as Name
19+import qualified Data.Set as Set
20+import Data.Word (Word8, Word16)
21+import Foreign.Ptr (Ptr, plusPtr)
22+import GHC.Exts (Char(C#), Int#, (+#), (-#), chr#, uncheckedIShiftL#, word2Int#)
23+import GHC.Word (Word8(W8#))
24+
25+import qualified AST.Source as Src
26+import Parse.Utils (Parser)
27+import Parse.Primitives (unsafeIndex)
28+import qualified Parse.Primitives as P
29+import qualified Reporting.Error.Syntax as E
30+
31+
32+
33+-- LOCAL UPPER
34+
35+
36+upper :: Parser Name.Name
37+upper =
38+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
39+ let (# newPos, newCol #) = chompUpper pos end col in
40+ if pos == newPos then
41+ eerr row col ctx E.Upper
42+ else
43+ let !name = Name.fromPtr pos newPos in
44+ cok name (P.State newPos end indent row newCol ctx)
45+
46+
47+
48+-- LOCAL LOWER
49+
50+
51+lower :: Parser Name.Name
52+lower =
53+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
54+ let (# newPos, newCol #) = chompLower pos end col in
55+ if pos == newPos then
56+ eerr row col ctx E.Lower
57+ else
58+ let !name = Name.fromPtr pos newPos in
59+ if Set.member name reservedWords then
60+ eerr row col ctx E.Lower
61+ else
62+ let
63+ !newState =
64+ P.State newPos end indent row newCol ctx
65+ in
66+ cok name newState
67+
68+
69+{-# NOINLINE reservedWords #-}
70+reservedWords :: Set.Set Name.Name
71+reservedWords =
72+ Set.fromList
73+ [ "if", "then", "else"
74+ , "case", "of"
75+ , "let", "in"
76+ , "type"
77+ , "module", "where"
78+ , "import", "exposing"
79+ , "as"
80+ , "port"
81+ ]
82+
83+
84+
85+-- MODULE NAME
86+
87+
88+moduleName :: Parser Name.Name
89+moduleName =
90+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
91+ let
92+ (# pos1, col1 #) = chompUpper pos end col
93+ (# status, newPos, newCol #) = moduleNameHelp pos1 end col1
94+ in
95+ case status of
96+ Good ->
97+ let
98+ !name = Name.fromPtr pos newPos
99+ !newState = P.State newPos end indent row newCol ctx
100+ in
101+ cok name newState
102+
103+ Bad ->
104+ eerr row newCol ctx E.ModuleName
105+
106+
107+data ModuleNameStatus
108+ = Good
109+ | Bad
110+
111+
112+moduleNameHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# ModuleNameStatus, Ptr Word8, Word16 #)
113+moduleNameHelp pos end col =
114+ if isDot pos end then
115+ let
116+ !pos1 = plusPtr pos 1
117+ (# newPos, newCol #) = chompUpper pos1 end (col + 1)
118+ in
119+ if pos1 == newPos then
120+ (# Bad, newPos, newCol #)
121+ else
122+ moduleNameHelp newPos end newCol
123+
124+ else
125+ (# Good, pos, col #)
126+
127+
128+
129+-- FOREIGN UPPER
130+
131+
132+data Upper
133+ = Unqualified Name.Name
134+ | Qualified Name.Name Name.Name
135+
136+
137+foreignUpper :: Parser Upper
138+foreignUpper =
139+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
140+ let (# upperStart, upperEnd, newCol #) = foreignUpperHelp pos end col in
141+ if upperStart == upperEnd then
142+ eerr row newCol ctx E.Upper
143+ else
144+ let
145+ !newState = P.State upperEnd end indent row newCol ctx
146+ !name = Name.fromPtr upperStart upperEnd
147+ !foreign =
148+ if upperStart == pos then
149+ Unqualified name
150+ else
151+ let !home = Name.fromPtr pos (plusPtr upperStart (-1)) in
152+ Qualified home name
153+ in
154+ cok foreign newState
155+
156+
157+foreignUpperHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# Ptr Word8, Ptr Word8, Word16 #)
158+foreignUpperHelp pos end col =
159+ let
160+ (# newPos, newCol #) = chompUpper pos end col
161+ in
162+ if pos == newPos then
163+ (# pos, pos, col #)
164+
165+ else if isDot newPos end then
166+ foreignUpperHelp (plusPtr newPos 1) end (newCol + 1)
167+
168+ else
169+ (# pos, newPos, newCol #)
170+
171+
172+
173+-- FOREIGN ALPHA
174+
175+
176+foreignAlpha :: Parser Src.Expr_
177+foreignAlpha =
178+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
179+ let (# alphaStart, alphaEnd, newCol, varType #) = foreignAlphaHelp pos end col in
180+ if alphaStart == alphaEnd then
181+ eerr row newCol ctx E.Alpha
182+ else
183+ let
184+ !newState = P.State alphaEnd end indent row newCol ctx
185+ !name = Name.fromPtr alphaStart alphaEnd
186+ in
187+ if alphaStart == pos then
188+ if Set.member name reservedWords then
189+ eerr row col ctx E.Alpha
190+ else
191+ cok (Src.Var varType name) newState
192+ else
193+ let !home = Name.fromPtr pos (plusPtr alphaStart (-1)) in
194+ cok (Src.VarQual varType home name) newState
195+
196+
197+foreignAlphaHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# Ptr Word8, Ptr Word8, Word16, Src.VarType #)
198+foreignAlphaHelp pos end col =
199+ let
200+ (# lowerPos, lowerCol #) = chompLower pos end col
201+ in
202+ if pos < lowerPos then
203+ (# pos, lowerPos, lowerCol, Src.LowVar #)
204+
205+ else
206+ let
207+ (# upperPos, upperCol #) = chompUpper pos end col
208+ in
209+ if pos == upperPos then
210+ (# pos, pos, col, Src.CapVar #)
211+
212+ else if isDot upperPos end then
213+ foreignAlphaHelp (plusPtr upperPos 1) end (upperCol + 1)
214+
215+ else
216+ (# pos, upperPos, upperCol, Src.CapVar #)
217+
218+
219+
220+---- CHAR CHOMPERS ----
221+
222+
223+
224+-- DOTS
225+
226+
227+{-# INLINE isDot #-}
228+isDot :: Ptr Word8 -> Ptr Word8 -> Bool
229+isDot pos end =
230+ pos < end && unsafeIndex pos == 0x2e {- . -}
231+
232+
233+
234+-- UPPER CHARS
235+
236+
237+chompUpper :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# Ptr Word8, Word16 #)
238+chompUpper pos end col =
239+ let !width = getUpperWidth pos end in
240+ if width == 0 then
241+ (# pos, col #)
242+ else
243+ chompInnerChars (plusPtr pos width) end (col + 1)
244+
245+
246+{-# INLINE getUpperWidth #-}
247+getUpperWidth :: Ptr Word8 -> Ptr Word8 -> Int
248+getUpperWidth pos end =
249+ if pos < end then
250+ getUpperWidthHelp pos end (unsafeIndex pos)
251+ else
252+ 0
253+
254+
255+{-# INLINE getUpperWidthHelp #-}
256+getUpperWidthHelp :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int
257+getUpperWidthHelp pos _ word
258+ | 0x41 {- A -} <= word && word <= 0x5A {- Z -} = 1
259+ | word < 0xc0 = 0
260+ | word < 0xe0 = if Char.isUpper (chr2 pos word) then 2 else 0
261+ | word < 0xf0 = if Char.isUpper (chr3 pos word) then 3 else 0
262+ | word < 0xf8 = if Char.isUpper (chr4 pos word) then 4 else 0
263+ | True = 0
264+
265+
266+
267+-- LOWER CHARS
268+
269+
270+chompLower :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# Ptr Word8, Word16 #)
271+chompLower pos end col =
272+ let !width = getLowerWidth pos end in
273+ if width == 0 then
274+ (# pos, col #)
275+ else
276+ chompInnerChars (plusPtr pos width) end (col + 1)
277+
278+
279+{-# INLINE getLowerWidth #-}
280+getLowerWidth :: Ptr Word8 -> Ptr Word8 -> Int
281+getLowerWidth pos end =
282+ if pos < end then
283+ getLowerWidthHelp pos end (unsafeIndex pos)
284+ else
285+ 0
286+
287+
288+{-# INLINE getLowerWidthHelp #-}
289+getLowerWidthHelp :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int
290+getLowerWidthHelp pos _ word
291+ | 0x61 {- a -} <= word && word <= 0x7A {- z -} = 1
292+ | word < 0xc0 = 0
293+ | word < 0xe0 = if Char.isLower (chr2 pos word) then 2 else 0
294+ | word < 0xf0 = if Char.isLower (chr3 pos word) then 3 else 0
295+ | word < 0xf8 = if Char.isLower (chr4 pos word) then 4 else 0
296+ | True = 0
297+
298+
299+
300+-- INNER CHARS
301+
302+
303+chompInnerChars :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# Ptr Word8, Word16 #)
304+chompInnerChars !pos end !col =
305+ let !width = getInnerWidth pos end in
306+ if width == 0 then
307+ (# pos, col #)
308+ else
309+ chompInnerChars (plusPtr pos width) end (col + 1)
310+
311+
312+getInnerWidth :: Ptr Word8 -> Ptr Word8 -> Int
313+getInnerWidth pos end =
314+ if pos < end then
315+ getInnerWidthHelp pos end (unsafeIndex pos)
316+ else
317+ 0
318+
319+
320+{-# INLINE getInnerWidthHelp #-}
321+getInnerWidthHelp :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int
322+getInnerWidthHelp pos _ word
323+ | 0x61 {- a -} <= word && word <= 0x7A {- z -} = 1
324+ | 0x41 {- A -} <= word && word <= 0x5A {- Z -} = 1
325+ | 0x30 {- 0 -} <= word && word <= 0x39 {- 9 -} = 1
326+ | word == 0x5F {- _ -} = 1
327+ | word < 0xc0 = 0
328+ | word < 0xe0 = if Char.isAlpha (chr2 pos word) then 2 else 0
329+ | word < 0xf0 = if Char.isAlpha (chr3 pos word) then 3 else 0
330+ | word < 0xf8 = if Char.isAlpha (chr4 pos word) then 4 else 0
331+ | True = 0
332+
333+
334+
335+-- EXTRACT CHARACTERS
336+
337+
338+{-# INLINE chr2 #-}
339+chr2 :: Ptr Word8 -> Word8 -> Char
340+chr2 pos firstWord =
341+ let
342+ !i1# = unpack firstWord
343+ !i2# = unpack (unsafeIndex (plusPtr pos 1))
344+ !c1# = uncheckedIShiftL# (i1# -# 0xC0#) 6#
345+ !c2# = i2# -# 0x80#
346+ in
347+ C# (chr# (c1# +# c2#))
348+
349+
350+{-# INLINE chr3 #-}
351+chr3 :: Ptr Word8 -> Word8 -> Char
352+chr3 pos firstWord =
353+ let
354+ !i1# = unpack firstWord
355+ !i2# = unpack (unsafeIndex (plusPtr pos 1))
356+ !i3# = unpack (unsafeIndex (plusPtr pos 2))
357+ !c1# = uncheckedIShiftL# (i1# -# 0xE0#) 12#
358+ !c2# = uncheckedIShiftL# (i2# -# 0x80#) 6#
359+ !c3# = i3# -# 0x80#
360+ in
361+ C# (chr# (c1# +# c2# +# c3#))
362+
363+
364+{-# INLINE chr4 #-}
365+chr4 :: Ptr Word8 -> Word8 -> Char
366+chr4 pos firstWord =
367+ let
368+ !i1# = unpack firstWord
369+ !i2# = unpack (unsafeIndex (plusPtr pos 1))
370+ !i3# = unpack (unsafeIndex (plusPtr pos 2))
371+ !i4# = unpack (unsafeIndex (plusPtr pos 3))
372+ !c1# = uncheckedIShiftL# (i1# -# 0xF0#) 18#
373+ !c2# = uncheckedIShiftL# (i2# -# 0x80#) 12#
374+ !c3# = uncheckedIShiftL# (i3# -# 0x80#) 6#
375+ !c4# = i4# -# 0x80#
376+ in
377+ C# (chr# (c1# +# c2# +# c3# +# c4#))
378+
379+
380+unpack :: Word8 -> Int#
381+unpack (W8# word#) =
382+ word2Int# word#