CommonPrograms.hs

--
-- Unshipping Docker
--
-- Copyright © 2014 Anchor Systems, Pty Ltd and Others
--
-- The code in this file, and the program it is a part of, is
-- made available to you by its authors as open source software:
-- you can redistribute it and/or modify it under the terms of
-- the 3-clause BSD licence.
--

{-# LANGUAGE DeriveFunctor #-}

import System.Exit
import Control.Monad.Free
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S

data Command x
  = List FilePath x
  | Touch FilePath x
  | Contents FilePath (ByteString -> x)
  | Echo ByteString x
  | Help x
  | Exit Int
  deriving (Functor)

ls :: FilePath -> Free Command ByteString
ls path = liftF $ List path (S.pack path)

touch :: FilePath -> Free Command ()
touch path = liftF $ Touch path ()

cat :: FilePath -> Free Command ByteString
cat path = liftF $ Contents path id

echo :: ByteString -> Free Command ()
echo x = liftF $ Echo x ()

exit :: Int -> Free Command ()
exit code = liftF $ Exit code

help :: Free Command ()
help = liftF $ Help ()

-- Collapse our IOFree DSL into IO monad actions.
interpretDebug :: Free Command a -> IO a
interpretDebug (Pure r) = return r
interpretDebug (Free x) = case x of
    List path k -> do
                    putStrLn ("I would list " ++ path)
                    interpretDebug k

    Touch path k -> do
                    putStrLn ("I would touch " ++ path)
                    interpretDebug k

    Contents path k -> do
                    putStrLn ("I would apply f to " ++ path)
                    let p = S.pack "(what would have been read)"
                    interpretDebug (k p)
    Echo str k  -> do
                    putStrLn ("I will echo " ++ S.unpack str)
                    interpretDebug k

    Help k      -> putStrLn "Help for all" >> interpretDebug k

    Exit code   -> case code of 
                        0    -> exitWith ExitSuccess
                        _    -> exitWith (ExitFailure code)

interpretActual :: Free Command a -> IO a
interpretActual = iterM run
  where
    run (List path k)  = exec ("ls " ++ path) >> k
    run (Touch path k) = exec ("touch " ++ path) >> k
    run (Contents path k) = S.readFile path >>= k
    run (Echo str k)   = S.putStr str >> k
    run (Help k)       = exec "echo help" >> k
    run (Exit code)    = case code of 
                            0 -> exitWith ExitSuccess
                            _ -> exitWith (ExitFailure code)

    exec = putStrLn -- CHANGE

directoryListing :: Free Command ()
directoryListing = do
    ls "."
    touch "./junk"
    x <- cat "/etc/hostname"
    echo x
    exit 1
    help

main :: IO ()
main = interpretDebug directoryListing