Created
November 28, 2014 00:20
-
-
Save istathar/4419ed14a7eda4e1368e to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- | |
-- 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 | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment