eros 0.1.0.0 → 0.2.0.0

raw patch · 12 files changed

+636/−379 lines, 12 filesdep +aeson-prettynew-component:exe:eroscPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson-pretty

API changes (from Hackage documentation)

Files

• eros.cabal +24/−7
• res/phraselist-schema.json +0/−27
• res/schemata/erosc-input.json +20/−0
• res/schemata/erosc-output.json +19/−0
• res/schemata/phraselist.json +27/−0
• src/Text/Eros/Message.hs +0/−61
• src/Text/Eros/Phrase.hs +0/−57
• src/Text/Eros/Phraselist.hs +0/−227
• src/erosc/Main.hs +98/−0
• src/lib/Text/Eros/Message.hs +61/−0
• src/lib/Text/Eros/Phrase.hs +57/−0
• src/lib/Text/Eros/Phraselist.hs +330/−0

@@ -1,5 +1,5 @@ name:                eros-version:             0.1.0.0+version:             0.2.0.0 synopsis:            A text censorship library. description:   A Haskell library for censoring text, using@@ -11,7 +11,6 @@   There exist compressed versions, for use within your code. You can see the   compressed versions   <https://github.com/pharpend/eros/tree/master/res/phraselists-ugly here>.- homepage:            https://eros.valkyrian.com/ license:             BSD3 license-file:        LICENSE@@ -21,7 +20,9 @@ category:            Text build-type:          Simple data-files:-  res/phraselist-schema.json+  res/schemata/erosc-input.json+  res/schemata/erosc-output.json+  res/schemata/phraselist.json   res/phraselists-ugly/chat.json   res/phraselists-ugly/conspiracy.json   res/phraselists-ugly/drug-advocacy.json@@ -56,9 +57,10 @@ library   exposed-modules:       Text.Eros.Message-      Text.Eros.Phrase-      Text.Eros.Phraselist-  -- other-modules:       +    , Text.Eros.Phrase+    , Text.Eros.Phraselist+  other-modules:       +      Paths_eros   other-extensions:       FlexibleInstances     , OverloadedStrings@@ -68,7 +70,7 @@     , bytestring     , containers     , text-  hs-source-dirs:      src/+  hs-source-dirs:      src/lib/   default-language:    Haskell2010  Test-Suite test-phrase@@ -83,8 +85,23 @@     , eros     , QuickCheck     , text+  default-language:    Haskell2010 +executable erosc+  build-depends:+      aeson+    , aeson-pretty+    , base >=4.7 && <4.8+    , bytestring+    , containers+    , eros+    , text+  hs-source-dirs: src/erosc/+  main-is: Main.hs+  default-language:    Haskell2010+ source-repository head   type:     git   location: https://github.com/pharpend/eros.git   branch:   master+  tag:      v.0.2

@@ -1,27 +0,0 @@-{-  "name": "PhraseList",-  "type": "array",-  "items": {-    "type": "object",-    "properties": {-      "phrase": {-        "type": "string",-        "description": "the phrase",-        "required": true-      },-      "score": {-        "type": "number",-        "description": "The phrase's score.",-        "required": true-      },-      "forest": {-        "type": "array",-        "description": "Subsequent phrases.",-        "required": true,-        "items": {-          "type": "object"-        }-      }-    }-  }-}

@@ -0,0 +1,20 @@+{+  "name": "erosc-input",+  "type": "object",+  "description": "The schema for the input to erosc.",+  "properties": {+    "text": {+      "type": "string",+      "description": "The text you want to be checked against the phraselists.",+      "required": true+    },+    "eros-lists": {+      "type": "array",+      "description": "The phraselists provided by eros you want \"text\" to be checked against.",+      "required": true,+      "items": {+        "type": "string"+      }+    },+  }+}

@@ -0,0 +1,19 @@+{+  "name": "erosc-output",+  "type": "array",+  "description": "The output of erosc.",+  "items": {+    "type": "object",+    "description": "The phraselist name, along with the score for that phraselist.",+    "properties": {+      "eros-list": {+        "type": "string",+        "description": "The name of the phraselist corresponding to this object."+      },+      "score": {+        "type": "number",+        "description": "The score corresponding to this phraselist."+      }+    }+  }+}

