diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,5 @@ -# Revision history for damn +# Revision history for damnpacket -## 0.1.0.0 -- YYYY-mm-dd +## 1.2.0 -* First version. Released on an unsuspecting world. +* Minor rewrite using base-compat instead of CPP diff --git a/damnpacket.cabal b/damnpacket.cabal --- a/damnpacket.cabal +++ b/damnpacket.cabal @@ -1,43 +1,48 @@ -name: damnpacket -version: 1.1.0 -synopsis: Parsing dAmn messages -description: This module provides a datatype and convenience functions for parsing, manipulating, and rendering deviantART Message Network messages. -license: MIT -license-file: LICENSE -author: Jude Taylor -maintainer: me@jude.bio -category: Network -build-type: Simple -extra-source-files: ChangeLog.md -cabal-version: >=1.10 +name: damnpacket +version: 1.3.0 +synopsis: Parsing dAmn messages +description: This module provides a datatype and convenience functions for parsing, + manipulating, and rendering deviantART Message Network messages. +license: MIT +license-file: LICENSE +author: Jude Taylor +maintainer: me@jude.xyz +tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3 +category: Network +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >= 1.10 +source-repository head + type: git + location: https://github.com/pikajude/damnpacket + library - exposed-modules: Network.Damn - Network.Damn.Format.IRC - Network.Damn.Format.Damn - other-modules: Network.Damn.Tablumps - Network.Damn.Tablumps.TH - Network.Damn.Format.Base - Network.Damn.Format.Damn.Internal - build-depends: base == 4.* - , attoparsec - , bytestring - , fail - , html-entities - , template-haskell - , text - , th-lift-instances - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall + exposed-modules: Network.Damn + Network.Damn.Format.Damn + Network.Damn.Format.IRC + other-modules: Network.Damn.Format.Base + Network.Damn.Format.Damn.Internal + Network.Damn.Tablumps + Network.Damn.Tablumps.TH + hs-source-dirs: src + build-depends: base == 4.* + , attoparsec + , base-compat-batteries == 0.10.* + , bytestring + , fail + , html-entity + , semigroups + , template-haskell + , text + , th-lift-instances + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + ghc-options: -Wall test-suite parse + type: exitcode-stdio-1.0 main-is: parse.hs hs-source-dirs: test + build-depends: base, HUnit, QuickCheck, bytestring, damnpacket, hspec default-language: Haskell2010 - type: exitcode-stdio-1.0 - build-depends: base, bytestring, damnpacket, HUnit, hspec, QuickCheck - -source-repository head - location: https://github.com/pikajude/damnpacket - type: git diff --git a/src/Network/Damn.hs b/src/Network/Damn.hs --- a/src/Network/Damn.hs +++ b/src/Network/Damn.hs @@ -1,59 +1,56 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} #define PATTERNS (__GLASGOW_HASKELL__ >= 710) #if PATTERNS -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} #endif -- | This module provides a datatype and convenience functions for parsing, -- manipulating, and rendering deviantART Message Network messages. -module Network.Damn ( - -- *** Datatypes - Message(..), - SubMessage(..), - MessageBody, +module Network.Damn + ( -- *** Datatypes + Message(..) + , SubMessage(..) + , MessageBody -- *** Working with message bodies - bodyBytes, Formatter, bodyWithFormat, - toBody, toBodyText, + , bodyBytes + , Formatter + , bodyWithFormat + , toBody + , toBodyText -- *** Working with sub-messages - subMessage, + , subMessage #if PATTERNS - pattern SubM, + , pattern SubM #endif -- *** Parsing - parseMessage, - messageP, + , parseMessage + , messageP -- *** Rendering - render, + , render -- *** Tablumps - Lump(..) -) where + , Lump(..) + ) where -import Control.Applicative -import qualified Control.Monad -import Control.Monad.Fail -import Data.Attoparsec.ByteString hiding (word8) -import qualified Data.Attoparsec.ByteString as A -import qualified Data.Attoparsec.ByteString.Char8 as C -import Data.ByteString +import Control.Applicative +import Data.Attoparsec.ByteString hiding (word8) +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Char8 as C +import Data.ByteString import qualified Data.ByteString as B -import Data.Char -import Data.Ix -import Data.Monoid -import Data.String -import Data.Text hiding (singleton) -import Data.Word -import Network.Damn.Format.Base (Formatter) -import Network.Damn.Format.Damn.Internal (textToBytes) -import Network.Damn.Tablumps -import Prelude hiding (fail) -#if __GLASGOW_HASKELL__ <= 708 -import Data.Foldable (foldMap) -#endif +import Data.Char +import Data.Ix +import Data.String +import Data.Text hiding (singleton) +import Data.Word +import Network.Damn.Format.Base (Formatter) +import Network.Damn.Format.Damn.Internal (textToBytes) +import Network.Damn.Tablumps +import Prelude.Compat -- | A top-level dAmn message. -- @@ -85,32 +82,33 @@ -- when 'Text' appears in fields of this record or of 'SubMessage', you can -- assume that the HTML entity decoding step has already been handled. data Message = Message - { messageName :: ByteString - , messageArgument :: Maybe ByteString - , messageAttrs :: [(ByteString, Text)] - , messageBody :: Maybe MessageBody - } deriving (Eq, Show) + { messageName :: ByteString + , messageArgument :: Maybe ByteString + , messageAttrs :: [(ByteString, Text)] + , messageBody :: Maybe MessageBody + } deriving (Eq, Show) -- | A second-level dAmn message. Note that this message can omit the -- name/argument pair. data SubMessage = SubMessage - { subMessageName :: Maybe ByteString - , subMessageArgument :: Maybe ByteString - , subMessageAttrs :: [(ByteString, Text)] - , subMessageBody :: Maybe MessageBody - } deriving (Eq, Show) + { subMessageName :: Maybe ByteString + , subMessageArgument :: Maybe ByteString + , subMessageAttrs :: [(ByteString, Text)] + , subMessageBody :: Maybe MessageBody + } deriving (Eq, Show) -- | The body of a message, which can be converted to various formats -- ('bodyWithFormat') or parsed as a 'SubMessage' ('subMessage'). data MessageBody = MessageBody - { -- | View the original binary content of a 'MessageBody'. - -- - -- To interpret this as textual data, use - -- 'bodyWithFormat'. - bodyBytes :: ByteString - -- | Try to parse a 'MessageBody' as a 'SubMessage'. - , subMessage :: forall m. MonadFail m => m SubMessage - } + { -- | View the original binary content of a 'MessageBody'. + -- + -- To interpret this as textual data, use + -- 'bodyWithFormat'. + bodyBytes :: ByteString + -- | Try to parse a 'MessageBody' as a 'SubMessage'. + , subMessage :: forall m. Monad m => + m SubMessage + } instance IsString MessageBody where fromString = toBody . fromString @@ -118,7 +116,6 @@ -- bodyRaw (MessageBody b _) = show b -- bodyText (MessageBody b _) = lumpsToText b -- bodyTextInline (MessageBody b _) = lumpsToTextInline b - instance Show MessageBody where show (MessageBody b _) = show b @@ -151,9 +148,10 @@ -- | Convert a 'MessageBody' to some stringlike representation using the -- given 'Formatter'. (See 'Network.Damn.Format.Damn.damnFormat'). bodyWithFormat :: Monoid s => Formatter s -> MessageBody -> s -bodyWithFormat f = foldMap f . dropColorAbbrs . toLumps . bodyBytes where +bodyWithFormat f = foldMap f . dropColorAbbrs . toLumps . bodyBytes -- these are annoying and nobody needs them - dropColorAbbrs (Right (Abbr c) : Right C_Abbr : xs) + where + dropColorAbbrs (Right (Abbr c):Right C_Abbr:xs) | "colors:" `B.isPrefixOf` c = xs | otherwise = Right (Abbr c) : dropColorAbbrs (Right C_Abbr : xs) dropColorAbbrs (x:xs) = x : dropColorAbbrs xs @@ -163,25 +161,22 @@ messageP = do name <- C.takeWhile1 C.isAlpha_iso8859_15 next <- C.peekChar' - arg <- if next == ' ' - then C.char ' ' *> (Just <$> C.takeWhile1 (/= '\n')) - else pure Nothing - + arg <- + if next == ' ' + then C.char ' ' *> (Just <$> C.takeWhile1 (/= '\n')) + else pure Nothing _ <- C.char '\n' attrs <- many attr - body <- parseBody - return $ Message name arg attrs body parseBody :: Parser (Maybe MessageBody) parseBody = do next <- C.anyChar case next of - '\n' -> Just . toBody - <$> Data.Attoparsec.ByteString.takeWhile (/= 0) <* A.word8 0 + '\n' -> Just . toBody <$> Data.Attoparsec.ByteString.takeWhile (/= 0) <* A.word8 0 '\0' -> pure Nothing - _ -> Control.Monad.fail "Malformed packet" + _ -> fail "Malformed packet" subMessageP :: Parser SubMessage subMessageP = do @@ -190,7 +185,7 @@ Just a -> do otherAttrs <- many attr body <- parseBody - return $ SubMessage Nothing Nothing (a:otherAttrs) body + return $ SubMessage Nothing Nothing (a : otherAttrs) body Nothing -> do Message a b c d <- messageP return $ SubMessage (Just a) b c d @@ -204,15 +199,16 @@ return (k, htmlDecode $ bytesToText v) nameChars :: Word8 -> Bool -nameChars x = inRange (integralOrd 'a', integralOrd 'z') x - || inRange (integralOrd 'A', integralOrd 'Z') x - || inRange (integralOrd '0', integralOrd '9') x - where integralOrd = fromIntegral . ord +nameChars x = + inRange (integralOrd 'a', integralOrd 'z') x || + inRange (integralOrd 'A', integralOrd 'Z') x || + inRange (integralOrd '0', integralOrd '9') x + where + integralOrd = fromIntegral . ord -- | 'MessageBody' smart constructor. toBody :: ByteString -> MessageBody -toBody x = MessageBody x - (either Control.Monad.fail return $ parseOnly subMessageP (x <> "\0")) +toBody x = MessageBody x (either fail return $ parseOnly subMessageP (x <> "\0")) -- | Like 'toBody', but convert codepoints outside the ASCII range to HTML -- entities. @@ -232,15 +228,12 @@ -- >>> render (Message "foo" (Just "bar") [("attr1", "☭")] Nothing) -- "foo bar\nattr1=☭\n\NUL" render :: Message -> ByteString -render (Message name arg attrs body) = appendArg arg name - <> "\n" - <> renderAttrs attrs - <> renderBody body - <> "\0" - where - appendArg (Just b) = (<> (" " <> b)) - appendArg _ = id - renderAttrs [] = "" - renderAttrs ((a,b):bs) = a <> "=" <> textToBytes b <> "\n" <> renderAttrs bs - renderBody (Just (MessageBody b _)) = "\n" <> b - renderBody _ = "" +render (Message name arg attrs body) = + appendArg arg name <> "\n" <> renderAttrs attrs <> renderBody body <> "\0" + where + appendArg (Just b) = (<> (" " <> b)) + appendArg _ = id + renderAttrs [] = "" + renderAttrs ((a, b):bs) = a <> "=" <> textToBytes b <> "\n" <> renderAttrs bs + renderBody (Just (MessageBody b _)) = "\n" <> b + renderBody _ = "" diff --git a/src/Network/Damn/Format/Base.hs b/src/Network/Damn/Format/Base.hs --- a/src/Network/Damn/Format/Base.hs +++ b/src/Network/Damn/Format/Base.hs @@ -1,9 +1,10 @@ -module Network.Damn.Format.Base ( - module Network.Damn.Format.Base, - module Network.Damn.Tablumps, - Text -) where +module Network.Damn.Format.Base + ( module Network.Damn.Format.Base + , module Network.Damn.Tablumps + , Text + ) where +import Data.Either import Data.Text import Network.Damn.Tablumps diff --git a/src/Network/Damn/Format/Damn.hs b/src/Network/Damn/Format/Damn.hs --- a/src/Network/Damn/Format/Damn.hs +++ b/src/Network/Damn/Format/Damn.hs @@ -1,18 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.Damn.Format.Damn ( - damnFormat, - damnFormatBytes -) where +module Network.Damn.Format.Damn + ( damnFormat + , damnFormatBytes + ) where -import Data.ByteString (ByteString) +import Data.ByteString (ByteString) import Data.Text.Encoding import Network.Damn.Format.Base import Network.Damn.Format.Damn.Internal +import Prelude.Compat --- | @damnFormat@ is, essentially, a formatter that transforms a raw --- dAmn message into the text that the sender typed into the dAmn web --- client. +-- | @damnFormat@ transforms a raw dAmn message into the text that the +-- sender typed into the dAmn web client. damnFormat :: Formatter Text damnFormat = either id (decodeUtf8 . damnFormat') diff --git a/src/Network/Damn/Format/Damn/Internal.hs b/src/Network/Damn/Format/Damn/Internal.hs --- a/src/Network/Damn/Format/Damn/Internal.hs +++ b/src/Network/Damn/Format/Damn/Internal.hs @@ -1,63 +1,70 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.Damn.Format.Damn.Internal ( - textToBytes, damnFormat' -) where +module Network.Damn.Format.Damn.Internal + ( textToBytes + , damnFormat' + ) where -import Data.ByteString (ByteString) -import Data.ByteString.Builder -import qualified Data.ByteString.Lazy as LB (toStrict) -import Data.Char -import Data.Monoid -import Data.Text (Text) +import Data.ByteString (ByteString) +import Data.ByteString.Builder +import qualified Data.ByteString.Lazy as LB (toStrict) +import Data.Char +import Data.Monoid.Compat +import Data.Text (Text) import qualified Data.Text -import Network.Damn.Tablumps.TH +import Network.Damn.Tablumps.TH +import Prelude.Compat textToBytes :: Text -> ByteString -textToBytes = LB.toStrict . toLazyByteString . Data.Text.foldr (\ c b -> maybeEscape c <> b) "" where +textToBytes = + LB.toStrict . toLazyByteString . Data.Text.foldr (\c b -> maybeEscape c <> b) "" + where maybeEscape c | ord c <= 127 = word8 (fromIntegral $ ord c) | otherwise = "&#x" <> word32Hex (fromIntegral $ ord c) <> ";" damnFormat' :: Lump -> ByteString -damnFormat' (A x y) = " x <> "\" title=\"" <> y <> "\">" -damnFormat' C_A = "" -damnFormat' (Abbr x) = " x <> "\">" -damnFormat' C_Abbr = "" -damnFormat' (Acro x) = " x <> "\">" -damnFormat' C_Acro = "" +damnFormat' (A x y) = " x <> "\" title=\"" <> y <> "\">" +damnFormat' C_A = "" +damnFormat' (Abbr x) = " x <> "\">" +damnFormat' C_Abbr = "" +damnFormat' (Acro x) = " x <> "\">" +damnFormat' C_Acro = "" damnFormat' (Avatar x _) = ":icon" <> x <> ":" -damnFormat' B = "" -damnFormat' C_B = "" -damnFormat' Bcode = "" -damnFormat' C_Bcode = "" -damnFormat' Br = "
" -damnFormat' Code = "" -damnFormat' C_Code = "" -damnFormat' (Dev _ x) = ":dev" <> x <> ":" -damnFormat' (Embed x y z) = " x <> "\" height=\"" <> y <> "\" width=\"" <> z <> "\">" -damnFormat' C_Embed = "" +damnFormat' B = "" +damnFormat' C_B = "" +damnFormat' Bcode = "" +damnFormat' C_Bcode = "" +damnFormat' Br = "
" +damnFormat' Code = "" +damnFormat' C_Code = "" +damnFormat' (Dev _ x) = ":dev" <> x <> ":" +damnFormat' (Embed x y z) = + " x <> "\" height=\"" <> y <> "\" width=\"" <> z <> "\">" +damnFormat' C_Embed = "" damnFormat' (Emote x _ _ _ _) = x -damnFormat' I = "" -damnFormat' C_I = "" -damnFormat' (Iframe x y z) = "" -damnFormat' (Img x y z) = " x <> "\" height=\"" <> y <> "\" width=\"" <> z <> "\">" -damnFormat' Li = "
  • " -damnFormat' C_Li = "
    • " +damnFormat' I = "" +damnFormat' C_I = "" +damnFormat' (Iframe x y z) = + "" +damnFormat' (Img x y z) = + " x <> "\" height=\"" <> y <> "\" width=\"" <> z <> "\">" +damnFormat' Li = "
  • " +damnFormat' C_Li = "
    • " damnFormat' (Link x _) = x -damnFormat' Ol = "
      " -damnFormat' C_Ol = "
    " -damnFormat' P = "

    " -damnFormat' C_P = "

    " -damnFormat' S = "" -damnFormat' C_S = "" -damnFormat' Sub = "" -damnFormat' C_Sub = "" -damnFormat' Sup = "" -damnFormat' C_Sup = "" +damnFormat' Ol = "
      " +damnFormat' C_Ol = "
    " +damnFormat' P = "

    " +damnFormat' C_P = "

    " +damnFormat' S = "" +damnFormat' C_S = "" +damnFormat' Sub = "" +damnFormat' C_Sub = "" +damnFormat' Sup = "" +damnFormat' C_Sup = "" damnFormat' (Thumb x _ _ _ _ _) = ":thumb" <> x <> ":" -damnFormat' U = "" -damnFormat' C_U = "" -damnFormat' Ul = "" +damnFormat' U = "" +damnFormat' C_U = "" +damnFormat' Ul = "" diff --git a/src/Network/Damn/Format/IRC.hs b/src/Network/Damn/Format/IRC.hs --- a/src/Network/Damn/Format/IRC.hs +++ b/src/Network/Damn/Format/IRC.hs @@ -1,24 +1,26 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} -- | Format a dAmn message body as an inline text approximation, including -- IRC styles. -module Network.Damn.Format.IRC ( - ircFormat, Lines, unLines -) where +module Network.Damn.Format.IRC + ( ircFormat + , Lines + , unLines + ) where -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.String -import Data.Text.Encoding -import Network.Damn.Format.Base -import Network.Damn.Format.Damn.Internal -#if __GLASGOW_HASKELL__ <= 708 -import Data.Monoid -#endif +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Semigroup.Compat +import Data.String +import Data.Text.Encoding +import Network.Damn.Format.Base +import Network.Damn.Format.Damn.Internal +import Prelude.Compat -newtype Lines = Lines ByteString deriving (Show, Monoid, IsString) +newtype Lines = + Lines ByteString + deriving (Show, Monoid, Semigroup, IsString) unLines :: Lines -> [ByteString] unLines (Lines bs) = B.split 10 bs @@ -35,11 +37,11 @@ ircFormat = either (Lines . encodeUtf8) (Lines . ircFormat') ircFormat' :: Lump -> ByteString -ircFormat' B = "\x02" +ircFormat' B = "\x02" ircFormat' C_B = "\x02" -ircFormat' Br = "\n" -ircFormat' I = "\x1D" +ircFormat' Br = "\n" +ircFormat' I = "\x1D" ircFormat' C_I = "\x1D" -ircFormat' U = "\x1F" +ircFormat' U = "\x1F" ircFormat' C_U = "\x1F" -ircFormat' x = damnFormat' x +ircFormat' x = damnFormat' x diff --git a/src/Network/Damn/Tablumps.hs b/src/Network/Damn/Tablumps.hs --- a/src/Network/Damn/Tablumps.hs +++ b/src/Network/Damn/Tablumps.hs @@ -1,124 +1,99 @@ {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} -module Network.Damn.Tablumps ( - module Network.Damn.Tablumps, - Lump(..) -) where +module Network.Damn.Tablumps + ( module Network.Damn.Tablumps + , Lump(..) + ) where -import Control.Applicative -import Control.Arrow (left) -import Data.Attoparsec.ByteString hiding (word8) +import Control.Applicative +import Control.Arrow +import Data.Attoparsec.ByteString hiding (word8) import qualified Data.Attoparsec.ByteString.Char8 as C -import Data.ByteString (ByteString) -import Data.Monoid -import Data.Text (Text) -import Data.Text.Encoding -import Data.Text.Internal.Builder (toLazyText) -import Data.Text.Lazy (toStrict) -import HTMLEntities.Decoder -import Network.Damn.Tablumps.TH - --- type Lump = (ByteString, [ByteString]) --- data Lump = Lump deriving (Eq, Show) +import Data.ByteString (ByteString) +import Data.Either.Compat +import Data.Monoid.Compat +import Data.Text (Text) +import Data.Text.Encoding +import Network.Damn.Tablumps.TH +import Prelude.Compat +import qualified Text.HTMLEntity as HE tablumpP :: Parser [Either ByteString Lump] -tablumpP = many $ (Left <$> C.takeWhile1 (/= '&')) - <|> lump - <|> fmap Left (C.string "&") +tablumpP = many $ (Left <$> C.takeWhile1 (/= '&')) <|> lump <|> fmap Left (C.string "&") lump :: Parser (Either a Lump) -lump = (C.char '&' *>) $ choice - [ $(ary 2 "a" 'A) - , $(ary 0 "/a" 'C_A) - - , $(ary 1 "abbr" 'Abbr) - , $(ary 0 "/abbr" 'C_Abbr) - - , $(ary 1 "acro" 'Acro) - , $(ary 0 "/acro" 'C_Acro) - - , $(ary 2 "avatar" 'Avatar) - - , $(ary 0 "b" 'B) - , $(ary 0 "/b" 'C_B) - - , $(ary 0 "bcode" 'Bcode) - , $(ary 0 "/bcode" 'C_Bcode) - - , $(ary 0 "br" 'Br) - - , $(ary 0 "code" 'Code) - , $(ary 0 "/code" 'C_Code) - - , $(ary 2 "dev" 'Dev) - - , $(ary 3 "embed" 'Embed) - , $(ary 0 "/embed" 'C_Embed) - - , $(ary 5 "emote" 'Emote) - - , $(ary 0 "i" 'I) - , $(ary 0 "/i" 'C_I) - - , $(ary 3 "iframe" 'Iframe) - , $(ary 0 "/iframe" 'C_Iframe) - - , $(ary 3 "img" 'Img) - - , $(ary 0 "li" 'Li) - , $(ary 0 "/li" 'C_Li) - - , link - - , $(ary 0 "ol" 'Ol) - , $(ary 0 "/ol" 'C_Ol) - - , $(ary 0 "p" 'P) - , $(ary 0 "/p" 'C_P) - - , $(ary 0 "s" 'S) - , $(ary 0 "/s" 'C_S) - - , $(ary 0 "sub" 'Sub) - , $(ary 0 "/sub" 'C_Sub) - - , $(ary 0 "sup" 'Sup) - , $(ary 0 "/sup" 'C_Sup) - - , $(ary 6 "thumb" 'Thumb) - - , $(ary 0 "u" 'U) - , $(ary 0 "/u" 'C_U) - - , $(ary 0 "ul" 'Ul) - , $(ary 0 "/ul" 'C_Ul) - ] - where - link = do - _ <- string "link" - _ <- C.char '\t' - arg1 <- arg - arg2 <- arg - case arg2 of - "&" -> pure $ Right $ Link arg1 Nothing - _ -> do - _ <- string "&\t" - pure $ Right $ Link arg1 (Just arg2) - arg = C.takeWhile (/= '\t') <* C.char '\t' +lump = + (C.char '&' *>) $ + choice + [ $(ary 2 "a" 'A) + , $(ary 0 "/a" 'C_A) + , $(ary 1 "abbr" 'Abbr) + , $(ary 0 "/abbr" 'C_Abbr) + , $(ary 1 "acro" 'Acro) + , $(ary 0 "/acro" 'C_Acro) + , $(ary 2 "avatar" 'Avatar) + , $(ary 0 "b" 'B) + , $(ary 0 "/b" 'C_B) + , $(ary 0 "bcode" 'Bcode) + , $(ary 0 "/bcode" 'C_Bcode) + , $(ary 0 "br" 'Br) + , $(ary 0 "code" 'Code) + , $(ary 0 "/code" 'C_Code) + , $(ary 2 "dev" 'Dev) + , $(ary 3 "embed" 'Embed) + , $(ary 0 "/embed" 'C_Embed) + , $(ary 5 "emote" 'Emote) + , $(ary 0 "i" 'I) + , $(ary 0 "/i" 'C_I) + , $(ary 3 "iframe" 'Iframe) + , $(ary 0 "/iframe" 'C_Iframe) + , $(ary 3 "img" 'Img) + , $(ary 0 "li" 'Li) + , $(ary 0 "/li" 'C_Li) + , link + , $(ary 0 "ol" 'Ol) + , $(ary 0 "/ol" 'C_Ol) + , $(ary 0 "p" 'P) + , $(ary 0 "/p" 'C_P) + , $(ary 0 "s" 'S) + , $(ary 0 "/s" 'C_S) + , $(ary 0 "sub" 'Sub) + , $(ary 0 "/sub" 'C_Sub) + , $(ary 0 "sup" 'Sup) + , $(ary 0 "/sup" 'C_Sup) + , $(ary 6 "thumb" 'Thumb) + , $(ary 0 "u" 'U) + , $(ary 0 "/u" 'C_U) + , $(ary 0 "ul" 'Ul) + , $(ary 0 "/ul" 'C_Ul) + ] + where + link = do + _ <- string "link" + _ <- C.char '\t' + arg1 <- arg + arg2 <- arg + case arg2 of + "&" -> pure $ Right $ Link arg1 Nothing + _ -> do + _ <- string "&\t" + pure $ Right $ Link arg1 (Just arg2) + arg = C.takeWhile (/= '\t') <* C.char '\t' toLumps :: ByteString -> [Either Text Lump] -toLumps t = case parseOnly tablumpP t of - Right y -> map (left (htmlDecode . bytesToText)) $ joinLefts y - Left _ -> [Left $ bytesToText t] - where - joinLefts (Left a : Left b : xs) = joinLefts (Left (a <> b) : xs) - joinLefts (x:xs) = x : joinLefts xs - joinLefts [] = [] +toLumps t = + case parseOnly tablumpP t of + Right y -> map (left (htmlDecode . bytesToText)) $ joinLefts y + Left _ -> [Left $ bytesToText t] + where + joinLefts (Left a:Left b:xs) = joinLefts (Left (a <> b) : xs) + joinLefts (x:xs) = x : joinLefts xs + joinLefts [] = [] bytesToText :: ByteString -> Text bytesToText = decodeLatin1 htmlDecode :: Text -> Text -htmlDecode = toStrict . toLazyText . htmlEncodedText +htmlDecode = HE.decode' diff --git a/src/Network/Damn/Tablumps/TH.hs b/src/Network/Damn/Tablumps/TH.hs --- a/src/Network/Damn/Tablumps/TH.hs +++ b/src/Network/Damn/Tablumps/TH.hs @@ -1,73 +1,88 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} -#define ARG ByteString - module Network.Damn.Tablumps.TH where -import Data.Attoparsec.ByteString (string) +import Data.Attoparsec.ByteString (string) import qualified Data.Attoparsec.ByteString.Char8 as C -import Data.ByteString (ByteString) -import Language.Haskell.TH -#if __GLASGOW_HASKELL__ <= 708 -import Control.Applicative -#endif +import Data.ByteString (ByteString) +import Language.Haskell.TH +import Prelude.Compat ary :: Int -> String -> Name -> ExpQ -ary n s con = [e|do - _ <- string s - _ <- C.char '\t' - Right <$> $(mkApps) - |] - where - mkApps = foldl (\ a b -> [e|$(a) <*> $(b)|]) [e|pure $(conE con)|] - $ replicate n [e|C.takeWhile (/= '\t') <* C.char '\t'|] +ary n s con = + [|do _ <- string s + _ <- C.char '\t' + Right <$> $(mkApps)|] + where + mkApps = + foldl (\a b -> [|$(a) <*> $(b)|]) [|pure $(conE con)|] $ + replicate n [|C.takeWhile (/= '\t') <* C.char '\t'|] -- | Tokens representing tablumps. -- -- These constructors are defined first in order of arity, then -- alphabetically. -data Lump = A ARG ARG - | C_A - | Abbr ARG - | C_Abbr - | Acro ARG - | C_Acro - | Avatar ARG ARG - | B - | C_B - | Bcode - | C_Bcode - | Br - | Code - | C_Code - | Dev ARG ARG - | Embed ARG ARG ARG - | C_Embed - | Emote ARG ARG ARG ARG ARG - | I - | C_I - | Iframe ARG ARG ARG - | C_Iframe - | Img ARG ARG ARG - | Li - | C_Li - | Link ARG (Maybe ARG) - | Ol - | C_Ol - | P - | C_P - | S - | C_S - | Sub - | C_Sub - | Sup - | C_Sup - | Thumb ARG ARG ARG ARG ARG ARG - | U - | C_U - | Ul - | C_Ul - deriving (Eq, Show) +data Lump + = A ByteString + ByteString + | C_A + | Abbr ByteString + | C_Abbr + | Acro ByteString + | C_Acro + | Avatar ByteString + ByteString + | B + | C_B + | Bcode + | C_Bcode + | Br + | Code + | C_Code + | Dev ByteString + ByteString + | Embed ByteString + ByteString + ByteString + | C_Embed + | Emote ByteString + ByteString + ByteString + ByteString + ByteString + | I + | C_I + | Iframe ByteString + ByteString + ByteString + | C_Iframe + | Img ByteString + ByteString + ByteString + | Li + | C_Li + | Link ByteString + (Maybe ByteString) + | Ol + | C_Ol + | P + | C_P + | S + | C_S + | Sub + | C_Sub + | Sup + | C_Sup + | Thumb ByteString + ByteString + ByteString + ByteString + ByteString + ByteString + | U + | C_U + | Ul + | C_Ul + deriving (Eq, Show) {-# ANN module ("HLint: ignore Use camelCase" :: String) #-}