-- |
-- Module      : Debian.Package.Build.Monad
-- Copyright   : 2014-2015 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : portable
--
-- This module provides monad types to control build scripts.
module Debian.Package.Build.Monad
       ( Trace, runTrace, traceCommand, traceOut, putLog
       , bracketTrace, bracketTrace_

       , BaseDir

       , askBaseDir, askBuildDir

       , BuildDir, buildDirRelative, buildDirAbsolute

       , Config, defaultConfig, buildDir, debianDirName, sourceExcludes

       , Build, liftTrace, unBuild, runBuild, askConfig
       , bracketBuild, bracketBuild_
       ) where

import System.FilePath ((</>))
import System.IO (hPutStrLn, hFlush, stderr, stdout)
import Control.Applicative ((<$>))
import Control.Monad (when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
import Control.Exception (bracket)


readerBracket :: Monad m
             => (m a -> (a -> m b) -> (a -> m c) -> m c)
             -> ReaderT r m a
             -> (a -> ReaderT r m b)
             -> (a -> ReaderT r m c)
             -> ReaderT r m c
readerBracket :: (m a -> (a -> m b) -> (a -> m c) -> m c)
-> ReaderT r m a
-> (a -> ReaderT r m b)
-> (a -> ReaderT r m c)
-> ReaderT r m c
readerBracket m a -> (a -> m b) -> (a -> m c) -> m c
brkt ReaderT r m a
open a -> ReaderT r m b
close a -> ReaderT r m c
body = do
  r
r <- ReaderT r m r
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  m c -> ReaderT r m c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m c -> ReaderT r m c) -> m c -> ReaderT r m c
forall a b. (a -> b) -> a -> b
$ m a -> (a -> m b) -> (a -> m c) -> m c
brkt
    (ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r m a
open r
r)
    (\a
a -> ReaderT r m b -> r -> m b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ReaderT r m b
close a
a) r
r)
    (\a
a -> ReaderT r m c -> r -> m c
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ReaderT r m c
body a
a) r
r)

toBracket_ :: Monad m
           => (m a -> (a -> m b) -> (a -> m c) -> m c)
           -> m a
           -> m b
           -> m c
           -> m c
toBracket_ :: (m a -> (a -> m b) -> (a -> m c) -> m c)
-> m a -> m b -> m c -> m c
toBracket_ m a -> (a -> m b) -> (a -> m c) -> m c
brkt m a
start m b
end m c
body =
  m a -> (a -> m b) -> (a -> m c) -> m c
brkt m a
start (m b -> a -> m b
forall a b. a -> b -> a
const m b
end) (m c -> a -> m c
forall a b. a -> b -> a
const m c
body)

-- | Action type with trace flag
type Trace = ReaderT Bool IO

-- | Run 'Trace' monad
runTrace :: Trace a -> Bool -> IO a
runTrace :: Trace a -> Bool -> IO a
runTrace =  Trace a -> Bool -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT

traceIO :: IO () -> Trace ()
traceIO :: IO () -> Trace ()
traceIO IO ()
printIO = do
  Bool
t <- ReaderT Bool IO Bool
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  Bool -> Trace () -> Trace ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
t (Trace () -> Trace ()) -> Trace () -> Trace ()
forall a b. (a -> b) -> a -> b
$ IO () -> Trace ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO ()
printIO

-- | bracket for 'Trace' monad
bracketTrace :: Trace a -> (a -> Trace b) -> (a -> Trace c) -> Trace c
bracketTrace :: Trace a -> (a -> Trace b) -> (a -> Trace c) -> Trace c
bracketTrace =  (IO a -> (a -> IO b) -> (a -> IO c) -> IO c)
-> Trace a -> (a -> Trace b) -> (a -> Trace c) -> Trace c
forall (m :: * -> *) a b c r.
Monad m =>
(m a -> (a -> m b) -> (a -> m c) -> m c)
-> ReaderT r m a
-> (a -> ReaderT r m b)
-> (a -> ReaderT r m c)
-> ReaderT r m c
readerBracket IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket

-- | bracket_ for 'Trace' monad
bracketTrace_ :: Trace a -> Trace b -> Trace c -> Trace c
bracketTrace_ :: Trace a -> Trace b -> Trace c -> Trace c
bracketTrace_ =  (Trace a -> (a -> Trace b) -> (a -> Trace c) -> Trace c)
-> Trace a -> Trace b -> Trace c -> Trace c
forall (m :: * -> *) a b c.
Monad m =>
(m a -> (a -> m b) -> (a -> m c) -> m c)
-> m a -> m b -> m c -> m c
toBracket_ Trace a -> (a -> Trace b) -> (a -> Trace c) -> Trace c
forall a b c.
Trace a -> (a -> Trace b) -> (a -> Trace c) -> Trace c
bracketTrace

