diff --git a/benchmarks/parse.hs b/benchmarks/parse.hs --- a/benchmarks/parse.hs +++ b/benchmarks/parse.hs @@ -2,26 +2,24 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} {-# LANGUAGE OverloadedStrings #-} -import Control.Exception (evaluate) import Criterion.Main import Text.Damn.Packet -import Data.Map (fromList) import Data.Maybe (fromJust) import Data.Monoid -import Data.Text (Text) +import Data.ByteString (ByteString) main :: IO () main = defaultMain [ bgroup "Parsing" [ - bench "phony" $ nf parse "" - , bench "cmd" $ nf parse cmd - , bench "cmdParam" $ nf parse cmdParam - , bench "cmdArgs" $ nf parse cmdArgs - , bench "cmdParamArgs" $ nf parse cmdParamArgs - , bench "cmdBody" $ nf parse cmdBody - , bench "cmdParamBody" $ nf parse cmdParamBody - , bench "cmdArgsBody" $ nf parse cmdArgsBody - , bench "cmdParamArgsBody" $ nf parse cmdParamArgsBody ] + bench "phony" $ nf parse' "" + , bench "cmd" $ nf parse' cmd + , bench "cmdParam" $ nf parse' cmdParam + , bench "cmdArgs" $ nf parse' cmdArgs + , bench "cmdParamArgs" $ nf parse' cmdParamArgs + , bench "cmdBody" $ nf parse' cmdBody + , bench "cmdParamBody" $ nf parse' cmdParamBody + , bench "cmdArgsBody" $ nf parse' cmdArgsBody + , bench "cmdParamArgsBody" $ nf parse' cmdParamArgsBody ] , bgroup "Rendering" [ bench "cmd" $ nf render cmdPkt , bench "cmdParam" $ nf render cmdParamPkt @@ -34,7 +32,7 @@ ] cmd, cmdParam, cmdArgs, cmdParamArgs, - cmdBody, cmdParamBody, cmdArgsBody, cmdParamArgsBody :: Text + cmdBody, cmdParamBody, cmdArgsBody, cmdParamArgsBody :: ByteString cmd = "ping" cmdParam = "ping foobar" cmdArgs = "ping\nfoo=bar\nbaz=qux" @@ -44,6 +42,8 @@ cmdArgsBody = cmdArgs <> "\n\nfoobar" cmdParamArgsBody = cmdParamArgs <> "\n\nfoobar" +cmdPkt, cmdParamPkt, cmdArgsPkt, cmdParamArgsPkt, cmdBodyPkt, + cmdParamBodyPkt, cmdArgsBodyPkt, cmdParamArgsBodyPkt :: Packet cmdPkt = fromJust $! parse' cmd cmdParamPkt = fromJust $! parse' cmdParam cmdArgsPkt = fromJust $! parse' cmdArgs diff --git a/damnpacket.cabal b/damnpacket.cabal --- a/damnpacket.cabal +++ b/damnpacket.cabal @@ -1,8 +1,5 @@ --- Initial damnpacket.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - name: damnpacket -version: 0.1.2 +version: 0.2.0 synopsis: Parsing dAmn packets license: MIT license-file: LICENSE @@ -18,10 +15,11 @@ other-modules: Text.Damn.Packet.Internal Text.Damn.Packet.Parser build-depends: base >= 4.4 && < 4.8 - , attoparsec >= 0.10.4 + , bytestring >= 0.10 , containers >= 0.4 , deepseq >= 1.3 - , text >= 0.11 + , trifecta + , utf8-string hs-source-dirs: src default-language: Haskell2010 @@ -31,10 +29,11 @@ ghc-options: -w -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: tests build-depends: base - , damnpacket + , bytestring >= 0.10 , containers >= 0.5 + , damnpacket , QuickCheck >= 2.6 - , text >= 0.11 + default-language: Haskell2010 benchmark parse type: exitcode-stdio-1.0 @@ -42,7 +41,8 @@ ghc-options: -Wall -O2 -threaded hs-source-dirs: benchmarks build-depends: base - , damnpacket + , bytestring >= 0.10 , containers >= 0.5 , criterion >= 0.8 - , text >= 0.11 + , damnpacket + default-language: Haskell2010 diff --git a/src/Text/Damn/Packet/Internal.hs b/src/Text/Damn/Packet/Internal.hs --- a/src/Text/Damn/Packet/Internal.hs +++ b/src/Text/Damn/Packet/Internal.hs @@ -14,12 +14,12 @@ import Control.Applicative import Control.DeepSeq +import Data.ByteString (ByteString) import Data.Data import Data.Map (Map) -import Data.Text (Text) -- | A type synonym--because pressing spacebar is pretty irritating. -type Arguments = Map Text Text +type Arguments = Map ByteString ByteString lens :: Functor f => (s -> a) -> (s -> b -> t) -> (a -> f b) -> s -> f t lens sa sbt afb s = sbt s <$> afb (sa s) @@ -52,10 +52,10 @@ -- , 'pktBody' = 'Just' \"value of property\" -- } -- @ -data Packet = Packet { pktCommand :: Text - , pktParameter :: Maybe Text +data Packet = Packet { pktCommand :: ByteString + , pktParameter :: Maybe ByteString , pktArgs :: Arguments - , pktBody :: Maybe Text + , pktBody :: Maybe ByteString } deriving (Eq, Data, Show, Typeable) instance NFData Packet where @@ -67,14 +67,14 @@ -- | A lens on 'pktCommand'. pktCommandL :: Functor f - => (Text -> f Text) + => (ByteString -> f ByteString) -> Packet -> f Packet pktCommandL = lens pktCommand (\pk b -> pk { pktCommand = b }) {-# INLINE pktCommandL #-} -- | A lens on 'pktParameter'. pktParameterL :: Functor f - => (Maybe Text -> f (Maybe Text)) + => (Maybe ByteString -> f (Maybe ByteString)) -> Packet -> f Packet pktParameterL = lens pktParameter (\pk b -> pk { pktParameter = b }) {-# INLINE pktParameterL #-} @@ -88,7 +88,7 @@ -- | A lens on 'pktBody'. pktBodyL :: Functor f - => (Maybe Text -> f (Maybe Text)) + => (Maybe ByteString -> f (Maybe ByteString)) -> Packet -> f Packet pktBodyL = lens pktBody (\pk b -> pk { pktBody = b }) {-# INLINE pktBodyL #-} diff --git a/src/Text/Damn/Packet/Parser.hs b/src/Text/Damn/Packet/Parser.hs --- a/src/Text/Damn/Packet/Parser.hs +++ b/src/Text/Damn/Packet/Parser.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -- | Parsing Packets. module Text.Damn.Packet.Parser ( @@ -16,13 +15,14 @@ import Prelude hiding (null) import Control.Applicative ((<$>), (*>), liftA3, pure) import Control.Arrow (second) -import Data.Attoparsec.Text hiding (parse) import Data.Char import qualified Data.Map as M import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as T +import qualified Data.ByteString as B +import Data.ByteString.UTF8 (ByteString) +import qualified Data.ByteString.UTF8 as B hiding (length, drop) import Text.Damn.Packet.Internal +import Text.Trifecta hiding (render) -- | A lens on 'pktSubpacket''. pktSubpacketL :: Functor f => (Maybe Packet -> f (Maybe Packet)) -> Packet -> f Packet @@ -34,23 +34,23 @@ -- | Due to the way dAmn packets are designed, it's not possible to -- unambiguously determine whether a packet has a subpacket or just a body. -- Thus you will need to request a subpacket yourself. -pktSubpacket :: Packet -> Either String Packet +pktSubpacket :: Packet -> Result Packet pktSubpacket Packet { pktBody = b } = - case b of Nothing -> Left "Parent packet has no body!" + case b of Nothing -> Failure "Parent packet has no body!" Just pk -> parse pk {-# INLINE pktSubpacket #-} -- | Use when you don't care about the reason for parse failure. pktSubpacket' :: Packet -> Maybe Packet pktSubpacket' p = case pktSubpacket p of - Left _ -> Nothing - Right pk -> Just pk + Success pk -> Just pk + _ -> Nothing {-# INLINE pktSubpacket' #-} -- | 'render' converts a packet back into the dAmn text format. -- This is used by 'pktSubpacketL' to fulfill the lens laws, but you might -- find it useful if you want to write packets to dAmn. -render :: Packet -> Text +render :: Packet -> ByteString render (Packet cmd prm args b) = cmd <> maybe "" (" " <>) prm @@ -59,37 +59,37 @@ {-# INLINE render #-} -- | Parse some text, providing a packet or the reason for parse failure. -parse :: Text -> Either String Packet -parse str = if T.null body +parse :: ByteString -> Result Packet +parse str = if B.null body then packet else addBody packet where adjustedStr = accountForLoginSpace str - (header, body) = second (T.drop 2) $ T.breakOn "\n\n" adjustedStr - packet = parseOnly headP header - addBody (Right s) = Right $ s { pktBody = Just body } - addBody l@Left{..} = l + (header, body) = second (B.drop 2) $ B.breakSubstring "\n\n" adjustedStr + packet = parseByteString headP mempty header + addBody (Success s) = Success $ s { pktBody = Just body } + addBody l = l -- | Parse some text, discarding any failure message. -parse' :: Text -> Maybe Packet +parse' :: ByteString -> Maybe Packet parse' s = case parse s of - Left _ -> Nothing - Right pk -> Just pk + Success pk -> Just pk + _ -> Nothing {-# INLINE parse' #-} headP :: Parser Packet headP = do - cmd <- takeWhile1 (not . isSpace) + cmd <- some (satisfy (not . isSpace)) prm <- option Nothing paramP args <- argsP - return $ Packet cmd prm args Nothing + return $ Packet (B.fromString cmd) (fmap B.fromString prm) args Nothing where - paramP = fmap Just (char ' ' *> takeWhile1 (not . isSpace)) "parameter" + paramP = fmap Just (char ' ' *> some (satisfy (not . isSpace))) "parameter" argsP = do - ch <- peekChar + ch <- optional (char '\n') case ch of Just '\n' -> liftA3 M.insert - (char '\n' >> takeTill (=='=')) - (char '=' >> takeTill (=='\n')) + (B.fromString <$> some (notChar '=')) + (char '=' >> fmap B.fromString (some (notChar '\n'))) argsP _ -> pure mempty @@ -106,8 +106,10 @@ -- That is, with an extra space after the \"event\" argument. Since this is -- unintuitive behavior and no other packet behaves this way, the parser has -- a special case for login packets where it will eliminate the extra newline. -accountForLoginSpace :: Text -> Text -accountForLoginSpace s = if "login " `T.isPrefixOf` s - then T.replace "\n\n" "\n" s +accountForLoginSpace :: ByteString -> ByteString +accountForLoginSpace s = if "login " `B.isPrefixOf` s + then replace "\n\n" "\n" s else s + where replace find rep ss = case B.breakSubstring find ss of + (a, b) -> a <> rep <> replace find rep (B.drop (B.length find) b) {-# INLINE accountForLoginSpace #-} diff --git a/tests/render.hs b/tests/render.hs --- a/tests/render.hs +++ b/tests/render.hs @@ -1,17 +1,18 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} import Control.Applicative ((<*>), (<$>)) import Control.Monad (unless) import Data.Map (fromList, toList) -import Data.Text (Text, pack, unpack) +import Data.ByteString (ByteString, pack, unpack) import System.Exit import Test.QuickCheck import Test.QuickCheck.Test (isSuccess) import Text.Damn.Packet -instance Arbitrary Text where - arbitrary = pack <$> vectorOf 10 (elements ['a'..'z']) +instance Arbitrary ByteString where + arbitrary = pack <$> vectorOf 10 (elements [97..122]) shrink m = pack <$> shrink (unpack m) instance Arbitrary Packet where