diff --git a/HStringTemplate.cabal b/HStringTemplate.cabal new file mode 100644 --- /dev/null +++ b/HStringTemplate.cabal @@ -0,0 +1,36 @@ +name: HStringTemplate +version: 0.2 +synopsis: StringTemplate implementation in Haskell. +description: A port of the Java library by Terrence Parr. +category: Text +license: BSD3 +license-file: LICENSE +author: Sterling Clover +maintainer: s.clover@gmail.com +Tested-With: GHC == 6.8.2 +Build-Type: Simple +build-Depends: base +Cabal-Version: >= 1.2 + +flag small-base +flag syb-with-class +flag simple-generics + +library + if flag(syb-with-class) + build-depends: syb-with-class + exposed-modules: Text.StringTemplate.GenericWithClass + + if flag(simple-generics) + exposed-modules: Text.StringTemplate.GenericStandard + + if flag(small-base) + build-depends: base >= 3, filepath, parsec, containers, pretty, time, old-time, old-locale, bytestring, directory, array + else + build-depends: base < 3, filepath, parsec + exposed-modules: Text.StringTemplate + other-modules: Text.StringTemplate.Instances + Text.StringTemplate.Group + Text.StringTemplate.Base + Text.StringTemplate.Classes + ghc-options: -Wall diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Stering Clover 2008 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,16 @@ +Module : Text.StringTemplate.Base +Copyright : (c) Sterling Clover 2008 +License : BSD 3 Clause +Maintainer : s.clover@gmail.com +Stability : experimental +Portability : portable + +A StringTemplate is a String with "holes" in it. This is a port of the Java StringTemplate library written by Terrence Parr. (). + +This library implements the basic 3.1 grammar, lacking group files (though not groups themselves), Regions, and Interfaces. The goal is not to blindly copy the StringTemplate API, but rather to take its central ideas and implement them in a Haskellish manner. Indentation and wrapping, for example, are implemented through the HughesPJ Pretty Printing library. Calling toPPDoc on a StringTemplate yields a Doc with appropriate paragraph-fill wrapping that can be rendered in the usual fashion. + +This library extends the current StringTemplate grammar by allowing the application of alternating attributes to anonymous as well as regular templates, including therefore sets of alternating attributes. + +Basic instances are provided of the StringTemplateShows and ToSElem class. Any type deriving ToSElem can be passed automatically as a StringTemplate attribute. This package can be installed with syb-with-class bindings that provide a ToSElem instance for anything deriving 'Data.Generics.SYB.WithClass.Basics.Data'. When defining an instance of ToSElem that can take a format parameter, you should first define an instance of StringTemplateShows, and then define an instance of ToSElem where @ toSElem = stShowsToSE@. + +Along with the haddocks, additional documentation and commentary is at http://fmapfixreturn.wordpress.com diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/Text/StringTemplate.hs b/Text/StringTemplate.hs new file mode 100644 --- /dev/null +++ b/Text/StringTemplate.hs @@ -0,0 +1,58 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.StringTemplate.Base +-- Copyright : (c) Sterling Clover 2008 +-- License : BSD 3 Clause +-- Maintainer : s.clover@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- A StringTemplate is a String with \"holes\" in it. +-- This is a port of the Java StringTemplate library written by Terrence Parr. +-- (). +-- +-- This library implements the basic 3.1 grammar, lacking group files +-- (though not groups themselves), Regions, and Interfaces. +-- The goal is not to blindly copy the StringTemplate API, but rather to +-- take its central ideas and implement them in a Haskellish manner. +-- Indentation and wrapping, for example, are implemented through the +-- HughesPJ Pretty Printing library. Calling toPPDoc on a StringTemplate +-- yields a Doc with appropriate paragraph-fill wrapping that can be +-- rendered in the usual fashion. +-- +-- This library extends the current StringTemplate grammar by allowing the +-- application of alternating attributes to anonymous +-- as well as regular templates, including therefore sets of alternating +-- attributes. +-- +-- Basic instances are provided of the StringTemplateShows and ToSElem class. +-- Any type deriving ToSElem can be passed automatically as a StringTemplate +-- attribute. This package can be installed with syb-with-class bindings +-- that provide a ToSElem instance for anything deriving +-- 'Data.Generics.SYB.WithClass.Basics.Data'. When defining an instance of +-- ToSElem that can take a format parameter, you should first define an +-- instance of StringTemplateShows, and then define an instance of ToSElem +-- where @ toSElem = stShowsToSE@. +----------------------------------------------------------------------------- + +module Text.StringTemplate ( + -- * Types + StringTemplate, STGroup, + -- * Classes + ToSElem(..), StringTemplateShows(..), stShowsToSE, Stringable(..), + -- * Creation + newSTMP, newAngleSTMP, getStringTemplate, + -- * Display + toString, toPPDoc, render, + -- * Modification + setAttribute, setManyAttrib, withContext, + optInsertTmpl, optInsertGroup, + setEncoder, setEncoderGroup, + -- * Groups + groupStringTemplates, addSuperGroup, addSubGroup, + mergeSTGroups, directoryGroup, unsafeVolatileDirectoryGroup, + directoryGroupLazy + ) where +import Text.StringTemplate.Base +import Text.StringTemplate.Group +import Text.StringTemplate.Instances() diff --git a/Text/StringTemplate/Base.hs b/Text/StringTemplate/Base.hs new file mode 100644 --- /dev/null +++ b/Text/StringTemplate/Base.hs @@ -0,0 +1,422 @@ +{-# OPTIONS_HADDOCK not-home #-} + +module Text.StringTemplate.Base + (StringTemplate(..), StringTemplateShows(..), ToSElem(..), STGroup, + Stringable(..), stShowsToSE, + toString, toPPDoc, render, newSTMP, newAngleSTMP, getStringTemplate, + setAttribute, setManyAttrib, withContext, optInsertTmpl, setEncoder, + paddedTrans, SEnv(..), parseSTMP + ) where +import Control.Monad +import Control.Arrow hiding (pure) +import Control.Applicative hiding ((<|>),many) +import Data.Maybe +import Data.Monoid +import Data.List +import Text.ParserCombinators.Parsec +import qualified Data.Map as M +import qualified Text.PrettyPrint.HughesPJ as PP + +import Text.StringTemplate.Classes +--import Debug.Trace --DEBUG +import Text.StringTemplate.Instances() + +{-------------------------------------------------------------------- + Generic Utilities +--------------------------------------------------------------------} + +o :: (b -> c) -> (a -> a1 -> b) -> a -> a1 -> c +o = (.).(.) +infixr 8 `o` + +(|.) :: (t1 -> t2) -> (t -> t1) -> t -> t2 +(|.) f g x = f (g x) +infixr 3 |. + +(.>>) :: (Monad m) => m a -> m b -> m b +(.>>) f g = f >> g +infixr 5 .>> + +fromMany :: b -> ([a] -> b) -> [a] -> b +fromMany e _ [] = e +fromMany _ f xs = f xs + +swing :: (((a -> c1) -> c1) -> b -> c) -> b -> a -> c +swing = flip . (. flip id) + +paddedTrans :: a -> [[a]] -> [[a]] +paddedTrans _ [] = [] +paddedTrans n as = take (maximum . map length $ as) . trans $ as + where trans ([] : xss) = (n : map h xss) : trans ([n] : (map t xss)) + trans ((x : xs) : xss) = (x : map h xss) : trans (m xs : (map t xss)) + trans _ = []; + h (x:_) = x; h _ = n; t (_:y:xs) = (y:xs); t _ = [n]; + m (x:xs) = (x:xs); m _ = [n]; + + +{-------------------------------------------------------------------- + StringTemplate and the API +--------------------------------------------------------------------} + +-- | A function that generates StringTemplates. +-- This is conceptually a query function into a \"group\" of StringTemplates. +type STGroup a = String -> (StFirst (StringTemplate a)) + +-- | A String with \"holes\" in it. StringTemplates may be composed of any +-- 'Stringable' type, which at the moment includes 'String's, 'ByteString's, +-- PrettyPrinter 'Doc's, and 'Endo' 'String's, which are actually of type +-- 'ShowS'. When a StringTemplate is composed of a type, its internals are +-- as well, so it is, so to speak \"turtles all the way down.\" +data StringTemplate a = STMP {senv :: SEnv a, runSTMP :: SEnv a -> a} + +-- | Renders a StringTemplate to a String. +toString :: StringTemplate String -> String +toString = render + +-- | Renders a StringTemplate to a 'Text.PrettyPrint.HughesPJ.Doc'. +toPPDoc :: StringTemplate PP.Doc -> PP.Doc +toPPDoc = render + +-- | Generic render function for a StringTemplate of any type. +render :: Stringable a => StringTemplate a -> a +render = runSTMP <*> senv + +-- | Parses a String to produce a StringTemplate, with \'$\'s as delimiters. +-- It is constructed with a stub group that cannot look up other templates. +newSTMP :: Stringable a => String -> StringTemplate a +newSTMP = STMP (SEnv M.empty [] mempty id) . parseSTMP ('$','$') + +-- | Parses a String to produce a StringTemplate, delimited by angle brackets. +-- It is constructed with a stub group that cannot look up other templates. +newAngleSTMP :: Stringable a => String -> StringTemplate a +newAngleSTMP = STMP (SEnv M.empty [] mempty id) . parseSTMP ('$','$') + +-- | Yields a StringTemplate with the appropriate attribute set. +-- If the attribute already exists, it is appended to a list. +setAttribute :: (ToSElem a, Stringable b) => String -> a -> StringTemplate b -> StringTemplate b +setAttribute s x st = st {senv = envInsApp s (toSElem x) (senv st)} + +-- | Yields a StringTemplate with the appropriate attributes set. +-- If any attribute already exists, it is appended to a list. +setManyAttrib :: (ToSElem a, Stringable b) => [(String, a)] -> StringTemplate b -> StringTemplate b +setManyAttrib = flip . foldl' . flip $ uncurry setAttribute + +-- | Replaces the attributes of a StringTemplate with those +-- described in the second argument. If the argument does not yield +-- a set of named attributes but only a single one, that attribute +-- is named, as a default, \"it\". +withContext :: (ToSElem a, Stringable b) => StringTemplate b -> a -> StringTemplate b +withContext st x = case toSElem x of + SM a -> st {senv = (senv st) {smp = a}} + b -> st {senv = (senv st) {smp = M.singleton "it" b}} + +-- | Queries an String Template Group and returns Just the appropriate +-- StringTemplate if it exists, otherwise, Nothing. +getStringTemplate :: (Stringable a) => String -> STGroup a -> Maybe (StringTemplate a) +getStringTemplate s sg = stGetFirst (sg s) + +-- | Adds a set of global options to a single template +optInsertTmpl :: [(String, String)] -> StringTemplate a -> StringTemplate a +optInsertTmpl x st = st {senv = optInsert (map (second justSTR) x) (senv st)} + +-- | Sets an encoding function of a template that all values are +-- rendered with. For example one useful encoder would be 'Text.Html.stringToHtmlString'. All attributes will be encoded once and only once. +setEncoder :: (Stringable a) => (String -> String) -> StringTemplate a -> StringTemplate a +setEncoder x st = st {senv = (senv st) {senc = x} } + +{-------------------------------------------------------------------- + Internal API +--------------------------------------------------------------------} +--IMPLEMENT groups having stLookup return a Maybe for regions + +data SEnv a = SEnv {smp :: SMap a, sopts :: [(String, (SEnv a -> SElem a))], sgen :: STGroup a, senc :: String -> String} + +envLookup :: (Monad m) => String -> SEnv a -> m (SElem a) +envLookup x = M.lookup x . smp +envInsert :: (String, SElem a) -> SEnv a -> SEnv a +envInsert (s, x) y = y {smp = M.insert s x (smp y)} +envInsApp :: Stringable a => String -> SElem a -> SEnv a -> SEnv a +envInsApp s x y = y {smp = M.insertWith go s x (smp y)} + where go a (LI bs) = LI (a:bs) + go a b = LI [a,b] + +optLookup :: String -> SEnv a -> Maybe (SEnv a -> SElem a) +optLookup x = lookup x . sopts +optInsert :: [(String, SEnv a -> SElem a)] -> SEnv a -> SEnv a +optInsert x env = env {sopts = x ++ sopts env} +nullOpt :: SEnv a -> SElem a +nullOpt = fromMaybe (justSTR "") =<< optLookup "null" + +stLookup :: (Stringable a) => [Char] -> SEnv a -> StringTemplate a +stLookup x env = maybe (newSTMP ("No Template Found for: " ++ x)) + (\st-> st {senv = env}) $ stGetFirst (sgen env x) + +parseSTMP :: (Stringable a) => (Char, Char) -> String -> SEnv a -> a +parseSTMP x = either (showStr . show) (id) . runParser (stmpl False) x "" + +{-------------------------------------------------------------------- + Internal API for polymorphic display of elements +--------------------------------------------------------------------} + +showVal :: Stringable a => SEnv a -> SElem a -> a +showVal snv se = + case se of (STR x) -> stEncode x + (LI xs) -> joinUpWith showVal xs + (SM sm) -> joinUpWith showAssoc $ M.assocs sm + (STSH x) -> stEncode (format x) + (SBLE x) -> x + SNull -> showVal <*> nullOpt $ snv + where sepVal = fromMaybe (justSTR "") =<< optLookup "separator" $ snv + format = maybe stshow . stfshow <*> optLookup "format" $ snv + joinUpWith f = mintercalate (showVal snv sepVal) . map (f snv) + showAssoc e (k,v) = stEncode (k ++ ": ") `mlabel` showVal e v + stEncode = stFromString . senc snv + +showStr :: Stringable a => String -> SEnv a -> a +showStr = flip showVal . STR + +{-------------------------------------------------------------------- + Utility Combinators +--------------------------------------------------------------------} + +justSTR :: String -> b -> SElem a +justSTR = const . STR +stshow :: STShow -> String +stshow (STShow a) = stringTemplateShow a +stfshow :: Stringable a => SEnv a -> (SEnv a -> SElem a) -> STShow -> String +stfshow snv fs (STShow a) = stringTemplateFormattedShow + (stToString `o` showVal <*> fs $ snv) a + +around :: Char -> GenParser Char st t -> Char -> GenParser Char st t +around x p y = do {char x; v<-p; char y; return v} +spaced :: GenParser Char st t -> GenParser Char st t +spaced p = do {spaces; v<-p; spaces; return v} +word :: GenParser Char st [Char] +word = many1 alphaNum +comlist :: GenParser Char st a -> GenParser Char st [a] +comlist p = spaced (p `sepBy1` spaced (char ',')) + +props :: Stringable a => GenParser Char (Char, Char) [SEnv a -> SElem a] +props = many $ char '.' >> (around '(' subexprn ')' <|> justSTR <$> word) + +escapedChar, escapedStr :: [Char] -> GenParser Char st [Char] +escapedChar chs = + noneOf chs >>= \x -> if x == '\\' then anyChar >>= \y -> + if y `elem` chs then return [y] else return [x, y] else return [x] +escapedStr chs = concat <$> many1 (escapedChar chs) + +{-------------------------------------------------------------------- + The Grammar +--------------------------------------------------------------------} + +-- | if p is true, stmpl can fail gracefully, false it dies hard. +-- Set to false at the top level, and true within if expressions. +stmpl :: Stringable a => Bool -> GenParser Char (Char,Char) (SEnv a -> a) +stmpl p = do + (ca, cb) <- getState + mconcat <$> many (showStr <$> escapedStr [ca] <|> try (around ca optExpr cb) + <|> try comment <|> bl "template") + where bl | p = try blank | otherwise = blank + +subStmp :: Stringable a => GenParser Char (Char,Char) (([SElem a], [SElem a]) -> SEnv a -> a) +subStmp = do + (ca, cb) <- getState + udEnv <- option (transform ["it"]) (transform <$> try attribNames) + st <- mconcat <$> many (showStr <$> escapedStr (ca:"}|") + <|> try (around ca optExpr cb) + <|> try comment <|> blank "subtemplate") + return (st `o` udEnv) + where transform an (att,is) = + flip (foldr envInsert) $ zip ("i":"i0":an) (is++att) + attribNames = (char '|' >>) . return =<< comlist (spaced word) + +comment :: Stringable a => GenParser Char (Char,Char) (SEnv a -> a) +comment = do + (ca, cb) <- getState + string (ca:'!':[]) >> manyTill anyChar (try . string $ '!':cb:[]) + return (showStr "") + +blank :: Stringable a => GenParser Char (Char,Char) (SEnv a -> a) +blank = do + (ca, cb) <- getState + char ca + spaces + char cb + return (showStr "") + +optExpr :: Stringable a => GenParser Char (Char,Char) (SEnv a -> a) +optExpr = do + (_, cb) <- getState + (try (string ("else"++[cb])) <|> try (string "elseif(") <|> + try (string "endif")) .>> fail "Malformed If Statement." <|> return () + expr <- try stat <|> spaced exprn + opts <- many opt + skipMany (char ';') + return $ expr |. optInsert opts + where opt = around ';' (spaced word) '=' >>= (<$> spaced subexprn) . (,) + +{-------------------------------------------------------------------- + Statements +--------------------------------------------------------------------} + +getProp :: Stringable a => [SEnv a -> SElem a] -> SElem a -> SEnv a -> SElem a +getProp (p:ps) (SM mp) = maybe SNull . flip (getProp ps) <*> + flip M.lookup mp . ap (stToString `o` showVal) p +getProp (_:_) _ = const SNull +getProp _ se = const se + +ifIsSet :: t -> t -> Bool -> SElem a -> t +ifIsSet t e n SNull = if n then e else t +ifIsSet t e n _ = if n then t else e + +parseif :: Stringable a => Char -> GenParser Char (Char, Char) (Bool, SEnv a -> SElem a, [SEnv a -> SElem a], Char, SEnv a -> a, SEnv a -> a) +parseif cb = (,,,,,) `fmap` option True (char '!' >> return False) `ap` subexprn + `ap` props `ap` (char ')' >> char cb) `ap` stmpl True `ap` + (try elseifstat <|> try elsestat <|> endifstat) + +stat ::Stringable a => GenParser Char (Char, Char) (SEnv a -> a) +stat = do + (_, cb) <- getState + string "if(" + (n, e, p, _, act, cont) <- parseif cb + return (ifIsSet act cont n =<< getProp p =<< e) + +elseifstat ::Stringable a => GenParser Char (Char, Char) (SEnv a -> a) +elseifstat = do + (ca, cb) <- getState + char ca >> string "elseif(" + (n, e, p, _, act, cont) <- parseif cb + return (ifIsSet act cont n =<< getProp p =<< e) + +elsestat ::Stringable a => GenParser Char (Char, Char) (SEnv a -> a) +elsestat = do + (ca, cb) <- getState + around ca (string "else") cb + act <- stmpl True + char ca >> string "endif" + return act + +endifstat ::Stringable a => GenParser Char (Char, Char) (SEnv a -> a) +endifstat = getState >>= char . fst >> string "endif" >> return (showStr "") + +{-------------------------------------------------------------------- + Expressions +--------------------------------------------------------------------} + +exprn :: Stringable a => GenParser Char (Char,Char) (SEnv a -> a) +exprn = do + exprs <- comlist subexprn "expression" + templ <- many (char ':' >> iterApp <$> comlist (anonTmpl <|> regTemplate)) + return $ fromMany (showVal <*> head exprs) + ((sequence exprs >>=) . seqTmpls) templ + +seqTmpls :: Stringable a => [[SElem a] -> SEnv a -> a] -> [SElem a] -> SEnv a -> a +seqTmpls [f] y = f y +seqTmpls (f:fs) y = seqTmpls fs =<< (:[]) . SBLE . f y +seqTmpls _ _ = const (stFromString "") + +subexprn :: Stringable a => GenParser Char (Char,Char) (SEnv a -> SElem a) +subexprn = cct <$> spaced + (braceConcat + <|> SBLE `o` ($ ([SNull],ix0)) <$> try regTemplate + <|> attrib + <|> SBLE `o` ($ ([SNull],ix0)) <$> anonTmpl + "expression") + `sepBy1` spaced (char '+') + where cct xs@(_:_:_) = SBLE |. + flip mconcatMap <$> showVal <*> sequence xs + cct [x] = x + cct _ = const SNull + +braceConcat :: Stringable a => GenParser Char (Char,Char) (SEnv a -> SElem a) +braceConcat = LI . foldr go [] `o` sequence <$> around '['(comlist subexprn)']' + where go (LI x) lst = x++lst; go x lst = x:lst + + +literal :: GenParser Char st (b -> SElem a) +literal = justSTR <$> (around '"' (concat <$> many (escapedChar "\"")) '"' + <|> around '\'' (concat <$> many (escapedChar "'")) '\'') + +attrib :: Stringable a => GenParser Char (Char,Char) (SEnv a -> SElem a) +attrib = do + a <- literal <|> try functn <|> prepExp <$> word <|> around '(' subexprn ')' + "attribute" + proprs <- props + return $ fromMany a ((a >>=) . getProp) proprs + where prepExp var = fromMaybe SNull <$> envLookup var + +functn :: Stringable a => GenParser Char (Char,Char) (SEnv a -> SElem a) +functn = do + f <- string "first" <|> string "rest" <|> string "strip" + <|> try (string "length") <|> string "last" + (fApply f .) <$> around '(' subexprn ')' + where fApply str (LI xs) + | str == "first" = head xs + | str == "last" = last xs + | str == "rest" = (LI . tail) xs + | str == "strip" = LI . filter (not . liNil) $ xs + | str == "length" = STR . show . length $ xs + fApply str x + | str == "rest" = (LI []) + | str == "length" = STR "1" + | otherwise = x + liNil (LI x) = null x + liNil _ = False + +{-------------------------------------------------------------------- + Templates +--------------------------------------------------------------------} +--change makeTmpl to do notation for clarity? + +mkIndex :: Num b => [b] -> [[SElem a]] +mkIndex = map ((:) . STR . show . (1+) <*> (:[]) . STR . show) +ix0 :: [SElem a] +ix0 = [STR "1",STR "0"] + +cycleApp :: (Stringable a) => [([SElem a], [SElem a]) -> SEnv a -> a] -> [([SElem a], [SElem a])] -> SEnv a -> a +cycleApp x y = mconcatMap (zipWith ($) (cycle x) y) . flip ($) + +pluslen :: [a] -> [([a], [SElem b])] +pluslen xs = zip (map (:[]) xs) $ mkIndex [0..(length xs)] + +liTrans :: [SElem a] -> [([SElem a], [SElem a])] +liTrans = pluslen' . paddedTrans SNull . map u + where u (LI x) = x; u x = [x] + pluslen' xs = zip xs $ mkIndex [0..(length (head xs))] + +iterApp :: Stringable a => [([SElem a], [SElem a]) -> SEnv a -> a] -> [SElem a] -> SEnv a -> a +iterApp [f] (LI xs:[]) = (mconcatMap $ pluslen xs) . flip f +iterApp [f] vars@(LI _:_) = (mconcatMap $ liTrans vars) . flip f +iterApp [f] v = f (v,ix0) +iterApp fs (LI xs:[]) = cycleApp fs (pluslen xs) +iterApp fs vars@(LI _:_) = cycleApp fs (liTrans vars) +iterApp fs xs = cycleApp fs (pluslen xs) + +anonTmpl :: Stringable a => GenParser Char (Char, Char) (([SElem a], [SElem a]) -> SEnv a -> a) +anonTmpl = around '{' subStmp '}' + +regTemplate :: Stringable a => GenParser Char (Char, Char) (([SElem a], [SElem a]) -> SEnv a -> a) +regTemplate = do + try (functn::GenParser Char (Char,Char) (SEnv String -> SElem String)) .>> fail "" <|> return () + name <- justSTR <$> many1 (alphaNum <|> char '.' <|> char '/') + <|> around '(' subexprn ')' + vals <- around '(' (spaced $ try assgn <|> anonassgn <|> return []) ')' + return $ join . (. name) . makeTmpl vals + where makeTmpl v ((se:_),is) (STR x) = + render |. stBind . (zip ["it","i","i0"] (se:is) ++) + . swing (map . second) v <*> stLookup x + makeTmpl _ _ _ = showStr "Invalid Template Specified" + stBind v st = st {senv = foldr envInsert (senv st) v} + anonassgn = (:[]) . (,) "it" <$> subexprn + assgn = (spaced word >>= (<$> char '=' .>> spaced subexprn) . (,)) + `sepEndBy1` char ';' + +--DEBUG + +{-pTrace s = pt <|> return () + where pt = try $ + do + x <- try $ many1 anyChar + trace (s++": " ++x) $ try $ char 'z' + fail x +-} diff --git a/Text/StringTemplate/Classes.hs b/Text/StringTemplate/Classes.hs new file mode 100644 --- /dev/null +++ b/Text/StringTemplate/Classes.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE ExistentialQuantification, FlexibleInstances #-} +{-# OPTIONS_HADDOCK not-home #-} +module Text.StringTemplate.Classes + (SElem(..), StringTemplateShows(..), ToSElem(..), SMap, STShow(..), + StFirst(..), Stringable(..), stShowsToSE + ) where +import qualified Data.Map as M +import Data.List +import Data.Monoid +import qualified Data.ByteString.Char8 as B +import qualified Text.PrettyPrint.HughesPJ as PP + +newtype StFirst a = StFirst { stGetFirst :: Maybe a } + deriving (Eq, Ord, Read, Show) +instance Monoid (StFirst a) where + mempty = StFirst Nothing + r@(StFirst (Just _)) `mappend` _ = r + StFirst Nothing `mappend` r = r + +instance Functor StFirst where + fmap f x = StFirst . fmap f . stGetFirst $ x + +type SMap a = M.Map String (SElem a) + +data SElem a = STR String | STSH STShow | SM (SMap a) | LI [SElem a] | SBLE a | SNull + +-- | The ToSElem class should be instantiated for all types that can be +-- inserted as attributes into a StringTemplate. +class ToSElem a where + toSElem :: Stringable b => a -> SElem b + toSElemList :: Stringable b => [a] -> SElem b + toSElemList = LI . map toSElem + +-- | The StringTemplateShows class should be instantiated for all types that are +-- directly displayed in a StringTemplate, but take an optional format string. Each such type must have an appropriate ToSElem method defined as well. +class (Show a) => StringTemplateShows a where + -- | Defaults to 'show'. + stringTemplateShow :: a -> String + stringTemplateShow = show + -- | Defaults to @ flip $ const . stringTemplateShow @ + stringTemplateFormattedShow :: String -> a -> String + stringTemplateFormattedShow = flip $ const . stringTemplateShow + +-- | This method should be used to create ToSElem instances for +-- types defining a custom formatted show function. +stShowsToSE :: (StringTemplateShows a, Stringable b) => a -> SElem b +stShowsToSE = STSH . STShow + +data STShow = forall a.(StringTemplateShows a) => STShow a + +-- | The Stringable class should be instantiated with care. +-- Generally, the provided instances should be enough for anything. +class Monoid a => Stringable a where + stFromString :: String -> a + stToString :: a -> String + -- | Defaults to @ mconcatMap m k = foldr (mappend . k) mempty m @ + mconcatMap :: [b] -> (b -> a) -> a + mconcatMap m k = foldr (mappend . k) mempty m + -- | Defaults to @ (mconcat .) . intersperse @ + mintercalate :: a -> [a] -> a + mintercalate = (mconcat .) . intersperse + -- | Defaults to @ mappend @ + mlabel :: a -> a -> a + mlabel = mappend + +instance Stringable [Char] where + stFromString = id + stToString = id + +instance Stringable PP.Doc where + stFromString = PP.text + stToString = PP.render + mconcatMap m k = PP.fcat . map k $ m + mintercalate = (PP.fcat .) . PP.punctuate + mlabel x y = (x PP.$$ PP.nest 1 y) + +instance Monoid PP.Doc where + mempty = PP.empty + x `mappend` y = x PP.<> y + +instance Stringable B.ByteString where + stFromString = B.pack + stToString = B.unpack + +instance Stringable (Endo String) where + stFromString = Endo . (++) + stToString = ($ []) . appEndo diff --git a/Text/StringTemplate/GenericStandard.hs b/Text/StringTemplate/GenericStandard.hs new file mode 100644 --- /dev/null +++ b/Text/StringTemplate/GenericStandard.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleInstances, OverlappingInstances, UndecidableInstances, Rank2Types, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-------------------------------------------------------------------- +-- | Generic Instance for ToSElem using standard Data.Generic libraries. +--------------------------------------------------------------------} + +module Text.StringTemplate.GenericStandard() where +import qualified Data.Map as M +import Text.StringTemplate.Classes +import Text.StringTemplate.Instances() +import Data.Generics.Basics +import Data.Generics.Aliases + +gToSElem :: forall a b.(Data a, Stringable b) => a -> SElem b +gToSElem = (\x -> + case (map stripInitUnder (constrFields . toConstr $ x)) of + [] -> LI (STR (showConstr (toConstr x)) : + (gmapQ gToSElem x)) + fs -> SM (M.fromList (zip fs (gmapQ gToSElem x))) + ) + `ext1Q` (\t -> case t of (Just x) -> gToSElem x; _ -> SNull) + `ext1Q` (SM . fmap gToSElem) + `ext1Q` (LI . map gToSElem) + `extQ` (toSElem :: Bool -> SElem b) + `extQ` (toSElem :: Float -> SElem b) + `extQ` (toSElem :: Double -> SElem b) + `extQ` (toSElem :: Int -> SElem b) + `extQ` (toSElem :: Integer -> SElem b) + `extQ` (toSElem :: String -> SElem b) + +instance Data a => ToSElem a + where toSElem = gToSElem + +stripInitUnder :: [Char] -> [Char] +stripInitUnder ('_':s) = stripInitUnder s +stripInitUnder s = s diff --git a/Text/StringTemplate/GenericWithClass.hs b/Text/StringTemplate/GenericWithClass.hs new file mode 100644 --- /dev/null +++ b/Text/StringTemplate/GenericWithClass.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE FlexibleInstances, OverlappingInstances, FlexibleContexts, UndecidableInstances, Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-------------------------------------------------------------------- +-- | Generic Instance for ToSElem using syb-with-class. +-- Inspired heavily-to-entirely by Alex Drummond's RJson. +--------------------------------------------------------------------} + +module Text.StringTemplate.GenericWithClass() where +import qualified Data.Map as M +import Text.StringTemplate.Classes +import Data.Generics.SYB.WithClass.Basics + +stripInitialUnderscores :: [Char] -> [Char] +stripInitialUnderscores ('_':s) = stripInitialUnderscores s +stripInitialUnderscores s = s + +data ToSElemD a = ToSElemD { toSElemD :: Stringable b => a -> SElem b } + +toSElemProxy :: Proxy ToSElemD +toSElemProxy = error "This value should never be evaluated!" + +instance ToSElem a => Sat (ToSElemD a) where + dict = ToSElemD { toSElemD = toSElem } + +genericToSElem :: (Data ToSElemD a, ToSElem a, Stringable b) => a -> SElem b +genericToSElem x + | isAlgType (dataTypeOf toSElemProxy x) = + case (map stripInitialUnderscores (getFields x)) of + [] -> LI (STR (showConstr (toConstr toSElemProxy x)) : + (gmapQ toSElemProxy (toSElemD dict) x)) + fs -> SM (M.fromList (zip fs (gmapQ toSElemProxy (toSElemD dict) x))) + | True = + error ("Unable to serialize the primitive type '" ++ + dataTypeName (dataTypeOf toSElemProxy x) ++ "'") + +getFields :: Data ToSElemD a => a -> [String] +getFields = constrFields . (toConstr toSElemProxy) + +instance Data ToSElemD t => ToSElem t where + toSElem = genericToSElem diff --git a/Text/StringTemplate/Group.hs b/Text/StringTemplate/Group.hs new file mode 100644 --- /dev/null +++ b/Text/StringTemplate/Group.hs @@ -0,0 +1,126 @@ +{-# OPTIONS_HADDOCK not-home #-} + +module Text.StringTemplate.Group + (groupStringTemplates, addSuperGroup, addSubGroup, setEncoderGroup, + mergeSTGroups, directoryGroup, optInsertGroup, + directoryGroupLazy, unsafeVolatileDirectoryGroup + ) where +import Control.Applicative hiding ((<|>),many) +import Control.Arrow +import Data.Monoid +import Data.List +import System.Time +import System.FilePath +import System.Directory +import Data.IORef +import System.IO.Unsafe +import System.IO.Error +import qualified Data.Map as M + +import Text.StringTemplate.Base +import Text.StringTemplate.Classes + +{-------------------------------------------------------------------- + Utilities +--------------------------------------------------------------------} + +(<$$>) :: (Functor f1, Functor f) => (a -> b) -> f (f1 a) -> f (f1 b) +(<$$>) x y = ((<$>) . (<$>)) x y + +sgInsert :: (String -> StFirst (StringTemplate a)) -> StringTemplate a -> StringTemplate a +sgInsert g st = let e = senv st in st {senv = e {sgen = sgen e `mappend` g} } +sgOverride :: STGroup a -> StringTemplate a -> StringTemplate a +sgOverride g st = let e = senv st in st {senv = e {sgen = g `mappend` sgen e} } + + +{-------------------------------------------------------------------- + Group API +--------------------------------------------------------------------} + +-- | Given a list of named of StringTemplates, returns a group which generates +-- them such that they can call one another. +groupStringTemplates :: [(String,StringTemplate a)] -> STGroup a +groupStringTemplates xs = newGen + where newGen s = StFirst (M.lookup s ng) + ng = foldl' (flip $ uncurry M.insert) M.empty $ + map (second $ sgInsert newGen) xs + +-- | Given a path, returns a group which generates all files in said directory +-- which have the proper \"st\" extension. +-- This function is strict, with all files read once. As it performs file IO, +-- expect it to throw the usual exceptions. +directoryGroup :: (Stringable a) => FilePath -> IO (STGroup a) +directoryGroup path = groupStringTemplates <$> + (fmap <$> zip . (map dropExtension) + <*> mapM (newSTMP <$$> readFile) + =<< filter ((".st" ==) . takeExtension) + <$> getDirectoryContents path) + +-- | Given a path, returns a group which generates all files in said directory +-- which have the proper \"st\" extension. +-- This function is lazy in the same way that readFile is lazy, with all +-- files read on demand, but no more than once. As it performs file IO, +-- expect it to throw the usual exceptions. And, as it is lazy, expect +-- these exceptions in unexpected places. +directoryGroupLazy :: (Stringable a) => FilePath -> IO (STGroup a) +directoryGroupLazy path = groupStringTemplates <$> + (fmap <$> zip . (map dropExtension) + <*> mapM (unsafeInterleaveIO . (newSTMP <$$> readFile)) + =<< filter ((".st" ==) . takeExtension) + <$> getDirectoryContents path) + +-- | Adds a supergroup to any StringTemplate group such that templates from +-- the original group are now able to call ones from the supergroup as well. +addSuperGroup :: STGroup a -> STGroup a -> STGroup a +addSuperGroup f g = sgInsert g <$$> f + +-- | Adds a \"subgroup\" to any StringTemplate group such that templates from +-- the original group now have template calls \"shadowed\" by the subgroup. +addSubGroup :: STGroup a -> STGroup a -> STGroup a +addSubGroup f g = sgOverride g <$$> f + +-- | Merges two groups into a single group. This function is left-biased, +-- prefering bindings from the first group when there is a conflict. +mergeSTGroups :: STGroup a -> STGroup a -> STGroup a +mergeSTGroups f g = addSuperGroup f g `mappend` addSubGroup g f + +-- | Adds a set of global options to a group +optInsertGroup :: [(String, String)] -> STGroup a -> STGroup a +optInsertGroup opts f = optInsertTmpl opts <$$> f + +-- | Sets an encoding function of a group that all values are +-- rendered with in each enclosed template +setEncoderGroup :: (Stringable a) => (String -> String) -> STGroup a -> STGroup a +setEncoderGroup x f = setEncoder x <$$> f + +{-# NOINLINE unsafeVolatileDirectoryGroup #-} + +-- | Given an integral amount of seconds and a path, returns a group generating +-- all files in said directory with the proper \"st\" extension, +-- cached for that amount of seconds. IO errors are \"swallowed\" by this so +-- that exceptions don't arise in unexpected places. +-- This violates referential transparency, but can be very useful in developing +-- templates for any sort of server application. +-- It should be swapped out for production purposes. +unsafeVolatileDirectoryGroup :: Stringable a => String -> Int -> IO (STGroup a) +unsafeVolatileDirectoryGroup path i = return (cacheSTGroup i stfg) + where stfg = StFirst . Just . STMP (SEnv M.empty [] stfg id) + . parseSTMP ('$', '$') . unsafePerformIO . flip catch + (return . ("IO Error: " ++) . ioeGetErrorString) + . readFile . (path ) + cacheSTGroup :: Int -> STGroup a -> STGroup a + cacheSTGroup m g = unsafePerformIO $ go <$> newIORef M.empty + where go r s = unsafePerformIO $ do + mp <- readIORef r + now <- getClockTime + maybe (udReturn now) + (\(t, st) -> if (tdSec . normalizeTimeDiff $ + diffClockTimes now t) > m + then udReturn now + else return st) + . M.lookup s $ mp + where udReturn now = do + let st = g s + atomicModifyIORef r $ + flip (,) () . M.insert s (now, st) + return st diff --git a/Text/StringTemplate/Instances.hs b/Text/StringTemplate/Instances.hs new file mode 100644 --- /dev/null +++ b/Text/StringTemplate/Instances.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE FlexibleInstances, OverlappingInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_HADDOCK not-home #-} + +module Text.StringTemplate.Instances where +import Text.StringTemplate.Classes + +import qualified Data.Map as M +import Numeric +import Data.Ratio +import Data.Array +import Data.Maybe +import qualified Data.Foldable as F +import qualified System.Time as OldTime +import System.Locale +import Data.Time + +{-------------------------------------------------------------------- + Additional instances for items that may be set as StringTemplate + attributes. The code should provide examples of how to proceed. +--------------------------------------------------------------------} + +--Basics +instance ToSElem Char where + toSElem = STR . (:[]) + toSElemList = STR + +instance ToSElem Bool where + toSElem True = STR "" + toSElem _ = SNull + +instance (ToSElem a) => ToSElem (Maybe a) where + toSElem (Just x) = toSElem x + toSElem _ = SNull + +instance (ToSElem a) => ToSElem (M.Map String a) where + toSElem = SM . fmap toSElem + +instance (ToSElem a) => ToSElem [a] where + toSElem = toSElemList + +instance (ToSElem a, Ix i) => ToSElem (Array i a) where + toSElem = toSElem . elems + +instance (ToSElem a, F.Foldable t) => ToSElem (t a) where + toSElem = toSElemList . F.toList + +--Numbers +instance StringTemplateShows Float where + stringTemplateShow = flip showFloat "" + stringTemplateFormattedShow = flip flip [] . showGFloat . fmap fst . listToMaybe . reads +instance ToSElem Float where + toSElem = stShowsToSE + +instance StringTemplateShows Double where + stringTemplateShow = flip showFloat "" + stringTemplateFormattedShow = flip flip [] . showGFloat . fmap fst . listToMaybe . reads +instance ToSElem Double where + toSElem = stShowsToSE + +instance ToSElem Int where + toSElem = STR . show + +instance ToSElem Integer where + toSElem = STR . show + +instance Integral a => ToSElem (Ratio a) where + toSElem = STR . show + +--Dates and Times +instance StringTemplateShows OldTime.CalendarTime where + stringTemplateShow = OldTime.calendarTimeToString + stringTemplateFormattedShow = OldTime.formatCalendarTime defaultTimeLocale +instance ToSElem OldTime.CalendarTime where + toSElem = stShowsToSE + +instance StringTemplateShows OldTime.TimeDiff where + stringTemplateShow = OldTime.timeDiffToString + stringTemplateFormattedShow = OldTime.formatTimeDiff defaultTimeLocale +instance ToSElem OldTime.TimeDiff where + toSElem = stShowsToSE + +instance StringTemplateShows Day where + stringTemplateShow = show + stringTemplateFormattedShow = formatTime defaultTimeLocale +instance ToSElem Day where + toSElem = stShowsToSE + +instance StringTemplateShows LocalTime where + stringTemplateShow = show + stringTemplateFormattedShow = formatTime defaultTimeLocale +instance ToSElem LocalTime where + toSElem = stShowsToSE + +instance StringTemplateShows TimeOfDay where + stringTemplateShow = show + stringTemplateFormattedShow = formatTime defaultTimeLocale +instance ToSElem TimeOfDay where + toSElem = stShowsToSE + +instance StringTemplateShows UTCTime where + stringTemplateShow = show + stringTemplateFormattedShow = formatTime defaultTimeLocale +instance ToSElem UTCTime where + toSElem = stShowsToSE + +instance StringTemplateShows TimeZone where + stringTemplateShow = show + stringTemplateFormattedShow = formatTime defaultTimeLocale +instance ToSElem TimeZone where + toSElem = stShowsToSE + +instance StringTemplateShows ZonedTime where + stringTemplateShow = show + stringTemplateFormattedShow = formatTime defaultTimeLocale +instance ToSElem ZonedTime where + toSElem = stShowsToSE + +--Tuples +instance (ToSElem a, ToSElem b) => ToSElem (a, b) where + toSElem (a,b) = LI [toSElem a, toSElem b] +instance (ToSElem a, ToSElem b, ToSElem c) => ToSElem (a, b, c) where + toSElem (a,b,c) = LI [toSElem a, toSElem b, toSElem c] +instance (ToSElem a, ToSElem b, ToSElem c, ToSElem d) => ToSElem (a, b, c, d) where + toSElem (a,b,c,d) = LI [toSElem a, toSElem b, toSElem c, toSElem d] +instance (ToSElem a, ToSElem b, ToSElem c, ToSElem d, ToSElem e) => ToSElem (a, b, c, d, e) where + toSElem (a,b,c,d,e) = LI [toSElem a, toSElem b, toSElem c, toSElem d, toSElem e] diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import qualified Properties +import qualified Units + +main = do + Properties.main + Units.main diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -0,0 +1,165 @@ +{-# OPTIONS -O2 -fglasgow-exts #-} + +module Properties where +import Text.Printf +import Control.Monad +import Control.Arrow hiding (pure) +import Control.Applicative hiding ((<|>),many) +import Data.Maybe +import Data.Monoid +import Data.List +import System.IO +import System.Random hiding (next) +import qualified Data.Map as M + +import Text.StringTemplate.Classes +import Text.StringTemplate.Instances +import Text.StringTemplate.Base +import Text.StringTemplate.Group +import Test.QuickCheck +import System.Environment + +--import Debug.Trace +--mytrace h x = trace (h ++ ": " ++ x) $ x + +main :: IO () +main = do + args <- getArgs + let n = if null args then 100 else read (head args) + (results, passed) <- liftM unzip $ mapM + (\(s,a) -> printf "%-25s: " s >> a n) tests + printf "Passed %d tests!\n" (sum passed) + when (not . and $ results) $ fail "Not all tests passed!" + where + tests = + [("prop_paddedTrans" , mytest prop_paddedTrans), + ("prop_constStr" , mytest prop_constStr), + ("prop_emptyNulls" , mytest prop_emptyNulls), + ("prop_fullNulls" , mytest prop_fullNulls), + ("prop_substitution" , mytest prop_substitution), + ("prop_separator" , mytest prop_separator), + ("prop_attribs" , mytest prop_attribs), + ("prop_comment" , mytest prop_comment), + ("prop_ifelse" , mytest prop_ifelse), + ("prop_simpleGroup" , mytest prop_simpleGroup) + ] + +{----------------------------------------------------------------------- + Limited tests for now: just for list juggling and some basic parsing. +-----------------------------------------------------------------------} + +prop_paddedTrans (x::[Int]) (y::[Int]) (z::[Int]) n = + (length pt == length npt) && + all (3 ==) (map length pt) && + all (all (==n)) (zipWith unmerge (paddedTrans n pt) [x,y,z]) + where pt = paddedTrans n [x,y,z] + npt = transpose [x,y,z] + unmerge xl@(x:xs) (y:ys) + | x == y = unmerge xs ys + | otherwise = xl + unmerge x y = x + +prop_constStr (LitString x) = x == (toString . newSTMP $ x) + +prop_emptyNulls (LitString x) (LitString y) i = + (concat . replicate (abs i) $ x) == + (toString . newSTMP . concat . replicate (abs i) $ tmpl) + where tmpl = x++"$"++y++"$" + +prop_fullNulls (LitString x) (LitString y) i = + length y > 0 ==> + (concat . replicate (abs i) $ x++y) == + (toString . newSTMP . concat . replicate (abs i) $ tmpl) + where tmpl = x++"$"++y++";null='"++y++"'$" + +prop_substitution (LitString x) (LitString y) (LitString z) i = + length y > 0 ==> + (concat . replicate (abs i) $ x++z) == + (toString . setAttribute y z . + newSTMP . concat . replicate (abs i) $ tmpl) + where tmpl = x++"$"++y++"$" + +prop_separator (LitString x) (LitString y) (LitString z) i = + length x > 0 ==> + (concat . intersperse z . replicate (abs i) $ y) == + (toString . setAttribute x (replicate (abs i) y) + . newSTMP $ tmpl) + where tmpl = "$"++x++";separator='"++z++"'$" + +prop_comment (LitString x) (LitString y) (LitString z) = + toString (newSTMP (x ++ "$!" ++ y ++ "!$" ++ z)) == x ++ z + +prop_attribs (LitString x) i = + toString (setManyAttrib (replicate (abs i) ("f",x)) $ newSTMP "$f$") + == (concat . replicate (abs i) $ x) + +prop_ifelse a b c d = + toString (setManyAttrib alist . newSTMP $ "$if(a)$a$elseif(b)$b$elseif(c)$c$else$$if(d)$d$else$e$endif$$endif$") == (fst . head . filter snd) alist + where alist = [("a",a),("b",b),("c",c),("d",d),("e",True)] + +prop_simpleGroup (LitString x) (LitString y) (LitString z) (LitString t) = + length x > 0 && length y > 0 && length z > 0 && length t > 0 + && length (nub [x,y,z,t]) == 4 ==> + x == (toString . fromJust . getStringTemplate x $ grp) + where tm = newSTMP x + tm' = newSTMP $ "$"++y++"()$" + tmIt = newSTMP "$it$" + tm'' = newSTMP $ "$"++z++"():"++t++"()$" + grp = groupStringTemplates [(y,tm),(z,tm'),(t,tmIt),(x,tm'')] + +newtype LitChar = LitChar {unLitChar :: Char} deriving Show +instance Arbitrary LitChar where + arbitrary = LitChar <$> choose ('a','z') + coarbitrary = undefined + +newtype LitString = LitString String deriving Show +instance Arbitrary LitString where + arbitrary = LitString . map unLitChar <$> sized (\n -> choose (0,n) >>= vector) + coarbitrary = undefined +{-------------------------------------------------------------------- + QuickCheck Driver: This lovely code borrowed wholesale from XMonad. +--------------------------------------------------------------------} + +mytest :: Testable a => a -> Int -> IO (Bool, Int) +mytest a n = mycheck defaultConfig + { configMaxTest=n + , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] } a + +mycheck :: Testable a => Config -> a -> IO (Bool, Int) +mycheck config a = do + rnd <- newStdGen + mytests config (evaluate a) rnd 0 0 [] + +mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO (Bool, Int) +mytests config gen rnd0 ntest nfail stamps + | ntest == configMaxTest config = done "OK," ntest stamps >> return (True, ntest) + | nfail == configMaxFail config = done "Arguments exhausted after" ntest stamps >> return (True, ntest) + | otherwise = + do putStr (configEvery config ntest (arguments result)) >> hFlush stdout + case ok result of + Nothing -> + mytests config gen rnd1 ntest (nfail+1) stamps + Just True -> + mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) + Just False -> + putStr ( "Falsifiable after " + ++ show ntest + ++ " tests:\n" + ++ unlines (arguments result) + ) >> hFlush stdout >> return (False, ntest) + where + result = generate (configSize config ntest) rnd2 gen + (rnd1,rnd2) = split rnd0 + +done :: String -> Int -> [[String]] -> IO () +done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) + where + table = display . map entry . reverse . sort . map pairLength . group + . sort . filter (not . null) $ stamps + display [] = ".\n" + display [x] = " (" ++ x ++ ").\n" + display xs = ".\n" ++ unlines (map (++ ".") xs) + pairLength xss@(xs:_) = (length xss, xs) + entry (n, xs) = percentage n ntest ++ " " + ++ concat (intersperse ", " xs) + percentage n m = show ((100 * n) `div` m) ++ "%" diff --git a/tests/Units.hs b/tests/Units.hs new file mode 100644 --- /dev/null +++ b/tests/Units.hs @@ -0,0 +1,41 @@ +{-# OPTIONS -O2 -fglasgow-exts #-} + +module Units where +import System.IO +import qualified Data.Map as M + +import Text.StringTemplate.Classes +import Text.StringTemplate.Instances +import Text.StringTemplate.Base +import Text.StringTemplate.Group +import Test.HUnit +import System.Environment + +no_prop = toString (setAttribute "foo" "f" $ newSTMP "a$foo.bar$a") + ~=? "aa" + +one_prop = toString (setAttribute "foo" (M.singleton "bar" "baz") $ newSTMP "a$foo.bar$a") + ~=? "abaza" + +anon_tmpl = toString (setAttribute "foo" "f" $ newSTMP "a$foo:{{$foo$\\}}$a") + ~=? "a{f}a" + +setA = setAttribute "foo" ["a","b","c"] +func_first = toString (setA $ newSTMP "$first(foo)$") ~=? "a" +func_last = toString (setA $ newSTMP "$last(foo)$") ~=? "c" +func_rest = toString (setA $ newSTMP "$rest(foo)$") ~=? "bc" +func_length = toString (setA $ newSTMP "$length(foo)$") ~=? "3" + +tests = TestList ["no_prop" ~: no_prop, + "one_prop" ~: one_prop, + "func_first" ~: func_first, + "func_last" ~: func_last, + "func_rest" ~: func_rest, + "func_length" ~: func_length, + "anon_tmpl" ~: anon_tmpl] + +main = do + c <- runTestTT tests + if (errors c > 0 || failures c > 0) + then fail "Not all tests passed." + else return () diff --git a/tests/loc.hs b/tests/loc.hs new file mode 100644 --- /dev/null +++ b/tests/loc.hs @@ -0,0 +1,12 @@ +import Control.Monad +import System.Exit + +main = do foo <- getContents + let actual_loc = filter (not.null) $ filter isntcomment $ + map (dropWhile (==' ')) $ lines foo + loc = length actual_loc + putStrLn $ show loc ++ " lines of code." + +isntcomment ('-':'-':_) = False +isntcomment ('{':'-':_) = False -- pragmas +isntcomment _ = True