seonbi 0.2.3 → 0.3.0
raw patch · 23 files changed
+1311/−104 lines, 23 filesdep +bytestring-triedep +case-insensitivedep +cmarkdep −text-triedep ~Diffdep ~aesondep ~base
Dependencies added: bytestring-trie, case-insensitive, cmark, html-entities
Dependencies removed: text-trie
Dependency ranges changed: Diff, aeson, base, cases, file-embed, hlint, optparse-applicative, random
Files
- CHANGES.md +92/−2
- README.md +43/−5
- app/seonbi-api.hs +73/−14
- app/seonbi.hs +19/−9
- seonbi.cabal +37/−25
- src/Text/Seonbi/ContentTypes.hs +348/−0
- src/Text/Seonbi/Facade.hs +34/−21
- src/Text/Seonbi/Hanja.hs +13/−5
- src/Text/Seonbi/Html.hs +1/−0
- src/Text/Seonbi/Html/Entity.hs +1/−0
- src/Text/Seonbi/Html/Lang.hs +166/−0
- src/Text/Seonbi/Html/Printer.hs +32/−4
- src/Text/Seonbi/Html/Tag.hs +59/−1
- src/Text/Seonbi/Html/TagStack.hs +17/−2
- src/Text/Seonbi/Punctuation.hs +9/−4
- src/Text/Seonbi/Trie.hs +140/−9
- test/Text/Seonbi/ContentTypesSpec.hs +56/−0
- test/Text/Seonbi/FacadeSpec.hs +2/−2
- test/Text/Seonbi/HangulSpec.hs +0/−1
- test/Text/Seonbi/HanjaSpec.hs +27/−0
- test/Text/Seonbi/Html/LangSpec.hs +111/−0
- test/Text/Seonbi/PunctuationSpec.hs +17/−0
- test/doctest.hs +14/−0
CHANGES.md view
@@ -1,14 +1,104 @@ Seonbi changelog ================ +Version 0.3.0+-------------++Released November 18, 2021.++ - Since this version, it requires GHC 8.8.* at least, and supports GHC 9.0.*+ at most.++ - Now supports several content types besides HTML/XHTML. The below list+ shows all supported content types: [[#18]]++ - `text/html` (previously non-XHTML mode)+ - `application/xhtml+xml` (previously XHTML mode)+ - `text/plain` (added)+ - `text/markdown` (added)++ The below Haskell APIs changed:++ - Added `Text.Seonbi.ContentTypes` module.+ - Added `contentType` field for `Configuration m a`.+ - Removed `xhtml` field for `Configuration m a` in favor of+ new `contentType` field for the same type.++ The below CLI options changed:++ - Added `-t`/`--content-type` option with the default value `text/html`.+ - Removed Removed `-x`/`--xhtml` option in favor of new+ `-t`/`--content-type` option. In order to use XHTML mode, give it+ `-t application/xhtml+xml` option.++ The below HTTP APIs changed:++ - Added a mandatory field `"content"` to requests.+ - Deprecated the `"sourceHtml"` field of requests in favor of the new+ `"content"` field.+ - Added an optional field `"contentType"` with the default value+ `"text/html"` to requests.+ - Deprecated the `"xhtml"` field of requests in favor of the new+ `"contentType"` field. The legacy field will be gone in the next+ minor release.+ In order to use XHTML mode, configure `"contentType"` field with+ `"application/xhtml+xml"`.+ - Added `"content"` field to responses.+ - Deprecated the `"resultHtml"` field of responses in favor of the new+ `"content"` field. The legacy field is not provided for non-HTML+ types, and will be gone in the next minor release.+ - Added `"contentType"` field to responses.+ - Added `"warnings"` field to responses.++ - Added `Text.Seonbi.Html.Lang` module.++ - Some transformations inappropriate for non-Korean contents are no more+ applied to elements written in other languages than Korean. The below+ functions respect elements `lang` attributes: [[#10]]++ - `Text.Seonbi.Hanja.phoneticizeHanja`+ - `Text.Seonbi.Punctuation.normalizeStops`++ - Removed several functions from `Text.Seonbi.Trie` module:++ - `toListBy`+ - `lookupBy`+ - `submap`+ - `match`+ - `matches`+ - `alterBy`+ - `adjust`+ - `delete`+ - `mapBy`+ - `filterMap`++ - `Text.Seonbi.Trie.Trie` type is not an instance of the following typeclasses+ anymore:++ - `Generic a => Generic (Trie a)`+ - `Binary a => Binary (Trie a)`+ - `Generic1 Trie`+ - `type Rep (Trie a)`+ - `type Rep1 Trie`++ - Added `Text.Seonbi.Html.Printer.printText` function.+ - Added `Text.Seonbi.Html.Tag.headingLevel` function.+ - Added `Text.Seonbi.Html.Tag.headingTag` function.+ - Added `Text.Seonbi.Html.Tag.headingTag'` function.+ - Added `Text.Seonbi.Html.TagStack.last` function.++[#10]: https://github.com/dahlia/seonbi/issues/10+[#18]: https://github.com/dahlia/seonbi/issues/18++ Version 0.2.3 ------------- Released on September 26, 2021. - - Fixed stops normalizer's bug where trailing spaces following stops had been+ - Fixed stops normalizer's bug where trailing spaces following stops had been trimmed after normalized.- - Fixed stops normalizer's buf where unnecessary trailing spaces following+ - Fixed stops normalizer's buf where unnecessary trailing spaces following stops had been inserted after normalized. In particular, unnecessary spaces between stops and closing parentheses/brackets are no more inserted.
README.md view
@@ -38,11 +38,20 @@ - A hyphen or an equality symbol wrapped by inequality symbols (`<->`, `<=>`) into bi-directional arrows (`↔`, `⇔`) -Since its transformations work in HTML-level, it also plays well with web-markup languages like CommonMark, Markdown, and Textile. In a similar way to-SmartyPants, it does not modify characters within several sensitive-HTML elements like `<pre>`/`<code>`/`<script>`/`<kbd>`.+Each transformations can be partially turned on and off, and some+transformations have many options. +All transformations work with both plain texts and rich text tree.+In a similar way to SmartyPants, it does not modify characters within+several sensitive HTML elements like `<pre>`/`<code>`/`<script>`/`<kbd>`.+Chinese/Japanese stops or hanzi/kanji characters inside elements with+`lang="zh"`/`lang="ja"`[^1] are never transformed.++[^1]: Technically, only Korean contents and language-unspecified elements+ are transformed. Elements having `lang` attribute with language tags+ referring to any Korean language are treated as Korean contents,+ e.g., `ko`, `ko-Hang`, `kor-KP`, `kor-Kore`.+ [releases]: https://github.com/dahlia/seonbi/releases [releases-badge]: https://img.shields.io/github/v/release/dahlia/seonbi [hackage]: https://hackage.haskell.org/package/seonbi@@ -56,6 +65,33 @@ [Korean mixed script]: https://en.wikipedia.org/wiki/Korean_mixed_script +End-user apps+-------------++Technically, Seonbi is basically exposed as a software component,+which is also known as API (application programming interface), to be used+as a module of other softwares.++However, as these official interfaces are not for humans but machines, it's+not easy to use for end-users whom haven't experienced software+programming. For such end-users, here's the list of end-user apps:++ - [Demo web app]: The official web app. Not that mobile-friendly+ (usable though).+ - [Seonbi Translator] (선비 번역기): An iOS shortcut made by+ [Heechan Bak] ([@channprj]).+ - [seonbi-webapp]: Probably aims to replace the official web app.+ Made by Lee Dogeon ([@moreal]).+ - [seonbi-ext]: A browser extension made by Lee Dogeon ([@moreal]).++[Seonbi Translator]: https://www.icloud.com/shortcuts/1e468a5dd0104fc5b69fe803952fc154+[Heechan Bak]: https://chann.dev/+[@channprj]: https://github.com/channprj+[seonbi-webapp]: https://github.com/moreal/seonbi-webapp+[@moreal]: https://github.com/moreal+[seonbi-ext]: https://github.com/moreal/seonbi-ext++ Installation ------------ @@ -121,6 +157,7 @@ { "preset": "ko-kr",+ "contentType": "text/html", "sourceHtml": "<p>하늘과 바람과 별과 詩</p>" } @@ -128,10 +165,11 @@ HTTP/1.1 200 OK Content-Type: application/json- Server: Seonbi/0.2.3+ Server: Seonbi/0.3.0 { "success": true,+ "contentType": "text/html", "resultHtml": "<p>하늘과 바람과 별과 시</p>" }
app/seonbi-api.hs view
@@ -7,6 +7,7 @@ import Control.Concurrent (threadDelay) import Control.Monad+import Data.Maybe (catMaybes) import Data.String import Data.Version import GHC.Exts (IsList (..))@@ -16,6 +17,7 @@ import qualified Data.Aeson.Types import qualified Data.ByteString as B import qualified Data.Map.Strict as M+import qualified Data.Set as S import Data.Text import Data.Text.Encoding import Network.Wai@@ -28,14 +30,38 @@ import Text.Seonbi.Trie as Trie data Input = Input- { sourceHtml :: Text+ { source :: Text , configuration :: Configuration IO ()+ , warnings :: [Text] } deriving (Show) instance FromJSON Input where parseJSON = withObject "Input" $ \ v -> do- sourceHtml' <- v .: "sourceHtml"+ sourceMaybe <- v .:? "content"+ (source', w1) <- case sourceMaybe of+ Just s -> return (s, Nothing)+ Nothing -> do+ sourceHtml' <- v .:? "sourceHtml"+ case sourceHtml' of+ Just h -> return+ ( h+ , Just $ "key \"sourceHtml\" is deprecated in " <>+ "favour of \"content\""+ )+ Nothing -> fail "key \"content\" not present" preset <- v .:? "preset"+ contentTypeMaybe <- v .:? "contentType"+ (contentType', w2) <- case contentTypeMaybe of+ Just t -> return (t, Nothing)+ Nothing -> do+ xhtml <- v .:? "xhtml"+ case xhtml of+ Just x -> return+ ( if x then "application/xhtml+xml" else "text/html"+ , Just $ "key \"xhtml\" is deprecated in favour of " <>+ "\"contentType\""+ )+ Nothing -> return ("text/html", Nothing) config <- case preset of Just locale -> let presets' = presets :: M.Map Text (Configuration IO ())@@ -50,7 +76,6 @@ , intercalate ", " (M.keys presets') ] Nothing -> do- xhtml' <- v .:? "xhtml" .!= False quote' <- v .:? "quote" cite' <- v .:? "cite" arrow' <- v .:? "arrow"@@ -60,7 +85,7 @@ hanja' <- v .:? "hanja" .!= Nothing return Configuration { debugLogger = Nothing- , xhtml = xhtml'+ , contentType = contentType' , quote = quote' , cite = cite' , arrow = arrow'@@ -69,8 +94,23 @@ , stop = stop' , hanja = hanja' }- return $ Input sourceHtml' config+ return $ Input+ { source = source'+ , configuration = config { contentType = contentType' }+ , warnings = catMaybes [w1, w2]+ } +instance FromJSON ContentType where+ parseJSON = withText "ContentType" $ \ t ->+ if contentTypeFromText t `S.member` contentTypes+ then return (contentTypeFromText t)+ else fail $ unpack $ Data.Text.concat+ [ "Unknown content type: "+ , t+ , "; available content types: "+ , intercalate ", " $ contentTypeText <$> S.elems contentTypes+ ]+ instance FromJSON QuoteOption instance FromJSON CiteOption instance FromJSON ArrowOption@@ -117,12 +157,29 @@ inputJson <- lazyRequestBody request threadDelay (debugDelayMs * 1000) case eitherDecode' inputJson of- Right (Input source config) -> do+ Right (Input source config warnings) -> do result <- transformHtmlText config source- respond' status200 $ object+ let type' = contentType config+ let warningComments =+ if Prelude.null warnings+ then Data.Text.empty+ else Data.Text.concat+ [ "<!--\n"+ , Data.Text.intercalate "\n" warnings+ , "\n-->"+ ]+ respond' status200 $ object $ [ "success" .= Bool True- , "resultHtml" .= String result+ , "content" .= String result+ , "warnings" .= Array+ (GHC.Exts.fromList $ String <$> warnings)+ , "contentType" .= String (contentTypeText type') ]+ +++ [ "resultHtml" .= String (warningComments <> result)+ | type' == "text/html" ||+ type' == "application/xhtml+xml"+ ] Left msg -> respond' status400 $ object [ "success" .= Bool False , "message" .= String (pack msg)@@ -194,13 +251,14 @@ ) <*> ( AppOptions <$> (- ( Just <$> strOption- ( long "allow-origin"- <> short 'o'- <> metavar "ORIGIN"- <> help "Allow cross-origin (i.e., CORS)"+ optional+ ( strOption+ ( long "allow-origin"+ <> short 'o'+ <> metavar "ORIGIN"+ <> help "Allow cross-origin (i.e., CORS)"+ ) )- ) <|> pure Nothing ) <*> option auto@@ -233,5 +291,6 @@ let netloc = showHostPreference (getHost serverSettings') ++ ":" ++ show (getPort serverSettings') let url = "http://" ++ netloc ++ "/"+ hPutStrLn stderr $ "seonbi-api v" ++ showVersion Meta.version hPutStrLn stderr url runSettings serverSettings' $ app appOptions
app/seonbi.hs view
@@ -25,6 +25,7 @@ #endif import Data.ByteString.Lazy import Data.Map.Strict+import qualified Data.Set as S import qualified Data.Text as T import Data.Text.Lazy import Data.Text.Lazy.Encoding@@ -92,7 +93,7 @@ , config :: Configuration IO () , dictionaries :: [FilePath] , noKrStdict :: Bool- , xhtml :: Bool+ , contentType' :: ContentType , debug :: Bool , version :: Bool , input :: FilePath@@ -137,9 +138,11 @@ enumKeyword = T.unpack . enumKeyword' enumKeywords :: forall a . (Enum a, Show a) => Proxy a -> String-enumKeywords _ = T.unpack $ T.intercalate ", " $- fmap enumKeyword' [(toEnum 0 :: a) ..]+enumKeywords _ = commas $ enumKeyword' <$> [(toEnum 0 :: a) ..] +commas :: [T.Text] -> String+commas = T.unpack . T.intercalate ", "+ parser :: Parser Seonbi parser = Seonbi <$> strOption@@ -166,7 +169,7 @@ "Available presets: " ++ Data.List.intercalate ", " (Data.Map.Strict.keys presets')) )- <|> ( Configuration Nothing False+ <|> ( Configuration Nothing "text/html" <$> ( flag' Nothing ( long "no-quote" <> short 'Q'@@ -297,10 +300,14 @@ <> help ("Do not use Standard Korean Language Dictionary " ++ "(標準國語大辭典) by South Korean NIKL (國立國語院)") )- <*> switch- ( long "xhtml"- <> short 'x'- <> help "XHTML mode"+ <*> strOption+ ( long "content-type"+ <> short 't'+ <> metavar "TYPE"+ <> value "text/html"+ <> help ("Content type. Available types: " ++ commas+ (contentTypeText <$> S.elems contentTypes) +++ " [default: text/html]") ) <*> switch ( long "debug"@@ -347,6 +354,7 @@ , config , dictionaries , noKrStdict+ , contentType' , debug , version , input@@ -371,6 +379,7 @@ { debugLogger = debugLogger' , hanja = Just hanja' { reading = reading' } }+ let configWithContentType = config' { contentType = contentType' } when version $ do Prelude.putStrLn $ showVersion Meta.version exitSuccess@@ -390,7 +399,8 @@ enc -> enc debugPrint ("encoding: " ++ encodingName) result <- catchIOError- (transformHtmlLazyText config' $ toUnicode encodingName contents)+ (transformHtmlLazyText configWithContentType $+ toUnicode encodingName contents) (\ e -> hPutStrLn stderr (ioeGetErrorString e) >> exitFailure) let resultBytes = fromUnicode encodingName result if output == "-"
seonbi.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: seonbi-version: 0.2.3+version: 0.3.0 synopsis: SmartyPants for Korean language description: Please see the README.md on GitHub at <https://github.com/dahlia/seonbi>. category: Text@@ -36,10 +36,10 @@ , bytestring , directory ==1.* , filepath- , http-client >=0.5 && <0.7+ , http-client >=0.5 && <0.8 , temporary >=1.2 && <1.4 , text- , zip >=1.1 && <1.3+ , zip >=1.1 && <1.8 flag embed-dictionary description: Embed dictionary rather than load from file@@ -58,12 +58,14 @@ library exposed-modules:+ Text.Seonbi.ContentTypes Text.Seonbi.Facade Text.Seonbi.Hangul Text.Seonbi.Hanja Text.Seonbi.Html Text.Seonbi.Html.Clipper Text.Seonbi.Html.Entity+ Text.Seonbi.Html.Lang Text.Seonbi.Html.Preservation Text.Seonbi.Html.Printer Text.Seonbi.Html.Scanner@@ -80,17 +82,20 @@ hs-source-dirs: src build-depends:- aeson >=1.3.1 && <1.5+ aeson >=1.3.1 && <1.6 , attoparsec >=0.12 && <1- , base >=4.7 && <5+ , base >=4.12 && <5 , bytestring+ , bytestring-trie >=0.2.5 && <0.3+ , case-insensitive ==1.* , cassava ==0.5.*+ , cmark >=0.6 && <1 , containers , data-default >=0.2 && <1- , file-embed >=0.0.10 && <0.0.12+ , file-embed >=0.0.10 && <0.0.16 , filepath ==1.*+ , html-entities ==1.* , text- , text-trie >=0.2.5 && <0.3 if os(darwin) ghc-options: -Wall -fprint-explicit-kinds -optP-Wno-nonportable-include-path else@@ -108,10 +113,11 @@ hs-source-dirs: app build-depends:- aeson >=1.3.1 && <1.5- , base >=4.7 && <5+ aeson >=1.3.1 && <1.6+ , base >=4.12 && <5 , bytestring , containers+ , html-entities ==1.* , text if os(darwin) ghc-options: -Wall -fprint-explicit-kinds -optP-Wno-nonportable-include-path@@ -120,16 +126,16 @@ if flag(iconv) cpp-options: -DICONV build-depends:- cases ==0.1.3.2+ cases >=0.1.3.2 && <0.1.5 , html-charset ==0.1.* , iconv ==0.4.*- , optparse-applicative ==0.14.*+ , optparse-applicative >=0.14 && <0.17 , seonbi else build-depends:- cases ==0.1.3.2+ cases >=0.1.3.2 && <0.1.5 , html-charset ==0.1.*- , optparse-applicative ==0.14.*+ , optparse-applicative >=0.14 && <0.17 , seonbi if flag(static) ld-options: -static@@ -148,12 +154,13 @@ hs-source-dirs: app build-depends:- aeson >=1.3.1 && <1.5- , base >=4.7 && <5+ aeson >=1.3.1 && <1.6+ , base >=4.12 && <5 , bytestring , containers+ , html-entities ==1.* , http-types ==0.12.*- , optparse-applicative ==0.14.*+ , optparse-applicative >=0.14 && <0.17 , seonbi , text , wai >=3.2 && <3.4@@ -180,12 +187,13 @@ ghc-options: -threaded build-depends: QuickCheck- , aeson >=1.3.1 && <1.5- , base >=4.7 && <5+ , aeson >=1.3.1 && <1.6+ , base >=4.12 && <5 , bytestring , containers , doctest , doctest-discover+ , html-entities ==1.* , seonbi , text , unicode-show@@ -202,11 +210,12 @@ test ghc-options: -threaded build-depends:- aeson >=1.3.1 && <1.5- , base >=4.7 && <5+ aeson >=1.3.1 && <1.6+ , base >=4.12 && <5 , bytestring , containers- , hlint >=2.1.7 && <2.2+ , hlint >=2.1.7 && <3.3+ , html-entities ==1.* , text if os(darwin) ghc-options: -Wall -fprint-explicit-kinds -optP-Wno-nonportable-include-path@@ -218,10 +227,12 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules:+ Text.Seonbi.ContentTypesSpec Text.Seonbi.FacadeSpec Text.Seonbi.HangulSpec Text.Seonbi.HanjaSpec Text.Seonbi.Html.ClipperSpec+ Text.Seonbi.Html.LangSpec Text.Seonbi.Html.PreservationSpec Text.Seonbi.Html.PrinterSpec Text.Seonbi.Html.ScannerSpec@@ -234,17 +245,18 @@ test ghc-options: -Wno-incomplete-uni-patterns -threaded -rtsopts -with-rtsopts=-N build-depends:- Diff >=0.3.4 && <0.4- , aeson >=1.3.1 && <1.5- , base >=4.7 && <5+ Diff >=0.3.4 && <0.5+ , aeson >=1.3.1 && <1.6+ , base >=4.12 && <5 , bytestring , containers , directory ==1.* , filepath ==1.* , hspec >=2.4.8 && <3 , hspec-discover >=2.4.8 && <3+ , html-entities ==1.* , interpolatedstring-perl6 >=1.0.1 && <2- , random ==1.1.*+ , random >=1.1 && <1.3 , seonbi , text if os(darwin)
+ src/Text/Seonbi/ContentTypes.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+module Text.Seonbi.ContentTypes+ ( ContentType+ , HtmlTransformer+ , TextTransformer+ , asCommonMarkTransformer+ , asHtmlTransformer+ , asHtmlTransformer'+ , asPlainTextTransformer+ , asXhtmlTransformer+ , contentTypeFromText+ , contentTypes+ , contentTypeText+ , transformWithContentType+ ) where++#if MIN_VERSION_base(4,13,0)+import Prelude hiding (MonadFail)+#endif++import Control.Monad (forM)+import Control.Monad.Fail (MonadFail)+import Data.Maybe (fromMaybe, isNothing)+import Data.List+import Text.Read (readMaybe)++import CMark+import Data.CaseInsensitive+import Data.Set+import Data.Text as ST+import Data.Text.Lazy as LT+import Data.Text.Lazy.Builder+import HTMLEntities.Builder+import HTMLEntities.Decoder++import Text.Seonbi.Html+import Text.Seonbi.Html.Tag (headingLevel, headingTag')+import qualified Text.Seonbi.Html.TagStack as TagStack++-- | Represents a function that transforms an 'HtmlEntity' list.+type HtmlTransformer m+ = (Monad m, MonadFail m) => [HtmlEntity] -> m [HtmlEntity]++-- | Represents a function that transforms a text.+type TextTransformer m+ = (Monad m, MonadFail m) => LT.Text -> m LT.Text++-- | Represents a function that transforms an 'HtmlTransformer' into+-- a 'TextTransformer'.+type TransformerTransformer m+ = (Monad m, MonadFail m) => HtmlTransformer m -> TextTransformer m++-- | Gets a 'TransformerTransformer' that transforms 'HtmlTransformer' into+-- a 'TextTransformer' which transforms an HTML/XHTML text.+asHtmlTransformer'+ :: (Monad m, MonadFail m)+ => Bool+ -- ^ 'True' for XHTML, and 'False' for HTML.+ -> TransformerTransformer m+ -- ^ A 'TransformerTransformer' that transforms an 'HtmlTransformer' into+ -- a 'TextTransformer' which transforms an HTML/XHTML text.+asHtmlTransformer' xhtml transformer htmlText = do+ case scanHtml htmlText of+ Done "" input -> do+ output <- transformer input+ return $ printHtml' output+ _ ->+ fail "failed to parse input"+ where+ printHtml' :: [HtmlEntity] -> LT.Text+ printHtml'+ | xhtml = printXhtml+ | otherwise = printHtml++-- | Transforms an 'HtmlTransformer' into a 'TextTransformer' which transforms+-- an HTML text.+asHtmlTransformer :: (Monad m, MonadFail m) => TransformerTransformer m+asHtmlTransformer = asHtmlTransformer' False++-- | Transforms an 'HtmlTransformer' into a 'TextTransformer' which transforms+-- an XHTML text.+asXhtmlTransformer :: (Monad m, MonadFail m) => TransformerTransformer m+asXhtmlTransformer = asHtmlTransformer' True++-- | Transforms an 'HtmlTransformer' into a 'TextTransformer' which transforms+-- a plain text.+asPlainTextTransformer :: (Monad m, MonadFail m) => TransformerTransformer m+asPlainTextTransformer transformer text' = do+ let escaped = toLazyText $ HTMLEntities.Builder.text $ LT.toStrict text'+ let entities = [HtmlText TagStack.empty $ LT.toStrict escaped]+ output <- transformer entities+ return $ printText output++-- | Transforms an 'HtmlTransformer' into a 'TextTransformer' which transforms+-- a CommonMark (Markdown) text.+asCommonMarkTransformer :: (Monad m, MonadFail m) => TransformerTransformer m+asCommonMarkTransformer transformer input = do+ let inputNode = commonmarkToNode [optSourcePos, optUnsafe] $+ LT.toStrict input+ inputEntities <- fromNode [] inputNode+ outputEntities <- transformer $ normalizeText inputEntities+ let outputNodes = toNode outputEntities+ let outputNode = case outputNodes of+ [node@(Node _ DOCUMENT _)] -> node+ nodes -> Node Nothing DOCUMENT nodes+ return $ LT.fromStrict $+ nodeToCommonmark [optSourcePos , optUnsafe] Nothing outputNode+ where+ fromNode :: (Monad m, MonadFail m) => HtmlTagStack -> Node -> m [HtmlEntity]+ fromNode stack (Node posInfo nodeType children) = case nodeType of+ DOCUMENT ->+ nodeWithChildren Article+ THEMATIC_BREAK -> return+ [ HtmlStartTag stack HR (posAttr posInfo)+ , HtmlEndTag stack HR+ ]+ PARAGRAPH ->+ nodeWithChildren P+ BLOCK_QUOTE ->+ nodeWithChildren BlockQuote+ HTML_BLOCK html ->+ case scanHtml $ LT.fromStrict html of+ Done "" input' -> return $ rebaseStack input'+ _ -> return [HtmlCdata stack html]+ CUSTOM_BLOCK _ _ ->+ return []+ CODE_BLOCK info text' -> return+ [ HtmlStartTag stack Pre (posAttr posInfo <> attr' "info" info)+ , HtmlCdata (nextStack Pre) text'+ , HtmlEndTag stack Pre+ ]+ HEADING level ->+ nodeWithChildren $ headingTag' level+ LIST listAttrs ->+ nodeWithChildren' UL $ attr' "list-attrs" listAttrs+ ITEM ->+ nodeWithChildren LI+ TEXT text' ->+ return [HtmlCdata stack text']+ SOFTBREAK -> return+ [ HtmlStartTag stack BR (posAttr posInfo <> attr' "softbreak" True)+ , HtmlEndTag stack BR+ ]+ LINEBREAK -> return+ [ HtmlStartTag stack BR (posAttr posInfo)+ , HtmlEndTag stack BR+ ]+ HTML_INLINE html ->+ case scanHtml $ LT.fromStrict html of+ Done "" input' -> return $ rebaseStack input'+ _ -> return [HtmlCdata stack html]+ CUSTOM_INLINE _ _ ->+ return []+ CODE text' -> return+ [ HtmlStartTag stack Code (posAttr posInfo)+ , HtmlCdata (nextStack Code) text'+ , HtmlEndTag stack Code+ ]+ EMPH ->+ nodeWithChildren Em+ STRONG ->+ nodeWithChildren Strong+ LINK href title ->+ nodeWithChildren' A $ rawAttr " href" href <> rawAttr " title" title+ IMAGE src title ->+ nodeWithChildren' Img $ rawAttr " src" src <> rawAttr " title" title+ where+ nextStack :: HtmlTag -> HtmlTagStack+ nextStack = (`TagStack.push` stack)+ nodeWithChildren :: (Monad m, MonadFail m) => HtmlTag -> m [HtmlEntity]+ nodeWithChildren tag' = nodeWithChildren' tag' ""+ nodeWithChildren' :: (Monad m, MonadFail m)+ => HtmlTag -> ST.Text -> m [HtmlEntity]+ nodeWithChildren' tag' extraAttrs = do+ mid <- forM children $ do+ fromNode (nextStack tag')+ let middle = Data.List.concat mid+ return $ HtmlStartTag stack tag' (posAttr posInfo <> extraAttrs) :+ middle ++ [HtmlEndTag stack tag']+ rebase' :: HtmlTagStack -> HtmlTagStack+ rebase' = TagStack.rebase [] stack+ rebaseStack :: [HtmlEntity] -> [HtmlEntity]+ rebaseStack = Prelude.map (\e -> e { tagStack = rebase' $ tagStack e })+ toNode :: [HtmlEntity] -> [Node]+ toNode [] = []+ toNode (x:xs) = case x of+ HtmlComment _ comment' ->+ Node Nothing (htmlNode comment') [] : toNode xs+ HtmlCdata _ cdata ->+ Node Nothing (TEXT cdata) [] : toNode xs+ HtmlText _ rawText' ->+ Node Nothing (TEXT $ unescape rawText') [] : toNode xs+ HtmlEndTag _ _ ->+ toNode xs+ start@(HtmlStartTag stack tag' attrs) ->+ let (children', rest) = Data.List.break (endOf stack tag') xs+ (end, rest') = case rest of+ end'@(HtmlEndTag endStack endTag):afterEnd ->+ if endStack == stack && endTag == tag'+ then ([end'], afterEnd)+ else ([], rest)+ _ -> ([], rest)+ posInfo = fromMaybe Nothing+ (getAttr attrs "posinfo" :: Maybe (Maybe PosInfo))+ softbreak = getAttr attrs "softbreak" :: Maybe Bool+ childrenHtmlNode = htmlNode $ LT.toStrict $ printHtml $+ start : children' ++ end+ nodeType = case tag' of+ Article -> DOCUMENT+ BlockQuote -> BLOCK_QUOTE+ HR -> THEMATIC_BREAK+ P -> PARAGRAPH+ Pre -> case getAttr "info" attrs of+ Just info -> CODE_BLOCK info $ printText' children'+ Nothing -> childrenHtmlNode+ UL ->+ maybe childrenHtmlNode LIST (getAttr attrs "list-attrs")+ LI -> ITEM+ BR ->+ if softbreak == Just True then SOFTBREAK else LINEBREAK+ Code -> CODE $ printText' children'+ Em -> EMPH+ Strong -> STRONG+ A -> LINK+ (fromMaybe ST.empty $ getRawAttr attrs "href")+ (fromMaybe ST.empty $ getRawAttr attrs "title")+ Img -> IMAGE+ (fromMaybe ST.empty $ getRawAttr attrs "src")+ (fromMaybe ST.empty $ getRawAttr attrs "title")+ _ ->+ maybe childrenHtmlNode HEADING (headingLevel tag')+ (nodeType', nodeChildren) =+ if isNothing posInfo && isNothing softbreak+ then (childrenHtmlNode, [])+ else (nodeType, toNode children')+ in+ Node posInfo nodeType' nodeChildren : toNode rest'+ where+ block :: Bool+ block = case TagStack.last (tagStack x) of+ Just A -> False+ Just Em -> False+ Just H1 -> False+ Just H2 -> False+ Just H3 -> False+ Just H4 -> False+ Just H5 -> False+ Just H6 -> False+ Just P -> False+ Just Strong -> False+ Just tag' -> isNothing (headingLevel tag')+ _ -> True+ htmlNode :: ST.Text -> NodeType+ htmlNode+ | block = HTML_BLOCK+ | otherwise = HTML_INLINE+ unescape :: ST.Text -> ST.Text+ unescape = toStrict . toLazyText . htmlEncodedText+ rawAttr :: ST.Text -> ST.Text -> ST.Text+ rawAttr name value = ST.append name $ toStrict $+ "=\"" <> toLazyText (HTMLEntities.Builder.text value) <> "\""+ attr :: Show a => ST.Text -> a -> ST.Text+ attr name value =+ rawAttr ("data-seonbi-cmark-" <> name) $ ST.pack (show value)+ attr' :: Show a => ST.Text -> a -> ST.Text+ attr' name = ST.cons ' ' . attr name+ posAttr :: Maybe PosInfo -> ST.Text+ posAttr = attr "posinfo"+ getRawAttr :: HtmlRawAttrs -> ST.Text -> Maybe ST.Text+ getRawAttr attrs name =+ case ST.breakOn prefix attrs of+ (_, "") -> Nothing+ (_, head') ->+ case ST.break (== '"') (ST.drop (ST.length prefix) head') of+ (_, "") -> Nothing+ (value, _) ->+ Just $ toStrict $ toLazyText $ htmlEncodedText value+ where+ prefix :: ST.Text+ prefix = name <> "=\""+ getAttr :: Read a => HtmlRawAttrs -> ST.Text -> Maybe a+ getAttr attrs name =+ case getRawAttr attrs ("data-seonbi-cmark-" <> name) of+ Nothing -> Nothing+ Just value -> readMaybe $ ST.unpack value+ endOf :: HtmlTagStack -> HtmlTag -> HtmlEntity -> Bool+ endOf stack tag' (HtmlEndTag endStack endTag) =+ not (endStack `TagStack.descendsFrom` stack) || endTag == tag'+ endOf _ _ _ = False+ printText' :: [HtmlEntity] -> ST.Text+ printText' = toStrict . printText+++-- | Represents a case-insensitive content type.+type ContentType = CI ST.Text++-- | Converts a 'Text' to a 'ContentType'.+contentTypeFromText :: ST.Text -> ContentType+contentTypeFromText = mk++-- | Converts a 'ContentType' to a 'Text'.+contentTypeText :: ContentType -> ST.Text+contentTypeText = original++newtype TransformerTransformer' m =+ TransformerTransformer' (TransformerTransformer m)+transformers :: (Monad m, MonadFail m)+ => [(ContentType, TransformerTransformer' m)]+transformers =+ [ ("text/html", TransformerTransformer' asHtmlTransformer)+ , ("application/xhtml+xml", TransformerTransformer' asXhtmlTransformer)+ , ("text/plain", TransformerTransformer' asPlainTextTransformer)+ , ("text/markdown", TransformerTransformer' asCommonMarkTransformer)+ ]++-- | Supported content types.+contentTypes :: Set ContentType+contentTypes = (Data.Set.fromList . Prelude.map fst)+ (transformers :: [(ContentType, TransformerTransformer' IO)])++getTransformerTransformer :: (Monad m, MonadFail m)+ => ContentType+ -> Maybe (TransformerTransformer' m)+getTransformerTransformer contentType =+ snd <$> Data.List.find ((== contentType) . fst) transformers++-- | Applies an 'HtmlTransformer' to the given text with respect to the+-- given content type.+transformWithContentType+ :: (Monad m, MonadFail m)+ => ContentType+ -- ^ A content type. If the content type is unsupported (i.e. not in+ -- 'contentTypes'), this function fails.+ -> HtmlTransformer m+ -- ^ An 'HtmlTransformer' to apply.+ -> LT.Text+ -- ^ A input text to transform.+ -> m LT.Text+ -- ^ A transformed text.+transformWithContentType contentType transformer inputText =+ case getTransformerTransformer contentType of+ Nothing -> fail $ ST.unpack $+ "unknown content type: " <> contentTypeText contentType+ Just (TransformerTransformer' transformTransformer) ->+ transformTransformer transformer inputText
src/Text/Seonbi/Facade.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} #ifdef EMBED_DICTIONARY {-# LANGUAGE TemplateHaskell #-} #endif@@ -17,6 +19,11 @@ , ko_KP , ko_KR , presets+ -- * Content types+ , ContentType+ , contentTypeFromText+ , contentTypes+ , contentTypeText -- * Dictionaries , HanjaDictionary , readDictionaryFile@@ -31,7 +38,13 @@ , StopOption (..) ) where +#if MIN_VERSION_base(4,13,0)+import Prelude hiding (MonadFail)+#endif++import Control.Monad.Fail (MonadFail) import Data.Char+import Data.Kind (Type) import Data.Maybe import Data.String (IsString) import GHC.Exts (IsList (toList))@@ -58,6 +71,7 @@ #ifndef EMBED_DICTIONARY import Paths_seonbi (getDataDir) #endif+import Text.Seonbi.ContentTypes import Text.Seonbi.Hanja import Text.Seonbi.Html import Text.Seonbi.Punctuation@@ -71,8 +85,9 @@ data Monad m => Configuration m a = Configuration { -- | An optional debugging logger to print its internal AST. debugLogger :: Maybe (HtmlEntity -> m a)- -- | Whether to take and result in XHTML instead of HTML.- , xhtml :: Bool+ -- | A content type of the input and output. It has to be a member of+ -- 'contentTypes'.+ , contentType :: ContentType -- | An option to decide how quotation marks are rendered. -- If 'Nothing' no quotes are transformed. , quote :: Maybe QuoteOption@@ -97,7 +112,7 @@ show c = "Configuration {\n" <> " debugLogger = " <> maybe "Nothing" (const "Just ...") (debugLogger c) <> "," <>- " xhtml = " <> show (xhtml c) <> "," <>+ " contentType = " <> show (contentType c) <> "," <> " quote = " <> show (quote c) <> "," <> " arrow = " <> show (cite c) <> "," <> " cite = " <> show (arrow c) <> "," <>@@ -227,28 +242,26 @@ show initialSoundLaw <> " }" --- | Transforms a given HTML text. 'Nothing' if it fails to parse the given--- HTML text.-transformHtmlText :: Monad m => Configuration m a -> Text -> m Text+-- | Transforms a given text. 'Nothing' if it fails to parse the given+-- text.+transformHtmlText :: forall (m :: Type -> Type) a. (Monad m, MonadFail m)+ => Configuration m a -> Text -> m Text transformHtmlText config = fmap LT.toStrict . transformHtmlLazyText config . LT.fromStrict -- | A lazy version of 'transformHtmlText' function.-transformHtmlLazyText :: Monad m => Configuration m a -> LT.Text -> m LT.Text-transformHtmlLazyText config@Configuration { xhtml, debugLogger } htmlText =- case scanHtml htmlText of- Done "" input -> do- case debugLogger of- Just logger -> mapM_ logger input- Nothing -> return ()- return $ printHtml' $ toTransformer config input- _ ->- fail "failed to parse input"+transformHtmlLazyText :: forall (m :: Type -> Type) a. (Monad m, MonadFail m)+ => Configuration m a -> LT.Text -> m LT.Text+transformHtmlLazyText config@Configuration { contentType, debugLogger } =+ transformWithContentType contentType transformerM where- printHtml' :: [HtmlEntity] -> LT.Text- printHtml'- | xhtml = printXhtml- | otherwise = printHtml+ transformer :: [HtmlEntity] -> [HtmlEntity]+ transformer = toTransformer config+ transformerM = case debugLogger of+ Nothing -> return <$> transformer+ Just logger -> \ input -> do+ mapM_ logger input+ return $ transformer input toTransformers :: Monad m => Configuration m a -> [[HtmlEntity] -> [HtmlEntity]] toTransformers Configuration { quote@@ -345,7 +358,7 @@ , initialSoundLaw = True } }- , xhtml = False+ , contentType = "text/html" } -- | Preset 'Configuration' for North Korean orthography.
src/Text/Seonbi/Hanja.hs view
@@ -46,6 +46,7 @@ import Text.Seonbi.Hangul import Text.Seonbi.Html+import Text.Seonbi.Html.Lang import Text.Seonbi.Html.Preservation import Text.Seonbi.Html.TagStack (push) import qualified Text.Seonbi.Trie as Trie@@ -184,13 +185,20 @@ else Right (stack, hanj, hang) | (hanj, hang) <- Prelude.zip hanjaWords hangulWords ]- | e <- concatMap transform entities+ | e <- concatMap transform (annotateWithLang entities) ] splitByDigits :: Text -> [Text] splitByDigits = Data.Text.groupBy (\ a b -> isDigit a == isDigit b)- transform :: HtmlEntity -> [Either HtmlEntity (HtmlTagStack, Text, Text)]- transform entity@HtmlText { tagStack = tagStack', rawText = rawText' }- | isPreservedTagStack tagStack' =+ transform :: LangHtmlEntity+ -> [Either HtmlEntity (HtmlTagStack, Text, Text)]+ transform LangHtmlEntity+ { lang = lang+ , entity = entity@HtmlText+ { tagStack = tagStack'+ , rawText = rawText'+ }+ }+ | isPreservedTagStack tagStack' || isNeverKorean lang = [Left entity] | otherwise = case analyzeHanjaText rawText' of@@ -202,7 +210,7 @@ -- Note that htmlText here can have HTML entities. | (trueIfHanja, htmlText) <- pairs ]- transform entity =+ transform LangHtmlEntity { entity } = [Left entity] -- FIXME: This should be public: debugRenderer :: HanjaWordRenderer -> HanjaWordRenderer
src/Text/Seonbi/Html.hs view
@@ -10,6 +10,7 @@ -- -- | See more on "Text.Seonbi.Html.Printer" module. , printHtml+ , printText , printXhtml , -- * HTML entities --
src/Text/Seonbi/Html/Entity.hs view
@@ -8,6 +8,7 @@ import Text.Seonbi.Html.Tag (HtmlTag) import Text.Seonbi.Html.TagStack (HtmlTagStack) +-- | All element attributes in a string. type HtmlRawAttrs = Text -- | An event entity emitted by 'scanHtml'.
+ src/Text/Seonbi/Html/Lang.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.Seonbi.Html.Lang+ ( LangHtmlEntity (..)+ , LanguageTag+ , annotateWithLang+ , extractLang+ , isKorean+ , isNeverKorean+ ) where++import Control.Applicative+import Data.Char (isSpace)+import Data.Maybe++import Data.Attoparsec.Text+import Data.Text++import Text.Seonbi.Html.Entity+import Text.Seonbi.Html.Tag (HtmlTag)++-- | Represents a language tag. Although it is defined as an alias for 'Text',+-- it can be structured in the future. Do not use its contents directly.+type LanguageTag = Text++-- | Extracts the language tag from the given raw HTML attributes if it has+-- @lang@ attribute.+--+-- >>> extractLang ""+-- Nothing+-- >>> extractLang "lang=en"+-- Just "en"+-- >>> extractLang "lang=\"ko-KR\""+-- Just "ko-kr"+-- >>> extractLang " lang='ko-Hang'"+-- Just "ko-hang"+extractLang+ :: HtmlRawAttrs+ -- ^ A raw HTML attributes to extract the language tag from.+ -> Maybe LanguageTag+ -- ^ A language tag extracted from the given raw HTML attributes.+ -- If the given raw HTML attributes does not have @lang@ attribute or+ -- its value is invalid, 'Nothing' is returned.+extractLang attrs =+ case parseOnly parser' attrs of+ Right (Just lang') ->+ let lt = toLower . strip . normalizeEntities $ lang'+ in if Data.Text.null lt then Nothing else Just lt+ _ -> Nothing+ where+ parser' :: Parser (Maybe Text)+ parser' = do+ skipSpace+ attrs' <- langAttr `sepBy` space+ skipSpace+ return $ listToMaybe $ catMaybes attrs'+ langAttr :: Parser (Maybe Text)+ langAttr = do+ (isLang, cont) <- attrIsLang+ value <- if cont then attrValue else return ""+ return (if isLang then Just value else Nothing)+ attrIsLang :: Parser (Bool, Bool)+ attrIsLang = choice+ [ asciiCI "lang=" >> return (True, True)+ , do { _ <- takeWhile1 (/= '=')+ ; eq <- optional (char '=')+ ; return (False, isJust eq)+ }+ ]+ attrValue :: Parser Text+ attrValue = choice+ [ do { skip (== '"'); v <- takeTill (== '"'); skip (== '"'); return v }+ , do { skip (== '\'')+ ; v <- takeTill (== '\'')+ ; skip (== '\''); return v+ }+ , takeWhile1 (not . isSpace)+ ]+ normalizeEntities :: Text -> Text+ normalizeEntities+ = Data.Text.replace "‐" "-"+ . Data.Text.replace "‐" "-"+ . Data.Text.replace "‐" "-"+ . Data.Text.replace "‐" "-"+ . Data.Text.replace "‐" "-"++-- | Annotates 'HtmlEntity' with the 'lang' tag extracted from it or its+-- ancestors.+data LangHtmlEntity = LangHtmlEntity+ { -- | The @lang@ tag extracted from the HTML 'entity' or its ancestors.+ lang :: Maybe LanguageTag+ -- | The annotated HTML 'entity'.+ , entity :: HtmlEntity+ } deriving (Show, Eq)++-- | Annotates the given HTML entities with the language tag extracted from+-- their @lang@ attributes. If a parent entity has @lang@ attribute, its+-- all descendants are annotated with the same language tag.+annotateWithLang :: [HtmlEntity] -> [LangHtmlEntity]+annotateWithLang =+ annotate []+ where+ annotate :: [(HtmlTag, Maybe LanguageTag)]+ -> [HtmlEntity]+ -> [LangHtmlEntity]+ annotate _ [] = []+ annotate stack (x@HtmlStartTag { tag = tag', rawAttributes = attrs } : xs) =+ LangHtmlEntity thisLang x : annotate nextStack xs+ where+ parentLang :: Maybe LanguageTag+ parentLang = case stack of+ (_, l):_ -> l+ _ -> Nothing+ thisLang :: Maybe LanguageTag+ thisLang = extractLang attrs <|> parentLang+ nextStack :: [(HtmlTag, Maybe LanguageTag)]+ nextStack = (tag', thisLang) : stack+ annotate stack (x@HtmlEndTag { tag = tag' } : xs) =+ LangHtmlEntity thisLang x : annotate nextStack xs+ where+ (nextStack, thisLang) = case stack of+ [] -> ([], Nothing)+ s@((t, lang'):ys) ->+ (if t == tag' then ys else s, lang')+ annotate stack (x : xs) =+ LangHtmlEntity parentLang x : annotate stack xs+ where+ parentLang :: Maybe LanguageTag+ parentLang = case stack of+ (_, l):_ -> l+ _ -> Nothing++-- | Determines whether the given language tag refers to any kind of Korean.+--+-- >>> isKorean "ko"+-- True+-- >>> isKorean "ko-KR"+-- True+-- >>> isKorean "kor-Hang"+-- True+-- >>> isKorean "en"+-- False+-- >>> isKorean "en-KR"+-- False+isKorean :: LanguageTag -> Bool+isKorean lang' =+ l == "ko" || l == "kor" ||+ "ko-" `isPrefixOf` l ||+ "kor-" `isPrefixOf` l+ where+ l :: Text+ l = toLower lang'++-- | Determines whether the given language tag undoubtedly does not refer+-- to any kind of Korean.+--+-- >>> isNeverKorean $ Just "ko"+-- False+-- >>> isNeverKorean $ Just "ko-KR"+-- False+-- >>> isNeverKorean Nothing+-- False+-- >>> isNeverKorean $ Just "en"+-- True+isNeverKorean :: Maybe LanguageTag -> Bool+isNeverKorean Nothing = False+isNeverKorean (Just lang') = not (isKorean lang')
src/Text/Seonbi/Html/Printer.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Text.Seonbi.Html.Printer ( printHtml+ , printText , printXhtml ) where @@ -9,14 +11,19 @@ import qualified Data.Text import Data.Text.Lazy+import Data.Text.Lazy.Builder+import HTMLEntities.Decoder import Text.Seonbi.Html.Entity import Text.Seonbi.Html.Tag --- | Print the list of 'HtmlEntity' into a lazy 'Text'.---+-- $setup -- >>> :set -XOverloadedStrings -- >>> import Text.Seonbi.Html.Scanner+-- >>> :set -interactive-print=Text.Show.Unicode.uprint++-- | Print the list of 'HtmlEntity' into a lazy 'Text'.+-- -- >>> let Done "" tokens = scanHtml "<p>Hello,<br>\n<em>world</em>!</p>" -- >>> printHtml tokens -- "<p>Hello,<br>\n<em>world</em>!</p>"@@ -26,8 +33,6 @@ -- | Similar to 'printHtml' except it renders void (self-closing) tags as -- like @<br/>@ instead of @<br>@. ----- >>> :set -XOverloadedStrings--- >>> import Text.Seonbi.Html.Scanner -- >>> let Done "" tokens = scanHtml "<p>Hello,<br>\n<em>world</em>!</p>" -- >>> printXhtml tokens -- "<p>Hello,<br/>\n<em>world</em>!</p>"@@ -72,3 +77,26 @@ renderAttrs attrs | isSpace (Data.Text.head attrs) = fromStrict attrs | otherwise = ' ' `cons` fromStrict attrs++-- | Print only the text contents (including CDATA sections) without tags+-- into a lazy 'Text'.+--+-- >>> let Done "" tokens = scanHtml "<p>Hello,<br>\n<em>world</em>!</p>"+-- >>> printText tokens+-- "Hello,\nworld!"+--+-- Entities are decoded:+--+-- >>> let Done "" tokens = scanHtml "<p><code><>"&</code></p>"+-- >>> printText tokens+-- "<>\"&"+printText :: [HtmlEntity] -> Text+printText [] = Data.Text.Lazy.empty+printText (x:xs) =+ render x <> printText xs+ where+ render :: HtmlEntity -> Text+ render = \ case+ HtmlText { rawText = t } -> toLazyText $ htmlEncodedText t+ HtmlCdata { text = t } -> fromStrict t+ _ -> Data.Text.Lazy.empty
src/Text/Seonbi/Html/Tag.hs view
@@ -2,12 +2,16 @@ module Text.Seonbi.Html.Tag ( HtmlTag (..) , HtmlTagKind (..)+ , headingLevel+ , headingTag+ , headingTag' , htmlTagKind , htmlTagName , htmlTagNames , htmlTags ) where +import Data.Maybe import Data.Map.Strict import Data.Set import Data.Text@@ -206,7 +210,7 @@ [(htmlTagName t, t) | t <- Data.Set.toList htmlTags] -- | The kind of an 'HtmlTag'.--- +-- -- >>> Data.Set.filter ((== EscapableRawText) . htmlTagKind) htmlTags -- fromList [TextArea,Title] htmlTagKind :: HtmlTag -> HtmlTagKind@@ -325,3 +329,57 @@ Var -> Normal Video -> Normal WBR -> Void++-- | Get the heading level of an 'HtmlTag', if it is a heading tag+-- ('H1' to 'H6').+--+-- >>> headingLevel H1+-- Just 1+-- >>> headingLevel H6+-- Just 6+-- >>> headingLevel P+-- Nothing+headingLevel :: HtmlTag -> Maybe Int+headingLevel = \ case+ H1 -> Just 1+ H2 -> Just 2+ H3 -> Just 3+ H4 -> Just 4+ H5 -> Just 5+ H6 -> Just 6+ _ -> Nothing++-- | Get the heading tag with the given heading level. If the level is+-- invalid, then 'Nothing' is returned.+--+-- >>> headingTag 1+-- Just H1+-- >>> headingTag 6+-- Just H6+-- >>> headingTag 7+-- Nothing+headingTag :: Int -> Maybe HtmlTag+headingTag = \ case+ 1 -> Just H1+ 2 -> Just H2+ 3 -> Just H3+ 4 -> Just H4+ 5 -> Just H5+ 6 -> Just H6+ _ -> Nothing++-- | Get the heading tag with the given heading level. If the level is+-- greater than 6, then 'H6' is returned. If the level is less than 1,+-- then 'H1' is returned.+--+-- >>> headingTag' 1+-- H1+-- >>> headingTag' 6+-- H6+-- >>> headingTag' 0+-- H1+-- >>> headingTag' 7+-- H6+headingTag' :: Int -> HtmlTag+headingTag' level =+ fromMaybe (if level > 6 then H6 else H1) $ headingTag level
src/Text/Seonbi/Html/TagStack.hs view
@@ -7,13 +7,16 @@ , depth , empty , fromList+ , last , pop , push , rebase , toList ) where -import Data.List+import Prelude hiding (last)++import Data.List hiding (last) import GHC.Exts (IsList (..)) import Text.Seonbi.Html.Tag@@ -50,6 +53,18 @@ depth :: HtmlTagStack -> Int depth (HtmlTagStack stack) = Data.List.length stack +-- | Get the deepest tag from a 'HtmlTagStack'.+--+-- >>> :set -XOverloadedLists+-- >>> let stack = [Div, Article, P, Em] :: HtmlTagStack+-- >>> last stack+-- Just Em+-- >>> last []+-- Nothing+last :: HtmlTagStack -> Maybe HtmlTag+last (HtmlTagStack []) = Nothing+last (HtmlTagStack (tag:_)) = Just tag+ -- | Build a new stack from a stack by replacing its bottom with a new base. -- -- >>> :set -XOverloadedLists@@ -107,7 +122,7 @@ HtmlTagStack (head' ++ tail') pop _ (HtmlTagStack []) = empty --- | Check if a node ('HtmlEntity') that a 'HtmlTagStack' (the first argument) +-- | Check if a node ('HtmlEntity') that a 'HtmlTagStack' (the first argument) -- refers is contained by a node that another 'HtmlTagStack' (the second -- argument), or they are sibling at least. --
src/Text/Seonbi/Punctuation.hs view
@@ -51,6 +51,7 @@ import Text.Seonbi.Html import Text.Seonbi.Html.Clipper+import Text.Seonbi.Html.Lang import Text.Seonbi.Html.Preservation import Text.Seonbi.Html.Wrapper import Text.Seonbi.PairedTransformer@@ -295,14 +296,18 @@ -- | Normalizes sentence stops (periods, commas, and interpuncts). normalizeStops :: Stops -> [HtmlEntity] -> [HtmlEntity]-normalizeStops stops input = (`fmap` normalizeText input) $ \ case- e@HtmlText { tagStack = stack, rawText = txt } ->- if isPreservedTagStack stack+normalizeStops stops input = (`fmap` annotatedEntities) $ \ case+ LangHtmlEntity { lang = l+ , entity = e@HtmlText { tagStack = stack, rawText = txt }+ } ->+ if isPreservedTagStack stack || isNeverKorean l then e else e { rawText = replaceText txt }- e ->+ LangHtmlEntity { entity = e } -> e where+ annotatedEntities :: [LangHtmlEntity]+ annotatedEntities = (annotateWithLang . normalizeText) input replaceText :: Text -> Text replaceText txt = case parseOnly parser txt of
src/Text/Seonbi/Trie.hs view
@@ -1,17 +1,148 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-}--- | This re-exports 'Data.Trie.Text'.+-- | A trie from 'Text' keys to values. module Text.Seonbi.Trie- ( module Data.Trie.Text+ ( Trie+ , elems+ , empty+ , fromList+ , insert+ , keys+ , lookup+ , member+ , mergeBy+ , null+ , singleton+ , size+ , toList+ , unionL+ , unionR ) where -import GHC.Exts+import Prelude hiding (lookup, null) -import Data.Text-import Data.Text.Lazy (toStrict)-import Data.Trie.Text+import Control.Monad (ap)+import qualified GHC.Exts -instance IsList (Trie a) where+import Data.ByteString (ByteString)+import Data.Text hiding (empty, null, singleton)+import Data.Text.Encoding (encodeUtf8, decodeUtf8)+import qualified Data.Trie as BTrie++-- | A trie from 'Text' keys to 'a' values.+newtype Trie a+ = Trie (BTrie.Trie a)+ deriving (Eq, Show)++encodeKey :: Text -> ByteString+encodeKey = encodeUtf8++decodeKey :: ByteString -> Text+decodeKey = decodeUtf8++-- | The empty trie.+empty :: Trie a+empty = Trie BTrie.empty++-- | Checks if the trie is empty.+null :: Trie a -> Bool+null (Trie btrie) = BTrie.null btrie++-- | Constructs a singleton trie.+singleton :: Text -> a -> Trie a+singleton key value = Trie $ BTrie.singleton (encodeKey key) value++-- | Gets the number of elements in the trie.+size :: Trie a -> Int+size (Trie btrie) = BTrie.size btrie++fromList' :: [(Text, a)] -> Trie a+fromList' list = Trie $ BTrie.fromList [(encodeKey k, v) | (k, v) <- list]++toList' :: Trie a -> [(Text, a)]+toList' (Trie btrie) = [(decodeKey k, v) | (k, v) <- BTrie.toList btrie]++-- | Converts a list of associated pairs into a trie. For duplicate keys,+-- values earlier in the list shadow later ones.+fromList :: [(Text, a)] -> Trie a+fromList = fromList'++-- | Converts a trie into a list of associated pairs. Keys will be ordered.+toList :: Trie a -> [(Text, a)]+toList = toList'++-- | Lists all keys in the trie. Keys will be ordered.+keys :: Trie a -> [Text]+keys (Trie btrie) = Prelude.map decodeKey $ BTrie.keys btrie++-- | Lists all values in the trie. Values are ordered by their associated keys.+elems :: Trie a -> [a]+elems (Trie btrie) = BTrie.elems btrie++-- | Gets the value associated with a key if it exists.+lookup :: Text -> Trie a -> Maybe a+lookup key (Trie btrie) = BTrie.lookup (encodeKey key) btrie++-- | Checks if a key has a value in the trie.+member :: Text -> Trie a -> Bool+member key (Trie btrie) = BTrie.member (encodeKey key) btrie++-- | Inserts a new key into the trie.+insert+ :: Text+ -- ^ A new key to insert. If there is already the same key in the trie,+ -- the existing value is overwritten by the new value.+ -> a+ -- ^ A value associated to the key.+ -> Trie a+ -- ^ An existing trie.+ -> Trie a+ -- ^ The new trie with the inserted key.+insert key value (Trie btrie) = Trie $ BTrie.insert (encodeKey key) value btrie++-- | Combines two tries, using a function to resolve collisions. This can only+-- define the space of functions between union and symmetric difference but,+-- with those two, all set operations can be defined (albeit inefficiently).+mergeBy :: (a -> a -> Maybe a) -> Trie a -> Trie a -> Trie a+mergeBy f (Trie a) (Trie b) = Trie $ BTrie.mergeBy f a b++-- | Combines two tries, resolving conflicts by choosing the value from the+-- left (former) trie.+unionL :: Trie a -> Trie a -> Trie a+unionL (Trie left) (Trie right) = Trie $ BTrie.unionL left right++-- | Combines two tries, resolving conflicts by choosing the value from the+-- right (latter) trie.+unionR :: Trie a -> Trie a -> Trie a+unionR (Trie left) (Trie right) = Trie $ BTrie.unionR left right++instance Functor Trie where+ fmap f (Trie btrie) = Trie $ fmap f btrie++instance Foldable Trie where+ foldMap f (Trie btrie) = foldMap f btrie++instance Traversable Trie where+ traverse f (Trie btrie) = Trie <$> traverse f btrie++instance Applicative Trie where+ pure = return+ (<*>) = ap++instance Monad Trie where+ return = singleton ""+ Trie btrie >>= f = Trie $ btrie >>= (\ v -> case f v of { Trie b -> b })++instance (Semigroup a) => Semigroup (Trie a) where+ (Trie a) <> (Trie b) = Trie (a <> b)++instance (Monoid a) => Monoid (Trie a) where+ mempty = Trie mempty+ mappend (Trie a) (Trie b) = Trie $ mappend a b++instance GHC.Exts.IsList (Trie a) where type Item (Trie a) = (Text, a)- fromList = Data.Trie.Text.fromList- toList trie = [(toStrict k, v) | (k, v) <- Data.Trie.Text.toList trie]+ fromList = fromList'+ toList = toList'
+ test/Text/Seonbi/ContentTypesSpec.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.Seonbi.ContentTypesSpec (spec) where++import Data.Text+import qualified Data.Text.Lazy as LT+import Data.Text.Lazy.Builder++import Test.Hspec++import Text.Seonbi.Html+import Text.Seonbi.ContentTypes+import qualified HTMLEntities.Builder+import HTMLEntities.Decoder++textReverser :: (Monad m, MonadFail m) => HtmlTransformer m+textReverser entities =+ return $ reverseText <$> entities+ where+ reverseText :: HtmlEntity -> HtmlEntity+ reverseText e@HtmlText { rawText = t } =+ e { rawText = encode $ Data.Text.reverse $ decode t }+ reverseText e@HtmlCdata { text = t } =+ e { text = Data.Text.reverse t }+ reverseText e =+ e+ decode :: Text -> Text+ decode = LT.toStrict . toLazyText . htmlEncodedText+ encode :: Text -> Text+ encode = LT.toStrict . toLazyText . HTMLEntities.Builder.text++spec :: Spec+spec = do+ specify "asHtmlTransformer" $ do+ r <- asHtmlTransformer textReverser "<p>foo <em>bar</em><br> baz</p>"+ r `shouldBe` "<p> oof<em>rab</em><br>zab </p>"+ specify "asXhtmlTransformer" $ do+ r <- asXhtmlTransformer textReverser "<p>foo <em>bar</em><br> baz</p>"+ r `shouldBe` "<p> oof<em>rab</em><br/>zab </p>"+ specify "asPlainTextTransformer" $ do+ r <- asPlainTextTransformer textReverser+ "<p>foo <em>bar</em><br> baz</p>"+ r `shouldBe` ">p/<zab >rb<>me/<rab>me< oof>p<"+ specify "asCommonMarkTransformer" $ do+ r <- asCommonMarkTransformer textReverser+ "# Foo\n\nBar *Baz*\nQux\n\n> Quote <em>tag</em>\n"+ r `shouldBe` "# ooF\n\n raB*zaB*\nxuQ\n\n> etouQ<em>gat</em>\n"+ specify "transformWithContentType" $ do+ let input = "*foo* <em>bar</em><br>"+ h <- transformWithContentType "text/html" textReverser input+ h `shouldBe` " *oof*<em>rab</em><br>"+ x <- transformWithContentType "application/xhtml+xml" textReverser input+ x `shouldBe` " *oof*<em>rab</em><br/>"+ p <- transformWithContentType "text/plain" textReverser input+ p `shouldBe` ">rb<>me/<rab>me< *oof*"+ m <- transformWithContentType "text/markdown" textReverser input+ m `shouldBe` "*oof* <em>rab</em><br>\n"
test/Text/Seonbi/FacadeSpec.hs view
@@ -25,7 +25,7 @@ , (".ko-KP.html", ko_KP) ] -shouldHaveSameText :: (HasCallStack) => Text -> Text -> Expectation+shouldHaveSameText :: HasCallStack => Text -> Text -> Expectation actual `shouldHaveSameText` expected = unless (actual == expected) (expectationFailure msg) where@@ -79,6 +79,6 @@ , emDash = False , stop = Nothing , hanja = Nothing- , xhtml = False+ , contentType = "text/html" , debugLogger = Nothing }
test/Text/Seonbi/HangulSpec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} module Text.Seonbi.HangulSpec (spec) where
test/Text/Seonbi/HanjaSpec.hs view
@@ -302,6 +302,33 @@ let phone = normalizeText . phoneticizeHanja def phone [HtmlText [Pre] "1996年 그들이 地球를 支配했을 때"] `shouldBe` [HtmlText [Pre] "1996年 그들이 地球를 支配했을 때"]+ it "transforms nothing in non-Korean elements" $ do+ let phone = normalizeText . phoneticizeHanja def+ let input =+ [ HtmlStartTag [] P ""+ , HtmlText [P] "2004年 開封한 日本 映畫 "+ , HtmlStartTag [P] Span "lang=\"ja\""+ , HtmlText [P, Span] "誰も知らない"+ , HtmlEndTag [P] Span+ , HtmlText [P] "는 이듬해 韓國에서도 "+ , HtmlStartTag [P] Span "lang=ko-Hang"+ , HtmlText [P, Span] "아무도 모른다"+ , HtmlEndTag [P] Span+ , HtmlText [P] "라는 題目으로 開封했다."+ ]+ let output =+ [ HtmlStartTag [] P ""+ , HtmlText [P] "2004년 개봉한 일본 영화 "+ , HtmlStartTag [P] Span "lang=\"ja\""+ , HtmlText [P, Span] "誰も知らない"+ , HtmlEndTag [P] Span+ , HtmlText [P] "는 이듬해 한국에서도 "+ , HtmlStartTag [P] Span "lang=ko-Hang"+ , HtmlText [P, Span] "아무도 모른다"+ , HtmlEndTag [P] Span+ , HtmlText [P] "라는 제목으로 개봉했다."+ ]+ phone input `shouldBe` output describe "convertInitialSoundLaw" $ do specify "녀, 뇨, 뉴, 니 should be 여, 요, 유, 이" $ do convertInitialSoundLaw '녀' `shouldBe` '여'
+ test/Text/Seonbi/Html/LangSpec.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+module Text.Seonbi.Html.LangSpec (spec) where++import Test.Hspec++import Text.Seonbi.Html+import Text.Seonbi.Html.Lang++source :: [HtmlEntity]+source =+ [ HtmlStartTag+ { tagStack = []+ , tag = P+ , rawAttributes = "id=\"foo\" lang=\"en\""+ }+ , HtmlText { tagStack = [P], rawText = "English" }+ , HtmlEndTag { tagStack = [], tag = P }+ , HtmlStartTag { tagStack = [], tag = Div, rawAttributes = "" }+ , HtmlStartTag+ { tagStack = [Div]+ , tag = P+ , rawAttributes = "class=bar lang=ja"+ }+ , HtmlStartTag { tagStack = [Div, P], tag = B, rawAttributes = "" }+ , HtmlText { tagStack = [Div, P, B], rawText = "日本語" }+ , HtmlEndTag { tagStack = [Div, P], tag = B }+ , HtmlStartTag+ { tagStack = [Div, P]+ , tag = Span+ , rawAttributes = "lang='yue-Hant'"+ }+ , HtmlText { tagStack = [Div, P, Span], rawText = "與" }+ , HtmlStartTag { tagStack = [Div, P, Span], tag = B, rawAttributes = "" }+ , HtmlText { tagStack = [Div, P, Span, B], rawText = "與粵語" }+ , HtmlEndTag { tagStack = [Div, P, Span], tag = B }+ , HtmlEndTag { tagStack = [Div, P], tag = Span }+ , HtmlEndTag { tagStack = [Div], tag = P }+ , HtmlEndTag { tagStack = [], tag = Div }+ ]++annotated :: [LangHtmlEntity]+annotated =+ [ LangHtmlEntity+ (Just "en")+ HtmlStartTag+ { tagStack = []+ , tag = P+ , rawAttributes = "id=\"foo\" lang=\"en\""+ }+ , LangHtmlEntity+ (Just "en")+ HtmlText { tagStack = [P], rawText = "English" }+ , LangHtmlEntity (Just "en") HtmlEndTag { tagStack = [], tag = P }+ , LangHtmlEntity+ Nothing+ HtmlStartTag { tagStack = [], tag = Div, rawAttributes = "" }+ , LangHtmlEntity+ (Just "ja")+ HtmlStartTag+ { tagStack = [Div]+ , tag = P+ , rawAttributes = "class=bar lang=ja"+ }+ , LangHtmlEntity+ (Just "ja")+ HtmlStartTag { tagStack = [Div, P], tag = B, rawAttributes = "" }+ , LangHtmlEntity+ (Just "ja")+ HtmlText { tagStack = [Div, P, B], rawText = "日本語" }+ , LangHtmlEntity (Just "ja") HtmlEndTag { tagStack = [Div, P], tag = B }+ , LangHtmlEntity+ (Just "yue-hant")+ HtmlStartTag+ { tagStack = [Div, P]+ , tag = Span+ , rawAttributes = "lang='yue-Hant'"+ }+ , LangHtmlEntity+ (Just "yue-hant")+ HtmlText { tagStack = [Div, P, Span], rawText = "與" }+ , LangHtmlEntity+ (Just "yue-hant")+ HtmlStartTag { tagStack = [Div, P, Span], tag = B, rawAttributes = "" }+ , LangHtmlEntity+ (Just "yue-hant")+ HtmlText { tagStack = [Div, P, Span, B], rawText = "與粵語" }+ , LangHtmlEntity+ (Just "yue-hant")+ HtmlEndTag { tagStack = [Div, P, Span], tag = B }+ , LangHtmlEntity+ (Just "yue-hant")+ HtmlEndTag { tagStack = [Div, P], tag = Span }+ , LangHtmlEntity (Just "ja") HtmlEndTag { tagStack = [Div] , tag = P }+ , LangHtmlEntity Nothing HtmlEndTag { tagStack = [], tag = Div }+ ]++spec :: Spec+spec = do+ specify "extractLang" $ do+ extractLang "" `shouldBe` Nothing+ extractLang "lang=en" `shouldBe` Just "en"+ extractLang "lang=en-US" `shouldBe` Just "en-us"+ extractLang "lang='ko-KR'" `shouldBe` Just "ko-kr"+ extractLang "lang=\"zh-Hant\"" `shouldBe` Just "zh-hant"+ extractLang "lang=\"yue-Hans-HK\"" `shouldBe` Just "yue-hans-hk"+ extractLang "id=\"foo\" lang=\"en\"" `shouldBe` Just "en"+ extractLang "id=\"foo\" lang=zh-CN class=bar" `shouldBe` Just "zh-cn"+ specify "annotateWithLang" $ do+ annotateWithLang [] `shouldBe` []+ annotateWithLang source `shouldBe` annotated
test/Text/Seonbi/PunctuationSpec.hs view
@@ -535,3 +535,20 @@ , HtmlEndTag [P] Span , HtmlEndTag [] P ]+ it "does not touch inside non-Korean contents" $ do+ let input =+ [ HtmlStartTag [] P ""+ , HtmlText [P] "《大學》의 「三綱領」에 다음과 같은 말이 나온다。"+ , HtmlEndTag [] P+ , HtmlStartTag [] BlockQuote "lang=lzh"+ , HtmlText [BlockQuote] "大學之道，在明明德，在親民，在止於至善。"+ , HtmlEndTag [] BlockQuote+ ] :: [HtmlEntity]+ normalizeStops horizontalStops input `shouldBe`+ [ HtmlStartTag [] P ""+ , HtmlText [P] "《大學》의 「三綱領」에 다음과 같은 말이 나온다."+ , HtmlEndTag [] P+ , HtmlStartTag [] BlockQuote "lang=lzh"+ , HtmlText [BlockQuote] "大學之道，在明明德，在親民，在止於至善。"+ , HtmlEndTag [] BlockQuote+ ]
test/doctest.hs view
@@ -1,1 +1,15 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 810+main :: IO ()+main = do+ putStrLn "Temporarily, doctests are ignored for GHC >= 8.10 due to bugs:\n"+ putStrLn " https://github.com/sol/doctest/issues/301"+#elif __GLASGOW_HASKELL__ >= 808 && defined(mingw32_HOST_OS)+main :: IO ()+main = do+ putStr "Temporarily, doctests are ignored for GHC >= 8.8 on Windows "+ putStrLn "due to bugs:\n"+ putStrLn " https://github.com/sol/doctest/issues/300"+#else {-# OPTIONS_GHC -F -pgmF doctest-discover -optF test/doctest.json #-}+#endif