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