{-# LANGUAGE CPP,NoMonomorphismRestriction, FlexibleContexts #-}
-- | Filter for compressing the 'Response' body.
module Happstack.Server.Internal.Compression
    ( compressedResponseFilter
    , compressedResponseFilter'
    , compressWithFilter
    , gzipFilter
    , deflateFilter
    , identityFilter
    , starFilter
    , encodings
    , standardEncodingHandlers
    ) where
import Happstack.Server.SimpleHTTP
import Text.ParserCombinators.Parsec
import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
#endif
import Data.Maybe
import Data.List
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Codec.Compression.GZip as GZ
import qualified Codec.Compression.Zlib as Z

-- | reads the @Accept-Encoding@ header.  Then, if possible
-- will compress the response body with methods @gzip@ or @deflate@.
--
-- This function uses 'standardEncodingHandlers'. If you want to
-- provide alternative handers (perhaps to change compression levels),
-- see 'compressedResponseFilter''
--
-- > main =
-- >   simpleHTTP nullConf $
-- >      do str <- compressedResponseFilter
-- >         return $ toResponse ("This response compressed using: " ++ str)
compressedResponseFilter :: (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m, MonadFail m) =>
                            m String -- ^ name of the encoding chosen
compressedResponseFilter :: forall (m :: * -> *).
(FilterMonad Response m, MonadPlus m, WebMonad Response m,
 ServerMonad m, MonadFail m) =>
m String
compressedResponseFilter = forall (m :: * -> *).
(FilterMonad Response m, MonadPlus m, WebMonad Response m,
 ServerMonad m, MonadFail m) =>
[(String, String -> Bool -> m ())] -> m String
compressedResponseFilter' forall (m :: * -> *).
(FilterMonad Response m, MonadFail m) =>
[(String, String -> Bool -> m ())]
standardEncodingHandlers

-- | reads the @Accept-Encoding@ header.  Then, if possible
-- will compress the response body using one of the supplied filters.
--
-- A filter function takes two arguments. The first is a 'String' with
-- the value to be used as the 'Content-Encoding' header. The second
-- is 'Bool' which indicates if the compression filter is allowed to
-- fallback to @identity@.
--
-- This is important if the resource being sent using sendfile, since
-- sendfile does not provide a compression option. If @identity@ is
-- allowed, then the file can be sent uncompressed using sendfile. But
-- if @identity@ is not allowed, then the filter will need to return
-- error 406.
--
-- You should probably always include the @identity@ and @*@ encodings
-- as acceptable.
--
-- > myFilters :: (FilterMonad Response m) => [(String, String -> Bool -> m ()]
-- > myFilters = [ ("gzip"    , gzipFilter)
-- >             , ("identity", identityFilter)
-- >             , ("*"       , starFilter)
-- >             ]
-- >
-- > main =
-- >   simpleHTTP nullConf $
-- >      do let filters =
-- > str <- compressedResponseFilter'
-- >         return $ toResponse ("This response compressed using: " ++ str)
compressedResponseFilter' ::
    (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m, MonadFail m)
    => [(String, String -> Bool -> m ())]  -- ^ compression filter assoc list
    -> m String                            -- ^ name of the encoding chosen
compressedResponseFilter' :: forall (m :: * -> *).
(FilterMonad Response m, MonadPlus m, WebMonad Response m,
 ServerMonad m, MonadFail m) =>
[(String, String -> Bool -> m ())] -> m String
compressedResponseFilter' [(String, String -> Bool -> m ())]
encodingHandlers = do
    forall (m :: * -> *).
ServerMonad m =>
String -> m (Maybe ByteString)
getHeaderM String
"Accept-Encoding" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return String
"identity") ByteString -> m String
installHandler)

  where
    badEncoding :: String
badEncoding = String
"Encoding returned not in the list of known encodings"

    installHandler :: ByteString -> m String
installHandler ByteString
accept = do
      let eEncoding :: Either String [String]
