{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Irc.RawIrcMsg
(
RawIrcMsg(..)
, TagEntry(..)
, rawIrcMsg
, msgTags
, msgPrefix
, msgCommand
, msgParams
, parseRawIrcMsg
, renderRawIrcMsg
, prefixParser
, simpleTokenParser
, asUtf8
) where
import Control.Applicative
import Data.Attoparsec.Text as P
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as Builder
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Irc.UserInfo
import View
data RawIrcMsg = RawIrcMsg
{ RawIrcMsg -> [TagEntry]
_msgTags :: [TagEntry]
, RawIrcMsg -> Maybe UserInfo
_msgPrefix :: Maybe UserInfo
, RawIrcMsg -> Text
_msgCommand :: !Text
, RawIrcMsg -> [Text]
_msgParams :: [Text]
}
deriving (RawIrcMsg -> RawIrcMsg -> Bool
(RawIrcMsg -> RawIrcMsg -> Bool)
-> (RawIrcMsg -> RawIrcMsg -> Bool) -> Eq RawIrcMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawIrcMsg -> RawIrcMsg -> Bool
$c/= :: RawIrcMsg -> RawIrcMsg -> Bool
== :: RawIrcMsg -> RawIrcMsg -> Bool
$c== :: RawIrcMsg -> RawIrcMsg -> Bool
Eq, ReadPrec [RawIrcMsg]
ReadPrec RawIrcMsg
Int -> ReadS RawIrcMsg
ReadS [RawIrcMsg]
(Int -> ReadS RawIrcMsg)
-> ReadS [RawIrcMsg]
-> ReadPrec RawIrcMsg
-> ReadPrec [RawIrcMsg]
-> Read RawIrcMsg
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RawIrcMsg]
$creadListPrec :: ReadPrec [RawIrcMsg]
readPrec :: ReadPrec RawIrcMsg
$creadPrec :: ReadPrec RawIrcMsg
readList :: ReadS [RawIrcMsg]
$creadList :: ReadS [RawIrcMsg]
readsPrec :: Int -> ReadS RawIrcMsg
$creadsPrec :: Int -> ReadS RawIrcMsg
Read, Int -> RawIrcMsg -> ShowS
[RawIrcMsg] -> ShowS
RawIrcMsg -> String
(Int -> RawIrcMsg -> ShowS)
-> (RawIrcMsg -> String)
-> ([RawIrcMsg] -> ShowS)
-> Show RawIrcMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RawIrcMsg] -> ShowS
$cshowList :: [RawIrcMsg] -> ShowS
show :: RawIrcMsg -> String
$cshow :: RawIrcMsg -> String
showsPrec :: Int -> RawIrcMsg -> ShowS
$cshowsPrec :: Int -> RawIrcMsg -> ShowS
Show)
data TagEntry = TagEntry {-# UNPACK #-} !Text {-# UNPACK #-} !Text
deriving (TagEntry -> TagEntry -> Bool
(TagEntry -> TagEntry -> Bool)
-> (TagEntry -> TagEntry -> Bool) -> Eq TagEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TagEntry -> TagEntry -> Bool
$c/= :: TagEntry -> TagEntry -> Bool
== :: TagEntry -> TagEntry -> Bool
$c== :: TagEntry -> TagEntry -> Bool
Eq, ReadPrec [TagEntry]
ReadPrec TagEntry
Int -> ReadS TagEntry
ReadS [TagEntry]
(Int -> ReadS TagEntry)
-> ReadS [TagEntry]
-> ReadPrec TagEntry
-> ReadPrec [TagEntry]
-> Read TagEntry
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TagEntry]
$creadListPrec :: ReadPrec [TagEntry]
readPrec :: ReadPrec TagEntry
$creadPrec :: ReadPrec TagEntry
readList :: ReadS [TagEntry]
$creadList :: ReadS [TagEntry]
readsPrec :: Int -> ReadS TagEntry
$creadsPrec :: Int -> ReadS TagEntry
Read, Int -> TagEntry -> ShowS
[TagEntry] -> ShowS
TagEntry -> String
(Int -> TagEntry -> ShowS)
-> (TagEntry -> String) -> ([TagEntry] -> ShowS) -> Show TagEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TagEntry] -> ShowS
$cshowList :: [TagEntry] -> ShowS
show :: TagEntry -> String
$cshow :: TagEntry -> String
showsPrec :: Int -> TagEntry -> ShowS
$cshowsPrec :: Int -> TagEntry -> ShowS
Show)
msgTags :: Functor f => ([TagEntry] -> f [TagEntry]) -> RawIrcMsg -> f RawIrcMsg
msgTags :: ([TagEntry] -> f [TagEntry]) -> RawIrcMsg -> f RawIrcMsg
msgTags [TagEntry] -> f [TagEntry]
f RawIrcMsg
m = (\[TagEntry]
x -> RawIrcMsg
m { _msgTags :: [TagEntry]
_msgTags = [TagEntry]
x }) ([TagEntry] -> RawIrcMsg) -> f [TagEntry] -> f RawIrcMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TagEntry] -> f [TagEntry]
f (RawIrcMsg -> [TagEntry]
_msgTags RawIrcMsg
m)
msgPrefix :: Functor f => (Maybe UserInfo -> f (Maybe UserInfo)) -> RawIrcMsg -> f RawIrcMsg
msgPrefix :: (Maybe UserInfo -> f (Maybe UserInfo)) -> RawIrcMsg -> f RawIrcMsg
msgPrefix Maybe UserInfo -> f (Maybe UserInfo)
f RawIrcMsg
m = (\Maybe UserInfo
x -> RawIrcMsg
m { _msgPrefix :: Maybe UserInfo
_msgPrefix = Maybe UserInfo
x }) (Maybe UserInfo -> RawIrcMsg) -> f (Maybe UserInfo) -> f RawIrcMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UserInfo -> f (Maybe UserInfo)
f (RawIrcMsg -> Maybe UserInfo
_msgPrefix RawIrcMsg
m)
msgCommand :: Functor f => (Text -> f Text) -> RawIrcMsg -> f RawIrcMsg
msgCommand :: (Text -> f Text) -> RawIrcMsg -> f RawIrcMsg
msgCommand Text -> f Text
f RawIrcMsg
m = (\Text
x -> RawIrcMsg
m { _msgCommand :: Text
_msgCommand = Text
x }) (Text -> RawIrcMsg) -> f Text -> f RawIrcMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> f Text
f (RawIrcMsg -> Text
_msgCommand RawIrcMsg
m)
msgParams :: Functor f => ([Text] -> f [Text]) -> RawIrcMsg -> f RawIrcMsg
msgParams :: ([Text] -> f [Text]) -> RawIrcMsg -> f RawIrcMsg
msgParams [Text] -> f [Text]
f RawIrcMsg
m = (\[Text]
x -> RawIrcMsg
m { _msgParams :: [Text]
_msgParams = [Text]
x }) ([Text] -> RawIrcMsg) -> f [Text] -> f RawIrcMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> f [Text]
f (RawIrcMsg -> [Text]
_msgParams RawIrcMsg
m)
parseRawIrcMsg :: Text -> Maybe RawIrcMsg
parseRawIrcMsg :: Text -> Maybe RawIrcMsg
parseRawIrcMsg Text
x =
case Parser RawIrcMsg -> Text -> Either String RawIrcMsg
forall a. Parser a -> Text -> Either String a
parseOnly Parser RawIrcMsg
rawIrcMsgParser Text
x of
Left{} -> Maybe RawIrcMsg
forall a. Maybe a
Nothing
Right RawIrcMsg
r -> RawIrcMsg -> Maybe RawIrcMsg
forall a. a -> Maybe a
Just RawIrcMsg
r
maxMiddleParams :: Int
maxMiddleParams :: Int
maxMiddleParams = Int
14
rawIrcMsgParser :: Parser RawIrcMsg
rawIrcMsgParser :: Parser RawIrcMsg
rawIrcMsgParser =
do [TagEntry]
tags <- [TagEntry] -> Maybe [TagEntry] -> [TagEntry]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [TagEntry] -> [TagEntry])
-> Parser Text (Maybe [TagEntry]) -> Parser Text [TagEntry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Text [TagEntry] -> Parser Text (Maybe [TagEntry])
forall b. Char -> Parser b -> Parser (Maybe b)
guarded Char
'@' Parser Text [TagEntry]
tagsParser
Maybe UserInfo
prefix <- Char -> Parser UserInfo -> Parser (Maybe UserInfo)
forall b. Char -> Parser b -> Parser (Maybe b)
guarded Char
':' Parser UserInfo
prefixParser
Text
cmd <- Parser Text
simpleTokenParser
[Text]
params <- Int -> Parser [Text]
paramsParser Int
maxMiddleParams
RawIrcMsg -> Parser RawIrcMsg
forall (m :: * -> *) a. Monad m => a -> m a
return (RawIrcMsg -> Parser RawIrcMsg) -> RawIrcMsg -> Parser RawIrcMsg
forall a b. (a -> b) -> a -> b
$! RawIrcMsg :: [TagEntry] -> Maybe UserInfo -> Text -> [Text] -> RawIrcMsg
RawIrcMsg
{ _msgTags :: [TagEntry]
_msgTags = [TagEntry]
tags
, _msgPrefix :: Maybe UserInfo
_msgPrefix = Maybe UserInfo
prefix
, _msgCommand :: Text
_msgCommand = Text
cmd
, _msgParams :: [Text]
_msgParams = [Text]
params
}
paramsParser ::
Int -> Parser [Text]
paramsParser :: Int -> Parser [Text]
paramsParser !Int
n =
do Bool
end <- Parser Text Bool
forall t. Chunk t => Parser t Bool
P.atEnd
if Bool
end
then [Text] -> Parser [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do Bool
isColon <- Char -> Parser Text Bool
optionalChar Char
':'
if Bool
isColon Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then Parser [Text]
finalParam
else Parser [Text]
middleParam
where
finalParam :: Parser [Text]
finalParam =
do Text
x <- Parser Text
takeText
let !x' :: Text
x' = Text -> Text
Text.copy Text
x
[Text] -> Parser [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text
x']
middleParam :: Parser [Text]
middleParam =
do Text
x <- Parser Text
simpleTokenParser
[Text]
xs <- Int -> Parser [Text]
paramsParser (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
[Text] -> Parser [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
xText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
xs)
tagsParser :: Parser [TagEntry]
tagsParser :: Parser Text [TagEntry]
tagsParser = Parser TagEntry
tagParser Parser TagEntry -> Parser Text Char -> Parser Text [TagEntry]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Char -> Parser Text Char
char Char
';' Parser Text [TagEntry] -> Parser Text () -> Parser Text [TagEntry]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
spaces
tagParser :: Parser TagEntry
tagParser :: Parser TagEntry
tagParser =
do Text
key <- (Char -> Bool) -> Parser Text
P.takeWhile (String -> Char -> Bool
notInClass String
"=; ")
Maybe Char
_ <- Parser Text Char -> Parser Text (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser Text Char
char Char
'=')
Text
val <- (Char -> Bool) -> Parser Text
P.takeWhile (String -> Char -> Bool
notInClass String
"; ")
TagEntry -> Parser TagEntry
forall (m :: * -> *) a. Monad m => a -> m a
return (TagEntry -> Parser TagEntry) -> TagEntry -> Parser TagEntry
forall a b. (a -> b) -> a -> b
$! Text -> Text -> TagEntry
TagEntry Text
key (Text -> Text
unescapeTagVal Text
val)
unescapeTagVal :: Text -> Text
unescapeTagVal :: Text -> Text
unescapeTagVal = String -> Text
Text.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
aux ShowS -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
where
aux :: ShowS
aux (Char
'\\':Char
':':String
xs) = Char
';'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
aux String
xs
aux (Char
'\\':Char
's':String
xs) = Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
aux String
xs
aux (Char
'\\':Char
'\\':String
xs) = Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
aux String
xs
aux (Char
'\\':Char
'r':String
xs) = Char
'\r'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
aux String
xs
aux (Char
'\\':Char
'n':String
xs) = Char
'\n'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
aux String
xs
aux (Char
x:String
xs) = Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
aux String
xs
aux String
"" = String
""
escapeTagVal :: Text -> Text
escapeTagVal :: Text -> Text
escapeTagVal = (Char -> Text) -> Text -> Text
Text.concatMap Char -> Text
aux
where
aux :: Char -> Text
aux Char
';' = Text
"\\:"
aux Char
' ' = Text
"\\s"
aux Char
'\\' = Text
"\\\\"
aux Char
'\r' = Text
"\\r"
aux Char
'\n' = Text
"\\n"
aux Char
x = Char -> Text
Text.singleton Char
x
prefixParser :: Parser UserInfo
prefixParser :: Parser UserInfo
prefixParser =
do Text
tok <- Parser Text
simpleTokenParser
UserInfo -> Parser UserInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (UserInfo -> Parser UserInfo) -> UserInfo -> Parser UserInfo
forall a b. (a -> b) -> a -> b
$! Text -> UserInfo
parseUserInfo Text
tok
simpleTokenParser :: Parser Text
simpleTokenParser :: Parser Text
simpleTokenParser =
do Text
xs <- (Char -> Bool) -> Parser Text
P.takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ')
Parser Text ()
spaces
Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$! Text -> Text
Text.copy Text
xs
spaces :: Parser ()
spaces :: Parser Text ()
spaces = (Char -> Bool) -> Parser Text ()
P.skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
renderRawIrcMsg :: RawIrcMsg -> ByteString
renderRawIrcMsg :: RawIrcMsg -> ByteString
renderRawIrcMsg !RawIrcMsg
m
= ByteString -> ByteString
L.toStrict
(ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toLazyByteString
(Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [TagEntry] -> Builder
renderTags ((([TagEntry] -> Const [TagEntry] [TagEntry])
-> RawIrcMsg -> Const [TagEntry] RawIrcMsg)
-> RawIrcMsg -> [TagEntry]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view ([TagEntry] -> Const [TagEntry] [TagEntry])
-> RawIrcMsg -> Const [TagEntry] RawIrcMsg
forall (f :: * -> *).
Functor f =>
([TagEntry] -> f [TagEntry]) -> RawIrcMsg -> f RawIrcMsg
msgTags RawIrcMsg
m)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> (UserInfo -> Builder) -> Maybe UserInfo -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty UserInfo -> Builder
renderPrefix (((Maybe UserInfo -> Const (Maybe UserInfo) (Maybe UserInfo))
-> RawIrcMsg -> Const (Maybe UserInfo) RawIrcMsg)
-> RawIrcMsg -> Maybe UserInfo
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view (Maybe UserInfo -> Const (Maybe UserInfo) (Maybe UserInfo))
-> RawIrcMsg -> Const (Maybe UserInfo) RawIrcMsg
forall (f :: * -> *).
Functor f =>
(Maybe UserInfo -> f (Maybe UserInfo)) -> RawIrcMsg -> f RawIrcMsg
msgPrefix RawIrcMsg
m)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder (((Text -> Const Text Text) -> RawIrcMsg -> Const Text RawIrcMsg)
-> RawIrcMsg -> Text
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view (Text -> Const Text Text) -> RawIrcMsg -> Const Text RawIrcMsg
forall (f :: * -> *).
Functor f =>
(Text -> f Text) -> RawIrcMsg -> f RawIrcMsg
msgCommand RawIrcMsg
m)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Builder
buildParams ((([Text] -> Const [Text] [Text])
-> RawIrcMsg -> Const [Text] RawIrcMsg)
-> RawIrcMsg -> [Text]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view ([Text] -> Const [Text] [Text])
-> RawIrcMsg -> Const [Text] RawIrcMsg
forall (f :: * -> *).
Functor f =>
([Text] -> f [Text]) -> RawIrcMsg -> f RawIrcMsg
msgParams RawIrcMsg
m)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
'\r'
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
'\n'
rawIrcMsg ::
Text ->
[Text] -> RawIrcMsg
rawIrcMsg :: Text -> [Text] -> RawIrcMsg
rawIrcMsg = [TagEntry] -> Maybe UserInfo -> Text -> [Text] -> RawIrcMsg
RawIrcMsg [] Maybe UserInfo
forall a. Maybe a
Nothing
renderTags :: [TagEntry] -> Builder
renderTags :: [TagEntry] -> Builder
renderTags [] = Builder
forall a. Monoid a => a
mempty
renderTags [TagEntry]
xs
= Char -> Builder
Builder.char8 Char
'@'
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (Char -> Builder
Builder.char8 Char
';') ((TagEntry -> Builder) -> [TagEntry] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map TagEntry -> Builder
renderTag [TagEntry]
xs))
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
' '
renderTag :: TagEntry -> Builder
renderTag :: TagEntry -> Builder
renderTag (TagEntry Text
key Text
val)
| Text -> Bool
Text.null Text
val = Text -> Builder
Text.encodeUtf8Builder Text
key
| Bool
otherwise = Text -> Builder
Text.encodeUtf8Builder Text
key
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
'='
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder (Text -> Text
escapeTagVal Text
val)
renderPrefix :: UserInfo -> Builder
renderPrefix :: UserInfo -> Builder
renderPrefix UserInfo
u
= Char -> Builder
Builder.char8 Char
':'
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder (UserInfo -> Text
renderUserInfo UserInfo
u)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
' '
buildParams :: [Text] -> Builder
buildParams :: [Text] -> Builder
buildParams [Text
x]
| Text
" " Text -> Text -> Bool
`Text.isInfixOf` Text
x Bool -> Bool -> Bool
|| Text
":" Text -> Text -> Bool
`Text.isPrefixOf` Text
x Bool -> Bool -> Bool
|| Text -> Bool
Text.null Text
x
= Char -> Builder
Builder.char8 Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
':' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder Text
x
buildParams (Text
x:[Text]
xs)
| Text -> Bool
Text.null Text
x = Char -> Builder
Builder.char8 Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder Text
"*" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Builder
buildParams [Text]
xs
| Bool
otherwise = Char -> Builder
Builder.char8 Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder Text
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Builder
buildParams [Text]
xs
buildParams [] = Builder
forall a. Monoid a => a
mempty
guarded :: Char -> Parser b -> Parser (Maybe b)
guarded :: Char -> Parser b -> Parser (Maybe b)
guarded Char
c Parser b
p =
do Bool
success <- Char -> Parser Text Bool
optionalChar Char
c
if Bool
success then b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b) -> Parser b -> Parser (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser b
p else Maybe b -> Parser (Maybe b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe b
forall a. Maybe a
Nothing
optionalChar :: Char -> Parser Bool
optionalChar :: Char -> Parser Text Bool
optionalChar Char
c = Bool
True Bool -> Parser Text Char -> Parser Text Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Text Char
char Char
c Parser Text Bool -> Parser Text Bool -> Parser Text Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Text Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
asUtf8 :: ByteString -> Text
asUtf8 :: ByteString -> Text
asUtf8 ByteString
x = case ByteString -> Either UnicodeException Text
Text.decodeUtf8' ByteString
x of
Right Text
txt -> Text
txt
Left{} -> ByteString -> Text
decodeCP1252 ByteString
x
decodeCP1252 :: ByteString -> Text
decodeCP1252 :: ByteString -> Text
decodeCP1252 ByteString
bs = String -> Text
Text.pack [ Vector Char
cp1252 Vector Char -> Int -> Char
forall a. Vector a -> Int -> a
Vector.! Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x | Word8
x <- ByteString -> [Word8]
B.unpack ByteString
bs ]
cp1252 :: Vector Char
cp1252 :: Vector Char
cp1252 = String -> Vector Char
forall a. [a] -> Vector a
Vector.fromList
(String -> Vector Char) -> String -> Vector Char
forall a b. (a -> b) -> a -> b
$ [Char
'\x00'..Char
'\x7f']
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"€\x81‚ƒ„…†‡ˆ‰Š‹Œ\x8dŽ\x8f\x90‘’“”•–—˜™š›œ\x9džŸ"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'\xa0'..Char
'\xff']