@@ -0,0 +1,27 @@+{+  "name": "phraselist",+  "type": "array",+  "items": {+    "type": "object",+    "properties": {+      "phrase": {+        "type": "string",+        "description": "the phrase",+        "required": true+      },+      "score": {+        "type": "number",+        "description": "The phrase's score.",+        "required": true+      },+      "forest": {+        "type": "array",+        "description": "Subsequent phrases.",+        "required": true,+        "items": {+          "type": "object"+        }+      }+    }+  }+}

@@ -1,61 +0,0 @@--- |--- Module       : Text.Eros.Message--- Description  : Module for censoring pieces of text.--- Copyright    : 2014, Peter Harpending--- License      : BSD3--- Maintainer   : Peter Harpending <pharpend2@gmail.com>--- Stability    : experimental--- Portability  : archlinux---- This module deals specifically with pieces of 'Text'.--module Text.Eros.Message (messageScore) where---- Here, we have all the imports.-import           Data.List-import qualified Data.Map.Strict as M-import qualified Data.Text.Lazy as L-import           Data.Tree-import           Text.Eros.Phrase-import           Text.Eros.Phraselist----- |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---- |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-  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")---- |Given a message, find its score.-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

@@ -1,57 +0,0 @@--- |--- Module       : Text.Eros.Phrase--- Description  : Pure interface for 'Phrase's and 'PhraseTree's.--- Copyright    : 2014, Peter Harpending.--- License      : BSD3--- Maintainer   : Peter Harpending <pharpend2@gmail.com>--- Stability    : experimental--- Portability  : archlinux--- --module Text.Eros.Phrase where--import qualified Data.Map as M-import           Data.Ord (comparing)-import           Data.Text.Lazy (Text)-import           Data.Tree---- |A Phrase is a piece of Text, with an int representing its--- weight. These are the used internally within 'eros', in--- 'Tree's. -data Phrase = Phrase { phrase :: Text-                     , score  :: Int-                     }-  deriving (Read, Show)--instance Eq Phrase where-  a == b = (score a) == (score b)-  a /= b = (score a) /= (score b)--instance Ord Phrase where-  -- |To compare 'Phrases', just compare their 'score's-  compare = comparing score---- |A 'Tree' of 'Phrase's-type PhraseTree = Tree Phrase--- |A 'Forest' of 'Phrase's-type PhraseForest = Forest Phrase--- |A Map of text values the appropriate tree-type PhraseMap = M.Map Text PhraseTree---- |The 'score' of the 'PhraseTree' is the sum of the 'score's of its 'Node's.-treeScore :: PhraseTree -> Int-treeScore = sum . map score . flatten---- |Given a list of 'PhraseTree's, return the top-level 'phrase's.-forestPhrases :: [PhraseTree] -> [Text]-forestPhrases = map forestPhrase---- |Given a 'PhraseTree', return the top-level 'phrase'.-forestPhrase :: PhraseTree -> Text-forestPhrase (Node phr subf) = phrase phr---- |Given a list of 'PhraseTree's, return a map of each phrase with--- the appropriate tree.-mkMap :: PhraseForest -> PhraseMap-mkMap = M.fromList . phraseTreeAlist-  where phraseTreeAlist frs = zip (forestPhrases frs) frs

