yesod-fay 0.2.0.1 → 0.3.0
raw patch · 3 files changed
+155/−61 lines, 3 filesdep +directorydep +yesod-staticdep ~fay
Dependencies added: directory, yesod-static
Dependency ranges changed: fay
Files
- Language/Fay/Yesod.hs +40/−12
- Yesod/Fay.hs +111/−47
- yesod-fay.cabal +4/−2
Language/Fay/Yesod.hs view
@@ -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})"
Yesod/Fay.hs view
@@ -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)
yesod-fay.cabal view
@@ -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 <http://www.yesodweb.com/blog/2012/10/yesod-fay-js>. 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