diff --git a/HStringTemplate.cabal b/HStringTemplate.cabal --- a/HStringTemplate.cabal +++ b/HStringTemplate.cabal @@ -1,5 +1,5 @@ name: HStringTemplate -version: 0.5.1.3 +version: 0.6 synopsis: StringTemplate implementation in Haskell. description: A port of the Java library by Terrence Parr. category: Text @@ -25,9 +25,9 @@ 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 + build-depends: syb, base >= 4, base < 5, filepath, parsec < 3, containers, pretty, time, old-time, old-locale, bytestring, directory, array, text else - build-depends: base > 3, base < 4, filepath, parsec < 3, containers, pretty, time, old-time, old-locale, bytestring, directory, array + 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/Base.hs b/Text/StringTemplate/Base.hs --- a/Text/StringTemplate/Base.hs +++ b/Text/StringTemplate/Base.hs @@ -120,7 +120,6 @@ 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 @@ -147,7 +146,7 @@ -- | 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 :: (Stringable a) => (a -> a) -> 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. @@ -161,7 +160,7 @@ --------------------------------------------------------------------} --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} +data SEnv a = SEnv {smp :: SMap a, sopts :: [(String, (SEnv a -> SElem a))], sgen :: STGroup a, senc :: a -> a} inSGen :: (STGroup a -> STGroup a) -> StringTemplate a -> StringTemplate a inSGen f st@STMP{senv = env} = st {senv = env {sgen = f (sgen env)} } @@ -210,23 +209,26 @@ Internal API for polymorphic display of elements --------------------------------------------------------------------} +mconcatMap' :: Stringable a => SEnv a -> [b] -> (b -> a) -> a +mconcatMap' snv xs f = mintercalate sep . map f $ xs + where sep = showVal snv $ fromMaybe (justSTR "") =<< optLookup "separator" $ snv + showVal :: Stringable a => SEnv a -> SElem a -> a showVal snv se = case se of STR x -> stEncode x - BS x -> stFromByteString x + BS x -> stEncodeBS x LI xs -> joinUpWith showVal xs SM sm -> joinUpWith showAssoc $ M.assocs sm STSH x -> stEncode (format x) - SBLE x -> x + SBLE x -> senc snv 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) + where format = maybe stshow . stfshow <*> optLookup "format" $ snv + joinUpWith f xs = mconcatMap' snv xs (f snv) showAssoc e (k,v) = stEncode (k ++ ": ") `mlabel` showVal e v - stEncode = stFromString . senc snv + stEncode = senc snv . stFromString + stEncodeBS = senc snv . stFromByteString showStr :: Stringable a => String -> SEnv a -> a ---showStr = flip showVal . STR showStr = const . stFromString {-------------------------------------------------------------------- @@ -262,13 +264,15 @@ {-------------------------------------------------------------------- The Grammar --------------------------------------------------------------------} +myConcat :: Stringable a => [SEnv a -> a] -> (SEnv a -> a) +myConcat xs a = smconcat $ map ($ a) xs -- | 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 -> TmplParser (SEnv a -> a) stmpl p = do (ca, cb) <- getSeps - mconcat <$> many (showStr <$> escapedStr [ca] <|> try (around ca optExpr cb) + myConcat <$> many (showStr <$> escapedStr [ca] <|> try (around ca optExpr cb) <|> try comment <|> bl "template") where bl | p = try blank | otherwise = blank @@ -276,7 +280,7 @@ subStmp = do (ca, cb) <- getSeps udEnv <- option (transform ["it"]) (transform <$> try attribNames) - st <- mconcat <$> many (showStr <$> escapedStr (ca:"}|") + st <- myConcat <$> many (showStr <$> escapedStr (ca:"}|") <|> try (around ca optExpr cb) <|> try comment <|> blank "subtemplate") return (st <$$> udEnv) @@ -304,15 +308,21 @@ (try (string ("else"++[cb])) <|> try (string "elseif(") <|> try (string "endif")) .>> fail "Malformed If Statement." <|> return () expr <- try ifstat <|> spaced exprn - opts <- many opt - skipMany (char ';') + opts <- (char ';' >> optList) <|> return [] return $ expr . optInsert opts - where opt = around ';' (spaced word) '=' >>= (<$> spaced subexprn) . (,) + where -- opt = around ';' (spaced word) '=' >>= (<$> spaced subexprn) . (,) + optList = sepBy oneOpt (char ',' <|> char ';') + oneOpt = do + o <- spaced word + char '=' + v <- spaced subexprn + return (o,v) {-------------------------------------------------------------------- Statements --------------------------------------------------------------------} +--if env then do stuff getProp :: Stringable a => [SEnv a -> SElem a] -> SElem a -> SEnv a -> SElem a getProp (p:ps) (SM mp) env = case M.lookup (stToString . showVal env $ p env) mp of @@ -412,7 +422,7 @@ (fApply f .) <$> around '(' subexprn ')' where fApply str (LI xs) | str == "first" = if null xs then SNull else head xs - | str == "last" = last xs + | str == "last" = if null xs then SNull else last xs | str == "rest" = if null xs then SNull else (LI . tail) xs | str == "strip" = LI . filter (not . liNil) $ xs | str == "length" = STR . show . length $ xs @@ -434,7 +444,7 @@ 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 ($) +cycleApp x y snv = mconcatMap' snv (zipWith ($) (cycle x) y) ($ snv) pluslen :: [a] -> [([a], [SElem b])] pluslen xs = zip (map (:[]) xs) $ mkIndex [0..(length xs)] @@ -445,12 +455,12 @@ 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 -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) +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 +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 anonTmpl :: Stringable a => TmplParser (([SElem a], [SElem a]) -> SEnv a -> a) anonTmpl = around '{' subStmp '}' diff --git a/Text/StringTemplate/Classes.hs b/Text/StringTemplate/Classes.hs --- a/Text/StringTemplate/Classes.hs +++ b/Text/StringTemplate/Classes.hs @@ -9,6 +9,10 @@ import Data.Monoid import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT import qualified Text.PrettyPrint.HughesPJ as PP newtype StFirst a = StFirst { stGetFirst :: Maybe a } @@ -57,24 +61,33 @@ -- | The Stringable class should be instantiated with care. -- Generally, the provided instances should be enough for anything. -class Monoid a => Stringable a where +class 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 - mconcatMap m k = foldr (mappend . k) mempty m + mconcatMap m k = foldr (smappend . k) smempty m -- | Defaults to @ (mconcat .) . intersperse @ mintercalate :: a -> [a] -> a - mintercalate = (mconcat .) . intersperse - -- | Defaults to @ mlabel x y = mconcat [x, stFromString "[", y, stFromString "]"] @ + mintercalate = (smconcat .) . intersperse + -- | Defaults to @ mlabel x y = smconcat [x, stFromString "[", y, stFromString "]"] @ mlabel :: a -> a -> a - mlabel x y = mconcat [x, stFromString "[", y, stFromString "]"] + mlabel x y = smconcat [x, stFromString "[", y, stFromString "]"] + -- | Just mempty. Here to avoid orphan instances + smempty :: a + -- | Just mappend. Here to avoid orphan instances + smappend :: a -> a -> a + -- | Just mconcat. Here to avoid orphan instances + smconcat :: [a] -> a + smconcat xs = foldr (smappend . id) smempty xs instance Stringable String where stFromString = id stToString = id + smempty = "" + smappend = (++) instance Stringable PP.Doc where stFromString = PP.text @@ -82,21 +95,39 @@ 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 + smempty = PP.empty + smappend = (PP.<>) instance Stringable B.ByteString where stFromString = B.pack stFromByteString = B.concat . LB.toChunks stToString = B.unpack + smempty = B.empty + smappend = B.append instance Stringable LB.ByteString where stFromString = LB.pack stFromByteString = id stToString = LB.unpack + smempty = LB.empty + smappend = LB.append +instance Stringable T.Text where + stFromString = T.pack + stFromByteString = T.decodeUtf8 . B.concat . LB.toChunks + stToString = T.unpack + smempty = T.empty + smappend = T.append + +instance Stringable LT.Text where + stFromString = LT.pack + stFromByteString = LT.decodeUtf8 + stToString = LT.unpack + smempty = LT.empty + smappend = LT.append + instance Stringable (Endo String) where stFromString = Endo . (++) stToString = ($ []) . appEndo + smempty = mempty + smappend = mappend diff --git a/Text/StringTemplate/GenericStandard.hs b/Text/StringTemplate/GenericStandard.hs --- a/Text/StringTemplate/GenericStandard.hs +++ b/Text/StringTemplate/GenericStandard.hs @@ -10,6 +10,15 @@ import Text.StringTemplate.Instances() import Data.Generics.Basics import Data.Generics.Aliases +import qualified Data.Map as M +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Maybe +-- import qualified System.Time as OldTime +-- import System.Locale +-- import Data.Time +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT gToSElem :: forall a b.(Data a, Stringable b) => a -> SElem b gToSElem = (\x -> @@ -21,12 +30,25 @@ `ext1Q` (\t -> case t of (Just x) -> gToSElem x; _ -> SNull) `ext1Q` (SM . fmap gToSElem) `ext1Q` (LI . map gToSElem) + -- `extQ` (toSElem :: OldTime.CalendarTime -> SElem b) + -- `extQ` (toSElem :: OldTime.TimeDiff -> SElem b) + -- `extQ` (toSElem :: TimeOfDay -> SElem b) + -- `extQ` (toSElem :: UTCTime -> SElem b) + -- `extQ` (toSElem :: TimeZone -> SElem b) + -- `extQ` (toSElem :: ZonedTime -> SElem b) + -- `extQ` (toSElem :: Day -> SElem b) + -- `extQ` (toSElem :: LocalTime -> SElem b) + `extQ` (toSElem :: LB.ByteString -> SElem b) + `extQ` (toSElem :: B.ByteString -> SElem b) + `extQ` (toSElem :: LT.Text -> SElem b) + `extQ` (toSElem :: T.Text -> SElem b) `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 diff --git a/Text/StringTemplate/Group.hs b/Text/StringTemplate/Group.hs --- a/Text/StringTemplate/Group.hs +++ b/Text/StringTemplate/Group.hs @@ -42,10 +42,12 @@ getTmplsRecursive :: FilePath -> FilePath -> IO [(FilePath, FilePath)] getTmplsRecursive base fp = do - dirContents <- getDirectoryContents fp - subDirs <- filterM doesDirectoryExist =<< getDirectoryContents fp + dirContents <- filter (not . isPrefixOf ".") <$> getDirectoryContents fp + subDirs <- filterM (doesDirectoryExist . (fp )) dirContents subs <- concat <$> mapM (\x -> getTmplsRecursive (base x) (fp x)) subDirs - return $ (map (() fp &&& () base) $ filter ((".st" ==) . takeExtension) dirContents) ++ subs + return $ (map ((fp ) &&& (\x -> base dropExtension x)) $ + filter ((".st" ==) . takeExtension) dirContents) + ++ subs {-------------------------------------------------------------------- Group API @@ -111,7 +113,7 @@ -- | 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 :: (Stringable a) => (a -> a) -> STGroup a -> STGroup a setEncoderGroup x f = (inSGen (setEncoderGroup x) . setEncoder x) <$$> f -- | For any requested template, returns a message that the template was diff --git a/Text/StringTemplate/Instances.hs b/Text/StringTemplate/Instances.hs --- a/Text/StringTemplate/Instances.hs +++ b/Text/StringTemplate/Instances.hs @@ -16,7 +16,12 @@ import qualified System.Time as OldTime import System.Locale import Data.Time +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT + {-------------------------------------------------------------------- Additional instances for items that may be set as StringTemplate attributes. The code should provide examples of how to proceed. @@ -32,6 +37,12 @@ instance ToSElem B.ByteString where toSElem = BS . LB.fromChunks . (:[]) + +instance ToSElem LT.Text where + toSElem = BS . LT.encodeUtf8 + +instance ToSElem T.Text where + toSElem = BS . LB.fromChunks . (:[]) . T.encodeUtf8 instance ToSElem Bool where toSElem True = STR ""