@@ -1,227 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}---- |--- Module       : Text.Eros.Phraselist--- Description  : A module for dealing with Phraselists.--- Copyright    : 2014, Peter Harpending.--- License      : BSD3--- Maintainer   : Peter Harpending <pharpend2@gmail.com>--- Stability    : experimental--- Portability  : archlinux------ If you want to make your own phraselist, you need to write a JSON--- file, in accordance with the--- <https://raw.githubusercontent.com/pharpend/eros/master/res/phraselist-schema.json schema>.--- Once you do that, make a data type for your phraselist.--- Make your data type an instance of 'Phraselist', and you're good to--- go.--- --- For example, let's say your phraselist is @mylist.json@, and it's--- all in accordance with the schema. Your code would look something--- like this:--- --- @--- data MyList = MyList--- --- instance Phraselist MyList where---   phraselistPath MyList = getDataFileName "mylist.json"---   phraselistPath _      = undefined--- @--- --- Don't forget to add @mylist.json@ to @Data-Files@ in your @.cabal@--- file.--- --- If you want to use one of the lists we already supply--- --module Text.Eros.Phraselist where--import           Control.Applicative ((<$>), (<*>))-import           Control.Monad (mzero, sequence)-import           Data.Aeson-import qualified Data.ByteString.Lazy as B-import           Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as L-import           Data.Tree-import           Paths_eros-import           System.Exit-import           Text.Eros.Phrase--class Phraselist t where-  phraselistPath :: t -> IO FilePath---- |A set of 'Phraselist's. Note that this is actually a list, and I'm--- calling it a "set" for purely lexical purposes.-type PhraselistSet = Phraselist t => [t]---- |The phraselists in @res/@. Each of these constructors correspond--- to one of the files--- <https://github.com/pharpend/eros/tree/master/res/phraselists-pretty here>.--- --- Gitlab has a terrible interface, so I won't provide links to each--- one of them.-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---- |A list of phraselists we provide.-erosLists :: [ErosList]-erosLists = [ 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-            ]---- |A list of the paths to the phraselists we provide.-erosListPaths :: IO [FilePath]-erosListPaths = mapM phraselistPath erosLists---- These are the data paths for the various PhraseLists-instance Phraselist ErosList where-  phraselistPath Chat            = getDataFileName "res/phraselists-ugly/chat.json"-  phraselistPath Conspiracy      = getDataFileName "res/phraselists-ugly/conspiracy.json"-  phraselistPath DrugAdvocacy    = getDataFileName "res/phraselists-ugly/drug-advocacy.json"-  phraselistPath Forums          = getDataFileName "res/phraselists-ugly/forums.json"-  phraselistPath Gambling        = getDataFileName "res/phraselists-ugly/gambling.json"-  phraselistPath Games           = getDataFileName "res/phraselists-ugly/games.json"-  phraselistPath Gore            = getDataFileName "res/phraselists-ugly/gore.json"-  phraselistPath IdTheft         = getDataFileName "res/phraselists-ugly/id-theft.json"-  phraselistPath IllegalDrugs    = getDataFileName "res/phraselists-ugly/illegal-drugs.json"-  phraselistPath Intolerance     = getDataFileName "res/phraselists-ugly/intolerance.json"-  phraselistPath LegalDrugs      = getDataFileName "res/phraselists-ugly/legal-drugs.json"-  phraselistPath Malware         = getDataFileName "res/phraselists-ugly/malware.json"-  phraselistPath Music           = getDataFileName "res/phraselists-ugly/music.json"-  phraselistPath News            = getDataFileName "res/phraselists-ugly/news.json"-  phraselistPath Nudism          = getDataFileName "res/phraselists-ugly/nudism.json"-  phraselistPath Peer2Peer       = getDataFileName "res/phraselists-ugly/peer2peer.json"-  phraselistPath Personals       = getDataFileName "res/phraselists-ugly/personals.json"-  phraselistPath Pornography     = getDataFileName "res/phraselists-ugly/pornography.json"-  phraselistPath Proxies         = getDataFileName "res/phraselists-ugly/proxies.json"-  phraselistPath SecretSocieties = getDataFileName "res/phraselists-ugly/secret-societies.json"-  phraselistPath SelfLabeling    = getDataFileName "res/phraselists-ugly/self-labeling.json"-  phraselistPath Sport           = getDataFileName "res/phraselists-ugly/sport.json"-  phraselistPath Translation     = getDataFileName "res/phraselists-ugly/translation.json"-  phraselistPath UpstreamFilter  = getDataFileName "res/phraselists-ugly/upstream-filter.json"-  phraselistPath Violence        = getDataFileName "res/phraselists-ugly/violence.json"-  phraselistPath WarezHacking    = getDataFileName "res/phraselists-ugly/warez-hacking.json"-  phraselistPath Weapons         = getDataFileName "res/phraselists-ugly/weapons.json"-  phraselistPath Webmail         = getDataFileName "res/phraselists-ugly/webmail.json"---- |Placeholder type used to read JSON. The JSON schema (currently, at--- least) is such that one needs this type to read the JSON. You can--- use 'fromPAT' to convert this type into a 'PhraseTree'-data PhraseAlmostTree = PhraseAlmostTree { patPhrase :: Text-                                         , patScore  :: Int-                                         , patForest :: [PhraseAlmostTree]-                                         }-  deriving (Show, Read)---- |Alias for 'PhraseAlmostTree'-type PAT = PhraseAlmostTree---- |You can read the--- <https://raw.githubusercontent.com/pharpend/eros/master/res/phraselist-schema.json JSON schema>--- to see how this works.-instance FromJSON PAT where-  parseJSON (Object v) = PhraseAlmostTree-    <$> v .: "phrase"-    <*> v .: "score"-    <*> v .: "forest"-  parseJSON _          = fail "Object not a PhraseAlmostTree."---- |Convert a 'PAT' into a 'PhraseTree'.-fromPAT :: PAT -> PhraseTree-fromPAT (PhraseAlmostTree p s f) = Node (Phrase p s) $ map fromPAT f---- |I figure some people like to type a lot.-fromPhraseAlmostTree :: PAT -> PhraseTree-fromPhraseAlmostTree = fromPAT---- |Read a 'Phraselist', marshal it into a 'PhraseForest'.-readPhraselist :: Phraselist t => t -> IO PhraseForest-readPhraselist elist = do-  lpath <- phraselistPath elist-  ltext <- B.readFile lpath-  let ljson = (eitherDecode ltext) :: Either String [PAT]-  case ljson of-    Left msg   -> fail msg-    Right pats -> return $ map fromPAT pats---- |Alias for 'readPhraselist'-loadPhraselist :: Phraselist t => t -> IO PhraseForest-loadPhraselist = readPhraselist---- |Alias for 'readPhraselist'-readPhraseFile :: Phraselist t => t -> IO PhraseForest-readPhraseFile = readPhraselist---- |Alias for 'readPhraselist'-loadPhraseFile :: Phraselist t => t -> IO PhraseForest-loadPhraseFile = readPhraselist---- |Alias for 'readPhraselist'-readPhraseForest :: Phraselist t => t -> IO PhraseForest-readPhraseForest = readPhraselist---- |Alias for 'readPhraselist'-loadPhraseForest :: Phraselist t => t -> IO PhraseForest-loadPhraseForest = readPhraselist---- |Load a 'Phraselist' directly into a 'PhraseMap'-readPhraseMap :: Phraselist t => t -> IO PhraseMap-readPhraseMap plist = fmap mkMap $ readPhraselist plist---- |Alias for 'readPhraseMap'-loadPhraseMap :: Phraselist t => t -> IO PhraseMap-loadPhraseMap = readPhraseMap

