snaplet-lss (empty) → 0.1.0.0
raw patch · 5 files changed
+201/−0 lines, 5 filesdep +basedep +directorydep +filepathsetup-changed
Dependencies added: base, directory, filepath, heist, hspec-snap, hspec2, lens, lss, snap, snaplet-lss, text, xmlhtml
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- snaplet-lss.cabal +38/−0
- spec/Main.hs +59/−0
- src/Snap/Snaplet/Lss.hs +72/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Daniel Patterson++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 Daniel Patterson nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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+OWNER OR CONTRIBUTORS 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ snaplet-lss.cabal view
@@ -0,0 +1,38 @@+name: snaplet-lss+version: 0.1.0.0+synopsis: Lexical Style Sheets - Snap Web Framework adaptor.+homepage: https://github.com/dbp/lss+license: BSD3+license-file: LICENSE+author: Daniel Patterson+maintainer: dbp@dbpmail.net+category: Language+build-type: Simple+cabal-version: >=1.10++library+ build-depends: base >=4.7 && <4.8,+ lss >= 0.1 && < 0.2,+ xmlhtml >= 0.1 && < 0.3,+ heist,+ snap,+ text,+ directory,+ filepath+ hs-source-dirs: src/+ exposed-modules:+ Snap.Snaplet.Lss+ default-language: Haskell2010++Test-Suite test-snaplet-lss+ type: exitcode-stdio-1.0+ hs-source-dirs: spec+ main-is: Main.hs+ default-language: Haskell2010+ build-depends: base >= 4.6 && < 4.8,+ snap,+ lens,+ text,+ hspec-snap,+ hspec2+ build-depends: snaplet-lss == 0.1.0.0
+ spec/Main.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++----------------------------------------------------------+-- Section 0: Imports. --+----------------------------------------------------------+import Control.Lens+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Snap (Handler, Method (..), Snaplet, addRoutes,+ makeSnaplet, nestSnaplet, route,+ subSnaplet)+import Snap.Snaplet.Heist++import Test.Hspec+import Test.Hspec.Snap++import Snap.Snaplet.Lss++----------------------------------------------------------+-- Section 1: Example application used for testing. --+----------------------------------------------------------++data App = App { _heist :: Snaplet (Heist App), _lss :: Snaplet Lss }++makeLenses ''App++instance HasHeist App where+ heistLens = subSnaplet heist++routes = [("test", render "test")+ ,("test2", render "test2")]++app = makeSnaplet "app" "An snaplet example application." Nothing $ do+ addRoutes routes+ h <- nestSnaplet "" heist $ heistInit "templates"+ l <- nestSnaplet "" lss $ initLss h+ return $ App h l+++----------------------------------------------------------+-- Section 2: Test suite against application. --+----------------------------------------------------------++main :: IO ()+main = hspec $ snap (route routes) app $ do+ describe "basic tests" $ do+ it "should have style tag when applying function" $ do+ p <- get "/test"+ p `shouldHaveSelector` "style"+ p `shouldHaveText` "background-color"+ p `shouldHaveText` "red"+ it "should substitute params into css rules" $ do+ p <- get "/test2"+ -- NOTE(dbp 2014-09-04): The CSS library renders with odd spacing and treatment of numbers.+ p `shouldHaveText` "font-size : 10.0em"
+ src/Snap/Snaplet/Lss.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}+module Snap.Snaplet.Lss (Lss(..), initLss, lssSplices) where++import Control.Monad (when)+import Data.List (isSuffixOf)+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Unique+import Heist (Splices, getParamNode,+ hcInterpretedSplices, ( ## ))+import Heist.Interpreted (Splice)+import Prelude hiding ((++))+import Snap+import Snap.Snaplet.Heist (Heist, addConfig)+import System.Directory+import System.FilePath+import qualified Text.XmlHtml as X++import Language.Lss++(++) :: Monoid d => d -> d -> d+(++) = mappend++data Lss = Lss++initLss :: Snaplet (Heist b) -> SnapletInit b Lss+initLss heist = makeSnaplet "lss" "" Nothing $ do+ dir <- getSnapletFilePath+ dirExists <- liftIO $ doesDirectoryExist dir+ when (not dirExists) $ liftIO $ createDirectory dir+ files <- map (dir </>) <$> liftIO (getDirectoryContents dir)+ st <- foldM (\s f -> do isF <- liftIO $ doesFileExist f+ if not isF || not (".lss" `isSuffixOf` f)+ then return s+ else do+ c <- liftIO $ T.readFile f+ case parseDefs c of+ Left err -> error $ "Lss: Error parsing file " ++ f ++ ": " ++ err+ Right stat -> return $ mappend s stat)+ mempty+ files+ addConfig heist mempty { hcInterpretedSplices = lssSplices st }+ return Lss+++lssSplices :: (MonadIO m, Functor m) => LssState -> Splices (Splice m)+lssSplices st = "lss" ## lssSplice+ where lssSplice =+ do n <- getParamNode+ case X.getAttribute "apply" n of+ Nothing -> error "Lss: Can't apply <lss> tag without `apply` attribute."+ Just a ->+ case parseApp a of+ Left err -> error $ "Lss: error parsing `apply` attribute: " ++ err+ Right (LssApp ident args) ->+ do case apply st ident args of+ Left err -> error $ "Lss: error applying " ++ (T.unpack $ unIdent ident)+ ++ ": " ++ T.unpack err+ Right rules -> do+ let childs = case X.getAttribute "class" n of+ Nothing -> X.elementChildren n+ Just cls -> map (addClass cls) (X.elementChildren n)+ sym <- (("lss" ++) . show . hashUnique) <$> liftIO newUnique+ return $ attach sym rules childs+ where addClass newCls n@(X.Element _ attrs _) =+ let classAttr = case lookup "class" attrs of+ Nothing -> ("class", newCls)+ Just cls -> ("class", newCls ++ " " ++ cls)+ in n { X.elementAttrs = classAttr : filter ((/= "class").fst) attrs}+ addClass _ n = n