module Snap.Snaplet.Fay.Internal where
import Control.Applicative
import Control.Monad
import Data.Default
import qualified Language.Fay.Compiler as F
import qualified Language.Fay.Types as F
import System.Directory
import System.FilePath
data Fay = Fay {
snapletFilePath :: FilePath
, verbose :: Bool
, compileMode :: CompileMode
, prettyPrint :: Bool
, _includeDirs :: [FilePath]
}
srcDir :: Fay -> FilePath
srcDir = (</> "src") . snapletFilePath
destDir :: Fay -> FilePath
destDir = (</> "js") . snapletFilePath
includeDirs :: Fay -> [FilePath]
includeDirs config = srcDir config : _includeDirs config
data CompileMode = Development | Production
deriving Eq
data CompileResult = Success String | NotFound | Error String
compileFile :: Fay -> FilePath -> IO CompileResult
compileFile config f = do
exists <- doesFileExist f
if not exists
then do
putStrLn $ "snaplet-fay: Could not find: " ++ hsRelativePath f
return NotFound
else do
res <- F.compileFile def { F.configDirectoryIncludes = includeDirs config
, F.configPrettyPrint = prettyPrint config
, F.configAutorun = True } f
case res of
Right out -> do
verbosePut config $ "Compiled " ++ hsRelativePath f
writeFile (jsPath config f) out
return $ Success out
Left err -> do
let errString = "snaplet-fay: Error compiling " ++ hsRelativePath f ++ ":\n" ++ show err
putStrLn errString
return $ Error errString
compileAll :: Fay -> IO ()
compileAll config = do
files <- extFiles "hs" (srcDir config)
forM_ files $ compileFile config
oldFiles <- extFiles "js" (destDir config) >>= filterM (liftM not . doesFileExist . hsPath config)
forM_ oldFiles $ \f -> do
removeFile f
verbosePut config $ "Removed orphaned " ++ jsRelativePath f
where
hasSuffix :: String -> String -> Bool
hasSuffix s suffix = reverse suffix == take (length suffix) (reverse s)
filename :: FilePath -> FilePath
filename = reverse . takeWhile (/= '/') . reverse
toHsName :: String -> String
toHsName x = case reverse x of
('s':'j':'.': (reverse -> file)) -> file ++ ".hs"
_ -> x
extFiles :: String -> FilePath -> IO [FilePath]
extFiles ext dir = map (dir </>) . filter (`hasSuffix` ('.' : ext)) <$> getDirectoryContents dir
jsPath :: Fay -> FilePath -> FilePath
jsPath config f = destDir config </> filename (F.toJsName f)
hsPath :: Fay -> FilePath -> FilePath
hsPath config f = srcDir config </> filename (toHsName f)
jsRelativePath :: FilePath -> FilePath
jsRelativePath f = "snaplets/fay/js" </> filename f
hsRelativePath :: FilePath -> FilePath
hsRelativePath f = "snaplets/fay/src" </> filename f
verbosePut :: Fay -> String -> IO ()
verbosePut config = when (verbose config) . putStrLn . ("snaplet-fay: " ++ )