diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -9,139 +9,6 @@ [compressed versions](https://github.com/pharpend/eros/tree/master/res/phraselists-ugly) for use in your code. -Eros is still in development, and is not ready to be actually used. If you would -like to contribute, please do. - -You can try the -[API documentation on Hackage](http://hackage.haskell.org/package/eros) if you -want to learn how to use the library. Hackage isn't terribly reliable at -successfully building the documentation, so I also publish the documentation on -[GitHub pages](https://pharpend.github.io/eros-haddock) - -# Usage - v.0.5.2.0 - -This is a usage guide for version 0.5.2.0. There will be more up-to-date usage -guides as more versions come, hopefully. - -To install, add `eros >=0.5 && <0.6` to the `build-depends` field in your -library's `.cabal` file - -You can get all the functions, simply by `import`ing `Text.Eros`. - -Hackage seems to be unable to build the API documentation for Eros, but it won't -hurt to check [eros on Hackage](http://hackage.haskell.org/package/eros). If -that doesn't work, I publish the documentation -[here](https://pharpend.github.io/eros-haddock). - -## Using `Text.Eros` - -The basic idea is you take a `Message` type, and check it against a `PhraseMap`, -using `messageScore`. `Message` is actually just a type alias for `Tl.Text`, so -just enable the `OverloadedStrings` extension, and pretend you're using normal -strings. - -In GHCi, - -`:set -XOverloadedStrings` - -`import Text.Eros` - -In a file, - -``` {.haskell} - {-# LANGUAGE OverloadedStrings #-} - import Text.Eros -``` - -### Constructing `PhraseMap`s - -A `PhraseMap` is just a `Phraselist` marshaled into the more Haskell-friendly -`Ms.Map` type. - -Eros provides a large number of `Phraselist`s. - -``` {.haskell} - data ErosList = Chat - | Conspiracy - | DrugAdvocacy - | Forums - | Gambling - | Games - | Gore - | IdTheft - | IllegalDrugs - | Intolerance - | LegalDrugs - | Malware - | Music - | News - | Nudism - | Peer2Peer - | Personals - | Pornography - | Proxies - | SecretSocieties - | SelfLabeling - | Sport - | Translation - | UpstreamFilter - | Violence - | WarezHacking - | Weapons - | Webmail - deriving (Eq) -``` - -The easiest way to marshal a `Phraselist` into a `PhraseMap` is to use the -`readPhraseMap` function. - -``` {.haskell} - readPhraseMap :: Phraselist t => t -> IO PhraseMap -``` - -Use it like this - -`pornMap <- readPhraseMap Pornography` -`30` - -Internally, `readPhraseMap` reads JSON data containing the `Phraselist`, -marshals it into a list of `PhraseAlmostTree`s, converts those into a -`PhraseForsest`, and then into a `PhraseMap`. - -You can obviously use `mkMap` and `readPhraselist` to do it yourself, but it's a -lot easier to just use `readPhraseMap`. - -You can then use `messageScore` to see the `Score` (actually an `Int`) of each -message. - -`messageScore "Go fuck yourself." pornMap` - -`messageScore` is not case sensitive, so `go fUck YoUrself` returns the same -score as `go fuck yourself`, and so on. - -If you want to use multiple eros lists, do something like this - -`let myLists = [Chat, Pornography, Weapons]` - -`myMaps <- mapM readPhraseMap myLists` - -`map (messageScore "Go fuck yourself") myMaps` -`[0, 30, 0]` - -### Using your own phraselists - -I haven't added *good* support in for this yet, but there still is support -nonetheless. Your phraselist needs to be in JSON, in accordance with the -Phraselist schema (I'm too lazy to find a link to it). - -``` {.haskell} - data MyList = MyList - instance Phraselist MyList where - phraselistPath MyList = "/path/to/phraselist" -``` - -You can then do the normal stuff with `messageScore` and `readPhraseMap`. - # Contributing I would love if people would contribute. QuickCheck tests are desperately diff --git a/eros.cabal b/eros.cabal --- a/eros.cabal +++ b/eros.cabal @@ -1,16 +1,19 @@ name: eros -version: 0.5.3.2 +version: 0.6.0.0 synopsis: A text censorship library. description: A Haskell library for censoring text, using . - + . I converted the phraselists into JSON. You can view the converted phraselists . - + . I recommend looking at the API documentation for 'Text.Eros' if you want an - idea of how to use the library. I publish the documentation - . + idea of how to use the library. + . + Changelog + . + [0.6] - Fixed algorithm, added "flat score" for zero-depth message score. license: BSD3 license-file: LICENSE diff --git a/src/Text/Eros/Message.hs b/src/Text/Eros/Message.hs --- a/src/Text/Eros/Message.hs +++ b/src/Text/Eros/Message.hs @@ -1,17 +1,19 @@ --- | --- Module : Text.Eros.Message --- Description : Module for censoring pieces of text. --- Copyright : 2014, Peter Harpending --- License : BSD3 --- Maintainer : Peter Harpending --- Stability : experimental --- Portability : archlinux +{- | +Module : Text.Eros.Message +Description : Module for censoring pieces of text. +Copyright : 2014, Peter Harpending +License : BSD3 +Maintainer : Peter Harpending +Stability : experimental +Portability : archlinux --- This module deals specifically with pieces of 'Text'. +This module deals specifically with pieces of Text. +-} module Text.Eros.Message where -- Here, we have all the imports. +import Control.Applicative import Data.List import qualified Data.Map.Strict as M import qualified Data.Text.Lazy as L @@ -22,40 +24,79 @@ -- |I can never remember what I named things, so here are a bunch of -- type synonyms. -type BadWord = L.Text -type Message = L.Text -type MessagePart = L.Text -type Restof = L.Text -type RestOf = L.Text -type Word = L.Text -type Score = Int +type BadWord = L.Text +type Message = L.Text +type MessagePart = L.Text +type Multiplicity = Int +type Restof = L.Text +type RestOf = L.Text +type Word = L.Text +type Score = Int +type SubMap = PhraseMap --- |Does a top-level split of a 'Message'. Returns a list of pairs, --- with the first element being the score up to that point in the --- message, as well as the rest of the message. That gives you --- somewhat of an idea how it works, but that's not quite it -messageSplit :: Message -> PhraseMap -> [(Score, RestOf)] -messageSplit initialText sayingsMap = concat $ filter (/= []) - $ nub - $ map breakSaying potentialSayings +-- |Given a message, get all the bad words in the message, along with +-- the rest of the message +badWordsRestof :: Message -> PhraseMap -> [(BadWord, Restof)] +badWordsRestof msg pmap = concat keyLists + where lowerMsg = L.toLower msg + mapKeys = M.keys pmap + keyLists = [ brokenKeys + | key <- mapKeys + , let keyTuples = L.breakOnAll key lowerMsg + restOfs = map snd keyTuples + brokenKeys = map (L.splitAt (L.length key)) restOfs + , keyTuples /= [] + ] + +-- |Given a message, get all the bad words in the message, along with +-- their multiplicity. +badWordMults :: Message -> PhraseMap -> M.Map BadWord Multiplicity +badWordMults msg pmap = M.fromList keysInMsg where - potentialSayings = M.keys sayingsMap - breakSaying saying = map (trimSaying saying . snd) $ broked saying - trimSaying saying txt = (sayScore saying, L.strip $ L.drop (L.length saying) txt) - sayScore saying = case maybeScore saying of - Just score -> score - Nothing -> 0 - maybeScore saying = fmap score $ fmap rootLabel $ M.lookup saying sayingsMap - broked saying = L.breakOnAll saying lowerText -- looks like [("go ", "fuck yourself ")] - lowerText = L.toLower initialText -- looks like "go fuck yourself" (compared to "gO fUcK yOURSelf") - trimPair (a, b) = (L.strip a, L.strip b) -- looks like ("go", "fuck yourself") + keysInMsg = [ brokenKeyPairs + | key <- mapKeys + , let keyTuples = L.breakOnAll key lowerMsg + restOfs = map snd keyTuples + brokenKeys = map (L.take (L.length key)) restOfs + brokenKeyPairs = (head brokenKeys, length brokenKeys) + , keyTuples /= [] + ] + lowerMsg = L.toLower msg + mapKeys = M.keys pmap --- |Given a message, find its score. +-- |Message score flat - no-depth score +messageScore_ :: Message -> PhraseMap -> Score +messageScore_ msg pmap = sum [ (getBadWordScore badwd pmap) * mult + | (badwd, mult) <- M.toList $ badWordMults msg pmap + ] + +getBadWordScore :: BadWord -> PhraseMap -> Score +getBadWordScore badwd pmap = case maybeScore of + Just sc -> sc + Nothing -> 0 + where maybeScore = score <$> rootLabel <$> M.lookup badwd pmap + +getBadWordSubMap :: BadWord -> PhraseMap -> SubMap +getBadWordSubMap badwd pmap = case maybeSubMap of + Just mp -> mp + Nothing -> M.empty + where maybeSubMap = mkMap <$> subForest <$> M.lookup badwd pmap + +badWordsRestofScoreSubm :: Message -> PhraseMap -> [(BadWord, Restof, Score, SubMap)] +badWordsRestofScoreSubm msg pmap = [ (bdwd, rstof, bws, sbm) + | (bdwd, rstof) <- badWordsRestof msg pmap + , let bws = getBadWordScore bdwd pmap + sbm = getBadWordSubMap bdwd pmap + ] + +brss :: Message -> PhraseMap -> [(BadWord, Restof, Score, SubMap)] +brss = badWordsRestofScoreSubm + messageScore :: Message -> PhraseMap -> Score messageScore msg pmap - | L.empty == msg = 0 - | otherwise = (sum topScores) + (sum lowerScores) - where - msgSplit = messageSplit msg pmap - topScores = map fst msgSplit - lowerScores = map (\m -> messageScore m pmap) $ map snd msgSplit + | L.empty == msg = 0 + | M.empty == pmap = 0 + | otherwise = sum [ scr + lowerScore + | (bdw, rof, scr, sbm) <- brss msg pmap + , let lowerScore = messageScore rof sbm + ]