@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +-- |This is the main module for the eros client. This is not the meat &+-- potatoes of the program, but this is the bread & butter.+-- +module Main where++import           Control.Applicative+import           Control.Monad (mzero)+import           Data.Aeson+import           Data.Aeson.Encode.Pretty+import qualified Data.ByteString.Lazy   as LzByte+import qualified Data.Text.Lazy         as LzText+import qualified Data.Text.Lazy.IO      as LazyIO+import qualified Data.Map               as M+import qualified System.IO              as StdIO+import           Text.Eros.Message+import           Text.Eros.Phrase (mkMap)+import           Text.Eros.Phraselist++-- |It's convenient to think of Scores as Scores, although, they are truly ints.+type Score = Int++-- |We represent the input data in its own data type. This is needed+-- for JSON parsing, but it will also be useful down the road, when I+-- allow input that isn't JSON.+data EroscInput = EroscInput { text      :: LzText.Text+                             , erosLists :: [ErosList]+                             }++-- |This is pretty self-explanatory+instance FromJSON ErosList where+  parseJSON (String s) = case erosListByName (LzText.fromStrict s) of+                           Just list -> return list+                           Nothing   -> mzero+  parseJSON _          = mzero++-- |This is pretty self-explanatory+instance FromJSON EroscInput where+  parseJSON (Object v) = EroscInput+    <$> v .: "text"+    <*> v .: "eros-lists"+  parseJSON _          = mzero++-- |This is the output data type. I will make an instance of ToJSON+-- for this data type. Again, at the start, only JSON input and output+-- is existent.+data EroscOutput = EroscOutput { elScore :: [(ErosList, Score)] }++-- |Pretty self-explanatory+instance ToJSON ErosList where+  toJSON el = case erosNameByList el of+                Just nom -> toJSON nom+                Nothing  -> "Well, something got fucked up."++-- |Pretty self-explanatory+instance ToJSON (ErosList, Score) where+  toJSON (el, sc) = object [ "eros-list" .= el+                           , "score"     .= sc+                           ]++-- |Pretty self-explanatory+instance ToJSON EroscOutput where+  toJSON (EroscOutput elm) = toJSON elm++erosEncode :: ToJSON a => a -> LzByte.ByteString+erosEncode = encodePretty' defConfig { confIndent = 2+                                     }++main :: IO ()+main = do+  -- take the json from stdin, try to decode it+  inputBt <- LzByte.hGetContents StdIO.stdin+  let eitherJson = (eitherDecode inputBt) :: Either String EroscInput+  -- if by chance, it isn't decoded, the program shall flip its shit+  case eitherJson of+    Left msg      -> fail msg+    Right ecInput -> runInput ecInput++runInput :: EroscInput -> IO ()+runInput ipt = do+  result <- processInput ipt+  let jsonText = erosEncode result+  LzByte.hPutStr StdIO.stdout jsonText++processInput :: EroscInput -> IO EroscOutput+processInput (EroscInput txt lists) = do+    outLists <- mapM listPair lists+    return $ EroscOutput outLists+  where+    listPair :: ErosList -> IO (ErosList, Score)+    listPair ls = do+      pmap <- loadPhraseMap ls+      let scr = messageScore txt pmap+      return (ls, scr)+  +