eEncoding = [String] -> String -> Either String [String]
bestEncoding (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, String -> Bool -> m ())]
encodingHandlers) forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS.unpack ByteString
accept
      (String
coding, Bool
identityAllowed, String -> Bool -> m ()
action) <- case Either String [String]
eEncoding of
          Left String
_ -> do
            forall (m :: * -> *). FilterMonad Response m => Int -> m ()
setResponseCode Int
406
            forall a (m :: * -> *) b. WebMonad a m => a -> m b
finishWith forall a b. (a -> b) -> a -> b
$ forall a. ToMessage a => a -> Response
toResponse String
""

          Right encs :: [String]
encs@(String
a:[String]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return (String
a
                                     , String
"identity" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
encs
                                     , forall a. a -> Maybe a -> a
fromMaybe (\ String
_ Bool
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
badEncoding)
                                          (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
a [(String, String -> Bool -> m ())]
encodingHandlers)
                                     )
          Right [] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
badEncoding
      String -> Bool -> m ()
action String
coding Bool
identityAllowed
      forall (m :: * -> *) a. Monad m => a -> m a
return String
coding

-- | Ignore the @Accept-Encoding@ header in the 'Request' and attempt to compress the body of the response with @gzip@.
--
-- calls 'compressWithFilter' using 'GZ.compress'.
--
-- see also: 'compressedResponseFilter'
gzipFilter::(FilterMonad Response m) =>
            String -- ^ encoding to use for Content-Encoding header
          -> Bool   -- ^ fallback to identity for SendFile
          -> m ()
gzipFilter :: forall (m :: * -> *).
FilterMonad Response m =>
String -> Bool -> m ()
gzipFilter = forall (m :: * -> *).
FilterMonad Response m =>
(ByteString -> ByteString) -> String -> Bool -> m ()
compressWithFilter ByteString -> ByteString
GZ.compress

-- | Ignore the @Accept-Encoding@ header in the 'Request' and attempt compress the body of the response with zlib's
-- @deflate@ method
--
-- calls 'compressWithFilter' using 'Z.compress'.
--
-- see also: 'compressedResponseFilter'
deflateFilter::(FilterMonad Response m) =>
               String -- ^ encoding to use for Content-Encoding header
             -> Bool   -- ^ fallback to identity for SendFile
             -> m ()
deflateFilter :: forall (m :: * -> *).
FilterMonad Response m =>
String -> Bool -> m ()
deflateFilter = forall (m :: * -> *).
FilterMonad Response m =>
(ByteString -> ByteString) -> String -> Bool -> m ()
compressWithFilter ByteString -> ByteString
Z.compress

-- | compression filter for the identity encoding (aka, do nothing)
--
-- see also: 'compressedResponseFilter'
identityFilter :: (FilterMonad Response m) =>
                  String  -- ^ encoding to use for Content-Encoding header
               -> Bool    -- ^ fallback to identity for SendFile (irrelavant for this filter)
               -> m ()
identityFilter :: forall (m :: * -> *).
FilterMonad Response m =>
String -> Bool -> m ()
identityFilter = forall (m :: * -> *).
FilterMonad Response m =>
(ByteString -> ByteString) -> String -> Bool -> m ()
compressWithFilter forall a. a -> a
id

-- | compression filter for the * encoding
--
-- This filter always fails.
starFilter :: (FilterMonad Response m, MonadFail m) =>
              String  -- ^ encoding to use for Content-Encoding header
           -> Bool    -- ^ fallback to identity for SendFile (irrelavant for this filter)
           -> m ()
starFilter :: forall (m :: * -> *).
(FilterMonad Response m, MonadFail m) =>
String -> Bool -> m ()
starFilter String
_ Bool
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"chose * as content encoding"

-- | Ignore the @Accept-Encoding@ header in the 'Request' and attempt to compress the body of the response using the supplied compressor.
--
-- We can not compress files being transfered using 'SendFile'. If
-- @identity@ is an allowed encoding, then just return the 'Response'
-- unmodified. Otherwise we return @406 Not Acceptable@.
--
-- see also: 'gzipFilter', 'deflateFilter', 'identityFilter', 'starFilter', 'compressedResponseFilter''
compressWithFilter :: (FilterMonad Response m) =>
                      (L.ByteString -> L.ByteString) -- ^ function to compress the body
                   -> String -- ^ encoding to use for Content-Encoding header
                   -> Bool   -- ^ fallback to identity for SendFile
                   -> m ()
compressWithFilter :: forall (m :: * -> *).
FilterMonad Response m =>
(ByteString -> ByteString) -> String -> Bool -> m ()
compressWithFilter ByteString -> ByteString
compressor String
encoding Bool
identityAllowed =
    forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter forall a b. (a -> b) -> a -> b
$ \Response
r ->
        case Response
r of
          Response{} -> forall r. HasHeaders r => String -> String -> r -> r
setHeader String
"Content-Encoding" String
encoding          forall a b. (a -> b) -> a -> b
$
                        forall r. HasHeaders r => String -> String -> r -> r
setHeader String
"Vary"             String
"Accept-Encoding" forall a b. (a -> b) -> a -> b
$
                         Response
r {rsBody :: ByteString
rsBody = ByteString -> ByteString
compressor forall a b. (a -> b) -> a -> b
$ Response -> ByteString
rsBody Response
r}
          Response
_ | Bool
identityAllowed -> Response
r
            | Bool
otherwise       -> (forall a. ToMessage a => a -> Response
toResponse String
"") { rsCode :: Int
rsCode = Int
406 }

-- | based on the rules describe in rfc2616 sec. 14.3
bestEncoding :: [String] -> String -> Either String [String]
bestEncoding :: [String] -> String -> Either String [String]
bestEncoding [String]
availableEncodings String
encs = do
        [(String, Maybe Double)]
encList<-forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) (forall a b. b -> Either a b
Right) forall a b. (a -> b) -> a -> b
$ forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse forall st. GenParser Char st [(String, Maybe Double)]
encodings String
"" String
encs
        case [(String, Maybe Double)] -> [String]
