diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/Text/Domplate.hs b/Text/Domplate.hs new file mode 100644 --- /dev/null +++ b/Text/Domplate.hs @@ -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 diff --git a/Text/Domplate/Context.hs b/Text/Domplate/Context.hs new file mode 100644 --- /dev/null +++ b/Text/Domplate/Context.hs @@ -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!" + diff --git a/Text/Domplate/Replace.hs b/Text/Domplate/Replace.hs new file mode 100644 --- /dev/null +++ b/Text/Domplate/Replace.hs @@ -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' diff --git a/domplate.cabal b/domplate.cabal new file mode 100644 --- /dev/null +++ b/domplate.cabal @@ -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