diff --git a/HStringTemplate.cabal b/HStringTemplate.cabal --- a/HStringTemplate.cabal +++ b/HStringTemplate.cabal @@ -1,5 +1,6 @@ +Cabal-Version: 1.18 name: HStringTemplate -version: 0.7.3 +version: 0.8.8 synopsis: StringTemplate implementation in Haskell. description: A port of the Java library by Terrence Parr. category: Text @@ -7,17 +8,37 @@ license-file: LICENSE author: Sterling Clover maintainer: s.clover@gmail.com -Tested-With: GHC == 7.0.4 +Tested-With: GHC == 8.2, GHC == 9.0.1 Build-Type: Simple -build-Depends: base -Cabal-Version: >= 1.6 -library - build-depends: syb, base >= 4, base < 5, filepath, parsec < 4, containers, pretty >= 1.1.0.0, - time, old-time, old-locale, bytestring, directory, array, text, deepseq, utf8-string, blaze-builder, void, template-haskell >= 2.3, mtl +source-repository head + type: darcs + location: http://hub.darcs.net/sterlingclover/hstringtemplate +library + default-language: Haskell2010 + build-depends: + base >= 4 && < 5, + array < 0.6, + blaze-builder < 0.5, + bytestring < 0.11, + deepseq < 1.5, + text < 1.3, + containers < 0.7, + template-haskell >= 2.3 && < 2.18, + pretty < 1.2, + directory < 1.4, + filepath < 1.5, + mtl < 2.3, + old-locale < 1.1, + parsec > 3 && < 4, + semigroups >= 0.16 && < 0.20, + syb < 0.8, + void < 0.8, + time >= 1.4.2 && < 1.10 + exposed-modules: Text.StringTemplate Text.StringTemplate.Base Text.StringTemplate.Classes @@ -28,6 +49,11 @@ Text.StringTemplate.Renderf ghc-options: -Wall -source-repository head - type: darcs - location: http://patch-tag.com/r/sclv/hstringtemplate +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: tests + build-depends: HStringTemplate, base, containers, QuickCheck >= 2.13, random >= 1.0 , HUnit >= 1.5 + other-modules: Properties + Units diff --git a/Text/StringTemplate/Base.hs b/Text/StringTemplate/Base.hs --- a/Text/StringTemplate/Base.hs +++ b/Text/StringTemplate/Base.hs @@ -267,7 +267,7 @@ 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. +-- | Returns a tuple of three lists. The first is of templates with parse errors, and their errors. The next is of missing attributes, and the last is of missing templates. If there are no errors, then all lists will be empty. This check is performed recursively. checkTemplateDeep :: (Stringable a, NFData a) => StringTemplate a -> ([(String,String)], [String], [String]) checkTemplateDeep t = case runSTMP t of Left err -> ([("Top Level Template", err)], [],[]) diff --git a/Text/StringTemplate/Classes.hs b/Text/StringTemplate/Classes.hs --- a/Text/StringTemplate/Classes.hs +++ b/Text/StringTemplate/Classes.hs @@ -12,6 +12,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB --import qualified Data.ByteString.Lazy.Builder as DBB +import qualified Data.Semigroup as SG import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as LT @@ -21,10 +22,12 @@ newtype StFirst a = StFirst { stGetFirst :: Maybe a } deriving (Eq, Ord, Read, Show) +instance SG.Semigroup (StFirst a) where + r@(StFirst (Just _)) <> _ = r + StFirst Nothing <> r = r instance Monoid (StFirst a) where - mempty = StFirst Nothing - r@(StFirst (Just _)) `mappend` _ = r - StFirst Nothing `mappend` r = r + mempty = StFirst Nothing + mappend = (SG.<>) instance Functor StFirst where fmap f = StFirst . fmap f . stGetFirst diff --git a/Text/StringTemplate/Group.hs b/Text/StringTemplate/Group.hs --- a/Text/StringTemplate/Group.hs +++ b/Text/StringTemplate/Group.hs @@ -15,14 +15,14 @@ import Control.Monad import Data.Monoid import Data.List -import System.Time import System.FilePath import System.Directory import Data.IORef +import System.IO import System.IO.Unsafe import System.IO.Error -import System.IO.UTF8 as U import qualified Data.Map as M +import Data.Time import Text.StringTemplate.Base import Text.StringTemplate.Classes @@ -34,11 +34,17 @@ (<$$>) :: (Functor f1, Functor f) => (a -> b) -> f (f1 a) -> f (f1 b) (<$$>) = (<$>) . (<$>) -readFile' :: FilePath -> IO String -readFile' f = do - x <- U.readFile f - length x `seq` return x +readFileUTF :: FilePath -> IO String +readFileUTF f = do + h <- openFile f ReadMode + hSetEncoding h utf8 + hGetContents h +readFileStrictly :: FilePath -> IO String +readFileStrictly f = do + x <- readFileUTF 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 @@ -74,7 +80,7 @@ -- | Given a path, returns a group which generates all files in said directory which have the supplied extension. directoryGroupExt :: (Stringable a) => FilePath -> FilePath -> IO (STGroup a) directoryGroupExt ext path = - groupFromFiles readFile' . + groupFromFiles readFileStrictly . map (() path &&& takeBaseName) . filter ((ext ==) . takeExtension) =<< getDirectoryContents path @@ -91,18 +97,18 @@ -- | Given a path, returns a group which generates all files in said directory which have the supplied extension. directoryGroupLazyExt :: (Stringable a) => FilePath -> FilePath -> IO (STGroup a) directoryGroupLazyExt ext path = - groupFromFiles U.readFile . + groupFromFiles readFileUTF . map (() path &&& takeBaseName) . filter ((ext ==) . 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. +-- \"foo\/bar.st\" may be referenced by \"foo\/bar\" in the returned group. directoryGroupRecursive :: (Stringable a) => FilePath -> IO (STGroup a) directoryGroupRecursive = directoryGroupRecursiveExt ".st" -- | As with 'directoryGroupRecursive', but a template extension is supplied. directoryGroupRecursiveExt :: (Stringable a) => FilePath -> FilePath -> IO (STGroup a) -directoryGroupRecursiveExt ext path = groupFromFiles readFile' =<< getTmplsRecursive ext "" path +directoryGroupRecursiveExt ext path = groupFromFiles readFileStrictly =<< getTmplsRecursive ext "" path -- | See documentation for 'directoryGroupRecursive'. directoryGroupRecursiveLazy :: (Stringable a) => FilePath -> IO (STGroup a) @@ -110,7 +116,7 @@ -- | As with 'directoryGroupRecursiveLazy', but a template extension is supplied. directoryGroupRecursiveLazyExt :: (Stringable a) => FilePath -> FilePath -> IO (STGroup a) -directoryGroupRecursiveLazyExt ext path = groupFromFiles U.readFile =<< getTmplsRecursive ext "" path +directoryGroupRecursiveLazyExt ext path = groupFromFiles readFileUTF =<< getTmplsRecursive ext "" 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. @@ -154,14 +160,16 @@ unsafeVolatileDirectoryGroup path m = return . flip addSubGroup extraTmpls $ cacheSTGroup stfg where stfg = StFirst . Just . newSTMP . unsafePerformIO . flip CE.catch (return . (\e -> "IO Error: " ++ show (ioeGetFileName e) ++ " -- " ++ ioeGetErrorString e)) - . U.readFile . (path ) . (++".st") + . readFileUTF . (path ) . (++".st") extraTmpls = addSubGroup (groupStringTemplates [("dumpAttribs", dumpAttribs)]) nullGroup + delayTime :: Double + delayTime = fromIntegral m cacheSTGroup :: STGroup a -> STGroup a cacheSTGroup g = unsafePerformIO $ do !ior <- newIORef M.empty return $ \s -> unsafePerformIO $ do mp <- readIORef ior - curtime <- getClockTime + curtime <- getCurrentTime let udReturn now = do let st = g s atomicModifyIORef ior $ @@ -170,7 +178,7 @@ case M.lookup s mp of Nothing -> udReturn curtime Just (t, st) -> - if (tdSec . normalizeTimeDiff $ - diffClockTimes curtime t) > m + if (realToFrac $ + diffUTCTime curtime t) > delayTime then udReturn curtime else return st diff --git a/Text/StringTemplate/Instances.hs b/Text/StringTemplate/Instances.hs --- a/Text/StringTemplate/Instances.hs +++ b/Text/StringTemplate/Instances.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, OverlappingInstances #-} +{-# LANGUAGE CPP, FlexibleInstances, OverlappingInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK not-home #-} @@ -13,16 +13,16 @@ import Data.Array import Data.Maybe import qualified Data.Foldable as F -import qualified System.Time as OldTime -import System.Locale import Data.Time import Data.Void 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 +#if !MIN_VERSION_time(1,5,0) +import System.Locale (defaultTimeLocale) +#endif + {-------------------------------------------------------------------- Additional instances for items that may be set as StringTemplate attributes. The code should provide examples of how to proceed. @@ -94,17 +94,6 @@ toSElem = STR . show --Dates and Times -instance StringTemplateShows OldTime.CalendarTime where - stringTemplateShow = OldTime.calendarTimeToString - stringTemplateFormattedShow = OldTime.formatCalendarTime defaultTimeLocale -instance ToSElem OldTime.CalendarTime where - toSElem = stShowsToSE - -instance StringTemplateShows OldTime.TimeDiff where - stringTemplateShow = OldTime.timeDiffToString - stringTemplateFormattedShow = OldTime.formatTimeDiff defaultTimeLocale -instance ToSElem OldTime.TimeDiff where - toSElem = stShowsToSE instance StringTemplateShows Day where stringTemplateShow = show diff --git a/Text/StringTemplate/QQ.hs b/Text/StringTemplate/QQ.hs --- a/Text/StringTemplate/QQ.hs +++ b/Text/StringTemplate/QQ.hs @@ -19,6 +19,7 @@ import qualified Language.Haskell.TH as TH import Language.Haskell.TH.Quote import Text.StringTemplate.Base +import qualified Data.Set as S quoteTmplExp :: String -> TH.ExpQ quoteTmplPat :: String -> TH.PatQ @@ -32,10 +33,9 @@ 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 + base = TH.AppE (TH.VarE (TH.mkName "Text.StringTemplate.newSTMP")) (TH.LitE (TH.StringL s)) + tmpl = S.foldr addAttrib base $ S.fromList vars addAttrib var = TH.AppE - (TH.AppE (TH.AppE (TH.VarE (TH.mkName "setAttribute")) + (TH.AppE (TH.AppE (TH.VarE (TH.mkName "Text.StringTemplate.setAttribute")) (TH.LitE (TH.StringL ('`' : var ++ "`")))) (TH.VarE (TH.mkName var))) - diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import qualified Properties +import qualified Units + +main = do + Properties.main + Units.main diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -0,0 +1,120 @@ +{-# OPTIONS -O2 -fglasgow-exts #-} + +module Properties where +import Text.Printf +import Control.Monad +import Control.Arrow +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 +import Text.StringTemplate.Classes +import Text.StringTemplate.Base +import Test.QuickCheck +import System.Environment + + +main :: IO () +main = do + args <- getArgs + let n = if null args then 100 else read (head args) + results <- mapM (\ (s, a) -> printf "%-25s: " s >> fmap (\x->(s,x)) a) tests + mapM print results + when (not $ all (isSuccess . snd) results) $ fail "Not all tests passed!" + where + isSuccess (Success _ _ _ _ _ _) = True + isSuccess _ = False + 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) + ] +mytest x = quickCheckResult x +{----------------------------------------------------------------------- + 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 i' $ x) == + (toString . newSTMP . concat . replicate i' $ tmpl) + where tmpl = x++"$"++y++"$" + i' = min (abs i) 10 + +prop_fullNulls (LitString x) (LitString y) i = + length y > 0 ==> + (concat . replicate i' $ x++y) == + (toString . newSTMP . concat . replicate i' $ tmpl) + where tmpl = x++"$"++y++";null='"++y++"'$" + i' = min (abs i) 10 + +prop_substitution (LitString x) (LitString y) (LitString z) i = + length y > 0 ==> + (concat . replicate i' $ x++z) == + (toString . setAttribute y z . + newSTMP . concat . replicate i' $ tmpl) + where tmpl = x++"$"++y++"$" + i' = min (abs i) 10 + +prop_separator (LitString x) (LitString y) (LitString z) i = + length x > 0 ==> + (concat . intersperse z . replicate i' $ y) == + (toString . setAttribute x (replicate i' y) + . newSTMP $ tmpl) + where tmpl = "$"++x++";separator='"++z++"'$" + i' = min (abs i) 10 + +prop_comment (LitString x) (LitString y) (LitString z) = + toString (newSTMP (x ++ "$!" ++ y ++ "!$" ++ z)) == x ++ z + +prop_attribs (LitString x) i = + toString (setManyAttrib (replicate i' ("f",x)) $ newSTMP "$f$") + == (concat . replicate i' $ x) + where + i' = min (abs i) 10 + +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') + +newtype LitString = LitString String deriving Show +instance Arbitrary LitString where + arbitrary = LitString . map unLitChar <$> sized (\n -> choose (0,n) >>= vector) diff --git a/tests/Units.hs b/tests/Units.hs new file mode 100644 --- /dev/null +++ b/tests/Units.hs @@ -0,0 +1,42 @@ +{-# OPTIONS -O2 -fglasgow-exts #-} + +module Units where +import System.IO +import qualified Data.Map as M + +import Text.StringTemplate +import Text.StringTemplate.Classes +import Text.StringTemplate.Base +import Test.HUnit +import Control.Monad +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" +func_reverse = toString (setA $ newSTMP "$reverse(foo)$") ~=? "cba" + +tests = TestList ["no_prop" ~: no_prop, + "one_prop" ~: one_prop, + "func_first" ~: func_first, + "func_last" ~: func_last, + "func_rest" ~: func_rest, + "func_reverse" ~: func_reverse, + "func_length" ~: func_length, + "anon_tmpl" ~: anon_tmpl] + +main = do + c <- runTestTT tests + when (errors c > 0 || failures c > 0) $ + fail "Not all tests passed."