WordCount.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeInType #-}

module WordCount where

import Capability.Reader
import Capability.State
import Capability.Sink
import Control.Lens (ifor_)
import Data.Coerce (coerce)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Control.Monad.Reader (ReaderT (..))
import Data.IORef
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Monoid (Sum (..))
import GHC.Generics (Generic)
import Test.Common
import Test.Hspec

-- | Accumulating key-value mapping.
--
-- The 'Monoid' instance will 'mappend'
-- values to keys that occur on both sides.
newtype Accum map = Accum map

instance (Ord k, Semigroup v)
  => Semigroup (Accum (Map k v)) where
    (<>) = coerce $ Map.unionWith @k @v (<>)

instance (Ord k, Semigroup v)
  => Monoid (Accum (Map k v)) where
    mempty = coerce $ Map.empty @k @v
    mappend = (<>)


-- | Counts occurrences of values @k@.
newtype Occurrences k = Occurrences (Map k Int)
  deriving (Monoid, Semigroup) via Accum (Map k (Sum Int))
  deriving Show

-- | A single occurrence of the given value.
oneOccurrence :: k -> Occurrences k
oneOccurrence k = Occurrences $ Map.singleton k 1


-- | Count the occurrence of a single letter.
countLetter ::
  HasSink "letterCount" (Occurrences Char) m
  => Char -> m ()
countLetter letter = yield @"letterCount" (oneOccurrence letter)

-- | Count the occurrence of a single word.
countWord ::
  HasSink "wordCount" (Occurrences Text) m
  => Text -> m ()
countWord word = yield @"wordCount" (oneOccurrence word)


-- | Count the occurrence of a single word and all the letters in it.
countWordAndLetters ::
  ( HasSink "letterCount" (Occurrences Char) m
  , HasSink "wordCount" (Occurrences Text) m )
  => Text -> m ()
countWordAndLetters word = do
  countWord word
  mapM_ countLetter (Text.unpack word)


-- | Count the occurrences of words and letters in a text,
-- excluding white space.
countWordsAndLettersInText ::
  ( HasSink "letterCount" (Occurrences Char) m
  , HasSink "wordCount" (Occurrences Text) m )
  => Text -> m ()
countWordsAndLettersInText text =
  mapM_ countWordAndLetters (Text.words text)


-- | Counter application context.
data CounterCtx = CounterCtx
  { letterCount :: IORef (Occurrences Char)
    -- ^ Counting letter occurrences.
  , wordCount :: IORef (Occurrences Text)
    -- ^ Counting word occurrences.
  } deriving Generic

-- | Counter application monad.
newtype Counter a = Counter { runCounter :: CounterCtx -> IO a }
  deriving (Functor, Applicative, Monad) via (ReaderT CounterCtx IO)
  deriving (HasSink "letterCount" (Occurrences Char)) via
    (SinkLog  -- Generate HasSink using HasState of Monoid
    (ReaderIORef  -- Generate HasState from HasReader of IORef
    (Field "letterCount" "ctx"  -- Focus on the field letterCount
    (MonadReader  -- Generate HasReader using mtl MonadReader
    (ReaderT CounterCtx IO)))))  -- Use mtl ReaderT newtype
  deriving (HasSink "wordCount" (Occurrences Text)) via
    SinkLog (ReaderIORef
    (Field "wordCount" "ctx" (MonadReader (ReaderT CounterCtx IO))))


-- | Given a text count the occurrences of all words and letters in it,
-- excluding white space, and print the outcome to standard output.
wordAndLetterCount :: Text -> IO ()
wordAndLetterCount text = do
  lettersRef <- newIORef $ Occurrences Map.empty
  wordsRef <- newIORef $ Occurrences Map.empty
  let ctx = CounterCtx
        { letterCount = lettersRef
        , wordCount = wordsRef
        }
      counter :: Counter ()
      counter = countWordsAndLettersInText text
  runCounter counter ctx
  let printOccurrencesOf name ref = do
        putStrLn name
        Occurrences occurrences <- readIORef ref
        ifor_ occurrences $ \item num ->
          putStrLn $ show item ++ ": " ++ show num
  printOccurrencesOf "Letters" lettersRef
  printOccurrencesOf "Words" wordsRef


----------------------------------------------------------------------
-- Test Cases

spec :: Spec
spec = do
  describe "Counter" $ do
    it "handles the empty text" $
      wordAndLetterCount "" `shouldPrint`
        "Letters\n\
        \Words\n"
    it "handles one word" $
      wordAndLetterCount "banana" `shouldPrint`
        "Letters\n'a': 3\n'b': 1\n'n': 2\n\
        \Words\n\"banana\": 1\n"
    it "handles two words" $
      wordAndLetterCount "mississipi river" `shouldPrint`
        "Letters\n'e': 1\n'i': 5\n'm': 1\n'p': 1\n'r': 2\n's': 4\n'v': 1\n\
        \Words\n\"mississipi\": 1\n\"river\": 1\n"
    it "handles two lines" $
      wordAndLetterCount "banana apple\napple banana" `shouldPrint`
        "Letters\n'a': 8\n'b': 2\n'e': 2\n'l': 2\n'n': 4\n'p': 4\n\
        \Words\n\"apple\": 2\n\"banana\": 2\n"