acceptable [(String, Maybe Double)]
encList of
            [] -> forall a b. a -> Either a b
Left String
"no encoding found"
            [String]
a -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [String]
a
    where
        -- first intersect with the list of encodings we know how to deal with at all
        knownEncodings:: [(String,Maybe Double)] -> [(String, Maybe Double)]
        knownEncodings :: [(String, Maybe Double)] -> [(String, Maybe Double)]
knownEncodings [(String, Maybe Double)]
m = forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
intersectBy (\(String, Maybe Double)
x (String, Maybe Double)
y->forall a b. (a, b) -> a
fst (String, Maybe Double)
x forall a. Eq a => a -> a -> Bool
== forall a b. (a, b) -> a
fst (String, Maybe Double)
y) [(String, Maybe Double)]
m (forall a b. (a -> b) -> [a] -> [b]
map (\String
x -> (String
x,forall a. Maybe a
Nothing)) [String]
availableEncodings)
        -- this expands the wildcard, by figuring out if we need to include "identity" in the list
        -- Then it deletes the wildcard entry, drops all the "q=0" entries (which aren't allowed).
        --
        -- note this implementation is a little conservative.  if someone were to specify "*"
        -- without a "q" value, it would be this server is willing to accept any format at all.
        -- We pretty much assume we can't send them /any/ format and that they really
        -- meant just "identity" this seems safe to me.
        knownEncodings':: [(String,Maybe Double)] -> [(String, Maybe Double)]
        knownEncodings' :: [(String, Maybe Double)] -> [(String, Maybe Double)]
knownEncodings' [(String, Maybe Double)]
m = forall a. (a -> Bool) -> [a] -> [a]
filter forall {a} {a}. (Eq a, Num a) => (a, Maybe a) -> Bool
dropZero forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Bool) -> a -> [a] -> [a]
deleteBy (\(String
a,Maybe Double
_) (String
b,Maybe Double
_)->String
aforall a. Eq a => a -> a -> Bool
==String
b) (String
"*",forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$
            case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"*" ([(String, Maybe Double)] -> [(String, Maybe Double)]
knownEncodings [(String, Maybe Double)]
m) of
                Maybe (Maybe Double)
Nothing -> [(String, Maybe Double)] -> [(String, Maybe Double)]
addIdent forall a b. (a -> b) -> a -> b
$ [(String, Maybe Double)] -> [(String, Maybe Double)]
knownEncodings [(String, Maybe Double)]
m
                Just (Just Double
a) | Double
aforall a. Ord a => a -> a -> Bool
>Double
0 -> [(String, Maybe Double)] -> [(String, Maybe Double)]
addIdent forall a b. (a -> b) -> a -> b
$ [(String, Maybe Double)] -> [(String, Maybe Double)]
knownEncodings [(String, Maybe Double)]
m
                              | Bool
otherwise -> [(String, Maybe Double)] -> [(String, Maybe Double)]
knownEncodings [(String, Maybe Double)]
m
                Just (Maybe Double
Nothing) -> [(String, Maybe Double)] -> [(String, Maybe Double)]
addIdent forall a b. (a -> b) -> a -> b
$ [(String, Maybe Double)] -> [(String, Maybe Double)]
knownEncodings [(String, Maybe Double)]
m
        dropZero :: (a, Maybe a) -> Bool
dropZero (a
_, Just a
a) | a
aforall a. Eq a => a -> a -> Bool
==a
0      = Bool
False
                             | Bool
otherwise = Bool
True
        dropZero (a
_, Maybe a
Nothing) = Bool
True
        addIdent:: [(String,Maybe Double)] -> [(String, Maybe Double)]
        addIdent :: [(String, Maybe Double)] -> [(String, Maybe Double)]
addIdent [(String, Maybe Double)]
m = if forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"identity" [(String, Maybe Double)]
m
            then [(String, Maybe Double)]
m forall a. [a] -> [a] -> [a]
++ [(String
"identity",forall a. Maybe a
Nothing)]
            else [(String, Maybe Double)]
m
        -- finally we sort the list of available encodings.
        acceptable:: [(String,Maybe Double)] -> [String]
        acceptable :: [(String, Maybe Double)] -> [String]
acceptable [(String, Maybe Double)]
l = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip (String, Maybe Double) -> (String, Maybe Double) -> Ordering
cmp) forall a b. (a -> b) -> a -> b
$  [(String, Maybe Double)] -> [(String, Maybe Double)]
knownEncodings'  [(String, Maybe Double)]
l
        -- let the client choose but break ties with gzip
        encOrder :: [(String, b)]