tprint :: Char -> String -> IO ()
tprint :: Char -> String -> IO ()
tprint Char
pc String
s = do
  let fh :: Handle
fh = Handle
stderr
  Handle -> String -> IO ()
hPutStrLn Handle
fh (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Char
pc Char -> String -> String
forall a. a -> [a] -> [a]
: String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
  Handle -> IO ()
hFlush Handle
fh

-- | Command string trace print along with trace flag
traceCommand :: String -> Trace ()
traceCommand :: String -> Trace ()
traceCommand =  IO () -> Trace ()
traceIO (IO () -> Trace ()) -> (String -> IO ()) -> String -> Trace ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> IO ()
tprint Char
'+'

-- | Output string trace print along with trace flag
traceOut :: String -> Trace ()
traceOut :: String -> Trace ()
traceOut =  IO () -> Trace ()
traceIO (IO () -> Trace ()) -> (String -> IO ()) -> String -> Trace ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> IO ()
tprint Char
'>'

-- | Put log stinrg with flush.
putLog :: String -> Trace ()
putLog :: String -> Trace ()
putLog String
s = IO () -> Trace ()
traceIO (IO () -> Trace ()) -> IO () -> Trace ()
forall a b. (a -> b) -> a -> b
$ do
  let fh :: Handle
fh = Handle
stdout
  Handle -> String -> IO ()
hPutStrLn Handle
fh String
s
  Handle -> IO ()
hFlush Handle
fh

-- | Type to specify base directory filepath
type BaseDir = FilePath

-- | Type to specify build working directory
newtype BuildDir = BuildDir (Either FilePath FilePath)

-- | Use relative path from base-dir as build workding directory
buildDirRelative :: FilePath -> BuildDir
buildDirRelative :: String -> BuildDir
buildDirRelative = Either String String -> BuildDir
BuildDir (Either String String -> BuildDir)
-> (String -> Either String String) -> String -> BuildDir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String String
forall a b. a -> Either a b
Left

-- | Use absolute path as build workding directory
buildDirAbsolute :: FilePath -> BuildDir
buildDirAbsolute :: String -> BuildDir
buildDirAbsolute =  Either String String -> BuildDir
BuildDir (Either String String -> BuildDir)
-> (String -> Either String String) -> String -> BuildDir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String String
forall a b. b -> Either a b
Right

-- | Fold build dir
unBuildDir :: FilePath -> BuildDir -> FilePath
unBuildDir :: String -> BuildDir -> String
unBuildDir String
base (BuildDir Either String String
b) = (String -> String)
-> (String -> String) -> Either String String -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String
base String -> String -> String
</>) String -> String
forall a. a -> a
id Either String String
b

-- | Show 'BuildDir' is relative or absolute
instance Show BuildDir where
  show :: BuildDir -> String
show = BuildDir -> String
d  where
    d :: BuildDir -> String
d (BuildDir (Left  String
p)) = String
"Relative " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p
    d (BuildDir (Right String
p)) = String
"Absolute " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p

-- | Build configuration type
data Config =
  Config
  { Config -> BuildDir
buildDir        :: BuildDir   -- ^ Specify build dir
  , Config -> String
debianDirName   :: FilePath   -- ^ Name of debian directory
  , Config -> [String]
sourceExcludes  :: [FilePath] -- ^ Exclude directories to setup source directory
  } deriving Int -> Config -> String -> String
[Config] -> String -> String
Config -> String
(Int -> Config -> String -> String)
-> (Config -> String)
-> ([Config] -> String -> String)
-> Show Config
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Config] -> String -> String
$cshowList :: [Config] -> String -> String
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> String -> String
$cshowsPrec :: Int -> Config -> String -> String
Show

-- | Default configuration
defaultConfig :: (Config, Bool)
defaultConfig :: (Config, Bool)
defaultConfig =  (Config :: BuildDir -> String -> [String] -> Config
Config
                  { buildDir :: BuildDir
buildDir       = String -> BuildDir
buildDirRelative String
".debian-build"
                  , debianDirName :: String
debianDirName  = String
"debian"
                  , sourceExcludes :: [String]
sourceExcludes = [String
".git", String
".hg"]
                  },
                  Bool
True)

-- | Monad type with build base directory and build configuration.
type Build = ReaderT BaseDir (ReaderT Config Trace)

