diff --git a/benchmarks/parse.hs b/benchmarks/parse.hs --- a/benchmarks/parse.hs +++ b/benchmarks/parse.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} @@ -6,24 +7,32 @@ import Criterion.Main import Text.Damn.Packet import Data.Map (fromList) +import Data.Maybe (fromJust) import Data.Monoid import Data.Text (Text) main :: IO () main = do - let mypkt = samplePacket - evaluate mypkt defaultMain [ - 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 "render" $ nf render mypkt + 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 ] + , bgroup "Rendering" [ + bench "cmd" $ nf render cmdPkt + , bench "cmdParam" $ nf render cmdParamPkt + , bench "cmdArgs" $ nf render cmdArgsPkt + , bench "cmdParamArgs" $ nf render cmdParamArgsPkt + , bench "cmdBody" $ nf render cmdBodyPkt + , bench "cmdParamBody" $ nf render cmdParamBodyPkt + , bench "cmdArgsBody" $ nf render cmdArgsBodyPkt + , bench "cmdParamArgsBody" $ nf render cmdParamArgsBodyPkt ] ] cmd, cmdParam, cmdArgs, cmdParamArgs, @@ -37,9 +46,11 @@ cmdArgsBody = cmdArgs <> "\n\nfoobar" cmdParamArgsBody = cmdParamArgs <> "\n\nfoobar" -samplePacket :: Packet -samplePacket = Packet { pktCommand = "property" - , pktParameter = Just "chat:WriteRoom" - , pktArgs = fromList [("p", "title"), ("body", "someBody")] - , pktBody = Just "this is the property" - } +cmdPkt = fromJust $! parse' cmd +cmdParamPkt = fromJust $! parse' cmdParam +cmdArgsPkt = fromJust $! parse' cmdArgs +cmdParamArgsPkt = fromJust $! parse' cmdParamArgs +cmdBodyPkt = fromJust $! parse' cmdBody +cmdParamBodyPkt = fromJust $! parse' cmdParamBody +cmdArgsBodyPkt = fromJust $! parse' cmdArgsBody +cmdParamArgsBodyPkt = fromJust $! parse' cmdParamArgsBody diff --git a/damnpacket.cabal b/damnpacket.cabal --- a/damnpacket.cabal +++ b/damnpacket.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: damnpacket -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Parsing dAmn packets license: MIT license-file: LICENSE @@ -17,7 +17,7 @@ exposed-modules: Text.Damn.Packet other-modules: Text.Damn.Packet.Internal Text.Damn.Packet.Parser - build-depends: base >= 4.4 && < 4.7 + build-depends: base >= 4.4 && < 4.8 , attoparsec >= 0.10 , containers >= 0.5 , deepseq >= 1.3 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} @@ -17,13 +18,16 @@ import Data.Data import Data.Map (Map) import Data.Text (Text) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707 import Data.Typeable (Typeable) +#endif -- | A type synonym--because pressing spacebar is pretty irritating. type Arguments = Map Text Text lens :: Functor f => (s -> a) -> (s -> b -> t) -> (a -> f b) -> s -> f t lens sa sbt afb s = sbt s <$> afb (sa s) +{-# INLINE lens #-} -- | Represents a dAmn packet. -- @@ -70,21 +74,25 @@ => (Text -> f Text) -> 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)) -> Packet -> f Packet pktParameterL = lens pktParameter (\pk b -> pk { pktParameter = b }) +{-# INLINE pktParameterL #-} -- | A lens on 'pktArgs'. pktArgsL :: Functor f => (Arguments -> f Arguments) -> Packet -> f Packet pktArgsL = lens pktArgs (\pk b -> pk { pktArgs = b }) +{-# INLINE pktArgsL #-} -- | A lens on 'pktBody'. pktBodyL :: Functor f => (Maybe Text -> f (Maybe Text)) -> 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,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -12,11 +13,15 @@ ) where import Prelude hiding (null) -import Control.Applicative ((<$>), (<*>), (*>), many) +import Control.Applicative ((<$>), (*>), liftA3, pure +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707 + , (<*>), many +#endif + ) import Control.Arrow (second) import Data.Attoparsec.Text hiding (parse) import Data.Char -import Data.Map (fromList, toList) +import qualified Data.Map as M import Data.Monoid import Data.Text (Text) import qualified Data.Text as T @@ -27,6 +32,7 @@ pktSubpacketL afb s = setter s <$> afb (getter s) where getter p = pktSubpacket' p setter pkt m = pkt { pktBody = render <$> m } +{-# INLINE pktSubpacketL #-} -- | 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. @@ -51,8 +57,9 @@ render (Packet cmd prm args b) = cmd <> maybe "" (" " <>) prm - <> T.concat (map (\(k,v) -> "\n" <> k <> "=" <> v) (toList args)) + <> M.foldrWithKey (\k v m -> "\n" <> k <> "=" <> v <> m) "" args <> maybe "" ("\n\n" <>) b +{-# INLINE render #-} -- | Parse some text, providing a packet or the reason for parse failure. parse :: Text -> Either String Packet @@ -76,15 +83,34 @@ headP = do cmd <- takeWhile1 (not . isSpace) prm <- option Nothing paramP - args <- fromList <$> argsP + args <- argsP return $ Packet cmd prm args Nothing where paramP = fmap Just (char ' ' *> takeWhile1 (not . isSpace)) "parameter" - argsP = many ((,) <$> (char '\n' >> takeTill (=='=')) - <*> (char '=' >> takeTill (=='\n'))) - "arguments" + argsP = do + ch <- peekChar + case ch of + Just '\n' -> liftA3 M.insert + (char '\n' >> takeTill (=='=')) + (char '=' >> takeTill (=='\n')) + argsP + _ -> pure mempty +-- | The login packet looks like this: +-- +-- @ +--login username +--e=event +-- +--symbol=~ +--realname=Some Name +-- @ +-- +-- 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 else s +{-# INLINE accountForLoginSpace #-}