git.iko.soy/elk
on master help sign in
Update all the parser code for the new Parser.Primitives
commitf4b2de36c0b27d4b873a4398c748f2747799bc25 authorEvan Czaplicki <evancz@users.noreply.github.com> dateThu 27 Dec 2018, 11:28 (8 years ago) parentf4707e6
23 files changed+2798−2651
compare with master
unifiedsplit
compiler/src/Parse/Declaration.hs+110−90 compiler/src/Parse/Docs.hs+275 compiler/src/Parse/Expression.hs+183−161 compiler/src/Parse/Keyword.hs+266 compiler/src/Parse/Module.hs+292−173 compiler/src/Parse/Number.hs+302 compiler/src/Parse/Parse.hs−65 compiler/src/Parse/Pattern.hs+86−88 compiler/src/Parse/Primitives/Kernel.hs−116 compiler/src/Parse/Primitives/Keyword.hs−235 compiler/src/Parse/Primitives/Number.hs−297 compiler/src/Parse/Primitives/Shader.hs−69 compiler/src/Parse/Primitives/Symbol.hs−259 compiler/src/Parse/Primitives/Utf8.hs−323 compiler/src/Parse/Primitives/Variable.hs−376 compiler/src/Parse/Primitives/Whitespace.hs−223 compiler/src/Parse/Repl.hs+37−48 compiler/src/Parse/Shader.hs+106−28 compiler/src/Parse/Symbol.hs+94 compiler/src/Parse/Type.hs+76−100 compiler/src/Parse/Utf8.hs+333 compiler/src/Parse/Utils.hs+256 compiler/src/Parse/Variable.hs+382
compiler/src/Parse/Declaration.hs+110−90
@@ -1,117 +1,139 @@
11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
22{-# LANGUAGE OverloadedStrings #-}
33module Parse.Declaration
4− ( declaration
4+ ( Decl(..)
5+ , declaration
56 , infix_
67 )
78 where
89
910
1011import qualified Data.Name as Name
11−import qualified Data.Text.Encoding as Text
1212
1313import qualified AST.Source as Src
1414import qualified AST.Utils.Binop as Binop
1515import qualified Parse.Expression as Expr
1616import qualified Parse.Pattern as Pattern
17−import Parse.Primitives
18−import qualified Parse.Primitives.Keyword as Keyword
19−import qualified Parse.Primitives.Number as Number
20−import qualified Parse.Primitives.Symbol as Symbol
21−import qualified Parse.Primitives.Variable as Var
22−import qualified Parse.Primitives.Whitespace as W
17+import qualified Parse.Keyword as Keyword
18+import qualified Parse.Number as Number
19+import qualified Parse.Symbol as Symbol
2320import 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
2425import qualified Reporting.Annotation as A
2526import qualified Reporting.Error.Syntax as E
26−import qualified Reporting.Region as R
2727
2828
2929
3030-- DECLARATION
3131
3232
33−declaration :: SParser Src.Decl
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+
40+declaration :: SParser Decl
3441declaration =
35− hint E.Decl $
3642 do start <- getPosition
37− oneOf
38− [ doc_ start
39− , type_ start
40− , port_ start
41− , def_ start
43+ oneOf E.XXX
44+ [ typeDecl start
45+ , portDecl
46+ , valueDecl start
4247 ]
4348
4449
4550
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−
5951-- DEFINITION and ANNOTATION
6052
6153
62−{-# INLINE def_ #-}
63−def_ :: R.Position -> SParser Src.Decl
64−def_ start =
54+{-# INLINE valueDecl #-}
55+valueDecl :: A.Position -> SParser Decl
56+valueDecl start =
6557 do name <- Var.lower
66− nameEnd <- getPosition
67− let locatedName = A.at start nameEnd name
58+ end <- getPosition
6859 spaces
69− oneOf
70− [ do Symbol.hasType
71− inContext start (E.Annotation name) $
72− do spaces
73− (tipe, end, space) <- Type.expression
74− return ( A.at start end (Src.Annotation locatedName tipe), end, space )
75− , inContext start (E.Definition name) $
76− definitionHelp start locatedName []
60+ oneOf E.XXX
61+ [
62+ do word1 0x3A {-:-} E.XXX
63+ pushContext start (E.Annotation name)
64+ spaces
65+ (tipe, _, space) <- Type.expression
66+ popContext ()
67+ checkAligned space
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
7778 ]
7879
7980
80−definitionHelp :: R.Position -> A.Located Name.Name -> [Src.Pattern] -> SParser Src.Decl
81−definitionHelp start name revArgs =
82− oneOf
83− [ do arg <- hint E.Arg Pattern.term
81+valueHelp :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> SParser Decl
82+valueHelp start name tipe revArgs =
83+ oneOf E.XXX
84+ [ do arg <- Pattern.term
8485 spaces
85− definitionHelp start name (arg : revArgs)
86− , do Symbol.equals
86+ valueHelp start name tipe (arg : revArgs)
87+ , do word1 0x3D {-=-} E.XXX
8788 spaces
8889 (body, end, space) <- Expr.expression
89− let def = A.at start end (Src.Definition name (reverse revArgs) body)
90− return ( def, end, space )
90+ let value = A.at start end (Src.Value name (reverse revArgs) body tipe)
91+ return ( Value value, end, space )
9192 ]
9293
9394
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+
94113
95114-- TYPE ALIAS and UNION TYPES
96115
97116
98−{-# INLINE type_ #-}
99−type_ :: R.Position -> SParser Src.Decl
100−type_ start =
117+{-# INLINE typeDecl #-}
118+typeDecl :: A.Position -> SParser Decl
119+typeDecl start =
101120 do Keyword.type_
102121 spaces
103− oneOf
104− [ do Keyword.alias_
105− inContext start E.TypeAlias $
106− do spaces
107− (name, args) <- nameArgsEquals
108− (tipe, end, pos) <- Type.expression
109− return ( A.at start end (Src.Alias name args tipe), end, pos )
110− , inContext start E.TypeUnion $
111− do (name, args) <- nameArgsEquals
112− (firstCtor, firstEnd, firstSpace) <- Type.unionConstructor
113− (ctors, end, pos) <- chompConstructors [firstCtor] firstEnd firstSpace
114− return ( A.at start end (Src.Union name args ctors), end, pos )
122+ oneOf E.XXX
123+ [
124+ inContext E.TypeAlias Keyword.alias_ $
125+ do spaces
126+ (name, args) <- nameArgsEquals
127+ (tipe, end, pos) <- Type.expression
128+ let alias = A.at start end (Src.Alias name args tipe)
129+ return (Alias alias, end, pos)
130+ ,
131+ do pushContext start E.TypeUnion
132+ (name, args) <- nameArgsEquals
133+ (firstCtor, firstEnd, firstSpace) <- Type.unionConstructor
134+ (ctors, end, pos) <- chompConstructors [firstCtor] firstEnd firstSpace
135+ let union = A.at start end (Src.Union name args ctors)
136+ popContext (Union union, end, pos)
115137 ]
116138
117139
@@ -124,21 +146,21 @@ nameArgsEquals =
124146
125147nameArgsEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser (A.Located Name.Name, [A.Located Name.Name])
126148nameArgsEqualsHelp name args =
127− oneOf
149+ oneOf E.XXX
128150 [ do arg <- addLocation Var.lower
129151 spaces
130152 nameArgsEqualsHelp name (arg:args)
131− , do Symbol.equals
153+ , do word1 0x3D {-=-} E.XXX
132154 spaces
133155 return ( name, reverse args )
134156 ]
135157
136158
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])]
138160chompConstructors ctors end pos =
139− oneOf
161+ oneOf E.XXX
140162 [ do checkSpace pos
141− Symbol.pipe
163+ word1 0x7C {-|-} E.XXX
142164 spaces
143165 (ctor, newEnd, newSpace) <- Type.unionConstructor
144166 chompConstructors (ctor:ctors) newEnd newSpace
@@ -150,18 +172,17 @@ chompConstructors ctors end pos =
150172-- PORT
151173
152174
153−{-# INLINE port_ #-}
154−port_ :: R.Position -> SParser Src.Decl
155−port_ start =
156− do Keyword.port_
157− inContext start E.Port $
158− do spaces
159− name <- addLocation Var.lower
160− spaces
161− Symbol.hasType
162− spaces
163− (tipe, end, pos) <- Type.expression
164− return ( A.at start end (Src.Port name tipe), end, pos )
175+{-# INLINE portDecl #-}
176+portDecl :: SParser Decl
177+portDecl =
178+ inContext E.Port Keyword.port_ $
179+ do spaces
180+ name <- addLocation Var.lower
181+ spaces
182+ word1 0x3A {-:-} E.XXX
183+ spaces
184+ (tipe, end, pos) <- Type.expression
185+ return ( Port (Src.Port name tipe), end, pos )
165186
166187
167188
@@ -170,14 +191,13 @@ port_ start =
170191
171192-- INVARIANT: always chomps to a freshline
172193--
173−infix_ :: Parser Src.Decl
194+infix_ :: Parser (A.Located Src.Binop)
174195infix_ =
175196 do start <- getPosition
176− Keyword.infix_
177− inContext start E.Infix $
197+ inContext E.Infix Keyword.infix_ $
178198 do spaces
179199 associativity <-
180− oneOf
200+ oneOf E.XXX
181201 [ Keyword.left_ >> return Binop.Left
182202 , Keyword.right_ >> return Binop.Right
183203 , Keyword.non_ >> return Binop.Non
@@ -185,13 +205,13 @@ infix_ =
185205 spaces
186206 precedence <- Number.precedence
187207 spaces
188− Symbol.leftParen
208+ word1 0x28 {-(-} E.XXX
189209 op <- Symbol.binop
190− Symbol.rightParen
210+ word1 0x29 {-)-} E.XXX
191211 spaces
192− Symbol.equals
212+ word1 0x3D {-=-} E.XXX
193213 spaces
194214 name <- Var.lower
195215 end <- getPosition
196− checkFreshLine =<< W.whitespace
216+ checkFreshLine =<< whitespace
197217 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
77
88
99import qualified Data.Name as Name
10+import Data.Word (Word16)
1011
1112import qualified AST.Source as Src
12−import Parse.Primitives
13−import qualified Parse.Primitives.Keyword as Keyword
14−import qualified Parse.Primitives.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
13+import qualified Parse.Keyword as Keyword
14+import qualified Parse.Number as Number
1915import qualified Parse.Pattern as Pattern
2016import qualified Parse.Shader as Shader
17+import qualified Parse.Symbol as Symbol
2118import 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
2224import qualified Reporting.Annotation as A
2325import qualified Reporting.Error.Syntax as E
24−import qualified Reporting.Region as R
2526
2627
2728
@@ -30,9 +31,8 @@ import qualified Reporting.Region as R
3031
3132term :: Parser Src.Expr
3233term =
33− hint E.Expr $
3434 do start <- getPosition
35− oneOf
35+ oneOf E.XXX
3636 [ variable start >>= accessible start
3737 , string start
3838 , number start
@@ -45,21 +45,21 @@ term =
4545 ]
4646
4747
48−string :: R.Position -> Parser Src.Expr
48+string :: A.Position -> Parser Src.Expr
4949string start =
5050 do str <- Utf8.string
5151 end <- getPosition
5252 return (A.at start end (Src.Str str))
5353
5454
55−character :: R.Position -> Parser Src.Expr
55+character :: A.Position -> Parser Src.Expr
5656character start =
5757 do chr <- Utf8.character
5858 end <- getPosition
5959 return (A.at start end (Src.Chr chr))
6060
6161
62−number :: R.Position -> Parser Src.Expr
62+number :: A.Position -> Parser Src.Expr
6363number start =
6464 do nmbr <- Number.number
6565 end <- getPosition
@@ -72,25 +72,25 @@ number start =
7272 Src.Float float
7373
7474
75−accessor :: R.Position -> Parser Src.Expr
75+accessor :: A.Position -> Parser Src.Expr
7676accessor start =
77− do Symbol.dot
77+ do word1 0x2E {-.-} E.XXX
7878 field <- Var.lower
7979 end <- getPosition
8080 return (A.at start end (Src.Accessor field))
8181
8282
83−variable :: R.Position -> Parser Src.Expr
83+variable :: A.Position -> Parser Src.Expr
8484variable start =
8585 do var <- Var.foreignAlpha
8686 end <- getPosition
8787 return (A.at start end var)
8888
8989
90−accessible :: R.Position -> Src.Expr -> Parser Src.Expr
90+accessible :: A.Position -> Src.Expr -> Parser Src.Expr
9191accessible start expr =
92− oneOf
93− [ do Symbol.dot
92+ oneOf E.XXX
93+ [ do word1 0x2E {-.-} E.XXX
9494 pos <- getPosition
9595 field <- Var.lower
9696 end <- getPosition
@@ -104,30 +104,29 @@ accessible start expr =
104104-- LISTS
105105
106106
107−list :: R.Position -> Parser Src.Expr
107+list :: A.Position -> Parser Src.Expr
108108list start =
109− do Symbol.leftSquare
110− inContext start E.ExprList $
111− do spaces
112− oneOf
113− [ do (entry, _, pos) <- expression
114− checkSpace pos
115− listHelp start [entry]
116− , do Symbol.rightSquare
117− end <- getPosition
118− return (A.at start end (Src.List []))
119− ]
120−
121−
122−listHelp :: R.Position -> [Src.Expr] -> Parser Src.Expr
109+ inContext E.ExprList (word1 0x5B {-[-} E.XXX) $
110+ do spaces
111+ oneOf E.XXX
112+ [ do (entry, _, pos) <- expression
113+ checkSpace pos
114+ listHelp start [entry]
115+ , do word1 0x5D {-]-} E.XXX
116+ end <- getPosition
117+ return (A.at start end (Src.List []))
118+ ]
119+
120+
121+listHelp :: A.Position -> [Src.Expr] -> Parser Src.Expr
123122listHelp start entries =
124− oneOf
125− [ do Symbol.comma
123+ oneOf E.XXX
124+ [ do word1 0x2C {-,-} E.XXX
126125 spaces
127126 (entry, _, pos) <- expression
128127 checkSpace pos
129128 listHelp start (entry:entries)
130− , do Symbol.rightSquare
129+ , do word1 0x5D {-]-} E.XXX
131130 end <- getPosition
132131 return (A.at start end (Src.List (reverse entries)))
133132 ]
@@ -137,14 +136,14 @@ listHelp start entries =
137136-- TUPLES
138137
139138
140−tuple :: R.Position -> Parser Src.Expr
139+tuple :: A.Position -> Parser Src.Expr
141140tuple start =
142− do Symbol.leftParen
143− pos <- getPosition
144− spos <- W.whitespace
145− inContext start E.ExprTuple $ oneOf $
141+ inContext E.ExprTuple (word1 0x28 {-(-} E.XXX) $
142+ do pos <- getPosition
143+ spos <- whitespace
144+ oneOf E.XXX
146145 [ do noSpace pos spos
147− try (Symbol.minus >> Symbol.rightParen)
146+ word2 0x2D 0x29 {--)-} E.XXX
148147 end <- getPosition
149148 return $ A.at start end (Src.Op "-")
150149
@@ -155,27 +154,27 @@ tuple start =
155154
156155 , do noSpace pos spos
157156 op <- Symbol.binop
158− Symbol.rightParen
157+ word1 0x29 {-)-} E.XXX
159158 end <- getPosition
160159 return $ A.at start end (Src.Op op)
161160
162161 , do noSpace pos spos
163− Symbol.rightParen
162+ word1 0x29 {-)-} E.XXX
164163 end <- getPosition
165164 return (A.at start end Src.Unit)
166165
167166 ]
168167
169168
170−tupleHelp :: R.Position -> Src.Expr -> [Src.Expr] -> Parser Src.Expr
169+tupleHelp :: A.Position -> Src.Expr -> [Src.Expr] -> Parser Src.Expr
171170tupleHelp start firstExpr revExprs =
172− oneOf
173− [ do Symbol.comma
171+ oneOf E.XXX
172+ [ do word1 0x2C {-,-} E.XXX
174173 spaces
175174 (entry, _, pos) <- expression
176175 checkSpace pos
177176 tupleHelp start firstExpr (entry : revExprs)
178− , do Symbol.rightParen
177+ , do word1 0x29 {-)-} E.XXX
179178 end <- getPosition
180179 case reverse revExprs of
181180 [] ->
@@ -190,33 +189,32 @@ tupleHelp start firstExpr revExprs =
190189-- RECORDS
191190
192191
193−record :: R.Position -> Parser Src.Expr
192+record :: A.Position -> Parser Src.Expr
194193record start =
195− do Symbol.leftCurly
196− inContext start E.ExprRecord $
197− do spaces
198− oneOf
199− [ do Symbol.rightCurly
200− end <- getPosition
201− return (A.at start end (Src.Record []))
202− , do starter <- addLocation Var.lower
203− spaces
204− oneOf
205− [ do Symbol.pipe
206− spaces
207− firstField <- chompField
208− fields <- chompFields [firstField]
209− end <- getPosition
210− return (A.at start end (Src.Update starter fields))
211− , do Symbol.equals
212− spaces
213− (value, _, nextPos) <- expression
214− checkSpace nextPos
215− fields <- chompFields [(starter, value)]
216− end <- getPosition
217− return (A.at start end (Src.Record fields))
218− ]
219− ]
194+ inContext E.ExprRecord (word1 0x7B {- { -} E.XXX) $
195+ do spaces
196+ oneOf E.XXX
197+ [ do word1 0x7D {-}-} E.XXX
198+ end <- getPosition
199+ return (A.at start end (Src.Record []))
200+ , do starter <- addLocation Var.lower
201+ spaces
202+ oneOf E.XXX
203+ [ do word1 0x7C {-|-} E.XXX
204+ spaces
205+ firstField <- chompField
206+ fields <- chompFields [firstField]
207+ end <- getPosition
208+ return (A.at start end (Src.Update starter fields))
209+ , do word1 0x3D {-=-} E.XXX
210+ spaces
211+ (value, _, nextPos) <- expression
212+ checkSpace nextPos
213+ fields <- chompFields [(starter, value)]
214+ end <- getPosition
215+ return (A.at start end (Src.Record fields))
216+ ]
217+ ]
220218
221219
222220type Field = ( A.Located Name.Name, Src.Expr )
@@ -224,12 +222,12 @@ type Field = ( A.Located Name.Name, Src.Expr )
224222
225223chompFields :: [Field] -> Parser [Field]
226224chompFields fields =
227− oneOf
228− [ do Symbol.comma
225+ oneOf E.XXX
226+ [ do word1 0x2C {-,-} E.XXX
229227 spaces
230228 f <- chompField
231229 chompFields (f : fields)
232− , do Symbol.rightCurly
230+ , do word1 0x7D {-}-} E.XXX
233231 return (reverse fields)
234232 ]
235233
@@ -238,7 +236,7 @@ chompField :: Parser Field
238236chompField =
239237 do key <- addLocation Var.lower
240238 spaces
241− Symbol.equals
239+ word1 0x3D {-=-} E.XXX
242240 spaces
243241 (value, _, pos) <- expression
244242 checkSpace pos
@@ -255,16 +253,15 @@ type ExprParser =
255253
256254expression :: ExprParser
257255expression =
258− hint E.Expr $
259256 do start <- getPosition
260− oneOf
257+ oneOf E.XXX
261258 [ let_ start
262259 , if_ start
263260 , case_ start
264261 , function start
265262 , do expr <- possiblyNegativeTerm start
266263 end <- getPosition
267− space <- W.whitespace
264+ space <- whitespace
268265 exprHelp start (State [] expr [] end space)
269266 ]
270267
@@ -274,20 +271,19 @@ data State =
274271 { _ops :: ![(Src.Expr, A.Located Name.Name)]
275272 , _expr :: !Src.Expr
276273 , _args :: ![Src.Expr]
277− , _end :: !R.Position
274+ , _end :: !A.Position
278275 , _pos :: !SPos
279276 }
280277
281278
282−exprHelp :: R.Position -> State -> ExprParser
279+exprHelp :: A.Position -> State -> ExprParser
283280exprHelp start (State ops expr args end pos) =
284− oneOf
281+ oneOf E.XXX
285282 [ -- argument
286− hint E.Arg $
287283 do checkSpace pos
288284 arg <- term
289285 newEnd <- getPosition
290− newPos <- W.whitespace
286+ newPos <- whitespace
291287 exprHelp start (State ops expr (arg:args) newEnd newPos)
292288
293289 , -- infix operator
@@ -296,30 +292,29 @@ exprHelp start (State ops expr args end pos) =
296292 opName <- Symbol.binop
297293 opEnd <- getPosition
298294 let op = A.at opStart opEnd opName
299− spos <- W.whitespace
300− hint (E.AfterOpExpr opName) (checkSpace spos)
295+ spos <- whitespace
296+ checkSpace spos
301297 newStart <- getPosition
302− hint (E.AfterOpExpr opName) $
303− if "-" == opName && end /= opStart && opEnd == newStart
298+ if "-" == opName && end /= opStart && opEnd == newStart
304299 then
305300 -- negative terms
306301 do rawTerm <- term
307302 newEnd <- getPosition
308− newPos <- W.whitespace
303+ newPos <- whitespace
309304 let arg = A.at opStart newEnd (Src.Negate rawTerm)
310305 exprHelp start (State ops expr (arg:args) newEnd newPos)
311306 else
312− oneOf
307+ oneOf E.XXX
313308 [ -- term
314309 do newExpr <- possiblyNegativeTerm newStart
315310 newEnd <- getPosition
316− newPos <- W.whitespace
311+ newPos <- whitespace
317312 let newOps = (toCall expr args, op) : ops
318313 exprHelp start (State newOps newExpr [] newEnd newPos)
319314
320315 , -- final term
321316 do (newLast, newEnd, newPos) <-
322− oneOf
317+ oneOf E.XXX
323318 [ let_ newStart
324319 , case_ newStart
325320 , if_ newStart
@@ -341,10 +336,10 @@ exprHelp start (State ops expr args end pos) =
341336 ]
342337
343338
344−possiblyNegativeTerm :: R.Position -> Parser Src.Expr
339+possiblyNegativeTerm :: A.Position -> Parser Src.Expr
345340possiblyNegativeTerm start =
346− oneOf
347− [ do Symbol.minus
341+ oneOf E.XXX
342+ [ do word1 0x2D {---} E.XXX
348343 expr <- term
349344 end <- getPosition
350345 return (A.at start end (Src.Negate expr))
@@ -366,13 +361,13 @@ toCall func revArgs =
366361-- IF EXPRESSION
367362
368363
369−if_ :: R.Position -> ExprParser
364+if_ :: A.Position -> ExprParser
370365if_ start =
371− do Keyword.if_
372− inContext start E.ExprIf $ ifHelp start []
366+ inContext E.ExprIf Keyword.if_ $
367+ ifHelp start []
373368
374369
375−ifHelp :: R.Position -> [(Src.Expr, Src.Expr)] -> ExprParser
370+ifHelp :: A.Position -> [(Src.Expr, Src.Expr)] -> ExprParser
376371ifHelp start branches =
377372 do spaces
378373 (condition, _, condPos) <- expression
@@ -380,11 +375,11 @@ ifHelp start branches =
380375 Keyword.then_
381376 spaces
382377 (thenBranch, _, thenPos) <- expression
383− hint E.ElseBranch $ checkSpace thenPos
384− hint E.ElseBranch $ Keyword.else_
378+ checkSpace thenPos
379+ Keyword.else_
385380 spaces
386381 let newBranches = (condition, thenBranch) : branches
387− oneOf
382+ oneOf E.XXX
388383 [ do Keyword.if_
389384 ifHelp start newBranches
390385 , do (elseBranch, elseEnd, elseSpace) <- expression
@@ -397,27 +392,26 @@ ifHelp start branches =
397392-- LAMBDA EXPRESSION
398393
399394
400−function :: R.Position -> ExprParser
395+function :: A.Position -> ExprParser
401396function start =
402− do Symbol.lambda
403− inContext start E.ExprFunc $
404− do spaces
405− arg <- Pattern.term
406− spaces
407− revArgs <- gatherArgs [arg]
408− spaces
409− (body, end, space) <- expression
410− let func = A.at start end (Src.Lambda (reverse revArgs) body)
411− return ( func, end, space )
397+ inContext E.ExprFunc (word1 0x5C {-\-} E.XXX) $
398+ do spaces
399+ arg <- Pattern.term
400+ spaces
401+ revArgs <- gatherArgs [arg]
402+ spaces
403+ (body, end, space) <- expression
404+ let func = A.at start end (Src.Lambda (reverse revArgs) body)
405+ return ( func, end, space )
412406
413407
414408gatherArgs :: [Src.Pattern] -> Parser [Src.Pattern]
415409gatherArgs args =
416− oneOf
410+ oneOf E.XXX
417411 [ do arg <- Pattern.term
418412 spaces
419413 gatherArgs (arg:args)
420− , do Symbol.rightArrow
414+ , do word2 0x2D 0x3E {-->-} E.XXX
421415 return args
422416 ]
423417
@@ -426,41 +420,40 @@ gatherArgs args =
426420-- CASE EXPRESSIONS
427421
428422
429−case_ :: R.Position -> ExprParser
423+case_ :: A.Position -> ExprParser
430424case_ start =
431− do Keyword.case_
432− inContext start E.ExprCase $
433− do spaces
434− (switcher, _, switcherPos) <- expression
435− checkSpace switcherPos
436− Keyword.of_
437− spaces
438− oldIndent <- getIndent
439− newIndent <- getCol
440− setIndent newIndent
441− (firstBranch, firstEnd, firstPos) <- branchHelp
442− (branches, end, pos) <- caseHelp [firstBranch] firstEnd firstPos
443− setIndent oldIndent
444− return
445− ( A.at start end (Src.Case switcher branches)
446− , end
447− , pos
448− )
425+ inContext E.ExprCase Keyword.case_ $
426+ do spaces
427+ (switcher, _, switcherPos) <- expression
428+ checkSpace switcherPos
429+ Keyword.of_
430+ spaces
431+ oldIndent <- getIndent
432+ newIndent <- getCol
433+ setIndent newIndent
434+ (firstBranch, firstEnd, firstPos) <- branchHelp
435+ (branches, end, pos) <- caseHelp [firstBranch] firstEnd firstPos
436+ setIndent oldIndent
437+ return
438+ ( A.at start end (Src.Case switcher branches)
439+ , end
440+ , pos
441+ )
449442
450443
451444branchHelp :: SParser (Src.Pattern, Src.Expr)
452445branchHelp =
453446 do (pattern, patternPos) <- Pattern.expression
454447 checkSpace patternPos
455− Symbol.rightArrow
448+ word2 0x2D 0x3E {-->-} E.XXX
456449 spaces
457450 (branchExpr, end, pos) <- expression
458451 return ( (pattern, branchExpr), end, pos )
459452
460453
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)]
462455caseHelp branches end pos =
463− oneOf
456+ oneOf E.XXX
464457 [ do checkAligned pos
465458 (branch, newEnd, newPos) <- branchHelp
466459 caseHelp (branch:branches) newEnd newPos
@@ -472,7 +465,7 @@ caseHelp branches end pos =
472465-- LET EXPRESSION
473466
474467
475−let_ :: R.Position -> ExprParser
468+let_ :: A.Position -> ExprParser
476469let_ start =
477470 do oldIndent <- getIndent
478471 letIndent <- getCol
@@ -486,9 +479,9 @@ let_ start =
486479 letHelp start oldIndent [def] end space
487480
488481
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
490483letHelp start oldIndent revDefs end pos =
491− oneOf
484+ oneOf E.XXX
492485 [ do checkAligned pos
493486 (def, newEnd, newPos) <- letDef
494487 letHelp start oldIndent (def:revDefs) newEnd newPos
@@ -510,7 +503,7 @@ letHelp start oldIndent revDefs end pos =
510503
511504letDef :: SParser (A.Located Src.Def)
512505letDef =
513− oneOf
506+ oneOf E.XXX
514507 [ definition
515508 , destructure
516509 ]
@@ -524,33 +517,62 @@ definition :: SParser (A.Located Src.Def)
524517definition =
525518 do start <- getPosition
526519 name <- Var.lower
527− nameEnd <- getPosition
520+ end <- getPosition
528521 spaces
529− oneOf
530− [ do Symbol.hasType
531− inContext start (E.Annotation name) $
532− do spaces
533− (tipe, end, space) <- Type.expression
534− return ( A.at start end (Src.Annotate name tipe), end, space )
535− , inContext start (E.Definition name) $
536− definitionHelp start (A.at start nameEnd name) []
522+ oneOf E.XXX
523+ [
524+ do word1 0x3A {-:-} E.XXX
525+ pushContext start (E.Annotation name)
526+ spaces
527+ (tipe, _, space) <- Type.expression
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+ ,
537+ do pushContext start (E.Definition name)
538+ def <- definitionHelp start (A.at start end name) Nothing []
539+ popContext def
537540 ]
538541
539542
540−definitionHelp :: R.Position -> A.Located Name.Name -> [Src.Pattern] -> SParser (A.Located Src.Def)
541−definitionHelp start name revArgs =
542− oneOf
543− [ do arg <- hint E.Arg Pattern.term
543+definitionHelp :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> SParser (A.Located Src.Def)
544+definitionHelp start name tipe revArgs =
545+ oneOf E.XXX
546+ [ do arg <- Pattern.term
544547 spaces
545− definitionHelp start name (arg : revArgs)
546− , do Symbol.equals
548+ definitionHelp start name tipe (arg : revArgs)
549+ , do word1 0x3D {-=-} E.XXX
547550 spaces
548551 (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)
550553 return ( def, end, space )
551554 ]
552555
553556
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+
554576
555577-- DESTRUCTURE
556578
@@ -560,7 +582,7 @@ destructure =
560582 do start <- getPosition
561583 pattern <- Pattern.term
562584 spaces
563− Symbol.equals
585+ word1 0x3D {-=-} E.XXX
564586 spaces
565587 (expr, end, space) <- expression
566588 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 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
33module Parse.Module
4− ( module_
4+ ( fromByteString
5+ , Header(..)
6+ , Effects(..)
7+ , chompHeader
58 , chompImports
69 , freshLine
7− , exposing
810 )
911 where
1012
1113
14+import qualified Data.ByteString as B
1215import qualified Data.Name as Name
1316
1417import qualified AST.Source as Src
1518import qualified Elm.Compiler.Imports as Imports
1619import 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
1824import qualified Parse.Primitives as P
19−import qualified Parse.Primitives.Keyword as Keyword
20−import qualified Parse.Primitives.Symbol as Symbol
21−import qualified Parse.Primitives.Variable as Var
22−import qualified Parse.Primitives.Whitespace as W
25+import Parse.Primitives hiding (Parser, State, fromByteString)
26+import Parse.Utils
2327import qualified Reporting.Annotation as A
2428import 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)
2652
2753
2854
2955-- MODULE
3056
3157
32−module_ :: Pkg.Name -> Parser decls -> Parser (Src.Module decls)
33−module_ pkgName chompDecls =
58+normal :: Parser (Either E.Error Src.Module)
59+normal =
3460 do freshLine
35− header <- oneOf [ Just <$> chompHeader, return Nothing ]
36− imports <- Imports.addDefaults pkgName <$> chompImports []
37− decls <- chompDecls
38− return (Src.Module header imports decls)
61+ header <- chompHeader
62+ imports <- chompImports []
63+ decls <- chompDecls []
64+ endOfFile
65+ return (checkModule header (Imports.addDefaults imports) [] decls)
3966
4067
41−chompHeader :: Parser Src.Header
42−chompHeader =
43− do start <- P.getPosition
44− P.pushContext start E.Module
45− (name, effects) <- chompNameAndEffects
46− P.hint E.Exposing $ Keyword.exposing_
47− P.spaces
48− exports <- P.addLocation exposing
49− P.popContext ()
50− docs <- chompDocComment
51− return (Src.Header name effects exports docs)
52−
53−
54−
55−-- MODULE NAME
56−--
57−-- module MyThing
58−-- port module MyThing
59−-- effect module MyThing where { command = MyCmd }
60−--
61−chompNameAndEffects :: Parser (Name.Name, Src.Effects)
62−chompNameAndEffects =
63− oneOf
64− [
65− do Keyword.module_
66− P.spaces
67− name <- Var.moduleName
68− P.spaces
69− return ( name, Src.NoEffects )
70− ,
71− do start <- P.getPosition
72− Keyword.port_
73− P.spaces
74− Keyword.module_
75− end <- P.getPosition
76− P.spaces
77− name <- Var.moduleName
78− P.spaces
79− return ( name, Src.Ports (R.Region start end) )
80− ,
81− do start <- P.getPosition
82− Keyword.effect_
83− P.spaces
84− Keyword.module_
85− end <- P.getPosition
86− P.spaces
87− name <- Var.moduleName
88− P.spaces
89− manager <- chompManager
90− return ( name, Src.Manager (R.Region start end) manager )
68+core :: Parser (Either E.Error Src.Module)
69+core =
70+ do freshLine
71+ header <- chompHeader
72+ imports <- chompImports []
73+ binops <- chompBinops []
74+ decls <- chompDecls []
75+ endOfFile
76+ return (checkModule header imports binops decls)
77+
78+
79+platform :: Parser (Either E.Error Src.Module)
80+platform =
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+
91+-- CHECK MODULE
92+
93+
94+checkModule :: Maybe Header -> [Src.Import] -> [A.Located Src.Binop] -> [Decl.Decl] -> Either E.Error Src.Module
95+checkModule maybeHeader imports binops decls =
96+ let
97+ (Header name effects exports) = maybe (Header "Main" NoEffects (A.At A.one Src.Open)) id maybeHeader
98+ (values, unions, aliases, ports) = categorizeDecls [] [] [] [] decls
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
126+ [] ->
127+ (values, unions, aliases, ports)
128+
129+ decl:otherDecls ->
130+ case decl of
131+ Decl.Value value -> categorizeDecls (value:values) unions aliases ports otherDecls
132+ Decl.Union union -> categorizeDecls values (union:unions) aliases ports otherDecls
133+ Decl.Alias alias -> categorizeDecls values unions (alias:aliases) ports otherDecls
134+ Decl.Port port_ -> categorizeDecls values unions aliases (port_:ports) otherDecls
135+
136+
137+
138+-- FRESH LINES
139+
140+
141+freshLine :: Parser ()
142+freshLine =
143+ checkFreshLine =<< whitespace
144+
145+
146+endOfFile :: Parser ()
147+endOfFile =
148+ P.Parser $ \state@(P.State pos end _ row col ctx) _ eok _ eerr ->
149+ if pos < end then
150+ eerr row col ctx E.EndOfFile
151+ else
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
91175 ]
92176
93177
94178
95−-- MANAGER
96−--
97−-- where { command = MyCmd }
98−-- where { subscription = MySub }
99−-- where { command = MyCmd, subscription = MySub }
100−--
179+-- HEADER
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+ ,
226+ -- effect module MyThing where { command = MyCmd } exposing (..)
227+ do Keyword.effect_
228+ pushContext start E.Module
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+
101251chompManager :: Parser Src.Manager
102252chompManager =
103− do Keyword.where_
104− P.spaces
105− Symbol.leftCurly
106− P.spaces
107− oneOf
253+ do word1 0x7B {- { -} E.XXX
254+ spaces
255+ oneOf E.XXX
108256 [ do cmd <- chompCommand
109− P.spaces
110− oneOf
111− [ do Symbol.rightCurly
112− P.spaces
257+ spaces
258+ oneOf E.XXX
259+ [ do word1 0x7D {-}-} E.XXX
260+ spaces
113261 return (Src.Cmd cmd)
114− , do Symbol.comma
115− P.spaces
262+ , do word1 0x2C {-,-} E.XXX
263+ spaces
116264 sub <- chompSubscription
117− P.spaces
118− Symbol.rightCurly
119− P.spaces
265+ spaces
266+ word1 0x7D {-}-} E.XXX
267+ spaces
120268 return (Src.Fx cmd sub)
121269 ]
122270 , do sub <- chompSubscription
123− P.spaces
124− oneOf
125− [ do Symbol.rightCurly
126− P.spaces
271+ spaces
272+ oneOf E.XXX
273+ [ do word1 0x7D {-}-} E.XXX
274+ spaces
127275 return (Src.Sub sub)
128− , do Symbol.comma
129− P.spaces
276+ , do word1 0x2C {-,-} E.XXX
277+ spaces
130278 cmd <- chompCommand
131− P.spaces
132− Symbol.rightCurly
133− P.spaces
279+ spaces
280+ word1 0x7D {-}-} E.XXX
281+ spaces
134282 return (Src.Fx cmd sub)
135283 ]
136284 ]
@@ -139,37 +287,19 @@ chompManager =
139287chompCommand :: Parser (A.Located Name.Name)
140288chompCommand =
141289 do Keyword.command_
142− P.spaces
143− Symbol.equals
144− P.spaces
145− P.addLocation Var.upper
290+ spaces
291+ word1 0x3D {-=-} E.XXX
292+ spaces
293+ addLocation Var.upper
146294
147295
148296chompSubscription :: Parser (A.Located Name.Name)
149297chompSubscription =
150298 do Keyword.subscription_
151− P.spaces
152− Symbol.equals
153− P.spaces
154− P.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− ]
299+ spaces
300+ word1 0x3D {-=-} E.XXX
301+ spaces
302+ addLocation Var.upper
173303
174304
175305
@@ -178,20 +308,20 @@ chompDocComment =
178308
179309chompImports :: [Src.Import] -> Parser [Src.Import]
180310chompImports imports =
181− oneOf
182− [ do start <- P.getPosition
311+ oneOf E.XXX
312+ [ do start <- getPosition
183313 Keyword.import_
184− P.pushContext start E.Import
185− P.spaces
186− name <- P.addLocation Var.moduleName
187− pos <- W.whitespace
188− oneOf
189− [ do P.checkFreshLine pos
190− P.popContext ()
314+ pushContext start E.Import
315+ spaces
316+ name <- addLocation Var.moduleName
317+ pos <- whitespace
318+ oneOf E.XXX
319+ [ do checkFreshLine pos
320+ popContext ()
191321 chompImports $
192322 Src.Import name Nothing (Src.Explicit []) : imports
193− , do P.checkSpace pos
194− oneOf
323+ , do checkSpace pos
324+ oneOf E.XXX
195325 [ chompAs name imports
196326 , chompExposing name Nothing imports
197327 ]
@@ -203,15 +333,15 @@ chompImports imports =
203333chompAs :: A.Located Name.Name -> [Src.Import] -> Parser [Src.Import]
204334chompAs name imports =
205335 do Keyword.as_
206− P.spaces
336+ spaces
207337 alias <- Var.upper
208− pos <- W.whitespace
209− oneOf
210− [ do P.checkFreshLine pos
211− P.popContext ()
338+ pos <- whitespace
339+ oneOf E.XXX
340+ [ do checkFreshLine pos
341+ popContext ()
212342 chompImports $
213343 Src.Import name (Just alias) (Src.Explicit []) : imports
214− , do P.checkSpace pos
344+ , do checkSpace pos
215345 chompExposing name (Just alias) imports
216346 ]
217347
@@ -219,10 +349,10 @@ chompAs name imports =
219349chompExposing :: A.Located Name.Name -> Maybe Name.Name -> [Src.Import] -> Parser [Src.Import]
220350chompExposing name maybeAlias imports =
221351 do Keyword.exposing_
222− P.spaces
352+ spaces
223353 exposed <- exposing
224354 freshLine
225− P.popContext ()
355+ popContext ()
226356 chompImports $
227357 Src.Import name maybeAlias exposed : imports
228358
@@ -233,65 +363,54 @@ chompExposing name maybeAlias imports =
233363
234364exposing :: Parser Src.Exposing
235365exposing =
236− P.hint E.Listing $
237− do Symbol.leftParen
238− P.spaces
239− oneOf
240− [ do Symbol.doubleDot
241− P.spaces
242− Symbol.rightParen
366+ do word1 0x28 {-(-} E.XXX
367+ spaces
368+ oneOf E.XXX
369+ [ do word2 0x2E 0x2E {-..-} E.XXX
370+ spaces
371+ word1 0x29 {-)-} E.XXX
243372 return Src.Open
244− , do entry <- P.addLocation chompEntry
245− P.spaces
373+ , do entry <- addLocation chompEntry
374+ spaces
246375 exposingHelp [entry]
247376 ]
248377
249378
250379exposingHelp :: [A.Located Src.Exposed] -> Parser Src.Exposing
251380exposingHelp revEntries =
252− oneOf
253− [ do Symbol.comma
254− P.spaces
255− entry <- P.addLocation chompEntry
256− P.spaces
381+ oneOf E.XXX
382+ [ do word1 0x2C {-,-} E.XXX
383+ spaces
384+ entry <- addLocation chompEntry
385+ spaces
257386 exposingHelp (entry:revEntries)
258− , do Symbol.rightParen
387+ , do word1 0x29 {-)-} E.XXX
259388 return (Src.Explicit (reverse revEntries))
260389 ]
261390
262391
263392chompEntry :: Parser Src.Exposed
264393chompEntry =
265− oneOf
394+ oneOf E.XXX
266395 [ Src.Lower <$> Var.lower
267− , do Symbol.leftParen
396+ , do word1 0x28 {-(-} E.XXX
268397 op <- Symbol.binop
269− Symbol.rightParen
398+ word1 0x29 {-)-} E.XXX
270399 return (Src.Operator op)
271400 , do name <- Var.upper
272− P.spaces
401+ spaces
273402 Src.Upper name <$> privacy
274403 ]
275404
276405
277406privacy :: Parser Src.Privacy
278407privacy =
279− oneOf
280− [ do Symbol.leftParen
281− P.spaces
282− Symbol.doubleDot
283− P.spaces
284− Symbol.rightParen
408+ oneOf E.XXX
409+ [ do word1 0x28 {-(-} E.XXX
410+ spaces
411+ word2 0x2E 0x2E {-..-} E.XXX
412+ spaces
413+ word1 0x29 {-)-} E.XXX
285414 return Src.Public
286415 , return Src.Private
287416 ]
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
1111import qualified Data.Name as Name
1212
1313import 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
1520import qualified Parse.Primitives as P
16−import qualified Parse.Primitives.Keyword as Keyword
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)
21+import Parse.Primitives (addLocation, getPosition, inContext, oneOf, word1)
2222import qualified Reporting.Annotation as A
2323import qualified Reporting.Error.Syntax as E
24−import qualified Reporting.Region as R
2524
2625
2726
@@ -30,19 +29,18 @@ import qualified Reporting.Region as R
3029
3130term :: Parser Src.Pattern
3231term =
33− hint E.Pattern $
34− do start <- getPosition
35− oneOf
36− [ record start
37− , tuple start
38− , list start
39− , termHelp start
40− ]
32+ do start <- getPosition
33+ oneOf E.XXX
34+ [ record start
35+ , tuple start
36+ , list start
37+ , termHelp start
38+ ]
4139
4240
43−termHelp :: R.Position -> Parser Src.Pattern
41+termHelp :: A.Position -> Parser Src.Pattern
4442termHelp start =
45− oneOf
43+ oneOf E.XXX
4644 [
4745 do Symbol.underscore
4846 end <- getPosition
@@ -54,7 +52,7 @@ termHelp start =
5452 ,
5553 do upper <- Var.foreignUpper
5654 end <- getPosition
57− let region = R.Region start end
55+ let region = A.Region start end
5856 return $ A.at start end $
5957 case upper of
6058 Var.Unqualified name ->
@@ -70,7 +68,7 @@ termHelp start =
7068 return (A.at start end (Src.PInt int))
7169
7270 Number.Float _ ->
73− P.noFloatsAllowedInPatterns
71+ noFloatsAllowedInPatterns
7472 ,
7573 do str <- Utf8.string
7674 end <- getPosition
@@ -82,36 +80,39 @@ termHelp start =
8280 ]
8381
8482
83+noFloatsAllowedInPatterns :: Parser a
84+noFloatsAllowedInPatterns =
85+ P.Parser $ \(P.State _ _ _ row col ctx) _ _ cerr _ ->
86+ cerr row col ctx E.FloatInPattern
8587
8688
8789
8890-- RECORDS
8991
9092
91−record :: R.Position -> Parser Src.Pattern
93+record :: A.Position -> Parser Src.Pattern
9294record start =
93− do Symbol.leftCurly
94− inContext start E.ExprRecord $
95− do spaces
96− oneOf
97− [ do var <- addLocation Var.lower
98− spaces
99− recordHelp start [var]
100− , do Symbol.rightCurly
101− end <- getPosition
102− return (A.at start end (Src.PRecord []))
103− ]
104−
105−
106−recordHelp :: R.Position -> [A.Located Name.Name] -> Parser Src.Pattern
95+ inContext E.ExprRecord (word1 0x7B {- { -} E.XXX) $
96+ do spaces
97+ oneOf E.XXX
98+ [ do var <- addLocation Var.lower
99+ spaces
100+ recordHelp start [var]
101+ , do word1 0x7D {-}-} E.XXX
102+ end <- getPosition
103+ return (A.at start end (Src.PRecord []))
104+ ]
105+
106+
107+recordHelp :: A.Position -> [A.Located Name.Name] -> Parser Src.Pattern
107108recordHelp start vars =
108− oneOf
109− [ do Symbol.comma
109+ oneOf E.XXX
110+ [ do word1 0x2C {-,-} E.XXX
110111 spaces
111112 var <- addLocation Var.lower
112113 spaces
113114 recordHelp start (var:vars)
114− , do Symbol.rightCurly
115+ , do word1 0x7D {-}-} E.XXX
115116 end <- getPosition
116117 return (A.at start end (Src.PRecord vars))
117118 ]
@@ -121,30 +122,29 @@ recordHelp start vars =
121122-- TUPLES
122123
123124
124−tuple :: R.Position -> Parser Src.Pattern
125+tuple :: A.Position -> Parser Src.Pattern
125126tuple start =
126− do Symbol.leftParen
127− inContext start E.ExprTuple $
128− do spaces
129− oneOf
130− [ do (pattern, sPos) <- expression
131− checkSpace sPos
132− tupleHelp start pattern []
133− , do Symbol.rightParen
134− end <- getPosition
135− return (A.at start end Src.PUnit)
136− ]
137−
138−
139−tupleHelp :: R.Position -> Src.Pattern -> [Src.Pattern] -> Parser Src.Pattern
127+ inContext E.ExprTuple (word1 0x28 {-(-} E.XXX) $
128+ do spaces
129+ oneOf E.XXX
130+ [ do (pattern, sPos) <- expression
131+ checkSpace sPos
132+ tupleHelp start pattern []
133+ , do word1 0x29 {-)-} E.XXX
134+ end <- getPosition
135+ return (A.at start end Src.PUnit)
136+ ]
137+
138+
139+tupleHelp :: A.Position -> Src.Pattern -> [Src.Pattern] -> Parser Src.Pattern
140140tupleHelp start firstPattern revPatterns =
141− oneOf
142− [ do Symbol.comma
141+ oneOf E.XXX
142+ [ do word1 0x2C {-,-} E.XXX
143143 spaces
144144 (pattern, sPos) <- expression
145145 checkSpace sPos
146146 tupleHelp start firstPattern (pattern : revPatterns)
147− , do Symbol.rightParen
147+ , do word1 0x29 {-)-} E.XXX
148148 case reverse revPatterns of
149149 [] ->
150150 return firstPattern
@@ -159,30 +159,29 @@ tupleHelp start firstPattern revPatterns =
159159-- LIST
160160
161161
162−list :: R.Position -> Parser Src.Pattern
162+list :: A.Position -> Parser Src.Pattern
163163list start =
164− do Symbol.leftSquare
165− inContext start E.PatternList $
166− do spaces
167− oneOf
168− [ do (pattern, sPos) <- expression
169− checkSpace sPos
170− listHelp start [pattern]
171− , do Symbol.rightSquare
172− end <- getPosition
173− return (A.at start end (Src.PList []))
174− ]
175−
176−
177−listHelp :: R.Position -> [Src.Pattern] -> Parser Src.Pattern
164+ inContext E.PatternList (word1 0x5B {-[-} E.XXX) $
165+ do spaces
166+ oneOf E.XXX
167+ [ do (pattern, sPos) <- expression
168+ checkSpace sPos
169+ listHelp start [pattern]
170+ , do word1 0x5D {-]-} E.XXX
171+ end <- getPosition
172+ return (A.at start end (Src.PList []))
173+ ]
174+
175+
176+listHelp :: A.Position -> [Src.Pattern] -> Parser Src.Pattern
178177listHelp start patterns =
179− oneOf
180− [ do Symbol.comma
178+ oneOf E.XXX
179+ [ do word1 0x2C {-,-} E.XXX
181180 spaces
182181 (pattern, sPos) <- expression
183182 checkSpace sPos
184183 listHelp start (pattern:patterns)
185− , do Symbol.rightSquare
184+ , do word1 0x5D {-]-} E.XXX
186185 end <- getPosition
187186 return (A.at start end (Src.PList (reverse patterns)))
188187 ]
@@ -194,17 +193,16 @@ listHelp start patterns =
194193
195194expression :: Parser (Src.Pattern, SPos)
196195expression =
197− hint E.Pattern $
198− do start <- getPosition
199− cTerm <- exprTerm
200− exprHelp start [] cTerm
196+ do start <- getPosition
197+ cTerm <- exprTerm
198+ exprHelp start [] cTerm
201199
202200
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)
204202exprHelp start patterns (pattern, _end, sPos) =
205− oneOf
203+ oneOf E.XXX
206204 [ do checkSpace sPos
207− Symbol.cons
205+ word1 0x3A {-:-} E.XXX
208206 spaces
209207 cTerm <- exprTerm
210208 exprHelp start (pattern:patterns) cTerm
@@ -228,8 +226,8 @@ exprHelp start patterns (pattern, _end, sPos) =
228226
229227
230228cons :: Src.Pattern -> Src.Pattern -> Src.Pattern
231−cons tl@(A.At (R.Region _ end) _) hd@(A.At (R.Region start _) _) =
232− A.at start end (Src.PCons hd tl)
229+cons tl hd =
230+ A.merge hd tl (Src.PCons hd tl)
233231
234232
235233
@@ -238,24 +236,24 @@ cons tl@(A.At (R.Region _ end) _) hd@(A.At (R.Region start _) _) =
238236
239237exprTerm :: SParser Src.Pattern
240238exprTerm =
241− oneOf
239+ oneOf E.XXX
242240 [
243241 do start <- getPosition
244242 upper <- Var.foreignUpper
245243 end <- getPosition
246− exprTermHelp (R.Region start end) upper start []
244+ exprTermHelp (A.Region start end) upper start []
247245 ,
248− do t@(A.At (R.Region _ end) _) <- term
246+ do t@(A.At (A.Region _ end) _) <- term
249247 pos <- whitespace
250248 return (t, end, pos)
251249 ]
252250
253251
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
255253exprTermHelp region upper start revArgs =
256254 do end <- getPosition
257255 sPos <- whitespace
258− oneOf
256+ oneOf E.XXX
259257 [ do checkSpace sPos
260258 arg <- term
261259 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
88
99
1010import qualified Data.ByteString.UTF8 as BS_UTF8
11−import qualified Data.Text as Text
12−import Data.Text (Text)
1311import Data.Name (Name)
1412
1513import qualified AST.Source as Src
16−import qualified Parse.Module as Module
17−import Parse.Primitives
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
14+import qualified Parse.Primitives as P
15+import Parse.Utils
2316
2417
2518
@@ -27,10 +20,10 @@ import qualified Reporting.Annotation as A
2720
2821
2922data Entry
30− = Import Name (Maybe Name) Src.Exposing Text
31− | Type Name Text
32− | Def (Maybe Name) Text
33− | Other Text
23+ = Import Name (Maybe Name) Src.Exposing String
24+ | Type Name String
25+ | Def (Maybe Name) String
26+ | Other String
3427 | Annotation
3528 | Port
3629
@@ -40,33 +33,40 @@ data Entry
4033
4134
4235parseEntry :: String -> Entry
43−parseEntry rawEntry =
44− let
45− source =
46− Text.pack rawEntry
47− in
48− case run (entryParser source) (BS_UTF8.fromString rawEntry) of
49− Right entry ->
50− entry
36+parseEntry source =
37+ case P.fromByteString parser (BS_UTF8.fromString source) of
38+ P.Ok entry _ ->
39+ entry
5140
52− Left _ ->
53− Other source
41+ P.Err _ _ _ _ ->
42+ Other source
5443
5544
56−entryParser :: Text -> Parser Entry
57−entryParser source =
45+parser :: Parser Entry
46+parser =
47+ error "TODO parse the REPL stuff"
48+
49+{-
5850 oneOf
59− [ do Keyword.import_
51+ [
52+ do Keyword.import_
6053 spaces
6154 name <- Var.moduleName
6255 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+ ]
6464 return (Import name alias exposing source)
65−
66− , do Keyword.port_
65+ ,
66+ do Keyword.port_
6767 return Port
68−
69− , do Keyword.type_
68+ ,
69+ do Keyword.type_
7070 spaces
7171 oneOf
7272 [ do Keyword.alias_
@@ -75,20 +75,20 @@ entryParser source =
7575 ]
7676 name <- Var.upper
7777 return (Type name source)
78−
79− , do root <- Pattern.term
78+ ,
79+ do root <- Pattern.term
8080 spaces
8181 case A.toValue root of
8282 Src.PVar name ->
8383 oneOf
84− [ do Symbol.hasType
84+ [ do word1 0x3A {-:-} E.XXX
8585 return Annotation
8686 , do chompArgs
8787 return (Def (Just name) source)
8888 ]
8989
9090 _ ->
91− do Symbol.equals
91+ do word1 0x3D {-=-} E.XXX
9292 return (Def Nothing source)
9393 ]
9494
@@ -99,7 +99,7 @@ chompArgs =
9999 [ do Pattern.term
100100 spaces
101101 chompArgs
102− , do Symbol.equals
102+ , do word1 0x3D {-=-} E.XXX
103103 return ()
104104 ]
105105
@@ -114,15 +114,4 @@ tryAlias =
114114 Just <$> Var.upper
115115 , return Nothing
116116 ]
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− ]
117+-}
compiler/src/Parse/Shader.hs+106−28
@@ -1,5 +1,5 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, UnboxedTuples #-}
33module Parse.Shader
44 ( shader
55 )
@@ -9,7 +9,9 @@ module Parse.Shader
99import qualified Data.List as List
1010import qualified Data.Map as Map
1111import 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)
1315import qualified Language.GLSL.Parser as GLP
1416import qualified Language.GLSL.Syntax as GLS
1517import qualified Text.Parsec as Parsec
@@ -17,37 +19,101 @@ import qualified Text.Parsec.Error as Parsec
1719
1820import qualified AST.Source as Src
1921import qualified AST.Utils.Shader as Shader
22+import Parse.Utils (Parser)
23+import qualified Parse.Primitives as P
2024import qualified Reporting.Annotation as A
21−import qualified Reporting.Region as R
22−import Parse.Primitives (Parser, getPosition)
23−import qualified Parse.Primitives.Shader as Shader
25+import qualified Reporting.Error.Syntax as E
2426
2527
2628
27−-- SHADERS
29+-- SHADER
2830
2931
30−shader :: R.Position -> Parser Src.Expr
31−shader start@(R.Position row col) =
32− do block <- Shader.block
33− shdr <- parseSource row col (Text.unpack block)
34− end@(R.Position row2 col2) <- getPosition
35− let uid = List.intercalate ":" (map show [row, col, row2, col2])
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))
32+shader :: A.Position -> Parser Src.Expr
33+shader start@(A.Position row col) =
34+ do block <- parseBlock
35+ shdr <- parseGlsl row col block
36+ end <- P.getPosition
37+ let src = List.intercalate "\\n" (lines block)
38+ return (A.at start end (Src.Shader (Utf8.fromChars src) shdr))
3839
3940
40−parseSource :: Int -> Int -> String -> Parser Shader.Shader
41−parseSource startRow startCol src =
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+
106+parseGlsl :: Word16 -> Word16 -> String -> Parser Shader.Types
107+parseGlsl startRow startCol src =
42108 case GLP.parse src of
43109 Right (GLS.TranslationUnit decls) ->
44− return (foldr addInput emptyShader (concatMap extractInputs decls))
110+ return (foldr addInput emptyTypes (concatMap extractInputs decls))
45111
46112 Left err ->
47113 let
48114 pos = Parsec.errorPos err
49− row = Parsec.sourceLine pos
50− col = Parsec.sourceColumn pos
115+ row = fromIntegral (Parsec.sourceLine pos)
116+ col = fromIntegral (Parsec.sourceColumn pos)
51117 msg =
52118 Parsec.showErrorMessages
53119 "or"
@@ -58,22 +124,32 @@ parseSource startRow startCol src =
58124 (Parsec.errorMessages err)
59125 in
60126 if row == 1 then
61− Shader.failure startRow (startCol + 6 + col) (Text.pack msg)
127+ failure startRow (startCol + 6 + col) msg
62128 else
63− Shader.failure (startRow + row - 1) col (Text.pack msg)
129+ failure (startRow + row - 1) col msg
130+
64131
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)
65136
66−emptyShader :: Shader.Shader
67−emptyShader =
68− Shader.Shader Map.empty Map.empty Map.empty
69137
70138
71−addInput :: (GLS.StorageQualifier, Shader.Type, String) -> Shader.Shader -> Shader.Shader
139+-- INPUTS
140+
141+
142+emptyTypes :: Shader.Types
143+emptyTypes =
144+ Shader.Types Map.empty Map.empty Map.empty
145+
146+
147+addInput :: (GLS.StorageQualifier, Shader.Type, String) -> Shader.Types -> Shader.Types
72148addInput (qual, tipe, name) glDecls =
73149 case qual of
74− GLS.Attribute -> glDecls { Shader._attribute = Map.insert (Name.fromString name) tipe (Shader._attribute glDecls) }
75− GLS.Uniform -> glDecls { Shader._uniform = Map.insert (Name.fromString name) tipe (Shader._uniform glDecls) }
76− GLS.Varying -> glDecls { Shader._varying = Map.insert (Name.fromString name) tipe (Shader._varying glDecls) }
150+ GLS.Attribute -> glDecls { Shader._attribute = Map.insert (Name.fromChars name) tipe (Shader._attribute glDecls) }
151+ GLS.Uniform -> glDecls { Shader._uniform = Map.insert (Name.fromChars name) tipe (Shader._uniform glDecls) }
152+ GLS.Varying -> glDecls { Shader._varying = Map.insert (Name.fromChars name) tipe (Shader._varying glDecls) }
77153 _ -> error "Should never happen due to `extractInputs` function"
78154
79155
@@ -101,3 +177,5 @@ extractInputs decl =
101177 GLS.Sampler2D -> [(qual, Shader.Texture, name)]
102178 _ -> []
103179 _ -> []
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
1010import qualified Data.Name as Name
1111
1212import qualified AST.Source as Src
13−import Parse.Primitives (Parser, SParser, addLocation, checkSpace, getPosition, hint, spaces, oneOf)
14−import qualified Parse.Primitives as P
15−import qualified Parse.Primitives.Symbol as Symbol
16−import qualified Parse.Primitives.Variable as Var
17−import Parse.Primitives.Whitespace (SPos, whitespace)
13+import Parse.Primitives (addLocation, getPosition, inContext, oneOf, word1, word2)
14+import Parse.Utils (Parser, SParser, SPos, checkSpace, spaces, whitespace)
15+import qualified Parse.Variable as Var
1816import qualified Reporting.Annotation as A
1917import qualified Reporting.Error.Syntax as E
20−import qualified Reporting.Region as R
2118
2219
2320
@@ -26,25 +23,64 @@ import qualified Reporting.Region as R
2623
2724term :: Parser Src.Type
2825term =
29− hint E.Type $
30− do start <- getPosition
31− oneOf
32− [ app0
33− , variable start
34− , tuple start
35− , record start
36− ]
37−
38−
39−
40−-- TYPE VARIABLES
41−
42−
43−variable :: R.Position -> Parser Src.Type
44−variable start =
45− do var <- Var.lower
46− end <- getPosition
47− return (A.at start end (Src.TVar var))
26+ do start <- getPosition
27+ oneOf E.XXX
28+ [
29+ -- types with no arguments (Int, Float, etc.)
30+ do upper <- Var.foreignUpper
31+ end <- getPosition
32+ let region = A.Region start end
33+ return $ A.At region $
34+ case upper of
35+ Var.Unqualified name ->
36+ Src.TType region name []
37+
38+ Var.Qualified home name ->
39+ Src.TTypeQual region home name []
40+ ,
41+ -- type variables
42+ do var <- Var.lower
43+ end <- getPosition
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+ ]
4884
4985
5086
@@ -53,16 +89,15 @@ variable start =
5389
5490expression :: SParser Src.Type
5591expression =
56− hint E.Type $
5792 do start <- getPosition
5893 (tipe1, end1, pos1) <-
59− oneOf
94+ oneOf E.XXX
6095 [ app start
6196 , (,,) <$> term <*> getPosition <*> whitespace
6297 ]
63− oneOf
98+ oneOf E.XXX
6499 [ do checkSpace pos1
65− Symbol.rightArrow
100+ word2 0x2D 0x3E {-->-} E.XXX
66101 spaces
67102 (tipe2, end2, pos2) <- expression
68103 let tipe = A.at start end2 (Src.TLambda tipe1 tipe2)
@@ -75,29 +110,14 @@ expression =
75110-- TYPE CONSTRUCTORS
76111
77112
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
94114app start =
95115 do upper <- Var.foreignUpper
96116 nameEnd <- getPosition
97117 namePos <- whitespace
98118 (args, end, pos) <- eatArgs [] nameEnd namePos
99119
100− let region = R.Region start nameEnd
120+ let region = A.Region start nameEnd
101121 let tipe =
102122 case upper of
103123 Var.Unqualified name ->
@@ -119,9 +139,9 @@ unionConstructor =
119139 return ( (A.at start nameEnd name, args), end, pos )
120140
121141
122−eatArgs :: [Src.Type] -> R.Position -> SPos -> SParser [Src.Type]
142+eatArgs :: [Src.Type] -> A.Position -> SPos -> SParser [Src.Type]
123143eatArgs args end pos =
124− oneOf
144+ oneOf E.XXX
125145 [ do checkSpace pos
126146 arg <- term
127147 newEnd <- getPosition
@@ -135,30 +155,15 @@ eatArgs args end pos =
135155-- TUPLES
136156
137157
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
154159tupleEnding start firstType revTypes =
155− oneOf
156− [ do Symbol.comma
160+ oneOf E.XXX
161+ [ do word1 0x2C {-,-} E.XXX
157162 spaces
158163 (tipe, _, pos) <- expression
159164 checkSpace pos
160165 tupleEnding start firstType (tipe : revTypes)
161− , do Symbol.rightParen
166+ , do word1 0x29 {-)-} E.XXX
162167 end <- getPosition
163168 case reverse revTypes of
164169 [] ->
@@ -174,46 +179,17 @@ tupleEnding start firstType revTypes =
174179-- RECORD
175180
176181
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−
206182type Field = ( A.Located Name.Name, Src.Type )
207183
208184
209185chompFields :: [Field] -> Parser [Field]
210186chompFields fields =
211− oneOf
212− [ do Symbol.comma
187+ oneOf E.XXX
188+ [ do word1 0x2C {-,-} E.XXX
213189 spaces
214190 f <- field
215191 chompFields (f : fields)
216− , do Symbol.rightCurly
192+ , do word1 0x7D {-}-} E.XXX
217193 return (reverse fields)
218194 ]
219195
@@ -222,7 +198,7 @@ field :: Parser Field
222198field =
223199 do name <- addLocation Var.lower
224200 spaces
225− Symbol.hasType
201+ word1 0x3A {-:-} E.XXX
226202 spaces
227203 (tipe, _, endPos) <- expression
228204 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#