domplate (empty) → 0.1
raw patch · 6 files changed
+481/−0 lines, 6 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, tagsoup, text, unordered-containers, vector, yaml
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- Text/Domplate.hs +87/−0
- Text/Domplate/Context.hs +71/−0
- Text/Domplate/Replace.hs +253/−0
- domplate.cabal +38/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Anton Ekblad++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 Anton Ekblad 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
+ Text/Domplate.hs view
@@ -0,0 +1,87 @@+-- | Simple templating using HTML5 as the template language. Templates are+-- specified by adding special attributes to tags. During substitution, these+-- attributes are stripped from the HTML. The following attributes are+-- recognized:+--+-- * @insert="identifier"@ - replace the tag's contents with the value+-- bound to @identifier@ in the substitution context.+-- * @replace="identifier"@ - replace the whole tag and its contents with+-- the value bound to @identifier@ in the substitution context.+-- * @when="identifier"@ - only render this tag if @identifier@ is set to+-- true in the substitution context.+-- * @unless="identifier"@ - the dual of @when@; only render this tag if+-- @identifier@ is set to false in the substitution context.+-- * @forall="identifier"@ - render this tag and its contents once for each+-- element in the list bound to @identifier@ in the substitution context.+-- The contents of the element may refer to the current iteration's value+-- of @identifier@ by that same name.+--+-- Substitution can also be performed on the attributes of tags. The+-- following attribute substitutions are recognized:+--+-- * @when:identifier:attr="value"@ - only include @attr@ is @identifier@+-- is set to true in the substitution context.+-- * @unless:identifier:attr="value"@ - only include @attr@ is @identifier@+-- is set to false in the substitution context.+-- * @insert:identifier:attr="value"@ - overwrite the value of @attr@ with+-- whatever @identifier@ is bound to in the substitution context.+--+-- Contexts can be nested, in which case nested keys are separated by+-- periods, as in @parent.child.grandchild@. Keys may be prefixed with a+-- question mark, in which case they are considered to be "weak keys".+-- If a weak key does not exist in the context, it will be replaced by a+-- sensible default value instead of causing an error. The defaults for the+-- different value types are as follows:+--+-- * bool: false+-- * string: ""+-- * array: []+-- * object: {}+--+-- As numbers are treated just like strings, they have an empty string as+-- their default value as well.+--+-- In general, values used as text must be declared text by the context and+-- so on, but the following coercions are permitted:+--+-- * bool to string+-- * array to bool+--+-- Coercion of array to bool, with the empty list being considered false and+-- all other list considered true, is permitted to allow templates to take+-- special action in the case of an empty list.+--+-- Contexts may be constructed programatically using the provided+-- combinators, converted from JSON objects or lists of key-value pairs, or+-- parsed from a YAML-formatted string using 'parseContext'.+module Text.Domplate (+ Text, Monoid, Template, Context, Value (..), Key,+ parseTemplate, replace,+ add, remove, fromList, Text.Domplate.Context.lookup, empty, size, (<>),+ parseContext,+ compile+ ) where+import Control.Applicative hiding (empty)+import Data.Monoid+import Data.Text (Text)+import Data.Yaml (Value (..))+import Text.Domplate.Context+import Text.Domplate.Replace+import qualified Data.ByteString as BS (readFile, writeFile)++-- | Compile a template using a context parsed from a context file.+-- Throws an error if context parsing or substitution fails.+compile :: FilePath -- ^ Template file.+ -> FilePath -- ^ Context file.+ -> FilePath -- ^ Output file.+ -> IO ()+compile template context outfile = do+ t <- parseTemplate <$> BS.readFile template+ ec <- parseContext <$> BS.readFile context+ case fmapL show ec >>= replace t of+ Right s -> BS.writeFile outfile s+ Left e -> error e++fmapL :: (a -> b) -> Either a c -> Either b c+fmapL f (Left x) = Left (f x)+fmapL _ (Right x) = Right x
+ Text/Domplate/Context.hs view
@@ -0,0 +1,71 @@+module Text.Domplate.Context where+import qualified Data.Text as T+import qualified Data.HashMap.Strict as M+import Data.ByteString (ByteString)+import Data.Yaml+import Data.Monoid++-- | A key to be read from the context.+type Key = T.Text++-- | An Unplate context. A simple mapping from keys to values.+newtype Context = Ctx (M.HashMap Key Value)+ deriving Show++instance Monoid Context where+ mempty = empty+ mappend (Ctx a) (Ctx b) = Ctx $ M.union a b+ mconcat = Ctx . M.unions . map (\(Ctx ctx) -> ctx)++typeOf :: Value -> String+typeOf (String _) = "text"+typeOf (Number _) = "number"+typeOf (Bool _) = "boolean"+typeOf (Array _) = "array"+typeOf (Object _) = "object"+typeOf (Null) = "null"++-- | Create a context from a JSON object. Throws an error if the value is not+-- an object.+fromJSON :: Value -> Context+fromJSON (Object o) = Ctx o+fromJSON _ = error "Tried to make a context out of a non-object!"++-- | Create a context from a list mapping keys to values.+fromList :: [(Key, Value)] -> Context+fromList = Ctx . M.fromList++-- | Create a JSON object from a context.+toValue :: Context -> Value+toValue (Ctx ctx) = Object ctx++-- | Add a new value to the given context. If the value already exists, it is+-- overwritten.+add :: Key -> Value -> Context -> Context+add k v (Ctx ctx) = Ctx $ M.insert k v ctx++-- | Remove a value from the given context.+remove :: Key -> Context -> Context+remove k (Ctx ctx) = Ctx $ M.delete k ctx++-- | An empty context.+empty :: Context+empty = Ctx M.empty++-- | Look up a value in the top level context.+lookup :: Key -> Context -> Maybe Value+lookup key (Ctx m) = M.lookup key m++-- | Get the size of the context. Nested contexts count a single element,+-- regardless of their size.+size :: Context -> Int+size (Ctx m) = M.size m++-- | Parse a context from a YAML-formatted 'ByteString'.+parseContext :: ByteString -> Either String Context+parseContext bs = do+ val <- decodeEither bs+ case val of+ Object ctx -> return $ Ctx ctx+ _ -> Left "Decoded value was not an object!"+
+ Text/Domplate/Replace.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.Domplate.Replace (Template, parseTemplate, replace) where+import Prelude hiding (lookup)+import qualified Prelude as P+import qualified Data.Text as T+import qualified Data.Vector as V+import Data.Text.Encoding (encodeUtf8, decodeUtf8)+import Control.Applicative hiding (empty)+import Data.Maybe (catMaybes)+import Text.HTML.TagSoup+import Text.Domplate.Context+import Data.Yaml+import Data.ByteString (ByteString)++-- | A domplate template.+newtype Template = Template [Tag T.Text]++-- | Parse an HTML5 string into a template.+parseTemplate :: ByteString -> Template+parseTemplate = Template . parseTags . decodeUtf8++data InternalKey = Weak [Key] | Strong [Key]++-- | Perform substitutions on the given template using the given context,+-- returning a 'ByteString'.+replace :: Template -> Context -> Either String ByteString+replace = genericReplace encodeUtf8++-- | Perform substitutions on the given template using the given context,+-- returning a 'T.Text'.+replaceText :: Template -> Context -> Either String T.Text+replaceText = genericReplace id++genericReplace :: (T.Text -> a) -> Template -> Context -> Either String a+genericReplace conv (Template template) context =+ conv . renderTagsOptions opts . reverse <$> replace' template context+ where+ opts = renderOptions {optEscape = id}+ replace' ts ctx =+ step [] ts+ where+ -- Substitute tags and attributes for a list of tags.+ step acc (TagOpen name attrs : tags) = do+ attrs' <- catMaybes <$> mapM replaceAttr attrs+ substTag acc (TagOpen name attrs' : tags)+ step acc t = do+ substTag acc t++ substTag acc (tag@(TagOpen _ attrs):tags)+ | Just key <- P.lookup "insert" attrs =+ handleInsert acc (stripAttr "insert" tag) (mkKey key) tags++ | Just key <- P.lookup "replace" attrs =+ handleReplace acc tag (mkKey key) tags++ | Just key <- P.lookup "forall" attrs =+ handleForall acc (stripAttr "forall" tag) (mkKey key) tags++ | Just key <- P.lookup "when" attrs =+ handleWhen acc (stripAttr "when" tag) (mkKey key) tags++ | Just key <- P.lookup "unless" attrs =+ handleUnless acc (stripAttr "unless" tag) (mkKey key) tags++ substTag acc (tag:tags) = step (tag : acc) tags+ substTag acc [] = return acc++ -- Substitute attributes when/unless/insert:id:attr+ replaceAttr a@(k, val) =+ case T.splitOn ":" k of+ ["when", key, attr] -> do+ v <- nestedLookup (Bool False) (mkKey key) ctx+ case truthOf v of+ Just True -> return (Just (attr, val))+ Just False -> return Nothing+ _ -> typeError (mkKey key) "bool" (typeOf v)+ ["unless", key, attr] -> do+ v <- nestedLookup (Bool False) (mkKey key) ctx+ case truthOf v of+ Just True -> return Nothing+ Just False -> return (Just (attr, val))+ _ -> typeError (mkKey key) "bool" (typeOf v)+ ["insert", key, attr] -> do+ v <- nestedLookup (String "") (mkKey key) ctx+ case stringOf v of+ Just s -> return (Just (attr, s))+ _ -> typeError (mkKey key) "string" (typeOf v)+ _ -> do+ return $ Just a++ mkKey k+ | T.head k == '?' = Weak $ T.splitOn "." $ T.tail k+ | otherwise = Strong $ T.splitOn "." k++ stripAttr s (TagOpen t as) = TagOpen t [a | a <- as, fst a /= s]++ handleInsert acc tag@(TagOpen nm _) key tags = do+ v <- nestedLookup (String "") key ctx+ case (dropUntilClose nm tags, stringOf v) of+ (ts', Just val) -> step (TagClose nm:TagText val:tag:acc) ts'+ _ -> typeError key "string" (typeOf v)++ handleReplace acc tag@(TagOpen name _) key tags = do+ v <- nestedLookup (String "") key ctx+ case stringOf v of+ Just s -> step (TagText s : acc) (dropUntilClose name tags)+ _ -> typeError key "string" (typeOf v)++ handleWhen acc tag@(TagOpen name _) key tags = do+ v <- nestedLookup (Bool False) key ctx+ case truthOf v of+ Just True -> step (tag : acc) tags+ Just False -> step acc (dropUntilClose name tags)+ _ -> typeError key "bool" (typeOf v)++ handleUnless acc tag@(TagOpen name _) key tags = do+ v <- nestedLookup (Bool False) key ctx+ case truthOf v of+ Just False -> step (tag : acc) tags+ Just True -> step acc (dropUntilClose name tags)+ _ -> typeError key "bool" (typeOf v)++ handleForall acc tag@(TagOpen name _) key tags = do+ let t = tag:takeUntilClose name tags ++ [TagClose name]+ rest = dropUntilClose name tags+ k = case key of+ Strong k -> k+ Weak k -> k+ v <- nestedLookup (Array V.empty) key ctx+ case v of+ Array l -> do+ outs <- mapM (forallIter t k (V.length l-1))+ (zip [0..] (V.toList l))+ step (concat (reverse (outs)) ++ acc) rest+ _ -> do+ typeError key "array" (typeOf v)++ forallIter t k lastIx (ix, v) = do+ ctx' <- nestedAdd k v ctx+ ctx'' <- if ix == 0+ then nestedAdd ["_first"] (Bool True) ctx'+ else nestedAdd ["_first"] (Bool False) ctx'+ ctx''' <- if ix == lastIx+ then nestedAdd ["_last"] (Bool True) ctx''+ else nestedAdd ["_last"] (Bool False) ctx''+ replace' t ctx'''++truthOf :: Value -> Maybe Bool+truthOf (Bool b) = Just b+truthOf (Array a) = Just $ V.null a+truthOf _ = Nothing++stringOf :: Value -> Maybe T.Text+stringOf (String s) = Just s+stringOf (Bool True) = Just "true"+stringOf (Bool False) = Just "false"+stringOf (Number n) = Just $ T.pack $ show n+stringOf _ = Nothing++nestedAdd :: [Key] -> Value -> Context -> Either String Context+nestedAdd key val ctx = go key ctx+ where+ go [k] m = do+ return $ add k val m+ go (k:ks) m = do+ case lookup k m of+ Just (Object ctx') -> do+ Ctx ctx'' <- go ks (Ctx ctx')+ return $ add k (Object ctx'') m+ _ -> do+ Ctx ctx' <- go ks empty+ return $ add k (Object ctx') m+ go _ _ = do+ notFoundError (Strong key)++-- | Lookup a value in a nested context.+nestedLookup :: Value -> InternalKey -> Context -> Either String Value+nestedLookup def key = go key'+ where+ (key', notFound) = case key of+ Weak k -> (k, return def)+ Strong k -> (k, notFoundError key)+ go [k] m =+ case lookup k m of+ Just v -> return v+ _ -> notFound+ go (k:ks) m =+ case lookup k m of+ Just (Object m') -> go ks (Ctx m')+ _ -> notFound+ go _ _ =+ notFound++-- | Take tags until a matching closing tag is found. Does not return the+-- closing tag.+takeUntilClose :: T.Text -> [Tag T.Text] -> [Tag T.Text]+takeUntilClose str = go 0+ where+ go n (tag:tags) =+ case tag of+ TagOpen name _+ | voidTag name -> tag:go n tags+ | otherwise -> tag:go (n+1) tags+ TagClose name+ | name == str && n == 0 -> []+ | otherwise -> tag:go (n-1) tags+ _ -> tag:go n tags+ go _ tags =+ []++-- | Drop tags until a matching closing tag is found. Drops the closing tag.+dropUntilClose :: T.Text -> [Tag T.Text] -> [Tag T.Text]+dropUntilClose str tags+ | voidTag str = tags+ | otherwise = go 0 tags+ where+ go n (tag:tags) =+ case tag of+ TagOpen name _+ | voidTag name -> go n tags+ | otherwise -> go (n+1) tags+ TagClose name+ | name == str && n == 0 -> tags+ | otherwise -> go (n-1) tags+ _ -> go n tags+ go _ tags =+ tags++voidTag :: T.Text -> Bool+voidTag t = t `elem` [+ "area", "base", "br", "col", "command", "embed", "hr", "img", "input",+ "keygen", "link", "meta", "param", "source", "track", "wbr"+ ]++-- | A type mismatch has occurred.+typeError :: InternalKey -> String -> String -> Either String a+typeError k tTemplate tCtx =+ Left $ unwords [+ T.unpack k', "was used as a", tTemplate, "by template,",+ "but declared", tCtx, "by context!"+ ]+ where+ k' = case k of+ Weak k' -> T.intercalate (T.singleton '.') k'+ Strong k' -> T.intercalate (T.singleton '.') k'++-- | A key was not found.+notFoundError :: InternalKey -> Either String a+notFoundError k = Left $ T.unpack k' ++ " was not found in the context!"+ where+ k' = case k of+ Weak k' -> T.intercalate (T.singleton '.') k'+ Strong k' -> T.intercalate (T.singleton '.') k'
+ domplate.cabal view
@@ -0,0 +1,38 @@+name: domplate+version: 0.1+synopsis: A simple templating library using HTML5 as its template+ language.+description: Add replacement, insertion, conditional and loop+ attributes to your HTML tags, then perform the+ corresponding substitutions directly on your HTML using+ a context built using standard JSON tools or parsed from+ a standard YAML file.+homepage: https://github.com/valderman/domplate+license: BSD3+license-file: LICENSE+author: Anton Ekblad+maintainer: anton@ekblad.cc+-- copyright: +category: Web, Text+build-type: Simple+cabal-version: >=1.10++library+ exposed-modules:+ Text.Domplate+ other-modules:+ Text.Domplate.Context,+ Text.Domplate.Replace+ other-extensions:+ OverloadedStrings+ build-depends:+ base >=4.5 && <4.8,+ text >=1.1,+ yaml >=0.8,+ containers >=0.5,+ unordered-containers >=0.2,+ bytestring >=0.10,+ tagsoup >=0.13,+ vector >=0.10+ default-language:+ Haskell2010