examples/Makefile
ghc-options: -fglasgow-exts -fwarn-missing-signatures -fwarn-unused-imports -funbox-strict-fields -O3
+
--Executable: HelloWorld
--Main-Is: HelloWorld.hs
--Hs-Source-Dirs: ., examples
---ghc-options: -threaded -fglasgow-exts -O3
+--ghc-options: -fglasgow-exts -O3 -prof -auto-all
major <- many1 digit
char '.'
minor <- many1 digit
- return $ HttpVersion (read major) (read minor)
+ return $ HttpVersion (read' major) (read' minor)
+ where
+ read' "1" = 1 -- この二つが
+ read' "0" = 0 -- 壓倒的に頻出する
+ read' s = read s
hPutHttpVersion :: Handle -> HttpVersion -> IO ()
( Parser
, ParserResult(..)
+ , failP
+
, parse
, parseStr
, notFollowedBy
, many
, many1
- , manyTill
- , many1Till
, count
, option
, sepBy
return x = x `seq` Parser $! return $! Success x
fail _ = Parser $! return $! IllegalInput
+-- |@'failP'@ is just a synonym for @'Prelude.fail Prelude.undefined'@.
+failP :: Parser a
+failP = fail undefined
+
-- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(result,
-- remaining)@.
parse :: Parser a -> ByteString -> (ParserResult a, ByteString)
if B.null input then
return ReachedEOF
else
- do let c = B.head input
- put (B.tail input, isEOFFatal)
- return (Success c)
+ do put (B.tail input, isEOFFatal)
+ return (Success $! B.head input)
eof :: Parser ()
satisfy :: (Char -> Bool) -> Parser Char
satisfy f = f `seq`
do c <- anyChar
- unless (f c) (fail "")
- return c
+ if f c then
+ return c
+ else
+ failP
char :: Char -> Parser Char
oneOf :: [Char] -> Parser Char
-oneOf = foldl (<|>) (fail "") . map char
+oneOf = foldl (<|>) failP . map char
notFollowedBy :: Parser a -> Parser ()
notFollowedBy p = p `seq`
- p >>= fail "" <|> return ()
+ (p >> failP) <|> return ()
digit :: Parser Char
if c >= '0' && c <= '9' then
return c
else
- fail ""
+ failP
hexDigit :: Parser Char
(c >= 'A' && c <= 'F') then
return c
else
- fail ""
+ failP
many :: Parser a -> Parser [a]
many1 :: Parser a -> Parser [a]
many1 p = p `seq`
- do ret <- many p
- case ret of
- [] -> fail ""
- xs -> return xs
-
-
-manyTill :: Parser a -> Parser end -> Parser [a]
-manyTill p end
- = p `seq` end `seq`
- many $! do x <- p
- end
- return x
-
-
-many1Till :: Parser a -> Parser end -> Parser [a]
-many1Till p end
- = p `seq` end `seq`
- many1 $! do x <- p
- end
- return x
+ do x <- p
+ xs <- many p
+ return (x:xs)
count :: Int -> Parser a -> Parser [a]
httpDateTime :: Parser ClockTime
-httpDateTime = do foldl (<|>) (fail "") (map string week)
+httpDateTime = do foldl (<|>) failP (map string week)
char ','
char ' '
day <- liftM read (count 2 digit)
char ' '
- mon <- foldl (<|>) (fail "") (map tryEqToFst (zip month [1..]))
+ mon <- foldl (<|>) failP (map tryEqToFst (zip month [1..]))
char ' '
year <- liftM read (count 4 digit)
char ' '
, ("TRACE" , TRACE )
, ("CONNECT", CONNECT)
]
- in foldl (<|>) (fail "") $ map (\ (str, mth)
+ in foldl (<|>) failP $ map (\ (str, mth)
-> string str >> return mth) methods)
<|>
token >>= return . ExtensionMethod
uriP :: Parser URI
uriP = do str <- many1 $ satisfy (\ c -> not (isCtl c || c == ' '))
case parseURIReference str of
- Nothing -> fail ""
+ Nothing -> failP
Just uri -> return uri
\ No newline at end of file
acceptRequest input
-- キューに最大パイプライン深度以上のリクエストが溜まってゐる
-- 時は、それが限度以下になるまで待つ。
- = do atomically $ do queue <- readTVar tQueue
+ = {-# SCC "acceptRequest" #-}
+ do atomically $ do queue <- readTVar tQueue
when (S.length queue >= cnfMaxPipelineDepth cnf)
retry
acceptNonparsableRequest :: StatusCode -> IO ()
acceptNonparsableRequest status
- = do itr <- newInteraction cnf addr Nothing
+ = {-# SCC "acceptNonparsableRequest" #-}
+ do itr <- newInteraction cnf addr Nothing
atomically $ do updateItr itr itrResponse
$ \ res -> res {
resStatus = status
acceptParsableRequest :: Request -> ByteString -> IO ()
acceptParsableRequest req input
- = do itr <- newInteraction cnf addr (Just req)
+ = {-# SCC "acceptParsableRequest" #-}
+ do itr <- newInteraction cnf addr (Just req)
action
<- atomically $
do preprocess itr
acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
acceptSemanticallyInvalidRequest itr input
- = do writeItr itr itrState Done
+ = {-# SCC "acceptSemanticallyInvalidRequest" #-}
+ do writeItr itr itrState Done
writeDefaultPage itr
postprocess itr
enqueue itr
acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
acceptRequestForNonexistentResource itr input
- = do updateItr itr itrResponse
+ = {-# SCC "acceptRequestForNonexistentResource" #-}
+ do updateItr itr itrResponse
$ \res -> res {
resStatus = NotFound
}
acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
- = do let itr = oldItr { itrResourcePath = Just rsrcPath }
+ = {-# SCC "acceptRequestForExistentResource" #-}
+ do let itr = oldItr { itrResourcePath = Just rsrcPath }
requestHasBody <- readItr itr itrRequestHasBody id
enqueue itr
return $ do runResource rsrcDef itr
observeRequest :: Interaction -> ByteString -> IO ()
observeRequest itr input
- = do isChunked <- atomically $ readItr itr itrRequestIsChunked id
+ = {-# SCC "observeRequest" #-}
+ do isChunked <- atomically $ readItr itr itrRequestIsChunked id
if isChunked then
observeChunkedRequest itr input
else
observeChunkedRequest :: Interaction -> ByteString -> IO ()
observeChunkedRequest itr input
- = do action
+ = {-# SCC "observeChunkedRequest" #-}
+ do action
<- atomically $
do isOver <- readItr itr itrReqChunkIsOver id
if isOver then
seekNextChunk :: Interaction -> ByteString -> STM (IO ())
seekNextChunk itr input
- = case parse chunkHeaderP input of
+ = {-# SCC "seekNextChunk" #-}
+ case parse chunkHeaderP input of
-- 最終チャンク (中身が空)
(Success 0, input')
-> case parse chunkTrailerP input' of
chunkWasMalformed :: Interaction -> IO ()
chunkWasMalformed itr
- = atomically $ do updateItr itr itrResponse
+ = {-# SCC "chunkWasMalformed" #-}
+ atomically $ do updateItr itr itrResponse
$ \ res -> res {
resStatus = BadRequest
}
observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
observeNonChunkedRequest itr input
- = do action
+ = {-# SCC "observeNonChunkedRequest" #-}
+ do action
<- atomically $
do wantedM <- readItr itr itrReqBodyWanted id
if wantedM == Nothing then
action
enqueue :: Interaction -> STM ()
- enqueue itr = do queue <- readTVar tQueue
+ enqueue itr = {-# SCC "enqueue" #-}
+ do queue <- readTVar tQueue
writeTVar tQueue (itr <| queue)
\ No newline at end of file
where
awaitSomethingToWrite :: IO ()
awaitSomethingToWrite
- = do action
+ = {-# SCC "awaitSomethingToWrite" #-}
+ do action
<- atomically $!
do -- キューが空でなくなるまで待つ
queue <- readTVar tQueue
writeContinueIfNecessary :: Interaction -> STM (IO ())
writeContinueIfNecessary itr
- = itr `seq`
+ = {-# SCC "writeContinueIfNecessary" #-}
+ itr `seq`
do expectedContinue <- readItr itr itrExpectedContinue id
if expectedContinue then
do wroteContinue <- readItr itr itrWroteContinue id
-- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
-- 空でなければ、それを出力する。空である時は、もし状態が
-- Done であれば後処理をする。
- = itr `seq`
+ = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
+ itr `seq`
do wroteHeader <- readItr itr itrWroteHeader id
if not wroteHeader then
- return $ writeHeader itr
+ return $! writeHeader itr
else
do bodyToSend <- readItr itr itrBodyToSend id
writeContinue :: Interaction -> IO ()
writeContinue itr
- = itr `seq`
+ = {-# SCC "writeContinue" #-}
+ itr `seq`
do let cont = Response {
resVersion = HttpVersion 1 1
, resStatus = Continue
writeHeader :: Interaction -> IO ()
writeHeader itr
- = itr `seq`
+ = {-# SCC "writeHeader" #-}
+ itr `seq`
do res <- atomically $! do writeItr itr itrWroteHeader True
readItr itr itrResponse id
hPutResponse h res
writeBodyChunk :: Interaction -> IO ()
writeBodyChunk itr
- = itr `seq`
+ = {-# SCC "writeBodyChunk" #-}
+ itr `seq`
do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
willChunkBody <- atomically $! readItr itr itrWillChunkBody id
chunk <- atomically $! do chunk <- readItr itr itrBodyToSend id
finishBodyChunk :: Interaction -> IO ()
finishBodyChunk itr
- = itr `seq`
+ = {-# SCC "finishBodyChunk" #-}
+ itr `seq`
do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
willChunkBody <- atomically $! readItr itr itrWillChunkBody id
when (not willDiscardBody && willChunkBody)
finalize :: Interaction -> IO ()
finalize itr
- = itr `seq`
+ = {-# SCC "finalize" #-}
+ itr `seq`
do finishBodyChunk itr
willClose <- atomically $!
do queue <- readTVar tQueue
projects / Lucu.git / commitdiff