+text =
+ liftM (Text . concat) $ many1
+ ( many1 (satisfy (\ch -> not (isAlpha ch || ch `elem` "\"#'-_{")))
+ <|> (do a <- satisfy (\ch -> isAlpha ch || ch == '_')
+ b <- many (satisfy (\ch -> isAlphaNum ch || ch == '_' || ch == '\''))
+ return (a:b))
+ <|> (do char '\"'; a <- hsString '\"'; char '\"'; return ("\""++a++"\""))
+ <|> (do try (string "##"); return "#")
+ <|> (do char '\''; a <- hsString '\''; char '\''; return ("\'"++a++"\'"))
+ <|> (do try (string "--"); a <- many (satisfy (/= '\n')); return ("--"++a))
+ <|> string "-"
+ <|> (do try (string "{-"); a <- hsComment; return ("{-"++a))
+ <|> string "{"
+ <?> "Haskell source")
+
+hsComment :: Parser String
+hsComment =
+ ( (do a <- many1 (noneOf "-{"); b <- hsComment; return (a++b))
+ <|> try (string "-}")
+ <|> (do char '-'; b <- hsComment; return ('-':b))
+ <|> (do try (string "{-"); a <- hsComment; b <- hsComment; return ("{-"++a++b))
+ <|> (do char '{'; b <- hsComment; return ('{':b))
+ <?> "Haskell comment")
+
+hsString :: Char -> Parser String
+hsString quote =
+ liftM concat $ many
+ ( many1 (noneOf (quote:"\n\\"))
+ <|> (do char '\\'; a <- escape; return ('\\':a))
+ <?> "Haskell character or string")
+ where
+ escape = (do a <- many1 (satisfy isSpace); char '\\'; return (a++"\\"))
+ <|> (do a <- anyChar; return [a])