diff options
Diffstat (limited to 'testsuite/tests/perf/compiler/T17516.hs')
| -rw-r--r-- | testsuite/tests/perf/compiler/T17516.hs | 334 |
1 files changed, 334 insertions, 0 deletions
diff --git a/testsuite/tests/perf/compiler/T17516.hs b/testsuite/tests/perf/compiler/T17516.hs new file mode 100644 index 0000000000..ae5a4ef6a4 --- /dev/null +++ b/testsuite/tests/perf/compiler/T17516.hs @@ -0,0 +1,334 @@ +-- Reduced from Codec.MIME.String.Headers from mime-string-0.5 +module T17516 (get_addr_spec, get_to) where + +import Prelude hiding ( (<*>), (<$>), (<*), (<$) ) +import Data.Char +import Data.List (intersperse) + +import T17516A + +----------------------- +-- Utils + +ignore :: Parser inp a -> Parser inp () +ignore p = () <$ p + +boxp :: Parser inp a -> Parser inp [a] +boxp p = box <$> p + +----------------------- +-- RFC 2234 + +p_CTL :: Parser Char Char +p_CTL = pPred (\c -> ord c < 32 || ord c == 127) + +p_SP :: Parser Char Char +p_SP = pChar ' ' + +p_HTAB :: Parser Char Char +p_HTAB = pChar '\t' + +p_WSP :: Parser Char Char +p_WSP = p_SP <|> p_HTAB + +----------------------- +-- RFC 2822 + +p_NO_WS_CTL :: Parser Char Char +p_NO_WS_CTL = pPred (\c -> let o = ord c in 1 <= o && o <= 8 + || o == 11 + || o == 12 + || 14 <= o && o <= 31 + || o == 127) + +-- If we follow the spec precisely then we get pMany (pMany), and hence +-- non-termination, so we merge the definition of p_obs_text in. +p_text :: Parser Char String +p_text = concat + <$> pMany ( + p_encoded_words + <| boxp (pPred (\c -> let o = ord c in 0 <= o && o <= 9 + || o == 11 + || o == 12 + || 14 <= o && o <= 127)) + ) + +-- We are lax about checking they have any necessary surrounding +-- whitespace +p_encoded_words :: Parser Char String +p_encoded_words = (\x xs -> x ++ concat xs) + <$> p_encoded_word + <*> pMany (id <$ cws <*> p_encoded_word) + +-- XXX What happens if iconv doesn't understand the charset "cs"? +p_encoded_word :: Parser Char String +p_encoded_word = (\_ dec text -> dec text) + <$ pString "=?" + <*> p_charset + <* pChar '?' + <*> p_encoding + <* pChar '?' + <*> p_encoded_text + <* pString "?=" + +-- token definition inlined as they use a different one to p_token. +p_charset :: Parser Char String +p_charset = pAtLeast 1 (pPred isAscii <!> (p_SP <|> p_CTL <|> p_especials)) + +p_especials :: Parser Char Char +p_especials = pPred (`elem` "()<>@,;:\\\"/[]?.=") + +-- This is much stricter than specified, but if it's not [qQbB] then +-- we'd want to fall back to showing it as a string anyway. +p_encoding :: Parser Char (String -> String) +p_encoding = id <$ (pChar 'Q' <|> pChar 'q') + <|> id <$ (pChar 'B' <|> pChar 'b') + +p_encoded_text :: Parser Char String +p_encoded_text = pMany (pPred (\c -> isAsciiPrint c && c /= '?' && c /= ' ')) + +p_quoted_pair :: Parser Char String +p_quoted_pair = id <$ pChar '\\' <*> p_text <|> boxp p_obs_qp + +p_obs_qp :: Parser Char Char +p_obs_qp = id <$ pChar '\\' <*> pPred isAscii + +-- Done differently as the newlines are already gone +p_FWS :: Parser Char String +p_FWS = pMany p_WSP + +p_ctext :: Parser Char Char +p_ctext = p_NO_WS_CTL + <|> pPred (\c -> let o = ord c in 33 <= o && o <= 39 + || 42 <= o && o <= 91 + || 93 <= o && o <= 126) + +p_ccontent :: Parser Char () +p_ccontent = ignore p_ctext <|> ignore p_quoted_pair <|> p_comment + +p_comment :: Parser Char () +p_comment = () + <$ pChar '(' + <* pMany (() <$ pMany p_NO_WS_CTL <* p_ccontent) + <* pMany p_NO_WS_CTL + <* pChar ')' + +-- We might want to keep the result. If we do then we also need to +-- handle encoded words properly. +-- This isn't quite CFWS as we need to be able to accept "1.0" +-- as a MIME version with cws between all the characters. +-- Also, we've already removed all the newlines in the headers. +cws :: Parser Char () +cws = ignore $ pMany (ignore (pAtLeast 1 p_WSP) <|> p_comment) + +p_qtext :: Parser Char Char +p_qtext = p_NO_WS_CTL + <|> pPred (\c -> let o = ord c in o == 33 + || 35 <= o && o <= 91 + || 93 <= o && o <= 126) + +p_qcontent :: Parser Char String +p_qcontent = boxp p_qtext + <|> p_quoted_pair + +p_quoted_string :: Parser Char String +p_quoted_string = (++) + <$ cws + <* pChar '"' + <*> (concat <$> pMany ((++) <$> pOptDef "" p_FWS <*> p_qcontent)) + <*> pOptDef "" p_FWS + <* pChar '"' + +p_dcontent :: Parser Char String +p_dcontent = boxp p_dtext <|> p_quoted_pair + +p_dtext :: Parser Char Char +p_dtext = p_NO_WS_CTL + <|> pPred (\c -> let o = ord c in 33 <= o && o <= 90 + || 94 <= o && o <= 126) + +p_atom :: Parser Char String +p_atom = id + <$ cws + <*> pAtLeast 1 p_atext + <* cws + +p_atext :: Parser Char Char +p_atext = pPred (\c -> isAsciiAlphaNum c || c `elem` "!#$%&'+-/=?^_`{|}~") + +p_dot_atom :: Parser Char String +p_dot_atom = id + <$ cws + <*> p_dot_atom_text + <* cws + +p_word :: Parser Char String +p_word = p_atom <|> p_quoted_string + +-- This incorporates obs-phrase +p_phrase :: Parser Char [String] +p_phrase = (:) + <$> (p_encoded_words <| p_word) + <*> pMany (id <$ cws <*> (p_encoded_words <| p_word <| pString ".")) + <|> boxp p_quoted_string + +p_dot_atom_text :: Parser Char String +p_dot_atom_text = (\x xs -> x ++ concat xs) + <$> pAtLeast 1 p_atext + <*> pMany ((:) <$> pChar '.' <*> pAtLeast 1 p_atext) + +p_local_part :: Parser Char String +p_local_part = p_dot_atom <|> p_quoted_string <|> p_obs_local_part + +p_obs_local_part :: Parser Char String +p_obs_local_part = (\x xs -> x ++ concat xs) + <$> p_word + <*> pMany ((:) <$> pChar '.' <*> p_word) + +p_domain :: Parser Char Domain +p_domain = Domain <$> p_dot_atom <|> p_domain_literal <|> p_obs_domain + +p_domain_literal :: Parser Char Domain +p_domain_literal = (LiteralDomain . concat) + <$ cws + <* pChar '[' + <*> pMany ( id + <$ p_FWS + <*> p_dcontent) + <* p_FWS + <* pChar ']' + <* cws + +p_obs_domain :: Parser Char Domain +p_obs_domain = (\x xs -> Domain (x ++ concat xs)) + <$> p_atom + <*> pMany ((:) <$> pChar '.' <*> p_atom) + +data Domain = Domain String | LiteralDomain String + deriving (Show, Read, Eq) + +newtype To = To [Address] + deriving (Show, Read) + +data Address = Address Mailbox + | Group String [Mailbox] + deriving (Show, Read) + +get_to :: String -> Maybe To +get_to xs + = case parse ph_to xs of + Left t -> Just t + Right _ -> Nothing + +ph_to :: Parser Char To +ph_to = To <$ cws <*> p_address_list <* cws <* pEOI + +-- obs-addr-list merged in +p_address_list :: Parser Char [Address] +p_address_list = (:) + <$ pMany (() <$ pChar ',' <* cws) + <*> p_address + <*> pMany ( id + <$ pAtLeast 1 (() <$ cws <* pChar ',') + <* cws + <*> p_address) + <* pMany (() <$ cws <* pChar ',') + +p_address :: Parser Char Address +p_address = Address <$> p_mailbox + <|> p_group + +p_group :: Parser Char Address +p_group = Group + <$> p_display_name + <* cws + <* pChar ':' + <* cws + <*> pOptDef [] p_mailbox_list + <* cws + <* pChar ';' + +-- obs-mbox-list merged in +p_mailbox_list :: Parser Char [Mailbox] +p_mailbox_list = (:) + <$ pMany (() <$ pChar ',' <* cws) + <*> p_mailbox + <*> pMany ( id + <$ pAtLeast 1 (() <$ cws <* pChar ',') + <* cws + <*> p_mailbox) + <* pMany (() <$ cws <* pChar ',') + +data Mailbox = Mailbox (Maybe String) RoutedEmailAddress + deriving (Show, Read, Eq) + +p_mailbox :: Parser Char Mailbox +p_mailbox = p_name_addr + <|> (Mailbox Nothing . NormalEmailAddress) <$> p_addr_spec + +p_name_addr :: Parser Char Mailbox +p_name_addr = Mailbox + <$> pMaybe p_display_name + <* cws + <*> p_angle_addr + +data EmailAddress = EmailAddress String Domain + deriving (Show, Read, Eq) + +data RoutedEmailAddress = NormalEmailAddress EmailAddress + | RoutedEmailAddress [Domain] EmailAddress + deriving (Show, Read, Eq) + +p_angle_addr :: Parser Char RoutedEmailAddress +p_angle_addr = ($) + <$ pChar '<' + <* cws + -- This next makes us also satisfy obs-angle-addr + <*> pOptDef NormalEmailAddress + (RoutedEmailAddress <$> p_obs_route <* cws) + <*> p_addr_spec + <* cws + <* pChar '>' + +get_addr_spec :: String -> Maybe EmailAddress +get_addr_spec xs + = case parse p_addr_spec xs of + Left e -> Just e + Right _ -> Nothing + +p_addr_spec :: Parser Char EmailAddress +p_addr_spec = EmailAddress + <$> p_local_part + <* cws + <* pChar '@' + <* cws + <*> p_domain + +p_display_name :: Parser Char String +p_display_name = (concat . intersperse " ") <$> p_phrase + +p_obs_route :: Parser Char [Domain] +p_obs_route = id <$> p_obs_domain_list <* pChar ':' + +p_obs_domain_list :: Parser Char [Domain] +p_obs_domain_list = (:) + <$ pChar '@' + <* cws + <*> p_domain + <*> pMany ( id + <$ pMaybe (() <$ cws <* pChar ',') + <* cws + <* pChar '@' + <* cws + <*> p_domain) + +-- Utils + +isAsciiPrint :: Char -> Bool +isAsciiPrint c = isAscii c && isPrint c + +isAsciiAlphaNum :: Char -> Bool +isAsciiAlphaNum c = isAscii c && isAlphaNum c + +box :: a -> [a] +box x = [x] |