wc.hs

import Data.Text (Text, map,
                  toLower, words, pack)

import Data.Text.IO (readFile)
import Data.Char (isLetter)
import Prelude hiding (map, words, readFile)
import Data.Map.Strict (toList, fromListWith)
import GHC.Exts (sortWith)
import Control.DeepSeq
import Control.Parallel.Strategies hiding(parMap)
import GHC.Conc (numCapabilities)
import System.Environment(getArgs)
import Data.Array

main :: IO ()
main = do
  [f] <- getArgs
  file <- readFile f
  let totalWords = words . toLower $ file
      firstBatch = runEval $ do
        wordChunks <- rpar (force splitN numCapabilities totalWords)
        quarter <- rpar (force splitN 4 totalWords)
        wc <- rpar (force length totalWords)
        rseq wordChunks
        rseq wc
        rseq quarter
        return (wordChunks, wc, quarter)

      wcfStats = runEval $ do
        wcfBlocks <- parMap wordCountFreq (fst' firstBatch)
        wcfQuarter <- parMap (cmnSuccThe [])
          (thd' firstBatch)
        rseq wcfBlocks
        rseq wcfQuarter
        return (wcfBlocks, wcfQuarter)

      wcf = topTen $ toList (fromListWith (+) $ concat (fst wcfStats))
      wcfQuarterStats = runEval $ parMap (topOne . wordCountFreq) $ snd wcfStats
  print $ "word count is " ++ show (snd' firstBatch)
  print wcf
  print $ wcfQuarterStats


wordCountFreq :: [Text] -> [(Text, Int)]
wordCountFreq input = go $ input where
    go str = toList (fromListWith (+) (zip str (repeat 1)))

cmnSuccThe :: [Text] -> [Text] -> [Text]
cmnSuccThe a [] = a
cmnSuccThe a n@(x:xs)
  | x  == pack("the") = cmnSuccThe newList restList
  | x  /= pack("the") = cmnSuccThe a xs
  where
    restList = drop 1 xs
    newList = take 1 xs ++ a

topTen :: [(Text, Int)] -> [(Text, Int)]
topTen = take 10 . reverse . sortWith snd

topOne :: [(Text, Int)] -> [(Text, Int)]
topOne = take 1 . reverse . sortWith snd

parMap :: (a -> b) -> [a] -> Eval [b]
parMap f [] = return []
parMap f (a:as) = do
   b <- rpar (f a)
   bs <- parMap f as
   return (b:bs)

splitN i xs
  | i > 1  = splitN (i - 1) restListElem ++ [listElem]
  | i == 1 = [xs]
  where n = length xs `div` i
        listElem = take n xs
        restListElem = drop n xs

fst' :: (a,b,c) -> a
fst' (a,_,_) = a

snd' :: (a,b,c) -> b
snd' (_,a,_) = a

thd' :: (a,b,c) -> c
thd' (_,_,a) = a

2 Core

cli

threadscope