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 {
srcDir :: FilePath
, destDir :: FilePath
, includeDirs :: [FilePath]
, verbose :: Bool
, compileMethod :: CompileMethod
}
data CompileMethod = CompileOnDemand | CompileAll
compileFile :: Fay -> FilePath -> IO (Maybe String)
compileFile config f = do
exists <- doesFileExist f
if not exists
then do
putStrLn $ "snaplet-fay: Could not find: " ++ hsRelativePath f
return Nothing
else do
res <- F.compileFile (def { F.configDirectoryIncludes = includeDirs config }) True f
case res of
Right out -> do
verbosePut config $ "Compiled " ++ hsRelativePath f
return $ Just out
Left err -> do
putStrLn $ "snaplet-fay: Error compiling " ++ hsRelativePath f ++ ":"
print err
return Nothing
shouldCompile :: Fay -> FilePath -> IO Bool
shouldCompile config hsFile = do
jsExists <- doesFileExist (jsPath config hsFile)
if not jsExists
then return True
else do
hsmod <- getModificationTime hsFile
jsmod <- getModificationTime (jsPath config hsFile)
return $ hsmod > jsmod
compileAll :: Fay -> IO ()
compileAll config = do
files <- filterM (shouldCompile config) =<< extFiles "hs" (srcDir config)
forM_ files $ \f -> do
res <- compileFile config f
case res of
Just s -> writeFile (jsPath config f) s
Nothing -> return ()
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: " ++ )