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.6.12 +version: 0.8.8 synopsis: StringTemplate implementation in Haskell. description: A port of the Java library by Terrence Parr. category: Text @@ -7,38 +8,52 @@ 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 -flag smaller-base -flag syb-with-class -flag quasi-quotation -library - 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 +source-repository head + type: darcs + location: http://hub.darcs.net/sterlingclover/hstringtemplate - if flag(smaller-base) - build-depends: syb, base >= 4, base < 5, filepath, parsec < 4, containers, pretty, time, old-time, old-locale, bytestring, directory, array, text, deepseq, utf8-string, blaze-builder - else - build-depends: base > 3, base < 4, filepath, parsec < 4, containers, pretty, time, old-time, old-locale, bytestring, directory, array, text, utf8-string, blaze-builder +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 Text.StringTemplate.GenericStandard + Text.StringTemplate.QQ other-modules: Text.StringTemplate.Instances Text.StringTemplate.Group 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)], [],[]) @@ -292,6 +292,7 @@ showVal snv se = case se of STR x -> stEncode x BS x -> stEncodeBS x + TXT x -> stEncodeText x LI xs -> joinUpWith showVal xs SM sm -> joinUpWith showAssoc $ M.assocs sm STSH x -> stEncode (format x) @@ -301,8 +302,9 @@ 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 = senc snv . stFromString - stEncodeBS = senc snv . stFromByteString + stEncode = senc snv . stFromString + stEncodeBS = senc snv . stFromByteString + stEncodeText = senc snv . stFromText showStr :: Stringable a => String -> SEnv a -> a showStr = const . stFromString @@ -349,7 +351,7 @@ The Grammar --------------------------------------------------------------------} myConcat :: Stringable a => [SEnv a -> a] -> (SEnv a -> a) -myConcat xs a = smconcat $ map ($ a) xs +myConcat xs a = mconcatMap xs ($ a) -- | if p is true, stmpl can fail gracefully, false it dies hard. @@ -415,7 +417,10 @@ getProp (p:ps) (SM mp) env = case M.lookup (stToString . showVal env $ p env) mp of Just prop -> getProp ps prop env - Nothing -> SNull + Nothing -> case optLookup "throwException" env of + Just _ -> C.throw . NoAttrib $ "yeek" --intercalate "." . map showIt $ (p:ps) + Nothing -> SNull + --where showIt x = stToString . showVal env $ x env getProp (_:_) _ _ = SNull getProp _ se _ = se diff --git a/Text/StringTemplate/Classes.hs b/Text/StringTemplate/Classes.hs --- a/Text/StringTemplate/Classes.hs +++ b/Text/StringTemplate/Classes.hs @@ -11,26 +11,32 @@ import qualified Blaze.ByteString.Builder.Char.Utf8 as BB 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 +import qualified Data.Text.Lazy.Builder as TB import qualified Data.Text.Lazy.Encoding as LT import qualified Text.PrettyPrint.HughesPJ as PP 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 type SMap a = M.Map String (SElem a) -data SElem a = STR String - | BS LB.ByteString +data SElem a = STR String + | BS LB.ByteString + | TXT LT.Text | STSH STShow | SM (SMap a) | LI [SElem a] @@ -64,33 +70,26 @@ -- | The Stringable class should be instantiated with care. -- Generally, the provided instances should be enough for anything. -class Stringable a where +class Monoid a => Stringable a where stFromString :: String -> a stFromByteString :: LB.ByteString -> a - stFromByteString = stFromString . LB.unpack + stFromByteString = stFromText . LT.decodeUtf8 + stFromText :: LT.Text -> a + stFromText = stFromString . LT.unpack stToString :: a -> String -- | Defaults to @ mconcatMap m k = foldr (mappend . k) mempty m @ mconcatMap :: [b] -> (b -> a) -> a - mconcatMap m k = foldr (smappend . k) smempty m + mconcatMap m k = foldr (mappend . k) mempty m -- | Defaults to @ (mconcat .) . intersperse @ mintercalate :: a -> [a] -> a - mintercalate = (smconcat .) . intersperse - -- | Defaults to @ mlabel x y = smconcat [x, stFromString "[", y, stFromString "]"] @ + mintercalate = (mconcat .) . intersperse + -- | Defaults to @ mlabel x y = mconcat [x, stFromString "[", y, stFromString "]"] @ mlabel :: a -> a -> a - 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 + mlabel x y = mconcat [x, stFromString "[", y, stFromString "]"] instance Stringable String where stFromString = id stToString = id - smempty = "" - smappend = (++) instance Stringable PP.Doc where stFromString = PP.text @@ -98,47 +97,48 @@ mconcatMap m k = PP.fcat . map k $ m mintercalate = (PP.fcat .) . PP.punctuate mlabel x y = x PP.$$ PP.nest 1 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 + stFromText = LT.toStrict stToString = T.unpack - smempty = T.empty - smappend = T.append instance Stringable LT.Text where stFromString = LT.pack stFromByteString = LT.decodeUtf8 + stFromText = id stToString = LT.unpack - smempty = LT.empty - smappend = LT.append instance Stringable BB.Builder where stFromString = BB.fromString stFromByteString = BB.fromLazyByteString stToString = LB.unpack . BB.toLazyByteString - smappend = mappend - smempty = mempty +{- +instance Stringable LBB.Builder where + stFromString = stringUtf8 + stFromByteString = LBB.lazyByteString + stToString = LB.unpack . LBB.toLazyByteString +-} + +instance Stringable TB.Builder where + stFromString = TB.fromString + stFromText = TB.fromLazyText + stToString = LT.unpack . TB.toLazyText + + --add dlist instance instance Stringable (Endo String) where stFromString = Endo . (++) stToString = ($ []) . appEndo - smempty = mempty - smappend = mappend diff --git a/Text/StringTemplate/GenericWithClass.hs b/Text/StringTemplate/GenericWithClass.hs deleted file mode 100644 --- a/Text/StringTemplate/GenericWithClass.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE FlexibleInstances, OverlappingInstances, FlexibleContexts, UndecidableInstances, Rank2Types #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --------------------------------------------------------------------- --- | Generic Instance for ToSElem using syb-with-class. --- Inspired heavily-to-entirely by Alex Drummond's RJson. ---------------------------------------------------------------------} - -module Text.StringTemplate.GenericWithClass() where -import qualified Data.Map as M -import Text.StringTemplate.Classes -import Data.Generics.SYB.WithClass.Basics - -stripInitialUnderscores :: String -> String -stripInitialUnderscores ('_':s) = stripInitialUnderscores s -stripInitialUnderscores s = s - -data ToSElemD a = ToSElemD { toSElemD :: Stringable b => a -> SElem b } - -toSElemProxy :: Proxy ToSElemD -toSElemProxy = error "This value should never be evaluated!" - -instance (ToSElem a, Data ToSElemD a) => Sat (ToSElemD a) where - dict = ToSElemD { toSElemD = toSElem } - -genericToSElem :: (Data ToSElemD a, ToSElem a, Stringable b) => a -> SElem b -genericToSElem x - | isAlgType (dataTypeOf toSElemProxy x) = - case (map stripInitialUnderscores (getFields x)) of - [] -> LI (STR (showConstr (toConstr toSElemProxy x)) : - gmapQ toSElemProxy (toSElemD dict) x) - fs -> SM (M.fromList (zip fs (gmapQ toSElemProxy (toSElemD dict) x))) - | True = - error ("Unable to serialize the primitive type '" ++ - dataTypeName (dataTypeOf toSElemProxy x) ++ "'") - -getFields :: Data ToSElemD a => a -> [String] -getFields = constrFields . toConstr toSElemProxy - -instance Data ToSElemD t => ToSElem t where - toSElem = genericToSElem 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,21 +13,28 @@ 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. --------------------------------------------------------------------} --Basics +instance ToSElem () where + toSElem _ = STR "" + +instance ToSElem Void where + toSElem = absurd + instance ToSElem Char where toSElem = STR . (:[]) toSElemList = STR @@ -39,10 +46,10 @@ toSElem = BS . LB.fromChunks . (:[]) instance ToSElem LT.Text where - toSElem = BS . LT.encodeUtf8 + toSElem = TXT instance ToSElem T.Text where - toSElem = BS . LB.fromChunks . (:[]) . T.encodeUtf8 + toSElem = TXT . LT.fromStrict instance ToSElem Bool where toSElem True = STR "" @@ -87,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."