iterator_pattern.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

import Control.Compose
import Control.Monad.Trans.State.Lazy
import Data.Char

newtype Const b a = Const { unConst :: b }
newtype M m a = Wrap { unWrap :: m a }

instance Functor m => Functor (M m) where
  fmap f x = Wrap (fmap f $ unWrap x)

instance Monad m => Applicative (M m) where 
  pure = Wrap . return
  f <*> x = Wrap (unWrap f <*> unWrap x)

class Coerce a b | a -> b where
  down :: a -> b
  up :: b -> a

instance Coerce (Id a) a where
  down = unId
  up = Id

instance Coerce (Const b a) b where
  down = unConst
  up = Const

instance (Coerce (m a) b, Coerce (n a) c) => Coerce ((m :*: n) a) (b, c) where
  down mxn = let (x, y) = unProd mxn in (down x, down y)
  up (x, y) = Prod (up x, up y)

instance (Functor m, Functor n, Coerce (m b) c, Coerce (n a) b) => Coerce ((m :. n) a) c where
  down = down . (fmap down) . unO
  up = O . (fmap up) . up

instance Coerce (m a) c => Coerce (M m a) c where
  down = down . unWrap
  up = Wrap . up

-- Word Count
type Count = Const Integer

instance Functor Count where
  fmap _ (Const x) = Const x

instance Applicative Count where
  pure _ = Const 0
  (Const x) <*> (Const y) = Const $ x + y

instance Coerce (State s a) (s -> (a, s)) where
  down = runState
  up = state

count :: a -> Count b
count _ = Const 1

cciBody :: Char -> Count a
cciBody = count

cci :: String -> Count [a]
cci = traverse cciBody

test :: Bool -> Integer
test b = if b then 1 else 0

lciBody :: Char -> Count a
lciBody c = up (test (c == '\n'))

wciBody :: Char -> (M (State Bool) :. Count) a
wciBody c = up (updateState c) where
  updateState :: Char -> Bool -> (Integer, Bool)
  updateState c w = let s = not (isSpace c) in (test (not w && s), s)

wci :: String -> (M (State Bool) :. Count) [a]
wci = traverse wciBody

runWci :: String -> Integer
runWci s = fst (down (wci s) False)