UniqHash.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}

module UniqHash (main, uniqHash) where

import Data.Machine
import Control.Monad          (when)
import System.Directory       (doesFileExist)
import Control.Category       (Category)
import Data.Digest.Pure.MD5   (MD5Digest, hash')
import Control.Monad.IO.Class (liftIO)

import qualified Data.Map        as M
import qualified Data.ByteString as B

--- UniqHash

main :: IO ()
main = runT_ $ stdinMachine ~> uniqHash ~> stdoutMachine

uniqHash :: ProcessT IO String String
uniqHash = splitZip echo (fileExists ~> md5machine)
        ~> construct (lookupM M.empty)

--- Helpers

stdinMachine :: SourceT IO String
stdinMachine = construct $ liftIO getContents >>= mapM_ yield . lines

stdoutMachine :: ProcessT IO String ()
stdoutMachine = repeatedly $ await >>= liftIO . putStrLn

fileExists :: ProcessT IO String (Maybe String)
fileExists = repeatedly $ do
  fn <- await
  ex <- liftIO $ doesFileExist fn

  yield $ if ex then Just fn
                else Nothing

md5machine :: ProcessT IO (Maybe String) (Maybe MD5Digest)
md5machine = repeatedly $ await >>= liftIO . fileMD5 >>= yield
  where
  fileMD5 :: Maybe String -> IO (Maybe MD5Digest)
  fileMD5 (Just fileName) = fmap (Just . hash') (B.readFile fileName)
  fileMD5  Nothing        = return Nothing

lookupM :: (Category k, Ord o, Eq a) => M.Map o a -> PlanT (k (o, a)) o m ()
lookupM m = do
  (fileName, hashVal) <- await

  case M.lookup fileName m of
       Nothing -> yield fileName
       Just v  -> when (hashVal /= v) (yield fileName)

  lookupM (M.insert fileName hashVal m)

-- Possibly exist in libraries?

double :: MachineT IO (Is o) o
double = repeatedly $ do
  i <- await
  yield i
  yield i

splitZipWith :: ProcessT IO a a' -> ProcessT IO a b' -> TeeT IO a' b' c -> MachineT IO (Is a) c
splitZipWith a b o = double ~> fit cappedT (tee a b o)
  where
  -- Redefined since this is private...
  cappedT :: T a a b -> Is a b
  cappedT R = Refl
  cappedT L = Refl

splitZip :: ProcessT IO a a' -> ProcessT IO a b' -> MachineT IO (Is a) (a', b')
splitZip a b = splitZipWith a b tpair

tpair :: MachineT IO (T t t1) (t, t1)
tpair = repeatedly $ do
  fn <- awaits L
  md <- awaits R
  yield (fn,md)