@@ -1,84 +1,681 @@
11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2+{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples #-}
23module Parse.Primitives
3− ( IParser, parse
4− , expecting, failure
5− , withPos, block, checkIndent, indented
4+ ( Parser
5+ , run
6+ , try, lookAhead, failure, deadend, expecting, endOfFile
7+ , oneOf
8+ , text, lowVar, capVar
9+ , getPosition, setIndent
10+ , Space(..), whitespace
11+ , string, character
612 )
713 where
814
9−import Control.Monad.Identity (Identity, runIdentity)
10−import qualified Text.Parsec.Pos as Pos
11−import Text.Parsec
12− ( ParsecT, runParserT, getState, putState
13− , SourcePos, sourceColumn, sourceLine, setSourceLine, getPosition
14− , getInput, setInput
15− , ParseError, (<?>), parserFail, anyToken, many1
16− )
15+import Prelude hiding (length)
16+import qualified Data.Char as Char
17+import qualified Data.Text as Text
18+import qualified Data.Text.Array as Text
19+import qualified Data.Text.Internal as Text
20+import qualified Data.Text.Unsafe as Text
21+import qualified Data.Text.Lazy as LT
22+import qualified Data.Text.Lazy.Builder as LB
23+import Data.Text.Internal.Encoding.Utf16 (chr2)
24+import Data.Text.Internal.Unsafe.Char (unsafeChr)
25+import qualified Control.Applicative as Applicative ( Applicative(..), Alternative(..) )
26+import Control.Monad
27+
28+import qualified Reporting.Region as Region
1729
1830
1931
2032-- PARSER
2133
2234
23−type IParser a =
24− ParsecT String SourcePos Identity a
35+newtype Parser a =
36+ Parser
37+ { _run
38+ :: forall b.
39+ State
40+ -> (a -> State -> b) -- consumed ok
41+ -> (Error -> b) -- consumed err
42+ -> (a -> State -> b) -- empty ok
43+ -> (Error -> b) -- empty err
44+ -> b
45+ }
46+
47+
48+data State =
49+ State
50+ { _array :: !Text.Array
51+ , _offset :: !Int
52+ , _length :: !Int
53+ , _indent :: !Int
54+ , _row :: !Int
55+ , _col :: !Int
56+ }
57+
58+
59+data Result a
60+ = Ok a State
61+ | Err Error
62+
63+
64+data Error
65+ = Error !Int !Int
66+ deriving (Show)
67+
68+
69+
70+-- RUN PARSER
71+
72+
73+run :: Parser a -> Text.Text -> Either Error a
74+run parser (Text.Text array offset length) =
75+ case _run parser (State array offset length 0 1 1) Ok Err Ok Err of
76+ Ok value _ ->
77+ Right value
78+
79+ Err err ->
80+ Left err
81+
82+
83+
84+-- COMBINATORS
85+
86+
87+try :: Parser a -> Parser a
88+try parser =
89+ Parser $ \state cok _ eok eerr ->
90+ _run parser state cok eerr eok eerr
91+
92+
93+lookAhead :: Parser a -> Parser a
94+lookAhead parser =
95+ Parser $ \state _ cerr eok eerr ->
96+ _run parser state eok cerr eok eerr
97+ -- TODO used to mess with error info in ok. Why?
98+
99+
100+failure :: error -> Parser a
101+failure _msg =
102+ Parser $ \(State _ _ _ _ row col) _ cerr _ _ ->
103+ cerr (Error row col)
104+
105+
106+deadend :: error -> Parser a
107+deadend _msg =
108+ Parser $ \(State _ _ _ _ row col) _ _ _ eerr ->
109+ eerr (Error row col)
110+
111+
112+expecting :: String -> Parser a -> Parser a
113+expecting _msg parser =
114+ Parser $ \state@(State _ _ _ _ row col) cok cerr eok eerr ->
115+ let
116+ eok' x s = eok x s
117+ eerr' _err = eerr (Error row col)
118+ in
119+ _run parser state cok cerr eok' eerr'
120+
121+
122+endOfFile :: Parser ()
123+endOfFile =
124+ Parser $ \state@(State _ _ length _ row col) _ _ eok eerr ->
125+ if length == 0 then
126+ eok () state
127+
128+ else
129+ eerr (Error row col)
130+
131+
132+
133+-- FUNCTOR
134+
135+
136+instance Functor Parser where
137+ fmap f parser =
138+ Parser $ \state cok cerr eok eerr ->
139+ let
140+ cok' x s = cok (f x) s
141+ eok' x s = eok (f x) s
142+ in
143+ _run parser state cok' cerr eok' eerr
144+
145+
146+
147+-- APPLICATIVE
148+
149+
150+instance Applicative.Applicative Parser where
151+ pure = return
152+ (<*>) = ap -- TODO: Can this be optimized?
153+
154+
155+instance Applicative.Alternative Parser where
156+ empty = allTheOptionsFailed
157+ (<|>) = oneOfHelp
158+
159+
160+oneOf :: [Parser a] -> Parser a
161+oneOf parsers =
162+ foldr oneOfHelp allTheOptionsFailed parsers
163+
164+
165+allTheOptionsFailed :: Parser a
166+allTheOptionsFailed =
167+ Parser $ \_ _ _ _ eerr ->
168+ eerr $ error "TODO allTheOptionsFailed"
169+
170+
171+oneOfHelp :: Parser a -> Parser a -> Parser a
172+oneOfHelp parser1 parser2 =
173+ Parser $ \state cok cerr eok eerr ->
174+ let
175+ meerr err =
176+ let
177+ neok y state' = eok y state'
178+ neerr err' = eerr (error "TODO oneOfHelp" err err')
179+ in
180+ _run parser2 state cok cerr neok neerr
181+ in
182+ _run parser1 state cok cerr eok meerr
183+
184+
185+
186+-- MONAD
187+
188+
189+instance Monad Parser where
190+ return x =
191+ Parser $ \state _ _ eok _ ->
192+ eok x state
193+
194+ parser >>= callback =
195+ Parser $ \state cok cerr eok eerr ->
196+ let
197+ cok' x state1 =
198+ let
199+ peok y state2 = cok y state2
200+ peerr err = cerr (error "TODO >>= cok" err)
201+ in
202+ _run (callback x) state1 cok cerr peok peerr
203+
204+ eok' x state1 =
205+ let
206+ peok y state2 = eok y state2
207+ peerr err = eerr (error "TODO >>= eok" err)
208+ in
209+ _run (callback x) state1 cok cerr peok peerr
210+ in
211+ _run parser state cok' cerr eok' eerr
212+
213+
214+
215+-- TEXT
216+
217+
218+text :: Text.Text -> Parser ()
219+text (Text.Text tArray tOffset tLen) =
220+ Parser $ \(State array offset length indent row col) cok _ _ eerr ->
221+ if tLen <= length && Text.equal tArray tOffset array offset tLen then
222+ let
223+ (# newRow, newCol #) =
224+ moveCursor tArray tOffset tLen row col
225+ in
226+ cok () (State array (offset + tLen) (length - tLen) indent newRow newCol)
227+
228+ else
229+ eerr (error "TODO text")
230+
231+
232+moveCursor :: Text.Array -> Int -> Int -> Int -> Int -> (# Int, Int #)
233+moveCursor array offset length row col =
234+ if length == 0 then
235+ (# row, col #)
236+
237+ else
238+ let
239+ !word1 = Text.unsafeIndex array offset
240+ in
241+ if word1 == 0x000A then
242+ moveCursor array (offset + 1) (length - 1) (row + 1) 1
243+
244+ else if word1 < 0xD800 || word1 > 0xDBFF then
245+ moveCursor array (offset + 1) (length - 1) row (col + 1)
246+
247+ else
248+ moveCursor array (offset + 2) (length - 2) row (col + 1)
249+
250+
251+
252+-- VARIABLES
253+
254+
255+lowVar :: Parser Text.Text
256+lowVar =
257+ varPrim Char.isLower
258+
259+
260+capVar :: Parser Text.Text
261+capVar =
262+ varPrim Char.isUpper
263+
264+
265+{-# INLINE varPrim #-}
266+varPrim :: (Char -> Bool) -> Parser Text.Text
267+varPrim isGoodFirstChar =
268+ Parser $ \(State array offset length indent row col) cok _ _ eerr ->
269+ if length == 0 then
270+ eerr (error "TODO varPrim")
271+
272+ else
273+ let
274+ (Text.Iter char size) = peek array offset
275+ in
276+ if isGoodFirstChar char then
277+ let
278+ (# newOffset, newLength, newCol #) =
279+ varPrimHelp array (offset + size) (length - size) (col + 1)
280+
281+ !newSize =
282+ newOffset - offset
283+
284+ makeArray =
285+ do mutableArray <- Text.new newSize
286+ Text.copyI mutableArray 0 array offset newSize
287+ return mutableArray
288+
289+ copiedText =
290+ Text.Text (Text.run makeArray) 0 newSize
291+ in
292+ cok copiedText (State array newOffset newLength indent row newCol)
293+
294+ else
295+ eerr (error "TODO varPrim 2")
296+
297+
298+{-# INLINE peek #-}
299+peek :: Text.Array -> Int -> Text.Iter
300+peek array offset =
301+ let
302+ !word1 = Text.unsafeIndex array offset
303+ in
304+ if word1 < 0xD800 || word1 > 0xDBFF then
305+ Text.Iter (unsafeChr word1) 1
306+ else
307+ Text.Iter (chr2 word1 (Text.unsafeIndex array (offset + 1))) 2
308+
309+
310+varPrimHelp :: Text.Array -> Int -> Int -> Int -> (# Int, Int, Int #)
311+varPrimHelp array offset length col =
312+ if length == 0 then
313+ (# offset, length, col #)
314+
315+ else
316+ let
317+ (Text.Iter char size) = peek array offset -- TODO look for latin chars directly?
318+ in
319+ if Char.isAlphaNum char || char == '_' then
320+ varPrimHelp array (offset + size) (length - size) (col + 1)
321+
322+ else
323+ (# offset, length, col #)
324+
325+
326+
327+-- STATE
328+
329+
330+getPosition :: Parser Region.Position
331+getPosition =
332+ Parser $ \state@(State _ _ _ _ row col) _ _ eok _ ->
333+ eok (Region.Position row col) state
334+
335+
336+setIndent :: Int -> Parser ()
337+setIndent indent =
338+ Parser $ \state _ _ eok _ ->
339+ eok () (state { _indent = indent })
340+
341+
342+
343+-- WHITESPACE
344+
345+
346+data Space
347+ = None
348+ | Freshline
349+ | BeforeIndent
350+ | Aligned
351+ | AfterIndent
352+ deriving (Show)
353+
354+
355+whitespace :: Parser Space
356+whitespace =
357+ Parser $ \(State array offset length indent row col) cok cerr _ _ ->
358+ case eatSpaces array offset length row col of
359+ Left err ->
360+ cerr err
361+
362+ Right (newOffset, newLength, newRow, newCol) ->
363+ let
364+ !space =
365+ if newOffset == offset then
366+ None -- TODO empty success?
367+ else if newCol == 1 then
368+ Freshline
369+ else if newCol > indent then
370+ AfterIndent
371+ else if newCol == indent then
372+ Aligned
373+ else
374+ BeforeIndent
375+ in
376+ cok space (State array newOffset newLength indent newRow newCol)
377+
378+
379+eatSpaces :: Text.Array -> Int -> Int -> Int -> Int -> Either Error ( Int, Int, Int, Int )
380+eatSpaces array offset length row col =
381+ if length == 0 then
382+ Right ( offset, length, row, col )
383+
384+ else
385+ case Text.unsafeIndex array offset of
386+ 0x0020 {- -} ->
387+ eatSpaces array (offset + 1) (length - 1) row (col + 1)
388+
389+ 0x000A {- \n -} ->
390+ eatSpaces array (offset + 1) (length - 1) (row + 1) 1
391+
392+ 0x007B {- { -} ->
393+ eatMultiComment array offset length row col
394+
395+ 0x002D {- - -} ->
396+ eatLineComment array offset length row col
397+
398+ 0x000D {- \r -} ->
399+ eatSpaces array (offset + 1) (length - 1) row col
400+
401+ 0x0009 {- \t -} ->
402+ Left (Error row col)
403+
404+ _ ->
405+ Right ( offset, length, row, col )
406+
407+
408+
409+-- LINE COMMENTS
410+
411+
412+eatLineComment :: Text.Array -> Int -> Int -> Int -> Int -> Either Error ( Int, Int, Int, Int )
413+eatLineComment array offset length row col =
414+ if length == 1 then
415+ Right ( offset, length, row, col )
416+
417+ else
418+ case Text.unsafeIndex array (offset + 1) of
419+ 0x002D {- - -} ->
420+ eatLineCommentHelp array (offset + 2) (length - 2) row (col + 2)
421+
422+ _ ->
423+ Right ( offset, length, row, col )
424+
425+
426+eatLineCommentHelp :: Text.Array -> Int -> Int -> Int -> Int -> Either Error ( Int, Int, Int, Int )
427+eatLineCommentHelp array offset length row col =
428+ if length == 0 then
429+ Right ( offset, length, row, col )
430+
431+ else
432+ let
433+ !word = Text.unsafeIndex array offset
434+ in
435+ if word == 0x000A {- \n -} then
436+ eatSpaces array (offset + 1) (length - 1) (row + 1) 1
437+
438+ else if word < 0xD800 || word > 0xDBFF then
439+ eatLineCommentHelp array (offset + 1) (length - 1) row (col + 1)
440+
441+ else
442+ eatLineCommentHelp array (offset + 2) (length - 2) row (col + 1)
443+
444+
445+
446+-- MULTI COMMENTS
447+
448+
449+eatMultiComment :: Text.Array -> Int -> Int -> Int -> Int -> Either Error ( Int, Int, Int, Int )
450+eatMultiComment array offset length row col =
451+ if length == 1 then
452+ Right ( offset, length, row, col )
453+
454+ else
455+ case Text.unsafeIndex array (offset + 1) of
456+ 0x002D {- - -} ->
457+ eatMultiCommentHelp array (offset + 2) (length - 2) row (col + 2) 1
458+
459+ _ ->
460+ Right ( offset, length, row, col )
461+
462+
463+eatMultiCommentHelp :: Text.Array -> Int -> Int -> Int -> Int -> Int -> Either Error ( Int, Int, Int, Int )
464+eatMultiCommentHelp array offset length row col openComments =
465+ if length == 0 then
466+ Left (Error row col) -- never closed the comment!
467+
468+ else
469+ let
470+ !word = Text.unsafeIndex array offset
471+ in
472+ if word == 0x000A {- \n -} then
473+
474+ eatMultiCommentHelp array (offset + 1) (length - 1) (row + 1) 1 openComments
475+
476+ else if word == 0x002D {- - -} && length > 1 && Text.unsafeIndex array (offset + 1) == 0x007D {- } -} then
477+
478+ if openComments == 1 then
479+ eatSpaces array (offset + 2) (length - 2) row (col + 2)
480+ else
481+ eatMultiCommentHelp array (offset + 2) (length - 2) row (col + 2) (openComments - 1)
482+
483+ else if word == 0x007B {- { -} && length > 1 && Text.unsafeIndex array (offset + 1) == 0x002D {- - -} then
484+
485+ eatMultiCommentHelp array (offset + 2) (length - 2) row (col + 2) (openComments + 1)
486+
487+ else if word < 0xD800 || word > 0xDBFF then
488+
489+ eatMultiCommentHelp array (offset + 1) (length - 1) row (col + 1) openComments
490+
491+ else
492+
493+ eatMultiCommentHelp array (offset + 2) (length - 2) row (col + 1) openComments
494+
495+
496+
497+-- STRINGS
498+
499+
500+string :: Parser Text.Text
501+string =
502+ Parser $ \(State array offset length indent row col) cok cerr _ eerr ->
503+ if length == 0 then
504+ eerr (Error row col)
505+
506+ else
507+ let
508+ !word = Text.unsafeIndex array offset
509+ in
510+ if word /= 0x0022 {- " -} then
511+ eerr (Error row col)
512+
513+ else if Text.unsafeIndex array (offset + 1) == 0x0022 {- " -} && Text.unsafeIndex array (offset + 2) == 0x0022 {- " -} then
514+ error "TODO multiString"
515+
516+ else
517+ case singleString array (offset + 1) (length - 1) row (col + 1) (offset + 1) mempty of
518+ Left msg ->
519+ cerr msg
520+
521+ Right ( newOffset, newLength, newCol, str ) ->
522+ cok str (State array newOffset newLength indent row newCol)
523+
524+
525+
526+-- SINGLE STRINGS
527+
528+
529+singleString :: Text.Array -> Int -> Int -> Int -> Int -> Int -> LB.Builder -> Either Error ( Int, Int, Int, Text.Text )
530+singleString array offset length row col initialOffset builder =
531+ if length == 0 then
532+ Left (Error row col)
533+
534+ else
535+ let
536+ !word = Text.unsafeIndex array offset
537+ in
538+ if word == 0x0022 {- " -} then
539+ let
540+ finalBuilder =
541+ mappend builder $ LB.fromText $
542+ Text.Text array initialOffset (offset - initialOffset)
543+
544+ str =
545+ LT.toStrict (LB.toLazyTextWith (offset - initialOffset) finalBuilder)
546+ in
547+ Right ( offset + 1, length - 1, col + 1, str )
548+
549+ else if word == 0x000A {- \n -} then
550+ Left (Error row col)
551+
552+ else if word == 0x005C {- \ -} then
553+ case eatEscape array (offset + 1) (length - 1) row (col + 1) of
554+ Left err ->
555+ Left err
556+
557+ Right ( size, char ) ->
558+ let
559+ !newOffset = offset + size
560+ chunk = Text.Text array initialOffset (offset - initialOffset)
561+ newBuilder = mappend builder (mappend (LB.fromText chunk) (LB.singleton char))
562+ in
563+ singleString array newOffset (length - size) row (col + size) newOffset newBuilder
564+
565+ else if word < 0xD800 || word > 0xDBFF then
566+ singleString array (offset + 1) (length - 1) row (col + 1) initialOffset builder
567+
568+ else
569+ singleString array (offset + 2) (length - 2) row (col + 1) initialOffset builder
570+
571+
572+eatEscape :: Text.Array -> Int -> Int -> Int -> Int -> Either Error ( Int, Char )
573+eatEscape array offset length row col =
574+ if length == 0 then
575+ Left (Error row col)
576+
577+ else
578+ case Text.unsafeIndex array offset of
579+ 0x0061 {- a -} -> Right ( 2, '\a' )
580+ 0x0062 {- b -} -> Right ( 2, '\b' )
581+ 0x0066 {- f -} -> Right ( 2, '\f' )
582+ 0x006E {- n -} -> Right ( 2, '\n' )
583+ 0x0072 {- r -} -> Right ( 2, '\r' )
584+ 0x0074 {- t -} -> Right ( 2, '\t' )
585+ 0x0076 {- v -} -> Right ( 2, '\v' )
586+ 0x0022 {- " -} -> Right ( 2, '\"' )
587+ 0x005C {- \ -} -> Right ( 2, '\\' )
588+ 0x0027 {- ' -} -> Right ( 2, '\'' )
589+ 0x0078 {- x -} ->
590+ case eatHex array (offset + 1) (length - 1) 0 of
591+ Nothing ->
592+ Left (Error row col)
593+
594+ Just (newOffset, code) ->
595+ if code <= 0x10FFFF then
596+ Right ( newOffset - offset + 1, toEnum (fromInteger code) )
597+ else
598+ Left (Error row col)
599+
600+ _ ->
601+ Left (Error row col)
602+
603+
604+eatHex :: Text.Array -> Int -> Int -> Integer -> Maybe ( Int, Integer )
605+eatHex array offset length n =
606+ if length == 0 then
607+ Nothing
608+
609+ else
610+ let
611+ !word = Text.unsafeIndex array offset
612+ in
613+ if 0x0030 <= word && word <= 0x0039 then
614+ eatHex array (offset + 1) (length - 1) (16 * n + fromIntegral (word - 0x0030))
25615
616+ else if 0x0061 <= word && word <= 0x0066 then
617+ eatHex array (offset + 1) (length - 1) (16 * n + 10 + fromIntegral (word - 0x0061))
26618
27−parse :: IParser a -> String -> Either ParseError a
28−parse parser source =
29− runIdentity (runParserT parser (Pos.initialPos "") "" source)
619+ else if 0x0041 <= word && word <= 0x0046 then
620+ eatHex array (offset + 1) (length - 1) (16 * n + 10 + fromIntegral (word - 0x0041))
30621
622+ else
623+ Just (offset, n)
31624
32625
33−-- ERROR HANDLING
34626
627+-- CHARACTER
35628
36−expecting :: String -> IParser a -> IParser a
37−expecting =
38− flip (<?>)
39629
630+character :: Parser Char
631+character =
632+ Parser $ \(State array offset length indent row col) cok cerr _ eerr ->
633+ if length <= 3 then
634+ eerr (Error row col)
40635
41−failure :: String -> IParser a
42−failure msg =
43− do input <- getInput
44− setInput ('x' : input)
45− anyToken
46− fail msg
636+ else
637+ if Text.unsafeIndex array offset /= 0x0027 {- ' -} then
638+ eerr (Error row col)
47639
640+ else
641+ case characterHelp array (offset + 1) (length - 1) row (col + 1) of
642+ Left err ->
643+ cerr err
48644
645+ Right ( size, char ) ->
646+ let
647+ !newOffset = offset + size
648+ !newLength = length + size
649+ in
650+ if newLength == 0 then
651+ cerr (Error row col)
49652
50−-- INDENTATION
653+ else if Text.unsafeIndex array newOffset == 0x0027 {- ' -} then
654+ cok char (State array newOffset newLength indent row (col + size + 2))
51655
656+ else
657+ cerr (Error row col)
52658
53−withPos :: IParser a -> IParser a
54−withPos parser =
55− do old <- getState
56− new <- getPosition
57− putState new
58− result <- parser
59− putState old
60− return result
61659
660+characterHelp :: Text.Array -> Int -> Int -> Int -> Int -> Either Error ( Int, Char )
661+characterHelp array offset length row col =
662+ let
663+ !word = Text.unsafeIndex array offset
664+ in
665+ if word == 0x0027 {- ' -} then
666+ Left (Error row col)
62667
63−block :: IParser a -> IParser [a]
64−block parser =
65− withPos $
66− many1 (checkIndent >> parser)
668+ else if word == 0x005C {- \ -} then
669+ eatEscape array (offset + 1) (length - 1) row (col + 1)
67670
671+ else if word == 0x000A {- \n -} then
672+ Left (Error row col)
68673
69−checkIndent :: IParser ()
70−checkIndent =
71− do old <- getState
72− new <- getPosition
73− if sourceColumn old == sourceColumn new
74− then return ()
75− else parserFail "indentation doesn't match"
674+ else if word < 0xD800 || word > 0xDBFF then
675+ Right (1, unsafeChr word)
76676
677+ else if length > 0 then
678+ Right (2, chr2 word (Text.unsafeIndex array offset))
77679
78−indented :: IParser ()
79−indented =
80− do old <- getState
81− new <- getPosition
82− if sourceColumn new <= sourceColumn old
83− then parserFail "not indented"
84− else putState $ setSourceLine old (sourceLine new)
680+ else
681+ Left (Error row col)