Lecture6.hs

{-# LANGUAGE TypeOperators #-}

module Lecture6 where

import Control.Applicative
import Control.Monad.State hiding (sequence)
import Data.Char (isSpace)
import Data.Monoid hiding (getAll)
import Prelude hiding (sequence)

class Functor t => Traversable t where
  traverse :: Applicative f => (a -> f b) -> t a -> f (t b)
  traverse f t = sequence $ fmap f t
  
  sequence :: Applicative f => t (f a) -> f (t a)
  sequence t = traverse id t

instance Traversable [] where
  traverse _ [] = pure []
  traverse f (x : xs) = (:) <$> f x <*> traverse f xs

newtype K a b = K { getK :: a }

instance Functor (K a) where
  fmap _ (K a) = K a

instance Monoid a => Applicative (K a) where
  pure _ = K mempty
  K f <*> K x = K (f <> x)

foldMapTraversable :: (Monoid b, Traversable f) => (a -> b) -> f a -> b
foldMapTraversable f t = getK $ traverse (K . f) t

foldTraversable :: (Monoid b, Traversable f) => f b -> b
foldTraversable = foldMapTraversable id

newtype Compose f g a = Compose { getCompose :: f (g a) }

instance (Functor f, Functor g) => Functor (Compose f g) where
  fmap f (Compose x) = Compose (fmap (fmap f) x)

instance (Applicative f, Applicative g) => Applicative (Compose f g) where
  pure = Compose . pure . pure
  Compose f <*> Compose x = Compose $ (<*>) <$> f <*> x

data (:*:) f g a = (:.:) (f a) (g a)

instance (Functor f, Functor g) => Functor (f :*: g) where
  fmap f (x :.: y) = fmap f x :.: fmap f y

instance (Applicative f, Applicative g) => Applicative (f :*: g) where
  pure x = pure x :.: pure x
  (f1 :.: f2) <*> (x1 :.: x2) = (f1 <*> x1) :.: (f2 <*> x2)

pointwise :: (a -> f b) -> (a -> g b) -> a -> (f :*: g) b
pointwise f g a = f a :.: g a

countChars :: (Char -> K (Sum Integer) a)
countChars _ = K (Sum 1)

test :: Num a => Bool -> a
test False = 0
test True = 1

countLines :: (Char -> K (Sum Integer) a)
countLines c = K (Sum $ test (c == '\n'))

countWords :: (Char -> Compose (State Bool) (K (Sum Integer)) a)
countWords c = Compose $ do
  inWord <- get
  when (not inWord && not (isSpace c)) $
    put True
  when (inWord && isSpace c) $
    put False
  let result = test (not inWord && not (isSpace c))
  return (K $ Sum result)

main :: IO ()
main =
  do contents <- getContents
     let (K cc :.: (K lc :.: Compose wc)) = traverse (countChars `pointwise` (countLines `pointwise` countWords)) contents
     putStrLn $ "Char count = " ++ show (getSum cc)
     putStrLn $ "Line count = " ++ show (getSum lc)
     putStrLn $ "Word count = " ++ show (getSum . getK . fst $ runState wc False)

data Iterator a
  = Stop
  | Yield a (Bool -> Iterator a)

instance Monoid (Iterator a) where
  mempty = Stop
  Stop `mappend` m2 = m2
  Yield a f `mappend` m2 = Yield a (fmap (<> m2) f)

iterator :: Traversable f => f a -> Iterator a
iterator x = getK $ traverse (\a -> K $ Yield a $ \_ -> Stop) x

iterateList :: [a] -> Iterator a
iterateList = iterator

getAll :: Iterator a -> [a]
getAll Stop = []
getAll (Yield x cont) = x : getAll (cont True)

mergeList :: Ord a => [a] -> [a] -> [a]
mergeList xs ys = mergeIter (iterateList xs) (iterateList ys)
  where
    mergeIter Stop it2 = getAll it2
    mergeIter it1 Stop = getAll it1
    mergeIter it1@(Yield x c1) it2@(Yield y c2)
      | x <= y = x : mergeIter (c1 True) it2
      | otherwise = y : mergeIter it1 (c2 True)