@@ -1,228 +1,328 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−{-# LANGUAGE OverloadedStrings #-}
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}
2+{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples, OverloadedStrings #-}
33module Parse.Primitives
4− ( I.Parser
5− , I.oneOf
6− , run, runAt
7− , try, deadend, hint, endOfFile
8− , noFloatsAllowedInPatterns
9− , getPosition, getCol
10− , pushContext, popContext
4+ ( Result(..)
5+ , fromByteString
6+ , fromFile
7+ , Parser(..)
8+ , State(..)
9+ , Context(..)
10+ , oneOf
11+ , pushContext, popContext, inContext
12+ , getPosition, getCol, addLocation
1113 , getIndent, setIndent
12− , W.SPos
13− , SParser
14− , addLocation, inContext
15− , spaces, noSpace, checkSpace, checkAligned, checkFreshLine
14+ , word1, word2
15+ , unsafeIndex, isWord, getCharWidth
1616 )
1717 where
1818
1919
2020import Prelude hiding (length)
21+import qualified Control.Applicative as Applicative (Applicative(..))
22+import Control.Monad
2123import qualified Data.ByteString.Internal as B
24+import Data.Word (Word8, Word16)
25+import Foreign.Ptr (Ptr, plusPtr)
26+import Foreign.Storable (peek)
27+import GHC.ForeignPtr (touchForeignPtr, unsafeForeignPtrToPtr)
2228
23−import Parse.Primitives.Internals (Parser(..), State(..), expect, noError)
24−import qualified Parse.Primitives.Internals as I
25−import qualified Parse.Primitives.Whitespace as W
29+import qualified File.IO as IO
2630import qualified Reporting.Annotation as A
27−import qualified Reporting.Error.Syntax as E
28−import qualified Reporting.Region as R
2931
3032
3133
32−-- RUN
34+-- PARSER
3335
3436
35−run :: Parser a -> B.ByteString -> Either E.Error a
36−run parser bytes =
37− runAt 1 1 parser bytes
37+newtype Parser c x a =
38+ Parser (
39+ forall b.
40+ State c
41+ -> (a -> State c -> b) -- consumed ok
42+ -> (a -> State c -> b) -- empty ok
43+ -> (Word16 -> Word16 -> Context c -> x -> b) -- consumed err
44+ -> (Word16 -> Word16 -> Context c -> x -> b) -- empty err
45+ -> b
46+ )
47+
48+
49+data State c =
50+ State
51+ { _pos :: !(Ptr Word8)
52+ , _end :: !(Ptr Word8)
53+ , _indent :: !Word16
54+ , _row :: !Word16
55+ , _col :: !Word16
56+ , _context :: Context c
57+ }
58+
59+
60+data Context c
61+ = NoContext
62+ | Frame {-# UNPACK #-} !Word16 {-# UNPACK #-} !Word16 c (Context c)
63+
3864
3965
40−runAt :: Int -> Int -> Parser a -> B.ByteString -> Either E.Error a
41−runAt startRow startColumn (Parser parser) (B.PS fp offset length) =
42− case parser (State fp offset (offset + length) 0 startRow startColumn []) Ok Err Ok Err of
43− Ok value _ _ ->
44− Right value
66+-- FUNCTOR
4567
46− Err (E.ParseError row col problem) ->
68+
69+instance Functor (Parser c x) where
70+ {-# INLINE fmap #-}
71+ fmap f (Parser parser) =
72+ Parser $ \state cok eok cerr eerr ->
4773 let
48− pos = R.Position row col
49− mkError overallRegion subRegion =
50− Left (E.Parse overallRegion subRegion problem)
74+ cok' a s = cok (f a) s
75+ eok' a s = eok (f a) s
5176 in
52− case problem of
53− E.BadChar endCol ->
54− mkError (R.Region pos (R.Position row endCol)) Nothing
77+ parser state cok' eok' cerr eerr
78+
79+
80+
81+-- APPLICATIVE
82+
5583
56− E.BadEscape width _ ->
57− mkError (R.Region pos (R.Position row (col + width))) Nothing
84+instance Applicative.Applicative (Parser c x) where
85+ {-# INLINE pure #-}
86+ pure = return
5887
59− E.BadUnderscore badCol ->
60− mkError (R.Region pos (R.Position row badCol)) Nothing
88+ {-# INLINE (<*>) #-}
89+ (<*>) = ap
6190
62− E.BadOp _ ((_, start) : _) ->
63− mkError (R.Region start pos) (Just (R.Region pos pos))
6491
65− E.Theories ((_, start) : _) _ ->
66− mkError (R.Region start pos) (Just (R.Region pos pos))
6792
68− _ ->
69− mkError (R.Region pos pos) Nothing
93+-- ONE OF
7094
7195
96+{-# INLINE oneOf #-}
97+oneOf :: x -> [Parser c x a] -> Parser c x a
98+oneOf x parsers =
99+ Parser $ \state cok eok cerr eerr ->
100+ oneOfHelp state cok eok cerr eerr x parsers
72101
73−-- RESULT
74102
103+oneOfHelp
104+ :: State c
105+ -> (a -> State c -> b)
106+ -> (a -> State c -> b)
107+ -> (Word16 -> Word16 -> Context c -> x -> b)
108+ -> (Word16 -> Word16 -> Context c -> x -> b)
109+ -> x
110+ -> [Parser c x a]
111+ -> b
112+oneOfHelp state cok eok cerr eerr x parsers =
113+ case parsers of
114+ Parser parser : parsers ->
115+ let
116+ eerr' _ _ _ _ =
117+ oneOfHelp state cok eok cerr eerr x parsers
118+ in
119+ parser state cok eok cerr eerr'
75120
76−data Result a
77− = Ok a State E.ParseError
78− | Err E.ParseError
121+ [] ->
122+ let
123+ (State _ _ _ row col ctx) = state
124+ in
125+ eerr row col ctx x
79126
80127
81128
82−-- COMBINATORS
129+-- MONAD
83130
84131
85−try :: Parser a -> Parser a
86−try (Parser parser) =
87− Parser $ \state cok _ eok eerr ->
88− parser state cok eerr eok eerr
132+instance Monad (Parser c x) where
133+ {-# INLINE return #-}
134+ return value =
135+ Parser $ \state _ eok _ _ ->
136+ eok value state
89137
138+ {-# INLINE (>>=) #-}
139+ (Parser parserA) >>= callback =
140+ Parser $ \state cok eok cerr eerr ->
141+ let
142+ cok' a s =
143+ case callback a of
144+ Parser parserB -> parserB s cok cok cerr cerr
90145
91−deadend :: [E.Theory] -> Parser a
92−deadend thrys =
93− Parser $ \(State _ _ _ _ row col ctx) _ _ _ eerr ->
94− eerr (E.ParseError row col (E.Theories ctx thrys))
146+ eok' a s =
147+ case callback a of
148+ Parser parserB -> parserB s cok eok cerr eerr
149+ in
150+ parserA state cok' eok' cerr eerr
95151
96152
97−hint :: E.Next -> Parser a -> Parser a
98−hint next (Parser parser) =
99− Parser $ \state@(State _ _ _ _ row col ctx) cok cerr eok eerr ->
100− let
101− eok' x s _ =
102− eok x s (expect row col ctx (E.Expecting next))
103153
104− eerr' _ =
105− eerr (expect row col ctx (E.Expecting next))
154+-- FROM BYTESTRING
155+
156+
157+data Result c x a
158+ = Ok a (State c)
159+ | Err Word16 Word16 (Context c) x
160+
161+
162+fromByteString :: Parser c x a -> B.ByteString -> Result c x a
163+fromByteString (Parser parser) (B.PS fp offset length) =
164+ B.accursedUnutterablePerformIO $
165+ let
166+ !pos = plusPtr (unsafeForeignPtrToPtr fp) offset
167+ !end = plusPtr pos length
168+ !result = parser (State pos end 0 1 1 NoContext) Ok Ok Err Err
106169 in
107− parser state cok cerr eok' eerr'
170+ do touchForeignPtr fp
171+ return result
108172
109173
110−endOfFile :: Parser ()
111−endOfFile =
112− Parser $ \state@(State _ offset terminal _ _ _ _) _ _ eok eerr ->
113− if offset < terminal then
114− eerr noError
115− else
116− eok () state noError
174+fromFile :: Parser c x a -> FilePath -> IO (Result c x a)
175+fromFile parser path =
176+ fromByteString parser <$> IO.readUtf8 path -- TODO try mmap
117177
118178
119−noFloatsAllowedInPatterns :: Parser a
120−noFloatsAllowedInPatterns =
121− Parser $ \(State _ _ _ _ row col _) _ cerr _ _ ->
122− cerr (E.ParseError row col E.FloatInPattern)
123179
180+-- POSITION
124181
125182
126−-- STATE
183+getCol :: Parser c x Word16
184+getCol =
185+ Parser $ \state@(State _ _ _ _ col _) _ eok _ _ ->
186+ eok col state
127187
128188
129189{-# INLINE getPosition #-}
130−getPosition :: Parser R.Position
190+getPosition :: Parser c x A.Position
131191getPosition =
132− Parser $ \state@(State _ _ _ _ row col _) _ _ eok _ ->
133− eok (R.Position row col) state noError
192+ Parser $ \state@(State _ _ _ row col _) _ eok _ _ ->
193+ eok (A.Position row col) state
134194
135195
136−getIndent :: Parser Int
137−getIndent =
138− Parser $ \state@(State _ _ _ indent _ _ _) _ _ eok _ ->
139− eok indent state noError
140−
196+addLocation :: Parser c x a -> Parser c x (A.Located a)
197+addLocation (Parser parser) =
198+ Parser $ \state@(State _ _ _ srow scol _) cok eok cerr eerr ->
199+ let
200+ cok' a s@(State _ _ _ erow ecol _) = cok (A.At (A.Region (A.Position srow scol) (A.Position erow ecol)) a) s
201+ eok' a s@(State _ _ _ erow ecol _) = eok (A.At (A.Region (A.Position srow scol) (A.Position erow ecol)) a) s
202+ in
203+ parser state cok' eok' cerr eerr
141204
142−getCol :: Parser Int
143−getCol =
144− Parser $ \state@(State _ _ _ _ _ col _) _ _ eok _ ->
145− eok col state noError
146205
147206
148−pushContext :: R.Position -> E.Context -> Parser ()
149−pushContext pos ctx =
150− Parser $ \state@(State _ _ _ _ _ _ context) _ _ eok _ ->
151− eok () (state { _context = (ctx, pos) : context }) noError
207+-- INDENT
152208
153209
154−popContext :: a -> Parser a
155−popContext value =
156− Parser $ \state@(State _ _ _ _ _ _ context) _ _ eok _ ->
157− eok value (state { _context = tail context }) noError
210+getIndent :: Parser c x Word16
211+getIndent =
212+ Parser $ \state@(State _ _ indent _ _ _) _ eok _ _ ->
213+ eok indent state
158214
159215
160−setIndent :: Int -> Parser ()
216+setIndent :: Word16 -> Parser c x ()
161217setIndent indent =
162− Parser $ \state _ _ eok _ ->
163− eok () (state { _indent = indent }) noError
164−
218+ Parser $ \(State pos end _ row col context) _ eok _ _ ->
219+ let
220+ !newState =
221+ State pos end indent row col context
222+ in
223+ eok () newState
165224
166225
167−-- SPACE PARSER
168226
227+-- CONTEXT
169228
170−type SParser a =
171− Parser (a, R.Position, W.SPos)
172229
230+pushContext :: A.Position -> c -> Parser c x ()
231+pushContext (A.Position r c) ctx =
232+ Parser $ \(State pos end indent row col context) _ eok _ _ ->
233+ let
234+ !newContext = Frame r c ctx context
235+ !newState = State pos end indent row col newContext
236+ in
237+ eok () newState
173238
174239
175−-- LOCATION
240+popContext :: a -> Parser c x a
241+popContext value =
242+ Parser $ \(State pos end indent row col context) _ eok _ _ ->
243+ case context of
244+ Frame _ _ _ context ->
245+ let
246+ !newState =
247+ State pos end indent row col context
248+ in
249+ eok value newState
250+
251+ NoContext ->
252+ error "compiler error, trying to popContext on NoContext"
253+
254+
255+inContext :: c -> Parser c x start -> Parser c x a -> Parser c x a
256+inContext tag (Parser parserStart) (Parser parserA) =
257+ Parser $ \state@(State _ _ _ frow fcol _) cok eok cerr eerr ->
258+ let
259+ cokS _ (State pos end indent row col ctx) =
260+ let
261+ !newContext = Frame frow fcol tag ctx
262+ !newState = State pos end indent row col newContext
263+ cokA a s = cok a (s { _context = ctx })
264+ in
265+ parserA newState cokA cokA cerr cerr
266+
267+ eokS _ (State pos end indent row col ctx) =
268+ let
269+ !newContext = Frame frow fcol tag ctx
270+ !newState = State pos end indent row col newContext
271+ cokA a s = cok a (s { _context = ctx })
272+ eokA a s = eok a (s { _context = ctx })
273+ in
274+ parserA newState cokA eokA cerr eerr
275+ in
276+ parserStart state cokS eokS cerr eerr
176277
177278
178−addLocation :: Parser a -> Parser (A.Located a)
179−addLocation parser =
180− do start <- getPosition
181− value <- parser
182− end <- getPosition
183− return (A.at start end value)
184279
280+-- SYMBOLS
185281
186−inContext :: R.Position -> E.Context -> Parser a -> Parser a
187−inContext pos ctx parser =
188− do pushContext pos ctx
189− a <- parser
190− popContext a
191282
283+word1 :: Word8 -> x -> Parser c x ()
284+word1 word x =
285+ Parser $ \(State pos end indent row col ctx) cok _ _ eerr ->
286+ if pos < end && unsafeIndex pos == word then
287+ let !newState = State (plusPtr pos 1) end indent row (col + 1) ctx in
288+ cok () newState
289+ else
290+ eerr row col ctx x
192291
193−-- WHITESPACE VARIATIONS
194292
293+word2 :: Word8 -> Word8 -> x -> Parser c x ()
294+word2 w1 w2 x =
295+ Parser $ \(State pos end indent row col ctx) cok _ _ eerr ->
296+ let
297+ !pos1 = plusPtr pos 1
298+ in
299+ if pos1 < end && unsafeIndex pos == w1 && unsafeIndex pos1 == w2 then
300+ let !newState = State (plusPtr pos 2) end indent row (col + 2) ctx in
301+ cok () newState
302+ else
303+ eerr row col ctx x
195304
196−spaces :: Parser ()
197−spaces =
198− checkSpace =<< W.whitespace
199305
200306
201−noSpace :: R.Position -> W.SPos -> Parser ()
202−noSpace pos (W.SPos spos) =
203− if pos == spos
204− then return ()
205− else deadend []
307+-- LOW-LEVEL CHECKS
206308
207309
208−checkSpace :: W.SPos -> Parser ()
209−checkSpace (W.SPos (R.Position _ col)) =
210− do indent <- getIndent
211− if col > indent && col > 1
212− then return ()
213− else deadend [E.BadSpace]
310+unsafeIndex :: Ptr Word8 -> Word8
311+unsafeIndex ptr =
312+ B.accursedUnutterablePerformIO (peek ptr)
214313
215314
216−checkAligned :: W.SPos -> Parser ()
217−checkAligned (W.SPos (R.Position _ col)) =
218− do indent <- getIndent
219− if col == indent
220− then return ()
221− else deadend [E.BadSpace]
315+{-# INLINE isWord #-}
316+isWord :: Ptr Word8 -> Ptr Word8 -> Word8 -> Bool
317+isWord pos end word =
318+ pos < end && unsafeIndex pos == word
222319
223320
224−checkFreshLine :: W.SPos -> Parser ()
225−checkFreshLine (W.SPos (R.Position _ col)) =
226− if col == 1
227− then return ()
228− else deadend [E.BadSpace]
321+getCharWidth :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int
322+getCharWidth _pos _end word
323+ | word < 0x80 = 1
324+ | word < 0xc0 = error "Need UTF-8 encoded input. Ran into unrecognized bits."
325+ | word < 0xe0 = 2
326+ | word < 0xf0 = 3
327+ | word < 0xf8 = 4
328+ | True = error "Need UTF-8 encoded input. Ran into unrecognized bits."