module Snap.Snaplet.Fay.Internal where
import Control.Applicative
import Control.Monad
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Default
import qualified Fay as F
import qualified Fay.Compiler.Config as F
import System.Directory
import System.FilePath
data Fay = Fay {
snapletFilePath :: FilePath
, verbose :: Bool
, compileMode :: CompileMode
, prettyPrint :: Bool
, _includeDirs :: [FilePath]
, packages :: [String]
} deriving (Show)
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, Show)
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
f' <- canonicalizePath f
res <- flip F.compileFile f' $ F.addConfigPackages (packages config) $
F.addConfigDirectoryIncludePaths (includeDirs config) $
def { F.configPrettyPrint = prettyPrint config
, F.configFilePath = Just 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 $ Success $ "console.error('" ++ (C.unpack . A.encode) 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
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: " ++ )