git.iko.soy/elk
on master help sign in
Begin switching parser from UTF-16 to UTF-8
commit3b6fe38547b5502ecdb332918c23f5d9d5ae6b81 authorEvan Czaplicki <evancz@users.noreply.github.com> dateWed 11 Oct 2017, 15:07 (9 years ago) parentfa03159
12 files changed+2322−1588
compare with master
unifiedsplit
elm-compiler.cabal+11−1 src/Parse/Helpers.hs−222 src/Parse/Primitives.hs+79−1365 src/Parse/Primitives/Internals.hs+251 src/Parse/Primitives/Kernel.hs+117 src/Parse/Primitives/Keyword.hs+191 src/Parse/Primitives/Number.hs+267 src/Parse/Primitives/Shader.hs+69 src/Parse/Primitives/Symbol.hs+262 src/Parse/Primitives/Utf8.hs+478 src/Parse/Primitives/Variable.hs+374 src/Parse/Primitives/Whitespace.hs+223
elm-compiler.cabal+11−1
@@ -112,13 +112,21 @@ Library
112112 Optimize.Port,
113113 Parse.Declaration,
114114 Parse.Expression,
115− Parse.Helpers,
116115 Parse.Kernel,
117116 Parse.Literal,
118117 Parse.Module,
119118 Parse.Parse,
120119 Parse.Pattern,
121120 Parse.Primitives,
121+ Parse.Primitives.Internals,
122+ Parse.Primitives.Kernel,
123+ Parse.Primitives.Keyword,
124+ Parse.Primitives.Number,
125+ Parse.Primitives.Shader,
126+ Parse.Primitives.Symbol,
127+ Parse.Primitives.Utf8,
128+ Parse.Primitives.Variable,
129+ Parse.Primitives.Whitespace,
122130 Parse.Repl,
123131 Parse.Type,
124132 Reporting.Annotation,
@@ -163,6 +171,7 @@ Library
163171 directory >= 1.0 && < 2.0,
164172 edit-distance >= 0.2 && < 0.3,
165173 filepath >= 1 && < 2.0,
174+ ghc-prim,
166175 language-glsl >= 0.0.2 && < 0.3,
167176 mtl >= 2.2 && < 3,
168177 parsec,
@@ -172,6 +181,7 @@ Library
172181 semigroups,
173182 text >= 1 && < 2,
174183 unordered-containers,
184+ utf8-string,
175185 vector
176186
177187
src/Parse/Helpers.hsdeleted−222
@@ -1,222 +0,0 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Parse.Helpers
4− ( module Parse.Primitives
5− , SParser
6− , qualifiedVar, qualifiedCapVar
7− , equals, rightArrow, hasType, comma, pipe, cons, dot, minus, lambda
8− , leftParen, rightParen, leftSquare, rightSquare, leftCurly, rightCurly
9− , addLocation, inContext
10− , spaces, noSpace, checkSpace, checkAligned, checkFreshLine
11− )
12− where
13−
14−import qualified Data.Text as Text
15−import Data.Text (Text)
16−
17−import Parse.Primitives
18−import qualified Parse.Primitives as P
19−import qualified Reporting.Annotation as A
20−import qualified Reporting.Error.Syntax as E
21−import qualified Reporting.Region as R
22−
23−
24−
25−-- SPACE PARSER
26−
27−
28−type SParser a =
29− Parser (a, R.Position, SPos)
30−
31−
32−
33−-- VARIABLES
34−
35−
36−qualifiedCapVar :: Parser Text
37−qualifiedCapVar =
38− do var <- capVar
39− qualifiedVarHelp qualifiedCapVarHelp [var]
40−
41−
42−qualifiedCapVarHelp :: Parser a
43−qualifiedCapVarHelp =
44− deadend [E.CapVar]
45−
46−
47−qualifiedVar :: Parser Text
48−qualifiedVar =
49− oneOf
50− [ lowVar
51− , do var <- capVar
52− qualifiedVarHelp lowVar [var]
53− ]
54−
55−
56−qualifiedVarHelp :: Parser Text -> [Text] -> Parser Text
57−qualifiedVarHelp altEnding vars =
58− oneOf
59− [ do dot
60− oneOf
61− [ do var <- capVar
62− qualifiedVarHelp altEnding (var:vars)
63− , do var <- altEnding
64− return (Text.intercalate "." (reverse (var:vars)))
65− ]
66− , return (Text.intercalate "." (reverse vars))
67− ]
68−
69−
70−
71−-- COMMON SYMBOLS
72−
73−
74−{-# NOINLINE equals #-}
75−equals :: Parser ()
76−equals =
77− symbol "="
78−
79−
80−{-# NOINLINE rightArrow #-}
81−rightArrow :: Parser ()
82−rightArrow =
83− symbol "->"
84−
85−
86−{-# NOINLINE hasType #-}
87−hasType :: Parser ()
88−hasType =
89− symbol ":"
90−
91−
92−{-# NOINLINE comma #-}
93−comma :: Parser ()
94−comma =
95− symbol ","
96−
97−
98−{-# NOINLINE pipe #-}
99−pipe :: Parser ()
100−pipe =
101− symbol "|"
102−
103−
104−{-# NOINLINE cons #-}
105−cons :: Parser ()
106−cons =
107− symbol "::"
108−
109−
110−{-# NOINLINE dot #-}
111−dot :: Parser ()
112−dot =
113− symbol "."
114−
115−
116−{-# NOINLINE minus #-}
117−minus :: Parser ()
118−minus =
119− symbol "-"
120−
121−
122−{-# NOINLINE lambda #-}
123−lambda :: Parser ()
124−lambda =
125− oneOf [ symbol "\\", symbol "\x03BB" ]
126−
127−
128−
129−-- ENCLOSURES
130−
131−
132−{-# NOINLINE leftParen #-}
133−leftParen :: Parser ()
134−leftParen =
135− symbol "("
136−
137−
138−{-# NOINLINE rightParen #-}
139−rightParen :: Parser ()
140−rightParen =
141− symbol ")"
142−
143−
144−{-# NOINLINE leftSquare #-}
145−leftSquare :: Parser ()
146−leftSquare =
147− symbol "["
148−
149−
150−{-# NOINLINE rightSquare #-}
151−rightSquare :: Parser ()
152−rightSquare =
153− symbol "]"
154−
155−
156−{-# NOINLINE leftCurly #-}
157−leftCurly :: Parser ()
158−leftCurly =
159− symbol "{"
160−
161−
162−{-# NOINLINE rightCurly #-}
163−rightCurly :: Parser ()
164−rightCurly =
165− symbol "}"
166−
167−
168−
169−-- LOCATION
170−
171−
172−addLocation :: Parser a -> Parser (A.Located a)
173−addLocation parser =
174− do start <- getPosition
175− value <- parser
176− end <- getPosition
177− return (A.at start end value)
178−
179−
180−inContext :: R.Position -> E.Context -> Parser a -> Parser a
181−inContext pos ctx parser =
182− do P.pushContext pos ctx
183− a <- parser
184− P.popContext a
185−
186−
187−-- WHITESPACE VARIATIONS
188−
189−
190−spaces :: Parser ()
191−spaces =
192− checkSpace =<< whitespace
193−
194−
195−noSpace :: R.Position -> SPos -> Parser ()
196−noSpace pos (SPos spos) =
197− if pos == spos
198− then return ()
199− else deadend []
200−
201−
202−checkSpace :: SPos -> Parser ()
203−checkSpace (SPos (R.Position _ col)) =
204− do indent <- getIndent
205− if col > indent && col > 1
206− then return ()
207− else deadend [E.BadSpace]
208−
209−
210−checkAligned :: SPos -> Parser ()
211−checkAligned (SPos (R.Position _ col)) =
212− do indent <- getIndent
213− if col == indent
214− then return ()
215− else deadend [E.BadSpace]
216−
217−
218−checkFreshLine :: SPos -> Parser ()
219−checkFreshLine (SPos (R.Position _ col)) =
220− if col == 1
221− then return ()
222− else deadend [E.BadSpace]
src/Parse/Primitives.hs+79−1365
@@ -1,136 +1,77 @@
11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples, OverloadedStrings #-}
2+{-# LANGUAGE OverloadedStrings #-}
33module Parse.Primitives
4− ( Parser
4+ ( I.Parser
5+ , I.oneOf
56 , run, runAt
67 , try, deadend, hint, endOfFile
7− , oneOf
8− , symbol, underscore, keyword, keywords
9− , lowVar, capVar, infixOp
108 , getPosition, getCol
119 , getContext, pushContext, popContext
1210 , getIndent, setIndent
13− , SPos(..), whitespace
14− , docComment, chompUntilDocs
15− , string, character
16− , digit, number
17− , shaderSource, shaderFailure
18− , kernelChunk, ChunkTag(..)
11+ , W.SPos
12+ , SParser
13+ , addLocation, inContext
14+ , spaces, noSpace, checkSpace, checkAligned, checkFreshLine
1915 )
2016 where
2117
18+
2219import Prelude hiding (length)
23−import qualified Control.Applicative as Applicative ( Applicative(..), Alternative(..) )
24−import Control.Monad
25−import qualified Data.ByteString as BS
26−import qualified Data.ByteString.Builder as BS (toLazyByteString, word16HexFixed)
27−import qualified Data.ByteString.Lazy as BS (toStrict)
28−import qualified Data.Char as Char
29−import Data.Monoid ((<>))
30−import qualified Data.Set as Set
31−import Data.Text (Text)
32−import qualified Data.Text as Text
33−import qualified Data.Text.Array as Text
34−import qualified Data.Text.Encoding as Text
35−import qualified Data.Text.Internal as Text
36−import qualified Data.Text.Unsafe as Text
37−import qualified Data.Text.Lazy as LT
38−import qualified Data.Text.Lazy.Builder as B
39−import Data.Text.Internal.Encoding.Utf16 (chr2)
40−import Data.Text.Internal.Unsafe.Char (unsafeChr)
41−import GHC.Word (Word8, Word16)
42−
43−import qualified AST.Helpers as Help (isSymbol)
44−import qualified AST.Literal as L
20+import qualified Data.ByteString.Internal as B
21+
22+import Parse.Primitives.Internals (Parser(..), State(..), expect, noError)
23+import qualified Parse.Primitives.Internals as I
24+import qualified Parse.Primitives.Whitespace as W
4525import qualified Reporting.Annotation as A
4626import qualified Reporting.Error.Syntax as E
4727import qualified Reporting.Region as R
48−import Reporting.Error.Syntax
49− ( ParseError(..), Problem(..), Theory(..), BadOp(..)
50− )
51−
52−
53−
54−-- PARSER
55−
56−
57−newtype Parser a =
58− Parser (
59− forall b.
60− State
61− -> (a -> State -> ParseError -> b) -- consumed ok
62− -> ( ParseError -> b) -- consumed err
63− -> (a -> State -> ParseError -> b) -- empty ok
64− -> ( ParseError -> b) -- empty err
65− -> b
66− )
67−
68−
69−data State =
70− State
71− { _array :: !Text.Array
72− , _offset :: !Int
73− , _length :: !Int
74− , _indent :: !Int
75− , _row :: !Int
76− , _col :: !Int
77− , _context :: E.ContextStack
78− }
79−
80−
81−{-# NOINLINE noError #-}
82−noError :: ParseError
83−noError =
84− ParseError 0 0 (Theories [] [])
8528
8629
87−{-# INLINE expect #-}
88−expect :: Int -> Int -> E.ContextStack -> Theory -> ParseError
89−expect row col ctx theory =
90− ParseError row col (Theories ctx [theory])
9130
31+-- RUN
9232
9333
94−-- RUN PARSER
34+run :: Parser a -> B.ByteString -> Either (A.Located E.Error) a
35+run parser bytes =
36+ runAt 1 1 parser bytes
9537
9638
97−run :: Parser a -> Text -> Either (A.Located E.Error) a
98−run parser text =
99− runAt 1 1 parser text
100−
101−
102−runAt :: Int -> Int -> Parser a -> Text -> Either (A.Located E.Error) a
103−runAt sRow sCol (Parser parser) (Text.Text array offset length) =
104− case parser (State array offset length 0 sRow sCol []) Ok Err Ok Err of
39+runAt :: Int -> Int -> Parser a -> B.ByteString -> Either (A.Located E.Error) a
40+runAt startRow startColumn (Parser parser) (B.PS fp offset length) =
41+ case parser (State fp offset (offset + length) 0 startRow startColumn []) Ok Err Ok Err of
10542 Ok value _ _ ->
10643 Right value
10744
108− Err (ParseError row col problem) ->
45+ Err (E.ParseError row col problem) ->
10946 let
11047 pos = R.Position row col
11148 mkError overallRegion subRegion =
11249 Left (A.A overallRegion (E.Parse subRegion problem))
11350 in
11451 case problem of
115− BadChar endCol ->
52+ E.BadChar endCol ->
11653 mkError (R.Region pos (R.Position row endCol)) Nothing
11754
118− BadEscape width _ ->
55+ E.BadEscape width _ ->
11956 mkError (R.Region pos (R.Position row (col + width))) Nothing
12057
121− BadOp _ ((_, start) : _) ->
58+ E.BadOp _ ((_, start) : _) ->
12259 mkError (R.Region start pos) (Just (R.Region pos pos))
12360
124− Theories ((_, start) : _) _ ->
61+ E.Theories ((_, start) : _) _ ->
12562 mkError (R.Region start pos) (Just (R.Region pos pos))
12663
12764 _ ->
12865 mkError (R.Region pos pos) Nothing
12966
13067
68+
69+-- RESULT
70+
71+
13172data Result a
132− = Ok a State ParseError
133− | Err ParseError
73+ = Ok a State E.ParseError
74+ | Err E.ParseError
13475
13576
13677
@@ -143,16 +84,10 @@ try (Parser parser) =
14384 parser state cok eerr eok eerr
14485
14586
146−shaderFailure :: Int -> Int -> Text -> Parser a
147−shaderFailure row col msg =
148− Parser $ \_ _ cerr _ _ ->
149− cerr (ParseError row col (BadShader msg))
150−
151−
152−deadend :: [Theory] -> Parser a
87+deadend :: [E.Theory] -> Parser a
15388deadend thrys =
15489 Parser $ \(State _ _ _ _ row col ctx) _ _ _ eerr ->
155− eerr (ParseError row col (Theories ctx thrys))
90+ eerr (E.ParseError row col (E.Theories ctx thrys))
15691
15792
15893hint :: E.Next -> Parser a -> Parser a
@@ -160,387 +95,21 @@ hint next (Parser parser) =
16095 Parser $ \state@(State _ _ _ _ row col ctx) cok cerr eok eerr ->
16196 let
16297 eok' x s _ =
163− eok x s (expect row col ctx (Expecting next))
98+ eok x s (expect row col ctx (E.Expecting next))
16499
165100 eerr' _ =
166− eerr (expect row col ctx (Expecting next))
101+ eerr (expect row col ctx (E.Expecting next))
167102 in
168103 parser state cok cerr eok' eerr'
169104
170105
171106endOfFile :: Parser ()
172107endOfFile =
173− Parser $ \state@(State _ _ length _ _ _ _) _ _ eok eerr ->
174− if length == 0 then
175− eok () state noError
176−
177− else
108+ Parser $ \state@(State _ offset terminal _ _ _ _) _ _ eok eerr ->
109+ if offset < terminal then
178110 eerr noError
179−
180−
181−
182−-- FUNCTOR
183−
184−
185−instance Functor Parser where
186− {-# INLINE fmap #-}
187− fmap f (Parser parser) =
188− Parser $ \state cok cerr eok eerr ->
189− let
190− cok' x s e = cok (f x) s e
191− eok' x s e = eok (f x) s e
192− in
193− parser state cok' cerr eok' eerr
194−
195−
196−
197−-- APPLICATIVE
198−
199−
200−instance Applicative.Applicative Parser where
201− {-# INLINE pure #-}
202− pure = return
203−
204− {-# INLINE (<*>) #-}
205− (<*>) = ap
206−
207−
208−instance Applicative.Alternative Parser where
209− {-# INLINE empty #-}
210− empty = allTheOptionsFailed
211−
212− {-# INLINE (<|>) #-}
213− (<|>) = oneOfHelp
214−
215−
216−oneOf :: [Parser a] -> Parser a
217−oneOf parsers =
218− foldr oneOfHelp allTheOptionsFailed parsers
219−
220−
221−allTheOptionsFailed :: Parser a
222−allTheOptionsFailed =
223− Parser $ \_ _ _ _ eerr ->
224− eerr noError
225−
226−
227−oneOfHelp :: Parser a -> Parser a -> Parser a
228−oneOfHelp (Parser parser1) (Parser parser2) =
229− Parser $ \state cok cerr eok eerr ->
230− let
231− eerr1 e1 =
232− let
233− eok2 y s e2 = eok y s (mergeErrors e1 e2)
234− eerr2 e2 = eerr (mergeErrors e1 e2)
235− in
236− parser2 state cok cerr eok2 eerr2
237− in
238− parser1 state cok cerr eok eerr1
239−
240−
241−mergeErrors :: ParseError -> ParseError -> ParseError
242−mergeErrors e1@(ParseError r1 c1 p1) e2@(ParseError r2 c2 p2) =
243− case compare r1 r2 of
244− LT -> e2
245− GT -> e1
246− EQ ->
247− case compare c1 c2 of
248− LT -> e2
249− GT -> e1
250− EQ ->
251− case (p1, p2) of
252− (Theories _ [], Theories _ _) ->
253− e2
254−
255− (Theories _ _, Theories _ []) ->
256− e1
257−
258− (Theories ctx ts1, Theories _ ts2) ->
259− ParseError r1 c1 (Theories ctx (ts1 ++ ts2))
260−
261− (Theories _ _, _) ->
262− e2
263−
264− (_, _) ->
265− e1
266−
267−
268−
269−-- MONAD
270−
271−
272−instance Monad Parser where
273− {-# INLINE return #-}
274− return value =
275− Parser $ \state _ _ eok _ ->
276− eok value state noError
277−
278− {-# INLINE (>>=) #-}
279− (Parser parser) >>= callback =
280− Parser $ \state cok cerr eok eerr ->
281− let
282− cok1 x s1 e1 =
283− let
284− eok2 y s2 e2 = cok y s2 (mergeErrors e1 e2)
285− eerr2 e2 = cerr (mergeErrors e1 e2)
286− in
287− case callback x of
288− Parser parser2 -> parser2 s1 cok cerr eok2 eerr2
289−
290− eok1 x s1 e1 =
291− let
292− eok2 y s2 e2 = eok y s2 (mergeErrors e1 e2)
293− eerr2 e2 = eerr (mergeErrors e1 e2)
294− in
295− case callback x of
296− Parser parser2 -> parser2 s1 cok cerr eok2 eerr2
297− in
298− parser state cok1 cerr eok1 eerr
299−
300−
301−
302−-- TEXT
303−
304−
305−{-# INLINE symbol #-}
306−symbol :: Text -> Parser ()
307−symbol sym@(Text.Text tArray tOffset tLen) =
308− let !theory = Symbol sym in
309− Parser $ \(State array offset length indent row col ctx) cok _ _ eerr ->
310− if tLen <= length && Text.equal tArray tOffset array offset tLen then
311− let
312− (# newRow, newCol #) =
313− moveCursor tArray tOffset tLen row col
314−
315− !newState =
316− State array (offset + tLen) (length - tLen) indent newRow newCol ctx
317− in
318− cok () newState noError
319−
320− else
321− eerr (expect row col ctx theory)
322−
323−
324−moveCursor :: Text.Array -> Int -> Int -> Int -> Int -> (# Int, Int #)
325−moveCursor array offset length row col =
326− if length == 0 then
327− (# row, col #)
328−
329− else
330− let
331− !word = Text.unsafeIndex array offset
332− in
333− if word == 0x000A {- \n -} then
334− moveCursor array (offset + 1) (length - 1) (row + 1) 1
335−
336− else if word < 0xD800 || 0xDBFF < word then
337− moveCursor array (offset + 1) (length - 1) row (col + 1)
338−
339− else
340− moveCursor array (offset + 2) (length - 2) row (col + 1)
341−
342−
343−underscore :: Parser ()
344−underscore =
345− Parser $ \(State array offset length indent row col ctx) cok cerr _ eerr ->
346− if length == 0 || Text.unsafeIndex array offset /= 0x005F {- _ -} then
347− eerr noError
348−
349− else if length >= 2 && isInnerVarChar (peekChar array (offset + 1)) then
350− cerr (ParseError row (col + 1) (BadUnderscore (peekChar array (offset + 1))))
351−
352− else
353− let
354− !newState =
355− State array (offset + 1) (length - 1) indent row (col + 1) ctx
356− in
357− cok () newState noError
358−
359−
360−
361−-- KEYWORDS
362−
363−
364−keyword :: Text -> Parser ()
365−keyword kwd@(Text.Text tArray tOffset tLen) =
366− Parser $ \(State array offset length indent row col ctx) cok _ _ eerr ->
367− if tLen <= length && Text.equal tArray tOffset array offset tLen then
368−
369− if isInnerVarChar (peekChar array (offset + tLen)) then
370− eerr (expect row col ctx (Keyword kwd))
371−
372− else
373− let
374− (# newRow, newCol #) =
375− moveCursor tArray tOffset tLen row col
376−
377− !newState =
378− State array (offset + tLen) (length - tLen) indent newRow newCol ctx
379− in
380− cok () newState noError
381−
382− else
383− eerr (expect row col ctx (Keyword kwd))
384−
385−
386−keywords :: Set.Set Text
387−keywords =
388− Set.fromList
389− [ "if", "then", "else"
390− , "case", "of"
391− , "let", "in"
392− , "type"
393− , "module", "where"
394− , "import", "exposing"
395− , "as"
396− , "port"
397− ]
398−
399−
400−
401−-- VARIABLES
402−
403−
404−lowVar :: Parser Text.Text
405−lowVar =
406− varPrim LowVar Char.isLower
407−
408−
409−capVar :: Parser Text.Text
410−capVar =
411− varPrim CapVar Char.isUpper
412−
413−
414−{-# INLINE varPrim #-}
415−varPrim :: Theory -> (Char -> Bool) -> Parser Text.Text
416−varPrim theory isGoodFirstChar =
417− Parser $ \(State array offset length indent row col ctx) cok _ _ eerr ->
418− if length == 0 then
419− eerr (expect row col ctx theory)
420−
421− else
422− let
423− (Text.Iter char size) = peek array offset
424− in
425− if isGoodFirstChar char then
426− let
427− (# newOffset, newLength, newCol #) =
428− varPrimHelp array (offset + size) (length - size) (col + 1)
429−
430− copiedText =
431− copyText array offset (newOffset - offset)
432− in
433− if Set.member copiedText keywords then
434− eerr (expect row newCol ctx theory)
435− else
436− cok copiedText (State array newOffset newLength indent row newCol ctx) noError
437−
438− else
439− eerr (expect row col ctx theory)
440−
441−
442−{-# INLINE copyText #-}
443−copyText :: Text.Array -> Int -> Int -> Text.Text
444−copyText array offset size =
445− let
446− makeArray =
447− do mutableArray <- Text.new size
448− Text.copyI mutableArray 0 array offset size
449− return mutableArray
450− in
451− Text.Text (Text.run makeArray) 0 size
452−
453−
454−{-# INLINE peek #-}
455−peek :: Text.Array -> Int -> Text.Iter
456−peek array offset =
457− let
458− !word = Text.unsafeIndex array offset
459− in
460− if word < 0xD800 || 0xDBFF < word then
461− Text.Iter (unsafeChr word) 1
462− else
463− Text.Iter (chr2 word (Text.unsafeIndex array (offset + 1))) 2
464−
465−
466−{-# INLINE peekChar #-}
467−peekChar :: Text.Array -> Int -> Char
468−peekChar array offset =
469− let
470− !word = Text.unsafeIndex array offset
471− in
472− if word < 0xD800 || 0xDBFF < word then
473− unsafeChr word
474− else
475− chr2 word (Text.unsafeIndex array (offset + 1))
476−
477−
478−varPrimHelp :: Text.Array -> Int -> Int -> Int -> (# Int, Int, Int #)
479−varPrimHelp array offset length col =
480− if length == 0 then
481− (# offset, length, col #)
482−
483− else
484− let
485− (Text.Iter char size) = peek array offset -- TODO look for latin chars directly?
486− in
487− if isInnerVarChar char then
488− varPrimHelp array (offset + size) (length - size) (col + 1)
489−
490− else
491− (# offset, length, col #)
492−
493−
494−{-# INLINE isInnerVarChar #-}
495−isInnerVarChar :: Char -> Bool
496−isInnerVarChar char =
497− Char.isAlphaNum char || char == '_'
498−
499−
500−
501−-- INFIX OPS
502−
503−
504−infixOp :: Parser Text
505−infixOp =
506− Parser $ \(State array offset length indent row col ctx) cok cerr _ eerr ->
507− if length == 0 then
508− eerr (expect row col ctx InfixOp)
509−
510111 else
511− let
512− (Text.Iter char size) = peek array offset
513− in
514− if not (Help.isSymbol char) then
515− eerr (expect row col ctx InfixOp)
516− else
517− case infixOpHelp array (offset + size) (length - size) row (col + 1) of
518− Left err ->
519− cerr err
520−
521− Right ( newOffset, newLength, newCol ) ->
522− case copyText array offset (newOffset - offset) of
523− "." -> cerr (ParseError row col (BadOp Dot ctx))
524− "|" -> cerr (ParseError row col (BadOp Pipe ctx))
525− "->" -> cerr (ParseError row col (BadOp Arrow ctx))
526− "=" -> cerr (ParseError row col (BadOp Equals ctx))
527− ":" -> cerr (ParseError row col (BadOp HasType ctx))
528− op -> cok op (State array newOffset newLength indent row newCol ctx) noError
529−
530−
531−infixOpHelp :: Text.Array -> Int -> Int -> Int -> Int -> Either ParseError (Int, Int, Int)
532−infixOpHelp array offset length row col =
533− if length == 0 then
534− Right ( offset, length, col )
535−
536− else
537− let
538− (Text.Iter char size) = peek array offset
539− in
540− if Help.isSymbol char then
541− infixOpHelp array (offset + size) (length - size) row (col + 1)
542− else
543− Right ( offset, length, col )
112+ eok () state noError
544113
545114
546115
@@ -591,920 +160,65 @@ setIndent indent =
591160
592161
593162
594−-- WHITESPACE
595−
596−
597−newtype SPos =
598− SPos R.Position
599−
600−
601−whitespace :: Parser SPos
602−whitespace =
603− Parser $ \(State array offset length indent row col ctx) cok cerr _ _ ->
604− case eatSpaces array offset length row col of
605− Left err ->
606− cerr err
607−
608− Right (newOffset, newLength, newRow, newCol) ->
609− cok
610− (SPos (R.Position newRow newCol))
611− (State array newOffset newLength indent newRow newCol ctx)
612− noError
613−
614−
615−eatSpaces :: Text.Array -> Int -> Int -> Int -> Int -> Either ParseError ( Int, Int, Int, Int )
616−eatSpaces array offset length row col =
617− if length == 0 then
618− Right ( offset, length, row, col )
619−
620− else
621− case Text.unsafeIndex array offset of
622− 0x0020 {- -} ->
623− eatSpaces array (offset + 1) (length - 1) row (col + 1)
624−
625− 0x000A {- \n -} ->
626− eatSpaces array (offset + 1) (length - 1) (row + 1) 1
627−
628− 0x007B {- { -} ->
629− eatMultiComment array offset length row col
630−
631− 0x002D {- - -} ->
632− eatLineComment array offset length row col
633−
634− 0x000D {- \r -} ->
635− eatSpaces array (offset + 1) (length - 1) row col
636−
637− 0x0009 {- \t -} ->
638− Left (ParseError row col Tab)
639−
640− _ ->
641− Right ( offset, length, row, col )
642−
643−
644−
645−-- LINE COMMENTS
646−
647−
648−eatLineComment :: Text.Array -> Int -> Int -> Int -> Int -> Either ParseError ( Int, Int, Int, Int )
649−eatLineComment array offset length row col =
650− if length == 1 then
651− Right ( offset, length, row, col )
652−
653− else
654− case Text.unsafeIndex array (offset + 1) of
655− 0x002D {- - -} ->
656− eatLineCommentHelp array (offset + 2) (length - 2) row (col + 2)
657−
658− _ ->
659− Right ( offset, length, row, col )
660−
661−
662−eatLineCommentHelp :: Text.Array -> Int -> Int -> Int -> Int -> Either ParseError ( Int, Int, Int, Int )
663−eatLineCommentHelp array offset length row col =
664− if length == 0 then
665− Right ( offset, length, row, col )
666−
667− else
668− let
669− !word = Text.unsafeIndex array offset
670− in
671− if word == 0x000A {- \n -} then
672− eatSpaces array (offset + 1) (length - 1) (row + 1) 1
673−
674− else if word < 0xD800 || 0xDBFF < word then
675− eatLineCommentHelp array (offset + 1) (length - 1) row (col + 1)
676−
677− else
678− eatLineCommentHelp array (offset + 2) (length - 2) row (col + 1)
679−
680−
681−
682−-- MULTI COMMENTS
683−
684−
685−eatMultiComment :: Text.Array -> Int -> Int -> Int -> Int -> Either ParseError ( Int, Int, Int, Int )
686−eatMultiComment array offset length row col =
687− if length <= 2 then
688− Right ( offset, length, row, col )
689−
690− else
691− let
692− !yesDash = Text.unsafeIndex array (offset + 1) == 0x002D {- - -}
693− !noBar = Text.unsafeIndex array (offset + 2) /= 0x007C {- | -}
694− in
695− if yesDash && noBar then
696− do (newOffset, newLength, newRow, newCol) <-
697− eatMultiCommentHelp array (offset + 2) (length - 2) row (col + 2) 1
698− eatSpaces array newOffset newLength newRow newCol
699−
700− else
701− Right ( offset, length, row, col )
702−
703−
704−eatMultiCommentHelp :: Text.Array -> Int -> Int -> Int -> Int -> Int -> Either ParseError ( Int, Int, Int, Int )
705−eatMultiCommentHelp array offset length row col openComments =
706− if length == 0 then
707− Left (ParseError row col EndOfFile_Comment)
708−
709− else
710− let
711− !word = Text.unsafeIndex array offset
712− in
713− if word == 0x000A {- \n -} then
714−
715− eatMultiCommentHelp array (offset + 1) (length - 1) (row + 1) 1 openComments
716−
717− else if word == 0x002D {- - -} && length > 1 && Text.unsafeIndex array (offset + 1) == 0x007D {- } -} then
718−
719− if openComments == 1 then
720− Right ( offset + 2, length - 2, row, col + 2 )
721− else
722− eatMultiCommentHelp array (offset + 2) (length - 2) row (col + 2) (openComments - 1)
723−
724− else if word == 0x007B {- { -} && length > 1 && Text.unsafeIndex array (offset + 1) == 0x002D {- - -} then
725−
726− eatMultiCommentHelp array (offset + 2) (length - 2) row (col + 2) (openComments + 1)
727−
728− else if word < 0xD800 || 0xDBFF < word then
729−
730− eatMultiCommentHelp array (offset + 1) (length - 1) row (col + 1) openComments
731−
732− else
733−
734− eatMultiCommentHelp array (offset + 2) (length - 2) row (col + 1) openComments
735−
736−
737−
738−-- DOCUMENTATION COMMENT
739−
740−
741−docComment :: Parser Text
742−docComment =
743− do docCommentOpen
744− Parser $ \(State array offset length indent row col ctx) cok cerr _ _ ->
745− case eatMultiCommentHelp array offset length row col 1 of
746− Left err ->
747− cerr err
748−
749− Right (newOffset, newLength, newRow, newCol) ->
750− cok
751− (copyText array offset (newOffset - offset - 2))
752− (State array newOffset newLength indent newRow newCol ctx)
753− noError
754−
755−
756−{-# NOINLINE docCommentOpen #-}
757−docCommentOpen :: Parser ()
758−docCommentOpen =
759− symbol "{-|"
760−
761−
762−chompUntilDocs :: Parser Bool
763−chompUntilDocs =
764− Parser $ \(State array offset length indent row col ctx) cok _ _ _ ->
765− let
766− (# isStart, newOffset, newLength, newRow, newCol #) =
767− eatDocs array offset length row col
768−
769− !newState =
770− State array newOffset newLength indent newRow newCol ctx
771− in
772− cok isStart newState noError
773−
774−
775−eatDocs :: Text.Array -> Int -> Int -> Int -> Int -> (# Bool, Int, Int, Int, Int #)
776−eatDocs array offset length row col =
777− if length == 0 then
778− (# False, offset, length, row, col #)
779−
780− else if isDocsStart array offset length then
781− (# True, offset + 5, length - 5, row, col + 5 #)
782−
783− else
784− let
785− !word = Text.unsafeIndex array offset
786− in
787− if word == 0x000A {- \n -} then
788− eatDocs array (offset + 1) (length - 1) (row + 1) 1
789−
790− else if word < 0xD800 || 0xDBFF < word then
791− eatDocs array (offset + 1) (length - 1) row (col + 1)
792−
793− else
794− eatDocs array (offset + 2) (length - 2) row (col + 1)
795−
796−
797−isDocsStart :: Text.Array -> Int -> Int -> Bool
798−isDocsStart array offset length =
799− length >= 5
800− && Text.unsafeIndex array offset == 0x0040 {- @ -}
801− && Text.unsafeIndex array (offset + 1) == 0x0064 {- d -}
802− && Text.unsafeIndex array (offset + 2) == 0x006F {- o -}
803− && Text.unsafeIndex array (offset + 3) == 0x0063 {- c -}
804− && Text.unsafeIndex array (offset + 4) == 0x0073 {- s -}
805−
806−
807−
808−-- STRINGS
809−
810−
811−string :: Parser Text.Text
812−string =
813− Parser $ \(State array offset length indent row col ctx) cok cerr _ eerr ->
814− if length == 0 then
815− eerr noError
816−
817− else
818− let
819− !word = Text.unsafeIndex array offset
820− in
821− if word /= 0x0022 {- " -} then
822− eerr noError
823−
824− else
825− let
826− stringResult =
827− if length >= 3 && isQuote array (offset + 1) && isQuote array (offset + 2) then
828− multiString array (offset + 3) (length - 3) row (col + 3) (offset + 3) mempty
829− else
830− singleString array (offset + 1) (length - 1) row (col + 1) (offset + 1) mempty
831− in
832− case stringResult of
833− Left err ->
834− cerr err
835−
836− Right ( newOffset, newLength, newCol, builder ) ->
837− cok
838− (LT.toStrict (B.toLazyText builder))
839− (State array newOffset newLength indent row newCol ctx)
840− noError
841−
842−
843−{-# INLINE isQuote #-}
844−isQuote :: Text.Array -> Int -> Bool
845−isQuote array offset =
846− Text.unsafeIndex array offset == 0x0022 {- " -}
847−
848−
849−
850−-- SINGLE STRINGS
851−
852−
853−singleString :: Text.Array -> Int -> Int -> Int -> Int -> Int -> B.Builder -> Either ParseError ( Int, Int, Int, B.Builder )
854−singleString array offset length row col initialOffset builder =
855− if length == 0 then
856− Left (ParseError row col EndOfFile_String)
857−
858− else
859− let
860− !word = Text.unsafeIndex array offset
861− in
862− if word == 0x0022 {- " -} then
863− Right
864− ( offset + 1
865− , length - 1
866− , col + 1
867− , builder <> B.fromText (copyText array initialOffset (offset - initialOffset))
868− )
869−
870− else if word == 0x000A {- \n -} then
871− Left (ParseError row col NewLineInString)
872−
873− else if word == 0x0027 {- ' -} then
874− singleStringHelp array offset length row col initialOffset builder 1 "\\'"
875−
876− else if word == 0x005C {- \ -} then
877− case eatEscape array (offset + 1) (length - 1) of
878− EscapeNormal ->
879− singleString array (offset + 2) (length - 2) row (col + 2) initialOffset builder
880−
881− EscapeUnicode delta code ->
882− singleStringHelp array offset length row col initialOffset builder delta code
883−
884− EscapeProblem newOffset problem ->
885− Left (ParseError row col (BadEscape (newOffset - offset) problem))
886−
887− EscapeEndOfFile ->
888− Left (ParseError row (col + 1) EndOfFile_String)
889−
890− else if word < 0xD800 || 0xDBFF < word then
891− singleString array (offset + 1) (length - 1) row (col + 1) initialOffset builder
892−
893− else
894− singleString array (offset + 2) (length - 2) row (col + 1) initialOffset builder
895−
896−
897−singleStringHelp :: Text.Array -> Int -> Int -> Int -> Int -> Int -> B.Builder -> Int -> Text.Text -> Either ParseError ( Int, Int, Int, B.Builder )
898−singleStringHelp array offset length row col initialOffset builder delta escape =
899− let
900− chunk = copyText array initialOffset (offset - initialOffset)
901− newBuilder = builder <> B.fromText chunk <> B.fromText escape
902− !newOffset = offset + delta
903− in
904− singleString array newOffset (length - delta) row (col + delta) newOffset newBuilder
905−
906−
907−
908−-- MULTI STRINGS
909−
910−
911−multiString :: Text.Array -> Int -> Int -> Int -> Int -> Int -> B.Builder -> Either ParseError ( Int, Int, Int, B.Builder )
912−multiString array offset length row col initialOffset builder =
913− if length < 3 then
914− Left (ParseError row col EndOfFile_MultiString)
915−
916− else
917− let
918− !word = Text.unsafeIndex array offset
919− in
920− if word == 0x0022 {- " -} && isQuote array (offset + 1) && isQuote array (offset + 2) then
921− Right
922− ( offset + 3
923− , length - 3
924− , col + 3
925− , builder <> B.fromText (copyText array initialOffset (offset - initialOffset))
926− )
927−
928− else if word == 0x0027 {- ' -} then
929− multiStringHelp array offset length row col initialOffset builder 1 "\\'"
930−
931− else if word == 0x000A {- \n -} then
932− multiStringHelp array offset length row col initialOffset builder 1 "\\n"
933−
934− else if word == 0x005C {- \ -} then
935−
936− case eatEscape array (offset + 1) (length - 1) of
937− EscapeNormal ->
938− multiString array (offset + 2) (length - 2) row (col + 2) initialOffset builder
939−
940− EscapeUnicode delta code ->
941− multiStringHelp array offset length row col initialOffset builder delta code
942−
943− EscapeProblem newOffset problem ->
944− Left (ParseError row col (BadEscape (newOffset - offset) problem))
945−
946− EscapeEndOfFile ->
947− Left (ParseError row (col + 1) EndOfFile_MultiString)
948−
949− else if word < 0xD800 || 0xDBFF < word then
950− multiString array (offset + 1) (length - 1) row (col + 1) initialOffset builder
951−
952− else
953− multiString array (offset + 2) (length - 2) row (col + 1) initialOffset builder
954−
955−
956−multiStringHelp :: Text.Array -> Int -> Int -> Int -> Int -> Int -> B.Builder -> Int -> Text.Text -> Either ParseError ( Int, Int, Int, B.Builder )
957−multiStringHelp array offset length row col initialOffset builder delta escape =
958− let
959− chunk = copyText array initialOffset (offset - initialOffset)
960− newBuilder = builder <> B.fromText chunk <> B.fromText escape
961− !newOffset = offset + delta
962− in
963− multiString array newOffset (length - delta) row (col + delta) newOffset newBuilder
964−
965−
966−
967−-- CHARACTER
968−
969−
970−character :: Parser Text
971−character =
972− Parser $ \(State array offset length indent row col ctx) cok cerr _ eerr ->
973− if length == 0 then
974− eerr noError
975−
976− else
977− if Text.unsafeIndex array offset /= 0x0027 {- ' -} then
978− eerr noError
979−
980− else
981− case chompChar array (offset + 1) (length - 1) row (col + 1) 0 "" of
982− Left err ->
983− cerr err
984−
985− Right ( newOffset, newLength, newCol, numChars, mostRecentChar ) ->
986− if numChars /= 1 then
987− cerr (ParseError row col (BadChar newCol))
988− else
989− cok mostRecentChar
990− (State array newOffset newLength indent row newCol ctx)
991− noError
992−
993−chompChar :: Text.Array -> Int -> Int -> Int -> Int -> Int -> Text.Text -> Either ParseError ( Int, Int, Int, Int, Text.Text )
994−chompChar array offset length row col numChars mostRecentChar =
995− if length == 0 then
996− Left (ParseError row col EndOfFile_Char)
997−
998− else
999− let
1000− !word = Text.unsafeIndex array offset
1001− in
1002− if word == 0x0027 {- ' -} then
1003− Right
1004− ( offset + 1
1005− , length - 1
1006− , col + 1
1007− , numChars
1008− , mostRecentChar
1009− )
1010−
1011− else if word == 0x000A {- \n -} then
1012− Left (ParseError row col NewLineInChar)
1013−
1014− else if word == 0x0022 {- " -} then
1015− chompChar array (offset + 1) (length - 1) row (col + 1) (numChars + 1) "\\\""
1016−
1017− else if word == 0x005C {- \ -} then
1018− case eatEscape array (offset + 1) (length - 1) of
1019− EscapeNormal ->
1020− chompChar array (offset + 2) (length - 2) row (col + 2) (numChars + 1) (copyText array offset 2)
1021−
1022− EscapeUnicode delta code ->
1023− chompChar array (offset + delta) (length - delta) row (col + delta) (numChars + 1) code
1024−
1025− EscapeProblem newOffset problem ->
1026− Left (ParseError row col (BadEscape (newOffset - offset) problem))
1027−
1028− EscapeEndOfFile ->
1029− Left (ParseError row col EndOfFile_Char)
1030−
1031− else if word < 0xD800 || 0xDBFF < word then
1032− chompChar array (offset + 1) (length - 1) row (col + 1) (numChars + 1) (copyText array offset 1)
1033−
1034− else
1035− chompChar array (offset + 2) (length - 2) row (col + 1) (numChars + 1) (copyText array offset 2)
1036−
1037−
1038−
1039−-- ESCAPE CHARACTERS
1040−
1041−
1042−data Escape
1043− = EscapeNormal
1044− | EscapeUnicode !Int Text.Text
1045− | EscapeProblem !Int E.EscapeProblem
1046− | EscapeEndOfFile
1047−
1048−
1049−eatEscape :: Text.Array -> Int -> Int -> Escape
1050−eatEscape array offset length =
1051− if length == 0 then
1052− EscapeEndOfFile
1053−
1054− else
1055− case Text.unsafeIndex array offset of
1056− 0x006E {- n -} -> EscapeNormal
1057− 0x0072 {- r -} -> EscapeNormal
1058− 0x0074 {- t -} -> EscapeNormal
1059− 0x0022 {- " -} -> EscapeNormal
1060− 0x0027 {- ' -} -> EscapeNormal
1061− 0x005C {- \ -} -> EscapeNormal
1062− 0x0075 {- u -} -> eatUnicode array (offset + 1) (length - 1)
1063− _ -> EscapeProblem offset E.UnknownEscape
1064−
1065−
1066−eatUnicode :: Text.Array -> Int -> Int -> Escape
1067−eatUnicode array offset length =
1068− if length == 0 || Text.unsafeIndex array offset /= 0x007B {- { -} then
1069− EscapeProblem offset E.UnicodeSyntax
1070− else
1071− let
1072− !digitOffset =
1073− offset + 1
1074−
1075− (# newOffset, newLength, code #) =
1076− chompHex array digitOffset (length - 1)
1077−
1078− !numDigits =
1079− newOffset - digitOffset
1080− in
1081− if newLength == 0 || Text.unsafeIndex array newOffset /= 0x007D {- } -} then
1082− EscapeProblem newOffset E.UnicodeSyntax
1083−
1084− else if code < 0 || 0x10FFFF < code then
1085− EscapeProblem (newOffset + 1) E.UnicodeRange
1086−
1087− else if numDigits < 4 || 6 < numDigits then
1088− EscapeProblem (newOffset + 1) $
1089− E.UnicodeLength numDigits (copyText array digitOffset numDigits)
1090−
1091− else
1092− EscapeUnicode (numDigits + 4) (codePointToBuilder code)
1093−
1094−
1095−{-# INLINE codePointToBuilder #-}
1096−codePointToBuilder :: Int -> Text.Text
1097−codePointToBuilder code =
1098− if code < 0xFFFF then
1099− "\\u" <> toHex code
1100−
1101− else
1102− "\\u" <> toHex ((code `div` 0x400) + 0xD800)
1103− <>
1104− "\\u" <> toHex ((code `mod` 0x400) + 0xDC00)
1105−
1106−
1107−toHex :: Int -> Text.Text
1108−toHex word16 =
1109− Text.decodeUtf8 $ BS.toStrict $ BS.toLazyByteString $
1110− BS.word16HexFixed (fromIntegral word16)
1111−
1112−
1113−
1114−-- DIGITS
1115−
1116−
1117−digit :: Parser Int
1118−digit =
1119− Parser $ \(State array offset length indent row col ctx) cok _ _ eerr ->
1120− if length == 0 then
1121− eerr (expect row col ctx Digit)
1122−
1123− else
1124− let
1125− !word = Text.unsafeIndex array offset
1126− in
1127− if isDigit word then
1128− cok
1129− (fromIntegral (word - 0x0030 {- 0 -}))
1130− (State array (offset + 1) (length - 1) indent row (col + 1) ctx)
1131− noError
1132− else
1133− eerr (expect row col ctx Digit)
1134−
1135−
1136−
1137−-- NUMBERS
1138−
1139−
1140−number :: Parser L.Literal
1141−number =
1142− Parser $ \(State array offset length indent row col ctx) cok cerr _ eerr ->
1143− if length == 0 then
1144− eerr noError
1145−
1146− else
1147− let
1148− !word = Text.unsafeIndex array offset
1149− in
1150− if not (isDigit word) then
1151− eerr noError
1152−
1153− else
1154− let
1155− chompResults =
1156− if word == 0x0030 {- 0 -} then
1157− chompZero array offset (offset + 1) (length - 1)
1158− else
1159− chompInt array offset (offset + 1) (length - 1)
1160− in
1161− case chompResults of
1162− Left (newOffset, problem) ->
1163− cerr (ParseError row (col + (newOffset - offset)) problem)
1164−
1165− Right (newOffset, newLength, literal) ->
1166− if isDirtyEnd array newOffset newLength then
1167− cerr (ParseError row (col + (newOffset - offset)) BadNumberEnd)
1168−
1169− else
1170− cok
1171− literal
1172− (State array newOffset newLength indent row (col + (newOffset - offset)) ctx)
1173− noError
1174−
1175−
1176−isDirtyEnd :: Text.Array -> Int -> Int -> Bool
1177−isDirtyEnd array offset length =
1178− if length == 0 then
1179− False
1180−
1181− else
1182− let
1183− !char = peekChar array offset
1184− in
1185− Char.isAlpha char || char == '_'
1186−
1187−
1188−chompInt :: Text.Array -> Int -> Int -> Int -> Either (Int, Problem) (Int, Int, L.Literal)
1189−chompInt array startOffset offset length =
1190− if length == 0 then
1191−
1192− Right ( offset, length, readInt array startOffset offset )
1193−
1194− else
1195−
1196− let
1197− !word = Text.unsafeIndex array offset
1198− in
1199− if isDigit word then
1200− chompInt array startOffset (offset + 1) (length - 1)
1201−
1202− else if word == 0x002E {- . -} then
1203− chompFraction array startOffset (offset + 1) (length - 1)
1204−
1205− else if word == 0x0065 {- e -} || word == 0x0045 {- E -} then
1206− chompExponent array startOffset (offset + 1) (length - 1)
1207−
1208− else
1209− Right ( offset, length, readInt array startOffset offset )
1210−
1211−
1212−chompFraction :: Text.Array -> Int -> Int -> Int -> Either (Int, Problem) (Int, Int, L.Literal)
1213−chompFraction array startOffset offset length =
1214− if length == 0 then
1215− Left (offset, BadNumberDot)
1216−
1217− else if isDigit (Text.unsafeIndex array offset) then
1218− chompFractionHelp array startOffset (offset + 1) (length - 1)
1219−
1220− else
1221− Left (offset, BadNumberDot)
1222−
1223−
1224−chompFractionHelp :: Text.Array -> Int -> Int -> Int -> Either (Int, Problem) (Int, Int, L.Literal)
1225−chompFractionHelp array startOffset offset length =
1226− if length == 0 then
1227− Right (offset, length, readFloat array startOffset offset)
1228−
1229− else
1230− let
1231− !word = Text.unsafeIndex array offset
1232− in
1233− if isDigit word then
1234− chompFractionHelp array startOffset (offset + 1) (length - 1)
1235−
1236− else if word == 0x0065 {- e -} || word == 0x0045 {- E -} then
1237− chompExponent array startOffset (offset + 1) (length - 1)
1238−
1239− else
1240− Right (offset, length, readFloat array startOffset offset)
1241−
1242−
1243−chompExponent :: Text.Array -> Int -> Int -> Int -> Either (Int, Problem) (Int, Int, L.Literal)
1244−chompExponent array startOffset offset length =
1245− if length == 0 then
1246− Right (offset, length, readFloat array startOffset offset)
1247−
1248− else
1249− let
1250− !word = Text.unsafeIndex array offset
1251− in
1252− if isDigit word then
1253− chompExponentHelp array startOffset (offset + 1) (length - 1)
1254−
1255− else if word == 0x002B {- + -} || word == 0x002D {- - -} then
1256−
1257− if length > 1 && isDigit (Text.unsafeIndex array (offset + 1)) then
1258− chompExponentHelp array startOffset (offset + 2) (length - 2)
1259− else
1260− Left (offset, BadNumberExp)
1261−
1262− else
1263− Left (offset, BadNumberExp)
1264−
1265−
1266−chompExponentHelp :: Text.Array -> Int -> Int -> Int -> Either (Int, Problem) (Int, Int, L.Literal)
1267−chompExponentHelp array startOffset offset length =
1268− if length == 0 then
1269− Right (offset, length, readFloat array startOffset offset)
1270−
1271− else if isDigit (Text.unsafeIndex array offset) then
1272− chompExponentHelp array startOffset (offset + 1) (length - 1)
1273−
1274− else
1275− Right (offset, length, readFloat array startOffset offset)
1276−
1277−
1278−chompZero :: Text.Array -> Int -> Int -> Int -> Either (Int, Problem) (Int, Int, L.Literal)
1279−chompZero array startOffset offset length =
1280− if length == 0 then
1281− Right ( offset, length, L.IntNum 0 )
1282−
1283− else
1284− let
1285− !word = Text.unsafeIndex array offset
1286− in
1287− if word == 0x0078 {- x -} then
1288− chompHexNumber array (offset + 1) (length - 1)
1289−
1290− else if word == 0x002E {- . -} then
1291− chompFraction array startOffset (offset + 1) (length - 1)
1292−
1293− else if isDigit word then
1294− Left (offset, BadNumberZero)
163+-- SPACE PARSER
1295164
1296− else
1297− Right ( offset, length, L.IntNum 0 )
1298165
166+type SParser a =
167+ Parser (a, R.Position, W.SPos)
1299168
1300−chompHexNumber :: Text.Array -> Int -> Int -> Either (Int, Problem) (Int, Int, L.Literal)
1301−chompHexNumber array offset length =
1302− let
1303− (# newOffset, newLength, hexNumber #) =
1304− chompHex array offset length
1305− in
1306− if hexNumber == -1 then
1307− Left ( newOffset, BadNumberHex )
1308− else
1309− Right ( newOffset, newLength, L.IntNum hexNumber )
1310169
1311170
171+-- LOCATION
1312172
1313−-- NUMBER HELPERS
1314173
174+addLocation :: Parser a -> Parser (A.Located a)
175+addLocation parser =
176+ do start <- getPosition
177+ value <- parser
178+ end <- getPosition
179+ return (A.at start end value)
1315180
1316−{-# INLINE isDigit #-}
1317−isDigit :: Word16 -> Bool
1318−isDigit word =
1319− word <= 0x0039 {- 9 -} && word >= 0x0030 {- 0 -}
1320181
182+inContext :: R.Position -> E.Context -> Parser a -> Parser a
183+inContext pos ctx parser =
184+ do pushContext pos ctx
185+ a <- parser
186+ popContext a
1321187
1322−{-# INLINE readInt #-}
1323−readInt :: Text.Array -> Int -> Int -> L.Literal
1324−readInt array startOffset endOffset =
1325− L.IntNum $ read $ Text.unpack $
1326− Text.Text array startOffset (endOffset - startOffset)
1327−
1328−
1329−{-# INLINE readFloat #-}
1330−readFloat :: Text.Array -> Int -> Int -> L.Literal
1331−readFloat array startOffset endOffset =
1332− L.FloatNum $ read $ Text.unpack $
1333− Text.Text array startOffset (endOffset - startOffset)
1334−
1335−
1336−
1337−-- CHOMP HEX
1338−
1339−
1340−-- Return -1 if it has NO digits
1341−-- Return -2 if it has BAD digits
1342−
1343−{-# INLINE chompHex #-}
1344−chompHex :: Text.Array -> Int -> Int -> (# Int, Int, Int #)
1345−chompHex array offset length =
1346− chompHexHelp array offset length (-1) 0
1347−
1348−
1349−chompHexHelp :: Text.Array -> Int -> Int -> Int -> Int -> (# Int, Int, Int #)
1350−chompHexHelp array offset length finalNumber hexNumber =
1351− if length == 0 then
1352− (# offset, length, finalNumber #)
1353− else
1354− let
1355− !newNumber =
1356− stepHex (Text.unsafeIndex array offset) hexNumber
1357− in
1358− if newNumber < 0 then
1359− (# offset, length, if newNumber == -1 then finalNumber else -2 #)
1360− else
1361− chompHexHelp array (offset + 1) (length - 1) newNumber newNumber
1362−
1363−
1364−{-# INLINE stepHex #-}
1365−stepHex :: Word16 -> Int -> Int
1366−stepHex word hexNumber =
1367− if word <= 0x0039 {- 9 -} && word >= 0x0030 {- 0 -} then
1368− 16 * hexNumber + fromIntegral (word - 0x0030 {- 0 -})
1369−
1370− else if word <= 0x0066 {- f -} && word >= 0x0061 {- a -} then
1371− 16 * hexNumber + 10 + fromIntegral (word - 0x0061 {- a -})
1372−
1373− else if word <= 0x0046 {- F -} && word >= 0x0041 {- A -} then
1374− 16 * hexNumber + 10 + fromIntegral (word - 0x0041 {- A -})
1375−
1376− else
1377− -1
1378−
1379−
1380−
1381−-- SHADER
1382−
1383−
1384−shaderSource :: Parser Text
1385−shaderSource =
1386− do shaderSourceOpen
1387− Parser $ \(State array offset length indent row col ctx) cok cerr _ _ ->
1388− case eatShader array offset length row col of
1389− Nothing ->
1390− cerr (ParseError row col EndOfFile_Shader)
1391−
1392− Just ( shaderEndOffset, newRow, newCol ) ->
1393− let
1394− !size = shaderEndOffset - offset
1395− !newState =
1396− State array (shaderEndOffset + 2) (length - size - 2) indent newRow newCol ctx
1397− in
1398− cok (copyText array offset size) newState noError
1399−
1400−
1401−{-# NOINLINE shaderSourceOpen #-}
1402−shaderSourceOpen :: Parser ()
1403−shaderSourceOpen =
1404− symbol "[glsl|"
1405−
1406−
1407−eatShader :: Text.Array -> Int -> Int -> Int -> Int -> Maybe (Int, Int, Int)
1408−eatShader array offset length row col =
1409− if length < 2 then
1410− Nothing
1411−
1412− else
1413− let
1414− !word = Text.unsafeIndex array offset
1415− in
1416− if word == 0x007C {- | -} && Text.unsafeIndex array (offset + 1) == 0x005D {- ] -} then
1417− Just ( offset, row, col + 2 )
1418−
1419− else if word == 0x000A {- \n -} then
1420− eatShader array (offset + 1) (length - 1) (row + 1) 1
1421−
1422− else if word < 0xD800 || 0xDBFF < word then
1423− eatShader array (offset + 1) (length - 1) row (col + 1)
1424−
1425− else
1426− eatShader array (offset + 2) (length - 2) row (col + 1)
1427−
1428−
1429−
1430−-- KERNEL CHOMP
1431−
1432−
1433−data ChunkTag
1434− = KernelEnum Word8 Text
1435− | KernelProd
1436− | KernelDebug
1437− | KernelImport Text
1438− | KernelJsField Text
1439− | KernelElmField Text
1440−
1441−
1442−kernelChunk :: Parser (BS.ByteString, Maybe ChunkTag)
1443−kernelChunk =
1444− Parser $ \(State array offset length indent row col ctx) cok _ _ _ ->
1445− let
1446− (# maybeChunkTag, jsOffset, newOffset, newLength, newRow, newCol #) =
1447− chompChunk array offset length row col
1448−
1449− !javascript =
1450− Text.encodeUtf8 (copyText array offset (jsOffset - offset))
1451−
1452− !newState =
1453− State array newOffset newLength indent newRow newCol ctx
1454− in
1455− cok (javascript, maybeChunkTag) newState noError
1456−
1457−
1458−chompChunk :: Text.Array -> Int -> Int -> Int -> Int -> (# Maybe ChunkTag, Int, Int, Int, Int, Int #)
1459−chompChunk array offset length row col =
1460− if length == 0 then
1461− (# Nothing, offset, offset, length, row, col #)
1462−
1463− else
1464− let
1465− !word = Text.unsafeIndex array offset
1466− in
1467− if word == 0x005F {- _ -} && length > 3 && Text.unsafeIndex array (offset + 1) == 0x005F {- _ -} then
1468− chompChunkTag array offset (offset + 2) (length - 2) row (col + 2)
1469−
1470− else if word == 0x000A {- \n -} then
1471− chompChunk array (offset + 1) (length - 1) (row + 1) 1
1472188
1473− else if word < 0xD800 || 0xDBFF < word then
1474− chompChunk array (offset + 1) (length - 1) row (col + 1)
189+-- WHITESPACE VARIATIONS
1475190
1476− else
1477− chompChunk array (offset + 2) (length - 2) row (col + 1)
1478191
192+spaces :: Parser ()
193+spaces =
194+ checkSpace =<< W.whitespace
1479195
1480−chompChunkTag :: Text.Array -> Int -> Int -> Int -> Int -> Int -> (# Maybe ChunkTag, Int, Int, Int, Int, Int #)
1481−chompChunkTag array jsOffset offset length row col =
1482− let
1483− (# newOffset, newLength, newCol #) =
1484− varPrimHelp array (offset + 1) (length - 1) (col + 1)
1485196
1486− !word =
1487− Text.unsafeIndex array offset
197+noSpace :: R.Position -> W.SPos -> Parser ()
198+noSpace pos (W.SPos spos) =
199+ if pos == spos
200+ then return ()
201+ else deadend []
1488202
1489− !chunkTag =
1490− if word == 0x0024 {- $ -} then
1491− KernelElmField (copyText array (offset + 1) (newOffset - offset - 1))
1492203
1493− else
1494− let !chunk = copyText array offset (newOffset - offset) in
1495− if isDigit word then
1496− KernelEnum (fromIntegral (word - 0x0030 {- 0 -})) chunk
204+checkSpace :: W.SPos -> Parser ()
205+checkSpace (W.SPos (R.Position _ col)) =
206+ do indent <- getIndent
207+ if col > indent && col > 1
208+ then return ()
209+ else deadend [E.BadSpace]
1497210
1498− else if 0x0061 {- a -} <= word && word <= 0x007A {- z -} then
1499− KernelJsField chunk
1500211
1501− else if chunk == "DEBUG" then
1502− KernelDebug
212+checkAligned :: W.SPos -> Parser ()
213+checkAligned (W.SPos (R.Position _ col)) =
214+ do indent <- getIndent
215+ if col == indent
216+ then return ()
217+ else deadend [E.BadSpace]
1503218
1504− else if chunk == "PROD" then
1505− KernelProd
1506219
1507− else
1508− KernelImport chunk
1509− in
1510− (# Just chunkTag, jsOffset, newOffset, newLength, row, newCol #)
220+checkFreshLine :: W.SPos -> Parser ()
221+checkFreshLine (W.SPos (R.Position _ col)) =
222+ if col == 1
223+ then return ()
224+ else deadend [E.BadSpace]
src/Parse/Primitives/Internals.hsnew file+251
@@ -0,0 +1,251 @@
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2+{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples, OverloadedStrings #-}
3+module Parse.Primitives.Internals
4+ ( Parser(..)
5+ , State(..)
6+ , noError, expect
7+ , unsafeIndex, isWord, getCharWidth
8+ , isSubstring, isNonNewlineAscii
9+ , oneOf
10+ )
11+ where
12+
13+
14+import Prelude hiding (length)
15+import qualified Control.Applicative as Applicative ( Applicative(..), Alternative(..) )
16+import Control.Monad
17+import qualified Data.ByteString.Internal as B
18+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
19+import Foreign.Ptr (plusPtr)
20+import Foreign.Storable (peekByteOff)
21+import GHC.ForeignPtr (touchForeignPtr, unsafeForeignPtrToPtr)
22+import GHC.Word (Word8)
23+
24+import qualified Reporting.Error.Syntax as E
25+
26+
27+
28+-- PARSER
29+
30+
31+newtype Parser a =
32+ Parser (
33+ forall b.
34+ State
35+ -> (a -> State -> E.ParseError -> b) -- consumed ok
36+ -> ( E.ParseError -> b) -- consumed err
37+ -> (a -> State -> E.ParseError -> b) -- empty ok
38+ -> ( E.ParseError -> b) -- empty err
39+ -> b
40+ )
41+
42+
43+data State =
44+ State
45+ { _source :: !(ForeignPtr Word8)
46+ , _offset :: !Int
47+ , _terminal :: !Int
48+ , _indent :: !Int
49+ , _row :: !Int
50+ , _col :: !Int
51+ , _context :: E.ContextStack
52+ }
53+
54+
55+
56+-- ERRORS
57+
58+
59+{-# NOINLINE noError #-}
60+noError :: E.ParseError
61+noError =
62+ E.ParseError 0 0 (E.Theories [] [])
63+
64+
65+{-# INLINE expect #-}
66+expect :: Int -> Int -> E.ContextStack -> E.Theory -> E.ParseError
67+expect row col ctx theory =
68+ E.ParseError row col (E.Theories ctx [theory])
69+
70+
71+
72+-- LOW-LEVEL CHECKS
73+
74+
75+unsafeIndex :: ForeignPtr Word8 -> Int -> Word8
76+unsafeIndex fp offset =
77+ B.accursedUnutterablePerformIO $
78+ do word <- peekByteOff (unsafeForeignPtrToPtr fp) offset
79+ touchForeignPtr fp
80+ return word
81+
82+
83+{-# INLINE isWord #-}
84+isWord :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Bool
85+isWord fp offset terminal word =
86+ offset < terminal && unsafeIndex fp offset == word
87+
88+
89+getCharWidth :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Int
90+getCharWidth _fp _offset _terminal word
91+ | word < 0x80 = 1
92+ | word < 0xc0 = error "Need UTF-8 encoded input. Ran into unrecognized bits."
93+ | word < 0xe0 = 2
94+ | word < 0xf0 = 3
95+ | word < 0xf8 = 4
96+ | True = error "Need UTF-8 encoded input. Ran into unrecognized bits."
97+
98+
99+{-# INLINE isSubstring #-}
100+isSubstring :: ForeignPtr Word8 -> Int -> Int -> ForeignPtr Word8 -> Int -> Int -> Bool
101+isSubstring subFp subOffset subLength fp offset terminal =
102+ offset + subLength <= terminal
103+ &&
104+ equals fp offset subFp subOffset subLength
105+
106+
107+equals :: ForeignPtr Word8 -> Int -> ForeignPtr Word8 -> Int -> Int -> Bool
108+equals fp1 offset1 fp2 offset2 length =
109+ B.accursedUnutterablePerformIO $
110+ withForeignPtr fp1 $ \ptr1 ->
111+ withForeignPtr fp2 $ \ptr2 ->
112+ do i <- B.memcmp (plusPtr ptr1 offset1) (plusPtr ptr2 offset2) (fromIntegral length)
113+ return $! i == 0
114+
115+
116+
117+-- VERIFY BYTESTRING STRUCTURE
118+
119+
120+-- Written weird to try to make TCE more likely
121+isNonNewlineAscii :: ForeignPtr Word8 -> Int -> Int -> Bool
122+isNonNewlineAscii !fp !offset !terminal =
123+ if offset < terminal then
124+ let !word = unsafeIndex fp offset in
125+ if word < 128 && word /= 0x0A {- \n -} then
126+ isNonNewlineAscii fp (offset + 1) terminal
127+ else
128+ False
129+
130+ else
131+ True
132+
133+
134+
135+-- FUNCTOR
136+
137+
138+instance Functor Parser where
139+ {-# INLINE fmap #-}
140+ fmap f (Parser parser) =
141+ Parser $ \state cok cerr eok eerr ->
142+ let
143+ cok' x s e = cok (f x) s e
144+ eok' x s e = eok (f x) s e
145+ in
146+ parser state cok' cerr eok' eerr
147+
148+
149+
150+-- APPLICATIVE
151+
152+
153+instance Applicative.Applicative Parser where
154+ {-# INLINE pure #-}
155+ pure = return
156+
157+ {-# INLINE (<*>) #-}
158+ (<*>) = ap
159+
160+
161+instance Applicative.Alternative Parser where
162+ {-# INLINE empty #-}
163+ empty = allTheOptionsFailed
164+
165+ {-# INLINE (<|>) #-}
166+ (<|>) = oneOfHelp
167+
168+
169+oneOf :: [Parser a] -> Parser a
170+oneOf parsers =
171+ foldr oneOfHelp allTheOptionsFailed parsers
172+
173+
174+allTheOptionsFailed :: Parser a
175+allTheOptionsFailed =
176+ Parser $ \_ _ _ _ eerr ->
177+ eerr noError
178+
179+
180+oneOfHelp :: Parser a -> Parser a -> Parser a
181+oneOfHelp (Parser parser1) (Parser parser2) =
182+ Parser $ \state cok cerr eok eerr ->
183+ let
184+ eerr1 e1 =
185+ let
186+ eok2 y s e2 = eok y s (mergeErrors e1 e2)
187+ eerr2 e2 = eerr (mergeErrors e1 e2)
188+ in
189+ parser2 state cok cerr eok2 eerr2
190+ in
191+ parser1 state cok cerr eok eerr1
192+
193+
194+mergeErrors :: E.ParseError -> E.ParseError -> E.ParseError
195+mergeErrors e1@(E.ParseError r1 c1 p1) e2@(E.ParseError r2 c2 p2) =
196+ case compare r1 r2 of
197+ LT -> e2
198+ GT -> e1
199+ EQ ->
200+ case compare c1 c2 of
201+ LT -> e2
202+ GT -> e1
203+ EQ ->
204+ case (p1, p2) of
205+ (E.Theories _ [], E.Theories _ _) ->
206+ e2
207+
208+ (E.Theories _ _, E.Theories _ []) ->
209+ e1
210+
211+ (E.Theories ctx ts1, E.Theories _ ts2) ->
212+ E.ParseError r1 c1 (E.Theories ctx (ts1 ++ ts2))
213+
214+ (E.Theories _ _, _) ->
215+ e2
216+
217+ (_, _) ->
218+ e1
219+
220+
221+
222+-- MONAD
223+
224+
225+instance Monad Parser where
226+ {-# INLINE return #-}
227+ return value =
228+ Parser $ \state _ _ eok _ ->
229+ eok value state noError
230+
231+ {-# INLINE (>>=) #-}
232+ (Parser parser) >>= callback =
233+ Parser $ \state cok cerr eok eerr ->
234+ let
235+ cok1 x s1 e1 =
236+ let
237+ eok2 y s2 e2 = cok y s2 (mergeErrors e1 e2)
238+ eerr2 e2 = cerr (mergeErrors e1 e2)
239+ in
240+ case callback x of
241+ Parser parser2 -> parser2 s1 cok cerr eok2 eerr2
242+
243+ eok1 x s1 e1 =
244+ let
245+ eok2 y s2 e2 = eok y s2 (mergeErrors e1 e2)
246+ eerr2 e2 = eerr (mergeErrors e1 e2)
247+ in
248+ case callback x of
249+ Parser parser2 -> parser2 s1 cok cerr eok2 eerr2
250+ in
251+ parser state cok1 cerr eok1 eerr
src/Parse/Primitives/Kernel.hsnew file+117
@@ -0,0 +1,117 @@
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.Text.Encoding as Text
13+import Data.Text (Text)
14+import Data.Word (Word8)
15+import Foreign.ForeignPtr (ForeignPtr)
16+
17+import Parse.Primitives.Internals (Parser(..), State(..), noError)
18+import qualified Parse.Primitives.Internals as I
19+import qualified Parse.Primitives.Variable as Var
20+
21+
22+
23+-- SPECIAL
24+
25+
26+data Special
27+ = Enum Word8 Text
28+ | Prod
29+ | Debug
30+ | Import Text
31+ | JsField Text
32+ | ElmField Text
33+
34+
35+
36+-- CHUNK
37+
38+
39+chunk :: Parser (B.ByteString, Maybe Special)
40+chunk =
41+ Parser $ \(State fp offset terminal indent row col ctx) cok _ _ _ ->
42+ let
43+ (# maybeSpecial, jsOffset, newOffset, newRow, newCol #) =
44+ chompChunk fp offset terminal row col
45+
46+ !javascript = B.PS fp offset (jsOffset - offset)
47+ !newState = State fp newOffset terminal indent newRow newCol ctx
48+ in
49+ cok (javascript, maybeSpecial) newState noError
50+
51+
52+
53+-- CHOMP CHUNK
54+
55+
56+chompChunk :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> (# Maybe Special, Int, Int, Int, Int #)
57+chompChunk fp offset terminal row col =
58+ if offset >= terminal then
59+ (# Nothing, offset, offset, row, col #)
60+
61+ else
62+ let !word = I.unsafeIndex fp offset in
63+ if word == 0x5F {- _ -} then
64+
65+ let
66+ !offset1 = offset + 1
67+ !offset3 = offset + 3
68+ in
69+ if offset3 <= terminal && I.unsafeIndex fp offset1 == 0x5F {- _ -} then
70+ chompSpecial fp offset3 terminal row (col + 3) offset
71+ else
72+ chompChunk fp offset1 terminal row (col + 1)
73+
74+ else if word == 0x0A {- \n -} then
75+ chompChunk fp (offset + 1) terminal (row + 1) 1
76+
77+ else
78+ let !newOffset = offset + I.getCharWidth fp offset terminal word in
79+ chompChunk fp newOffset terminal row (col + 1)
80+
81+
82+
83+-- CHOMP TAG
84+
85+
86+-- relies on external checks in chompChunk
87+chompSpecial :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Int -> (# Maybe Special, Int, Int, Int, Int #)
88+chompSpecial fp offset terminal row col jsOffset =
89+ let
90+ (# newOffset, newCol #) =
91+ Var.chompInnerChars fp offset terminal col
92+
93+ !tagOffset = offset - 1
94+ !word = I.unsafeIndex fp tagOffset
95+
96+ !special =
97+ if word == 0x24 {- $ -} then
98+ ElmField (Text.decodeUtf8 (B.PS fp offset (newOffset - offset)))
99+
100+ else
101+ let !name = Text.decodeUtf8 (B.PS fp tagOffset (newOffset - tagOffset)) in
102+ if 0x30 <= word && word <= 0x39 then
103+ Enum (fromIntegral (word - 0x30)) name
104+
105+ else if 0x61 {- a -} <= word && word <= 0x7A {- z -} then
106+ JsField name
107+
108+ else if name == "DEBUG" then
109+ Debug
110+
111+ else if name == "PROD" then
112+ Prod
113+
114+ else
115+ Import name
116+ in
117+ (# Just special, jsOffset, newOffset, row, newCol #)
src/Parse/Primitives/Keyword.hsnew file+191
@@ -0,0 +1,191 @@
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+ , module_, import_, exposing_, as_, where_, effect_
9+ , infix_, infixr_, infixl_
10+ )
11+ where
12+
13+
14+import Control.Exception (assert)
15+import qualified Data.ByteString.Internal as B
16+import qualified Data.ByteString.Char8 as Char8
17+
18+import Parse.Primitives.Internals (Parser(..), State(..), expect, noError)
19+import qualified Parse.Primitives.Internals as I
20+import qualified Parse.Primitives.Variable as Var
21+import qualified Reporting.Error.Syntax as E
22+
23+
24+
25+-- PRIVATE IMPLEMENTATION
26+
27+
28+{- We can some avoid allocation by declaring all available keywords here.
29+That means the `keyword` function should only be used within this file on
30+values tagged as NOINLINE.
31+-}
32+keyword :: B.ByteString -> Parser ()
33+keyword kwd@(B.PS kwdFp kwdOffset kwdLength) =
34+ let
35+ !theory =
36+ assert
37+ (I.isNonNewlineAscii kwdFp kwdOffset (kwdOffset + kwdLength))
38+ (E.Keyword (Char8.unpack kwd))
39+ in
40+ Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr ->
41+ if I.isSubstring kwdFp kwdOffset kwdLength fp offset terminal
42+ && Var.getInnerWidth fp (offset + kwdLength) terminal == 0
43+ then
44+ let
45+ !newState =
46+ State fp (offset + kwdLength) terminal indent (row + kwdLength) col ctx
47+ in
48+ cok () newState noError
49+
50+ else
51+ eerr (expect row col ctx theory)
52+
53+
54+
55+-- DECLARATIONS
56+
57+
58+{-# NOINLINE type_ #-}
59+type_ :: Parser ()
60+type_ =
61+ keyword "type"
62+
63+
64+{-# NOINLINE alias_ #-}
65+alias_ :: Parser ()
66+alias_ =
67+ keyword "alias"
68+
69+
70+{-# NOINLINE port_ #-}
71+port_ :: Parser ()
72+port_ =
73+ keyword "port"
74+
75+
76+
77+-- IF EXPRESSIONS
78+
79+
80+{-# NOINLINE if_ #-}
81+if_ :: Parser ()
82+if_ =
83+ keyword "if"
84+
85+
86+{-# NOINLINE then_ #-}
87+then_ :: Parser ()
88+then_ =
89+ keyword "then"
90+
91+
92+{-# NOINLINE else_ #-}
93+else_ :: Parser ()
94+else_ =
95+ keyword "else"
96+
97+
98+
99+-- CASE EXPRESSIONS
100+
101+
102+{-# NOINLINE case_ #-}
103+case_ :: Parser ()
104+case_ =
105+ keyword "case"
106+
107+
108+{-# NOINLINE of_ #-}
109+of_ :: Parser ()
110+of_ =
111+ keyword "of"
112+
113+
114+
115+-- LET EXPRESSIONS
116+
117+
118+{-# NOINLINE let_ #-}
119+let_ :: Parser ()
120+let_ =
121+ keyword "let"
122+
123+
124+{-# NOINLINE in_ #-}
125+in_ :: Parser ()
126+in_ =
127+ keyword "in"
128+
129+
130+
131+-- IMPORTS
132+
133+
134+{-# NOINLINE module_ #-}
135+module_ :: Parser ()
136+module_ =
137+ keyword "module"
138+
139+
140+{-# NOINLINE import_ #-}
141+import_ :: Parser ()
142+import_ =
143+ keyword "import"
144+
145+
146+{-# NOINLINE exposing_ #-}
147+exposing_ :: Parser ()
148+exposing_ =
149+ keyword "exposing"
150+
151+
152+{-# NOINLINE as_ #-}
153+as_ :: Parser ()
154+as_ =
155+ keyword "as"
156+
157+
158+{-# NOINLINE where_ #-}
159+where_ :: Parser ()
160+where_ =
161+ keyword "where"
162+
163+
164+{-# NOINLINE effect_ #-}
165+effect_ :: Parser ()
166+effect_ =
167+ keyword "effect"
168+
169+
170+
171+-- INFIX
172+
173+
174+{-# NOINLINE infix_ #-}
175+infix_ :: Parser ()
176+infix_ =
177+ keyword "infix"
178+
179+
180+{-# NOINLINE infixr_ #-}
181+infixr_ :: Parser ()
182+infixr_ =
183+ keyword "infixr"
184+
185+
186+{-# NOINLINE infixl_ #-}
187+infixl_ :: Parser ()
188+infixl_ =
189+ keyword "infixl"
190+
191+
src/Parse/Primitives/Number.hsnew file+267
@@ -0,0 +1,267 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns, UnboxedTuples #-}
3+module Parse.Primitives.Number
4+ ( number
5+ , chompHex
6+ )
7+ where
8+
9+
10+import Prelude hiding (length)
11+import qualified Data.ByteString.Char8 as Char8
12+import qualified Data.ByteString.Internal as B
13+import Foreign.ForeignPtr (ForeignPtr)
14+import GHC.Word (Word8)
15+
16+import qualified AST.Literal as L
17+import Parse.Primitives.Internals (Parser(..), State(..), noError)
18+import qualified Parse.Primitives.Internals as I
19+import qualified Parse.Primitives.Variable as Var
20+import qualified Reporting.Error.Syntax as E
21+
22+
23+
24+-- HELPERS
25+
26+
27+isDirtyEnd :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Bool
28+isDirtyEnd fp offset terminal word =
29+ Var.getInnerWidthHelp fp offset terminal word > 0
30+
31+
32+{-# INLINE isDecimalDigit #-}
33+isDecimalDigit :: Word8 -> Bool
34+isDecimalDigit word =
35+ word <= 0x39 {- 9 -} && word >= 0x30 {- 0 -}
36+
37+
38+
39+-- NUMBERS
40+
41+
42+number :: Parser L.Literal
43+number =
44+ Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr ->
45+ if offset >= terminal then
46+ eerr noError
47+
48+ else
49+ let !word = I.unsafeIndex fp offset in
50+ if not (isDecimalDigit word) then
51+ eerr noError
52+
53+ else
54+ let
55+ outcome =
56+ if word == 0x30 {- 0 -} then
57+ chompZero fp (offset + 1) terminal
58+ else
59+ chompInt fp (offset + 1) terminal (fromIntegral (word - 0x30 {- 0 -}))
60+ in
61+ case outcome of
62+ Err newOffset problem ->
63+ cerr (E.ParseError row (col + (newOffset - offset)) problem)
64+
65+ OkInt newOffset n ->
66+ let
67+ !integer = L.IntNum n
68+ !newState = State fp newOffset terminal indent row (col + (newOffset - offset)) ctx
69+ in
70+ cok integer newState noError
71+
72+ OkFloat newOffset ->
73+ let
74+ !length = newOffset - offset
75+ !float = L.FloatNum $ read $ Char8.unpack $ B.PS fp offset length
76+ !newState = State fp newOffset terminal indent row (col + length) ctx
77+ in
78+ cok float newState noError
79+
80+
81+
82+-- CHOMP OUTCOME
83+
84+
85+data Outcome
86+ = Err { _offset :: Int, _problem :: E.Problem }
87+ | OkInt { _offset :: Int, _value :: Int }
88+ | OkFloat { _offset :: Int }
89+
90+
91+
92+-- CHOMP INT
93+
94+
95+chompInt :: ForeignPtr Word8 -> Int -> Int -> Int -> Outcome
96+chompInt fp !offset terminal !n =
97+ if offset >= terminal then
98+
99+ OkInt offset n
100+
101+ else
102+
103+ let
104+ !word = I.unsafeIndex fp offset
105+ in
106+ if isDecimalDigit word then
107+ chompInt fp (offset + 1) terminal (10 * n + fromIntegral (word - 0x30 {- 0 -}))
108+
109+ else if word == 0x2E {- . -} then
110+ chompFraction fp (offset + 1) terminal
111+
112+ else if word == 0x65 {- e -} || word == 0x45 {- E -} then
113+ chompExponent fp (offset + 1) terminal
114+
115+ else if isDirtyEnd fp offset terminal word then
116+ Err offset E.BadNumberEnd
117+
118+ else
119+ OkInt offset n
120+
121+
122+
123+-- CHOMP FRACTION
124+
125+
126+chompFraction :: ForeignPtr Word8 -> Int -> Int -> Outcome
127+chompFraction fp offset terminal =
128+ if offset >= terminal then
129+ Err offset E.BadNumberDot
130+
131+ else if isDecimalDigit (I.unsafeIndex fp offset) then
132+ chompFractionHelp fp (offset + 1) terminal
133+
134+ else
135+ Err offset E.BadNumberDot
136+
137+
138+chompFractionHelp :: ForeignPtr Word8 -> Int -> Int -> Outcome
139+chompFractionHelp fp offset terminal =
140+ if offset >= terminal then
141+ OkFloat offset
142+
143+ else
144+ let !word = I.unsafeIndex fp offset in
145+ if isDecimalDigit word then
146+ chompFractionHelp fp (offset + 1) terminal
147+
148+ else if word == 0x65 {- e -} || word == 0x45 {- E -} then
149+ chompExponent fp (offset + 1) terminal
150+
151+ else if isDirtyEnd fp offset terminal word then
152+ Err offset E.BadNumberEnd
153+
154+ else
155+ OkFloat offset
156+
157+
158+
159+-- CHOMP EXPONENT
160+
161+
162+chompExponent :: ForeignPtr Word8 -> Int -> Int -> Outcome
163+chompExponent fp offset terminal =
164+ if offset >= terminal then
165+ Err offset E.BadNumberExp
166+
167+ else
168+ let !word = I.unsafeIndex fp offset in
169+ if isDecimalDigit word then
170+ chompExponentHelp fp (offset + 1) terminal
171+
172+ else if word == 0x2B {- + -} || word == 0x2D {- - -} then
173+
174+ let !offset1 = offset + 1 in
175+ if offset1 < terminal && isDecimalDigit (I.unsafeIndex fp offset1) then
176+ chompExponentHelp fp (offset + 2) terminal
177+ else
178+ Err offset E.BadNumberExp
179+
180+ else
181+ Err offset E.BadNumberExp
182+
183+
184+chompExponentHelp :: ForeignPtr Word8 -> Int -> Int -> Outcome
185+chompExponentHelp fp offset terminal =
186+ if offset >= terminal then
187+ OkFloat offset
188+
189+ else if isDecimalDigit (I.unsafeIndex fp offset) then
190+ chompExponentHelp fp (offset + 1) terminal
191+
192+ else
193+ OkFloat offset
194+
195+
196+
197+-- CHOMP ZERO
198+
199+
200+chompZero :: ForeignPtr Word8 -> Int -> Int -> Outcome
201+chompZero fp offset terminal =
202+ if offset >= terminal then
203+ OkInt offset 0
204+
205+ else
206+ let !word = I.unsafeIndex fp offset in
207+ if word == 0x78 {- x -} then
208+ chompHexInt fp (offset + 1) terminal
209+
210+ else if word == 0x2E {- . -} then
211+ chompFraction fp (offset + 1) terminal
212+
213+ else if isDecimalDigit word then
214+ Err offset E.BadNumberZero
215+
216+ else if isDirtyEnd fp offset terminal word then
217+ Err offset E.BadNumberEnd
218+
219+ else
220+ OkInt offset 0
221+
222+
223+chompHexInt :: ForeignPtr Word8 -> Int -> Int -> Outcome
224+chompHexInt fp offset terminal =
225+ let (# newOffset, answer #) = chompHex fp offset terminal in
226+ if answer < 0 then
227+ Err newOffset E.BadNumberHex
228+ else
229+ OkInt newOffset answer
230+
231+
232+
233+-- CHOMP HEX
234+
235+
236+-- Return -1 if it has NO digits
237+-- Return -2 if it has BAD digits
238+
239+{-# INLINE chompHex #-}
240+chompHex :: ForeignPtr Word8 -> Int -> Int -> (# Int, Int #)
241+chompHex fp offset terminal =
242+ chompHexHelp fp offset terminal (-1) 0
243+
244+
245+chompHexHelp :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> (# Int, Int #)
246+chompHexHelp fp offset terminal answer accumulator =
247+ if offset >= terminal then
248+ (# offset, answer #)
249+ else
250+ let
251+ !newAnswer =
252+ stepHex fp offset terminal (I.unsafeIndex fp offset) accumulator
253+ in
254+ if newAnswer < 0 then
255+ (# offset, if newAnswer == -1 then answer else -2 #)
256+ else
257+ chompHexHelp fp (offset + 1) terminal newAnswer newAnswer
258+
259+
260+{-# INLINE stepHex #-}
261+stepHex :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Int -> Int
262+stepHex fp offset terminal word acc
263+ | 0x30 {- 0 -} <= word && word <= 0x39 {- 9 -} = 16 * acc + fromIntegral (word - 0x30 {- 0 -})
264+ | 0x61 {- a -} <= word && word <= 0x66 {- f -} = 16 * acc + 10 + fromIntegral (word - 0x61 {- a -})
265+ | 0x41 {- A -} <= word && word <= 0x46 {- F -} = 16 * acc + 10 + fromIntegral (word - 0x41 {- A -})
266+ | isDirtyEnd fp offset terminal word = -2
267+ | True = -1
src/Parse/Primitives/Shader.hsnew file+69
@@ -0,0 +1,69 @@
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)
src/Parse/Primitives/Symbol.hsnew file+262
@@ -0,0 +1,262 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns, OverloadedStrings #-}
3+module Parse.Primitives.Symbol
4+ ( underscore
5+ , binop, binopTable
6+ , equals, rightArrow, hasType, comma, pipe, cons, dot, 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.Map as Map
19+import qualified Data.IntSet as IntSet
20+import qualified Data.Vector as Vector
21+import Data.Text (Text)
22+import qualified Data.Text.Encoding as Text
23+import Foreign.ForeignPtr (ForeignPtr)
24+import GHC.Word (Word8)
25+
26+import Parse.Primitives.Internals (Parser(..), State(..), expect, noError, oneOf)
27+import qualified Parse.Primitives.Internals as I
28+import qualified Parse.Primitives.Variable as Var
29+import qualified Reporting.Error.Syntax as E
30+import Reporting.Error.Syntax (Theory(..), BadOp(..))
31+
32+
33+
34+-- UNDERSCORE
35+
36+
37+underscore :: Parser ()
38+underscore =
39+ Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr ->
40+ if offset == terminal || I.unsafeIndex fp offset /= 0x5F {- _ -} then
41+ eerr noError
42+ else
43+ let
44+ !newOffset = offset + 1
45+ !newCol = col + 1
46+ in
47+ if Var.getInnerWidth fp newOffset terminal > 0 then
48+ cerr (E.ParseError row newCol E.BadUnderscore)
49+ else
50+ let !newState = State fp newOffset terminal indent row newCol ctx in
51+ cok () newState noError
52+
53+
54+
55+-- BINOP
56+
57+
58+binop :: Parser Text
59+binop =
60+ Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr ->
61+ let !newOffset = chompOps fp offset terminal in
62+ if offset == newOffset then
63+ eerr (expect row col ctx E.InfixOp)
64+
65+ else
66+ let !length = newOffset - offset in
67+ case Text.decodeUtf8 (B.PS fp offset length) of
68+ "." -> cerr (E.ParseError row col (E.BadOp Dot ctx))
69+ "|" -> cerr (E.ParseError row col (E.BadOp Pipe ctx))
70+ "->" -> cerr (E.ParseError row col (E.BadOp Arrow ctx))
71+ "=" -> cerr (E.ParseError row col (E.BadOp Equals ctx))
72+ ":" -> cerr (E.ParseError row col (E.BadOp HasType ctx))
73+ op -> cok op (State fp newOffset terminal indent row (col + length) ctx) noError
74+
75+
76+chompOps :: ForeignPtr Word8 -> Int -> Int -> Int
77+chompOps fp offset terminal =
78+ if offset < terminal && isBinopCharHelp (I.unsafeIndex fp offset) then
79+ chompOps fp (offset + 1) terminal
80+ else
81+ offset
82+
83+
84+{-# INLINE isBinopCharHelp #-}
85+isBinopCharHelp :: Word8 -> Bool
86+isBinopCharHelp word =
87+ word < 128 && Vector.unsafeIndex binopCharVector (fromIntegral word)
88+
89+
90+{-# NOINLINE binopCharVector #-}
91+binopCharVector :: Vector.Vector Bool
92+binopCharVector =
93+ Vector.generate 128 (\i -> IntSet.member i binopCharSet)
94+
95+
96+{-# NOINLINE binopCharSet #-}
97+binopCharSet :: IntSet.IntSet
98+binopCharSet =
99+ IntSet.fromList (map Char.ord (Map.keys binopTable))
100+
101+
102+binopTable :: Map.Map Char Char
103+binopTable =
104+ Map.fromList $
105+ zip
106+ "+-/*=.<>:&|^?%~!"
107+ "abcdefghijklmnop"
108+
109+
110+
111+-- PRIVATE SYMBOL IMPLEMENTATION
112+
113+
114+{- We can some avoid allocation by declaring all available symbols here.
115+That means the `symbol` function should only be used within this file on
116+values tagged as NOINLINE.
117+-}
118+symbol :: B.ByteString -> Parser ()
119+symbol sym@(B.PS symFp symOffset symLength) =
120+ let
121+ !theory =
122+ assert
123+ (I.isNonNewlineAscii symFp symOffset (symOffset + symLength))
124+ (Symbol (Char8.unpack sym))
125+ in
126+ Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr ->
127+ if I.isSubstring symFp symOffset symLength fp offset terminal then
128+ let !newState = State fp (offset + symLength) terminal indent (row + symLength) col ctx in
129+ cok () newState noError
130+
131+ else
132+ eerr (expect row col ctx theory)
133+
134+
135+
136+-- COMMON SYMBOLS
137+
138+
139+{-# NOINLINE equals #-}
140+equals :: Parser ()
141+equals =
142+ symbol "="
143+
144+
145+{-# NOINLINE rightArrow #-}
146+rightArrow :: Parser ()
147+rightArrow =
148+ symbol "->"
149+
150+
151+{-# NOINLINE hasType #-}
152+hasType :: Parser ()
153+hasType =
154+ symbol ":"
155+
156+
157+{-# NOINLINE comma #-}
158+comma :: Parser ()
159+comma =
160+ symbol ","
161+
162+
163+{-# NOINLINE pipe #-}
164+pipe :: Parser ()
165+pipe =
166+ symbol "|"
167+
168+
169+{-# NOINLINE cons #-}
170+cons :: Parser ()
171+cons =
172+ symbol "::"
173+
174+
175+{-# NOINLINE dot #-}
176+dot :: Parser ()
177+dot =
178+ symbol "."
179+
180+
181+{-# NOINLINE minus #-}
182+minus :: Parser ()
183+minus =
184+ symbol "-"
185+
186+
187+{-# NOINLINE lambda #-}
188+lambda :: Parser ()
189+lambda =
190+ oneOf [ symbol "\\", symbol "\x03BB" ]
191+
192+
193+
194+-- ENCLOSURES
195+
196+
197+{-# NOINLINE leftParen #-}
198+leftParen :: Parser ()
199+leftParen =
200+ symbol "("
201+
202+
203+{-# NOINLINE rightParen #-}
204+rightParen :: Parser ()
205+rightParen =
206+ symbol ")"
207+
208+
209+{-# NOINLINE leftSquare #-}
210+leftSquare :: Parser ()
211+leftSquare =
212+ symbol "["
213+
214+
215+{-# NOINLINE rightSquare #-}
216+rightSquare :: Parser ()
217+rightSquare =
218+ symbol "]"
219+
220+
221+{-# NOINLINE leftCurly #-}
222+leftCurly :: Parser ()
223+leftCurly =
224+ symbol "{"
225+
226+
227+{-# NOINLINE rightCurly #-}
228+rightCurly :: Parser ()
229+rightCurly =
230+ symbol "}"
231+
232+
233+
234+-- COMMENTS
235+
236+
237+{-# NOINLINE elmDocCommentOpen #-}
238+elmDocCommentOpen :: Parser ()
239+elmDocCommentOpen =
240+ symbol "{-|"
241+
242+
243+{-# NOINLINE jsMultiCommentOpen #-}
244+jsMultiCommentOpen :: Parser ()
245+jsMultiCommentOpen =
246+ symbol "/*"
247+
248+
249+{-# NOINLINE jsMultiCommentClose #-}
250+jsMultiCommentClose :: Parser ()
251+jsMultiCommentClose =
252+ symbol "*/"
253+
254+
255+
256+-- SHADER
257+
258+
259+{-# NOINLINE shaderBlockOpen #-}
260+shaderBlockOpen :: Parser ()
261+shaderBlockOpen =
262+ symbol "[glsl|"
src/Parse/Primitives/Utf8.hsnew file+478
@@ -0,0 +1,478 @@
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 Data.Bits
12+--import qualified Data.ByteString as B
13+import qualified Data.ByteString.Internal as B
14+import qualified Data.ByteString.UTF8 as Utf8
15+import qualified Data.Char as Char
16+import Data.Monoid ((<>))
17+import qualified Data.Text as Text
18+import qualified Data.Text.Encoding as Text
19+import qualified Data.Text.Lazy as LText
20+import qualified Data.Text.Lazy.Builder as Text
21+import Foreign.ForeignPtr (ForeignPtr)
22+--import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
23+--import Foreign.Ptr (plusPtr)
24+--import GHC.IO (stToIO, unsafeDupablePerformIO)
25+--import GHC.Exts (Int(I#), Ptr(Ptr))
26+--import qualified GHC.Prim as Prim
27+--import GHC.ST (ST(ST))
28+import GHC.Word (Word8(..))
29+
30+import Parse.Primitives.Internals (Parser(..), State(..), noError)
31+import qualified Parse.Primitives.Internals as I
32+import qualified Parse.Primitives.Number as Number
33+import qualified Reporting.Error.Syntax as E
34+
35+
36+
37+-- CHARACTER
38+
39+
40+character :: Parser Text.Text
41+character =
42+ Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr ->
43+ if offset >= terminal || I.unsafeIndex fp offset /= 0x27 {- ' -} then
44+ eerr noError
45+
46+ else
47+ case chompChar fp (offset + 1) terminal (col + 1) 0 "" of
48+ Bad newCol problem ->
49+ cerr (E.ParseError row newCol problem)
50+
51+ Good newOffset newCol numChars mostRecent ->
52+ if numChars /= 1 then
53+ cerr (E.ParseError row col (E.BadChar newCol))
54+ else
55+ let !newState = State fp newOffset terminal indent row newCol ctx in
56+ cok mostRecent newState noError
57+
58+
59+data CharResult
60+ = Bad Int E.Problem
61+ | Good Int Int Int Text.Text
62+
63+
64+chompChar :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Text.Text -> CharResult
65+chompChar fp offset terminal col numChars mostRecent =
66+ if offset >= terminal then
67+ Bad col E.EndOfFile_Char
68+
69+ else
70+ let
71+ !word = I.unsafeIndex fp offset
72+ in
73+ if word == 0x27 {- ' -} then
74+ Good (offset + 1) (col + 1) numChars mostRecent
75+
76+ else if word == 0x0A {- \n -} then
77+ Bad col E.NewLineInChar
78+
79+ else if word == 0x22 {- " -} then
80+ chompChar fp (offset + 1) terminal (col + 1) (numChars + 1) "\\\""
81+
82+ else if word == 0x5C {- \ -} then
83+ case eatEscape fp (offset + 1) terminal of
84+ EscapeNormal ->
85+ chompChar fp (offset + 2) terminal (col + 2) (numChars + 1) (toText fp offset 2)
86+
87+ EscapeUnicode delta bits ->
88+ chompChar fp (offset + delta) terminal (col + delta) (numChars + 1) (Text.pack bits)
89+
90+ EscapeProblem newOffset problem ->
91+ Bad col (E.BadEscape (newOffset - offset) problem)
92+
93+ EscapeEndOfFile ->
94+ Bad col E.EndOfFile_Char
95+
96+ else
97+ let !width = I.getCharWidth fp offset terminal word in
98+ chompChar fp (offset + width) terminal (col + 1) (numChars + 1) (toText fp offset width)
99+
100+
101+toText :: ForeignPtr Word8 -> Int -> Int -> Text.Text
102+toText fp offset length =
103+ Text.decodeUtf8 (B.PS fp offset length)
104+
105+
106+
107+-- STRINGS
108+
109+
110+string :: Parser Text.Text
111+string =
112+ Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr ->
113+ if isDoubleQuote fp offset terminal then
114+
115+ let
116+ !offset1 = offset + 1
117+ result =
118+ if isDoubleQuote fp offset1 terminal && isDoubleQuote fp (offset + 2) terminal then
119+ multiString fp (offset + 3) terminal row (col + 3) (offset + 3) mempty
120+ else
121+ singleString fp offset1 terminal row (col + 1) offset1 mempty
122+ in
123+ case result of
124+ Err err ->
125+ cerr err
126+
127+ Ok newOffset newRow newCol builder ->
128+ let
129+ !newState = State fp newOffset terminal indent newRow newCol ctx
130+ !content = LText.toStrict (Text.toLazyText builder)
131+ in
132+ cok content newState noError
133+
134+ else
135+ eerr noError
136+
137+
138+{-# INLINE isDoubleQuote #-}
139+isDoubleQuote :: ForeignPtr Word8 -> Int -> Int -> Bool
140+isDoubleQuote fp offset terminal =
141+ offset < terminal && I.unsafeIndex fp offset == 0x22 {- " -}
142+
143+
144+data StringResult
145+ = Err E.ParseError
146+ | Ok !Int !Int !Int Text.Builder
147+
148+
149+finalize :: ForeignPtr Word8 -> Int -> Int -> Text.Builder -> Text.Builder
150+finalize fp start end builder =
151+ if start == end then
152+ builder
153+ else
154+ builder <> Text.fromText (Text.decodeUtf8 (B.PS fp start (end - start)))
155+
156+
157+addBits :: Text.Builder -> ForeignPtr Word8 -> Int -> Int -> Text.Builder -> Text.Builder
158+addBits bits fp start end builder =
159+ if start == end then
160+ builder <> bits
161+ else
162+ builder <> Text.fromText (Text.decodeUtf8 (B.PS fp start (end - start))) <> bits
163+
164+
165+
166+-- SINGLE STRINGS
167+
168+
169+singleString :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Int -> Text.Builder -> StringResult
170+singleString fp offset terminal row col initialOffset builder =
171+ if offset >= terminal then
172+ Err (E.ParseError row col E.EndOfFile_String)
173+
174+ else
175+ let
176+ !word = I.unsafeIndex fp offset
177+ in
178+ if word == 0x22 {- " -} then
179+ Ok (offset + 1) row (col + 1) $
180+ finalize fp initialOffset offset builder
181+
182+ else if word == 0x0A {- \n -} then
183+ Err (E.ParseError row col E.NewLineInString)
184+
185+ else if word == 0x27 {- ' -} then
186+ let !newOffset = offset + 1 in
187+ singleString fp newOffset terminal row (col + 1) newOffset $
188+ addBits singleQuoteBits fp initialOffset offset builder
189+
190+ else if word == 0x5C {- \ -} then
191+ case eatEscape fp (offset + 1) terminal of
192+ EscapeNormal ->
193+ singleString fp (offset + 2) terminal row (col + 2) initialOffset builder
194+
195+ EscapeUnicode delta bits ->
196+ let !newOffset = offset + delta in
197+ singleString fp newOffset terminal row (col + delta) newOffset $
198+ addBits (Text.fromText (Text.pack bits)) fp initialOffset offset builder
199+
200+ EscapeProblem newOffset problem ->
201+ Err (E.ParseError row col (E.BadEscape (newOffset - offset) problem))
202+
203+ EscapeEndOfFile ->
204+ Err (E.ParseError row (col + 1) E.EndOfFile_String)
205+
206+ else
207+ let !newOffset = offset + I.getCharWidth fp offset terminal word in
208+ singleString fp newOffset terminal row (col + 1) initialOffset builder
209+
210+
211+
212+-- MULTI STRINGS
213+
214+
215+multiString :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Int -> Text.Builder -> StringResult
216+multiString fp offset terminal row col initialOffset builder =
217+ if offset >= terminal then
218+ Err (E.ParseError row col E.EndOfFile_MultiString)
219+
220+ else
221+ let !word = I.unsafeIndex fp offset in
222+ if word == 0x22 {- " -} && isDoubleQuote fp (offset + 1) terminal && isDoubleQuote fp (offset + 2) terminal then
223+ Ok (offset + 3) row (col + 3) $
224+ finalize fp initialOffset offset builder
225+
226+ else if word == 0x27 {- ' -} then
227+ let !offset1 = offset + 1 in
228+ multiString fp offset1 terminal row (col + 1) offset1 $
229+ addBits singleQuoteBits fp initialOffset offset builder
230+
231+ else if word == 0x0A {- \n -} then
232+ let !offset1 = offset + 1 in
233+ multiString fp offset1 terminal (row + 1) 1 offset1 $
234+ addBits newlineBits fp initialOffset offset builder
235+
236+ else if word == 0x5C {- \ -} then
237+ case eatEscape fp (offset + 1) terminal of
238+ EscapeNormal ->
239+ multiString fp (offset + 2) terminal row (col + 2) initialOffset builder
240+
241+ EscapeUnicode delta bits ->
242+ let !newOffset = offset + delta in
243+ multiString fp newOffset terminal row (col + delta) newOffset $
244+ addBits (Text.fromText (Text.pack bits)) fp initialOffset offset builder
245+
246+ EscapeProblem newOffset problem ->
247+ Err (E.ParseError row col (E.BadEscape (newOffset - offset) problem))
248+
249+ EscapeEndOfFile ->
250+ Err (E.ParseError row (col + 1) E.EndOfFile_MultiString)
251+
252+ else
253+ let !newOffset = offset + I.getCharWidth fp offset terminal word in
254+ multiString fp newOffset terminal row (col + 1) newOffset builder
255+
256+
257+
258+-- ESCAPE CHARACTERS
259+
260+
261+data Escape
262+ = EscapeNormal
263+ | EscapeUnicode !Int [Char]
264+ | EscapeProblem !Int E.EscapeProblem
265+ | EscapeEndOfFile
266+
267+
268+eatEscape :: ForeignPtr Word8 -> Int -> Int -> Escape
269+eatEscape fp offset terminal =
270+ if offset >= terminal then
271+ EscapeEndOfFile
272+
273+ else
274+ case I.unsafeIndex fp offset of
275+ 0x6E {- n -} -> EscapeNormal
276+ 0x72 {- r -} -> EscapeNormal
277+ 0x74 {- t -} -> EscapeNormal
278+ 0x22 {- " -} -> EscapeNormal
279+ 0x27 {- ' -} -> EscapeNormal
280+ 0x5C {- \ -} -> EscapeNormal
281+ 0x75 {- u -} -> eatUnicode fp (offset + 1) terminal
282+ _ -> EscapeProblem offset E.UnknownEscape
283+
284+
285+eatUnicode :: ForeignPtr Word8 -> Int -> Int -> Escape
286+eatUnicode fp offset terminal =
287+ if offset >= terminal || I.unsafeIndex fp offset /= 0x7B {- { -} then
288+ EscapeProblem offset E.UnicodeSyntax
289+ else
290+ let
291+ !digitOffset = offset + 1
292+ (# newOffset, code #) = Number.chompHex fp digitOffset terminal
293+ !numDigits = newOffset - digitOffset
294+ in
295+ if newOffset >= terminal || I.unsafeIndex fp newOffset /= 0x7D {- } -} then
296+ EscapeProblem newOffset E.UnicodeSyntax
297+
298+ else if code < 0 || 0x10FFFF < code then
299+ EscapeProblem (newOffset + 1) E.UnicodeRange
300+
301+ else if numDigits < 4 || 6 < numDigits then
302+ EscapeProblem (newOffset + 1) $
303+ E.UnicodeLength numDigits (Utf8.toString (B.PS fp digitOffset numDigits))
304+
305+ else
306+ EscapeUnicode (numDigits + 4) (codePointToBits code)
307+
308+
309+
310+-- CODE POINT TO BITS
311+
312+
313+codePointToBits :: Int -> [Char]
314+codePointToBits code =
315+ if code < 0xFFFF then
316+ wordToBits code
317+
318+ else
319+ wordToBits ((code `div` 0x400) + 0xD800)
320+ ++
321+ wordToBits ((code `mod` 0x400) + 0xDC00)
322+
323+
324+wordToBits :: Int -> [Char]
325+wordToBits code =
326+ [ '\\' -- 0x5C -- \
327+ , 'u' -- 0x75 -- u
328+ , toBits code 0
329+ , toBits code 8
330+ , toBits code 16
331+ , toBits code 24
332+ ]
333+
334+
335+toBits :: Int -> Int -> Char
336+toBits code offset =
337+ let !n = fromIntegral (shiftR code offset .&. 0x000F) in
338+ Char.chr $ if n < 10 then 0x30 + n else 0x41 + (n - 10)
339+
340+
341+{-# NOINLINE singleQuoteBits #-}
342+singleQuoteBits :: Text.Builder
343+singleQuoteBits =
344+ "\\\'"
345+
346+
347+{-# NOINLINE newlineBits #-}
348+newlineBits :: Text.Builder
349+newlineBits =
350+ "\\n"
351+
352+
353+
354+---- CHUNKS
355+
356+
357+--data Chunk
358+-- = Copy { _offset :: Int, _length :: Int }
359+-- | Bits [Word8]
360+
361+
362+--finalize :: Int -> Int -> [Chunk] -> [Chunk]
363+--finalize start end chunks =
364+-- reverse $
365+-- if start == end then
366+-- chunks
367+-- else
368+-- Copy start (end - start) : chunks
369+
370+
371+--addBits :: [Word8] -> Int -> Int -> [Chunk] -> [Chunk]
372+--addBits bits start end chunks =
373+-- if start == end then
374+-- Bits bits : chunks
375+-- else
376+-- Bits bits : Copy start (end - start) : chunks
377+
378+
379+--chunkLength :: Chunk -> Int
380+--chunkLength chunk =
381+-- case chunk of
382+-- Copy _ len ->
383+-- len
384+
385+-- Bits bits ->
386+-- length bits
387+
388+
389+
390+---- CHUNK TO SHORT
391+
392+
393+--chunkToShort :: ForeignPtr Word8 -> Chunk -> S.ShortByteString
394+--chunkToShort fp chunk =
395+-- unsafeDupablePerformIO $ stToIO $
396+-- do MBA mba <- newMutableByteArray (chunkLength chunk)
397+-- case chunk of
398+-- Copy offset len ->
399+-- do copyToByteArray (unsafeForeignPtrToPtr fp `plusPtr` offset) mba 0 len
400+-- freeze mba
401+
402+-- Bits bits ->
403+-- do _ <- writeBits mba 0 bits
404+-- freeze mba
405+
406+
407+
408+---- CHUNKS TO SHORT
409+
410+
411+--chunksToShort :: ForeignPtr Word8 -> [Chunk] -> S.ShortByteString
412+--chunksToShort fp chunks =
413+-- unsafeDupablePerformIO $ stToIO $
414+-- do MBA mba <- newMutableByteArray (sum (map chunkLength chunks))
415+-- chunksToShortHelp fp mba 0 chunks
416+
417+
418+--chunksToShortHelp :: ForeignPtr Word8 -> Prim.MutableByteArray# s -> Int -> [Chunk] -> ST s S.ShortByteString
419+--chunksToShortHelp fp mba index chunks =
420+-- case chunks of
421+-- [] ->
422+-- freeze mba
423+
424+-- chunk : others ->
425+-- case chunk of
426+-- Copy offset len ->
427+-- do copyToByteArray (unsafeForeignPtrToPtr fp `plusPtr` offset) mba index len
428+-- chunksToShortHelp fp mba (index + len) others
429+
430+-- Bits bits ->
431+-- do newIndex <- writeBits mba index bits
432+-- chunksToShortHelp fp mba newIndex others
433+
434+
435+
436+---- CHUNKS HELPERS
437+
438+
439+--data MBA s = MBA (Prim.MutableByteArray# s)
440+
441+
442+--newMutableByteArray :: Int -> ST s (MBA s)
443+--newMutableByteArray (I# len) =
444+-- ST $ \s1 ->
445+-- case Prim.newByteArray# len s1 of
446+-- (# s2, mba #) -> (# s2, MBA mba #)
447+
448+
449+--freeze :: Prim.MutableByteArray# s -> ST s S.ShortByteString
450+--freeze mba =
451+-- ST $ \s1 ->
452+-- case Prim.unsafeFreezeByteArray# mba s1 of
453+-- (# s2, ba #) -> (# s2, S.SBS ba #)
454+
455+
456+--copyToByteArray :: Ptr Word8 -> Prim.MutableByteArray# s -> Int -> Int -> ST s ()
457+--copyToByteArray (Ptr src) dst (I# dstOffset) (I# len) =
458+-- ST $ \s1 ->
459+-- case Prim.copyAddrToByteArray# src dst dstOffset len s1 of
460+-- s2 -> (# s2, () #)
461+
462+
463+--writeBits :: Prim.MutableByteArray# s -> Int -> [Word8] -> ST s Int
464+--writeBits mba index bits =
465+-- case bits of
466+-- [] ->
467+-- return index
468+
469+-- word : others ->
470+-- do writeWord8Array mba index word
471+-- writeBits mba (index + 1) others
472+
473+
474+--writeWord8Array :: Prim.MutableByteArray# s -> Int -> Word8 -> ST s ()
475+--writeWord8Array mba (I# offset) (W8# word) =
476+-- ST $ \s1 ->
477+-- case Prim.writeWord8Array# mba offset word s1 of
478+-- s2 -> (# s2, () #)
src/Parse/Primitives/Variable.hsnew file+374
@@ -0,0 +1,374 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}
3+module Parse.Primitives.Variable
4+ ( lower
5+ , upper
6+ , moduleName
7+ , foreignUpper
8+ , foreignAlpha
9+ , chompInnerChars
10+ , getInnerWidth
11+ , getInnerWidthHelp
12+ )
13+ where
14+
15+
16+import Control.Exception (assert)
17+import Data.Bits ((.&.), (.|.), shiftL)
18+import qualified Data.ByteString.Internal as B
19+import qualified Data.Char as Char
20+import qualified Data.Set as Set
21+import Data.Text (Text)
22+import qualified Data.Text.Encoding as Text
23+import Foreign.ForeignPtr (ForeignPtr)
24+import GHC.Word (Word8)
25+
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 Text
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 !variable = Text.decodeUtf8 (B.PS fp offset (newOffset - offset)) in
42+ cok variable (State fp newOffset terminal indent row newCol ctx) noError
43+
44+
45+
46+-- LOCAL LOWER
47+
48+
49+lower :: Parser Text
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 !variable = Text.decodeUtf8 (B.PS fp offset (newOffset - offset)) in
57+ if Set.member variable reservedWords then
58+ eerr (expect row col ctx E.LowVar)
59+ else
60+ cok variable (State fp newOffset terminal indent row newCol ctx) noError
61+
62+
63+{-# NOINLINE reservedWords #-}
64+reservedWords :: Set.Set Text
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 Text
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 = Text.decodeUtf8 (B.PS 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+foreignUpper :: Parser (Maybe Text, Text)
122+foreignUpper =
123+ Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr ->
124+ let (# start, end, newCol #) = foreignUpperHelp fp offset terminal col in
125+ if start == end then
126+ eerr (expect row newCol ctx E.CapVar)
127+ else
128+ let
129+ !foreign = toForeign fp offset start end
130+ !newState = State fp end terminal indent row newCol ctx
131+ in
132+ cok foreign newState noError
133+
134+
135+foreignUpperHelp :: ForeignPtr Word8 -> Int -> Int -> Int -> (# Int, Int, Int #)
136+foreignUpperHelp fp offset terminal col =
137+ let
138+ (# newOffset, newCol #) = chompUpper fp offset terminal col
139+ in
140+ if offset == newOffset then
141+ (# offset, offset, col #)
142+
143+ else if isDot fp newOffset terminal then
144+ foreignUpperHelp fp (newOffset + 1) terminal (newCol + 1)
145+
146+ else
147+ (# offset, newOffset, newCol #)
148+
149+
150+
151+-- FOREIGN ALPHA
152+
153+
154+foreignAlpha :: Parser (Maybe Text, Text)
155+foreignAlpha =
156+ Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr ->
157+ let (# start, end, newCol #) = foreignAlphaHelp fp offset terminal col in
158+ if start == end then
159+ eerr (E.ParseError row newCol (E.Theories ctx [E.LowVar, E.CapVar]))
160+ else
161+ cok (toForeign fp offset start end) (State fp end terminal indent row newCol ctx) noError
162+
163+
164+foreignAlphaHelp :: ForeignPtr Word8 -> Int -> Int -> Int -> (# Int, Int, Int #)
165+foreignAlphaHelp fp offset terminal col =
166+ let
167+ (# lowerOffset, lowerCol #) = chompLower fp offset terminal col
168+ in
169+ if offset < lowerOffset then
170+ (# offset, lowerOffset, lowerCol #)
171+
172+ else
173+ let
174+ (# upperOffset, upperCol #) = chompUpper fp offset terminal col
175+ in
176+ if offset == upperOffset then
177+ (# offset, offset, col #)
178+
179+ else if isDot fp upperOffset terminal then
180+ foreignAlphaHelp fp (upperOffset + 1) terminal (upperCol + 1)
181+
182+ else
183+ (# offset, upperOffset, upperCol #)
184+
185+
186+
187+-- TO FOREIGN NAME
188+
189+
190+toForeign :: ForeignPtr Word8 -> Int -> Int -> Int -> ( Maybe Text, Text )
191+toForeign fp offset start end =
192+ let
193+ !qualifier =
194+ if start == offset then
195+ Nothing
196+ else
197+ Just (Text.decodeUtf8 (B.PS fp offset ((start - 1) - offset)))
198+
199+ !variable =
200+ Text.decodeUtf8 (B.PS fp start (end - start))
201+ in
202+ ( qualifier, variable )
203+
204+
205+
206+
207+---- CHAR CHOMPERS ----
208+
209+
210+
211+-- DOTS
212+
213+
214+{-# INLINE isDot #-}
215+isDot :: ForeignPtr Word8 -> Int -> Int -> Bool
216+isDot fp offset terminal =
217+ offset < terminal && unsafeIndex fp offset == 0x2e {- . -}
218+
219+
220+
221+-- UPPER CHARS
222+
223+
224+chompUpper :: ForeignPtr Word8 -> Int -> Int -> Int -> (# Int, Int #)
225+chompUpper fp offset terminal col =
226+ let !width = getUpperWidth fp offset terminal in
227+ if width == 0 then
228+ (# offset, col #)
229+ else
230+ chompInnerChars fp (offset + width) terminal (col + 1)
231+
232+
233+{-# INLINE getUpperWidth #-}
234+getUpperWidth :: ForeignPtr Word8 -> Int -> Int -> Int
235+getUpperWidth fp offset terminal =
236+ if offset < terminal then
237+ getUpperWidthHelp fp offset terminal (unsafeIndex fp offset)
238+ else
239+ 0
240+
241+
242+{-# INLINE getUpperWidthHelp #-}
243+getUpperWidthHelp :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Int
244+getUpperWidthHelp fp offset terminal word
245+ | 0x41 {- A -} <= word && word <= 0x5A {- Z -} = 1
246+ | word < 0xc0 = 0
247+ | word < 0xe0 = if Char.isUpper (getChar2 fp offset terminal word) then 2 else 0
248+ | word < 0xf0 = if Char.isUpper (getChar3 fp offset terminal word) then 3 else 0
249+ | word < 0xf8 = if Char.isUpper (getChar4 fp offset terminal word) then 4 else 0
250+ | True = 0
251+
252+
253+
254+-- LOWER CHARS
255+
256+
257+chompLower :: ForeignPtr Word8 -> Int -> Int -> Int -> (# Int, Int #)
258+chompLower fp offset terminal col =
259+ let !width = getLowerWidth fp offset terminal in
260+ if width == 0 then
261+ (# offset, col #)
262+ else
263+ chompInnerChars fp (offset + width) terminal (col + 1)
264+
265+
266+{-# INLINE getLowerWidth #-}
267+getLowerWidth :: ForeignPtr Word8 -> Int -> Int -> Int
268+getLowerWidth fp offset terminal =
269+ if offset < terminal then
270+ getLowerWidthHelp fp offset terminal (unsafeIndex fp offset)
271+ else
272+ 0
273+
274+
275+{-# INLINE getLowerWidthHelp #-}
276+getLowerWidthHelp :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Int
277+getLowerWidthHelp fp offset terminal word
278+ | 0x61 {- a -} <= word && word <= 0x7A {- z -} = 1
279+ | word < 0xc0 = 0
280+ | word < 0xe0 = if Char.isLower (getChar2 fp offset terminal word) then 2 else 0
281+ | word < 0xf0 = if Char.isLower (getChar3 fp offset terminal word) then 3 else 0
282+ | word < 0xf8 = if Char.isLower (getChar4 fp offset terminal word) then 4 else 0
283+ | True = 0
284+
285+
286+
287+-- INNER CHARS
288+
289+
290+chompInnerChars :: ForeignPtr Word8 -> Int -> Int -> Int -> (# Int, Int #)
291+chompInnerChars fp !offset terminal !col =
292+ let !width = getInnerWidth fp offset terminal in
293+ if width == 0 then
294+ (# offset, col #)
295+ else
296+ chompInnerChars fp (offset + width) terminal (col + 1)
297+
298+
299+getInnerWidth :: ForeignPtr Word8 -> Int -> Int -> Int
300+getInnerWidth fp offset terminal =
301+ if offset < terminal then
302+ getInnerWidthHelp fp offset terminal (unsafeIndex fp offset)
303+ else
304+ 0
305+
306+
307+{-# INLINE getInnerWidthHelp #-}
308+getInnerWidthHelp :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Int
309+getInnerWidthHelp fp offset terminal word
310+ | 0x61 {- a -} <= word && word <= 0x7A {- z -} = 1
311+ | 0x41 {- A -} <= word && word <= 0x5A {- Z -} = 1
312+ | 0x30 {- 0 -} <= word && word <= 0x39 {- 9 -} = 1
313+ | word == 0x5F {- _ -} = 1
314+ | word < 0xc0 = 0
315+ | word < 0xe0 = if Char.isAlpha (getChar2 fp offset terminal word) then 2 else 0
316+ | word < 0xf0 = if Char.isAlpha (getChar3 fp offset terminal word) then 3 else 0
317+ | word < 0xf8 = if Char.isAlpha (getChar4 fp offset terminal word) then 4 else 0
318+ | True = 0
319+
320+
321+
322+-- EXTRACT CHARACTERS
323+
324+
325+push :: Word8 -> Int -> Int
326+push word code =
327+ assert (word .&. 0xc0 == 0x80) (
328+ shiftL code 6 .|. fromEnum (word .&. 0x3f)
329+ )
330+
331+
332+getChar2 :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Char
333+getChar2 fp offset terminal word =
334+ assert (offset + 2 <= terminal) (
335+ let
336+ !word1 = word .&. 0x1f
337+ !word2 = unsafeIndex fp (offset + 1)
338+ !code = push word2 (fromEnum word1)
339+ in
340+ assert (0x80 <= code) (
341+ toEnum code
342+ )
343+ )
344+
345+
346+getChar3 :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Char
347+getChar3 fp offset terminal word =
348+ assert (offset + 3 <= terminal) (
349+ let
350+ !word1 = word .&. 0x0f
351+ !word2 = unsafeIndex fp (offset + 1)
352+ !word3 = unsafeIndex fp (offset + 2)
353+ !code = push word3 (push word2 (fromEnum word1))
354+ in
355+ assert ((0x800 <= code && code < 0xd800) || (0xdfff < code && code < 0xfffe)) (
356+ toEnum code
357+ )
358+ )
359+
360+
361+getChar4 :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Char
362+getChar4 fp offset terminal word =
363+ assert (offset + 4 <= terminal) (
364+ let
365+ !word1 = word .&. 0x07
366+ !word2 = unsafeIndex fp (offset + 1)
367+ !word3 = unsafeIndex fp (offset + 2)
368+ !word4 = unsafeIndex fp (offset + 3)
369+ !code = push word4 (push word3 (push word2 (fromEnum word1)))
370+ in
371+ assert (0x10000 <= code && code < 0x110000) (
372+ toEnum code
373+ )
374+ )
src/Parse/Primitives/Whitespace.hsnew file+223
@@ -0,0 +1,223 @@
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 = offset1 + 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"