1{-# LANGUAGE BangPatterns #-} 2{-# LANGUAGE GADTs #-} 3{-# LANGUAGE LambdaCase #-} 4{-# LANGUAGE MagicHash #-} 5{-# LANGUAGE RankNTypes #-} 6{-# LANGUAGE ScopedTypeVariables #-} 7{-# LANGUAGE TypeInType #-} 8{-# LANGUAGE UnboxedSums #-} 9{-# LANGUAGE UnboxedTuples #-} 10 11{-# OPTIONS_GHC 12 -Weverything 13 -fno-warn-unsafe 14 -fno-warn-implicit-prelude 15 -fno-warn-missing-import-lists 16 -fno-warn-noncanonical-monoid-instances 17 -O2 18#-} 19 20module Packed.Bytes.Parser 21 ( Parser(..) 22 , Result(..) 23 , Leftovers(..) 24 , parseStreamST 25 , any 26 , failure 27 ) where 28 29import Control.Applicative 30import Data.Primitive (ByteArray(..)) 31import GHC.Int (Int(I#)) 32import GHC.ST (ST(..),runST) 33import GHC.Types (TYPE) 34import GHC.Word (Word8(W8#)) 35import Packed.Bytes (Bytes(..)) 36import Packed.Bytes.Stream.ST (ByteStream(..)) 37import Prelude hiding (any,replicate) 38 39import qualified Data.Primitive as PM 40import qualified Control.Monad 41 42import GHC.Exts (Int#,ByteArray#,Word#,State#,(+#),(-#),(>#),indexWord8Array#) 43 44type Bytes# = (# ByteArray#, Int#, Int# #) 45type Maybe# (a :: TYPE r) = (# (# #) | a #) 46type Leftovers# s = (# Bytes# , ByteStream s #) 47type Result# s a = (# Maybe# (Leftovers# s), Maybe# a #) 48 49data Result s a = Result 50 { resultLeftovers :: !(Maybe (Leftovers s)) 51 , resultValue :: !(Maybe a) 52 } 53 54data Leftovers s = Leftovers 55 { leftoversChunk :: {-# UNPACK #-} !Bytes 56 -- ^ The last chunk pulled from the stream 57 , leftoversStream :: ByteStream s 58 -- ^ The remaining stream 59 } 60 61data PureResult a = PureResult 62 { pureResultLeftovers :: {-# UNPACK #-} !Bytes 63 , pureResultValue :: !(Maybe a) 64 } deriving (Show) 65 66emptyByteArray :: ByteArray 67emptyByteArray = runST (PM.newByteArray 0 >>= PM.unsafeFreezeByteArray) 68 69parseStreamST :: ByteStream s -> Parser a -> ST s (Result s a) 70parseStreamST stream (Parser f) = ST $ \s0 -> 71 case f (# | (# (# unboxByteArray emptyByteArray, 0#, 0# #), stream #) #) s0 of 72 (# s1, r #) -> (# s1, boxResult r #) 73 74boxResult :: Result# s a -> Result s a 75boxResult (# leftovers, val #) = case val of 76 (# (# #) | #) -> Result (boxLeftovers leftovers) Nothing 77 (# | a #) -> Result (boxLeftovers leftovers) (Just a) 78 79boxLeftovers :: Maybe# (Leftovers# s) -> Maybe (Leftovers s) 80boxLeftovers (# (# #) | #) = Nothing 81boxLeftovers (# | (# theBytes, stream #) #) = Just (Leftovers (boxBytes theBytes) stream) 82 83instance Functor Parser where 84 fmap = mapParser 85 86-- Remember to write liftA2 by hand at some point. 87instance Applicative Parser where 88 pure = pureParser 89 (<*>) = Control.Monad.ap 90 91instance Monad Parser where 92 return = pure 93 (>>=) = bindLifted 94 95newtype Parser a = Parser 96 { getParser :: forall s. 97 Maybe# (Leftovers# s) 98 -> State# s 99 -> (# State# s, Result# s a #) 100 } 101 102nextNonEmpty :: ByteStream s -> State# s -> (# State# s, Maybe# (Leftovers# s) #) 103nextNonEmpty (ByteStream f) s0 = case f s0 of 104 (# s1, r #) -> case r of 105 (# (# #) | #) -> (# s1, (# (# #) | #) #) 106 (# | (# theBytes@(# _,_,len #), stream #) #) -> case len of 107 0# -> nextNonEmpty stream s1 108 _ -> (# s1, (# | (# theBytes, stream #) #) #) 109 110withNonEmpty :: forall s b. 111 Maybe# (Leftovers# s) 112 -> State# s 113 -> (State# s -> (# State# s, Result# s b #)) 114 -> (Word# -> Bytes# -> ByteStream s -> State# s -> (# State# s, Result# s b #)) 115 -- The first argument is a Word8, not a full machine word. 116 -- The second argument is the complete,non-empty chunk 117 -- with the head byte still intact. 118 -> (# State# s, Result# s b #) 119withNonEmpty (# (# #) | #) s0 g _ = g s0 120withNonEmpty (# | (# bytes0@(# arr0,off0,len0 #), stream0 #) #) s0 g f = case len0 ># 0# of 121 1# -> f (indexWord8Array# arr0 off0) bytes0 stream0 s0 122 _ -> case nextNonEmpty stream0 s0 of 123 (# s1, r #) -> case r of 124 (# (# #) | #) -> g s1 125 (# | (# bytes1@(# arr1, off1, _ #), stream1 #) #) -> 126 f (indexWord8Array# arr1 off1) bytes1 stream1 s1 127 128-- | Consume the next byte from the input. 129any :: Parser Word8 130any = Parser go where 131 go :: Maybe# (Leftovers# s) -> State# s -> (# State# s, Result# s Word8 #) 132 go m s0 = withNonEmpty m s0 133 (\s -> (# s, (# (# (# #) | #), (# (# #) | #) #) #)) 134 (\theByte theBytes stream s -> 135 (# s, (# (# | (# unsafeDrop# 1# theBytes, stream #) #), (# | W8# theByte #) #) #) 136 ) 137 138-- TODO: improve this 139mapParser :: (a -> b) -> Parser a -> Parser b 140mapParser f p = bindLifted p (pureParser . f) 141 142pureParser :: a -> Parser a 143pureParser a = Parser $ \leftovers0 s0 -> 144 (# s0, (# leftovers0, (# | a #) #) #) 145 146bindLifted :: Parser a -> (a -> Parser b) -> Parser b 147bindLifted (Parser f) g = Parser $ \leftovers0 s0 -> case f leftovers0 s0 of 148 (# s1, (# leftovers1, val #) #) -> case val of 149 (# (# #) | #) -> (# s1, (# leftovers1, (# (# #) | #) #) #) 150 (# | x #) -> case g x of 151 Parser k -> k leftovers1 s1 152 153-- This assumes that the Bytes is longer than the index. It also does 154-- not eliminate zero-length references to byte arrays. 155unsafeDrop# :: Int# -> Bytes# -> Bytes# 156unsafeDrop# i (# arr, off, len #) = (# arr, off +# i, len -# i #) 157 158unboxByteArray :: ByteArray -> ByteArray# 159unboxByteArray (ByteArray arr) = arr 160 161boxBytes :: Bytes# -> Bytes 162boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c) 163 164failure :: Parser a 165failure = Parser (\m s -> (# s, (# m, (# (# #) | #) #) #)) 166 167