diff --git a/HStringTemplate.cabal b/HStringTemplate.cabal --- a/HStringTemplate.cabal +++ b/HStringTemplate.cabal @@ -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 diff --git a/Text/StringTemplate.hs b/Text/StringTemplate.hs --- a/Text/StringTemplate.hs +++ b/Text/StringTemplate.hs @@ -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, diff --git a/Text/StringTemplate/Base.hs b/Text/StringTemplate/Base.hs --- a/Text/StringTemplate/Base.hs +++ b/Text/StringTemplate/Base.hs @@ -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 diff --git a/Text/StringTemplate/Classes.hs b/Text/StringTemplate/Classes.hs --- a/Text/StringTemplate/Classes.hs +++ b/Text/StringTemplate/Classes.hs @@ -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 diff --git a/Text/StringTemplate/Group.hs b/Text/StringTemplate/Group.hs --- a/Text/StringTemplate/Group.hs +++ b/Text/StringTemplate/Group.hs @@ -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 diff --git a/Text/StringTemplate/QQ.hs b/Text/StringTemplate/QQ.hs --- a/Text/StringTemplate/QQ.hs +++ b/Text/StringTemplate/QQ.hs @@ -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