damnpacket 1.1.0 → 1.3.0
raw patch · 9 files changed
+373/−375 lines, 9 filesdep +base-compat-batteriesdep +html-entitydep +semigroupsdep −html-entitiesPVP ok
version bump matches the API change (PVP)
Dependencies added: base-compat-batteries, html-entity, semigroups
Dependencies removed: html-entities
API changes (from Hackage documentation)
+ Network.Damn.Format.IRC: instance GHC.Base.Semigroup Network.Damn.Format.IRC.Lines
- Network.Damn: subMessage :: MessageBody -> forall m. MonadFail m => m SubMessage
+ Network.Damn: subMessage :: MessageBody -> forall m. Monad m => m SubMessage
Files
- ChangeLog.md +3/−3
- damnpacket.cabal +41/−36
- src/Network/Damn.hs +80/−87
- src/Network/Damn/Format/Base.hs +6/−5
- src/Network/Damn/Format/Damn.hs +8/−8
- src/Network/Damn/Format/Damn/Internal.hs +55/−48
- src/Network/Damn/Format/IRC.hs +22/−20
- src/Network/Damn/Tablumps.hs +84/−109
- src/Network/Damn/Tablumps/TH.hs +74/−59
ChangeLog.md view
@@ -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
damnpacket.cabal view
@@ -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
src/Network/Damn.hs view
@@ -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 _ = ""
src/Network/Damn/Format/Base.hs view
@@ -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
src/Network/Damn/Format/Damn.hs view
@@ -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')
src/Network/Damn/Format/Damn/Internal.hs view
@@ -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) = "<a href=\"" <> x <> "\" title=\"" <> y <> "\">"-damnFormat' C_A = "</a>"-damnFormat' (Abbr x) = "<abbr title=\"" <> x <> "\">"-damnFormat' C_Abbr = "</abbr>"-damnFormat' (Acro x) = "<acronym title=\"" <> x <> "\">"-damnFormat' C_Acro = "</acronym>"+damnFormat' (A x y) = "<a href=\"" <> x <> "\" title=\"" <> y <> "\">"+damnFormat' C_A = "</a>"+damnFormat' (Abbr x) = "<abbr title=\"" <> x <> "\">"+damnFormat' C_Abbr = "</abbr>"+damnFormat' (Acro x) = "<acronym title=\"" <> x <> "\">"+damnFormat' C_Acro = "</acronym>" damnFormat' (Avatar x _) = ":icon" <> x <> ":"-damnFormat' B = "<b>"-damnFormat' C_B = "</b>"-damnFormat' Bcode = "<bcode>"-damnFormat' C_Bcode = "</bcode>"-damnFormat' Br = "<br/>"-damnFormat' Code = "<code>"-damnFormat' C_Code = "</code>"-damnFormat' (Dev _ x) = ":dev" <> x <> ":"-damnFormat' (Embed x y z) = "<embed src=\"" <> x <> "\" height=\"" <> y <> "\" width=\"" <> z <> "\">"-damnFormat' C_Embed = "</embed>"+damnFormat' B = "<b>"+damnFormat' C_B = "</b>"+damnFormat' Bcode = "<bcode>"+damnFormat' C_Bcode = "</bcode>"+damnFormat' Br = "<br/>"+damnFormat' Code = "<code>"+damnFormat' C_Code = "</code>"+damnFormat' (Dev _ x) = ":dev" <> x <> ":"+damnFormat' (Embed x y z) =+ "<embed src=\"" <> x <> "\" height=\"" <> y <> "\" width=\"" <> z <> "\">"+damnFormat' C_Embed = "</embed>" damnFormat' (Emote x _ _ _ _) = x-damnFormat' I = "<i>"-damnFormat' C_I = "</i>"-damnFormat' (Iframe x y z) = "<iframe src=\"" <> x <> "\" height=\"" <> y <> "\" width=\"" <> z <> "\">"-damnFormat' C_Iframe = "</iframe>"-damnFormat' (Img x y z) = "<img src=\"" <> x <> "\" height=\"" <> y <> "\" width=\"" <> z <> "\">"-damnFormat' Li = "<li>"-damnFormat' C_Li = "</li>"+damnFormat' I = "<i>"+damnFormat' C_I = "</i>"+damnFormat' (Iframe x y z) =+ "<iframe src=\"" <> x <> "\" height=\"" <> y <> "\" width=\"" <> z <> "\">"+damnFormat' C_Iframe = "</iframe>"+damnFormat' (Img x y z) =+ "<img src=\"" <> x <> "\" height=\"" <> y <> "\" width=\"" <> z <> "\">"+damnFormat' Li = "<li>"+damnFormat' C_Li = "</li>" damnFormat' (Link x _) = x-damnFormat' Ol = "<ol>"-damnFormat' C_Ol = "</ol>"-damnFormat' P = "<p>"-damnFormat' C_P = "</p>"-damnFormat' S = "<s>"-damnFormat' C_S = "</s>"-damnFormat' Sub = "<sub>"-damnFormat' C_Sub = "</sub>"-damnFormat' Sup = "<sup>"-damnFormat' C_Sup = "</sup>"+damnFormat' Ol = "<ol>"+damnFormat' C_Ol = "</ol>"+damnFormat' P = "<p>"+damnFormat' C_P = "</p>"+damnFormat' S = "<s>"+damnFormat' C_S = "</s>"+damnFormat' Sub = "<sub>"+damnFormat' C_Sub = "</sub>"+damnFormat' Sup = "<sup>"+damnFormat' C_Sup = "</sup>" damnFormat' (Thumb x _ _ _ _ _) = ":thumb" <> x <> ":"-damnFormat' U = "<u>"-damnFormat' C_U = "</u>"-damnFormat' Ul = "<ul>"-damnFormat' C_Ul = "</ul>"+damnFormat' U = "<u>"+damnFormat' C_U = "</u>"+damnFormat' Ul = "<ul>"+damnFormat' C_Ul = "</ul>"
src/Network/Damn/Format/IRC.hs view
@@ -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
src/Network/Damn/Tablumps.hs view
@@ -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'
src/Network/Damn/Tablumps/TH.hs view
@@ -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) #-}