number lines XLVIII

lines_url.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}

-- https://gist.github.com/michaelt/88e1fac12876857deefe
-- following
-- https://gist.github.com/gelisam/c769d186493221d7ebbe and associated controversy.

module Main where

import Pipes
import Pipes.Group
import Pipes.HTTP
import Pipes.Text hiding (take, map)
import Pipes.Text.Encoding
import Pipes.Text.IO (toHandle,stdout)
import qualified Pipes.ByteString as PB
import qualified Pipes.Prelude as P

import qualified System.IO as IO
import System.Environment (getArgs)
import Data.Functor.Compose
import Control.Monad.Trans.Free
import Control.Monad
import Data.Char
import qualified Data.Text as T
import Control.Lens hiding (each)
import Prelude hiding (lines, filter)
import Text.Read (readMaybe)
import Data.Maybe 

main = do
  ns <- fmap (catMaybes . map readMaybe) getArgs :: IO [Int] -- req <- parseUrl "http://www.example.com"
  req <- parseUrl "https://raw.githubusercontent.com/michaelt/kjv/master/kjv.txt"
  withManager tlsManagerSettings $ \m ->
    withHTTP req m $ \resp ->  void $ runEffect $ 
     number_lines ns (responseBody resp ^. utf8 . lines) >-> toHandle IO.stdout
 where 
  number_lines :: Monad m => [Int] -> FreeT (Producer Text m) m x -> Producer Text m ()
  number_lines [0] = number_lines_0
  number_lines [1] = number_lines_1
  number_lines [2] = number_lines_2
  number_lines _   = number_lines_3

prepend :: Integer -> Text
prepend n = T.pack ("\n" ++ show n ++ " ")

number_lines_1 :: Monad m => FreeT (Producer Text m) m s -> Producer Text m () 
number_lines_1 = void . concats . zipsWith (\a p -> yield a >> p) prefixes 
 where prefixes = for (each [1 ..]) (yield . prepend)

number_lines_2 :: Monad m => FreeT (Producer Text m) m r -> Producer Text m ()
number_lines_2 = void . concats . maps mkPrefix . zips (each [1 ..]) 
 where mkPrefix (P n fx) = yield (prepend n) >> fx

number_lines_3 :: Monad m => FreeT (Producer Text m) m s -> Producer Text m ()
number_lines_3  = void . concats . zipWithFree mkPrefix integers  where 
  mkPrefix (n,x) prod = do yield (prepend n)
                           fmap ((,) x) prod
  integers :: Monad m => FreeT ((,) Integer) m ()
  integers = singletons $ each [1::Integer ..]

number_lines_0 :: Monad m => FreeT (Producer Text m) m bad -> Producer Text m ()
number_lines_0  = number_loop (1 :: Integer) where
  number_loop n freeProducers = do
        freeProducer <- lift $ runFreeT freeProducers
        case freeProducer of
          Pure badbytes -> do yield $ T.pack "\n"
                              return ()
          Free p -> do yield (prepend n) 
                       nextFreeProducers <- p
                       number_loop (n + 1) nextFreeProducers

zipsWith :: (Monad m, Functor f, Functor g) 
   => (forall x . a -> f x -> g x)
   -> Producer a m r 
   -> FreeT f m s
   -> FreeT g m (Either (r, FreeT f m s) (Producer a m r, s))

zipsWith phi prod (FreeT mff) = FreeT (mff >>= loop prod)  where
  loop p ff = liftM (pure_loop ff) (next p)
  pure_loop ff e = case (e, ff) of 
      (Left r, _)               -> Pure $ Left  (r, FreeT (return ff))
      (Right (a,p'), Pure s)    -> Pure $ Right (yield a >> p', s)
      (Right (a,p'), Free free) -> 
                      let new_layer = phi a free 
                          recurse f = FreeT (runFreeT f >>= loop p') 
                      in Free (fmap recurse new_layer)


data P a f r = P !a (f r) -- Compose ((,) a) f r
instance Functor f => Functor (P a f) where
  fmap f (P a fr) = P a (fmap f fr)

zips :: (Functor f, Monad m) =>
       Producer a m x
       -> FreeT f m b -> FreeT (P a f) m (Either (FreeT f m b) b)
zips p = liftM (either (Left . snd) (Right . snd)) . zipsWith P p

zips' :: (Functor f, Monad m) 
      => Producer a m x
      -> FreeT f m r
      -> FreeT (Compose ((,) a) f) m (Either (FreeT f m r) r)
zips' p = liftM (either (Left . snd) (Right . snd)) 
          . zipsWith (\a b -> Compose (a,b)) p

singletons :: Monad m => Producer a m r -> FreeT ((,) a) m r
singletons = FreeT . liftM (either Pure (Free . fmap singletons)) . next 

pack_singletons :: Monad m => FreeT ((,) a) m r -> Producer a m r
pack_singletons = lift . runFreeT >=> go
  where go = \case Pure r -> return r
                   Free (a,fff) -> do yield a
                                      pack_singletons fff

zipWithFree :: (Monad m, Functor f, Functor g, Functor h) 
  => (forall x y . f x -> g y -> h (x,y)) 
  -> FreeT f m r -> FreeT g m s 
  -> FreeT h m (Either (r,FreeT g m s) (FreeT f m r, s))
zipWithFree phi = loop where
  loop (FreeT mf) (FreeT mg) = FreeT (liftM2 pure_ mf mg)
  pure_ (Pure r)  p          = Pure (Left  (r, FreeT (return p)))
  pure_ q         (Pure s)   = Pure (Right (FreeT (return q), s))
  pure_ (Free fx) (Free gy)  = Free (fmap (uncurry loop) (phi fx gy))

-- ------
-- attempt at a better return type and 
-- maybe better (pure) first argument type
-- ------

zippedWith :: (Monad m, Functor f, Functor g, Foldable foldable) 
     => (forall x . a -> f x -> g x)
     -> foldable a
     -> FreeT f m s
     -> FreeT g m (Either (FreeT f m s) s)
zippedWith phi fs  = liftM cases . zipsWith phi (each fs)
    where cases (Left  (_,free)) = Left free
          cases (Right (_, s))   = Right s