diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,64 @@ +Copyright (c) 2014, Marcin Tolysz All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Marcin Tolysz nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +--- +-- snoyberg/yesod-js +Copyright 2010, Michael Snoyman. All rights reserved. + +The following license covers this documentation, and the source code, except +where otherwise indicated. + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +--- +-- yesodweb/shakespeare + +Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +-- + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Text/Naked/Coffee.hs b/src/Text/Naked/Coffee.hs new file mode 100644 --- /dev/null +++ b/src/Text/Naked/Coffee.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +-- | A Shakespearean module for CoffeeScript, introducing type-safe, +-- compile-time variable and url interpolation. It is exactly the same as +-- "Text.Julius", except that the template is first compiled to Javascript with +-- the system tool @coffee@. +-- +-- To use this module, @coffee@ must be installed on your system. +-- +-- @#{...}@ is the Shakespearean standard for variable interpolation, but +-- CoffeeScript already uses that sequence for string interpolation. Therefore, +-- Shakespearean interpolation is introduced with @%{...}@. +-- +-- If you interpolate variables, +-- the template is first wrapped with a function containing javascript variables representing shakespeare variables, +-- then compiled with @coffee@, +-- and then the value of the variables are applied to the function. +-- This means that in production the template can be compiled +-- once at compile time and there will be no dependency in your production +-- system on @coffee@. +-- +-- Your code: +-- +-- > b = 1 +-- > console.log(#{a} + b) +-- +-- Function wrapper added to your coffeescript code: +-- +-- > ((shakespeare_var_a) => +-- > b = 1 +-- > console.log(shakespeare_var_a + b) +-- > ) +-- +-- This is then compiled down to javascript, and the variables are applied: +-- +-- > ;(function(shakespeare_var_a){ +-- > var b = 1; +-- > console.log(shakespeare_var_a + b); +-- > })(#{a}); +-- +-- +-- Further reading: +-- +-- 1. Shakespearean templates: +-- +-- 2. CoffeeScript: +module Text.Naked.Coffee + ( -- * Functions + -- ** Template-Reading Functions + -- | These QuasiQuoter and Template Haskell methods return values of + -- type @'JavascriptUrl' url@. See the Yesod book for details. + ncoffee + , ncoffeeFile + , ncoffeeFileReload + , ncoffeeFileDebug + +#ifdef TEST_EXPORT + , coffeeSettings +#endif + ) where + +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Language.Haskell.TH.Syntax +import Text.Shakespeare +import Text.Julius +import Prelude +import qualified Data.Text.Lazy as T +import Data.Text.Lazy.Builder (fromLazyText) + +-- just kill the last semipcolon +coffeeSettings :: Q ShakespeareSettings +coffeeSettings = do + jsettings <- javascriptSettings + drp <- [| \ex url -> Javascript . fromLazyText . {- T.drop 1 . T.init .-} T.init . T.init . renderJavascript $ ex url |] + return $ jsettings { varChar = '%' + , modifyFinalValue = Just drp + , preConversion = Just PreConvert { + preConvert = ReadProcess "coffee" ["-spb"] + , preEscapeIgnoreBalanced = "'\"`" -- don't insert backtacks for variable already inside strings or backticks. + , preEscapeIgnoreLine = "#" -- ignore commented lines + , wrapInsertion = Just WrapInsertion { + wrapInsertionIndent = Just " " + , wrapInsertionStartBegin = "(" + , wrapInsertionSeparator = ", " + , wrapInsertionStartClose = ") =>" + , wrapInsertionEnd = "" + , wrapInsertionAddParens = False + } + } + } + +-- | Read inline, quasiquoted CoffeeScript. +ncoffee :: QuasiQuoter +ncoffee = QuasiQuoter { quoteExp = \s -> do + rs <- coffeeSettings + quoteExp (shakespeare rs) s + } + +-- | Read in a CoffeeScript template file. This function reads the file once, at +-- compile time. +ncoffeeFile :: FilePath -> Q Exp +ncoffeeFile fp = do + rs <- coffeeSettings + shakespeareFile rs fp + +-- | Read in a CoffeeScript template file. This impure function uses +-- unsafePerformIO to re-read the file on every call, allowing for rapid +-- iteration. +ncoffeeFileReload :: FilePath -> Q Exp +ncoffeeFileReload fp = do + rs <- coffeeSettings + shakespeareFileReload rs fp + +-- | Deprecated synonym for 'coffeeFileReload' +ncoffeeFileDebug :: FilePath -> Q Exp +ncoffeeFileDebug = ncoffeeFileReload +{-# DEPRECATED ncoffeeFileDebug "Please use coffeeFileReload instead." #-} diff --git a/src/Yesod/AngularUI.hs b/src/Yesod/AngularUI.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/AngularUI.hs @@ -0,0 +1,428 @@ +{-# Language OverloadedStrings + , QuasiQuotes + , RecordWildCards + , LambdaCase + , TemplateHaskell + , BangPatterns + , FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , UndecidableInstances + , ScopedTypeVariables + , RankNTypes + , TypeFamilies + , ViewPatterns + #-} + +module Yesod.AngularUI + ( YesodAngular (..) + , runAngularUI + , addCommand + , addCommandMaybe + -- ^ mostly internal + , addModules + , addDirective + , addConfig + , addConfigRaw + , addService + + , addFactoryStore + -- ^ naive persistent store + , addFactory + , addController + , addProvide + , addFilter + , addConstant + -- some normal stuff + , addSetup + -- ^ before the code, maybe some imports? + + , addWhen + , setDefaultRoute + , addREST + , addRESTRaw + -- placeholders for some generic rest api/ maybe a subsite? + , tcFile + , tcVFile + , state + , url + , name + , nameA + , addData + , GAngular + ) where + + +--- the chaos +import Control.Applicative ((<$>)) +import Control.Monad.Trans.Writer (WriterT, runWriterT, tell, execWriter) +-- import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, catMaybes) +import Data.Monoid (First (..), Monoid (..), (<>)) +import Data.Text (Text) +import Text.Hamlet +import Text.Blaze.Html +import Text.Julius +import Text.Lucius +import Yesod.Core (Route, + getUrlRenderParams, getMessageRender, getYesod, lift, + lookupGetParam, newIdent, + sendResponse, notFound) +import Yesod.Core.Widget +import qualified Text.Blaze.Html5 as H +import Text.Jasmine (minify) +import Yesod.Core.Types +import Yesod.Core.Json +import Language.Haskell.TH.Syntax (Q, Exp (..), Lit (..)) +import Language.Haskell.TH (listE) +import qualified Data.Text as T + +import Prelude hiding (head, init, last, readFile, tail, writeFile) +import Control.Monad.Trans.Resource +import Control.Monad.IO.Class +import Text.Shakespeare.I18N +import qualified Data.Text.Lazy.Encoding as E (encodeUtf8, decodeUtf8) + +import Yesod.AngularUI.Router +import Yesod.AngularUI.Types as TS + + +renSoMsg :: (SomeMessage master -> Text) -> SomeMessage master -> Html +renSoMsg f = toHtml . f + +runAngularUI :: (YesodAngular master) + => GAngular master IO () -- ^ angular app + -> (Text -> WidgetT master IO () -> HandlerT master IO Html) -- ^ layout + -> HandlerT master IO Html +runAngularUI ga dl = do + master <- getYesod + mrender <- renSoMsg <$> getMessageRender + urender <- getUrlRenderParams + + ((), AngularWriter{..}) <- runWriterT ga + + mc <- lookupGetParam "command" + fromMaybe (return ()) $ mc >>= flip Map.lookup awCommands + modname <- newIdent + let defaultRoute = + case (awDefaultRoute, awStateName) of + (filter (`elem` awStateName) -> x:_, _) -> [julius|.otherwise("/#{rawJS x}")|] + (_, x:_) -> [julius|.otherwise("/#{rawJS x}")|] + (_,[]) -> mempty + dl modname $ do + mapM_ (\x -> addScriptEither $ x master) urlAngularJs + angularUIEntry + toWidgetHead $ Minify awLook + toWidget (combined mrender urender) + toWidgetBody $ Minify [julius| +^{awSetup} + +angular + .module("#{rawJS modname}", #{rawJS $ show awModules }, function($provide) { + // $provide.constant("menu",# {toJSON awMenu}); + ^{awServices} + }) + ^{awDirectives} + ^{awConfigs} + .config(function($urlRouterProvider, $stateProvider) { + $urlRouterProvider ^{awRoutes} ^{defaultRoute} ; + $stateProvider ^{awStates}; + }); + ^{awControllers} +|] + +newtype Minify a = Minify a + +instance render ~ RY site => ToWidgetHead site (Minify [CssUrl (Route site)]) where + toWidgetHead (Minify j) = toWidgetHead $ \r -> H.style $ preEscapedLazyText $ mconcat $ map (renderCssUrl r) j + +instance render ~ RY site => ToWidgetBody site (Minify (render -> Javascript)) where + toWidgetBody (Minify j) = toWidget $ \r -> H.script $ preEscapedLazyText $ E.decodeUtf8 $ minify $ E.encodeUtf8 $ renderJavascriptUrl r j + +addModules :: (Monad m) => [Text] -> GAngular master m () +addModules x = tell mempty{ awModules = x } + +addConfig :: (Monad m) => Text + -> ((Route master -> [(Text, Text)] -> Text) -> Javascript) + -> GAngular master m () +addConfig name' funcall = do + let n = name' `mappend` "Provider" + tell mempty + { awConfigs = [julius|.config(["#{rawJS n}", function (#{rawJS n}){ + #{rawJS n}.^{funcall}; }])|] + } + +addConfigRaw :: (Monad m) => ((Route master -> [(Text, Text)] -> Text) -> Javascript) + -> GAngular master m () +addConfigRaw funcall = tell mempty { awConfigs = [julius|.config(^{funcall})|] } + +addDirective :: (Monad m) => Text + -> ((Route master -> [(Text, Text)] -> Text) -> Javascript) + -> GAngular master m () +addDirective n funcall = + tell mempty + { awDirectives = [julius|.directive("#{rawJS n}", ^{funcall} )|] + } + +addController :: (Monad m) => Text + -> ((Route master -> [(Text, Text)] -> Text) -> Javascript) + -> GAngular master m () +addController n funcall = + tell mempty + { awDirectives = [julius|.controller("#{rawJS n}", ^{funcall} )|] + } + + +addFilter :: (Monad m) => Text + -> ((Route master -> [(Text, Text)] -> Text) -> Javascript) + -> GAngular master m () +addFilter n funcall = + tell mempty + { awDirectives = [julius|.filter("#{rawJS n}", ^{funcall} )|] + } + + +addFactory :: (Monad m) => Text + -> ((Route master -> [(Text, Text)] -> Text) -> Javascript) + -> GAngular master m () +addFactory n funcall = addProvide [js|factory("#{rawJS n}",^{funcall})|] + +addREST :: (Monad m) => Text + -> ((Route master -> [(Text, Text)] -> Text) -> Javascript) + -> GAngular master m () +addREST n funcall = + tell mempty + { awModules = ["ngResource"] + , awDirectives = [julius| + .factory("#{rawJS n}",["$resource", function($resource){ + return $resource(^{funcall}); }])|] + } + +addRESTRaw :: (Monad m) => Text + -> ((Route master -> [(Text, Text)] -> Text) -> Javascript) + -> GAngular master m () +addRESTRaw n funcall = + tell mempty + { awModules = ["ngResource"] + , awDirectives = [julius| + .factory("#{rawJS n}",["$resource", function($resource){ + ^{funcall} + }])|] + } + +addService :: (Monad m) => + Text + -> ((Route master -> [(Text, Text)] -> Text) -> Javascript) + -> GAngular master m () +-- ^ adds a service +addService n funcall = addProvide [js|service("#{rawJS n}",^{funcall})|] + +addProvide :: (Monad m) => ((Route master -> [(Text, Text)] -> Text) -> Javascript) -> GAngular master m () +addProvide funcall = + tell mempty + { awServices = [julius| + $provide.^{funcall} ;|] + } + +addConstant :: (Monad m) => Text -> ((Route master -> [(Text, Text)] -> Text) -> Javascript) -> GAngular master m () +-- ^ add constant, remember to quote if raw text +addConstant n funcall = addProvide [julius|constant("#{rawJS n}",^{funcall})|] + +addSetup :: (Monad m) => ((Route master -> [(Text, Text)] -> Text) -> Javascript) + -> GAngular master m () +-- ^ inject this code befor calling angular +addSetup funcall = + tell mempty + { awSetup = [julius|^{funcall};|] + } + +addCommand :: (FromJSON input, ToJSON output) + => (input -> HandlerT master IO output) + -> GAngular master IO Text +-- ^ add a command (which is always printed) +addCommand f = addCommandMaybe (fmap (Just <$>) f) + +addCommandMaybe :: (FromJSON input, ToJSON output) + => (input -> HandlerT master IO (Maybe output)) + -> GAngular master IO Text +addCommandMaybe f = do + n <- lift newIdent + tell (mempty :: AngularWriter master IO) { awCommands = Map.singleton n handler } + return $ "?command=" `mappend` n + where + handler = requireJsonBody >>= f >>= \case + Just output -> do repjson <- returnJson output + sendResponse repjson + Nothing -> notFound + +addWhen :: ( Monad m + , MonadThrow m + , MonadBaseControl IO m + , MonadIO m + ) => Text -- ^ one route + -> Text -- ^ the other one + -> GAngular master m () +addWhen fro to = tell mempty {awRoutes = [julius|.when("#{rawJS fro}","#{rawJS to}")|] } + +setDefaultRoute :: (Monad m) => Text -> GAngular master m() +setDefaultRoute x = tell mempty { awDefaultRoute = [x] } + +addFactoryStore :: (Monad m) => Text -> GAngular master m () +addFactoryStore n = addFactory (n <> "Store") [julius| function(){ + var lc = {}; + return { update: function (s){ _.extend(lc,s)} + , full: function (s){ return lc; } + , set: function (e,v) { lc[e] = v; } + , get: function (e){ return lc[e]; } + , has: function (e){ return _.has(lc,e); } + , getD : function (d, e){ return _.has(lc,e) ? lc[e] : d; } + , isEmpty : function (){ return _.isEmpty(lc) } + , clear : function(){lc = {}} + } + } + |] + + + +url :: Monad m => Text -> WriterT (UiState master) m () +url u = tell mempty {uisUrl = Just u} + +name :: Monad m => Text -> WriterT (UiState master) m () +name n = tell mempty {uisName = First (Just n)} + +nameA :: Monad m => Text -> WriterT (UiState master) m () +nameA n = tell mempty + { uisName = First (Just n) + , uiTC = mempty { tcTempl = TmplInl "" } + , uiAbstract = True + } + +addData :: Monad m => JavascriptUrl (Route master) -> WriterT (UiState master) m () +addData d = tell mempty {uiData = [d]} + +emptyFunction :: JavascriptUrl url +emptyFunction = [julius| function(){} |] + +tcFile :: Text -> Q Exp +tcFile st = + [|tell mempty { uisName = First (Just $(liftT st)) + , uiTC = UiTC + (TmplExt $(autoHamlet st "")) + (CtrlExt $(fromMaybe [| emptyFunction |] $ autoJulius st "")) + $(listE $ catMaybes [autoLucius st "", autoCassius st ""]) + }|] + where + liftT t = do + p <- [|T.pack|] + return $ AppE p $ LitE $ StringL $ T.unpack t + +tcVFile :: Text -> Text -> Q Exp +tcVFile st view = + [|tell mempty + { uisName = First (Just $(liftT st)) + , uiV = [ ( $(liftT view) + , UiTC + (TmplExt $(autoHamlet st view)) + (CtrlExt $(fromMaybe [| emptyFunction |] $ autoJulius st view)) + $(listE $ catMaybes [autoLucius st view, autoCassius st view]) + ) + ] + }|] + where + liftT t = do + p <- [|T.pack|] + return $ AppE p $ LitE $ StringL $ T.unpack t + +state + :: ( Monad m + , MonadThrow m + , MonadBaseControl IO m + , MonadIO m + ) + => GUiState master () -> GAngular master m () +state sa = do + let a = execWriter sa + tell mempty {awUiState = [a]} + addUIState a + +renderTemplate + :: ( Monad m + , MonadThrow m + , MonadBaseControl IO m + , MonadIO m + ) + => StateTemplate master -> GAngular master m (Maybe (JavascriptUrl (Route master))) +renderTemplate = \case + TmplExt t -> do + n <- lift newIdent + tell mempty { combined = [ihamlet|