-- | Lift from 'Trace' monad into monad with 'Build' configuration.
liftTrace :: Trace a -> Build a
liftTrace :: Trace a -> Build a
liftTrace =  ReaderT Config Trace a -> Build a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT Config Trace a -> Build a)
-> (Trace a -> ReaderT Config Trace a) -> Trace a -> Build a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace a -> ReaderT Config Trace a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Unpack 'Build' configuration monad into 'Trace'.
unBuild :: Build a -> BaseDir -> Config -> Trace a
unBuild :: Build a -> String -> Config -> Trace a
unBuild Build a
b String
bd = ReaderT Config Trace a -> Config -> Trace a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT Config Trace a -> Config -> Trace a)
-> ReaderT Config Trace a -> Config -> Trace a
forall a b. (a -> b) -> a -> b
$ Build a -> String -> ReaderT Config Trace a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Build a
b String
bd

-- | Run 'Build' configuration monad
runBuild :: Build a -> BaseDir -> Config -> Bool -> IO a
runBuild :: Build a -> String -> Config -> Bool -> IO a
runBuild Build a
b String
bd = Trace a -> Bool -> IO a
forall a. Trace a -> Bool -> IO a
runTrace (Trace a -> Bool -> IO a)
-> (Config -> Trace a) -> Config -> Bool -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Build a -> String -> Config -> Trace a
forall a. Build a -> String -> Config -> Trace a
unBuild Build a
b String
bd

-- | bracket for 'Build' monad
bracketBuild :: Build a -> (a -> Build b) -> (a -> Build c) -> Build c
bracketBuild :: Build a -> (a -> Build b) -> (a -> Build c) -> Build c
bracketBuild =  (ReaderT Config Trace a
 -> (a -> ReaderT Config Trace b)
 -> (a -> ReaderT Config Trace c)
 -> ReaderT Config Trace c)
-> Build a -> (a -> Build b) -> (a -> Build c) -> Build c
forall (m :: * -> *) a b c r.
Monad m =>
(m a -> (a -> m b) -> (a -> m c) -> m c)
-> ReaderT r m a
-> (a -> ReaderT r m b)
-> (a -> ReaderT r m c)
-> ReaderT r m c
readerBracket ((ReaderT Config Trace a
  -> (a -> ReaderT Config Trace b)
  -> (a -> ReaderT Config Trace c)
  -> ReaderT Config Trace c)
 -> Build a -> (a -> Build b) -> (a -> Build c) -> Build c)
-> (ReaderT Config Trace a
    -> (a -> ReaderT Config Trace b)
    -> (a -> ReaderT Config Trace c)
    -> ReaderT Config Trace c)
-> Build a
-> (a -> Build b)
-> (a -> Build c)
-> Build c
forall a b. (a -> b) -> a -> b
$ (ReaderT Bool IO a
 -> (a -> ReaderT Bool IO b)
 -> (a -> ReaderT Bool IO c)
 -> ReaderT Bool IO c)
-> ReaderT Config Trace a
-> (a -> ReaderT Config Trace b)
-> (a -> ReaderT Config Trace c)
-> ReaderT Config Trace c
forall (m :: * -> *) a b c r.
Monad m =>
(m a -> (a -> m b) -> (a -> m c) -> m c)
-> ReaderT r m a
-> (a -> ReaderT r m b)
-> (a -> ReaderT r m c)
-> ReaderT r m c
readerBracket ReaderT Bool IO a
-> (a -> ReaderT Bool IO b)
-> (a -> ReaderT Bool IO c)
-> ReaderT Bool IO c
forall a b c.
Trace a -> (a -> Trace b) -> (a -> Trace c) -> Trace c
bracketTrace

-- | bracket_ for 'Build' monad
bracketBuild_ :: Build a -> Build b -> Build c -> Build c
bracketBuild_ :: Build a -> Build b -> Build c -> Build c
bracketBuild_ =  (Build a -> (a -> Build b) -> (a -> Build c) -> Build c)
-> Build a -> Build b -> Build c -> Build c
forall (m :: * -> *) a b c.
Monad m =>
(m a -> (a -> m b) -> (a -> m c) -> m c)
-> m a -> m b -> m c -> m c
toBracket_ Build a -> (a -> Build b) -> (a -> Build c) -> Build c
forall a b c.
Build a -> (a -> Build b) -> (a -> Build c) -> Build c
bracketBuild

-- | Get base directory in 'Build' monad
askBaseDir :: Build FilePath
askBaseDir :: Build String
askBaseDir =  Build String
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

-- | Get build configuration in 'Build' monad
askConfig :: Build Config
askConfig :: Build Config
askConfig =  ReaderT Config Trace Config -> Build Config
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT Config Trace Config
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

-- | Get build working directory in 'Build' monad
askBuildDir :: Build FilePath
askBuildDir :: Build String
askBuildDir =  do
  BuildDir
bd <- Config -> BuildDir
buildDir (Config -> BuildDir)
-> Build Config -> ReaderT String (ReaderT Config Trace) BuildDir
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Build Config
askConfig
  (String -> BuildDir -> String
`unBuildDir` BuildDir
bd) (String -> String) -> Build String -> Build String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Build String
askBaseDir