module Development.Duplo.Utilities where
import Control.Applicative ((<$>))
import Control.Lens.Operators
import Control.Monad (filterM, zipWithM)
import Control.Monad.Except (ExceptT(..), runExceptT)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Class (lift)
import Data.List (intercalate, isSuffixOf)
import Development.Duplo.Files (readFile, File(..), fileContent)
import Development.Shake (CmdOption(..))
import Development.Shake.FilePath ((</>))
import Prelude hiding (readFile)
import System.Console.ANSI (setSGR, SGR(..), ConsoleLayer(..), ColorIntensity(..), Color(..))
import System.FilePath.Posix (joinPath, splitPath)
import qualified Control.Lens as CL
import qualified Development.Duplo.Component as CM
import qualified Development.Duplo.Types.AppInfo as AI
import qualified Development.Duplo.Types.Config as TC
import qualified Development.Shake as DS
type CompiledContent = ExceptT String DS.Action
type FileProcessor = [File] -> CompiledContent [File]
type StringProcessor = String -> CompiledContent String
makePattern :: FilePath -> String -> FilePath
makePattern base extension = base ++ "//*" ++ extension
makeValidPattern :: FilePath -> String -> DS.Action [FilePath]
makeValidPattern base extension = do
exists <- DS.doesDirectoryExist base
let ptrn = makePattern base extension
return [ ptrn | exists ]
makeFilePatterns :: [FilePath] -> [String] -> DS.Action [DS.FilePattern]
makeFilePatterns bases exts = do
patternList <- zipWithM makeValidPattern bases exts
let concat = foldl1 (++)
let patterns = if null patternList
then return []
else concat patternList
return patterns
getDirectoryFilesInOrder :: FilePath -> String -> [DS.FilePattern] -> DS.Action [FilePath]
getDirectoryFilesInOrder base extension patterns = do
let listSize = length patterns
let exts = replicate listSize extension
let absPatterns = fmap (base </>) patterns
validPatterns <- makeFilePatterns absPatterns exts
let relPatterns = fmap (drop (length base + 1)) validPatterns
let patternLists = fmap (replicate 1) relPatterns
let getFiles = getDirectoryFiles base
allFiles <- mapM getFiles patternLists
let files = concat $ filter (not . null) allFiles
return files
compile :: TC.BuildConfig
-> FilePath
-> [String]
-> [FilePath]
-> FileProcessor
-> StringProcessor
-> CompiledContent String
compile config compiler params paths preprocess postprocess = do
mapM_ (lift . DS.putNormal . ("Including " ++)) paths
let cwd = config ^. TC.cwd
files <- mapM (readFile cwd) paths
processed <- preprocess files
let contents = fmap (^. fileContent) processed
let concatenated = intercalate "\n" contents ++ "\n"
postprocessed <- (++ "\n") <$> postprocess concatenated
envOpt <- createStdEnv config
lift $ DS.putNormal $ "Compiling with: "
++ compiler
++ " "
++ unwords params
DS.Stdout compiled <-
lift $ DS.command [DS.Stdin postprocessed, envOpt] compiler params
return compiled
expandPaths :: FilePath -> String -> [FilePath] -> [FilePath] -> DS.Action [FilePath]
expandPaths cwd extension staticPaths dynamicPaths = do
let expandStatic = map (\p -> cwd </> p ++ extension)
let expandDynamic = map (cwd </>)
staticExpanded <- filterM DS.doesFileExist $ expandStatic staticPaths
dynamicExpanded <- getDirectoryFilesInOrder cwd extension dynamicPaths
return $ staticExpanded ++ expandDynamic dynamicExpanded
createPathDirectories :: [FilePath] -> DS.Action ()
createPathDirectories paths = do
let mkdir dir = DS.command_ [] "mkdir" ["-p", dir]
existing <- filterM (fmap not . DS.doesDirectoryExist) paths
mapM_ mkdir existing
createIntermediaryDirectories :: String -> DS.Action ()
createIntermediaryDirectories path =
DS.command_ [] "mkdir" ["-p", dir]
where
dir = joinPath $ init $ splitPath path
expandDeps :: [String] -> (String -> [FilePath]) -> [FilePath]
expandDeps deps expander = concat $ fmap expander deps
getDirectoryFiles :: FilePath -> [DS.FilePattern] -> DS.Action [FilePath]
getDirectoryFiles base patterns = do
exist <- DS.doesDirectoryExist base
if exist
then DS.getDirectoryFiles base patterns
else return []
errorPrintSetter :: IO ()
errorPrintSetter = setSGR [ SetColor Background Vivid Red
, SetColor Foreground Vivid White
]
headerPrintSetter :: IO ()
headerPrintSetter = setSGR [ SetColor Foreground Vivid Magenta ]
successPrintSetter :: IO ()
successPrintSetter = setSGR [ SetColor Background Vivid Green
, SetColor Foreground Vivid White
]
logStatus :: IO () -> String -> IO ()
logStatus printSetter message = do
printSetter
putStr $ "\n>> " ++ message
setSGR [Reset]
putStrLn ""
createStdEnv :: MonadIO m => TC.BuildConfig -> m CmdOption
createStdEnv config = do
let cwd = config ^. TC.cwd
let util = config ^. TC.utilPath
let nodejs = config ^. TC.nodejsPath
let misc = config ^. TC.miscPath
let target = config ^. TC.targetPath
DS.addEnv [ ("DUPLO_UTIL", util)
, ("DUPLO_NODEJS", nodejs)
, ("DUPLO_CWD", cwd)
, ("DUPLO_MISC", misc)
, ("DUPLO_TARGET", target)
]