lss (empty) → 0.1.0.0
raw patch · 5 files changed
+292/−0 lines, 5 filesdep +attoparsecdep +basedep +containerssetup-changed
Dependencies added: attoparsec, base, containers, directory, filepath, hspec2, language-css, language-css-attoparsec, lss, text, xmlhtml
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- lss.cabal +40/−0
- spec/Main.hs +82/−0
- src/Language/Lss.hs +138/−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
+ lss.cabal view
@@ -0,0 +1,40 @@+name: lss+version: 0.1.0.0+synopsis: Lexical Style Sheets - a language for writing styles that is focused around lexical (ie, static) scoping and re-use of large components.+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,+ language-css >= 0.0.3 && <= 0.1,+ language-css-attoparsec >= 0.0.3 && <= 0.1,+ xmlhtml >= 0.1 && < 0.3,+ text,+ directory,+ filepath,+ containers,+ attoparsec+ hs-source-dirs: src/+ exposed-modules:+ Language.Lss+ default-language: Haskell2010++Test-Suite test-lss+ type: exitcode-stdio-1.0+ hs-source-dirs: spec+ main-is: Main.hs+ default-language: Haskell2010+ build-depends: base >= 4.6 && < 4.8,+ language-css >= 0.0.3 && < 0.1,+ language-css-attoparsec >= 0.0.3 && < 0.1,+ containers,+ attoparsec,+ text,+ hspec2+ build-depends: lss == 0.1.0.0
+ spec/Main.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import qualified Data.Attoparsec.Text as A+import Data.Either (rights)+import qualified Data.Map as M+import Data.Text (Text)+import qualified Data.Text as T+import qualified Language.Css.Parse as P+import qualified Language.Css.Syntax as C+import Language.Lss+import Test.Hspec++isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft _ = False++type TConst = (Text, Text)+type TFunc = ([Text], [TConst], [Text])++buildState :: [(Text, TFunc)] -> [TConst] -> LssState+buildState fs cs = LssState (M.fromList (consts cs)) (M.fromList (funcs fs))+ where consts = map (\(i,e) -> let Right expr = A.parseOnly P.exprp e+ in (C.Ident (T.unpack i), expr))+ funcs = map (\(i, (ps, lcs, b)) -> let params = rights (map (A.parseOnly P.identp) ps)+ cs' = M.fromList $ consts lcs+ rules = rights (map (A.parseOnly P.rulesetp) b)+ in (C.Ident (T.unpack i), LssFunc params cs' rules))++buildApp :: Text -> [Text] -> LssApp+buildApp n as = let Right name = A.parseOnly P.identp n+ args = rights (map (A.parseOnly P.exprp) as)+ in LssApp name args++unRight :: Either a b -> b+unRight (Right v) = v+unRight _ = error "Expected right"++main :: IO ()+main = hspec $ do+ describe "parseDefs" $ do+ it "should parse a bare const" $ do+ parseDefs "x = #ccc" `shouldBe` (Right (buildState [] [("x", "#ccc")]))+ it "should parse two consts" $ do+ parseDefs "x = #ccc\n y = 10em" `shouldBe` (Right (buildState [] [ ("x", "#ccc")+ , ("y", "10em")]))+ it "should parse an argumentless, empty function" $ do+ parseDefs "x {}" `shouldBe` (Right (buildState [("x", ([],[],[]))] []))+ it "should parse an argumentless, empty function with parens" $ do+ parseDefs "x() {}" `shouldBe` (Right (buildState [("x", ([],[],[]))] []))+ it "should not parse a function with a space before parens" $ do+ parseDefs "x () {}" `shouldSatisfy` isLeft+ it "should parse an argumentless empty fuction with some css inside" $ do+ parseDefs "x { p { font-size: 1em; } }" `shouldBe`+ (Right (buildState [("x", ([],[],["p { font-size: 1em; }"]))] []))+ it "should parse local constants within a function" $ do+ parseDefs "x { y = 10em }" `shouldBe` (Right (buildState [("x", ([],[("y", "10em")],[]))]+ []))+ it "should parse a one argument function" $ do+ parseDefs "x(size) {}" `shouldBe`+ (Right (buildState [("x", (["size"],[],[]))] []))+ it "should parse arguments in a function" $ do+ parseDefs "x(size, weight) {}" `shouldBe`+ (Right (buildState [("x", (["size", "weight"],[],[]))] []))+ describe "parseApp" $ do+ it "should parse bare function name" $+ parseApp "foo" `shouldBe` (Right (buildApp "foo" []))+ it "should parse a function with parens" $+ parseApp "foo()" `shouldBe` (Right (buildApp "foo" []))+ it "should parse a function with one argument" $+ parseApp "foo(#ccc)" `shouldBe` (Right (buildApp "foo" ["#ccc"]))+ describe "apply" $ do+ it "should produce body of argumentless function" $+ apply (unRight $ parseDefs "x { p { font-size: 1em; } }")+ (C.Ident "x")+ []+ `shouldBe` (Right [unRight $ A.parseOnly P.rulesetp "p { font-size: 1em; }"])+ it "should do replacement within function" $+ apply (unRight $ parseDefs "x(size) { p { font-size: size; } }")+ (C.Ident "x")+ [unRight $ A.parseOnly P.exprp "10em"]+ `shouldBe` (Right [unRight $ A.parseOnly P.rulesetp "p { font-size: 10em; }"])
+ src/Language/Lss.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}++module Language.Lss ( LssState(..)+ , LssFunc(..)+ , LssApp(..)+ , parseDefs+ , parseApp+ , apply+ , attach+ , unIdent) where++import Control.Applicative ((<$>), (<*), (<*>))+import Control.Arrow ((&&&))+import qualified Data.Attoparsec.Text as A+import Data.List (partition)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Language.Css.Parse as P+import qualified Language.Css.Pretty as C+import qualified Language.Css.Syntax as C+import Prelude hiding ((++))+import qualified Text.XmlHtml as X++(++) :: Monoid d => d -> d -> d+(++) = mappend++type ConstMap = Map C.Ident C.Expr+type Symbol = String++deriving instance Ord C.Ident+unIdent :: C.Ident -> Text+unIdent (C.Ident s) = T.pack s++data LssState = LssState { sConstants :: ConstMap, sFunctions :: Map C.Ident LssFunc} deriving (Show, Eq)++data LssFunc = LssFunc { fParams :: [C.Ident], fLocalConstants :: ConstMap, fBody :: [C.RuleSet] } deriving (Show, Eq)++data LssApp = LssApp { aIdent :: C.Ident, cArgs :: [C.Expr]} deriving (Show, Eq)++instance Monoid LssState where+ mempty = LssState M.empty M.empty+ mappend (LssState c1 f1) (LssState c2 f2) = LssState (M.union c2 c1) (M.union f2 f1)+++data FunOrConstOrRule = Fun { unFun :: (C.Ident, LssFunc) }+ | Const { unConst :: (C.Ident, C.Expr) }+ | Rule { unRule :: C.RuleSet }+ deriving Show+isConst (Const _) = True+isConst _ = False++parseDefs :: Text -> Either String LssState+parseDefs = A.parseOnly (lssGrammar <* A.endOfInput)+ where lssGrammar = do res <- A.many' (A.choice [A.skipSpace >> fun, A.skipSpace >> con])+ let (cons, funs) = partition isConst res+ return (LssState (M.fromList $ map unConst cons) (M.fromList $ map unFun funs))+ fun = do ident <- P.identp+ params <- A.option [] $ do+ A.char '('+ ps <- A.option [] (do param <- P.identp+ rest <- A.many' $ A.char ',' >> A.skipSpace >> P.identp+ return (param:rest))+ A.char ')'+ return ps+ A.skipSpace+ A.char '{'+ res <- A.many' (A.choice [Rule <$> (A.skipSpace >> P.rulesetp), A.skipSpace >> con])+ let (cons, rules) = partition isConst res+ A.skipSpace+ A.char '}'+ return $ Fun (ident, LssFunc params (M.fromList $ map unConst cons) (map unRule rules))+ con = do ident <- P.identp+ A.skipSpace+ A.char '='+ A.skipSpace+ expr <- P.exprp+ return $ Const (ident, expr)++parseApp = A.parseOnly (lssApplication <* A.endOfInput)+ where lssApplication = do id <- P.identp+ args <- A.option [] $ do+ A.char '('+ as <- A.option [] (do arg <- P.exprp+ rest <- A.many' $ A.char ',' >> A.skipSpace >> P.exprp+ return (arg:rest))+ A.char ')'+ return as+ return $ LssApp id args++apply :: LssState -> C.Ident -> [C.Expr] -> Either Text [C.RuleSet]+apply state ident args = case M.lookup ident (sFunctions state) of+ Nothing -> Left $ "Unknown function: " ++ unIdent ident ++ "."+ Just (LssFunc params locals body) | length params == length args ->+ let localSubst = map (uncurry subst) (M.assocs locals)+ in Right $ map (\b -> foldr ($) b (zipWith subst params args ++ localSubst)) body+ Just (LssFunc params _ _) ->+ Left $ "Invalid number of arguments to " ++ unIdent ident+ ++ ": expected " ++ T.pack (show $ length params)+ ++ ", but got " ++ T.pack (show $ length args)+ ++ " instead."+ where subst param arg (C.RuleSet sels decls) = C.RuleSet sels (map (substDecl param arg) decls)+ substDecl param arg (C.Decl prio prop expr) = C.Decl prio prop (substExpr param arg expr)+ substExpr param arg expr =+ case expr of+ C.EVal val -> case val of+ C.VIdent ide | ide == param -> arg+ _ -> expr+ C.SlashSep exp1 exp2 -> C.SlashSep (substExpr param arg exp1) (substExpr param arg exp2)+ C.CommaSep exp1 exp2 -> C.CommaSep (substExpr param arg exp1) (substExpr param arg exp2)+ C.SpaceSep exp1 exp2 -> C.SpaceSep (substExpr param arg exp1) (substExpr param arg exp2)++attach :: Symbol -> [C.RuleSet] -> [X.Node] -> [X.Node]+attach sym rules nodes = styleNode : map (addClass (T.pack sym)) nodes+ where styleNode = X.Element "style" [("type", "text/css")] [X.TextNode $ T.pack $ C.prettyPrint $ C.StyleSheet Nothing [] (map (C.SRuleSet . addSels) rules)]+ addSels (C.RuleSet sels decls) = C.RuleSet (concatMap addSel sels) decls+ addSel sel = let desc = C.DescendSel (C.SSel (C.UnivSel [C.ClassSel sym])) sel+ adj = addAdj sel+ in [desc, adj]+ addAdj sel = case sel of+ C.SSel sim -> addSSel sim+ C.DescendSel sel1 sel2 -> C.DescendSel (addAdj sel1) sel2+ C.ChildSel sel1 sel2 -> C.ChildSel (addAdj sel1) sel2+ C.AdjSel sel1 sel2 -> C.AdjSel (addAdj sel1) sel2+ addSSel sim = case sim of+ C.UnivSel sels -> C.SSel (C.UnivSel (C.ClassSel sym : sels))+ C.TypeSel el sels -> C.SSel (C.TypeSel el (C.ClassSel sym : sels))+ addClass classSym node =+ case node of+ X.Element _ attrs _ ->+ let classAttr = case lookup "class" attrs of+ Nothing -> ("class", classSym)+ Just cls -> ("class", classSym ++ " " ++ cls)+ in node { X.elementAttrs = classAttr : filter ((/= "class").fst) attrs}+ _ -> node