encOrder = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [a]
reverse [String]
availableEncodings) [b
1..]
        m0 :: Maybe Double -> Double
m0 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Double
0.0::Double) forall a. a -> a
id
        cmp :: (String, Maybe Double) -> (String, Maybe Double) -> Ordering
cmp (String
s,Maybe Double
mI) (String
t,Maybe Double
mJ) | Maybe Double -> Double
m0 Maybe Double
mI forall a. Eq a => a -> a -> Bool
== Maybe Double -> Double
m0 Maybe Double
mJ
            = forall a. Ord a => a -> a -> Ordering
compare (Maybe Double -> Double
m0 forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s forall {b}. (Num b, Enum b) => [(String, b)]
encOrder) (Maybe Double -> Double
m0 forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
t forall {b}. (Num b, Enum b) => [(String, b)]
encOrder)
                          | Bool
otherwise = forall a. Ord a => a -> a -> Ordering
compare (Maybe Double -> Double
m0 Maybe Double
mI) (Maybe Double -> Double
m0 Maybe Double
mJ)


-- | an assoc list of encodings and their corresponding compression
-- functions.
--
-- e.g.
--
-- > [("gzip", gzipFilter), ("identity", identityFilter), ("*",starFilter)]
standardEncodingHandlers :: (FilterMonad Response m, MonadFail m) =>
                            [(String, String -> Bool -> m ())]
