git.iko.soy/elk
on e00a3f3 help sign in
elk/src/Parse/Primitives.hs
1372 lines 37 kB history raw
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples, OverloadedStrings #-}
3module Parse.Primitives
4 ( Parser
5 , run, runAt
6 , try, deadend, hint, endOfFile
7 , oneOf
8 , symbol, underscore, keyword, keywords
9 , lowVar, capVar, infixOp
10 , getPosition, getCol
11 , getContext, pushContext, popContext
12 , getIndent, setIndent
13 , SPos(..), whitespace
14 , docComment, chompUntilDocs
15 , string, character
16 , digit, number
17 , shaderSource, shaderFailure
18 , kernelChunk, ChunkTag(..)
19 )
20 where
22import Prelude hiding (length)
23import qualified Control.Applicative as Applicative ( Applicative(..), Alternative(..) )
24import Control.Monad
25import qualified Data.ByteString as BS
26import qualified Data.Char as Char
27import Data.Monoid ((<>))
28import qualified Data.Set as Set
29import Data.Text (Text)
30import qualified Data.Text as Text
31import qualified Data.Text.Array as Text
32import qualified Data.Text.Encoding as Text
33import qualified Data.Text.Internal as Text
34import qualified Data.Text.Unsafe as Text
35import qualified Data.Text.Lazy as LT
36import qualified Data.Text.Lazy.Builder as LB
37import Data.Text.Internal.Encoding.Utf16 (chr2)
38import Data.Text.Internal.Unsafe.Char (unsafeChr)
39import GHC.Word (Word8, Word16)
41import qualified AST.Helpers as Help (isSymbol)
42import qualified AST.Literal as L
43import qualified Reporting.Annotation as A
44import qualified Reporting.Error.Syntax as E
45import qualified Reporting.Region as R
46import Reporting.Error.Syntax
47 ( ParseError(..), Problem(..), Theory(..), BadOp(..)
48 )
52-- PARSER
55newtype Parser a =
56 Parser
57 { _run
58 :: forall b.
59 State
60 -> (a -> State -> ParseError -> b) -- consumed ok
61 -> ( ParseError -> b) -- consumed err
62 -> (a -> State -> ParseError -> b) -- empty ok
63 -> ( ParseError -> b) -- empty err
64 -> b
65 }
68data State =
69 State
70 { _array :: !Text.Array
71 , _offset :: !Int
72 , _length :: !Int
73 , _indent :: !Int
74 , _row :: !Int
75 , _col :: !Int
76 , _context :: E.ContextStack
77 }
80{-# NOINLINE noError #-}
81noError :: ParseError
82noError =
83 ParseError 0 0 (Theories [] [])
86{-# INLINE expect #-}
87expect :: Int -> Int -> E.ContextStack -> Theory -> ParseError
88expect row col ctx theory =
89 ParseError row col (Theories ctx [theory])
93-- RUN PARSER
96run :: Parser a -> Text -> Either (A.Located E.Error) a
97run parser text =
98 runAt 1 1 parser text
101runAt :: Int -> Int -> Parser a -> Text -> Either (A.Located E.Error) a
102runAt sRow sCol parser (Text.Text array offset length) =
103 case _run parser (State array offset length 0 sRow sCol []) Ok Err Ok Err of
104 Ok value _ _ ->
105 Right value
107 Err (ParseError row col problem) ->
108 let
109 pos = R.Position row col
110 region = R.Region pos pos
111 mkError overallRegion subRegion =
112 Left (A.A overallRegion (E.Parse subRegion problem))
113 in
114 case problem of
115 BadOp _ ((_, start) : _) ->
116 mkError (R.Region start pos) (Just region)
118 Theories ((_, start) : _) _ ->
119 mkError (R.Region start pos) (Just region)
121 _ ->
122 mkError region Nothing
125data Result a
126 = Ok a State ParseError
127 | Err ParseError
131-- COMBINATORS
134try :: Parser a -> Parser a
135try parser =
136 Parser $ \state cok _ eok eerr ->
137 _run parser state cok eerr eok eerr
140shaderFailure :: Int -> Int -> Text -> Parser a
141shaderFailure row col msg =
142 Parser $ \_ _ cerr _ _ ->
143 cerr (ParseError row col (BadShader msg))
146deadend :: [Theory] -> Parser a
147deadend thrys =
148 Parser $ \(State _ _ _ _ row col ctx) _ _ _ eerr ->
149 eerr (ParseError row col (Theories ctx thrys))
152hint :: E.Next -> Parser a -> Parser a
153hint next parser =
154 Parser $ \state@(State _ _ _ _ row col ctx) cok cerr eok eerr ->
155 let
156 eok' x s _ =
157 eok x s (expect row col ctx (Expecting next))
159 eerr' _ =
160 eerr (expect row col ctx (Expecting next))
161 in
162 _run parser state cok cerr eok' eerr'
165endOfFile :: Parser ()
166endOfFile =
167 Parser $ \state@(State _ _ length _ _ _ _) _ _ eok eerr ->
168 if length == 0 then
169 eok () state noError
171 else
172 eerr noError
176-- FUNCTOR
179instance Functor Parser where
180 fmap f parser =
181 Parser $ \state cok cerr eok eerr ->
182 let
183 cok' x s e = cok (f x) s e
184 eok' x s e = eok (f x) s e
185 in
186 _run parser state cok' cerr eok' eerr
190-- APPLICATIVE
193instance Applicative.Applicative Parser where
194 pure = return
195 (<*>) = ap
198instance Applicative.Alternative Parser where
199 empty = allTheOptionsFailed
200 (<|>) = oneOfHelp
203oneOf :: [Parser a] -> Parser a
204oneOf parsers =
205 foldr oneOfHelp allTheOptionsFailed parsers
208allTheOptionsFailed :: Parser a
209allTheOptionsFailed =
210 Parser $ \_ _ _ _ eerr ->
211 eerr noError
214oneOfHelp :: Parser a -> Parser a -> Parser a
215oneOfHelp parser1 parser2 =
216 Parser $ \state cok cerr eok eerr ->
217 let
218 eerr1 e1 =
219 let
220 eok2 y s e2 = eok y s (mergeErrors e1 e2)
221 eerr2 e2 = eerr (mergeErrors e1 e2)
222 in
223 _run parser2 state cok cerr eok2 eerr2
224 in
225 _run parser1 state cok cerr eok eerr1
228mergeErrors :: ParseError -> ParseError -> ParseError
229mergeErrors e1@(ParseError r1 c1 p1) e2@(ParseError r2 c2 p2) =
230 case compare r1 r2 of
231 LT -> e2
232 GT -> e1
233 EQ ->
234 case compare c1 c2 of
235 LT -> e2
236 GT -> e1
237 EQ ->
238 case (p1, p2) of
239 (Theories _ [], Theories _ _) ->
240 e2
242 (Theories _ _, Theories _ []) ->
243 e1
245 (Theories ctx ts1, Theories _ ts2) ->
246 ParseError r1 c1 (Theories ctx (ts1 ++ ts2))
248 (Theories _ _, _) ->
249 e2
251 (_, _) ->
252 e1
256-- MONAD
259instance Monad Parser where
260 return value =
261 Parser $ \state _ _ eok _ ->
262 eok value state noError
264 parser >>= callback =
265 Parser $ \state cok cerr eok eerr ->
266 let
267 cok1 x s1 e1 =
268 let
269 eok2 y s2 e2 = cok y s2 (mergeErrors e1 e2)
270 eerr2 e2 = cerr (mergeErrors e1 e2)
271 in
272 _run (callback x) s1 cok cerr eok2 eerr2
274 eok1 x s1 e1 =
275 let
276 eok2 y s2 e2 = eok y s2 (mergeErrors e1 e2)
277 eerr2 e2 = eerr (mergeErrors e1 e2)
278 in
279 _run (callback x) s1 cok cerr eok2 eerr2
280 in
281 _run parser state cok1 cerr eok1 eerr
285-- TEXT
288symbol :: Text -> Parser ()
289symbol sym@(Text.Text tArray tOffset tLen) =
290 Parser $ \(State array offset length indent row col ctx) cok _ _ eerr ->
291 if tLen <= length && Text.equal tArray tOffset array offset tLen then
292 let
293 (# newRow, newCol #) =
294 moveCursor tArray tOffset tLen row col
296 !newState =
297 State array (offset + tLen) (length - tLen) indent newRow newCol ctx
298 in
299 cok () newState noError
301 else
302 eerr (expect row col ctx (Symbol sym))
305moveCursor :: Text.Array -> Int -> Int -> Int -> Int -> (# Int, Int #)
306moveCursor array offset length row col =
307 if length == 0 then
308 (# row, col #)
310 else
311 let
312 !word = Text.unsafeIndex array offset
313 in
314 if word == 0x000A {- \n -} then
315 moveCursor array (offset + 1) (length - 1) (row + 1) 1
317 else if word < 0xD800 || word > 0xDBFF then
318 moveCursor array (offset + 1) (length - 1) row (col + 1)
320 else
321 moveCursor array (offset + 2) (length - 2) row (col + 1)
324underscore :: Parser ()
325underscore =
326 Parser $ \(State array offset length indent row col ctx) cok cerr _ eerr ->
327 if length == 0 || Text.unsafeIndex array offset /= 0x005F {- _ -} then
328 eerr noError
330 else if length >= 2 && isInnerVarChar (peekChar array (offset + 1)) then
331 cerr (ParseError row (col + 1) (BadUnderscore (peekChar array (offset + 1))))
333 else
334 let
335 !newState =
336 State array (offset + 1) (length - 1) indent row (col + 1) ctx
337 in
338 cok () newState noError
342-- KEYWORDS
345keyword :: Text -> Parser ()
346keyword kwd@(Text.Text tArray tOffset tLen) =
347 Parser $ \(State array offset length indent row col ctx) cok _ _ eerr ->
348 if tLen <= length && Text.equal tArray tOffset array offset tLen then
350 if isInnerVarChar (peekChar array (offset + tLen)) then
351 eerr (expect row col ctx (Keyword kwd))
353 else
354 let
355 (# newRow, newCol #) =
356 moveCursor tArray tOffset tLen row col
358 !newState =
359 State array (offset + tLen) (length - tLen) indent newRow newCol ctx
360 in
361 cok () newState noError
363 else
364 eerr (expect row col ctx (Keyword kwd))
367keywords :: Set.Set Text
368keywords =
369 Set.fromList
370 [ "if", "then", "else"
371 , "case", "of"
372 , "let", "in"
373 , "type"
374 , "module", "where"
375 , "import", "exposing"
376 , "as"
377 , "port"
378 ]
382-- VARIABLES
385lowVar :: Parser Text.Text
386lowVar =
387 varPrim LowVar Char.isLower
390capVar :: Parser Text.Text
391capVar =
392 varPrim CapVar Char.isUpper
395{-# INLINE varPrim #-}
396varPrim :: Theory -> (Char -> Bool) -> Parser Text.Text
397varPrim theory isGoodFirstChar =
398 Parser $ \(State array offset length indent row col ctx) cok _ _ eerr ->
399 if length == 0 then
400 eerr (expect row col ctx theory)
402 else
403 let
404 (Text.Iter char size) = peek array offset
405 in
406 if isGoodFirstChar char then
407 let
408 (# newOffset, newLength, newCol #) =
409 varPrimHelp array (offset + size) (length - size) (col + 1)
411 copiedText =
412 copyText array offset (newOffset - offset)
413 in
414 if Set.member copiedText keywords then
415 eerr (expect row newCol ctx theory)
416 else
417 cok copiedText (State array newOffset newLength indent row newCol ctx) noError
419 else
420 eerr (expect row col ctx theory)
423{-# INLINE copyText #-}
424copyText :: Text.Array -> Int -> Int -> Text.Text
425copyText array offset size =
426 let
427 makeArray =
428 do mutableArray <- Text.new size
429 Text.copyI mutableArray 0 array offset size
430 return mutableArray
431 in
432 Text.Text (Text.run makeArray) 0 size
435{-# INLINE peek #-}
436peek :: Text.Array -> Int -> Text.Iter
437peek array offset =
438 let
439 !word = Text.unsafeIndex array offset
440 in
441 if word < 0xD800 || word > 0xDBFF then
442 Text.Iter (unsafeChr word) 1
443 else
444 Text.Iter (chr2 word (Text.unsafeIndex array (offset + 1))) 2
447{-# INLINE peekChar #-}
448peekChar :: Text.Array -> Int -> Char
449peekChar array offset =
450 let
451 !word = Text.unsafeIndex array offset
452 in
453 if word < 0xD800 || word > 0xDBFF then
454 unsafeChr word
455 else
456 chr2 word (Text.unsafeIndex array (offset + 1))
459varPrimHelp :: Text.Array -> Int -> Int -> Int -> (# Int, Int, Int #)
460varPrimHelp array offset length col =
461 if length == 0 then
462 (# offset, length, col #)
464 else
465 let
466 (Text.Iter char size) = peek array offset -- TODO look for latin chars directly?
467 in
468 if isInnerVarChar char then
469 varPrimHelp array (offset + size) (length - size) (col + 1)
471 else
472 (# offset, length, col #)
475{-# INLINE isInnerVarChar #-}
476isInnerVarChar :: Char -> Bool
477isInnerVarChar char =
478 Char.isAlphaNum char || char == '_'
482-- INFIX OPS
485infixOp :: Parser Text
486infixOp =
487 Parser $ \(State array offset length indent row col ctx) cok cerr _ eerr ->
488 if length == 0 then
489 eerr (expect row col ctx InfixOp)
491 else
492 let
493 (Text.Iter char size) = peek array offset
494 in
495 if not (Help.isSymbol char) then
496 eerr (expect row col ctx InfixOp)
497 else
498 case infixOpHelp array (offset + size) (length - size) row (col + 1) of
499 Left err ->
500 cerr err
502 Right ( newOffset, newLength, newCol ) ->
503 case copyText array offset (newOffset - offset) of
504 "." -> cerr (ParseError row col (BadOp Dot ctx))
505 "|" -> cerr (ParseError row col (BadOp Pipe ctx))
506 "->" -> cerr (ParseError row col (BadOp Arrow ctx))
507 "=" -> cerr (ParseError row col (BadOp Equals ctx))
508 ":" -> cerr (ParseError row col (BadOp HasType ctx))
509 op -> cok op (State array newOffset newLength indent row newCol ctx) noError
512infixOpHelp :: Text.Array -> Int -> Int -> Int -> Int -> Either ParseError (Int, Int, Int)
513infixOpHelp array offset length row col =
514 if length == 0 then
515 Right ( offset, length, col )
517 else
518 let
519 (Text.Iter char size) = peek array offset
520 in
521 if Help.isSymbol char then
522 infixOpHelp array (offset + size) (length - size) row (col + 1)
523 else
524 Right ( offset, length, col )
528-- STATE
531getPosition :: Parser R.Position
532getPosition =
533 Parser $ \state@(State _ _ _ _ row col _) _ _ eok _ ->
534 eok (R.Position row col) state noError
537getIndent :: Parser Int
538getIndent =
539 Parser $ \state@(State _ _ _ indent _ _ _) _ _ eok _ ->
540 eok indent state noError
543getCol :: Parser Int
544getCol =
545 Parser $ \state@(State _ _ _ _ _ col _) _ _ eok _ ->
546 eok col state noError
549getContext :: Parser E.ContextStack
550getContext =
551 Parser $ \state@(State _ _ _ _ _ _ ctx) _ _ eok _ ->
552 eok ctx state noError
555pushContext :: R.Position -> E.Context -> Parser ()
556pushContext pos ctx =
557 Parser $ \state@(State _ _ _ _ _ _ context) _ _ eok _ ->
558 eok () (state { _context = (ctx, pos) : context }) noError
561popContext :: a -> Parser a
562popContext value =
563 Parser $ \state@(State _ _ _ _ _ _ context) _ _ eok _ ->
564 eok value (state { _context = tail context }) noError
567setIndent :: Int -> Parser ()
568setIndent indent =
569 Parser $ \state _ _ eok _ ->
570 eok () (state { _indent = indent }) noError
574-- WHITESPACE
577newtype SPos =
578 SPos R.Position
581whitespace :: Parser SPos
582whitespace =
583 Parser $ \(State array offset length indent row col ctx) cok cerr _ _ ->
584 case eatSpaces array offset length row col of
585 Left err ->
586 cerr err
588 Right (newOffset, newLength, newRow, newCol) ->
589 cok
590 (SPos (R.Position newRow newCol))
591 (State array newOffset newLength indent newRow newCol ctx)
592 noError
595eatSpaces :: Text.Array -> Int -> Int -> Int -> Int -> Either ParseError ( Int, Int, Int, Int )
596eatSpaces array offset length row col =
597 if length == 0 then
598 Right ( offset, length, row, col )
600 else
601 case Text.unsafeIndex array offset of
602 0x0020 {- -} ->
603 eatSpaces array (offset + 1) (length - 1) row (col + 1)
605 0x000A {- \n -} ->
606 eatSpaces array (offset + 1) (length - 1) (row + 1) 1
608 0x007B {- { -} ->
609 eatMultiComment array offset length row col
611 0x002D {- - -} ->
612 eatLineComment array offset length row col
614 0x000D {- \r -} ->
615 eatSpaces array (offset + 1) (length - 1) row col
617 0x0009 {- \t -} ->
618 Left (ParseError row col Tab)
620 _ ->
621 Right ( offset, length, row, col )
625-- LINE COMMENTS
628eatLineComment :: Text.Array -> Int -> Int -> Int -> Int -> Either ParseError ( Int, Int, Int, Int )
629eatLineComment array offset length row col =
630 if length == 1 then
631 Right ( offset, length, row, col )
633 else
634 case Text.unsafeIndex array (offset + 1) of
635 0x002D {- - -} ->
636 eatLineCommentHelp array (offset + 2) (length - 2) row (col + 2)
638 _ ->
639 Right ( offset, length, row, col )
642eatLineCommentHelp :: Text.Array -> Int -> Int -> Int -> Int -> Either ParseError ( Int, Int, Int, Int )
643eatLineCommentHelp array offset length row col =
644 if length == 0 then
645 Right ( offset, length, row, col )
647 else
648 let
649 !word = Text.unsafeIndex array offset
650 in
651 if word == 0x000A {- \n -} then
652 eatSpaces array (offset + 1) (length - 1) (row + 1) 1
654 else if word < 0xD800 || word > 0xDBFF then
655 eatLineCommentHelp array (offset + 1) (length - 1) row (col + 1)
657 else
658 eatLineCommentHelp array (offset + 2) (length - 2) row (col + 1)
662-- MULTI COMMENTS
665eatMultiComment :: Text.Array -> Int -> Int -> Int -> Int -> Either ParseError ( Int, Int, Int, Int )
666eatMultiComment array offset length row col =
667 if length <= 2 then
668 Right ( offset, length, row, col )
670 else
671 let
672 !yesDash = Text.unsafeIndex array (offset + 1) == 0x002D {- - -}
673 !noBar = Text.unsafeIndex array (offset + 2) /= 0x007C {- | -}
674 in
675 if yesDash && noBar then
676 do (newOffset, newLength, newRow, newCol) <-
677 eatMultiCommentHelp array (offset + 2) (length - 2) row (col + 2) 1
678 eatSpaces array newOffset newLength newRow newCol
680 else
681 Right ( offset, length, row, col )
684eatMultiCommentHelp :: Text.Array -> Int -> Int -> Int -> Int -> Int -> Either ParseError ( Int, Int, Int, Int )
685eatMultiCommentHelp array offset length row col openComments =
686 if length == 0 then
687 Left (ParseError row col EndOfFile_Comment)
689 else
690 let
691 !word = Text.unsafeIndex array offset
692 in
693 if word == 0x000A {- \n -} then
695 eatMultiCommentHelp array (offset + 1) (length - 1) (row + 1) 1 openComments
697 else if word == 0x002D {- - -} && length > 1 && Text.unsafeIndex array (offset + 1) == 0x007D {- } -} then
699 if openComments == 1 then
700 Right ( offset + 2, length - 2, row, col + 2 )
701 else
702 eatMultiCommentHelp array (offset + 2) (length - 2) row (col + 2) (openComments - 1)
704 else if word == 0x007B {- { -} && length > 1 && Text.unsafeIndex array (offset + 1) == 0x002D {- - -} then
706 eatMultiCommentHelp array (offset + 2) (length - 2) row (col + 2) (openComments + 1)
708 else if word < 0xD800 || word > 0xDBFF then
710 eatMultiCommentHelp array (offset + 1) (length - 1) row (col + 1) openComments
712 else
714 eatMultiCommentHelp array (offset + 2) (length - 2) row (col + 1) openComments
718-- DOCUMENTATION COMMENT
721docComment :: Parser Text
722docComment =
723 do symbol "{-|"
724 Parser $ \(State array offset length indent row col ctx) cok cerr _ _ ->
725 case eatMultiCommentHelp array offset length row col 1 of
726 Left err ->
727 cerr err
729 Right (newOffset, newLength, newRow, newCol) ->
730 cok
731 (copyText array offset (newOffset - offset))
732 (State array newOffset newLength indent newRow newCol ctx)
733 noError
736chompUntilDocs :: Parser Bool
737chompUntilDocs =
738 Parser $ \(State array offset length indent row col ctx) cok _ _ _ ->
739 let
740 (# isStart, newOffset, newLength, newRow, newCol #) =
741 eatDocs array offset length row col
743 !newState =
744 State array newOffset newLength indent newRow newCol ctx
745 in
746 cok isStart newState noError
749eatDocs :: Text.Array -> Int -> Int -> Int -> Int -> (# Bool, Int, Int, Int, Int #)
750eatDocs array offset length row col =
751 if length == 0 then
752 (# False, offset, length, row, col #)
754 else if isDocsStart array offset length then
755 (# True, offset + 5, length - 5, row, col + 5 #)
757 else
758 let
759 !word = Text.unsafeIndex array offset
760 in
761 if word == 0x000A {- \n -} then
762 eatDocs array (offset + 1) (length - 1) (row + 1) 1
764 else if word < 0xD800 || word > 0xDBFF then
765 eatDocs array (offset + 1) (length - 1) row (col + 1)
767 else
768 eatDocs array (offset + 2) (length - 2) row (col + 1)
771isDocsStart :: Text.Array -> Int -> Int -> Bool
772isDocsStart array offset length =
773 length >= 5
774 && Text.unsafeIndex array offset == 0x0040 {- @ -}
775 && Text.unsafeIndex array (offset + 1) == 0x0064 {- d -}
776 && Text.unsafeIndex array (offset + 2) == 0x006F {- o -}
777 && Text.unsafeIndex array (offset + 3) == 0x0063 {- c -}
778 && Text.unsafeIndex array (offset + 4) == 0x0073 {- s -}
782-- STRINGS
785string :: Parser Text.Text
786string =
787 Parser $ \(State array offset length indent row col ctx) cok cerr _ eerr ->
788 if length == 0 then
789 eerr noError
791 else
792 let
793 !word = Text.unsafeIndex array offset
794 in
795 if word /= 0x0022 {- " -} then
796 eerr noError
798 else
799 let
800 stringResult =
801 if length >= 3 && isQuote array (offset + 1) && isQuote array (offset + 2) then
802 multiString array (offset + 3) (length - 3) row (col + 3) (offset + 3) mempty
803 else
804 singleString array (offset + 1) (length - 1) row (col + 1) (offset + 1) mempty
805 in
806 case stringResult of
807 Left err ->
808 cerr err
810 Right ( newOffset, newLength, newCol, builder ) ->
811 cok
812 (LT.toStrict (LB.toLazyText builder))
813 (State array newOffset newLength indent row newCol ctx)
814 noError
817{-# INLINE isQuote #-}
818isQuote :: Text.Array -> Int -> Bool
819isQuote array offset =
820 Text.unsafeIndex array offset == 0x0022 {- " -}
824-- SINGLE STRINGS
827singleString :: Text.Array -> Int -> Int -> Int -> Int -> Int -> LB.Builder -> Either ParseError ( Int, Int, Int, LB.Builder )
828singleString array offset length row col initialOffset builder =
829 if length == 0 then
830 Left (ParseError row col EndOfFile_String)
832 else
833 let
834 !word = Text.unsafeIndex array offset
835 in
836 if word == 0x0022 {- " -} then
837 let
838 finalBuilder =
839 mappend builder $ LB.fromText $
840 Text.Text array initialOffset (offset - initialOffset)
841 in
842 Right ( offset + 1, length - 1, col + 1, finalBuilder )
844 else if word == 0x000A {- \n -} then
845 Left (ParseError row col NewLineInString)
847 else if word == 0x0027 {- ' -} then
849 let
850 !newOffset = offset + 1
851 chunk = Text.Text array initialOffset (offset - initialOffset)
852 newBuilder = builder <> LB.fromText chunk <> LB.fromText "\\'"
853 in
854 singleString array newOffset (length - 1) row (col + 1) newOffset newBuilder
856 else if word == 0x005C {- \ -} then
857 case eatEscape array (offset + 1) (length - 1) row (col + 1) EndOfFile_String of
858 Left err ->
859 Left err
861 Right size ->
862 singleString array (offset + size) (length - size) row (col + size) initialOffset builder
864 else if word < 0xD800 || word > 0xDBFF then
865 singleString array (offset + 1) (length - 1) row (col + 1) initialOffset builder
867 else
868 singleString array (offset + 2) (length - 2) row (col + 1) initialOffset builder
871eatEscape :: Text.Array -> Int -> Int -> Int -> Int -> Problem -> Either ParseError Int
872eatEscape array offset length row col problem =
873 if length == 0 then
874 Left (ParseError row col problem)
876 else
877 case Text.unsafeIndex array offset of
878 0x0061 {- a -} -> Right 2
879 0x0062 {- b -} -> Right 2
880 0x0066 {- f -} -> Right 2
881 0x006E {- n -} -> Right 2
882 0x0072 {- r -} -> Right 2
883 0x0074 {- t -} -> Right 2
884 0x0076 {- v -} -> Right 2
885 0x0022 {- " -} -> Right 2
886 0x005C {- \ -} -> Right 2
887 0x0027 {- ' -} -> Right 2
888 0x0075 {- u -} | length >= 5 && fourHex array offset -> Right 6
889 _ ->
890 Left (ParseError row col BadEscape)
893fourHex :: Text.Array -> Int -> Bool
894fourHex array offset =
895 isHex (Text.unsafeIndex array (offset + 1))
896 && isHex (Text.unsafeIndex array (offset + 2))
897 && isHex (Text.unsafeIndex array (offset + 3))
898 && isHex (Text.unsafeIndex array (offset + 4))
902-- MULTI STRINGS
905multiString :: Text.Array -> Int -> Int -> Int -> Int -> Int -> LB.Builder -> Either ParseError ( Int, Int, Int, LB.Builder )
906multiString array offset length row col initialOffset builder =
907 if length < 3 then
908 Left (ParseError row col EndOfFile_MultiString)
910 else
911 let
912 !word = Text.unsafeIndex array offset
913 in
914 if word == 0x0022 {- " -} && isQuote array (offset + 1) && isQuote array (offset + 2) then
916 let
917 finalBuilder =
918 mappend builder $ LB.fromText $
919 Text.Text array initialOffset (offset - initialOffset)
920 in
921 Right ( offset + 3, length - 3, col + 3, finalBuilder )
923 else if word == 0x0027 {- ' -} then
925 let
926 !newOffset = offset + 1
927 chunk = Text.Text array initialOffset (offset - initialOffset)
928 newBuilder = builder <> LB.fromText chunk <> LB.fromText "\\'"
929 in
930 multiString array newOffset (length - 1) row (col + 1) newOffset newBuilder
932 else if word == 0x000A {- \n -} then
934 let
935 !newOffset = offset + 1
936 chunk = Text.Text array initialOffset (offset - initialOffset)
937 newBuilder = builder <> LB.fromText chunk <> LB.fromText "\\n"
938 in
939 multiString array newOffset (length - 1) (row + 1) 1 newOffset newBuilder
941 else if word == 0x005C {- \ -} then
943 case eatEscape array (offset + 1) (length - 1) row (col + 1) EndOfFile_MultiString of
944 Left err ->
945 Left err
947 Right size ->
948 multiString array (offset + size) (length - size) row (col + size) initialOffset builder
950 else if word < 0xD800 || word > 0xDBFF then
951 multiString array (offset + 1) (length - 1) row (col + 1) initialOffset builder
953 else
954 multiString array (offset + 2) (length - 2) row (col + 1) initialOffset builder
958-- CHARACTER
961character :: Parser Text
962character =
963 Parser $ \(State array offset length indent row col ctx) cok cerr _ eerr ->
964 if length == 0 then
965 eerr noError
967 else
968 if Text.unsafeIndex array offset /= 0x0027 {- ' -} then
969 eerr noError
971 else if length < 3 then
972 cerr (ParseError row col BadChar)
974 else
975 case characterHelp array (offset + 1) (length - 1) row (col + 1) of
976 Left err ->
977 cerr err
979 Right (endCol, size) ->
980 let
981 !newOffset = offset + size + 1
982 !newLength = length - size - 1
983 in
984 if newLength == 0 || Text.unsafeIndex array newOffset /= 0x0027 {- ' -} then
985 cerr (ParseError row col BadChar)
987 else
988 cok
989 (copyText array (offset + 1) size)
990 (State array (newOffset + 1) (newLength - 1) indent row endCol ctx)
991 noError
994characterHelp :: Text.Array -> Int -> Int -> Int -> Int -> Either ParseError ( Int, Int )
995characterHelp array offset length row col =
996 let
997 !word = Text.unsafeIndex array offset
998 in
999 if word == 0x0027 {- ' -} || word == 0x000A {- \n -} then
1000 Left (ParseError row col BadChar)
1002 else if word == 0x005C {- \ -} then
1003 do n <- eatEscape array (offset + 1) (length - 1) row (col + 1) BadChar
1004 return (col + n + 2, n)
1006 else if word < 0xD800 || word > 0xDBFF then
1007 Right (col + 3, 1)
1009 else if length > 2 then
1010 Right (col + 3, 2)
1012 else
1013 Left (ParseError row col BadChar)
1017-- DIGITS
1020digit :: Parser Int
1021digit =
1022 Parser $ \(State array offset length indent row col ctx) cok _ _ eerr ->
1023 if length == 0 then
1024 eerr (expect row col ctx Digit)
1026 else
1027 let
1028 !word = Text.unsafeIndex array offset
1029 in
1030 if isDigit word then
1031 cok
1032 (fromIntegral (word - 0x0030 {- 0 -}))
1033 (State array (offset + 1) (length - 1) indent row (col + 1) ctx)
1034 noError
1035 else
1036 eerr (expect row col ctx Digit)
1040-- NUMBERS
1043number :: Parser L.Literal
1044number =
1045 Parser $ \(State array offset length indent row col ctx) cok cerr _ eerr ->
1046 if length == 0 then
1047 eerr noError
1049 else
1050 let
1051 !word = Text.unsafeIndex array offset
1052 in
1053 if not (isDigit word) then
1054 eerr noError
1056 else
1057 let
1058 chompResults =
1059 if word == 0x0030 {- 0 -} then
1060 chompZero array offset (offset + 1) (length - 1)
1061 else
1062 chompInt array offset (offset + 1) (length - 1)
1063 in
1064 case chompResults of
1065 Left (newOffset, problem) ->
1066 cerr (ParseError row (col + (newOffset - offset)) problem)
1068 Right (newOffset, newLength, literal) ->
1069 if isDirtyEnd array newOffset newLength then
1070 cerr (ParseError row (col + (newOffset - offset)) BadNumberEnd)
1072 else
1073 cok
1074 literal
1075 (State array newOffset newLength indent row (col + (newOffset - offset)) ctx)
1076 noError
1079isDirtyEnd :: Text.Array -> Int -> Int -> Bool
1080isDirtyEnd array offset length =
1081 if length == 0 then
1082 False
1084 else
1085 let
1086 !char = peekChar array offset
1087 in
1088 Char.isAlpha char || char == '_'
1091chompInt :: Text.Array -> Int -> Int -> Int -> Either (Int, Problem) (Int, Int, L.Literal)
1092chompInt array startOffset offset length =
1093 if length == 0 then
1095 Right ( offset, length, readInt array startOffset offset )
1097 else
1099 let
1100 !word = Text.unsafeIndex array offset
1101 in
1102 if isDigit word then
1103 chompInt array startOffset (offset + 1) (length - 1)
1105 else if word == 0x002E {- . -} then
1106 chompFraction array startOffset (offset + 1) (length - 1)
1108 else if word == 0x0065 {- e -} || word == 0x0045 {- E -} then
1109 chompExponent array startOffset (offset + 1) (length - 1)
1111 else
1112 Right ( offset, length, readInt array startOffset offset )
1115chompFraction :: Text.Array -> Int -> Int -> Int -> Either (Int, Problem) (Int, Int, L.Literal)
1116chompFraction array startOffset offset length =
1117 if length == 0 then
1118 Left (offset, BadNumberDot)
1120 else if isDigit (Text.unsafeIndex array offset) then
1121 chompFractionHelp array startOffset (offset + 1) (length - 1)
1123 else
1124 Left (offset, BadNumberDot)
1127chompFractionHelp :: Text.Array -> Int -> Int -> Int -> Either (Int, Problem) (Int, Int, L.Literal)
1128chompFractionHelp array startOffset offset length =
1129 if length == 0 then
1130 Right (offset, length, readFloat array startOffset offset)
1132 else
1133 let
1134 !word = Text.unsafeIndex array offset
1135 in
1136 if isDigit word then
1137 chompFractionHelp array startOffset (offset + 1) (length - 1)
1139 else if word == 0x0065 {- e -} || word == 0x0045 {- E -} then
1140 chompExponent array startOffset (offset + 1) (length - 1)
1142 else
1143 Right (offset, length, readFloat array startOffset offset)
1146chompExponent :: Text.Array -> Int -> Int -> Int -> Either (Int, Problem) (Int, Int, L.Literal)
1147chompExponent array startOffset offset length =
1148 if length == 0 then
1149 Right (offset, length, readFloat array startOffset offset)
1151 else
1152 let
1153 !word = Text.unsafeIndex array offset
1154 in
1155 if isDigit word then
1156 chompExponentHelp array startOffset (offset + 1) (length - 1)
1158 else if word == 0x002B {- + -} || word == 0x002D {- - -} then
1160 if length > 1 && isDigit (Text.unsafeIndex array (offset + 1)) then
1161 chompExponentHelp array startOffset (offset + 2) (length - 2)
1162 else
1163 Left (offset, BadNumberExp)
1165 else
1166 Left (offset, BadNumberExp)
1169chompExponentHelp :: Text.Array -> Int -> Int -> Int -> Either (Int, Problem) (Int, Int, L.Literal)
1170chompExponentHelp array startOffset offset length =
1171 if length == 0 then
1172 Right (offset, length, readFloat array startOffset offset)
1174 else if isDigit (Text.unsafeIndex array offset) then
1175 chompExponentHelp array startOffset (offset + 1) (length - 1)
1177 else
1178 Right (offset, length, readFloat array startOffset offset)
1181chompZero :: Text.Array -> Int -> Int -> Int -> Either (Int, Problem) (Int, Int, L.Literal)
1182chompZero array startOffset offset length =
1183 if length == 0 then
1184 Right ( offset, length, L.IntNum 0 )
1186 else
1187 let
1188 !word = Text.unsafeIndex array offset
1189 in
1190 if word == 0x0078 {- x -} then
1191 chompHex array startOffset (offset + 1) (length - 1)
1193 else if word == 0x002E {- . -} then
1194 chompFraction array startOffset (offset + 1) (length - 1)
1196 else if isDigit word then
1197 Left (offset, BadNumberZero)
1199 else
1200 Right ( offset, length, L.IntNum 0 )
1203chompHex :: Text.Array -> Int -> Int -> Int -> Either (Int, Problem) (Int, Int, L.Literal)
1204chompHex array startOffset offset length =
1205 if length == 0 then
1206 Left (offset, BadNumberHex)
1208 else if isHex (Text.unsafeIndex array offset) then
1209 chompHexHelp array startOffset (offset + 1) (length - 1)
1211 else
1212 Left (offset, BadNumberHex)
1215chompHexHelp :: Text.Array -> Int -> Int -> Int -> Either (Int, Problem) (Int, Int, L.Literal)
1216chompHexHelp array startOffset offset length =
1217 if length == 0 then
1218 Right ( offset, length, readInt array startOffset offset )
1220 else if isHex (Text.unsafeIndex array offset) then
1221 chompHexHelp array startOffset (offset + 1) (length - 1)
1223 else
1224 Right ( offset, length, readInt array startOffset offset )
1228-- NUMBER HELPERS
1231{-# INLINE isDigit #-}
1232isDigit :: Word16 -> Bool
1233isDigit word =
1234 word <= 0x0039 {- 9 -} && word >= 0x0030 {- 0 -}
1237{-# INLINE isHex #-}
1238isHex :: Word16 -> Bool
1239isHex word =
1240 word <= 0x0066 {- f -} && (word >= 0x0061 {- a -} || isDigit word || isCapHex word)
1243{-# INLINE isCapHex #-}
1244isCapHex :: Word16 -> Bool
1245isCapHex word =
1246 0x0041 {- A -} <= word && word <= 0x0046 {- F -}
1249{-# INLINE readInt #-}
1250readInt :: Text.Array -> Int -> Int -> L.Literal
1251readInt array startOffset endOffset =
1252 L.IntNum $ read $ Text.unpack $
1253 Text.Text array startOffset (endOffset - startOffset)
1256{-# INLINE readFloat #-}
1257readFloat :: Text.Array -> Int -> Int -> L.Literal
1258readFloat array startOffset endOffset =
1259 L.FloatNum $ read $ Text.unpack $
1260 Text.Text array startOffset (endOffset - startOffset)
1264-- SHADER
1267shaderSource :: Parser Text
1268shaderSource =
1269 do symbol "[glsl|"
1270 Parser $ \(State array offset length indent row col ctx) cok cerr _ _ ->
1271 case eatShader array offset length row col of
1272 Nothing ->
1273 cerr (ParseError row col EndOfFile_Shader)
1275 Just ( shaderEndOffset, newRow, newCol ) ->
1276 let
1277 !size = shaderEndOffset - offset
1278 !newState =
1279 State array (shaderEndOffset + 2) (length - size - 2) indent newRow newCol ctx
1280 in
1281 cok (copyText array offset size) newState noError
1284eatShader :: Text.Array -> Int -> Int -> Int -> Int -> Maybe (Int, Int, Int)
1285eatShader array offset length row col =
1286 if length < 2 then
1287 Nothing
1289 else
1290 let
1291 !word = Text.unsafeIndex array offset
1292 in
1293 if word == 0x007C {- | -} && Text.unsafeIndex array (offset + 1) == 0x005D {- ] -} then
1294 Just ( offset, row, col + 2 )
1296 else if word == 0x000A {- \n -} then
1297 eatShader array (offset + 1) (length - 1) (row + 1) 1
1299 else if word < 0xD800 || word > 0xDBFF then
1300 eatShader array (offset + 1) (length - 1) row (col + 1)
1302 else
1303 eatShader array (offset + 2) (length - 2) row (col + 1)
1307-- KERNEL CHOMP
1310data ChunkTag = KernelEnum Word8 | KernelImport
1313kernelChunk :: Parser (BS.ByteString, Maybe (ChunkTag, Text))
1314kernelChunk =
1315 Parser $ \(State array offset length indent row col ctx) cok _ _ _ ->
1316 let
1317 (# maybeChunkTag, newOffset, newLength, newRow, newCol #) =
1318 kernelChunkHelp array offset length row col
1320 javascript =
1321 Text.encodeUtf8 (Text.Text array offset (newOffset - offset))
1322 in
1323 case maybeChunkTag of
1324 Nothing ->
1325 let
1326 !newState =
1327 State array newOffset newLength indent newRow newCol ctx
1328 in
1329 cok (javascript, Nothing) newState noError
1331 Just tag ->
1332 let
1333 (# newerOffset, newerLength, newerCol #) =
1334 varPrimHelp array newOffset newLength newCol
1336 !newState =
1337 State array newerOffset newerLength indent newRow newerCol ctx
1339 !kernelSymbol =
1340 Text.Text array newOffset (newerOffset - newOffset)
1341 in
1342 cok (javascript, Just (tag, kernelSymbol)) newState noError
1345kernelChunkHelp :: Text.Array -> Int -> Int -> Int -> Int -> (# Maybe ChunkTag, Int, Int, Int, Int #)
1346kernelChunkHelp array offset length row col =
1347 if length == 0 then
1348 (# Nothing, offset, length, row, col #)
1350 else
1351 let
1352 !word = Text.unsafeIndex array offset
1353 in
1354 if word == 0x005F {- _ -} && length > 3 && Text.unsafeIndex array (offset + 1) == 0x005F {- _ -} then
1355 (# Just (toChunkTag (Text.unsafeIndex array (offset + 2))), offset, length, row, col #)
1357 else if word == 0x000A {- \n -} then
1358 kernelChunkHelp array (offset + 1) (length - 1) (row + 1) 1
1360 else if word < 0xD800 || word > 0xDBFF then
1361 kernelChunkHelp array (offset + 1) (length - 1) row (col + 1)
1363 else
1364 kernelChunkHelp array (offset + 2) (length - 2) row (col + 1)
1367toChunkTag :: Word16 -> ChunkTag
1368toChunkTag word =
1369 if isDigit word then
1370 KernelEnum (fromIntegral (word - 0x0030 {- 0 -}))
1371 else
1372 KernelImport