HStringTemplate 0.6 → 0.6.1

raw patch · 6 files changed

+138/−50 lines, 6 filesdep +paralleldep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: parallel

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• HStringTemplate.cabal +4/−2
• Text/StringTemplate.hs +1/−1
• Text/StringTemplate/Base.hs +127/−42
• Text/StringTemplate/Classes.hs +2/−0
• Text/StringTemplate/Group.hs +1/−2
• Text/StringTemplate/QQ.hs +3/−3

@@ -1,5 +1,5 @@ name:                HStringTemplate-version:             0.6+version:             0.6.1 synopsis:            StringTemplate implementation in Haskell. description:         A port of the Java library by Terrence Parr. category:            Text@@ -20,14 +20,16 @@   if flag(syb-with-class)     build-depends:   syb-with-class     exposed-modules: Text.StringTemplate.GenericWithClass+   if flag(quasi-quotation)     build-depends: template-haskell >= 2.3, mtl     exposed-modules: Text.StringTemplate.QQ    if flag(smaller-base)-    build-depends:   syb, base >= 4, base < 5, filepath, parsec < 3, containers, pretty, time, old-time, old-locale, bytestring, directory, array, text+    build-depends:   syb, base >= 4, base < 5, filepath, parsec < 3, containers, pretty, time, old-time, old-locale, bytestring, directory, array, text, parallel   else     build-depends:   base > 3, base < 4, filepath, parsec < 3, containers, pretty, time, old-time, old-locale, bytestring, directory, array, text+   exposed-modules:   Text.StringTemplate                      Text.StringTemplate.Base                      Text.StringTemplate.Classes

@@ -43,7 +43,7 @@   -- * Creation   newSTMP, newAngleSTMP, getStringTemplate, getStringTemplate',   -- * Display-  toString, toPPDoc, render, dumpAttribs,+  toString, toPPDoc, render, dumpAttribs, checkTemplate, checkTemplateDeep,   -- * Modification   setAttribute, (|=), setManyAttrib,   setNativeAttribute, setManyNativeAttrib,

