HStringTemplate 0.2 → 0.3
raw patch · 7 files changed
+89/−49 lines, 7 files
Files
- HStringTemplate.cabal +7/−6
- Text/StringTemplate.hs +7/−6
- Text/StringTemplate/Base.hs +26/−14
- Text/StringTemplate/Classes.hs +8/−3
- Text/StringTemplate/Group.hs +19/−14
- Text/StringTemplate/Instances.hs +6/−6
- Text/StringTemplate/Renderf.hs +16/−0
HStringTemplate.cabal view
@@ -1,5 +1,5 @@ name: HStringTemplate-version: 0.2+version: 0.3 synopsis: StringTemplate implementation in Haskell. description: A port of the Java library by Terrence Parr. category: Text@@ -18,19 +18,20 @@ library if flag(syb-with-class)- build-depends: 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+ build-depends: base >= 3, filepath, parsec, containers, pretty, time, old-time, old-locale, bytestring, directory, array else- build-depends: base < 3, filepath, parsec+ build-depends: base < 3, filepath, parsec exposed-modules: Text.StringTemplate- other-modules: Text.StringTemplate.Instances- Text.StringTemplate.Group Text.StringTemplate.Base Text.StringTemplate.Classes+ other-modules: Text.StringTemplate.Instances+ Text.StringTemplate.Group+ Text.StringTemplate.Renderf ghc-options: -Wall
Text/StringTemplate.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Module : Text.StringTemplate.Base+-- Module : Text.StringTemplate -- Copyright : (c) Sterling Clover 2008 -- License : BSD 3 Clause -- Maintainer : s.clover@gmail.com@@ -39,20 +39,21 @@ -- * Types StringTemplate, STGroup, -- * Classes- ToSElem(..), StringTemplateShows(..), stShowsToSE, Stringable(..),+ ToSElem(..), StringTemplateShows(..), stShowsToSE, Stringable(..), SEType(..), -- * Creation- newSTMP, newAngleSTMP, getStringTemplate,+ newSTMP, newAngleSTMP, getStringTemplate, getStringTemplate', -- * Display- toString, toPPDoc, render,+ toString, toPPDoc, render, dumpAttribs, -- * Modification- setAttribute, setManyAttrib, withContext,+ setAttribute, (|=), setManyAttrib, withContext, optInsertTmpl, optInsertGroup, setEncoder, setEncoderGroup, -- * Groups groupStringTemplates, addSuperGroup, addSubGroup, mergeSTGroups, directoryGroup, unsafeVolatileDirectoryGroup,- directoryGroupLazy+ directoryGroupLazy, nullGroup ) where import Text.StringTemplate.Base import Text.StringTemplate.Group+import Text.StringTemplate.Renderf import Text.StringTemplate.Instances()
Text/StringTemplate/Base.hs view
@@ -3,9 +3,10 @@ module Text.StringTemplate.Base (StringTemplate(..), StringTemplateShows(..), ToSElem(..), STGroup, Stringable(..), stShowsToSE,- toString, toPPDoc, render, newSTMP, newAngleSTMP, getStringTemplate,+ toString, toPPDoc, render, newSTMP, newAngleSTMP,+ getStringTemplate, getStringTemplate', setAttribute, setManyAttrib, withContext, optInsertTmpl, setEncoder,- paddedTrans, SEnv(..), parseSTMP+ paddedTrans, SEnv(..), parseSTMP, dumpAttribs ) where import Control.Monad import Control.Arrow hiding (pure)@@ -18,16 +19,15 @@ 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`+(<$$>) :: (Functor f1, Functor f) => (a -> b) -> f (f1 a) -> f (f1 b)+(<$$>) x y = ((<$>) . (<$>)) x y+infixr 8 <$$> (|.) :: (t1 -> t2) -> (t -> t1) -> t -> t2 (|.) f g x = f (g x)@@ -115,6 +115,12 @@ getStringTemplate :: (Stringable a) => String -> STGroup a -> Maybe (StringTemplate a) getStringTemplate s sg = stGetFirst (sg s) +-- | As with 'getStringTemplate' but never inlined, so appropriate for use+-- with volatile template groups.+{-# NOINLINE getStringTemplate' #-}+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)}@@ -124,6 +130,12 @@ setEncoder :: (Stringable a) => (String -> String) -> StringTemplate a -> StringTemplate a setEncoder x st = st {senv = (senv st) {senc = x} } +-- | A special template that simply dumps the values of all the attributes set in it.+-- 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)+ {-------------------------------------------------------------------- Internal API --------------------------------------------------------------------}@@ -185,7 +197,7 @@ 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+ (stToString <$$> 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}@@ -225,7 +237,7 @@ st <- mconcat <$> many (showStr <$> escapedStr (ca:"}|") <|> try (around ca optExpr cb) <|> try comment <|> blank <?> "subtemplate")- return (st `o` udEnv)+ return (st <$$> udEnv) where transform an (att,is) = flip (foldr envInsert) $ zip ("i":"i0":an) (is++att) attribNames = (char '|' >>) . return =<< comlist (spaced word)@@ -261,7 +273,7 @@ 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+ flip M.lookup mp . ap (stToString <$$> showVal) p getProp (_:_) _ = const SNull getProp _ se = const se @@ -318,9 +330,9 @@ subexprn :: Stringable a => GenParser Char (Char,Char) (SEnv a -> SElem a) subexprn = cct <$> spaced (braceConcat- <|> SBLE `o` ($ ([SNull],ix0)) <$> try regTemplate+ <|> SBLE <$$> ($ ([SNull],ix0)) <$> try regTemplate <|> attrib- <|> SBLE `o` ($ ([SNull],ix0)) <$> anonTmpl+ <|> SBLE <$$> ($ ([SNull],ix0)) <$> anonTmpl <?> "expression") `sepBy1` spaced (char '+') where cct xs@(_:_:_) = SBLE |.@@ -329,7 +341,7 @@ cct _ = const SNull braceConcat :: Stringable a => GenParser Char (Char,Char) (SEnv a -> SElem a)-braceConcat = LI . foldr go [] `o` sequence <$> around '['(comlist subexprn)']'+braceConcat = LI . foldr go [] <$$> sequence <$> around '['(comlist subexprn)']' where go (LI x) lst = x++lst; go x lst = x:lst @@ -382,7 +394,7 @@ 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))]+ 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:[]) = (mconcatMap $ pluslen xs) . flip f@@ -398,7 +410,7 @@ 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 '/')+ name <- justSTR <$> many1 (alphaNum <|> char '/'<|> char '_') <|> around '(' subexprn ')' vals <- around '(' (spaced $ try assgn <|> anonassgn <|> return []) ')' return $ join . (. name) . makeTmpl vals
Text/StringTemplate/Classes.hs view
@@ -8,6 +8,7 @@ import Data.List import Data.Monoid import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as LB import qualified Text.PrettyPrint.HughesPJ as PP newtype StFirst a = StFirst { stGetFirst :: Maybe a }@@ -37,7 +38,7 @@ -- | Defaults to 'show'. stringTemplateShow :: a -> String stringTemplateShow = show- -- | Defaults to @ flip $ const . stringTemplateShow @+ -- | Defaults to @ \ _ a -> stringTemplateShow a @ stringTemplateFormattedShow :: String -> a -> String stringTemplateFormattedShow = flip $ const . stringTemplateShow @@ -59,9 +60,9 @@ -- | Defaults to @ (mconcat .) . intersperse @ mintercalate :: a -> [a] -> a mintercalate = (mconcat .) . intersperse- -- | Defaults to @ mappend @+ -- | Defaults to @ mlabel x y = mconcat [x, stFromString "[", y, stFromString "]"] @ mlabel :: a -> a -> a- mlabel = mappend+ mlabel x y = mconcat [x, stFromString "[", y, stFromString "]"] instance Stringable [Char] where stFromString = id@@ -81,6 +82,10 @@ instance Stringable B.ByteString where stFromString = B.pack stToString = B.unpack++instance Stringable LB.ByteString where+ stFromString = LB.pack+ stToString = LB.unpack instance Stringable (Endo String) where stFromString = Endo . (++)
Text/StringTemplate/Group.hs view
@@ -3,7 +3,7 @@ module Text.StringTemplate.Group (groupStringTemplates, addSuperGroup, addSubGroup, setEncoderGroup, mergeSTGroups, directoryGroup, optInsertGroup,- directoryGroupLazy, unsafeVolatileDirectoryGroup+ directoryGroupLazy, unsafeVolatileDirectoryGroup, nullGroup ) where import Control.Applicative hiding ((<|>),many) import Control.Arrow@@ -32,7 +32,6 @@ 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 --------------------------------------------------------------------}@@ -42,8 +41,7 @@ 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+ ng = M.fromList $ map (second $ sgInsert newGen) xs -- | Given a path, returns a group which generates all files in said directory -- which have the proper \"st\" extension.@@ -52,7 +50,7 @@ directoryGroup :: (Stringable a) => FilePath -> IO (STGroup a) directoryGroup path = groupStringTemplates <$> (fmap <$> zip . (map dropExtension)- <*> mapM (newSTMP <$$> readFile)+ <*> mapM (newSTMP <$$> (readFile . (path </>))) =<< filter ((".st" ==) . takeExtension) <$> getDirectoryContents path) @@ -65,7 +63,8 @@ directoryGroupLazy :: (Stringable a) => FilePath -> IO (STGroup a) directoryGroupLazy path = groupStringTemplates <$> (fmap <$> zip . (map dropExtension)- <*> mapM (unsafeInterleaveIO . (newSTMP <$$> readFile))+ <*> mapM (unsafeInterleaveIO .+ (newSTMP <$$> (readFile . (path </>)))) =<< filter ((".st" ==) . takeExtension) <$> getDirectoryContents path) @@ -93,23 +92,29 @@ setEncoderGroup :: (Stringable a) => (String -> String) -> STGroup a -> STGroup a setEncoderGroup x f = setEncoder x <$$> f -{-# NOINLINE unsafeVolatileDirectoryGroup #-}+-- | For any requested template, returns a message that the template was+-- unable to be found. Useful to add as a super group for a set of templates+-- under development, to aid in debugging.+nullGroup :: Stringable a => STGroup a+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, -- 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.+-- 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 path i = return (cacheSTGroup i stfg)+unsafeVolatileDirectoryGroup path m = return . flip addSubGroup extraTmpls $ cacheSTGroup 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+ (return . (\e -> "IO Error: " ++ show (ioeGetFileName e) ++ " -- " ++ ioeGetErrorString e))+ . 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
Text/StringTemplate/Instances.hs view
@@ -82,37 +82,37 @@ instance StringTemplateShows Day where stringTemplateShow = show- stringTemplateFormattedShow = formatTime defaultTimeLocale + stringTemplateFormattedShow = formatTime defaultTimeLocale instance ToSElem Day where toSElem = stShowsToSE instance StringTemplateShows LocalTime where stringTemplateShow = show- stringTemplateFormattedShow = formatTime defaultTimeLocale + stringTemplateFormattedShow = formatTime defaultTimeLocale instance ToSElem LocalTime where toSElem = stShowsToSE instance StringTemplateShows TimeOfDay where stringTemplateShow = show- stringTemplateFormattedShow = formatTime defaultTimeLocale + stringTemplateFormattedShow = formatTime defaultTimeLocale instance ToSElem TimeOfDay where toSElem = stShowsToSE instance StringTemplateShows UTCTime where stringTemplateShow = show- stringTemplateFormattedShow = formatTime defaultTimeLocale + stringTemplateFormattedShow = formatTime defaultTimeLocale instance ToSElem UTCTime where toSElem = stShowsToSE instance StringTemplateShows TimeZone where stringTemplateShow = show- stringTemplateFormattedShow = formatTime defaultTimeLocale + stringTemplateFormattedShow = formatTime defaultTimeLocale instance ToSElem TimeZone where toSElem = stShowsToSE instance StringTemplateShows ZonedTime where stringTemplateShow = show- stringTemplateFormattedShow = formatTime defaultTimeLocale + stringTemplateFormattedShow = formatTime defaultTimeLocale instance ToSElem ZonedTime where toSElem = stShowsToSE
+ Text/StringTemplate/Renderf.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+module Text.StringTemplate.Renderf ((|=), SEType(..)) where+import Text.StringTemplate.Base++class Stringable b => SEType b a where+ renderf :: StringTemplate b -> a+instance Stringable a => SEType a a where+ renderf = render+instance Stringable a => SEType a (StringTemplate a) where+ renderf = id+instance (ToSElem a, SEType b r) => SEType b ((String, a) -> r) where+ renderf x = \(k,v) -> renderf $ setAttribute k v x++(|=) :: (Monad m) => a -> m a1 -> m (a, a1)+k |= v = return . (,) k =<< v+infixl 5 |=