standardEncodingHandlers :: forall (m :: * -> *).
(FilterMonad Response m, MonadFail m) =>
[(String, String -> Bool -> m ())]
standardEncodingHandlers = forall a b. [a] -> [b] -> [(a, b)]
zip [String]
standardEncodings forall (m :: * -> *).
(FilterMonad Response m, MonadFail m) =>
[String -> Bool -> m ()]
handlers

standardEncodings :: [String]
standardEncodings :: [String]
standardEncodings =
    [String
"gzip"
    ,String
"x-gzip"
--    ,"compress" -- as far as I can tell there is no haskell library that supports this
--    ,"x-compress" -- as far as I can tell, there is no haskell library that supports this
    ,String
"deflate"
    ,String
"identity"
    ,String
"*"
    ]

handlers::(FilterMonad Response m, MonadFail m) => [String -> Bool -> m ()]
handlers :: forall (m :: * -> *).
(FilterMonad Response m, MonadFail m) =>
[String -> Bool -> m ()]
handlers =
    [ forall (m :: * -> *).
FilterMonad Response m =>
String -> Bool -> m ()
gzipFilter
    , forall (m :: * -> *).
FilterMonad Response m =>
String -> Bool -> m ()
gzipFilter
--    ,compressFilter
--    ,compressFilter
    , forall (m :: * -> *).
FilterMonad Response m =>
String -> Bool -> m ()
deflateFilter
    , forall (m :: * -> *).
FilterMonad Response m =>
String -> Bool -> m ()
identityFilter
    , forall (m :: * -> *).
(FilterMonad Response m, MonadFail m) =>
String -> Bool -> m ()
starFilter
    ]

-- | a parser for the Accept-Encoding header
encodings :: GenParser Char st [(String, Maybe Double)]
encodings :: forall st. GenParser Char st [(String, Maybe Double)]
encodings = forall st. GenParser Char st ()
ws forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (forall st. GenParser Char st (String, Maybe Double)
encoding1 forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy` forall tok st a. GenParser tok st a -> GenParser tok st a
try forall st. GenParser Char st ()
sep) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\[(String, Maybe Double)]
x -> forall st. GenParser Char st ()
ws forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [(String, Maybe Double)]
x)
    where
        ws :: GenParser Char st ()
        ws :: forall st. GenParser Char st ()
ws = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()

        sep :: GenParser Char st ()
        sep :: forall st. GenParser Char st ()
sep = do
            forall st. GenParser Char st ()
ws
            Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
','
            forall st. GenParser Char st ()
ws

        encoding1 :: GenParser Char st ([Char], Maybe Double)
        encoding1 :: forall st. GenParser Char st (String, Maybe Double)
encoding1 = do
            String
encoding <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-') forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"*"
            forall st. GenParser Char st ()
ws
            Maybe String
quality<-forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe forall st. GenParser Char st String
qual
            forall (m :: * -> *) a. Monad m => a -> m a
return (String
encoding, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Read a => String -> a
read Maybe String
quality)

        qual :: GenParser Char st String
        qual :: forall st. GenParser Char st String
qual = do
            forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
';' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall st. GenParser Char st ()
ws forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'q' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall st. GenParser Char st ()
ws forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'=' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall st. GenParser Char st ()
ws
            String
q<-forall st. GenParser Char st String
float
            forall (m :: * -> *) a. Monad m => a -> m a
return String
q

        int :: GenParser Char st String
        int :: forall st. GenParser Char st String
int = forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit

        float :: GenParser Char st String
        float :: forall st. GenParser Char st String
float = do
                String
wholePart<-forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
                String
fractionalPart<-forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option String
"" forall st. GenParser Char st String
fraction
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
wholePart forall a. [a] -> [a] -> [a]
++ String
fractionalPart
            forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
                do
                String
fractionalPart<-forall st. GenParser Char st String
fraction
                forall (m :: * -> *) a. Monad m => a -> m a
return String
fractionalPart
        fraction :: GenParser Char st String
        fraction :: forall st. GenParser Char st String
fraction = do
            Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.'
            String
fractionalPart<-forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option String
"" forall st. GenParser Char st String
int
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Char
'.'forall a. a -> [a] -> [a]
:String
fractionalPart