@@ -1,3 +1,4 @@+{-# LANGUAGE RelaxedPolyRec, DeriveDataTypeable #-} {-# OPTIONS_HADDOCK not-home #-}  module Text.StringTemplate.Base@@ -9,26 +10,33 @@      setNativeAttribute, setManyNativeAttrib,      withContext, optInsertTmpl, setEncoder,      paddedTrans, SEnv(..), parseSTMP, dumpAttribs,+     checkTemplate, checkTemplateDeep,      parseSTMPNames     ) where-import Control.Monad import Control.Arrow import Control.Applicative hiding ((<|>),many)+import Control.Monad+import Control.Parallel.Strategies(rnf, NFData(..))+import qualified Control.Exception as C+import Data.List import Data.Maybe import Data.Monoid-import Data.List+import Data.Typeable+import System.IO.Unsafe+ import Text.ParserCombinators.Parsec import qualified Data.Map as M import qualified Text.PrettyPrint.HughesPJ as PP  import Text.StringTemplate.Classes import Text.StringTemplate.Instances()+import Debug.Trace  {--------------------------------------------------------------------   Generic Utilities --------------------------------------------------------------------} -type TmplParser = GenParser Char ((Char, Char),[String])+type TmplParser = GenParser Char ((Char, Char),[String],[String],[String])  (<$$>) :: (Functor f1, Functor f) => (a -> b) -> f (f1 a) -> f (f1 b) (<$$>) = (<$>) . (<$>)@@ -71,7 +79,7 @@ -- 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}+data StringTemplate a = STMP {senv :: SEnv a,  runSTMP :: Either String (SEnv a -> a), chkSTMP :: SEnv a -> (Maybe String, Maybe [String], Maybe [String])}  -- | Renders a StringTemplate to a String. toString :: StringTemplate String -> String@@ -83,17 +91,26 @@  -- | Generic render function for a StringTemplate of any type. render :: Stringable a => StringTemplate a -> a-render = runSTMP <*> senv+render = either (showStr) id . runSTMP <*> senv +nullEnv = SEnv M.empty [] mempty id++-- | Returns a tuple of three Maybes. The first is set if there is a parse error in the template.+-- The next is set to a list of attributes that have not been set, or Nothing if all attributes are set.+-- The last is set to a list of invoked templates that cannot be looked up, or Nothing if all invoked templates can be found.+-- Note that this check is shallow -- i.e. missing attributes and templates are only caught in the top level template, not any invoked subtemplate.+checkTemplate :: Stringable a => StringTemplate a -> (Maybe String, Maybe [String], Maybe [String])+checkTemplate t = chkSTMP t (senv t)+ -- | 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 ('$','$')+newSTMP s = STMP nullEnv (parseSTMP ('$','$') s) (chkStmp ('$','$') s)  -- | 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 s = STMP nullEnv (parseSTMP ('<','>') s) (chkStmp ('<','>') s)  -- | Yields a StringTemplate with the appropriate attribute set. -- If the attribute already exists, it is appended to a list.@@ -111,7 +128,7 @@ -- 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)}+setNativeAttribute s x st = st {senv = envInsApp s (SNAT x) (senv st)}  -- | Yields a StringTemplate with the appropriate attributes set. -- If any attribute already exists, it is appended to a list.@@ -153,7 +170,7 @@ -- This may be made available to any template as a function by adding it to its group. -- I.e. @ myNewGroup = addSuperGroup myGroup $ groupStringTemplates [("dumpAttribs", dumpAttribs)] @ dumpAttribs :: Stringable a => StringTemplate a-dumpAttribs = STMP (SEnv M.empty [] mempty id) $ \env -> showVal env (SM $ smp env)+dumpAttribs = STMP nullEnv (Right $ \env -> showVal env (SM $ smp env)) (const (Nothing, Nothing, Nothing))  {--------------------------------------------------------------------   Internal API@@ -167,6 +184,14 @@  envLookup :: String -> SEnv a -> Maybe (SElem a) envLookup x = M.lookup x . smp++envLookupEx :: String -> SEnv a -> SElem a+envLookupEx x snv = case M.lookup x (smp snv) of+                      Just a -> a+                      Nothing -> case optLookup "throwException" snv of+                                   Just _ -> C.throw $ NoAttrib x+                                   Nothing -> SNull+ 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@@ -190,21 +215,63 @@ mergeSEnvs :: SEnv a -> SEnv a -> SEnv a 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 :: (Stringable a) => (Char, Char) -> String -> Either String (SEnv a -> a)+parseSTMP x = either (Left . show) Right . runParser (stmpl False) (x,[],[],[]) ""  getSeps :: TmplParser (Char, Char)-getSeps = fst <$> getState+getSeps = (\(x,_,_,_) -> x) <$> getState -tellNames :: String -> TmplParser ()-tellNames x = getState >>= \(s,n) -> setState (s,x:n)+tellName :: String -> TmplParser ()+tellName x = getState >>= \(s,q,n,t) -> setState (s,q,x:n,t) -parseSTMPNames :: String -> Either ParseError [String]-parseSTMPNames = runParser getRefs (('$','$'),[]) ""+tellQQ :: String -> TmplParser ()+tellQQ x = getState >>= \(s,q,n,t) -> setState (s,x:q,n,t)++tellTmpl :: String -> TmplParser ()+tellTmpl x = getState >>= \(s,q,n,t) -> setState (s,q,n,x:t)++-- | Gets all quasiquoted names, normal names & templates used in a given template.+-- Must be passed a pair of chars denoting the delimeters to be used.+parseSTMPNames :: (Char, Char) -> String -> Either ParseError ([String],[String],[String])+parseSTMPNames cs s = runParser getRefs (cs,[],[],[]) "" s     where getRefs = do-            stmpl False :: TmplParser (SEnv String -> String)-            snd <$> getState+            (stmpl False :: TmplParser (SEnv String -> String))+            (_,qqnames,regnames,tmpls) <- getState+            return (qqnames, regnames, tmpls) +chkStmp :: Stringable a => (Char, Char) -> String -> SEnv a -> (Maybe String, Maybe [String], Maybe [String])+chkStmp cs s snv = case parseSTMPNames cs s of+                     Left err -> (Just $ "Parse error: " ++ show err, Nothing, Nothing)+                     Right (_, regnames, tmpls) ->+                         let nonms   = filter (\x -> not $ elem x (M.keys $ smp snv)) regnames+                             notmpls = filter (\x -> isNothing $ stGetFirst (sgen snv x)) tmpls+                         in (Nothing, if null nonms then Nothing else Just nonms,+                                      if null notmpls then Nothing else Just notmpls)++data TmplException = NoAttrib String | NoTmpl String | ParseError String String deriving (Show, Typeable)+instance C.Exception TmplException++-- | Generic render function for a StringTemplate of any type.+renderErr :: Stringable a => String -> StringTemplate a -> a+renderErr n t = case runSTMP t of+                Right rt -> rt (senv t)+                Left err -> case optLookup "throwException" (senv t) of+                              Just _ -> C.throw $ ParseError n err+                              Nothing -> showStr err (senv t)++-- | Returns a tuple of three lists. The first is of templates with parse errors, and their erros. The next is of missing attributes, and the last is of missing templates. If there are no errors, then all lists will be empty.+checkTemplateDeep :: (Stringable a, NFData a) => StringTemplate a -> ([(String,String)], [String], [String])+checkTemplateDeep t = case runSTMP t of+                        Left err -> ([("Top Level Template", err)], [],[])+                        Right _ -> unsafePerformIO $ go ([],[],[]) $ inSGen (`mappend` nullGroup) $ optInsertTmpl [("throwException","true")] t+    where go (e1,e2,e3) tmpl = (C.evaluate (rnf $ render tmpl) >> return (e1,e2,e3)) `C.catch`+                                  \e -> case e of NoTmpl x -> go (e1,e2,x:e3) $ addSub x tmpl+                                                  NoAttrib x -> go (e1,x:e2, e3) $ setAttribute x "" tmpl+                                                  ParseError n x -> go ((n,x):e1,e2,e3) $ addSub n tmpl+          addSub x tmpl = inSGen (mappend $ blankGroup x) tmpl+          blankGroup x s = StFirst $ if x == s then Just (newSTMP "") else Nothing+          nullGroup x = StFirst $ Just (C.throw $ NoTmpl x)+ {--------------------------------------------------------------------   Internal API for polymorphic display of elements --------------------------------------------------------------------}@@ -220,7 +287,8 @@                    LI xs  -> joinUpWith showVal xs                    SM sm  -> joinUpWith showAssoc $ M.assocs sm                    STSH x -> stEncode (format x)-                   SBLE x -> senc snv x+                   SNAT x -> senc snv x+                   SBLE x -> x                    SNull  -> showVal <*> nullOpt $ snv     where format = maybe stshow . stfshow <*> optLookup "format" $ snv           joinUpWith f xs = mconcatMap' snv xs (f snv)@@ -257,8 +325,7 @@  escapedChar, escapedStr :: String -> GenParser Char st String escapedChar chs =-    noneOf chs >>= \x -> if x == '\\' then anyChar >>= \y ->-    if y `elem` chs then return [y] else return [x, y] else return [x]+    noneOf chs >>= \x -> if x == '\\' then anyChar >>= \y -> return [y] else return [x] escapedStr chs = concat <$> many1 (escapedChar chs)  {--------------------------------------------------------------------@@ -367,16 +434,23 @@  exprn :: Stringable a => TmplParser (SEnv a -> a) exprn = do-  exprs <- comlist subexprn <?> "expression"-  templ <- many (char ':' >> iterApp <$> comlist (anonTmpl <|> regTemplate)) <?> "template call"+  exprs <- comlist ( (SBLE <$$> around '(' exprn ')')+                     <|> subexprn)+             <?> "expression"+  templ <- tmplChain   return $ fromMany (showVal <*> head exprs)-             ((sequence exprs >>=) . seqTmpls) templ+             ((sequence exprs >>=) . seqTmpls') templ+      where tmplChain = many (char ':' >> iterApp <$> comlist (anonTmpl <|> regTemplate)) <?> "template call" -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 "")+seqTmpls' :: Stringable a => [[SElem a] -> SEnv a -> [a]] -> [SElem a] -> SEnv a -> a+seqTmpls' tmpls elems snv = mintercalate sep $ seqTmpls tmpls elems snv+    where sep = showVal snv $ fromMaybe (justSTR "") =<< optLookup "separator" $ snv +seqTmpls :: Stringable a => [[SElem a] -> SEnv a -> [a]] -> [SElem a] -> SEnv a -> [a]+seqTmpls [f]    y snv = f y snv+seqTmpls (f:fs) y snv = concatMap (\x -> seqTmpls fs x snv) (map ((:[]) . SBLE) $ f y snv)+seqTmpls  _ _ _   = [stFromString ""]+ subexprn :: Stringable a => TmplParser (SEnv a -> SElem a) subexprn = cct <$> spaced             (braceConcat@@ -402,28 +476,33 @@ attrib = do   a <-     literal        <|> try functn-       <|> prepExp <$> word-       <|> prepExp <$> qqWord+       <|> envLookupEx <$> regWord+       <|> envLookupEx <$> qqWord        <|> around '(' subexprn ')'           <?> "attribute"   proprs <- props   return $ fromMany a ((a >>=) . getProp) proprs-      where prepExp var = fromMaybe SNull <$> envLookup var-            qqWord = do+      where qqWord = do               w <- around '`' word '`'-              tellNames w+              tellQQ w               return $ '`' : w ++ "`"+            regWord = do+              w <- word+              tellName w+              return w  --add null func functn :: Stringable a => TmplParser (SEnv a -> SElem a) functn = do-  f <- string "first" <|> string "rest" <|> string "strip"+  f <- string "first" <|> try (string "rest") <|> string "reverse"+       <|> string "strip"        <|> try (string "length") <|> string "last" <?> "function"   (fApply f .) <$> around '(' subexprn ')'       where fApply str (LI xs)                 | str == "first"  = if null xs then SNull else head xs                 | str == "last"   = if null xs then SNull else last xs                 | str == "rest"   = if null xs then SNull else (LI . tail) xs+                | str == "reverse" = LI . reverse $ xs                 | str == "strip"  = LI . filter (not . liNil) $ xs                 | str == "length" = STR . show . length $ xs             fApply str x@@ -438,13 +517,15 @@ --------------------------------------------------------------------} --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 snv = mconcatMap' snv (zipWith ($) (cycle x) y) ($ snv)+cycleApp :: (Stringable a) => [([SElem a], [SElem a]) -> SEnv a -> a] -> [([SElem a], [SElem a])]  -> SEnv a -> [a]+cycleApp x y snv = map ($ snv) (zipWith ($) (cycle x) y)  pluslen :: [a] -> [([a], [SElem b])] pluslen xs = zip (map (:[]) xs) $ mkIndex [0..(length xs)]@@ -454,10 +535,11 @@     where u (LI x) = x; u x = [x]           pluslen' xs = zip xs $ mkIndex [0..(length xs)] -iterApp :: Stringable a => [([SElem a], [SElem a]) -> SEnv a -> a] -> [SElem a] -> SEnv a -> a-iterApp [f] (LI xs:[])    snv = (mconcatMap' snv $ pluslen xs) . flip f $ snv-iterApp [f] vars@(LI _:_) snv = (mconcatMap' snv $ liTrans vars) . flip f $ snv-iterApp [f] v             snv = f (v,ix0) snv+--map repeatedly, then finally concat+iterApp :: Stringable a => [([SElem a], [SElem a]) -> SEnv a -> a] -> [SElem a] -> SEnv a -> [a]+iterApp [f] (LI xs:[])    snv = map (flip f snv) (pluslen xs)+iterApp [f] vars@(LI _:_) snv = map (flip f snv) (liTrans vars)+iterApp [f] v             snv = [f (v,ix0) snv] iterApp fs (LI xs:[])     snv = cycleApp fs (pluslen xs) snv iterApp fs vars@(LI _:_)  snv = cycleApp fs (liTrans vars) snv iterApp fs xs             snv = cycleApp fs (pluslen xs) snv@@ -470,16 +552,19 @@   try (functn::TmplParser (SEnv String -> SElem String)) .>> fail "" <|> return ()   name <- justSTR <$> many1 (alphaNum <|> char '/'<|> char '_')           <|> around '(' subexprn ')'+  tryTellTmpl (name nullEnv)   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+                renderErr x |. 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 ';'+            tryTellTmpl (STR x) = tellTmpl x+            tryTellTmpl _ = return ()  --DEBUG 

@@ -33,6 +33,7 @@              | SM (SMap a)              | LI [SElem a]              | SBLE a+             | SNAT a              | SNull  -- | The ToSElem class should be instantiated for all types that can be@@ -126,6 +127,7 @@     smempty = LT.empty     smappend = LT.append +--add dlist instance instance Stringable (Endo String) where     stFromString = Endo . (++)     stToString = ($ []) . appEndo

@@ -132,8 +132,7 @@ -- by default, as it should prove useful for debugging and developing templates. 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+    where stfg = StFirst . Just . newSTMP . unsafePerformIO . flip catch                        (return . (\e -> "IO Error: " ++ show (ioeGetFileName e) ++ " -- " ++ ioeGetErrorString e))                  . readFile . (path </>) . (++".st")           extraTmpls = addSubGroup (groupStringTemplates [("dumpAttribs", dumpAttribs)]) nullGroup

@@ -30,9 +30,9 @@ quoteTmplPat = error "Cannot apply stmp quasiquoter in patterns" quoteTmplExp s = return tmpl   where-    vars = case parseSTMPNames s of-             Right xs -> xs-             Left  err -> error $ show err+    vars = case parseSTMPNames ('$','$') s of+             Right (xs,_,_) -> xs+             Left  err -> fail $ show err     base  = TH.AppE (TH.VarE (TH.mkName "newSTMP")) (TH.LitE (TH.StringL s))     tmpl  = foldr addAttrib base vars     addAttrib var = TH.AppE