packages feed

HStringTemplate 0.4.3 → 0.5

raw patch · 12 files changed

+225/−327 lines, 12 filesdep +template-haskell

Dependencies added: template-haskell

Files

HStringTemplate.cabal view
@@ -1,5 +1,5 @@ name:                HStringTemplate-version:             0.4.3+version:             0.5 synopsis:            StringTemplate implementation in Haskell. description:         A port of the Java library by Terrence Parr. category:            Text@@ -15,6 +15,7 @@ flag small-base flag syb-with-class flag simple-generics+flag quasi-quotation  library   if flag(syb-with-class)@@ -23,6 +24,10 @@    if flag(simple-generics)     exposed-modules: Text.StringTemplate.GenericStandard++  if flag(quasi-quotation)+    build-depends: template-haskell >= 2.3+    exposed-modules: Text.StringTemplate.QQ    if flag(small-base)     build-depends:   base >= 3, filepath, parsec < 3, containers, pretty, time, old-time, old-locale, bytestring, directory, array
− README 
@@ -1,16 +0,0 @@-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. (<http://www.stringtemplate.org>).--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
Text/StringTemplate.hs view
@@ -45,12 +45,15 @@   -- * Display   toString, toPPDoc, render, dumpAttribs,   -- * Modification-  setAttribute, (|=), setManyAttrib, withContext,+  setAttribute, (|=), setManyAttrib,+  setNativeAttribute, setManyNativeAttrib,+  withContext,   optInsertTmpl, optInsertGroup,   setEncoder, setEncoderGroup,   -- * Groups   groupStringTemplates, addSuperGroup, addSubGroup,   mergeSTGroups, directoryGroup, unsafeVolatileDirectoryGroup,+  directoryGroupRecursive, directoryGroupRecursiveLazy,   directoryGroupLazy, nullGroup   ) where import Text.StringTemplate.Base
Text/StringTemplate/Base.hs view
@@ -5,8 +5,11 @@      Stringable(..), stShowsToSE, inSGen,      toString, toPPDoc, render, newSTMP, newAngleSTMP,      getStringTemplate, getStringTemplate',-     setAttribute, setManyAttrib, withContext, optInsertTmpl, setEncoder,-     paddedTrans, SEnv(..), parseSTMP, dumpAttribs+     setAttribute, setManyAttrib,+     setNativeAttribute, setManyNativeAttrib,+     withContext, optInsertTmpl, setEncoder,+     paddedTrans, SEnv(..), parseSTMP, dumpAttribs,+     parseSTMPNames     ) where import Control.Monad import Control.Arrow@@ -25,6 +28,8 @@   Generic Utilities --------------------------------------------------------------------} +type TmplParser x = GenParser Char ((Char, Char),[String]) x+ (<$$>) :: (Functor f1, Functor f) => (a -> b) -> f (f1 a) -> f (f1 b) (<$$>) x y = ((<$>) . (<$>)) x y infixr 8 <$$>@@ -88,7 +93,7 @@ -- | 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 ('$','$')+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.@@ -100,6 +105,22 @@ setManyAttrib :: (ToSElem a, Stringable b) => [(String, a)] -> StringTemplate b -> StringTemplate b setManyAttrib = flip . foldl' . flip $ uncurry setAttribute +-- | Yields a StringTemplate with the appropriate attribute set.+-- If the attribute already exists, it is appended to a list.+-- This will not translate the attribute through any intermediate+-- representation, so is more efficient when, e.g. setting+-- attributes that are large bytestrings in a bytestring template.+setNativeAttribute :: Stringable b => String -> b -> StringTemplate b -> StringTemplate b+setNativeAttribute s x st = st {senv = envInsApp s (SBLE x) (senv st)}++-- | Yields a StringTemplate with the appropriate attributes set.+-- If any attribute already exists, it is appended to a list.+-- Attributes are added natively, which may provide+-- efficiency gains.+setManyNativeAttrib :: (Stringable b) => [(String, b)] -> StringTemplate b -> StringTemplate b+setManyNativeAttrib = flip . foldl' . flip $ uncurry setNativeAttribute++ -- | 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@@ -171,8 +192,20 @@ mergeSEnvs x y = SEnv {smp = M.union (smp x) (smp y), sopts = (sopts y ++ sopts x), sgen = sgen x, senc = senc y}  parseSTMP :: (Stringable a) => (Char, Char) -> String -> SEnv a -> a-parseSTMP x = either (showStr .  show) (id) . runParser (stmpl False) x ""+parseSTMP x = either (showStr .  show) (id) . runParser (stmpl False) (x,[]) "" +getSeps :: TmplParser (Char, Char)+getSeps = fst <$> getState++tellNames :: String -> TmplParser ()+tellNames x = getState >>= \(s,n) -> setState (s,x:n)++parseSTMPNames :: String -> Either ParseError [String]+parseSTMPNames = runParser getRefs (('$','$'),[]) ""+    where getRefs = do+            stmpl False :: TmplParser (SEnv String -> String)+            snd <$> getState+ {--------------------------------------------------------------------   Internal API for polymorphic display of elements --------------------------------------------------------------------}@@ -180,6 +213,7 @@ showVal :: Stringable a => SEnv a -> SElem a -> a showVal snv se = case se of                    STR x  -> stEncode x+                   BS  x  -> stFromByteString x                    LI xs  -> joinUpWith showVal xs                    SM sm  -> joinUpWith showAssoc $ M.assocs sm                    STSH x -> stEncode (format x)@@ -216,7 +250,7 @@ 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 :: Stringable a => TmplParser [SEnv a -> SElem a] props = many $ char '.' >> (around '(' subexprn ')' <|> justSTR <$> word)  escapedChar, escapedStr :: [Char] -> GenParser Char st [Char]@@ -231,16 +265,16 @@  -- | 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 :: Stringable a => Bool -> TmplParser (SEnv a -> a) stmpl p = do-  (ca, cb) <- getState+  (ca, cb) <- getSeps   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 :: Stringable a => TmplParser (([SElem a], [SElem a]) -> SEnv a -> a) subStmp = do-  (ca, cb) <- getState+  (ca, cb) <- getSeps   udEnv <- option (transform ["it"]) (transform <$> try attribNames)   st <- mconcat <$> many (showStr <$> escapedStr (ca:"}|")                          <|> try (around ca optExpr cb)@@ -250,29 +284,29 @@                 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 :: Stringable a => TmplParser (SEnv a -> a) comment = do-  (ca, cb) <- getState+  (ca, cb) <- getSeps   string (ca:'!':[]) >> manyTill anyChar (try . string $ '!':cb:[])   return (showStr "") -blank :: Stringable a => GenParser Char (Char,Char) (SEnv a -> a)+blank :: Stringable a => TmplParser (SEnv a -> a) blank = do-  (ca, cb) <- getState+  (ca, cb) <- getSeps   char ca   spaces   char cb   return (showStr "") -optExpr :: Stringable a => GenParser Char (Char,Char) (SEnv a -> a)+optExpr :: Stringable a => TmplParser (SEnv a -> a) optExpr = do-  (_, cb) <- getState+  (_, cb) <- getSeps   (try (string ("else"++[cb])) <|> try (string "elseif(") <|>     try (string "endif")) .>> fail "Malformed If Statement." <|> return ()-  expr <- try stat <|> spaced exprn+  expr <- try ifstat <|> spaced exprn   opts <- many opt   skipMany (char ';')-  return $ expr |. optInsert opts+  return $ expr . optInsert opts       where opt = around ';' (spaced word) '=' >>= (<$> spaced subexprn) . (,)  {--------------------------------------------------------------------@@ -280,50 +314,48 @@ --------------------------------------------------------------------}  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 <$$> showVal) p-getProp (_:_) _ = const SNull-getProp _ se = const se+getProp (p:ps) (SM mp) env =+  case M.lookup (stToString . showVal env $ p env) mp of+    Just prop -> getProp ps prop env+    Nothing -> SNull+getProp (_:_) _ _ = SNull+getProp _ se _ = 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+ifstat ::Stringable a => TmplParser (SEnv a -> a)+ifstat = do+  (_, cb) <- getSeps   string "if("-  (n, e, p, _, act, cont) <- parseif cb+  n <- option True (char '!' >> return False)+  e <- subexprn+  p <- props+  char ')' >> char cb+  act <- stmpl True+  cont <- (try elseifstat <|> try elsestat <|> endifstat)   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)+elseifstat ::Stringable a => TmplParser (SEnv a -> a)+elseifstat = getSeps >>= char . fst >> string "else" >> ifstat -elsestat ::Stringable a => GenParser Char (Char, Char) (SEnv a -> a)+elsestat ::Stringable a => TmplParser (SEnv a -> a) elsestat = do-  (ca, cb) <- getState+  (ca, cb) <- getSeps   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 "")+endifstat ::Stringable a => TmplParser (SEnv a -> a)+endifstat = getSeps >>= char . fst >> string "endif" >> return (showStr "")  {--------------------------------------------------------------------   Expressions --------------------------------------------------------------------} -exprn :: Stringable a => GenParser Char (Char,Char) (SEnv a -> a)+exprn :: Stringable a => TmplParser (SEnv a -> a) exprn = do   exprs <- comlist subexprn <?> "expression"   templ <- many (char ':' >> iterApp <$> comlist (anonTmpl <|> regTemplate)) <?> "template call"@@ -335,7 +367,7 @@ seqTmpls (f:fs) y = seqTmpls fs =<< (:[]) . SBLE . f y seqTmpls  _ _     = const (stFromString "") -subexprn :: Stringable a => GenParser Char (Char,Char) (SEnv a -> SElem a)+subexprn :: Stringable a => TmplParser (SEnv a -> SElem a) subexprn = cct <$> spaced             (braceConcat              <|> SBLE <$$> ($ ([SNull],ix0)) <$> try regTemplate@@ -348,23 +380,32 @@           cct [x] = x           cct  _  = const SNull -braceConcat :: Stringable a => GenParser Char (Char,Char) (SEnv a -> SElem a)+braceConcat :: Stringable a => TmplParser (SEnv a -> SElem a) braceConcat = LI . foldr go [] <$$> 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 "'")) '\'')+                   <|> around '\'' (concat <$> many (escapedChar "'")) '\'') -attrib :: Stringable a => GenParser Char (Char,Char) (SEnv a -> SElem a)+attrib :: Stringable a => TmplParser (SEnv a -> SElem a) attrib = do-  a <- literal <|> try functn <|> prepExp <$> word <|> around '(' subexprn ')'-         <?> "attribute"+  a <-     literal+       <|> try functn+       <|> prepExp <$> word+       <|> prepExp <$> qqWord+       <|> around '(' subexprn ')'+          <?> "attribute"   proprs <- props   return $ fromMany a ((a >>=) . getProp) proprs       where prepExp var = fromMaybe SNull <$> envLookup var+            qqWord = do+              w <- around '`' word '`'+              tellNames w+              return $ '`' : w ++ "`" -functn :: Stringable a => GenParser Char (Char,Char) (SEnv a -> SElem a)+--add null func+functn :: Stringable a => TmplParser (SEnv a -> SElem a) functn = do   f <- string "first" <|> string "rest" <|> string "strip"        <|> try (string "length") <|> string "last" <?> "function"@@ -411,12 +452,12 @@ 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 :: Stringable a => TmplParser (([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 :: Stringable a => TmplParser (([SElem a], [SElem a]) -> SEnv a -> a) regTemplate = do-  try (functn::GenParser Char (Char,Char) (SEnv String -> SElem String)) .>> fail "" <|> return ()+  try (functn::TmplParser (SEnv String -> SElem String)) .>> fail "" <|> return ()   name <- justSTR <$> many1 (alphaNum <|> char '/'<|> char '_')           <|> around '(' subexprn ')'   vals <- around '(' (spaced $ try assgn <|> anonassgn <|> return []) ')'
Text/StringTemplate/Classes.hs view
@@ -23,7 +23,13 @@  type SMap a = M.Map String (SElem a) -data SElem a = STR String | STSH STShow | SM (SMap a) | LI [SElem a] | SBLE a | SNull+data SElem a = STR String+             | BS LB.ByteString+             | 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.@@ -53,6 +59,8 @@ -- Generally, the provided instances should be enough for anything. class Monoid a => Stringable a where     stFromString :: String -> a+    stFromByteString :: LB.ByteString -> a+    stFromByteString = stFromString . LB.unpack     stToString :: a -> String     -- | Defaults to  @ mconcatMap m k = foldr (mappend . k) mempty m @     mconcatMap :: [b] -> (b -> a) -> a@@ -81,10 +89,12 @@  instance Stringable B.ByteString where     stFromString = B.pack+    stFromByteString = B.concat . LB.toChunks     stToString = B.unpack  instance Stringable LB.ByteString where     stFromString = LB.pack+    stFromByteString = id     stToString = LB.unpack  instance Stringable (Endo String) where
Text/StringTemplate/Group.hs view
@@ -1,12 +1,15 @@+{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK not-home #-}  module Text.StringTemplate.Group     (groupStringTemplates, addSuperGroup, addSubGroup, setEncoderGroup,      mergeSTGroups, directoryGroup, optInsertGroup,-     directoryGroupLazy, unsafeVolatileDirectoryGroup, nullGroup+     directoryGroupLazy, directoryGroupRecursive, directoryGroupRecursiveLazy,+     unsafeVolatileDirectoryGroup, nullGroup     ) where-import Control.Applicative hiding ((<|>),many)+import Control.Applicative import Control.Arrow+import Control.Monad import Data.Monoid import Data.List import System.Time@@ -27,6 +30,23 @@ (<$$>) :: (Functor f1, Functor f) => (a -> b) -> f (f1 a) -> f (f1 b) (<$$>) x y = ((<$>) . (<$>)) x y +readFile' :: FilePath -> IO String+readFile' f = do+  x <- readFile f+  length x `seq` return x++groupFromFiles :: Stringable a => (FilePath -> IO String) -> [(FilePath,String)] -> IO (STGroup a)+groupFromFiles rf fs = groupStringTemplates <$> forM fs  (\(f,fname) -> do+     stmp <- newSTMP <$> rf f+     return $ (fname, stmp))++getTmplsRecursive :: FilePath -> FilePath -> IO [(FilePath, FilePath)]+getTmplsRecursive base fp = do+          dirContents <- getDirectoryContents fp+          subDirs <- filterM doesDirectoryExist =<< getDirectoryContents fp+          subs <- concat <$> mapM (\x -> getTmplsRecursive (base </> x) (fp </> x)) subDirs+          return $ (map (\x -> (fp </> x, base </> x)) $ filter ((".st" ==) . takeExtension) dirContents) ++ subs+ {--------------------------------------------------------------------   Group API --------------------------------------------------------------------}@@ -43,26 +63,33 @@ -- 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 . (path </>)))-                           =<< filter ((".st" ==) . takeExtension)-                       <$> getDirectoryContents path)+directoryGroup path =+    groupFromFiles readFile' .+    map (\x -> (path </> x, takeBaseName x)) . 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,+-- files read on demand, but no more than once. The list of files, however,+-- is generated at the time the function is called. As this 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 . (path </>))))-                               =<< filter ((".st" ==) . takeExtension)-                           <$> getDirectoryContents path)+directoryGroupLazy path =+    groupFromFiles readFile .+    map (\x -> (path </> x, takeBaseName x)) . filter ((".st" ==) . takeExtension) =<<+    getDirectoryContents path +-- | As with 'directoryGroup', but traverses subdirectories as well. A template named+-- \"foo/bar.st\" may be referenced by \"foo/bar\" in the returned group.+directoryGroupRecursive :: (Stringable a) => FilePath -> IO (STGroup a)+directoryGroupRecursive path = groupFromFiles readFile' =<< getTmplsRecursive "" path++-- | See documentation for 'directoryGroupRecursive'.+directoryGroupRecursiveLazy :: (Stringable a) => FilePath -> IO (STGroup a)+directoryGroupRecursiveLazy path = groupFromFiles readFile =<< getTmplsRecursive "" 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@@ -94,14 +121,14 @@ nullGroup = \x -> StFirst . Just . newSTMP $ "Could not find template: " ++ x  -- | Given an integral amount of seconds and a path, returns a group generating--- all files in said directory with the proper \"st\" extension,+-- all files in said directory and subdirectories 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. The dumpAttribs template is added to the returned group -- by default, as it should prove useful for debugging and developing templates.-unsafeVolatileDirectoryGroup :: Stringable a => String -> Int -> IO (STGroup a)+unsafeVolatileDirectoryGroup :: Stringable a => FilePath -> Int -> IO (STGroup a) unsafeVolatileDirectoryGroup path m = return . flip addSubGroup extraTmpls $ cacheSTGroup stfg     where stfg = StFirst . Just . STMP (SEnv M.empty [] stfg id)                  . parseSTMP ('$', '$') . unsafePerformIO . flip catch@@ -109,18 +136,20 @@                  . readFile . (path </>) . (++".st")           extraTmpls = addSubGroup (groupStringTemplates [("dumpAttribs", dumpAttribs)]) nullGroup           cacheSTGroup :: STGroup a -> STGroup a-          cacheSTGroup 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+          cacheSTGroup g = unsafePerformIO $ do+                             !ior <- newIORef M.empty+                             return $ \s -> unsafePerformIO $ do+                               mp  <- readIORef ior+                               curtime <- getClockTime+                               let udReturn now = do+                                       let st = g s+                                       atomicModifyIORef ior $+                                         flip (,) () . M.insert s (now, st)+                                       return st+                               case M.lookup s mp of+                                 Nothing -> udReturn curtime+                                 Just (t, st) ->+                                     if (tdSec . normalizeTimeDiff $+                                               diffClockTimes curtime t) > m+                                       then udReturn curtime+                                       else return st
Text/StringTemplate/Instances.hs view
@@ -7,6 +7,8 @@  import qualified Data.Map as M import Numeric+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as LB import Data.Ratio import Data.Array import Data.Maybe@@ -24,6 +26,12 @@ instance ToSElem Char where     toSElem = STR . (:[])     toSElemList = STR++instance ToSElem LB.ByteString where+    toSElem = BS++instance ToSElem B.ByteString where+    toSElem = BS . LB.fromChunks . (:[])  instance ToSElem Bool where     toSElem True = STR ""
+ Text/StringTemplate/QQ.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE DeriveDataTypeable, QuasiQuotes #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.StringTemplate.QQ+-- Copyright   :  (c) Sterling Clover 2009+-- License     :  BSD 3 Clause+-- Maintainer  :  s.clover@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- This module provides stmp, a quasi-quoter for StringTemplate expressions.+-- Quoted templates are guaranteed syntactically well-formed at compile time,+-- and antiquotation (of identifiers only) is provided by backticks.+-- Usage: @ let var = [0,1,2] in toString [$stmp|($`var`; separator = ', '$)|] === "(0, 1, 2)"@+-----------------------------------------------------------------------------++module Text.StringTemplate.QQ (stmp) where++import Data.Generics+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Quote+import Text.StringTemplate.Base+import Text.ParserCombinators.Parsec+import Control.Monad.Writer+import Control.Applicative++quoteTmplExp :: String -> TH.ExpQ+quoteTmplPat :: String -> TH.PatQ++stmp = QuasiQuoter quoteTmplExp quoteTmplPat++quoteTmplPat = error "Cannot apply stmp quasiquoter in patterns"+quoteTmplExp s = return tmpl+  where+    vars = case parseSTMPNames s of+             Right xs -> xs+             Left  err -> error "err"+    base  = TH.AppE (TH.VarE (TH.mkName "newSTMP")) (TH.LitE (TH.StringL $ s))+    tmpl  = foldr addAttrib base vars+    addAttrib var x = TH.AppE+        (TH.AppE (TH.AppE (TH.VarE (TH.mkName "setAttribute"))+                          (TH.LitE (TH.StringL ('`' : var ++ "`"))))+                 (TH.VarE (TH.mkName  var)))+        x
− tests/Main.hs 
@@ -1,8 +0,0 @@-module Main where--import qualified Properties-import qualified Units--main = do-  Properties.main-  Units.main
− tests/Properties.hs 
@@ -1,165 +0,0 @@-{-# 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) ++ "%"
− tests/Units.hs 
@@ -1,41 +0,0 @@-{-# 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 ()
− tests/loc.hs 
@@ -1,12 +0,0 @@-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