@@ -0,0 +1,61 @@+-- |+-- Module       : Text.Eros.Message+-- Description  : Module for censoring pieces of text.+-- Copyright    : 2014, Peter Harpending+-- License      : BSD3+-- Maintainer   : Peter Harpending <pharpend2@gmail.com>+-- Stability    : experimental+-- Portability  : archlinux++-- This module deals specifically with pieces of 'Text'.++module Text.Eros.Message (messageScore) where++-- Here, we have all the imports.+import           Data.List+import qualified Data.Map.Strict as M+import qualified Data.Text.Lazy as L+import           Data.Tree+import           Text.Eros.Phrase+import           Text.Eros.Phraselist+++-- |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++-- |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+  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")++-- |Given a message, find its score.+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

@@ -0,0 +1,57 @@+-- |+-- Module       : Text.Eros.Phrase+-- Description  : Pure interface for 'Phrase's and 'PhraseTree's.+-- Copyright    : 2014, Peter Harpending.+-- License      : BSD3+-- Maintainer   : Peter Harpending <pharpend2@gmail.com>+-- Stability    : experimental+-- Portability  : archlinux+-- ++module Text.Eros.Phrase where++import qualified Data.Map as M+import           Data.Ord (comparing)+import           Data.Text.Lazy (Text)+import           Data.Tree++-- |A Phrase is a piece of Text, with an int representing its+-- weight. These are the used internally within 'eros', in+-- 'Tree's. +data Phrase = Phrase { phrase :: Text+                     , score  :: Int+                     }+  deriving (Read, Show)++instance Eq Phrase where+  a == b = (score a) == (score b)+  a /= b = (score a) /= (score b)++instance Ord Phrase where+  -- |To compare 'Phrases', just compare their 'score's+  compare = comparing score++-- |A 'Tree' of 'Phrase's+type PhraseTree = Tree Phrase+-- |A 'Forest' of 'Phrase's+type PhraseForest = Forest Phrase+-- |A Map of text values the appropriate tree+type PhraseMap = M.Map Text PhraseTree++-- |The 'score' of the 'PhraseTree' is the sum of the 'score's of its 'Node's.+treeScore :: PhraseTree -> Int+treeScore = sum . map score . flatten++-- |Given a list of 'PhraseTree's, return the top-level 'phrase's.+forestPhrases :: [PhraseTree] -> [Text]+forestPhrases = map forestPhrase++-- |Given a 'PhraseTree', return the top-level 'phrase'.+forestPhrase :: PhraseTree -> Text+forestPhrase (Node phr subf) = phrase phr++-- |Given a list of 'PhraseTree's, return a map of each phrase with+-- the appropriate tree.+mkMap :: PhraseForest -> PhraseMap+mkMap = M.fromList . phraseTreeAlist+  where phraseTreeAlist frs = zip (forestPhrases frs) frs

