diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/lss.cabal b/lss.cabal new file mode 100644 --- /dev/null +++ b/lss.cabal @@ -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 diff --git a/spec/Main.hs b/spec/Main.hs new file mode 100644 --- /dev/null +++ b/spec/Main.hs @@ -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; }"]) diff --git a/src/Language/Lss.hs b/src/Language/Lss.hs new file mode 100644 --- /dev/null +++ b/src/Language/Lss.hs @@ -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