diff --git a/Language/Fay/Yesod.hs b/Language/Fay/Yesod.hs --- a/Language/Fay/Yesod.hs +++ b/Language/Fay/Yesod.hs @@ -1,44 +1,72 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} -- | Module to be shared between server and client. -- -- This module must be valid for both GHC and Fay. module Language.Fay.Yesod where +import Prelude +#ifdef FAY +import FFI +#else import Language.Fay.FFI -import Language.Fay.Prelude +#endif +import Data.Data +#ifdef FAY + +data Text = Text + deriving (Show, Read, Eq, Typeable, Data) + +fromString :: String -> Text +fromString = ffi "%1" + +toString :: Text -> String +toString = ffi "%1" + +#else + +import qualified Data.Text as T + +type Text = T.Text + +fromString :: String -> Text +fromString = T.pack + +toString :: Text -> String +toString = T.unpack + +#endif + -- | A proxy type for specifying what type a command should return. The final -- field for each data constructor in a command datatype should be @Returns@. data Returns a = Returns deriving (Show, Read, Data, Typeable) -- | Call a command. -call :: (Foreign a, Foreign command) - => (Returns a -> command) +call :: (Returns a -> command) -> (a -> Fay ()) -- ^ Success Handler -> Fay () call f g = ajaxCommand (f Returns) g -- ! Call a command, handling errors as well -callWithErrorHandling :: (Foreign a, Foreign command) - => (Returns a -> command) +callWithErrorHandling + :: (Returns a -> command) -> (a -> Fay ()) -- ^ Success Handler -> (Fay ()) -- ^ Failure Handler -> Fay () callWithErrorHandling f g h = ajaxCommandWithErrorHandling (f Returns) g h -- | Run the AJAX command. -ajaxCommand :: (Foreign a, Foreign command) - => command - -> (a -> Fay ()) -- ^ Success Handler +ajaxCommand :: Automatic command + -> (Automatic a -> Fay ()) -- ^ Success Handler -> Fay () ajaxCommand = ffi "jQuery['ajax']({ url: window['yesodFayCommandPath'], type: 'POST', data: { json: JSON.stringify(%1) }, dataType: 'json', success : %2})" -- | Run the AJAX command, handling errors as well -ajaxCommandWithErrorHandling :: (Foreign a, Foreign command) - => command - -> (a -> Fay ()) -- ^ Success Handler +ajaxCommandWithErrorHandling + :: Automatic command + -> (Automatic a -> Fay ()) -- ^ Success Handler -> (Fay ()) -- ^ Failure Handler -> Fay () ajaxCommandWithErrorHandling = ffi "jQuery['ajax']({ url: window['yesodFayCommandPath'], type: 'POST', data: { json: JSON.stringify(%1) }, dataType: 'json', success : %2, error: %3})" diff --git a/Yesod/Fay.hs b/Yesod/Fay.hs --- a/Yesod/Fay.hs +++ b/Yesod/Fay.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -58,6 +57,8 @@ module Yesod.Fay ( -- * Typeclass YesodFay (..) + , YesodFaySettings (..) + , yesodFaySettings -- * Include Fay programs , fayFileProd , fayFileReload @@ -72,67 +73,65 @@ , YesodJquery (..) ) where -import Control.Monad (unless) +import Control.Applicative ((<$>)) +import Control.Monad (unless, when) import Control.Monad.IO.Class (liftIO) -import Data.Aeson (decode, toJSON) +import Data.Aeson (decode, toJSON, Value) import Data.Aeson.Encode (fromValue) import qualified Data.ByteString.Lazy as L import Data.Data (Data) import Data.Default (def) +import Data.Maybe (isNothing) +import Data.Monoid ((<>), mempty) import Data.Text (pack, unpack) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import Data.Text.Encoding (encodeUtf8) -import Data.Text.Lazy.Builder (fromText, toLazyText) +import qualified Data.Text.Lazy.Encoding as TLE +import Data.Text.Lazy.Builder (fromText, toLazyText, Builder) import Filesystem (createTree, isFile, readTextFile) -import Filesystem.Path.CurrentOS (directory, encodeString) -#if MIN_VERSION_fay(0,10,0) -import Language.Fay (compileFile) -#else -import Language.Fay.Compiler (compileFile) -#endif -import Language.Fay.Convert (readFromFay, showToFay) -import Language.Fay.FFI (Foreign) -import Language.Fay.Types (CompileConfig, +import Filesystem.Path.CurrentOS (directory, encodeString, (), decodeString) +import Fay (compileFile, getRuntime) +import Fay.Convert (readFromFay, showToFay) +import Fay.Types (CompileConfig, configDirectoryIncludes, - addConfigDirectoryIncludes, - configTypecheck) + configTypecheck, + configExportRuntime, + configNaked) import Language.Fay.Yesod (Returns (Returns)) import Language.Haskell.TH.Syntax (Exp (LitE), Lit (StringL), Pred (ClassP), Q, Type (VarT), mkName, qAddDependentFile, qRunIO) +import System.Directory (copyFile) import System.Exit (ExitCode (ExitSuccess)) import System.Process (rawSystem) import Text.Julius (Javascript (Javascript), julius) import Yesod.Core (GHandler, GWidget, RenderRoute (..), RepJson, Yesod, - YesodDispatch (..), + YesodDispatch (..), addScript, addScriptEither, getUrlRender, getYesod, lift, lookupPostParam, mkYesodSub, parseRoutes, - toMasterHandler, toWidget) + toMasterHandler, toWidget, toWidgetHead) import Yesod.Form.Jquery (YesodJquery (..)) import Yesod.Handler (invalidArgs) import Yesod.Json (jsonToRepJson) +import Yesod.Static +jsMainCall :: Bool -> String -> Builder +jsMainCall False _ = mempty +jsMainCall True mn' = + "Fay$$_(" <> mn <> "$main);" + where + mn = fromText $ T.pack mn' + -- | Type class for applications using Fay. -- -- We depend on @YesodJquery@ since the generated client-side code uses jQuery -- for making Ajax calls. We have an associated type stating the command -- datatype. Since this datatype must be used by both the client and server, -- you should place its definition in the @fay-shared@ folder. -class ( Data (YesodFayCommand master) - , Read (YesodFayCommand master) - , Foreign (YesodFayCommand master) - , YesodJquery master - ) - => YesodFay master where - -- | The command type. This type must be shared between client and server - -- code, and should therefore be placed somewhere in @fay-shared@. The last - -- field for each data constructor must be of type @Returns@, with a type - -- parameter specify the actual return type. For example: - -- - -- > data Command = GetFib Int (Returns Int) - type YesodFayCommand master - +class YesodJquery master => YesodFay master where -- | User-defined function specifying how to respond to commands. Using the -- above datatype, this might look like: -- @@ -167,9 +166,24 @@ type CommandHandler sub master = forall s. (forall a. Show a => Returns a -> a -> GHandler sub master s) - -> YesodFayCommand master + -> Value -> GHandler sub master s +-- | A setttings data type for indicating whether the generated Javascript +-- should contain a copy of the Fay runtime or not. +data YesodFaySettings = YesodFaySettings + { yfsModuleName :: String + , yfsSeparateRuntime :: Maybe (FilePath, Exp) + , yfsPostProcess :: String -> IO String + , yfsExternal :: Maybe (FilePath, Exp) + } + +yesodFaySettings :: String -> YesodFaySettings +yesodFaySettings moduleName = YesodFaySettings moduleName Nothing return Nothing + +updateRuntime :: FilePath -> IO () +updateRuntime fp = getRuntime >>= \js -> createTree (directory $ decodeString fp) >> copyFile js fp + -- | The Fay subsite. data FaySite = FaySite @@ -201,7 +215,7 @@ case mtxt of Nothing -> invalidArgs ["No JSON provided"] Just txt -> - case decode (L.fromChunks [encodeUtf8 txt]) >>= readFromFay of + case decode (L.fromChunks [encodeUtf8 txt]) of Nothing -> error $ "Unable to parse input: " ++ show txt Just cmd -> f go cmd where @@ -229,11 +243,22 @@ addScriptEither $ urlJqueryJs master render <- lift getUrlRender -- FIXME get rid of toLazyText call below - toWidget [julius|window.yesodFayCommandPath = #{toJSON $ render $ fayRoute FayCommandR};|] + toWidgetHead [julius|window.yesodFayCommandPath = #{toJSON $ render $ fayRoute FayCommandR};|] mkfp :: String -> FilePath mkfp name = "fay/" ++ name ++ ".hs" +requireFayRuntime :: YesodFaySettings -> Q Exp +requireFayRuntime settings = do + maybe (return ()) + (\(path,_) -> qRunIO $ updateRuntime (path ++ "/fay-runtime.js")) + (yfsSeparateRuntime settings) + case yfsSeparateRuntime settings of + Nothing -> [| return () |] + Just (_,exp) -> do + hash <- qRunIO $ getRuntime >>= fmap base64md5 . L.readFile + [| addScript ($(return exp) (StaticRoute ["fay-runtime.js"] [(T.pack hash, "")])) |] + -- | A function that takes a String giving the Fay module name, and returns an -- TH splice that generates a @Widget@. type FayFile = String -> Q Exp @@ -241,27 +266,66 @@ -- | Does a full compile of the Fay code via GHC for type checking, and then -- embeds the Fay-generated Javascript as a static string. File changes during -- runtime will not be reflected. -fayFileProd :: FayFile -fayFileProd name = do +fayFileProd :: YesodFaySettings -> Q Exp +fayFileProd settings = do qAddDependentFile fp qRunIO writeYesodFay - eres <- qRunIO $ compileFile config fp + eres <- qRunIO $ compileFile config + { configExportRuntime = exportRuntime + , configNaked = not exportRuntime + } fp case eres of Left e -> error $ "Unable to compile Fay module \"" ++ name ++ "\": " ++ show e - Right s -> [|requireJQuery >> toWidget (const $ Javascript $ fromText $ pack s)|] + Right s -> do + s' <- qRunIO $ yfsPostProcess settings s + let contents = fromText (pack s') <> jsMainCall (not exportRuntime) name + external <- + case yfsExternal settings of + Nothing -> return [|Nothing|] + Just (fp, exp) -> do + let name = concat ["faygen-", hash, ".js"] + hash = base64md5 contents' + contents' = TLE.encodeUtf8 $ toLazyText contents + qRunIO $ L.writeFile (concat [fp, "/", name]) contents' + return [| Just ($(return exp), name) |] + + [| do + requireJQuery + $(requireFayRuntime settings) + case $external of + Nothing -> toWidget $ const $ Javascript $ fromText $ pack + $(return $ LitE $ StringL $ TL.unpack $ toLazyText contents) + Just (constructor, name) -> addScript $ constructor $ StaticRoute [name] [] + |] where + name = yfsModuleName settings + exportRuntime = isNothing (yfsSeparateRuntime settings) fp = mkfp name config :: CompileConfig -config = addConfigDirectoryIncludes ["fay", "fay-shared"] def +config = def + { configDirectoryIncludes + = (Nothing, "fay") + : (Nothing, "fay-shared") + : configDirectoryIncludes def + } -- | Performs no type checking on the Fay code. Each time the widget is -- requested, the Fay code will be compiled from scratch to Javascript. -fayFileReload :: FayFile -fayFileReload name = do - qRunIO writeYesodFay - [| - liftIO (compileFile config { configTypecheck = False } $ mkfp name) >>= \eres -> - (case eres of - Left e -> error $ "Unable to compile Fay module \"" ++ name ++ "\": " ++ show e - Right s -> requireJQuery >> toWidget (const $ Javascript $ fromText $ pack s))|] +fayFileReload :: YesodFaySettings -> Q Exp +fayFileReload settings = do + qRunIO writeYesodFay + [| + liftIO (compileFile config + { configTypecheck = False + , configExportRuntime = exportRuntime + , configNaked = not exportRuntime + } + $ mkfp name) >>= \eres -> do + (case eres of + Left e -> error $ "Unable to compile Fay module \"" ++ name ++ "\": " ++ show e + Right s -> requireJQuery >> $(requireFayRuntime settings) + >> toWidget (const $ Javascript $ fromText (pack s) <> jsMainCall (not exportRuntime) name))|] + where + name = yfsModuleName settings + exportRuntime = isNothing (yfsSeparateRuntime settings) diff --git a/yesod-fay.cabal b/yesod-fay.cabal --- a/yesod-fay.cabal +++ b/yesod-fay.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: yesod-fay -version: 0.2.0.1 +version: 0.3.0 synopsis: Utilities for using the Fay Haskell-to-JS compiler with Yesod. description: For initial discussion, see . This is a work-in-progress. homepage: https://github.com/snoyberg/yesod-fay @@ -18,11 +18,12 @@ exposed-modules: Yesod.Fay Language.Fay.Yesod build-depends: base >= 4 && < 5 - , fay >= 0.11 + , fay >= 0.14 , transformers >= 0.2 , aeson >= 0.6 , bytestring >= 0.9 , data-default >= 0.4 + , directory >= 1.1.0.2 , text >= 0.11 , system-fileio >= 0.3 , system-filepath >= 0.4 @@ -32,3 +33,4 @@ , yesod-core >= 1.1 , yesod-form >= 1.1 , yesod-json >= 1.1 + , yesod-static >= 1.1.1.2