Compiling tagsoup with optimizations loops infinitely on HEAD
Compiling the tagsoup-0.14.8 library on GHC HEAD (commit ad44b504) causes an infinite loop (or possibly just exponential compile times). Here is a standalone version of the module from tagsoup that blows up compile times:
{-# LANGUAGE RecordWildCards, PatternGuards #-}
module Text.HTML.TagSoup.Specification(dat) where
-- Code taken from the tagsoup library, which is BSD-3-licensed.
import Data.Char (isAlpha, isAlphaNum, isDigit, toLower)
-- We make some generalisations:
-- <!name is a valid tag start closed by >
-- <?name is a valid tag start closed by ?>
-- </!name> is a valid closing tag
-- </?name> is a valid closing tag
-- <a "foo"> is a valid tag attibute in ! and ?, i.e missing an attribute name
-- We also don't do lowercase conversion
-- Entities are handled without a list of known entity names
-- We don't have RCData, CData or Escape modes (only effects dat and tagOpen)
data TypeTag = TypeNormal -- <foo
| TypeXml -- <?foo
| TypeDecl -- <!foo
| TypeScript -- <script
deriving Eq
-- 2.4.1 Common parser idioms
white x = x `elem` " \t\n\f\r"
-- 8.2.4 Tokenization
type Parser = S -> [Out]
-- 8.2.4.1 Data state
dat :: Parser
dat S{..} = pos $ case hd of
'&' -> charReference tl
'<' -> tagOpen tl
_ | eof -> []
_ -> hd & dat tl
-- 8.2.4.2 Character reference data state
charReference s = charRef dat False Nothing s
-- 8.2.4.3 Tag open state
tagOpen S{..} = case hd of
'!' -> markupDeclOpen tl
'/' -> closeTagOpen tl
_ | isAlpha hd -> Tag & hd & tagName (if isScript s then TypeScript else TypeNormal) tl
'>' -> errSeen "<>" & '<' & '>' & dat tl
'?' -> neilXmlTagOpen tl -- NEIL
_ -> errSeen "<" & '<' & dat s
isScript = f "script"
where
f (c:cs) S{..} = toLower hd == c && f cs tl
f [] S{..} = white hd || hd == '/' || hd == '>' || hd == '?' || eof
-- seen "<?", emitted []
neilXmlTagOpen S{..} = case hd of
_ | isAlpha hd -> Tag & '?' & hd & tagName TypeXml tl
_ -> errSeen "<?" & '<' & '?' & dat s
-- seen "?", expecting ">"
neilXmlTagClose S{..} = pos $ case hd of
'>' -> TagEnd & dat tl
_ -> errSeen "?" & beforeAttName TypeXml s
-- just seen ">" at the end, am given tl
neilTagEnd typ S{..}
| typ == TypeXml = pos $ errWant "?>" & TagEnd & dat s
| typ == TypeScript = pos $ TagEnd & neilScriptBody s
| otherwise = pos $ TagEnd & dat s
-- Inside a <script> tag, only break on </script
neilScriptBody o@S{..}
| hd == '<', S{..} <- tl
, hd == '/', S{..} <- tl
, isScript s
= dat o
| eof = []
| otherwise = pos $ hd & neilScriptBody tl
-- 8.2.4.4 Close tag open state
-- Deviation: We ignore the if CDATA/RCDATA bits and tag matching
-- Deviation: On </> we output </> to the text
-- Deviation: </!name> is a closing tag, not a bogus comment
closeTagOpen S{..} = case hd of
_ | isAlpha hd || hd `elem` "?!" -> TagShut & hd & tagName TypeNormal tl
'>' -> errSeen "</>" & '<' & '/' & '>' & dat tl
_ | eof -> '<' & '/' & dat s
_ -> errWant "tag name" & bogusComment s
-- 8.2.4.5 Tag name state
tagName typ S{..} = pos $ case hd of
_ | white hd -> beforeAttName typ tl
'/' -> selfClosingStartTag typ tl
'>' -> neilTagEnd typ tl
'?' | typ == TypeXml -> neilXmlTagClose tl
_ | isAlpha hd -> hd & tagName typ tl
_ | eof -> errWant (if typ == TypeXml then "?>" else ">") & dat s
_ -> hd & tagName typ tl
-- 8.2.4.6 Before attribute name state
beforeAttName typ S{..} = pos $ case hd of
_ | white hd -> beforeAttName typ tl
'/' -> selfClosingStartTag typ tl
'>' -> neilTagEnd typ tl
'?' | typ == TypeXml -> neilXmlTagClose tl
_ | typ /= TypeNormal && hd `elem` "\'\"" -> beforeAttValue typ s -- NEIL
_ | hd `elem` "\"'<=" -> errSeen [hd] & AttName & hd & attName typ tl
_ | eof -> errWant (if typ == TypeXml then "?>" else ">") & dat s
_ -> AttName & hd & attName typ tl
-- 8.2.4.7 Attribute name state
attName typ S{..} = pos $ case hd of
_ | white hd -> afterAttName typ tl
'/' -> selfClosingStartTag typ tl
'=' -> beforeAttValue typ tl
'>' -> neilTagEnd typ tl
'?' | typ == TypeXml -> neilXmlTagClose tl
_ | hd `elem` "\"'<" -> errSeen [hd] & def
_ | eof -> errWant (if typ == TypeXml then "?>" else ">") & dat s
_ -> def
where def = hd & attName typ tl
-- 8.2.4.8 After attribute name state
afterAttName typ S{..} = pos $ case hd of
_ | white hd -> afterAttName typ tl
'/' -> selfClosingStartTag typ tl
'=' -> beforeAttValue typ tl
'>' -> neilTagEnd typ tl
'?' | typ == TypeXml -> neilXmlTagClose tl
_ | typ /= TypeNormal && hd `elem` "\"'" -> AttVal & beforeAttValue typ s -- NEIL
_ | hd `elem` "\"'<" -> errSeen [hd] & def
_ | eof -> errWant (if typ == TypeXml then "?>" else ">") & dat s
_ -> def
where def = AttName & hd & attName typ tl
-- 8.2.4.9 Before attribute value state
beforeAttValue typ S{..} = pos $ case hd of
_ | white hd -> beforeAttValue typ tl
'\"' -> AttVal & attValueDQuoted typ tl
'&' -> AttVal & attValueUnquoted typ s
'\'' -> AttVal & attValueSQuoted typ tl
'>' -> errSeen "=" & neilTagEnd typ tl
'?' | typ == TypeXml -> neilXmlTagClose tl
_ | hd `elem` "<=" -> errSeen [hd] & def
_ | eof -> errWant (if typ == TypeXml then "?>" else ">") & dat s
_ -> def
where def = AttVal & hd & attValueUnquoted typ tl
-- 8.2.4.10 Attribute value (double-quoted) state
attValueDQuoted typ S{..} = pos $ case hd of
'\"' -> afterAttValueQuoted typ tl
'&' -> charRefAttValue (attValueDQuoted typ) (Just '\"') tl
_ | eof -> errWant "\"" & dat s
_ -> hd & attValueDQuoted typ tl
-- 8.2.4.11 Attribute value (single-quoted) state
attValueSQuoted typ S{..} = pos $ case hd of
'\'' -> afterAttValueQuoted typ tl
'&' -> charRefAttValue (attValueSQuoted typ) (Just '\'') tl
_ | eof -> errWant "\'" & dat s
_ -> hd & attValueSQuoted typ tl
-- 8.2.4.12 Attribute value (unquoted) state
attValueUnquoted typ S{..} = pos $ case hd of
_ | white hd -> beforeAttName typ tl
'&' -> charRefAttValue (attValueUnquoted typ) Nothing tl
'>' -> neilTagEnd typ tl
'?' | typ == TypeXml -> neilXmlTagClose tl
_ | hd `elem` "\"'<=" -> errSeen [hd] & def
_ | eof -> errWant (if typ == TypeXml then "?>" else ">") & dat s
_ -> def
where def = hd & attValueUnquoted typ tl
-- 8.2.4.13 Character reference in attribute value state
charRefAttValue :: Parser -> Maybe Char -> Parser
charRefAttValue resume c s = charRef resume True c s
-- 8.2.4.14 After attribute value (quoted) state
afterAttValueQuoted typ S{..} = pos $ case hd of
_ | white hd -> beforeAttName typ tl
'/' -> selfClosingStartTag typ tl
'>' -> neilTagEnd typ tl
'?' | typ == TypeXml -> neilXmlTagClose tl
_ | eof -> dat s
_ -> errSeen [hd] & beforeAttName typ s
-- 8.2.4.15 Self-closing start tag state
selfClosingStartTag typ S{..} = pos $ case hd of
_ | typ == TypeXml -> errSeen "/" & beforeAttName typ s
'>' -> TagEndClose & dat tl
_ | eof -> errWant ">" & dat s
_ -> errSeen "/" & beforeAttName typ s
-- 8.2.4.16 Bogus comment state
bogusComment S{..} = Comment & bogusComment1 s
bogusComment1 S{..} = pos $ case hd of
'>' -> CommentEnd & dat tl
_ | eof -> CommentEnd & dat s
_ -> hd & bogusComment1 tl
-- 8.2.4.17 Markup declaration open state
markupDeclOpen S{..} = case hd of
_ | Just s <- next "--" -> Comment & commentStart s
_ | isAlpha hd -> Tag & '!' & hd & tagName TypeDecl tl -- NEIL
_ | Just s <- next "[CDATA[" -> cdataSection s
_ -> errWant "tag name" & bogusComment s
-- 8.2.4.18 Comment start state
commentStart S{..} = pos $ case hd of
'-' -> commentStartDash tl
'>' -> errSeen "<!-->" & CommentEnd & dat tl
_ | eof -> errWant "-->" & CommentEnd & dat s
_ -> hd & comment tl
-- 8.2.4.19 Comment start dash state
commentStartDash S{..} = pos $ case hd of
'-' -> commentEnd tl
'>' -> errSeen "<!--->" & CommentEnd & dat tl
_ | eof -> errWant "-->" & CommentEnd & dat s
_ -> '-' & hd & comment tl
-- 8.2.4.20 Comment state
comment S{..} = pos $ case hd of
'-' -> commentEndDash tl
_ | eof -> errWant "-->" & CommentEnd & dat s
_ -> hd & comment tl
-- 8.2.4.21 Comment end dash state
commentEndDash S{..} = pos $ case hd of
'-' -> commentEnd tl
_ | eof -> errWant "-->" & CommentEnd & dat s
_ -> '-' & hd & comment tl
-- 8.2.4.22 Comment end state
commentEnd S{..} = pos $ case hd of
'>' -> CommentEnd & dat tl
'-' -> errWant "-->" & '-' & commentEnd tl
_ | white hd -> errSeen "--" & '-' & '-' & hd & commentEndSpace tl
'!' -> errSeen "!" & commentEndBang tl
_ | eof -> errWant "-->" & CommentEnd & dat s
_ -> errSeen "--" & '-' & '-' & hd & comment tl
-- 8.2.4.23 Comment end bang state
commentEndBang S{..} = pos $ case hd of
'>' -> CommentEnd & dat tl
'-' -> '-' & '-' & '!' & commentEndDash tl
_ | eof -> errWant "-->" & CommentEnd & dat s
_ -> '-' & '-' & '!' & hd & comment tl
-- 8.2.4.24 Comment end space state
commentEndSpace S{..} = pos $ case hd of
'>' -> CommentEnd & dat tl
'-' -> commentEndDash tl
_ | white hd -> hd & commentEndSpace tl
_ | eof -> errWant "-->" & CommentEnd & dat s
_ -> hd & comment tl
-- 8.2.4.38 CDATA section state
cdataSection S{..} = pos $ case hd of
_ | Just s <- next "]]>" -> dat s
_ | eof -> dat s
_ | otherwise -> hd & cdataSection tl
-- 8.2.4.39 Tokenizing character references
-- Change from spec: this is reponsible for writing '&' if nothing is to be written
charRef :: Parser -> Bool -> Maybe Char -> S -> [Out]
charRef resume att end S{..} = case hd of
_ | eof || hd `elem` "\t\n\f <&" || maybe False (== hd) end -> '&' & resume s
'#' -> charRefNum resume s tl
_ -> charRefAlpha resume att s
charRefNum resume o S{..} = case hd of
_ | hd `elem` "xX" -> charRefNum2 resume o True tl
_ -> charRefNum2 resume o False s
charRefNum2 resume o hex S{..} = case hd of
_ | hexChar hex hd -> (if hex then EntityHex else EntityNum) & hd & charRefNum3 resume hex tl
_ -> errSeen "&" & '&' & resume o
charRefNum3 resume hex S{..} = case hd of
_ | hexChar hex hd -> hd & charRefNum3 resume hex tl
';' -> EntityEnd True & resume tl
_ -> EntityEnd False & errWant ";" & resume s
charRefAlpha resume att S{..} = case hd of
_ | isAlpha hd -> EntityName & hd & charRefAlpha2 resume att tl
_ -> errSeen "&" & '&' & resume s
charRefAlpha2 resume att S{..} = case hd of
_ | alphaChar hd -> hd & charRefAlpha2 resume att tl
';' -> EntityEnd True & resume tl
_ | att -> EntityEnd False & resume s
_ -> EntityEnd False & errWant ";" & resume s
alphaChar x = isAlphaNum x || x `elem` ":-_"
hexChar False x = isDigit x
hexChar True x = isDigit x || (x >= 'a' && x <= 'f') || (x >= 'A' && x <= 'F')
-----
-- Text.HTML.TagSoup.Implementation
-----
data Out
= Char Char
| Tag -- <
| TagShut -- </
| AttName
| AttVal
| TagEnd -- >
| TagEndClose -- />
| Comment -- <!--
| CommentEnd -- -->
| EntityName -- &
| EntityNum -- &#
| EntityHex -- &#x
| EntityEnd Bool -- Attributed followed by ; for True, missing ; for False
| Warn String
-- | Pos Position
errSeen x = Warn $ "Unexpected " ++ show x
errWant x = Warn $ "Expected " ++ show x
data S = S
{s :: S
,tl :: S
,hd :: Char
,eof :: Bool
,next :: String -> Maybe S
,pos :: [Out] -> [Out]
}
infixr &
class Outable a where (&) :: a -> [Out] -> [Out]
instance Outable Char where (&) = ampChar
instance Outable Out where (&) = ampOut
ampChar x y = Char x : y
ampOut x y = x : yNote that you will need to compile with optimizations enabled:
$ ghc-stage2 -fforce-recomp Bug.hs -OI have not attempted to minimize this further.