@@ -0,0 +1,330 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module       : Text.Eros.Phraselist+-- Description  : A module for dealing with Phraselists.+-- Copyright    : 2014, Peter Harpending.+-- License      : BSD3+-- Maintainer   : Peter Harpending <pharpend2@gmail.com>+-- Stability    : experimental+-- Portability  : archlinux+--+-- If you want to make your own phraselist, you need to write a JSON+-- file, in accordance with the+-- <https://raw.githubusercontent.com/pharpend/eros/master/res/phraselist-schema.json schema>.+-- Once you do that, make a data type for your phraselist.+-- Make your data type an instance of 'Phraselist', and you're good to+-- go.+-- +-- For example, let's say your phraselist is @mylist.json@, and it's+-- all in accordance with the schema. Your code would look something+-- like this:+-- +-- @+-- data MyList = MyList+-- +-- instance Phraselist MyList where+--   phraselistPath MyList = getDataFileName "mylist.json"+--   phraselistPath _      = undefined+-- @+-- +-- Don't forget to add @mylist.json@ to @Data-Files@ in your @.cabal@+-- file.+-- +-- If you want to use one of the lists we already supply+-- ++module Text.Eros.Phraselist where++import           Control.Applicative  ((<$>), (<*>))+import           Control.Monad        (mzero, sequence)+import           Data.Aeson+import qualified Data.ByteString.Lazy as B+import qualified Data.Map             as M+import           Data.Text.Lazy       (Text)+import qualified Data.Text.Lazy       as L+import           Data.Tree+import           Paths_eros+import           System.Exit+import           Text.Eros.Phrase++class Phraselist t where+  phraselistPath :: t -> IO FilePath++-- |A set of 'Phraselist's. Note that this is actually a list, and I'm+-- calling it a "set" for purely lexical purposes.+type PhraselistSet = Phraselist t => [t]++-- |The phraselists in @res/@. Each of these constructors correspond+-- to one of the files+-- <https://github.com/pharpend/eros/tree/master/res/phraselists-pretty here>.+-- +-- Gitlab has a terrible interface, so I won't provide links to each+-- one of them.+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++instance Eq ErosList where+  (==) Chat Chat = True+  (==) Conspiracy Conspiracy = True+  (==) DrugAdvocacy DrugAdvocacy = True+  (==) Forums Forums = True+  (==) Gambling Gambling = True+  (==) Games Games = True+  (==) Gore Gore = True+  (==) IdTheft IdTheft = True+  (==) IllegalDrugs IllegalDrugs = True+  (==) Intolerance Intolerance = True+  (==) LegalDrugs LegalDrugs = True+  (==) Malware Malware = True+  (==) Music Music = True+  (==) News News = True+  (==) Nudism Nudism = True+  (==) Peer2Peer Peer2Peer = True+  (==) Personals Personals = True+  (==) Pornography Pornography = True+  (==) Proxies Proxies = True+  (==) SecretSocieties SecretSocieties = True+  (==) SelfLabeling SelfLabeling = True+  (==) Sport Sport = True+  (==) Translation Translation = True+  (==) UpstreamFilter UpstreamFilter = True+  (==) Violence Violence = True+  (==) WarezHacking WarezHacking = True+  (==) Weapons Weapons = True+  (==) Webmail Webmail = True+  (==) Chat _ = False+  (==) Conspiracy _ = False+  (==) DrugAdvocacy _ = False+  (==) Forums _ = False+  (==) Gambling _ = False+  (==) Games _ = False+  (==) Gore _ = False+  (==) IdTheft _ = False+  (==) IllegalDrugs _ = False+  (==) Intolerance _ = False+  (==) LegalDrugs _ = False+  (==) Malware _ = False+  (==) Music _ = False+  (==) News _ = False+  (==) Nudism _ = False+  (==) Peer2Peer _ = False+  (==) Personals _ = False+  (==) Pornography _ = False+  (==) Proxies _ = False+  (==) SecretSocieties _ = False+  (==) SelfLabeling _ = False+  (==) Sport _ = False+  (==) Translation _ = False+  (==) UpstreamFilter _ = False+  (==) Violence _ = False+  (==) WarezHacking _ = False+  (==) Weapons _ = False+  (==) Webmail _ = False++-- |A list of phraselists we provide.+erosLists :: [ErosList]+erosLists = [ 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+            ]++-- |A list of the paths to the phraselists we provide.+erosListPaths :: IO [FilePath]+erosListPaths = mapM phraselistPath erosLists++erosListNames :: [L.Text]+erosListNames = [ "chat"+                , "conspiracy"+                , "drug-advocacy"+                , "forums"+                , "gambling"+                , "games"+                , "gore"+                , "id-theft"+                , "illegal-drugs"+                , "intolerance"+                , "legal-drugs"+                , "malware"+                , "music"+                , "news"+                , "nudism"+                , "peer2peer"+                , "personals"+                , "pornography"+                , "proxies"+                , "secret-societies"+                , "self-labeling"+                , "sport"+                , "translation"+                , "upstream-filter"+                , "violence"+                , "warez-hacking"+                , "weapons"+                , "webmail"+                ]++-- |You can't really order the lists, so we won't use 'M.Map'+erosListNamePairs :: [(ErosList, L.Text)]+erosListNamePairs = zip erosLists erosListNames++erosNameByList :: ErosList -> Maybe L.Text+erosNameByList key = lookup key erosListNamePairs++erosNameListMap :: M.Map L.Text ErosList+erosNameListMap = M.fromList $ zip erosListNames erosLists++erosListByName :: L.Text -> Maybe ErosList+erosListByName key = M.lookup key erosNameListMap ++-- These are the data paths for the various PhraseLists+instance Phraselist ErosList where+  phraselistPath Chat            = getDataFileName "res/phraselists-ugly/chat.json"+  phraselistPath Conspiracy      = getDataFileName "res/phraselists-ugly/conspiracy.json"+  phraselistPath DrugAdvocacy    = getDataFileName "res/phraselists-ugly/drug-advocacy.json"+  phraselistPath Forums          = getDataFileName "res/phraselists-ugly/forums.json"+  phraselistPath Gambling        = getDataFileName "res/phraselists-ugly/gambling.json"+  phraselistPath Games           = getDataFileName "res/phraselists-ugly/games.json"+  phraselistPath Gore            = getDataFileName "res/phraselists-ugly/gore.json"+  phraselistPath IdTheft         = getDataFileName "res/phraselists-ugly/id-theft.json"+  phraselistPath IllegalDrugs    = getDataFileName "res/phraselists-ugly/illegal-drugs.json"+  phraselistPath Intolerance     = getDataFileName "res/phraselists-ugly/intolerance.json"+  phraselistPath LegalDrugs      = getDataFileName "res/phraselists-ugly/legal-drugs.json"+  phraselistPath Malware         = getDataFileName "res/phraselists-ugly/malware.json"+  phraselistPath Music           = getDataFileName "res/phraselists-ugly/music.json"+  phraselistPath News            = getDataFileName "res/phraselists-ugly/news.json"+  phraselistPath Nudism          = getDataFileName "res/phraselists-ugly/nudism.json"+  phraselistPath Peer2Peer       = getDataFileName "res/phraselists-ugly/peer2peer.json"+  phraselistPath Personals       = getDataFileName "res/phraselists-ugly/personals.json"+  phraselistPath Pornography     = getDataFileName "res/phraselists-ugly/pornography.json"+  phraselistPath Proxies         = getDataFileName "res/phraselists-ugly/proxies.json"+  phraselistPath SecretSocieties = getDataFileName "res/phraselists-ugly/secret-societies.json"+  phraselistPath SelfLabeling    = getDataFileName "res/phraselists-ugly/self-labeling.json"+  phraselistPath Sport           = getDataFileName "res/phraselists-ugly/sport.json"+  phraselistPath Translation     = getDataFileName "res/phraselists-ugly/translation.json"+  phraselistPath UpstreamFilter  = getDataFileName "res/phraselists-ugly/upstream-filter.json"+  phraselistPath Violence        = getDataFileName "res/phraselists-ugly/violence.json"+  phraselistPath WarezHacking    = getDataFileName "res/phraselists-ugly/warez-hacking.json"+  phraselistPath Weapons         = getDataFileName "res/phraselists-ugly/weapons.json"+  phraselistPath Webmail         = getDataFileName "res/phraselists-ugly/webmail.json"++-- |Placeholder type used to read JSON. The JSON schema (currently, at+-- least) is such that one needs this type to read the JSON. You can+-- use 'fromPAT' to convert this type into a 'PhraseTree'+data PhraseAlmostTree = PhraseAlmostTree { patPhrase :: Text+                                         , patScore  :: Int+                                         , patForest :: [PhraseAlmostTree]+                                         }+  deriving (Show, Read)++-- |Alias for 'PhraseAlmostTree'+type PAT = PhraseAlmostTree++-- |You can read the+-- <https://raw.githubusercontent.com/pharpend/eros/master/res/phraselist-schema.json JSON schema>+-- to see how this works.+instance FromJSON PAT where+  parseJSON (Object v) = PhraseAlmostTree+    <$> v .: "phrase"+    <*> v .: "score"+    <*> v .: "forest"+  parseJSON _          = fail "Object not a PhraseAlmostTree."++-- |Convert a 'PAT' into a 'PhraseTree'.+fromPAT :: PAT -> PhraseTree+fromPAT (PhraseAlmostTree p s f) = Node (Phrase p s) $ map fromPAT f++-- |I figure some people like to type a lot.+fromPhraseAlmostTree :: PAT -> PhraseTree+fromPhraseAlmostTree = fromPAT++-- |Read a 'Phraselist', marshal it into a 'PhraseForest'.+readPhraselist :: Phraselist t => t -> IO PhraseForest+readPhraselist elist = do+  lpath <- phraselistPath elist+  ltext <- B.readFile lpath+  let ljson = (eitherDecode ltext) :: Either String [PAT]+  case ljson of+    Left msg   -> fail msg+    Right pats -> return $ map fromPAT pats++-- |Alias for 'readPhraselist'+loadPhraselist :: Phraselist t => t -> IO PhraseForest+loadPhraselist = readPhraselist++-- |Alias for 'readPhraselist'+readPhraseFile :: Phraselist t => t -> IO PhraseForest+readPhraseFile = readPhraselist++-- |Alias for 'readPhraselist'+loadPhraseFile :: Phraselist t => t -> IO PhraseForest+loadPhraseFile = readPhraselist++-- |Alias for 'readPhraselist'+readPhraseForest :: Phraselist t => t -> IO PhraseForest+readPhraseForest = readPhraselist++-- |Alias for 'readPhraselist'+loadPhraseForest :: Phraselist t => t -> IO PhraseForest+loadPhraseForest = readPhraselist++-- |Load a 'Phraselist' directly into a 'PhraseMap'+readPhraseMap :: Phraselist t => t -> IO PhraseMap+readPhraseMap plist = fmap mkMap $ readPhraselist plist++-- |Alias for 'readPhraseMap'+loadPhraseMap :: Phraselist t => t -> IO PhraseMap+loadPhraseMap = readPhraseMap