Comparison of Arrow and Applicative classes by implementing file IO

ArrowVsApplicative.hs

{- 

example from

    http://blog.downstairspeople.org/2010/06/14/a-brutal-introduction-to-arrows/

rewritten using Applicative instance from

    http://cdsmith.wordpress.com/2011/07/30/arrow-category-applicative-part-i/

-}

module ArrowVsApplicative where

import Prelude hiding ( id, (.) )
import Control.Category
import Control.Arrow
import Control.Applicative

data IORWA a b = IORWA [FilePath] (a -> IO b)

instance Category IORWA where
  id = IORWA [] return

  IORWA sa actionA . IORWA sb actionB =
    IORWA (sa ++ sb) (\x -> actionB x >>= actionA)

instance Arrow IORWA where
  arr f = IORWA [] $ return . f

  first (IORWA s action) =
    IORWA s $ \(x,k) -> do x' <- action x
                           return (x',k)

instance ArrowChoice IORWA where
  left (IORWA files action) =
    IORWA files $ either (fmap Left . action) (return . Right)

instance Functor (IORWA a) where
  fmap f (IORWA files action) = IORWA files (fmap f . action)

instance Applicative (IORWA a) where
  pure x = IORWA [] (const (return x))

  IORWA as f <*> IORWA bs x = IORWA (as ++ bs) (\t -> f t <*> x t)

writeFileA :: FilePath -> IORWA String ()
writeFileA path = IORWA [path] $ \s -> writeFile path s

readFileA :: FilePath -> IORWA () String
readFileA path = IORWA [path] $ \_ -> readFile path



copy :: FilePath -> FilePath -> IORWA () ()
copy from to = writeFileA to . readFileA from



catArr :: [FilePath] -> FilePath -> IORWA () ()
catArr infiles outfile = writeFilesArr outfile . readFilesArr infiles

readFilesArr :: [FilePath] -> IORWA () [String]
readFilesArr []     = arr (const [])
readFilesArr (f:fs) = (readFileA f &&& readFilesArr fs) >>> arr (uncurry (:))

writeFilesArr :: FilePath -> IORWA [String] ()
writeFilesArr file =
    arr viewList >>> (id ||| ((writeFileA file *** writeFilesArr file)
                               >>> arr (const ())))
  where
    viewList []     = Left ()
    viewList (x:xs) = Right (x,xs)



catApp :: [FilePath] -> FilePath -> IORWA () ()
catApp infiles outfile = writeFilesApp outfile . readFilesApp infiles

readFilesApp :: [FilePath] -> IORWA () [String]
readFilesApp []     = pure []
readFilesApp (f:fs) = (:) <$> readFileA f <*> readFilesApp fs

writeFilesApp :: FilePath -> IORWA [String] ()
writeFilesApp file = undefined



cat2Arr :: (FilePath,FilePath) -> FilePath -> IORWA () ()
cat2Arr (in1,in2) out = write2Arr out . read2Arr (in1,in2)

read2Arr :: (FilePath,FilePath) -> IORWA () (String,String)
read2Arr (in1,in2) = readFileA in1 &&& readFileA in2

write2Arr :: FilePath -> IORWA (String,String) ()
write2Arr file = writeFileA file *** writeFileA file >>> arr (const ())



cat2App :: (FilePath,FilePath) -> FilePath -> IORWA () ()
cat2App (in1,in2) out = write2App out . read2App (in1,in2)

read2App :: (FilePath,FilePath) -> IORWA () (String,String)
read2App (in1,in2) = (,) <$> readFileA in1 <*> readFileA in2

write2App :: FilePath -> IORWA (String,String) ()
write2App file = undefined